diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c9dcd1a --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +*.o +*.so* +.cache/* + +# This directory usually contains recmats. +calib + +# This is the default queue directory. +drf_queue \ No newline at end of file diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..e69de29 diff --git a/AUTHORS.rst b/AUTHORS.rst new file mode 100644 index 0000000..300cd84 --- /dev/null +++ b/AUTHORS.rst @@ -0,0 +1,41 @@ +******************* +Authors and Credits +******************* + +OSIRIS DRP Project Contributors +============================ + +Project Coordinators +-------------------- +* Jim Lyke (@jlyke-keck) +* Tuan Do (@followthesheep) + +Alphabetical list of contributors +--------------------------------- +* Anna Boehle (@aboehle) +* Randy Campbell +* Sam Chappell +* Devin Chu +* Mike Fitzgerald (@astrofitz) +* Tom Gasawy +* Christof Iserlohe +* Alfred Krabbe +* James Larkin +* Jim Lyke (@jlyke-keck) +* Kelly Lockhart +* Jessica Lu +* Etsuko Mieda +* Mike McElwain +* Marshall Perrin +* Alex Rudy (@alexrudy) +* Breann Sitarski +* Andrey Vayner +* Greg Walth +* Jason Weiss +* Tommer Wizanski +* Shelley Wright + +(If you have contributed to the OSIRIS pipeline and your name is missing, +please send an email to the coordinators, or +`open a pull request for this page `_ +in the `OsirisDRP repository `_) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..8d5c6d9 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,119 @@ +# Contributing to the Osiris DRP + +## Reporting Issues + +Please report [issues](https://github.com/Keck-DataReductionPipelines/OsirisDRP/issues) on GitHub to the [OsirisDRP repository](https://github.com/Keck-DataReductionPipelines/OsirisDRP). Please include the version of IDL you are using, and the shell you are using. + +## Contributing code +So you're interested in contributing code to to the OsirisDRP? Excellent! + +Most contributions to OsirisDRP are done via pull requests from GitHub users' +forks of the [OsirisDRP repository](https://github.com/astropy/astropy). If you're new to this style of development, +Astropy has a good summary of this [development workflow](http://docs.astropy.org/en/latest/development/workflow/development_workflow.html), but we'll describe it for the OsirisDRP below. + +### Getting the development version + +First, you'll need an account on [GitHub](http://github.com). Then go to and click on the "Fork" button in the upper right hand corner. This will make a "Forked" copy of the Osiris DRP in your GitHub Account. + +Then, clone the OsirisDRP to your computer: + +``` + + $ git clone https://github.com/your-user-name/OsirisDRP.git + Cloning into 'OsirisDRP'... + remote: Counting objects: 2386, done. + remote: Compressing objects: 100% (97/97), done. + remote: Total 2386 (delta 60), reused 0 (delta 0), pack-reused 2288 + Receiving objects: 100% (2386/2386), 5.41 MiB | 957.00 KiB/s, done. + Resolving deltas: 100% (1674/1674), done. + Checking connectivity... done. + $ cd OsirisDRP/ + $ git checkout develop +``` + +Now, you need to set your repository up so that you can collect the latest changes from the Keck version of the OsirisDRP. To do this, add a git remote (called ``upstream`` by convention): + +``` + $ git remote add upstream https://github.com/Keck-DataReductionPipelines/OsirisDRP.git + $ git fetch upstream + Fetching upstream + remote: Counting objects: 630, done. + remote: Compressing objects: 100% (78/78), done. + remote: Total 630 (delta 68), reused 30 (delta 30), pack-reused 522 + Receiving objects: 100% (630/630), 1.31 MiB | 365.00 KiB/s, done. + Resolving deltas: 100% (86/86), completed with 24 local objects. + From https://github.com/Keck-DataReductionPipelines/OsirisDRP + * [new branch] develop -> upstream/develop + * [new branch] master -> upstream/master +``` + +To get the latest changes to the development version of the pipeline, pull from ``upstream/develop`` + +``` + $ git pull upstream develop + From https://github.com/Keck-DataReductionPipelines/OsirisDRP + * branch develop -> FETCH_HEAD + Already up-to-date. +``` + +### Making changes + +Now make your awesome changes to the pipeline! When you are done, commit them to your git repository. + +For example, lets pretend you've added ``my-awesome-file`` + +``` + $ git add my-awesome-file + $ git commit +``` + +### Testing your changes + +The OSIRIS Data reduction pipeline has a testing framework. It requires ``python``, ``py.test`` and ``astropy``. If you use anaconda for your python you can install ``py.test`` and ``astropy`` with ``$ conda install pytest astropy``. If you have a standard python installation, you can try installing ``py.test`` and ``astropy`` using pip, with ``$ pip install pytest astropy``. + +To test your changes, you can use the existing test framework. You can find information on writing new tests in ``tests/README.md``. You can then run your tests with ``make test`` + +``` + $ make test +``` + +### Giving your changes back to the community + +Now you need to publish your changes to GitHub: + +``` + $ git push develop +``` + +Then, you can go to your repository on GitHub (e.g. ), and there should be a button there to create a pull request. Create the pull request, add a description! + +### Things to consider about your pull request + +Once you open a pull request (which should be opened against the ``develop`` +branch, not against any of the other branches), please make sure that you +include the following: + +- **Code**: the code you are adding, which should follow as much as possible + our [coding guidelines](http://docs.astropy.org/en/latest/development/codeguide.html). + +- **Tests**: these are usually tests that ensures that code that previously + failed now works (regression tests) or tests that cover as much as possible + of the new functionality to make sure it doesn't break in future, and also + returns consistent results on all platforms (since we run these tests on many + platforms/configurations). For more information about how to write tests, see + ``tests/README.md``. + +- **Changelog entry**: whether you are fixing a bug or adding new + functionality, you should add an entry to the ``CHANGES.rst`` file that + includes if possible the issue number (if you are opening a pull request you + may not know this yet, but you can add it once the pull request is open). If + you're not sure where to put the changelog entry, wait at least until a + maintainer has reviewed your PR and assigned it to a milestone. + + You do not need to include a changelog entry for fixes to bugs introduced in + the developer version and which are not present in the stable releases. In + general you do not need to include a changelog entry for minor documentation + or test updates. Only user-visible changes (new features/API changes, fixed + issues) need to be mentioned. If in doubt ask the core maintainer reviewing + your changes. + diff --git a/EXAMPLE.md b/EXAMPLE.md new file mode 100644 index 0000000..b556355 --- /dev/null +++ b/EXAMPLE.md @@ -0,0 +1,285 @@ +# Example Installation + +## System Info + +- MacBook Pro (Retina 13-inch, Early 2015) +- 2.7 GHz Intel Core i5 +- OS X El Capitan v10.11.1 +- IDL v8.5 +- Ureka installed -- needed only to run DRP test in python +- XQuartz v2.7.8 +- User "jlyke" has admin priviledges + +## Go to directory in which you wish to copy the OSIRIS DRP +``` +[JLyke-MacBook:/Applications] jlyke% pwd +/Applications +``` +## Clone the DRP repository from github +``` +[JLyke-MacBook:/Applications] jlyke% git clone https://github.com/Keck-DataReductionPipelines/OsirisDRP.git +[JLyke-MacBook:/Applications] jlyke% ls -lrt | tail -1 +drwxr-xr-x 10 jlyke admin 340 May 6 10:14 OsirisDRP/ +[JLyke-MacBook:/Applications] jlyke% du -hs OsirisDRP + 26M OsirisDRP +``` +## Change to the newly installed directory +``` +JLyke-MacBook:/Applications] jlyke% cd OsirisDRP +/Applications/OsirisDRP +``` +## Determine which branches have been updated +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git fetch -a +remote: Counting objects: 4, done. +remote: Compressing objects: 100% (4/4), done. +remote: Total 4 (delta 0), reused 0 (delta 0), pack-reused 0 +Unpacking objects: 100% (4/4), done. +From https://github.com/Keck-DataReductionPipelines/OsirisDRP + 0740aaf..82b86b1 develop -> origin/develop +``` +## By default, you are on the "master" branch. Change to the desired branch, here "develop" +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git checkout develop +Branch develop set up to track remote branch develop from origin. +Switched to a new branch 'develop' +``` +## Check that your local files match those in the repository, this does not look for new files in the repository +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git status +On branch develop +Your branch is up-to-date with 'origin/develop'. +nothing to commit, working directory clean +``` +## Check whether the repository has new files that are not in your local copy + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git fetch +remote: Counting objects: 33, done. +remote: Compressing objects: 100% (33/33), done. +remote: Total 33 (delta 14), reused 0 (delta 0), pack-reused 0 +Unpacking objects: 100% (33/33), done. +From https://github.com/Keck-DataReductionPipelines/OsirisDRP + 82b86b1..5aed808 develop -> origin/develop +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git status +On branch develop +Your branch is behind 'origin/develop' by 7 commits, and can be fast-forwarded. + (use "git pull" to update your local branch) +nothing to commit, working directory clean +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% git pull +Updating 82b86b1..5aed808 +Fast-forward + README.md | 34 ++++++++++-- + backbone/drpStartup.pro | 4 +- + scripts/osirisSetup.csh | 53 ++++++++++++++++++ + scripts/osirisSetup.sh | 83 +++++++++++++++++++++-------- + scripts/run_odrp | 9 +++- + tests/drpStartup.pro | 9 +++- + tests/drptestbones/backbone.py | 6 +++ + tests/test_calstar/001.test_calstar.waiting | 20 ------- + tests/test_teluric/001.test_teluric.waiting | 20 ------- + 9 files changed, 165 insertions(+), 73 deletions(-) + create mode 100644 scripts/osirisSetup.csh + mode change 100644 => 100755 scripts/osirisSetup.sh + delete mode 100644 tests/test_calstar/001.test_calstar.waiting + delete mode 100644 tests/test_teluric/001.test_teluric.waiting + +>-- git pull request --< +``` +## make clean to remove previously compiled software + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% make clean +rm -f modules/source/*.o +rm -f modules/source/libosiris_drp_ext_null.so.0.0 +``` +## make the DRP +### Note that the warnings from IDL are benign + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% make + +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/osiris_rename_null.c -o modules/source/osiris_rename_null.o +In file included from modules/source/osiris_rename_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/osiris_rename_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/osiris_wait_on_sem_signal_null.c -o modules/source/osiris_wait_on_sem_signal_null.o +In file included from modules/source/osiris_wait_on_sem_signal_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/osiris_wait_on_sem_signal_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/osiris_post_sem_signal_null.c -o modules/source/osiris_post_sem_signal_null.o +In file included from modules/source/osiris_post_sem_signal_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/osiris_post_sem_signal_null.c:8: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/osiris_test.c -o modules/source/osiris_test.o +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/osiris_rectify_lib.c -o modules/source/osiris_rectify_lib.o +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/mkrecmatrx_000.c -o modules/source/mkrecmatrx_000.o +In file included from modules/source/mkrecmatrx_000.c:11: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/mkrecmatrx_000.c:11: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/spatrectif_000.c -o modules/source/spatrectif_000.o +In file included from modules/source/spatrectif_000.c:11: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/spatrectif_000.c:11: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/dumpxmlptr.c -o modules/source/dumpxmlptr.o +In file included from modules/source/dumpxmlptr.c:6: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/dumpxmlptr.c:6: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +modules/source/dumpxmlptr.c:14:57: warning: format specifies type 'unsigned int' + but the argument has type 'void *' [-Wformat] + (void)fprintf(stdout, "dumpxmlptr: argv[0] = %08x\n", argv[0]); + ~~~~ ^~~~~~~ +3 warnings generated. +cc -Imodules/source/include -I/Applications/exelis/idl/external/include -D__REENTRANT -fPIC -g -O2 -DHAVE_CONFIG_H -c modules/source/idlgetpid.c -o modules/source/idlgetpid.o +In file included from modules/source/idlgetpid.c:6: +/Applications/exelis/idl/external/include/idl_export.h:2758:9: warning: + 'strlcpy' macro redefined [-Wmacro-redefined] +#define strlcpy IDL_StrBase_strlcpy + ^ +/usr/include/secure/_string.h:104:9: note: previous definition is here +#define strlcpy(dest, src, len) \ + ^ +In file included from modules/source/idlgetpid.c:6: +/Applications/exelis/idl/external/include/idl_export.h:2762:9: warning: + 'strlcat' macro redefined [-Wmacro-redefined] +#define strlcat IDL_StrBase_strlcat + ^ +/usr/include/secure/_string.h:110:9: note: previous definition is here +#define strlcat(dest, src, len) \ + ^ +2 warnings generated. +cc -bundle modules/source/osiris_rename_null.o modules/source/osiris_wait_on_sem_signal_null.o modules/source/osiris_post_sem_signal_null.o modules/source/osiris_test.o modules/source/osiris_rectify_lib.o modules/source/mkrecmatrx_000.o modules/source/spatrectif_000.o modules/source/dumpxmlptr.o modules/source/idlgetpid.o -L/opt/local/lib/ -lm -lcfitsio -lm -o modules/source/libosiris_drp_ext_null.so.0.0 +``` +## Pipeline is installed, try a test + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% make test +py.test +make: py.test: No such file or directory +make: *** [test] Error 1 +``` +## The test requires py.test to be installed, check python install +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% which python +/usr/bin/python +``` +## Force the Ureka version of python + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% ur_setup +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% which python +/Applications/Ureka/variants/common/bin/python +``` +## Install the test framework + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% pip install pytest astropy +Requirement already satisfied (use --upgrade to upgrade): pytest in /Applications/Ureka/python/lib/python2.7/site-packages +Requirement already satisfied (use --upgrade to upgrade): astropy in /Applications/Ureka/python/lib/python2.7/site-packages +Requirement already satisfied (use --upgrade to upgrade): py>=1.4.25 in /Applications/Ureka/python/lib/python2.7/site-packages (from pytest) +Requirement already satisfied (use --upgrade to upgrade): numpy>=1.6.0 in /Applications/Ureka/python/lib/python2.7/site-packages (from astropy) +Cleaning up... +``` +## Verify that py.test is now available + +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% which py.test +/Applications/Ureka/python/bin/py.test +``` +## Try the test again +``` +[JLyke-MacBook:/Applications/OsirisDRP] jlyke% make test +py.test +============================= test session starts ============================== +platform darwin -- Python 2.7.5 -- py-1.4.26 -- pytest-2.6.4 +plugins: pandokia +collected 1 items + +tests/test_emission_line/test_emission_line.py . + +========================== 1 passed in 93.84 seconds =========================== +``` +## Test Successful diff --git a/INSTALLPROBLEMS.md b/INSTALLPROBLEMS.md new file mode 100644 index 0000000..3211abd --- /dev/null +++ b/INSTALLPROBLEMS.md @@ -0,0 +1,36 @@ +# Problems installing the pipeline? + +This file contains a bunch of common pipeline installation problems and their solutions. + +## Wrong Architecture Errors + +If you get an error like this: + +``` + % DRPBACKBONE::ERRORHANDLER: ERROR in drpBackbone::ErrorHandler - -379: CALL_EXTERNAL: Error loading sharable executable. + Symbol: osiris_wait_on_sem_signal, File = ./modules/source/libosiris_drp_ext_null.so.0.0 + dlopen(./modules/source/libosiris_drp_ext_null.so.0.0, 1): no suitable image found. + Did find: ./modules/source/libosiris_drp_ext_null.so.0.0: mach-o, but wrong + architecture + +``` + +There is a mismatch between your compiled architectures somewhere between CFITSIO, IDL and ``libosiris`` (the compiled portion of the OSIRIS DRP). You can check the compiled architechture with ``lipo -info``, e.g. for ``libosiris``: + +``` + $ lipo -info ./modules/source/libosiris_drp_ext_null.so.0.0 + Non-fat file: ./modules/source/libosiris_drp_ext_null.so.0.0 is architecture: x86_64 +``` + +You should see an architecture like ``x86_64``. You should check the architecture of ``libosiris`` and ``cfitsio``. They need to match the architecture of IDL. You can find out your IDL architecture from within IDL with the following: + +``` + IDL> print, !VERSION.arch + x86_64 +``` + +If you need to explicitly tell your compilier to target a specific architecutre, you might try the following copiler flags: + +- For 32 bit systems, either ``-m32`` or ``-arch i386`` +- For 64 bit systems, ``-arch x86_64`` + diff --git a/Makefile b/Makefile index 619cfbe..bb82f71 100644 --- a/Makefile +++ b/Makefile @@ -31,9 +31,11 @@ FILES = RELFILES = override SYSNAM = kss/osiris/drs/ -override VERNUM = 3.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). - +ifeq ($(wildcard $(KROOT)/etc/config.mk),) +include Makefile.local +else include $(KROOT)/etc/config.mk - +endif diff --git a/Makefile.local b/Makefile.local new file mode 100644 index 0000000..8102832 --- /dev/null +++ b/Makefile.local @@ -0,0 +1,17 @@ +# +# Makefile.local +# OsirisDRP +# +# Created by Alexander Rudy on 2016-05-04. +# + +SOURCE = modules/source +include modules/source/Makefile.local + +.PHONY: test + + + + +test: all + . scripts/osirisSetup.sh && osirisSetup && py.test \ No newline at end of file diff --git a/README.md b/README.md index dac3b6e..80ed204 100644 --- a/README.md +++ b/README.md @@ -1,23 +1,190 @@ -# OSIRIS Data Reduction Pipeline +# Keck OSIRIS Data Reduction Pipeline + +* [Release Notes for v4.0.0](#release-notes-for-v4.0.0) +* [Important Runtime Notes](#important-runtime-notes) +* [Installation](#installation) +* [Running the Pipeline](#running-the-pipeline) +* [Testing the Pipeline](#testing-the-pipeline) + +## Release Notes for v4.0.0 +**2017-01-23** + +Major updates: +- Updates to the code in order to run the pipeline for the new detector (2016 data and newer). +- Installation has now been simplified (see below for install directions). Bash scripts have been included for those who would like to use bash shell. +- Test framework is now available to run tests of the pipeline (requires pytest module in python, see README in ''tests'' directory) +- Optimized algorithms for the construction of data cubes +- qlook2, odrfgui, and oopgui are now also included in the repository + +Minor Updates: +- WCS bugs have been fixed. +- qlook2 fixes + - units bug is fixed + - fix initial autoscale to imager display + - clean up startup scripts + +## Important Runtime Notes + +**Cosmic Ray Module** +- We do not recommend running the cosmic ray module on data in 2016 or later, as it will introduce significant artifacts and reduce overall signal to noise. This is due to the fact that unresolved emission lines such as OH lines are now sharper on the detector. The cosmic ray module will tend to interpret this as a cosmic ray. To remove cosmic rays, we recommend combining data with the mosaic module with the MEANCLIP keyword if there are sufficient number of frames. +- The cosmic ray module may lead to artifacts in data before 2016 as well, but at a lesser level. We recommend checking on individual science cases. +- The pipeline team is investigating different cosmic ray modules for +a future release. +- More information is available in [Issue 49](https://github.com/Keck-DataReductionPipelines/OsirisDRP/issues/49) or in the [wiki](https://github.com/Keck-DataReductionPipelines/OsirisDRP/wiki/Tests:-cosmic-ray-module). + +**Old Modules** +- For data taken in 2016 onward, it is no longer necessary to run the following modules: Remove Cross Talk, Glitch Identification. It is fine to keep them in the DRF XML, these modules will automatically not run on the new data. + +**Current Important OSIRIS Issues** + +- For certain cases, there are flux mis-assignment: [Issue 20](https://github.com/Keck-DataReductionPipelines/OsirisDRP/issues/20), [wiki link](https://github.com/Keck-DataReductionPipelines/OsirisDRP/wiki/Tests:-Quantified-Flux-Mis-assignment) +- Spatial rippling is seen in the integrate flux of sky lines spatially across the field: [Issue 21](https://github.com/Keck-DataReductionPipelines/OsirisDRP/issues/21) +- [2016-09-07 OSIRIS Hackathon report](https://drive.google.com/open?id=0B_YkzZoUSrX-YnpCRjVZRkRPWnM) on these and other issues from the most recent OSIRIS Hackathon + +## Installation +### Prerequisites To install and run the OSIRIS DRP, you will need the following: - A working C compiler (e.g. ``gcc``) - A copy of the compiled library cfitsio -- A working installation of IDL +- A working installation of IDL (the IDL binary directory should be in your ``PATH`` environment variable) +- Python dependencies (optional, for testing): pytest, astropy + +### Options to install the pipeline + +- [Using a python script](#installing-with-a-python-script) -- this is the simplest method for the most recent release +- [Manually install from github repository](#installing-from-source) -- useful if you want to use the latest pipeline development version + +### Installing with a python script + +- Download the installation script [install_osiris_drs.py](https://github.com/Keck-DataReductionPipelines/OsirisDRP/blob/release/scripts/install_osiris_drs.py) +- Run the script +``` +chmod +x install_osiris_drs.py +./install_osiris_drs.py +``` +- For more information and script options: +``` +./install_osiris_drs.py --help +``` + +### Installing from source + +Either clone or download the source from github (the [``develop``](https://github.com/Keck-DataReductionPipelines/OsirisDRP/tree/develop) branch has the latest development) + +Set up the following environment variables (optional). The defaults should work for installations of IDL on Mac OS X and CFITSIO installed using [MacPorts][]: + +- ``IDL_INCLUDE``: The IDL include directory. If you don't set ``IDL_INCLUDE``, it defaults to ``IDL_INCLUDE=/Applications/exelis/idl/external/include`` +- ``CFITSIOLIBDIR``: The directory containing your installation of CFITSIO. If you don't set ``CFITSIOLIBDIR``, it will default to ``CFITSIOLIBDIR=/opt/local/lib``, which is correct for [MacPorts][]. + +Run the makefile from the top level of the OSIRIS DRP source code: + +``` +make all +``` + +You should see that the pipeline has been built correctly. Be sure you are using ``gmake`` (which on OS X is the only ``make``, so using ``make`` works.) -## Pipeline Version +[MacPorts]: https://www.macports.org -The current pipeline version is v3.2 and is released in the master branch of this repository. Clone the repository, compile, and run. +### OSIRIS DRP Runtime Environment -If you would like to try out the development version for reducing data, you can switch to the the develop branch. +The OSIRIS DRP requires various environment variables to find and run +the pipeline. Instructions are below for bash (should work for other +POSIX compliant shells) and c-shell. If you want to set up your +environment every time you start your shell (e.g. via ``.cshrc`` or +``.bashrc``), you can add the environment variable, +``OSIRIS_VERBOSE=0`` to silence the output of the setup +scripts. Otherwise, they will print useful messages about the setup of +your OSIRIS pipeline environment. -If you would like to work on OSIRIS pipeline code, please fork the develop branch into your own git account. Once your modifications are complete, submit a pull request. +#### Environment Setup in Bash -## Running the Pipeline +To setup the OSIRIS environment, source the file +``scripts/osirisSetup.sh``, then run ``osirisSetup`` with the root +directory of your OSIRIS DRF installation. If your OSIRIS pipeline is +installed in ``/usr/local/osiris/drs/``, then you would do: + +``` +$ source scripts/osirisSetup.sh +To use the OSIRIS DRP, run osirisSetup /path/to/my/drp + +$ osirisSetup /my/path/to/osiris/drp/ +Setting OSIRIS_ROOT=/my/path/to/osiris/drp/ +Adding /my/path/to/osiris/drp/scripts to your path. +Successfully setup OSIRIS DRP environment. +The DRP is in /my/path/to/osiris/drp/ +``` + +You can change all of the relevant OSIRIS variables later by running +``osirisSetup`` again. ``osirisSetup`` will add +``$OSIRIS_ROOT/scripts`` to your environment's PATH variable by +default. To skip this step, run ``osirisSetup`` with ``-n``: + +``` +$ osirisSetup -n /my/path/to/osiris/drp/ +Setting OSIRIS_ROOT=/my/path/to/osiris/drp/ +Successfully setup OSIRIS DRP environment. +The DRP is in /my/path/to/osiris/drp/ +``` + +You can add these lines to your ``.bashrc`` file or other startup profile if you want to set up the osiris environment variables for all of your shell sessions. Add lines like this to your profile: + +``` +OSIRIS_VERBOSE=0 +source /my/path/to/osiris/drp/scripts/osirisSetup.sh +osirisSetup /my/path/to/osiris/drp +``` + + +#### Environment Setup in CSH + +To setup the OSIRIS environment, set the environment variable +``OSIRIS_ROOT`` to the root directory for the OSIRIS data reduction +pipeline. Then source the file ``scripts/osirisSetup.csh``. + +``` +$ setenv OSIRIS_ROOT /my/path/to/osiris/drp/ + +$ source scripts/osirisSetup.csh +Using OSIRIS_ROOT=/my/path/to/osiris/drp/ +Successfully setup OSIRIS DRP environment. +The DRP is in /my/path/to/osiris/drp/ +You might want to add /my/path/to/osiris/drp/scripts to your PATH. +``` + +You can add these lines to your ``.cshrc`` file or other startup profile if you want to set up the osiris environment variables for each of your shell sessions. Add lines like this to your profile: + +``` +set OSIRIS_VERBOSE=0 +setenv OSIRIS_ROOT=/my/path/to/osiris/drp/ +source ${OSIRIS_ROOT}/scripts/osirisSetup.csh +setenv PATH ${PATH}:${OSIRIS_ROOT}/scripts +``` + +### Running the Pipeline + +To run the pipeline, use ``run_odrp``. If you don't want the pipeline +to open a new xterm window, call ``run_odrp -n``. Please check out the OSIRIS pipeline manual: -## Troubleshooting +### Testing the Pipeline + +To run the suite of tests on the pipeline, and you have ``pytest`` and ``astropy`` in your python environment: + +``` +make test +``` + +The first time you run the tests, data will be downloaded so it will take longer. If the tests pass, your pipeline is installed properly. You will see something like the following if the tests pass: + +``` +======================== 2 passed, 2 skipped in 41.77 seconds =================== +``` + + +### Troubleshooting -If you run into problems, please re-read this README.md. +If you run into problems, please re-read this README.md, then read INSTALLPROBLEMS.md for some common installation problems. diff --git a/backbone/Makefile b/backbone/Makefile index 6360288..a0d2a5c 100644 --- a/backbone/Makefile +++ b/backbone/Makefile @@ -44,7 +44,7 @@ RELPRO = drpBackbone__define.pro \ PROSUB = odrs/backbone override SYSNAM = kss/osiris/drs/backbone/ -override VERNUM = 3.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). diff --git a/backbone/Makefile.bak b/backbone/Makefile.bak new file mode 100644 index 0000000..6360288 --- /dev/null +++ b/backbone/Makefile.bak @@ -0,0 +1,51 @@ +############################################################################### +#+ +# Module: $KSSDIR/osiris/drs/backbone +# +# Revisions: +# +# Author: Jason Weiss +# +# Date: 2005/09/20 +# +# Description: Makefile for DRP backbone +#- +############################################################################### + +# Include files. + +INCLUDE = + +# C source and object files. +CFLAGS = + +SOURCE = +OBJECT = + +DIRS = SupportFiles + +# Files to make are ... +FILES = + +# Files to release are ... +RELFILES = + +RELDAT = +RELPRO = drpBackbone__define.pro \ + drpConfigParser__define.pro \ + drpDRFParser__define.pro \ + drpDRFPipeline__define.pro \ + drpMain.pro \ + drpPipeline__define.pro \ + drpRun.pro \ + osiris_drp_backbone_startup.pro + + +PROSUB = odrs/backbone + +override SYSNAM = kss/osiris/drs/backbone/ +override VERNUM = 3.2 + +# Include general make rules (use /etc if no environment variable). + +include $(KROOT)/etc/config.mk diff --git a/backbone/SupportFiles/Makefile b/backbone/SupportFiles/Makefile index 69881a9..6912429 100644 --- a/backbone/SupportFiles/Makefile +++ b/backbone/SupportFiles/Makefile @@ -34,7 +34,7 @@ RELDAT = osirisDRPConfigFile \ RPBconfig.xml override SYSNAM = kss/osiris/drs/backbone/ -override VERNUM = 3.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). diff --git a/backbone/SupportFiles/Makefile.bak b/backbone/SupportFiles/Makefile.bak new file mode 100644 index 0000000..69881a9 --- /dev/null +++ b/backbone/SupportFiles/Makefile.bak @@ -0,0 +1,41 @@ +############################################################################### +#+ +# Module: $KSSDIR/osiris/drs/backbone/SupportFiles +# +# Revisions: +# +# Author: Jason Weiss +# +# Date: 2005/09/20 +# +# Description: Makefile for DRP backbone support files (RPBconfig.xml) +#- +############################################################################### + +# Include files. + +INCLUDE = + +# C source and object files. +CFLAGS = + +SOURCE = +OBJECT = + +DIRS = + +# Files to make are ... +FILES = + +# Files to release are ... +RELFILES = + +RELDAT = osirisDRPConfigFile \ + RPBconfig.xml + +override SYSNAM = kss/osiris/drs/backbone/ +override VERNUM = 3.2 + +# Include general make rules (use /etc if no environment variable). + +include $(KROOT)/etc/config.mk diff --git a/backbone/SupportFiles/RPBconfig.xml b/backbone/SupportFiles/RPBconfig.xml index d385c8f..19794d1 100644 --- a/backbone/SupportFiles/RPBconfig.xml +++ b/backbone/SupportFiles/RPBconfig.xml @@ -8,6 +8,7 @@ assembcube_COMMON___06_09CoeffFile ='$OSIRIS_DRP_DATA_PATH/osiris_wave_coeffs_060223-091004.fits' assembcube_COMMON___09_12CoeffFile ='$OSIRIS_DRP_DATA_PATH/osiris_wave_coeffs_091005-120103.fits' assembcube_COMMON___12_12CoeffFile ='$OSIRIS_DRP_DATA_PATH/osiris_wave_coeffs_120104-121109.fits' + assembcube_COMMON___13_15CoeffFile ='$OSIRIS_DRP_DATA_PATH/osiris_wave_coeffs_121110-151231.fits' assembcube_COMMON___Filterfile ='$OSIRIS_DRP_DATA_PATH/osiris_filter_info.list' caelum_mosaic_COMMON___Debug = '0' @@ -72,7 +73,7 @@ makeflatfi_COMMON___Mode="MED" mkrecmatrx_COMMON___slice="14" - mkrecmatrx_COMMON___shift="-13" + mkrecmatrx_COMMON___shift="-26" mkrecmatrx_COMMON___weight_limit="0.01" mkrectdark_COMMON___Debug="1" mkrectdark_COMMON___framesInDark="10" @@ -182,6 +183,9 @@ + + + @@ -231,8 +235,7 @@ - + @@ -274,13 +277,12 @@ o make handedness correct for Keck I Data"> - + - + diff --git a/backbone/drpBackbone__define.pro b/backbone/drpBackbone__define.pro index 4e759d8..4d59a2e 100644 --- a/backbone/drpBackbone__define.pro +++ b/backbone/drpBackbone__define.pro @@ -14,6 +14,7 @@ ; 2004-03-15 TMG Changed the use of FINDFILE to FILE_SEARCH which seems to have fixed the memory ; error. ; 2004-06-02 TMG Remove references to CRF since it is not needed anymore. +; 2016-04-28 ARR Refactor ::Run into methods so that one can run a single DRF on command. ; ;----------------------------------------------------------------------------------------------------- PRO drpBackbone__define @@ -50,8 +51,10 @@ PRO drpBackbone::Cleanup END - -PRO drpBackbone::Run, QueueDir +;+ +; Run the tasks required to start the DRP backbone. +;- +PRO drpBackbone::Start COMMON APP_CONSTANTS COMMON MSGCONSTANTS @@ -61,9 +64,9 @@ PRO drpBackbone::Run, QueueDir CATCH, Error ; Catch errors before the pipeline IF Error EQ 0 THEN BEGIN drpSetAppConstants ; Set the application constants - drpPushCallStack, 'drpBackbone::Run' + drpPushCallStack, 'drpBackbone::Run' Self -> OpenLog, drpXlateFileName(GETENV('OSIRIS_DRP_DEFAULTLOGDIR')) + '/' + general_log_name(), /GENERAL - drpLog, 'Run Backbone', /GENERAL + drpLog, 'Run Backbone', /GENERAL InErrHandler = 0 ; The following should probably be done in a drpBackbone::INIT method Self.Parser = OBJ_NEW('drpDRFParser') @@ -74,121 +77,225 @@ PRO drpBackbone::Run, QueueDir ;drpLog, 'drpBackbone::Run: About to parse config file', /GENERAL drpDefineStructs ; Define the DRP structures ENDIF ELSE BEGIN + DRPCONTINUE = 0 Self -> ErrorHandler CLOSE, LOG_GENERAL FREE_LUN, LOG_GENERAL CLOSE, LOG_DRF FREE_LUN, LOG_DRF RETURN - ENDELSE - - ; Replace this fixed assignement with some environment variable stuff - -; Commented out by James Larkin, Oct. 29, 2005 -; OriginalPath = STRING(!PATH) -; newModulePath = drpXlateFileName(GETENV('OSIRIS_DRP_MODULE_PATH')) + ':' + OriginalPath -; drpSetModulePath, newModulePath -; OriginalPath = STRING(!PATH) -; newModulePath = drpXlateFileName(GETENV('OSIRIS_DRP_IDL_DOWNLOADS_PATH')) + ':' + OriginalPath -; drpSetModulePath, newModulePath -; OriginalPath = STRING(!PATH) -; newModulePath = drpXlateFileName(GETENV('OSIRIS_DRP_BACKBONE_PATH')) + ':' + OriginalPath -; drpSetModulePath, newModulePath - - ; Poll the 'queue' directory continuously. If a DRF is encountered, reduce it. - DRPCONTINUE = 1 ; Start off with a continuous loop - WHILE DRPCONTINUE EQ 1 DO BEGIN - CATCH, Error ; Catch errors inside the pipeline - IF Error EQ 0 THEN BEGIN - queueDirName = QueueDir + '*.waiting' - FileNameArray = FILE_SEARCH(queueDirName) - CurrentDRF = drpGetNextWaitingFile(FileNameArray) - IF CurrentDRF.Name NE '' THEN BEGIN - drpLog, 'Found file:' + CurrentDRF.Name, /GENERAL - wait, 1.0 ; Wait 1 seconds to make sure file is fully written. - drpSetStatus, CurrentDRF, QueueDir, 'working' - DRFFileName = drpFileNameFromStruct(QueueDir, CurrentDRF) - ; Re-parse the configuration file, in case it has been changed. - OPENR, lun, CONFIG_FILENAME_FILE, /GET_LUN - READF, lun, CONFIG_FILENAME - FREE_LUN, lun - Self.ConfigParser -> ParseFile, drpXlateFileName(CONFIG_FILENAME) - Self.ConfigParser -> getParameters, Self - CATCH, parserError - IF parserError EQ 0 THEN BEGIN - continueAfterDRFParsing = 1 ; Assume it will be Ok to continue - Self.Parser -> ParseFile, DRFFileName, Self - CATCH, /CANCEL - ENDIF ELSE BEGIN - ; This branch, for errors we have not thought of yet, will cause a - ; memory leak. I do not understand it, but the the destruction and - ; recreation of the DRF parser seems to be the source of the leak. - ; TMG July 12, 2004 - ; Call the local error handler - Self -> ErrorHandler, CurrentDRF, QueueDir - ; Destroy the current DRF parser and punt the DRF - OBJ_DESTROY, Self.Parser - ; Recreate a parser object for the next DRF in the pipeline - Self.Parser = OBJ_NEW('drpDRFParser') - continueAfterDRFParsing = 0 - CATCH, /CANCEL - ENDELSE - IF continueAfterDRFParsing EQ 1 THEN BEGIN - Self.ConfigParser -> getIDLFunctions, Self - Self -> OpenLog, Self.LogPath + '/' + CurrentDRF.Name + '.log', /DRF - Result = Self.DRFPipeline -> Reduce(*Self.Modules, *Self.Data, Self) - IF Result EQ 1 THEN BEGIN - PRINT, "Success" - drpSetStatus, CurrentDRF, QueueDir, 'done' - ENDIF ELSE BEGIN - PRINT, "Failure" - drpSetStatus, CurrentDRF, QueueDir, 'failed' - ENDELSE - ; Free any remaining THIS memory here - IF PTR_VALID(Self.Data) THEN BEGIN - FOR i = N_ELEMENTS(*Self.Data)-1, 0, -1 DO BEGIN - PTR_FREE, (*Self.Data)[i].IntAuxFrames[*] - PTR_FREE, (*Self.Data)[i].IntFrames[*] - PTR_FREE, (*Self.Data)[i].Headers[*] - PTR_FREE, (*Self.Data)[i].Frames[*] - ENDFOR - ENDIF ; PTR_VALID(Self.Data) - - ; We are done with the DRF, so close its log file - CLOSE, LOG_DRF - FREE_LUN, LOG_DRF - ENDIF ELSE BEGIN ; ENDIF continueAfterDRFParsing EQ 1 - ; This code if continueAfterDRFParsing == 0 - drpLog, 'drpBackbone::Run: Reduction failed due to parsing error in file ' + DRFFileName, /GENERAL - drpSetStatus, CurrentDRF, QueueDir, 'failed' - ; If we failed with outstanding data, then clean it up. - IF PTR_VALID(Self.Data) THEN BEGIN - FOR i = N_ELEMENTS(*Self.Data)-1, 0, -1 DO BEGIN - PTR_FREE, (*Self.Data)[i].IntAuxFrames[*] - PTR_FREE, (*Self.Data)[i].IntFrames[*] - PTR_FREE, (*Self.Data)[i].Headers[*] - PTR_FREE, (*Self.Data)[i].Frames[*] - ENDFOR - ENDIF - ENDELSE -drpMemoryMarkSimple, 'xh' -;HEAP_GC, /VERBOSE ; Use this if the RBconfig.xml parameter list gets "big" - ENDIF + ENDELSE + CATCH, /CANCEL +END + +;+ +; Given a filename, run it through the DRF queue. +; Optionally, provide the name of the queue directory. +; Otherwise, assume that the DRF is in the queue directory. +;- +PRO drpBackbone::DoFile, Filename, QueueDir=QueueDir + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + CATCH, Error ; Catch errors inside the pipeline + IF Error EQ 0 THEN BEGIN + IF ~KEYWORD_SET(QueueDir) THEN BEGIN + parsed = FILE_PATH_NAME_EXT(Filename) + QueueDir = parsed.path + ENDIF + + CurrentDRF = {structQueryEntry} + parsed_file = file_path_name_ext(Filename) + CurrentDRF.status = STRMID(parsed_file.ext, 1) + parsed_file = file_path_name_ext(parsed_file.name) + CurrentDRF.name = STRMID(parsed_file.ext, 1) + CurrentDRF.index = parsed_file.name + Self -> DoSingle, CurrentDRF, QueueDir + ENDIF ELSE BEGIN + PRINT, "Calling Self -> ErrorHandler..." + Self -> ErrorHandler, CurrentDRF, QueueDir + CLOSE, LOG_DRF + FREE_LUN, LOG_DRF + ENDELSE + +END + +;+ +; Process a single CurrentDRF struct. +; This inernal method is used by both drpBackbone::DoQueueOnce +; and drpBackbone::DoFile +;- +PRO drpBackbone::DoSingle, CurrentDRF, QueueDir + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + IF CurrentDRF.Name NE '' THEN BEGIN + drpLog, 'Found file:' + CurrentDRF.Name, /GENERAL + wait, 1.0 ; Wait 1 seconds to make sure file is fully written. + drpSetStatus, CurrentDRF, QueueDir, 'working' + DRFFileName = drpFileNameFromStruct(QueueDir, CurrentDRF) + ; Re-parse the configuration file, in case it has been changed. + OPENR, lun, CONFIG_FILENAME_FILE, /GET_LUN + READF, lun, CONFIG_FILENAME + FREE_LUN, lun + Self.ConfigParser -> ParseFile, drpXlateFileName(CONFIG_FILENAME) + Self.ConfigParser -> getParameters, Self + CATCH, parserError + IF parserError EQ 0 THEN BEGIN + continueAfterDRFParsing = 1 ; Assume it will be Ok to continue + Self.Parser -> ParseFile, DRFFileName, Self + CATCH, /CANCEL ENDIF ELSE BEGIN - PRINT, "Calling Self -> ErrorHandler..." + ; This branch, for errors we have not thought of yet, will cause a + ; memory leak. I do not understand it, but the the destruction and + ; recreation of the DRF parser seems to be the source of the leak. + ; TMG July 12, 2004 + ; Call the local error handler Self -> ErrorHandler, CurrentDRF, QueueDir + ; Destroy the current DRF parser and punt the DRF + OBJ_DESTROY, Self.Parser + ; Recreate a parser object for the next DRF in the pipeline + Self.Parser = OBJ_NEW('drpDRFParser') + continueAfterDRFParsing = 0 + CATCH, /CANCEL + ENDELSE + IF continueAfterDRFParsing EQ 1 THEN BEGIN + Self.ConfigParser -> getIDLFunctions, Self + Self -> OpenLog, Self.LogPath + '/' + CurrentDRF.Name + '.log', /DRF + Result = Self.DRFPipeline -> Reduce(*Self.Modules, *Self.Data, Self) + IF Result EQ 1 THEN BEGIN + PRINT, "Success" + drpSetStatus, CurrentDRF, QueueDir, 'done' + ENDIF ELSE BEGIN + PRINT, "Failure" + drpSetStatus, CurrentDRF, QueueDir, 'failed' + ENDELSE + ; Free any remaining THIS memory here + IF PTR_VALID(Self.Data) THEN BEGIN + FOR i = N_ELEMENTS(*Self.Data)-1, 0, -1 DO BEGIN + PTR_FREE, (*Self.Data)[i].IntAuxFrames[*] + PTR_FREE, (*Self.Data)[i].IntFrames[*] + PTR_FREE, (*Self.Data)[i].Headers[*] + PTR_FREE, (*Self.Data)[i].Frames[*] + ENDFOR + ENDIF ; PTR_VALID(Self.Data) + + ; We are done with the DRF, so close its log file CLOSE, LOG_DRF FREE_LUN, LOG_DRF - ENDELSE + ENDIF ELSE BEGIN ; ENDIF continueAfterDRFParsing EQ 1 + ; This code if continueAfterDRFParsing == 0 + drpLog, 'drpBackbone::Run: Reduction failed due to parsing error in file ' + DRFFileName, /GENERAL + drpSetStatus, CurrentDRF, QueueDir, 'failed' + ; If we failed with outstanding data, then clean it up. + IF PTR_VALID(Self.Data) THEN BEGIN + FOR i = N_ELEMENTS(*Self.Data)-1, 0, -1 DO BEGIN + PTR_FREE, (*Self.Data)[i].IntAuxFrames[*] + PTR_FREE, (*Self.Data)[i].IntFrames[*] + PTR_FREE, (*Self.Data)[i].Headers[*] + PTR_FREE, (*Self.Data)[i].Frames[*] + ENDFOR + ENDIF + ENDELSE +drpMemoryMarkSimple, 'xh' +;HEAP_GC, /VERBOSE ; Use this if the RBconfig.xml parameter list gets "big" +ENDIF +END + +;+ +; Get the next waiting DRF and process it. +; This is a single run through the main DRP while loop. +;- +PRO drpBackbone::DoQueueOnce, QueueDir + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + CATCH, Error ; Catch errors inside the pipeline + IF Error EQ 0 THEN BEGIN + queueDirName = QueueDir + '*.waiting' + FileNameArray = FILE_SEARCH(queueDirName) + CurrentDRF = drpGetNextWaitingFile(FileNameArray) + Self -> DoSingle, CurrentDRF, QueueDir + ENDIF ELSE BEGIN + PRINT, "Calling Self -> ErrorHandler..." + Self -> ErrorHandler, CurrentDRF, QueueDir + CLOSE, LOG_DRF + FREE_LUN, LOG_DRF + ENDELSE +END + +;+ +; Get all waiting DRFs and process them. +;- +PRO drpBackbone::ConsumeQueue, QueueDir + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + queueDirName = QueueDir + '*.waiting' + FileNameArray = FILE_SEARCH(queueDirName) + s = size(FileNameArray) + WHILE N_ELEMENTS(FileNameArray) GT 0 AND DRPCONTINUE DO BEGIN + CATCH, Error; Catch errors inside the pipeline + IF Error EQ 0 THEN BEGIN + CurrentDRF = drpGetNextWaitingFile(FileNameArray) + DRFFileName = drpFileNameFromStruct(QueueDir, CurrentDRF) + Self -> DoSingle, CurrentDRF, QueueDir + ENDIF ELSE BEGIN + PRINT, "Calling Self -> ErrorHandler..." + Self -> ErrorHandler, CurrentDRF, QueueDir + CLOSE, LOG_DRF + FREE_LUN, LOG_DRF + ENDELSE + IF CurrentDRF.Name NE '' THEN BEGIN + done = where(FileNameArray EQ DRFFileName, nmatch) + IF N_ELEMENTS(FileNameArray) EQ 1 THEN BEGIN + DRPCONTINUE=0 + ENDIF + IF NMATCH GT 0 AND N_ELEMENTS(FileNameArray) GT 1 THEN BEGIN + remove, done, FileNameArray + s = SIZE(FileNameArray) + ENDIF + ENDIF + ENDWHILE +END + +;+ +; Called to close log files etc when the DRP queue is done. +;- +PRO drpBackbone::Finish + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + + CLOSE, LOG_GENERAL + FREE_LUN, LOG_GENERAL +END + + +;+ +; Consume the DRP backbone queue indefinietly. +;- +PRO drpBackbone::Run, QueueDir + COMMON APP_CONSTANTS + COMMON MSGCONSTANTS + COMMON MSGBUFFERIN + COMMON MSGBUFFEROUT + Self -> Start + WHILE DRPCONTINUE EQ 1 DO BEGIN + Self -> DoQueueOnce, QueueDir drpCheckMessages ; Check to see if we told ourselves to stop via the GUI ; Delay added to keep CPU usage ; down. Suggested by Marshall Perrin ; Feb 18, 2006 ; Moved to the correct place JEL, May 30, 2007 - wait, 1 + wait, 1 ENDWHILE - CLOSE, LOG_GENERAL - FREE_LUN, LOG_GENERAL + Self -> Finish END @@ -197,6 +304,11 @@ PRO drpBackbone::OpenLog, LogFile, GENERAL = LogGeneral, DRF = LogDRF COMMON APP_CONSTANTS drpPushCallStack, 'drpBackbone::OpenLog' + + LogDirectory = FILE_DIRNAME(LogFile) + IF NOT FILE_TEST(LogDirectory, /DIRECTORY) THEN BEGIN + FILE_MKDIR, LogDirectory + ENDIF IF KEYWORD_SET(LogGeneral) THEN BEGIN drpIOLock @@ -292,6 +404,7 @@ PRO drpBackbone::ErrorHandler, CurrentDRF, QueueDir ENDIF ENDIF ELSE BEGIN ; Will this cause a recursion error? + DRPCONTINUE = 0 MESSAGE, 'ERROR in drpBackbone::ErrorHandler - ' + STRTRIM(STRING(!ERR),2) + ': ' + !ERR_STRING, /INFO ENDELSE diff --git a/backbone/drpMain.pro b/backbone/drpMain.pro index a310201..16ecf07 100644 --- a/backbone/drpMain.pro +++ b/backbone/drpMain.pro @@ -81,7 +81,7 @@ PRO drpSetAppConstants PRINTDEPTH = 0 LOG_GENERAL = 1 LOG_DRF = 2 - DRPCONTINUE = 0 + DRPCONTINUE = 1 CALL_STACK = '' OK = 0 diff --git a/backbone/drpResolve.pro b/backbone/drpResolve.pro new file mode 100644 index 0000000..ebd7cb4 --- /dev/null +++ b/backbone/drpResolve.pro @@ -0,0 +1,5 @@ + +RESOLVE_ALL, RESOLVE_PROCEDURE='drpRun', /CONTINUE_ON_ERROR +FILES = FILE_SEARCH(getenv("OSIRIS_IDL_BASE") + "/modules/*_[0-9][0-9][0-9].pro") +FOR I=0, N_ELEMENTS(FILES)-1 DO $ + RESOLVE_ALL, RESOLVE_EITHER=FILE_BASENAME(FILES[I], '.pro'), /CONTINUE_ON_ERROR diff --git a/backbone/drpRun.pro b/backbone/drpRun.pro index 33d3ab4..262984e 100644 --- a/backbone/drpRun.pro +++ b/backbone/drpRun.pro @@ -11,14 +11,14 @@ PRO drpRun, QUEUE_DIR=queue_dir drpData = GETENV('OSIRIS_DRP_DATA_PATH') drpConfig = GETENV('OSIRIS_DRP_CONFIG_FILE') IDLversion = !version.release - print, " " + print, " " PRINT, "*****************************************************" print, "* *" PRINT, "* OSIRIS DATA REDUCTION PIPELINE *" print, "* *" print, "*###################################################*" print, "* *" - print, "* VERSION 3.2 *" + print, "* VERSION 4.0.0 *" print, "* *" print, "* James Larkin, Shelley Wright, *" print, "* Jason Weiss, Mike McElwain, *" @@ -27,6 +27,11 @@ PRO drpRun, QUEUE_DIR=queue_dir print, "* Tom Gasaway, Tommer Wizanski, *" print, "* Randy Campbell, Jim Lyke *" print, "* *" + print, "* Other contributors (alphabetical): *" + print, "* Anna Boehle, Sam Chappell, Devin Chu, Tuan Do, *" + print, "* Mike Fitzgerald, Kelly Lockhart, Jessica Lu, *" + print, "* Etsuko Mieda, Breann Sitarski, Alex Rudy, *" + print, "* Andrey Vayner, Greg Walth *" print, "*****************************************************" PRINT, "DRF Queue directory = " + initialQueueDir PRINT, "BACKBONE directory = " + backboneDir diff --git a/backbone/drpStartup.pro b/backbone/drpStartup.pro new file mode 100644 index 0000000..9f4944e --- /dev/null +++ b/backbone/drpStartup.pro @@ -0,0 +1,65 @@ +; get KROOT envvar +kroot_dir=getenv('KROOT') +if (kroot_dir eq '') then $ + kroot_dir='/kroot' + +drs_idl_root = getenv('OSIRIS_IDL_BASE') + +if (drs_idl_root EQ '') and (kroot_dir ne '') then $ + drs_idl_root=kroot_dir+'/rel/default/idl/odrs/' + +IF (drs_idl_root NE '') THEN $ + backbone_dir=drs_idl_root+'/backbone/' & $ + module_dir=drs_idl_root+'/modules/' & $ + idl_downloads_dir=module_dir+'idl_downloads/' & $ + +IF (drs_idl_root EQ '') THEN print, "OSIRIS_IDL_BASE=", drs_idl_root +IF (drs_idl_root EQ '') THEN print, "The OSIRIS DRP cannot locate the correct source code directory." +IF (drs_idl_root EQ '') THEN print, "Did you forget to set the environment variable OSIRIS_IDL_BASE?" +IF (drs_idl_root EQ '') THEN print, "You should run scripts/osirisSetup.sh to set environment variables" +IF (drs_idl_root EQ '') THEN EXIT, /NO_CONFIRM + +!PATH=backbone_dir+':'+module_dir+':'+'+'+idl_downloads_dir+':'+'' +!PATH=expand_path(!PATH) + +readcol_path = FILE_WHICH('readcol.pro') +IF (readcol_path EQ '') THEN print, "The OSIRIS DRP cannot locate readcol.pro, part of the IDL astrolib" +IF (readcol_path EQ '') THEN EXIT, /NO_CONFIRM + +.compile skysclim.pro +.compile strn.pro +.compile buie_avgclip.pro +.compile strnumber.pro +.compile ICG_LIB.pro +.compile break_path.pro +.compile daycnv.pro +.compile detabify.pro +.compile fxhmodify.pro +.compile fxhread.pro +.compile gettok.pro +.compile valid_num.pro +.compile fxpar.pro +.compile check_fits.pro +.compile fxparpos.pro +.compile fxaddpar.pro +.compile get_date.pro +.compile is_ieee_big.pro +.compile mkhdr.pro +.compile mpfit.pro +.compile mpfitfun.pro +.compile mrd_hread.pro +.compile mrd_skip.pro +.compile sxaddpar.pro +.compile sxdelpar.pro +.compile sxpar.pro +.compile readfits.pro +.compile writefits.pro +.compile meanclipdrl.pro +.compile general_log_name.pro +.compile drpMain.pro +.compile drpBackbone__define.pro +.compile drpConfigParser__define.pro +.compile drpDRFParser__define.pro +.compile drpDRFPipeline__define.pro +.compile drpPipeline__define.pro +.compile drpRun.pro diff --git a/backbone/osiris_drp_backbone_startup.pro b/backbone/osiris_drp_backbone_startup.pro index a355d8a..234ca80 100644 --- a/backbone/osiris_drp_backbone_startup.pro +++ b/backbone/osiris_drp_backbone_startup.pro @@ -1,91 +1,3 @@ -; define backbone code location - -; get KROOT envvar -kroot_dir=getenv('KROOT') -if (kroot_dir eq '') then $ - kroot_dir='/kroot' - - -drs_idl_root = getenv('OSIRIS_IDL_BASE') -; begin and else statements are not supported in batch mode. -if (drs_idl_root eq '') then $ - drs_idl_root=kroot_dir+'/rel/default/idl/odrs/' & $ - backbone_dir=drs_idl_root+'backbone/' & $ - module_dir=drs_idl_root+'modules/' & $ - idl_downloads_dir=module_dir+'idl_downloads/' - -if (drs_idl_root ne '') then $ - backbone_dir=drs_idl_root+'/backbone/' & $ - module_dir=drs_idl_root+'/modules/' & $ - idl_downloads_dir=module_dir+'idl_downloads/' - - -; put backbone code in idl path -!path=backbone_dir+':'+module_dir+':'+idl_downloads_dir+':'+!path - -; put idl astro library in the path (7.1.1 does this the IDL bin dir) -; not working the way I want it to... -!path='/usr/local/pkg/astron/pro/astro:'+!path -!path='/usr/local/pkg/astron/pro/astron:'+!path -!path='/usr/local/pkg/astron/pro/database:'+!path -!path='/usr/local/pkg/astron/pro/disk_io:'+!path -!path='/usr/local/pkg/astron/pro/fits:'+!path -!path='/usr/local/pkg/astron/pro/fits_bintable:'+!path -!path='/usr/local/pkg/astron/pro/fits_table:'+!path -!path='/usr/local/pkg/astron/pro/idlphot:'+!path -!path='/usr/local/pkg/astron/pro/image:'+!path -!path='/usr/local/pkg/astron/pro/jhuapl:'+!path -!path='/usr/local/pkg/astron/pro/math:'+!path -!path='/usr/local/pkg/astron/pro/misc:'+!path -!path='/usr/local/pkg/astron/pro/plot:'+!path -!path='/usr/local/pkg/astron/pro/robust:'+!path -!path='/usr/local/pkg/astron/pro/sdas:'+!path -!path='/usr/local/pkg/astron/pro/sdas_table:'+!path -!path='/usr/local/pkg/astron/pro/sockets:'+!path -!path='/usr/local/pkg/astron/pro/structure:'+!path -!path='/usr/local/pkg/astron/pro/tv:'+!path -!path=expand_path(!path) - -; compile procedures -.compile skysclim.pro -.compile strn.pro -.compile buie_avgclip.pro -.compile strnumber.pro -.compile ICG_LIB.pro -.compile break_path.pro -.compile daycnv.pro -.compile detabify.pro -.compile fxhmodify.pro -.compile fxhread.pro -.compile gettok.pro -.compile valid_num.pro -.compile fxpar.pro -.compile check_fits.pro -.compile fxparpos.pro -.compile fxaddpar.pro -.compile get_date.pro -.compile is_ieee_big.pro -.compile mkhdr.pro -.compile mpfit.pro -.compile mpfitfun.pro -.compile mrd_hread.pro -.compile mrd_skip.pro -.compile sxaddpar.pro -.compile sxdelpar.pro -.compile sxpar.pro -.compile readfits.pro -.compile writefits.pro -.compile meanclipdrl.pro -.compile general_log_name.pro -.compile drpMain.pro -.compile drpBackbone__define.pro -.compile drpConfigParser__define.pro -.compile drpDRFParser__define.pro -.compile drpDRFPipeline__define.pro -.compile drpPipeline__define.pro -.compile drpRun.pro - - ; Check to see if we need to use an alternate DRF queue alt_drf_queue = GETENV('OSIRIS_ALTERNATE_DRF_QUEUE_DIR') ;PRINT, '' diff --git a/data/Makefile b/data/Makefile index be96e7e..b915e16 100644 --- a/data/Makefile +++ b/data/Makefile @@ -36,10 +36,11 @@ RELDAT = osiris_cal_line.list \ osiris_wave_coeffs_050222-060222.fits \ osiris_wave_coeffs_060223-091004.fits \ osiris_wave_coeffs_091005-120103.fits \ - osiris_wave_coeffs_120104-121109.fits + osiris_wave_coeffs_120104-121109.fits \ + osiris_wave_coeffs_121110-151231.fits override SYSNAM = kss/osiris/drs/data/ -override VERNUM = 3.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). diff --git a/data/Makefile.bak b/data/Makefile.bak new file mode 100644 index 0000000..be96e7e --- /dev/null +++ b/data/Makefile.bak @@ -0,0 +1,46 @@ +############################################################################### +#+ +# Module: $KSSDIR/osiris/drs/data +# +# Revisions: +# +# Author: Jason Weiss +# +# Date: 2005/09/20 +# +# Description: Makefile for DRP data files +#- +############################################################################### + +# Include files. + +INCLUDE = + +# C source and object files. +CFLAGS = + +SOURCE = +OBJECT = + +DIRS = + +# Files to make are ... +FILES = + +# Files to release are ... +RELFILES = + +RELDAT = osiris_cal_line.list \ + osiris_filter_info.list \ + osiris_wave_coeffs.fits \ + osiris_wave_coeffs_050222-060222.fits \ + osiris_wave_coeffs_060223-091004.fits \ + osiris_wave_coeffs_091005-120103.fits \ + osiris_wave_coeffs_120104-121109.fits + +override SYSNAM = kss/osiris/drs/data/ +override VERNUM = 3.2 + +# Include general make rules (use /etc if no environment variable). + +include $(KROOT)/etc/config.mk diff --git a/data/osiris_wave_coeffs.fits b/data/osiris_wave_coeffs.fits index 6d816ec..b24bbf9 100644 Binary files a/data/osiris_wave_coeffs.fits and b/data/osiris_wave_coeffs.fits differ diff --git a/data/osiris_wave_coeffs_121110-151231.fits b/data/osiris_wave_coeffs_121110-151231.fits new file mode 100644 index 0000000..6d816ec Binary files /dev/null and b/data/osiris_wave_coeffs_121110-151231.fits differ diff --git a/modules/Makefile b/modules/Makefile index 9a87f64..48b52f2 100644 --- a/modules/Makefile +++ b/modules/Makefile @@ -70,7 +70,7 @@ RELPRO = adjchan_000.pro \ PROSUB = odrs/modules override SYSNAM = kss/osiris/drs/modules/ -override VERNUM = 3.2.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). diff --git a/modules/Makefile.bak b/modules/Makefile.bak new file mode 100644 index 0000000..9a87f64 --- /dev/null +++ b/modules/Makefile.bak @@ -0,0 +1,77 @@ +############################################################################### +#+ +# Module: $KSSDIR/osiris/drs/modules +# +# Revisions: +# +# Author: Jason Weiss +# +# Date: 2005/09/20 +# +# Description: Makefile for DRP modules +#- +############################################################################### + +# Include files. + +INCLUDE = + +# C source and object files. +CFLAGS = + +SOURCE = +OBJECT = + +DIRS = idl_downloads source + +# Files to make are ... +FILES = + +# Files to release are ... +RELFILES = + +RELDAT = +RELPRO = adjchan_000.pro \ + assembcube_000.pro \ + calibrwave_000.pro \ + cleancosmic_000.pro \ + combframes_000.pro \ + corrtilt_000.pro \ + divblackbo_000.pro \ + divideflat_000.pro \ + divstarspe_000.pro \ + extracstar_000.pro \ + fitdispers_000.pro \ + glitchid_000.pro \ + linext_000.pro \ + makedarkfr_000.pro \ + mkdatacube_000.pro \ + mkrecmatrx_000.pro \ + mkrectdark_000.pro \ + mkwavcalfr_000.pro \ + mkwavsmo_000.pro \ + mosaic_000.pro \ + mosaicdpos_000.pro \ + nrmflxdens_000.pro \ + nrmflxmagn_000.pro \ + oflipy_000.pro \ + remhydr_000.pro \ + rmcrosstalk_000.pro \ + savedatset_000.pro \ + saveflatfi_000.pro \ + spatrectif_000.pro \ + srtrectdat_000.pro \ + subtradark_000.pro \ + swapchan_000.pro \ + scaledskysub_000.pro \ + addwcs_000.pro \ + rename_000.pro + +PROSUB = odrs/modules + +override SYSNAM = kss/osiris/drs/modules/ +override VERNUM = 3.2.2 + +# Include general make rules (use /etc if no environment variable). + +include $(KROOT)/etc/config.mk diff --git a/modules/addwcs_000.pro b/modules/addwcs_000.pro index c8ba143..eb8882b 100644 --- a/modules/addwcs_000.pro +++ b/modules/addwcs_000.pro @@ -140,10 +140,13 @@ FUNCTION addwcs_000, DataSet, Modules, Backbone sxaddpar, *DataSet.Headers[0], "PC2_3", pc[0,1], "RA, Dec axes rotated by "+PA_str+" degr." sxaddpar, *DataSet.Headers[0], "PC3_2", pc[1,0], "RA, Dec axes rotated by "+PA_str+" degr." sxaddpar, *DataSet.Headers[0], "PC3_3", pc[1,1], "RA, Dec axes rotated by "+PA_str+" degr." - sxaddpar, *DataSet.Headers[0], "SPECSYS1", "TOPOCENT", "Axis 1 is in topocentric coordinates." - ; TODO I don't fully understand the WCS paper explanation of SSYSOBS... ???!?! - sxaddpar, *DataSet.Headers[0], "SSYSOBS1", "TOPOCENT", "Axis 1 is constant in in topocentric coordinates." - ; TODO WCS paper III suggests adding MJD-AVG to specify midpoint of + + ; The spectral axis is in topocentric coordiantes (i.e. constant) + sxaddpar, *DataSet.Headers[0], "SPECSYS", "TOPOCENT", "Spec axis ref frame is in topocentric coordinates." + ; The spectral axis reference frame does not vary with the celestial axes + sxaddpar, *DataSet.Headers[0], "SSYSOBS", "TOPOCENT", "Spec axis ref frame is constant across RADEC axes." + + ; TODO WCS paper III suggests adding MJD-AVG to specify midpoint of ; observations for conversions to barycentric. sxaddpar, *DataSet.Headers[0], "RADESYS", "FK5", "RA and Dec are in FK5" sxaddpar, *DataSet.Headers[0], "EQUINOX", 2000.0, "RA, Dec equinox is J2000, I think" diff --git a/modules/adjchan_000.pro b/modules/adjchan_000.pro old mode 100755 new mode 100644 index 1bd3e7c..f77b547 --- a/modules/adjchan_000.pro +++ b/modules/adjchan_000.pro @@ -53,6 +53,11 @@ ; dependent on julian date from 01/2009 to 10/2009 ; (SAW - Oct 2009) ; +; - Added a Julian date check for after the detector +; upgrade to the H2RG. If date is after 1/1/2016 (MJD = +; 57388.0) then the adjust channel algorithm is not +; run. (A. Boehle - April 2016) +; ; @END ; ;----------------------------------------------------------------------- @@ -72,6 +77,31 @@ FUNCTION adjchan_000, DataSet, Modules, Backbone ; Read the modified Julian date. jul_date = sxpar(*DataSet.Headers[0],"MJD-OBS", count=num) + ; update for detector upgrade to H2RG: + ; check Julian date of data: if after Jan. 1st, 2016, + ; then remove crosstalk is not run because data is from new H2RG detector + if (jul_date ge 57388.0) then begin + print, 'Adjust channels not performed: data is from H2RG detector.' + drpLog, 'Adjust channels not performed: data is from H2RG detector.', /DRF, DEPTH=1 + + ; use the top 13 pixels of each column excluding ref pixels, + ; which get no light, to correct the DC offset between columns + ; due to 60 Hz noise (added: 4/17/16) + for n = 0, (nFrames-1) do begin + im = *DataSet.Frames[n] + + medians = median(im[*,2032:2044],dimension=2) + for yy=0, 2047 do begin + im[*,yy] = im[*,yy] - medians + endfor + + *DataSet.Frames[n] = im + + endfor + + endif else begin + + ; Accumulate the deltas for the upper and lower halfs of the detector del_upper = 0.0 num_upper = 0.0 @@ -488,6 +518,8 @@ FUNCTION adjchan_000, DataSet, Modules, Backbone end + endelse + ; it is not neccessary to change the dataset pointer report_success, functionName, T diff --git a/modules/assembcube_000.pro b/modules/assembcube_000.pro index fcf954f..57276ba 100644 --- a/modules/assembcube_000.pro +++ b/modules/assembcube_000.pro @@ -53,6 +53,8 @@ ; 1) lambda-y-x orientation ; 2) pointing origin change due to Keck-II to Keck-I move ; 3) rotation matrix +; @Modified Jim Lyke (Apr 2016) +; Added additional wavelength solutions for 13-15, new SPEC: 16- ; ; ; @END @@ -92,6 +94,7 @@ FUNCTION assembcube_000, DataSet, Modules, Backbone s06_09CoeffFile = strg(Backbone->getParameter('assembcube_COMMON___06_09CoeffFile')) s09_12CoeffFile = strg(Backbone->getParameter('assembcube_COMMON___09_12CoeffFile')) s12_12CoeffFile = strg(Backbone->getParameter('assembcube_COMMON___12_12CoeffFile')) + s13_15CoeffFile = strg(Backbone->getParameter('assembcube_COMMON___13_15CoeffFile')) ; midwave is a wavelength offset used to make the poly fit symmetric in wavelength ; This must match what is in the routine that fits raw spectra: plot_fwhm @@ -213,14 +216,18 @@ FUNCTION assembcube_000, DataSet, Modules, Backbone print, "Using wavelength coefficient solution from Oct 4, 2009 - Jan 3, 2012" coeffFile = s09_12CoeffFile endif - ;finds coeffs between Jan 2012 and Dec 2012 + ;finds coeffs between Jan 2012 and Nov 2012 if ( (num eq 1) and (jul_date ge 55930.0 and jul_date lt 56242.0) ) then begin print, "Using wavelength coefficient solution from Jan 3, 2012 - Nov 9, 2012" coeffFile = s12_12CoeffFile endif - ; Use the new coeffs that are AFTER Nov 2012 - if ( (num eq 1) and (jul_date ge 56242.0)) then begin - print, "Using wavelength coefficient solution for data taken AFTER Nov 9, 2012" + ; finds coeffs between Nov 2012 and Dec 2015 + if ( (num eq 1) and (jul_date ge 56242.0 and jul_date lt 57388.0)) then begin + print, "Using wavelength coefficient solution from Nov 9, 2012 - Dec 31, 2015" + coeffFile = s13_15CoeffFile + endif + ; use current coeff file for dates Jan 1, 2016 and after + if ( (num eq 1) and (jul_date ge 57388.0 )) then begin coeffFile = s_CoeffFile endif @@ -520,33 +527,32 @@ print,'cotemp ',cotemp endif ; the following is from mosaic_000.pro: ; Make default center the broad band values - - if jul_date lt 55942.5 then begin ; (Mieda-201407: x reference pixel correction for x flip due to Keck-I optics) - pnt_cen=[32.0,9.0] - if ( n_sf eq 1 ) then begin - bb = strcmp('b',strmid(s_filter,2,1)) - if ( strcmp('Zn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Zn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Zn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] - if ( strcmp('Zn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] - if ( strcmp('Jn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,17.0] - if ( strcmp('Jn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,22.0] - if ( strcmp('Jn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Jn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] - if ( strcmp('Hn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,19.0] - if ( strcmp('Hn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,23.0] - if ( strcmp('Hn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Hn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] - if ( strcmp('Hn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] - if ( strcmp('Kn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,19.0] - if ( strcmp('Kn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,23.0] - if ( strcmp('Kn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Kn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] - if ( strcmp('Kn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] - if ( strcmp('Kc3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] - if ( strcmp('Kc4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] - if ( strcmp('Kc5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] - endif + if jul_date lt 55942.5 then begin ; (Mieda-201407: x reference pixel correction for x flip due to Keck-I optics) + pnt_cen=[32.0,9.0] + if ( n_sf eq 1 ) then begin + bb = strcmp('b',strmid(s_filter,2,1)) + if ( strcmp('Zn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Zn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Zn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] + if ( strcmp('Zn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] + if ( strcmp('Jn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,17.0] + if ( strcmp('Jn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,22.0] + if ( strcmp('Jn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Jn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] + if ( strcmp('Hn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,19.0] + if ( strcmp('Hn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,23.0] + if ( strcmp('Hn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Hn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] + if ( strcmp('Hn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] + if ( strcmp('Kn1',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,19.0] + if ( strcmp('Kn2',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,23.0] + if ( strcmp('Kn3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Kn4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] + if ( strcmp('Kn5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] + if ( strcmp('Kc3',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,25.0] + if ( strcmp('Kc4',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,28.0] + if ( strcmp('Kc5',strmid(s_filter,0,3)) eq 1 ) then pnt_cen=[32.0,33.0] + end endif else begin pnt_cen=[32.0,n_dims[3]-1-9.0] if ( n_sf eq 1 ) then begin @@ -582,47 +588,36 @@ print,'cotemp ',cotemp sxaddpar, *DataSet.Headers[q], "WAVEFILE", coeffFileNoPath, "Wavelength Solution File" sxaddpar, *DataSet.Headers[q], "WCSAXES", 3, "Number of axes in WCS system" sxaddpar, *DataSet.Headers[q], "CTYPE1", "WAVE", "Vacuum wavelength." - - ; (Mieda-201407: CTYPE, CUNIT, CRVAL are supposed to be 2 for RA and 3 for Dec - ;sxaddpar, *DataSet.Headers[q], "CTYPE2", "RA---TAN", "Right Ascension." - ;sxaddpar, *DataSet.Headers[q], "CTYPE3", "DEC--TAN", "Declination." - sxaddpar, *DataSet.Headers[q], "CTYPE2", "DEC--TAN", "Declination." - sxaddpar, *DataSet.Headers[q], "CTYPE3", "RA---TAN", "Right Ascension." - + ; (Mieda-201407: CTYPE, CUNIT, CRVAL are supposed to be 2 for RA and 3 for Dec + sxaddpar, *DataSet.Headers[q], "CTYPE2", "DEC--TAN", "Declination." + sxaddpar, *DataSet.Headers[q], "CTYPE3", "RA---TAN", "Right Ascension." sxaddpar, *DataSet.Headers[q], "CUNIT1", "nm", "Vacuum wavelength unit is nanometers" - ;sxaddpar, *DataSet.Headers[q], "CUNIT2", "deg", "R.A. unit is degrees, always" - ;sxaddpar, *DataSet.Headers[q], "CUNIT3", "deg", "Declination unit is degrees, always" - sxaddpar, *DataSet.Headers[q], "CUNIT2", "deg", "Declination unit is degrees, always" - sxaddpar, *DataSet.Headers[q], "CUNIT3", "deg", "R.A. unit is degrees, always" - + sxaddpar, *DataSet.Headers[q], "CUNIT2", "deg", "Declination unit is degrees, always" + sxaddpar, *DataSet.Headers[q], "CUNIT3", "deg", "R.A. unit is degrees, always" sxaddpar, *DataSet.Headers[q], 'CRVAL1', minl, " [nm] Wavelength at reference pixel" - ;sxaddpar, *DataSet.Headers[q], "CRVAL2", sxpar(*DataSet.Headers[q],"RA"), " [deg] R.A. at reference pixel" - ;sxaddpar, *DataSet.Headers[q], "CRVAL3", sxpar(*DataSet.Headers[q],"DEC"), " [deg] Declination at reference pixel" sxaddpar, *DataSet.Headers[q], "CRVAL2", sxpar(*DataSet.Headers[q],"DEC"), " [deg] Declination at reference pixel" - sxaddpar, *DataSet.Headers[q], "CRVAL3", sxpar(*DataSet.Headers[q],"RA"), " [deg] R.A. at reference pixel" - + sxaddpar, *DataSet.Headers[q], "CRVAL3", sxpar(*DataSet.Headers[q],"RA"), " [deg] R.A. at reference pixel" sxaddpar, *DataSet.Headers[q], 'CRPIX1', 1, "Reference pixel location" sxaddpar, *DataSet.Headers[q], "CRPIX2", pnt_cen[0], "Reference pixel location" sxaddpar, *DataSet.Headers[q], "CRPIX3", pnt_cen[1], "Reference pixel location" - sxaddpar, *DataSet.Headers[q], 'CDELT1', disp , "Wavelength scale is "+string(disp)+" nm/channel " + sxaddpar, *DataSet.Headers[q], 'CDELT1', disp , "Wavelength scale is "+string(disp)+" nm/channel " sxaddpar, *DataSet.Headers[q], "CDELT2", pixelscale/3600., "Pixel scale is "+pixelscale_str+" arcsec/pixel" sxaddpar, *DataSet.Headers[q], "CDELT3", pixelscale/3600., "Pixel scale is "+pixelscale_str+" arcsec/pixel" ; rotation matrix. - ;pc = [[cos(d_PA), -sin(d_PA)], $ - ; [sin(d_PA), cos(d_PA)]] - pc = [[cos(d_PA), sin(d_PA)], $ - [sin(d_PA), -cos(d_PA)]] ; (Mieda-201407: Rotation matrix correction + [sin(d_PA), -cos(d_PA)]] ; (Mieda-201407: Rotation matrix correction sxaddpar, *DataSet.Headers[q], "PC1_1", 1, "Spectral axis is unrotated" sxaddpar, *DataSet.Headers[q], "PC2_2", pc[0,0], "RA, Dec axes rotated by "+PA_str+" degr." sxaddpar, *DataSet.Headers[q], "PC2_3", pc[0,1], "RA, Dec axes rotated by "+PA_str+" degr." sxaddpar, *DataSet.Headers[q], "PC3_2", pc[1,0], "RA, Dec axes rotated by "+PA_str+" degr." sxaddpar, *DataSet.Headers[q], "PC3_3", pc[1,1], "RA, Dec axes rotated by "+PA_str+" degr." - sxaddpar, *DataSet.Headers[q], "SPECSYS1", "TOPOCENT", "Axis 1 is in topocentric coordinates." - ; TODO I don't fully understand the WCS paper explanation of SSYSOBS... ???!?! - sxaddpar, *DataSet.Headers[q], "SSYSOBS1", "TOPOCENT", "Axis 1 is in topocentric coordinates." + ; The spectral axis is in topocentric coordiantes (i.e. constant) + sxaddpar, *DataSet.Headers[q], "SPECSYS", "TOPOCENT", "Spec axis ref frame is in topocentric coordinates." + ; The spectral axis reference frame does not vary with the celestial axes + sxaddpar, *DataSet.Headers[q], "SSYSOBS", "TOPOCENT", "Spec axis ref frame is constant across RADEC axes." + ; TODO WCS paper III suggests adding MJD-AVG to specify midpoint of ; observations for conversions to barycentric. sxaddpar, *DataSet.Headers[q], "RADESYS", "FK5", "RA and Dec are in FK5" diff --git a/modules/combframes_000.pro b/modules/combframes_000.pro old mode 100755 new mode 100644 index 352c133..d1f274d --- a/modules/combframes_000.pro +++ b/modules/combframes_000.pro @@ -347,13 +347,24 @@ FUNCTION combframes_000, DataSet, Modules, Backbone if ( n_Dims(2) ne 2048 ) then $ return, error ('Error, y-dim must be 2048') + if ( nFrames lt 2 ) then $ + return, error ('Combframes requires at least 2 frames.') + + + ; update for detector upgrade to H2RG: + ; check Julian date of data: if after Jan. 1st, 2016, + ; then readout channel offsets are not adjusted before frames are combined, + ; because data is from new H2RG detector. + ; read in header of first frame to get MJD + jul_date = sxpar(*DataSet.Headers[0], "MJD-OBS", count=num) + if (jul_date ge 57388.0) then begin + print, 'Data is from H2RG detector: readout channels do not need to be adjusted for offsets.' + endif else begin + itime = float(SXPAR(*DataSet.Headers[0],'ITIME')) if ( itime lt 1.0 ) then itime = 2.0 print, 'itime=', itime - if ( nFrames lt 2 ) then $ - return, error ('Combframes requires at least 2 frames.') - ; Create an average frame to determine the offset levels avg = fltarr(2048,2048) num = fltarr(2048,2048) @@ -439,6 +450,9 @@ FUNCTION combframes_000, DataSet, Modules, Backbone end end + endelse + + ; Now finally combine the frames into ; a single frame through medianing ; each pixel where valid. @@ -516,8 +530,12 @@ FUNCTION combframes_000, DataSet, Modules, Backbone itime = string(sxpar(*DataSet.Headers[0], 'ITIME')) - + ; updated code for H2RG (by jlyke, added by A. Boehle - April 2016) + ; For H2, this file name DOES NOT include the .fits file extension. + ; For H2RG, this file name DOES include the .fits file extenstion. fname = sxpar(*DataSet.Headers[0],'DATAFILE') + fn = STRSPLIT(fname, '.', /EXTRACT) + fname = fn[0] fname = strtrim(fname,2) + '_combo_'+strtrim(itime,2) fname = strtrim(fname,2) message,/info, fname diff --git a/modules/divblackbo_000.pro b/modules/divblackbo_000.pro old mode 100755 new mode 100644 diff --git a/modules/divstarspe_000.pro b/modules/divstarspe_000.pro index a442ef4..2b235c3 100644 --- a/modules/divstarspe_000.pro +++ b/modules/divstarspe_000.pro @@ -87,7 +87,12 @@ FUNCTION divstarspe_000, DataSet, Modules, Backbone end end ; Edit file name in header to replace datset with calstar + ; updated code for H2RG (by jlyke, added by A. Boehle - April 2016) + ; For H2, this file name DOES NOT include the .fits file extension. + ; For H2RG, this file name DOES include the .fits file extenstion. fname = sxpar(*DataSet.Headers[i],'DATAFILE') + fn = STRSPLIT(fname, '.', /EXTRACT) + fname = fn[0] fname = fname + '_tlc' print, fname SXADDPAR, *DataSet.Headers[i], "DATAFILE", fname diff --git a/modules/extracstar_000.pro b/modules/extracstar_000.pro index 1bc2645..3ff70a6 100644 --- a/modules/extracstar_000.pro +++ b/modules/extracstar_000.pro @@ -165,7 +165,12 @@ FUNCTION extracstar_000, DataSet, Modules, Backbone SXADDPAR, *DataSet.Headers[q], "NAXIS1", n_dims[1],AFTER='NAXIS' ; Edit file name in header to replace datset with calstar + ; updated code for H2RG (by jlyke, added by A. Boehle - April 2016) + ; For H2, this file name DOES NOT include the .fits file extension. + ; For H2RG, this file name DOES include the .fits file extenstion. fname = sxpar(*DataSet.Headers[q],'DATAFILE') + fn = STRSPLIT(fname, '.', /EXTRACT) + fname = fn[0] fname = fname + '_1d' print, fname SXADDPAR, *DataSet.Headers[q], "DATAFILE", fname diff --git a/modules/glitchid_000.pro b/modules/glitchid_000.pro old mode 100755 new mode 100644 index 2465a38..1066181 --- a/modules/glitchid_000.pro +++ b/modules/glitchid_000.pro @@ -41,6 +41,8 @@ ; @HISTORY 6.14.2005, created ; 11.21.2005, modified with M. Perrin suggestions ; 06.17.2006, modified for ratio detection +; 04.06.2016, modified so algorithm is not run on data from +; new H2RG detector (A. Boehle) ; @AUTHOR Shelley Wright ; @@ -68,6 +70,16 @@ FUNCTION glitchid_000, DataSet, Modules, Backbone print, "Number of frames = ", nFrames print, "Size of each =", n_Dims + ; update for detector upgrade to H2RG: + ; check Julian date of data: if after Jan. 1st, 2016, + ; then glitch ID is not run because data is from new H2RG detector. + ; read in header of first frame to get MJD + jul_date = sxpar(*DataSet.Headers[0], "MJD-OBS", count=num) + if (jul_date ge 57388.0) then begin + print, 'Glitch ID not performed: data is from H2RG detector.' + drpLog, 'Glitch ID not performed: data is from H2RG detector.', /DRF, DEPTH=1 + endif else begin + for n = 0, (nFrames-1) do begin ;;; Read in the image @@ -180,6 +192,8 @@ FUNCTION glitchid_000, DataSet, Modules, Backbone endfor + endelse + ; it is not neccessary to change the dataset pointer report_success, functionName, T diff --git a/modules/idl_downloads/DRPXLA~2.PRO b/modules/idl_downloads/DRPXLA~2.PRO new file mode 100644 index 0000000..1afee25 --- /dev/null +++ b/modules/idl_downloads/DRPXLA~2.PRO @@ -0,0 +1,56 @@ +FUNCTION drpXlateFileName, input + + ; Returns the translated name of the file string by expanding any + ; environment variables in the input string. + ; E.g., if $HOME=/Users/tgasaway then $HOME/code/backbone should be + ; translated as /Users/tgasaway/code/backbone + ; If any presumed environment variables do not translate, or if there + ; are no environment variables, then the function returns the original + ; input string. + + ; Split the input string into parts + inSplit = STRSPLIT(input, '[$,/]', /EXTRACT, /REGEX) + + ReturnOriginal = 0 ; Assume that we won't have to return the original + ; because of errors + + ; Translate all of the environment variables that we find. + FOR i = 0, (N_ELEMENTS(inSplit)-1) DO BEGIN + IF STRPOS(input, '$'+inSplit[i]) NE -1 THEN BEGIN + ; We have an environment variable embedded in the input string so + ; replace the string with it's translation. + temp = GETENV(STRUPCASE(inSplit[i])) + IF temp NE '' THEN BEGIN + inSplit[i] = temp + ENDIF ELSE BEGIN + ReturnOriginal = 1 ; We failed translate an environment variable + ; so set the error return + ENDELSE + ENDIF + ENDFOR + + IF ReturnOriginal NE 1 THEN BEGIN + ; Now that we have translated everything we can, reassemble the string correctly + output = '' + ; Prepend '/' if one began the input string + IF STRPOS(input, '/') EQ 0 THEN BEGIN + output = '/' + ENDIF + i = 0 + IF N_ELEMENTS(inSplit)-2 GE 0 THEN BEGIN + FOR i = 0, (N_ELEMENTS(inSplit)-2) DO BEGIN + output = output + inSplit[i] + output = output + '/' + ENDFOR + ENDIF + output = output + inSplit[i] ; Do case for i == N_ELEMENTS(inSplit)-1 + ; Append final'/' if one ended the input string + IF STRPOS(input, '/', /REVERSE_SEARCH) EQ STRLEN(input)-1 THEN BEGIN + output = output + '/' + ENDIF + ENDIF ELSE BEGIN + output = input + ENDELSE + + RETURN, output +END diff --git a/modules/idl_downloads/Makefile b/modules/idl_downloads/Makefile index ef56cfd..6fe20b0 100644 --- a/modules/idl_downloads/Makefile +++ b/modules/idl_downloads/Makefile @@ -258,7 +258,7 @@ RELPRO = add_fitskwd_to_header.pro \ PROSUB = odrs/modules/idl_downloads override SYSNAM = kss/osiris/drs/modules/idl_downloads/ -override VERNUM = 3.2 +override VERNUM = 4.1 # Include general make rules (use /etc if no environment variable). diff --git a/modules/idl_downloads/Makefile.bak b/modules/idl_downloads/Makefile.bak new file mode 100644 index 0000000..ef56cfd --- /dev/null +++ b/modules/idl_downloads/Makefile.bak @@ -0,0 +1,265 @@ +############################################################################### +#+ +# Module: $KSSDIR/osiris/drs/modules/idl_downloads/Makefile +# +# Revisions: +# +# Author: Jason Weiss +# +# Date: 2005/09/20 +# +# Description: Makefile for auxillary idl files for DRP modules +#- +############################################################################### + +# Include files. + +INCLUDE = + +# C source and object files. +CFLAGS = + +SOURCE = +OBJECT = + +DIRS = + +# Files to make are ... +FILES = + +# Files to release are ... +RELFILES = + +RELDAT = +RELPRO = add_fitskwd_to_header.pro \ + arr_chk.pro \ + average_frames.pro \ + blackbody.pro \ + bool_arr_chk.pro \ + bool_arr_match.pro \ + bool_contains_finite.pro \ + bool_contains_inf.pro \ + bool_contains_nan.pro \ + bool_contains_neg.pro \ + bool_dataset_integrity.pro \ + bool_dim_match.pro \ + bool_invert.pro \ + bool_is_bool.pro \ + bool_is_byte.pro \ + bool_is_complex.pro \ + bool_is_cube.pro \ + bool_is_defined.pro \ + bool_is_double.pro \ + bool_is_float.pro \ + bool_is_heap.pro \ + bool_is_image.pro \ + bool_is_integer.pro \ + bool_is_obj.pro \ + bool_is_ptrarr.pro \ + bool_is_ptr.pro \ + bool_is_scalar.pro \ + bool_is_sky.pro \ + bool_is_string.pro \ + bool_is_struct.pro \ + bool_is_vector.pro \ + bool_pointer_integrity.pro \ + bool_ptrarr_valid.pro \ + bool_ptr_cube.pro \ + bool_ptr_image.pro \ + bool_ptr_valid.pro \ + buie_avgclip.pro \ + break_path.pro \ + calc_reg_wl_grid.pro \ + calculate_regular_wavelength_grid.pro \ + calculate_weight.pro \ + calibrwave.pro \ + check_bits.pro \ + check_fits.pro \ + check_median.pro \ + check_module.pro \ + check_noise.pro \ + checkvalidity.pro \ + chktag.pro \ + clean_op.pro \ + clean.pro \ + clear_frame.pro \ + clip_frames.pro \ + clipimages.pro \ + clip.pro \ + cmapply.pro \ + cmset_op.pro \ + cube2image.pro \ + cubes_mosaic_cubes.pro \ + data_valid.pro \ + daycnv.pro \ + debug_info.pro \ + declare_app_constants.pro \ + define_error_constants.pro \ + define_module.pro \ + delete_frame.pro \ + det2coord.pro \ + detabify.pro \ + determine_mosaic_offsets_from_header.pro \ + div_by_vector.pro \ + drpxlatefilename.pro \ + drpXlateFileName.pro \ + equalize_bak.pro \ + equalize.pro \ + error.pro \ + extbit.pro \ + extr_horne_1.pro \ + extr_stellar_spec_2.pro \ + extr_stellar_spec.pro \ + filterinfo.pro \ + findlines_get_index.pro \ + findlines_get_lamp_status.pro \ + findlines_new.pro \ + findlines.pro \ + findlines_read_calline_file.pro \ + findlines_x.pro \ + findlines_y.pro \ + findspecres.pro \ + find_with_def.pro \ + fit_dispersion.pro \ + fits_close.pro \ + fitsdir.pro \ + fits_help.pro \ + fits_info.pro \ + fits_open.pro \ + fits_read.pro \ + fits_write.pro \ + fix_nb_scan.pro \ + frame_op.pro \ + frame_op_ssr.pro \ + fxaddpar.pro \ + fxhmodify.pro \ + fxhread.pro \ + fxparpos.pro \ + fxpar.pro \ + fxposit.pro \ + gauss1p.pro \ + gauss1.pro \ + gauss2.pro \ + general_log_name.pro \ + generate_kernel.pro \ + get_date.pro \ + get_filter_param.pro \ + get_kwd.pro \ + get_linelist.pro \ + gettok.pro \ + headfits.pro \ + hexpict.pro \ + ICG_LIB.pro \ + image_stat_on_rect.pro \ + img_aperture.pro \ + img_cube2image.pro \ + img_lin2dfit2.pro \ + info.pro \ + intauxframe_compatibility.pro \ + interponed.pro \ + intframe2noise.pro \ + intframe_translate.pro \ + int_valid.pro \ + is_ieee_big.pro \ + lenslets.pro \ + linearize.pro \ + linfitframes.pro \ + lin_fit_planes.pro \ + make_dataset_euro3d_compliant.pro \ + make_det_response.pro \ + make_euro3d_compliant.pro \ + make_filename.pro \ + MakeFileName.pro \ + makestddrpdata.pro \ + meanclipdrl.pro \ + median_filter_1d.pro \ + medianscheck.pro \ + minmax_2d.pro \ + mkhdr.pro \ + moffat.pro \ + mosaicdith_imag_integrity.pro \ + mosaicdith_integrity.pro \ + mosaicdith_spec_integrity.pro \ + mosaic.pro \ + mpchilim.pro \ + mpchitest.pro \ + mpcurvefit.pro \ + mpfit2dfun.pro \ + mpfit2dpeak.pro \ + mpfitellipse.pro \ + mpfitexpr.pro \ + mpfitfun.pro \ + mpfitpeak.pro \ + mpfit.pro \ + mpftest.pro \ + mpnormlim.pro \ + mpnormtest.pro \ + mrd_hread.pro \ + mrd_skip.pro \ + my_index.pro \ + noiseanalysis.pro \ + onedata.pro \ + onedatasmall.pro \ + oneintframeaux.pro \ + oneintframeauxsmall.pro \ + oneintframe.pro \ + oneintframesmall.pro \ + psf_fit_from_cube.pro \ + qbit_transform.pro \ + qbit_translate.pro \ + rdbv.pro \ + readfits.pro \ + replicate_vector.pro \ + report_success.pro \ + resize_dataset.pro \ + save_dataset.pro \ + search_bad_pixels_via_noise.pro \ + searchBadPixelsViaNoise.pro \ + setbit.pro \ + setfitparm.pro \ + set_header.pro \ + sfit_surface.pro \ + shift_image.pro \ + shift_object.pro \ + sigfig.pro \ + sigma_poly_fit.pro \ + skysclim.pro \ + smile.pro \ + spec_opt_extract_spec_from_cube_simple.pro \ + strg.pro \ + strn.pro \ + strnumber.pro \ + struct_merge.pro \ + struct_trimtags.pro \ + strwithzeroes.pro \ + subtract_slice_bg_from_cube.pro \ + sxaddpar.pro \ + sxdelpar.pro \ + sxpar.pro \ + tnmin.pro \ + update_dataset_pointer.pro \ + update_dataset.pro \ + valid_num.pro \ + valid.pro \ + verify_dataset_naxis.pro \ + verify_naxis.pro \ + warning.pro \ + weightedmean.pro \ + writefits.pro \ + write_spiffi_cube.pro \ + zerodata.pro \ + zerodatasmall.pro \ + zerointframeaux.pro \ + zerointframeauxsmall.pro \ + zerointframe.pro \ + zerointframesmall.pro \ + imdisp.pro + +PROSUB = odrs/modules/idl_downloads + +override SYSNAM = kss/osiris/drs/modules/idl_downloads/ +override VERNUM = 3.2 + +# Include general make rules (use /etc if no environment variable). + +include $(KROOT)/etc/config.mk diff --git a/modules/idl_downloads/add_fitskwd_to_header.pro b/modules/idl_downloads/add_fitskwd_to_header.pro old mode 100755 new mode 100644 diff --git a/modules/idl_downloads/arr_chk.pro b/modules/idl_downloads/arr_chk.pro old mode 100755 new mode 100644 diff --git a/modules/idl_downloads/astro/LICENSE b/modules/idl_downloads/astro/LICENSE new file mode 100644 index 0000000..12f0866 --- /dev/null +++ b/modules/idl_downloads/astro/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2014, Wayne Landsman + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/modules/idl_downloads/astro/README.md b/modules/idl_downloads/astro/README.md new file mode 100644 index 0000000..30de104 --- /dev/null +++ b/modules/idl_downloads/astro/README.md @@ -0,0 +1,4 @@ +IDLAstro +======== + +Astronomy related procedures in the commercial IDL language diff --git a/modules/idl_downloads/astro/aaareadme.txt b/modules/idl_downloads/astro/aaareadme.txt new file mode 100644 index 0000000..60d404e --- /dev/null +++ b/modules/idl_downloads/astro/aaareadme.txt @@ -0,0 +1,88 @@ +THE IDL ASTRONOMY USER'S LIBRARY (April 2014) + +The IDL Astronomy Users Library is a central repository for general purpose +astronomy procedures written in IDL. The library currently contains +500+ procedures including general FITS I/O, interfaces with STSDAS and IRAF, +astronomical utilities, and photometry and spectral analysis procedures. +The library is not meant to be an integrated package, but rather is a +collection of procedures from which users can pick and choose (and possibly +modify) for their own use. Submitted procedures are given a cursory testing, +but are basically stored in the library as submitted. The IDL +Astronomy User's Library was funded through November 2000 under the NASA +Astrophysics Data program. + +The homepage for the IDL Astronomy Library is http://idlastro.gsfc.nasa.gov. +There is no longer any FTP access and downloads must be performed from the Web +or using WGET. The default version of the Library requires IDL V6.4, +although earlier frozen versions are available in the old/ directory. + +The success of the IDL Astronomy User's Library depends upon the +willingness of users to give as well as take. Submission of relevant +procedures is strongly encouraged. Equally important is the notification +(or correction) of programming bugs or documentation errors. + +I will post news about major updates to the comp.lang.idl-pvwave +Usenet newsgroup. + +Questions about the IDL Astronomy Library can be addressed to +Wayne Landsman Wayne.Landsman@nasa.gov + (301)-286-3625 + + +The directory contains the following files + + aaareadme.txt - this file + astron.tar.gz - a gzip'ed Unix tar file containing all Library procedures + text files, and data files. + astron.dir.tar.gz - This file is an alternative to astron.tar.gz. It + contains the same files as astron.tar.gz but maintains the library + procedures in their respective sub-directories. + astron.zip - A .zip version of the Astronomy Library, but with X-windows-only + procedures (e.g. curs.pro) removed + contents.txt - an ASCII file giving one-line descriptions of all + 500+ procedures currently in the Library. This listing is also + available at http://idlastro.gsfc.nasa.gov/contents.html + coyote_astron.tar.gz - A gzip'ed tar file of the Coyote library procedures + used by the Astronomy library. This file is an alternative to + downloading the entire Coyote library at + http://www.idlcoyote.com/documents/programs.php + guidelines.txt - Suggested programming guidelines for Astronomy library + procedures. + news.txt - an ASCII file listing all additions or changes to the Library + in the past 6 months in reverse chronological order. This file + should be checked periodically as new and modified procedures are added + to the Library. Also availabile as an HTML file at + http://idlastro.gsfc.nasa.gov/news.html + +The following subdirectories are available + + text - contains a collection of ASCII and LaTex files concerning various + categories of IDL procedures. + coyote - Contains Coyote Library routines which are needed by at least one + Astronomy Library routine. These are *not* included in the Astron + Library zip or tar files. + data - contains data files used by a couple of Library procedures. *Due to + their size, the files testpo.405 and JPLEPH.405 are not included in + the .tar and.zip files. This environment variable ASTRO_DATA should + point to this directory. + markwardt - Contains the procedures from the Markwardt library which are used + by SOLVE_ASTRO. These are *not* included in the Astron library zip + zip or tar files. + obsolete - repository for procedures removed from the Library because their + use has diminished or their functionality has been replaced by other + procedures. + pro - Contains all the Library procedures as individual ASCII files. + These procedures are placed in subdirectories according to their + category, e.g. pro/fits, pro/sdas, pro/idlphot + old - Contains tar files of frozen versions of the IDL Astronomy Library + compatible with earlier IDL versions + v8 - A beta test directory of procedures using new features in IDL V8 + zdbase - Contains compressed binary tar files of popular astronomical + catalogs formatted as IDL databases. See the file + zdbase/aaareadme.txt for more info. + contrib - contains self-contained IDL astronomy-related packages that + are *not* part of the standard astronomy library distribution. + See contrib/aaareadme.txt for more info. + + + diff --git a/modules/idl_downloads/astro/contents.txt b/modules/idl_downloads/astro/contents.txt new file mode 100644 index 0000000..fe9b640 --- /dev/null +++ b/modules/idl_downloads/astro/contents.txt @@ -0,0 +1,585 @@ + Contents of IDL Astronomy User's Library Mar 2016 + (also see http://idlastro.gsfc.nasa.gov/contents.html) + +Astronomical Utilities in pro/astro +________ +-------- +ADSTRING() - Format RA and DEC as a character string +AIRTOVAC - Convert air wavelengths to vacuum wavelengths +AITOFF - Convert longitude,latitude to X,Y using Aitoff equal-area projection +AITOFF_GRID - Create an overlay grid using the AITOFF projection +ALTAZ2HADEC - Convert Horizon (Alt-Az) coordinates to Hour Angle and Declination +ARCBAR - Draw an arcbar over an image showing the astronomical plate scale +ARROWS - Given a FITS header, display a "weathervane" showing N-E orientation +ASTDISP - Display formatter for pixel + astronomical coordinates +ASTRO - Interactive driver to compute astronomical precession, + or coordinate conversions (calls EULER and PRECESS). +BARYVEL - Compute components of barycentric Earth velocity, given Julian date +BPRECESS - Precess coordinates, proper motion from J2000 to B1950 +CALZ_UNRED - Deredden a galaxy spectrum using the Calzetti et al. (2000) formula +CCM_UNRED - Deredden a spectrum using the Cardelli, Clayton and Mathis (1989) + parameterization. +CO_ABERRATION - Calculate changes to Ra and Dec due to aberration effects +CO_NUTATE - Calculate changes in RA and Dec due to nutation of the Earth's rotation +CO_REFRACT() - Calculate correction to altitude due to atmospheric refraction +COSMO_PARAM - Derive a full set of cosmological parameters given a subset +CT2LST- Convert from civil time to local sidereal time +DATE() - Convert day of year to a DY-MON-CCYY string (FITS standard) +DATE_CONV() - Function to perform various date format conversions +DAYCNV- Convert from Julian Date to calendar date. +DEREDD- Deredden Stromgren indices (called by UVBYBETA) +ECI2GEO() - Convert Earth-centered inertial coordinates to geographic coords +EQ2HOR - Convert celestial (ra-dec) coords to local horizon coords (alt-az). +EQPOLE - Convert longitude,latitude to X,Y using polar equal-area projection +EQPOLE_GRID - Create overlay grid using polar equal-area projection +EULER - Astronomical coordinate system conversions +FLUX2MAG() - Convert from flux units to magnitudes +FM_UNRED - Deredden a spectrum using the Fitzpatrick & Massa (1998) + parameterization. +GAL_UVW - Calculate the Galactic space velocity (U,V,W) of a star +GAL_FLAT() - Correct a galaxy image for inclination effects. +GALAGE - Derive a galaxy age as a function of redshift for a cosmological model +GCIRC - Compute rigorous great circle distance +GEO2ECI() - Convert geographic coordinates to Earth-centered inertial coords +GEO2GEODETIC() - Convert from geographic to geodetic coordinates +GEO2MAG() - Convert from geographic to geomagnetic coordinates +GEODETIC2GEO() - Convert from geodetic to geographic coordinates +GET_COORDS - Read in angular input in decimal or sexigesimal format +GET_DATE - Get the current date in CCYY-MM-DD format (FITS standard) +GET_JULDATE - Get the current Julian date as a double precision scalar +GLACTC- Convert between Galactic (or SuperGalactic) and equatorial coordinates +GLACTC_PM - Convert between celestial and Galactic (or Supergalactic) proper motion +HADEC2ALTAZ - Converts Hour Angle and Declination to Horizon (alt-az) coordinates +HELIO - Compute (low-precision) heliocentric coordinates of the planets +HELIO_JD() - Convert geocentric (reduced) Julian date to heliocentric Julian date +HELIO_RV() - Compute radial velocity given binary star orbit parameters +HOR2EQ - Convert local horizon coords (alt-az) to equatorial (ra-dec). +IMCONTOUR - Contour plots with astronomical labeling (either RA,Dec or + arc distance from the image center +IMF() - Return values for a multi-component power law initial mass function +ISMEUV() - Compute EUV optical depth due to photoionization of HI, HeI and HeII +JDCNV - Convert from calendar date to Julian date. +JPLEPHINTERP - Interpolate position and motion of planetary bodies (JPL Ephemeris) +JPLEPHREAD - Open and read JPL DE200 or DE405 Ephemeride FITS File +JPRECESS - Precess positions & proper motions from B1950 to J2000 +JULDATE-Convert from calendar date to reduced Julian date. +LSF_ROTATE - Create a 1-d convolution kernel to broaden a spectrum from a rotating star +LUMDIST - Return luminosity distance for a given redshift & cosmological model +MAG2GEO() - Convert from geomagnetic to geographic coordinates +MAG2FLUX() - Convert from magnitudes to flux units +MONTH_CNV() Convert a month name to the equivalent number or vice-versa +MOONPOS- Compute the RA and Dec (and distance) of the Moon at a given date +MPHASE - Compute illuminated fraction of the Moon's disk for given Julian dates +NUTATE - Compute the nutation in longitude and latitude for given Julian date(s) +OBSERVATORY - Return coordinates, altitude & time zones of an observatory +PLANCK() - Returns a blackbody flux for a given effective temperature +PLANET_COORDS - Return low-precision RA and Dec of planets give a date(s) +POSANG - Compute the position angle between sources of specified RA and Dec +PRECESS - Precess RA and Dec to a new equinox +PRECESS_CD - Precess the PC (or CD) matrix in a FITS header to a new equinox +PRECESS_XYZ - Precess equatorial geocentric rectangular coordinates +PREMAT() - Returns precession matrix from equinox 1 to equinox 2 +QDCB_GRID - Create overlay grid using COBE quad cube database coordinates +RADEC - Format RA, Dec as Hours,Min,Sec,Deg,Min,Sec +SIXTY - Convert decimal number to sexigesimal +SPHDIST() - Find angular distance on a sphere (in /jhuapl) +SUNPOS - Compute the RA and Dec of the Sun at a given date +TDB2TDT() - Relativistic clock corrections due to Earth motion in solar system +TEN() - Convert sexigesimal number to decimal +TENV() - Like TEN but will work on a vector of sexigesimal numbers. +TICPOS - Specify distance between tic marks for astronomical coordinates +TICLABELS - Create labels for astronomical coordinate tick marks +TICS - Compute the optimum distance between tic marks for astronomical labeling +TIC_ONE - Determine optimum position of the first tic in astronomical labeling +UVBYBETA - Use Stromgren indices to derive dereddened colors, metallicity, + and effective Temperature. +VACTOAIR - Convert vacuum wavelengths to air wavelengths. +XYZ - Compute heliocentric rectangular coordinates at given Julian date. +YMD2DN() - Convert year,month,day to day number of the year (in /jhuapl) +YDN2MD - Convert day number of the year to year, month,day +ZANG() - Compute angular size as a function of redshift in a Friedman cosmology +ZENPOS - Compute the RA and Dec of the local zenith at a given date + +---------------------------------------------------------------------------- +DAOPHOT-Type Photometry Procedures in pro/idlphot (see text/daophot.tex) +________ +-------- +APER - Circular APERture photometry +CNTRD - Obtain the centroid of a star by locating where derivatives go to zero +DAOERF - Calculate the intensity, (and optionally, the derivatives) of + a bivariate Gaussian, integrated over pixels. Called by DAO_VALUE +DAO_VALUE - Obtain the value of a DAOPHOT PSF function at a given set of points +FIND - FIND point sources within an image +GCNTRD - Determine centroid by Gaussian fits to the marginal X,Y distributions +GETPSF - Obtain a PSF (Gaussian + residuals) from isolated stars. +GROUP - Place stars with non-overlapping PSF's in distinct groups +MMM - (Mean, Median, Mode) sophisticated sky background computation +NSTAR - Simultaneous PSF fitting of a group of stars +PIXWT - Compute the area of the intersection of a circle on a rectangle +PKFIT - Fit a Gaussian + residuals to a isolated star (called by GETPSF) +RDPSF - Read a PSF file that was created by GETPSF into an IDL array. +RINTER - Cubic Interpolation at a set of reference points, optionally + obtain derivatives. (in /image) +SKY - Compute image sky level using MMM +SRCOR - Correlate the source positions in two different lists +SUBSTAR- Subtract a scaled PSF at specified star positions +T_APER - Driver procedure for APER with I/O to a disk FITS ASCII table +T_FIND - Driver procedure for FIND with I/O to a disk FITS ASCII table +T_GROUP- Driver procedure for GROUP with I/O to a disk FITS ASCII table +T_GETPSF - Driver procedure for GETPSF with I/O to a disk FITS ASCII table +T_NSTAR - Driver procedure for NSTAR with I/O to a disk FITS ASCII table +T_SUBSTAR - Driver procedure for SUBSTAR with I/O to a disk FITS ASCII table + +----------------------------------------------------------------------- +Database Procedures in pro/database (see text/database.tex) +____________ +------------ +DBBUILD - Load or append a database with new entry values. +DBCIRCLE() - Find entries within a specified circular area. +DBCLOSE - Close a database +DBCOMPARE - Display the values of two database entries side by side +DDBCREATE - Create a new database data, index and/or format file. +DBDELETE - Delete an entry from a database +DBEDIT - Interactively edit the entries in a database +DBEXT - Extract items from a database into IDL variables +DBFIND() - Find entries meeting specified criteria in an IDL database +DBGET() - Use instead of DBFIND when search values are in an IDL vector +DBHELP - List names of databases, or entries within a database +DB_INFO() - Lower level routine to obtain information on an opened database +DBINDEX - Update the IDL database index file. +DB_ITEM_INFO() - Lower level routine to obtain information on specified item(s) +DB_ITEM - Lower level routine to return item number and other information +DBMATCH() - Match database entries one-to-one to specified item values +DBOPEN - Open a IDL database +DBPRINT - Print specified fields about specified entries in an IDL database +DBPUT - Lower level routine to place new value for specified item into an entry +DBRD - Lower level routine to read an entry from a database +DBSORT() - Sort entries in an IDL database +DBTARGET() - Find entries within specified distance of an astronomical target +DBUPDATE - Update an IDL database with new item values. +DB_OR() - Combine two catalog entry lists, removing duplicate values +DBVAL - Lower level routine to extract value of specified item from an entry +DBXVAL - Lower level routine to extract values of specified item from an entry +DBWRT - Lower level routine to update or add a new entry to a database +IMDBASE - Find all catalog sources within the field of an astronomical image +DB_ENT2EXT,DB_ENT2HOST,DBEXT_DBF,DBEXT_IND,DBXPUT,DBFPARSE,DBFIND_ENTRY, +DBFIND_SORT,DBSEARCH,DBTITLE,DB_TITLE() - Lower level database procedures + +---------------------------------------------------------------------------- +Disk I/O (e.g. IRAF files) in pro/disk_io +_________ +--------- +IRAFDIR - Describe IRAF images on specified directory +IRAFRD - Read a disk IRAF image file into IDL variables. +IRAFWRT - Write IDL image and header to an IRAF (.pix & .imh) file +READ_FMR() - Read a journal (ApJ, AJ) machine-readable table into IDL +WFPC2_READ - Read a Wide Field/Planetary Camera 2 (WFPC2) image + +----------------------------------------------------------------------- +FITS Astrometry and Calibration in pro/astrom (see text/astrom.tex) +________ +-------- +ADD_DISTORT - Add SIP distortion parameters into a FITS header +AD2XY - Use astrometry structure to convert celestial to pixel coordinates +ADXY - Use FITS header to convert celestial (RA,Dec) to pixel coordinates +CONS_DEC() - Obtain the X and Y coordinates of a line of constant + declination +CONS_RA() - Obtain the X and Y coordinates of a line of constant right + ascension +EXTAST- EXTract ASTrometry parameters from a FITS header into an IDL structure +FITS_CD_FIX - Update obsolete representations of the CD matrix in a FITS header +GET_EQUINOX() - Return a numeric equinox value from a FITS header +GETROT - GET ROTation and plate scale from a FITS header +GSSS_STDAST - Insert the closest tangent projection astrometry into an STScI + Guidestar Survey Image +GSSSADXY - Convert RA, Dec to pixel coordinates for an STScI survey image +GSSSEXTAST - Extract astrometry parameters from an STScI Survey Image +GSSSXYAD - Convert pixel coordinates to RA, Dec for an STScI survey image +HASTROM - Rotate, Congrid, and/or shift an image until astrometry matches + that in a reference FITS header. Used to align images. +HBOXAVE - Boxaverage an image and update astrometry in a FITS header +HCONGRID - CONGRID an image and update astrometry in a FITS header +HEULER - Convert between Galactic, celestial and ecliptic coordinates in FITS a +header +HEXTRACT - Extract a subimage and update astrometry in a FITS header +HPRECESS - Precess the astrometry in a FITS header to a new equinox. +HREBIN - REBIN an image and update the astrometry in a FITS header +HREVERSE - Reverse an image about either dimension and update astrometry + in a FITS header +HROT - Rotate an image and update astrometry in a FITS header. +HROTATE - Apply IDL ROTATE function and update astrometry in a FITS header +MAKE_ASTR - Build an astrometry structure from input parameter values +PRECESS_CD - Precess coordinate description (CD) matrix in a FITS header + to a new equinox. Called by HPRECESS +PUTAST - Put astrometry parameters (e.g. rotation, plate scale) into a FITS header. +SIP_EVAL() - Compute distorted coordinates given SIP (simple imaging polynomial) +coefficients +SOLVE_ASTRO - Solve for an tangent-plane astrometric plate solution with +optional distortion terms. +STARAST - Obtain an exact astrometry solution given the coordinates and + plate position of 2 or 3 stars. +TNX_EVAL() - Compute distorted coordinates give TNX (IRAF) projection +TPV_EVAL() - Compute distorted coordinates given TPV (Tangent + PV_ polynomial) +coefficients +UPDATE_DISTORT - Update SIP astrometry coefficients for a linear transformation +WCS_CHECK_CTYPE - Check that pair of CTYPE parameters conform to WCS format. +WCS_GETPOLE - Compute the coordinates of the native pole for non-polar projection +WCSSPH2XY - Convert between longitude,latitude to X,Y angular coordinates for + 25 different map projection types +WCSXY2SPH - Inverse of WCSSPH2XY +WCS_DEMO - Demo program for WCSSPH2XY and WCSXY2SPH +WCS_ROTATE - Rotate between standard (e.g. celestial) and native coordinates +XYAD - Use FITS header to convert pixel (X,Y) to celestial(RA, Dec) coordinates +XY2AD - Use astrometry structure to convert pixel to celestial coordinates +XYXY - Convert X,Y values on one image to X,Y values in another image + using astrometry in the FITS headers + +---------------------------------------------------------------------------- +STSDAS Image manipulation in pro/sdas +________ +-------- +EXTGRP - Extract group parameter information out of SXREAD output +ST_DISKREAD - Read an HST FITS file and reconstruct a GEIS (STSDAS) file +SXGINFO - Return info on all group parameters in a FITS header +SXGPAR() - Obtain group parameter values from a FITS header and parameter block +SXGREAD() - Read group parameters from an STSDAS file +SXHCOPY - Copy a selected portion of one header into another +SXHMAKE - Create a basic STSDAS header file from an IDL data array +SXHREAD - Read a STSDAS header from disk +SXHWRITE - Write a STSDAS header to disk +SXMAKE - Make a basic STSDAS header from an IDL array +SXOPEN - Open an STSDAS disk file for subsequent I/O +SXREAD() - Read an STSDAS image from disk +SXWRITE - Write an image to STSDAS format + +---------------------------------------------------------------------------- +FITS ASCII & Binary Table I/O in pro/fits_table ( see text/ft.tex ) +________ +-------- +FTAB_DELROW - Delete specified rows in a FITS table extension +FTAB_EXT - Extract specified columns of a FITS table extension into IDL vectors +FTAB_HELP - Print info about the fields in a FITS table extension +FTAB_PRINT - Print specified columns and rows of a FITS table extension +FTADDCOL - Add a new column to a FITS ASCII table +FTCREATE - Create an empty FITS ASCII table header and data array +FTDELCOL - Delete specified column from a FITS ASCII table data array +FTDELROW - Delete specified row(s) from a FITS ASCII table data array +FTGET() - Extract a specified field from a column in a FITS ASCII table array +FTHELP - Display the fields in a FITS ASCII table header +FTHMOD - Modify the attributes of a field in a FITS ASCII table +FTINFO - Return an informational structure from a FITS ASCII table header +FTKEEPROW - Subscript (and reorder) a FITS ASCII table array +FTPRINT - Print specified columns and rows in a FITS ASCII table array +FTPUT - Update or add data to a field in a FITS ASCII table array +FTSIZE - Return the size and number of fields in a FITS ASCII table array +FTSORT - Sort a FITS ASCII table according to the values in a specified field. +TBDELCOL - Delete specified column from a FITS Binary table array +TBDELROW - Delete specified row(s) from a FITS Binary table array +TBGET() - Extract a specified field from a column in a FITS Binary table +TBHELP - Display the fields in a FITS Binary table header +TBINFO - Return an informational structure from a FITS Binary table header +TBPRINT - Print specified columns and rows in a FITS Binary table array +TBSIZE - Return the size and number of fields in a FITS Binary table array + +------------------------------------------------------------------------- +FITS Binary Table Extensions I/O in pro/fits_bintable +_________ +--------- +FXADDPAR - Add or modify a parameter in a FITS header array. +FXBADDCOL - Adds a column to a binary table extension. +FXBCLOSE - Close a FITS binary table extension opened for read. +FXBCOLNUM() - Returns a binary table column number. +FXBCREATE - Open a new binary table at the end of a FITS file. +FXBDIMEN() - Returns the dimensions for a column in a FITS binary table. +FXBFIND - Find column keywords in a FITS binary table header. +FXBFINDLUN() - Find logical unit number UNIT in FXBINTABLE common block. +FXBFINISH - Close a FITS binary table extension file opened for write. +FXBGROW - Increase the number of rows in a binary table +FXBHEADER() - Returns the header of an open FITS binary table. +FXBHELP - Prints short description of columns in a FITS binary table. +FXBHMAKE - Create basic FITS binary table extension (BINTABLE) header. +FXBINTABLE - Common block FXBINTABLE used by "FXB" routines. +FXBISOPEN() - Returns true if UNIT points to an open FITS binary table. +FXBOPEN - Open FITS binary table extension for read or update +FXBPARSE - Parse the binary table extension header. +FXBREAD - Read a data array from a disk FITS binary table file. +FXBREADM - Read multiple columns/rows from a FITS binary table file. +FXBSTATE() - Returns the state of a FITS binary table. +FXBTDIM() - Parse TDIM-like keywords. +FXBTFORM - Returns information about FITS binary table columns. +FXBWRITE - Write a binary data array to a disk FITS binary table file. +FXBWRITM - Write multiple columns/rows to a FITS binary table file +FXFINDEND - Find the end of a FITS file. +FXHCLEAN - Removes required keywords from FITS header. +FXHMAKE - Create a basic FITS header array. +FXHMODIFY - Modify a FITS header in a file on disk. +FXHREAD - Reads a FITS header from an opened disk file. +FXPAR() - Obtain the value of a parameter in a FITS header. +FXPARPOS() - Finds position to insert record into FITS header. +FXREAD - Read basic FITS files. +FXWRITE - Write a disk FITS file. + +------------------------------------------------------------------------- +FITS I/O in pro/fits +_________ +--------- +CHECK_FITS - Check that array agrees with NAXISi, BITPIX keywords of FITS header +FITSDIR - Display info about primary FITS header(s) on disk +FITSRGB_to_TIFF - Combine separate red, green, blue FITS files into TIFF format +FITS_ADD_CHECKSUM - Add/update the CHECKSUM/DATASUM keywords in a FITS header +FITS_ASCII_ENCODE() - Encode an unsigned longword as an ASCII string +FITS_CLOSE - Close a FITS file defined by a FITS Control Block (see FITS_OPEN) +FITS_HELP - Summarize the primary data units and extensions in a FITS file +FITS_OPEN - Open a FITS file and define a FITS Control Block (FCB) +FITS_READ - Read a FITS file specified by name or FITS Control Block (FCB) +FITS_TEST_CHECKSUM() - Verify the values of the CHECKSUM/DATASUM FITS keywords +FITS_WRITE - Write a FITS primary data unit or extension +FITS_INFO - Display info about disk FITS file(s) at a terminal or in Common +FXMOVE() - Skip a specified number of extensions in a FITS file +FXPOSIT() - Open a FITS file positioned to beginning of a specified extension +HEADFITS() - Read a FITS header from a disk FITS file. +MKHDR - Make a minimal FITS header for an image array. +MODFITS - Modify the header or data in a FITS array (without changing the size) +MRDFITS() - Read FITS file mapping table columns into IDL structure tags +MRD_HREAD - Like FXHREAD but can also read a FITS header from a Unix pipe +MWRFITS - Write a FITS file from a IDL array or structure +RDFITS_STRUCT - Read an entire disk FITS file into an IDL structure +READFITS() - Read a disk FITS file into an IDL data and header array. +SXADDHIST - Add a history record to a FITS header +SXADDPAR - Add or modify a parameter in a FITS header +SXDELPAR - Delete a keyword from a FITS header +SXPAR() - Obtain the value of a keyword in a FITS header +WRITEFITS - Write IDL data and header array to a disk FITS file. + +----------------------------------------------------------------------------- +Image Manipulation in pro/image +_______ +------- +BOXAVE() - Boxave an image, always using at least REAL*4 arithmetic +CONVOLVE() - Convolve an image with a PSF using the product of Fourier Transforms +CORREL_IMAGES() - Correlation of two images. Called by CORREL_OPTIMIZE +CORREL_OPTIMIZE - Compute the optimal pixel offset of one image relative + to another by maximizing the correlation function. +CORRMAT_ANALYZE - Analyze the correlation function made by CORREL_IMAGE +CR_REJECT - General iterative cosmic ray rejection for 2 or more images +DIST_CIRCLE - Create a mask array useful for circular aperture photometry. +DIST_ELLIPSE - Create a mask array useful for elliptical aperture photometry. +FILTER_IMAGE() - Like MEDIAN or SMOOTH but handles edges & allows iteration +FREBIN - Expand or contract an image while conserving flux +IMLIST - Display image pixel values around a specified center +MAX_ENTROPY - Deconvolution by Maximum Entropy, given a PSF +MAX_LIKELIHOOD - Deconvolution by maximum likelihood, given a PSF +MEDARR - Median filter across a set of images (e.g. for cosmic ray removal) +POSITIVITY() - Map an image uniquely and smoothly into all positive values +PSF_GAUSSIAN() - Create a 1-d, 2-d, or 3-d Gaussian with specified FWHM, center +SIGMA_FILTER() - Replaces pixels deviant by more than a specified sigma from + its neighbors. Useful for cosmic ray removal. +SKYADJ_CUBE - Remove the sky level from individual images of a data cube +XMEDSKY - Compute the median sky as a 1-d function of X (for slitless spectra) + +---------------------------------------------------------------------------- +Math and Statistics in pro/math +_________ +--------- +ASINH() - Return the inverse hyperbolic sine of its argument +AVG() - Return the average value of an array or 1 dimension of an array. +CIC - Cloud In Cell interpolation of irregularly gridded data +CSPLINE() - Interpolate using the Numerical Recipes natural cubic spline +FACTOR - Find the prime factors of a given number (in /jhuapl) +FITEXY - Best straight-line fit to data with errors in both coordinates +FLEGENDRE() - Compute the first M terms in a Legendre polynomial expansion +GAUSSIAN() - Evaluate a 1-d Gaussian and optionally its derivative +HERMITE() - Interpolate a tabulated function using a Hermite spline +KSONE - Compute the one-sided Kolmogorov-Smirnov statistic +KSTWO - Compute the two-sided Kolmogorov-Smirnov statistic +KUIPERONE - Compute the one-sided Kuiper statistic (NR) +KUIPERTWO - Compute the two-sided Kuiper statistic (NR) +LINMIX_ERR - Bayesian approach to linear regression with errors in both X and Y +LINTERP - Linearly interpolate X,Y vectors onto a new X grid +MEANCLIP - Compute an iteratively sigma-clipped mean on a data set +MLINMIX_ERR : Bayesian approach to linear regression with errors in both X and Y and multiple independent variables. +MINF_BRACKET - Find 3 points which bracket the minimum of a function +MINF_CONJ_GRAD - Find local minimum of a scalar valued function of several + variables using conjugate gradient method +MINF_PARABOLIC - Minimize a function using Brent's method with parabolic interpolation +MINF_PARABOL_D - Minimize a function using Brent's method with derivatives +MLINMIX_ERR : Bayesian approach to linear regression with errors in both X and Y and multiple independent variables. +MRANDOMN : Generate random vectors from a multivariate normal density. +MULTINOM - Simulate multinomial random variables +NGP - Nearest Grid Point interpolation of irregularly gridded data +PCA - Perform a principal component analysis (Karhunen-Loeve expansion) +PENT() - Return the information entropy S of time-series data for a set of trial periods +PERMUTE() - Rearrange the elements of an array in random order +POIDEV() - Generate a Poisson random deviate +POLINT - Polynomial interpolation of an (X,Y) pair +POLYLEG() - Evaluate a Legendre polynomial with specified coefficients +POLY_SMOOTH() - Apply a least-squares (Savitzky-Golay) polynomial smoothing filter +PRIME - Return the first N primes (in /jhuapl) +PROB_KS - Return the significance of a Kolmogorov-Smirnov statistic +PROB_KUIPER - Return the significance of the Kuiper statistic +QSIMP - Integrate using Simpson's rule to specified accuracy +QTRAP - Integrate using trapezoidal rule to specified accuracy. +QUADTERP - Quadratic interpolation of X,Y vectors onto a new X grid +RANDOMCHI - Generate chi-square distributed random variables +RANDOMDIR - Generate Dirichlet-distributed random variables +RANDOMGAM - Generate random numbers from a gamma distribution. +RANDOMP - Create a vector of random numbers distributed as a power-law +RANDOMWISH - Draw random matrices from a Wishart distribution +SAFE_CORRELATE() - compute the probability that data is uncorrelated + while accounting for data uncertainties +SIXLIN - Compute linear regression by 6 different methods. +SPLINE_SMOOTH - Compute cubic smoothing spline to (weighted) data +TABINV - Find the effective index of a function value. +TRANSFORM_COEFF - Compute new polynomial coefficients under a linear transformation +TRAPZD - Compute Nth iteration of trapezoidal rule. Called by QSIMP, QTRAP +TSC - Triangular Shaped Cloud interpolation of irregularly gridded data onto a regular grid +TSUM() - Trapezoidal integration of the area under a curve +ZBRENT() - Find the root of a function known to lie between specified limits + +---------------------------------------------------------------------------- +Plotting Procedures in pro/plot +------------ +------------ +CLEANPLOT - Reset all plotting system variables to their default (X) values +AL_LEGEND - Create an annotation legend for a plot +AL_LEGENDTEST - Demo program demonstrating the capabilities of AL_LEGEND +LINEID_PLOT - Annotate the identified lines in a spectrum +MULTIPLOT - Create multiple plots with shared axes +OPLOTERROR - Overplot Y vs. X with optional X and Y error bars +PARTVELVEC - Plot the velocity vectors of a set of particles +PLOTERROR - Plot Y vs. X with optional X and Y error bars +PLOTHIST - Plot the histogram of an array +PLOTSYM - Define useful plotting symbols not in the standard PSYM definition +RDPLOT - Like intrinsic CURSOR procedure but with a full-screen cursor +SUNSYMBOL() - Return the character string to plot a subscripted Sun symbol +VSYM - Create "Mongo"-like plotting symbols, rotationally symmetric polygons + +---------------------------------------------------------------------------- +Robust Statistics procedures in pro/robust +___________ +----------- +AUTOHIST - Draw a histogram using automatic bin-sizing. +BIWEIGHT_MEAN() - Iterative biweighted determination of mean and standard deviation +HISTOGAUSS - Outlier-resistant autoscaled histogram drawing +MEDSMOOTH() - Median smoothing including the points at the ends +RESISTANT_MEAN - Outlier-resistant determination of mean and std. deviation. +ROB_CHECKFIT() - Utility to determine quality of a fit and return biweights +ROBUST_LINEFIT() - Robust fit of Y vs X (or bisector of Y vs X and X vs Y) +ROBUST_POLY_FIT() - Robust polynomial fit +ROBUST_SIGMA() - Robust analog of the standard deviation +---------------------------------------------------------------------------- +IDL Structure procedures in pro/structure +___________ +----------- +COMPARE_STRUCT() - Compare all matching Tag names and return differences +COPY_STRUCT - Copy Fields with matching Tag names from one structure to another +CREATE_STRUCT - Create an IDL structure from a list of tag types and dimensions +MRD_STRUCT() - Like CREATE_STRUCT but tag values can be specified in a string +PRINT_STRUCT - Print specified tags from structure (to LUN if given) +TAG_EXIST() - Determine if a tag exists in a given structure +WHERE_TAG() - Like WHERE but works on a structure tag names + +---------------------------------------------------------------------------- +Web Socket Procedures in pro/sockets +___________ +----------- +WEBGET() - Use the IDL SOCKET procedure to get data from http servers +QUERYGSC() - Query the Guide Star Catalog (GSC V2.3.2) at STScI by position +QUERYDSS - Query the digital sky survey (DSS) online at the ESO or STSCI servers +QUERYSIMBAD - Query the SIMBAD or NED name resolver to obtain J2000 coordinates +QUERYVIZIER() - Positional query of any catalog in the VIZIER database. +QUERY_IRSA_CAT - queries IRSA catalogs, returning an IDL structure +READ_IPAC_TABLE - reads an IPAC Table file into an IDL structure +READ_IPAC_VAR - converts an internal variable to an IDL structure +WRITE_IPAC_TABLE - writes an IDL structure to an IPAC Table file +---------------------------------------------------------------------------- +TV Display Procedures in pro/tv +___________ +----------- +BLINK - Blink two or more windows in an image display +CURS - Change the shape of the (X windows only) cursor +CURVAL - Interactive display of image intensities and astronomical coordinates +PIXCOLOR - Set specified pixel values to a specified color +SIGRANGE() - Find range of pixel values which contain 90% of the image values +TVBOX - Draw a box of specified size on the image display +TVCIRCLE - Draw a circle of specified radius on the image display +TVELLIPSE - Draw an ellipse of specified axes on the image display +TVLASER - Write an image to postscript file with annotation from a FITS header +TVLIST - Display intensity values surrounding the cursor position +UNZOOM_XY - Convert from window coordinates to image coordinates +ZOOM_XY - Convert from image coordinates to window coordinates + +----------------------------------------------------------------------------- +Miscellaneous (Non-Astronomy) Procedures in pro/misc +________ +-------- +ASTROLIB - Add the non-standard system variables used in the IDL Astronomy User's Library +BLKSHIFT - Shift a block of data to a new (possibly overlapping) position in a + file +BOOST_ARRAY - Append one array onto another, adjusting dimensions if necessary +BREAK_PATH() - break up a !PATH-like string into individual directories +BSORT() - Like the IDL SORT function but subscript order is maintained when + value are equal -- like a bubble sort. +CHECKSUM32 - Compute the 32bit checksum of an array (ones-complement arithmetic) +CIRRANGE - Force an angle to be in the range 0 to 360 (or 0 to 2*!PI). +CONCAT_DIR - concatenate directory and file name for current OS +DELVARX - Delete an IDL variable; like DELVAR but works at any calling level +DETABIFY() - Replace tabs in a character string by equivalent number of spaces +EXPAND_TILDE() - Expand tilde in UNIX directory names +F_FORMAT() - Find the "best" F format to display an array of REAL*4 numbers. +FDECOMP - Decompose a file name (Disk + Directory + Name + Extension + Version) +FILE_LAUNCH - Launch a file using default application of the operating system +FINDPRO - Find all occurrences of a procedure in one's !PATH +FIND_ALL_DIR - Find all directories under a specified directory +FIND_WITH_DEF - Search for files with default path and extension +FORPRINT -Print a set of vectors by looping over each index value +GET_PIPE_FILESIZE - Determine the number of bytes in a unit opened as a pipe with SPAWN +GETOPT() - Parse a user supplied string into numeric value(s). +GETPRO - Search !PATH directory for a procedure and copy into user's directory +GETTOK() - Extract a string up to a specified character. +GETWRD() - Get specified item (word) from a string (in /jhuapl) +HGREP - Find a substring in a FITS header or other string array +HOST_TO_IEEE - Convert IDL variable from host machine bit order to IEEE +HPRINT - Pretty terminal display of a FITS header (or other string array) +IEEE_TO_HOST - Convert IDL variable from IEEE bit order to host machine +ISARRAY() - Determine if an IDL variable is an array (in /jhuapl) +IS_IEEE_BIG() - Determine if the host machine is IEEE big endian +LIST_WITH_PATH() - Search for files within specified directory path +MAKE_2D - Change from 1-D indexing to 2-D indexing +MATCH - Find the subscripts where the values of two vectors match. +MATCH2 - Find the matches for each element of two arrays. +MRD_SKIP - Skip a number of bytes from current location in a file or a Unix pipe +MINMAX() - Return the min and max of an array in an 2 element vector +N_BYTES() - Return the number of bytes in an IDL variable +NINT() - Like intrinsic ROUND() function but returns integer instead of long +NULLTRIM() -Delete all characters after, and including, the the first null + byte(0). Called by TAB_PUT. +ONE_ARROW - Draw an arrow labeled with a single character +ONE_RAY - Draw a ray by specifying starting point, angle, and length +ORDINAL() - Return the English equivalent of ordinal numbers, i.e. '1st','2nd' +POLREC - Convert from polar to rectangular coordinates (in /jhuapl) +QGET_STRING() - Read a string (eg. password) from the keyboard without echoing it +RDFLOAT - Quickly read an ASCII file with columns of data into IDL vectors +READCOL - Read a file of free-format ASCII columns into IDL vectors +READFMT - Quickly read a file of fixed-format ASCII columns into IDL vectors +READ_KEY() - Like GET_KBRD but returns a code for escape sequences. +RECPOL - Convert from rectangular to polar coordinates (in /jhuapl) +REMCHAR - Remove all appearances of a character from a string. +REM_DUP() - Remove duplicate values from a vector. +REMOVE - Contract a vector or up to 8 vectors by removing specified elements +REPCHR() - Replace all occurrences of one character by another (in /jhuapl) +REPSTR() - Replace all occurrences of one substring in a string by another. +SELECT_W - Allow user to interactively select from a list of strings +SPEC_DIR() - Complete specification of a file name using default disk & directory +STORE_ARRAY - Insert one array into another, adjusting dimensions if necessary +STRCOMPRESS2() - Remove blanks around specified spaces in a string +STRN() - Convert a number to a string and remove padded blanks. +STRNUMBER()- Determine whether a string is a valid numeric value. +TEXTOPEN - Open a file for text output as specified by TEXTOUT keyword +TEXTCLOSE - Close a file that had been opened by TEXTOPEN. +TO_HEX() - Translate a decimal integer to a hex string. +VALID_NUM() - Determine if a string is a valid number (cf. STRNUMBER) +VECT() - Display a set of numbers to a string with delimiters +WHERENAN() - Find points equal to big-endian IEEE NaN (not a number) values +XDISPSTR - Widget display of a string array with a simple search facility +ZPARCHECK - Check the type and size of a parameter diff --git a/modules/idl_downloads/astro/news.txt b/modules/idl_downloads/astro/news.txt new file mode 100644 index 0000000..f39c7b8 --- /dev/null +++ b/modules/idl_downloads/astro/news.txt @@ -0,0 +1,1541 @@ + +19-Apr-2016: PLOTHIST - Make /NaN,/AUTOBIN and BOXPLOT the default + +11-Apr-2016: WRITEFITS - Added /SILENT keyword + +30-Mar-2016: F_FORMAT() - fix problem with display of large negative numbers + +23-Mar-2016: FILE_LAUNCH - Launch a file using default application of the operating system + +10-Mar-2016: TPV_EVAL - Fixed bug in 4th order term, added 5th, 6th and 7th order terms + +01-Mar-2016: APER - Avoid integer overflow for very large images + +24-Feb-2016: MWRFITS - Abort if a structure with more than 999 tags supplied + +08-Feb-2016: MODFITS - Make it optional to supply FITS header, as advertised + +21-Jan-2016: WCSSPH2XY - long and lat must have same number of elements, but not necessarily dimensions + +11-Dec-2015: MMM - Always return floating point sky mode + +03-Dec-2015: PUTAST - RADECSYS was misspelled, also fix possible clash between + TPV distortion and use of LONGPOLE/LATPOLE + +24-Nov-2015: HREBIN - Now has /TOTAL keyword to preserve total counts or surface + flux (e.g. counts/(arc sec)^2) + +9-Oct-2015: READCOL - Assume file is compressed if its name ends in '.gz' + +30-Sep-2015: SXPAR(), SXADDPAR - Now work with null values in a FITS header + +22-Sep-2015: FXPAR(), FXADDPAR - Now work with null values in a FITS header + +18-Sep-2015: QUERYGSC - Updated for new server format + FTDELCOL - Columns can now be specified by number as advertised + +12-Sep-2015: EXTAST - Make sure CROTA defined for GLS projection + +10-Sep-2015: HEXTRACT - Fix problem with GLS projection + REPSTR() - Use CALL_METHOD() so that it compiles in IDL 7.1 and earlier + DIST_ELLIPSE - Make POS_ANG optional as documented + +06-Aug-2015: SXPAR() - 72 character fields were being trimmed to 71 characters + +28-Jul-2015: MWRFITS - Fixed bug when checking logical columns that include nulls + GLACTC_PM - Fixed occasional bug when computing sign of proper motion + +14-May-2015: SXPAR() - Now has IFound output keyword to report matching + indices when using a keyword* name input + +27-Apr-2015: AD2XY, XY2AD - no longer check that CDELT[0] differs from 1 + +25-Mar-2015: FITS_INFO - Use 64 bit long to deal with huge FITS files + +06-Feb-2015: SXPAR() - Return logicals as IDL boolean in V8.4 or later + +05-Feb-2015: DBFPARSE - Allow parenthesis within string searches. + +29-Jan-2015: DBSEARCH - Nov 2014 fix for "less than" string values was spurious, reverting + + REPSTR() - Use .REPLACE() method for IDL 8.4 or later + +19-Jan-2015: DBCREATE- Default maximum # of items is now 1000 rather than 200 + +23-Dec-2014: FXHMODIFY - Only issue a warning if keyword EXTEND is missing + +04-Dec-2014: RESISTANT_MEAN - Fix problem with use of DIMENSION keyword with +non-square arrays + +10-Nov-2014: FITS_OPEN - Allow compressed file names to include spaces + +02-Nov-2014: DBSEARCH - Fix problem with string "less than" searches + +01-Nov-2014: SXPAR() - Use cgErrorMsg rather than On_error,2 + +26-Nov-2014: QUERYVIZIER - Add /CFA keyword, remove /CADC keyword + +20-Oct-2014: MATCH2 - Fix occasional problem with strings with numerical content + +14-Oct-2014: MWRFITS - Avoid LONG overflow for very large files + +26-Sep-2014: FXREAD - Fix bug in handling of BSCALE keyword + +3-Sep-2014: HEULER - Now work for GLS projection + PUTAST - PV1_3, PV1_4 keywords take precedence over LONPOLE, + LATPOLE coordinates + +25-Aug-2014: STRN() - Fix truncation problem when used with vector input + +9-Aug-2014: HPRECESS - Now works for GLS projection + + 29-Jul-2014: MODFITS - A scalar in the header field means no header + PLOTHIST - Fix /FILL to work when axes are inverted + + 21-Jul-2014: SAFE_CORRELATE() - compute the probability that data is uncorrelated + while accounting for data uncertainties + +14-Jul-2014: XY2AD - Faster evalution of SIP polynomial + +9-Jul-2014: CONVOLVE() - Fix bug where output is double precision even for + float input + +14-Jun-2014: EQ2HOR - Fix case of scalar position but vector JD + +3-Jun-2014: TSUM() - Added /NaN keyword + +30-May-2014: EXTAST - Fixed bug introduced Jan 2014 where SIP parameters were + not recognized when NAXIS = 0 + +07-May-2014: FITS_READ - Fix bug when using /DATA_ONLY + +05-May-2014: FITS_OPEN - can now read Unix compressed (.Z) FITS files + FITS_READ - close unit when reading .fz or .Z compressed files + SXADDPAR - Don't allow NaN values to be written to FITS header + +25-Apr-2014: MRDFITS(), FITS_OPEN - Use LONG64 for very large tables + +24-Apr-2014: SXPAR(), FXPAR() - Don't convert LONG64 values to double precision + +24-Apr-2014: TBGET() - Use V6.0 notation + TBINFO - Use long64 for .numval for very large tables + +23-Apr-2014: MWRFITS - Added /No_Copy keyword, fix problem with 32 bit overflow + +18-Apr-2014: GSSSADXY - No longer call DELVARX which apparently can be slow + QUERYGSC() - Update for new server format. The names and number + of structure tags has now changed. + +7-Apr-2014: SOLVE_ASTRO - Solve for an tangent-plane astrometric plate solution with +optional distortion terms. Requires MPFIT, MPFIT2dFUN from the Markwardt Library + + New /markwardt directory contains procedures from the Markwardt + library used in the Astron Library + +7-Apr-2014: MRDFITS() - Work with LONG64 variable length binary tables + +18-Mar-2014: MRDFITS() - Suppress "zero length" message when /SILENT is set + +13-Mar-2014: STRN() - Now accepts vector input + +12-Mar-2014: TNX_EVAL() - Evaluate distortion correction given IRAF TNX +coefficients (polynomial only) + + AD2XY, ADD_DISTORT, EXTAST, PUTAST, XY2AD - now support IRAF TNX + projection (polynomial only -- not yet Chebyshev or Legendre). + +5-Mar-2014: TPV_EVAL() - Correct several typos for 4th order terms + +26-Feb-2014: FITSDIR - Don't let a corrupted file cause an abort + +26-Feb-2014: QUERYVIZIER - Updated for new http: syntax if /CANADA is set + FITSRGB_TO_TIFF - use 24bit display when /Visualize is set + +25-Feb-2014: HASTROM - Now has a /SILENT keyword + +05-Feb-2014: MULTIPLOT - Now handles [!X/Y.OMargin] + +25-Jan-2014: Removed spurious versions of EXTAST, XY2AD, and SIP_EVAL which + had been duplicated in the /fits directory. + +24-Jan-2014: FM_UNRED - Fix computation of output keyword EXTCURVE + +10-Jan-2014: QuerySimbad- Now has optional keywords to get magnitude and +parallax. + +9-Jan-2014: WCS_CHECK_CTYPE - Now recognize when "RA" and "DEC" CTYPE values +are flipped. + +3-Jan-2013: AD2XY, XY2AD, EXTAST, TPV_EVAL() - Now support the TPV model of + distortion (used by the SCAMP software) + +14-Dec-2013: AD2XY, EXTAST, SIP_EVAL() - support reverse SIP distortion + calculation when only forward coefficients supplied + WCSXY2SPH - Return scalar output for scalar input for ZPN + projection + WCSSPH2XY - Polar offset correctly done in radians + +13-Dec-2013: WCS_ROTATE - Avoid roundoff error when longitude = +/- 180 + +1-Dec-2013: EXTAST - Add warning if astrometry includes SCAMP distortions + (These are not yet evaluated but will be in the future). + +05-Nov-2013:MRANDOMN - Use LA_CHOLDC instead of CHOLDC to enable use of STATUS keyword + + SELECT_W - Add kluge for Unix systems when Y_SCROLL_SIZE is set. + +29-Oct-2013: DBCREATE - .db files no longer need be in current directory + +27-Sep-2013: New procedures to query IRSA catalogs and tables + QUERY_IRSA_CAT - queries IRSA catalogs, returning an IDL structure + READ_IPAC_TABLE - reads an IPAC Table file into an IDL structure + READ_IPAC_VAR - converts an internal variable to an IDL structure + WRITE_IPAC_TABLE - writes an IDL structure to an IPAC Table file + +21-Sep-2013: EXTAST - Fix for converting GLS projection to SLS + +19-Sep-2013: MRD_STRUCT - Fix typo when creating LONG64 arrays with + /No_Execute + +17-Sep-2013: XDISPSTR - Now has POS keyword to specify where to display the + widget on the screen. + +31-Aug-2013: DBSEARCH - Put in a strtrim() prior to sorting + SELECT_W - Fix SELECTIN keyword problem introduced 20-Aug + +28-Aug-2013: AD2XY, PUTAST - Fix bugs introduced 30-Jul-2013 + + Library now assumes IDL V6.4 or later. Look at /old + for older versions + +23-Aug-2013: READFITS() - Fix bug when skipping extensions with > 2GB + +20-Aug-2013: APER - Don't ever modify input SKYRAD parameter + + SELECT_W - Use CW_BGROUP instead of obsolete XMENU, implement + comments parameter as ToolTips + DBOPEN - Use tooltips when called without any parameters + +13-Aug-2013: AD2XY - Don't modify shape of input arrays + +7-Aug-2013: UNZOOM_XY - Fix algorithm for non-zero zoom values + +30-Jul-2013: Major upgrade to world coordinate procedures including adding + HealPix "butterfly" (XPH) projection, using the "Version 2" + astrometry structure with 11 new tags, and stricter adherence to + the WCS standard + + AD2XY, ADXY, EXTAST, MAKE_AST, PUTAST, WCS_GETPOLE, + WCS_ROTATE, WCSSPH2XY, WCSXY2SPH, XY2AD, XYAD + + WCS_CHECK_CTYPE - Check that pair of CTYPE parameters conform to + WCS format. + +18-Jul-2013: DATE_CONV() = Now has a /BAD_DATE output keyword + + XDISPSTR - Made widget resizeable + +17-Jul-2013: EXTAST - Major rewrite to add AXES, REVERSE, COORD_SYS, + PROJECTION,, RADECSYS, EQUINOX, DATEOBS, MJDOBS, PV1, + and X0Y0 tags to the structure. + + SKY - Fixed occasional out of bounds problem when /NAN set. + +10-Jul-2013: WRITEFITS - 28 June bug fix introduced error when CHECKSUM is set + and NAXIS = 0 + +01-Jul-2013: SELECT_W - Added Columns, y_scroll_size keyword inputs, + +28-Jun-2013: WRITEFITS - Fixed bug when using /CHECKSUM with unsigned integers + +11-Jun-2013: RDPLOT - Added /CURSOR_STANDARD keyword, fix occasional crashes + +23-May-2013: EQ2HOR - Fix problem with scalar JD and vector RA,Dec + +22-May-2013: CO_NUTATE, CO_ABERRATION - Fix problems when JD is a 1-element + vector and RA,Dec have 2 or more values + +17-May-2013: WCSSPH2XY, WCSXY2SPH -- Allow GPL as a synonym for SFL projection + +1-May-2013: Text file idl_stsdas.tex moved to /obsolete since the Library + no longer supports STSDAS tables. + +19-Apr-2013: RESISTANT_MEAN - Allow a row/column to be all NaN values + +10-Apr-2013: RESISTANT_MEAN - fix problem when NaN values present + PLOTHIST - Fix problems when /XLOG is set + +1-Apr-2013: EXTAST - Work with PARITEL headers with extra quotes + +26-Mar-2013: PARTVELVEC - Now work NaN values in input array. + +8-Mar-2013: MRDFITS() - Fix problem when ther FITS columns differ only in having + a different case. + +6-Mar-2013: AL_LEGEND - Can now use embedded symbols in items string array + +26-Feb-2013: WEBGET() -- Allow http_proxy to be upper or lower case + +21-Feb-2013: MRDFITS() - Fix problem introduced Nov 2010 when using /FSCALE + +15-Feb-2013: SUNSYMBOL() - Use DejaVuSans true-type font for V8.2 or later + +14-Feb-2013; OPLOTERROR - Work with a Coyote resizeable window + +30-Jan-2013: ARCBAR - Fix problem when using /DATA coordinates and not in + postscript. + +28-Jan-2013: PUTAST - Spurious error message introduced April 2012 when CD + matrix supplied. + +15-Jan-2013: Coyote library procedures are no longer included in the Astron + library .tar or .zip files and must be downloaded separately from + http://www.idlcoyote.com/documents/programs.php. Alternatively, + one can download coyote_astron.tar.gz which contains a subset of + the Coyote library routines needed by the Astronomy library. + +11-Jan-2013: FITS_INFO - Fill EXTNAME even when /SILENT is set + +3-Jan-2013: DBCIRCLE() - Fix occasional problem when crossing 0h + +13-Dec-2012: AL_LEGEND - Fixed bug when linsize, /right called simultaneously + +29-Nov-2012: RHOTHETA() - Calculate separation and position angle of a binary star + given its orbital elements + +26-Nov-2012: AL_LEGENDTEST - Renamed from LEGENDTEST + +02-Nov-2012: PUTAST - Don't warn about missing reverse SIP coefficients when + forward transformation has order 0 + +01-Nov-2012: READFITS() - Fixed check that header begins with 'SIMPLE' + + Removed legend.pro because its name conflicts with IDL 8.0 + intrinsic function. Use AL_LEGEND instead. + +25-Oct-2012: OPLOTERROR - Fixed problem when overplotting a single point. + +24-Oct-2012: DBCREATE - Fix occasional problem where item descriptions overlap. + +22-Oct-2012: HCONGRID, HREBIN - Allow new CRPIX* values to be double precision + +17-Oct-2012: TICLABELS - Bug fixed where degrees (not just hours) would be + forced to be between 0 and 24. + +12-Oct-2012: MWRFITS - Bug fixed to set location of column header comments. + SXADDHIST - Bug fix when finding location to insert a comment + + **Procedures in /sdas_table have been moved to the /obsolete + directory http://idlastro.gsfc.nasa.gov/ftp/obsolete/ ** + +10-Oct-2012: MRDFITS() - Better error checking for FPack compressed files + +02-Oct-2012: FITS_OPEN - work with gzip'ed files even if gzip is not available + +21-Sep-2012: FITS_INFO - Increase maximum number of file extensions from 400 to +2000. + +05-Sep-2012: ADSTRING() - can now convert longitudes >99.99 to sexagesimal + +24-Aug-2012: EQ2HOR - use STRICT_EXTRA to flag spurious keywords + CO_ABERRAtION - fixed case both the Julian Date and RA,Dec are + vectors + +09-Aug-2012: MWRFITS - Better documentation, error checking for logical columns + +07-Aug-2012: AL_LEGEND - A symbol can now be specified by its cgSYMBOL name + +30-Jul-2012: PERMUTE() - Moved from /contrib to the main library + +19-Jul-2012: WRITEFITS - Now writes a dummy primary header if user supplies + an extension table header. + +16-Jul-2012: RESISTANT_MEAN - Use of Dimension keyword yielded transpose of + correct value. + + READCOL- Correctly handle blanks without a conversion error + +20-Jun-2012: QUERYVIZIER() - Better handling of case when more than one catalog returned + +29-May-2012: WCSSPH2XY, WCSXY2SPH -- Added HealCart projection + +25-May-2012: EXTAST - Recognize obsolete keywords PC001002, CD001002 + HISTOGAUSS - Better formatting of text output + +03-May-2012:MRD_STRUCT - Added more capabilities in /No_execute mode + +02-May-2012: HELIO_RV() - Change convergence test from relative to absolute + precision on E + +30-Apr-2012: SXPAR(), FXPAR() - Fixed problem extracting keywordN when N=0 + +17-Apr-2012: FXBREADM, FXBWRITM - Now use long64 to support files > 2GB + +12-Apr-2012: TVBOX - Added /SQUARE keyword to keep box square even when + X and Y plotting scales differ. + +04-Apr-2012: PUTAST - Now adds SIP distortion parameters if present + +25-Mar-2012: TVELLIPSE - Now has /FILL keyword to draw filled ellipses + +21-Mar-2012: MULTIPLOT - Default to use a white background color + +20-Mar-2012: TVCIRCLE, TVELLIPSE, TVBOX - Added /DEVICE keyword, fix 04-Jan-2012 + change. + +07-Mar-2012: TICLABELS - Fix problem when a label falls at exactly 0 degrees + +07-Feb-2012: MODFITS - now works with a 1 element structure + +01-Feb-2012: AL_LEGEND - Fix problems with use with a CG window, and + setting a background color + +31-Jan-2012: DELVARX - No longer uses EXECUTE, always frees memory + +12-Jan-2012: MRD_HREAD - Now has a /NO_BADHEADER keyword to abort if any bad + characters are found in the FITS header. + +05-Jan-2012: PLOTERROR, OPLOTERROR - Speed improvement by calling PLOTS + rather than CGPLOTS internally. + + FITS_HELP - Use V6.0 notation + +04-Jan-2012: TVCIRCLE, TVBOX, TVELLIPSE - Default to data coordinates if + !X.CRANGE is set (i.e. plot system defined) + WEBGET() - Timeout now defaults to 15 seconds and applies to both + reading and connecting from the socket + REM_DUP() - Call BSORT() to ensure original order maintained for + equal values + +03-Jan-2012: TABINV - Faster test for monotonicity, allow double precision + output + +02-Jan-2012: ZBRENT - Can now pass parameters to user function via _EXTRA + +20-Dec-2011: DBPRINT - Fix problem when displaying linked databases + +15-Dec-2011: WEBGET() - Work for web sites with out a MIME type + +14-Dec-2011: AL_LEGEND - Removed call to SYMCAT to avoid symbol problems + +10-Dec-2011: LINMIX_ERR - Fix bug when updating MU with Metropolis-Hastings + +08-Dec-2011: MMM, APER -- Now have a MINSKY keyword + PLOTHIST - Plot Keywords now work properly with /ROTATE + +03-Dec-2011: AL_LEGEND - Fixed typo that kept BTHICK keyword from working + +25-Nov-2011: EXTAST - Give warning if reverse SIP coefficients not supplied + +23-Nov-2011: GLACTC_PM - Correct occasional sign error in galactic longitude + +02-Oct-2011: QUERYSIMBAD - Display coordinates if /PRINT set, or only + one parameter supplied. + +22-Sep-2011: GET_EQUINOX - Added ALT keyword, support RADESYS keyword + +15-Sep-2011: DBOPEN, DB_ENT2EXT, DB_ENT2HOST - Fix Nov 2010 bug that affects + external databases + +25-Aug-2011: GETROT - Fix problem when X and Y rotations have opposite signs + STARAST - Check for singular matrix (collinear star positions) + +19-Aug-2011: PUTAST - Don't add PV2 value to FITS header for WCS types (e.g. + 'TAN') for which it is not defined, added PLTSCL, ROTAT + keywords + + PIXCOLOR - Can specify Coyote graphics colors + +07-Aug-2011: MAKE_ASTR - Fixed bug introduced October 2010 for setting default + plate scale. Affected use of STARAST. + +04-Aug-2011: PLOTHIST - Explictly set XSTYLE,YSTYLE to avoid confusion when + _EXTRA keywords are used by both PLOTS and PLOT. + +20-Jul-2011: LEGEND - Replace SIZE with CHARSIZE keyword in calls to XYOUTS + for GDL compatibility + +9-Jul-2011: TVBOX - Now has /FILL keyword + +25-Jun-2011: AL_LEGEND - Erroneous call to CGQUERY instead of CGCONTROL + +01-Jun-2011: HROTATE - Work even if no astrometry present, just update NAXIS* + +31-May-2011: SXADDPAR - Fix problem saving comment when slashes present + +16-May-2011: AL_LEGEND - Fixed problem when using resizable graphics window + +09-May-2011: AL_LEGEND - Added LINSIZE keyword to control size of line + +02-May-2011: MODFITS - Don't try to update CHECKSUM keywords when a structure + supplied + MRDFITS - Use better defaults for null values for FITS ASCII tables + +23-Apr-2011: FORPRINT - Comments can now be a vector (one per line) + +17-Apr-2011: HELIO_RV() - Allow any consistent time system, not just HJD + +07-Apr-2011: QUERYVIZIER()- Ignore vector tags, (such as SEDs recently added + to the 2Mass catalog) + +06-Apr-2011: OPLOTERROR - "Hats" were not being plotted + +05-Apr-2011: FILTER_IMAGE() - Keep double precision datatype if using /ALL_PIXELS + +28-Mar-2011: MRDFITS() - Fix bug with ROWS keyword introduced Nov 2010 + +17-mar-2011 AIRTOVAC - now iterates for even better precision + +14-Mar-2011: AIRTOVAC, VACTOAIR - Use more accurate formula, added optional + output keyword + +13-Mar-2011: SRCOR - Fixed problem when sources separated by more than 180 + degrees and no critical radius set. + +07-Mar-2011: GETTOK() - Added /NOTRIM to leave input string unaltered + +28-Feb-2011: HEADFITS(), MODFITS, WRITEFITS, CHECK_FITS, FITSDIR - Use V6.0 + notation + +25-Feb-2011: KSONE, KUIPERONE, KUIPERTWO, AUTOHIST, HISTOGAUSS - now use + Coyote Graphics + +16-Feb-2011: + The following 16 procedures now use the Coyote Graphics library + (http://www.idlcoyote.com/graphics_tips/coyote_graphics.html ) -- + AL_LEGEND,ARCBAR, ARROWS, + IMCONTOUR,LEGEND_TEST, LINEID_PLOT, MULTIPLOT, ONE_ARROW, + ONE_RAY, OPLOTERRROR, PARTVELVEC, PLOTERROR, PLOTHIST, TVBOX, + TVELLIPSE, TVCIRCLE + + AL_LEGEND - Added BACKGROUND_COLOR keyword + +14-Feb-2011: READCOL - Added COMPRESS keyword to read gzip'ed text files + +10-Feb-2011: DB_ITEM - Ignore any blank lines in the .items file + REMOVE - Fix occasional integer overflow problem + +02-Feb-2011: READFITS() - First header not necessarily primary header if unit + rather than filename supplied + +24-Jan-2010: READCOL - Now accepts full FORTRAN format values (e.g. F4.1) + +21-Jan-2010: GAL_UVW - Updated to a more recent local standard of rest vector + +11-Jan-2010: MRDFITS() - fixed use of /FSCALE from bug introduced 11-Nov-2010 + +23-Dec-2010: MRDFITS() = Fix reading of complex valued data in variable length + binary tables + +18-Dec-2010: DBOPEN - Fixed bug opening multiple databases + + /fanning directory renamed to /coyote + +06-Dec-2010: FITS_READ, FITS_OPEN - Now support Fpack compressed FITS files + ( http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) + +05-Dec-2010: GET_PIPE_FILESIZE - Determine the number of bytes in a unit opened + as a pipe with SPAWN + +20-Nov-2010: TEXTOPEN, FORPRINT - Now have a /WIDTH keyword to pass to OPENW + (and avoid possible problems with 80 character wraparound) + +18-Nov-2010: MWRFITS - Fix problem with longword overflow, update to V6.0 + notation + +11-Nov-2010: MRDFITS() - Fixed problem with unsigned integers, update to V6.0 + notation + +28-Oct-2010: PLOTHIST - Added FTHICK keyword to control thickness of lines used + in POLYFILL + +14-Oct-2010: DBSEARCH, FITS_OPEN - Use compound operators, slightly faster + + MAKE_ASTR - Default plate scale is now 1"/pixel (not 1 deg/pix) + +13-Oct-2010: Database routines now support databases with entry lengths larger + than 32767 bytes. This requires some changes in the internal + database formating but these changes should be transparent to the + user. Modified routines are + + DBCREATE, DBEXT_DBF, DBFIND() DB_INFO(), DB_ITEM, DB_ITEM_INFO(), + DBOPEN + + DBWRT - Faster byte swapping + +11-Oct-2010: LEGEND - Now has BTHICK keyword to control legend box thickness + +04-Oct-2010 COSMO_PARAM - Better error checking. + +08-Sep-2010: READCOL - Now has /QUICK keyword for faster (but less flexible) + reading + KSTWO - Fix 32 bit overflow problem when computing N_eff for very + large integers + +19-Aug-2010: CNTRD - Fix bug that would return NaN values rather than -1,-1 + when centroiding failed + GCNTRD - Gaussian smooth image prior to finding maximum pixel + (unless /KEEPCENTER is set ) + DB_ENT2HOST - Fix bug with multidimensional strings + + +18-Aug-2010: DBPRINT - Fix display of multidimensional data + AL_LEGEND - Duplicate of legend.pro that avoids name conflict with + new IDL 8.0 LEGEND() function. + +17-Aug-2010: MRDFITS() - Fix bug with /EMPTYSTRING keyword and multidimensional + strings + DB_ENT2EXT - Fix bug with multidimensional strings + +8-Aug-2010: READFITS() - Fix possible problem when startrow=0 supplied + +3-Aug-2010: READFITS() - Faster access to FPACK decompression + MRD_STRUCT - Serious bug introduced 16-Jul fixed. Could have + caused MRDFITS() to fail if short integers present. + +30-Jul-2010: GETPRO - Test for .sav file, more robust test for write privilege + +24-Jul-2010: READCOL - Free memory used by internal pointers + DBBUILD - Fix for when first parameter is multi-valued + +16-Jul-2010: LEGEND - Make a box with sharper edges + +14-Jul-2010: WFPC2_READ - Fix header when only reading PC chip in MEF format + +12-Jul-2010: QUERYGSC - fix case for dec between -1 and 0 + +11-Jul-2010: QUERYSIMBAD - Added /SILENT keyword + +08-Jul-2010 FXPOSIT() - Prompt for file name if supplied as an empty string + (same effect for MRDFITS(), HEADFITS() ) + +02-Jul-2010: DBCIRCLE() - Fields RA_OBJ (degrees) now works correctly + +24-Jun-2010: ROBUST_SIGMA() - Correctly handle data with NaN values + +20-Jun-2010: FXREAD - Update BLANK keyword when applying BSCALE/BZERO + +03-Jun-2010: READFITS() - Use short-circuit operators, correct treatment of + BLANK keyword, use dialog_pickfile when filename supplied as an + empty string. + +24-May-2010: WCS_GETPOLE - Make native pole calculaions ocnsistently in radians + READFMT - Recognize 'G' format, use SKIP_LUN + DBBUILD - Avoid spurious warning message about # of elements + +09-May-2010: FXBFIND - Fix potentially serious bug introduced April 2010 + DBFIND_SORT - Fixed occasional out of bounds error + +06-May-2010: WFPC2_READ - Can now read multi-extension FITS format + +04-May-2010: MATCH - Added EPSILON keyword to get matches within tolerance. + +09-Apr-2010: FXBREADM - Add support for columns with TNULLn keywords + +07-Apr-2010: DBCREATE - Remove spurious warning that database name is too long + +06-Apr-2010: FXBTORM, FXBHELP, FXBFIND, FXBPARSE - Stop using obsolete !ERR + system variable (and maintain GDL compatibility) + +06-Apr-2010: READCOL - Graceful return even if no valid lines present + +05-Apr-2010: FXBCREATE - Fixed rare truncation of FITS header when updating + THEAP keyword + +02-Apr-2010: FTAB_PRINT, TBPRINT - Can now print in 'table' format (1 row per + line by setting the column parameter to '*'; also added a + NUM_HEADER_LINES keyword. + +28-Mar-2010: FXBADDCOL - Do *not* force TTYPE* keyword to upper case + +23-Mar-2010: Now have a /fanning directory containing procedures from David + Fanning's library ( http://www.dfanning.com/) used with Astron + procedures. Currently contains + + SETDEFAULTVALUE - Set default value for positional & keyword + argument + SYMCAT() - a direct graphics symbol catalog + +22-Mar-2010: CONVOLVE - Add /No_PAD keyword for better speed and less memory usage + when edge effects are not important + +11-Mar-2010: QUERYVIZIER - Avoid error if output columns but not data returned + +10-Mar-2010: MRDFITS() - Fix COLUMN keyword to work as advertised + +06-Mar-2010: REMOVE - Can now remove elements from up to 25 vectors + +25-Feb-2010: READCOL - Now recognizs LL, UL, and ULL data types + STRNUMBER() - Now has a /L64 keyword + +18-Feb-2010: SXPAR(), FXPAR() - Fix problem with extracting very large negative + integers. + + QUERYGSC() - Handle updated server format which now also returns + infrared photometry + +17-Feb-2010: READ_FMR() - Read a journal (ApJ, AJ) machine-readable table into IDL + +09-Feb-2010: CO_REFRACT() - Allow more than 32767 elements + +02-Feb-2010: REPSTR() - Test for empty input string (could cause infinite loop) + +01-Jan-2010: VALID_NUM() -- Corrected bug that would treat '124.' as invalid + +31-Dec-2009: SRCOR - Return as soon as no matches are found + +17-Dec-2009: SRCOR - Fix RA search to account for cos(Dec) + RESISTANT_MEAN - Now has DIMENSION keyword to take mean over 1 + dimension, more consistent double precision + +11-Dec-2009: DBCREATE - Warn if record length exceeds 32767 bytes + FXBREAD - Fix use of DIMENSION keyword + +29-Nov-2009: MWRFITS - Fix /USE_COLNUM for binary tables + DBFIND_SORT - Fixed 01-Nov update to not use VALUE_LOCATE on single + value + +25-Nov-2009: READCOL - Use pointers to improve speed and avoid bug with using + SCOPE_VARFETCH() in IDL 7.1 workbench. + MULTIPLOT - Reinitialize common block if M[X/Y]TITLE set + +03-Nov-2009: LEGEND - PSYM values between 11 and 46 will now use the plotting + symbols defined in David Fanning's SYMCAT() function + http://www.dfanning.com/programs/symcat.pro + +01-Nov-2009: DBINDEX, DBFIND_SORT -- Now allow string items to be sorted + +30-Oct-2009: READFITS() - Ignore degenerate trailing dimensions with NSLICE keyword + +29-Oct-2009: CONVOLVE - Pad images prior to FFT to avoid edge effects + +23-Oct-2009: GLACTC_PM - Convert between celestial and Galactic (or Supergalactic) proper motion + +19-Oct-2009: FITS_READ - Make sure FIRST is long64 for very large files + +30-Sep-2009: FXADDPAR - Now has /NOLOGICAL keyword to *not* interpret 'T' and + 'F' as logical values + MWRFITS - Allow TTYPE values of 'T' and 'F' + +16-Sep-2009: TAG_EXIST() - June 2009 update wasn't setting INDEX keyword + +20-Aug-2009: READCOL - Now allows up to 40 output parameters + FTAB_EXT - Now allows up to 30 output parameters + +14-Aug-2009: HPRECESS, PRECESS_CD - Use J/Bprecess for conversion between + J2000 and B1950 + +11-Aug-2009: FITS_ADD_CHECKSUM - Make sure FITS header has 80 characters/line + +10-Aug-2009: FDECOMP - Removed MacOS section (since it is same as Unix) + BLKSHIFT - MacoS *can* move beyond EOF with POINT_LUN + +31-Jul-2009: MRDFITS - Added /EMPTYSTRING keyword to bypass IDL memory bug + when reading empty strings + +31-Jul-2009: DBFIND - Avoid possible "Illegal Operand" error + +30-Jul-2009: MRD_STRUCT - restored 131 character limit for execute() + +22-Jul-2009: READFITS() - Fix error using NUMROW,STARTROW with non-byte data, + allow these keywords to be used with primary array + +21-Jul-2009: SXPAR() - Faster handling of Long String convention + +17-Jul-2009: WHERE_TAG(), CREATE_STRUCT(), TAG_EXIST(), SXDELPAR - cleaner and + slightly faster coding + + Removed NUMLINES() which is superceded since V5.6 by FILE_LINES + +16-Jul-2009: Remove N_STRUCT() (now in /obsolete) since it is rinky-dink + (and to recapture the namespace) + +15-Jul-2009: TABINV - use ARRAY_EQUAL for speed, always internal double + precision + +14-Jul-2009: FXPOSIT, MRDFITS() - More complete handling of FPACK compressed + files, including automatic detection of FPACK compression. + +11-Jul-2009: KSONE - work for functions that do not accept keywords + +03-Jul-2009: RDFITS_STRUCT - Added EXTEN keyword to only read specified + extensions + + DBSEARCH() - Faster search for large databases + MRD_HREAD - Now has a /SKIPDATA to position at end of HDU + +03-Jul-2009: Library now requires IDL V6.1 or later + IDL_VALIDNAME - removed since an intrinsic function since V6.0 + + ADSTRING - Use new formatting for "+" and "-" + CHECKSUM32 - Use TOTAL(/INTEGER) for faster performance + DBBUILD - Eliminate use of EXECUTE() and use SCOPE_VARFETCH(), + accept up to 50 input variables. + MRD_STRUCT - Assume lmgr() function available + + +02-Jul-2009: WCSSPH2XY - Check for valid range of nonlinear polynomial in + a ZPN projection. + +01-Jul-2009: MRDFITS() - Fixed bug introduced March 2009 when using file unit + (the Unixpipe variable was undefined) + +29-Jun-2009: MWRFITS - trim alias, implement logical TFORM 'L', don't add + space after TFORM key + +28-Jun-2009: DBCREATE - Remove calls to IEEE_TO_HOST + +23-Jun-2009: LINMIX_ERR - Fixed bug so the iteration count reset after the burnin + stage when /SILENT + +17-Jun-2009: MRDFITS() - Fixed typo giving an error with /FSCALE + introduced April 2009 + HOR2EQ - Fixed case of scalar Julian date but vector positions + CO_ABERRATION - Fix error with vector input + SRCOR - Fix case when no matches found with /SPHERICAL + +9-Jun-2009: MODFITS -- allow input data to be an (MRDFITS) structure + +27-May-2009: FXPOSIT(), READFITS, MRDFITS, HEADFITS() - can now read FITS files + compressed with FPACK ( http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) + +15-May-2009: CREATE_STRUCT - Now puts "compile_opt hidden" in temporary .pro + file to suppress error messages + +05-May-2009: CHECKSUM32 - Skip byteswapping for float or longword data + +30-Apr-2009: DBCIRCLE() - Fix problem when RA range exceeds 24h + +10-Apr-2009: MWRFITS - Small efficiency update when writing ASCII tables + +03-Apr-2009: MRDFITS() - Small efficiency updates in MRD_SCALE + +01-Apr-2009: PLOTERROR, OPLOTERROR - Fixed problem when axes are both + logarithmic and reversed + +19-Mar-2009: TAG_EXIST() - Added a dummy /RECURSE keyword for compatibility + with the Solarsoft version + +16-Mar-2009: FXPOSIT() - Now opens files with the /SWAP_IF_LITTLE_ENDIAN keyword + for byteswapping on the fly. + MRDFITS() - Use new FXPOSIT() for much faster byteswapping. **The + new MRDFITS() must be used with the new fxposit.pro ** + +13-Mar-2009: GCIRC - Now uses haversine formula for less roundoff error at the + milliarcsecond level + SRCOR - Now much faster when using spherical coordinates. Added + /SILENT keyword + +09-Mar-2009: IMDBASE - Addded /SILENT keyword + +24-Feb-2009: WEBGET() - Now has TIMEOUT keyword (defaulting to 30s) + +21-Feb-2009: GETROT - Account for rotation introduced by nondefault value + of LONGPOLE + SKY - Avoid possible out of bounds if /NAN set + +20-Feb-2009: EXTAST - Fix typo for AZP projection, nonzero longpole + If duplicate WCS keywords, then use the *last* values + + DBOPEN - Fix typos in keywords passed to BYTEORDER + +10-Feb-2009: FXBADDCOL, FXBWRITM - Now work with unsigned integers + FXADDPAR - Increase formatting precision for double precision + + RXTE Software in contrib/rxte directory updated to Version 1.2 + +06-Feb-2009: TEN(), TENV() - Now accept string inputs + +02-Feb-2009: READCOL - Now has STRINGSKIP keyword to skip lines beginning with a + specified string + +22-Jan-2009: ROBUST_POLY_FIT() - Added /DOUBLE keyword, removed obsolete call + to POLYFITW + HELIO - Work for more than 32767 positions + +21-Jan-2009: PLOTHIST - Now has a /ROTATE keyword to switch X and Y axis + (put the plot on its side). + +18-Jan-2009: WEBGET(), QUERYVIZIER() - Added /SILENT keyword + +13-Jan-2009: ASTROLIB - Removed !DEBUG definition (no longer used) + +12-Jan-2009: SCREEN_SELECT, SELECT_O, SCR_*.PRO moved to /obsolete directory + (i.e. widgets are now assumed to be always available). + + +09-Jan-2009: MWRFITS - Now has output STATUS keyword to indicate success/failure + JPLEPHINTERP - Now allows base time TBASE to be scalar or vector + +22-Dec-2008: KSTWO - Fix bug when maximum difference occurs at the end of the + array + +19-Dec-2008: DBCIRCLE() - Added /GALACTIC input keyword and COUNT output keyword + +12-Dec-2008: GAL_UVW - Now 10 times faster for large arrays + +26-Nov-2008: JPLEPHINTERP - More input checking, SSB and EMB aliases for + solar system and earth-moon barycenter + +25-Nov-2008: QUERYSIMBAD - Remove CADC keyword, add CFA keyword, update address + of Sesame server + +11-Nov-2008 FIND - Now has /MONITOR keyword to control whether to display each + individual star + READCOL - Now has NLINES output keyword + +29-Sep-2008: EULER - Now has /RADIAN keyword + +06-Sep-2008 FITS_WRITE - Delete BSCALE/BZERO before writing file + PLOTHIST - Check whether all values are NaN + +28-Aug-2008: IMCONTOUR - Work when RA crosses 0 hours + TICLABELS - Use 0h labeling instead of 24h + +19-Aug-2008: ADSTRING() - Fix roundoff error when -1 < dec < 0 , add PRECISION + keyword + +15-Aug-2008: READCOL - COUNT output keyword added giving number of valid lines + EXTAST - Now use the *last* values if duplicate astrometry + keywords are present in the FITS header + +08-Aug-2008: MRDFITS() - Added OUTALIAS keyword, use vector form of VALID_NUM() + +07-Aug-2008: VALID_NUM() - Major rewrite to use STREGEX, accept vector input + SXPAR() - Use vectorized form of VALID_NUM + +05-Aug-2008: QUERYVIZIER() - Use STRCOMRPESS2 for more robust searches using + Constraint string + +04-Aug-2008: STRCOMPRESS2() - Remove blanks around specified chars in a string + +01-Aug-2008: DBCREATE - Fix bug introduced May 2008 when not in ZDBASE dir + DBGET() - Fix possible bug when sublist supplied + +30-Jul-2008: MODFITS - Now has EXTNAME input keyword + JDCNV - Now checks for valid day, month ranges + CT2LST - Change sign of time zone parameter to match standard + Positive East of Greenwich (ahead of GMT). + QUERYVIZIER() - Allow for possible lower-case returned formats + +19-Jul-2008: OBSERVATORY - Fix error message for unknown observatory + MODFITS - Fix bug when adding CHECKSUM changed header size + FITS_ADD_CHECKSUM - Don't update DATASUM if not already present + and no data array supplied. + + RXTE Software in contrib/rxte directory updated to Version 1.1 + +27-Jun-2008: EULER - Use less virtual memory for large arrays + +24-Jun-2008: MRDFITS() - More informative error message when EOF encountered. + +18-Jun-2008: GAL_UVW - Fix overflow for >32767 elements and update Sun velocity + +12-Jun-2008: FITS_ADD_CHECKSUM - Fix error when CHECKSUM is an empty string + +07-Jun-2008: QUERYVIZIER - Now recognize 'D' format specification + +13-May-2008: FITS_ADD_CHECKSUM - Fix problem with images with multiples of + 2880 bytes. + +10-May-2008: READFITS() - Now always reset BSCALE/BZERO after applying even for + unsigned integers + +03-Apr-2008: HEXTRACT - Added ALT keyword to specify alternate astrometry + UPDATE_DISTORT - Update SIP nonlinear transformation astrometry + coefficient for a linear transformation + +27-Mar-2008: SIZE_STRUCT() - Moved to /obsolete directory becuase it is + superceded by LENGTH and DATA_LENGTH keywords to N_TAGS + +21-Mar-2008: FIND - Now computes centroids using marginal Gaussian fits + GCNTRD - Modified centroid algorithm to match IRAF/DAOFIND & + allow shifts of more than 1 pixel from initial guess. + + +19-Mar=2008: FXBREADM, FXBWRITM - Read/write 64 bit integer columns + +18-Mar-2008: FITS_INFO, FXBOPEN, FXBPARSE, FXFINDEND, FXBFINDLUN - Update + integers to LONG64 to deal with very large files. + + HREBIN, HCONGRID - Don't update BSCALE/BZERO for unsigned integer + +13-Mar-2008: APER - Allow output of negative fluxes (if /FLUX is set) + +10-Mar-2008: READFITS() - Avoid 32bit overflow when using NSLICE keyword + +03-Mar-2008: QUERYVIZIER - Update Strasbourg Web address to work correctly + +01-Mar-2008: DBCREATE - No longer requires user to be on a ZDBASE directory + FIND - /SILENT now suppresses *all* output + +18-Feb-2008: WRITEFITS - EXTEND keyword is no longer required in the primary + header of a FITS file with extensions as in proposed new + FITS guideline + +14-Feb-2008: RESISTANT_MEAN - Use double precision internally + IMCONTOUR - Make use of the OVERLAY keyword always optional + +29-Jan-2008: SKY - Avoid possible out of bounds if /NaN set. + +17-Jan-2008: CONS_RA() - Ensure that returned declination is between -90 and 90 + IMCONTOUR - Added OVERLAY keyword to ensure accuracy ot 1 pixel + when overlaying an image. Use FORMAT_AXIS_VALUES() + + New /contrib/rxte directory contains "IDL Extractor" programs + to extract light curves, spectra and power spectra from RXTE data + (and also Swift and Chandra data). + +14-Jan-2008: FXWRITE - Now has /APPEND keyword to append to existing FITS files + FXHMAKE - Now has /XTENSION keyword to specify header is for an + image extension. + FXBWRITM - Now allows output table to have TSCAL/TZERO keyword + values, unless new /NOSCALE keyword is set + FXBREADM - Now recognizes unsigned integer scalings, and scalings + can be either float or double precision. + +08-Jan-2008: ADD_DISTORT -- Add a SIP distortion astrometry structure into a + FITS header + HREBIN, HCONGRID - will now update SIP distortion coefficients + when expanding or compressing an image + MMM - make sure that program never aborts but returns gracefully + +24-Dec-2007 TRANSFORM_COEFF - Compute new polynomial coefficients under a + linear transformation + +19-Dec-2007: FITS_INFO - Now has out keyword EXTNAME to return extension names + QUERYGSC() - Updated Webserver name (sigh) + +13-Dec-2007: MODFITS - Ensure that supplied header contains 80 byte lines + +11-Dec-2007: QUERYVIZIER(), CREATE_STRUCT() - Use vector form of IDL_VALIDNAME + if IDL V6.4 or later + +4-Dec-2007: FXMOVE() - Fix data size calculation for very large files + FXPOSIT() - Added LUNIT keyword for user-supplied unit number + +2-Dec-2007; QUERYGSC() - major rewrite to use new STScI server & GSC 2.3.2 + + QUERYUSNO (to query USNO-A2 catalog) has been removed since the + newer USNO-B1 catalog can be queried with QUERYIVIZIER, e.g. + IDL> info = queryvizier('usno-b1','m13',5) + +25-Nov-2007: Minimum IDL version is now IDL V5.6 + Updated procedures include RDFLOAT, BLKSHIFT, MEDARR, DBDELETE, + FTAB_DELROW, GETPRO, WEBGET, READCOL, READFMT, READFITS, MRDFITS + + PRODUCT() - removed since intrinsic PRODUCT() is in V5.6 + + PLOTHIST - Added AXISCOLOR keyword, fix color problem when + overplotting + +20-Nov-2007: ABSCAL() - Moved to /obsolete directory + +14-Nov-2007: FXFINDEND, FXMOVE, FXBOPEN, FXREAD, FXWRITE, FXHMODIFY - Now + account for possibility 64bit integers needed for # of bytes. + +13-Nov-2007: CORREL_IMAGES - Always REBIN() using floating pt. arithmetic + +27-Oct-2007: WCSXY2SPH, WCSSPH2XY - Now supports the HEALPIX projection + +12-Oct-2007: WRITEFITS - By default, update CHECKSUM keywords if already present + +26-Sep-2007: FIND - Fix error message when no local maxima found + +13-Sep-2007: HOR2EQ - Avoid integer overflow for more than 32767 points + +31-Aug-2007: MODFITS - Fix problem when data size must be extended + MULTIPLOT - Added /SQUARE keyword, overall (x)(y)title keyword. + Can now control gaps between plots and overall tick format. + +22-Aug-2007: MRDFITS() - Fix problem when both /FSCALE and /UNSIGNED set + +8-Aug-2007: READFITS() - Fix bug introduced Mar 2006 in applying Bzero + +6-Aug-2007: MATCH2 - New procedure to find every matching element in 2 arrays + +3-Aug-2007: LEGEND - 13-Jul update introduced a bug for /NORMAL coords + FXADDPAR - Bug fix for long string convention + OBSERVATORY - Added info for Mount Graham observatory + WCSSPH2XY, WCSXY2SPH - Correct treatment of PVi_j parameters + +13-Jul-2007: WEBGET() - Partially upgrade to support HTTP 1.1 + LEGEND - Don't modify position keyword + DATE_CONV() - Add Julian date capabilities + +06-Jul-2007: HPRECESS - Fix for case where CROTA2 is in the FITS header + PUTAST - Allow PC matrix to updated when CD matrix is supplied + +02-Jul-2007: QUERYSIMBAD - Update for parsing new /NED format + +24-Jun-2007: WEBGET() - Now has a POST keyword for POST rather than GET queries + +22-Jun-2007: FITS_READ - Added /PDU keyword to always inherit primary header + even if INHERIT=T is not present (pre-April 2007 behavior) + MRDFITS() - Fix for variable length arrays when used with the + virtual machine. + +29-May-2007: LINMIX_ERR, MLINMIX_ERR - Improved Bayesian prior for more reliable + results + +25-May-2007: CHECK_FITS - Work again for a null array + +17-May-2007: New procedures supplied by Brandon Kelly (Steward U.) + + LINMIX_ERR : Bayesian approach to linear regression with errors in both X + and Y + MLINMIX_ERR : Bayesian approach to multiple linear regression with errors in + both X and Y + MRANDOMN : Generate random vectors from a multivariate normal density. + MULTINOM : Genereate random vectors from a multinomial distribution. + RANDOMCHI : Generate random numbers from a chi-square density. + RANDOMDIR : Generate random vectors from a Dirichlet density. + RANDOMGAM : Generate random numbers from a gamma distribution. + RANDOMWISH : Generate random matrices from a Wishart density. + +15-May-2007: FITS_READ, READFITS(), WRITEFITS - Set data variable to LONG64 + for handling very large files + +08-May-2007: MEDARR - Added /DOUBLE keyword to force double precision + +07-May-2007: PSF_GAUSSIAN() - Do not modify NPIXEL input keyword + +24-Apr-2007: REM_DUP() - Use faster algorithm when flag parameter not given + FORPRINT - Fix error message when variable is undefined + +23-Apr-2007: FXADDPAR - Now has an ERRMSG output keyword to capture error + messages. + +14-Apr-2007: FITS_OPEN - Warn user that compressed files cannot be updated + +13-Apr-2007: WEBGET - Friendlier error recovery + +12-Apr-2007: FITS_READ - Don't inherit the primary header unless INHERIT = T + +9-Apr-2007: GCIRC - Use internal double precision for U=0 mode as advertised + EXTAST, MAKE_ASTR - .CRPIX tag now double instead of float + +6-Apr-2007: MRDFITS - Convert ASCII table array output to DOUBLE if needed to + preserve precision + +28-Mar-2007: HEXTRACT - Work for dimensions larger than 32767 + +21-Mar-2007: TBINFO - Now has a /NOSCALE keyword to skip TSCAL, TZERO + TBPRINT, TBGET() - Avoid pointer leaks due to TBINFO call + TBDELCOL - Use /NOSCALE in call to TBINFO + +13-Mar-2007: MODFITS - Update the file control block (FCB) structure if the + file size changes + +09-Mar-2007: AD2XY, XY2AD - Use CRVAL ref. point for non-WCS transformations + +08-Mar-2007: DBDELETE - Fix problem when deleting final entry + FXMOVE - Use a case-independent search for EXTNAME + +06-Mar-2007: QUERYSIMBAD - Update NED query to account for new IPAC format + +05-Mar-2007: SKY - Fix problem for very large (>5000 x 5000) images + +02-Mar-2007: MWRFITS - fix problem where strings were being right-justified + instead of being written exactly as supplied. + +21-Feb-2007: TVELLIPSE - Added /MAJOR, /MINOR keywords to add major, minor axes + +16-Feb-2007: FTAB_PRINT - Check for empty extension + +15-Feb-2007: LIST_WITH_PATH - Restore pre-Sep 2006 behavior of not searching + subdirectories + +12-Feb-2007: PCA - fix bug in computation of attribute projections + +9-Feb-2007: DBMATCH - Fixed bug where /FULLSTRING was always being set + +8-Feb-2007: CREATE_STRUCT - Added a descriptor type 'K' for LONG64 data + +7-Feb-2007: REMCHAR - Work for string arrays with more than 32767 elements + +6-Feb-2007: QUERYSIMBAD - Now use the more reliable Simbad Sesame name server, + added /VERBOSE,/CADC keywords + +20-Jan-2007: TEXTOPEN - Make sure output keyword MORE_SET is always defined + + EXTAST - Now includes .NAXIS tag in output astrometry structure + PUTAST - New /NAXIS keyword to write .NAXIS values to FITS header + +09-Jan-2007: DBPRINT, DBEXT_DBF - Remove use of EXECUTE() statements + +03-Jan-2007: READCOL - Now has /PRESERVE_NULL keyword. This was formerly set + as the default + +28-Dec-2006: DBEXT, WFPC2_READ, FTAB_EXT - Avoid EXECUTE() for V6.1 or later + +26-Dec-2006: DBINDEX- Automatically enlarge index (.dbx) file if necessary + Fix serious bug introduced 18-Dec + +19-Dec-2006: CONVOLVE() - Avoid unnecessary recomputation for double complex + + TVCIRCLE - Make default integers LONG so largest postscript circles + display properly. + +18-Dec-2006: DBSORT, DBINDEX - Avoid use of EXECUTE() for V6.1 or later + +16-Dec-2006: MRDFITS(), HEADFITS() - Can now specify FITS extension by name (in + the EXTNAME keyword) + FXMOVE(), FXPOSIT() - Added EXT_NO, ERRMSG keywords + +13-Dec-2006: MRD_SKIP - Restored check to avoid POINT_LUN with compressed files + +8-Dec-2006: WEBGET - Added case for reading FITS images from FIRST survey + +1-Dec-2006: EXTGRP - Restored to Library (needed by WFPC2_READ) + +24-Nov-2006:FITEXY - normalize input data before processing + +22-Nov-2006: CHECK_FITS - Fix dimension error introduced 14-Nov + +20-Nov-2006: RDPLOT - Major upgrade, added BACKGROUND, /ACCUMULATE keywords + fixed full cursor display for different setups + +15-Nov-2006: EXTAST - Use GSSS astrometry if WCNAME = "DSS" (as in + recent DSS images from the STScI server) + +14-Nov-2006: CHECK_FITS - Removed support for STSDAS headers + +2-Nov-2006: APER - All additional keywords to be passed to MEANCLIP + +1-Nov-2006: ONE_RAY, ONE_ARROW - Now accept /DATA and /NORMAL keywords + +25-Oct-2006: FITS_READ - Fix bug when using /DATA_ONLY keyword + +20-Oct-2006: QUERYVIZIER - Set target='NONE' for an all-sky search, accept + '+/-' constraints + +17-Oct-2006: TBINFO - treat Logical type as character 'T' or 'F' + +13-Oct-2006:GCIRC - Option (U=2) to supply input longitude, latitude in Degrees + +3-Oct-2006: TVELLIPSE - Now uses _EXTRA to pass optional keywords to PLOTS + +2-Oct-2006: MRD_SKIP - now uses POINT_LUN for compressed files since it is as + fast as any other method + READFITS() - Now calls MRD_SKIP to select fastest possible method + of skipping bytes + +26-Sep-2006: FITS_OPEN, FITS_READ, FITS_WRITE, MODFITS - now use + /SWAP_IF_LITTLE_ENDIAN keyword to OPEN + +25-Sep-2006: Library now requires V5.5 or later. VMS support has been removed + from most procedures + + The following "stale" procedures have been removed from the Library + They can still be obtained from + http://idlastro.gsfc.nasa.gov/ftp/obsolete/ + + afhread - Used for mostly obsolete WFPC1 data + astrmfix = Used for mostly obsolete FOC data + conv_stsdas - Mainly for converting between VAX and unix + conv_vax_unix() - Vaxes rarely used + conv_unix_vax - Vaxes rarely used + datatype() - JHUAPL routine + dbcompress - TRUNCATE_ON_CLOSE makes it unnecessary + def_dirlist -- Mainly for VMS + extgrp - mainly for old WFPC1/FOC data + getfiles -- Use dialog_pickfile instead + getlog.pro -- mainly for VMS + imgread -- for mostly obsolete WFPC1/FOC data + mid_*.pro -- Midas I/O routines, no evidence that they are used + osfcnvrt.pro -- mainly for VMS + strd - only worked for small set of (mostly obsolete) GEIS files + stsub, stsubim - only worked for small set of (mostly obsolete) + GEIS files + spline_smooth -- Never worked properly + redshift -- 1970's cosmology, from JHUAPL library + sxhedit -- just use a regular editor + table_conv.pro - mainly for vax/unix conversion + wfpcread -- WFPC1 data rarely used + + +12-Sep-2006: FITS_OPEN - Support very large files by using 64 bit variables + +9-Sep-2006: DBDELETE -Use TRUNCATE_LUN (if V5.6 or later) to compress the .dbf + file after deleting entries. DBCOMPRESS moved to + obsolete directory. + +1-Sep-2006: READCOL, STRNUMBER() now have a /NAN keyword to specify that + empty strings should be interpreted as NAN values + +30-Aug-2006: STRNUMBER() - An empty string is a valid number (=0.0) + +25-Aug-2006: HASTROM - Account for half-pixel shift when using nearest neighbor + +23-Aug-2006: FORPRINT - Warn if supplied vectors are not all the same size + +11-Aug-2006: TBPRINT - Fixed check for multiple values + +08-Aug-2006: MWRFITS - Allow logical columns to be specified as bytes + +04-Aug-2006: PLOTHIST - fix possible color problem introduced May 2006 + +26-Jul-2006: TBINFO - Added ERRMSG keyword, Treat repeat count for strings as + specifying string length, not number of elements + +25-Jul-2006: FITS_OPEN - FCB.Filename now expands any wildcards + +21-Jul-2006: DBFPARSE - Don't convert DATE/TIME to numeric for string items + +14-Jul-2006: DBCREATE - New MAXENTRY keyword to override hardcoded #maxentries + +12-Jul-2006: QUERYVIZIER - Removed V6.0 notation to restore V5.4 compatibility + +06-Jul-2006: MWRFITS - Make 29-Jun-2006 fix work for pre V6.0 versions + +29-Jun-2006: MWRFITS - Fix problem introduced May 2006 with multi-dimensional + strings + + MRDFITS - Better error catching for gzip files, fix handling + of unsigned integers when BSCALE not present + +27-Jun-2006: PLOTHIST - Now supports logarithmic axes (/XLOG, /YLOG) + +26-Jun-2006: DBCREATE - Fix problem introduced May 2006 when default integer + types were change to LONG + +23-Jun-2006: MWRFITS - Use /SWAP_IF_LITTLE_ENDIAN keyword to OPEN for + improved speed. + +8-Jun-2006: TBPRINT - Use case-insensitive match of column names with TTYPES + +7-Jun-2006: FITS_OPEN - Call XDISPSTR if /HPRINT is set on a GUI terminal + HPRINT - Call XDISPSTR if on a GUI terminal + +5-Jun-2006: XDISPSTR - Widget display of text with a simple search capability + +2-Jun-2006: GETPRO - Now uses FILE_WHICH() function for improved speed + FINDPRO - Use FILE_SEARCH instead of FINDFILE for V5.5 or later + +26-May-2006: PLOTHIST - Add /BOXPLOT keyword, use exact XRANGE as default + +16-May-2006: FDECOMP - Include final delimiter in directory name under + Windows, as advertised + QUERYVIZIER() - New /ALLCOLUMNS keyword to return all catalog + columns. Also, QUERYVIZIER() **now returns an + anonymous rather than a named structure** + +1-May-2006: DBCREATE - Make sure to use lowercase file names on Unix + HROT - Work with a 1 element floating point angle + +28-Apr-2006: MRDFITS(), TBGET() - Use faster byteswapping keywords to BYTEORDER + +25-Apr-2006: DBEDIT - Now use DIALOG_MESSAGE for error messages + + A_b() - Moved to obsolete directory + +24-Apr-2006: AITOFF_GRID, ARCBAR, HISTOGAUSS, SUNSYMBOL(), TICLABELS - + Now have a FONT keyword to specify font (-1, 0 or 1) + + HOST_TO_IEEE, IEEE_TO_HOST - use new keywords to BYTEORDER + for improved performance + +21-Apr-2006: FITS_WRITE - Fix problem when number of bytes exceeds 32 bit word + N_BYTES() - Now returns a long64 integer + QUERYVIZIER() - Recognize 'E' format (same as 'F'format) + +14-Apr-2006: Library now requires V5.4 or later, v53 directory contains + frozen version, V5.4 related changes include: + GET_DATE - Removed LOCAL_DIFF keyword + FSTRING() - moved to obsolete directory + ADSTRING(), TO_HEX(), FTPUT - removed call to FSTRING() + BOXAVE() - allow 64bit integers + GETTOK(), MATCH, FM_UNRED - use COMPLEMENT keyword to WHERE + HPRINT, FTDELCOL - Use BREAK instead of GOTO + MRD_SKIP, FITS_OPEN, FITS_INFO - Use fstat.compress + GET_JULDATE - Use /UTC keyword to SYSTIME() + DB_ITEM, FITSDIR, NUMLINES(), IRAFRD - Use FILE_EXPAND_PATH + +13-Apr-2006: DATE_CONV() - removed RETALL from error messages + MMM - Now has NaN keyword to check for not-a-number values + +05-Apr-2006: HPRECESS - Fix algorithm when CROTA2 in FITS header + XYAD - Include equinox when displaying coordinates + +03-Apr-2006: DATE_CONV() - Don't include space in output FITS date + +01-Apr-2006: FITS_READ, READFITS() - Do not modify BSCALE/BZERO in FITS header + if reading unsigned integers + +31-Mar-2006: MODFITS - Make sure last line of input FITS header is END + DBPRINT - Fix display on GUI terminals + +27-Mar-2006: POLY_SMOOTH() - Add /EDGE_TRUNCATE to CONVOL call + +22-Mar-2006: QUERYVIZIER - 22 Feb update was not properly returning the first + object found. + +17-Mar-2006: FXHMODIFY - Fixed problem when needing to extend size of primary + header with a call to BLKSHIFT + +14-Mar-2006: DBEDIT - Added /BYTENUM keyword to treat bytes as numbers rather + than characters + +1-Mar-2006: SIXTY() - Added /TrailSign keyword to always place minus sign + on first element, rather than first nonzero element. + +28-Feb-2006: CONVOLVE() - Match output precision type to that of input + +24-Feb-2006: NUMLINES() -- Handle Unix files with spaces prior to IDL V5.6 + +23-Feb-2006: FXBADDCOL, FXBTFORM -- Added support for 64 bit integers + MWRFITS - Removed warning about 64bit integers now that they are + standard FITS (as of December 2005) + +22-Feb-2006: QUERYVIZIER - Updated for a change in the VIZIER output + +6-Feb-2006: FXPOSIT - Remove leading spaces in filename when FINDFILE used + +20-Jan-2006: RESISTANT_MEAN - Fix calculation of SIGMA_MEAN + MMM - Fixed error introduced June 2004 removing outliers when + READNOISE not set + +29-Dec-2005: WCSSPH2XY, WCSXY2SPH - Fixed AIRY projection when centered at + 90 degree latitude + +21-Dec-2005: CO_REFRACT() - Fix problem with vector input when /TO_OBSERVED set + +15-Dec-2005: JPLEPHINTERP - Fix highest order term in velocity computation + +05-Dec-2005: TEN(), TENV() - Now recognize -0.0 as a negative value + +23-Nov-2005: APER - Added MEANBACK keyword to use sigma-clipped mean instead + of calling mmm.pro + MMM - Added /SILENT keyword to suppress error messages + +17-Nov-2005: TBPRINT - Better display formatting (space between columns) + +16-Nov-2005: MEANCLIP - Added /DOUBLE keyword + +09-Nov-2005: PRINT_STRUCT - Avoid overflow when displaying more than 10000 + elements + +27-Oct-2005: SXADDPAR - Work again with empty string input + MMM - Fewer aborts for strange sky histograms + +15-Sep-2005: LEGEND - Added FONT keyword [-1,0 or 1} to pass to XYOUTS commands. + +09-Sep-2005: TBHELP - Fixed bug introduced 31-Aug-2005 to not display TFORM + +02-Sep-2005: TVBOX - Don't round coordinates when /DATA is set + +31-Aug-2005: FTAB_HELP - Now defaults to display all extensions + TBHELP, FTHELP - Slightly more compact display formats + +26-Aug-2005: QUERYVIZIER - Make dis (3rd parameter) optional (as advertised) + +17-Aug-2005: HEULER - Use double precision to compute new North Pole + +21-Jul-2005: FITS_INFO - Now work for FITS files with SIMPLE=F + +18-Jul-2005: WCSSPH2XY - Return unprojectable points as NaN values + PLOTHIST - Added /AUTOBIN keyword to set the number of bins to + the square root of the number of samples + +05-Jul-2005: READCOL - added "compile_opt idl2" to ensure pre-V6.1 compatibility + +22-Jun-2005: MRD_STRUCT - Fix problem when both NO_EXECUTE and STRUCTYPE set + QUERYVIZIER - Eliminate use of EXECUTE() statement + READCOL - Eliminate use of EXECUTE() for V6.1 or later; accept + null strings separated by delimiter ,e.g. ',,,' + +18-May-2005: SXADDPAR - Fix SAVECOMMENT error with non-string values + +17-May-2005: PUTAST - Don't use CROTA2 keyword if skew is present in the input + astrometry + GETROT - Added ALT keyword + +12-May-2005: HREBIN, HCONGRID - Fixed problem in output astrometry if CROTA2 or + PC matrix used. Added ALT keyword. + +05-May-2005: ADXY - Still work if no WCS coordinates are present + +02-May-2005: FXBWRITM - Remove call to EXECUTE() when using POINTERS keyword + +25-Apr-2005: KSONE - Allow passing keywords to func_name via _EXTRA facility + +20-Apr-2005: TICPOS - Fix cases where tic increment is at degree/minute or + minute/arcsec boundary + +19-Apr-2005: IMDBASE - Now accepts ALT keyword for alternate astrometry + +11-Apr-2005: FXBGROW - Fixed bug in the zeroing of the output file + +06-Apr-2005: JPLEPHINTERP - Handle custom-built ephemerides + +30-Mar-2005: PARTVELVEC - Now has a VecColors keyword to set arrow colors + +08-Mar-2005: FXREAD - Can now be used to read image extensions + +25-Feb-2005: READFITS() - Fix problem with unsigned integers introduced Sep 2004 + HASTROM - Check for distortion parameters in headers, add more + FITS HISTORY records + +24-Feb-2005: MINMAX() - Work again for versions prior to V5.5 + +07-Feb-2005: MRDFITS() - Fix problem when /USE_COLNUM is set + +03-Feb-2005: MRDFITS() - Fix problem with string variable binary tables, + possible math overflow on non-IEEE machines + +01-Feb-2005: FITS_HELP - Don't truncate displayed EXTNAME values at 10 chars + +31-Jan-2005: BLKSHIFT - Call TRUNCATE_LUN when shifting data forward from the + end of the file. + +20-Jan-2005: MOONPOS, NUTATE - Avoid possible integer overflow + +12-Jan-2005: MRDFITS() - Fixed problem reading zero width arrays in binary + tables on non-IEEE (e.g. Linux) machines + +10-Jan-2005: MINMAX() - Added SUBSCRIPT_MIN and SUBSCRIPT_MAX output keywords + +03-Jan-2005: MWRFITS - Fix writing of empty strings to a binary table + +31-Dec-2004: MODFITS - More robust error reporting + +16-Dec-2004: MRDFITS() - Propragate /SILENT to MRD_HREAD, more LONG64 casting + APER - Fixed bug introduced 11/04 when there are no bad pixels + +15-Dec-2004: RDFITS_STRUCT - Don't copy primary header into extension headers + +14-Dec-2004: FITS_INFO - Check entire header for EXTNAME keyword + SXPAR() - Make sure ABORT parameter always defined + +10-Dec-2004: CHECKSUM32 - Sep. 2004 update introduced byte-ordering error for + Linux boxes + + +24-Nov-2004: HROTATE - If GSSS astrometry is present, then convert to standard + world coordinate system (WCS) astrometry + +22-Nov-2004: WRITEFITS - Fixed problem when CHECKSUM set, and a heap array given + +02-Nov-2004: APER - Now has /NAN keyword to signal a check for NaN pixels + +29-Oct-2004: MMM - Improved numerical precision + +25-Oct-2004: MRDFITS() - Check if extra degenerate NAXISi keywords are present + +19-Oct-2004: WRITEFITS - Added ability to write to heap area + CURVAL - Now has "ALT" keyword to select alternate astrometry + +18-Oct-2004: HPRINT - Fixed 1 line offset on terminal that don't support /MORE + +15-Oct-2004: XYAD, XY2AD, AD2XY - Now work for FITS headers with WCS keywords + (CRPIX, CRVAL, CDELT) but no astronomical projection. + +12-Oct-2004: RDFITS_STRUCT - Now has a /HEADER_ONLY keyword to read all the + headers (and no data) in a FITS file + +11-Oct-2004: HPRINT, FORPRINT - Do a simple PRINT if IDL in demo mode + +01-Oct-2004: UNZOOM_XY, ZOOM_XY, TVLIST, CURVAL - Now compatible with versions + in the MOUSSE library (http://archive.stsci.edu/uit/analysis.html) + diff --git a/modules/idl_downloads/astro/pro/.idlwave_catalog b/modules/idl_downloads/astro/pro/.idlwave_catalog new file mode 100644 index 0000000..46c465c --- /dev/null +++ b/modules/idl_downloads/astro/pro/.idlwave_catalog @@ -0,0 +1,582 @@ +;; +;; IDLWAVE catalog for library Astrolib +;; Automatically Generated -- do not edit. +;; Created by idlwave_catalog on Tue Feb 10 14:55:21 2015 +;; +(setq idlwave-library-catalog-libname "Astrolib") +(setq idlwave-library-catalog-routines + '(("spc" fun nil (lib "factor.pro" nil "Astrolib") "Result = %s(n, text)" (nil ("character") ("help") ("notrim"))) + ("print_fact" pro nil (lib "factor.pro" nil "Astrolib") "%s, p, n" (nil ("help"))) + ("factor" pro nil (lib "factor.pro" nil "Astrolib") "%s, x, p, n" (nil ("debug") ("help") ("quiet") ("try"))) + ("ad2xy" pro nil (lib "ad2xy.pro" nil "Astrolib") "%s, a, d, astr, x, y" (nil)) + ("add_distort" pro nil (lib "add_distort.pro" nil "Astrolib") "%s, hdr, astr" (nil)) + ("adstring" fun nil (lib "adstring.pro" nil "Astrolib") "Result = %s(ra_dec, dec, precision)" (nil ("PRECISION") ("TRUNCATE"))) + ("adxy" pro nil (lib "adxy.pro" nil "Astrolib") "%s, hdr, a, d, x, y" (nil ("ALT") ("PRINT"))) + ("airtovac" pro nil (lib "airtovac.pro" nil "Astrolib") "%s, wave_air, wave_vac" (nil)) + ("aitoff" pro nil (lib "aitoff.pro" nil "Astrolib") "%s, l, b, x, y" (nil)) + ("AITOFF_GRID" pro nil (lib "aitoff_grid.pro" nil "Astrolib") "%s, DLONG, DLAT" (nil ("_EXTRA") ("CHARSIZE") ("CHARTHICK") ("FONT") ("LABEL") ("NEW"))) + ("altaz2hadec" pro nil (lib "altaz2hadec.pro" nil "Astrolib") "%s, alt, az, lat, ha, dec" (nil)) + ("aper" pro nil (lib "aper.pro" nil "Astrolib") "%s, image, xc, yc, mags, errap, sky, skyerr, phpadu, apr, skyradii, badpix" (nil ("CLIPSIG") ("CONVERGE_NUM") ("EXACT") ("FLUX") ("MAXITER") ("MEANBACK") ("MINSKY") ("Nan") ("PRINT") ("READNOISE") ("SETSKYVAL") ("SILENT"))) + ("arcbar" pro nil (lib "arcbar.pro" nil "Astrolib") "%s, hdr, arclen" (nil ("COLOR") ("DATA") ("FONT") ("LABEL") ("NORMAL") ("POSITION") ("SECONDS") ("SIZE") ("THICK"))) + ("arrows" pro nil (lib "arrows.pro" nil "Astrolib") "%s, h, xcen, ycen" (nil ("arrowlen") ("charsize") ("color") ("Data") ("font") ("Normal") ("NotVertex") ("thick"))) + ("asinh" fun nil (lib "asinh.pro" nil "Astrolib") "Result = %s(x)" (nil)) + ("AstDisp" pro nil (lib "astdisp.pro" nil "Astrolib") "%s, x, y, ra, dec, DN" (nil ("Coords") ("silent"))) + ("astro" pro nil (lib "astro.pro" nil "Astrolib") "%s, selection" (nil ("EQUINOX") ("FK4"))) + ("ASTROLIB" pro nil (lib "astrolib.pro" nil "Astrolib") "%s" (nil)) + ("AUTOHIST" pro nil (lib "autohist.pro" nil "Astrolib") "%s, V, ZX, ZY, XX, YY" (nil ("_EXTRA") ("NOPLOT"))) + ("AVG" fun nil (lib "avg.pro" nil "Astrolib") "Result = %s(ARRAY, DIMENSION)" (nil ("DOUBLE") ("NAN"))) + ("baryvel" pro nil (lib "baryvel.pro" nil "Astrolib") "%s, dje, deq, dvelh, dvelb" (nil ("JPL"))) + ("BIWEIGHT_MEAN" fun nil (lib "biweight_mean.pro" nil "Astrolib") "Result = %s(Y, SIGMA, WEIGHTs)" (nil)) + ("BLINK" pro nil (lib "blink.pro" nil "Astrolib") "%s, wndw, t" (nil)) + ("BLKSHIFT" pro nil (lib "blkshift.pro" nil "Astrolib") "%s, UNIT, POS0, DELTA0" (nil ("BUFFERSIZE") ("ERRMSG") ("NOZERO") ("TO"))) + ("BOOST_ARRAY" pro nil (lib "boost_array.pro" nil "Astrolib") "%s, DESTINATION, APPEND" (nil)) + ("boxave" fun nil (lib "boxave.pro" nil "Astrolib") "Result = %s(array, xsize, ysize)" (nil)) + ("Bprecess" pro nil (lib "bprecess.pro" nil "Astrolib") "%s, ra, dec, ra_1950, dec_1950" (nil ("EPOCH") ("MU_RADEC") ("PARALLAX") ("RAD_VEL"))) + ("BREAK_PATH" fun nil (lib "break_path.pro" nil "Astrolib") "Result = %s(PATHS)" (nil ("NOCURRENT"))) + ("Bsort" fun nil (lib "bsort.pro" nil "Astrolib") "Result = %s(Array, Asort)" (nil ("INFO") ("REVERSE"))) + ("calz_unred" pro nil (lib "calz_unred.pro" nil "Astrolib") "%s, wave, flux, ebv, funred" (nil ("R_V"))) + ("ccm_UNRED" pro nil (lib "ccm_unred.pro" nil "Astrolib") "%s, wave, flux, ebv, funred" (nil ("R_V"))) + ("check_FITS" pro nil (lib "check_fits.pro" nil "Astrolib") "%s, im, hdr, dimen, idltype" (nil ("ERRMSG") ("FITS") ("NOTYPE") ("SDAS") ("SILENT") ("UPDATE"))) + ("checksum32" pro nil (lib "checksum32.pro" nil "Astrolib") "%s, array, checksum" (nil ("FROM_IEEE") ("NOSAVE"))) + ("cic" fun nil (lib "cic.pro" nil "Astrolib") "Result = %s(value, posx, nx, posy, ny, posz, nz)" (nil ("AVERAGE") ("ISOLATED") ("NO_MESSAGE") ("WRAPAROUND"))) + ("cirrange" pro nil (lib "cirrange.pro" nil "Astrolib") "%s, ang" (nil ("RADIANS"))) + ("CleanPlot" pro nil (lib "cleanplot.pro" nil "Astrolib") "%s" (nil ("ShowOnly") ("silent"))) + ("cntrd" pro nil (lib "cntrd.pro" nil "Astrolib") "%s, img, x, y, xcen, ycen, fwhm" (nil ("DEBUG") ("EXTENDBOX") ("KeepCenter") ("SILENT"))) + ("co_aberration" pro nil (lib "co_aberration.pro" nil "Astrolib") "%s, jd, ra, dec, d_ra, d_dec" (nil ("eps"))) + ("co_nutate" pro nil (lib "co_nutate.pro" nil "Astrolib") "%s, jd, ra, dec, d_ra, d_dec" (nil ("d_eps") ("d_psi") ("eps"))) + ("co_refract_forward" fun nil (lib "co_refract.pro" nil "Astrolib") "Result = %s(a)" (nil ("P") ("T"))) + ("co_refract" fun nil (lib "co_refract.pro" nil "Astrolib") "Result = %s(a)" (nil ("altitude") ("epsilon") ("pressure") ("temperature") ("To_observed"))) + ("compare_struct" fun nil (lib "compare_struct.pro" nil "Astrolib") "Result = %s(struct_A, struct_B, Struct_Name)" (nil ("BRIEF") ("EXCEPT") ("FULL") ("NaN") ("RECUR_A") ("RECUR_B"))) + ("concat_dir" fun nil (lib "concat_dir.pro" nil "Astrolib") "Result = %s(dirname, filnam)" (nil)) + ("CONS_DEC" fun nil (lib "cons_dec.pro" nil "Astrolib") "Result = %s(DEC, X, ASTR, ALPHA)" (nil)) + ("CONS_RA" fun nil (lib "cons_ra.pro" nil "Astrolib") "Result = %s(RA, Y, ASTR, DELTA)" (nil)) + ("convolve" fun nil (lib "convolve.pro" nil "Astrolib") "Result = %s(image, psf)" (nil ("AUTO_CORRELATION") ("CORRELATE") ("FT_IMAGE") ("FT_PSF") ("NO_FT") ("NO_PAD"))) + ("copy_struct" pro nil (lib "copy_struct.pro" nil "Astrolib") "%s, struct_From, struct_To, NT_copied, Recur_Level" (nil ("EXCEPT_TAGS") ("RECUR_From") ("RECUR_TANDEM") ("RECUR_TO") ("SELECT_TAGS"))) + ("copy_struct_inx" pro nil (lib "copy_struct_inx.pro" nil "Astrolib") "%s, struct_From, struct_To, NT_copied, Recur_Level" (nil ("EXCEPT_TAGS") ("INDEX_From") ("INDEX_To") ("RECUR_From") ("RECUR_TANDEM") ("RECUR_To") ("SELECT_TAGS"))) + ("correl_images" fun nil (lib "correl_images.pro" nil "Astrolib") "Result = %s(image_A, image_B)" (nil ("MAGNIFICATION") ("MONITOR") ("NUMPIX") ("REDUCTION") ("XOFFSET_B") ("XSHIFT") ("YOFFSET_B") ("YSHIFT"))) + ("correl_optimize" pro nil (lib "correl_optimize.pro" nil "Astrolib") "%s, image_A, image_B, xoffset_optimum, yoffset_optimum" (nil ("MAGNIFICATION") ("MONITOR") ("NUMPIX") ("PLATEAU_TRESH") ("PRINT") ("XOFF_INIT") ("YOFF_INIT"))) + ("corrmat_analyze" pro nil (lib "corrmat_analyze.pro" nil "Astrolib") "%s, correl_mat, xoffset_optimum, yoffset_optimum, max_corr, edge, plateau" (nil ("MAGNIFICATION") ("PLATEAU_THRESH") ("PRINT") ("REDUCTION") ("XOFF_INIT") ("YOFF_INIT"))) + ("cosmo_param" pro nil (lib "cosmo_param.pro" nil "Astrolib") "%s, Omega_m, Omega_Lambda, Omega_k, q0" (nil)) + ("cr_reject" pro nil (lib "cr_reject.pro" nil "Astrolib") "%s, input_cube, rd_noise_dn, dark_dn, gain, mult_noise, combined_image, combined_noise, combined_npix" (nil ("BIAS") ("DFACTOR") ("DILATION") ("EXPTIME") ("INIT_MEAN") ("INIT_MED") ("INIT_MIN") ("INPUT_MASK") ("MASK_CUBE") ("MEAN_LOOP") ("MEDIAN_LOOP") ("MINIMUM_LOOP") ("NOCLEARMASK") ("NOISE_CUBE") ("NOSKYADJUST") ("NSIG") ("NULL_VALUE") ("RESTORE_SKY") ("SKYBOX") ("SKYVALS") ("TRACKING_SET") ("VERBOSE") ("WEIGHTING") ("XMEDSKY"))) + ("create_struct" pro nil (lib "create_struct.pro" nil "Astrolib") "%s, struct, strname, tagnames, tag_descript" (nil ("CHATTER") ("DIMEN") ("NODELETE"))) + ("cspline" fun nil (lib "cspline.pro" nil "Astrolib") "Result = %s(xx, yy, tt)" (nil ("Deriv"))) + ("CT2LST" pro nil (lib "ct2lst.pro" nil "Astrolib") "%s, lst, lng, tz, tme, day, mon, year" (nil)) + ("curs" pro nil (lib "curs.pro" nil "Astrolib") "%s, sel" (nil)) + ("curval" pro nil (lib "curval.pro" nil "Astrolib") "%s, hd, im" (nil ("ALT") ("Filename") ("OFFSET") ("ZOOM"))) + ("DAO_VALUE" fun nil (lib "dao_value.pro" nil "Astrolib") "Result = %s(XX, YY, GAUSS, PSF, DVDX, DVDY)" (nil)) + ("daoerf" pro nil (lib "daoerf.pro" nil "Astrolib") "%s, x, y, a, f, pder" (nil)) + ("DATE" fun nil (lib "date.pro" nil "Astrolib") "Result = %s(YEAR, DAY)" (nil)) + ("date_conv" fun nil (lib "date_conv.pro" nil "Astrolib") "Result = %s(date, type)" (nil ("BAD_DATE"))) + ("DAYCNV" pro nil (lib "daycnv.pro" nil "Astrolib") "%s, XJD, YR, MN, DAY, HR" (nil)) + ("DB_ENT2EXT" pro nil (lib "db_ent2ext.pro" nil "Astrolib") "%s, ENTRY" (nil)) + ("DB_ENT2HOST" pro nil (lib "db_ent2host.pro" nil "Astrolib") "%s, ENTRY, DBNO" (nil)) + ("db_info" fun nil (lib "db_info.pro" nil "Astrolib") "Result = %s(request, dbname)" (nil)) + ("db_item" pro nil (lib "db_item.pro" nil "Astrolib") "%s, items, itnum, ivalnum, idltype, sbyte, numvals, nbytes" (nil ("errmsg"))) + ("db_item_info" fun nil (lib "db_item_info.pro" nil "Astrolib") "Result = %s(request, itnums)" (nil)) + ("db_or" fun nil (lib "db_or.pro" nil "Astrolib") "Result = %s(list1, list2)" (nil)) + ("db_titles" pro nil (lib "db_titles.pro" nil "Astrolib") "%s, fnames, titles" (nil)) + ("dbbuild" pro nil (lib "dbbuild.pro" nil "Astrolib") "%s, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25, v26, v27, v28, v29, v30, v31, v32, v33, v34, v35, v36, v37, v38, v39, v40, v41, v42, v43, v44, v45, v46, v47, v48, v49, v50" (nil ("NOINDEX") ("SILENT") ("STATUS"))) + ("dbcircle" fun nil (lib "dbcircle.pro" nil "Astrolib") "Result = %s(ra_cen, dec_cen, radius, dis, sublist)" (nil ("COUNT") ("GALACTIC") ("SILENT") ("TO_B1950") ("TO_J2000"))) + ("dbclose" pro nil (lib "dbclose.pro" nil "Astrolib") "%s, dummy" (nil)) + ("dbcompare" pro nil (lib "dbcompare.pro" nil "Astrolib") "%s, list1, list2, items" (nil ("DIFF") ("TEXTOUT"))) + ("dbcreate" pro nil (lib "dbcreate.pro" nil "Astrolib") "%s, name, newindex, newdb, maxitems" (nil ("EXTERNAL") ("Maxentry"))) + ("dbdelete" pro nil (lib "dbdelete.pro" nil "Astrolib") "%s, list, name" (nil ("DEBUG"))) + ("widgetedit_event" pro nil (lib "dbedit.pro" nil "Astrolib") "%s, event" (nil)) + ("widedit" pro nil (lib "dbedit.pro" nil "Astrolib") "%s" (nil)) + ("dbedit" pro nil (lib "dbedit.pro" nil "Astrolib") "%s, list, items" (nil ("bytenum"))) + ("dbedit_basic" pro nil (lib "dbedit_basic.pro" nil "Astrolib") "%s, list, items" (nil)) + ("dbext" pro nil (lib "dbext.pro" nil "Astrolib") "%s, list, items, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12" (nil)) + ("dbext_dbf" pro nil (lib "dbext_dbf.pro" nil "Astrolib") "%s, list, dbno, sbyte, nbytes, idltype, nval, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18" (nil ("item_dbno"))) + ("dbext_ind" pro nil (lib "dbext_ind.pro" nil "Astrolib") "%s, list, item, dbno, values" (nil)) + ("dbfind" fun nil (lib "dbfind.pro" nil "Astrolib") "Result = %s(spar, listin)" (nil ("Count") ("errmsg") ("fullstring") ("SILENT"))) + ("dbfind_entry" pro nil (lib "dbfind_entry.pro" nil "Astrolib") "%s, type, svals, nentries, values" (nil ("Count"))) + ("dbfind_sort" pro nil (lib "dbfind_sort.pro" nil "Astrolib") "%s, it, type, svals, list" (nil ("COUNT") ("FULLSTRING"))) + ("dbfparse" pro nil (lib "dbfparse.pro" nil "Astrolib") "%s, spar, items, stype, values" (nil)) + ("dbget" fun nil (lib "dbget.pro" nil "Astrolib") "Result = %s(item, values, listin)" (nil ("Count") ("FULLSTRING") ("SILENT"))) + ("dbhelp" pro nil (lib "dbhelp.pro" nil "Astrolib") "%s, flag" (nil ("sort") ("TEXTOUT"))) + ("dbindex" pro nil (lib "dbindex.pro" nil "Astrolib") "%s, items" (nil)) + ("dbindex_blk" fun nil (lib "dbindex_blk.pro" nil "Astrolib") "Result = %s(unit, nb, bsz, ofb, dtype)" (nil)) + ("dbmatch" fun nil (lib "dbmatch.pro" nil "Astrolib") "Result = %s(item, values, listin)" (nil ("FULLSTRING"))) + ("dbopen" pro nil (lib "dbopen.pro" nil "Astrolib") "%s, name, update" (nil ("UNAVAIL"))) + ("dbprint" pro nil (lib "dbprint.pro" nil "Astrolib") "%s, list, items" (nil ("Adjustformat") ("FORMS") ("NoHeader") ("TEXTOUT"))) + ("dbput" pro nil (lib "dbput.pro" nil "Astrolib") "%s, item, val, entry" (nil)) + ("dbrd" pro nil (lib "dbrd.pro" nil "Astrolib") "%s, enum, entry, available, dbno" (nil ("noconvert"))) + ("dbsearch" pro nil (lib "dbsearch.pro" nil "Astrolib") "%s, type, svals, values, good" (nil ("COUNT") ("FULLSTRING"))) + ("dbsort" fun nil (lib "dbsort.pro" nil "Astrolib") "Result = %s(list, items)" (nil ("REVERSE"))) + ("dbtarget" fun nil (lib "dbtarget.pro" nil "Astrolib") "Result = %s(target, radius, sublist)" (nil ("DIS") ("SILENT") ("TO_B1950"))) + ("dbtitle" fun nil (lib "dbtitle.pro" nil "Astrolib") "Result = %s(c, f)" (nil)) + ("dbupdate" pro nil (lib "dbupdate.pro" nil "Astrolib") "%s, list, items, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14" (nil ("NOINDEX"))) + ("dbval" fun nil (lib "dbval.pro" nil "Astrolib") "Result = %s(entry, item)" (nil)) + ("dbwrt" pro nil (lib "dbwrt.pro" nil "Astrolib") "%s, entry, index, append" (nil ("noconvert"))) + ("dbxput" pro nil (lib "dbxput.pro" nil "Astrolib") "%s, val, entry, idltype, sbyte, nbytes" (nil)) + ("dbxval" fun nil (lib "dbxval.pro" nil "Astrolib") "Result = %s(entry, idltype, nvalues, sbyte, nbytes)" (nil ("bswap"))) + ("delvarx" pro nil (lib "delvarx.pro" nil "Astrolib") "%s, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9" (nil ("free_mem"))) + ("deredd" pro nil (lib "deredd.pro" nil "Astrolib") "%s, Eby, by, m1, c1, ub, by0, m0, c0, ub0" (nil ("update"))) + ("DETABIFY" fun nil (lib "detabify.pro" nil "Astrolib") "Result = %s(CHAR_STR)" (nil)) + ("dist_circle" pro nil (lib "dist_circle.pro" nil "Astrolib") "%s, im, n, xcen, ycen" (nil ("DOUBLE"))) + ("dist_ellipse" pro nil (lib "dist_ellipse.pro" nil "Astrolib") "%s, im, n, xc, yc, ratio, pos_ang" (nil ("DOUBLE"))) + ("eci2geo" fun nil (lib "eci2geo.pro" nil "Astrolib") "Result = %s(ECI_XYZ, JDtim)" (nil)) + ("eq2hor" pro nil (lib "eq2hor.pro" nil "Astrolib") "%s, ra, dec, jd, alt, az, ha" (nil ("_extra") ("aberration_") ("altitude") ("B1950") ("lat") ("lon") ("nutate_") ("obsname") ("precess_") ("refract_") ("verbose") ("WS"))) + ("eqpole" pro nil (lib "eqpole.pro" nil "Astrolib") "%s, l, b, x, y" (nil ("southpole"))) + ("EQPOLE_GRID" pro nil (lib "eqpole_grid.pro" nil "Astrolib") "%s, DLONG, DLAT" (nil ("_EXTRA") ("CHARSIZE") ("CHARTHICK") ("LABELS") ("NEW") ("SOUTHPOLE"))) + ("EULER" pro nil (lib "euler.pro" nil "Astrolib") "%s, AI, BI, AO, BO, SELECT" (nil ("FK4") ("RADIAN") ("SELECT"))) + ("expand_tilde" fun nil (lib "expand_tilde.pro" nil "Astrolib") "Result = %s(name)" (nil)) + ("extast" pro nil (lib "extast.pro" nil "Astrolib") "%s, hdr, astr, noparams" (nil ("alt"))) + ("extgrp" pro nil (lib "extgrp.pro" nil "Astrolib") "%s, hdr, par" (nil)) + ("f_format" fun nil (lib "f_format.pro" nil "Astrolib") "Result = %s(minval, maxval, factor, length)" (nil)) + ("al_legend" pro nil (lib "al_legend.pro" nil "Astrolib") "%s, items" (nil ("background_color") ("BOTTOM_LEGEND") ("BOX") ("BTHICK") ("CENTER_LEGEND") ("CHARSIZE") ("CHARTHICK") ("CLEAR") ("COLORS") ("CORNERS") ("DATA") ("DELIMITER") ("DEVICE") ("FILL") ("FONT") ("HELP") ("HORIZONTAL") ("LEFT_LEGEND") ("LINESTYLE") ("LINSIZE") ("MARGIN") ("NORMAL") ("NUMBER") ("OUTLINE_COLOR") ("POSITION") ("PSPACING") ("PSYM") ("RIGHT_LEGEND") ("SPACING") ("SYMSIZE") ("TEXTCOLORS") ("THICK") ("TOP_LEGEND") ("USERSYM") ("VECTORFONT") ("VERTICAL") ("WINDOW"))) + ("fdecomp" pro nil (lib "fdecomp.pro" nil "Astrolib") "%s, filename, disk, dir, name, qual, version" (nil ("OSfamily"))) + ("filter_image" fun nil (lib "filter_image.pro" nil "Astrolib") "Result = %s(image)" (nil ("ALL_PIXELS") ("FWHM_GAUSSIAN") ("ITERATE_SMOOTH") ("MEDIAN") ("NO_FT_CONVOL") ("PSF") ("SMOOTH"))) + ("find" pro nil (lib "find.pro" nil "Astrolib") "%s, image, x, y, flux, sharp, roundness, hmin, fwhm, roundlim, sharplim" (nil ("MONITOR") ("PRINT") ("SILENT"))) + ("FIND_ALL_DIR" fun nil (lib "find_all_dir.pro" nil "Astrolib") "Result = %s(PATH)" (nil ("PATH_FORMAT") ("PLUS_REQUIRED") ("RESET"))) + ("FIND_WITH_DEF" fun nil (lib "find_with_def.pro" nil "Astrolib") "Result = %s(FILENAME, PATHS, EXTENSIONS)" (nil ("NOCURRENT") ("RESET"))) + ("FindPro" pro nil (lib "findpro.pro" nil "Astrolib") "%s, Proc_Name" (nil ("DirList") ("NoPrint") ("ProList"))) + ("chisq_fitexy" fun nil (lib "fitexy.pro" nil "Astrolib") "Result = %s(B_angle)" (nil)) + ("fitexy" pro nil (lib "fitexy.pro" nil "Astrolib") "%s, x, y, A_intercept, B_slope, sigma_A_B, chi_sq, q" (nil ("TOLERANCE") ("X_SIGMA") ("Y_SIGMA"))) + ("fits_add_checksum" pro nil (lib "fits_add_checksum.pro" nil "Astrolib") "%s, hdr, im" (nil ("FROM_IEEE") ("no_timestamp"))) + ("fits_ascii_encode" fun nil (lib "fits_ascii_encode.pro" nil "Astrolib") "Result = %s(sum32)" (nil)) + ("fits_cd_fix" pro nil (lib "fits_cd_fix.pro" nil "Astrolib") "%s, hdr" (nil ("REVERSE"))) + ("fits_close" pro nil (lib "fits_close.pro" nil "Astrolib") "%s, fcb" (nil ("message") ("no_abort"))) + ("fits_help" pro nil (lib "fits_help.pro" nil "Astrolib") "%s, file_or_fcb" (nil)) + ("fits_info" pro nil (lib "fits_info.pro" nil "Astrolib") "%s, filename" (nil ("extname") ("N_ext") ("SILENT") ("TEXTOUT"))) + ("fits_open" pro nil (lib "fits_open.pro" nil "Astrolib") "%s, filename, fcb" (nil ("append") ("fpack") ("hprint") ("message") ("no_abort") ("update") ("write"))) + ("fits_read" pro nil (lib "fits_read.pro" nil "Astrolib") "%s, file_or_fcb, data, header, group_par" (nil ("data_only") ("enum") ("exten_no") ("extlevel") ("extname") ("extver") ("first") ("group") ("header_only") ("last") ("message") ("no_abort") ("no_pdu") ("no_unsigned") ("noscale") ("pdu") ("xtension"))) + ("fits_test_checksum" fun nil (lib "fits_test_checksum.pro" nil "Astrolib") "Result = %s(hdr, data)" (nil ("ERRMSG") ("FROM_IEEE"))) + ("fits_write" pro nil (lib "fits_write.pro" nil "Astrolib") "%s, file_or_fcb, data, header_in" (nil ("extlevel") ("extname") ("extver") ("header") ("message") ("no_abort") ("no_data") ("xtension"))) + ("fitsdir" pro nil (lib "fitsdir.pro" nil "Astrolib") "%s, directory" (nil ("alt1_keywords") ("alt2_keywords") ("alt3_keywords") ("exten") ("Keywords") ("nosize") ("NoTelescope") ("TEXTOUT"))) + ("FITSRGB_to_TIFF" pro nil (lib "fitsrgb_to_tiff.pro" nil "Astrolib") "%s, path, rgb_files, tiff_name" (nil ("BLUE") ("BY_PIXEL") ("GREEN") ("PREVIEW") ("RED"))) + ("flegendre" fun nil (lib "flegendre.pro" nil "Astrolib") "Result = %s(x, m)" (nil)) + ("flux2mag" fun nil (lib "flux2mag.pro" nil "Astrolib") "Result = %s(flux, zero_pt)" (nil ("ABwave"))) + ("fm_unred" pro nil (lib "fm_unred.pro" nil "Astrolib") "%s, wave, flux, ebv, funred" (nil ("avglmc") ("c1") ("c2") ("c3") ("c4") ("ExtCurve") ("gamma") ("lmc2") ("R_V") ("x0"))) + ("forprint" pro nil (lib "forprint.pro" nil "Astrolib") "%s, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18" (nil ("COMMENT") ("FORMAT") ("NoCOMMENT") ("NUMLINE") ("SILENT") ("STARTLINE") ("STDOUT") ("SUBSET") ("TEXTOUT") ("WIDTH"))) + ("frebin" fun nil (lib "frebin.pro" nil "Astrolib") "Result = %s(image, nsout, nlout)" (nil ("total"))) + ("ftab_delrow" pro nil (lib "ftab_delrow.pro" nil "Astrolib") "%s, filename, rows" (nil ("EXTEN_NO") ("NEWFILE"))) + ("ftab_ext" pro nil (lib "ftab_ext.pro" nil "Astrolib") "%s, file_or_fcb, columns, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25, v26, v27, v28, v29, v30, v31, v32, v33, v34, v35, v36, v37, v38, v39, v40, v41, v42, v43, v45, v46, v47, v48, v49, v50" (nil ("EXTEN_NO") ("ROWS"))) + ("ftab_help" pro nil (lib "ftab_help.pro" nil "Astrolib") "%s, file_or_fcb" (nil ("EXTEN_NO") ("TEXTOUT"))) + ("ftab_print" pro nil (lib "ftab_print.pro" nil "Astrolib") "%s, filename, columns, rows" (nil ("EXTEN_NO") ("FMT") ("num_header_lines") ("nval_per_line") ("TEXTOUT"))) + ("ftaddcol" pro nil (lib "ftaddcol.pro" nil "Astrolib") "%s, h, tab, name, idltype, tform, tunit, tscal, tzero, tnull" (nil)) + ("ftcreate" pro nil (lib "ftcreate.pro" nil "Astrolib") "%s, MAXCOLS, MAXROWS, H, TAB" (nil)) + ("ftdelcol" pro nil (lib "ftdelcol.pro" nil "Astrolib") "%s, h, tab, name" (nil)) + ("ftdelrow" pro nil (lib "ftdelrow.pro" nil "Astrolib") "%s, h, tab, rows" (nil)) + ("ftget" fun nil (lib "ftget.pro" nil "Astrolib") "Result = %s(hdr_or_ftstr, tab, field, rows, nulls)" (nil)) + ("fthelp" pro nil (lib "fthelp.pro" nil "Astrolib") "%s, h" (nil ("TEXTOUT"))) + ("fthmod" pro nil (lib "fthmod.pro" nil "Astrolib") "%s, h, field, parameter, value" (nil)) + ("ftinfo" pro nil (lib "ftinfo.pro" nil "Astrolib") "%s, h, ft_str" (nil ("Count"))) + ("ftkeeprow" pro nil (lib "ftkeeprow.pro" nil "Astrolib") "%s, h, tab, subs" (nil)) + ("ftprint" pro nil (lib "ftprint.pro" nil "Astrolib") "%s, h, tab, columns, rows" (nil ("textout"))) + ("ftput" pro nil (lib "ftput.pro" nil "Astrolib") "%s, h, tab, field, row, values, nulls" (nil)) + ("ftsize" pro nil (lib "ftsize.pro" nil "Astrolib") "%s, h, tab, ncols, nrows, tfields, ncols_all, nrows_all" (nil ("ERRMSG"))) + ("ftsort" pro nil (lib "ftsort.pro" nil "Astrolib") "%s, h, tab, hnew, tabnew, field" (nil ("reverse"))) + ("FXADDPAR_CONTPAR" pro nil (lib "fxaddpar.pro" nil "Astrolib") "%s, VALUE, CONTINUED" (nil)) + ("FXADDPAR_CONTWARN" pro nil (lib "fxaddpar.pro" nil "Astrolib") "%s, HEADER, NAME" (nil)) + ("FXADDPAR" pro nil (lib "fxaddpar.pro" nil "Astrolib") "%s, HEADER, NAME, VALUE, COMMENT" (nil ("AFTER") ("BEFORE") ("ERRMSG") ("FORMAT") ("NOCONTINUE") ("NOLOGICAL"))) + ("FXBADDCOL" pro nil (lib "fxbaddcol.pro" nil "Astrolib") "%s, INDEX, HEADER, ARRAY, TTYPE, COMMENT" (nil ("BIT") ("DCOMPLEX") ("ERRMSG") ("LOGICAL") ("NO_TDIM") ("TCUNI") ("TDELT") ("TDESC") ("TDISP") ("TDMAX") ("TDMIN") ("TNULL") ("TROTA") ("TRPIX") ("TRVAL") ("TSCAL") ("TUNIT") ("TZERO") ("VARIABLE"))) + ("FXBCLOSE" pro nil (lib "fxbclose.pro" nil "Astrolib") "%s, UNIT" (nil ("ERRMSG"))) + ("FXBCOLNUM" fun nil (lib "fxbcolnum.pro" nil "Astrolib") "Result = %s(UNIT, COL)" (nil ("ERRMSG"))) + ("FXBCREATE" pro nil (lib "fxbcreate.pro" nil "Astrolib") "%s, UNIT, FILENAME, HEADER, EXTENSION" (nil ("ERRMSG"))) + ("FXBDIMEN" fun nil (lib "fxbdimen.pro" nil "Astrolib") "Result = %s(UNIT, COL)" (nil ("ERRMSG"))) + ("FXBFIND" pro nil (lib "fxbfind.pro" nil "Astrolib") "%s, P1, KEYWORD, COLUMNS, VALUES, N_FOUND, DEFAULT" (nil ("COMMENTS"))) + ("FXBFINDLUN" fun nil (lib "fxbfindlun.pro" nil "Astrolib") "Result = %s(UNIT)" (nil)) + ("FXBFINISH" pro nil (lib "fxbfinish.pro" nil "Astrolib") "%s, UNIT" (nil ("ERRMSG"))) + ("FXBGROW" pro nil (lib "fxbgrow.pro" nil "Astrolib") "%s, UNIT, HEADER, NROWS" (nil ("BUFFERSIZE") ("ERRMSG") ("NOZERO"))) + ("FXBHEADER" fun nil (lib "fxbheader.pro" nil "Astrolib") "Result = %s(UNIT)" (nil)) + ("FXBHELP" pro nil (lib "fxbhelp.pro" nil "Astrolib") "%s, UNIT" (nil)) + ("FXBHMAKE" pro nil (lib "fxbhmake.pro" nil "Astrolib") "%s, HEADER, NROWS, EXTNAME, COMMENT" (nil ("DATE") ("ERRMSG") ("EXTLEVEL") ("EXTVER") ("INITIALIZE"))) + ("FXBISOPEN" fun nil (lib "fxbisopen.pro" nil "Astrolib") "Result = %s(UNIT)" (nil)) + ("FXBOPEN" pro nil (lib "fxbopen.pro" nil "Astrolib") "%s, UNIT, FILENAME0, EXTENSION, HEADER" (nil ("ACCESS") ("ERRMSG") ("NO_TDIM") ("REOPEN"))) + ("FXBPARSE" pro nil (lib "fxbparse.pro" nil "Astrolib") "%s, ILUN, HEADER" (nil ("ERRMSG") ("NO_TDIM"))) + ("FXBREAD" pro nil (lib "fxbread.pro" nil "Astrolib") "%s, UNIT, DATA, COL, ROW" (nil ("DIMENSIONS") ("ERRMSG") ("NANVALUE") ("NOIEEE") ("NOSCALE") ("VIRTUAL"))) + ("FXBREADM_CONV" pro nil (lib "fxbreadm.pro" nil "Astrolib") "%s, BB, DD, CTYPE, PERROW, NROWS" (nil ("DEFAULT_FLOAT") ("NANVALUE") ("NOIEEE") ("NOSCALE") ("TNULL_FLAG") ("TNULL_VALUE") ("TSCAL") ("TZERO") ("VARICOL"))) + ("FXBREADM" pro nil (lib "fxbreadm.pro" nil "Astrolib") "%s, UNIT, COL, D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, D10, D11, D12, D13, D14, D15, D16, D17, D18, D19, D20, D21, D22, D23, D24, D25, D26, D27, D28, D29, D30, D31, D32, D33, D34, D35, D36, D37, D38, D39, D40, D41, D42, D43, D44, D45, D46, D47" (nil ("BUFFERSIZE") ("DEFAULT_FLOAT") ("DIMENSIONS") ("ERRMSG") ("NANVALUE") ("NOIEEE") ("NOSCALE") ("PASS_METHOD") ("POINTERS") ("ROW") ("STATUS") ("VIRTUAL") ("WARNMSG"))) + ("FXBSTATE" fun nil (lib "fxbstate.pro" nil "Astrolib") "Result = %s(UNIT)" (nil)) + ("FXBTDIM" fun nil (lib "fxbtdim.pro" nil "Astrolib") "Result = %s(TDIM_KEYWORD)" (nil)) + ("FXBTFORM" pro nil (lib "fxbtform.pro" nil "Astrolib") "%s, HEADER, TBCOL, IDLTYPE, FORMAT, NUMVAL, MAXVAL" (nil ("ERRMSG"))) + ("FXBWRITE" pro nil (lib "fxbwrite.pro" nil "Astrolib") "%s, UNIT, DATA, COL, ROW" (nil ("BIT") ("ERRMSG") ("NANVALUE"))) + ("FXBWRITM" pro nil (lib "fxbwritm.pro" nil "Astrolib") "%s, UNIT, COL, D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, D10, D11, D12, D13, D14, D15, D16, D17, D18, D19, D20, D21, D22, D23, D24, D25, D26, D27, D28, D29, D30, D31, D32, D33, D34, D35, D36, D37, D38, D39, D40, D41, D42, D43, D44, D45, D46, D47, D48, D49" (nil ("BUFFERSIZE") ("ERRMSG") ("NANVALUE") ("NOIEEE") ("NOSCALE") ("PASS_METHOD") ("POINTERS") ("ROW") ("STATUS") ("WARNMSG"))) + ("FXFINDEND" pro nil (lib "fxfindend.pro" nil "Astrolib") "%s, UNIT, EXTENSION" (nil)) + ("FXHCLEAN" pro nil (lib "fxhclean.pro" nil "Astrolib") "%s, HEADER" (nil ("ERRMSG"))) + ("FXHMAKE" pro nil (lib "fxhmake.pro" nil "Astrolib") "%s, HEADER, DATA" (nil ("DATE") ("ERRMSG") ("EXTEND") ("INITIALIZE") ("XTENSION"))) + ("FXHMODIFY" pro nil (lib "fxhmodify.pro" nil "Astrolib") "%s, FILENAME, NAME, VALUE, COMMENT" (nil ("AFTER") ("BEFORE") ("ERRMSG") ("EXTENSION") ("FORMAT") ("NOGROW"))) + ("FXHREAD" pro nil (lib "fxhread.pro" nil "Astrolib") "%s, UNIT, HEADER, STATUS" (nil)) + ("FXMOVE" fun nil (lib "fxmove.pro" nil "Astrolib") "Result = %s(UNIT, EXTEN)" (nil ("ERRMSG") ("EXT_NO") ("SILENT"))) + ("FXPAR" fun nil (lib "fxpar.pro" nil "Astrolib") "Result = %s(HDR, NAME, ABORT)" (nil ("COMMENT") ("COUNT") ("DATATYPE") ("NOCONTINUE") ("POSTCHECK") ("PRECHECK") ("START"))) + ("FXPARPOS" fun nil (lib "fxparpos.pro" nil "Astrolib") "Result = %s(KEYWRD, IEND)" (nil ("AFTER") ("BEFORE"))) + ("FXPOSIT" fun nil (lib "fxposit.pro" nil "Astrolib") "Result = %s(XFILE, EXT_NO)" (nil ("COMPRESS") ("ERRMSG") ("EXTNUM") ("FPACK") ("HEADERONLY") ("LUNIT") ("NO_FPACK") ("readonly") ("SILENT") ("UNIXPIPE"))) + ("FXREAD" pro nil (lib "fxread.pro" nil "Astrolib") "%s, FILENAME, DATA, HEADER, P1, P2, P3, P4, P5" (nil ("AVERAGE") ("COMPRESS") ("ERRMSG") ("EXTENSION") ("NANVALUE") ("NODATA") ("NOSCALE") ("NOUPDATE") ("PROMPT") ("YSTEP"))) + ("FXWRITE" pro nil (lib "fxwrite.pro" nil "Astrolib") "%s, FILENAME, HEADER, DATA" (nil ("APPEND") ("ERRMSG") ("NANVALUE") ("NOUPDATE"))) + ("GAL_FLAT" fun nil (lib "gal_flat.pro" nil "Astrolib") "Result = %s(IMAGE, ANG, INC, CEN)" (nil ("INTERP"))) + ("gal_uvw" pro nil (lib "gal_uvw.pro" nil "Astrolib") "%s, u, v, w" (nil ("dec") ("distance") ("LSR") ("plx") ("pmdec") ("pmra") ("ra") ("vrad"))) + ("dtdz" fun nil (lib "galage.pro" nil "Astrolib") "Result = %s(z)" (nil ("lambda0") ("q0"))) + ("galage" fun nil (lib "galage.pro" nil "Astrolib") "Result = %s(z, zform)" (nil ("h0") ("k") ("lambda0") ("Omega_m") ("q0") ("SILENT"))) + ("gaussian" fun nil (lib "gaussian.pro" nil "Astrolib") "Result = %s(xi, parms, pderiv)" (nil ("DOUBLE"))) + ("gcirc" pro nil (lib "gcirc.pro" nil "Astrolib") "%s, u, ra1, dc1, ra2, dc2, dis" (nil)) + ("gcntrd" pro nil (lib "gcntrd.pro" nil "Astrolib") "%s, img, x, y, xcen, ycen, fwhm" (nil ("DEBUG") ("keepcenter") ("maxgood") ("SILENT"))) + ("geo2eci" fun nil (lib "geo2eci.pro" nil "Astrolib") "Result = %s(incoord, JDtim)" (nil)) + ("geo2geodetic" fun nil (lib "geo2geodetic.pro" nil "Astrolib") "Result = %s(gcoord)" (nil ("EQUATORIAL_RADIUS") ("PLANET") ("POLAR_RADIUS"))) + ("geo2mag" fun nil (lib "geo2mag.pro" nil "Astrolib") "Result = %s(incoord)" (nil)) + ("geodetic2geo" fun nil (lib "geodetic2geo.pro" nil "Astrolib") "Result = %s(ecoord)" (nil ("EQUATORIAL_RADIUS") ("PLANET") ("POLAR_RADIUS"))) + ("GET_COORDS" pro nil (lib "get_coords.pro" nil "Astrolib") "%s, Coords, PromptString, NumVals" (nil ("InString") ("Quiet"))) + ("get_date" pro nil (lib "get_date.pro" nil "Astrolib") "%s, dte, in_date" (nil ("OLD") ("TIMETAG"))) + ("GET_EQUINOX" fun nil (lib "get_equinox.pro" nil "Astrolib") "Result = %s(HDR, CODE)" (nil ("ALT"))) + ("get_juldate" pro nil (lib "get_juldate.pro" nil "Astrolib") "%s, jd" (nil)) + ("getopt" fun nil (lib "getopt.pro" nil "Astrolib") "Result = %s(input, type, numopt)" (nil ("count"))) + ("getpro" pro nil (lib "getpro.pro" nil "Astrolib") "%s, proc_name" (nil)) + ("getpsf" pro nil (lib "getpsf.pro" nil "Astrolib") "%s, image, xc, yc, apmag, sky, ronois, phpadu, gauss, psf, idpsf, psfrad, fitrad, psfname" (nil ("DEBUG"))) + ("getrot" pro nil (lib "getrot.pro" nil "Astrolib") "%s, hdr, rot, cdelt" (nil ("ALT") ("DEBUG") ("SILENT"))) + ("gettok" fun nil (lib "gettok.pro" nil "Astrolib") "Result = %s(st, char)" (nil ("exact") ("notrim"))) + ("RHOTHETA" fun nil (lib "rhotheta.pro" nil "Astrolib") "Result = %s(P, T, e, a, i, Omega, omega2, t2)" (nil)) + ("glactc" pro nil (lib "glactc.pro" nil "Astrolib") "%s, ra, dec, year, gl, gb, j" (nil ("degree") ("fk4") ("SuperGalactic"))) + ("glactc_pm" pro nil (lib "glactc_pm.pro" nil "Astrolib") "%s, ra, dec, mu_ra, mu_dec, year, gl, gb, mu_gl, mu_gb, j" (nil ("degree") ("fk4") ("mustar") ("SuperGalactic"))) + ("GROUP" pro nil (lib "group.pro" nil "Astrolib") "%s, X, Y, RCRIT, NGROUP" (nil)) + ("GSSS_StdAst" pro nil (lib "gsss_stdast.pro" nil "Astrolib") "%s, h, xpts, ypts" (nil)) + ("GSSSadxy" pro nil (lib "gsssadxy.pro" nil "Astrolib") "%s, gsa, ra, dec, x, y" (nil ("PRINT"))) + ("GSSSExtAst" pro nil (lib "gsssextast.pro" nil "Astrolib") "%s, h, astr, noparams" (nil)) + ("GSSSxyad" pro nil (lib "gsssxyad.pro" nil "Astrolib") "%s, gsa, xin, yin, ra, dec" (nil ("PRINT"))) + ("hadec2altaz" pro nil (lib "hadec2altaz.pro" nil "Astrolib") "%s, ha, dec, lat, alt, az" (nil ("WS"))) + ("hastrom" pro nil (lib "hastrom.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, refhd" (nil ("CUBIC") ("DEGREE") ("ERRMSG") ("INTERP") ("MISSING") ("NGRID") ("SILENT"))) + ("hboxave" pro nil (lib "hboxave.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, box" (nil ("ERRMSG"))) + ("hcongrid" pro nil (lib "hcongrid.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, newx, newy" (nil ("ALT") ("CUBIC") ("ERRMSG") ("HALF_HALF") ("INTERP") ("OUTSIZE"))) + ("HEADFITS" fun nil (lib "headfits.pro" nil "Astrolib") "Result = %s(filename)" (nil ("Compress") ("ERRMSG") ("EXTEN") ("SILENT"))) + ("HELIO" pro nil (lib "helio.pro" nil "Astrolib") "%s, JD, LIST, HRAD, HLONG, HLAT" (nil ("RADIAN"))) + ("helio_jd" fun nil (lib "helio_jd.pro" nil "Astrolib") "Result = %s(date, ra, dec)" (nil ("B1950") ("TIME_DIFF"))) + ("helio_rv" fun nil (lib "helio_rv.pro" nil "Astrolib") "Result = %s(HJD, T, P, V0, K, e, omega)" (nil)) + ("hermite" fun nil (lib "hermite.pro" nil "Astrolib") "Result = %s(xx, ff, x)" (nil ("FDERIV"))) + ("heuler" pro nil (lib "heuler.pro" nil "Astrolib") "%s, h_or_astr" (nil ("alt_in") ("alt_out") ("celestial") ("ecliptic") ("Galactic"))) + ("hextract" pro nil (lib "hextract.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, x0, x1, y0, y1" (nil ("ALT") ("ERRMSG") ("SILENT"))) + ("hgrep" pro nil (lib "hgrep.pro" nil "Astrolib") "%s, header, substring" (nil ("keepcase") ("linenum"))) + ("HISTOGAUSS" pro nil (lib "histogauss.pro" nil "Astrolib") "%s, SAMPLE, A, XX, YY, GX, GY" (nil ("_EXTRA") ("CHARSIZE") ("FONT") ("NOFIT") ("NOPLOT") ("Window"))) + ("hor2eq" pro nil (lib "hor2eq.pro" nil "Astrolib") "%s, alt, az, jd, ra, dec, ha" (nil ("_extra") ("aberration_") ("altitude") ("B1950") ("lat") ("lon") ("nutate_") ("obsname") ("precess_") ("refract_") ("verbose") ("WS"))) + ("host_to_ieee" pro nil (lib "host_to_ieee.pro" nil "Astrolib") "%s, data" (nil ("IDLTYPE"))) + ("HPRECESS" pro nil (lib "hprecess.pro" nil "Astrolib") "%s, HDR, YEARF" (nil)) + ("hprint" pro nil (lib "hprint.pro" nil "Astrolib") "%s, h, firstline" (nil)) + ("hrebin" pro nil (lib "hrebin.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, newx, newy" (nil ("ALT") ("ERRMSG") ("OUTSIZE") ("SAMPLE"))) + ("hreverse" pro nil (lib "hreverse.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, subs" (nil ("ERRMSG") ("SILENT"))) + ("hrot" pro nil (lib "hrot.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, angle, xc, yc, int" (nil ("CUBIC") ("ERRMSG") ("INTERP") ("MISSING") ("PIVOT"))) + ("hrotate" pro nil (lib "hrotate.pro" nil "Astrolib") "%s, oldim, oldhd, newim, newhd, direction" (nil ("ERRMSG"))) + ("ieee_to_host" pro nil (lib "ieee_to_host.pro" nil "Astrolib") "%s, data" (nil ("IDLTYPE"))) + ("imcontour" pro nil (lib "imcontour.pro" nil "Astrolib") "%s, im, hdr" (nil ("_EXTRA") ("NOerase") ("OVERLAY") ("PUTINFO") ("SUBTITLE") ("TYPE") ("window") ("XDELTA") ("XMID") ("XTITLE") ("YDELTA") ("YMID") ("YTITLE"))) + ("imdbase" pro nil (lib "imdbase.pro" nil "Astrolib") "%s, hdr, catalogue, list" (nil ("ALT") ("SILENT") ("SUBLIST") ("XPOS") ("XRANGE") ("YPOS") ("YRANGE"))) + ("imf" fun nil (lib "imf.pro" nil "Astrolib") "Result = %s(mass, expon, mass_range)" (nil)) + ("imlist" pro nil (lib "imlist.pro" nil "Astrolib") "%s, image, xc, yc" (nil ("DESCRIP") ("DX") ("DY") ("OFFSET") ("TEXTOUT") ("WIDTH"))) + ("irafdir" pro nil (lib "irafdir.pro" nil "Astrolib") "%s, directory" (nil ("TEXTOUT"))) + ("irafrd" pro nil (lib "irafrd.pro" nil "Astrolib") "%s, im, hd, filename" (nil ("SILENT"))) + ("irafwrt" pro nil (lib "irafwrt.pro" nil "Astrolib") "%s, image, hd, filename" (nil ("PIXDIR"))) + ("is_ieee_big" fun nil (lib "is_ieee_big.pro" nil "Astrolib") "Result = %s" (nil)) + ("GETWRD" fun nil (lib "getwrd.pro" nil "Astrolib") "Result = %s(TXTSTR, NTH, MTH)" (nil ("delimiter") ("help") ("last") ("location") ("notrim") ("nwords"))) + ("ismeuv" fun nil (lib "ismeuv.pro" nil "Astrolib") "Result = %s(wave, Hcol, HeIcol, HeIIcol)" (nil ("Fano"))) + ("JDCNV" pro nil (lib "jdcnv.pro" nil "Astrolib") "%s, YR, MN, DAY, HR, JULIAN" (nil)) + ("jplephinterp_calc" pro nil (lib "jplephinterp.pro" nil "Astrolib") "%s, info, raw, obj, t, x, y, z, vx, vy, vz" (nil ("tbase") ("velocity"))) + ("jplephinterp_denew" pro nil (lib "jplephinterp.pro" nil "Astrolib") "%s, info, raw, obj, t, x, y, z, vx, vy, vz" (nil ("tbase") ("velocity"))) + ("jplephinterp" pro nil (lib "jplephinterp.pro" nil "Astrolib") "%s, info, raw, t, x, y, z, vx, vy, vz" (nil ("center") ("decode_obj") ("earth") ("objectname") ("pos_vel_factor") ("posunits") ("sun") ("tbase") ("velocity") ("velunits") ("xobjnum"))) + ("jplephpar" fun nil (lib "jplephread.pro" nil "Astrolib") "Result = %s(header, parname)" (nil ("default") ("fatal"))) + ("jplephval" fun nil (lib "jplephread.pro" nil "Astrolib") "Result = %s(names, values, name)" (nil ("default") ("fatal"))) + ("jplephread" pro nil (lib "jplephread.pro" nil "Astrolib") "%s, filename, info, raw, jdlimits" (nil ("errmsg") ("status"))) + ("jplephtest" pro nil (lib "jplephtest.pro" nil "Astrolib") "%s, ephfile, testfile" (nil ("pause"))) + ("jprecess" pro nil (lib "jprecess.pro" nil "Astrolib") "%s, ra, dec, ra_2000, dec_2000" (nil ("EPOCH") ("MU_RADEC") ("PARALLAX") ("RAD_VEL"))) + ("JULDATE" pro nil (lib "juldate.pro" nil "Astrolib") "%s, DATE, JD" (nil ("PROMPT"))) + ("ksone" pro nil (lib "ksone.pro" nil "Astrolib") "%s, data, func_name, d, prob" (nil ("_EXTRA") ("PLOT") ("Window"))) + ("kstwo" pro nil (lib "kstwo.pro" nil "Astrolib") "%s, data1, data2, D, prob" (nil)) + ("kuiperone" pro nil (lib "kuiperone.pro" nil "Astrolib") "%s, data, func_name, d, prob" (nil ("_EXTRA") ("PLOT") ("WINDOW"))) + ("kuipertwo" pro nil (lib "kuipertwo.pro" nil "Astrolib") "%s, data1, data2, D, prob" (nil ("_EXTRA") ("PLOT") ("WINDOW"))) + ("PERMUTE" fun nil (lib "permute.pro" nil "Astrolib") "Result = %s(N, Seed)" (nil)) + ("isarray" fun nil (lib "isarray.pro" nil "Astrolib") "Result = %s(a)" (nil ("help"))) + ("lineid_plot" pro nil (lib "lineid_plot.pro" nil "Astrolib") "%s, wave, flux, wline, text1, text2" (nil ("_EXTRA") ("extend") ("lcharsize") ("lcharthick") ("window"))) + ("linmix_atanh" fun nil (lib "linmix_err.pro" nil "Astrolib") "Result = %s(x)" (nil)) + ("linmix_robsig" fun nil (lib "linmix_err.pro" nil "Astrolib") "Result = %s(x)" (nil)) + ("loglik_mixerr" fun nil (lib "linmix_err.pro" nil "Astrolib") "Result = %s(x, y, xvar, yvar, xycov, delta, theta, pi, mu, tausqr, Glabel)" (nil)) + ("logprior_mixerr" fun nil (lib "linmix_err.pro" nil "Astrolib") "Result = %s(mu, mu0, tausqr, usqr, wsqr)" (nil)) + ("linmix_metro_update" fun nil (lib "linmix_err.pro" nil "Astrolib") "Result = %s(logpost_new, logpost_old, seed, log_jrat)" (nil)) + ("linmix_metro_results" pro nil (lib "linmix_err.pro" nil "Astrolib") "%s, arate, ngauss" (nil)) + ("linmix_err" pro nil (lib "linmix_err.pro" nil "Astrolib") "%s, x, y, post" (nil ("delta") ("maxiter") ("metro") ("miniter") ("ngauss") ("silent") ("xsig") ("xycov") ("ysig"))) + ("linterp" pro nil (lib "linterp.pro" nil "Astrolib") "%s, Xtab, Ytab, Xint, Yint" (nil ("MISSING") ("NoInterp"))) + ("LIST_WITH_PATH" fun nil (lib "list_with_path.pro" nil "Astrolib") "Result = %s(FILENAME, PATHS)" (nil ("COUNT") ("NOCURRENT"))) + ("lsf_rotate" fun nil (lib "lsf_rotate.pro" nil "Astrolib") "Result = %s(deltav, vsini)" (nil ("EPSILON") ("VELGRID"))) + ("ldist" fun nil (lib "lumdist.pro" nil "Astrolib") "Result = %s(z)" (nil ("lambda0") ("q0"))) + ("lumdist" fun nil (lib "lumdist.pro" nil "Astrolib") "Result = %s(z)" (nil ("h0") ("k") ("Lambda0") ("Omega_m") ("q0") ("Silent"))) + ("mag2flux" fun nil (lib "mag2flux.pro" nil "Astrolib") "Result = %s(mag, zero_pt)" (nil ("ABwave"))) + ("mag2geo" fun nil (lib "mag2geo.pro" nil "Astrolib") "Result = %s(incoord)" (nil)) + ("make_2d" pro nil (lib "make_2d.pro" nil "Astrolib") "%s, x, y, xx, yy" (nil)) + ("make_astr" pro nil (lib "make_astr.pro" nil "Astrolib") "%s, astr" (nil ("AXES") ("CD") ("CRPIX") ("CRVAL") ("CTYPE") ("DATE_OBS") ("DELTA") ("EQUINOX") ("LATPOLE") ("LONGPOLE") ("MJD_OBS") ("NAXIS") ("pv1") ("PV2") ("RADECSYS"))) + ("match" pro nil (lib "match.pro" nil "Astrolib") "%s, a, b, suba, subb" (nil ("COUNT") ("epsilon") ("SORT"))) + ("match2" pro nil (lib "match2.pro" nil "Astrolib") "%s, a, b, suba, subb" (nil)) + ("max_entropy" pro nil (lib "max_entropy.pro" nil "Astrolib") "%s, data, psf, deconv, multipliers" (nil ("FT_PSF") ("LINEAR") ("LOGMIN") ("NO_FT") ("RE_CONVOL_IMAGE"))) + ("Max_Likelihood" pro nil (lib "max_likelihood.pro" nil "Astrolib") "%s, data, psf, deconv, Re_conv" (nil ("FT_PSF") ("GAUSSIAN") ("NO_FT") ("POSITIVITY_EPS") ("UNDERFLOW_ZERO"))) + ("MEANCLIP" pro nil (lib "meanclip.pro" nil "Astrolib") "%s, Image, Mean, Sigma" (nil ("CLIPSIG") ("CONVERGE_NUM") ("DOUBLE") ("MAXITER") ("SUBS") ("VERBOSE"))) + ("medarr" pro nil (lib "medarr.pro" nil "Astrolib") "%s, inarr, outarr, mask, output_mask" (nil)) + ("MEDSMOOTH" fun nil (lib "medsmooth.pro" nil "Astrolib") "Result = %s(ARRAY, WINDOW)" (nil)) + ("minF_bracket" pro nil (lib "minf_bracket.pro" nil "Astrolib") "%s, xa, xb, xc, fa, fb, fc" (nil ("DIRECTION") ("FUNC_NAME") ("POINT_NDIM"))) + ("minF_conj_grad" pro nil (lib "minf_conj_grad.pro" nil "Astrolib") "%s, p_min, f_min, conv_factor" (nil ("FUNC_NAME") ("INITIALIZE") ("QUADRATIC") ("TOLERANCE") ("USE_DERIV"))) + ("call_func_deriv" fun nil (lib "minf_parabol_d.pro" nil "Astrolib") "Result = %s(func_name, x, deriv)" (nil ("DIRECTION") ("POINT_NDIM"))) + ("minF_parabol_D" pro nil (lib "minf_parabol_d.pro" nil "Astrolib") "%s, xa, xb, xc, xmin, fmin" (nil ("DIRECTION") ("FUNC_NAME") ("MAX_ITERATIONS") ("POINT_NDIM") ("TOLERANCE"))) + ("minF_parabolic" pro nil (lib "minf_parabolic.pro" nil "Astrolib") "%s, xa, xb, xc, xmin, fmin" (nil ("DIRECTION") ("FUNC_NAME") ("MAX_ITERATIONS") ("POINT_NDIM") ("TOLERANCE"))) + ("minmax" fun nil (lib "minmax.pro" nil "Astrolib") "Result = %s(array, subs)" (nil ("DIMEN") ("NAN"))) + ("mkhdr" pro nil (lib "mkhdr.pro" nil "Astrolib") "%s, header, im, naxisx" (nil ("EXTEND") ("IMAGE"))) + ("mlinmix_chol_invert" fun nil (lib "mlinmix_err.pro" nil "Astrolib") "Result = %s(L)" (nil)) + ("mlinmix_posdef_invert" pro nil (lib "mlinmix_err.pro" nil "Astrolib") "%s, A" (nil)) + ("mlinmix_err" pro nil (lib "mlinmix_err.pro" nil "Astrolib") "%s, x, y, post" (nil ("delta") ("maxiter") ("miniter") ("ngauss") ("silent") ("xvar") ("xycov") ("yvar"))) + ("mmm" pro nil (lib "mmm.pro" nil "Astrolib") "%s, sky_vector, skymod, sigma, skew" (nil ("DEBUG") ("HIGHBAD") ("INTEGER") ("MAXITER") ("MINSKY") ("Nsky") ("ReadNoise") ("SILENT"))) + ("MODFITS" pro nil (lib "modfits.pro" nil "Astrolib") "%s, filename, data, header" (nil ("ERRMSG") ("EXTEN_NO") ("EXTNAME"))) + ("month_cnv" fun nil (lib "month_cnv.pro" nil "Astrolib") "Result = %s(MonthInput)" (nil ("Low") ("Short") ("Up"))) + ("MOONPOS" pro nil (lib "moonpos.pro" nil "Astrolib") "%s, jd, ra, dec, dis, geolong, geolat" (nil ("RADIAN"))) + ("mphase" pro nil (lib "mphase.pro" nil "Astrolib") "%s, jd, k" (nil)) + ("mrandomn" fun nil (lib "mrandomn.pro" nil "Astrolib") "Result = %s(seed, covar, nrand)" (nil ("STATUS"))) + ("mrd_hread" pro nil (lib "mrd_hread.pro" nil "Astrolib") "%s, unit, header, status" (nil ("ERRMSG") ("FIRSTBLOCK") ("NO_BADHEADER") ("SILENT") ("SKIPDATA"))) + ("mrd_skip" pro nil (lib "mrd_skip.pro" nil "Astrolib") "%s, unit, nskip" (nil)) + ("mrd_struct" fun nil (lib "mrd_struct.pro" nil "Astrolib") "Result = %s(names, values, nrow)" (nil ("no_execute") ("old_struct") ("silent") ("structyp") ("tempdir"))) + ("mrd_fxpar" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, hdr, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets" (nil)) + ("mrd_dofn" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(name, index, use_colnum)" (nil ("alias"))) + ("mrd_doff" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, form, dim, type" (nil)) + ("mrd_chkfn" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(name, namelist, index)" (nil ("silent"))) + ("mrd_unsigned_offset" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(type)" (nil)) + ("mrd_chkunsigned" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(bitpix, scale, zero)" (nil ("unsigned"))) + ("mrd_unsignedtype" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(data)" (nil)) + ("mrd_version" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s" (nil)) + ("mrd_atype" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, form, type, slen" (nil)) + ("mrd_read_ascii" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, unit, range, nbytes, nrows, nfld, typarr, posarr, lenarr, nullarr, table" (nil ("old_struct") ("rows"))) + ("mrd_ascii" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, header, structyp, use_colnum, range, table, nbytes, nrows, nfld, typarr, posarr, lenarr, nullarr, fnames, fvalues, scales, offsets, scaling, status" (nil ("alias") ("columns") ("outalias") ("rows") ("silent"))) + ("mrd_columns" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, table, columns, fnames, fvalues, vcls, vtpes, scales, offsets, scaling" (nil ("silent") ("structyp"))) + ("mrd_read_image" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, unit, range, maxd, rsize, table" (nil ("rows") ("status") ("unixpipe"))) + ("mrd_axes_trunc" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, naxis, dims, silent" (nil)) + ("mrd_image" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, header, range, maxd, rsize, table, scales, offsets, scaling, status" (nil ("rows") ("silent") ("unsigned"))) + ("mrd_ptrscale" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, array, scale, offset" (nil)) + ("mrd_string" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, table, header, typarr, fnames, fvalues, nrec" (nil ("silent") ("structyp"))) + ("mrd_scale" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, type, scales, offsets, table, header, fnames, fvalues, nrec" (nil ("dscale") ("silent") ("structyp"))) + ("mrd_varcolumn" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, vtype, array, heap, off, siz" (nil)) + ("mrd_fixcolumn" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, vtype, array, heap, off, siz" (nil)) + ("mrd_read_heap" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, unit, header, range, fnames, fvalues, vcls, vtpes, table, structyp, scaling, scales, offsets, status" (nil ("columns") ("fixed_var") ("pointer_var") ("rows") ("silent"))) + ("mrd_read_table" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, unit, range, rsize, structyp, nrows, nfld, typarr, table" (nil ("rows") ("unixpipe"))) + ("mrd_tdim" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, header, index, flen, arrstr" (nil ("no_tdim"))) + ("mrd_table" pro nil (lib "mrdfits.pro" nil "Astrolib") "%s, header, structyp, use_colnum, range, rsize, table, nrows, nfld, typarr, fnames, fvalues, vcls, vtpes, scales, offsets, scaling, status" (nil ("alias") ("columns") ("emptystring") ("no_tdim") ("outalias") ("rows") ("silent") ("unsigned"))) + ("mrdfits" fun nil (lib "mrdfits.pro" nil "Astrolib") "Result = %s(file, extension, header)" (nil ("alias") ("columns") ("compress") ("dscale") ("emptystring") ("error_action") ("extnum") ("fixed_var") ("fpack") ("fscale") ("no_fpack") ("no_tdim") ("outalias") ("pointer_var") ("range") ("rows") ("silent") ("status") ("structyp") ("unsigned") ("use_colnum") ("version"))) + ("multinom" fun nil (lib "multinom.pro" nil "Astrolib") "Result = %s(n, p, nrand)" (nil ("seed"))) + ("multiplot" pro nil (lib "multiplot.pro" nil "Astrolib") "%s, pmulti" (nil ("default") ("doxaxis") ("doyaxis") ("gap") ("help") ("initialize") ("mtitle") ("mTitOffset") ("mTitSize") ("mxTitle") ("mxTitOffset") ("mxTitSize") ("myTitle") ("myTitOffset") ("myTitSize") ("reset") ("rowmajor") ("square") ("verbose") ("xgap") ("xtickformat") ("ygap") ("ytickformat"))) + ("mwr_version" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s" (nil)) + ("mwr_unsigned_offset" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s(type)" (nil)) + ("chk_and_upd" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, header, key, value, comment" (nil ("nological"))) + ("mwr_checktype" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s(tag)" (nil ("alias"))) + ("mwr_ascii" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, input, siz, lun, bof, header" (nil ("alias") ("ascii") ("bscale") ("iscale") ("lscale") ("no_comment") ("no_types") ("null") ("separator") ("silent") ("terminator") ("use_colnum"))) + ("mwr_dummy" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, lun" (nil)) + ("mwr_validptr" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s(vtypes, nfld, index, array)" (nil)) + ("mwr_tablehdr" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, lun, input, header, vtypes" (nil ("alias") ("bit_cols") ("logical_cols") ("nbit_cols") ("no_comment") ("no_types") ("silent") ("use_colnum"))) + ("mwr_retable" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s(input, vtypes)" (nil)) + ("mwr_writeheap" fun nil (lib "mwrfits.pro" nil "Astrolib") "Result = %s(lun, vtypes)" (nil)) + ("mwr_tabledat" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, lun, input, header, vtypes" (nil)) + ("mwr_pscale" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, grp, header" (nil ("pscale") ("pzero"))) + ("mwr_findscale" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, flag, array, nbits, scale, offset, error" (nil)) + ("mwr_scale" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, array, scale, offset" (nil ("bscale") ("iscale") ("lscale") ("null"))) + ("mwr_header" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, lun, header" (nil)) + ("mwr_groupinfix" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, data, group, hdr" (nil)) + ("mwr_groupscale" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, maxval, group, hdr" (nil)) + ("mwr_image" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, input, siz, lun, bof, hdr" (nil ("bscale") ("group") ("iscale") ("lscale") ("no_comment") ("null") ("pscale") ("pzero") ("silent"))) + ("mwrfits" pro nil (lib "mwrfits.pro" nil "Astrolib") "%s, xinput, file, header" (nil ("alias") ("ascii") ("bit_cols") ("bscale") ("create") ("group") ("iscale") ("logical_cols") ("lscale") ("nbit_cols") ("no_comment") ("no_copy") ("no_types") ("null") ("pscale") ("pzero") ("separator") ("silent") ("status") ("terminator") ("use_colnum") ("version"))) + ("N_bytes" fun nil (lib "n_bytes.pro" nil "Astrolib") "Result = %s(a)" (nil)) + ("ngp" fun nil (lib "ngp.pro" nil "Astrolib") "Result = %s(value, posx, nx, posy, ny, posz, nz)" (nil ("AVERAGE") ("NO_MESSAGE") ("WRAPAROUND"))) + ("nint" fun nil (lib "nint.pro" nil "Astrolib") "Result = %s(x)" (nil ("LONG"))) + ("nstar" pro nil (lib "nstar.pro" nil "Astrolib") "%s, image, id, xc, yc, mags, sky, group, phpadu, readns, psfname, errmag, iter, chisq, peak" (nil ("DEBUG") ("PRINT") ("SILENT") ("VARSKY"))) + ("nulltrim" fun nil (lib "nulltrim.pro" nil "Astrolib") "Result = %s(st)" (nil)) + ("nutate" pro nil (lib "nutate.pro" nil "Astrolib") "%s, jd, nut_long, nut_obliq" (nil)) + ("observatory" pro nil (lib "observatory.pro" nil "Astrolib") "%s, obsname, obs_struct" (nil ("print"))) + ("one_arrow" pro nil (lib "one_arrow.pro" nil "Astrolib") "%s, xcen, ycen, angle, label" (nil ("arrowsize") ("charsize") ("color") ("data") ("font") ("linestyle") ("normal") ("thick"))) + ("one_ray" pro nil (lib "one_ray.pro" nil "Astrolib") "%s, xcen, ycen, len, angle, terminus" (nil ("_EXTRA") ("data") ("nodraw") ("normal"))) + ("oploterror" pro nil (lib "oploterror.pro" nil "Astrolib") "%s, x, y, xerr, yerr" (nil ("_EXTRA") ("ADDCMD") ("ERRCOLOR") ("ERRSTYLE") ("ERRTHICK") ("HATLENGTH") ("HIBAR") ("LOBAR") ("NOCLIP") ("NOHAT") ("NSKIP") ("Nsum") ("THICK") ("WINDOW"))) + ("ordinal" fun nil (lib "ordinal.pro" nil "Astrolib") "Result = %s(num)" (nil)) + ("partvelvec" pro nil (lib "partvelvec.pro" nil "Astrolib") "%s, velx, vely, posx, posy, x, y" (nil ("_EXTRA") ("COLOR") ("FRACTION") ("LENGTH") ("NOCLIP") ("OVER") ("VECCOLORS") ("WINDOW"))) + ("PCA" pro nil (lib "pca.pro" nil "Astrolib") "%s, data, eigenval, eigenvect, percentages, proj_obj, proj_atr" (nil ("COVARIANCE") ("MATRIX") ("SILENT") ("SSQ") ("TEXTOUT"))) + ("pent" fun nil (lib "pent.pro" nil "Astrolib") "Result = %s(p, t, x, m, n)" (nil)) + ("pixcolor" pro nil (lib "pixcolor.pro" nil "Astrolib") "%s, pix_value, color" (nil)) + ("Arc" fun nil (lib "pixwt.pro" nil "Astrolib") "Result = %s(x, y0, y1, r)" (nil)) + ("Chord" fun nil (lib "pixwt.pro" nil "Astrolib") "Result = %s(x, y0, y1)" (nil)) + ("Oneside" fun nil (lib "pixwt.pro" nil "Astrolib") "Result = %s(x, y0, y1, r)" (nil)) + ("Intarea" fun nil (lib "pixwt.pro" nil "Astrolib") "Result = %s(xc, yc, r, x0, x1, y0, y1)" (nil)) + ("Pixwt" fun nil (lib "pixwt.pro" nil "Astrolib") "Result = %s(xc, yc, r, x, y)" (nil)) + ("pkfit" pro nil (lib "pkfit.pro" nil "Astrolib") "%s, f, scale, x, y, sky, radius, ronois, phpadu, gauss, psf, errmag, chi, sharp, niter" (nil ("DEBUG"))) + ("planck" fun nil (lib "planck.pro" nil "Astrolib") "Result = %s(wave, temp)" (nil)) + ("planet_coords" pro nil (lib "planet_coords.pro" nil "Astrolib") "%s, date, ra, dec" (nil ("jd") ("jpl") ("planet"))) + ("ploterror" pro nil (lib "ploterror.pro" nil "Astrolib") "%s, x, y, xerr, yerr" (nil ("_EXTRA") ("ERRCOLOR") ("ERRSTYLE") ("ERRTHICK") ("HATLENGTH") ("NOCLIP") ("NOHAT") ("NSKIP") ("NSUM") ("TYPE") ("WINDOW") ("XLOG") ("XRANGE") ("YLOG") ("YRANGE"))) + ("plothist" pro nil (lib "plothist.pro" nil "Astrolib") "%s, arr, xhist, yhist" (nil ("_EXTRA") ("AUTOBin") ("axiscolor") ("BIN") ("Boxplot") ("Color") ("FCOLOR") ("Fill") ("FLINE") ("FORIENTATION") ("FPATTERN") ("FSPACING") ("FTHICK") ("Halfbin") ("LINESTYLE") ("NAN") ("NOPLOT") ("OVERPLOT") ("Peak") ("PSYM") ("rotate") ("THICK") ("WINDOW") ("xlog") ("XSTYLE") ("ylog") ("yrange") ("YSTYLE"))) + ("plotsym" pro nil (lib "plotsym.pro" nil "Astrolib") "%s, psym, psize" (nil ("Color") ("FILL") ("thick"))) + ("poidev" fun nil (lib "poidev.pro" nil "Astrolib") "Result = %s(xm)" (nil ("SEED"))) + ("polint" pro nil (lib "polint.pro" nil "Astrolib") "%s, xa, ya, x, y, dy" (nil)) + ("POLREC" pro nil (lib "polrec.pro" nil "Astrolib") "%s, R, A, X, Y" (nil ("degrees") ("help"))) + ("poly_smooth" fun nil (lib "poly_smooth.pro" nil "Astrolib") "Result = %s(data, width)" (nil ("COEFFICIENTS") ("DEGREE") ("DERIV_ORDER") ("NLEFT") ("NRIGHT"))) + ("polyleg" fun nil (lib "polyleg.pro" nil "Astrolib") "Result = %s(x, coeff)" (nil)) + ("POSANG" pro nil (lib "posang.pro" nil "Astrolib") "%s, u, ra1, dc1, ra2, dc2, angle" (nil)) + ("positivity" fun nil (lib "positivity.pro" nil "Astrolib") "Result = %s(x)" (nil ("DERIVATIVE") ("EPSILON"))) + ("precess" pro nil (lib "precess.pro" nil "Astrolib") "%s, ra, dec, equinox1, equinox2" (nil ("FK4") ("PRINT") ("RADIAN"))) + ("PRECESS_CD" pro nil (lib "precess_cd.pro" nil "Astrolib") "%s, cd, epoch1, epoch2, crval_old, crval_new" (nil ("FK4"))) + ("precess_xyz" pro nil (lib "precess_xyz.pro" nil "Astrolib") "%s, x, y, z, equinox1, equinox2" (nil)) + ("premat" fun nil (lib "premat.pro" nil "Astrolib") "Result = %s(equinox1, equinox2)" (nil ("FK4"))) + ("prime" fun nil (lib "prime.pro" nil "Astrolib") "Result = %s(n)" (nil ("help"))) + ("print_struct" pro nil (lib "print_struct.pro" nil "Astrolib") "%s, structure, Tags_to_print, title, string_matrix" (nil ("FILE") ("FORM_FLOAT") ("FRANGE") ("LUN_OUT") ("MAX_ELEMENTS") ("NO_TITLE") ("STRINGS") ("TNUMS") ("TRANGE") ("WHICH_TO_PRINT"))) + ("prob_ks" pro nil (lib "prob_ks.pro" nil "Astrolib") "%s, D, N_eff, probks" (nil)) + ("prob_kuiper" pro nil (lib "prob_kuiper.pro" nil "Astrolib") "%s, D, N_eff, probks" (nil)) + ("psf_gaussian" fun nil (lib "psf_gaussian.pro" nil "Astrolib") "Result = %s(parameters)" (nil ("CENTROID") ("DOUBLE") ("FWHM") ("NDIMENSION") ("NORMALIZE") ("NPIXEL") ("ST_DEV") ("XY_CORREL"))) + ("putast" pro nil (lib "putast.pro" nil "Astrolib") "%s, hdr, astr, crpix, crval, ctype" (nil ("ALT") ("CD_TYPE") ("EQUINOX") ("NAXIS"))) + ("QDCB_GRID" pro nil (lib "qdcb_grid.pro" nil "Astrolib") "%s, DLONG, DLAT" (nil ("LABELS") ("LINESTYLE"))) + ("qget_string" fun nil (lib "qget_string.pro" nil "Astrolib") "Result = %s(dummy)" (nil)) + ("qsimp" pro nil (lib "qsimp.pro" nil "Astrolib") "%s, func, A, B, S" (nil ("_EXTRA") ("EPS") ("MAX_ITER"))) + ("qtrap" pro nil (lib "qtrap.pro" nil "Astrolib") "%s, func, A, B, S" (nil ("_EXTRA") ("EPS") ("MAX_ITER"))) + ("quadterp" pro nil (lib "quadterp.pro" nil "Astrolib") "%s, xtab, ytab, xint, yint" (nil ("MISSING"))) + ("QueryDSS" pro nil (lib "querydss.pro" nil "Astrolib") "%s, target, Image, Header" (nil ("ESO") ("IMSIZE") ("NED") ("OUTFILE") ("STSCI") ("SURVEY") ("VERBOSE"))) + ("Querygsc" fun nil (lib "querygsc.pro" nil "Astrolib") "Result = %s(target, dis)" (nil ("BOX") ("HOURS") ("magrange") ("VERBOSE"))) + ("QuerySimbad" pro nil (lib "querysimbad.pro" nil "Astrolib") "%s, name, ra, de, id" (nil ("CADC") ("CFA") ("ERRMSG") ("Found") ("Hmag") ("Jmag") ("Kmag") ("NED") ("parallax") ("Print") ("Server") ("SILENT") ("Verbose") ("Vmag"))) + ("Queryvizier" fun nil (lib "queryvizier.pro" nil "Astrolib") "Result = %s(catalog, target, dis)" (nil ("ALLCOLUMNS") ("CANADA") ("CFA") ("CONSTRAINT") ("SILENT") ("VERBOSE"))) + ("radec" pro nil (lib "radec.pro" nil "Astrolib") "%s, ra, dec, ihr, imin, xsec, ideg, imn, xsc" (nil ("hours"))) + ("randomchi" fun nil (lib "randomchi.pro" nil "Astrolib") "Result = %s(seed, dof, nrand)" (nil)) + ("randomdir" fun nil (lib "randomdir.pro" nil "Astrolib") "Result = %s(seed, alpha, nrand)" (nil)) + ("randomgam" fun nil (lib "randomgam.pro" nil "Astrolib") "Result = %s(seed, alpha, beta, nrand)" (nil)) + ("randomp" pro nil (lib "randomp.pro" nil "Astrolib") "%s, x, pow, n" (nil ("range_x") ("seed"))) + ("randomwish" fun nil (lib "randomwish.pro" nil "Astrolib") "Result = %s(seed, dof, S, nrand)" (nil)) + ("rdfits_struct" pro nil (lib "rdfits_struct.pro" nil "Astrolib") "%s, filename, struct" (nil ("EXTEN") ("HEADER_ONLY") ("SILENT"))) + ("rdfloat" pro nil (lib "rdfloat.pro" nil "Astrolib") "%s, name, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19" (nil ("COLUMNS") ("DOUBLE") ("NUMLINE") ("SILENT") ("SKIPLINE"))) + ("RESET_RDPLOT" pro nil (lib "rdplot.pro" nil "Astrolib") "%s" (nil)) + ("RDPLOT" pro nil (lib "rdplot.pro" nil "Astrolib") "%s, x, y, WaitFlag" (nil ("ACCUMULATE") ("BACKGROUND") ("CHANGE") ("COLOR") ("CROSS") ("CURSOR_STANDARD") ("DATA") ("DEVICE") ("DOWN") ("Err") ("FULLCURSOR") ("LINESTYLE") ("NOCLIP") ("NORMAL") ("NOWAIT") ("PRINT") ("THICK") ("WAIT") ("XTITLE") ("XVALUES") ("YTITLE") ("YVALUES"))) + ("rdpsf" pro nil (lib "rdpsf.pro" nil "Astrolib") "%s, psf, hpsf, psfname" (nil)) + ("read_fmr" fun nil (lib "read_fmr.pro" nil "Astrolib") "Result = %s(filename)" (nil ("columns") ("help") ("missingvalue") ("use_colnum"))) + ("read_key" fun nil (lib "read_key.pro" nil "Astrolib") "Result = %s(wait)" (nil)) + ("readcol" pro nil (lib "readcol.pro" nil "Astrolib") "%s, name, v1, V2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25, v26, v27, v28, v29, v30, v31, v32, v33, v34, v35, v36, v37, v38, v39, v40, v41, v42, v43, v44, v45, v46, v47, v48, v49, v50" (nil ("COMMENT") ("COMPRESS") ("COUNT") ("DEBUG") ("DELIMITER") ("FORMAT") ("NAN") ("NLINES") ("NUMLINE") ("PRESERVE_NULL") ("QUICK") ("SILENT") ("SKIPLINE") ("STRINGSKIP"))) + ("READFITS" fun nil (lib "readfits.pro" nil "Astrolib") "Result = %s(filename, header, heap)" (nil ("CHECKSUM") ("COMPRESS") ("EXTEN_NO") ("FPACK") ("HBUFFER") ("NaNvalue") ("NO_UNSIGNED") ("NOSCALE") ("NSLICE") ("NUMROW") ("POINTLUN") ("SILENT") ("STARTROW") ("UNIXpipe"))) + ("readfmt" pro nil (lib "readfmt.pro" nil "Astrolib") "%s, name, fmt, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25" (nil ("DEBUG") ("NUMLINE") ("SILENT") ("SKIPLINE"))) + ("recpol" pro nil (lib "recpol.pro" nil "Astrolib") "%s, x, y, r, a" (nil ("degrees") ("help"))) + ("rem_dup" fun nil (lib "rem_dup.pro" nil "Astrolib") "Result = %s(a, flag)" (nil)) + ("remchar" pro nil (lib "remchar.pro" nil "Astrolib") "%s, st, char" (nil)) + ("remove" pro nil (lib "remove.pro" nil "Astrolib") "%s, index, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25" (nil)) + ("REPCHR" fun nil (lib "repchr.pro" nil "Astrolib") "Result = %s(OLD, C1, C2)" (nil ("help"))) + ("repstr" fun nil (lib "repstr.pro" nil "Astrolib") "Result = %s(obj, in, out)" (nil)) + ("RESISTANT_Mean" pro nil (lib "resistant_mean.pro" nil "Astrolib") "%s, Y, CUT, Mean, Sigma, Num_Rej" (nil ("dimension") ("double") ("goodvec") ("Silent") ("sumdim") ("wused"))) + ("RINTER" fun nil (lib "rinter.pro" nil "Astrolib") "Result = %s(P, X, Y, DFDX, DFDY)" (nil ("INITIALIZE"))) + ("ROB_CHECKFIT" fun nil (lib "rob_checkfit.pro" nil "Astrolib") "Result = %s(Y, YFIT, EPS, DEL, SIG, FRACDEV, NGOOD, W, B)" (nil ("BISQUARE_LIMIT"))) + ("ROBUST_LINEFIT" fun nil (lib "robust_linefit.pro" nil "Astrolib") "Result = %s(XIN, YIN, YFIT, SIG, SS)" (nil ("BISECT") ("Bisquare_Limit") ("Close_Factor") ("NUMIT"))) + ("ROBUST_POLY_FIT" fun nil (lib "robust_poly_fit.pro" nil "Astrolib") "Result = %s(X, Y, NDEG, YFIT, SIG)" (nil ("DOUBLE") ("NUMIT"))) + ("ROBUST_SIGMA" fun nil (lib "robust_sigma.pro" nil "Astrolib") "Result = %s(Y)" (nil ("GOODVEC") ("ZERO"))) + ("select_w_event" pro nil (lib "select_w.pro" nil "Astrolib") "%s, event" (nil)) + ("select_w" pro nil (lib "select_w.pro" nil "Astrolib") "%s, items, iselected, comments, command_line, only_one" (nil ("columns") ("Count") ("GROUP_LEADER") ("selectin") ("y_scroll_size"))) + ("get_pipe_filesize" pro nil (lib "get_pipe_filesize.pro" nil "Astrolib") "%s, unit, nbytes" (nil ("buffer"))) + ("sigma_filter" fun nil (lib "sigma_filter.pro" nil "Astrolib") "Result = %s(image, box_width)" (nil ("ALL_PIXELS") ("DEVIATION_IMAGE") ("ITERATE") ("KEEP_OUTLIERS") ("MONITOR") ("N_CHANGE") ("N_SIGMA") ("RADIUS") ("VARIANCE_IMAGE"))) + ("SIGRANGE" fun nil (lib "sigrange.pro" nil "Astrolib") "Result = %s(ARRAY)" (nil ("FRACTION") ("MISSING") ("RANGE"))) + ("sixlin" pro nil (lib "sixlin.pro" nil "Astrolib") "%s, xx, yy, a, siga, b, sigb" (nil ("weight"))) + ("sixty" fun nil (lib "sixty.pro" nil "Astrolib") "Result = %s(scalar)" (nil ("Trailsign"))) + ("sky" pro nil (lib "sky.pro" nil "Astrolib") "%s, image, skymode, skysig" (nil ("_EXTRA") ("CIRCLERAD") ("MEANBACK") ("NAN") ("SILENT"))) + ("EXTRAP" pro nil (lib "skyadj_cube.pro" nil "Astrolib") "%s, Deg, X, Y, Y2" (nil ("LIMS"))) + ("SKYADJ_CUBE" pro nil (lib "skyadj_cube.pro" nil "Astrolib") "%s, Datacube, Skyvals, Totsky" (nil ("EDEGREE") ("EXTRAPR") ("INPUT_MASK") ("NOEDIT") ("REGION") ("SELECT") ("VERBOSE") ("XMEDSKY"))) + ("spec_dir" fun nil (lib "spec_dir.pro" nil "Astrolib") "Result = %s(filename, extension)" (nil)) + ("sphdist" fun nil (lib "sphdist.pro" nil "Astrolib") "Result = %s(long1, lat1, long2, lat2)" (nil ("degrees") ("help"))) + ("srcor" pro nil (lib "srcor.pro" nil "Astrolib") "%s, x1in, y1in, x2in, y2in, dcr, ind1, ind2" (nil ("count") ("magnitude") ("option") ("silent") ("spherical"))) + ("st_diskread" pro nil (lib "st_diskread.pro" nil "Astrolib") "%s, infiles" (nil ("DUMP"))) + ("st_disk_data" pro nil (lib "st_diskread.pro" nil "Astrolib") "%s, unit, h, data, name, gcount, dimen, opsize, nbytes, itype" (nil)) + ("st_disk_table" pro nil (lib "st_diskread.pro" nil "Astrolib") "%s, unit, h, data, table_available" (nil)) + ("st_disk_geis" pro nil (lib "st_diskread.pro" nil "Astrolib") "%s, h, data, htab, tab, table_available, name, gcount, dimen, opsize, nbytes_g, itype" (nil)) + ("starast" pro nil (lib "starast.pro" nil "Astrolib") "%s, ra, dec, x, y, cd" (nil ("hdr") ("projection") ("righthanded"))) + ("STORE_ARRAY" pro nil (lib "store_array.pro" nil "Astrolib") "%s, DESTINATION, INSERT, INDEX" (nil)) + ("STR_INDEX" fun nil (lib "str_index.pro" nil "Astrolib") "Result = %s(str, substr, offset)" (nil)) + ("strcompress2" fun nil (lib "strcompress2.pro" nil "Astrolib") "Result = %s(str, chars)" (nil)) + ("strn" fun nil (lib "strn.pro" nil "Astrolib") "Result = %s(number)" (nil ("FORMAT") ("LENGTH") ("PADCHAR") ("PADTYPE"))) + ("strnumber" fun nil (lib "strnumber.pro" nil "Astrolib") "Result = %s(st, val)" (nil ("hex") ("L64") ("NaN"))) + ("substar" pro nil (lib "substar.pro" nil "Astrolib") "%s, image, x, y, mag, id, psfname" (nil ("VERBOSE"))) + ("sunpos" pro nil (lib "sunpos.pro" nil "Astrolib") "%s, jd, ra, dec, longmed, oblt" (nil ("RADIAN"))) + ("sunsymbol" fun nil (lib "sunsymbol.pro" nil "Astrolib") "Result = %s" (nil ("FONT"))) + ("sxaddhist" pro nil (lib "sxaddhist.pro" nil "Astrolib") "%s, history, header" (nil ("blank") ("comment") ("location") ("pdu"))) + ("sxaddpar" pro nil (lib "sxaddpar.pro" nil "Astrolib") "%s, Header, Name, Value, Comment, Location" (nil ("after") ("before") ("format") ("pdu") ("savecomment"))) + ("sxdelpar" pro nil (lib "sxdelpar.pro" nil "Astrolib") "%s, h, parname" (nil)) + ("sxginfo" pro nil (lib "sxginfo.pro" nil "Astrolib") "%s, h, par, type, sbyte, nbytes" (nil)) + ("sxgpar" fun nil (lib "sxgpar.pro" nil "Astrolib") "Result = %s(h, par, name, type, sbyte, nbytes)" (nil)) + ("sxgread" fun nil (lib "sxgread.pro" nil "Astrolib") "Result = %s(unit, group)" (nil)) + ("sxhcopy" pro nil (lib "sxhcopy.pro" nil "Astrolib") "%s, h, keyword1, keyword2, hout" (nil)) + ("sxhmake" pro nil (lib "sxhmake.pro" nil "Astrolib") "%s, data, groups, header" (nil)) + ("sxhread" pro nil (lib "sxhread.pro" nil "Astrolib") "%s, name, header" (nil)) + ("sxhwrite" pro nil (lib "sxhwrite.pro" nil "Astrolib") "%s, name, h" (nil)) + ("sxmake" pro nil (lib "sxmake.pro" nil "Astrolib") "%s, unit, File, Data, Par, Groups, Header" (nil ("PSIZE"))) + ("SXOPEN" pro nil (lib "sxopen.pro" nil "Astrolib") "%s, unit, fname, header, history, access" (nil)) + ("SXPAR" fun nil (lib "sxpar.pro" nil "Astrolib") "Result = %s(hdr, name, abort)" (nil ("COMMENT") ("COUNT") ("NoContinue") ("SILENT"))) + ("sxread" fun nil (lib "sxread.pro" nil "Astrolib") "Result = %s(unit, group, par)" (nil)) + ("SXWRITE" pro nil (lib "sxwrite.pro" nil "Astrolib") "%s, Unit, Data, Par" (nil)) + ("ymd2dn" fun nil (lib "ymd2dn.pro" nil "Astrolib") "Result = %s(yr, m, d)" (nil ("help"))) + ("t_aper" pro nil (lib "t_aper.pro" nil "Astrolib") "%s, image, fitsfile, apr, skyrad, badpix" (nil ("EXACT") ("NEWTABLE") ("PRINT") ("SETSKYVAL") ("SILENT"))) + ("t_find" pro nil (lib "t_find.pro" nil "Astrolib") "%s, image, im_hdr, fitsfile, hmin, fwhm, sharplim, roundlim" (nil ("PRINT") ("SILENT"))) + ("t_getpsf" pro nil (lib "t_getpsf.pro" nil "Astrolib") "%s, image, fitsfile, idpsf, psfrad, fitrad, psfname" (nil ("DEBUG") ("NEWTABLE"))) + ("t_group" pro nil (lib "t_group.pro" nil "Astrolib") "%s, fitsfile, rmax" (nil ("NEWTABLE") ("xpar") ("ypar"))) + ("t_nstar" pro nil (lib "t_nstar.pro" nil "Astrolib") "%s, image, fitsfile, psfname, groupsel" (nil ("DEBUG") ("NEWTABLE") ("PRINT") ("SILENT") ("VARSKY"))) + ("t_substar" pro nil (lib "t_substar.pro" nil "Astrolib") "%s, image, fitsfile, id, psfname" (nil ("NOPSF") ("VERBOSE"))) + ("sip_eval" fun nil (lib "sip_eval.pro" nil "Astrolib") "Result = %s(xy)" (nil)) + ("TPV_eval" fun nil (lib "tpv_eval.pro" nil "Astrolib") "Result = %s(xy)" (nil)) + ("TNX_eval" fun nil (lib "tnx_eval.pro" nil "Astrolib") "Result = %s(xy)" (nil)) + ("xi_solve_tpv" fun nil (lib "solve_astro.pro" nil "Astrolib") "Result = %s(xpixel, ypixel, pv1)" (nil ("TPVINFO"))) + ("eta_solve_tpv" fun nil (lib "solve_astro.pro" nil "Astrolib") "Result = %s(xpixel, ypixel, pv2)" (nil ("TPVINFO"))) + ("eta_solve_tnx" fun nil (lib "solve_astro.pro" nil "Astrolib") "Result = %s(xpixel, ypixel, params)" (nil ("TNXINFO"))) + ("xi_solve_tnx" fun nil (lib "solve_astro.pro" nil "Astrolib") "Result = %s(xpixel, ypixel, params)" (nil ("TNXINFO"))) + ("solve_astro" fun nil (lib "solve_astro.pro" nil "Astrolib") "Result = %s(radeg, decdeg, xpixel, ypixel)" (nil ("CRVAL") ("DISTORT") ("ETAORDER") ("ETARESID") ("ETARMS") ("n_tpvterms") ("NAXIS1") ("NAXIS2") ("NITER") ("NORTERMS") ("NREJ") ("REJECT") ("SUCCESS") ("VERBOSE") ("WFIT") ("XIORDER") ("XIRESID") ("XIRMS") ("XTERMS"))) + ("TABINV" pro nil (lib "tabinv.pro" nil "Astrolib") "%s, XARR, X, IEFF" (nil ("FAST"))) + ("tag_exist" fun nil (lib "tag_exist.pro" nil "Astrolib") "Result = %s(str, tag)" (nil ("index") ("quiet") ("recurse") ("top_level"))) + ("tbdelcol" pro nil (lib "tbdelcol.pro" nil "Astrolib") "%s, h, tab, name" (nil)) + ("tbdelrow" pro nil (lib "tbdelrow.pro" nil "Astrolib") "%s, h, tab, rows" (nil)) + ("tbget" fun nil (lib "tbget.pro" nil "Astrolib") "Result = %s(hdr_or_tbstr, tab, field, rows, nulls)" (nil ("CONTINUE") ("NOSCALE"))) + ("tbhelp" pro nil (lib "tbhelp.pro" nil "Astrolib") "%s, h" (nil ("TEXTOUT"))) + ("tbinfo" pro nil (lib "tbinfo.pro" nil "Astrolib") "%s, h, tb_str" (nil ("errmsg") ("NOSCALE"))) + ("tbprint" pro nil (lib "tbprint.pro" nil "Astrolib") "%s, hdr_or_tbstr, tab, columns, rows" (nil ("fmt") ("num_header_lines") ("nval_per_line") ("textout"))) + ("tbsize" pro nil (lib "tbsize.pro" nil "Astrolib") "%s, h, tab, ncols, nrows, tfields, ncols_all, nrows_all" (nil)) + ("tdb2tdt_calc" fun nil (lib "tdb2tdt.pro" nil "Astrolib") "Result = %s(jd)" (nil ("deriv") ("tbase"))) + ("tdb2tdt" fun nil (lib "tdb2tdt.pro" nil "Astrolib") "Result = %s(jd)" (nil ("deriv") ("tbase"))) + ("ten" fun nil (lib "ten.pro" nil "Astrolib") "Result = %s(dd, mm, ss)" (nil)) + ("tenv" fun nil (lib "tenv.pro" nil "Astrolib") "Result = %s(dd, mm, ss)" (nil)) + ("textclose" pro nil (lib "textclose.pro" nil "Astrolib") "%s" (nil ("textout"))) + ("TEXTOPEN" pro nil (lib "textopen.pro" nil "Astrolib") "%s, PROGRAM" (nil ("MORE_SET") ("SILENT") ("STDOUT") ("TEXTOUT") ("WIDTH"))) + ("tic_one" pro nil (lib "tic_one.pro" nil "Astrolib") "%s, min, pixx, incr, min2, tic1" (nil ("RA"))) + ("ticlabels" pro nil (lib "ticlabels.pro" nil "Astrolib") "%s, minval, numtics, incr, ticlabs" (nil ("DELTA") ("FONT") ("RA"))) + ("ticpos" pro nil (lib "ticpos.pro" nil "Astrolib") "%s, deglen, pixlen, ticsize, incr, units" (nil)) + ("tics" pro nil (lib "tics.pro" nil "Astrolib") "%s, radec_min, radec_max, numx, ticsize, incr" (nil ("RA"))) + ("TO_HEX" fun nil (lib "to_hex.pro" nil "Astrolib") "Result = %s(D, NCHAR)" (nil)) + ("transform_coeff" fun nil (lib "transform_coeff.pro" nil "Astrolib") "Result = %s(coeff, alpha, beta)" (nil)) + ("trapzd" pro nil (lib "trapzd.pro" nil "Astrolib") "%s, func, a, b, s, step" (nil ("_EXTRA"))) + ("tsc" fun nil (lib "tsc.pro" nil "Astrolib") "Result = %s(value, posx, nx, posy, ny, posz, nz)" (nil ("AVERAGE") ("ISOLATED") ("NO_MESSAGE") ("WRAPAROUND"))) + ("TSUM" fun nil (lib "tsum.pro" nil "Astrolib") "Result = %s(X, Y, IMIN, IMAX)" (nil ("NAN"))) + ("tvbox" pro nil (lib "tvbox.pro" nil "Astrolib") "%s, width, x, y, color" (nil ("_EXTRA") ("ANGLE") ("Color") ("DATA") ("DEVICE") ("SQUARE"))) + ("Tvcircle" pro nil (lib "tvcircle.pro" nil "Astrolib") "%s, radius, xc, yc, color" (nil ("_Extra") ("COLOR") ("DATA") ("Device") ("FILL"))) + ("tvellipse" pro nil (lib "tvellipse.pro" nil "Astrolib") "%s, rmax, rmin, xc, yc, pos_ang, color" (nil ("_Extra") ("COLOR") ("DATA") ("DEVICE") ("FILL") ("MAJOR") ("MINOR") ("NPOINTS"))) + ("TVLASER" pro nil (lib "tvlaser.pro" nil "Astrolib") "%s, hdr, Image" (nil ("BARPOS") ("BOTTOMDW") ("CARROWS") ("CLABELS") ("COLORPS") ("COMMENTS") ("CSIZE") ("CTITLE") ("DX") ("DY") ("ENCAP") ("FILENAME") ("HEADER") ("HELP") ("IMAGEOut") ("INTERP") ("MAGNIFY") ("NCOLORSDW") ("NO_PERS_INFO") ("NoClose") ("NODELETE") ("NOEIGHT") ("NOPRINT") ("NORETAIN") ("PORTRAIT") ("PRINTER") ("REVERSE") ("SCALE") ("TITLE") ("TrueColor") ("XDIM") ("XSTART") ("YDIM") ("YSTART"))) + ("tvlist" pro nil (lib "tvlist.pro" nil "Astrolib") "%s, image, dx, dy" (nil ("OFFSET") ("TEXTOUT") ("ZOOM"))) + ("unzoom_xy" pro nil (lib "unzoom_xy.pro" nil "Astrolib") "%s, xtv, ytv, xim, yim" (nil ("OFFSET") ("ZOOM"))) + ("update_distort" pro nil (lib "update_distort.pro" nil "Astrolib") "%s, distort, xcoeff, ycoeff" (nil)) + ("uvbybeta" pro nil (lib "uvbybeta.pro" nil "Astrolib") "%s, xby, xm1, xc1, xHbeta, xn, Te, MV, eby, delm0, radius" (nil ("eby_in") ("name") ("print") ("prompt") ("TEXTOUT"))) + ("vactoair" pro nil (lib "vactoair.pro" nil "Astrolib") "%s, wave_vac, wave_air" (nil)) + ("valid_num" fun nil (lib "valid_num.pro" nil "Astrolib") "Result = %s(string, value)" (nil ("INTEGER"))) + ("VECT" fun nil (lib "vect.pro" nil "Astrolib") "Result = %s(vctr, form)" (nil ("delim") ("Format"))) + ("VSYM" pro nil (lib "vsym.pro" nil "Astrolib") "%s, Nvert" (nil ("FILL") ("POLYGON") ("ROT") ("SKELETON") ("STAR") ("THICK"))) + ("wcssph2xy_plot" pro nil (lib "wcs_demo.pro" nil "Astrolib") "%s, file_unit, map, param1, param2" (nil)) + ("inversion_error" pro nil (lib "wcs_demo.pro" nil "Astrolib") "%s, file_unit, map, param1, param2" (nil)) + ("wcs_rot" pro nil (lib "wcs_demo.pro" nil "Astrolib") "%s, file_unit, map, param1, param2" (nil)) + ("wcs_demo" pro nil (lib "wcs_demo.pro" nil "Astrolib") "%s" (nil)) + ("WCS_GETPOLE" pro nil (lib "wcs_getpole.pro" nil "Astrolib") "%s, crval, lonpole, theta0, alpha_p, delta_p" (nil ("AT_POLE") ("LATPOLE"))) + ("wcs_rotate" pro nil (lib "wcs_rotate.pro" nil "Astrolib") "%s, longitude, latitude, phi, theta, crval" (nil ("LATPOLE") ("LONGPOLE") ("ORIGIN") ("PV1") ("REVERSE") ("THETA0"))) + ("wcssph2xy" pro nil (lib "wcssph2xy.pro" nil "Astrolib") "%s, longitude, latitude, x, y, map_type" (nil ("badindex") ("crval") ("crxy") ("ctype") ("face") ("latpole") ("longpole") ("north_offset") ("pv1") ("pv2") ("south_offset"))) + ("wcsxy2sph" pro nil (lib "wcsxy2sph.pro" nil "Astrolib") "%s, x, y, longitude, latitude, map_type" (nil ("crval") ("crxy") ("ctype") ("face") ("Latpole") ("longpole") ("pv1") ("pv2"))) + ("MimeType" pro nil (lib "webget.pro" nil "Astrolib") "%s, Header, Class, Type, Length" (nil)) + ("webget" fun nil (lib "webget.pro" nil "Astrolib") "Result = %s(url)" (nil ("COPYFILE") ("HTTP10") ("POST") ("SILENT") ("timeout"))) + ("wfpc2_metric" pro nil (lib "wfpc2_metric.pro" nil "Astrolib") "%s, xin, yin, xout, yout, chip" (nil ("FILTER") ("GLOBAL") ("Header") ("RADec") ("YEAR"))) + ("wfpc2_read" pro nil (lib "wfpc2_read.pro" nil "Astrolib") "%s, filename, chip1, header1, chip2, header2, chip3, header3, chip4, header4" (nil ("batwing") ("num_chip") ("path") ("trim"))) + ("where_Tag" fun nil (lib "where_tag.pro" nil "Astrolib") "Result = %s(Struct, Nfound)" (nil ("ISELECT") ("NOPRINT") ("RANGE") ("TAG_NAME") ("TAG_NUMBER") ("VALUES"))) + ("WHERENAN" fun nil (lib "wherenan.pro" nil "Astrolib") "Result = %s(ARRAY, COUNT)" (nil)) + ("writefits" pro nil (lib "writefits.pro" nil "Astrolib") "%s, filename, data, header, heap" (nil ("Append") ("CheckSum") ("compress") ("NaNValue"))) + ("XDISPSTR_EVENT" pro nil (lib "xdispstr.pro" nil "Astrolib") "%s, Event" (nil)) + ("XDISPSTR_CLEANUP" pro nil (lib "xdispstr.pro" nil "Astrolib") "%s, Id" (nil)) + ("XDISPSTR" pro nil (lib "xdispstr.pro" nil "Astrolib") "%s, Array" (nil ("BLOCK") ("FONT") ("GROUP_LEADER") ("HEIGHT") ("POS") ("TITLE") ("top_line") ("WIDTH"))) + ("XMEDSKY" pro nil (lib "xmedsky.pro" nil "Astrolib") "%s, Image, Bkg" (nil ("CLIP") ("Nsig"))) + ("xy2ad" pro nil (lib "xy2ad.pro" nil "Astrolib") "%s, x, y, astr, a, d" (nil)) + ("xyad" pro nil (lib "xyad.pro" nil "Astrolib") "%s, hdr, x, y, a, d" (nil ("ALT") ("CELESTIAL") ("ECLIPTIC") ("GALACTIC") ("PRECISION") ("PRINT"))) + ("xyxy" pro nil (lib "xyxy.pro" nil "Astrolib") "%s, hdra, hdrb, xa, ya, xb, yb" (nil)) + ("xyz" pro nil (lib "xyz.pro" nil "Astrolib") "%s, date, x, y, z, xvel, yvel, zvel" (nil ("equinox"))) + ("YDN2MD" pro nil (lib "ydn2md.pro" nil "Astrolib") "%s, YR, DY, M, D" (nil ("help"))) + ("zang" fun nil (lib "zang.pro" nil "Astrolib") "Result = %s(dl, z)" (nil ("h0") ("k") ("Lambda0") ("Omega_m") ("q0") ("SILENT"))) + ("ZBRENT" fun nil (lib "zbrent.pro" nil "Astrolib") "Result = %s(x1, x2)" (nil ("_EXTRA") ("FUNC_NAME") ("MAX_ITERATIONS") ("TOLERANCE"))) + ("ZENPOS" pro nil (lib "zenpos.pro" nil "Astrolib") "%s, date, ra, dec" (nil)) + ("zoom_xy" pro nil (lib "zoom_xy.pro" nil "Astrolib") "%s, xim, yim, xtv, ytv" (nil ("OFFSET") ("ZOOM"))) + ("zparcheck" pro nil (lib "zparcheck.pro" nil "Astrolib") "%s, progname, parameter, parnum, types, dimens, message" (nil)) + ("al_legendtest" pro nil (lib "al_legendtest.pro" nil "Astrolib") "%s" (nil)) + ("wcs_check_ctype" pro nil (lib "wcs_check_ctype.pro" nil "Astrolib") "%s, ctype, projection_type, coord_type" (nil)) + ("query_irsa_cat" fun nil (lib "query_irsa_cat.pro" nil "Astrolib") "Result = %s(targetname_OR_coords)" (nil ("catalog") ("change_null") ("DEBUG") ("outfile") ("radius") ("radunits"))) + ("read_ipac_table" fun nil (lib "read_ipac_table.pro" nil "Astrolib") "Result = %s(filename)" (nil ("change_null") ("debug"))) + ("read_ipac_var" fun nil (lib "read_ipac_var.pro" nil "Astrolib") "Result = %s(textvar)" (nil ("change_null") ("debug"))) + ("write_ipac_table" pro nil (lib "write_ipac_table.pro" nil "Astrolib") "%s, in_struct, outfile" (nil ("exact_format") ("format") ("short_format"))) + ("errtype" fun nil (lib "safe_correlate.pro" nil "Astrolib") "Result = %s(err, bad_err_msg)" (nil)) + ("vet_err" pro nil (lib "safe_correlate.pro" nil "Astrolib") "%s, err, errtype, n, bad_err_msg" (nil)) + ("generate_data" fun nil (lib "safe_correlate.pro" nil "Astrolib") "Result = %s(v, err, type, n, nsim, dbl, seed)" (nil)) + ("safe_correlate" fun nil (lib "safe_correlate.pro" nil "Astrolib") "Result = %s(x, y, xerr, yerr)" (nil ("nsim") ("seed"))))) diff --git a/modules/idl_downloads/astro/pro/ad2xy.pro b/modules/idl_downloads/astro/pro/ad2xy.pro new file mode 100644 index 0000000..ef148b0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ad2xy.pro @@ -0,0 +1,326 @@ +pro ad2xy, a, d, astr, x, y +;+ +; NAME: +; AD2XY +; PURPOSE: +; Compute X and Y from native coordinates and a FITS astrometry structure +; EXPLANATION: +; If a WCS projection (Calabretta & Greisen 2002, A&A, 395, 1077) is +; present, then the procedure WCSXY2SPH is used to compute native +; coordinates. If distortion is present then this is corrected. +; In all cases, the inverse of the CD matrix is applied and offset +; from the reference pixel to obtain X and Y. +; +; AD2XY is generally meant to be used internal to other procedures. For +; interactive purposes, use ADXY. +; +; CALLING SEQUENCE: +; AD2XY, a ,d, astr, x, y +; +; INPUTS: +; A - R.A. or longitude in DEGREES, scalar or vector. +; D - Dec. or longitude in DEGREES, scalar or vector +; If the input A and D are arrays with 2 or more dimensions, +; they will be converted to a 1-D vectors. +; ASTR - astrometry structure, output from EXTAST procedure containing: +; .CD - 2 x 2 array containing the astrometry parameters CD1_1 CD1_2 +; in DEGREES/PIXEL CD2_1 CD2_2 +; .CDELT - 2 element vector giving increment at reference point in +; DEGREES/PIXEL +; .CRPIX - 2 element vector giving X and Y coordinates of reference pixel +; (def = NAXIS/2) in FITS convention (first pixel is 1,1) +; .CRVAL - 2 element vector giving coordinates of the reference pixel +; in DEGREES +; .CTYPE - 2 element vector giving projection types +; .LONGPOLE - scalar longitude of north pole (default = 180) +; .PV2 - Vector of additional parameter (e.g. PV2_1, PV2_2) needed in +; some projections +; +; Fields added for version 2: +; .PV1 - Vector of projection parameters associated with longitude axis +; .AXES - 2 element integer vector giving the FITS-convention axis +; numbers associated with astrometry, in ascending order. +; Default [1,2]. +; .REVERSE - byte, true if first astrometry axis is Dec/latitude +; .COORDSYS - 1 or 2 character code giving coordinate system, including +; 'C' = RA/Dec, 'G' = Galactic, 'E' = Ecliptic, 'X' = unknown. +; .RADECSYS - String giving RA/Dec system e.g. 'FK4', 'ICRS' etc. +; .EQUINOX - Double giving the epoch of the mean equator and equinox +; .DATEOBS - Text string giving (start) date/time of observations +; .MJDOBS - Modified julian date of start of observations. +; .X0Y0 - Implied offset in intermediate world coordinates if user has +; specified a non-standard fiducial point via PV1 and also +; has set PV1_0a =/ 0 to indicate that the offset should be +; applied in order to place CRVAL at the IWC origin. +; Should be *added* to the IWC derived from application of +; CRPIX, CDELT, CD to the pixel coordinates. +; +; .DISTORT - Optional substructure specifying distortion parameters +; +; OUTPUTS: +; X - row position in pixels, scalar or vector +; Y - column position in pixels, scalar or vector +; +; X,Y will be in the standard IDL convention (first pixel is 0), and +; *not* the FITS convention (first pixel is 1) +; NOTES: +; AD2XY tests for presence of WCS coordinates by the presence of a dash +; in the 5th character position in the value of CTYPE (e.g 'DEC--SIN'). +; COMMON BLOCKS: +; BROYDEN_COMMON - Used when solving for a reverse distortion tranformation +; (either SIP or TGV) by iterating on the forward transformation. +; PROCEDURES USED: +; CGErrorMsg (from Coyote Library) +; TAG_EXIST(), WCSSPH2XY +; REVISION HISTORY: +; Converted to IDL by B. Boothman, SASC Tech, 4/21/86 +; Use astrometry structure, W. Landsman Jan. 1994 +; Do computation correctly in degrees W. Landsman Dec. 1994 +; Only pass 2 CRVAL values to WCSSPH2XY W. Landsman June 1995 +; Don't subscript CTYPE W. Landsman August 1995 +; Understand reversed X,Y (X-Dec, Y-RA) axes, W. Landsman October 1998 +; Consistent conversion between CROTA and CD matrix W. Landsman October 2000 +; No special case for tangent projection W. Landsman June 2003 +; Work for non-WCS coordinate transformations W. Landsman Oct 2004 +; Use CRVAL reference point for non-WCS transformation W.L. March 2007 +; Use post V6.0 notation W.L. July 2009 +; Allows use of Version 2 astrometry structure & optimised for +; large input arrays. Wrap test for cylindrical coords. J. P. Leahy July 2013 +; Wrap test failed for 2d input arrays +; T. Ellsworth-Bowers/W.Landsman July 2013 +; Tweaked to restore shape of arrays on exit JPL Aug 2013. +; ..and make them scalars if input is scalar JPL Aug 2013 +; Iterate when forward SIP coefficients are supplied but not the reverse +; coefficients. Don't compute poles if not a cylindrical system +; W. Landsman Dec 2013 +; Evaluate TPV distortion (SCAMP) if present W. Landsman Jan 2014 +; Support IRAF TNX projection M. Sullivan U. of Southhamptom Mar 2014 +; No longer check that CDELT[0] differs from 1 W. Landsman Apr 2015 +; +;- + + compile_opt idl2 + common broyden_coeff, xcoeff, ycoeff + + + if N_params() lT 4 then begin + print,'Syntax -- AD2XY, a, d, astr, x, y' + return + endif + + Catch, theError + IF theError NE 0 then begin + Catch,/Cancel + void = cgErrorMsg(/quiet) + RETURN + ENDIF + + if tag_exist(astr,'DISTORT') && ((astr.distort.name EQ 'TPV') || (astr.distort.name EQ 'TNX')) then $ + ctype = strmid(astr.ctype,0,4) + '-TAN' else ctype = astr.ctype + crval = astr.crval + + testing = 0B + size_a = SIZE(a) + ndima = size_a[0] + + astr2 = TAG_EXIST(astr,'AXES') ; version 2 astrometry structure + IF astr2 THEN reverse = astr.reverse ELSE BEGIN + coord = strmid(ctype,0,4) + reverse = ((coord[0] EQ 'DEC-') && (coord[1] EQ 'RA--')) || $ + ((coord[0] EQ 'GLAT') && (coord[1] EQ 'GLON')) || $ + ((coord[0] EQ 'ELAT') && (coord[1] EQ 'ELON')) + ENDELSE + if reverse then crval = rotate(crval,2) ;Invert CRVAL? + + if (ctype[0] EQ '') then begin + ctype = ['RA---TAN','DEC--TAN'] + message,'No CTYPE specified - assuming TANgent projection',/INF + endif + + spherical = strmid(astr.ctype[0],4,1) EQ '-' + if spherical then begin + IF astr2 THEN BEGIN + cylin = WHERE(astr.projection EQ ['CYP','CAR','MER','CEA','HPX'],Ncyl) + IF Ncyl GT 0 THEN BEGIN + testing = 1 + size_d = SIZE(d) + ndimd = size_d[0] + IF ndima GT 1 THEN a = REFORM(a, size_a[ndima+2], /OVERWRITE) + IF ndimd GT 1 THEN d = REFORM(d, size_d[ndimd+2], /OVERWRITE) + a0 = [a, 0d0,180d0] & d0 = [d, 0d0, 0d0] ; test points + wcssph2xy, a0, d0, xsi, eta, CTYPE = ctype, PV1 = astr.pv1, $ + PV2 = astr.pv2, CRVAL = crval, CRXY = astr.x0y0 + ENDIF ELSE BEGIN + pv1 = astr.pv1 + pv2 = astr.pv2 + if tag_exist(astr,'DISTORT') then $ + if astr.distort.name EQ 'TPV' then begin + pv1 = [0.0d,0,90.0d,180d,90d] ;Tangent projection + pv2 = [0.0,0.0] + ENDIF + wcssph2xy, a, d, xsi, eta, CTYPE = ctype, PV1 = pv1, $ + PV2 = pv2, CRVAL = crval, CRXY = astr.x0y0 + ENDELSE + ENDIF ELSE wcssph2xy, a, d, xsi, eta, CTYPE = ctype, PV2 = astr.pv2, $ + LONGPOLE = astr.longpole, CRVAL = crval, LATPOLE = astr.latpole + endif else begin + xsi = a - crval[0] & eta = d - crval[1] + endelse + cd = astr.cd + cdelt = astr.cdelt + + cd[0,0] *= cdelt[0] & cd[0,1] *= cdelt[0] + cd[1,1] *= cdelt[1] & cd[1,0] *= cdelt[1] + + if reverse then begin + temp = TEMPORARY(xsi) & xsi = TEMPORARY(eta) & eta = TEMPORARY(temp) + endif + + if tag_exist(astr,'DISTORT') && (astr.distort.name EQ 'TPV') then begin + ctype = strmid(astr.ctype,0,4) + '-TAN' + xcoeff = astr.pv1 + ycoeff = astr.pv2 + x0 = xcoeff[0] + y0 = ycoeff[0] + for i=0, N_elements(xsi)-1 do begin + xcoeff[0] = x0 - xsi[i] + ycoeff[0] = y0 - eta[i] + res = broyden([xsi[i],eta[i]], 'TPV_EVAL' ) + xsi[i] = res[0] + eta[i] = res[1] + endfor + ENDIF + if tag_exist(astr,'DISTORT') && (astr.distort.name EQ 'TNX') then begin + ctype = strmid(astr.ctype,0,4) + '-TAN' + xcoeff = astr.distort.lngcor + ycoeff = astr.distort.latcor + x0 = xcoeff.coeff[0] + y0 = ycoeff.coeff[0] + for i=0, N_elements(xsi)-1 do begin + xcoeff.coeff[0] = x0 - xsi[i] + ycoeff.coeff[0] = y0 - eta[i] + res = broyden([xsi[i],eta[i]], 'TNX_EVAL' ) + xsi[i] = res[0] + eta[i] = res[1] + endfor + ENDIF + + crpix = astr.crpix - 1 + + cdinv = invert(cd) + x = ( cdinv[0,0]*xsi + cdinv[0,1]*eta ) + y = ( cdinv[1,0]*TEMPORARY(xsi) + cdinv[1,1]*TEMPORARY(eta) ) + + if tag_exist(astr,'DISTORT') && ( astr.distort.name EQ 'SIP') then begin + distort = astr.distort + ap = distort.ap + bp = distort.bp + na = ((size(ap,/dimen))[0]) +; If reverse SIP coefficients are not supplied we iterate on the forward +; coefficients (using BROYDEN). + if na LE 1 then begin + xcoeff = distort.a + ycoeff = distort.b + x0 = xcoeff[0] + y0 = ycoeff[0] + for i=0, N_elements(x)-1 do begin + xcoeff[0] = x0 - x[i] + ycoeff[0] = y0 - y[i] + res = broyden([x[i],y[i]], 'SIP_EVAL' ) + x[i] = res[0] + y[i] = res[1] + endfor + endif else begin + xdif1 = x + ydif1 = y + for i=0,na-1 do begin + for j=0,na-1 do begin + if ap[i,j] NE 0.0 then xdif1 += x^i*y^j*ap[i,j] + if bp[i,j] NE 0.0 then ydif1 += x^i*y^j*bp[i,j] + endfor + endfor + + x = xdif1 + y = ydif1 + ENDELSE + ENDIF + + x += crpix[0] + y += crpix[1] + +; Check for wrapping in cylindrical projections: since the same phi +; appears at regular intervals in (x,y), depending on the location of +; the reference point on the pixel grid, some of the returned pixel +; values may be offset by 360 degrees from the ones we want. +; +; The pixel grid may be rotated relative to intermediate world coords, +; so the offset may have both x and y components in pixel space. +; +; Doesn't try if native and astronomical poles are misaligned +; as this fix doesn't work in that case. + + IF testing THEN BEGIN + npt = N_ELEMENTS(a) + x0 = x[npt:npt+1] & y0 = y[npt:npt+1] + x = x[0:npt-1] & y = y[0:npt-1] + + crval = astr.crval + IF astr.reverse THEN crval = REVERSE(crval) + WCS_GETPOLE, crval, astr.pv1[3]-astr.pv1[1], astr.pv1[2], $ + alpha_p, delta_p, $ + LATPOLE = astr.pv1[4], AT_POLE = at_pole + IF at_pole THEN BEGIN + naxis = astr.naxis + offmap = WHERE(x LT 0 OR y LT 0 OR $ + x GT naxis[0] OR y GT naxis[1], noff) + IF offmap[0] NE -1 THEN BEGIN + ; 360 degree shift + x360 = 2d0*(x0[1] - x0[0]) + y360 = 2d0*(y0[1] - y0[0]) + IF x360 LT 0 THEN BEGIN + x360 *= -1d0 + y360 *= -1d0 + ENDIF + xshift = x360 NE 0d0 + yshift = y360 NE 0d0 + ; Figure out which direction shift is + IF xshift THEN BEGIN + IF (MIN(x[offmap],/NAN) LT 0) THEN BEGIN + x[offmap] += x360 + IF yshift THEN y[offmap] += y360 + ENDIF ELSE IF MAX(x[offmap],/NAN) GT naxis[0] THEN BEGIN + x[offmap] -= x360 + IF yshift THEN y[offmap] -= y360 + ENDIF + ENDIF ELSE BEGIN + IF y360 LT 0 THEN BEGIN + x360 *= -1d0 + y360 *= -1d0 + ENDIF + IF (MIN(y[offmap],/NAN) LT 0) THEN BEGIN + IF xshift THEN x[offmap] += x360 + y[offmap] += y360 + ENDIF ELSE BEGIN + IF xshift THEN x[offmap] -= x360 + y[offmap] -= y360 + ENDELSE + ENDELSE + ENDIF + ENDIF + ENDIF + + + IF ndima GT 1 THEN BEGIN + a = REFORM(a, size_a[1:ndima], /OVERWRITE) + d = REFORM(d, size_a[1:ndima], /OVERWRITE) + x = REFORM(x, size_a[1:ndima], /OVERWRITE) + y = REFORM(y, size_a[1:ndima], /OVERWRITE) + ENDIF ELSE if ndima EQ 0 THEN BEGIN + a = a[0] + d = d[0] + x = x[0] + y = y[0] + ENDIF + + return + end diff --git a/modules/idl_downloads/astro/pro/add_distort.pro b/modules/idl_downloads/astro/pro/add_distort.pro new file mode 100644 index 0000000..ca871fd --- /dev/null +++ b/modules/idl_downloads/astro/pro/add_distort.pro @@ -0,0 +1,161 @@ + pro add_distort, hdr, astr +; NAME: +; ADD_DISTORT +; PURPOSE: +; Add the distortion parameters in an astrometry structure to a FITS header. +; EXPLANATION: +; Called by PUTAST to add SIP (http://fits.gsfc.nasa.gov/registry/sip.html ) +; or TNX ( http://fits.gsfc.nasa.gov/registry/tnx.html ) distortion +; parameters in an astrometry structure to a FITS header +; +; Prior to April 2012, PUTAST did not add distortion parameters so one +; had to call ADD_DISTORT after PUTAST. +; +; IDL> putast,h ,astr0 +; IDL> add_distort,h,astr0 +; +; CALLING SEQUENCE: +; add_distort, hdr, astr +; +; INPUTS: +; HDR - FITS header, string array. HDR will be updated to contain +; the supplied astrometry. +; ASTR - IDL structure containing values of the astrometry parameters +; CDELT, CRPIX, CRVAL, CTYPE, LONGPOLE, PV2, and DISTORT +; See EXTAST.PRO for more info about the structure definition +; +; PROCEDURES USED: +; SXADDPAR, TAG_EXIST() +; REVISION HISTORY: +; Written by W. Landsman May 2005 +; Enforce i+j = n for ij coefficients of order n W. Landsman April 2012 +; Support IRAF TNX distortion M. Sullivan March 2014 +;;- + npar = N_params() + + if ( npar LT 2 ) then begin ;Was header supplied? + print,'Syntax: ADD_DISTORT, Hdr, astr' + return + endif + + add_distort = tag_exist(astr,'distort') + IF(~ add_distort)THEN RETURN + + IF(astr.distort.name EQ 'SIP') then begin + + sxaddpar,hdr,'CTYPE1','RA---TAN-SIP' + sxaddpar,hdr,'CTYPE2','DEC--TAN-SIP' + distort = astr.distort + a_dimen = size(distort.a,/dimen) + b_dimen = size(distort.b,/dimen) + ap_dimen = size(distort.ap,/dimen) + bp_dimen = size(distort.bp,/dimen) + + if a_dimen[0] GT 0 then begin + a_order = a_dimen[0]-1 + sxaddpar, hdr, 'A_ORDER', a_order, /savec, $ + 'polynomial order, axis 1, detector to sky ' + for i=0, a_order do begin + for j = 0, a_order-i do begin + aij = distort.a[i,j] + if aij NE 0.0 then $ + sxaddpar, hdr, 'A_' + strtrim(i,2)+ '_' + strtrim(j,2), aij, $ + ' distortion coefficient', /savec + endfor + endfor + endif + + if b_dimen[0] GT 0 then begin + b_order = b_dimen[0]-1 + sxaddpar, hdr, 'B_ORDER', a_order, /savec , $ + 'polynomial order, axis 2, detector to sky' + for i=0, b_order do begin + for j = 0, b_order-i do begin + bij = distort.b[i,j] + if bij NE 0.0 then $ + sxaddpar, hdr, 'B_' + strtrim(i,2)+ '_' + strtrim(j,2), bij, $ + ' distortion coefficient', /savec + endfor + endfor + endif + + if ap_dimen[0] GT 0 then begin + ap_order = ap_dimen[0]-1 + sxaddpar, hdr, 'AP_ORDER', a_order, /savec, $ + ' polynomial order, axis 1, sky to detector ' + for i=0, ap_order do begin + for j = 0, ap_order-i do begin + apij = distort.ap[i,j] + if apij NE 0.0 then $ + sxaddpar, hdr, 'AP_' + strtrim(i,2)+ '_' + strtrim(j,2), apij, $ + ' distortion coefficient', /savec + endfor + endfor + endif + + + if bp_dimen[0] GT 0 then begin + bp_order = bp_dimen[0]-1 + sxaddpar, hdr, 'BP_ORDER', a_order, /savec, $ + ' polynomial order, axis 2, sky to detector ' + for i=0, bp_order do begin + for j = 0, bp_order-i do begin + bpij = distort.bp[i,j] + if bpij NE 0.0 then $ + sxaddpar, hdr, 'BP_' + strtrim(i,2)+ '_' + strtrim(j,2), bpij, $ + ' distortion coefficient', /savec + endfor + endfor + endif + + ENDIF ELSE IF(astr.distort.name EQ 'TNX')THEN BEGIN + + sxaddpar, hdr,'WAT0_001','system=image' + + string1='wtype=tnx axtype=ra lngcor = "3.' + string1+= ' '+STRN(astr.distort.lngcor.xiorder,FORMAT='(F2.0)') + string1+= ' '+STRN(astr.distort.lngcor.etaorder,FORMAT='(F2.0)') + string1+= ' '+STRN(astr.distort.lngcor.xterms,FORMAT='(F2.0)') + string1+= ' '+STRN(astr.distort.lngcor.ximin,FORMAT='(F19.16)') + string1+= ' '+STRN(astr.distort.lngcor.ximax,FORMAT='(F19.16)') + string1+= ' '+STRN(astr.distort.lngcor.etamin,FORMAT='(F19.16)') + string1+= ' '+STRN(astr.distort.lngcor.etamax,FORMAT='(F19.16)') + FOR i=0,N_ELEMENTS(astr.distort.lngcor.coeff)-1 DO BEGIN + string1+=' '+STRN(astr.distort.lngcor.coeff[i],FORMAT='(F19.16)') + ENDFOR + string1+= '"' + + string2='wtype=tnx axtype=dec latcor = "3. ' + string2+= ' '+STRN(astr.distort.latcor.xiorder,FORMAT='(F2.0)') + string2+= ' '+STRN(astr.distort.latcor.etaorder,FORMAT='(F2.0)') + string2+= ' '+STRN(astr.distort.latcor.xterms,FORMAT='(F2.0)') + string2+= ' '+STRN(astr.distort.latcor.ximin,FORMAT='(F19.16)') + string2+= ' '+STRN(astr.distort.latcor.ximax,FORMAT='(F19.16)') + string2+= ' '+STRN(astr.distort.latcor.etamin,FORMAT='(F19.16)') + string2+= ' '+STRN(astr.distort.latcor.etamax,FORMAT='(F19.16)') + FOR i=0,N_ELEMENTS(astr.distort.latcor.coeff)-1 DO BEGIN + string2+= ' '+STRN(astr.distort.latcor.coeff[i],FORMAT='(F19.16)') + ENDFOR + string2+= '"' + + len1=STRLEN(string1) + n1=len1/70 + IF(len1 MOD 68 GT 0)THEN n1++ + FOR i=0,n1-1 DO BEGIN + s=STRMID(string1,i*68,68) +; PRINT,'WAT1_'+STRN(i+1,FORMAT='(I3.3)'),' ',s + sxaddpar, hdr,'WAT1_'+STRN(i+1,FORMAT='(I3.3)'),s + ENDFOR + len2=STRLEN(string2) + n2=len2/70 + IF(len2 MOD 68 GT 0)THEN n2++ + FOR i=0,n2-1 DO BEGIN + s=STRMID(string2,i*68,68) +; PRINT,'WAT1_'+STRN(i+1,FORMAT='(I3.3)'),' ',s + sxaddpar, hdr,'WAT2_'+STRN(i+1,FORMAT='(I3.3)'),s + ENDFOR + + ENDIF + + return + end diff --git a/modules/idl_downloads/astro/pro/adstring.pro b/modules/idl_downloads/astro/pro/adstring.pro new file mode 100644 index 0000000..3e0ba13 --- /dev/null +++ b/modules/idl_downloads/astro/pro/adstring.pro @@ -0,0 +1,208 @@ +Function adstring,ra_dec,dec,precision, TRUNCATE = truncate,PRECISION=prec +;+ +; NAME: +; ADSTRING +; PURPOSE: +; Return RA and Dec as character string(s) in sexagesimal format. +; EXPLANATION: +; RA and Dec may be entered as either a 2 element vector or as +; two separate vectors (or scalars). One can also specify the precision +; of the declination in digits after the decimal point. +; +; CALLING SEQUENCE +; result = ADSTRING( ra_dec, precision, /TRUNCATE ) +; or +; result = ADSTRING( ra,dec,[ precision, /TRUNCATE ] ) +; or +; result = ADSTRING( dec, [ PRECISION= ] +; +; INPUTS: +; RA_DEC - 2 element vector giving the Right Ascension and declination +; in decimal degrees. +; or +; RA - Right ascension in decimal degrees, numeric scalar or vector +; DEC - Declination in decimal degrees, numeric scalar or vector +; +; If only one parameter is supplied then it must be either a scalar (which +; is converted to sexagesimal) or a two element [RA, Dec] vector. +; OPTIONAL INPUT: +; PRECISION - Integer scalar (0-4) giving the number of digits after the +; decimal of DEClination. The RA is automatically 1 digit more. +; This parameter may either be the third parameter after RA,DEC +; or the second parameter after [RA,DEC]. If only DEC is supplied +; then precision must be supplied as a keyword parameter. If no +; PRECISION parameter or keyword is passed, a precision of 1 for +; both RA and DEC is returned to maintain compatibility with past +; ADSTRING versions. Values of precision larger than 4 will +; be truncated to 4. If PRECISION is 3 or 4, then RA and Dec +; should be input as double precision. +; OPTIONAL INPUT KEYWORD: +; /TRUNCATE - if set, then the last displayed digit in the output is +; truncated in precision rather than rounded. This option is +; useful if ADSTRING() is used to form an official IAU name +; (see http://vizier.u-strasbg.fr/Dic/iau-spec.htx) with +; coordinate specification. The IAU name will typically be +; be created by applying STRCOMPRESS/REMOVE) after the ADSTRING() +; call, e.g. +; strcompress( adstring(ra,dec,0,/truncate), /remove) ;IAU format +; PRECISION = Alternate method of supplying the precision parameter, +; OUTPUT: +; RESULT - Character string(s) containing HR,MIN,SEC,DEC,MIN,SEC formatted +; as ( 2I3,F5.(p+1),2I3,F4.p ) where p is the PRECISION +; parameter. If only a single scalar is supplied it is +; converted to a sexagesimal string (2I3,F5.1). +; +; EXAMPLE: +; (1) Display CRVAL coordinates in a FITS header, H +; +; IDL> crval = sxpar(h,'CRVAL*') ;Extract 2 element CRVAL vector (degs) +; IDL> print, adstring(crval) ;Print CRVAL vector sexagesimal format +; +; (2) print,adstring(30.42,-1.23,1) ==> ' 02 01 40.80 -01 13 48.0' +; print,adstring(30.42,+0.23) ==> ' 02 01 40.8 +00 13 48.0' +; print,adstring(+0.23) ==> '+00 13 48.0' +; +; (3) The first two calls in (2) can be combined in a single call using +; vector input +; print,adstring([30.42,30.42],[-1.23,0.23], 1) +; PROCEDURES CALLED: +; RADEC, SIXTY() +; +; REVISION HISTORY: +; Written W. Landsman June 1988 +; Addition of variable precision and DEC seconds precision fix. +; ver. Aug. 1990 [E. Deutsch] +; Output formatting spiffed up October 1991 [W. Landsman] +; Remove ZPARCHECK call, accept 1 element vector April 1992 [W. Landsman] +; Call ROUND() instead of NINT() February 1996 [W. Landsman] +; Check roundoff past 60s October 1997 [W. Landsman] +; Work for Precision =4 November 1997 [W. Landsman] +; Major rewrite to allow vector inputs W. Landsman February 2000 +; Fix possible error in seconds display when Precision=0 +; P. Broos/W. Landsman April 2002 +; Added /TRUNCATE keyword, put leading zeros in seconds display +; P. Broos/W. Landsman September 2002 +; Fix declination zero values under vector processing W.Landsman Feb 2004 +; Fix possible problem in leading zero display W. Landsman June 2004 +; Assume since V5.4, omit fstring() call W. Landsman April 2006 +; Fix significant bug when round a declination with -199.99 W. L. Sep 2012 +;- + On_error,2 + compile_opt idl2 + + Npar = N_params() + + + case N_elements(ra_dec) of + + 1: if ( Npar EQ 1 ) then dec = ra_dec else ra = ra_dec + 2: begin + if (N_elements(dec) LT 2) then begin + ra = ra_dec[0] mod 360. + if N_elements(dec) EQ 1 then begin + precision = dec & Npar=3 & endif + dec = ra_dec[1] + endif else ra = ra_dec + end + else: begin + If (Npar Eq 1) then message, $ + 'ERROR - first parameter must be either a scalar or 2 element vector' + ra = ra_dec + end + endcase + + if N_elements(prec) EQ 1 then precision = prec + + if ( Npar GE 2 ) then $ + if N_elements(dec) NE N_elements(ra) then message, $ + 'ERROR - RA and Declination do not have equal number of elements' + + if N_elements(ra) EQ N_elements(dec) then begin + + badrange = where( (dec LT -90.) or (dec GT 90.), Nbad) + if Nbad GT 0 then message, /INF, $ + 'WARNING - Some declination values are out of valid range (-90 < dec <90)' + radec, ra, dec, ihr, imin, xsec, ideg, imn, xsc + if N_elements(precision) EQ 0 then precision = 0 + precision = precision > 0 < 4 ;No more than 4 decimal places + if ~keyword_set(truncate) then begin + roundsec = [59.5,59.95,59.995,59.9995,59.99995,59.999995] + carry = where(xsec GT roundsec[precision+1], Ncarry) + if Ncarry GT 0 then begin + imin[carry] = imin[carry] + 1 + xsec[carry] = 0.0 + mcarry = where(imin[carry] EQ 60, Nmcarry) + if Nmcarry GT 0 then begin + ic = carry[mcarry] + ihr[ic] = (ihr[ic] + 1) mod 24 + imin[ic] = 0 + endif + endif + endif else xsec = (long(xsec*10L^(precision+1)))/10.0d^(precision+1) + + secfmt = '(F0' + string( 3+precision+1,'(I1)' ) + '.' + $ + string( precision+1,'(I1)' ) + ')' + result = string(ihr,'(I3.2)') + string(imin,'(I3.2)') + ' ' +$ + strtrim(string(xsec,secfmt),2) + ' ' + if N_elements(precision) EQ 0 then precision = 1 + + endif else begin + + x = sixty(dec) + if N_elements(precision) EQ 0 then precision = 1 + ideg = fix(x[0]) & imn = fix(x[1]) & xsc = x[2] + result = '' + + endelse + + imn = abs(imn) & xsc = abs(xsc) + if ( precision EQ 0 ) then begin + secfmt = '(I03.2)' + if ~keyword_set(truncate) then begin + xsc = round(xsc) + carry = where(xsc EQ 60, Ncarry) + if Ncarry GT 0 then begin ;Updated April 2002 + xsc[carry] = 0 + imn[carry] = imn[carry] + 1 + endif + endif + endif else begin + + secfmt = '(F0' + string( 3+precision,'(I1)') + '.' + $ + string( precision,'(I1)') + ')' + + if ~keyword_set(truncate) then begin + ixsc = fix(xsc + 0.5/10^precision) + carry = where(ixsc GE 60, Ncarry) + if Ncarry GT 0 then begin + xsc[carry] = 0. + imn[carry] = imn[carry] + 1 + endif + endif else $ + xsc = (long(xsc*10^precision))/10.0d^precision + endelse + + pos = dec GE 0 + carry = where(imn EQ 60, Ncarry) + if Ncarry GT 0 then begin + ideg[carry] = ideg[carry] -1 + 2*pos[carry] + imn[carry] = 0 + endif + + deg = string(ideg,'(I+3.2)') + big = where(abs(ideg) ge 100, Nbig) + if Nbig GT 0 then deg[big] = string(ideg[big],'(I+4.3)') + zero = where(ideg EQ 0, Nzero) + if Nzero GT 0 then begin + negzero = where( dec[zero] LT 0, Nneg) + if Nneg GT 0 then deg[zero[negzero]] = '-00' + endif + + + return, result + deg + string(imn,'(I3.2)') + ' ' + $ + strtrim(string(xsc,secfmt),2) + + end diff --git a/modules/idl_downloads/astro/pro/adxy.pro b/modules/idl_downloads/astro/pro/adxy.pro new file mode 100644 index 0000000..736a772 --- /dev/null +++ b/modules/idl_downloads/astro/pro/adxy.pro @@ -0,0 +1,139 @@ +pro adxy, hdr, a, d, x, y, PRINT = print, ALT = alt ;Ra, Dec to X,Y +;+ +; NAME: +; ADXY +; PURPOSE: +; Use a FITS header to convert astronomical to pixel coordinates +; EXPLANATION: +; Use an image header to compute X and Y positions, given the +; RA and Dec (or longitude, latitude) in decimal degrees. +; +; CALLING SEQUENCE: +; ADXY, HDR ;Prompt for Ra and DEC +; ADXY, hdr, a, d, x, y, [ /PRINT, ALT= ] +; +; INPUTS: +; HDR - FITS Image header containing astrometry parameters +; +; OPTIONAL INPUTS: +; A - Right ascension in decimal DEGREES, scalar or vector +; D - Declination in decimal DEGREES, scalar or vector +; +; If A and D are not supplied, user will be prompted to supply +; them in either decimal degrees or HR,MIN,SEC,DEG,MN,SC format. +; +; OPTIONAL OUTPUT: +; X - row position in pixels, same number of elements as A and D +; Y - column position in pixels +; +; X and Y will be in standard IDL convention (first pixel is 0) and not +; the FITS convention (first pixel is 1). As in FITS an integral +; value corresponds to the center of a pixel. +; OPTIONAL KEYWORD INPUT: +; /PRINT - If this keyword is set and non-zero, then results are displayed +; at the terminal. +; ALT - single character 'A' through 'Z' or ' ' specifying an alternate +; astrometry system present in the FITS header. The default is +; to use the primary astrometry or ALT = ' '. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. +; +; OPERATIONAL NOTES: +; If less than 5 parameters are supplied, or if the /PRINT keyword is +; set, then the X and Y positions are displayed at the terminal. +; +; If the procedure is to be used repeatedly with the same header, +; then it would be faster to use AD2XY. +; +; PROCEDURES CALLED: +; AD2XY, ADSTRING(), EXTAST, GETOPT(), TEN() +; +; REVISION HISTORY: +; W. Landsman HSTX January, 1988 +; Use astrometry structure W. Landsman January, 1994 +; Changed default ADSTRING format W. Landsman September, 1995 +; Check if latitude/longitude reversed in CTYPE keyword W. L. Feb. 2004 +; Added ALT keyword W. Landsman September 2004 +; Work for non-spherical coordinate transformation W. Landsman May 2005 +; More informative error message if astrometry missing W.L. Feb 2008 +; Cosmetic updates W.L. July 2011 +; Use version 2 astrometry structure J. P. Leahy July 2013 +;- + Compile_opt idl2 + On_error,2 + + npar = N_params() + + if ( npar EQ 0 ) then begin + print,'Syntax - ADXY, hdr, [a, d, x, y, /PRINT, ALT= ]' + print,'If supplied, A and D must be in decimal DEGREES' + return + endif + + extast, hdr, astr, noparams, ALT = alt ;Extract astrometry from FITS header + if ( noparams LT 0 ) then begin + if alt EQ '' then $ + message,'ERROR - No astrometry info in supplied FITS header' $ + else message, $ + 'ERROR - No alt=' + alt + ' astrometry info in supplied FITS header' + endif + + astr2 = TAG_EXIST(astr,'AXES') ; Version 2 structure + + if npar lt 3 then begin + RD: print,'Coordinates must be entered in either decimal (2 parameter) ' + print,' or sexagesimal (6 parameter) format' + inp = '' + read,'ADXY: Enter coordinates: ',inp + radec = getopt(inp,'F') + case N_elements(radec) of + 2: begin + a = radec[0] & d = radec[1] + end + 6: begin + a = ten(radec[0:2]*15.) & d = ten(radec[3:5]) + end + else: begin + print,'ADXY: ERROR - Either 2 or 6 parameters must be entered' + return + end + endcase + endif + + case strmid( astr.ctype[0], 5,3) of + 'GSS': gsssadxy, astr, a, d, x, y ;HST Guide star astrometry + else: ad2xy, a, d, astr, x, y ;All other cases + endcase + + if (npar lt 5) || keyword_set( PRINT ) then begin + npts = N_elements(a) + tit = strmid(astr.ctype,0,4) + spherical = strmid(astr.ctype[0],4,1) EQ '-' + if spherical then begin + fmt = '(2F9.4,A,2X,2F8.2)' + str = adstring(a,d,1) + tit = strmid(astr.ctype,0,4) + tit = repchr(tit,'-',' ') + flip = astr2 ? astr.reverse : $ + (tit[0] EQ 'DEC ') || (tit[0] EQ 'ELAT') || (tit[0] EQ 'GLAT') + if flip then tit = rotate(tit,2) + print,' ' + tit[0] + ' ' + tit[1] + ' ' + tit[0] + $ + ' ' + tit[1] + ' X Y' + for i = 0l, npts-1 do $ + print,FORMAT = fmt, a[i], d[i], str[i], x[i], y[i] + endif else begin + unit1 = strtrim( sxpar( hdr, 'CUNIT1'+alt,count = N_unit1),2) + if N_unit1 EQ 0 then unit1 = '' + unit2 = strtrim( sxpar( hdr, 'CUNIT2'+alt,count = N_unit2),2) + if N_unit2 EQ 0 then unit2 = '' + print,' ' + tit[0] + ' ' + tit[1] + ' X Y' + if (N_unit1 GT 0) || (N_unit2 GT 0) then $ + print,unit1 ,unit2,f='(t5,a,t14,a)' + for i=0l, npts-1 do $ + print, a[i], d[i], x[i], y[i], f='(2F9.4,2X,2F8.2)' + endelse + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/airtovac.pro b/modules/idl_downloads/astro/pro/airtovac.pro new file mode 100644 index 0000000..1cbdd01 --- /dev/null +++ b/modules/idl_downloads/astro/pro/airtovac.pro @@ -0,0 +1,67 @@ +pro airtovac,wave_air, wave_vac +;+ +; NAME: +; AIRTOVAC +; PURPOSE: +; Convert air wavelengths to vacuum wavelengths +; EXPLANATION: +; Wavelengths are corrected for the index of refraction of air under +; standard conditions. Wavelength values below 2000 A will not be +; altered. Uses relation of Ciddor (1996). +; +; CALLING SEQUENCE: +; AIRTOVAC, WAVE_AIR, [ WAVE_VAC] +; +; INPUT/OUTPUT: +; WAVE_AIR - Wavelength in Angstroms, scalar or vector +; If this is the only parameter supplied, it will be updated on +; output to contain double precision vacuum wavelength(s). +; OPTIONAL OUTPUT: +; WAVE_VAC - Vacuum wavelength in Angstroms, same number of elements as +; WAVE_AIR, double precision +; +; EXAMPLE: +; If the air wavelength is W = 6056.125 (a Krypton line), then +; AIRTOVAC, W yields an vacuum wavelength of W = 6057.8019 +; +; METHOD: +; Formula from Ciddor 1996, Applied Optics 62, 958 +; +; NOTES: +; Take care within 1 A of 2000 A. Wavelengths below 2000 A *in air* are +; not altered. +; REVISION HISTORY +; Written W. Landsman November 1991 +; Use Ciddor (1996) formula for better accuracy in the infrared +; Added optional output vector, W Landsman Mar 2011 +; Iterate for better precision W.L./D. Schlegel Mar 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - AIRTOVAC, WAVE_AIR, [WAVE_VAC]' + print,'WAVE_AIR (Input) is the air wavelength in Angstroms' + return + endif + + wave_vac = double(wave_air) + g = where(wave_vac GE 2000, Ng) ;Only modify above 2000 A + + if Ng GT 0 then begin + + for iter=0, 1 do begin + sigma2 = (1d4/double(wave_vac[g]) )^2. ;Convert to wavenumber squared + +; Compute conversion factor + fact = 1.D + 5.792105D-2/(238.0185D0 - sigma2) + $ + 1.67917D-3/( 57.362D0 - sigma2) + + + wave_vac[g] = wave_air[g]*fact ;Convert Wavelength + endfor + if N_params() EQ 1 then wave_air = wave_vac + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/aitoff.pro b/modules/idl_downloads/astro/pro/aitoff.pro new file mode 100644 index 0000000..6e7fbee --- /dev/null +++ b/modules/idl_downloads/astro/pro/aitoff.pro @@ -0,0 +1,56 @@ +pro aitoff,l,b,x,y +;+ +; NAME: +; AITOFF +; PURPOSE: +; Convert longitude, latitude to X,Y using an AITOFF projection. +; EXPLANATION: +; This procedure can be used to create an all-sky map in Galactic +; coordinates with an equal-area Aitoff projection. Output map +; coordinates are zero longitude centered. +; +; CALLING SEQUENCE: +; AITOFF, L, B, X, Y +; +; INPUTS: +; L - longitude - scalar or vector, in degrees +; B - latitude - same number of elements as L, in degrees +; +; OUTPUTS: +; X - X coordinate, same number of elements as L. X is normalized to +; be between -180 and 180 +; Y - Y coordinate, same number of elements as L. Y is normalized to +; be between -90 and 90. +; +; NOTES: +; See AIPS memo No. 46, page 4, for details of the algorithm. This +; version of AITOFF assumes the projection is centered at b=0 degrees. +; +; REVISION HISTORY: +; Written W.B. Landsman STX December 1989 +; Modified for Unix: +; J. Bloch LANL SST-9 5/16/91 1.1 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + if N_params() ne 4 then begin + print,'Syntax - AITOFF, L, B, X, Y' + return + endif + + sa = l + if N_elements(sa) eq 1 then sa = fltarr(1) + sa + x180 = where (sa gt 180.0) + if x180[0] ne -1 then sa[x180] = sa[x180] - 360. + alpha2 = sa/(2*!RADEG) + delta = b/!RADEG + r2 = sqrt(2.) + f = 2*r2/!PI + cdec = cos(delta) + denom =sqrt(1. + cdec*cos(alpha2)) + x = cdec*sin(alpha2)*2.*r2/denom + y = sin(delta)*r2/denom + x = x*!radeg/f + y = y*!radeg/f + + return + end diff --git a/modules/idl_downloads/astro/pro/aitoff_grid.pro b/modules/idl_downloads/astro/pro/aitoff_grid.pro new file mode 100644 index 0000000..62e45f9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/aitoff_grid.pro @@ -0,0 +1,144 @@ +;+ +; NAME: +; AITOFF_GRID +; +; PURPOSE: +; Produce an overlay of latitude and longitude lines over a plot or image +; EXPLANATION: +; The grid is plotted on the current graphics device. AITOFF_GRID +; assumes that the ouput plot coordinates span the x-range of +; -180 to 180 and the y-range goes from -90 to 90. +; +; CALLING SEQUENCE: +; +; AITOFF_GRID [,DLONG,DLAT, LABEL=, /NEW, CHARTHICK=, CHARSIZE=, +; FONT=, _EXTRA=] +; +; OPTIONAL INPUTS: +; +; DLONG = Optional input longitude line spacing in degrees. If left +; out, defaults to 30. +; DLAT = Optional input latitude line spacing in degrees. If left +; out, defaults to 30. +; +; OPTIONAL INPUT KEYWORDS: +; +; LABEL = Optional keyword specifying that the latitude and +; longitude lines on the prime meridian and the +; equator should be labeled in degrees. If LABELS is +; given a value of 2, i.e. LABELS=2, then the longitude +; labels will be in hours instead of degrees. +; CHARSIZE = If /LABEL is set, then CHARSIZE specifies the size +; of the label characters (passed to XYOUTS) +; CHARTHICK = If /LABEL is set, then CHARTHICK specifies the +; thickness of the label characters (passed to XYOUTS) +; FONT = scalar font graphics keyword (-1,0 or 1) for text +; /NEW = If this keyword is set, then AITOFF_GRID will create +; a new plot grid, rather than overlay an existing plot. +; +; Any valid keyword to OPLOT such as COLOR, LINESTYLE, THICK can be +; passed to AITOFF_GRID (though the _EXTRA facility) to to specify the +; color, style, or thickness of the grid lines. +; OUTPUTS: +; Draws grid lines on current graphics device. +; +; EXAMPLE: +; Create a labeled Aitoff grid of the Galaxy, and overlay stars at +; specified Galactic longitudes, glong and latitudes, glat +; +; IDL> aitoff_grid,/label,/new ;Create labeled grid +; IDL> aitoff, glong, glat, x,y ;Convert to X,Y coordinates +; IDL> plots,x,y,psym=2 ;Overlay "star" positions +; +; PROCEDURES USED: +; AITOFF +; NOTES: +; If labeling in hours (LABEL=2) then the longitude spacing should be +; a multiple of 15 degrees +; +; AUTHOR AND MODIFICATIONS: +; +; J. Bloch 1.2 6/2/91 +; Converted to IDL V5.0 W. Landsman September 1997 +; Create default plotting coords, if needed W. Landsman August 2000 +; Added _EXTRA, CHARTHICK, CHARSIZE keywords W. Landsman March 2001 +; Several tweaks, plot only hours not minutes W. Landsman January 2002 +; Allow FONT keyword to be passed to XYOUTS. T. Robishaw Apr. 2006 +;- +PRO AITOFF_GRID,DLONG,DLAT,LABEL=LABEL, NEW = new, _EXTRA= E, $ + CHARSIZE = charsize, CHARTHICK =charthick, FONT=font + + if N_elements(dlong) EQ 0 then dlong = 30.0 + if N_elements(dlat) EQ 0 then dlat = 30.0 + if N_elements(font) EQ 0 then font = !p.font + +; If no plotting axis has been defined, then create a default one + + new = keyword_set(new) + if not new then new = (!X.crange[0] EQ 0) and (!X.crange[1] EQ 0) + if new then plot,[-180,180],[-90,90],/nodata,xsty=5,ysty=5 +; +; Do lines of constant longitude +; + lat=findgen(181)-90 + lng=fltarr(181,/nozero) + lngtot = long(180.0/dlong) + + for i=0,lngtot do begin + replicate_inplace, lng, -180.0 + (i*dlong) + aitoff,lng,lat,x,y + oplot,x,y,_extra=e + oplot,-x,y,_extra=e + endfor +; +; Do lines of constant latitude +; + lng = findgen(361)-180.0 + lat = fltarr(361,/nozero) + lattot=long(180.0/dlat) + for i=1,lattot do begin + replicate_inplace, lat, -90. + (i*dlat) + aitoff,lng,lat,x,y + oplot,x,y,_extra=e + endfor +; +; Do labeling if requested +; + if keyword_set(label) then begin + +; +; Label equator +; + if (!d.name eq 'PS') and (font eq 0) then hr = '!Uh!N' else hr='h' + xoff = 2*dlong/30. + for i=0,2*lngtot-1 do begin + lng = (180 + (i*dlong)) mod 360 + if (lng ne 0.0) and (lng ne 180.0) then begin + aitoff,lng,0.0,x,y + if label eq 1 then xyouts,x[0]+xoff,y[0]+1,$ + strcompress(string(lng,format="(I4)"),/remove_all), $ + charsize = charsize, charthick = charthick,font=font $ + else begin + tmp = lng/15. + xyouts,round(x[0])+xoff,round(y[0])+1,string(tmp[0],$ + format='(I2)') + hr, font=font,$ + charsize = charsize, charthick = charthick + endelse + endif + endfor +; +; Label prime meridian +; + lat = -90 + (indgen(lattot-1)+1)*dlat + aitoff,fltarr(lattot-1),lat,x,y + slat = strtrim(round(lat),2) + pos = where(lat GT 0, Npos) + if Npos GT 0 then slat[pos] = '+' + slat[pos] + for i=0,lattot-2 do begin + xyouts,x[i]+2,y[i]+1, slat[i], font=font, $ + charsize = charsize, charthick = charthick + endfor + endif + + return +end diff --git a/modules/idl_downloads/astro/pro/al_legend.pro b/modules/idl_downloads/astro/pro/al_legend.pro new file mode 100644 index 0000000..74c02f6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/al_legend.pro @@ -0,0 +1,572 @@ +;+ +; NAME: +; AL_LEGEND +; PURPOSE: +; Create an annotation legend for a plot. +; EXPLANATION: +; +; This procedure makes a legend for a plot. The legend can contain +; a mixture of symbols, linestyles, Hershey characters (vectorfont), +; and filled polygons (usersym). A test procedure, al_legendtest.pro, +; shows legend's capabilities. Placement of the legend is controlled +; with keywords like /right, /top, and /center or by using a position +; keyword for exact placement (position=[x,y]) or via mouse (/position). +; +; The procedure CGLEGEND in the Coyote library provides a similar +; capability. https://www.idlcoyote.com/idldoc/cg/cglegend.html +; CALLING SEQUENCE: +; AL_LEGEND [,items][,keyword options] +; EXAMPLES: +; The call: +; al_legend,['Plus sign','Asterisk','Period'],psym=[1,2,3] +; produces: +; ----------------- +; | | +; | + Plus sign | +; | * Asterisk | +; | . Period | +; | | +; ----------------- +; Each symbol is drawn with a cgPlots command, so they look OK. +; Other examples are given in optional output keywords. +; +; lines = indgen(6) ; for line styles +; items = 'linestyle '+strtrim(lines,2) ; annotations +; al_legend,items,linestyle=lines ; vertical legend---upper left +; items = ['Plus sign','Asterisk','Period'] +; sym = [1,2,3] +; al_legend,items,psym=sym ; ditto except using symbols +; al_legend,items,psym=sym,/horizontal ; horizontal format +; al_legend,items,psym=sym,box=0 ; sans border +; al_legend,items,psym=sym,delimiter='=' ; embed '=' betw psym & text +; al_legend,items,psym=sym,margin=2 ; 2-character margin +; al_legend,items,psym=sym,position=[x,y] ; upper left in data coords +; al_legend,items,psym=sym,pos=[x,y],/norm ; upper left in normal coords +; al_legend,items,psym=sym,pos=[x,y],/device ; upper left in device coords +; al_legend,items,psym=sym,/position ; interactive position +; al_legend,items,psym=sym,/right ; at upper right +; al_legend,items,psym=sym,/bottom ; at lower left +; al_legenditems,psym=sym,/center ; approximately near center +; al_legend,items,psym=sym,number=2 ; plot two symbols, not one +; Plot 3 filled colored squares +; al_legend,items,/fill,psym=[8,8,8],colors=['red','green','blue'] +; +; Another example of the use of AL_LEGEND can be found at +; http://www.idlcoyote.com/cg_tips/al_legend.php +; INPUTS: +; items = text for the items in the legend, a string array. +; For example, items = ['diamond','asterisk','square']. +; You can omit items if you don't want any text labels. The +; text can include many LaTeX symbols (e.g. $\leq$) for a less +; than equals symbol) as described in cgsymbol.pro. +; OPTIONAL INPUT KEYWORDS: +; +; linestyle = array of linestyle numbers If linestyle[i] < 0, then omit +; ith symbol or line to allow a multi-line entry. If +; linestyle = -99 then text will be left-justified. +; psym = array of plot symbol numbers or names. If psym[i] is negative, +; then a line connects pts for ith item. If psym[i] = 8, then the +; procedure USERSYM is called with vertices defined in the +; keyword usersym. If psym[i] = 88, then use the previously +; defined user symbol. If 11 <= psym[i] <= 46 then David +; Fanning's function CGSYMCAT() will be used for additional +; symbols. Note that PSYM=10 (histogram plot mode) is not +; allowed since it cannot be used with the cgPlots command. +; vectorfont = vector-drawn characters for the sym/line column, e.g., +; ['!9B!3','!9C!3','!9D!3'] produces an open square, a checkmark, +; and a partial derivative, which might have accompanying items +; ['BOX','CHECK','PARTIAL DERIVATIVE']. +; There is no check that !p.font is set properly, e.g., -1 for +; X and 0 for PostScript. This can produce an error, e.g., use +; !20 with PostScript and !p.font=0, but allows use of Hershey +; *AND* PostScript fonts together. +; N. B.: Choose any of linestyle, psym, and/or vectorfont. If none is +; present, only the text is output. If more than one +; is present, all need the same number of elements, and normal +; plot behaviour occurs. +; By default, if psym is positive, you get one point so there is +; no connecting line. If vectorfont[i] = '', +; then cgPlots is called to make a symbol or a line, but if +; vectorfont[i] is a non-null string, then cgText is called. +; /help = flag to print header +; /horizontal = flag to make the legend horizontal +; /vertical = flag to make the legend vertical (D=vertical) +; background_color - color name or number to fill the legend box. +; Automatically sets /clear. (D = -1) +; box = flag to include/omit box around the legend (D=include) +; outline_color = color of box outline (D = !P.color) +; bthick = thickness of the legend box (D = !P.thick) +; charsize = just like !p.charsize for plot labels +; charthick = just like !p.charthick for plot labels +; clear = flag to clear the box area before drawing the legend +; colors = array of colors names or numbers for plot symbols/lines +; See cgCOLOR for list of color names. Default is 'Opposite' +; If you are using index colors (0-255), then supply color as a byte, +; integer or string, but not as a long, which will be interpreted as +; a decomposed color. See http://www.idlcoyote.com/cg_tips/legcolor.php +; delimiter = embedded character(s) between symbol and text (D=none) +; font = scalar font graphics keyword (-1,0 or 1) for text +; linsize = Scale factor for line length (0-1), default = 1 +; Set to 0 to give a dot, 0.5 give half default line length +; margin = margin around text measured in characters and lines +; number = number of plot symbols to plot or length of line (D=1) +; spacing = line spacing (D=bit more than character height) +; position = data coordinates of the /top (D) /left (D) of the legend +; pspacing = psym spacing (D=3 characters) (when number of symbols is +; greater than 1) +; textcolors = array of color names or numbers for text. See cgCOLOR +; for a list of color names. Default is 'Opposite' of background +; thick = array of line thickness numbers (D = !P.thick), if used, then +; linestyle must also be specified +; normal = use normal coordinates for position, not data +; device = use device coordinates for position, not data +; /window - if set then send legend to a resizeable graphics window +; usersym = 2-D array of vertices, cf. usersym in IDL manual. +; (/USERSYM =square, default is to use existing USERSYM definition) +; /fill = flag to fill the usersym +; /left_legend = flag to place legend snug against left side of plot +; window (D) +; /right_legend = flag to place legend snug against right side of plot +; window. If /right,pos=[x,y], then x is position of RHS and +; text runs right-to-left. +; /top_legend = flag to place legend snug against top of plot window (D) +; /bottom = flag to place legend snug against bottom of plot window +; /top,pos=[x,y] and /bottom,pos=[x,y] produce same positions. +; +; If LINESTYLE, PSYM, VECTORFONT, SYMSIZE, THICK, COLORS, or +; TEXTCOLORS are supplied as scalars, then the scalar value is set for +; every line or symbol in the legend. +; Outputs: +; legend to current plot device +; OPTIONAL OUTPUT KEYWORDS: +; corners = 4-element array, like !p.position, of the normalized +; coords for the box (even if box=0): [llx,lly,urx,ury]. +; Useful for multi-column or multi-line legends, for example, +; to make a 2-column legend, you might do the following: +; c1_items = ['diamond','asterisk','square'] +; c1_psym = [4,2,6] +; c2_items = ['solid','dashed','dotted'] +; c2_line = [0,2,1] +; al_legend,c1_items,psym=c1_psym,corners=c1,box=0 +; al_legend,c2_items,line=c2_line,corners=c2,box=0,pos=[c1[2],c1[3]] +; c = [c1[0]c2[2],c1[3]>c2[3]] +; cgplots,[c[0],c[0],c[2],c[2],c[0]],[c[1],c[3],c[3],c[1],c[1]],/norm +; +; Useful also to place the legend. Here's an automatic way to place +; the legend in the lower right corner. The difficulty is that the +; legend's width is unknown until it is plotted. In this example, +; the legend is plotted twice: the first time in the upper left, the +; second time in the lower right. +; +; al_legend,['1','22','333','4444'],linestyle=indgen(4),corners=corners +; ; BOGUS LEGEND---FIRST TIME TO REPORT CORNERS +; xydims = [corners[2]-corners[0],corners[3]-corners[1]] +; ; SAVE WIDTH AND HEIGHT +; chdim=[!d.x_ch_size/float(!d.x_size),!d.y_ch_size/float(!d.y_size)] +; ; DIMENSIONS OF ONE CHARACTER IN NORMALIZED COORDS +; pos = [!x.window[1]-chdim[0]-xydims[0] $ +; ,!y.window[0]+chdim[1]+xydims[1]] +; ; CALCULATE POSITION FOR LOWER RIGHT +; cgplot,findgen(10) ; SIMPLE PLOT; YOU DO WHATEVER YOU WANT HERE. +; al_legend,['1','22','333','4444'],linestyle=indgen(4),pos=pos +; ; REDO THE LEGEND IN LOWER RIGHT CORNER +; You can modify the pos calculation to place the legend where you +; want. For example to place it in the upper right: +; pos = [!x.window[1]-chdim[0]-xydims[0],!y.window[1]-xydims[1]] +; Common blocks: +; none +; Procedure: +; If keyword help is set, call doc_library to print header. +; See notes in the code. Much of the code deals with placement of the +; legend. The main problem with placement is not being +; able to sense the length of a string before it is output. Some crude +; approximations are used for centering. +; Restrictions: +; Here are some things that aren't implemented. +; - An orientation keyword would allow lines at angles in the legend. +; - An array of usersyms would be nice---simple change. +; - An order option to interchange symbols and text might be nice. +; - Somebody might like double boxes, e.g., with box = 2. +; - Another feature might be a continuous bar with ticks and text. +; - There are no guards to avoid writing outside the plot area. +; - There is no provision for multi-line text, e.g., '1st line!c2nd line' +; Sensing !c would be easy, but !c isn't implemented for PostScript. +; A better way might be to simply output the 2nd line as another item +; but without any accompanying symbol or linestyle. A flag to omit +; the symbol and linestyle is linestyle[i] = -1. +; - There is no ability to make a title line containing any of titles +; for the legend, for the symbols, or for the text. +; Notes: +; This procedure was originally named LEGEND, but a distinct LEGEND() +; function was introduced into IDL V8.0. Therefore, the +; original LEGEND procedure was renamed to AL_LEGEND to avoid conflict. +; +; Modification history: +; write, 24-25 Aug 92, F K Knight (knight@ll.mit.edu) +; allow omission of items or omission of both psym and linestyle, add +; corners keyword to facilitate multi-column legends, improve place- +; ment of symbols and text, add guards for unequal size, 26 Aug 92, FKK +; add linestyle(i)=-1 to suppress a single symbol/line, 27 Aug 92, FKK +; add keyword vectorfont to allow characters in the sym/line column, +; 28 Aug 92, FKK +; add /top, /bottom, /left, /right keywords for automatic placement at +; the four corners of the plot window. The /right keyword forces +; right-to-left printing of menu. 18 Jun 93, FKK +; change default position to data coords and add normal, data, and +; device keywords, 17 Jan 94, FKK +; add /center keyword for positioning, but it is not precise because +; text string lengths cannot be known in advance, 17 Jan 94, FKK +; add interactive positioning with /position keyword, 17 Jan 94, FKK +; allow a legend with just text, no plotting symbols. This helps in +; simply describing a plot or writing assumptions done, 4 Feb 94, FKK +; added thick, symsize, and clear keyword Feb 96, W. Landsman HSTX +; David Seed, HR Wallingford, d.seed@hrwallingford.co.uk +; allow scalar specification of keywords, Mar 96, W. Landsman HSTX +; added charthick keyword, June 96, W. Landsman HSTX +; Made keyword names left,right,top,bottom,center longer, +; Aug 16, 2000, Kim Tolbert +; Added ability to have regular text lines in addition to plot legend +; lines in legend. If linestyle is -99 that item is left-justified. +; Previously, only option for no sym/line was linestyle=-1, but then text +; was lined up after sym/line column. 10 Oct 2000, Kim Tolbert +; Make default value of thick = !P.thick W. Landsman Jan. 2001 +; Don't overwrite existing USERSYM definition W. Landsman Mar. 2002 +; Added outline_color BT 24 MAY 2004 +; Pass font keyword to cgText commands. M. Fitzgerald, Sep. 2005 +; Default spacing, pspacing should be relative to charsize. M. Perrin, July 2007 +; Don't modify position keyword A. Kimball/ W. Landsman Jul 2007 +; Small update to Jul 2007 for /NORMAL coords. W. Landsman Aug 2007 +; Use SYMCAT() plotting symbols for 11<=PSYM<=46 W. Landsman Nov 2009 +; Make a sharper box edge T. Robishaw/W.Landsman July 2010 +; Added BTHICK keyword W. Landsman October 2010 +; Added BACKGROUND_COLOR keyword W. Landsman February 2011 +; Incorporate Coyote graphics W. Landsman February 2011 +; Added LINSIZE keyword W.L./V.Gonzalez May 2011 +; Fixed a small problem with Convert_Coord when the Window keyword is set. +; David Fanning, May 2011. +; Fixed problem when /clear and /Window are set J. Bailin/WL May 2011 +; CGQUERY was called instead of CGCONTROL W.L. June 2011 +; Fixed typo preventing BTHICK keyword from working W.L. Dec 2011 +; Remove call to SYMCAT() W.L. Dec 2011 +; Changed the way the WINDOW keyword adds commands to cgWindow, and +; now default to BACKGROUND for background color. 1 Feb 2012 David Fanning +; Allow 1 element SYMSIZE for vector input, WL Apr 2012. +; Allow to specify symbols by cgSYMCAT() name WL Aug 2012 +; Fixed bug when linsize, /right called simultaneously, Dec 2012, K.Stewart +; Added a check for embedded symbols in the items string array. March 2013. David Fanning +; +;- +pro al_legend, items, BOTTOM_LEGEND=bottom, BOX = box, CENTER_LEGEND=center, $ + CHARTHICK=charthick, CHARSIZE = charsize, CLEAR = clear, COLORS = colorsi, $ + CORNERS = corners, DATA=data, DELIMITER=delimiter, DEVICE=device, $ + FILL=fill, HELP = help, HORIZONTAL=horizontal,LEFT_LEGEND=left, $ + LINESTYLE=linestylei, MARGIN=margin, NORMAL=normal, NUMBER=number, $ + POSITION=position,PSPACING=pspacing, PSYM=psymi, RIGHT_LEGEND=right, $ + SPACING=spacing, SYMSIZE=symsizei, TEXTCOLORS=textcolorsi, THICK=thicki, $ + TOP_LEGEND=top, USERSYM=usersym, VECTORFONT=vectorfonti, $ + VERTICAL=vertical,OUTLINE_COLOR = outline_color, FONT = font, $ + BTHICK=bthick, background_color = bgcolor, WINDOW=window,LINSIZE = linsize +; +; =====>> HELP +; +compile_opt idl2 +;On_error,2 +if keyword_set(help) then begin & doc_library,'al_legend' & return & endif +; Should this commnad be added to a resizeable graphics window? +IF (Keyword_Set(window)) && ((!D.Flags AND 256) NE 0) THEN BEGIN + + cgWindow, 'al_legend', items, BOTTOM_LEGEND=bottom, BOX = box, CENTER_LEGEND=center, $ + CHARTHICK=charthick, CHARSIZE = charsize, CLEAR = clear, COLORS = colorsi, $ + CORNERS = corners, DATA=data, DELIMITER=delimiter, DEVICE=device, $ + FILL=fill, HELP = help, HORIZONTAL=horizontal,LEFT_LEGEND=left, $ + LINESTYLE=linestylei, MARGIN=margin, NORMAL=normal, NUMBER=number, $ + POSITION=position,PSPACING=pspacing, PSYM=psymi, RIGHT_LEGEND=right, $ + SPACING=spacing, SYMSIZE=symsizei, TEXTCOLORS=textcolorsi, THICK=thicki, $ + TOP_LEGEND=top, USERSYM=usersym, VECTORFONT=vectorfonti, $ + VERTICAL=vertical,OUTLINE_COLOR = outline_color, FONT = font, $ + BTHICK=thick, background_color = bgcolor, LINSIZE = linsize, ADDCMD=1 + + RETURN + ENDIF + ; + +; +; =====>> SET DEFAULTS FOR SYMBOLS, LINESTYLES, AND ITEMS. +; + ni = n_elements(items) + np = n_elements(psymi) + nl = n_elements(linestylei) + nth = n_elements(thicki) + nsym = n_elements(symsizei) + nv = n_elements(vectorfonti) + nlpv = max([np,nl,nv]) + n = max([ni,np,nl,nv]) ; NUMBER OF ENTRIES +strn = strtrim(n,2) ; FOR ERROR MESSAGES +if n eq 0 then message,'No inputs! For help, type al_legend,/help.' +if ni eq 0 then begin + items = replicate('',n) ; DEFAULT BLANK ARRAY +endif else begin + if size(items,/TNAME) NE 'STRING' then message, $ + 'First parameter must be a string array. For help, type al_legend,/help.' + if ni ne n then message,'Must have number of items equal to '+strn +endelse + +items = cgCheckForSymbols(items) ; Check for embedded symbols in the items array. +symline = (np ne 0) || (nl ne 0) ; FLAG TO PLOT SYM/LINE + if (np ne 0) && (np ne n) && (np NE 1) then message, $ + 'Must have 0, 1 or '+strn+' elements in PSYM array.' + if (nl ne 0) && (nl ne n) && (nl NE 1) then message, $ + 'Must have 0, 1 or '+strn+' elements in LINESTYLE array.' + if (nth ne 0) && (nth ne n) && (nth NE 1) then message, $ + 'Must have 0, 1 or '+strn+' elements in THICK array.' + + case nl of + 0: linestyle = intarr(n) ;Default = solid + 1: linestyle = intarr(n) + linestylei + else: linestyle = linestylei + endcase + + case nsym of + 0: symsize = replicate(!p.symsize,n) ;Default = !P.SYMSIZE + 1: symsize = intarr(n) + symsizei + else: symsize = symsizei + endcase + + + case nth of + 0: thick = replicate(!p.thick,n) ;Default = !P.THICK + 1: thick = intarr(n) + thicki + else: thick = thicki + endcase + + if size(psymi,/TNAME) EQ 'STRING' then begin + psym = intarr(n) + for i=0,N_elements(psymi)-1 do psym[i] = cgsymcat(psymi[i]) + endif else begin + + case np of ;Get symbols + 0: psym = intarr(n) ;Default = solid + 1: psym = intarr(n) + psymi + else: psym = psymi + endcase + endelse + + case nv of + 0: vectorfont = replicate('',n) + 1: vectorfont = replicate(vectorfonti,n) + else: vectorfont = vectorfonti + endcase +; +; =====>> CHOOSE VERTICAL OR HORIZONTAL ORIENTATION. +; +if n_elements(horizontal) eq 0 then $ ; D=VERTICAL + setdefaultvalue, vertical, 1 else $ + setdefaultvalue, vertical, ~horizontal + +; +; =====>> SET DEFAULTS FOR OTHER OPTIONS. +; + setdefaultvalue, box, 1 + if N_elements(bgcolor) NE 0 then clear = 1 + setdefaultvalue, bgcolor, 'BACKGROUND' + setdefaultvalue, clear, 0 + setdefaultvalue, linsize, 1. + setdefaultvalue, margin, 0.5 + setdefaultvalue, delimiter, '' + setdefaultvalue, charsize, !p.charsize + setdefaultvalue, charthick, !p.charthick + if charsize eq 0 then charsize = 1 + setdefaultvalue, number, 1 +; Default color is opposite the background color + case N_elements(colorsi) of + 0: colors = replicate('opposite',n) + 1: colors = replicate(colorsi,n) + else: colors = colorsi + endcase + + case N_elements(textcolorsi) of + 0: textcolors = replicate('opposite',n) + 1: textcolors = replicate(textcolorsi,n) + else: textcolors = textcolorsi + endcase + fill = keyword_set(fill) +if n_elements(usersym) eq 1 then usersym = 2*[[0,0],[0,1],[1,1],[1,0],[0,0]]-1 + +; +; =====>> INITIALIZE SPACING +; +setdefaultvalue, spacing, 1.2*charsize +setdefaultvalue, pspacing , 3*charsize +xspacing = !d.x_ch_size/float(!d.x_size) * (spacing > charsize) +yspacing = !d.y_ch_size/float(!d.y_size) * (spacing > charsize) +ltor = 1 ; flag for left-to-right +if n_elements(left) eq 1 then ltor = left eq 1 +if n_elements(right) eq 1 then ltor = right ne 1 +ttob = 1 ; flag for top-to-bottom +if n_elements(top) eq 1 then ttob = top eq 1 +if n_elements(bottom) eq 1 then ttob = bottom ne 1 +xalign = ltor ne 1 ; x alignment: 1 or 0 +yalign = -0.5*ttob + 1 ; y alignment: 0.5 or 1 +xsign = 2*ltor - 1 ; xspacing direction: 1 or -1 +ysign = 2*ttob - 1 ; yspacing direction: 1 or -1 +if ~ttob then yspacing = -yspacing +if ~ltor then xspacing = -xspacing +; +; =====>> INITIALIZE POSITIONS: FIRST CALCULATE X OFFSET FOR TEXT +; +xt = 0 +if nlpv gt 0 then begin ; SKIP IF TEXT ITEMS ONLY. +if vertical then begin ; CALC OFFSET FOR TEXT START + for i = 0,n-1 do begin + if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number + if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE + if psym[i] eq 0 then expand = linsize else expand = 2 + thisxt = (expand*pspacing*(num-1)*xspacing) + if ltor then xt = thisxt > xt else xt = thisxt < xt + endfor +endif ; NOW xt IS AN X OFFSET TO ALIGN ALL TEXT ENTRIES. +endif +; +; =====>> INITIALIZE POSITIONS: SECOND LOCATE BORDER +; + +if !x.window[0] eq !x.window[1] then begin + cgplot,/nodata,xstyle=4,ystyle=4,[0],/noerase +endif +; next line takes care of weirdness with small windows +pos = [min(!x.window),min(!y.window),max(!x.window),max(!y.window)] + +case n_elements(position) of + 0: begin + if ltor then px = pos[0] else px = pos[2] + if ttob then py = pos[3] else py = pos[1] + if keyword_set(center) then begin + if ~keyword_set(right) && ~keyword_set(left) then $ + px = (pos[0] + pos[2])/2. - xt + if ~keyword_set(top) && ~keyword_set(bottom) then $ + py = (pos[1] + pos[3])/2. + n*yspacing + endif + nposition = [px,py] + [xspacing,-yspacing] + end + 1: begin ; interactive + message,/inform,'Place mouse at upper left corner and click any mouse button.' + cursor,x,y,/normal + nposition = [x,y] + end + 2: begin ; convert upper left corner to normal coordinates + + ; if keyword window is set, get the current graphics window. + if keyword_set(window) then begin + wid = cgQuery(/current) + WSet, wid + endif + if keyword_set(data) then $ + nposition = convert_coord(position,/to_norm) $ + else if keyword_set(device) then $ + nposition = convert_coord(position,/to_norm,/device) $ + else if ~keyword_set(normal) then $ + nposition = convert_coord(position,/to_norm) else nposition= position + end + else: message,'Position keyword can have 0, 1, or 2 elements only. Try al_legend,/help.' +endcase + +yoff = 0.25*yspacing*ysign ; VERT. OFFSET FOR SYM/LINE. + +x0 = nposition[0] + (margin)*xspacing ; INITIAL X & Y POSITIONS +y0 = nposition[1] - margin*yspacing + yalign*yspacing ; WELL, THIS WORKS! +; +; =====>> OUTPUT TEXT FOR LEGEND, ITEM BY ITEM. +; =====>> FOR EACH ITEM, PLACE SYM/LINE, THEN DELIMITER, +; =====>> THEN TEXT---UPDATING X & Y POSITIONS EACH TIME. +; =====>> THERE ARE A NUMBER OF EXCEPTIONS DONE WITH IF STATEMENTS. +; +for iclr = 0,clear do begin + y = y0 ; STARTING X & Y POSITIONS + x = x0 + if ltor then xend = 0 else xend = 1 ; SAVED WIDTH FOR DRAWING BOX + + if ttob then ii = [0,n-1,1] else ii = [n-1,0,-1] + + for i = ii[0],ii[1],ii[2] do begin + if vertical then x = x0 else y = y0 ; RESET EITHER X OR Y + x = x + xspacing ; UPDATE X & Y POSITIONS + y = y - yspacing + if nlpv eq 0 then goto,TEXT_ONLY ; FLAG FOR TEXT ONLY + num = number + if (psym[i] eq 0) && (vectorfont[i] eq '') then num = (number + 1) > 3 + if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE + if psym[i] eq 0 then expand = 1 else expand = 2 + xp = x + expand*pspacing*indgen(num)*xspacing + if (psym[i] gt 0) && (num eq 1) && vertical then xp = x + xt/2. + yp = y + intarr(num) + if vectorfont[i] eq '' then yp += yoff + if psym[i] eq 0 then begin + if ltor eq 1 then xp = [min(xp),max(xp) -(max(xp)-min(xp))*(1.-linsize)] + if ltor ne 1 then xp = [min(xp) +(max(xp)-min(xp))*(1.-linsize),max(xp)] + yp = [min(yp),max(yp)] ; DITTO + endif + if (psym[i] eq 8) && (N_elements(usersym) GT 1) then $ + usersym,usersym,fill=fill,color=colors[i] +;; extra by djseed .. psym=88 means use the already defined usersymbol + if psym[i] eq 88 then p_sym =8 else $ + if psym[i] EQ 10 then $ + message,'PSYM=10 (histogram mode) not allowed to al_legend.pro' $ + else p_sym= psym[i] + + if vectorfont[i] ne '' then begin +; if (num eq 1) && vertical then xp = x + xt/2 ; IF 1, CENTERED. + cgText,xp,yp,vectorfont[i],width=width,color=colors[i], $ + size=charsize,align=xalign,charthick = charthick,/norm,font=font + xt = xt > width + xp = xp + width/2. + endif else begin + if symline and (linestyle[i] ge 0) then cgPlots,xp,yp,color=colors[i] $ + ,/normal,linestyle=linestyle[i],psym=p_sym,symsize=symsize[i], $ + thick=thick[i] + endelse + + if vertical then x += xt else if ltor then x = max(xp) else x = min(xp) + if symline then x += xspacing + + TEXT_ONLY: + if vertical && (vectorfont[i] eq '') && symline && (linestyle[i] eq -99) then x=x0 + xspacing + cgText,x,y,delimiter,width=width,/norm,color=textcolors[i], $ + size=charsize,align=xalign,charthick = charthick,font=font + x += width*xsign + if width ne 0 then x += 0.5*xspacing + cgText,x,y,items[i],width=width,/norm,color=textcolors[i],size=charsize, $ + align=xalign,charthick=charthick,font=font + x += width*xsign + if ~vertical && (i lt (n-1)) then x += 2*xspacing; ADD INTER-ITEM SPACE + xfinal = (x + xspacing*margin) + if ltor then xend = xfinal > xend else xend = xfinal < xend ; UPDATE END X + endfor + + if (iclr lt clear ) then begin +; =====>> CLEAR AREA + x = nposition[0] + y = nposition[1] + if vertical then bottom = n else bottom = 1 + ywidth = - (2*margin+bottom-0.5)*yspacing + corners = [x,y+ywidth,xend,y] + cgColorfill,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm, $ + color=bgcolor +; cgPlots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0], $ +; thick=2 + endif else begin + +; +; =====>> OUTPUT BORDER +; + x = nposition[0] + y = nposition[1] + if vertical then bottom = n else bottom = 1 + ywidth = - (2*margin+bottom-0.5)*yspacing + corners = [x,y+ywidth,xend,y] + if box then cgPlots,[x,xend,xend,x,x,xend],y + [0,0,ywidth,ywidth,0,0],$ + /norm, color = outline_color,thick=bthick + return + endelse +endfor + +end diff --git a/modules/idl_downloads/astro/pro/al_legendtest.pro b/modules/idl_downloads/astro/pro/al_legendtest.pro new file mode 100644 index 0000000..55e33be --- /dev/null +++ b/modules/idl_downloads/astro/pro/al_legendtest.pro @@ -0,0 +1,85 @@ + +;+ +; NAME: +; AL_LEGENDTEST +; PURPOSE: +; Demo program to show capabilities of the al_legend procedure. +; CALLING SEQUENCE: +; al_legendtest +; INPUTS: +; none +; OPTIONAL INPUTS: +; none +; KEYWORDS: +; none +; OUTPUTS: +; legends of note +; COMMON BLOCKS: +; none +; SIDE EFFECTS: +; Sets !20 font to symbol if PostScript and !p.font=0. +; RESTRICTIONS: +; With the vectorfont test, you'll get different results for PostScript +; depending on the value of !p.font. +; MODIFICATION HISTORY: +; write, 27 Aug 92, F.K.Knight (knight@ll.mit.edu) +; add test of /left,/right,/top,/bottom keywords, 21 June 93, FKK +; update based on recent changes to legend, 7 Feb 94, FKK +; Fix ambiguous CHAR keyword W. Landsman Sep 2007 +; Use Coyote graphics routines W. Landsman Jan 2011 +;- +pro al_legendtest +if (!d.name eq 'PS') && (!p.font eq 0) then device,/Symbol,font_index=20 +items = ['diamond','asterisk','square'] +explanation = ['The al_legend procedure annotates plots---' $ + ,' either using text alone,' $ + ,' or text with plot symbols, lines, and special characters.' $ + ,'The following are some examples.' $ + ,'Hit return to continue.'] +psym = [4,2,6] +lineitems = ['solid','dotted','DASHED'] +linestyle = [0,1,2] +citems = 'color '+strtrim(string(indgen(8)),2) +colors = ['red','blue','violet','green','yellow','brown','black','cyan'] +usersym,[-1,1,1,-1,-1],[-1,-1,1,1,-1],/fill +z = ['al_legend,explanation,charsize=1.5' $ + ,'al_legend,items,psym=[4,2,6]' $ + ,'cgplot,findgen(10) & al_legend,items,psym=[4,2,6] & al_legend,items,psym=[4,2,6],/bottom,/right' $ + ,'al_legend,lineitems,linestyle=linestyle,/right,/bottom' $ + ,'al_legend,items,psym=psym,/horizontal,chars=1.5 ; horizontal format' $ + ,'al_legend,[items,lineitems],psym=[psym,0,0,0],line=[0,0,0,linestyle],/center,box=0 ; sans border' $ + ,'al_legend,items,psym=psym,margin=1,spacing=2,chars=2,delimiter="=",/top,/center; delimiter & larger margin' $ + ,'al_legend,lineitems,line=linestyle,pos=[.3,.5],/norm,chars=2,number=4 ; position of legend' $ + ,'al_legend,items,psym=-psym,number=2,line=linestyle,/right; plot two symbols, not one' $ + ,'al_legend,citems,/fill,psym=15+intarr(8),colors=colors,chars=2; 8 filled squares' $ + ,'al_legend,[citems[0:4],lineitems],/fill,psym=[15+intarr(5),0*psym],line=[intarr(5),linestyle],colors=colors,chars=2,text=colors' $ + ,"al_legend,['Absurd','Sun Lover','Lucky Lady','Fishtail Palm'],vector=['ab!9r!3','!9nu!3','!9Wf!3','!9cN!20K!3'],charsize=2,/pos,psp=3"$ + ] +prompt = 'Hit return to continue:' +for i = 0,n_elements(z) - 1 do begin + cgerase + stat = execute(z[i]) + cgtext,.01,.15,'COMMAND TO MAKE LEGEND:',charsize=1.7,/norm + cgtext,.01,.05,z[i],/norm,charsize=1.2 + print,'Command: ',z[i] + print,prompt,format='($,a)' + a = get_kbrd(1) + print + endfor +;stop +cgerase +!p.charsize=2 +c1_items = ['Plus','Asterisk','Period','Diamond','Triangle','Square','X'] +c1_psym = indgen(7)+1 +c2_items = ['Solid','Dotted','Dashed','Dash Dot','Dash Dot Dot Dot','Long Dashes'] +c2_line = indgen(6) +al_legend,c1_items,psym=c1_psym,corners=c1,box=0 +al_legend,c2_items,line=c2_line,corners=c2,box=0,pos=[c1[2],c1[3]],/norm +c = [c1[0]c2[2],c1[3]>c2[3]] +cgplots,[c[0],c[0],c[2],c[2],c[0]],[c[1],c[3],c[3],c[1],c[1]],/norm +!p.charsize=0 +cgtext,.01,.05,$ + 'Multiple columns---type "al_legend,/help" for details.',/norm,charsize=1.2 +return +end + diff --git a/modules/idl_downloads/astro/pro/altaz2hadec.pro b/modules/idl_downloads/astro/pro/altaz2hadec.pro new file mode 100644 index 0000000..96d543b --- /dev/null +++ b/modules/idl_downloads/astro/pro/altaz2hadec.pro @@ -0,0 +1,69 @@ +PRO altaz2hadec, alt, az, lat, ha, dec +;+ +; NAME: +; ALTAZ2HADEC +; PURPOSE: +; Convert Horizon (Alt-Az) coordinates to Hour Angle and Declination. +; EXPLANATION:: +; Can deal with the NCP singularity. Intended mainly to be used by +; program hor2eq.pro +; CALLING SEQUENCE: +; ALTAZ2HADEC, alt, az, lat, ha, dec +; +; INPUTS +; alt - the local apparent altitude, in DEGREES, scalar or vector +; az - the local apparent azimuth, in DEGREES, scalar or vector, +; measured EAST of NORTH!!! If you have measured azimuth west-of-south +; (like the book MEEUS does), convert it to east of north via: +; az = (az + 180) mod 360 +; +; lat - the local geodetic latitude, in DEGREES, scalar or vector. +; +; OUTPUTS +; ha - the local apparent hour angle, in DEGREES. The hour angle is the +; time that right ascension of 0 hours crosses the local meridian. +; It is unambiguously defined. +; dec - the local apparent declination, in DEGREES. +; +; EXAMPLE: +; Arcturus is observed at an apparent altitude of 59d,05m,10s and an +; azimuth (measured east of north) of 133d,18m,29s while at the +; latitude of +43.07833 degrees. +; What are the local hour angle and declination of this object? +; +; IDL> altaz2hadec, ten(59,05,10), ten(133,18,29), 43.07833, ha, dec +; ===> Hour angle ha = 336.683 degrees +; Declination, dec = 19.1824 degrees +; +; The widely available XEPHEM code gets: +; Hour Angle = 336.683 +; Declination = 19.1824 +; +; REVISION HISTORY: +; Written Chris O'Dell Univ. of Wisconsin-Madison May 2002 +;- + + if N_params() LT 4 then begin + print,'Syntax - ALTAZ2HADEC, alt, az, lat, ha, dec' + return + endif + d2r = !dpi/180.0d + alt_r = alt*d2r + az_r = az*d2r + lat_r = lat*d2r + +;****************************************************************************** +; find local HOUR ANGLE (in degrees, from 0. to 360.) + ha = atan( -sin(az_r)*cos(alt_r), $ + -cos(az_r)*sin(lat_r)*cos(alt_r)+sin(alt_r)*cos(lat_r)) + ha = ha / d2r + w = where(ha LT 0.) + if w[0] ne -1 then ha[w] = ha[w] + 360. + ha = ha mod 360. + +; Find declination (positive if north of Celestial Equator, negative if south) + sindec = sin(lat_r)*sin(alt_r) + cos(lat_r)*cos(alt_r)*cos(az_r) + dec = asin(sindec)/d2r ; convert dec to degrees + + +END diff --git a/modules/idl_downloads/astro/pro/aper.pro b/modules/idl_downloads/astro/pro/aper.pro new file mode 100644 index 0000000..940bb0c --- /dev/null +++ b/modules/idl_downloads/astro/pro/aper.pro @@ -0,0 +1,476 @@ +pro aper,image,xc,yc,mags,errap,sky,skyerr,phpadu,apr,skyradii,badpix, $ + SETSKYVAL = setskyval,PRINT = print, SILENT = silent, FLUX=flux, $ + EXACT = exact, Nan = nan, READNOISE = readnoise, MEANBACK = meanback, $ + CLIPSIG=clipsig, MAXITER=maxiter,CONVERGE_NUM=converge_num, $ + MINSKY = minsky +;+ +; NAME: +; APER +; PURPOSE: +; Compute concentric aperture photometry (adapted from DAOPHOT) +; EXPLANATION: +; APER can compute photometry in several user-specified aperture radii. +; A separate sky value is computed for each source using specified inner +; and outer sky radii. +; +; CALLING SEQUENCE: +; APER, image, xc, yc, [ mags, errap, sky, skyerr, phpadu, apr, skyrad, +; badpix, /NAN, /EXACT, /FLUX, PRINT = , /SILENT, +; /MEANBACK, MINSKY=, SETSKYVAL = ] +; INPUTS: +; IMAGE - input image array +; XC - vector of x coordinates. +; YC - vector of y coordinates +; +; OPTIONAL INPUTS: +; PHPADU - Photons per Analog Digital Units, numeric scalar. Converts +; the data numbers in IMAGE to photon units. (APER assumes +; Poisson statistics.) +; APR - Vector of up to 12 REAL photometry aperture radii. +; SKYRAD - Two element vector giving the inner and outer radii +; to be used for the sky annulus. Ignored if the SETSKYVAL +; keyword is set. +; BADPIX - Two element vector giving the minimum and maximum value +; of a good pixel. If badpix is not supplied or if BADPIX[0] is +; equal to BADPIX[1] then it is assumed that there are no bad +; pixels. Note that fluxes will not be computed for any star +; with a bad pixel within the aperture area, but that bad pixels +; will be simply ignored for the sky computation. The BADPIX +; parameter is ignored if the /NAN keyword is set. +; +; OPTIONAL KEYWORD INPUTS: +; CLIPSIG - if /MEANBACK is set, then this is the number of sigma at which +; to clip the background. Default=3 +; CONVERGE_NUM: if /MEANBACK is set then if the proportion of +; rejected pixels is less than this fraction, the iterations stop. +; Default=0.02, i.e., iteration stops if fewer than 2% of pixels +; excluded. +; /EXACT - By default, APER counts subpixels, but uses a polygon +; approximation for the intersection of a circular aperture with +; a square pixel (and normalizes the total area of the sum of the +; pixels to exactly match the circular area). If the /EXACT +; keyword, then the intersection of the circular aperture with a +; square pixel is computed exactly. The /EXACT keyword is much +; slower and is only needed when small (~2 pixels) apertures are +; used with very undersampled data. +; /FLUX - By default, APER uses a magnitude system where a magnitude of +; 25 corresponds to 1 flux unit. If set, then APER will keep +; results in flux units instead of magnitudes. +; MAXITER if /MEANBACK is set then this is the ceiling on number of +; clipping iterations of the background. Default=5 +; /MEANBACK - if set, then the background is computed using the 3 sigma +; clipped mean (using meanclip.pro) rather than using the mode +; computed with mmm.pro. This keyword is useful for the Poisson +; count regime or where contamination is known to be minimal. +; MINSKY - Integer giving mininum number of sky values to be used with MMM +; APER will not compute a flux if fewer valid sky elements are +; within the sky annulus. Default = 20. +; /NAN - If set then APER will check for NAN values in the image. /NAN +; takes precedence over the BADPIX parameter. Note that fluxes +; will not be computed for any star with a NAN pixel within the +; aperture area, but that NAN pixels will be simply ignored for +; the sky computation. +; PRINT - if set and non-zero then APER will also write its results to +; a file aper.prt. One can specify the output file name by +; setting PRINT = 'filename'. +; READNOISE - Scalar giving the read noise (or minimum noise for any +; pixel. This value is passed to the procedure mmm.pro when +; computing the sky, and is only need for images where +; the noise is low, and pixel values are quantized. +; /SILENT - If supplied and non-zero then no output is displayed to the +; terminal. +; SETSKYVAL - Use this keyword to force the sky to a specified value +; rather than have APER compute a sky value. SETSKYVAL +; can either be a scalar specifying the sky value to use for +; all sources, or a 3 element vector specifying the sky value, +; the sigma of the sky value, and the number of elements used +; to compute a sky value. The 3 element form of SETSKYVAL +; is needed for accurate error budgeting. +; +; OUTPUTS: +; MAGS - NAPER by NSTAR array giving the magnitude for each star in +; each aperture. (NAPER is the number of apertures, and NSTAR +; is the number of stars). If the /FLUX keyword is not set, then +; a flux of 1 digital unit is assigned a zero point magnitude of +; 25. +; ERRAP - NAPER by NSTAR array giving error for each star. If a +; magnitude could not be determined then ERRAP = 9.99 (if in +; magnitudes) or ERRAP = !VALUES.F_NAN (if /FLUX is set). +; SKY - NSTAR element vector giving sky value for each star in +; flux units +; SKYERR - NSTAR element vector giving error in sky values +; +; EXAMPLE: +; Determine the flux and error for photometry radii of 3 and 5 pixels +; surrounding the position 234.2,344.3 on an image array, im. Compute +; the partial pixel area exactly. Assume that the flux units are in +; Poisson counts, so that PHPADU = 1, and the sky value is already known +; to be 1.3, and that the range [-32767,80000] for bad low and bad high +; pixels +; +; +; IDL> aper, im, 234.2, 344.3, flux, eflux, sky,skyerr, 1, [3,5], -1, $ +; [-32767,80000],/exact, /flux, setsky = 1.3 +; +; PROCEDURES USED: +; GETOPT, MMM, PIXWT(), STRN(), STRNUMBER() +; NOTES: +; Reasons that a valid magnitude cannot be computed include the following: +; (1) Star position is too close (within 0.5 pixels) to edge of the frame +; (2) Less than 20 valid pixels available for computing sky +; (3) Modal value of sky could not be computed by the procedure MMM +; (4) *Any* pixel within the aperture radius is a "bad" pixel +; (5) The total computed flux is negative. In this case the negative +; flux and error are returned. +; +; +; For the case where the source is fainter than the background, APER will +; return negative fluxes if /FLUX is set, but will otherwise give +; invalid data (since negative fluxes can't be converted to magnitudes) +; +; APER was modified in June 2000 in two ways: (1) the /EXACT keyword was +; added (2) the approximation of the intersection of a circular aperture +; with square pixels was improved (i.e. when /EXACT is not used) +; REVISON HISTORY: +; Adapted to IDL from DAOPHOT June, 1989 B. Pfarr, STX +; FLUX keyword added J. E. Hollis, February, 1996 +; SETSKYVAL keyword, increase maxsky W. Landsman, May 1997 +; Work for more than 32767 stars W. Landsman, August 1997 +; Don't abort for insufficient sky pixels W. Landsman May 2000 +; Added /EXACT keyword W. Landsman June 2000 +; Allow SETSKYVAL = 0 W. Landsman December 2000 +; Set BADPIX[0] = BADPIX[1] to ignore bad pixels W. L. January 2001 +; Fix chk_badpixel problem introduced Jan 01 C. Ishida/W.L. February 2001 +; Set bad fluxes and error to NAN if /FLUX is set W. Landsman Oct. 2001 +; Remove restrictions on maximum sky radius W. Landsman July 2003 +; Added /NAN keyword W. Landsman November 2004 +; Set badflux=0 if neither /NAN nor badpix is set M. Perrin December 2004 +; Added READNOISE keyword W. Landsman January 2005 +; Added MEANBACK keyword W. Landsman October 2005 +; Correct typo when /EXACT and multiple apertures used. W.L. Dec 2005 +; Remove VMS-specific code W.L. Sep 2006 +; Add additional keywords if /MEANBACK is set W.L Nov 2006 +; Allow negative fluxes if /FLUX is set W.L. Mar 2008 +; Previous update would crash if first star was out of range W.L. Mar 2008 +; Fix floating equality test for bad magnitudes W.L./J.van Eyken Jul 2009 +; Added MINSKY keyword W.L. Dec 2011 +; Don't ever modify input skyrad variable W. Landsman Aug 2013 +; Avoid integer overflow for very big images W. Landsman/R. Gutermuth Mar 2016 +;- + COMPILE_OPT IDL2 + On_error,2 +; Set parameter limits + ;Smallest number of pixels from which the sky may be determined + if N_elements(minsky) EQ 0 then minsky = 20 + maxsky = 10000 ;Maximum number of pixels allowed in the sky annulus. +; +if N_params() LT 3 then begin ;Enough parameters supplied? + print, $ + 'Syntax - APER, image, xc, yc, [ mags, errap, sky, skyerr, phpadu, apr, ' + print,' skyrad, badpix, /EXACT, /FLUX, SETSKYVAL = ,PRINT=, ]' + print,' /SILENT, /NAN, MINSKY=' + return +endif + + s = size(image) + if ( s[0] NE 2 ) then message, $ + 'ERROR - Image array (first parameter) must be 2 dimensional' + ncol = s[1] & nrow = s[2] ;Number of columns and rows in image array + + silent = keyword_set(SILENT) + + if ~keyword_set(nan) then begin + if (N_elements(badpix) NE 2) then begin ;Bad pixel values supplied +GET_BADPIX: + ans = '' + print,'Enter low and high bad pixel values, [RETURN] for defaults' + read,'Low and high bad pixel values [none]: ',ans + if ans EQ '' then badpix = [0,0] else begin + badpix = getopt(ans,'F') + if ( N_elements(badpix) NE 2 ) then begin + message,'Expecting 2 scalar values',/continue + goto,GET_BADPIX + endif + endelse + endif + + chk_badpix = badpix[0] LT badpix[1] ;Ignore bad pixel checks? + endif + + if ( N_elements(apr) LT 1 ) then begin ;Read in aperture sizes? + apr = fltarr(10) + read, 'Enter first aperture radius: ',ap + apr[0] = ap + ap = 'aper' + for i = 1,9 do begin +GETAP: + read,'Enter another aperture radius, [RETURN to terminate]: ',ap + if ap EQ '' then goto,DONE + result = strnumber(ap,val) + if result EQ 1 then apr[i] = val else goto, GETAP + endfor +DONE: + apr = apr[0:i-1] + endif + + + if N_elements(SETSKYVAL) GT 0 then begin + if N_elements( SETSKYVAL ) EQ 1 then setskyval = [setskyval,0.,1.] + if N_elements( SETSKYVAL ) NE 3 then message, $ + 'ERROR - Keyword SETSKYVAL must contain 1 or 3 elements' + skyrad = [ 0., max(apr) + 1] + endif else begin + if N_elements(skyradii) NE 2 then begin + skyrad = fltarr(2) + read,'Enter inner and outer sky radius (pixel units): ',skyrad + endif else skyrad = float(skyradii) + endelse + + if ( N_elements(phpadu) LT 1 ) then $ + read,'Enter scale factor in Photons per Analog per Digital Unit: ',phpadu + + Naper = N_elements( apr ) ;Number of apertures + Nstars = min([ N_elements(xc), N_elements(yc) ]) ;Number of stars to measure + + ms = strarr( Naper ) ;String array to display mag for each aperture + if keyword_set(flux) then $ + fmt = '(F8.1,1x,A,F7.1)' else $ ;Flux format + fmt = '(F9.3,A,F5.3)' ;Magnitude format + fmt2 = '(I5,2F8.2,F7.2,1x,3A,3(/,28x,4A,:))' ;Screen format + fmt3 = '(I4,5F8.2,1x,6A,2(/,44x,9A,:))' ;Print format + + mags = fltarr( Naper, Nstars) & errap = mags ;Declare arrays + sky = fltarr( Nstars ) & skyerr = sky + area = !PI*apr*apr ;Area of each aperture + + if keyword_set(EXACT) then begin + bigrad = apr + 0.5 + smallrad = apr/sqrt(2) - 0.5 + endif + + + if N_elements(SETSKYVAL) EQ 0 then begin + + rinsq = (skyrad[0]> 0.)^2 + routsq = skyrad[1]^2 + endif + + if keyword_set(PRINT) then begin ;Open output file and write header info? + if size(PRINT,/TNAME) NE 'STRING' then file = 'aper.prt' $ + else file = print + message,'Results will be written to a file ' + file,/INF + openw,lun,file,/GET_LUN + printf,lun,'Program: APER: '+ systime(), ' User: ', $ + getenv('USER'),' Host: ',getenv('HOST') + for j = 0, Naper-1 do printf,lun, $ + format='(a,i2,a,f4.1)','Radius of aperture ',j,' = ',apr[j] + if N_elements(SETSKYVAL) EQ 0 then begin + printf,lun,f='(/a,f4.1)','Inner radius for sky annulus = ',skyrad[0] + printf,lun,f='(a,f4.1)', 'Outer radius for sky annulus = ',skyrad[1] + endif else printf,lun,'Sky values fixed at ', strtrim(setskyval[0],2) + if keyword_set(FLUX) then begin + printf,lun,f='(/a)', $ + 'Star X Y Sky SkySig SkySkw Fluxes' + endif else printf,lun,f='(/a)', $ + 'Star X Y Sky SkySig SkySkw Magnitudes' + endif + print = keyword_set(PRINT) + +; Print header + if ~SILENT then begin + if KEYWORD_SET(FLUX) then begin + print, format="(/1X,'Star',5X,'X',7X,'Y',6X,'Sky',8X,'Fluxes')" + endif else print, $ + format="(/1X,'Star',5X,'X',7X,'Y',6X,'Sky',8X,'Magnitudes')" + endif + +; Compute the limits of the submatrix. Do all stars in vector notation. + + lx = long(xc-skyrad[1]) > 0 ;Lower limit X direction + ux = long(xc+skyrad[1]) < (ncol-1) ;Upper limit X direction + nx = ux-lx+1 ;Number of pixels X direction + ly = long(yc-skyrad[1]) > 0 ;Lower limit Y direction + uy = long(yc+skyrad[1]) < (nrow-1); ;Upper limit Y direction + ny = uy-ly +1 ;Number of pixels Y direction + dx = xc-lx ;X coordinate of star's centroid in subarray + dy = yc-ly ;Y coordinate of star's centroid in subarray + + edge = (dx-0.5) < (nx+0.5-dx) < (dy-0.5) < (ny+0.5-dy) ;Closest edge to array + badstar = ((xc LT 0.5) or (xc GT ncol-1.5) $ ;Stars too close to the edge + or (yc LT 0.5) or (yc GT nrow-1.5)) +; + badindex = where( badstar, Nbad) ;Any stars outside image + if ( Nbad GT 0 ) then message, /INF, $ + 'WARNING - ' + strn(nbad) + ' star positions outside image' + if keyword_set(flux) then begin + badval = !VALUES.F_NAN + baderr = badval + endif else begin + badval = 99.999 + baderr = 9.999 + endelse + + for i = 0L, Nstars-1 do begin ;Compute magnitudes for each star + apmag = replicate(badval, Naper) & magerr = replicate(baderr, Naper) + skymod = 0. & skysig = 0. & skyskw = 0. ;Sky mode sigma and skew + if badstar[i] then goto, BADSTAR + error1=apmag & error2 = apmag & error3 = apmag + + rotbuf = image[ lx[i]:ux[i], ly[i]:uy[i] ] ;Extract subarray from image +; RSQ will be an array, the same size as ROTBUF containing the square of +; the distance of each pixel to the center pixel. + + + dxsq = ( findgen( nx[i] ) - dx[i] )^2 + rsq = fltarr( nx[i], ny[i], /NOZERO ) + for ii = 0, ny[i]-1 do rsq[0,ii] = dxsq + (ii-dy[i])^2 + + + if keyword_set(exact) then begin + nbox = lindgen(nx[i]*ny[i]) + xx = reform( (nbox mod nx[i]), nx[i], ny[i]) + yy = reform( (nbox/nx[i]),nx[i],ny[i]) + x1 = abs(xx-dx[i]) + y1 = abs(yy-dy[i]) + endif else begin + r = sqrt(rsq) - 0.5 ;2-d array of the radius of each pixel in the subarray + endelse + +; Select pixels within sky annulus, and eliminate pixels falling +; below BADLO threshold. SKYBUF will be 1-d array of sky pixels + if N_elements(SETSKYVAL) EQ 0 then begin + + skypix = ( rsq GE rinsq ) and ( rsq LE routsq ) + if keyword_set(nan) then skypix = skypix and finite(rotbuf) $ + else if chk_badpix then skypix = skypix and ( rotbuf GT badpix[0] ) and $ + (rotbuf LT badpix[1] ) + sindex = where(skypix, Nsky) + Nsky = Nsky < maxsky ;Must be less than MAXSKY pixels + if ( nsky LT minsky ) then begin ;Sufficient sky pixels? + if ~silent then $ + message,'There aren''t enough valid pixels in the sky annulus.',/con + goto, BADSTAR + endif + skybuf = rotbuf[ sindex[0:nsky-1] ] + + if keyword_set(meanback) then $ + meanclip,skybuf,skymod,skysig, $ + CLIPSIG=clipsig, MAXITER=maxiter, CONVERGE_NUM=converge_num else $ + mmm, skybuf, skymod, skysig, skyskw, readnoise=readnoise,minsky=minsky + + + +; Obtain the mode, standard deviation, and skewness of the peak in the +; sky histogram, by calling MMM. + + skyvar = skysig^2 ;Variance of the sky brightness + sigsq = skyvar/nsky ;Square of standard error of mean sky brightness + +;If the modal sky value could not be determined, then all apertures for this +; star are bad + + if ( skysig LT 0.0 ) then goto, BADSTAR + + skysig = skysig < 999.99 ;Don't overload output formats + skyskw = skyskw >(-99)<999.9 + endif else begin + skymod = setskyval[0] + skysig = setskyval[1] + nsky = setskyval[2] + skyvar = skysig^2 + sigsq = skyvar/nsky + skyskw = 0 +endelse + + + + for k = 0,Naper-1 do begin ;Find pixels within each aperture + + if ( edge[i] GE apr[k] ) then begin ;Does aperture extend outside the image? + if keyword_set(EXACT) then begin + mask = fltarr(nx[i],ny[i]) + good = where( ( x1 LT smallrad[k] ) and (y1 LT smallrad[k] ), Ngood) + if Ngood GT 0 then mask[good] = 1.0 + bad = where( (x1 GT bigrad[k]) or (y1 GT bigrad[k] )) ;Fix 05-Dec-05 + mask[bad] = -1 + + gfract = where(mask EQ 0.0, Nfract) + if Nfract GT 0 then mask[gfract] = $ + PIXWT(dx[i],dy[i],apr[k],xx[gfract],yy[gfract]) > 0.0 + thisap = where(mask GT 0.0) + thisapd = rotbuf[thisap] + fractn = mask[thisap] + endif else begin +; + thisap = where( r LT apr[k] ) ;Select pixels within radius + thisapd = rotbuf[thisap] + thisapr = r[thisap] + fractn = (apr[k]-thisapr < 1.0 >0.0 ) ;Fraction of pixels to count + full = fractn EQ 1.0 + gfull = where(full, Nfull) + gfract = where(1 - full) + factor = (area[k] - Nfull ) / total(fractn[gfract]) + fractn[gfract] = fractn[gfract]*factor + endelse + +; If the pixel is bad, set the total counts in this aperture to a large +; negative number +; + if keyword_set(NaN) then $ + badflux = min(finite(thisapd)) EQ 0 $ + else if chk_badpix then begin + minthisapd = min(thisapd, max = maxthisapd) + badflux = (minthisapd LE badpix[0] ) or ( maxthisapd GE badpix[1]) + endif else badflux = 0 + + if ~badflux then $ + apmag[k] = total(thisapd*fractn) ;Total over irregular aperture + endif +endfor ;k + if keyword_set(flux) then g = where(finite(apmag), Ng) else $ + g = where(abs(apmag - badval) GT 0.01, Ng) + if Ng GT 0 then begin + apmag[g] = apmag[g] - skymod*area[g] ;Subtract sky from the integrated brightnesses + +; Add in quadrature 3 sources of error: (1) random noise inside the star +; aperture, including readout noise and the degree of contamination by other +; stars in the neighborhood, as estimated by the scatter in the sky values +; (this standard error increases as the square root of the area of the +; aperture); (2) the Poisson statistics of the observed star brightness; +; (3) the uncertainty of the mean sky brightness (this standard error +; increases directly with the area of the aperture). + + error1[g] = area[g]*skyvar ;Scatter in sky values + error2[g] = (apmag[g] > 0)/phpadu ;Random photon noise + error3[g] = sigsq*area[g]^2 ;Uncertainty in mean sky brightness + magerr[g] = sqrt(error1[g] + error2[g] + error3[g]) + + if ~keyword_set(FLUX) then begin + good = where (apmag GT 0.0, Ngood) ;Are there any valid integrated fluxes? + if ( Ngood GT 0 ) then begin ;If YES then compute errors + magerr[good] = 1.0857*magerr[good]/apmag[good] ;1.0857 = log(10)/2.5 + apmag[good] = 25.-2.5*alog10(apmag[good]) + endif + endif + endif + + BADSTAR: + +;Print out magnitudes for this star + + for ii = 0,Naper-1 do $ ;Concatenate mags into a string + + ms[ii] = string( apmag[ii],'+-',magerr[ii], FORM = fmt) + if PRINT then printf,lun, $ ;Write results to file? + form = fmt3, i, xc[i], yc[i], skymod, skysig, skyskw, ms + if ~SILENT then print,form = fmt2, $ ;Write results to terminal? + i,xc[i],yc[i],skymod,ms + + sky[i] = skymod & skyerr[i] = skysig ;Store in output variable + mags[0,i] = apmag & errap[0,i]= magerr + endfor ;i + + if PRINT then free_lun, lun ;Close output file + + return + end diff --git a/modules/idl_downloads/astro/pro/arcbar.pro b/modules/idl_downloads/astro/pro/arcbar.pro new file mode 100644 index 0000000..b331d29 --- /dev/null +++ b/modules/idl_downloads/astro/pro/arcbar.pro @@ -0,0 +1,155 @@ +Pro arcbar, hdr, arclen, LABEL = label, SIZE = size, THICK = thick, DATA =data, $ + COLOR = color, POSITION = position, NORMAL = normal, $ + SECONDS=SECONDS, FONT=font +;+ +; NAME: +; ARCBAR +; PURPOSE: +; Draw an arc bar on an image showing the astronomical plate scale +; +; CALLING SEQUENCE: +; ARCBAR, hdr, arclen,[ COLOR= , /DATA, LABEL= , /NORMAL, POSITION=, +; /SECONDS, SIZE=, THICK=, FONT= ] +; +; INPUTS: +; hdr - image FITS header with astrometry, string array +; OPTIONAL INPUT: +; arclen - numeric scalar giving length of bar in arcminutes (default) +; or arcseconds (if /SECONDS is set). Default is 1 arcminute +; +; OPTIONAL KEYWORD INPUTS: +; COLOR - name or integer scalar specifying the color to draw the arcbar +; See cgColor for a list of available color names +; /DATA - if set and non-zero, then the POSITION keyword and the arc +; length is given in data units +; LABEL - string giving user defined label for bar. Default label is size +; of bar in arcminutes +; /NORMAL - if this keyword is set and non-zero, then POSITION is given in +; normalized units +; POSITION - 2 element vector giving the (X,Y) position in device units +; (or normalized units if /NORMAL is set, or data units if /DATA +; is set) at which to place the scale bar. If not supplied, +; then the user will be prompted to place the cursor at the +; desired position +; /SECONDS - if set, then arlen is specified in arcseconds rather than +; arcminutes +; SIZE - scalar specifying character size of label, default = 1.0 +; THICK - Character thickness of the label, default = !P.THICK +; FONT - scalar font graphics keyword (-1,0 or 1) for text +; +; EXAMPLE: +; Suppose one has an image array, IM, and FITS header, HDR, with +; astrometry. Display the image and place a 3' arc minute scale bar +; at position 300,200 of the current image window +; +; IDL> cgimage, IM, /scale,/save ;Use /SAVE to set data coordinates +; IDL> arcbar, HDR, 3, pos = [300,200],/data +; +; RESTRICTIONS: +; When using using a device with scalable pixels (e.g. postscript) +; the data coordinate system must be established before calling ARCBAR. +; If data coordinates are not set, then ARCBAR assumes that the displayed +; image size is given by the NAXIS1 keyword in the FITS header. +; PROCEDURE CALLS: +; AD2XY, EXTAST, GSSSADXY, SXPAR(), SETDEFAULTVALUE, cgPlot, cgText +; REVISON HISTORY: +; written by L. Taylor (STX) from ARCBOX (Boothman) +; modified for Version 2 IDL, B. Pfarr, STX, 4/91 +; New ASTROMETRY structures W.Landsman, HSTX, Jan 94 +; Recognize a GSSS header W. Landsman June 94 +; Added /NORMAL keyword W. Landsman Feb. 96 +; Use NAXIS1 for postscript if data coords not set, W. Landsman Aug 96 +; Fixed typo for postscript W. Landsman Oct. 96 +; Account for zeropoint offset in postscript W. Landsman Apr 97 +; Added /DATA, /SECONDS keywords W. Landsman July 1998 +; Use device-independent label offset W. Landsman August 2001 +; Allow font keyword to be passed. T. Robishaw Apr. 2006 +; Remove obsolete TVCURSOR command W. Landsman Jul 2007 +; Use Coyote Graphics W. Landsman February 2011 +; Fix problem using data coordinates when not in postscript +; W. Landsman January 2013 +;- +; + compile_opt idl2 + On_error,2 ;Return to caller + + if N_params() LT 1 then begin + print, 'Syntax - ARCBAR, hdr,[ arclen, COLOR= ' + print, ' /DATA, LABEL=, /NORM, POS=, /SECONDS, SIZE=, THICK= ]' + return + endif + + extast, hdr, bastr, noparams ;extract astrom params in deg. + + if N_params() LT 2 then arclen = 1 ;default size = 1 arcmin + + setdefaultvalue, size, 1.0 + setdefaultvalue, thick, !P.THICK + setdefaultvalue, font, !P.FONT + + a = bastr.crval[0] + d = bastr.crval[1] + if keyword_set(seconds) then factor = 3600.0d else factor = 60.0 + d1 = d + (1/factor) ;compute x,y of crval + 1 arcmin + + proj = strmid(bastr.ctype[0],5,3) + + case proj of + 'GSS': gsssadxy, bastr, [a,a], [d,d1], x, y + else: ad2xy, [a,a], [d,d1], bastr, x, y + endcase + + dmin = sqrt( (x[1]-x[0])^2 + (y[1]-y[0])^2 ) ;det. size in pixels of 1 arcmin + + if ((!D.FLAGS AND 1) EQ 1) || keyword_set(data) then begin ;Device have scalable pixels? + if !X.s[1] NE 0 then begin + dmin = convert_coord( dmin, 0, /DATA, /TO_DEVICE) - $ + convert_coord( 0, 0, /DATA, /TO_DEVICE) ;Fixed Apr 97 + dmin = dmin[0] + endif else dmin = dmin/sxpar(hdr, 'NAXIS1' ) ;Fixed Oct. 96 + endif + + dmini2 = round(dmin * arclen) + + if ~keyword_set( POSITION) then begin + print,'Position the cursor where you want the bar to begin' + print,'Hit right mouse button when ready' + cursor,xi,yi,1,/device + endif else begin + if keyword_set(NORMAL) then begin + posn = convert_coord(position,/NORMAL, /TO_DEVICE) + xi = posn[0] & yi = posn[1] + endif else if keyword_set(DATA) then begin + posn = convert_coord(position,/DATA, /TO_DEVICE) + xi = posn[0] & yi = posn[1] + endif else begin + xi = position[0] & yi = position[1] + endelse + endelse + + xf = xi + dmini2 + dmini3 = dmini2/10 ;Height of vertical end bars = total length/10. + + cgPlots,[xi,xf],[yi,yi], COLOR=color, /DEV, THICK=thick + cgPlots,[xf,xf],[ yi+dmini3, yi-dmini3 ], COLOR=color, /DEV, THICK=thick + cgPlots,[xi,xi],[ yi+dmini3, yi-dmini3 ], COLOR=color, /DEV, THICK=thick + + if ~keyword_set(Seconds) then begin + if (!D.NAME EQ 'PS') && (FONT EQ 0) then $ ;Postscript Font? + arcsym='!9'+string(162B)+'!X' else arcsym = "'" + endif else begin + if (!D.NAME EQ 'PS') && (FONT EQ 0) then $ ;Postscript Font? + arcsym = '!9'+string(178B)+'!X' else arcsym = "''" + endelse + if ~keyword_set( LABEL) then begin + if (arclen LT 1) then arcstr = string(arclen,format='(f4.2)') $ + else arcstr = string(arclen) + label = strtrim(arcstr,2) + arcsym + endif + + yoffset = round(!D.Y_CH_SIZE/2.) + cgTEXT,(xi+xf)/2, yi+yoffset, label, SIZE = size,COLOR=color,/DEV, $ + alignment=0.5, CHARTHICK=thick, FONT=font + + return + end diff --git a/modules/idl_downloads/astro/pro/arrows.pro b/modules/idl_downloads/astro/pro/arrows.pro new file mode 100644 index 0000000..f1c7854 --- /dev/null +++ b/modules/idl_downloads/astro/pro/arrows.pro @@ -0,0 +1,138 @@ +pro arrows,h,xcen,ycen,thick=thick,charsize=charsize,arrowlen=arrowlen, $ + color=color,NotVertex=NotVertex,Normal = normal,Data=data,font=font +;+ +; NAME: +; ARROWS +; PURPOSE: +; To display "weathervane" directional arrows on an astronomical image +; EXPLANATION: +; Overlays a graphic showing orientation of North and East. +; +; CALLING SEQUENCE: +; ARROWS,h, [ xcen, ycen, ARROWLEN= , CHARSIZE= COLOR= , /DATA +; FONT=, /NORMAL, /NOTVERTEX, THICK= ] +; +; INPUTS: +; h - FITS header array, must include astrometry +; +; OPTIONAL INPUTS: +; xcen,ycen - numeric scalars, specifying the center position of +; arrows. Position in device units unless the /NORMALIZED +; keyword is specified. If not supplied, then ARROWS +; will prompt for xcen and ycen +; +; OPTIONAL KEYWORD INPUTS: +; arrowlen - length of arrows in terms of normal Y size of vector-drawn +; character, default = 3.5, floating point scalar +; charsize - character size, default = 2.0, floating point scalar +; color - color name or number for the arrows and NE letters. See +; cgCOLOR() for a list of color names. +; Data - if this keyword is set and nonzero, the input center (xcen, +; ycen) is understood to be in data coordinates +; font - IDL vector font number (1-20) to use to display NE letters. +; For example, set font=13 to use complex italic font. +; NotVertex - Normally (historically) the specified xcen,ycen indicated +; the position of the vertex of the figure. If this +; keyword is set, the xcen,ycen coordinates refer to a sort +; of 'center of mass' of the figure. This allows the +; figure to always appear with the area irregardless of +; the rotation angle. +; Normal - if this keyword is set and nonzero, the input center +; (xcen,ycen) is taken to be in normalized coordinates. The +; default is device coordinates. +; thick - line thickness, default = 2.0, floating point scalar +; OUTPUTS: +; none +; EXAMPLE: +; Draw a weathervane at (400,100) on the currently active window, +; showing the orientation of the image associated with a FITS header, hdr +; +; IDL> arrows, hdr, 400, 100 +; +; METHOD: +; Uses EXTAST to EXTract ASTrometry from the FITS header. The +; directions of North and East are computed and the procedure +; ONE_ARROW called to create the "weathervane". +; +; PROCEDURES USED: +; GETROT - Computes rotation from the FITS header +; ONE_ARROW - Draw a labeled arrow +; ZPARCHECK +; REVISON HISTORY: +; written by B. Boothman 2/5/86 +; Recoded with new procedures ONE_ARROW, ONE_RAY. R.S.Hill,HSTX,5/20/92 +; Added separate determination for N and E arrow to properly display +; arrows irregardless of handedness or other peculiarities and added +; /NotVertex keyword to improve positioning of figure. E.Deutsch 1/10/93 +; Added /DATA and /NORMAL keywords W. Landsman July 1993 +; Recognize GSSS header W. Landsman June 1993 +; Added /FONT keyword W. Landsman April 1995 +; Modified to work correctly for COLOR=0 J.Wm.Parker, HITC 1995 May 25 +; Work correctly for negative CDELT values W. Landsman Feb. 1996 +; Use GETROT to compute rotation W. Landsman June 2003 +; Restored /NotVertex keyword which was not working after June 2003 change +; W. Landsman January 2004 +;- + + On_error,2 ;Return to caller + + if (N_params() LT 1) then begin + print,'Syntax - ' + $ + 'ARROWS, hdr, [ xcen, ycen, ARROWLEN= , CHARSIZE= COLOR= , /DATA' + print,' FONT=, /NORMAL, /NotVertex, THICK= ]' + print,' hdr - FITS header with astrometry' + return + endif else zparcheck,'ARROWS',h,1,7,1,'FITS header array' + + if ( N_params() LT 3 ) then $ + read,'Enter x, y values for center of arrows: ',xcen,ycen + + setdefaultvalue, thick, 2.0 + setdefaultvalue, charsize, 2.0 + setdefaultvalue, arrowlen, 3.5 + setdefaultvalue, NotVertex, 0 + +; Derive Position Angles for North and East separately + + getrot,h,npa, cdelt,/SILENT + sgn = 1 - 2*(cdelt[0]*cdelt[1] GT 0) + epa = npa + sgn*90 + +; Make arrows reasonable size depending on device + + arrowlen_dev = arrowlen*!D.y_ch_size + arrowsize = [arrowlen_dev, arrowlen_dev/3.5, 35.0] ; See one_arrow.pro + + if keyword_set( NORMAL) then begin + newcen = convert_coord( xcen, ycen, /NORMAL, /TO_DEVICE) + xcent = newcen[0] + ycent = newcen[1] + endif else if keyword_set( DATA) then begin + newcen = convert_coord( xcen, ycen, /DATA, /TO_DEVICE) + xcent = newcen[0] + ycent = newcen[1] + endif else begin + xcent=xcen & ycent=ycen + endelse + +; Adjust Center to 'Center of Mass' if NotVertex set + if NotVertex then begin + rot = npa/!RADEG + dRAdX = cdelt[0]*cos(rot) + dRAdY = cdelt[1]*sin(rot) + dDECdX = cdelt[0]*sin(rot) + dDECdY = cdelt[1]*cos(rot) + RAnorm = sqrt( dRAdX^2 + dRAdY^2 ) + DECnorm = sqrt(dDECdX^2 + dDECdY^2 ) + xcent = xcen - (dRAdX+dDECdX)/2/RAnorm*arrowsize[0] + ycent = ycen - (dRAdY+dDECdY)/2/DECnorm*arrowsize[0] + endif + +; Draw arrows + one_arrow, xcent, ycent, 90+NPA, 'N', font= font, $ + charsize=charsize, thick=thick, color=color, arrowsize=arrowsize + one_arrow, xcent, ycent, 90+EPA, 'E', font = font, $ + charsize=charsize, thick=thick, color=color, arrowsize=arrowsize + + return + end diff --git a/modules/idl_downloads/astro/pro/asinh.pro b/modules/idl_downloads/astro/pro/asinh.pro new file mode 100644 index 0000000..0083d46 --- /dev/null +++ b/modules/idl_downloads/astro/pro/asinh.pro @@ -0,0 +1,40 @@ +function asinh, x +;+ +; NAME: +; ASINH +; PURPOSE: +; Return the inverse hyperbolic sine of the argument +; EXPLANATION: +; The inverse hyperbolic sine is used for the calculation of asinh +; magnitudes, see Lupton et al. (1999, AJ, 118, 1406) +; +; CALLING SEQUENCE +; result = asinh( x) +; INPUTS: +; X - hyperbolic sine, numeric scalar or vector or multidimensional array +; (not complex) +; +; OUTPUT: +; result - inverse hyperbolic sine, same number of elements as X +; double precision if X is double, otherwise floating pt. +; +; METHOD: +; Expression given in Numerical Recipes, Press et al. (1992), eq. 5.6.7 +; Note that asinh(-x) = -asinh(x) and that asinh(0) = 0. and that +; if y = asinh(x) then x = sinh(y). +; +; REVISION HISTORY: +; Written W. Landsman February, 2001 +; Work for multi-dimensional arrays W. Landsman August 2002 +; Simplify coding, and work for scalars again W. Landsman October 2003 +;- + On_error,2 + + y = alog( abs(x) + sqrt( x^2 + 1.0) ) + + index = where(x LT 0 ,count) + if count GT 0 then y[index] = -y[index] + + return, y + + end diff --git a/modules/idl_downloads/astro/pro/astdisp.pro b/modules/idl_downloads/astro/pro/astdisp.pro new file mode 100644 index 0000000..1521c05 --- /dev/null +++ b/modules/idl_downloads/astro/pro/astdisp.pro @@ -0,0 +1,98 @@ +pro AstDisp, x, y, ra, dec, DN, Coords=Coords, silent=silent +;+ +; NAME: +; ASTDISP +; +; PURPOSE: +; Print astronomical and pixel coordinates in a standard format +; EXPLANATION: +; This procedure (ASTrometry DISPlay) prints the astronomical and +; pixel coordinates in a standard format. X,Y must be supplied. RA,DEC +; may also be supplied, and a data number (DN) may also be +; supplied. With use of the Coords= keyword, a string containing the +; formatted data can be returned in addition or instead (with /silent) +; of printing. +; +; CALLING SEQUENCE: +; ASTDISP, x, y, [Ra, Dec, DN, COORD = , /SILENT ] +; +; INPUT: +; X - The X pixel coordinate(s), scalar or vector +; Y - The Y pixel coordinate(s), scalar or vector +; +; OPTIONAL INPUTS: +; RA - Right Ascension in *degrees*, scalar or vector +; DEC - DEClination in *degrees*, scalar or vector (if RA is supplied, DEC must also be supplied) +; DN - Data Number or Flux values +; +; Each of the inputs X,Y, RA, DEC, DN should have the same number of +; elements +; OPTIONAL INPUT KEYWORDS: +; SILENT Prevents printing. Only useful when used with Coords= +; OUTPUT: +; Printed positions in both degrees and sexagesimal format +; All passed variables remain unchanged +; OPTIONAL KEYWORD OUTPUT: +; COORDS Returns the formatted coordinates in a string +; PROCEDURES CALLED: +; ADSTRING - used to format the RA and Dec +; HISTORY: +; 10-AUG-90 Version 1 written by Eric W. Deutsch +; 20-AUG-91 Converted to standard header. Vectorized Code. E. Deutsch +; 20-NOV-92 Added Coords= and /silent. E.Deutsch +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + arg = N_params() + if (arg lt 2) then begin + print,'Call: IDL> AstDisp,x_pixel,y_pixel,[RA,DEC],[DN],[/silent,coords=]' + print,'e.g.: IDL> AstDisp,x,y,ra,dec' + return + endif + + if (arg eq 3) then message,'ERROR - Both RA and Dec values must be supplied' + + silent = keyword_set(SILENT) + +; X and Y must be supplied + + hdr = ' X Y' + fmt = '(f8.2,1x,f8.2' + if (arg le 2) then begin & type=0 & goto,PRN & endif + +; Ra and Dec can be optionally supplied + + hdr = hdr+' RA DEC RA DEC' + fmt = fmt+',2x,F9.4,1x,F9.4,2x,A' + if (arg le 4) then begin & type=1 & goto,PRN & endif + +; A data number can be optionally supplied + + hdr = hdr+' DN' + fmt = fmt+',3x,f9.3' + type = 2 + +PRN: + if not SILENT then print,hdr + Coords = strarr( N_elements(x)+1 ) + Coords[0] = hdr + + for i = 0, N_elements(x)-1 do begin + + case type of + + 0: out = string(format=fmt+')',x[i],y[i],/print) + 1: out = string(format=fmt+')',x[i],y[i],ra[i],dec[i], $ + adstring(ra[i],dec[i],2),/print) + 2: out = string(format=fmt+')',x[i],y[i],ra[i],dec[i], $ + adstring(ra[i],dec[i],2),DN[i],/print) + endcase + + if not SILENT then print,out + Coords[i+1] = out + + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/astro.pro b/modules/idl_downloads/astro/pro/astro.pro new file mode 100644 index 0000000..994a68d --- /dev/null +++ b/modules/idl_downloads/astro/pro/astro.pro @@ -0,0 +1,175 @@ +pro astro, selection, EQUINOX = equinox, FK4 = FK4 +;+ +; NAME: +; ASTRO +; PURPOSE: +; Interactive utility for precession and coordinate conversion. +; +; CALLING SEQUENCE: +; ASTRO, [ selection, EQUINOX =, /FK4] +; +; OPTIONAL INPUT: +; SELECTION - Scalar Integer (0-6) giving the the particular astronomical +; utility to be used. (0) Precession, (1) RA, Dec (2000) to Galactic +; coordinates, (2) Galactic to RA,Dec (2000) (3) RA,Dec (2000) to +; Ecliptic, (4) Ecliptic to RA, Dec, (5) Ecliptic to Galactic, (6) Galactic +; to Ecliptic. Program will prompt for SELECTION if this +; parameter is omitted. +; +; OPTIONAL KEYWORD INPUT: +; EQUINOX - numeric scalar specifying the equinox to use when converting +; between celestial and other coordinates. If not supplied, +; then the RA and Dec will be assumed to be in EQUINOX J2000. +; This keyword is ignored by the precession utility. For +; example, to convert from RA and DEC (J1975) to Galactic +; coordinates: +; +; IDL> astro, 1, E=1975 +; /FK4 - If this keyword is set and nonzero, then calculations are done +; in the FK4 system. For example, to convert from RA and Dec +; (B1975) to Galactic coordinates +; +; IDL> astro,1, E=1975,/FK4 +; METHOD: +; ASTRO uses PRECESS to compute precession, and EULER to compute +; coordinate conversions. The procedure GET_COORDS is used to +; read the coordinates, and ADSTRING to format the RA,Dec output. +; +; NOTES: +; (1) ASTRO temporarily sets !QUIET to suppress compilation messages and +; keep a pretty screen display. +; +; (2) ASTRO was changed in December 1998 to use J2000 as the default +; equinox, **and may be incompatible with earlier calls.*** +; +; (3) A nice online page for coordinate conversions is available at +; http://heasarc.gsfc.nasa.gov/cgi-bin/Tools/convcoord/convcoord.pl +; PROCEDURES USED: +; Procedures: GET_COORDS, EULER Function: ADSTRING +; REVISION HISTORY +; Written, W. Landsman November 1987 +; Code cleaned up W. Landsman October 1991 +; Added Equinox keyword, call to GET_COORDS, W. Landsman April, 1992 +; Allow floating point equinox input J. Parker/W. Landsman July 1996 +; Make FK5 the default, add FK4 keyword +;- + On_error,2 ;Return to caller + + input_type = [0,0,1,0,2,2,1] ;0= RA,Dec 1= Galactic 2 = Ecliptic + output_type = [0,1,0,2,0,1,2] + + sv_quiet = !quiet & !quiet = 1 ;Don't display compiled procedures + + + if keyword_set(FK4) then begin + if not keyword_set(EQUINOX) then equinox = 1950 + fk = 'B' + ref_year = 1950 + yeari = 1950 & yearf = 1950 + endif else begin + if not keyword_set(EQUINOX) then equinox = 2000 + fk = 'J' + ref_year = 2000 + yeari = 2000 & yearf = 2000 + endelse + eqname = fk + string(equinox,f='(f6.1)') + ')' + + select = ['(0) Precession: (RA, Dec)', $ + '(1) Conversion: (RA, Dec ' + eqname + ' --> Galactic', $ + '(2) Conversion: Galactic --> (RA, Dec ' + eqname, $ + '(3) Conversion: (RA, Dec ' + eqname + ' --> Ecliptic', $ + '(4) Conversion: Ecliptic --> (RA, Dec ' + eqname, $ + '(5) Conversion: Ecliptic --> Galactic', $ + '(6) Conversion: Galactic --> Ecliptic'] + + npar = N_params() + + SELECTOR: if (npar EQ 0 ) then begin + + print,'Select astronomical utility' + for i = 0,6 do print, select[i] + selection = 0 + print,' ' + read,'Enter Utility Number: ',selection + print,' ' + + endif + + if ( selection LT 0 ) or ( selection GT 6 ) then begin + + print,selection,' is not an available option' + npar = 0 + goto, SELECTOR + + endif + + print, select[selection] + + if keyword_set(EQUINOX) and (input_type[selection] EQ 0) then yeari =equinox + if keyword_set(EQUINOX) and (output_type[selection] EQ 0) then yearf = equinox + + if ( selection EQ 0 ) then read, $ + 'Enter initial and final equinox (e.g. 1975,2000): ',yeari,yearf + + + case output_type[selection] of + + 0: OutName = " RA Dec (" + fk + string( yearf, f= "(F6.1)" ) + "): " + 1: OutName = " Galactic longitude and latitude: " + 2: OutName = " Ecliptic longitude and latitude: (" + $ + fk + string( yearf, f= "(F6.1)" ) + ")" + endcase + + case input_type[selection] of + + 0: InName = "RA Dec (" + fk + string(yeari ,f ='(F6.1)' ) + ')' + 1: InName = "Galactic longitude and latitude: " + 2: InName = "Ecliptic longitude and latitude: (" + fk + $ + string(yeari ,f ='(F6.1)' ) + ')' + + endcase + + HELP_INP: if ( input_type[selection] EQ 0 ) then begin + + print,format='(/A)',' Enter RA, DEC with either 2 or 6 parameters ' + print,format='(A/)',' Either RA, DEC (degrees) or HR, MIN, SEC, DEG, MIN SEC' + + endif + + READ_INP: + + get_coords,coords,'Enter '+ InName, Numcoords + + if ( coords[0] EQ -999 ) then begin ;Normal Return + print,' ' + if Numcoords GT 0 then goto, READ_INP + !quiet = sv_quiet + return + endif + + ra = coords[0] & dec = coords[1] + if Numcoords EQ 6 then ra = ra*15. + + if ( selection EQ 0 ) then begin + + precess, ra , dec , yeari, yearf, FK4 = fk4 ;Actual Calculations + newra = ra & newdec = dec + + endif else begin + if yeari NE ref_year then precess, ra, dec, yeari, ref_year,FK4=fk4 + euler, ra, dec, newra, newdec, selection, fk4 = FK4 + if yearf NE ref_year then precess, newra,newdec, ref_year, yearf,FK4=fk4 + endelse + + if newra LT 0 then newra = newra + 360. + + if output_type[selection] EQ 0 then $ + print, outname + adstring( [newra,newdec], 1) $ + + else print, FORM = '(A,2F7.2,A,F7.2 )', $ + outname, newra, newdec + + print,' ' + goto, READ_INP + + end diff --git a/modules/idl_downloads/astro/pro/astrolib.pro b/modules/idl_downloads/astro/pro/astrolib.pro new file mode 100644 index 0000000..99d61f9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/astrolib.pro @@ -0,0 +1,51 @@ +PRO ASTROLIB +;+ +; NAME: +; ASTROLIB +; PURPOSE: +; Add the non-standard system variables used by the IDL Astronomy Library +; EXPLANATION: +; Also defines the environment variable ASTRO_DATA pointing to the +; directory containing data files associated with the IDL Astronomy +; library (system dependent -- user must edit the third line in the +; program below). +; +; CALLING SEQUENCE: +; ASTROLIB +; +; INPUTS: +; None. +; +; OUTPUTS: +; None. +; +; METHOD: +; The non-standard system variables !PRIV, !TEXTUNIT, and +; !TEXTOUT are added using DEFSYSV. +; +; REVISION HISTORY: +; Written, Wayne Landsman, July 1986. +; Use DEFSYSV instead of ADDSYSVAR December 1990 +; Test for system variable existence before definition July 2001 +; Assume since V55, remove VMS support W. Landsman Sep 2006 +; Remove !Debug, comment out ASTRO_DATA definition WL Jan 2009 +;- + On_error,2 + compile_opt idl2 + +; User should edit the folowing line and uncomment it to give the location of +; ASTRO_DATA on their own system (or define it in their .cshrc or .bashrc file). +; setenv,'ASTRO_DATA=/export/home/ftp/pub/data/' + + defsysv, '!PRIV', exist = exist + if ~exist then defsysv, '!PRIV', 0 + defsysv, '!TEXTUNIT', exist = exist + if ~exist then defsysv, '!TEXTUNIT', 0 + defsysv, '!TEXTOUT', exist = exist + if ~exist then defsysv, '!TEXTOUT', 1 + + message,'Astronomy Library system variables have been added',/INF + + return + end + diff --git a/modules/idl_downloads/astro/pro/autohist.pro b/modules/idl_downloads/astro/pro/autohist.pro new file mode 100644 index 0000000..66bff44 --- /dev/null +++ b/modules/idl_downloads/astro/pro/autohist.pro @@ -0,0 +1,106 @@ +PRO AUTOHIST,V, ZX,ZY,XX,YY, NOPLOT=whatever,_EXTRA = _extra +; +;+ +; NAME: +; AUTOHIST +; +; PURPOSE: +; Draw a histogram using automatic bin-sizing. +; EXPLANATION +; AUTOHIST chooses a number of bins (initially, SQRT(2*N). If this leads +; to a histogram in which > 1/5 of the central 50% of the bins are empty, +; it decreases the number of bins and tries again. The minimum # bins is +; 5. The max=199. Called by HISTOGAUSS and HALFAGAUSS. +; +; CALLING SEQUENCE: +; AUTOHIST, Sample, XLines, Ylines, XCenters, YCenters, [/NOPLOT, ] +; ...Plotting Keywords +; INPUT: +; Sample = the vector to be histogrammed +; +; OUTPUT: +; XLINES = vector of x coordinates of the points that trace the rectangular +; histogram bins +; YLINES = vector of y coordinates. To draw the histogram plot YLINES vs +; XLINES +; XCENTERS = the x values of the bin centers +; YCENTERS = the corresponding y values +; +; OPTIONAL INPUT KEYWORDS: +; /NOPLOT If set, nothing is drawn +; +; Any plotting keywords (e.g. XTITLE) may be supplied to AUTOHIST through +; the _EXTRA facility. +; REVISION HISTORY: +; Written, H. Freudenreich, STX, 1/91 +; 1998 March 17 - Changed shading of histogram. RSH, RSTX +; V5.0 update, _EXTRA keywords W. Landsman April 2002 +; Added NOCLIP keyword for POLYFILL call C. Paxson/W. Landsman July 2003 +; Use Coyote graphics W. Landsman Feb 2011 +;- + + ON_ERROR,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - AUTOHIST, Sample, XLines, Ylines, XCenters, YCenters, [ ' + print,' /NOPLOT, Plotting keywords... ]' + return + endif + + MINBIN=5 + + N = N_ELEMENTS(V) + NB = FIX(SQRT(2.*N)) < 199 + NB = NB > MINBIN + + X1 = MIN(V, MAX = X2) + +tryagain: + + DX = (X2-X1)/NB + XX = FINDGEN(NB)*DX + DX/2. + X1 + + IND = (V-X1)/DX > 0 <(NB-1) + +; Compute the histogram for the current binning + + YY = HISTOGRAM(IND,MIN=0,MAX = NB-1) + +; Count the fraction of empty bins in the middle half of the histogram: + X14 = (XX[NB-1]-XX[0])/4.+X1 + X34 = XX[NB-1]-(XX[NB-1]-XX[0])/4. + Q=WHERE( (YY EQ 0.) AND (XX GT X14) AND (XX LT X34), COUNT ) + IF (COUNT GT NB/10) AND (NB GT MINBIN) THEN BEGIN ; 20% EMPTY + NB = 3*NB/4 + IF NB LT (2*N) THEN GOTO,tryagain +ENDIF + +; Fill in ZX,ZY: + MB = 2*NB+2 + ZX = FLTARR(MB) & ZY = FLTARR(MB) + IT = INDGEN(NB)*2 + 1 + + ZY[IT] = YY & ZY[IT+1] = YY + + ZX[0] = X1 + ZX[IT] = XX - DX/2. & ZX[IT+1] = XX + DX/2. + ZX[MB-1] = X2 + +IF KEYWORD_SET(WHATEVER) THEN RETURN + +; Plot, then fill, the bins: + YTOP = MAX(YY[1:NB-2]) + YY[0] = YY[0] < YTOP + YY[NB-1] = YY[NB-1] < YTOP + cgPLOT,XX,YY,XRAN=[X1-DX,X2+DX],YRAN=[0.,1.1*YTOP],PSYM=10,_EXTRA=_extra + FOR J=0,NB-1 DO BEGIN + IF YY[J] GT 0 THEN BEGIN + A=[XX[J]-DX/2.,XX[J]+DX/2.,XX[J]+DX/2.,XX[J]-DX/2.] + B=[0.,0.,YY[J],YY[J]] + cgcolorFILL,A,B,orientation=45,noclip=0 + ENDIF +ENDFOR + +RETURN +END diff --git a/modules/idl_downloads/astro/pro/avg.pro b/modules/idl_downloads/astro/pro/avg.pro new file mode 100644 index 0000000..8f1a242 --- /dev/null +++ b/modules/idl_downloads/astro/pro/avg.pro @@ -0,0 +1,111 @@ +FUNCTION AVG,ARRAY,DIMENSION, NAN = NAN, DOUBLE = DOUBLE +;+ +; NAME: +; AVG +; PURPOSE: +; Return the average value of an array, or 1 dimension of an array +; EXPLANATION: +; Calculate the average value of an array, or calculate the average +; value over one dimension of an array as a function of all the other +; dimensions. +; +; In 2009, a DIMENSION keyword was added to the IDL MEAN() function, +; giving it the same capability as AVG(). Thus, the use of AVG() is now +; **deprecated** in favor of the MEAN() function. +; CALLING SEQUENCE: +; RESULT = AVG( ARRAY, [ DIMENSION, /NAN, /DOUBLE ] ) +; +; INPUTS: +; ARRAY = Input array. May be any type except string. +; +; OPTIONAL INPUT PARAMETERS: +; DIMENSION = Optional dimension to do average over, integer scalar +; +; OPTIONAL KEYWORD INPUT: +; /NAN - Set this keyword to cause the routine to check for occurrences of +; the IEEE floating-point value NaN in the input data. Elements with +; the value NaN are treated as missing data. +; /DOUBLE - By default, if the input Array is double-precision, complex, +; or double complex, the result is of the same type; 64 bit +; integers are also returned as double. Otherwise the result +; the result is floating-point. Use of the /DOUBLE keyword +; forces a double precision output. Note that internal +; computations are always done in double precision. +; OUTPUTS: +; The average value of the array when called with one parameter. +; +; If DIMENSION is passed, then the result is an array with all the +; dimensions of the input array except for the dimension specified, +; each element of which is the average of the corresponding vector +; in the input array. +; +; For example, if A is an array with dimensions of (3,4,5), then the +; command B = AVG(A,1) is equivalent to +; +; B = FLTARR(3,5) +; FOR J = 0,4 DO BEGIN +; FOR I = 0,2 DO BEGIN +; B[I,J] = TOTAL( A[I,*,J] ) / 4. +; ENDFOR +; ENDFOR +; +; RESTRICTIONS: +; Dimension specified must be valid for the array passed; otherwise the +; input array is returned as the output array. +; PROCEDURE: +; AVG(ARRAY) = TOTAL(ARRAY, /DOUBLE)/N_ELEMENTS(ARRAY) when called with +; one parameter. +; MODIFICATION HISTORY: +; William Thompson Applied Research Corporation +; July, 1986 8201 Corporate Drive +; Landover, MD 20785 +; Converted to Version 2 July, 1990 +; Replace SUM call with TOTAL W. Landsman May, 1992 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added /NAN keyword W. Landsman July 2000 +; Accept a scalar input value W. Landsman/jimm@berkeley November 2000 +; Internal calculations always in double precision W. Landsman March 2002 +; Return NAN if all values in array are NAN W. Landsman April 2002 +; Fixed coding bug if all values in array are NAN W. Landsman Jan 2004 +;- + ON_ERROR,2 + S = SIZE(ARRAY,/STR) + IF S.N_ELEMENTS EQ 1 THEN RETURN, array[0] + IF S.N_ELEMENTS EQ 0 THEN $ + MESSAGE,'Variable must be an array, name= ARRAY' +; + IF N_PARAMS() EQ 1 THEN BEGIN + IF KEYWORD_SET(NAN) THEN NPTS = TOTAL(FINITE(ARRAY) ) $ + ELSE NPTS = N_ELEMENTS(ARRAY) + IF NPTS EQ 0 THEN AVERAGE = !VALUES.F_NAN ELSE $ + AVERAGE = TOTAL(ARRAY, NAN=NAN,/DOUBLE) / NPTS + ENDIF ELSE BEGIN + IF ((DIMENSION GE 0) AND (DIMENSION LT S.N_DIMENSIONS)) THEN BEGIN + AVERAGE = TOTAL(ARRAY,DIMENSION+1,NAN=NAN,/DOUBLE) +; Install a bug workaround since TOTAL(A,/NAN) returns 0 rather than NAN if +; all A values are NAN. + IF KEYWORD_SET(NAN) THEN BEGIN + NPTS = TOTAL(FINITE(ARRAY),DIMENSION+1 ) + BAD = WHERE(NPTS EQ 0, NBAD) + AVERAGE = AVERAGE/(NPTS>1) + IF NBAD GT 0 THEN AVERAGE[BAD] = !VALUES.D_NAN + ENDIF ELSE AVERAGE = AVERAGE/S.DIMENSIONS[DIMENSION] + + END ELSE $ + MESSAGE,'*** Dimension out of range, name= ARRAY' + ENDELSE + +; Convert to floating point unless of type double, complex, or L64, or +; if /DOUBLE is set. + + IF ~KEYWORD_SET(DOUBLE) THEN BEGIN + CASE S.TYPE OF + 5: RETURN, AVERAGE + 6: RETURN, COMPLEXARR( FLOAT(AVERAGE), FLOAT(IMAGINARY(AVERAGE)) ) + 9: RETURN, AVERAGE + 14: RETURN, AVERAGE + 15: RETURN, AVERAGE + ELSE: RETURN, FLOAT(AVERAGE) + ENDCASE + ENDIF ELSE RETURN, AVERAGE + END diff --git a/modules/idl_downloads/astro/pro/baryvel.pro b/modules/idl_downloads/astro/pro/baryvel.pro new file mode 100644 index 0000000..132532e --- /dev/null +++ b/modules/idl_downloads/astro/pro/baryvel.pro @@ -0,0 +1,340 @@ +pro baryvel, dje, deq, dvelh, dvelb, JPL = JPL +;+ +; NAME: +; BARYVEL +; PURPOSE: +; Calculates heliocentric and barycentric velocity components of Earth. +; +; EXPLANATION: +; BARYVEL takes into account the Earth-Moon motion, and is useful for +; radial velocity work to an accuracy of ~1 m/s. +; +; CALLING SEQUENCE: +; BARYVEL, dje, deq, dvelh, dvelb, [ JPL = ] +; +; INPUTS: +; DJE - (scalar) Julian ephemeris date. +; DEQ - (scalar) epoch of mean equinox of dvelh and dvelb. If deq=0 +; then deq is assumed to be equal to dje. +; OUTPUTS: +; DVELH: (vector(3)) heliocentric velocity component. in km/s +; DVELB: (vector(3)) barycentric velocity component. in km/s +; +; The 3-vectors DVELH and DVELB are given in a right-handed coordinate +; system with the +X axis toward the Vernal Equinox, and +Z axis +; toward the celestial pole. +; +; OPTIONAL KEYWORD SET: +; JPL - if /JPL set, then BARYVEL will call the procedure JPLEPHINTERP +; to compute the Earth velocity using the full JPL ephemeris. +; The JPL ephemeris FITS file JPLEPH.405 must exist in either the +; current directory, or in the directory specified by the +; environment variable ASTRO_DATA. Alternatively, the JPL keyword +; can be set to the full path and name of the ephemeris file. +; A copy of the JPL ephemeris FITS file is available in +; http://idlastro.gsfc.nasa.gov/ftp/data/ +; PROCEDURES CALLED: +; Function PREMAT() -- computes precession matrix +; JPLEPHREAD, JPLEPHINTERP, TDB2TDT - if /JPL keyword is set +; NOTES: +; Algorithm taken from FORTRAN program of Stumpff (1980, A&A Suppl, 41,1) +; Stumpf claimed an accuracy of 42 cm/s for the velocity. A +; comparison with the JPL FORTRAN planetary ephemeris program PLEPH +; found agreement to within about 65 cm/s between 1986 and 1994 +; +; If /JPL is set (using JPLEPH.405 ephemeris file) then velocities are +; given in the ICRS system; otherwise in the FK4 system. +; EXAMPLE: +; Compute the radial velocity of the Earth toward Altair on 15-Feb-1994 +; using both the original Stumpf algorithm and the JPL ephemeris +; +; IDL> jdcnv, 1994, 2, 15, 0, jd ;==> JD = 2449398.5 +; IDL> baryvel, jd, 2000, vh, vb ;Original algorithm +; ==> vh = [-17.07243, -22.81121, -9.889315] ;Heliocentric km/s +; ==> vb = [-17.08083, -22.80471, -9.886582] ;Barycentric km/s +; IDL> baryvel, jd, 2000, vh, vb, /jpl ;JPL ephemeris +; ==> vh = [-17.07236, -22.81126, -9.889419] ;Heliocentric km/s +; ==> vb = [-17.08083, -22.80484, -9.886409] ;Barycentric km/s +; +; IDL> ra = ten(19,50,46.77)*15/!RADEG ;RA in radians +; IDL> dec = ten(08,52,3.5)/!RADEG ;Dec in radians +; IDL> v = vb[0]*cos(dec)*cos(ra) + $ ;Project velocity toward star +; vb[1]*cos(dec)*sin(ra) + vb[2]*sin(dec) +; +; REVISION HISTORY: +; Jeff Valenti, U.C. Berkeley Translated BARVEL.FOR to IDL. +; W. Landsman, Cleaned up program sent by Chris McCarthy (SfSU) June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added /JPL keyword W. Landsman July 2001 +; Documentation update W. Landsman Dec 2005 +;- + On_Error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax: BARYVEL, dje, deq, dvelh, dvelb' + print,' dje - input Julian ephemeris date' + print,' deq - input epoch of mean equinox of dvelh and dvelb' + print,' dvelh - output vector(3) heliocentric velocity comp in km/s' + print,' dvelb - output vector(3) barycentric velocity comp in km/s' + return + endif + + if keyword_set(JPL) then begin + if size(jpl,/TNAME) EQ 'STRING' then jplfile = jpl else $ + jplfile = find_with_def('JPLEPH.405','ASTRO_DATA') + if jplfile EQ '' then message,'ERROR - Cannot find JPL ephemeris file' + JPLEPHREAD,jplfile, pinfo, pdata, [long(dje), long(dje)+1] + JPLEPHINTERP, pinfo, pdata, dje, x,y,z,vx,vy,vz, /EARTH,/VELOCITY, $ + VELUNITS = 'KM/S' + dvelb = [vx,vy,vz] + JPLEPHINTERP, pinfo, pdata, dje, x,y,z,vx,vy,vz, /SUN,/VELOCITY, $ + VELUNITS = 'KM/S' + dvelh = dvelb - [vx,vy,vz] + if deq NE 2000 then begin + if deq EQ 0 then begin + DAYCNV, dje , year, month, day, hour + deq = year + month/12.d + day/365.25d + hour/8766.0d + endif + prema = premat(2000.0d,deq ) + dvelh = prema # dvelh + dvelb = prema # dvelb + endif + return + endif + +;Define constants + dc2pi = 2*!DPI + cc2pi = 2*!PI + dc1 = 1.0D0 + dcto = 2415020.0D0 + dcjul = 36525.0D0 ;days in Julian year + dcbes = 0.313D0 + dctrop = 365.24219572D0 ;days in tropical year (...572 insig) + dc1900 = 1900.0D0 + AU = 1.4959787D8 + +;Constants dcfel(i,k) of fast changing elements. + dcfel = [1.7400353D00, 6.2833195099091D02, 5.2796D-6 $ + ,6.2565836D00, 6.2830194572674D02, -2.6180D-6 $ + ,4.7199666D00, 8.3997091449254D03, -1.9780D-5 $ + ,1.9636505D-1, 8.4334662911720D03, -5.6044D-5 $ + ,4.1547339D00, 5.2993466764997D01, 5.8845D-6 $ + ,4.6524223D00, 2.1354275911213D01, 5.6797D-6 $ + ,4.2620486D00, 7.5025342197656D00, 5.5317D-6 $ + ,1.4740694D00, 3.8377331909193D00, 5.6093D-6 ] + dcfel = reform(dcfel,3,8) + +;constants dceps and ccsel(i,k) of slowly changing elements. + dceps = [4.093198D-1, -2.271110D-4, -2.860401D-8 ] + ccsel = [1.675104E-2, -4.179579E-5, -1.260516E-7 $ + ,2.220221E-1, 2.809917E-2, 1.852532E-5 $ + ,1.589963E00, 3.418075E-2, 1.430200E-5 $ + ,2.994089E00, 2.590824E-2, 4.155840E-6 $ + ,8.155457E-1, 2.486352E-2, 6.836840E-6 $ + ,1.735614E00, 1.763719E-2, 6.370440E-6 $ + ,1.968564E00, 1.524020E-2, -2.517152E-6 $ + ,1.282417E00, 8.703393E-3, 2.289292E-5 $ + ,2.280820E00, 1.918010E-2, 4.484520E-6 $ + ,4.833473E-2, 1.641773E-4, -4.654200E-7 $ + ,5.589232E-2, -3.455092E-4, -7.388560E-7 $ + ,4.634443E-2, -2.658234E-5, 7.757000E-8 $ + ,8.997041E-3, 6.329728E-6, -1.939256E-9 $ + ,2.284178E-2, -9.941590E-5, 6.787400E-8 $ + ,4.350267E-2, -6.839749E-5, -2.714956E-7 $ + ,1.348204E-2, 1.091504E-5, 6.903760E-7 $ + ,3.106570E-2, -1.665665E-4, -1.590188E-7 ] + ccsel = reform(ccsel,3,17) + +;Constants of the arguments of the short-period perturbations. + dcargs = [5.0974222D0, -7.8604195454652D2 $ + ,3.9584962D0, -5.7533848094674D2 $ + ,1.6338070D0, -1.1506769618935D3 $ + ,2.5487111D0, -3.9302097727326D2 $ + ,4.9255514D0, -5.8849265665348D2 $ + ,1.3363463D0, -5.5076098609303D2 $ + ,1.6072053D0, -5.2237501616674D2 $ + ,1.3629480D0, -1.1790629318198D3 $ + ,5.5657014D0, -1.0977134971135D3 $ + ,5.0708205D0, -1.5774000881978D2 $ + ,3.9318944D0, 5.2963464780000D1 $ + ,4.8989497D0, 3.9809289073258D1 $ + ,1.3097446D0, 7.7540959633708D1 $ + ,3.5147141D0, 7.9618578146517D1 $ + ,3.5413158D0, -5.4868336758022D2 ] + dcargs = reform(dcargs,2,15) + +;Amplitudes ccamps(n,k) of the short-period perturbations. + ccamps = $ + [-2.279594E-5, 1.407414E-5, 8.273188E-6, 1.340565E-5, -2.490817E-7 $ + ,-3.494537E-5, 2.860401E-7, 1.289448E-7, 1.627237E-5, -1.823138E-7 $ + , 6.593466E-7, 1.322572E-5, 9.258695E-6, -4.674248E-7, -3.646275E-7 $ + , 1.140767E-5, -2.049792E-5, -4.747930E-6, -2.638763E-6, -1.245408E-7 $ + , 9.516893E-6, -2.748894E-6, -1.319381E-6, -4.549908E-6, -1.864821E-7 $ + , 7.310990E-6, -1.924710E-6, -8.772849E-7, -3.334143E-6, -1.745256E-7 $ + ,-2.603449E-6, 7.359472E-6, 3.168357E-6, 1.119056E-6, -1.655307E-7 $ + ,-3.228859E-6, 1.308997E-7, 1.013137E-7, 2.403899E-6, -3.736225E-7 $ + , 3.442177E-7, 2.671323E-6, 1.832858E-6, -2.394688E-7, -3.478444E-7 $ + , 8.702406E-6, -8.421214E-6, -1.372341E-6, -1.455234E-6, -4.998479E-8 $ + ,-1.488378E-6, -1.251789E-5, 5.226868E-7, -2.049301E-7, 0.E0 $ + ,-8.043059E-6, -2.991300E-6, 1.473654E-7, -3.154542E-7, 0.E0 $ + , 3.699128E-6, -3.316126E-6, 2.901257E-7, 3.407826E-7, 0.E0 $ + , 2.550120E-6, -1.241123E-6, 9.901116E-8, 2.210482E-7, 0.E0 $ + ,-6.351059E-7, 2.341650E-6, 1.061492E-6, 2.878231E-7, 0.E0 ] + ccamps = reform(ccamps,5,15) + +;Constants csec3 and ccsec(n,k) of the secular perturbations in longitude. + ccsec3 = -7.757020E-8 + ccsec = [1.289600E-6, 5.550147E-1, 2.076942E00 $ + ,3.102810E-5, 4.035027E00, 3.525565E-1 $ + ,9.124190E-6, 9.990265E-1, 2.622706E00 $ + ,9.793240E-7, 5.508259E00, 1.559103E01 ] + ccsec = reform(ccsec,3,4) + +;Sidereal rates. + dcsld = 1.990987D-7 ;sidereal rate in longitude + ccsgd = 1.990969E-7 ;sidereal rate in mean anomaly + +;Constants used in the calculation of the lunar contribution. + cckm = 3.122140E-5 + ccmld = 2.661699E-6 + ccfdi = 2.399485E-7 + +;Constants dcargm(i,k) of the arguments of the perturbations of the motion +; of the moon. + dcargm = [5.1679830D0, 8.3286911095275D3 $ + ,5.4913150D0, -7.2140632838100D3 $ + ,5.9598530D0, 1.5542754389685D4 ] + dcargm = reform(dcargm,2,3) + +;Amplitudes ccampm(n,k) of the perturbations of the moon. + ccampm = [ 1.097594E-1, 2.896773E-7, 5.450474E-2, 1.438491E-7 $ + ,-2.223581E-2, 5.083103E-8, 1.002548E-2, -2.291823E-8 $ + , 1.148966E-2, 5.658888E-8, 8.249439E-3, 4.063015E-8 ] + ccampm = reform(ccampm,4,3) + +;ccpamv(k)=a*m*dl,dt (planets), dc1mme=1-mass(earth+moon) + ccpamv = [8.326827E-11, 1.843484E-11, 1.988712E-12, 1.881276E-12] + dc1mme = 0.99999696D0 + +;Time arguments. + dt = (dje - dcto) / dcjul + tvec = [1d0, dt, dt*dt] + +;Values of all elements for the instant(aneous?) dje. + temp = (tvec # dcfel) mod dc2pi + dml = temp[0] + forbel = temp[1:7] + g = forbel[0] ;old fortran equivalence + + deps = total(tvec*dceps) mod dc2pi + sorbel = (tvec # ccsel) mod dc2pi + e = sorbel[0] ;old fortran equivalence + +;Secular perturbations in longitude. +dummy=cos(2.0) + sn = sin((tvec[0:1] # ccsec[1:2,*]) mod cc2pi) + +;Periodic perturbations of the emb (earth-moon barycenter). + pertl = total(ccsec[0,*] * sn) + dt*ccsec3*sn[2] + pertld = 0.0 + pertr = 0.0 + pertrd = 0.0 + for k=0,14 do begin + a = (dcargs[0,k]+dt*dcargs[1,k]) mod dc2pi + cosa = cos(a) + sina = sin(a) + pertl = pertl + ccamps[0,k]*cosa + ccamps[1,k]*sina + pertr = pertr + ccamps[2,k]*cosa + ccamps[3,k]*sina + if k lt 11 then begin + pertld = pertld + (ccamps[1,k]*cosa-ccamps[0,k]*sina)*ccamps[4,k] + pertrd = pertrd + (ccamps[3,k]*cosa-ccamps[2,k]*sina)*ccamps[4,k] + endif + endfor + +;Elliptic part of the motion of the emb. + phi = (e*e/4d0)*(((8d0/e)-e)*sin(g) +5*sin(2*g) +(13/3d0)*e*sin(3*g)) + f = g + phi + sinf = sin(f) + cosf = cos(f) + dpsi = (dc1 - e*e) / (dc1 + e*cosf) + phid = 2*e*ccsgd*((1 + 1.5*e*e)*cosf + e*(1.25 - 0.5*sinf*sinf)) + psid = ccsgd*e*sinf / sqrt(dc1 - e*e) + +;Perturbed heliocentric motion of the emb. + d1pdro = dc1+pertr + drd = d1pdro * (psid + dpsi*pertrd) + drld = d1pdro*dpsi * (dcsld+phid+pertld) + dtl = (dml + phi + pertl) mod dc2pi + dsinls = sin(dtl) + dcosls = cos(dtl) + dxhd = drd*dcosls - drld*dsinls + dyhd = drd*dsinls + drld*dcosls + +;Influence of eccentricity, evection and variation on the geocentric +; motion of the moon. + pertl = 0.0 + pertld = 0.0 + pertp = 0.0 + pertpd = 0.0 + for k = 0,2 do begin + a = (dcargm[0,k] + dt*dcargm[1,k]) mod dc2pi + sina = sin(a) + cosa = cos(a) + pertl = pertl + ccampm[0,k]*sina + pertld = pertld + ccampm[1,k]*cosa + pertp = pertp + ccampm[2,k]*cosa + pertpd = pertpd - ccampm[3,k]*sina + endfor + +;Heliocentric motion of the earth. + tl = forbel[1] + pertl + sinlm = sin(tl) + coslm = cos(tl) + sigma = cckm / (1.0 + pertp) + a = sigma*(ccmld + pertld) + b = sigma*pertpd + dxhd = dxhd + a*sinlm + b*coslm + dyhd = dyhd - a*coslm + b*sinlm + dzhd= -sigma*ccfdi*cos(forbel[2]) + +;Barycentric motion of the earth. + dxbd = dxhd*dc1mme + dybd = dyhd*dc1mme + dzbd = dzhd*dc1mme + for k=0,3 do begin + plon = forbel[k+3] + pomg = sorbel[k+1] + pecc = sorbel[k+9] + tl = (plon + 2.0*pecc*sin(plon-pomg)) mod cc2pi + dxbd = dxbd + ccpamv[k]*(sin(tl) + pecc*sin(pomg)) + dybd = dybd - ccpamv[k]*(cos(tl) + pecc*cos(pomg)) + dzbd = dzbd - ccpamv[k]*sorbel[k+13]*cos(plon - sorbel[k+5]) + + endfor + +;Transition to mean equator of date. + dcosep = cos(deps) + dsinep = sin(deps) + dyahd = dcosep*dyhd - dsinep*dzhd + dzahd = dsinep*dyhd + dcosep*dzhd + dyabd = dcosep*dybd - dsinep*dzbd + dzabd = dsinep*dybd + dcosep*dzbd + +;Epoch of mean equinox (deq) of zero implies that we should use +; Julian ephemeris date (dje) as epoch of mean equinox. + if deq eq 0 then begin + dvelh = AU * ([dxhd, dyahd, dzahd]) + dvelb = AU * ([dxbd, dyabd, dzabd]) + return + endif + +;General precession from epoch dje to deq. + deqdat = (dje-dcto-dcbes) / dctrop + dc1900 + prema = premat(deqdat,deq,/FK4) + + dvelh = AU * ( prema # [dxhd, dyahd, dzahd] ) + dvelb = AU * ( prema # [dxbd, dyabd, dzabd] ) + + return + end diff --git a/modules/idl_downloads/astro/pro/biweight_mean.pro b/modules/idl_downloads/astro/pro/biweight_mean.pro new file mode 100644 index 0000000..2ecd438 --- /dev/null +++ b/modules/idl_downloads/astro/pro/biweight_mean.pro @@ -0,0 +1,88 @@ +FUNCTION BIWEIGHT_MEAN,Y,SIGMA, WEIGHTs +; +;+ +; NAME: +; BIWEIGHT_MEAN +; +; PURPOSE: +; Calculate the center and dispersion (like mean and sigma) of a +; distribution using bisquare weighting. +; +; CALLING SEQUENCE: +; Mean = BIWEIGHT_MEAN( Vector, [ Sigma, Weights ] ) +; +; INPUTS: +; Vector = Distribution in vector form +; +; OUTPUT: +; Mean - The location of the center. +; +; OPTIONAL OUTPUT ARGUMENTS: +; +; Sigma = An outlier-resistant measure of the dispersion about the +; center, analogous to the standard deviation. +; +; Weights = The weights applied to the data in the last iteration, +; floating point vector +; +; NOTES: +; Since a sample mean scaled by sigma/sqrt(N), has a Student's T +; distribution, the half-width of the 95% confidence interval for +; the sample mean can be determined as follows: +; ABS( T_CVF( .975, .7*(N-1) )*SIGMA/SQRT(N) ) +; where N = number of points, and 0.975 = 1 - (1 - 0.95)/2. +; PROCEDURES USED: +; ROBUST_SIGMA() +; REVISION HISTORY +; Written, H. Freudenreich, STX, 12/89 +; Modified 2/94, H.T.F.: use a biweighted standard deviation rather than +; median absolute deviation. +; Modified 2/94, H.T.F.: use the fractional change in SIGMA as the +; convergence criterion rather than the change in center/SIGMA. +; Modified May 2002 Use MEDIAN(/EVEN) +; Modified October 2002, Faster computation of weights +; Corrected documentation on 95% confidence interval of mean +; P.Broos/W. Landsman July 2003 +;- + + ON_ERROR,2 + maxit = 20 ; Allow 20 iterations, this should nearly always be sufficient + eps = 1.0e-24 + + n = n_elements(y) + close_enough =.03*sqrt(.5/(n-1)) ; compare to fractional change in width + + diff = 1.0e30 + itnum = 0 + +; As an initial estimate of the center, use the median: + y0=median(y,/even) + +; Calculate the weights: + dev = y-y0 + sigma = ROBUST_SIGMA( dev ) + + if sigma lt EPS then begin +; The median is IT. Do we need the weights? + if arg_present(weights) then begin +; Flag any value away from the median: + limit=3.*sigma + weights = float(abs(dev) LE limit) + endif + diff = 0. ; (skip rest of routine) + endif + +; Repeat: + while( (diff gt close_enough) and (itnum lt maxit) )do begin + itnum = itnum + 1 + uu = ( (y-y0)/(6.*sigma) )^2 + uu = uu < 1. + weights=(1.-uu)^2 & weights=weights/total(weights) + y0 = total( weights*y ) + dev = y-y0 + prev_sigma = sigma & sigma = robust_sigma( dev,/zero ) + if sigma gt eps then diff=abs(prev_sigma-sigma)/prev_sigma else diff=0. + endwhile + +return,y0 +end diff --git a/modules/idl_downloads/astro/pro/blink.pro b/modules/idl_downloads/astro/pro/blink.pro new file mode 100644 index 0000000..0fd34c2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/blink.pro @@ -0,0 +1,114 @@ +PRO BLINK, wndw, t +;+ +; NAME: +; BLINK +; PURPOSE: +; To allow the user to alternatively examine two or more windows within +; a single window. +; +; CALLING SEQUENCE: +; BLINK, Wndw [, T] +; +; INPUTS: +; Wndw A vector containing the indices of the windows to blink. +; T The time to wait, in seconds, between blinks. This is optional +; and set to 1 if not present. +; +; OUTPUTS: +; None. +; +; PROCEDURE: +; The images contained in the windows given are written to a pixmap. +; The contents of the the windows are copied to a display window, in +; order, until a key is struck. +; +; EXAMPLE: +; Blink windows 0 and 2 with a wait time of 3 seconds +; +; IDL> blink, [0,2], 3 +; +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 2 May 1990. +; Allow different size windows Wayne Landsman August, 1991 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; Check the parameters. +; +On_error,2 ;Return to caller +n = n_params(0) +cflg = 0 +IF (n LT 2) THEN BEGIN + IF (n LT 1) THEN cflg = 1 + t = 1.0 +ENDIF +IF (cflg NE 1) THEN BEGIN + s = size(wndw) + cflg = 2 + IF (s[0] GT 0) THEN BEGIN + IF (s[1] GT 1) THEN cflg = 0 + n_wndw = s[1] + ENDIF +ENDIF +; +; Check to see if a window is open. If so, save the +; index for later use. +; +IF (cflg EQ 0) THEN BEGIN + whld = !d.window + IF (whld LT 0) THEN cflg = 3 +ENDIF +; +; If not enough or incorrect parameters were given, +; complain and return. +; +IF (cflg NE 0) THEN BEGIN + IF (cflg EQ 1) THEN BEGIN + print, " Insufficient parameters given to BLINK." + print, " Syntax: BLINK, WIN_INDICES [, TIME]" + ENDIF + IF (cflg EQ 2) THEN print, " The array of window indices is invalid." + IF (cflg EQ 3) THEN print, " No windows are open." +ENDIF ELSE BEGIN +; +; +; Get the size of each window in the array. +; +device, window = opnd +ncol = intarr(n_wndw) +nrow = ncol +for i=0,n_wndw-1 do begin + if ~opnd[wndw[i]] then $ + message,'ERROR - Window '+ strtrim(wndw[i],2) + ' is not open' + wset, wndw[i] + ncol[i] = !d.x_vsize + nrow[i] = !d.y_vsize +endfor +; +; Write a message explaining how to terminate BLINK. +; + print, " " + print, "To exit BLINK, strike any key." + print, " " +; +; Create the display window and display the images. +; + window, /free, retain=2, xsize = max(ncol), ysize=max(nrow), $ + xpos=0, ypos=0, $ + title="Blink window - Press any key to exit" + whd = !d.window + i = 0L + WHILE (get_kbrd(0) EQ '') DO BEGIN + device, copy=[0, 0, ncol[i], nrow[i], 0, 0, wndw[i]] + i = (i + 1) mod n_wndw + wait, t + ENDWHILE +; +; Clear up and terminate. Close windows/pixmaps and +; restore the originally active window. +; + wdelete, whd + wset, whld +ENDELSE +; +RETURN +END diff --git a/modules/idl_downloads/astro/pro/blkshift.pro b/modules/idl_downloads/astro/pro/blkshift.pro new file mode 100644 index 0000000..faa8234 --- /dev/null +++ b/modules/idl_downloads/astro/pro/blkshift.pro @@ -0,0 +1,231 @@ +;+ +; NAME: +; BLKSHIFT +; +; PURPOSE: +; Shift a block of data to a new position in a file (possibly overlapping) +; +; CALLING SEQUENCE: +; +; BLKSHIFT, UNIT, POS, [ DELTA, TO=TO, /NOZERO, ERRMSG=ERRMSG, +; BUFFERSIZE=BUFFERSIZE ] +; +; DESCRIPTION: +; +; BLKSHIFT moves a block of data forward or backward, to a new +; position in a data file. The old and new positions of the block +; can overlap safely. +; +; The new position can be specified with either the DELTA parameter, +; which gives the number of bytes to move forward (positive delta) or +; backward (negative delta); or the TO keyword, which give the new +; absolute starting position of the block. +; +; The block can be moved beyond the current end of file point, in +; which case the intervening gap is filled with zeros (optionally). +; The gap left at the old position of the block is also optionally +; zero-filled. If a set of data up to the end of the file is being +; moved forward (thus making the file smaller) then +; the file is truncated at the new end.using TRUNCATE_LUN. +; +; INPUTS: +; +; UNIT - a logical unit number, opened for reading and writing. +; +; POS - POS[0] is the position of the block in the file, in bytes, +; before moving. POS[1], if present, is the size of the block +; in bytes. If POS[1] is not given, then the block is from +; POS[0] to the end of the file. +; +; DELTA - the (optional) offset in bytes between the old and new +; positions, from the start of the block. Positive values +; indicate moving the data forward (toward the end of file), +; and negative values indicate moving the data backward +; (toward the beginning of the file). One of DELTA and TO +; must be specified; DELTA overrides the TO keyword. +; +; Attempts to move the block beyond the end of the file will +; succeed. A block can never be moved beyond the beginning +; of the file; it will be moved to the beginning instead. +; +; KEYWORD PARAMETERS: +; +; TO - the absolute file offset in bytes for the new start of the +; block. One of DELTA and TO must be specified; DELTA +; overrides the TO keyword. +; +; /NOZERO - if set, then newly created gaps will not be explicitly +; zeroed. Note that in same systems (e.g. MacOS) the gaps will +; always be zeroed whether or not /NOZERO is set. +; +; ERRMSG - If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors +; are encountered, then a null string is returned. +; +; BLKSHIFT, UNIT, POS, DElTA, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; BUFFERSIZE - the maximum buffer size for transfers, in bytes. +; Larger values of this keyword impose larger memory +; requirements on the application; smaller values will +; lead to more transfer operations. +; Default: 32768 (bytes) +; +; ORIGINAL AUTHOR: +; Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770 +; craig.markwardt@nasa.gov +; +; MODIFICATION HISTORY: +; +; Written, CM, Apr 2000 +; Documented and re-written, CM, 20 Jul 2000 +; Renamed from FXSHIFT to BLKSHIFT, CM, 21 Jul 2000 +; Documentation, CM, 12 Dec 2002 +; Truncate if moving data block forward from the end of file +; using TRUNCATE_LUN W. Landsman Feb. 2005 +; Assume since V5.5, remove VMS support W. Landsman Sep 2006 +; Assume since V5.6, TRUNCATE_LUN available W. Landsman Sep 2006 +; MacOS can point beyond EOF W. Landsman Aug 2009 +; Use V6.0 notation W. Landsman Aprl 2014 +;- +PRO BLKSHIFT, UNIT, POS0, DELTA0, NOZERO=NOZERO0, ERRMSG=ERRMSG, $ + BUFFERSIZE=BUFFERSIZE0, TO=TO0 + + ;; Default error handling + compile_opt idl2 + on_error, 2 + on_ioerror, IO_FINISH + if n_params() LT 3 then begin + message = 'BLKSHIFT, UNIT, POS, DELTA' + goto, ERRMSG_OUT + endif + + ;; Make sure file is open for writing, and begin parameter + ;; processing + fs = fstat(unit) + if fs.open EQ 0 OR fs.write EQ 0 then begin + message = 'File '+fs.name+' is not open for writing' + goto, ERRMSG_OUT + endif + nozero = keyword_set(nozero0) + pos_beg = floor(pos0[0]) + if n_elements(pos0) GT 1 then pos_fin = floor(pos0[1]) + if n_elements(pos_fin) EQ 0 then pos_fin = fs.size - 1L + + if pos_beg GE fs.size then goto, GOOD_FINISH + if n_elements(to0) EQ 0 AND n_elements(delta0) EQ 0 then begin + message = 'Must specify DELTA or TO' + goto, ERRMSG_OUT + endif + + ;; Parse the delta value, and enforce the file positioning + if n_elements(delta0) GT 0 then begin + delta = floor(delta0[0]) + ;; Can't move beyond beginning of file + delta = ((pos_beg + delta) > 0L) - pos_beg + endif else begin + delta = (floor(to0[0]) > 0L) - pos_beg + endelse + + if delta EQ 0 then goto, GOOD_FINISH + if pos_fin GE fs.size then pos_fin = fs.size - 1L + if pos_fin LT pos_beg then goto, GOOD_FINISH + + if n_elements(buffersize0) EQ 0 then buffersize0 = 32768L + buffersize = long(buffersize0[0]) + if buffersize LE 0 then buffersize = 32768L + + ;; Seek to end of file and add zeroes (if needed) + pos_fin += 1L + + ;; Unless /Nozero set, the zeroes will be explicitly written + if (delta GT 0) && (nozero EQ 0) && (pos_fin+delta GT fs.size) then begin + point_lun, unit, fs.size + nleft = (pos_fin-fs.size) + delta + while nleft GT 0 do begin + ntrans = nleft < buffersize + if n_elements(bb0) NE ntrans then bb0 = bytarr(ntrans) + writeu, unit, bb0, transfer_count=cc + if cc EQ 0 then goto, IO_FINISH + nleft -= cc + endwhile + endif + + ;; Now shift the data forward or backward + if delta GT 0 then begin + + ;; Shift forward (toward end of file) + edat = pos_fin ;; End of to-be-copied data segment + while edat GT pos_beg do begin + ntrans = (edat - pos_beg) < buffersize + if n_elements(bb0) NE ntrans then bb0 = bytarr(ntrans) + point_lun, unit, edat - ntrans + readu, unit, bb0, transfer_count=cc + if cc NE ntrans then goto, IO_FINISH + point_lun, unit, edat - ntrans + delta + writeu, unit, bb0, transfer_count=cc + if cc NE ntrans then goto, IO_FINISH + edat -= ntrans + endwhile + endif else begin + + ;; Shift backward (toward beginning of file) + bdat = pos_beg ;; Beginning of to-be-copied data segment + while bdat LT pos_fin do begin + ntrans = (pos_fin - bdat) < buffersize + if n_elements(bb0) NE ntrans then bb0 = bytarr(ntrans) + point_lun, unit, bdat + readu, unit, bb0, transfer_count=cc + if cc NE ntrans then goto, IO_FINISH + point_lun, unit, bdat - abs(delta) + writeu, unit, bb0, transfer_count=cc + if cc NE ntrans then goto, IO_FINISH + bdat += ntrans + endwhile + if pos_fin EQ fs.size then begin + Truncate_Lun, unit + goto, GOOD_FINISH + endif + endelse + bb0 = [0b] & dummy = temporary(bb0) + + ;; Finally, zero out the gap we created + if nozero EQ 0 then begin + if delta GT 0 then begin + point_lun, unit, pos_beg ;; also, to be sure data is flushed + z_fin = pos_fin < (pos_beg + delta) + nleft = (z_fin - pos_beg) + endif else begin + z_beg = (pos_fin - abs(delta)) > pos_beg + nleft = (pos_fin - z_beg) + point_lun, unit, z_beg + endelse + while nleft GT 0 do begin + i = nleft < buffersize + if n_elements(bb0) NE i then bb0 = bytarr(i) + writeu, unit, bb0, transfer_count=cc + if cc EQ 0 then goto, IO_FINISH + nleft -= cc + endwhile + endif + point_lun, unit, pos_beg ;; again, to be sure data is flushed + + GOOD_FINISH: + if arg_present(errmsg) then errmsg = '' + return + + IO_FINISH: + on_ioerror, NULL + message = 'ERROR: BLKSHIFT operation failed because of an I/O error' + ;; fallthrough... + + ;; Error message processing. Control does not pass through here. + ERRMSG_OUT: + if arg_present(errmsg) then begin + errmsg = message + return + endif + message, message +END + diff --git a/modules/idl_downloads/astro/pro/boost_array.pro b/modules/idl_downloads/astro/pro/boost_array.pro new file mode 100644 index 0000000..d122903 --- /dev/null +++ b/modules/idl_downloads/astro/pro/boost_array.pro @@ -0,0 +1,130 @@ + PRO BOOST_ARRAY, DESTINATION, APPEND +;+ +; NAME: +; BOOST_ARRAY +; PURPOSE: +; Append one array onto a destination array +; EXPLANATION: +; Add array APPEND to array DESTINATION, allowing the dimensions of +; DESTINATION to adjust to accommodate it. If both input arrays have the +; same number of dimensions, then the output array will have one +; additional dimension. Otherwise, the last dimension of DESTINATION +; will be incremented by one. +; CATEGORY: +; Utility +; CALLING SEQUENCE: +; BOOST_ARRAY, DESTINATION, APPEND +; INPUT: +; DESTINATION = Array to be expanded. +; APPEND = Array to append to DESTINATION. +; OUTPUTS: +; DESTINATION = Expanded output array. +; RESTRICTIONS: +; DESTINATION and APPEND have to be either both of type string or both of +; numerical types. +; +; APPEND cannot have more dimensions than DESTINATION. +; +; MODIFICATION HISTOBY: +; Written Aug'88 (DMZ, ARC) +; Modified Sep'89 to handle byte arrays (DMZ) +; Modifed to version 2, Paul Hick (ARC), Feb 1991 +; Removed restriction to 2D arrays, William Thompson (ARC), Feb 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR, 2 ;On error, return to caller +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN MESSAGE, $ + 'Syntax: BOOST_ARRAY, DESTINATION, APPEND' +; +; Make sure APPEND is defined. +; + IF N_ELEMENTS(APPEND) EQ 0 THEN MESSAGE, $ + 'Array to be appended (APPEND) not defined' +; +; If DESTINATION is not defined, then set it equal to APPEND. +; + IF N_ELEMENTS(DESTINATION) EQ 0 THEN BEGIN + DESTINATION = APPEND + RETURN + ENDIF +; +; Get the array types and dimensions of DESTINATION and APPEND. +; + SD = SIZE(DESTINATION) + SA = SIZE(APPEND) + D_NDIM = SD[0] + A_NDIM = SA[0] + IF D_NDIM EQ 0 THEN D_DIM = 1 ELSE D_DIM = SD[1:D_NDIM] + IF A_NDIM EQ 0 THEN A_DIM = 1 ELSE A_DIM = SA[1:A_NDIM] + D_TYPE = SD[N_ELEMENTS(SD)-2] + A_TYPE = SA[N_ELEMENTS(SA)-2] +; +; Treat scalars as one-dimensional arrays. +; + D_NDIM = D_NDIM > 1 + A_NDIM = A_NDIM > 1 +; +; Check to see if both arrays are of type string or numeric. +; + IF D_TYPE EQ 7 THEN D_STRING = 1 ELSE D_STRING = 0 + IF A_TYPE EQ 7 THEN A_STRING = 1 ELSE A_STRING = 0 + IF D_STRING NE A_STRING THEN MESSAGE, $ + 'Data arrays should be either both string or both non-string' +; +; Calculate the number of dimensions in the output array. If both arrays have +; the same number of dimensions, then create a new array with an extra +; dimension of two. Otherwise, make sure that DESTINATION has more dimensions +; than APPEND. +; + IF D_NDIM EQ A_NDIM THEN BEGIN + R_DIM = [D_DIM > A_DIM, 2] + END ELSE IF D_NDIM LT A_NDIM THEN BEGIN + MESSAGE,'APPEND has more dimensions than DESTINATION' +; +; Otherwise, merge the dimensions of DESTINATION and APPEND, and add one to +; the final dimension. +; + END ELSE BEGIN + R_DIM = D_DIM + FOR I = 0,A_NDIM-1 DO R_DIM[I] = D_DIM[I] > A_DIM[I] + R_DIM[D_NDIM-1] = R_DIM[D_NDIM-1] + 1 + ENDELSE +; +; Create the output array with the correct number of elements, and the greater +; of the types of DESTINATION and APPEND. +; + OUTPUT = MAKE_ARRAY(DIMENSION=R_DIM, TYPE=(D_TYPE > A_TYPE)) +; +; Store DESTINATION in the output array. +; + R_NDIM = N_ELEMENTS(R_DIM) + CASE R_NDIM OF + 2: OUTPUT[0,0] = DESTINATION + 3: OUTPUT[0,0,0] = DESTINATION + 4: OUTPUT[0,0,0,0] = DESTINATION + 5: OUTPUT[0,0,0,0,0] = DESTINATION + 6: OUTPUT[0,0,0,0,0,0] = DESTINATION + 7: OUTPUT[0,0,0,0,0,0,0] = DESTINATION + ENDCASE +; +; Add APPEND at the end. +; + LAST = R_DIM[R_NDIM-1] - 1 + CASE R_NDIM OF + 2: OUTPUT[0,LAST] = APPEND + 3: OUTPUT[0,0,LAST] = APPEND + 4: OUTPUT[0,0,0,LAST] = APPEND + 5: OUTPUT[0,0,0,0,LAST] = APPEND + 6: OUTPUT[0,0,0,0,0,LAST] = APPEND + 7: OUTPUT[0,0,0,0,0,0,LAST] = APPEND + ENDCASE +; +; Replace DESTINATION with OUTPUT, and return. +; + DESTINATION = OUTPUT + RETURN + END diff --git a/modules/idl_downloads/astro/pro/boxave.pro b/modules/idl_downloads/astro/pro/boxave.pro new file mode 100644 index 0000000..899de45 --- /dev/null +++ b/modules/idl_downloads/astro/pro/boxave.pro @@ -0,0 +1,128 @@ +function boxave, array, xsize, ysize +;+ +; NAME: +; BOXAVE +; PURPOSE: +; Box-average a 1 or 2 dimensional array. +; EXPLANATION: +; This procedure differs from the intrinsic REBIN function in the follow +; 2 ways: +; +; (1) the box size parameter is specified rather than the output +; array size +; (2) for INTEGER arrays, BOXAVE computes intermediate steps using REAL*4 +; (or REAL*8 for 64bit integers) arithmetic. This is +; considerably slower than REBIN but avoids integer truncation +; +; CALLING SEQUENCE: +; result = BOXAVE( Array, Xsize,[ Ysize ] ) +; +; INPUTS: +; ARRAY - Two dimensional input Array to be box-averaged. Array may be +; one or 2 dimensions and of any type except character. +; +; OPTIONAL INPUTS: +; XSIZE - Size of box in the X direction, over which the array is to +; be averaged. If omitted, program will prompt for this +; parameter. +; YSIZE - For 2 dimensional arrays, the box size in the Y direction. +; If omitted, then the box size in the X and Y directions are +; assumed to be equal +; +; OUTPUT: +; RESULT - Output array after box averaging. If the input array has +; dimensions XDIM by YDIM, then RESULT has dimensions +; XDIM/NBOX by YDIM/NBOX. The type of RESULT is the same as +; the input array. However, the averaging is always computed +; using REAL arithmetic, so that the calculation should be exact. +; If the box size did not exactly divide the input array, then +; then not all of the input array will be boxaveraged. +; +; PROCEDURE: +; BOXAVE boxaverages all points simultaneously using vector subscripting +; +; NOTES: +; If im_int is a 512 x 512 integer (16 bit) array, then the two statements +; +; IDL> im = fix(round(rebin(float(im_int), 128, 128))) +; IDL> im = boxave( im_int,4) +; +; give equivalent results. The use of REBIN is faster, but BOXAVE is +; is less demanding on virtual memory, since one does not need to make +; a floating point copy of the entire array. +; +; REVISION HISTORY: +; Written, W. Landsman, October 1986 +; Call REBIN for REAL*4 and REAL*8 input arrays, W. Landsman Jan, 1992 +; Removed /NOZERO in output array definition W. Landsman 1995 +; Fixed occasional integer overflow problem W. Landsman Sep. 1995 +; Allow unsigned data types W. Landsman Jan. 2000 +; Assume since V5.4, Allow 64bit integers W. Landsman Apr 2006 +;- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then $ + message,'Syntax - out = BOXAVE( array, xsize, [ysize ])',/NoName + + s = size(array) + if ( s[0] NE 1 ) and ( s[0] NE 2 ) then $ + message,'Input array (first parameter) must be 1 or 2 dimensional' + + if N_elements(xsize) EQ 0 then read,'BOXAVE: Enter box size: ',xsize + if N_elements(ysize) EQ 0 then ysize = xsize + + s = size(array) + ninx = s[1] + noutx = ninx/xsize + type = s[ s[0] + 1] + integer = (type LT 4) or (type GE 12) + + if s[0] EQ 1 then begin ; 1 dimension? + + if integer then begin + + if xsize LT 2 then return, array + counter = lindgen(noutx)*xsize + output = array[counter] + for i=1,xsize-1 do output = output + array[counter + i] + if type GE 14 then nboxsq = double(xsize) else nboxsq = float(xsize) + + endif else return, rebin( array, noutx) ;Use REBIN if not integer + + endif else begin ; 2 dimensions + + niny = s[2] + nouty = niny/ysize + if integer then begin ;Byte, Integer, or Long + + if type GE 14 then begin + nboxsq = double( xsize*ysize ) + output = dblarr( noutx, nouty) ;Create output array + endif else begin + nboxsq = float( xsize*ysize ) + output = fltarr( noutx, nouty) ;Create output array + endelse + counter = lindgen( noutx*nouty ) + counter = xsize*(counter mod noutx) + $ + (ysize*ninx)*long((counter/noutx)) + + for i = 0L,xsize-1 do $ + for j = 0L,ysize-1 do $ + output = output + array[counter + (i + j*ninx)] + + endif else $ + return, rebin( array, noutx, nouty) ;Use REBIN if not integer + endelse + + case type of + 12: return, uint(round( output/nboxsq )) ;Unsigned Integer + 13: return, ulong( round(output/nboxsq)) ;Unsigned Long + 14: return, round(output/nboxsq, /L64) ;64bit integer + 15: return, ulong64(round(output/nboxsq,/L64)) ;Unsigned 64bit + 2: return, fix( round( output/ nboxsq )) ;Integer + 3: return, round( output / nboxsq ) ;Long + 1: return, byte( round( output/nboxsq) ) ;Byte + endcase + + end diff --git a/modules/idl_downloads/astro/pro/bprecess.pro b/modules/idl_downloads/astro/pro/bprecess.pro new file mode 100644 index 0000000..cf812a6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/bprecess.pro @@ -0,0 +1,219 @@ +pro Bprecess, ra, dec, ra_1950, dec_1950, MU_RADEC = mu_radec, $ + PARALLAX = parallax, RAD_VEL = rad_vel, EPOCH = epoch +;+ +; NAME: +; BPRECESS +; PURPOSE: +; Precess positions from J2000.0 (FK5) to B1950.0 (FK4) +; EXPLANATION: +; Calculates the mean place of a star at B1950.0 on the FK4 system from +; the mean place at J2000.0 on the FK5 system. +; +; CALLING SEQUENCE: +; bprecess, ra, dec, ra_1950, dec_1950, [ MU_RADEC = , PARALLAX = +; RAD_VEL =, EPOCH = ] +; +; INPUTS: +; RA,DEC - Input J2000 right ascension and declination in *degrees*. +; Scalar or N element vector +; +; OUTPUTS: +; RA_1950, DEC_1950 - The corresponding B1950 right ascension and +; declination in *degrees*. Same number of elements as +; RA,DEC but always double precision. +; +; OPTIONAL INPUT-OUTPUT KEYWORDS +; MU_RADEC - 2xN element double precision vector containing the proper +; motion in seconds of arc per tropical *century* in right +; ascension and declination. +; PARALLAX - N_element vector giving stellar parallax (seconds of arc) +; RAD_VEL - N_element vector giving radial velocity in km/s +; +; The values of MU_RADEC, PARALLAX, and RADVEL will all be modified +; upon output to contain the values of these quantities in the +; B1950 system. The parallax and radial velocity will have a very +; minor influence on the B1950 position. +; +; EPOCH - scalar giving epoch of original observations, default 2000.0d +; This keyword value is only used if the MU_RADEC keyword is not set. +; NOTES: +; The algorithm is taken from the Explanatory Supplement to the +; Astronomical Almanac 1992, page 186. +; Also see Aoki et al (1983), A&A, 128,263 +; +; BPRECESS distinguishes between the following two cases: +; (1) The proper motion is known and non-zero +; (2) the proper motion is unknown or known to be exactly zero (i.e. +; extragalactic radio sources). In this case, the reverse of +; the algorithm in Appendix 2 of Aoki et al. (1983) is used to +; ensure that the output proper motion is exactly zero. Better +; precision can be achieved in this case by inputting the EPOCH +; of the original observations. +; +; The error in using the IDL procedure PRECESS for converting between +; B1950 and J1950 can be up to 12", mainly in right ascension. If +; better accuracy than this is needed then BPRECESS should be used. +; +; An unsystematic comparison of BPRECESS with the IPAC precession +; routine (http://nedwww.ipac.caltech.edu/forms/calculator.html) always +; gives differences less than 0.15". +; EXAMPLE: +; The SAO2000 catalogue gives the J2000 position and proper motion for +; the star HD 119288. Find the B1950 position. +; +; RA(2000) = 13h 42m 12.740s Dec(2000) = 8d 23' 17.69'' +; Mu(RA) = -.0257 s/yr Mu(Dec) = -.090 ''/yr +; +; IDL> mu_radec = 100D* [ -15D*.0257, -0.090 ] +; IDL> ra = ten(13, 42, 12.740)*15.D +; IDL> dec = ten(8, 23, 17.69) +; IDL> bprecess, ra, dec, ra1950, dec1950, mu_radec = mu_radec +; IDL> print, adstring(ra1950, dec1950,2) +; ===> 13h 39m 44.526s +08d 38' 28.63" +; +; REVISION HISTORY: +; Written, W. Landsman October, 1992 +; Vectorized, W. Landsman February, 1994 +; Treat case where proper motion not known or exactly zero November 1994 +; Handling of arrays larger than 32767 Lars L. Christensen, march, 1995 +; Fixed bug where A term not initialized for vector input +; W. Landsman February 2000 +; Use V6.0 notation W. Landsman Mar 2011 +; +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - BPRECESS, ra,dec, ra_1950, dec_1950, [MU_RADEC =' + print,' PARALLAX = , RAD_VEL = ]' + print,' Input RA and Dec should be given in DEGREES for J2000' + print,' Proper motion, MU_RADEC, (optional) in arc seconds per *century*' + print,' Parallax (optional) in arc seconds' + print,' Radial Velocity (optional) in km/s' + return + + endif + + N = N_elements( ra ) + if N EQ 0 then message,'ERROR - First parameter (RA vector) is undefined' + + if ~keyword_set( RAD_VEL) then rad_vel = dblarr(N) else begin + rad_vel = rad_vel*1. + if N_elements( RAD_VEL) NE N then message, $ + 'ERROR - RAD_VEL keyword vector must contain ' + strtrim(N,2) +' values' + endelse + + if keyword_set( MU_RADEC) then begin + if (N_elements( mu_radec) NE 2*N ) then message, $ + 'ERROR - MU_RADEC keyword (proper motion) be dimensioned (2,' + $ + strtrim(N,2) + ')' + mu_radec = mu_radec*1. + endif + + if ~keyword_set( Parallax) then parallax = dblarr(N) else $ + parallax = parallax*1. + + if ~keyword_set(Epoch) then epoch = 2000.0d0 + + radeg = 180.D/!DPI + sec_to_radian = 1.d0/radeg/3600.d0 + + M = [ [+0.9999256795D, -0.0111814828D, -0.0048590040D, $ + -0.000551D, -0.238560D, +0.435730D ], $ + [ +0.0111814828D, +0.9999374849D, -0.0000271557D, $ + +0.238509D, -0.002667D, -0.008541D ], $ + [ +0.0048590039D, -0.0000271771D, +0.9999881946D , $ + -0.435614D, +0.012254D, +0.002117D ], $ + [ -0.00000242389840D, +0.00000002710544D, +0.00000001177742D, $ + +0.99990432D, -0.01118145D, -0.00485852D ], $ + [ -0.00000002710544D, -0.00000242392702D, +0.00000000006585D, $ + +0.01118145D, +0.99991613D, -0.00002716D ], $ + [ -0.00000001177742D, +0.00000000006585D,-0.00000242404995D, $ + +0.00485852D, -0.00002717D, +0.99996684D] ] + + A_dot = 1D-3*[1.244D, -1.579D, -0.660D ] ;in arc seconds per century + + ra_rad = ra/radeg & dec_rad = dec/radeg + cosra = cos( ra_rad ) & sinra = sin( ra_rad ) + cosdec = cos( dec_rad ) & sindec = sin( dec_rad ) + + dec_1950 = dec*0. + ra_1950 = ra*0. + + for i = 0L, N-1 do begin + +; Following statement moved inside loop in Feb 2000. + A = 1D-6*[ -1.62557D, -0.31919D, -0.13843D] ;in radians + + r0 = [ cosra[i]*cosdec[i], sinra[i]*cosdec[i], sindec[i] ] + + if keyword_set(mu_radec) then begin + + mu_a = mu_radec[ 0, i ] + mu_d = mu_radec[ 1, i ] + r0_dot = [ -mu_a*sinra[i]*cosdec[i] - mu_d*cosra[i]*sindec[i] , $ ;Velocity vector + mu_a*cosra[i]*cosdec[i] - mu_d*sinra[i]*sindec[i] , $ + mu_d*cosdec[i] ] + 21.095d * rad_vel[i] * parallax[i] * r0 + + endif else r0_dot = [0.0d0, 0.0d0, 0.0d0] + + R_0 = [ r0, r0_dot ] + R_1 = M # R_0 + + ; Include the effects of the E-terms of aberration to form r and r_dot. + + r1 = R_1[0:2] + r1_dot = R_1[3:5] + + if ~keyword_set(Mu_radec) then begin + r1 = r1 + sec_to_radian * r1_dot * (epoch - 1950.0d)/100. + A = A + sec_to_radian * A_dot * (epoch - 1950.0d)/100. + endif + + x1 = R_1[0] & y1 = R_1[1] & z1 = R_1[2] + rmag = sqrt( x1^2 + y1^2 + z1^2 ) + + + s1 = r1/rmag & s1_dot = r1_dot/rmag + + s = s1 + for j = 0,2 do begin + r = s1 + A - (total(s * A))*s + s = r/rmag + endfor + x = r[0] & y = r[1] & z = r[2] + r2 = x^2 + y^2 + z^2 + rmag = sqrt( r2 ) + + if keyword_set(Mu_radec) then begin + r_dot = s1_dot + A_dot - ( total( s * A_dot))*s + x_dot = r_dot[0] & y_dot= r_dot[1] & z_dot = r_dot[2] + mu_radec[0,i] = ( x*y_dot - y*x_dot) / ( x^2 + y^2) + mu_radec[1,i] = ( z_dot* (x^2 + y^2) - z*(x*x_dot + y*y_dot) ) / $ + ( r2*sqrt( x^2 + y^2) ) + endif + + dec_1950[i] = asin( z / rmag) + ra_1950[i] = atan( y, x) + + if parallax[i] GT 0. then begin + rad_vel[i] = ( x*x_dot + y*y_dot + z*z_dot )/ (21.095*Parallax[i]*rmag) + parallax[i] = parallax[i] / rmag + endif + endfor + + neg = where( ra_1950 LT 0, NNeg ) + if Nneg GT 0 then ra_1950[neg] = ra_1950[neg] + 2.D*!DPI + + ra_1950 = ra_1950*radeg & dec_1950 = dec_1950*radeg + +; Make output scalar if input was scalar + + sz = size(ra) + if sz[0] EQ 0 then begin + ra_1950 = ra_1950[0] & dec_1950 = dec_1950[0] + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/break_path.pro b/modules/idl_downloads/astro/pro/break_path.pro new file mode 100644 index 0000000..703c381 --- /dev/null +++ b/modules/idl_downloads/astro/pro/break_path.pro @@ -0,0 +1,140 @@ + FUNCTION BREAK_PATH, PATHS, NOCURRENT=NOCURRENT +;+ +; NAME: +; BREAK_PATH() +; +; PURPOSE: +; Breaks up a path string into its component directories. +; +; CALLING SEQUENCE: +; Result = BREAK_PATH( PATHS [ /NoCurrent]) +; +; INPUTS: +; PATHS = A string containing one or more directory paths. The +; individual paths are separated by commas, although in UNIX, +; colons can also be used. In other words, PATHS has the same +; format as !PATH, except that commas can be used as a separator +; regardless of operating system. +; +; A leading $ can be used in any path to signal that what follows +; is an environmental variable, but the $ is not necessary. +; Environmental variables can themselves contain multiple paths. +; +; OUTPUT: +; The result of the function is a string array of directories. +; Unless the NOCURRENT keyword is set, the first element of the array is +; always the null string, representing the current directory. All the +; other directories will end in the correct separator character for the +; current operating system. +; +; OPTIONAL INPUT KEYWORD: +; /NOCURRENT = If set, then the current directory (represented by +; the null string) will not automatically be prepended to the +; output. +; +; PROCEDURE CALLS: +; None. +; +; REVISION HISTORY: +; Version 1, William Thompson, GSFC, 6 May 1993. +; Added IDL for Windows compatibility. +; Version 2, William Thompson, GSFC, 16 May 1995 +; Added keyword NOCURRENT +; Version 3, William Thompson, GSFC, 29 August 1995 +; Modified to use OS_FAMILY +; Version 4, Zarro, GSFC, 4 August 1997 +; Added trim to input +; Fix directory character on Macintosh system A. Ferro February 2000 +; Use STRSPLIT instead of STR_SEP() W. Landsman July 2002 +; Remove VMS support W. Landsman September 2006 +;- +; + ON_ERROR, 2 +; +; Check the number of parameters: +; + IF SIZE(PATHS,/TNAME) NE 'STRING' THEN MESSAGE, $ + 'Syntax: Result = BREAK_PATH( PATHS )' +; +; Reformat PATHS into an array. The first element is the null string. In +; Unix, both the comma and colon character can be separators, so two passes +; are needed to extract everything. The same is true for Microsoft Windows +; and semi-colons. +; + sep = path_sep(/SEARCH_PATH) + PATH = ['',STRSPLIT(PATHS,SEP + ',',/EXTRACT)] +; +; For each path, see if it is really an environment variable. If so, then +; decompose the environmental variable into its constituent paths. +; + I = 0 + WHILE I LT N_ELEMENTS(PATH) DO BEGIN +; +; First, try the path by itself. Remove any trailing "/", "\", or ":" +; characters. + + CHAR = STRMID(PATH[I],STRLEN(PATH[I])-1,1) + IF (CHAR EQ '/') OR (CHAR EQ '\') OR (CHAR EQ ':') THEN $ + PATH[I] = STRMID(PATH[I],0,STRLEN(PATH[I])-1) + TEMP = PATH[I] + TEST = GETENV(TEMP) +; +; If that doesn't yield anything, and the path begins with the $ prompt, then +; try what follows after the $. +; + IF TEST EQ '' THEN IF STRMID(PATH[I],0,1) EQ '$' THEN BEGIN + FOLLOWING = STRMID(TEMP,1,STRLEN(TEMP)-1) + TEST = GETENV(FOLLOWING) + ENDIF +; +; +; If something was found, then decompose this into whatever paths it may +; contain. +; + IF TEST NE '' THEN BEGIN + PTH = STRSPLIT(TEST,SEP+',',/EXTRACT) +; +; Insert this sublist into the main path list. +; + IF N_ELEMENTS(PATH) EQ 1 THEN BEGIN + PATH = PTH + END ELSE IF I EQ 0 THEN BEGIN + PATH = [PTH,PATH[1:*]] + END ELSE IF I EQ N_ELEMENTS(PATH)-1 THEN BEGIN + PATH = [PATH[0:I-1],PTH] + END ELSE BEGIN + PATH = [PATH[0:I-1],PTH,PATH[I+1:*]] + ENDELSE +; +; Otherwise, check whether or not the path ends in the correct character. +; In Unix, if the path does not end in "/" then append it. Do the same with +; the "\" character in Microsoft Windows. This step is only taken once the +; routine has completely decomposed this part of the path list. +; + END ELSE BEGIN + IF PATH[I] NE '' THEN BEGIN + LAST = STRMID(PATH[I], STRLEN(PATH[I])-1, 1) + CASE !VERSION.OS_FAMILY OF + 'Windows': IF LAST NE '\' THEN $ + PATH[I] = PATH[I] + '\' + 'MacOS': IF LAST NE ':' THEN $ + PATH[I] = PATH[I] + ':' + ELSE: IF LAST NE '/' THEN $ + PATH[I] = PATH[I] + '/' + ENDCASE + ENDIF +; +; Advance to the next path, and continue. +; + I = I + 1 + ENDELSE + ENDWHILE +; +; If the NOCURRENT keyword was set, then remove the first element which +; represents the current directory +; + IF KEYWORD_SET(NOCURRENT) AND (N_ELEMENTS(PATH) GT 1) THEN $ + PATH = PATH[1:*] +; + RETURN, PATH + END diff --git a/modules/idl_downloads/astro/pro/bsort.pro b/modules/idl_downloads/astro/pro/bsort.pro new file mode 100644 index 0000000..d9e05db --- /dev/null +++ b/modules/idl_downloads/astro/pro/bsort.pro @@ -0,0 +1,103 @@ +function Bsort, Array, Asort, INFO=info, REVERSE = rev +;+ +; NAME: +; BSORT +; PURPOSE: +; Function to sort data into ascending order, like a simple bubble sort. +; EXPLANATION: +; Original subscript order is maintained when values are equal (stable sort). +; (This differs from the IDL SORT routine alone, which may rearrange +; order for equal values) +; +; A faster algorithm (radix sort) for numeric data is described at +; http://www.exelisvis.com/Learn/Blogs/IDLDataPointDetail/TabId/902/ArtMID/2926/ArticleID/13017/An-LSD-radix-sort-algorithm-in-IDL.aspx +; and available at +; https://github.com/mgalloy/mglib/blob/master/src/analysis/mg_sort.pro +; CALLING SEQUENCE: +; result = bsort( array, [ asort, /INFO, /REVERSE ] ) +; +; INPUT: +; Array - array to be sorted +; +; OUTPUT: +; result - sort subscripts are returned as function value +; +; OPTIONAL OUTPUT: +; Asort - sorted array +; +; OPTIONAL KEYWORD INPUTS: +; /REVERSE - if this keyword is set, and non-zero, then data is sorted +; in descending order instead of ascending order. +; /INFO = optional keyword to cause brief message about # equal values. +; +; HISTORY +; written by F. Varosi Oct.90: +; uses WHERE to find equal clumps, instead of looping with IF ( EQ ). +; compatible with string arrays, test for degenerate array +; 20-MAY-1991 JKF/ACC via T AKE- return indexes if the array to +; be sorted has all equal values. +; Aug - 91 Added REVERSE keyword W. Landsman +; Always return type LONG W. Landsman August 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + N = N_elements( Array ) + if N lt 1 then begin + print,'Input to BSORT must be an array' + return, [0L] + endif + + if N lt 2 then begin + asort = array ;MDM added 24-Sep-91 + return,[0L] ;Only 1 element + end +; +; sort array (in descending order if REVERSE keyword specified ) +; + subs = sort( Array ) + if keyword_set( REV ) then subs = rotate(subs,5) + Asort = Array[subs] +; +; now sort subscripts into ascending order +; when more than one Asort has same value +; + weq = where( (shift( Asort, -1 ) eq Asort) , Neq ) + + if keyword_set( info ) then $ + message, strtrim( Neq, 2 ) + " equal values Located",/CON,/INF + + if (Neq EQ n) then return,lindgen(n) ;Array is degenerate equal values + + if (Neq GT 0) then begin + + if (Neq GT 1) then begin ;find clumps of equality + + wclump = where( (shift( weq, -1 ) - weq) GT 1, Nclump ) + Nclump++ + + endif else Nclump = 1 + + if (Nclump LE 1) then begin + Clump_Beg = 0 + Clump_End = Neq-1 + endif else begin + Clump_Beg = [0,wclump+1] + Clump_End = [wclump,Neq-1] + endelse + + weq_Beg = weq[ Clump_Beg ] ;subscript ranges + weq_End = weq[ Clump_End ] + 1 ; of Asort equalities. + + if keyword_set( info ) then message, strtrim( Nclump, 2 ) + $ + " clumps of equal values Located",/CON,/INF + + for ic = 0L, Nclump-1 do begin ;sort each clump. + + subic = subs[ weq_Beg[ic] : weq_End[ic] ] + subs[ weq_Beg[ic] ] = subic[ sort( subic ) ] + endfor + + if N_params() GE 2 then Asort = Array[subs] ;resort array. + endif + +return, subs +end diff --git a/modules/idl_downloads/astro/pro/calz_unred.pro b/modules/idl_downloads/astro/pro/calz_unred.pro new file mode 100644 index 0000000..de40789 --- /dev/null +++ b/modules/idl_downloads/astro/pro/calz_unred.pro @@ -0,0 +1,79 @@ +pro calz_unred, wave, flux, ebv, funred, R_V = R_V +;+ +; NAME: +; CALZ_UNRED +; PURPOSE: +; Deredden a galaxy spectrum using the Calzetti et al. (2000) recipe +; EXPLANATION: +; Calzetti et al. (2000, ApJ 533, 682) developed a recipe for dereddening +; the spectra of galaxies where massive stars dominate the radiation output, +; valid between 0.12 to 2.2 microns. (CALZ_UNRED extrapolates between +; 0.12 and 0.0912 microns.) +; +; CALLING SEQUENCE: +; CALZ_UNRED, wave, flux, ebv, [ funred, R_V = ] +; INPUT: +; WAVE - wavelength vector (Angstroms) +; FLUX - calibrated flux vector, same number of elements as WAVE +; If only 3 parameters are supplied, then this vector will +; updated on output to contain the dereddened flux. +; EBV - color excess E(B-V), scalar. If a negative EBV is supplied, +; then fluxes will be reddened rather than deredenned. +; Note that the supplied color excess should be that derived for +; the stellar continuum, EBV(stars), which is related to the +; reddening derived from the gas, EBV(gas), via the Balmer +; decrement by EBV(stars) = 0.44*EBV(gas) +; +; OUTPUT: +; FUNRED - unreddened flux vector, same units and number of elements +; as FLUX. FUNRED values will be zeroed outside valid domain +; Calz_unred (0.0912 - 2.2 microns). +; +; OPTIONAL INPUT KEYWORD: +; R_V - Ratio of total to selective extinction, default = 4.05. +; Calzetti et al. (2000) estimate R_V = 4.05 +/- 0.80 from optical +; -IR observations of 4 starbursts. +; EXAMPLE: +; Estimate how a flat galaxy spectrum (in wavelength) between 1200 A +; and 3200 A is altered by a reddening of E(B-V) = 0.1. +; +; IDL> w = 1200 + findgen(40)*50 ;Create a wavelength vector +; IDL> f = w*0 + 1 ;Create a "flat" flux vector +; IDL> calz_unred, w, f, -0.1, fnew ;Redden (negative E(B-V)) flux vector +; IDL> plot,w,fnew +; +; NOTES: +; Use the 4 parameter calling sequence if you wish to save the +; original flux vector. +; PROCEDURE CALLS: +; POLY() +; REVISION HISTORY: +; Written W. Landsman Raytheon ITSS December, 2000 +;- + On_error, 2 + + if N_params() LT 3 then begin + print,'Syntax: CALZ_UNRED, wave, flux, ebv, [ funred, R_V=]' + return + endif + + if N_elements(R_V) EQ 0 then R_V = 4.05 + w1 = where((wave GE 6300) AND (wave LE 22000), c1) + w2 = where((wave GE 912) AND (wave LT 6300), c2) + x = 10000.0/wave ;Wavelength in inverse microns + + IF (c1 + c2) NE N_elements(wave) THEN message,/INF, $ + 'Warning - some elements of wavelength vector outside valid domain' + + klam = 0.0*flux + + IF c1 GT 0 THEN $ + klam[w1] = 2.659*(-1.857 + 1.040*x[w1]) + R_V + + IF c2 GT 0 THEN $ + klam[w2] = 2.659*(poly(x[w2], [-2.156, 1.509d0, -0.198d0, 0.011d0])) + R_V + + funred = flux*10.0^(0.4*klam*ebv) + if N_params() EQ 3 then flux = funred + + end diff --git a/modules/idl_downloads/astro/pro/ccm_unred.pro b/modules/idl_downloads/astro/pro/ccm_unred.pro new file mode 100644 index 0000000..7aacc10 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ccm_unred.pro @@ -0,0 +1,147 @@ +pro ccm_UNRED, wave, flux, ebv, funred, R_V = r_v +;+ +; NAME: +; CCM_UNRED +; PURPOSE: +; Deredden a flux vector using the CCM 1989 parameterization +; EXPLANATION: +; The reddening curve is that of Cardelli, Clayton, and Mathis (1989 ApJ. +; 345, 245), including the update for the near-UV given by O'Donnell +; (1994, ApJ, 422, 158). Parameterization is valid from the IR to the +; far-UV (3.5 microns to 0.1 microns). +; +; Users might wish to consider using the alternate procedure FM_UNRED +; which uses the extinction curve of Fitzpatrick (1999). +; CALLING SEQUENCE: +; CCM_UNRED, wave, flux, ebv, funred, [ R_V = ] +; or +; CCM_UNRED, wave, flux, ebv, [ R_V = ] +; INPUT: +; WAVE - wavelength vector (Angstroms) +; FLUX - calibrated flux vector, same number of elements as WAVE +; If only 3 parameters are supplied, then this vector will +; updated on output to contain the dereddened flux. +; EBV - color excess E(B-V), scalar. If a negative EBV is supplied, +; then fluxes will be reddened rather than deredenned. +; +; OUTPUT: +; FUNRED - unreddened flux vector, same units and number of elements +; as FLUX +; +; OPTIONAL INPUT KEYWORD +; R_V - scalar specifying the ratio of total selective extinction +; R(V) = A(V) / E(B - V). If not specified, then R_V = 3.1 +; Extreme values of R(V) range from 2.75 to 5.3 +; +; EXAMPLE: +; Determine how a flat spectrum (in wavelength) between 1200 A and 3200 A +; is altered by a reddening of E(B-V) = 0.1. Assume an "average" +; reddening for the diffuse interstellar medium (R(V) = 3.1) +; +; IDL> w = 1200 + findgen(40)*50 ;Create a wavelength vector +; IDL> f = w*0 + 1 ;Create a "flat" flux vector +; IDL> ccm_unred, w, f, -0.1, fnew ;Redden (negative E(B-V)) flux vector +; IDL> plot,w,fnew +; +; NOTES: +; (1) The CCM curve shows good agreement with the Savage & Mathis (1979) +; ultraviolet curve shortward of 1400 A, but is probably +; preferable between 1200 and 1400 A. +; (2) Many sightlines with peculiar ultraviolet interstellar extinction +; can be represented with a CCM curve, if the proper value of +; R(V) is supplied. +; (3) Curve is extrapolated between 912 and 1000 A as suggested by +; Longo et al. (1989, ApJ, 339,474) +; (4) Use the 4 parameter calling sequence if you wish to save the +; original flux vector. +; (5) Valencic et al. (2004, ApJ, 616, 912) revise the ultraviolet CCM +; curve (3.3 -- 8.0 um-1). But since their revised curve does +; not connect smoothly with longer and shorter wavelengths, it is +; not included here. +; +; REVISION HISTORY: +; Written W. Landsman Hughes/STX January, 1992 +; Extrapolate curve for wavelengths between 900 and 1000 A Dec. 1993 +; Use updated coefficients for near-UV from O'Donnell Feb 1994 +; Allow 3 parameter calling sequence April 1998 +; Converted to IDLV5.0 April 1998 +;- + + On_error, 2 + + if N_params() LT 3 then begin + print,'Syntax: CCM_UNRED, wave, flux, ebv, funred,[ R_V = ]' + return + endif + + if not keyword_set(R_V) then R_V = 3.1 + + x = 10000./ wave ; Convert to inverse microns + npts = N_elements( x ) + a = fltarr(npts) + b = fltarr(npts) +;****************************** + + good = where( (x GT 0.3) and (x LT 1.1), Ngood ) ;Infrared + if Ngood GT 0 then begin + a[good] = 0.574 * x[good]^(1.61) + b[good] = -0.527 * x[good]^(1.61) + endif + +;****************************** + + good = where( (x GE 1.1) and (x LT 3.3) ,Ngood) ;Optical/NIR + if Ngood GT 0 then begin ;Use new constants from O'Donnell (1994) + y = x[good] - 1.82 +; c1 = [ 1. , 0.17699, -0.50447, -0.02427, 0.72085, $ ;Original +; 0.01979, -0.77530, 0.32999 ] ;coefficients +; c2 = [ 0., 1.41338, 2.28305, 1.07233, -5.38434, $ ;from CCM89 +; -0.62251, 5.30260, -2.09002 ] + c1 = [ 1. , 0.104, -0.609, 0.701, 1.137, $ ;New coefficients + -1.718, -0.827, 1.647, -0.505 ] ;from O'Donnell + c2 = [ 0., 1.952, 2.908, -3.989, -7.985, $ ;(1994) + 11.102, 5.491, -10.805, 3.347 ] + + a[good] = poly( y, c1) + b[good] = poly( y, c2) + endif +;****************************** + + good = where( (x GE 3.3) and (x LT 8) ,Ngood) ;Mid-UV + if Ngood GT 0 then begin + + y = x[good] + F_a = fltarr(Ngood) & F_b = fltarr(Ngood) + good1 = where( (y GT 5.9), Ngood1 ) + if Ngood1 GT 0 then begin + y1 = y[good1] - 5.9 + F_a[ good1] = -0.04473 * y1^2 - 0.009779 * y1^3 + F_b[ good1] = 0.2130 * y1^2 + 0.1207 * y1^3 + endif + + a[good] = 1.752 - 0.316*y - (0.104 / ( (y-4.67)^2 + 0.341 )) + F_a + b[good] = -3.090 + 1.825*y + (1.206 / ( (y-4.62)^2 + 0.263 )) + F_b + endif + +; ******************************* + + good = where( (x GE 8) and (x LE 11), Ngood ) ;Far-UV + if Ngood GT 0 then begin + y = x[good] - 8. + c1 = [ -1.073, -0.628, 0.137, -0.070 ] + c2 = [ 13.670, 4.257, -0.420, 0.374 ] + a[good] = poly(y, c1) + b[good] = poly(y, c2) + endif + +; ******************************* + +; Now apply extinction correction to input flux vector + + A_V = R_V * EBV + A_lambda = A_V * (a + b/R_V) + if N_params() EQ 3 then flux = flux * 10.^(0.4*A_lambda) else $ + funred = flux * 10.^(0.4*A_lambda) ;Derive unreddened flux + + return + end diff --git a/modules/idl_downloads/astro/pro/check_fits.pro b/modules/idl_downloads/astro/pro/check_fits.pro new file mode 100644 index 0000000..4e4d768 --- /dev/null +++ b/modules/idl_downloads/astro/pro/check_fits.pro @@ -0,0 +1,227 @@ +pro check_FITS, im, hdr, dimen, idltype, UPDATE = update, NOTYPE = notype, $ + SDAS = sdas, FITS = fits, SILENT = silent, ERRMSG = errmsg +;+ +; NAME: +; CHECK_FITS +; PURPOSE: +; Check that keywords in a FITS header array match the associated data +; EXPLANATION: +; Given a FITS array IM, and a associated FITS header HDR, this +; procedure will check that +; (1) HDR is a string array, and IM is defined and numeric +; (2) The NAXISi values in HDR are appropriate to the dimensions +; of IM +; (3) The BITPIX value in HDR is appropriate to the datatype of IM +; If the /UPDATE keyword is present, then the FITS header will be +; modified, if necessary, to force agreement with the image array +; +; CALLING SEQUENCE: +; check_FITS, im, hdr, [ dimen, idltype, /UPDATE, /NOTYPE, /SILENT +; ERRMSG = ]' +; +; INPUT PARAMETERS: +; IM - FITS array, e.g. as read by READFITS +; HDR - FITS header (string array) associated with IM +; +; OPTIONAL OUTPUTS: +; dimen - vector containing actual array dimensions +; idltype- data type of the FITS array as specified in the IDL SIZE +; function (1 for BYTE, 2 for 16 bit integer, 3 for 32 bit integer, etc.) +; +; OPTIONAL KEYWORD INPUTS: +; /NOTYPE - If this keyword is set, then only agreement of the array +; dimensions with the FITS header are checked, and not the +; data type. +; /UPDATE - If this keyword is set then the BITPIX, NAXIS and NAXISi +; FITS keywords will be updated to agree with the array +; /FITS, /SDAS - these are obsolete keywords that now do nothing +; /SILENT - If keyword is set and nonzero, the informational messages +; will not be printed +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; +; PROCEDURE: +; Program checks the NAXIS and NAXISi keywords in the header to +; see if they match the image array dimensions, and checks whether +; the BITPIX keyword agrees with the array type. +; +; PROCEDURE CALLS: +; FXADDPAR, FXPAR(), SXDELPAR +; MODIFICATION HISTORY: +; Written, December 1991 W. Landsman Hughes/STX to replace CHKIMHD +; No error returned if NAXIS=0 and IM is a scalar W. Landsman Feb 93 +; Fixed bug for REAL*8 STSDAS data W. Landsman July 93 +; Make sure NAXIS agrees with NAXISi W. Landsman October 93 +; Converted to IDL V5.0 W. Landsman September 1997 +; Allow unsigned data types W. Landsman December 1999 +; Allow BZERO = 0 for unsigned data types W. Landsman January 2000 +; Added ERRMSG keyword, W. Landsman February 2000 +; Use FXADDPAR to put NAXISi in proper order W. Landsman August 2000 +; Improper FXADDPAR call for DATATYPE keyword W. Landsman December 2000 +; Remove explicit setting of obsolete !err W. Landsman February 2004 +; Remove SDAS support W. Landsman November 2006 +; Fix dimension errors introduced Nov 2006 +; Work again for null arrays W. Landsman/E. Hivon May 2007 +; Use V6.0 notation W.L. Feb. 2011 +;- + compile_opt idl2 + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - CHECK_FITS, im, hdr, dimen, idltype, ' + print,' [ /UPDATE, /NOTYPE, ERRMSG=, /SILENT ]' + return + endif + + if arg_present(errmsg) then errmsg = '' + + if size(hdr,/TNAME) NE 'STRING' then begin ;Is hdr of string type? + message= 'FITS header is not a string array' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message, 'ERROR - ' + message, /CON + return + endif + + im_info = size(im,/struc) + ndimen = im_info.n_dimensions + if ndimen GT 0 then dimen = im_info.dimensions[0:ndimen-1] + idltype = im_info.type + + + nax = fxpar( hdr, 'NAXIS', Count = N_naxis ) + if N_naxis EQ 0 then begin + message = 'FITS header missing NAXIS keyword' + if N_elements(errmsg) GT 0 then errmsg = message else $ + message,'ERROR - ' + message,/CON + return + endif + + if ndimen EQ 0 then $ ;Null primary array + if nax EQ 0 then return else begin + message = 'FITS array is not defined' + if N_elements(errmsg) GT 0 then errmsg = message else $ + message,'ERROR - ' +message,/con + return + endelse + + + naxis = fxpar( hdr, 'NAXIS*') + naxi = N_elements( naxis ) + if nax GT naxi then begin ;Does NAXIS agree with # of NAXISi? + if keyword_set( UPDATE) then begin + fxaddpar, hdr, 'NAXIS', naxi + if ~keyword_set(SILENT) then message, /INF, $ + 'NAXIS changed from ' + strtrim(nax,2) + ' to ' + strtrim(naxi,2) + endif else begin + message = 'FITS header has NAXIS = ' + strtrim(nax,2) + $ + ', but only ' + strtrim(naxi, 2) + ' axes defined' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message, 'ERROR - ' + message + return + endelse + endif + + last = naxi-1 ;Remove degenerate dimensions + while ( (naxis[last] EQ 1) && (last GE 1) ) do last-- + if last NE nax-1 then begin + naxis = naxis[ 0:last] + endif + + if ( ndimen NE last + 1 ) then begin + if ~keyword_set( UPDATE) THEN begin + message = $ + '# of NAXISi keywords does not match # of array dimensions' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message,'ERROR - ' + message,/CON + return + + endif else goto, DIMEN_ERROR + endif + + for i = 0,last do begin + if naxis[i] NE dimen[i] then begin + if ~keyword_set( UPDATE ) then begin + message = 'Invalid NAXIS' + strtrim( i+1,2 ) + $ + ' keyword value in header' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message,'ERROR - ' + message,/CON + return + endif else goto, DIMEN_ERROR + endif + endfor + +BITPIX: + + if ~keyword_set( NOTYPE ) then begin + + + bitpix = fxpar( hdr, 'BITPIX') + + case idltype of + + 1: if bitpix NE 8 then goto, BITPIX_ERROR + 2: if bitpix NE 16 then goto, BITPIX_ERROR + 4: if bitpix NE -32 then goto, BITPIX_ERROR + 3: if bitpix NE 32 then goto, BITPIX_ERROR + 5: if bitpix NE -64 then goto, BITPIX_ERROR + 12:if bitpix NE 16 then goto, BITPIX_ERROR + 13: if bitpix NE 32 then goto, BITPIX_ERROR + + else: begin + message = 'Data array is not a valid FITS datatype' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message,'ERROR - ' + message,/CON + return + end + + endcase + + endif + + return + +BITPIX_ERROR: + if keyword_set( UPDATE ) then begin + bpix = [0, 8, 16, 32, -32, -64, 32, 0, 0, 0, 0, 0, 16,32 ] + comm = ['',' Character or unsigned binary integer', $ + ' 16-bit twos complement binary integer', $ + ' 32-bit twos complement binary integer', $ + ' IEEE single precision floating point', $ + ' IEEE double precision floating point', $ + ' 32-bit twos complement binary integer','','','','','', $ + ' 16-bit unsigned binary integer', $ + ' 32-bit unsigned binary integer' ] + bitpix = bpix[idltype] + comment = comm[idltype] + if ~keyword_set(SILENT) then message, /INF, $ + 'BITPIX value of ' + strtrim(bitpix,2) + ' added to FITS header' + fxaddpar, hdr, 'BITPIX', bitpix, comment + return + + endif else begin + message = 'BITPIX value of ' + strtrim(bitpix,2) + $ + ' in FITS header does not match array' + if N_elements(ERRMSG) GT 0 then errmsg = message else $ + message,'ERROR - ' + message,/CON + return + endelse + +DIMEN_ERROR: + if keyword_set( UPDATE ) then begin + fxaddpar, hdr, 'NAXIS', ndimen, before = 'NAXIS1' + naxis = 'NAXIS' + strtrim(indgen(ndimen)+1,2) + for i = 1, ndimen do fxaddpar, hdr, naxis[i-1], dimen[i-1], $ + 'Number of positions along axis ' + strtrim(i,2), $ + after = 'NAXIS' + strtrim(i-1,2) + if naxi GT ndimen then begin + for i = ndimen+1, naxi do sxdelpar, hdr, 'NAXIS'+strtrim(i,2) + endif + if ~keyword_set(SILENT) then message, /INF, $ + 'NAXIS keywords in FITS header have been updated' + goto, BITPIX + endif + + end diff --git a/modules/idl_downloads/astro/pro/checksum32.pro b/modules/idl_downloads/astro/pro/checksum32.pro new file mode 100644 index 0000000..08d4654 --- /dev/null +++ b/modules/idl_downloads/astro/pro/checksum32.pro @@ -0,0 +1,122 @@ +pro checksum32, array, checksum, FROM_IEEE = from_IEEE, NOSAVE = nosave +;+ +; NAME: +; CHECKSUM32 +; +; PURPOSE: +; To compute the 32bit checksum of an array (ones-complement arithmetic) +; +; EXPLANATION: +; The 32bit checksum is adopted in the FITS Checksum convention +; http://fits.gsfc.nasa.gov/registry/checksum.html +; +; CALLING SEQUENCE: +; CHECKSUM32, array, checksum, [/FROM_IEEE, /NoSAVE] +; +; INPUTS: +; array - any numeric idl array. If the number of bytes in the array is +; not a multiple of four then it is padded with zeros internally +; (the array is returned unchanged). Convert a string array +; (e.g. a FITS header) to bytes prior to calling CHECKSUM32. +; +; OUTPUTS: +; checksum - unsigned long scalar, giving sum of array elements using +; ones-complement arithmetic +; OPTIONAL INPUT KEYWORD: +; +; /FROM_IEEE - If this keyword is set, then the input is assumed to be in +; big endian format (e.g. an untranslated FITS array). This keyword +; only has an effect on little endian machines (e.g. Linux boxes). +; +; /NoSAVE - if set, then the input array is not saved upon exiting. Use +; the /NoSave keyword to save time if the input array is not needed +; in further computations. +; METHOD: +; Uses TOTAL() to sum the array into an unsigned integer variable. The +; overflow bits beyond 2^32 are then shifted back to the least significant +; bits. The summing is done in chunks of 2^31 numbers to avoid loss +; of precision. Adapted from FORTRAN code in +; heasarc.gsfc.nasa.gov/docs/heasarc/ofwg/docs/general/checksum/node30.html +; +; RESTRICTIONS: +; (1) Not valid for object or pointer data types +; EXAMPLE: +; Find the 32 bit checksum of the array x = findgen(35) +; +; IDL> checksum32, x, s ===> s = 2920022024 +; FUNCTION CALLED: +; HOST_TO_IEEE, IS_IEEE_BIG(), N_BYTES() +; MODIFICATION HISTORY: +; Written W. Landsman June 2001 +; Work correctly on little endian machines, added /FROM_IEEE and /NoSave +; W. Landsman November 2002 +; Pad with zeros when array size not a multiple of 4 W.Landsman Aug 2003 +; Always copy to new array, somewhat slower but more robust algorithm +; especially for Linux boxes W. Landsman Sep. 2004 +; Sep. 2004 update not implemented correctly (sigh) W. Landsman Dec 2004 +; No need to byteswap 4 byte datatypes on little endian W. L. May 2009 +; Use /INTEGER keyword to TOTAL() function W.L. June 2009 +; +;- + if N_params() LT 2 then begin + print,'Syntax - CHECKSUM32, array, checksum, /FROM_IEEE, /NoSAVE' + return + endif + idltype = size(array,/type) + +; Convert data to byte. If array size is not a multiple of 4, then we pad with +; zeros + + N = N_bytes(array) + Nremain = N mod 4 + if Nremain GT 0 then begin + if keyword_set(nosave) then $ + uarray = [ byte(temporary(array),0,N), bytarr(4-Nremain)] $ + else uarray = [ byte(array,0,N), bytarr(4-Nremain)] + N = N + 4 - Nremain + endif else begin + if keyword_set(nosave) then $ + uarray = byte( temporary(array) ,0,N) else $ + uarray = byte( array ,0,N) + endelse + +; Get maximum number of base 2 digits available in an unsigned long array, +; without losing any precision. Since we will sum unsigned longwords, the +; original array must be byteswapped as longwords. + + maxnum = long64(2)^31 + Niter = (N-1)/maxnum + checksum = long64(0) + word32 = long64(2)^32 + bswap = ~is_ieee_big() + if bswap then begin + if ~keyword_set( from_ieee) then begin + if (idltype NE 3) && (idltype NE 4) then begin + if idltype NE 1 then host_to_ieee, uarray,idltype=idltype + byteorder,uarray,/NTOHL + endif + endif else byteorder,uarray,/NTOHL + endif + + for i=0, Niter do begin + + if i EQ Niter then begin + nbyte = (N mod maxnum) + if nbyte EQ 0 then nbyte = maxnum + endif else nbyte = maxnum + + checksum += total(ulong( uarray,maxnum*i,nbyte/4), /integer) +; Fold any overflow bits beyond 32 back into the word. + + hibits = long(checksum/word32) + while hibits GT 0 do begin + checksum = checksum - (hibits*word32) + hibits + hibits = long(checksum/word32) + endwhile + + checksum = ulong(checksum) + + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/cic.pro b/modules/idl_downloads/astro/pro/cic.pro new file mode 100644 index 0000000..b1ff45b --- /dev/null +++ b/modules/idl_downloads/astro/pro/cic.pro @@ -0,0 +1,417 @@ +FUNCTION cic,value,posx,nx,posy,ny,posz,nz, $ + AVERAGE=average,WRAPAROUND=wraparound,ISOLATED=isolated, $ + NO_MESSAGE=no_message +;+ +; NAME: +; CIC +; +; PURPOSE: +; Interpolate an irregularly sampled field using Cloud in Cell method +; +; EXPLANATION: +; This function interpolates an irregularly sampled field to a +; regular grid using Cloud In Cell (nearest grid point gets +; weight 1-dngp, point on other side gets weight dngp, where +; dngp is the distance to the nearest grid point in units of the +; cell size). +; +; CATEGORY: +; Mathematical functions, Interpolation +; +; CALLING SEQUENCE: +; Result = CIC, VALUE, POSX, NX[, POSY, NY, POSZ, NZ, +; AVERAGE = average, WRAPAROUND = wraparound, +; ISOLATED = isolated, NO_MESSAGE = no_message] +; +; INPUTS: +; VALUE: Array of sample weights (field values). For e.g. a +; temperature field this would be the temperature and the +; keyword AVERAGE should be set. For e.g. a density field +; this could be either the particle mass (AVERAGE should +; not be set) or the density (AVERAGE should be set). +; POSX: Array of X coordinates of field samples, unit indices: [0,NX>. +; NX: Desired number of grid points in X-direction. +; +; OPTIONAL INPUTS: +; POSY: Array of Y coordinates of field samples, unit indices: [0,NY>. +; NY: Desired number of grid points in Y-direction. +; POSZ: Array of Z coordinates of field samples, unit indices: [0,NZ>. +; NZ: Desired number of grid points in Z-direction. +; +; KEYWORD PARAMETERS: +; AVERAGE: Set this keyword if the nodes contain field samples +; (e.g. a temperature field). The value at each grid +; point will then be the weighted average of all the +; samples allocated to it. If this keyword is not +; set, the value at each grid point will be the +; weighted sum of all the nodes allocated to it +; (e.g. for a density field from a distribution of +; particles). (D=0). +; WRAPAROUND: Set this keyword if you want the first grid point +; to contain samples of both sides of the volume +; (see below). +; ISOLATED: Set this keyword if the data is isolated, i.e. not +; periodic. In that case total `mass' is not conserved. +; This keyword cannot be used in combination with the +; keyword WRAPAROUND. +; NO_MESSAGE: Suppress informational messages. +; +; Example of default allocation of nearest grid points: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---| Range allocated to gridpoints ([0.0,1.0> --> 0, etc.) +; 0 1 2 3 4 posx +; +; Example of ngp allocation for WRAPAROUND: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---|-- Range allocated to gridpoints ([0.5,1.5> --> 1, etc.) +; 0 1 2 3 4=0 posx +; +; +; OUTPUTS: +; Prints that a CIC interpolation is being performed of x +; samples to y grid points, unless NO_MESSAGE is set. +; +; RESTRICTIONS: +; Field data is assumed to be periodic with the sampled volume +; the basic cell, unless ISOLATED is set. +; All input arrays must have the same dimensions. +; Position coordinates should be in `index units' of the +; desired grid: POSX=[0,NX>, etc. +; Keywords ISOLATED and WRAPAROUND cannot both be set. +; +; PROCEDURE: +; Nearest grid point is determined for each sample. +; CIC weights are computed for each sample. +; Samples are interpolated to the grid. +; Grid point values are computed (sum or average of samples). +; NOTES: +; Use tsc.pro for a higher-order interpolation scheme, ngp.pro for a lower +; order interpolation scheme. A standard reference for these +; interpolation methods is: R.W. Hockney and J.W. Eastwood, Computer +; Simulations Using Particles (New York: McGraw-Hill, 1981). +; EXAMPLE: +; nx=20 +; ny=10 +; posx=randomu(s,1000) +; posy=randomu(s,1000) +; value=posx^2+posy^2 +; field=cic(value,posx*nx,nx,posy*ny,ny,/average) +; surface,field,/lego +; +; MODIFICATION HISTORY: +; Written by Joop Schaye, Feb 1999. +; Avoid integer overflow for large dimensions P.Riley/W.Landsman Dec. 1999 +;- + +nrsamples=n_elements(value) +nparams=n_params() +dim=(nparams-1)/2 + +IF dim LE 2 THEN BEGIN + nz=1 + IF dim EQ 1 THEN ny=1 +ENDIF +nxny=long(nx)*long(ny) + + +;--------------------- +; Some error handling. +;--------------------- + +on_error,2 ; Return to caller if an error occurs. + +IF NOT (nparams EQ 3 OR nparams EQ 5 OR nparams EQ 7) THEN BEGIN + message,'Incorrect number of arguments!',/continue + message,'Syntax: CIC, VALUE, POSX, NX[, POSY, NY, POSZ, NZ,' + $ + ' AVERAGE = average, PERIODIC = periodic]' +ENDIF + +IF (nrsamples NE n_elements(posx)) OR $ + (dim GE 2 AND nrsamples NE n_elements(posy)) OR $ + (dim EQ 3 AND nrsamples NE n_elements(posz)) THEN $ + message,'Input arrays must have the same dimensions!' + +IF keyword_set(isolated) AND keyword_set(wraparound) THEN $ + message,'Keywords ISOLATED and WRAPAROUND cannot both be set!' + +IF NOT keyword_set(no_message) THEN $ + print,'Interpolating ' + strtrim(string(nrsamples,format='(i10)'),1) $ + + ' samples to ' + strtrim(string(nxny*nz,format='(i10)'),1) + $ + ' grid points using CIC...' + + +;----------------------- +; Calculate CIC weights. +;----------------------- + +; Compute weights per axis, in order to reduce memory (everything +; needs to be in memory if we compute all nearest grid points first). + +;************* +; X-direction. +;************* + +; Coordinates of nearest grid point (ngp). +IF keyword_set(wraparound) THEN ngx=fix(posx+0.5) $ +ELSE ngx=fix(posx)+0.5 + +; Distance from sample to ngp. +dngx=ngx-posx + +; Index of ngp. +IF keyword_set(wraparound) THEN kx1=temporary(ngx) $ +ELSE kx1=temporary(ngx)-0.5 +; Weight of ngp. +wx1=1.0-abs(dngx) + +; Other side. +left=where(dngx LT 0.0,nrleft) ; samples with ngp to the left. +; The following is only correct if x(ngp)>posx (ngp to the right). +kx2=kx1-1 +; Correct points where x(ngp)posy (ngp to the right). + ky2=ky1-1 + ; Correct points where y(ngp)posz (ngp to the right). + kz2=kz1-1 + ; Correct points where z(ngp) --> cube length different from EDFW paper). + +index=kx1+ky1*nx+kz1*nxny +cicweight=wx1*wy1*wz1 +IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR +ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] +index=kx2+ky1*nx+kz1*nxny +cicweight=wx2*wy1*wz1 +IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR +ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + +IF dim GE 2 THEN BEGIN + index=kx1+ky2*nx+kz1*nxny + cicweight=wx1*wy2*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + index=kx2+ky2*nx+kz1*nxny + cicweight=wx2*wy2*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + + IF dim EQ 3 THEN BEGIN + index=kx1+ky1*nx+kz2*nxny + cicweight=wx1*wy1*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + index=kx2+ky1*nx+kz2*nxny + cicweight=wx2*wy1*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + index=kx1+ky2*nx+kz2*nxny + cicweight=wx1*wy2*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + index=kx2+ky2*nx+kz2*nxny + cicweight=wx2*wy2*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + totcicweight[index[j]]=totcicweight[index[j]]+cicweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+cicweight[j]*value[j] + ENDIF + +ENDIF + +; Free memory (no need to free any more local arrays, will not lower +; maximum memory usage). +index=0 + + +;-------------------------- +; Compute weighted average. +;-------------------------- + +IF keyword_set(average) THEN BEGIN + good=where(totcicweight NE 0,nrgood) + field[good]=temporary(field[good])/temporary(totcicweight[good]) +ENDIF + +return,field + +END ; End of function cic. diff --git a/modules/idl_downloads/astro/pro/cirrange.pro b/modules/idl_downloads/astro/pro/cirrange.pro new file mode 100644 index 0000000..e204405 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cirrange.pro @@ -0,0 +1,49 @@ +PRO cirrange, ang, RADIANS=rad +;+ +; NAME: +; CIRRANGE +; PURPOSE: +; To force an angle into the range 0 <= ang < 360. +; CALLING SEQUENCE: +; CIRRANGE, ang, [/RADIANS] +; +; INPUTS/OUTPUT: +; ang - The angle to modify, in degrees. This parameter is +; changed by this procedure. Can be a scalar or vector. +; The type of ANG is always converted to double precision +; on output. +; +; OPTIONAL INPUT KEYWORDS: +; /RADIANS - If present and non-zero, the angle is specified in +; radians rather than degrees. It is forced into the range +; 0 <= ang < 2 PI. +; PROCEDURE: +; The angle is transformed between -360 and 360 using the MOD operator. +; Negative values (if any) are then transformed between 0 and 360 +; MODIFICATION HISTORY: +; Written by Michael R. Greason, Hughes STX, 10 February 1994. +; Get rid of WHILE loop, W. Landsman, Hughes STX, May 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + if N_params() LT 1 then begin + print, 'Syntax: CIRRANGE, ang, [ /RADIANS ]' + return + endif + +; Determine the additive constant. + + if keyword_set(RAD) then cnst = !dpi * 2.d $ + else cnst = 360.d + +; Deal with the lower limit. + + ang = ang mod cnst + +; Deal with negative values, if any + + neg = where(ang LT 0., Nneg) + if Nneg GT 0 then ang[neg] = ang[neg] + cnst + + return + end diff --git a/modules/idl_downloads/astro/pro/cleanplot.pro b/modules/idl_downloads/astro/pro/cleanplot.pro new file mode 100644 index 0000000..abcd1b1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cleanplot.pro @@ -0,0 +1,150 @@ +Pro CleanPlot, silent=silent, ShowOnly = showonly ;Reset System Variables +;+ +; NAME: +; CLEANPLOT +; PURPOSE: +; Reset all plotting system variables (!P,!X,!Y,!Z) to their default values +; EXPLANATION: +; Reset all system variables (!P,!X,!Y,!Z) which are set by the user +; and which affect plotting to their default values. +; +; CALLING SEQUENCE: +; Cleanplot, [ /Silent, /ShowOnly] +; +; INPUTS: +; None +; +; OPTIONAL KEYWORD INPUT: +; /SHOWONLY - If set, then CLEANPLOT will display the plotting system +; variables with nondefault values, but it will not reset them. +; +; /SILENT - If set, then CLEANPLOT will not display a message giving the +; the system variables tags being reset. One cannot set +; both /SILENT and /SHOWONLY +; OUTPUTS: +; None +; +; SIDE EFFECTS: +; The system variables that concern plotting are reset to their default +; values. A message is output for each variable changed. +; The !P.CLIP and CRANGE, S, WINDOW, and REGION fields of the +; !X, !Y, and !Z system variables are not checked since these are +; set by the graphics device and not by the user. +; +; PROCEDURE: +; This does NOT reset the plotting device. +; This does not change any system variables that don't control plotting. +; +; RESTRICTIONS: +; If user default values for !P, !X, !Y and !Z are different from +; the defaults adopted below, user should change P_old etc accordingly +; +; MODIFICATION HISTORY: +; Written IDL Version 2.3.0 W. Landsman & K. Venkatakrishna May '92 +; Handle new system variables in V3.0.0 W. Landsman Dec 92 +; Assume user has at least V3.0.0 W. Landsman August 95 +; V5.0 has 60 instead of 30 TICKV values W. Landsman Sep. 97 +; Change !D.N_COLORS to !D.TABLE_SIZE for 24 bit displays +; W. Landsman April 1998 +; Added silent keyword to supress output & modified X_old to +; handle the new !X and !Y tags in IDL 5.4 S. Penton July 2000 +; Test for visual depth if > V5.1 W. Landsman July 2000 +; Macs can report a visual depth of 32 W. Landsman March 2001 +; Call device,get_visual_depth only for device which allow it +; W. Landsman June 2001 +; Default !P.color is 16777215 for 16 bit systems +; W. Landsman/M. Hadfield November 2001 +; Added ShowOnly keyword W. Landsman April 2002 +; Use V6.0 notation W. Landsman April 2011 +; +;- + compile_opt idl2 + + On_error,2 + silent = keyword_set(silent) + if keyword_set(showonly) then begin + print,'Current Plotting System Variables with non-default Values' + clearing = '' + oldvalue = ' ' + reset = 0 + endif else begin + clearing = 'Clearing ' + oldvalue = ', old value ' + reset = 1 + end +; For !X, !Y, and !Z we will assume that the default values except for MARGIN are +; either 0 or '', while for !P we explicitly write all default values in P_old + + P_old = { BACKGROUND: 0L,CHARSIZE:0.0, CHARTHICK:0.0, $ + CLIP:[0L,0,639,511,0,0], $ ;Not used + COLOR : !D.TABLE_SIZE-1, FONT: -1L, LINESTYLE: 0L, MULTI:lonarr(5),$ + NOCLIP: 0L, NOERASE: 0L, NSUM: 0L, POSITION: fltarr(4),$ + PSYM: 0L, REGION: fltarr(4), SUBTITLE:'', SYMSIZE:0.0, T:fltarr(4,4),$ + T3D:0L, THICK: 0.0, TITLE:'', TICKLEN:0.02, CHANNEL:0L } + + X_old=!X +for i=0,n_tags(!X)-1 do $ + if size(!X.(i),/type) eq 7 then X_old.(i)= '' else X_old.(i) = 0 + + X_old.MARGIN = [10.0,3.0] + + Y_old = X_old + Y_old.MARGIN = [4.0, 2.0] + + Z_old = X_old + Z_old.MARGIN = [0.0, 0.0] + + P_var = tag_names(!P) + + if !D.NAME EQ 'PS' then begin + P_old.background = 255 + P_old.color = 0 + endif else if ( (!D.NAME EQ 'X') || (!D.NAME EQ 'MAC') || $ + (!D.NAME EQ 'WIN') ) then begin + device,get_visual_depth = depth + if depth GT 8 then P_old.color = 16777215 else $ + P_old.color = 256L^(depth/8) - 1 + endif + +; Reset !P to its default value except for !P.CLIP + + for i=0, N_elements(P_var)-1 do begin + if i NE 3 then begin + n = N_elements(!P.(i)) + if ~array_equal(!P.(i), P_old.(i)) then Begin + if ~silent then $ + Print,clearing + '!P.'+P_var[i]+ oldvalue +'=',!P.(i) + if reset then !P.(i) = P_old.(i) + EndIf + endif + endfor +; Reset !X !Y and !Z to their default values + X_var = tag_names(!X) + Y_var = tag_names(!Y) + Z_var = tag_names(!Z) + + for i = 0, n_tags(!X)-1 do begin + if total( i EQ [7,8,11,12] ) EQ 0 then begin ;Skip S,CRANGE,WINDOW,REGION + n = N_elements(!X.(i)) + if ~array_equal(!X.(i) , X_old.(i)) then Begin + if ~silent then $ + Print,clearing + '!X.'+X_var[i]+ oldvalue + '=', !X.(i) + if reset then !X.(i) = X_old.(i) + EndIf + + if ~array_equal(!Y.(i), Y_old.(i)) then Begin + if ~silent then $ + Print,clearing + '!Y.'+Y_var[i]+ oldvalue + '=', !Y.(i) + if reset then !Y.(i) = Y_old.(i) + EndIf + + if ~array_equal(!Z.(i), Z_old.(i)) then Begin + if ~silent then $ + Print,clearing +'!Z.'+Z_var[i]+ oldvalue + '=',!Z.(i) + if reset then !Z.(i) = Z_old.(i) + EndIf + endif +endfor + +Return ;Completed +End diff --git a/modules/idl_downloads/astro/pro/cntrd.pro b/modules/idl_downloads/astro/pro/cntrd.pro new file mode 100644 index 0000000..04ceb81 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cntrd.pro @@ -0,0 +1,245 @@ +pro cntrd, img, x, y, xcen, ycen, fwhm, SILENT= silent, DEBUG=debug, $ + EXTENDBOX = extendbox, KeepCenter = KeepCenter +;+ +; NAME: +; CNTRD +; PURPOSE: +; Compute the centroid of a star using a derivative search +; EXPLANATION: +; CNTRD uses an early DAOPHOT "FIND" centroid algorithm by locating the +; position where the X and Y derivatives go to zero. This is usually a +; more "robust" determination than a "center of mass" or fitting a 2d +; Gaussian if the wings in one direction are affected by the presence +; of a neighboring star. +; +; CALLING SEQUENCE: +; CNTRD, img, x, y, xcen, ycen, [ fwhm , /KEEPCENTER, /SILENT, /DEBUG +; EXTENDBOX = ] +; +; INPUTS: +; IMG - Two dimensional image array +; X,Y - Scalar or vector integers giving approximate integer stellar +; center +; +; OPTIONAL INPUT: +; FWHM - floating scalar; Centroid is computed using a box of half +; width equal to 1.5 sigma = 0.637* FWHM. CNTRD will prompt +; for FWHM if not supplied +; +; OUTPUTS: +; XCEN - the computed X centroid position, same number of points as X +; YCEN - computed Y centroid position, same number of points as Y, +; floating point +; +; Values for XCEN and YCEN will not be computed if the computed +; centroid falls outside of the box, or if the computed derivatives +; are non-decreasing. If the centroid cannot be computed, then a +; message is displayed and XCEN and YCEN are set to -1. +; +; OPTIONAL OUTPUT KEYWORDS: +; /SILENT - Normally CNTRD prints an error message if it is unable +; to compute the centroid. Set /SILENT to suppress this. +; /DEBUG - If this keyword is set, then CNTRD will display the subarray +; it is using to compute the centroid. +; EXTENDBOX = {non-negative positive integer}. CNTRD searches a box with +; a half width equal to 1.5 sigma = 0.637* FWHM to find the +; maximum pixel. To search a larger area, set EXTENDBOX to +; the number of pixels to enlarge the half-width of the box. +; Default is 0; prior to June 2004, the default was EXTENDBOX= 3 +; /KeepCenter = By default, CNTRD finds the maximum pixel in a box +; centered on the input X,Y coordinates, and then extracts a new +; box about this maximum pixel. Set the /KeepCenter keyword +; to skip then step of finding the maximum pixel, and instead use +; a box centered on the input X,Y coordinates. +; PROCEDURE: +; Maximum pixel within distance from input pixel X, Y determined +; from FHWM is found and used as the center of a square, within +; which the centroid is computed as the value (XCEN,YCEN) at which +; the derivatives of the partial sums of the input image over (y,x) +; with respect to (x,y) = 0. In order to minimize contamination from +; neighboring stars stars, a weighting factor W is defined as unity in +; center, 0.5 at end, and linear in between +; +; RESTRICTIONS: +; (1) Does not recognize (bad) pixels. Use the procedure GCNTRD.PRO +; in this situation. +; (2) DAOPHOT now uses a newer algorithm (implemented in GCNTRD.PRO) in +; which centroids are determined by fitting 1-d Gaussians to the +; marginal distributions in the X and Y directions. +; (3) The default behavior of CNTRD changed in June 2004 (from EXTENDBOX=3 +; to EXTENDBOX = 0). +; (4) Stone (1989, AJ, 97, 1227) concludes that the derivative search +; algorithm in CNTRD is not as effective (though faster) as a +; Gaussian fit (used in GCNTRD.PRO). +; MODIFICATION HISTORY: +; Written 2/25/86, by J. K. Hill, S.A.S.C., following +; algorithm used by P. Stetson in DAOPHOT. +; Allowed input vectors G. Hennessy April, 1992 +; Fixed to prevent wrong answer if floating pt. X & Y supplied +; W. Landsman March, 1993 +; Convert byte, integer subimages to float W. Landsman May 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +; Better checking of edge of frame David Hogg October 2000 +; Avoid integer wraparound for unsigned arrays W.Landsman January 2001 +; Handle case where more than 1 pixel has maximum value W.L. July 2002 +; Added /KEEPCENTER, EXTENDBOX (with default = 0) keywords WL June 2004 +; Some errrors were returning X,Y = NaN rather than -1,-1 WL Aug 2010 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 5 then begin + print,'Syntax: CNTRD, img, x, y, xcen, ycen, [ fwhm, ' + print,' EXTENDBOX= , /KEEPCENTER, /SILENT, /DEBUG ]' + PRINT,'img - Input image array' + PRINT,'x,y - Input scalars giving approximate X,Y position' + PRINT,'xcen,ycen - Output scalars giving centroided X,Y position' + return + endif else if N_elements(fwhm) NE 1 then $ + read,'Enter approximate FWHM of image in pixels: ',fwhm + + sz_image = size(img) + if sz_image[0] NE 2 then message, $ + 'ERROR - Image array (first parameter) must be 2 dimensional' + + xsize = sz_image[1] + ysize = sz_image[2] + dtype = sz_image[3] ;Datatype + +; Compute size of box needed to compute centroid + + if ~keyword_set(extendbox) then extendbox = 0 + nhalf = fix(0.637*fwhm) > 2 ; + nbox = 2*nhalf+1 ;Width of box to be used to compute centroid + nhalfbig = nhalf + extendbox + nbig = nbox + extendbox*2 ;Extend box 3 pixels on each side to search for max pixel value + npts = N_elements(x) + xcen = float(x) & ycen = float(y) + ix = round( x ) ;Central X pixel ;Added 3/93 + iy = round( y ) ;Central Y pixel + + for i = 0,npts-1 do begin ;Loop over X,Y vector + + pos = strtrim(x[i],2) + ' ' + strtrim(y[i],2) + + if ~keyword_set(keepcenter) then begin + if ( (ix[i] LT nhalfbig) || ((ix[i] + nhalfbig) GT xsize-1) || $ + (iy[i] LT nhalfbig) || ((iy[i] + nhalfbig) GT ysize-1) ) then begin + if not keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos + ' too near edge of image' + xcen[i] = -1 & ycen[i] = -1 + goto, DONE + endif + + bigbox = img[ix[i]-nhalfbig : ix[i]+nhalfbig, iy[i]-nhalfbig : iy[i]+nhalfbig] + +; Locate maximum pixel in 'NBIG' sized subimage + + mx = max( bigbox) ;Maximum pixel value in BIGBOX + mx_pos = where(bigbox EQ mx, Nmax) ;How many pixels have maximum value? + idx = mx_pos mod nbig ;X coordinate of Max pixel + idy = mx_pos / nbig ;Y coordinate of Max pixel + if NMax GT 1 then begin ;More than 1 pixel at maximum? + idx = round(total(idx)/Nmax) + idy = round(total(idy)/Nmax) + endif else begin + idx = idx[0] + idy = idy[0] + endelse + + xmax = ix[i] - (nhalf+extendbox) + idx ;X coordinate in original image array + ymax = iy[i] - (nhalf+extendbox) + idy ;Y coordinate in original image array + endif else begin + xmax = ix[i] + ymax = iy[i] + endelse + +; --------------------------------------------------------------------- +; check *new* center location for range +; added by Hogg + + if ( (xmax LT nhalf) || ((xmax + nhalf) GT xsize-1) || $ + (ymax LT nhalf) || ((ymax + nhalf) GT ysize-1) ) then begin + if not keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos + ' moved too near edge of image' + xcen[i] = -1 & ycen[i] = -1 + goto, DONE + endif +; --------------------------------------------------------------------- + +; Extract smaller 'STRBOX' sized subimage centered on maximum pixel + + strbox = img[xmax-nhalf : xmax+nhalf, ymax-nhalf : ymax+nhalf] + if (dtype NE 4) and (dtype NE 5) then strbox = float(strbox) + + if keyword_set(DEBUG) then begin + message,'Subarray used to compute centroid:',/inf + print,strbox + endif + + ir = (nhalf-1) > 1 + dd = indgen(nbox-1) + 0.5 - nhalf +; Weighting factor W unity in center, 0.5 at end, and linear in between + w = 1. - 0.5*(abs(dd)-0.5)/(nhalf-0.5) + sumc = total(w) + +; Find X centroid + + deriv = shift(strbox,-1,0) - strbox ;Shift in X & subtract to get derivative + deriv = deriv[0:nbox-2,nhalf-ir:nhalf+ir] ;Don't want edges of the array + deriv = total( deriv, 2 ) ;Sum X derivatives over Y direction + sumd = total( w*deriv ) + sumxd = total( w*dd*deriv ) + sumxsq = total( w*dd^2 ) + + if sumxd GE 0 then begin ;Reject if X derivative not decreasing + + if ~keyword_set(SILENT) then message,/INF, $ + 'Unable to compute X centroid around position '+ pos + xcen[i]=-1 & ycen[i]=-1 + goto,DONE + endif + + dx = sumxsq*sumd/(sumc*sumxd) + if ( abs(dx) GT nhalf ) then begin ;Reject if centroid outside box + if not keyword_set(SILENT) then message,/INF, $ + 'Computed X centroid for position '+ pos + ' out of range' + xcen[i]=-1 & ycen[i]=-1 + goto, DONE + endif + + xcen[i] = xmax - dx ;X centroid in original array + +; Find Y Centroid + + deriv = shift(strbox,0,-1) - strbox + deriv = deriv[nhalf-ir:nhalf+ir,0:nbox-2] + deriv = total( deriv,1 ) + sumd = total( w*deriv ) + sumxd = total( w*deriv*dd ) + sumxsq = total( w*dd^2 ) + if (sumxd GE 0) then begin ;Reject if Y derivative not decreasing + if not keyword_set(SILENT) then message,/INF, $ + 'Unable to compute Y centroid around position '+ pos + xcen[i] = -1 & ycen[i] = -1 + goto, DONE + endif + + dy = sumxsq*sumd/(sumc*sumxd) + if (abs(dy) GT nhalf) then begin ;Reject if computed Y centroid outside box + if ~keyword_set(SILENT) then message,/INF, $ + 'Computed X centroid for position '+ pos + ' out of range' + xcen[i]=-1 & ycen[i]=-1 + goto, DONE + endif + + ycen[i] = ymax-dy + + DONE: + + endfor + + return + end + + diff --git a/modules/idl_downloads/astro/pro/co_aberration.pro b/modules/idl_downloads/astro/pro/co_aberration.pro new file mode 100644 index 0000000..e1ea5e3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/co_aberration.pro @@ -0,0 +1,92 @@ +PRO co_aberration, jd, ra, dec, d_ra, d_dec, eps=eps +;+ +; NAME: +; CO_ABERRATION +; PURPOSE: +; Calculate changes to Ra and Dec due to the effect of annual aberration +; EXPLANATION: +; as described in Meeus, Chap 23. +; CALLING SEQUENCE: +; co_aberration, jd, ra, dec, d_ra, d_dec, [EPS = ] +; INPUTS +; jd : Julian Date [scalar or vector] +; ra, dec : Arrays (or scalars) of the ra and dec's in degrees +; Note: if jd is a vector, then ra and dec must either be scalars, or +; vectors of the same length. +; +; OUTPUTS +; d_ra, d_dec: the corrections to ra and dec due to aberration in +; arcseconds. (These values can be added to the true RA +; and dec to get the apparent position). Note that d_ra +; is *not* multiplied by cos(dec), so that +; apparent_ra = ra + d_ra/3600. +; OPTIONAL INPUT KEYWORD: +; eps : set this to the true obliquity of the ecliptic (in radians), or +; it will be set for you if you don't know it (in that case, set it to +; an empty variable). +; EXAMPLE: +; Compute the change in RA and Dec of Theta Persei (RA = 2h46m,11.331s, Dec = +; 49d20',54.54") due to aberration on 2028 Nov 13.19 TD +; +; IDL> jdcnv,2028,11,13,.19*24,jd ;Get Julian date +; IDL> co_aberration,jd,ten(2,46,11.331)*15,ten(49,20,54.54),d_ra,d_dec +; +; ==> d_ra = 30.045" (=2.003s) d_dec = 6.697" +; NOTES: +; These formula are from Meeus, Chapters 23. Accuracy is much better than 1 +; arcsecond. +; +; The maximum deviation due to annual aberration is 20.49" and occurs when the +; Earth velocity is perpendicular to the direction of the star. +; +; REVISION HISTORY: +; Written, June 2002, Chris O'Dell, U. of Wisconsin +; Fix error with vector input W. Landsman June 2009 +; June 2009 update fixed case where JD was scalar but RA,Dec were vectors, but +; broke the case when both JD and RA,Dec were vectors Aug 2012 W. Landsman +; Further fix when JD is 1 element vector W. Landsman +;- + compile_opt idl2 + d2r = !dpi/180. + if N_elements(jd) EQ 1 then jd = jd[0] + T = (jd -2451545.0)/36525.0 ; julian centuries from J2000 of jd. + if n_elements(eps) eq 0 then begin ; must calculate obliquity of ecliptic + njd = n_elements(jd) + d_psi = dblarr(njd) + d_epsilon = d_psi + for i=0L,njd-1 do begin + nutate, jd[i], dp, de ; d_psi and d_epsilon in degrees + d_psi[i] = dp + d_epsilon[i] = de + endfor + eps0 = ten(23,26,21.448)*3600.d - 46.8150*T - 0.00059*T^2 + $ + 0.001813*T^3 + eps = (eps0 + d_epsilon)/3600.*d2r ; true obliquity of the ecliptic +; in radians +endif + + sunpos, jd, sunra, sundec, sunlon + +; Earth's orbital eccentricity + e = 0.016708634d - 0.000042037d*T - 0.0000001267d*T^2 +; longitude of perihelion, in degrees +pi = 102.93735 + 1.71946*T + 0.00046*T^2 +k = 20.49552 ;constant of aberration, in arcseconds + +;Useful Trig Functions +cd = cos(dec*d2r) & sd = sin(dec*d2r) +if N_elements(eps) EQ 1 then eps = eps[0] ;Special scalar case +ce = cos(eps) & te = tan(eps) +cp = cos(pi*d2r) & sp = sin(pi*d2r) +cs = cos(sunlon*d2r) & ss = sin(sunlon*d2r) +ca = cos(ra*d2r) & sa = sin(ra*d2r) + +term1 = (ca*cs*ce+sa*ss)/cd +term2 = (ca*cp*ce+sa*sp)/cd +term3 = (cs*ce*(te*cd-sa*sd)+ca*sd*ss) +term4 = (cp*ce*(te*cd-sa*sd)+ca*sd*sp) + +d_ra = -k * term1 + e*k * term2 +d_dec = -k * term3 + e*k * term4 + +END diff --git a/modules/idl_downloads/astro/pro/co_nutate.pro b/modules/idl_downloads/astro/pro/co_nutate.pro new file mode 100644 index 0000000..4371a7a --- /dev/null +++ b/modules/idl_downloads/astro/pro/co_nutate.pro @@ -0,0 +1,115 @@ +PRO co_nutate, jd, ra, dec, d_ra, d_dec, eps=eps, d_psi=d_psi, d_eps=d_eps +;+ +; NAME: +; CO_NUTATE +; PURPOSE: +; Calculate changes in RA and Dec due to nutation of the Earth's rotation +; EXPLANATION: +; Calculates necessary changes to ra and dec due to +; the nutation of the Earth's rotation axis, as described in Meeus, Chap 23. +; Uses formulae from Astronomical Almanac, 1984, and does the calculations +; in equatorial rectangular coordinates to avoid singularities at the +; celestial poles. +; +; CALLING SEQUENCE: +; CO_NUTATE, jd, ra, dec, d_ra, d_dec, [EPS=, D_PSI =, D_EPS = ] +; INPUTS +; JD: Julian Date [scalar or vector] +; RA, DEC : Arrays (or scalars) of the ra and dec's of interest +; +; Note: if jd is a vector, ra and dec MUST be vectors of the same length. +; +; OUTPUTS: +; d_ra, d_dec: the corrections to ra and dec due to nutation (must then +; be added to ra and dec to get corrected values). +; OPTIONAL OUTPUT KEYWORDS: +; EPS: set this to a named variable that will contain the obliquity of the +; ecliptic. +; D_PSI: set this to a named variable that will contain the nutation in the +; longitude of the ecliptic +; D_EPS: set this to a named variable that will contain the nutation in the +; obliquity of the ecliptic +; EXAMPLE: +; (1) Example 23a in Meeus: On 2028 Nov 13.19 TD the mean position of Theta +; Persei is 2h 46m 11.331s 49d 20' 54.54". Determine the shift in +; position due to the Earth's nutation. +; +; IDL> jd = JULDAY(11,13,2028,.19*24) ;Get Julian date +; IDL> CO_NUTATE, jd,ten(2,46,11.331)*15.,ten(49,20,54.54),d_ra,d_dec +; +; ====> d_ra = 15.843" d_dec = 6.217" +; PROCEDURES USED: +; NUTATE +; REVISION HISTORY: +; Written Chris O'Dell, 2002 +; Vector call to NUTATE W. Landsman June 2002 +; Fix when JD is 1 element vector, and RA,Dec are vectors WL May 2013 +;- + + if N_Params() LT 4 then begin + print,'Syntax - CO_NUTATE, jd, ra, dec, d_ra, d_dec, ' + print,' Output keywords: [EPS=, D_PSI =, D_EPS = ]' + return + endif + d2r = !dpi/180. + d2as = !dpi/(180.d*3600.d) + T = (jd -2451545.0)/36525.0 ; Julian centuries from J2000 of jd. + +; must calculate obliquity of ecliptic + nutate,jd,d_psi, d_eps + + eps0 = 23.4392911*3600.d - 46.8150*T - 0.00059*T^2 + 0.001813*T^3 + eps = (eps0 + d_eps)/3600.*d2r ; true obliquity of the ecliptic in radians + if N_elements(eps) EQ 1 then eps = eps[0] + if N_elements(d_psi) Eq 1 then d_psi = d_psi[0] + +;useful numbers + ce = cos(eps) + se = sin(eps) + +; convert ra-dec to equatorial rectangular coordinates + x = cos(ra*d2r) * cos(dec*d2r) + y = sin(ra*d2r) * cos(dec*d2r) + z = sin(dec*d2r) + +; apply corrections to each rectangular coordinate + x2 = x - (y*ce + z*se)*d_psi * d2as + y2 = y + (x*ce*d_psi - z*d_eps) * d2as + z2 = z + (x*se*d_psi + y*d_eps) * d2as + +; convert back to equatorial spherical coordinates + r = sqrt(x2^2 + y2^2 + z2^2) + xyproj = sqrt(x2^2 + y2^2) + + ra2 = x2 * 0.d + dec2= x2 * 0.d + + w1 = where( (xyproj eq 0) AND (z ne 0) ) + w2 = where(xyproj ne 0) + +; Calculate Ra and Dec in RADIANS (later convert to DEGREES) + if w1[0] ne -1 then begin + ; places where xyproj=0 (point at NCP or SCP) + dec2[w1] = asin(z2[w1]/r[w1]) + ra2[w1] = 0. + endif + if w2[0] ne -1 then begin + ; places other than NCP or SCP + ra2[w2] = atan(y2[w2],x2[w2]) + dec2[w2] = asin(z2[w2]/r[w2]) + endif + + ; convert to DEGREES + + ra2 = ra2 /d2r + dec2 = dec2 /d2r + + w = where(ra2 LT 0., Nw) + if Nw GT 0 then ra2[w] = ra2[w] + 360. + + +; Return changes in ra and dec in arcseconds + d_ra = (ra2 - ra) * 3600. + d_dec = (dec2 - dec) * 3600. + +END diff --git a/modules/idl_downloads/astro/pro/co_refract.pro b/modules/idl_downloads/astro/pro/co_refract.pro new file mode 100644 index 0000000..ec95de6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/co_refract.pro @@ -0,0 +1,186 @@ +;+ +; NAME: +; CO_REFRACT() +; +; PURPOSE: +; Calculate correction to altitude due to atmospheric refraction. +; +; DESCRIPTION: +; CO_REFRACT can calculate both apparent altitude from observed altitude and +; vice-versa. +; +; CALLING SEQUENCE: +; new_alt = CO_REFRACT(old_alt, [ ALTITUDE= , PRESSURE= , $ +; TEMPERATURE= , /TO_OBSERVED , EPSILON= ]) +; +; INPUT: +; old_alt - Observed (apparent) altitude, in DEGREES. (apparent if keyword +; /TO_OBSERVED set). May be scalar or vector. +; +; OUTPUT: +; Function returns apparent (observed) altitude, in DEGREES. (observed if +; keyword /TO_OBSERVED set). Will be of same type as input +; altitude(s). +; +; OPTIONAL KEYWORD INPUTS: +; ALTITUDE : The height of the observing location, in meters. This is +; only used to determine an approximate temperature and pressure, +; if these are not specified separately. [default=0, i.e. sea level] +; PRESSURE : The pressure at the observing location, in millibars. +; TEMPERATURE: The temperature at the observing location, in Kelvin. +; EPSILON: When keyword /TO_OBSERVED has been set, this is the accuracy +; to obtain via the iteration, in arcseconds [default = 0.25 +; arcseconds]. +; /TO_OBSERVED: Set this keyword to go from Apparent->Observed altitude, +; using the iterative technique. +; +; Note, if altitude is set, but temperature or pressure are not, the +; program will make an intelligent guess for the temperature and pressure. +; +; DESCRIPTION: +; +; Because the index of refraction of air is not precisely 1.0, the atmosphere +; bends all incoming light, making a star or other celestial object appear at +; a slightly different altitude (or elevation) than it really is. It is +; important to understand the following definitions: +; +; Observed Altitude: The altitude that a star is SEEN to BE, with a telescope. +; This is where it appears in the sky. This is always +; GREATER than the apparent altitude. +; +; Apparent Altitude: The altitude that a star would be at, if *there were no +; atmosphere* (sometimes called "true" altitude). This is +; usually calculated from an object's celestial coordinates. +; Apparent altitude is always LOWER than the observed +; altitude. +; +; Thus, for example, the Sun's apparent altitude when you see it right on the +; horizon is actually -34 arcminutes. +; +; This program uses couple simple formulae to estimate the effect for most +; optical and radio wavelengths. Typically, you know your observed altitude +; (from an observation), and want the apparent altitude. To go the other way, +; this program uses an iterative approach. +; +; EXAMPLE: +; The lower limb of the Sun is observed to have altitude of 0d 30'. +; Calculate the the true (=apparent) altitude of the Sun's lower limb using +; mean conditions of air pressure and temperature +; +; IDL> print, co_refract(0.5) ===> 0.025degrees (1.55') +; WAVELENGTH DEPENDENCE: +; This correction is 0 at zenith, about 1 arcminute at 45 degrees, and 34 +; arcminutes at the horizon FOR OPTICAL WAVELENGTHS. The correction is +; NON-NEGLIGIBLE at all wavelengths, but is not very easily calculable. +; These formulae assume a wavelength of 550 nm, and will be accurate to +; about 4 arcseconds for all visible wavelengths, for elevations of 10 +; degrees and higher. Amazingly, they are also ACCURATE FOR RADIO +; FREQUENCIES LESS THAN ~ 100 GHz. +; +; It is important to understand that these formulae really can't do better +; than about 30 arcseconds of accuracy very close to the horizon, as +; variable atmospheric effects become very important. +; +; REFERENCES: +; 1. Meeus, Astronomical Algorithms, Chapter 15. +; 2. Explanatory Supplement to the Astronomical Almanac, 1992. +; 3. Methods of Experimental Physics, Vol 12 Part B, Astrophysics, +; Radio Telescopes, Chapter 2.5, "Refraction Effects in the Neutral +; Atmosphere", by R.K. Crane. +; +; +; DEPENDENCIES: +; CO_REFRACT_FORWARD (contained in this file and automatically compiled). +; +; AUTHOR: +; Chris O'Dell +; Assistant Professor of Atmospheric Science +; Colorado State University +; Email: odell@atmos.colostate.edu +; +; REVISION HISTORY: +; version 1 (May 31, 2002) +; Update iteration formula, W. Landsman June 2002 +; Corrected slight bug associated with scalar vs. vector temperature and +; pressure inputs. 6/10/2002 +; Fixed problem with vector input when /TO_OBSERVED set W. Landsman Dec 2005 +; Allow arrays with more than 32767 elements W.Landsman/C.Dickinson Feb 2010 +;- +function co_refract_forward, a, P=P, T=T + +; INPUTS +; a = The observed (apparent) altitude, in DEGREES. +; May be scalar or vector. +; +; INPUT KEYWORDS +; P: Pressure [in millibars]. Default is 1010 millibars. [scalar or vector] +; T: Ground Temp [in Celsius]. Default is 0 Celsius. [scalar or vector] + +compile_opt idl2 +d2r = !dpi/180. +if n_elements(P) eq 0 then P = 1010. +if n_elements(T) eq 0 then T = 283. + +; you have observed the altitude a, and would like to know what the "apparent" +; altitude is (the one behind the atmosphere). +w = where(a LT 15.) +R = 0.0166667/tan((a + 7.31/(a+4.4))*d2r) + +;R = 1.02/tan((a + 10.3/(a+5.11))*d2r)/60. +; this formula goes the other direction! + +if w[0] ne -1 then R[w] = 3.569*(0.1594 + .0196*a[w] + $ + .00002*a[w]^2)/(1.+.505*a[w]+.0845*a[w]^2) +tpcor = P/1010. * 283/T +R = tpcor * R + +return, R + +END + +function co_refract, a, altitude=altitude, pressure=pressure, $ + temperature=temperature, To_observed=To_observed, epsilon=epsilon + +; This is the main window. Calls co_refract_forward either iteratively or a +; single time depending on the direction we are going for refraction. + +compile_opt idl2 +o = keyword_set(To_observed) +alpha = 0.0065 ; temp lapse rate [deg C per meter] + +if n_elements(altitude) eq 0 then altitude = 0. +if n_elements(temperature) eq 0 then begin + if altitude GT 11000 then temperature = 211.5 $ + else temperature = 283.0 - alpha*altitude +endif +; estimate Pressure based on altitude, using U.S. Standard Atmosphere formula. +if n_elements(pressure) eq 0 then $ + pressure = 1010.*(1-6.5/288000*altitude)^5.255 +if n_elements(epsilon) eq 0 then $ + epsilon = 0.25 ; accuracy of iteration for observed=1 case, in arcseconds + +if not o then begin + aout = a - co_refract_forward(a,P=pressure,T=temperature) +endif else begin + aout = a*0. + na = n_elements(a) +; if there are multiple elevations but only one temp and pressure entered, +; expand those to be arrays of the same size. + P = pressure + a*0. & T = temperature + a*0. + for i=0L,na-1 do begin + ;calculate initial refraction guess + dr = co_refract_forward(a[i],P=P[i],T=T[i]) + cur = a[i] + dr ; guess of observed location + + repeat begin + last = cur + dr = co_refract_forward(cur,P=P[i],T=T[i]) + cur= a[i] + dr + endrep until abs(last-cur)*3600. LT epsilon + aout[i] = cur + endfor +endelse + +if N_elements(aout) GT 1 then return, reform(aout) else return, aout + +END diff --git a/modules/idl_downloads/astro/pro/compare_struct.pro b/modules/idl_downloads/astro/pro/compare_struct.pro new file mode 100644 index 0000000..aa497e3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/compare_struct.pro @@ -0,0 +1,239 @@ +;+ +; NAME: +; COMPARE_STRUCT +; PURPOSE: +; Compare all matching tag names and return differences +; +; EXPLANATION: +; Compare all matching Tags names (except for "except_Tags") +; between two structure arrays (may have different struct.definitions), +; and return a structured List of fields found different. +; +; The Exelis contrib library has a faster but less powerful procedure +; struct_equal.pro, see +; http://www.exelisvis.com/Default.aspx?tabid=1540&id=1175 +; +; CALLING SEQUENCE: +; diff_List = compare_struct( struct_A, struct_B [ EXCEPT=, /BRIEF, +; /FULL, /NaN, /RECUR_A, /RECUR_B ) +; INPUTS: +; struct_A, struct_B : the two structure arrays to compare. +; Struct_Name : for internal recursion use only. +; OPTIONAL INPUT KEYWORDS: +; EXCEPT = string array of Tag names to ignore (NOT to compare). +; /BRIEF = number of differences found for each matching field +; of two structures is printed. +; /FULL = option to print even if zero differences found. +; /NaN = if set, then tag values are considered equal if they +; are both set to NaN +; /RECUR_A = option to search for Tag names +; in sub-structures of struct_A, +; and then call compare_struct recursively +; for those nested sub-structures. +; /RECUR_B = search for sub-structures of struct_B, +; and then call compare_struct recursively +; for those nested sub-structures. +; Note: +; compare_struct is automatically called recursively +; for those nested sub-structures in both struct_A and struct_B +; (otherwise cannot take difference) +; OUTPUT: +; Returns a structure array describing differences found. +; which can be examined using print,diff_List or help,/st,diff_List. +; The tags are +; TAG_NUM_A - the tag number in structure A +; TAG_NUM_B - the tag number in structure B +; FIELD - the tag name +; NDIFF - number of differences (always 1 for a scalar tag). +; PROCEDURE: +; Match Tag names and then use where function on tags. +; EXAMPLE: +; Find the tags in the !X system variable which are changed after a +; simple plot. +; IDL> x = !X ;Save original values +; IDL> plot, indgen(25) ;Make a simple plot +; IDL> help,/str,compare_struct(x,!X) ;See how structure has changed +; +; and one will see that the tags !X.crange and !X.S are changed +; by the plot. +; MODIFICATION HISTORY: +; written 1990 Frank Varosi STX @ NASA/GSFC (using copy_struct) +; modif Aug.90 by F.V. to check and compare same # of elements only. +; Added /NaN keyword W. Landsman March 2004 +; Don't test string for NaN values W. Landsman March 2008 +;- + +function compare_struct, struct_A, struct_B, EXCEPT=except_Tags, Struct_Name, $ + FULL=full, BRIEF=brief, NaN = NaN, $ + RECUR_A = recur_A, RECUR_B = recur_B + + compile_opt idl2 + common compare_struct, defined + if N_params() LT 2 then begin + print,'Syntax - diff_List = compare_struct(struct_A, struct_B ' + print,' [EXCEPT=, /BRIEF, /FULL, /NaN, /RECUR_A, /RECUR_B ]' + if N_elements(diff_List) GT 0 then return, diff_List else return, -1 + endif + + if N_elements( defined ) NE 1 then begin + + diff_List = { DIFF_LIST, Tag_Num_A:0, Tag_Num_B:0, $ + Field:"", Ndiff:0L } + defined = N_tags( diff_List ) + endif else diff_List = replicate( {DIFF_LIST}, 1 ) + + Ntag_A = N_tags( struct_A ) + if (Ntag_A LE 0) then begin + message," 1st argument must be a structure variable",/CONTIN + return,diff_List + endif + Ntag_B = N_tags( struct_B ) + if (Ntag_B LE 0) then begin + message," 2nd argument must be a structure variable",/CONTIN + return,diff_List + endif + + N_A = N_elements( struct_A ) + N_B = N_elements( struct_B ) + + if (N_A LT N_B) then begin + + message,"comparing "+strtrim(N_A,2)+" of first structure",/CON + message,"to first "+strtrim(N_A,2)+" of "+strtrim(N_B,2)+ $ + " in second structure",/CONTIN + + diff_List = compare_struct( struct_A, struct_B[0:N_A-1], $ + EXCEPT=except_Tags, $ + RECUR_A = recur_A, $ + RECUR_B = recur_B, $ + FULL=full, BRIEF=brief ) + return,diff_List + + endif else if (N_A GT N_B) then begin + + message,"comparing first "+strtrim(N_B,2)+" of "+ $ + strtrim(N_A,2)+" in first structure",/CON + message,"to "+strtrim(N_B,2)+" in second structure",/CONTIN + + diff_List = compare_struct( struct_A[0:N_B-1], struct_B, $ + EXCEPT=except_Tags, $ + RECUR_A = recur_A, $ + RECUR_B = recur_B, $ + FULL=full, BRIEF=brief ) + return,diff_List + endif + + Tags_A = tag_names( struct_A ) + Tags_B = tag_names( struct_B ) + wB = indgen( N_elements( Tags_B ) ) + Nextag = N_elements( except_Tags ) + + if (Nextag GT 0) then begin + + except_Tags = [strupcase( except_Tags )] + + for t=0,Nextag-1 do begin + + w = where( Tags_B NE except_Tags[t], Ntag_B ) + Tags_B = Tags_B[w] + wB = wB[w] + endfor + endif + + if N_elements( struct_name ) NE 1 then sname = "." $ + else sname = struct_name + "." + + for t = 0, Ntag_B-1 do begin + + wA = where( Tags_A EQ Tags_B[t] , nf ) + + if (nf GT 0) then begin + + tA = wA[0] + tB = wB[t] + + NtA = N_tags( struct_A.(tA) ) + NtB = N_tags( struct_B.(tB) ) + + if (NtA GT 0 ) AND (NtB GT 0) then begin + + if keyword_set( full ) OR keyword_set( brief ) then $ + print, sname + Tags_A[tA], " :" + + diffs = compare_struct( struct_A.(tA), struct_B.(tB), $ + sname + Tags_A[tA], $ + EXCEPT=except_Tags, $ + FULL=full, BRIEF=brief ) + diff_List = [ diff_List, diffs ] + + endif else if (NtA LE 0) AND (NtB LE 0) then begin + + if keyword_set(NaN) then begin + x1 = struct_b.(tB) + x2 = struct_a.(tA) + if (size(x1,/tname) NE 'STRING') and $ + (size(x2,/tname) NE 'STRING') then begin + g = where( finite(x1) or finite(x2), Ndiff ) + if Ndiff GT 0 then $ + w = where( x1[g] NE x2[g], Ndiff ) + endif + endif else $ + w = where( struct_B.(tB) NE struct_A.(tA) , Ndiff ) + + if (Ndiff GT 0) then begin + diff = replicate( {DIFF_LIST}, 1 ) + diff.Tag_Num_A = tA + diff.Tag_Num_B = tB + diff.Field = sname + Tags_A[tA] + diff.Ndiff = Ndiff + diff_List = [ diff_List, diff ] + endif + + if keyword_set( full ) OR $ + (keyword_set( brief ) AND (Ndiff GT 0)) then $ + print, Tags_A[tA], Ndiff, FORM="(15X,A15,I9)" + + endif else print, Tags_A[ta], " not compared" + + endif + endfor + + if keyword_set( recur_A ) then begin + + for tA = 0, Ntag_A-1 do begin + + if N_tags( struct_A.(tA) ) GT 0 then begin + + diffs = compare_struct( struct_A.(tA), struct_B, $ + sname + Tags_A[tA], $ + EXCEPT=except_Tags, $ + RECUR_A = recur_A, $ + RECUR_B = recur_B, $ + FULL=full, BRIEF=brief ) + diff_List = [ diff_List, diffs ] + endif + endfor + endif + + if keyword_set( recur_B ) then begin + + for tB = 0, Ntag_B-1 do begin + + if N_tags( struct_B.(tB) ) GT 0 then begin + + diffs = compare_struct( struct_A, struct_B.(tB), $ + sname + Tags_B[tB], $ + EXCEPT=except_Tags, $ + RECUR_A = recur_A, $ + RECUR_B = recur_B, $ + FULL=full, BRIEF=brief ) + diff_List = [ diff_List, diffs ] + endif + endfor + endif + + w = where( [diff_List.Ndiff] GT 0, np ) + if (np LE 0) then w = [0] + +return, diff_List[w] +end diff --git a/modules/idl_downloads/astro/pro/concat_dir.pro b/modules/idl_downloads/astro/pro/concat_dir.pro new file mode 100644 index 0000000..a89656a --- /dev/null +++ b/modules/idl_downloads/astro/pro/concat_dir.pro @@ -0,0 +1,110 @@ +;+ +; NAME: +; CONCAT_DIR() +; +; PURPOSE: +; To concatenate directory and file names for current OS. +; EXPLANATION: +; The given file name is appended to the given directory name with the +; format appropriate to the current operating system. +; +; CALLING SEQUENCE: +; result = concat_dir( directory, file) +; +; INPUTS: +; directory - the directory path (string) +; file - the basic file name and extension (string) +; can be an array of filenames. +; +; OUTPUTS: +; The function returns the concatenated string. If the file input +; is a string array then the output will be a string array also. +; +; EXAMPLES: +; IDL> pixfile = concat_dir('$DIR_GIS_MODEL','pixels.dat') +; +; IDL> file = ['f1.dat','f2.dat','f3.dat'] +; IDL> dir = '$DIR_NIS_CAL' +; IDL> + +; +; RESTRICTIONS: +; +; The version of CONCAT_DIR available at +; http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/system/concat_dir.pro +; includes (mostly) additional VMS-specific keywords. +; +; CATEGORY +; Utilities, Strings +; +; REVISION HISTORY: +; Prev Hist. : Yohkoh routine by M. Morrison +; Written : CDS version by C D Pike, RAL, 19/3/93 +; Version : Version 1 19/3/93 +; Documentation modified Nov-94 W. Landsman +; Add V4.0 support for Windows W. Landsman Aug 95 +; Converted to IDL V5.0 W. Landsman September 1997 +; Changed loops to long integer W. Landsman December 1998 +; Added Mac support, translate Windows environment variables, +; & treat case where dirname ends in '/' W. Landsman Feb. 2000 +; Assume since V5.5, remove VMS support W. Landsman Sep. 2006 +;- +; +function concat_dir, dirname, filnam +; +; Check number of parameters +; + if N_params() lt 2 then begin + print,'Syntax - out_string = concat_dir( directory, filename)' + print,' ' + return,'' + endif +; +; remove leading/trailing blanks +; + dir0 = strtrim(dirname, 2) + n_dir = N_Elements(dir0) +; +; Act according to operating system +; Under Windows, if the directory starts with a dollar sign, then check to see +; the if it's really an environment variable. If it is, then substitute the +; the environment variable for the directory name. +; + IF !VERSION.OS_FAMILY EQ 'Windows' THEN BEGIN + FOR i = 0l, n_dir-1 DO BEGIN + FIRST = STRMID(DIR0[I], 0, 1) + IF FIRST EQ '$' THEN BEGIN + SLASH = STRPOS(DIR0[I]+'/','/') < STRPOS(DIR0[I]+'\','\') + TEST = GETENV(STRMID(DIR0[I],1,SLASH-1)) + IF TEST NE '' THEN BEGIN + IF STRLEN(DIR0[I]) GT SLASH THEN TEST = TEST + $ + STRMID(DIR0[I],SLASH,STRLEN(DIR0[I])-SLASH) + DIR0[I] = TEST + ENDIF + ENDIF +; + last = STRMID(dir0[i], STRLEN(dir0[i])-1, 1) + IF (last NE '\') AND (last NE '/') AND (last NE ':') THEN BEGIN + dir0[i] = dir0[i] + '\' ;append an ending '\' + ENDIF + ENDFOR + +; Macintosh/UNIX section + + endif else begin + psep = path_sep() + for i = 0l, n_dir-1 do begin + last = strmid(dir0[i], strlen(dir0[i])-1, 1) + if(last ne psep) then dir0[i] = dir0[i] + psep ;append path separator + endfor +endelse + +; +; no '/' needed when using default directory +; + g = where(dirname EQ '', Ndef) + if Ndef GT 0 then dir0[g] = '' + + return, dir0 + filnam + + end diff --git a/modules/idl_downloads/astro/pro/cons_dec.pro b/modules/idl_downloads/astro/pro/cons_dec.pro new file mode 100644 index 0000000..414a9e1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cons_dec.pro @@ -0,0 +1,116 @@ +FUNCTION CONS_DEC,DEC,X,ASTR,ALPHA ;Find line of constant Dec +;+ +; NAME: +; CONS_DEC +; PURPOSE: +; Obtain the X and Y coordinates of a line of constant declination +; EXPLANATION: +; Returns a set of Y pixels values, given an image with astrometry, and +; either +; (1) A set of X pixel values, and a scalar declination value, or +; (2) A set of declination values, and a scalar X value +; +; Form (1) can be used to find the (X,Y) values of a line of constant +; declination. Form (2) can be used to find the Y positions of a set +; declinations, along a line of constant X. +; +; CALLING SEQUENCE: +; Y = CONS_DEC( DEC, X, ASTR, [ ALPHA ]) +; +; INPUTS: +; DEC - Declination value(s) in DEGREES (-!PI/2 < DEC < !PI/2). +; If X is a vector, then DEC must be a scalar. +; X - Specified X pixel value(s) for line of constant declination +; If DEC is a vector, then X must be a scalar. +; ASTR - Astrometry structure, as extracted from a FITS header by the +; procedure EXTAST +; OUTPUT: +; Y - Computed set of Y pixel values. The number of Y values is the +; same as either DEC or X, whichever is greater. +; +; OPTIONAL OUTPUT: +; ALPHA - the right ascensions (DEGREES) associated with the (X,Y) points +; +; RESTRICTIONS: +; Implemented only for the TANgent, SIN and CAR projections +; +; NOTES: +; The algorithm (and notation) is based on AIPS Memo 27 by Eric Greisen, +; with modifications for a coordinate description (CD) matrix as +; described in Paper II of Greisen & Calabretta (2002, A&A, 395, 1077). +; These documents are available from +; http://www.cv.nrao.edu/fits/documents/wcs/wcs.html +; +; REVISION HISTORY: +; Written, Wayne Landsman STX Co. April 1988 +; Use new astrometry structure, W. Landsman HSTX Jan. 1994 +; Use CD matrix, add SIN projection W. Landsman HSTX April, 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fix case where DEC is scalar, X is vector W. Landsman RITSS Feb. 2000 +; Fix possible sign error introduced Jan. 2000 W. Landsman May 2000 +; Work for the CARee' projection W. Landsman May 2003 +;- + On_error,2 + + if N_params() lt 3 then begin + print,'Syntax - Y = CONS_DEC( DEC, X, ASTR, [ALPHA] )' + return, 0 + endif + + RADEG = 180.0D/!DPI + + n = N_elements(x) + Ndec = N_elements(dec) + crpix = astr.crpix -1. + crval = astr.crval/RADEG + cd = astr.cd/RADEG + cdelt = astr.cdelt + + A = -cd[0,0]*cdelt[0] + B = -cd[0,1]*cdelt[0] + C = cd[1,0]*cdelt[1] + D = cd[1,1]*cdelt[1] + + xx = x - crpix[0] ;New coordinate origin + sdel0 = sin(crval[1]) & cdel0 = cos(crval[1]) + + ctype = strupcase( strmid(astr.ctype[0], 5,3)) + case ctype of + +'TAN': begin + aa = d + bb = (b*c-d*a)*xx*cdel0 + sdel0*b + sign = 2*( aa GT 0 ) - 1 + alpha = crval[0] + atan(bb/aa) + $ + sign * asin( tan(dec/RADEG)* ( (B*C-D*A)*xx*sdel0 - B*cdel0)/ $ + sqrt(aa^2+bb^2)) + end + +'SIN': begin + + aa = d + bb = b*sdel0 + sign = 2*( aa GT 0 ) - 1 + + denom = cos(dec/RADEG)*sqrt(aa^2+bb^2) + alpha = crval[0] + atan(bb/aa) + $ + sign * asin( ( (b*c-a*d)*xx - sin(dec/RADEG)*cdel0*b ) / denom ) + end + +'CAR': begin + alpha = crval[0] + (b*c -a*d)*xx + if (N_elements(alpha) EQ 1) and (Ndec GT 1) then $ + alpha = replicate(alpha[0],Ndec) +end + +ELSE: message,'ERROR - Program only works for TAN, SIN and CAR projections' + endcase + + alpha = alpha * RADEG + + if (N_elements(dec) EQ 1) and (n GT 1) then $ + ad2xy, alpha, replicate(dec, n) , astr, x1, y else $ + ad2xy, alpha, dec, astr, x1, y + + return,y + end diff --git a/modules/idl_downloads/astro/pro/cons_ra.pro b/modules/idl_downloads/astro/pro/cons_ra.pro new file mode 100644 index 0000000..c90fcb0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cons_ra.pro @@ -0,0 +1,119 @@ +FUNCTION CONS_RA,RA,Y,ASTR, DELTA ;Find line of constant RA +;+ +; NAME: +; CONS_RA +; PURPOSE: +; Obtain the X and Y coordinates of a line of constant right ascension +; EXPLANATION: +; Return a set of X pixel values given an image with astrometry, +; and either +; (1) a set of Y pixel values, and a scalar right ascension (or +; longitude), or +; (2) a set of right ascension values, and a scalar Y value. +; +; In usage (1), CONS_RA can be used to determine the (X,Y) values +; of a line of constant right ascension. In usage (2), CONS_RA can +; used to determine the X positions of specified RA values, along a +; line of constant Y. +; +; CALLING SEQUENCE: +; X = CONS_RA( RA, Y, ASTR, [ DEC] ) +; +; INPUTS: +; RA - Right Ascension value in DEGREES (0 < RA < 360.). If Y is a +; vector, then RA must be a scalar +; Y - Specified Y pixel value(s) for line of constant right ascension +; If RA is a vector, then Y must be a scalar +; ASTR - Astrometry structure as extracted from a FITS header by the +; procedure EXTAST +; OUTPUTS +; X - Computed set of X pixel values. The number of elements of X +; is the maximum of the number of elements of RA and Y. +; OPTIONAL OUTPUT: +; DEC - Computed set of declinations (in DEGREES) for X,Y, coordinates +; NOTES: +; The algorithm (and notation) is based on AIPS Memo 27 by Eric Greisen, +; with modifications for a coordinate description (CD) matrix as +; described in Paper II of Calabretta & Greisen (2002, A&A, 395, 1077). +; These documents are available from +; http://www.cv.nrao.edu/fits/documents/wcs/wcs.html +; +; RESTRICTIONS: +; Implemented only for the TANgent, SIN and CARtesian projections +; +; REVISION HISTORY: +; Written, Wayne Landsman STX Co. April, 1988 +; Algorithm adapted from AIPS memo No. 27 by Eric Greisen +; New astrometry structure +; Converted to IDL V5.0 W. Landsman September 1997 +; Added SIN projection W. Landsman January 2000 +; Fix possible sign error introduced Jan. 2000 W. Landsman May 2000 +; Work for the CARee' projection W. Landsman May 2003 +; For TAN projection ensure angles between -90 and 90 W. Landsman Jan 2008 +;- + On_error,2 + compile_opt idl2 + + if ( N_params() LT 3 ) then begin + print,'Syntax - X = CONS_RA( RA, Y, ASTR, [ Dec ])' + return, 0 + endif + + radeg = 180.0/!DPI + n = N_elements(y) + nra = N_elements(ra) + crpix = astr.crpix - 1. + crval = astr.crval/RADEG + cdelt = astr.cdelt + cdelta = [ [ cdelt[0], 0.],[0., cdelt[1] ] ] + cd = astr.cd/RADEG + cdel0 = cos( crval[1] ) & sdel0 = sin( crval[1] ) + delra = ra/RADEG - crval[0] + cdelra = cos( delra ) & sdelra = sin( delra ) + + ctype = strupcase( strmid(astr.ctype[0], 5,3)) + case ctype of + + 'TAN': begin + + cdi = invert( cdelta # cd ) ;Greisen uses invert of CD matrix + yy = y - ( crpix[1]) ;New coordinate origin, Unit pixel offset in CRPIX + delta = atan((sdel0*cdelra*cdi[1,1] - sin(delra)*cdi[1,0] + yy*cdelra*cdel0) $ + / (cdel0*cdi[1,1] - yy*sdel0)) + + end + 'SIN': begin + + A = -cd[0,0]*cdelt[0] + B = -cd[0,1]*cdelt[0] + C = cd[1,0]*cdelt[1] + D = cd[1,1]*cdelt[1] + yy = (y - crpix[1])*(b*c - a*d) ;New coordinate origin + aa = cdel0*d + bb = sdel0*cdelra*d + sdelra*b + denom = sqrt(aa^2 + bb^2) + delta = atan(bb/aa) + asin(yy/denom) + + end + + 'CAR': begin + A = -cd[0,0]*cdelt[0] + B = -cd[0,1]*cdelt[0] + C = cd[1,0]*cdelt[1] + D = cd[1,1]*cdelt[1] + delta = (y - crpix[1])*(b*c - a*d) +crval[1] ;New coordinate origin + if (N_elements(delta) EQ 1) and (Nra GT 1) then $ + delta = replicate(delta[0],Nra) + + end + + ELSE: message,'ERROR - Program only works for TAN and SIN projections' + endcase + + delta = delta*RADEG + if (Nra EQ 1) and (n GT 1) then $ + ad2xy, replicate(ra,n), delta, astr, x else $ + ad2xy, ra, delta, astr, x + + return, x + end diff --git a/modules/idl_downloads/astro/pro/convolve.pro b/modules/idl_downloads/astro/pro/convolve.pro new file mode 100644 index 0000000..f56e016 --- /dev/null +++ b/modules/idl_downloads/astro/pro/convolve.pro @@ -0,0 +1,178 @@ +function convolve, image, psf, FT_PSF=psf_FT, FT_IMAGE=imFT, NO_FT=noft, $ + CORRELATE=correlate, AUTO_CORRELATION=auto, $ + NO_PAD = no_pad +;+ +; NAME: +; CONVOLVE +; PURPOSE: +; Convolution of an image with a Point Spread Function (PSF) +; EXPLANATION: +; The default is to compute the convolution using a product of +; Fourier transforms (for speed). +; +; The image is padded with zeros so that a large PSF does not +; overlap one edge of the image with the opposite edge of the image. +; +; This routine is now partially obsolete due to the introduction of the +; intrinsic CONVOL_FFT() function in IDL 8.1 +; +; CALLING SEQUENCE: +; +; imconv = convolve( image1, psf, FT_PSF = psf_FT ) +; or: +; correl = convolve( image1, image2, /CORREL ) +; or: +; correl = convolve( image, /AUTO ) +; +; INPUTS: +; image = 2-D array (matrix) to be convolved with psf +; psf = the Point Spread Function, (size < or = to size of image). +; +; The PSF *must* be symmetric about the point +; FLOOR((n_elements-1)/2), where n_elements is the number of +; elements in each dimension. For Gaussian PSFs, the maximum +; of the PSF must occur in this pixel (otherwise the convolution +; will shift everything in the image). +; +; OPTIONAL INPUT KEYWORDS: +; +; FT_PSF = passes out/in the Fourier transform of the PSF, +; (so that it can be re-used the next time function is called). +; FT_IMAGE = passes out/in the Fourier transform of image. +; +; /CORRELATE uses the conjugate of the Fourier transform of PSF, +; to compute the cross-correlation of image and PSF, +; (equivalent to IDL function convol() with NO rotation of PSF) +; +; /AUTO_CORR computes the auto-correlation function of image using FFT. +; +; /NO_FT overrides the use of FFT, using IDL function convol() instead. +; (then PSF is rotated by 180 degrees to give same result) +; +; /NO_PAD - if set, then do not pad the image to avoid edge effects. +; This will improve memory and speed of the computation at the +; expense of edge effects. This was the default method prior +; to October 2009 +; METHOD: +; When using FFT, PSF is centered & expanded to size of image. +; HISTORY: +; written, Frank Varosi, NASA/GSFC 1992. +; Appropriate precision type for result depending on input image +; Markus Hundertmark February 2006 +; Fix the bug causing the recomputation of FFT(psf) and/or FFT(image) +; Sergey Koposov December 2006 +; Fix the centering bug +; Kyle Penner October 2009 +; Add /No_PAD keyword for better speed and memory usage when edge effects +; are not important. W. Landsman March 2010 +; Add warning when kernel type does not match integer array +; W. Landsman Feb 2012 +; Don't force double precision output W. Landsman July 2014 +;- + compile_opt idl2 + sp = size( psf_FT,/str ) & sif = size( imFT, /str ) + sim = size( image ) + + + if (sim[0] NE 2) || keyword_set( noft ) then begin + if keyword_set( auto ) then begin + message,"auto-correlation only for images with FFT",/INF + return, image + endif + dtype = size(image,/type) + if dtype LE 3 then if size(psf,/type) NE dtype then $ + message,/CON, $ + 'WARNING - ' + size(psf,/TNAME) + $ + ' kernel converted to type ' + size(image,/tname) + if keyword_set( correlate ) then $ + return, convol( image, psf ) $ + else return, convol( image, rotate( psf, 2 ) ) + endif + + if keyword_Set(No_Pad) then begin + + sc = sim/2 & npix = N_elements( image ) + if (sif.N_dimensions NE 2) || ((sif.type NE 6) && (sif.type NE 9)) || $ + (sif.dimensions[0] NE sim[1]) || (sif.dimensions[1] NE sim[2]) then imFT = FFT( image,-1 ) + + if keyword_set( auto ) then $ + return, shift( npix*real_part(FFT( imFT*conj( imFT ),1 )), sc[1],sc[2] ) + + if (sp.N_dimensions NE 2) || ((sp.type NE 6) && (sp.type NE 9)) || $ + (sp.dimensions[0] NE sim[1]) || (sp.dimensions[1] NE sim[2]) then begin + sp = size( psf ) + if (sp[0] NE 2) then begin + message,"must supply PSF matrix (2nd arg.)",/INFO + return, image + endif + Loc = ( sc - sp/2 ) > 0 ;center PSF in new array, + s = (sp/2 - sc) > 0 ;handle all cases: smaller or bigger + L = (s + sim-1) < (sp-1) + psf_FT = conj(image)*0 ;initialise with correct size+type according + ;to logic of conj and set values to 0 (type of psf_FT is conserved) + psf_FT[ Loc[1], Loc[2] ] = psf[ s[1]:L[1], s[2]:L[2] ] + psf_FT = FFT( psf_FT, -1, /OVERWRITE ) + endif + + if keyword_set( correlate ) then $ + conv = npix * real_part(FFT( imFT * conj( psf_FT ), 1 )) $ + else conv = npix * real_part(FFT( imFT * psf_FT, 1 )) + + sc = sc + (sim MOD 2) ;shift correction for odd size images. + + return, shift( conv, sc[1], sc[2] ) + endif else begin + + + sc = floor((sim-1)/2) & npix = n_elements(image)*4. + ; the spooky factor of 4 in npix is because we're going to pad the image + ; with zeros + + if (sif.N_dimensions NE 2) || ((sif.type NE 6) && (sif.type NE 9)) || $ + (sif.dimensions[0] NE sim[1]) || (sif.dimensions[1] NE sim[2]) then begin + + ; here is where we make an array with twice the dimensions of image and + ; pad with zeros -- thanks to Daniel Eisenstein for this fix + + image_big = make_array(type = sim[sim[0]+1], sim[1]*2, sim[2]*2) + image_big[0:sim[1]-1,0:sim[2]-1] = image + imFT = FFT( image_big,-1 ) + npix = n_elements(image_big) + + endif + + if keyword_set( auto ) then begin + intermed = shift( npix*real_part(FFT( imFT*conj( imFT ),1 )), sc[1],sc[2] ) + return, intermed[0:sim[1]-1,0:sim[2]-1] + endif + + + if (sp.N_dimensions NE 2) || ((sp.type NE 6) && (sp.type NE 9)) OR $ + (sp.dimensions[0] NE sim[1]) || (sp.dimensions[1] NE sim[2]) then begin + sp = size( psf ) + if (sp[0] NE 2) then begin + message,"must supply PSF matrix (2nd arg.)",/INFO + return, image + endif + ; this obfuscated line determines the offset between the center of the + ; image and the center of the PSF + Loc = ( sc - floor((sp-1)/2) ) > 0 + + psf_image = make_array(type = sim[sim[0]+1],sim[1]*2,sim[2]*2) + psf_image[Loc[1]:Loc[1]+sp[1]-1, Loc[2]:Loc[2]+sp[2]-1] = psf + psf_FT = FFT(psf_image, -1) + endif + + if keyword_set( correlate ) then begin + conv = npix * real_part(FFT( imFT * conj( psf_FT ), 1 )) + conv = shift(conv, sc[1], sc[2]) + endif else begin + conv = npix * real_part(FFT( imFT * psf_FT, 1 )) + conv = shift(conv, -sc[1], -sc[2]) + + endelse + + + return, conv[0:sim[1]-1,0:sim[2]-1] + endelse +end diff --git a/modules/idl_downloads/astro/pro/copy_struct.pro b/modules/idl_downloads/astro/pro/copy_struct.pro new file mode 100644 index 0000000..147fc0d --- /dev/null +++ b/modules/idl_downloads/astro/pro/copy_struct.pro @@ -0,0 +1,250 @@ +;+ +; NAME: +; COPY_STRUCT +; PURPOSE: +; Copy all fields with matching tag names from one structure to another +; EXPLANATION: +; COPY_STRUCT is similar to the intrinsic STRUCT_ASSIGN procedure but +; has optional keywords to exclude or specify specific tags. +; +; Fields with matching tag names are copied from one structure array to +; another structure array of different type. +; This allows copying of tag values when equating the structures of +; different types is not allowed, or when not all tags are to be copied. +; Can also recursively copy from/to structures nested within structures. +; Note that the number of elements in the output structure array +; is automatically adjusted to equal the length of input structure array. +; If this not desired then use pro copy_struct_inx which allows +; specifying via subscripts which elements are copied where in the arrays. +; +; CALLING SEQUENCE: +; +; copy_struct, struct_From, struct_To, NT_copied +; copy_struct, struct_From, struct_To, EXCEPT=["image","misc"] +; copy_struct, struct_From, struct_To, /RECUR_TANDEM +; +; INPUTS: +; struct_From = structure array to copy from. +; struct_To = structure array to copy values to. +; +; KEYWORDS: +; +; EXCEPT_TAGS = string array of tag names to ignore (to NOT copy). +; Used at all levels of recursion. +; +; SELECT_TAGS = tag names to copy (takes priority over EXCEPT). +; This keyword is not passed to recursive calls in order +; to avoid the confusion of not copying tags in sub-structures. +; +; /RECUR_FROM = search for sub-structures in struct_From, and then +; call copy_struct recursively for those nested structures. +; +; /RECUR_TO = search for sub-structures of struct_To, and then +; call copy_struct recursively for those nested structures. +; +; /RECUR_TANDEM = call copy_struct recursively for the sub-structures +; with matching Tag names in struct_From and struct_To +; (for use when Tag names match but sub-structure types differ). +; +; OUTPUTS: +; struct_To = structure array to which new tag values are copied. +; NT_copied = incremented by total # of tags copied (optional) +; +; INTERNAL: +; Recur_Level = # of times copy_struct calls itself. +; This argument is for internal recursive execution only. +; The user call is 1, subsequent recursive calls increment it, +; and the counter is decremented before returning. +; The counter is used just to find out if argument checking +; should be performed, and to set NT_copied = 0 first call. +; EXTERNAL CALLS: +; pro match (when keyword SELECT_TAGS is specified) +; PROCEDURE: +; Match Tag names and then use corresponding Tag numbers. +; HISTORY: +; written 1989 Frank Varosi STX @ NASA/GSFC +; mod Jul.90 by F.V. added option to copy sub-structures RECURSIVELY. +; mod Aug.90 by F.V. adjust # elements in TO (output) to equal +; # elements in FROM (input) & count # of fields copied. +; mod Jan.91 by F.V. added Recur_Level as internal argument so that +; argument checking done just once, to avoid confusion. +; Checked against Except_Tags in RECUR_FROM option. +; mod Oct.91 by F.V. added option SELECT_TAGS= selected field names. +; mod Aug.95 by W. Landsman to fix match of a single selected tag. +; mod Mar.97 by F.V. do not pass the SELECT_TAGS keyword in recursion. +; Converted to IDL V5.0 W. Landsman September 1997 +; mod May 01 by D. Schlegel use long integers +;- + +pro copy_struct, struct_From, struct_To, NT_copied, Recur_Level, $ + EXCEPT_TAGS = except_Tags, $ + SELECT_TAGS = select_Tags, $ + RECUR_From = recur_From, $ + RECUR_TO = recur_To, $ + RECUR_TANDEM = recur_tandem + + if N_elements( Recur_Level ) NE 1 then Recur_Level = 0L + + Ntag_from = N_tags( struct_From ) + Ntag_to = N_tags( struct_To ) + + if (Recur_Level EQ 0) then begin ;check only at first user call. + + NT_copied = 0L + + if (Ntag_from LE 0) OR (Ntag_to LE 0) then begin + message,"two arguments must be structures",/INFO + print," " + print,"syntax: copy_struct, struct_From, struct_To" + print," " + print,"keywords: EXCEPT_TAGS= , SELECT_TAGS=, " + print," /RECUR_From, /RECUR_TO, /RECUR_TANDEM" + return + endif + + N_from = N_elements( struct_From ) + N_to = N_elements( struct_To ) + + if (N_from GT N_to) then begin + + message," # elements (" + strtrim( N_to, 2 ) + $ + ") in output TO structure",/INFO + message," increased to (" + strtrim( N_from, 2 ) + $ + ") as in FROM structure",/INFO + struct_To = [ struct_To, $ + replicate( struct_To[0], N_from-N_to ) ] + + endif else if (N_from LT N_to) then begin + + message," # elements (" + strtrim( N_to, 2 ) + $ + ") in output TO structure",/INFO + message," decreased to (" + strtrim( N_from, 2 ) + $ + ") as in FROM structure",/INFO + struct_To = struct_To[0:N_from-1] + endif + endif + + Recur_Level = Recur_Level + 1 ;go for it... + + Tags_from = Tag_names( struct_From ) + Tags_to = Tag_names( struct_To ) + wto = lindgen( Ntag_to ) + +;Determine which Tags are selected or excluded from copying: + + Nseltag = N_elements( select_Tags ) + Nextag = N_elements( except_Tags ) + + if (Nseltag GT 0) then begin + + match, Tags_to, [strupcase( select_Tags )], mt, ms,COUNT=Ntag_to + + if (Ntag_to LE 0) then begin + message," selected tags not found",/INFO + return + endif + + Tags_to = Tags_to[mt] + wto = wto[mt] + + endif else if (Nextag GT 0) then begin + + except_Tags = [strupcase( except_Tags )] + + for t=0L,Nextag-1 do begin + w = where( Tags_to NE except_Tags[t], Ntag_to ) + Tags_to = Tags_to[w] + wto = wto[w] + endfor + endif + +;Now find the matching Tags and copy them... + + for t = 0L, Ntag_to-1 do begin + + wf = where( Tags_from EQ Tags_to[t] , nf ) + + if (nf GT 0) then begin + + from = wf[0] + to = wto[t] + + if keyword_set( recur_tandem ) AND $ + ( N_tags( struct_To.(to) ) GT 0 ) AND $ + ( N_tags( struct_From.(from) ) GT 0 ) then begin + + struct_tmp = struct_To.(to) + + copy_struct, struct_From.(from), struct_tmp, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_TANDEM, $ + RECUR_FROM = recur_From, $ + RECUR_TO = recur_To + + struct_To.(to) = struct_tmp + + endif else begin + + struct_To.(to) = struct_From.(from) + NT_copied = NT_copied + 1 + endelse + endif + endfor + +;Handle request for recursion on FROM structure: + + if keyword_set( recur_From ) then begin + + wfrom = lindgen( Ntag_from ) + + if (Nextag GT 0) then begin + + for t=0L,Nextag-1 do begin + w = where( Tags_from NE except_Tags[t], Ntag_from ) + Tags_from = Tags_from[w] + wfrom = wfrom[w] + endfor + endif + + for t = 0L, Ntag_from-1 do begin + + from = wfrom[t] + + if N_tags( struct_From.(from) ) GT 0 then begin + + copy_struct, struct_From.(from), struct_To, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_FROM, $ + RECUR_TO = recur_To, $ + RECUR_TANDEM = recur_tandem + endif + endfor + endif + +;Handle request for recursion on TO structure: + + if keyword_set( recur_To ) then begin + + for t = 0L, Ntag_to-1 do begin + + to = wto[t] + + if N_tags( struct_To.(to) ) GT 0 then begin + + struct_tmp = struct_To.(to) + + copy_struct, struct_From, struct_tmp, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_TO, $ + RECUR_FROM = recur_From, $ + RECUR_TANDEM = recur_tandem + struct_To.(to) = struct_tmp + endif + endfor + endif + + Recur_Level = Recur_Level - 1 +end diff --git a/modules/idl_downloads/astro/pro/copy_struct_inx.pro b/modules/idl_downloads/astro/pro/copy_struct_inx.pro new file mode 100644 index 0000000..c162bb4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/copy_struct_inx.pro @@ -0,0 +1,287 @@ +;+ +; NAME: +; COPY_STRUCT_INX +; PURPOSE: +; Copy matching tags & specified indices from one structure to another +; EXPLANATION: +; Copy all fields with matching tag names (except for "except_Tags") +; from one structure array to another structure array of different type. +; This allows copying of tag values when equating the structures of +; different types is not allowed, or when not all tags are to be copied. +; Can also recursively copy from/to structures nested within structures. +; This procedure is same as copy_struct with option to +; specify indices (subscripts) of which array elements to copy from/to. +; CALLING SEQUENCE: +; +; copy_struct_inx, struct_From, struct_To, NT_copied, INDEX_FROM=subf +; +; copy_struct_inx, struct_From, struct_To, INDEX_FROM=subf, INDEX_TO=subto +; +; INPUTS: +; struct_From = structure array to copy from. +; struct_To = structure array to copy values to. +; +; KEYWORDS: +; +; INDEX_FROM = indices (subscripts) of which elements of array to copy. +; (default is all elements of input structure array) +; +; INDEX_TO = indices (subscripts) of which elements to copy to. +; (default is all elements of output structure array) +; +; EXCEPT_TAGS = string array of Tag names to ignore (to NOT copy). +; Used at all levels of recursion. +; +; SELECT_TAGS = Tag names to copy (takes priority over EXCEPT). +; This keyword is not passed to recursive calls in order +; to avoid the confusion of not copying tags in sub-structures. +; +; /RECUR_FROM = search for sub-structures in struct_From, and then +; call copy_struct recursively for those nested structures. +; +; /RECUR_TO = search for sub-structures of struct_To, and then +; call copy_struct recursively for those nested structures. +; +; /RECUR_TANDEM = call copy_struct recursively for the sub-structures +; with matching Tag names in struct_From and struct_To +; (for use when Tag names match but sub-structure types differ). +; +; OUTPUTS: +; struct_To = structure array to which new tag values are copied. +; NT_copied = incremented by total # of tags copied (optional) +; +; INTERNAL: +; Recur_Level = # of times copy_struct_inx calls itself. +; This argument is for internal recursive execution only. +; The user call is 1, subsequent recursive calls increment it, +; and the counter is decremented before returning. +; The counter is used just to find out if argument checking +; should be performed, and to set NT_copied = 0 first call. +; EXTERNAL CALLS: +; pro match (when keyword SELECT_TAGS is specified) +; PROCEDURE: +; Match Tag names and then use corresponding Tag numbers, +; apply the sub-indices during = and recursion. +; HISTORY: +; adapted from copy_struct: 1991 Frank Varosi STX @ NASA/GSFC +; mod Aug.95 by F.V. to fix match of a single selected tag. +; mod Mar.97 by F.V. do not pass the SELECT_TAGS keyword in recursion, +; and check validity of INDEX_FROM and INDEX_TO in more detail. +; Converted to IDL V5.0 W. Landsman September 1997 +; Use long integers W. Landsman May 2001 +;- + +pro copy_struct_inx, struct_From, struct_To, NT_copied, Recur_Level, $ + EXCEPT_TAGS = except_Tags, $ + SELECT_TAGS = select_Tags, $ + INDEX_From = index_From, $ + INDEX_To = index_To, $ + RECUR_From = recur_From, $ + RECUR_To = recur_To, $ + RECUR_TANDEM = recur_tandem + + if N_elements( Recur_Level ) NE 1 then Recur_Level = 0L + + Ntag_from = N_tags( struct_From ) + Ntag_to = N_tags( struct_To ) + + if (Recur_Level EQ 0) then begin ;check only at first user call. + + NT_copied = 0L + + if (Ntag_from LE 0) OR (Ntag_to LE 0) then begin + message,"two arguments must be structures",/INFO + print," " + print,"syntax: copy_struct_inx, struct_From, struct_To" + print," " + print,"keywords: INDEX_From= , INDEX_To=" + print," EXCEPT_TAGS= , SELECT_TAGS=, " + print," /RECUR_From, /RECUR_To, /RECUR_TANDEM" + return + endif + + N_from = N_elements( struct_From ) + N_to = N_elements( struct_To ) + + if N_elements( index_From ) LE 0 then index_From = $ + lindgen( N_from ) + Ni_from = N_elements( index_From ) + if N_elements( index_To ) LE 0 then index_To = lindgen( Ni_from ) + Ni_to = N_elements( index_To ) + + if (Ni_from LT Ni_to) then begin + + message," # elements (" + strtrim( Ni_to, 2 ) + $ + ") in output TO indices",/INFO + message," decreased to (" + strtrim( Ni_from, 2 ) + $ + ") as in FROM indices",/INFO + index_To = index_To[0:Ni_from-1] + + endif else if (Ni_from GT Ni_to) then begin + + message," # elements (" + strtrim( Ni_from, 2 ) + $ + ") of input FROM indices",/INFO + message," decreased to (" + strtrim( Ni_to, 2 ) + $ + ") as in TO indices",/INFO + index_From = index_From[0:Ni_to-1] + endif + + Mi_to = max( [index_To] ) + Mi_from = max( [index_From] ) + + if (Mi_to GE N_to) then begin + + message," # elements (" + strtrim( N_to, 2 ) + $ + ") in output TO structure",/INFO + message," increased to (" + strtrim( Mi_to, 2 ) + $ + ") as max value of INDEX_To",/INFO + struct_To = [ struct_To, $ + replicate( struct_To[0], Mi_to-N_to ) ] + endif + + if (Mi_from GE N_from) then begin + + w = where( index_From LT N_from, nw ) + + if (nw GT 0) then begin + index_From = index_From[w] + message,"max value (" + strtrim( Mi_from, 2 ) +$ + ") in FROM indices",/INFO + print,"decreased to " + strtrim( N_from,2 ) + $ + ") as in FROM structure",/INFO + endif else begin + message,"all FROM indices are out of bounds",/IN + return + endelse + endif + endif + + Recur_Level = Recur_Level + 1 ;go for it... + + Tags_from = Tag_names( struct_From ) + Tags_to = Tag_names( struct_To ) + wto = lindgen( Ntag_to ) + +;Determine which Tags are selected or excluded from copying: + + Nseltag = N_elements( select_Tags ) + Nextag = N_elements( except_Tags ) + + if (Nseltag GT 0) then begin + + match, Tags_to, [strupcase( select_Tags )], mt, ms,COUNT=Ntag_to + + if (Ntag_to LE 0) then begin + message," selected tags not found",/INFO + return + endif + + Tags_to = Tags_to[mt] + wto = wto[mt] + + endif else if (Nextag GT 0) then begin + + except_Tags = [strupcase( except_Tags )] + + for t=0L,Nextag-1 do begin + w = where( Tags_to NE except_Tags[t], Ntag_to ) + Tags_to = Tags_to[w] + wto = wto[w] + endfor + endif + +;Now find the matching Tags and copy them... + + for t = 0L, Ntag_to-1 do begin + + wf = where( Tags_from EQ Tags_to[t] , nf ) + + if (nf GT 0) then begin + + from = wf[0] + to = wto[t] + + if keyword_set( recur_tandem ) AND $ + ( N_tags( struct_To.(to) ) GT 0 ) AND $ + ( N_tags( struct_From.(from) ) GT 0 ) then begin + + struct_tmp = struct_To[index_To].(to) + + copy_struct, struct_From[index_From].(from), $ + struct_tmp, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_TANDEM, $ + RECUR_FROM = recur_From, $ + RECUR_To = recur_To + + struct_To[index_To].(to) = struct_tmp + + endif else begin + + struct_To[index_To].(to) = $ + struct_From[index_From].(from) + NT_copied = NT_copied + 1 + endelse + endif + endfor + +;Handle request for recursion on FROM structure: + + if keyword_set( recur_From ) then begin + + wfrom = lindgen( Ntag_from ) + + if (Nextag GT 0) then begin + + for t=0L,Nextag-1 do begin + w = where( Tags_from NE except_Tags[t], Ntag_from ) + Tags_from = Tags_from[w] + wfrom = wfrom[w] + endfor + endif + + for t = 0L, Ntag_from-1 do begin + + from = wfrom[t] + + if N_tags( struct_From.(from) ) GT 0 then begin + + copy_struct_inx, struct_From.(from), struct_To, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_FROM, $ + INDEX_From = index_From, $ + INDEX_To = index_To, $ + RECUR_To = recur_To, $ + RECUR_TANDEM = recur_tandem + endif + endfor + endif + +;Handle request for recursion on TO structure: + + if keyword_set( recur_To ) then begin + + for t = 0L, Ntag_to-1 do begin + + to = wto[t] + + if N_tags( struct_To.(to) ) GT 0 then begin + + struct_tmp = struct_To[index_To].(to) + + copy_struct_inx, struct_From, struct_tmp, $ + NT_copied, Recur_Level, $ + EXCEPT=except_Tags, $ + /RECUR_To, $ + INDEX_From = index_From, $ + RECUR_FROM = recur_From, $ + RECUR_TANDEM = recur_tandem + struct_To[index_To].(to) = struct_tmp + endif + endfor + endif + + Recur_Level = Recur_Level - 1 +end diff --git a/modules/idl_downloads/astro/pro/correl_images.pro b/modules/idl_downloads/astro/pro/correl_images.pro new file mode 100644 index 0000000..de9aaa2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/correl_images.pro @@ -0,0 +1,210 @@ +function correl_images, image_A, image_B, XSHIFT = x_shift, $ + YSHIFT = y_shift, $ + XOFFSET_B = x_offset, $ + YOFFSET_B = y_offset, $ + REDUCTION = reducf, $ + MAGNIFICATION = Magf, $ + NUMPIX=numpix, MONITOR=monitor +;+ +; NAME: +; CORREL_IMAGES +; PURPOSE: +; Compute the 2-D cross-correlation function of two images +; EXPLANATION: +; Computes the 2-D cross-correlation function of two images for +; a range of (x,y) shifting by pixels of one image relative to the other. +; +; CALLING SEQUENCE: +; Result = CORREL_IMAGES( image_A, image_B, +; [XSHIFT=, YSHIFT=, XOFFSET_B=, YOFFSET_B=, REDUCTION=, +; MAGNIFICATION=, /NUMPIX, /MONITOR ) +; +; INPUTS: +; image_A, image_B = the two images of interest. +; +; OPTIONAL INPUT KEYWORDS: +; XSHIFT = the + & - shift to be applied in X direction, default=7. +; YSHIFT = the Y direction + & - shifting, default=7. +; +; XOFFSET_B = initial X pixel offset of image_B relative to image_A. +; YOFFSET_B = Y pixel offset, defaults are (0,0). +; +; REDUCTION = optional reduction factor causes computation of +; Low resolution correlation of bin averaged images, +; thus faster. Can be used to get approximate optimal +; (x,y) offset of images, and then called for successive +; lower reductions in conjunction with CorrMat_Analyze +; until REDUCTION=1, getting offset up to single pixel. +; +; MAGNIFICATION = option causes computation of high resolution correlation +; of magnified images, thus much slower. +; Shifting distance is automatically = 2 + Magnification, +; and optimal pixel offset should be known and specified. +; Optimal offset can then be found to fractional pixels +; using CorrMat_Analyze( correl_images( ) ). +; +; /NUMPIX - if set, causes the number of pixels for each correlation +; to be saved in a second image, concatenated to the +; correlation image, so Result is fltarr( Nx, Ny, 2 ). +; /MONITOR causes the progress of computation to be briefly printed. +; +; OUTPUTS: +; Result is the cross-correlation function, given as a matrix. +; +; PROCEDURE: +; Loop over all possible (x,y) shifts, compute overlap and correlation +; for each shift. Correlation set to zero when there is no overlap. +; +; MODIFICATION HISTORY: +; Written, July,1991, Frank Varosi, STX @ NASA/GSFC +; Use ROUND instead of NINT, June 1995, Wayne Landsman HSTX +; Avoid divide by zero errors, W. Landsman HSTX April 1996 +; Remove use of !DEBUG W. Landsman June 1997 +; Subtract mean of entire image before computing correlation, not just +; mean of overlap region H. Ebeling/W. Landsman June 1998 +; Always REBIN() using floating pt arithmetic W. Landsman Nov 2007 +; +;- + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - Result = CORREL_IMAGES( image_A, image_B,' + print,'[ XSHIFT=, YSHIFT=, XOFFSET_B=, YOFFSET_B=, REDUCTION=, ' + print,' MAGNIFICATION=, /NUMPIX, /MONITOR )' + return,-1 + endif + + simA = size( image_A ) + simB = size( image_B ) + do_int = (simA[3] LE 3) or (simA[3] GE 12) or $ + (simB[3] LE 3) or (simB[3] GE 12) + + if (simA[0] LT 2) OR (simB[0] LT 2) then begin + message,"first two arguments must be images",/INFO,/CONTIN + return,[-1] + endif + + if N_elements( x_offset ) NE 1 then x_offset=0 + if N_elements( y_offset ) NE 1 then y_offset=0 + + if N_elements( x_shift ) NE 1 then x_shift = 7 + if N_elements( y_shift ) NE 1 then y_shift = 7 + x_shift = abs( x_shift ) + y_shift = abs( y_shift ) + + if keyword_set( reducf ) then begin + + reducf = fix( reducf ) > 1 + if keyword_set( monitor ) then $ + print,"Reduction = ",strtrim( reducf, 2 ) + simA = simA/reducf + LA = simA * reducf -1 ;may have to drop edges of images. + simB = simB/reducf + LB = simB * reducf -1 + + if do_int then begin + + imtmp_A = Rebin( float( image_A[ 0:LA[1], 0:LA[2] ]), $ + simA[1], simA[2] ) + imtmp_B = Rebin( float( image_B[ 0:LB[1], 0:LB[2] ]), $ + simB[1], simB[2] ) + endif else begin + imtmp_A =Rebin( image_A[ 0:LA[1], 0:LA[2] ], simA[1], simA[2] ) + imtmp_B =Rebin( image_B[ 0:LB[1], 0:LB[2] ], simB[1], simB[2] ) + endelse + + xoff = round ( x_offset/reducf ) + yoff = round ( y_offset/reducf ) + xs = x_shift/reducf + ys = y_shift/reducf + + return, correl_images( imtmp_A, imtmp_B, XS=xs,YS=ys,$ + XOFF=xoff, YOFF=yoff, $ + MONITOR=monitor, NUMPIX=numpix ) + + endif else if keyword_set( Magf ) then begin + + Magf = fix( Magf ) > 1 + if keyword_set( monitor ) then $ + print,"Magnification = ",strtrim( Magf, 2 ) + simA = simA*Magf + simB = simB*Magf + + imtmp_A = rebin( image_A, simA[1], simA[2], /SAMPLE ) + imtmp_B = rebin( image_B, simB[1], simB[2], /SAMPLE ) + + xoff = round( x_offset*Magf ) + yoff = round( y_offset*Magf ) + + return, correl_images( imtmp_A, imtmp_B, XS=Magf+2, YS=Magf+2,$ + XOFF=xoff, YOFF=yoff, $ + MONITOR=monitor, NUMPIX=numpix ) + endif + + Nx = 2 * x_shift + 1 + Ny = 2 * y_shift + 1 + if keyword_set( numpix ) then Nim=2 else Nim=1 + + correl_mat = fltarr( Nx, Ny, Nim ) + + xs = round( x_offset ) - x_shift + ys = round( y_offset ) - y_shift + + sAx = simA[1]-1 + sAy = simA[2]-1 + sBx = simB[1]-1 + sBy = simB[2]-1 + meanA = total( image_A )/(simA[1]*simA[2]) + meanB = total( image_B )/(simB[1]*simB[2]) + + for y = 0, Ny-1 do begin ;compute correlation for each y,x shift. + + yoff = ys + y + yAmin = yoff > 0 + yAmax = sAy < (sBy + yoff) + yBmin = (-yoff) > 0 + yBmax = sBy < (sAy - yoff) ;Y overlap + + if (yAmax GT yAmin) then begin + + for x = 0, Nx-1 do begin + + xoff = xs + x + xAmin = xoff > 0 + xAmax = sAx < (sBx + xoff) + xBmin = (-xoff) > 0 + xBmax = sBx < (sAx - xoff) ;X overlap + + if (xAmax GT xAmin) then begin + + im_ov_A = image_A[ xAmin:xAmax, yAmin:yAmax ] + im_ov_B = image_B[ xBmin:xBmax, yBmin:yBmax ] + Npix = N_elements( im_ov_A ) + + if N_elements( im_ov_B ) NE Npix then begin + message,"overlap error: # pixels NE",/INFO,/CONT + print, Npix, N_elements( im_ov_B ) + endif + + im_ov_A = im_ov_A - meanA + im_ov_B = im_ov_B - meanB + totAA = total( im_ov_A * im_ov_A ) + totBB = total( im_ov_B * im_ov_B ) + + if (totAA EQ 0) or (totBB EQ 0) then $ + correl_mat[x,y] = 0.0 else $ + correl_mat[x,y] = total( im_ov_A * im_ov_B ) / $ + sqrt( totAA * totBB ) + + if keyword_set( numpix ) then correl_mat[x,y,1] = Npix + endif + + endfor + endif + + if keyword_set( monitor ) then print, Ny-y, FORM="($,i3)" + endfor + + if keyword_set( monitor ) then print," " + +return, correl_mat +end diff --git a/modules/idl_downloads/astro/pro/correl_optimize.pro b/modules/idl_downloads/astro/pro/correl_optimize.pro new file mode 100644 index 0000000..71c9395 --- /dev/null +++ b/modules/idl_downloads/astro/pro/correl_optimize.pro @@ -0,0 +1,125 @@ +pro correl_optimize, image_A, image_B, xoffset_optimum, yoffset_optimum, $ + XOFF_INIT = xoff_init, $ + YOFF_INIT = yoff_init, $ + PRINT=print, MONITOR=monitor, $ + NUMPIX=numpix, MAGNIFICATION=Magf, $ + PLATEAU_TRESH = plateau +;+ +; NAME: +; CORREL_OPTIMIZE +; +; PURPOSE: +; Find the optimal (x,y) pixel offset of image_B relative to image_A +; EXPLANATION" +; Optimal offset is computed by means of maximizing the correlation +; function of the two images. +; +; CALLING SEQUENCE: +; CORREL_OPTIMIZE, image_A, image_B, xoffset_optimum, yoffset_optimum +; [ XOFF_INIT=, YOFF_INIT=, MAGNIFICATION=, /PRINT, /NUMPIX, +; /MONITOR, PLATEAU_THRESH= ] +; +; INPUTS: +; image_A, image_B = the two images of interest. +; +; OPTIONAL INPUT KEYWORDS: +; XOFF_INIT = initial X pixel offset of image_B relative to image_A, +; YOFF_INIT = Y pixel offset, (default offsets are 0 and 0). +; MAGNIFICATION = option to determine offsets up to fractional pixels, +; (example: MAG=2 means 1/2 pixel accuracy, default=1). +; /NUMPIX: sqrt( sqrt( # pixels )) used as correlation weighting factor. +; /MONITOR causes the progress of computation to be briefly printed. +; /PRINT causes the results of analysis to be printed. +; PLATEAU_THRESH = threshold used for detecting plateaus in +; the cross-correlation matrix near maximum, (default=0.01), +; used only if MAGNIFICATION > 1. Decrease this value for +; high signal-to-noise data +; +; OUTPUTS: +; xoffset_optimum = optimal X pixel offset of image_B relative to image_A. +; yoffset_optimum = optimal Y pixel offset. +; +; CALLS: +; function correl_images( image_A, image_B ) +; pro corrmat_analyze +; +; PROCEDURE: +; The combination of function correl_images( image_A, image_B ) and +; corrmat_analyze of the result is used to obtain the (x,y) offset +; yielding maximal correlation. The combination is first executed at +; large REDUCTION factors to speed up computation, then zooming in +; recursively on the optimal (x,y) offset by factors of 2. +; Finally, the MAGNIFICATION option (if specified) +; is executed to determine the (x,y) offset up to fractional pixels. +; +; MODIFICATION HISTORY: +; Written, July,1991, Frank Varosi, STX @ NASA/GSFC +; Added PLATEAU_THRESH keyword June 1997, Wayne Landsman STX +; Converted to IDL V5.0 W. Landsman September 1997 +;- + if N_params() LT 2 then begin + print,'Syntax - CORREL_OPTIMIZE, imA, imB, Xoffset, Yoffset' + print,'Keywords - /Monitor, /Print, XoffInit =, YoffInit =' + $ + ', Magnification =, /Numpix' + return + endif + + simA = size( image_A ) + simB = size( image_B ) + + if (simA[0] LT 2) OR (simB[0] LT 2) then begin + message,"first two arguments must be images",/INFO,/CONTIN + return + endif + + if N_elements( xoff_init ) NE 1 then xoff_init=0 + if N_elements( yoff_init ) NE 1 then yoff_init=0 + if N_elements( plateau ) NE 1 then plateau = 0.01 + xoff = xoff_init + yoff = yoff_init + + reducf = min( [simA[1:2],simB[1:2]] ) / 8 ;Bin average to about + ; 8 by 8 pixel image. + if N_elements( Magf ) NE 1 then Magf=1 + + xsiz = max( [simA[1],simB[1]] ) + ysiz = max( [simA[2],simB[2]] ) + xshift = xsiz + yshift = ysiz ;shift over the whole images first correlation. + + while (reducf GT 1) do begin + + corrmat = correl_images( image_A, image_B, XOFF=xoff,YOFF=yoff,$ + NUM=numpix, XS=xshift,YS=yshift,$ + REDUCTION=reducf, MONIT=monitor ) + + corrmat_analyze, corrmat, xoff, yoff, XOFF=xoff, YOFF=yoff, $ + PRINT=print, REDUCTION=reducf + xshift = 2*reducf + yshift = 2*reducf ;shift over coarse pixels to refine + reducf = reducf/2 ; in further correlations. + endwhile + + xshift = xshift/2 ;now refine offsets to actual pixels. + yshift = yshift/2 + corrmat = correl_images( image_A, image_B, XOFF=xoff, YOFF=yoff,$ + MON=monitor, NUM=numpix, XS=xshift, YS=yshift ) + + corrmat_analyze, corrmat, xoffset_optimum, yoffset_optimum, $ + XOFF=xoff, YOFF=yoff, PRINT=print + + if (Magf GE 2) then begin + + xoff = xoffset_optimum ;refine offsets to + yoff = yoffset_optimum ; fractional pixels. + + corrmat = correl_images( image_A, image_B, XOFF=xoff,YOFF=yoff,$ + MAGNIFIC=Magf, MONITOR=monitor ) + + corrmat_analyze, corrmat, xoffset_optimum, yoffset_optimum, $ + XOFF=xoff,YOFF=yoff,$ + PRINT=print, MAG=Magf, $ + PLATEAU_THRESH = plateau + endif +return +end diff --git a/modules/idl_downloads/astro/pro/corrmat_analyze.pro b/modules/idl_downloads/astro/pro/corrmat_analyze.pro new file mode 100644 index 0000000..26af51c --- /dev/null +++ b/modules/idl_downloads/astro/pro/corrmat_analyze.pro @@ -0,0 +1,174 @@ +pro corrmat_analyze, correl_mat, xoffset_optimum, yoffset_optimum, $ + max_corr, edge, plateau, $ + XOFF_INIT = xoff_init, $ + YOFF_INIT = yoff_init, $ + REDUCTION = reducf, MAGNIFICATION = Magf, $ + PRINT = print, PLATEAU_THRESH = plateau_thresh +;+ +; NAME: +; CORRMAT_ANALYZE +; PURPOSE: +; Find the optimal (x,y) offset to maximize correlation of 2 images +; EXPLANATION: +; Analyzes the 2-D cross-correlation function of two images +; and finds the optimal(x,y) pixel offsets. +; Intended for use with function CORREL_IMAGES. +; +; CALLING SEQUENCE: +; corrmat_analyze, correl_mat, xoffset_optimum, yoffset_optimum, +; max_corr, edge, plateau, [XOFF_INIT=, YOFF_INIT=, REDUCTION=, +; MAGNIFICATION=, PLATEAU_THRESH=, /PRINT] +; +; INPUTS: +; correl_mat = the cross-correlation matrix of 2 images. +; (as computed by function CORREL_IMAGES( imA, imB ) ). +; +; NOTE: +; If correl_mat(*,*,1) is the number of pixels for each correlation, +; (the case when /NUMPIX was specified in call to CORREL_IMAGES) +; then sqrt( sqrt( # pixels )) is used as correlation weighting factor. +; +; OPTIONAL INPUT KEYWORDS: +; XOFF_INIT = initial X pixel offset of image_B relative to image_A. +; YOFF_INIT = Y pixel offset, (both as specified to correl_images). +; REDUCTION = reduction factor used in call to CORREL_IMAGES. +; MAGNIFICATION = magnification factor used in call to CORREL_IMAGES, +; this allows determination of offsets up to fractions of a pixel. +; PLATEAU_THRESH = threshold used for detecting plateaus in +; the cross-correlation matrix near maximum, (default=0.01), +; used only if MAGNIFICATION > 1 +; /PRINT causes the result of analysis to be printed. +; +; OUTPUTS: +; xoffset_optimum = optimal X pixel offset of image_B relative to image_A. +; yoffset_optimum = optimal Y pixel offset. +; max_corr = the maximal correlation corresponding to optimal offset. +; edge = 1 if maximum is at edge of correlation domain, otherwise=0. +; plateau = 1 if maximum is in a plateau of correlation function, else=0. +; +; PROCEDURE: +; Find point of maximum cross-correlation and calc. corresponding offsets. +; If MAGNIFICATION > 1: +; the correl_mat is checked for plateau near maximum, and if found, +; the center of plateau is taken as point of maximum cross-correlation. +; +; MODIFICATION HISTORY: +; Written, July-1991, Frank Varosi, STX @ NASA/GSFC +; Use ROUND instead of NINT, June 1995 Wayne Landsman HSTX +; Remove use of non-standard !DEBUG system variable W.L. HSTX +; Converted to IDL V5.0 W. Landsman September 1997 +;- + scm = size( correl_mat ) + + if (scm[0] LT 2) then begin + message,"first argument must be at least 2-D matrix",/INFO,/CON + return + endif + + Nx = scm[1] + Ny = scm[2] + x_shift = Nx/2 + y_shift = Ny/2 + if N_elements( xoff_init ) NE 1 then xoff_init=0 + if N_elements( yoff_init ) NE 1 then yoff_init=0 + + if (scm[0] GE 3) then begin ;weight by # of overlap pixels: + + Npix_mat = correl_mat[*,*,1] + Maxpix = max( Npix_mat ) + corr_mat = correl_mat[*,*,0] * sqrt( sqrt( Npix_mat/Maxpix ) ) + + endif else corr_mat = correl_mat + + max_corr = max( corr_mat, maxLoc ) + xi = (maxLoc MOD Nx) + yi = (maxLoc/Nx) + + if N_elements( Magf ) NE 1 then Magf=1 + if N_elements( reducf ) NE 1 then reducf=1 + if N_elements( plateau_thresh ) NE 1 then plateau_thresh=0.01 + plateau=0 + edge=0 + + if ( reducf GT 1 ) then begin + + xoffset_optimum = ( xi - x_shift + xoff_init/reducf ) * reducf + yoffset_optimum = ( yi - y_shift + yoff_init/reducf ) * reducf + xoffset_optimum = round( xoffset_optimum ) + yoffset_optimum = round( yoffset_optimum ) + format = "(2i5)" + + endif else if ( Magf GT 1 ) then begin + + w = where( (max_corr - corr_mat) LE plateau_thresh, Npl ) + + if (Npl GT 1) then begin + + wx = [ w MOD Nx ] + wy = [ w/Nx ] + wxmin = min( wx ) + wymin = min( wy ) + wxmax = max( wx ) + wymax = max( wy ) + npix = (wxmax - wxmin)+(wymax - wymin) + + if (Npl GE npix) AND $ + (xi GE wxmin) AND (xi LE wxmax) AND $ + (yi GE wymin) AND (yi LE wymax) then begin + plateau=1 + xi = wxmin + (wxmax - wxmin)/2. + yi = wymin + (wymax - wymin)/2. + max_corr = corr_mat[xi,yi] + endif + endif + + xoffset_optimum = xoff_init + float( xi - x_shift )/Magf + yoffset_optimum = yoff_init + float( yi - y_shift )/Magf + format = "(2f9.3)" + + endif else begin + xoffset_optimum = xi - x_shift + round( xoff_init ) + yoffset_optimum = yi - y_shift + round( yoff_init ) + format = "(2i5)" + endelse + + if (xi EQ 0) OR (xi EQ Nx-1) OR $ + (yi EQ 0) OR (yi EQ Ny-1) then edge=1 + + if keyword_set( print ) then begin + + mincm = min( corr_mat, minLoc ) + + if (scm[0] GE 3) then begin + xm = (minLoc MOD Nx) + ym = (minLoc/Nx) + Npixmin = Long( Npix_mat[xm,ym] ) * reducf * reducf + Npixmax = Long( Npix_mat[xi,yi] ) * reducf * reducf + info_min = " ( " + strtrim( Npixmin, 2 ) + " pixels )" + info_max = " ( " + strtrim( Npixmax, 2 ) + " pixels )" + endif else begin + info_min = "" + info_max = "" + endelse + + print," min Correlation = ", strtrim( mincm, 2 ), info_min + print," MAX Correlation = ", strtrim( max_corr, 2 ), info_max,$ + " at (x,y) offset:", $ + string( [ xoffset_optimum, yoffset_optimum ], FORM=format ) + + if (plateau) then begin + print," plateau of MAX Correlation:" + print," (Correl - MAX + " + $ + string( plateau_thresh, FORM="(F5.3)" ) + ") > 0" + print,(corr_mat - max(corr_mat) + plateau_thresh) > 0 + endif + + if (edge) then begin + print," Maximum is at EDGE of shift range, " + $ + "result is inconclusive" + print," try larger shift or new starting offset" + endif + endif + +return +end diff --git a/modules/idl_downloads/astro/pro/cosmo_param.pro b/modules/idl_downloads/astro/pro/cosmo_param.pro new file mode 100644 index 0000000..4472c9d --- /dev/null +++ b/modules/idl_downloads/astro/pro/cosmo_param.pro @@ -0,0 +1,106 @@ +pro cosmo_param,Omega_m, Omega_Lambda, Omega_k, q0 +;+ +; NAME: +; COSMO_PARAM +; PURPOSE: +; Derive full set of cosmological density parameters from a partial set +; EXPLANATION: +; This procedure is called by LUMDIST and GALAGE to allow the user a choice +; in defining any two of four cosmological density parameters. +; +; Given any two of the four input parameters -- (1) the normalized matter +; density Omega_m (2) the normalized cosmological constant, Omega_lambda +; (3) the normalized curvature term, Omega_k and (4) the deceleration +; parameter q0 -- this program will derive the remaining two. Here +; "normalized" means divided by the closure density so that +; Omega_m + Omega_lambda + Omega_k = 1. For a more +; precise definition see Carroll, Press, & Turner (1992, ArAA, 30, 499). +; +; If less than two parameters are defined, this procedure sets default +; values of Omega_k=0 (flat space), Omega_lambda = 0.7, Omega_m = 0.3 +; and q0 = -0.55 +; CALLING SEQUENCE: +; COSMO_PARAM, Omega_m, Omega_lambda, Omega_k, q0 +; +; INPUT-OUTPUTS: +; Omega_M - normalized matter energy density, non-negative numeric scalar +; Omega_Lambda - Normalized cosmological constant, numeric scalar +; Omega_k - normalized curvature parameter, numeric scalar. This is zero +; for a flat universe +; q0 - Deceleration parameter, numeric scalar = -R*(R'')/(R')^2 +; = 0.5*Omega_m - Omega_lambda +; NOTES: +; If more than two parameters are defined upon input (overspecification), +; then the first two defined parameters in the ordered list Omega_m, +; Omega_lambda, Omega_k, q0 are used to define the cosmology. +; EXAMPLE: +; Suppose one has Omega_m = 0.3, and Omega_k = 0.5 then to determine +; Omega_lambda and q0 +; +; IDL> cosmo_param, 0.3, omega_lambda, 0.5, q0 +; +; which will return omega_lambda = 0.2 and q0 = -2.45 +; REVISION HISTORY: +; W. Landsman Raytheon ITSS April 2000 +; Better Error checking W. Landsman/D. Syphers October 2010 +;- + + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - COSMO_PARAM, Omega_m, Omega_lambda, Omega_k, q0' + return + endif + + Nk = n_elements(Omega_k) < 1 + NLambda = N_elements(Omega_lambda) < 1 + Nomega = N_elements(Omega_m) < 1 + Nq0 = N_elements(q0) < 1 + +; Use must specify 0 or 2 parameters + + if total(Nk + Nlambda + Nomega + Nq0,/int) EQ 1 then $ + message,'ERROR - At least 2 cosmological parameters must be specified' + +; Check which two parameters are defined, and then determine the other two + + if (Nomega and Nlambda) then begin + if Nk EQ 0 then Omega_k = 1 - omega_m - Omega_lambda + if Nq0 EQ 0 then q0 = omega_m/2. - Omega_lambda + endif else $ + + if (Nomega and Nk) then begin + if Nlambda EQ 0 then Omega_lambda = 1. -omega_m - Omega_k + if Nq0 EQ 0 then q0 = -1 + Omega_k + 3*Omega_m/2 + endif else $ + + if (Nlambda and Nk) then begin + if Nomega EQ 0 then omega_m = 1.-Omega_lambda - Omega_k + if Nq0 EQ 0 then q0 = (1 - Omega_k - 3.*Omega_lambda)/2. + endif else $ + + if (Nomega and Nq0) then begin + if Nk EQ 0 then Omega_k = 1 + q0 - 3*omega_m/2. + if Nlambda EQ 0 then Omega_lambda = 1. - omega_m - Omega_k + endif else $ + + if (Nlambda and Nq0) then begin + if Nk EQ 0 then Omega_k = 1 - 2*q0 - 3*Omega_lambda + if Nomega EQ 0 then omega_m = 1.-Omega_lambda - Omega_k + endif else $ + + if (Nk and Nq0) then begin + if Nomega EQ 0 then omega_m = (1 + q0 - Omega_k)*2/3. + if Nlambda EQ 0 then Omega_lambda = 1. - omega_m - Omega_k + endif + +;Set default values + + if N_elements(Omega_k) EQ 0 then Omega_k = 0 ;Default is flat space + if N_elements(Omega_lambda) EQ 0 then Omega_lambda = 0.7 + if N_elements(omega_m) EQ 0 then omega_m = 1 - Omega_lambda + if N_elements(q0) EQ 0 then q0 = (1 - Omega_k - 3*Omega_lambda)/2. + + return + end diff --git a/modules/idl_downloads/astro/pro/cr_reject.pro b/modules/idl_downloads/astro/pro/cr_reject.pro new file mode 100644 index 0000000..ec0e315 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cr_reject.pro @@ -0,0 +1,886 @@ +PRO cr_reject, input_cube, rd_noise_dn, dark_dn, gain, mult_noise, $ + combined_image, combined_noise, combined_npix, $ + MASK_CUBE=mask_cube, NOISE_CUBE=noise_cube, $ + NSIG=nsig, MEDIAN_LOOP=median_loop, MEAN_LOOP=mean_loop, $ + MINIMUM_LOOP=minimum_loop, INIT_MED=init_med, $ + INIT_MIN=init_min, INIT_MEAN=init_mean, EXPTIME=exptime,$ + BIAS=bias, VERBOSE=verbose, $ + TRACKING_SET=tracking_set, DILATION=dilation, DFACTOR=dfactor, $ + NOSKYADJUST=noskyadjust,NOCLEARMASK=noclearmask, $ + XMEDSKY=xmedsky, RESTORE_SKY=restore_sky, $ + SKYVALS=skyvals, NULL_VALUE=null_value, $ + INPUT_MASK=input_mask, WEIGHTING=weighting, SKYBOX=skybox +;+ +; NAME: +; CR_REJECT +; +; PURPOSE: +; General, iterative cosmic ray rejection using two or more input images. +; +; EXPLANATION: +; Uses a noise model input by the user, rather than +; determining noise empirically from the images themselves. +; +; The image returned has the combined exposure time of all the input +; images, unless the bias flag is set, in which case the mean is +; returned. This image is computed by summation (or taking mean) +; regardless of loop and initialization options (see below). +; +; CALLING SEQUENCE: +; cr_reject, input_cube, rd_noise_dn, dark_dn, gain, mult_noise, $ +; combined_image, combined_npix, combined_noise +; +; MODIFIED ARGUMENT: +; input_cube - Cube in which each plane is an input image. +; If the noise model is used (rd_noise_dn, dark_dn, +; gain), then input_cube must be in units of DN. +; If an input noise cube is supplied (rd_noise_dn +; <0), then the units of input_cube and noise_cube +; merely need to be consistent. +; +; This array is used as a buffer and its contents +; are not guaranteed on output (although for now, +; weighting=0 with /restore_sky should give you back +; your input unaltered). +; +; INPUT ARGUMENTS: +; rd_noise_dn - Read noise per pixel. Units are DN. +; If negative, then the user supplies an error cube +; via the keyword noise_cube. In the latter case, +; mult_noise still applies, since it is basically a fudge. +; dark_dn - Dark rate in DN per pixel per s. This can be a scalar, +; or it can be a dark image divided by the exposure +; time. +; gain - Electrons per DN. +; mult_noise - Coefficient for multiplicative noise term -- helps +; account for differing PSFs or subpixel image shifts. +; +; INPUT KEYWORDS: +; exptime - If the images have different exposure times, pass +; them in a vector. You can leave this off for +; frames with the same exposure time, but dark counts +; won't be treated correctly. +; verbose - If set, lots of output. +; nsig - Rejection limit in units of pixel-to-pixel noise +; (sigma) on each input image. Can be specified as +; an array, in which case the dimension gives the +; maximum number of iterations to run. (Default = +; [8, 6, 4] +; dilation - With dfactor, provides functionality similar to the +; expansion of the CR with pfactor and radius in STSDAS +; crrej. Dilate gives the size of the border to be +; tested around each initially detected CR pixel. +; E.g., dilate=1 searches a 9 X 9 area centered on the +; original pixel. If dfactor is set, the default is 1. +; dfactor - See dilation. This parameter is equivalent to pfactor +; in STSDAS crrej. The current threshold for rejection +; is multiplied by this factor when doing the search +; with the dilated mask. If dilation is set, the default +; for this parameter is 0.5. +; bias - Set if combining biases (divides through by number +; of images at end, since exposure time is 0). +; tracking_set - Subscripts of pixels to be followed through the +; computation. +; noskyadjust - Sky not to be subtracted before rejection tests. Default +; is to do the subtraction. +; xmedsky - Flag. If set, the sky is computed as a 1-d array +; which is a column-by-column median. This is intended +; for STIS slitless spectra. If sky adjustment is +; disabled, this keyword has no effect. +; input_mask - Mask cube input by the user. Should be byte data +; because it's boolean. 1 means use the pixel, +; and 0 means reject the pixel - these rejections +; are in addition to those done by the CR rejection +; algorithm as such. +; +; The following keywords control how the current guess at a CR-free +; "check image" is recomputed on each iteration: +; +; median_loop - If set, the check image for each iteration is +; the pixel-by-pixel median. THE MEAN IS +; RETURNED in combined_image even if you set +; this option. (Default is mean_loop.) +; minimum_loop - If set, the check image for each iteration is +; the pixel-by-pixel minimum. THE MEAN IS +; RETURNED in combined_image even if you set +; this option. (Default is mean_loop.) +; mean_loop - If set, the check image for each iteration is +; the pixel-by-pixel mean. (Same as the default.) +; noclearmask - By default, the mask of CR flags is reset before +; every iteration, and a pixel that has been +; rejected has a chance to get back in the game +; if the average migrates toward its value. If this +; keyword is set, then any rejected pixel stays +; rejected in subsequent iterations. Note that what +; stsdas.hst_calib.wfpc.crrej does is the same +; as the default. For this procedure, the default +; was NOT to clear the flags, until 20 Oct. 1997. +; restore_sky - Flag. If set, the routine adds the sky back into +; input_cube before returning. Works only if +; weighting=0. +; null_value - Value to be used for output pixels to which no +; input pixels contribute. Default=0 +; weighting - Selects weighting scheme in final image +; combination: +; 0 (default) - Poissonian weighting - co-add +; detected DN from non-CR pixels. (Pixel-by- +; pixel scaling up to total exposure time, +; for pixels in stack where some rejected.) +; Equivalent to exptime weighting of rates. +; 1 or more - Sky and read noise weighting of rates. +; Computed as weighted average of DN rates, +; with total exp time multiplied back in +; afterward. +; +; In all cases, the image is returned as a sum in +; DN with the total exposure time of the image +; stack, and with total sky added back in. +; +; The following keywords allow the initial guess at a CR-free "check +; image" to be of a different kind from the iterative guesses: +; +; init_med - If set, the initial check image is +; the pixel-by-pixel median. (Not permitted if +; input_cube has fewer than 3 planes; default is minimum.) +; init_mean - If set, the initial check image is +; the pixel-by-pixel mean. (Default is minimum.) +; init_min - If set, the initial check image is +; the pixel-by-pixel minimum. (Same as the default.) +; +; OUTPUT ARGUMENTS:: +; combined_image - Mean image with CRs removed. +; combined_npix - Byte (or integer) image of same dimensions as +; combined_image, with each element containing +; the number of non-CR stacked pixels that +; went into the result. +; combined_noise - Noise in combined image according to noise model +; or supplied noise cube. +; +; OUTPUT KEYWORDS: +; mask_cube - CR masks for each input image. 1 means +; good pixel; 0 means CR pixel. +; skyvals - Sky value array. For an image cube with N planes, +; this array is fltarr(N) if the sky is a scalar per +; image plane, and fltarr(XDIM, N), is the XMEDSKY +; is set. +; +; INPUT/OUTPUT KEYWORD: +; noise_cube - Estimated noise in each pixel of input_cube as +; returned (if rd_noise_dn ge 0), or input noise +; per pixel of image_cube (if rd_noise_dn lt 0). +; skybox - X0, X1, Y0, Y1 bounds of image section used +; to compute sky. If supplied by user, this +; region is used. If not supplied, the +; image bounds are returned. This parameter might +; be used (for instance) if the imaging area +; doesn't include the whole chip. +; +; COMMON BLOCKS: none +; +; SIDE EFFECTS: none +; +; METHOD: +; +; COMPARISON WITH STSDAS +; +; Cr_reject emulates the crrej routine in stsdas.hst_calib.wfpc. +; The two routines have been verified to give identical results +; (except for some pixels along the edge of the image) under the +; following conditions: +; +; no sky adjustment +; no dilation of CRs +; initialization of trial image with minimum +; taking mean for each trial image after first (no choice +; in crrej) +; +; Dilation introduces a difference between crrej and this routine +; around the very edge of the image, because the IDL mask +; manipulation routines don't handle the edge the same way as crrej +; does. Away from the edge, crrej and cr_reject are the same with +; respect to dilation. +; +; The main difference between crrej and cr_reject is in the sky +; computation. Cr_reject does a DAOPHOT I sky computation on a +; subset of pixels grabbed from the image, whereas crrej searches +; for a histogram mode. +; +; REMARKS ON USAGE +; +; The default is that the initial guess at a CR-free image is the +; pixel-by-pixel minimum of all the input images. The pixels +; cut from each component image are the ones more than nsig(0) sigma +; from this minimum image. The next iteration is based on the +; mean of the cleaned-up component images, and the cut is taken +; at nsig(1) sigma. The next iteration is also based on the mean with +; the cut taken at nsig(2) sigma. +; +; The user can specify an arbitrary sequence of sigma cuts, e.g., +; nsig=[6,2] or nsig=[10,9,8,7]. The user can also specify that +; the initial guess is the median (/init_med) rather than the +; minimum, or even the mean. The iterated cleaned_up images after +; the first guess can be computed as the mean or the median +; (/mean_loop or /median_loop). The minimum_loop option is also +; specified, but this is a trivial case, and you wouldn't want +; to use it except perhaps for testing. +; +; The routine takes into account exposure time if you want it to, +; i.e., if the pieces of the CR-split aren't exactly the same. +; For bias frames (exposure time 0), set /bias to return the mean +; rather than the total of the cleaned-up component images. +; +; The crrej pfactor and radius to propagate the detected CRs +; outward from their initial locations have been implemented +; in slightly different form using the IDL DILATE function. +; +; It is possible to end up with output pixels to which no valid +; input pixels contribute. These end up with the value +; NULL_VALUE, and the corresponding pixels of combined_npix are +; also returned as 0. This result can occur when the pixel is +; very noisy across the whole image stack, i.e., if all the +; values are, at any step of the process, far from the stack +; average at that position even after rejecting the real +; outliers. Because pixels are flagged symmetrically N sigma +; above and below the current combined image (see code), all +; the pixels at a given position can end up getting flagged. +; (At least, that's how I think it happens.) +; +; MODIFICATION HISTORY: +; 5 Mar. 1997 - Written. R. S. Hill +; 14 Mar. 1997 - Changed to masking approach to keep better +; statistics and return CR-affected pixels to user. +; Option to track subset of pixels added. +; Dilation of initially detected CRs added. +; Other small changes. RSH +; 17 Mar. 1997 - Arglist and treatment of exposure times fiddled +; to mesh better with stis_cr. RSH +; 25 Mar. 1997 - Fixed bug if dilation finds nothing. RSH +; 4 Apr. 1997 - Changed name to cr_reject. RSH +; 15 Apr. 1997 - Restyled with emacs, nothing else done. RSH +; 18 Jun. 1997 - Input noise cube allowed. RSH +; 19 Jun. 1997 - Multiplicative noise deleted from final error. RSH +; 20 Jun. 1997 - Fixed error in using input noise cube. RSH +; 12 July 1997 - Sky adjustment option. RSH +; 27 Aug. 1997 - Dilation kernel made round, not square, and +; floating-point radius allowed. RSH +; 16 Sep. 1997 - Clearmask added. Intermediate as well as final +; mean is exptime weighted. RSH +; 17 Sep. 1997 - Redundant zeroes around dilation kernel trimmed. RSH +; 1 Oct. 1997 - Bugfix in preceding. RSH +; 21 Oct. 1997 - Clearmask changed to noclearmask. Bug in robust +; array division fixed (misplaced parens). Sky as +; a function of X (option). RSH +; 30 Jan. 1998 - Restore_sky keyword added. RSH +; 5 Feb. 1998 - Quick help corrected and updated. RSH +; 6 Feb. 1998 - Fixed bug in execution sequence for tracking_set +; option. RSH +; 18 Mar. 1998 - Eliminated confusing maxiter spec. Added +; null_value keyword. RSH +; 15 May 1998 - Input_mask keyword. RSH +; 27 May 1998 - Initialization of minimum image corrected. NRC, RSH +; 9 June 1998 - Input mask cube processing corrected. RSH +; 21 Sep. 1998 - Weighting keyword added. RSH +; 7 Oct. 1998 - Fixed bug in input_mask processing (introduced +; in preceding update). Input_mask passed to +; skyadj_cube. RSH +; 5 Mar. 1999 - Force init_min for 2 planes. RSH +; 1 Oct. 1999 - Make sure weighting=1 not given with noise cube. RSH +; 1 Dec. 1999 - Corrections to doc; restore_sky needs weighting=0. RSH +; 17 Mar. 2000 - SKYBOX added. RSH +;- +on_error,0 +IF n_params(0) LT 6 THEN BEGIN + print,'CALLING SEQUENCE: cr_reject, input_cube, rd_noise_dn, $' + print,' dark_dn, gain, mult_noise, combined_image, combined_noise, $' + print,' combined_npix' + print,'KEYWORD PARAMETERS: nsig, exptime, bias, verbose,' + print,' tracking_set, median_loop, mean_loop, minimum_loop, ' + print,' init_med, init_mean, init_min,' + print,' mask_cube, noise_cube, dilation, dfactor, noclearmask, ' + print,' noskyadjust, xmedsky, restore_sky, skyvals, null_value' + print,' input_mask, weighting, skybox' + return +ENDIF + +verbose = keyword_set(verbose) +xmed = keyword_set(xmedsky) + +track = n_elements(tracking_set) GT 0 + +sz = size(input_cube) +IF sz[0] NE 3 THEN BEGIN + print,'CR_REJECT: Input cube must have 3 dimensions.' + return +ENDIF + +IF n_elements(input_mask) GT 0 THEN BEGIN + szinpm = size(input_mask) + wsz = where(szinpm[0:3] NE sz[0:3], cwsz) + IF cwsz GT 0 THEN BEGIN + print,'CR_REJECT: INPUT_MASK must be same size as IMAGE_CUBE.' + return + ENDIF ELSE BEGIN + IF verbose THEN print,'CR_REJECT: Using INPUT_MASK.' + ENDELSE + use_input_mask = 1b +ENDIF ELSE BEGIN + use_input_mask = 0b +ENDELSE + +xdim = sz[1] +ydim = sz[2] +nimg = sz[3] +npix = xdim*ydim + +usemedian = keyword_set(median_loop) +usemean = keyword_set(mean_loop) +usemin = keyword_set(minimum_loop) +IF (usemean + usemedian + usemin) GT 1 THEN BEGIN + print,'CR_REJECT: Specify only one of MEDIAN_LOOP, MEAN_LOOP' $ + + ', or MINIMUM_LOOP' + return +ENDIF +IF (usemean + usemedian + usemin) EQ 0 THEN BEGIN + usemean = 1 +ENDIF + +inimed = keyword_set(init_med) +inimean = keyword_set(init_mean) +inimin = keyword_set(init_min) +IF (inimean + inimed + inimin) GT 1 THEN BEGIN + print,'CR_REJECT: Specify only one of INIT_MED, INIT_MEAN,' $ + + ' or INIT_MIN.' + return +ENDIF +IF (inimean + inimed + inimin) EQ 0 THEN BEGIN + inimin = 1 +ENDIF +IF nimg LT 3 AND inimed THEN BEGIN + inimed = 0 + inimin = 1 + IF verbose THEN BEGIN + print,'CR_REJECT: INIT_MED only permitted for 3 or more ' $ + + 'images.' + print,' Forcing INIT_MIN.' + ENDIF +ENDIF + +; +; Accumulation mode for bad pixels. +; +IF keyword_set(noclearmask) THEN BEGIN + clearmask = 0b + IF verbose THEN print,'CR_REJECT: CR flags accumulate strictly.' +ENDIF ELSE BEGIN + clearmask = 1b + IF verbose THEN print,'CR_REJECT: CR flags cleared between iterations.' +ENDELSE +; +; Default iterations. +; +IF (n_elements(nsig) LT 1) THEN BEGIN + nsig = [8, 6, 4] +ENDIF +sig_limit = nsig +maxiter = n_elements(nsig) +IF n_elements(null_value) LT 1 THEN null_value=0 +IF verbose THEN BEGIN + print,'CR_REJECT: Iteration spec: ' + print,' nsig = ',nsig + print,' maxiter = ',maxiter + print,' null_value = ',null_value +ENDIF +; +IF n_elements(exptime) NE 0 THEN BEGIN + IF n_elements(exptime) NE nimg THEN BEGIN + print,'CR_REJECT: EXPTIME must have one element per input image.' + return + ENDIF + zexp = 0b + FOR i=0,nimg-1 DO zexp = zexp OR (exptime[i] LE 0.0) + IF zexp THEN BEGIN + save_expt = exptime + exptime = make_array(nimg, value=1.0) + IF verbose THEN print, $ + 'CR_REJECT: All exposure times <= 0.' + ENDIF +ENDIF ELSE BEGIN + zexp = 1b + save_expt = make_array(nimg, value=0.0) + exptime = make_array(nimg, value=1.0) +ENDELSE +etot = total(exptime) + +IF n_elements(weighting) GT 0 THEN BEGIN + wgt = weighting + wgt = round(wgt) + IF wgt ne 0 and wgt ne 1 THEN BEGIN + print, 'CR_REJECT: Weighting must be 0 or 1' + print,' Executing return' + return + ENDIF +ENDIF ELSE BEGIN + wgt = 0 +ENDELSE + +IF verbose THEN BEGIN + print,'CR_REJECT: gain = ',gain + IF n_elements(dark_dn) EQ 1 THEN BEGIN + print,' dark rate = ',dark_dn + ENDIF ELSE BEGIN + print,' dark image supplied ' + ENDELSE + print,' read noise = ',rd_noise_dn + print,' multiplicative noise coefficient = ',mult_noise + print,' number of images = ',nimg + print,' exposure times: ' + print,exptime + print,' total exposure time = ',etot + CASE wgt OF + 0: print,' flux to be co-added' + 1: print,' weighting of rate by sky and read noise' + ENDCASE +ENDIF + +; +; Process dilation specs +; +IF keyword_set(dilation) OR keyword_set(dfactor) THEN BEGIN + do_dilation = 1b + IF n_elements(dilation) LT 1 THEN dilation = 1 + IF n_elements(dfactor) LT 1 THEN dfactor = 0.5 + IF (dilation LE 0) OR (dfactor LE 0) THEN BEGIN + print,'CR_REJECT: Dilation specs not valid: ' + print,' dilation = ',dilation + print,' dfactor = ',dfactor + return + ENDIF + kdim = 1 + 2*floor(dilation+1.e-4) + kernel = make_array(kdim, kdim, value=1b) + half_kern = fix(kdim/2) + wkz = where(shift(dist(kdim),half_kern,half_kern) $ + GT (dilation+0.0001), ckz) + IF ckz GT 0 THEN kernel[wkz] = 0b + IF verbose THEN BEGIN + print,'CR_REJECT: Dilation will be done. Specs:' + print,' dilation = ',dilation + print,' dfactor = ',dfactor + print,' kernel = ' + print,kernel + ENDIF +ENDIF ELSE BEGIN + do_dilation = 0b + IF verbose THEN print,'CR_REJECT: Mask dilation will not be done.' +ENDELSE + + +IF verbose THEN print,'CR_REJECT: Initializing noise and mask cube.' +IF rd_noise_dn GE 0 THEN BEGIN + IF verbose THEN print,'CR_REJECT: Noise cube computed.' + supplied = 0b + noise_cube = 0.0*input_cube + FOR i=0, nimg-1 DO BEGIN + noise_cube[0,0,i] = sqrt((rd_noise_dn^2 $ + + ((input_cube[*,*,i] $ + + dark_dn*exptime[i])>0)/gain) > 0.0) + ENDFOR +ENDIF ELSE BEGIN + IF verbose THEN print,'CR_REJECT: Noise cube supplied.' + supplied = 1b + IF wgt EQ 1 THEN BEGIN + print, 'CR_REJECT: WEIGHTING=1 incompatible with supplying ', $ + 'noise cube.' + print, ' Executing return.' + return + ENDIF +ENDELSE +; +; Mask flags CR with zeroes +; +mask_cube = make_array(xdim, ydim, nimg, value=1B) +IF nimg LE 255 THEN ivalue=byte(nimg) ELSE ivalue=fix(nimg) +combined_npix = make_array(xdim, ydim, value=ivalue) + +IF keyword_set(noskyadjust) THEN BEGIN + skyvals = fltarr(nimg) + totsky = 0 +ENDIF ELSE BEGIN + IF verbose THEN print,'CR_REJECT: Sky adjustment being made.' + skyadj_cube, input_cube, skyvals, totsky, $ + verbose=verbose, xmedsky=xmed, input_mask=input_mask, $ + region=skybox +ENDELSE + +IF verbose THEN print,'CR_REJECT: Scaling by exposure time.' + +FOR i=0,nimg-1 DO BEGIN + input_cube[0,0,i] = input_cube[*,*,i]/exptime[i] + noise_cube[0,0,i] = noise_cube[*,*,i]/exptime[i] +ENDFOR + +; +; Initialization of main loop. +; +ncut_tot = lonarr(nimg) +cr_subs = lonarr(npix) +IF inimin OR usemin THEN flagval = max(input_cube)+1 +IF inimed THEN BEGIN + IF verbose THEN print,'CR_REJECT: Initializing with median.' + IF use_input_mask THEN BEGIN + medarr,input_cube,combined_image,input_mask + ENDIF ELSE BEGIN + medarr,input_cube,combined_image + ENDELSE +ENDIF ELSE IF inimean THEN BEGIN + IF verbose THEN print,'CR_REJECT: Initializing with mean.' + IF use_input_mask THEN BEGIN + tm = total(input_mask,3) > 1e-6 + combined_image = total(input_cube*input_mask,3)/tm + wz = where(temporary(tm) le 0.001, cwz) + IF cwz GT 0 THEN $ + combined_image[temporary(wz)] = 0 + ENDIF ELSE BEGIN + combined_image = total(input_cube,3)/nimg + ENDELSE +ENDIF ELSE IF inimin THEN BEGIN + IF verbose THEN print,'CR_REJECT: Initializing with minimum.' + IF use_input_mask THEN BEGIN + combined_image = make_array(xdim,ydim,value=flagval) + FOR i=0, nimg-1 DO BEGIN + indx = where(input_mask[*,*,i] gt 0, cindx) + IF cindx GT 0 THEN $ + combined_image[indx] = $ + (combined_image < input_cube[*,*,i])[indx] + ENDFOR + wf = where(combined_image EQ flagval, cf) + IF cf GT 0 THEN combined_image[wf] = null_value + ENDIF ELSE BEGIN + combined_image = input_cube[*,*,0] + FOR i=1, nimg-1 DO BEGIN + combined_image = (combined_image < input_cube[*,*,i]) + ENDFOR + ENDELSE +ENDIF ELSE BEGIN + print,'CR_REJECT: Logic error in program initializing check image.' + return +ENDELSE +; +; ---------------- MAIN CR REJECTION LOOP. ------------------ +; +iter=0 +main_loop: +iter=iter+1 + +IF clearmask THEN mask_cube[*]=1b + +IF track THEN BEGIN + print,'CR_REJECT: Tracking. Iter = ',strtrim(iter,2) + print,' Combined_image: ' + print,combined_image[tracking_set] + FOR i = 0, nimg-1 DO BEGIN + print,' Image ', strtrim(i,2), ':' + print,(input_cube[*,*,i])[tracking_set] + print,' Noise ', strtrim(i,2), ':' + print,(noise_cube[*,*,i])[tracking_set] + print,' Mask ', strtrim(i,2), ':' + print,(mask_cube[*,*,i])[tracking_set] + ENDFOR +ENDIF +IF verbose THEN BEGIN + print,'CR_REJECT: Beginning iteration number ',strtrim(iter,2) + print,' Sigma limit = ',sig_limit[iter-1] +ENDIF + +FOR i=0, nimg-1 DO BEGIN + + skyarray = fltarr(xdim, ydim) + IF xmed THEN BEGIN + FOR jl = 0,ydim-1 DO skyarray[0,jl] = skyvals[*,i] + ENDIF ELSE BEGIN + skyarray[*] = skyvals[i] + ENDELSE + model_image = $ + (temporary(skyarray) + (combined_image + dark_dn)*exptime[i])>0 + + IF supplied THEN BEGIN + current_var = noise_cube[*,*,i]^2 $ + + ((mult_noise*temporary(model_image))/exptime[i])^2 + ENDIF ELSE BEGIN + current_var = (rd_noise_dn^2 + model_image/gain $ + + (mult_noise*temporary(model_image))^2) $ + / (exptime[i]^2) + ENDELSE + + IF track THEN BEGIN + print,'CR_REJECT: Tracking. Iter = ',strtrim(iter,2), $ + ' Image = ',strtrim(i,2) + print,' Current_var: ' + print,current_var[tracking_set] + ENDIF + + testnoise = sig_limit[iter-1] * sqrt(temporary(current_var)) + + IF track THEN BEGIN + print,' Testnoise: ' + print,testnoise[tracking_set] + ENDIF +; +; Absolute value used so that if you remove too much, at least you +; won't introduce a new bias. +; + cr_subs[0] = $ + where(abs(input_cube[*,*,i] - combined_image) $ + GT testnoise, count) + IF count GT 0 THEN BEGIN + mask_cube[i*npix + cr_subs[0:count-1]] $ + = replicate(0b,count) + ENDIF + IF verbose THEN print,'CR_REJECT: ',strtrim(count,2), $ + ' pixels flagged in image ',strtrim(i,2) + +; +; Dilation of mask +; + count2 = 0 + IF do_dilation THEN BEGIN + tempw = where(dilate(1b-mask_cube[*,*,i], kernel),dct) + IF dct GT 0 THEN BEGIN + ic1 = input_cube[npix*i + tempw] + tn1 = testnoise[tempw] + cmi = combined_image[tempw] + tewsub = where(abs(temporary(ic1) $ + - temporary(cmi)) $ + GT (dfactor*temporary(tn1)), count2) + cr_subs[0] = (temporary(tempw))[temporary(tewsub)>0] + IF count2 GT 0 THEN BEGIN + mask_cube[i*npix + cr_subs[0:count2-1]] $ + = replicate(0b,count2) + ENDIF + ENDIF + IF verbose THEN print,'CR_REJECT: Mask dilation performed. ', $ + strtrim(count2,2), ' pixels flagged in image ',strtrim(i,2) + ENDIF +ENDFOR + +FOR i=0, nimg-1 DO BEGIN + cr_subs[0] = where(1b-mask_cube[*,*,i],count) +; IF verbose THEN print,'CR_REJECT: ',strtrim(count,2), $ +; ' accumulated flags in image ',strtrim(i,2) +; IF count GT 0 THEN BEGIN +; input_cube(i*npix + cr_subs(0:count-1)) $ +; = combined_image(cr_subs(0:count-1)) +; noise_cube(i*npix + cr_subs(0:count-1)) $ +; = sqrt(current_var(cr_subs(0:count-1))) +; ENDIF +ENDFOR + +IF use_input_mask THEN BEGIN + combined_npix[0,0] = total((mask_cube AND input_mask),3) +ENDIF ELSE BEGIN + combined_npix[0,0] = total(mask_cube,3) +ENDELSE +; +; Loop termination condition. +; +IF (iter GE maxiter) THEN GOTO,end_main_loop + +IF usemedian THEN BEGIN + IF verbose THEN print,'CR_REJECT: Taking median.' + IF use_input_mask THEN BEGIN + medarr,input_cube,combined_image,mask_cube AND input_mask + ENDIF ELSE BEGIN + medarr,input_cube,combined_image,mask_cube + ENDELSE +ENDIF ELSE IF usemean THEN BEGIN + IF verbose THEN print,'CR_REJECT: Taking mean.' + IF use_input_mask THEN BEGIN + maskprod = input_mask[*,*,0] AND mask_cube[*,*,0] + combined_image = input_cube[*,*,0]*maskprod*exptime[0] + combined_expt = temporary(maskprod)*exptime[0] + IF nimg GT 1 THEN BEGIN + FOR i=1,nimg-1 DO BEGIN + maskprod = input_mask[*,*,i] AND mask_cube[*,*,i] + combined_image = combined_image $ + + input_cube[*,*,i]*maskprod*exptime[i] + combined_expt = combined_expt $ + + temporary(maskprod)*exptime[i] + ENDFOR + ENDIF + wexpt0 = where(combined_expt LE 0,cexpt0) + combined_image = combined_image / (combined_expt>1e-6) + IF cexpt0 GT 0 THEN combined_image[wexpt0] = 0 + ENDIF ELSE BEGIN + combined_image = input_cube[*,*,0]*mask_cube[*,*,0]*exptime[0] + combined_expt = mask_cube[*,*,0]*exptime[0] + IF nimg GT 1 THEN BEGIN + FOR i=1,nimg-1 DO BEGIN + combined_image = combined_image $ + + input_cube[*,*,i]*mask_cube[*,*,i]*exptime[i] + combined_expt = combined_expt $ + + mask_cube[*,*,i]*exptime[i] + ENDFOR + ENDIF + wexpt0 = where(combined_expt LE 0,cexpt0) + combined_image = combined_image / (combined_expt>1e-6) + IF cexpt0 GT 0 THEN combined_image[wexpt0] = 0 + ENDELSE +ENDIF ELSE IF usemin THEN BEGIN + IF verbose THEN print,'CR_REJECT: Taking minimum.' + IF use_input_mask THEN BEGIN + combined_image[*] = flagval + FOR i=0, nimg-1 DO BEGIN + indx = where((input_mask[*,*,i] $ + AND mask_cube[*,*,i]) gt 0, cindx) + IF cindx GT 0 THEN $ + combined_image[indx] = $ + (combined_image < input_cube[*,*,i])[indx] + ENDFOR + wf = where(combined_image EQ flagval, cf) + IF cf GT 0 THEN combined_image[wf] = null_value + ENDIF ELSE BEGIN + combined_image = input_cube[*,*,0] + FOR i=1, nimg-1 DO BEGIN + combined_image = (combined_image < input_cube[*,*,i]) + ENDFOR + ENDELSE + + IF use_input_mask THEN BEGIn + combined_image = input_cube[*,*,0]*input_mask[*,*,0] + FOR i=1, nimg-1 DO BEGIN + combined_image = (combined_image < input_cube[*,*,i] $ + *input_mask[*,*,i]) + ENDFOR + ENDIF ELSE BEGIN + combined_image = input_cube[*,*,0] + FOR i=1, nimg-1 DO BEGIN + combined_image = (combined_image < input_cube[*,*,i]) + ENDFOR + ENDELSE +ENDIF ELSE BEGIN + print,'CR_REJECT: Logic error in program recomputing check image.' + return +ENDELSE + +GOTO,main_loop +END_main_loop: +; +; End of CR rejection loop. +; +IF verbose THEN BEGIN + FOR i=0,nimg-1 DO BEGIN + wdummy = where(1b-mask_cube[*,*,i],count) + ncut_tot[i] = count + ENDFOR + print,'CR_REJECT: Total pixels changed: ' + print,ncut_tot +ENDIF + +IF track THEN BEGIN + print,'CR_REJECT: Tracking. After loop exit.' + print,' Combined_image: ' + print,combined_image[tracking_set] +; print,' Current_var: ' +; print,current_var[tracking_set] + FOR i = 0, nimg-1 DO BEGIN + print,' Image ', strtrim(i,2), ':' + print,(input_cube[*,*,i])[tracking_set] + print,' Noise ', strtrim(i,2), ':' + print,(noise_cube[*,*,i])[tracking_set] + print,' Mask ', strtrim(i,2), ':' + print,(mask_cube[*,*,i])[tracking_set] + ENDFOR +ENDIF + +; +; Compute weights according to scheme chosen +; +xrepl = make_array(dim=xdim,value=1) +yrepl = make_array(dim=ydim,value=1) + +IF wgt EQ 0 THEN BEGIN + wgts = xrepl # exptime +ENDIF ELSE BEGIN + IF xmed THEN skytmp = skyvals>1e-6 ELSE skytmp = xrepl # (skyvals>1e-6) + exp2tmp = xrepl # (exptime^2) + sky_rate_var = temporary(skytmp)/gain/exp2tmp + ron_rate_var = rd_noise_dn^2/temporary(exp2tmp) + wgts = 1.0/(temporary(sky_rate_var) + temporary(ron_rate_var)) +ENDELSE + +; +; Do the final co-addition +; +wgt_coeff = fltarr(xdim, ydim) +FOR i=0,nimg-1 DO BEGIN + plane_wgts = wgts[*,i] # yrepl + input_cube[0,0,i] = input_cube[*,*,i]*plane_wgts + noise_cube[0,0,i] = noise_cube[*,*,i]*plane_wgts + IF use_input_mask THEN BEGIN + mcim = (mask_cube[*,*,i] AND input_mask[*,*,i]) + ENDIF ELSE BEGIN + mcim = mask_cube[*,*,i] + ENDELSE + wgt_coeff[0,0] = wgt_coeff + temporary(mcim) * temporary(plane_wgts) +ENDFOR +wh0 = where(combined_npix EQ 0,c0) +wgt_coeff = etot/(wgt_coeff > 1.0e-8) +IF c0 GT 0 THEN wgt_coeff[wh0] = 0.0 + +IF verbose THEN BEGIN + IF c0 GT 0 THEN $ + print,'CR_REJECT: ',strtrim(c0,2),' pixels rejected on all inputs.' +ENDIF + +IF use_input_mask THEN BEGIN + IF xmed THEN BEGIN + combined_image = wgt_coeff * total(input_cube $ + * (mask_cube AND input_mask),3) $ + + totsky#yrepl + ENDIF ELSE BEGIN + combined_image = wgt_coeff * total(input_cube $ + * (mask_cube AND input_mask),3) $ + + totsky + ENDELSE + combined_noise = wgt_coeff * sqrt(total((noise_cube $ + * (mask_cube AND input_mask))^2,3)) +ENDIF ELSE BEGIN + IF xmed THEN BEGIN + combined_image = wgt_coeff * total(input_cube*mask_cube,3) $ + + totsky#yrepl + ENDIF ELSE BEGIN + combined_image = wgt_coeff * total(input_cube*mask_cube,3) $ + + totsky + ENDELSE + combined_noise = wgt_coeff * sqrt(total((noise_cube*mask_cube)^2,3)) +ENDELSE + +IF keyword_set(bias) THEN BEGIN + print,'CR_REJECT: Bias flag set -- returning mean instead of total.' + combined_image = combined_image/nimg + combined_noise = combined_noise/nimg +ENDIF + +IF c0 GT 0 THEN combined_image[wh0] = null_value + +IF keyword_set(restore_sky) THEN BEGIN + IF wgt EQ 0 THEN BEGIN + IF verbose THEN print,'CR_REJECT: Adding sky back into data cube' + IF xmed THEN BEGIN + FOR i=0,nimg-1 DO BEGIN + FOR j=0, ydim-1 DO input_cube[0,j,i] = input_cube[*,j,i] $ + + skyvals[*,i] + ENDFOR + ENDIF ELSE BEGIN + FOR i=0,nimg-1 DO $ + input_cube[0,0,i] = input_cube[*,*,i] + skyvals[i] + ENDELSE + ENDIF ELSE BEGIN + print, 'CR_REJECT: /RESTORE_SKY ignored because weighting spec ' $ + + 'not zero.' + ENDELSE +ENDIF + +IF zexp THEN exptime = save_expt + +return +END diff --git a/modules/idl_downloads/astro/pro/create_struct.pro b/modules/idl_downloads/astro/pro/create_struct.pro new file mode 100644 index 0000000..602dacb --- /dev/null +++ b/modules/idl_downloads/astro/pro/create_struct.pro @@ -0,0 +1,309 @@ +pro create_struct, struct, strname, tagnames, tag_descript, DIMEN = dimen, $ + CHATTER = chatter, NODELETE = nodelete +;+ +; NAME: +; CREATE_STRUCT +; PURPOSE: +; Create an IDL structure from a list of tag names and dimensions +; EXPLANATION: +; Dynamically create an IDL structure variable from list of tag names +; and data types of arbitrary dimensions. Useful when the type of +; structure needed is not known until run time. +; +; Unlike the intrinsic function CREATE_STRUCT(), this procedure does not +; require the user to know the number of tags before run time. (Note +; there is no name conflict since the intrinsic CREATE_STRUCT() is a +; function, and this file contains a procedure.) +; CALLING SEQUENCE: +; CREATE_STRUCT, STRUCT, strname, tagnames, tag_descript, +; [ DIMEN = , /CHATTER, /NODELETE ] +; +; INPUTS: +; STRNAME - name to be associated with structure (string) +; Must be unique for each structure created. Set +; STRNAME = '' to create an anonymous structure +; +; TAGNAMES - tag names for structure elements (string or string array) +; Any strings that are not valid IDL tag names (e.g. 'a\2') +; will be converted by IDL_VALIDNAME to a valid tagname by +; replacing with underscores as necessary (e.g. 'a_2') +; +; TAG_DESCRIPT - String descriptor for the structure, containing the +; tag type and dimensions. For example, 'A(2),F(3),I', would +; be the descriptor for a structure with 3 tags, strarr(2), +; fltarr(3) and Integer scalar, respectively. +; Allowed types are 'A' for strings, 'B' or 'L' for unsigned byte +; integers, 'I' for integers, 'J' for longword integers, +; 'K' for 64bit integers, 'F' or 'E' for floating point, +; 'D' for double precision 'C' for complex, and 'M' for double +; complex. Uninterpretable characters in a format field are +; ignored. +; +; For vectors, the tag description can also be specified by +; a repeat count. For example, '16E,2J' would specify a +; structure with two tags, fltarr(16), and lonarr(2) +; +; OPTIONAL KEYWORD INPUTS: +; DIMEN - number of dimensions of structure array (default is 1) +; +; CHATTER - If set, then CREATE_STRUCT() will display +; the dimensions of the structure to be created, and prompt +; the user whether to continue. Default is no prompt. +; +; /NODELETE - If set, then the temporary file created +; CREATE_STRUCT will not be deleted upon exiting. See below +; +; OUTPUTS: +; STRUCT - IDL structure, created according to specifications +; +; EXAMPLES: +; +; IDL> create_struct, new, 'name',['tag1','tag2','tag3'], 'D(2),F,A(1)' +; +; will create a structure variable new, with structure name NAME +; +; To see the structure of new: +; +; IDL> help,new,/struc +; ** Structure NAME, 3 tags, 20 length: +; TAG1 DOUBLE Array[2] +; TAG2 FLOAT 0.0 +; TAG3 STRING Array[1] +; +; PROCEDURE: +; Generates a temporary procedure file using input information with +; the desired structure data types and dimensions hard-coded. +; This file is then executed with CALL_PROCEDURE. +; +; NOTES: +; If CREATE_STRUCT cannot write a temporary .pro file in the current +; directory, then it will write the temporary file in the getenv('HOME') +; directory. +; +; Note that 'L' now specifies a LOGICAL (byte) data type and not a +; a LONG data type for consistency with FITS binary tables +; +; RESTRICTIONS: +; The name of the structure must be unique, for each structure created. +; Otherwise, the new variable will have the same structure as the +; previous definition (because the temporary procedure will not be +; recompiled). ** No error message will be generated *** +; +; SUBROUTINES CALLED: +; REPCHR() +; +; MODIFICATION HISTORY: +; Version 1.0 RAS January 1992 +; Modified 26 Feb 1992 for Rosat IDL Library (GAR) +; Modified Jun 1992 to accept arrays for tag elements -- KLV, Hughes STX +; Accept anonymous structures W. Landsman HSTX Sep. 92 +; Accept 'E' and 'J' format specifications W. Landsman Jan 93 +; 'L' format now stands for logical and not long array +; Accept repeat format for vectors W. Landsman Feb 93 +; Accept complex and double complex (for V4.0) W. Landsman Jul 95 +; Work for long structure definitions W. Landsman Aug 97 +; Write temporary file in HOME directory if necessary W. Landsman Jul 98 +; Use OPENR,/DELETE for OS-independent file removal W. Landsman Jan 99 +; Use STRSPLIT() instead of GETTOK() W. Landsman July 2002 +; Assume since V5.3 W. Landsman Feb 2004 +; Added RESOLVE_ROUTINE to ensure recompilation W. Landsman Sep. 2004 +; Delete temporary with FILE_DELETE W. Landsman Sep 2006 +; Assume since V5.5, delete VMS reference W.Landsman Sep 2006 +; Added 'K' format for 64 bit integers, IDL_VALIDNAME check on tags +; W. Landsman Feb 2007 +; Use vector form of IDL_VALIDNAME() if V6.4 or later W.L. Dec 2007 +; Suppress compilation mesage of temporary file A. Conley/W.L. May 2009 +; Remove FDECOMP, some cleaner coding W.L. July 2009 +; Do not limit string length to 1000 chars P. Broos, Feb 2011 +; Assume since IDL V6.4 W. Landsman Aug 2013 +;- +;------------------------------------------------------------------------------- + + compile_opt idl2 + if N_params() LT 4 then begin + print,'Syntax - CREATE_STRUCT, STRUCT, strname, tagnames, tag_descript,' + print,' [ DIMEN = , /CHATTER, /NODELETE ]' + return + endif + + if ~keyword_set( chatter) then chatter = 0 ;default is 0 + if (N_elements(dimen) eq 0) then dimen = 1 ;default is 1 + + if (dimen lt 1) then begin + print,' Number of dimensions must be >= 1. Returning.' + return + endif + +; For anonymous structure, strname = '' + anonymous = 0b + if (strlen( strtrim(strname,2)) EQ 0 ) then anonymous = 1b + + good_fmts = [ 'A', 'B', 'I', 'L', 'F', 'E', 'D', 'J','C','M', 'K' ] + fmts = ["' '",'0B','0','0B','0.0','0.0','0.0D0','0L','complex(0)', $ + 'dcomplex(0)', '0LL'] + arrs = [ 'strarr', 'bytarr', 'intarr', 'bytarr', 'fltarr', 'fltarr', $ + 'dblarr', 'lonarr','complexarr','dcomplexarr','lon64arr'] + ngoodf = N_elements( good_fmts ) + +; If tagname is a scalar string separated by commas, convert to a string array + + if size(tagnames,/N_dimensions) EQ 0 then begin + tagname = strsplit(tagnames,',',/EXTRACT) + endif else tagname = tagnames + + Ntags = N_elements(tagname) + +; Make sure supplied tag names are valid. + + tagname = idl_validname( tagname, /convert_all ) + +; If user supplied a scalar string descriptor then we want to break it up +; into individual items. This is somewhat complicated because the string +; delimiter is not always a comma, e.g. if 'F,F(2,2),I(2)', so we need +; to check positions of parenthesis also. + + sz = size(tag_descript) + if sz[0] EQ 0 then begin + tagvar = strarr( Ntags) + temptag = tag_descript + for i = 0, Ntags - 1 do begin + comma = strpos( temptag, ',' ) + lparen = strpos( temptag, '(' ) + rparen = strpos( temptag, ')' ) + if ( comma GT lparen ) and (comma LT Rparen) then pos = Rparen+1 $ + else pos = comma + if pos EQ -1 then begin + if i NE Ntags-1 then message, $ + 'WARNING - could only parse ' + strtrim(i+1,2) + ' string descriptors' + tagvar[i] = temptag + goto, DONE + endif else begin + tagvar[i] = strmid( temptag, 0, pos ) + temptag = strmid( temptag, pos+1) + endelse + endfor + DONE: + + endif else tagvar = tag_descript + +; create string array for IDL statements, to be written into +; 'temp_'+strname+'.pro' + + pro_string = strarr (ntags + 2) + + if (dimen EQ 1) then begin + + pro_string[0] = "struct = { " + strname + " $" + pro_string[ntags+1] = " } " + + endif else begin + + dimen = long(dimen) ;Changed to LONG from FIX Mar 95 + pro_string[0] = "struct " + " = replicate ( { " + strname + " $" + pro_string[ntags+1] = " } , " + string(dimen) + ")" + + endelse + + tagvar = strupcase(tagvar) + + for i = 0, ntags-1 do begin + + goodpos = -1 + for j = 0,ngoodf-1 do begin + fmt_pos = strpos( tagvar[i], good_fmts[j] ) + if ( fmt_pos GE 0 ) then begin + goodpos = j + break + endif + endfor + + if goodpos EQ -1 then begin + print,' Format not recognized: ' + tagvar[i] + print,' Allowed formats are :',good_fmts + stop,' Redefine tag format (' + string(i) + ' ) or quit now' + endif + + + if fmt_pos GT 0 then begin + + repeat_count = strmid( tagvar[i], 0, fmt_pos ) + if strnumber( repeat_count, value ) then begin + fmt = arrs[ goodpos ] + '(' + strtrim(fix(value), 2) + ')' + endif else begin + print,' Format not recognized: ' + tagvar[i] + stop,' Redefine tag format (' + string(i) + ' ) or quit now' + endelse + + endif else begin + +; Break up the tag descriptor into a format and a dimension + tagfmts = strmid( tagvar[i], 0, 1) + tagdim = strtrim( strmid( tagvar[i], 1, 80),2) + if strmid(tagdim,0,1) NE '(' then tagdim = '' + fmt = (tagdim EQ '') ? fmts[goodpos] : arrs[goodpos] + tagdim + endelse + + if anonymous and ( i EQ 0 ) then comma = '' else comma = " , " + + pro_string[i+1] = comma + tagname[i] + ": " + fmt + " $" + + endfor + +; Check that this structure definition is OK (if chatter set to 1) + + if keyword_set ( Chatter ) then begin + ans = '' + print,' Structure ',strname,' will be defined according to the following:' + temp = repchr( pro_string, '$', '') + print, temp + read,' OK to continue? (Y or N) ',ans + if strmid(strupcase(ans),0,1) eq 'N' then begin + print,' Returning at user request.' + return + endif + endif + +; --- Determine if a file already exists with same name as temporary file + + tempfile = 'temp_' + strlowcase( strname ) + while file_test( tempfile + '.pro' ) do tempfile = tempfile + 'x' + +; ---- open temp file and create procedure +; ---- If problems writing into the current directory, try the HOME directory + + cd,current= prodir + cdhome = 0 + openw, unit, tempfile +'.pro', /get_lun, ERROR = err + if (err LT 0) then begin + prodir = getenv('HOME') + tempfile = prodir + path_sep() + tempfile + while file_test( tempfile + '.pro' ) do tempfile = tempfile + 'x' + openw, unit, tempfile +'.pro', /get_lun, ERROR = err + if err LT 0 then message,'Unable to create a temporary .pro file' + cdhome = 1 + endif + name = file_basename(tempfile) + printf, unit, 'pro ' + name + ', struct' + printf,unit,'compile_opt hidden' + for j = 0,N_elements(pro_string)-1 do $ + printf, unit, strtrim( pro_string[j] ) + printf, unit, 'return' + printf, unit, 'end' + free_lun, unit + +; If using the HOME directory, it needs to be included in the IDL !PATH + + if cdhome then cd,getenv('HOME'),curr=curr + resolve_routine, name + Call_procedure, name, struct + if cdhome then cd,curr + + if keyword_set( NODELETE ) then begin + message,'Created temporary file ' + tempfile + '.pro',/INF + return + endif else file_delete, tempfile + '.pro' + + return + end ;pro create_struct + + diff --git a/modules/idl_downloads/astro/pro/cspline.pro b/modules/idl_downloads/astro/pro/cspline.pro new file mode 100644 index 0000000..7dede40 --- /dev/null +++ b/modules/idl_downloads/astro/pro/cspline.pro @@ -0,0 +1,79 @@ +function cspline,xx, yy, tt, Deriv = deriv +;+ +; NAME: +; CSPLINE +; +; PURPOSE: +; Function to evaluate a natural cubic spline at specified data points +; EXPLANATION: +; Combines the Numerical Recipes functions SPL_INIT and SPL_INTERP +; +; CALLING SEQUENCE: +; result = cspline( x, y, t, [ DERIV = ]) +; +; INPUTS: +; x - vector of spline node positions, must be monotonic increasing or +; decreasing +; y - vector of node values +; t - x-positions at which to evaluate the spline, scalar or vector +; +; INPUT-OUTPUT KEYWORD: +; DERIV - values of the second derivatives of the interpolating function +; at the node points. This is an intermediate step in the +; computation of the natural spline that requires only the X and +; Y vectors. If repeated interpolation is to be applied to +; the same (X,Y) pair, then some computation time can be saved +; by supplying the DERIV keyword on each call. On the first call +; DERIV will be computed and returned on output. +; +; OUTPUT: +; the values for positions t are returned as the function value +; If any of the input variables are double precision, then the output will +; also be double precision; otherwise the output is floating point. +; +; EXAMPLE: +; The following uses the example vectors from the SPL_INTERP documentation +; +; IDL> x = (findgen(21)/20.0)*2.0*!PI ;X vector +; IDL> y = sin(x) ;Y vector +; IDL> t = (findgen(11)/11.0)*!PI ;Values at which to interpolate +; IDL> cgplot,x,y,psym=1 ;Plot original grid +; IDL> cgplot, /over, t,cspline(x,y,t),psym=2 ;Overplot interpolated values +; +; METHOD: +; The "Numerical Recipes" implementation of the natural cubic spline is +; used, by calling the intrinsic IDL functions SPL_INIT and SPL_INTERP. +; +; HISTORY: +; version 1 D. Lindler May, 1989 +; version 2 W. Landsman April, 1997 +; Rewrite using the intrinsic SPL_INIT & SPL_INTERP functions +; Converted to IDL V5.0 W. Landsman September 1997 +; Work for monotonic decreasing X vector W. Landsman February 1999 +;- +;-------------------------------------------------------------------------- + + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax: result = cspline( x, y, t, [ DERIV = ] )' + return,-1 + endif + + n = N_elements(xx) + if xx[n-1] LT xx[0] then begin ;Descending order? + xrev = reverse(xx) + yrev = reverse(yy) + if N_elements(Deriv) NE n then begin + if min( xx - xx[1:*]) LT 0 then $ + message,'ERROR - Input vector not monotonic' + deriv = spl_init( xrev, yrev) + endif + return, spl_interp( xrev, yrev, deriv, tt) + endif + + if N_elements(Deriv) NE n then deriv = spl_init( xx, yy) + return, spl_interp( xx, yy, deriv, tt) + + end diff --git a/modules/idl_downloads/astro/pro/ct2lst.pro b/modules/idl_downloads/astro/pro/ct2lst.pro new file mode 100644 index 0000000..2244ce8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ct2lst.pro @@ -0,0 +1,109 @@ +PRO CT2LST, lst, lng, tz, tme, day, mon, year +;+ +; NAME: +; CT2LST +; PURPOSE: +; To convert from Local Civil Time to Local Mean Sidereal Time. +; +; CALLING SEQUENCE: +; CT2LST, Lst, Lng, Tz, Time, [Day, Mon, Year] +; or +; CT2LST, Lst, Lng, dummy, JD +; +; INPUTS: +; Lng - The longitude in degrees (east of Greenwich) of the place for +; which the local sidereal time is desired, scalar. The Greenwich +; mean sidereal time (GMST) can be found by setting Lng = 0. +; Tz - The time zone of the site in hours, positive East of the Greenwich +; meridian (ahead of GMT). Use this parameter to easily account +; for Daylight Savings time (e.g. -4=EDT, -5 = EST/CDT), scalar +; This parameter is not needed (and ignored) if Julian date is +; supplied. ***Note that the sign of TZ was changed in July 2008 +; to match the standard definition.*** +; Time or JD - If more than four parameters are specified, then this is +; the time of day of the specified date in decimal hours. If +; exactly four parameters are specified, then this is the +; Julian date of time in question, scalar or vector +; +; OPTIONAL INPUTS: +; Day - The day of the month (1-31),integer scalar or vector +; Mon - The month, in numerical format (1-12), integer scalar or vector +; Year - The 4 digit year (e.g. 2008), integer scalar or vector +; +; OUTPUTS: +; Lst The Local Sidereal Time for the date/time specified in hours. +; +; RESTRICTIONS: +; If specified, the date should be in numerical form. The year should +; appear as yyyy. +; +; PROCEDURE: +; The Julian date of the day and time is question is used to determine +; the number of days to have passed since 0 Jan 2000. This is used +; in conjunction with the GST of that date to extrapolate to the current +; GST; this is then used to get the LST. See Astronomical Algorithms +; by Jean Meeus, p. 84 (Eq. 11-4) for the constants used. +; +; EXAMPLE: +; Find the Greenwich mean sidereal time (GMST) on 2008 Jul 30 at 15:53 pm +; in Baltimore, Maryland (longitude=-76.72 degrees). The timezone is +; EDT or tz=-4 +; +; IDL> CT2LST, lst, -76.72, -4,ten(15,53), 30, 07, 2008 +; +; ==> lst = 11.356505 hours (= 11h 21m 23.418s) +; +; The Web site http://tycho.usno.navy.mil/sidereal.html contains more +; info on sidereal time, as well as an interactive calculator. +; PROCEDURES USED: +; jdcnv - Convert from year, month, day, hour to julian date +; +; MODIFICATION HISTORY: +; Adapted from the FORTRAN program GETSD by Michael R. Greason, STX, +; 27 October 1988. +; Use IAU 1984 constants Wayne Landsman, HSTX, April 1995, results +; differ by about 0.1 seconds +; Longitudes measured *east* of Greenwich W. Landsman December 1998 +; Time zone now measure positive East of Greenwich W. Landsman July 2008 +; Remove debugging print statement W. Landsman April 2009 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 THEN BEGIN + print,'Syntax - CT2LST, Lst, Lng, Tz, Time, Day, Mon, Year' + print,' or' + print,' CT2LST, Lst, Lng, Tz, JD' + return + endif +; If all parameters were given, then compute +; the Julian date; otherwise assume it is stored +; in Time. +; + + IF N_params() gt 4 THEN BEGIN + time = tme - tz + jdcnv, year, mon, day, time, jd + + ENDIF ELSE jd = double(tme) +; +; Useful constants, see Meeus, p.84 +; + c = [280.46061837d0, 360.98564736629d0, 0.000387933d0, 38710000.0 ] + jd2000 = 2451545.0D0 + t0 = jd - jd2000 + t = t0/36525 +; +; Compute GST in seconds. +; + theta = c[0] + (c[1] * t0) + t^2*(c[2] - t/ c[3] ) +; +; Compute LST in hours. +; + lst = ( theta + double(lng))/15.0d + neg = where(lst lt 0.0D0, n) + if n gt 0 then lst[neg] = 24.D0 + (lst[neg] mod 24) + lst = lst mod 24.D0 +; + RETURN + END diff --git a/modules/idl_downloads/astro/pro/curs.pro b/modules/idl_downloads/astro/pro/curs.pro new file mode 100644 index 0000000..c6282e5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/curs.pro @@ -0,0 +1,135 @@ +pro curs, sel +;+ +; NAME: +; CURS +; PURPOSE: +; Selects an X windows cursor shape +; CALLING SEQUENCE: +; curs ;Interactively select a cursor shape. +; curs, sel ;Make the given CURSOR_STANDARD value the cursor +; shape. +; OPTIONAL INPUT: +; sel - Either an integer giving the CURSOR_STANDARD value (usually an +; even value between 0 and 152) indicating the cursor shape, or +; a string from the following menu +; a -- Up arrow +; b -- Left-angled arrow +; c -- Right-angled arrow +; d -- Crosshair +; e -- Finger pointing left +; f -- Finger pointing right +; g -- Narrow crosshair +; h -- Cycle through all possible standard cursor shapes +; +; The full list of available cursor values is given in +; /usr/include/X11/cursorfont.h +; OUTPUTS: +; None. +; RESTRICTIONS: +; Uses the CURSOR_STANDARD keyword of the DEVICE procedure. Although +; this keyword is available in Windows IDL, the values +; used by this procedure are specific to the X windows device. +; +; PROCEDURE: +; If the user supplies a valid cursor shape value, it is set. Otherwise, +; an interactive command loop is entered; it will continue until a valid +; value is given. +; MODIFICATION HISTORY: +; Converted to VAX 3100 workstations / IDL V2. M. Greason, STX, May 1990. +; Avoid bad cursor parameter values W. Landsman February, 1991 +; Don't change value of input param W. Landsman August 1995 +; Use SIZE(/TNAME) instead of DATATYPE() W. Landsman October 2001 +;- +On_error,2 +if !D.NAME NE 'X' then message, $ + 'ERROR - Requires an X-windows display, current device is ' + !D.NAME +; Check parameter. +; +isel = indgen(76)*2 +nsel = n_elements(isel) +; +IF N_elements( sel ) EQ 0 THEN sel = 0 +; +; Get the selection interactively, if not already +; specified. +; +; Initialize. +; +mnu = [" a -- Up arrow", " b -- Left-angled arrow", $ + " c -- Right-angled arrow", " d -- Crosshair", $ + " e -- Finger pointing left", " f -- Finger pointing right", $ + " g -- Narrow crosshair", $ + " h -- Cycle through all possible standard cursor shapes", $ + " i -- Enter cursor shape number directly", " j -- Quit"] +nmnu = n_elements(mnu) +fmt = "($,'Code ',I3,' ',I3,' of ',I3,' ')" +IF size(sel,/TNAME) EQ 'STRING' then begin + cmd = strupcase(sel) + csel = -99 +ENDIF ELSE csel = sel +; +; While loop until a selection is made. +; +WHILE (csel LE 0) OR (csel GT isel[nsel-1]) DO BEGIN +; +; Get command. +; +if csel NE -99 then begin + print, "Cursor selection:" + print, " " + FOR i = 0, (nmnu-1) DO print, mnu[i] + print, " " + cmd = '' + read, "Enter the letter of the desired command: ",cmd +endif +; +; Perform the command. +; +MENU: CASE strupcase(cmd) OF + 'A' : csel = 22 ; Up arrow + 'B' : csel = 132 ; Left arrow + 'C' : csel = 2 ; Right arrow + 'D' : csel = 34 ; X-hair. + 'E' : csel = 56 ; Left hand. + 'F' : csel = 58 ; Right hand. + 'G' : csel = 33 ; Narrow crosshair. + 'H' : BEGIN ; Cycle thru all cursors. + print, " " + print, " " + print, "Cycling through the possible cursors." + print, " " + print, "Strike the space bar to select, any other" + print, "key to reject." + print, " " + print, " " + scr_curmov, 0, 1 + cont = 1 + FOR i = 0, (nsel-1) DO BEGIN + IF cont THEN BEGIN + csel = isel[i] + print, format=fmt, csel, i+1, nsel + scr_curmov, 2, 31 + device, cursor_standard=csel + IF get_kbrd(1) EQ ' ' THEN cont = 0 + ENDIF + ENDFOR + END + 'I' : BEGIN ; Get # from user. + print, " " + print, " " + print, format="(A14,$)", "Enter cursor #" + read, csel + IF (csel LE 0) OR (csel GT isel[nsel-1]) THEN $ + print, "Invalid entry." + END + 'J' : csel = 34 ; Quit. Set to X-hair. + ELSE : csel = 0 ; Invalid command. + ENDCASE +ENDWHILE +; +; Set the cursor shape +; +device, cursor_standard=csel +; +RETURN +END diff --git a/modules/idl_downloads/astro/pro/curval.pro b/modules/idl_downloads/astro/pro/curval.pro new file mode 100644 index 0000000..7dd13ba --- /dev/null +++ b/modules/idl_downloads/astro/pro/curval.pro @@ -0,0 +1,304 @@ +pro curval, hd, im, OFFSET = offset, ZOOM = zoom, Filename=Filename, ALT = alt +;+ +; NAME: +; CURVAL +; PURPOSE: +; Cursor controlled display of image intensities and astronomical coords +; EXPLANATION +; CURVAL displays different information depending whether the user +; supplied an image array, and/or a FITS header array +; +; Note that in the usual truecolor mode, the byte intensity returned by +; CURVAL does not correspond to the byte scaled image value but rather +; returns the maximum value in each color gun. +; CALLING SEQUENCE(S): +; curval ;Display x,y and byte intensity (inten) +; +; curval, im ;Display x,y,inten, and also pixel value (from image array) +; +; curval, hdr, [ im, OFFSET= , ZOOM=, FILENAME=, ALT=] +; +; OPTIONAL INPUTS: +; Hdr = FITS Header array +; Im = Array containing values that are displayed. Any type. +; +; OPTIONAL KEYWORD INPUTS: +; ALT - single character 'A' through 'Z' or ' ' specifying an alternate +; astrometry system present in the FITS header. The default is +; to use the primary astrometry or ALT = ' '. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. +; OFFSET - 2 element vector giving the location of the image pixel (0,0) +; on the window display. OFFSET can be positive (e.g if the +; image is centered in a larger window) or negative (e.g. if the +; only the central region of an image much larger than the window +; is being displayed. +; Default value is [0,0], or no offset. +; ZOOM - Scalar specifying the magnification of the window with respect +; to the image variable. Use, for example, if image has been +; REBINed before display. +; FILENAME = name of file to where CURVAL data can be saved. +; Data will only be saved if left or center mouse button +; are pressed. +; +; OUTPUTS: +; None. +; +; SIDE EFFECTS: +; X and Y values, etc., of the pixel under the cursor are constantly +; displayed. +; Pressing left or center mouse button prints a line of output, and +; starts a new line. +; Pressing right mouse button exits the procedure. +; If the keyword FILENAME is defined, the date and time, and a heading +; will be printed in the file before the data. +; +; PROCEDURES CALLED: +; ADSTRING(), EXTAST, GSSSXYAD, RADEC, SXPAR(), UNZOOM_XY, XY2AD +; REVISION HISTORY: +; Written, K. Rhode, STX May 1990 +; Added keyword FILENAME D. Alexander June 1991 +; Don't write to Journal file W. Landsman March 1993 +; Use astrometry structure W. Landsman Feb 1994 +; Modified for Mac IDL I. Freedman April 1994 +; Allow for zoomed or offset image W. Landsman Mar 1996 +; Proper rounding of zoomed pixel values W. Landsman/R. Hurt Dec. 1997 +; Remove unneeded calls to obsolete !ERR W. Landsman December 2000 +; Replace remaining !ERR calls with !MOUSE.BUTTON W. Landsman Jan 2001 +; Allow for non-celestial (e.g. Galactic) coordinates W. Landsman Apr 2003 +; Work if RA/Dec reversed in CTYPE keyword W. Landsman Feb. 2004 +; Always call UNZOOM_XY for MOUSSE compatibility W. Landsman Sep. 2004 +; Added ALT keyword W. Landsman October 2004 +; Always test if offset/zoom supplied W. Landsman Feb 2008 +;- + On_error,2 ;if an error occurs, return to caller + compile_opt idl2 + + + f_header = 0b ;True if a FITS header supplied + f_image = 0b ;True if an image array supplied + f_astrom = 0b ;True if FITS header contains astrometry + f_bscale = 0b ;True if FITS header contains BSCALE factors + f_imhd = 0b ;True if image array is in HD (1 parameter) + npar = N_params() + fileflag=0 ;True once left or middle mouse button pressed + + if !D.WINDOW EQ -1 then begin + message,'ERROR - No image window active',/INF + return + endif + + +if (!D.FLAGS and 256) EQ 256 then wshow,!D.WINDOW ;Bring active window to foreground + +; Print formats and header for different astrometry,image, BSCALE combinations + + cr = string(13b) + line0 = ' X Y Byte Inten' + line1 = ' X Y Byte Inten Value' + line5 = ' X Y ByteInten Value Flux' + + f0 = "($,a,i4,2x,i4,6x,i4)" + f1 = "($,a,i4,2x,i4,6x,i4,5x,a)" + f2 = "($,a,i4,2x,i4,6x,i4,7x,a,1x,a)" + f3 = "($,a,i4,2x,i4,2x,i4,7x,a,2x,a,1x,a,3x,e9.2)" + f4 = "($,a,i4,2x,i4,2x,i4,7x,a,1x,a,a)" + f5 = "($,a,i4,2x,i4,2x,i4,3x,a,5x,e9.2)" + + g0 = "(a,i4,2x,i4,6x,i4)" + g1 = "(a,i4,2x,i4,6x,i4,5x,a)" + g2 = "(a,i4,2x,i4,6x,i4,7x,a,1x,a)" + g3 = "(a,i4,2x,i4,2x,i4,7x,a,2x,a,1x,a,3x,e9.2)" + g4 = "(a,i4,2x,i4,2x,i4,7x,a,2x,a,1x,a)" + g5 = "(a,i4,2x,i4,2x,i4,3x,a,5x,e9.2)" + +if (npar gt 0) then begin + type = size(hd) + if (npar eq 1) and (type[0] eq 2) then begin + f_image = 1b & f_imhd = 1b + imtype = type + endif else if (type[2] ne 7) or (type[0] ne 1) then begin + print,'Syntax options: CURVAL ;Display byte values' + print,' CURVAL, IM ;where IM is a 2-D image,' + print,' CURVAL, Hdr ;where Hdr is a FITS header,' + print,' or CURVAL, Hdr,IM' + return + endif else if (type[2] eq 7) and (type[0] eq 1) then f_header = 1b + if (npar eq 2) then begin + f_image = 1b & f_header = 1b + imtype = size(im) + if (imtype[0] lt 2) or $ + (imtype[imtype[0]+2] ne imtype[1]*imtype[2]) then $ + message,'Image array (second parameter) is not two dimensional.' + endif +endif + +; Get information from the header + + if f_header then begin + + EXTAST, hd, astr, noparams, alt=alt ;Extract astrometry structure + if (noparams ge 0) then f_astrom = 1b + + if f_image then begin + bscale = sxpar(hd,'BSCALE') + if (bscale ne 0) then begin + bzero = sxpar(hd,'BZERO') + bunit = sxpar(hd,'BUNIT', Count = N_Bunit) + if N_Bunit GE 1 then $ + if f_astrom then line3 = line3 + '('+bunit+ ')' else $ + line5 = line5 + '('+bunit+')' + f_bscale = 1b + endif + endif + endif + +; Determine if an offset or zoom supplied + unzoom = f_image or f_header or keyword_set(offset) or keyword_set(zoom) + + if f_astrom GT 0 then begin + coord = strmid(astr.ctype,0,4) + coord = repchr(coord,'-',' ') + if (coord[0] EQ 'DEC ') or (coord[0] EQ 'ELAT') or $ + (coord[0] EQ 'GLAT') then coord = rotate(coord,2) + + line2 = ' X Y Byte Inten ' + coord[0] + ' ' +coord[1] + line3 = ' X Y ByteInten Value ' + coord[0] + ' ' + $ + coord[1] + ' Flux' + line4 = ' X Y ByteInten Value ' + coord[0] + ' ' + $ + coord[1] + + sexig = strupcase(strmid(coord[0],0,4)) EQ 'RA ' + endif + + print,'Press left or center mouse button for new output line,' + print,'... right mouse button to exit.' + +; different print statements, depending on the parameters + + case 1 of + +(f_image eq 0b) and (f_astrom eq 0b): begin + curtype = 0 & print, line0 & end ;No image or header info + +(f_image) and (f_astrom eq 0b) and (f_bscale eq 0b): begin + curtype = 1 & print,line1 & end ;Only image array supplied + +(f_image eq 0b) and (f_astrom) and (f_bscale eq 0b): begin + curtype = 2 & print,line2 & end ;Astrometry but no image array + +(f_image) and (f_astrom) and (f_bscale): begin + curtype =3 & print,line3 & end ;Image array + astrometry + BSCALE + +(f_image) and (f_astrom) and (f_bscale eq 0b): begin + curtype = 4 & print,line4 & end ;Image array +astrometry + +(f_image) and (f_astrom eq 0b) and (f_bscale): begin + curtype = 5 & print,line5 & end ;Image array + BSCALE + +endcase + if f_image then begin + dtype = imtype[imtype[0]+1] + if (dtype LT 4) or (dtype GE 12) then dfmt = '(I8)' else dfmt = '(G8.3)' + endif + + LOOP: sv_err = !MOUSE.BUTTON + !MOUSE.BUTTON = 0 + cursor,x,y,2,/DEVICE,/CHANGE + cr_err = !MOUSE.BUTTON + + if cr_err EQ 4 then begin + print,' ' + if fileflag then free_lun,lun + return + + endif + + + x = x>0 & y = y>0 + inten = fix(tvrd(x,y,1,1)) ; read the byte intensity + + if unzoom then unzoom_xy,x,y,offset=offset,zoom=zoom + + if f_astrom then begin + + case strmid(astr.ctype[0],5,3) of + 'GSS': gsssxyad, astr, x, y, a, d + else: xy2ad, x, y, astr, a, d ; convert to ra and dec + endcase + + if sexig then begin + str = adstring(a,d,2) + a = strmid(str,1,13) + d = strmid(str,14,13) + endif else begin + a = string(a,'(f10.2)') + ' ' + d = string(d,'(f10.2)') + ' ' + endelse + endif + + x = round(x) & y = round(y) + + if f_image then begin + if (x LT 0) or (x GE imtype[1]) or $ + (y LT 0) or (y GE imtype[2]) then value = 0 else $ + if f_imhd then value = hd[x,y] else value = im[x,y] + svalue = string(value,f=dfmt) + endif + + if f_bscale then flux = bscale*value + bzero + case curtype of + 0: print,form=f0,cr,x,y,inten + 1: print,form=f1,cr,x,y,inten,svalue + 2: print,form=f2,cr,x,y,inten,a,d + 3: print,form=f3,cr,x,y,inten,svalue,a,d,flux + 4: print,form=f4,cr,x,y,inten,svalue,a,d + 5: print,form=f5,cr,x,y,inten,svalue,flux + endcase + +; Were left or center buttons been pressed? + + if (cr_err GE 1) and (cr_err LE 3) and (cr_err NE sv_err) then begin + print,form="($,a)",string(10b) ; print a form feed + if keyword_set(filename) and (not fileflag) then begin ; open file & print table header to file + get_lun,lun + openw,lun,filename + printf,lun,'CURVAL: ',systime() ;print time and date to file + case 1 of ;different print statements for file, depending on parameters + + (f_image eq 0b) and (f_astrom eq 0b) : begin + printf, lun, line0 & end ;No image or header info + + (f_image) and (f_astrom eq 0b) and (f_bscale eq 0b) : begin + printf, lun, line1 & end ;Only image array supplied + + (f_image eq 0b) and (f_astrom) and (f_bscale eq 0b) : begin + printf, lun, line2 & end ;Astrometry but no image array + + (f_image) and (f_astrom) and (f_bscale) : begin + printf, lun, line3 & end ;Image array + astrometry + BSCALE + + (f_image) and (f_astrom) and (f_bscale eq 0b) : begin + printf, lun, line4 & end ;Image array + astrometry + + (f_image) and (f_astrom eq 0b) and (f_bscale) : begin + printf, lun, line5 & end ;Image array + BSCALE + endcase + fileflag=1 + endif + if keyword_set(filename) then begin + case curtype of + 0: printf, lun, form=g0,'', x, y, inten + 1: printf, lun, form=g1,'', x, y, inten, svalue + 2: printf, lun, form=g2,'', x, y, inten, a, d + 3: printf, lun, form=g3,'', x, y, inten, svalue, a, d, flux + 4: printf, lun, form=g4,'', x, y, inten, svalue, a, d + 5: printf, lun, form=g5,'', x, y, inten, svalue, flux + endcase + endif + endif + + goto,LOOP + + end diff --git a/modules/idl_downloads/astro/pro/dao_value.pro b/modules/idl_downloads/astro/pro/dao_value.pro new file mode 100644 index 0000000..2aaa4aa --- /dev/null +++ b/modules/idl_downloads/astro/pro/dao_value.pro @@ -0,0 +1,87 @@ +FUNCTION DAO_VALUE, XX, YY, GAUSS, PSF, DVDX, DVDY +;+ +; NAME: +; DAO_VALUE +; PURPOSE: +; Returns the value of a DAOPHOT point-spread function at a set of points. +; EXPLANATION: +; The value of the point-spread function is the sum of a +; two-dimensional integral under a bivariate Gaussian function, and +; a value obtained by interpolation in a look-up table. DAO_VALUE will +; optionally compute the derivatives wrt X and Y +; +; CALLING SEQUENCE: +; Result = DAO_VALUE( xx, yy, gauss, psf, [ dvdx, dvdy ] ) +; +; INPUTS: +; XX,YY - the real coordinates of the desired point relative +; to the centroid of the point-spread function. +; GAUSS - 5 element vector describing the bivariate Gaussian +; GAUSS(0)- the peak height of the best-fitting Gaussian profile. +; GAUSS(1,2) - x and y offsets from the centroid of the point-spread +; function to the center of the best-fitting Gaussian. +; GAUSS(3,4) - the x and y sigmas of the best-fitting Gaussian. +; PSF - a NPSF by NPSF array containing the look-up table. +; +; OUTPUTS: +; RESULT - the computed value of the point-spread function at +; a position XX, YY relative to its centroid (which +; coincides with the center of the central pixel of the +; look-up table). +; +; OPTIONAL OUTPUTS: +; DVDX,DVDY - the first derivatives of the composite point-spread +; function with respect to x and y. +; +; NOTES +; although the arguments XX,YY of the function DAO_VALUE +; are relative to the centroid of the PSF, the function RINTER which +; DAO_VALUE calls requires coordinates relative to the corner of the +; array (see code). +; +; PROCEDURES CALLED: +; DAOERF, RINTER() +; REVISON HISTORY: +; Adapted to IDL by B. Pfarr, STX, 11/17/87 from 1986 STSDAS version +; of DAOPHOT +; Converted to IDL V5.0 W. Landsman September 1997 +;- + s = size(psf) + npsf = s[1] + half = float(npsf-1)/2 + + x = 2.*xx + half ;Initialize + y = 2.*yy + half + +; X and Y are the coordinates relative to the corner of the look-up table, +; which has a half-pixel grid size. + + if ( (min(x) LT 1.) or ( max(x) GT npsf-2.) or $ + (min(y) LT 1.) or ( max(y) GT npsf-2.) ) then begin + message,'X,Y positions too close to edge of frame',/INF + return,xx*0 + endif + +; Evaluate the approximating Gaussian. +; Then add a value interpolated from the look-up table to the approximating +; Gaussian. Since the lookup table has a grid size of one-half pixel in each +; coordinate, the spatial derivatives must be multiplied by two to yield +; the derivatives in units of ADU/pixel in the big frame. + + if N_params() GT 4 then begin ;Compute derivatives? + + DAOERF, xx, yy, gauss, e, pder + value = e + RINTER( psf, x, y, dfdx, dfdy) + dvdx = 2.*dfdx - pder[*,1] + dvdy = 2.*dfdy - pder[*,2] + + endif else begin + + DAOERF, xx, yy, gauss, e + value = e + RINTER(psf,x,y) + + endelse + + return, value + + end diff --git a/modules/idl_downloads/astro/pro/daoerf.pro b/modules/idl_downloads/astro/pro/daoerf.pro new file mode 100644 index 0000000..f1451e6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/daoerf.pro @@ -0,0 +1,58 @@ +pro daoerf,x,y,a,f,pder ;DAOphot ERRor function +;+ +; NAME: +; DAOERF +; PURPOSE: +; Calulates the intensity, and derivatives, of a 2-d Gaussian PSF +; EXPLANATION: +; Corrects for the finite size of a pixel by integrating the Gaussian +; over the size of the pixel. Used in the IDL-DAOPHOT sequence. +; +; CALLING SEQUENCE: +; DAOERF, XIN, YIN, A, F, [ PDER ] +; +; INPUTS: +; XIN - input scalar, vector or array, giving X coordinate values +; YIN - input scalar, vector or array, giving Y coordinate values, must +; have same number of elements as XIN. +; A - 5 element parameter array describing the Gaussian +; A(0) - peak intensity +; A(1) - X position of peak intensity (centroid) +; A(2) - Y position of peak intensity (centroid) +; A(3) - X sigma of the gaussian (=FWHM/2.345) +; A(4) - Y sigma of gaussian +; +; OUTPUTS: +; F - array containing value of the function at each (XIN,YIN) +; The number of output elements in F and PDER is identical with +; the number of elements in X and Y +; +; OPTIONAL OUTPUTS: +; PDER - 2 dimensional array of size (NPTS,5) giving the analytic +; derivative at each value of F with respect to each parameter A. +; +; REVISION HISTORY: +; Written: W. Landsman October, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + norm = 2.506628275 ;norm = sqrt(2*!pi) + npts = N_elements(x) + + u2 = (x[*] - a[1] + 0.5)/a[3] & u1 = (x[*] - a[1] - 0.5)/a[3] + v2 = (y[*] - a[2] + 0.5)/a[4] & v1 = (y[*] - a[2] - 0.5)/a[4] + fx = norm*a[3]*(gaussint(u2) - gaussint(u1)) + fy = norm*a[4]*(gaussint(v2) - gaussint(v1)) + f = a[0]*fx*fy + if N_params() le 4 then return ;Need partial derivatives ? + + pder = fltarr(npts,5) + pder[0,0] = fx*fy + uplus = exp(-0.5*u2^2) & uminus = exp(-0.5*u1^2) + pder[0,1] = a[0]*fy*(-uplus + uminus) + vplus = exp(-0.5*v2^2) & vminus = exp(-0.5*v1^2) + pder[0,2] = a[0]*fx*(-vplus + vminus) + pder[0,3] = a[0]*fy*(fx/a[3] + u1*uminus - u2*uplus) + pder[0,4] = a[0]*fx*(fy/a[4] + v1*vminus - v2*vplus) + + return + end diff --git a/modules/idl_downloads/astro/pro/date.pro b/modules/idl_downloads/astro/pro/date.pro new file mode 100644 index 0000000..2abd07f --- /dev/null +++ b/modules/idl_downloads/astro/pro/date.pro @@ -0,0 +1,75 @@ +FUNCTION DATE,YEAR,DAY +;+ +; NAME: +; DATE +; PURPOSE: +; Convert day-of-year to a DD-MMM-YYYY string +; +; CALLING SEQUENCE: +; D_String = DATE(Year, day ) +; +; INPUTS: +; Year - Integer scalar specifying the year. If the year contains only +; two digits, then it is assumed to indicate the number of +; years after 1900. +; +; Day - Integer scalar giving number of days after Jan 0 of the +; specified year. Can be larger than 366 +; +; OUTPUTS: +; D_String - String giving date in format '13-MAR-1986' +; +; RESTRICTIONS: +; Will not work for years before 100 AD +; EXAMPLE: +; IDL> print, date(1997,279) +; '6-Oct-1997' +; +; MODIFICATION HISTORY: +; D.M. fecit 24 October,1983 +; Work for years outside of the 19th century W. Landsman September 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + IF day LE 0 THEN BEGIN + D_String = '%DATE-F-DAY.LE.ZERO' + ENDIF ELSE BEGIN + Last_Day = [31,59,90,120,151,181,212,243,273,304,334,365] + LD = [0,INTARR(11)+1] + Day_of_Year = Day + Months = 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC' + +; Every year that is exactly divisible by 4 is a leap year, except for years +; that exactly divisible by 100; these centurial years are leap years only if +; they are exactly divisible by 400. + + IF Year LT 100 THEN Yr = Year + 1900 ELSE Yr = Year + Leap = (((Yr MOD 4) EQ 0) AND ((Yr MOD 100) NE 0)) $ + OR ((Yr MOD 400) EQ 0) + N_Days = 365 + Leap + + WHILE Day_of_Year GT N_Days DO BEGIN + Day_of_Year = Day_of_Year - N_Days + Yr = Yr + 1 + Leap = (((Yr MOD 4) EQ 0) AND ((Yr MOD 100) NE 0)) $ + OR ((Yr MOD 400) EQ 0) + N_Days = 365 + Leap + END + + End_Date = '-' + STRTRIM(YR,2) + + IF Leap THEN Last_Day = Last_Day + LD + Last_Month = Day_of_Year LE Last_Day + Where_LD = WHERE(Last_Month, N_Month) + + IF N_Month EQ 12 THEN BEGIN + D_String = STRTRIM(Day_of_Year,2) + '-JAN' + End_Date + ENDIF ELSE BEGIN + LAST_Month = Where_LD[0] + Month = STRMID(Months,3*Last_Month,3) + Day_of_Month = Day_of_Year - Last_Day[Last_Month-1] + D_String = STRTRIM(Day_of_Month,2) + '-' + Month + End_Date + END + END + + RETURN,D_String + END diff --git a/modules/idl_downloads/astro/pro/date_conv.pro b/modules/idl_downloads/astro/pro/date_conv.pro new file mode 100644 index 0000000..e34a46d --- /dev/null +++ b/modules/idl_downloads/astro/pro/date_conv.pro @@ -0,0 +1,449 @@ +function date_conv,date,type, BAD_DATE = bad_date +;+ +; NAME: +; DATE_CONV +; PURPOSE: +; Procedure to perform conversion of dates to one of three possible formats. +; +; EXPLANATION: +; The following date formats are allowed +; +; format 1: real*8 scalar encoded as: +; year*1000 + day + hour/24. + min/24./60 + sec/24./60/60 +; where day is the day of year (1 to 366) +; format 2: Vector encoded as: +; date[0] = year (eg. 2005) +; date[1] = day of year (1 to 366) +; date[2] = hour +; date[3] = minute +; date[4] = second +; To indicate a date only, set a negative hour. +; format 3: string (ascii text) encoded as +; DD-MON-YEAR HH:MM:SS.SS +; (eg. 14-JUL-2005 15:25:44.23) +; OR +; YYYY-MM-DD HH:MM:SS.SS (ISO standard) +; (eg. 1987-07-14 15:25:44.23 or 1987-07-14T15:25:44.23) +; +; OR +; DD/MM/YY (pre-2000 option for FITS DATE keywords) +; Time of day segment is optional in all of these. +; +; format 4: three element vector giving spacecraft time words +; from a Hubble Space Telescope (HST) telemetry packet. Based on +; total number of secs since midnight, JAN. 1, 1979 +; +; format 5: Julian day. As this is also a scalar, like format 1, +; the distinction between the two on input is made based on their +; value. Numbers > 2300000 are interpreted as Julian days. +; +; CALLING SEQUENCE +; results = DATE_CONV( DATE, TYPE ) +; +; INPUTS: +; DATE - input date in one of the possible formats. Must be scalar. +; TYPE - type of output format desired. If not supplied then +; format 3 (real*8 scalar) is used. +; valid values: +; 'REAL' - format 1 +; 'VECTOR' - format 2 +; 'STRING' - format 3 +; 'FITS' - YYYY-MM-DDTHH:MM:SS.SS' +; 'JULIAN' - Julian date +; 'MODIFIED' - Modified Julian date (JD-2400000.5) +; TYPE can be abbreviated to the single character strings 'R', +; 'V', 'S', 'F', 'J', and 'M'. +; Nobody wants to convert TO spacecraft time (I hope!) +; OUTPUTS: +; The converted date is returned as the function value. +; Output is -1 if date is unrecognisable. +; +; If the time of day is omitted from the input, it will also +; be omitted from any output string (format STRING or FITS). +; Note that date-only strings are allowed by the FITS standard. +; For other output formats any missing time of day is set to +; 00:00:00.0 +; +; KEYWORD OUTPUTS +; +; BAD_DATE set to 1B if date is unrecognisable +; +; EXAMPLES: +; IDL> print,date_conv('2006-03-13 19:58:00.00'),f='(f15.5)' +; 2006072.83194 +; IDL> print,date_conv( 2006072.8319444d,'F') +; 2006-03-13T19:58:00.00 +; IDL> print,date_conv( 2006072.8319444d,'V') +; 2006.00 72.0000 19.0000 57.0000 59.9962 +; IDL> print,date_conv( 2006072.8319444d,'J'), f='(f15.5)' +; 2453808.33194 +; +; +; HISTORY: +; version 1 D. Lindler July, 1987 +; adapted for IDL version 2 J. Isensee May, 1990 +; Made year 2000 compliant; allow ISO format input jls/acc Oct 1998 +; DJL/ACC Jan 1998, Modified to work with dates such as 6-JAN-1996 where +; day of month has only one digit. +; DJL, Nov. 2000, Added input/output format YYYY-MM-DDTHH:MM:SS.SS +; Replace spaces with '0' in output FITS format W.Landsman April 2006 +; Added Julian date capabilities on input and output. M.Perrin, July 2007 +; Removed spurious /WARN keyword to MESSAGE W.L. Feb 2012 +; ...and another /WARN; added BAD_DATE, drop spurious time-of-day +; output from strings. J. P. Leahy July 2013 +; changed all /CONTINUE warning messages to /INFO: can be suppressed +; by setting !QUIET = 1. J. P. Leahy July 2013 +;- +;------------------------------------------------------------- +; +compile_opt idl2 +; data declaration +; +days = [0,31,28,31,30,31,30,31,31,30,31,30,31] +months = [' ','JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT',$ + 'NOV','DEC'] +; +; set default type if not supplied +; +if N_params() lt 2 then type = 'REAL' +; +; Determine type of input supplied +; +s = size(date) & ndim = s[0] & datatype = s[ndim+1] +if ndim gt 0 then begin ;vector? + if ndim gt 1 then goto,notvalid + if (s[1] ne 5) && (s[1] ne 3) then goto,notvalid + if (s[1] eq 5) then form = 2 else form = 4 + end else begin ;scalar input + if datatype eq 0 then goto,notvalid + if datatype eq 7 then form = 3 $ ;string + else form = 1 ;numeric scalar +end +; +; ----------------------------------- +; +;*** convert input to year,day,hour,minute,second +; +; ----------------------------------- +case form of + + 1: begin ;real scalar + ; The 'real' input format may be interpreted EITHER + ; a) if < 2300000 + ; as the traditional 'real*8 encoded' format used by date_conv + ; b) if > 2300000 + ; as a Julian Day Number + idate = long(date) + year = long(idate/1000) + + if year lt 2300 then begin + + ; if year is only 2 digits, assume 1900 + if year lt 100 then begin + message,/INF, $ + 'Warning: Year specified is only 2 digits, assuming 19xx' + year=1900+year + idate=1900000+idate + date=1900000.+date + end + day = idate - year*1000 + fdate = date-idate + fdate = fdate*24. + hour = fix(fdate) + fdate = (fdate-hour)*60.0 + minute = fix(fdate) + sec = float((fdate-minute)*60.0) + + endif else begin + daycnv, date, year, mn, mndy, hr + ; convert from month/day to day of year + ; how many days PRECEED the start of each month? + YDAYS = [0,31,59,90,120,151,181,212,243,273,304,334,366] + LEAP = (((YeaR MOD 4) EQ 0) AND ((YeaR MOD 100) NE 0)) OR $ + ((YeaR MOD 400) EQ 0) + IF LEAP THEN YDAYS[2:*] = YDAYS[2:*] + 1 + day = ydays[mn-1]+mndy + + hour = fix(hr) + fmin = (hr-hour)*60 + minute = fix(fmin) + sec = float((fmin-minute)*60) + endelse + end + + 2: begin ;vector + year = fix(date[0]) +; +; if year is only 2 digits, assume 1900 +; + if year lt 100 then begin + message,/INF, $ + 'Warning: Year specified is only 2 digits, assuming 19xx' + year=1900+year + end +; + day = fix(date[1]) + hour = fix(date[2]) + minute = fix(date[3]) + sec = float(date[4]) + end + + 3: begin ;string + temp = date +; +; check for old type of date, DD-MMM-YYYY +; + test = STRPOS(temp,'-') + if test ge 0 && test le 2 then begin + day_of_month = fix(gettok(temp,'-')) + month_name = gettok(temp,'-') + year = fix(gettok(temp,' ')) +; +; determine month number from month name +; + month_name = strupcase(month_name) + for mon = 1,12 do begin + if month_name eq months[mon] then goto,found + end + message,/INFORMATIONAL, 'Invalid month name specified' + goto, notvalid +; +; check for new type of date, ISO: YYYY-MM-DD +; + end else if strpos(temp,'-') eq 4 then begin + year = fix(gettok(temp,'-')) + month_name = gettok(temp,'-') + mon= FIX(month_name) + day_of_month=gettok(temp,' ') + if strlen(temp) eq 0 then begin + dtmp=gettok(day_of_month,'T') + temp=day_of_month + day_of_month=dtmp + end + day_of_month=fix(day_of_month) +; +; check for DD/MM/YY +; + end else if STRPOS(temp,'/') eq 2 then begin + day_of_month = FIX(gettok(temp,'/')) + mon = FIX(gettok(temp,'/')) + year = 1900 + FIX(STRMID(temp,0,2)) + end else goto, notvalid + + found: + hour = gettok(temp,':') + hour = hour NE '' ? FIX(hour) : -1 + minute = fix(gettok(temp,':')) + sec = float(strtrim(strmid(temp,0,5))) + + IF (mon LT 1 || mon GT 12) THEN BEGIN + MESSAGE, /INFORMATIONAL, 'Invalid month specified' + goto, notvalid + ENDIF +; +; if year is only 2 digits, assume 1900 +; + if year lt 100 then begin + message,/INFORMATIONAL, $ + 'Warning: Year specified is only 2 digits, assuming 19xx' + year=1900+year + end +; +; +; convert to day of year from month/day_of_month +; +; correction for leap years +; +; if (fix(year) mod 4) eq 0 then days(2) = 29 ;add one to february + lpyr = ((year mod 4) eq 0) and ((year mod 100) ne 0) $ + or ((year mod 400) eq 0) + if lpyr eq 1 then days[2] = 29 ; if leap year, add day to Feb. +; +; +; compute day of year +; + day = fix(total(days[0:mon-1])+day_of_month) + end + + 4 : begin ;spacecraft time + SC = DOUBLE(date) + SC = SC + (SC LT 0.0)*65536. ;Get rid of neg. numbers +; +; Determine total number of secs since midnight, JAN. 1, 1979 +; + SECS = SC[2]/64 + SC[1]*1024 + SC[0]*1024*65536. + SECS = SECS/8192.0D0 ;Convert from spacecraft units +; +; Determine number of years +; + MINS = SECS/60. + HOURS = MINS/60. + TOTDAYS = HOURS/24. + YEARS = TOTDAYS/365. + YEARS = FIX(YEARS) +; +; Compute number of leap years past +; + LEAPYEARS = (YEARS+2)/4 +; +; Compute day of year +; + DAY = FIX(TOTDAYS-YEARS*365.-LEAPYEARS) +; +; Correct for case of being right at end of leapyear +; + IF DAY LT 0 THEN BEGIN + DAY = DAY+366 + LEAPYEARS = LEAPYEARS-1 + YEARS = YEARS-1 + END +; +; COMPUTE HOUR OF DAY +; + TOTDAYS = YEARS*365.+DAY+LEAPYEARS + HOUR = FIX(HOURS - 24*TOTDAYS) + TOTHOURS = TOTDAYS*24+HOUR +; +; COMPUTE MINUTE +; + MINUTE = FIX(MINS-TOTHOURS*60) + TOTMIN = TOTHOURS*60+MINUTE +; +; COMPUTE SEC +; + SEC = SECS-TOTMIN*60 +; +; COMPUTE ACTUAL YEAR +; + YEAR = YEARS+79 +; +; if year is only 2 digits, assume 1900 +; + if year lt 100 then begin + message, /INF, $ + 'Warning: Year specified is only 2 digits, assuming 19xx' + year=1900+year + end +; +; +; START DAY AT ONE AND NOT ZERO +; + DAY++ + END +ENDCASE +; +; correction for leap years +; + if form ne 3 then begin ;Was it already done? + lpyr = ((year mod 4) eq 0) && ((year mod 100) ne 0) $ + || ((year mod 400) eq 0) + if lpyr eq 1 then days[2] = 29 ; if leap year, add day to Feb. + end +; +; check for valid day +; + if (day lt 1) || (day gt total(days)) then begin + message, /INFORMATIONAL, $ + 'ERROR -- There are only ' + strtrim(fix(total(days)),2) + $ + ' days in year '+strtrim(year,2) + goto, notvalid + endif +; +; find month which day occurs +; + day_of_month = day + month_num = 1 + while day_of_month gt days[month_num] do begin + day_of_month = day_of_month - days[month_num] + month_num = month_num+1 + end +; --------------------------------------- +; +; ***** Now convert to output format +; +; --------------------------------------- +; +; is type a string +; +s = size(type) +if (s[0] ne 0) or (s[1] ne 7) then $ + message,'ERROR - Output type specification must be a string' +; +outcode = STRMID(STRUPCASE(type),0,1) +IF (outcode EQ 'S' || outcode EQ 'F') && hour GE 0 THEN BEGIN + xsec = strmid(string(sec+100,'(f6.2)'),1,5) + if xsec EQ '60.00' then begin + minute = minute+1 + xsec = '00.00' + endif + xminute = string(minute,'(i2.2)') + if xminute EQ '60' then begin + hour = hour+1 + xminute = '00' + endif + tod = string(hour,'(i2.2)') + ':' +xminute + ':'+ xsec +ENDIF + +case outcode of + + 'V' : begin ;vector output + out = fltarr(5) + out[0] = year + out[1] = day + out[2] = hour > 0 + out[3] = minute + out[4] = sec + end + + 'R' : begin ;floating point scalar +; if year gt 1900 then year = year-1900 + out = sec/24.0d0/60./60. + minute/24.0d0/60. $ + + (hour > 0)/24.0d0 + day + year*1000d0 + end + + 'S' : begin ;string output + + month_name = months[month_num] +; +; encode into ascii_date +; + out = string(day_of_month,'(i2)') +'-'+ month_name +'-' + $ + string(year,'(i4)') + + ; Omit time of day from output string if not specified on input + IF hour GE 0 THEN out += ' '+tod + end + 'F' : begin + out = string(year,'(i4)')+'-'+string(month_num,'(I2.2)') $ + + '-' + string(day_of_month,'(i2.2)') + IF hour GE 0 THEN out += 'T' + tod + end + + 'J' : begin ; Julian Date + ydn2md, year, day, mn, dy + juldate, [year, mn, dy, hour, minute, sec], rjd + out = rjd+2400000 ; convert from reduced to regular JD + end + 'M' : begin ; Modified Julian Date = JD - 2400000.5 + ydn2md, year, day, mn, dy + juldate, [year, mn, dy, hour, minute, sec], rjd + out = rjd-0.5 ; convert from reduced to modified JD + end + + else: begin ;invalid type specified + print,'DATE_CONV-- Invalid output type specified' + print,' It must be ''REAL'', ''STRING'', ''VECTOR'', ''JULIAN'', ''MODIFIED'', or ''FITS''.' + return,-1 + end +endcase + +bad_date = 0B +return,out +; +; invalid input date error section +; +NOTVALID: +bad_date = 1B +message, 'Invalid input date specified', /INFORMATIONAL +return, -1 +end diff --git a/modules/idl_downloads/astro/pro/daycnv.pro b/modules/idl_downloads/astro/pro/daycnv.pro new file mode 100644 index 0000000..d0f7958 --- /dev/null +++ b/modules/idl_downloads/astro/pro/daycnv.pro @@ -0,0 +1,73 @@ +PRO DAYCNV, XJD, YR, MN, DAY, HR +;+ +; NAME: +; DAYCNV +; PURPOSE: +; Converts Julian dates to Gregorian calendar dates +; +; EXPLANATION: +; Duplicates the functionality of the intrinsic JUL2GREG procedure +; which was introduced in V8.2.1 +; CALLING SEQUENCE: +; DAYCNV, XJD, YR, MN, DAY, HR +; +; INPUTS: +; XJD = Julian date, positive double precision scalar or vector +; +; OUTPUTS: +; YR = Year (Integer) +; MN = Month (Integer) +; DAY = Day (Integer) +; HR = Hours and fractional hours (Real). If XJD is a vector, +; then YR,MN,DAY and HR will be vectors of the same length. +; +; EXAMPLE: +; IDL> DAYCNV, 2440000.D, yr, mn, day, hr +; +; yields yr = 1968, mn =5, day = 23, hr =12. +; +; WARNING: +; Be sure that the Julian date is specified as double precision to +; maintain accuracy at the fractional hour level. +; +; METHOD: +; Uses the algorithm of Fliegel and Van Flandern (1968) as reported in +; the "Explanatory Supplement to the Astronomical Almanac" (1992), p. 604 +; Works for all Gregorian calendar dates with XJD > 0, i.e., dates after +; -4713 November 23. +; REVISION HISTORY: +; Converted to IDL from Yeoman's Comet Ephemeris Generator, +; B. Pfarr, STX, 6/16/88 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + compile_opt idl2 + + if N_params() lt 2 then begin + print,"Syntax - DAYCNV, xjd, yr, mn, day, hr' + print,' Julian date, xjd, should be specified in double precision' + return + endif + +; Adjustment needed because Julian day starts at noon, calendar day at midnight + + jd = long(xjd) ;Truncate to integral day + frac = double(xjd) - jd + 0.5 ;Fractional part of calendar day + after_noon = where(frac ge 1.0, Next) + if Next GT 0 then begin ;Is it really the next calendar day? + frac[after_noon] = frac[after_noon] - 1.0 + jd[after_noon] = jd[after_noon] + 1 + endif + hr = frac*24.0 + l = jd + 68569 + n = 4*l / 146097l + l = l - (146097*n + 3l) / 4 + yr = 4000*(l+1) / 1461001 + l = l - 1461*yr / 4 + 31 ;1461 = 365.25 * 4 + mn = 80*l / 2447 + day = l - 2447*mn / 80 + l = mn/11 + mn = mn + 2 - 12*l + yr = 100*(n-49) + yr + l + return + end diff --git a/modules/idl_downloads/astro/pro/db_ent2ext.pro b/modules/idl_downloads/astro/pro/db_ent2ext.pro new file mode 100644 index 0000000..987424d --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_ent2ext.pro @@ -0,0 +1,121 @@ + PRO DB_ENT2EXT, ENTRY +;+ +; NAME: +; DB_ENT2EXT +; PURPOSE: +; Convert a database entry to external (IEEE) data format +; EXPLANATION: +; Converts a database entry to external (IEEE) data format prior to +; writing it. Called from DBWRT. +; +; CALLING SEQUENCE: +; DB_ENT2EXT, ENTRY +; +; INPUTS: +; ENTRY = Byte array containing a single record to be written to the +; database file. +; +; OUTPUTS: +; ENTRY = The converted array is returned in place of the input array. +; +; COMMON BLOCKS: +; DB_COM +; +; HISTORY: +; Version 1, William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Version 2, William Thompson, GSFC/CDS (ARC), 15 September 1995 +; Fixed bug where only the first element in a +; multidimensional array was converted. +; Version 2.1 W. Landsman August 2010 Fix for multidimensional strings +; Version 2.2 W. Landsman Sep 2011 Work with new DB format +;- +; + ON_ERROR,2 + COMPILE_OPT IDL2 +; +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2) +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .dbx file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 119 True if database is in external (IEEE) data format +; +; QITEMS[*,i] contains description of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; 24-25 Starting byte position in original DBF record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Print field length +; 100 Flag set to one if pointer item +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; +; +; QLINK[i] contains the entry number in the second data base +; corresponding to entry i in the first data base. +; + COMMON DB_COM,QDB,QITEMS,QLINK +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE, 'Syntax: DB_ENT2EXT, ENTRY' +; +; Get some information on the data base. +; + LEN = DB_INFO( 'LENGTH', 0 ) ;Record length + N_ITEMS = DB_INFO( 'ITEMS', 0 ) ;Number of items +; +; Determine if ENTRY is correct. +; + S = SIZE(ENTRY) + IF S[0] NE 1 THEN MESSAGE, 'ENTRY must be a 1-dimensional array' + IF S[1] NE LEN THEN MESSAGE, $ + 'ENTRY not the proper length of ' + STRTRIM(LEN,2) + ' bytes' + IF S[2] NE 1 THEN MESSAGE, 'ENTRY must be a byte array' +; +; Extract information about the individual items. +; + newdb = qdb[118, 0] + + IDLTYPE = FIX(QITEMS[20:21,*],0,N_ITEMS) + NVALUES = NEWDB ? LONG(QITEMS[179:182,*],0,N_ITEMS) : $ + FIX(QITEMS[22:23,*],0,N_ITEMS) + SBYTE = NEWDB ? LONG(QITEMS[183:186,*],0,N_ITEMS) : $ + FIX(QITEMS[24:25,*],0,N_ITEMS) + NBYTES = FIX(QITEMS[26:27,*],0,N_ITEMS)*NVALUES + BSWAP = (IDLTYPE NE 7) AND (IDLTYPE NE 1) +; +; For each entry, convert the data into external format. +; + FOR I = 0, N_ITEMS-1 DO BEGIN + IF BSWAP[I] THEN BEGIN + + ITEM = DBXVAL(ENTRY,IDLTYPE[I],NVALUES[I],SBYTE[I],NBYTES[I]) + SWAP_ENDIAN_INPLACE, ITEM, /SWAP_IF_LITTLE + DBXPUT, ITEM, ENTRY, IDLTYPE[I], SBYTE[I], NBYTES[I] + ENDIF + ENDFOR +; + RETURN + END diff --git a/modules/idl_downloads/astro/pro/db_ent2host.pro b/modules/idl_downloads/astro/pro/db_ent2host.pro new file mode 100644 index 0000000..5224950 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_ent2host.pro @@ -0,0 +1,134 @@ + PRO DB_ENT2HOST, ENTRY, DBNO +;+ +; NAME: +; DB_ENT2HOST +; PURPOSE: +; Converts a database entry from external data format to host format. +; EXPLANATION: +; All items are extracted from the entry, and then converted to host +; format, and placed back into the entry. Called from DBRD and DBEXT_DBF. +; +; CALLING SEQUENCE: +; DB_ENT2HOST, ENTRY, DBNO +; +; INPUTS: +; ENTRY = Byte array containing a single record read from the +; database file. +; DBNO = Number of the opened database file. +; +; OUTPUTS: +; ENTRY = The converted array is returned in place of the input array. +; +; COMMON BLOCKS: +; DB_COM +; +; HISTORY: +; Version 1, William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Version 2, William Thompson, GSFC/CDS (ARC), 15 September 1995 +; Fixed bug where only the first element in a +; multidimensional array was converted. +; Version 3, Richard Schwartz, GSFC/SDAC, 23 August 1996 +; Allow 2 dimensional byte arrays for entries to facilitate +; multiple entry processing. Pass IDLTYPE onto IEEE_TO_HOST +; Version 4, 2 May 2003, W. Thompson +; Use BSWAP keyword to DBXVAL instead of calling IEEE_TO_HOST. +; Version 4.1 W. Landsman August 2010 Fix for multidimensional strings +; Version 4.2 W. Landsman Sep 2011 Work with new DB format +;- +; + ON_ERROR,2 + COMPILE_OPT IDL2 +; +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2) +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .dbx file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 119 True if database is in external (IEEE) data format +; +; QITEMS[*,i] contains description of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; 24-25 Starting byte position in original DBF record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Print field length +; 100 Flag set to one if pointer item +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; +; +; QLINK[i] contains the entry number in the second data base +; corresponding to entry i in the first data base. +; + COMMON DB_COM,QDB,QITEMS,QLINK +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN MESSAGE, 'Syntax: DB_ENT2HOST, ENTRY, DBNO' +; +; Get some information on the data base. +; + LEN = DB_INFO( 'LENGTH', DBNO ) ;Record length + N_ITEMS = DB_INFO( 'ITEMS', DBNO ) ;Number of items +; +; Determine if ENTRY is correct. +; + S = SIZE(ENTRY) + IF S[0] GT 2 THEN MESSAGE, 'ENTRY must be a 1 or 2-dimensional array' + IF S[1] NE LEN THEN MESSAGE, $ + 'ENTRY not the proper length of ' + STRTRIM(LEN,2) + ' bytes' + IF S[2] NE 1 THEN MESSAGE, 'ENTRY must be a byte array' +; +; Find out which items belong to the database given by DBNO. +; + N = (SIZE(QITEMS))[2] ;Number of items in combined database. + DB_NUM = FIX(QITEMS[173:174,*],0,N) + W = WHERE(DB_NUM EQ DBNO, COUNT) + IF COUNT NE N_ITEMS THEN MESSAGE, $ + 'Database inconsistency--problem with number of items' +; +; Extract information about the individual items. +; + newdb = qdb[118, 0] + IDLTYPE = FIX(QITEMS[20:21,*],0,N) & IDLTYPE = IDLTYPE[W] + NVALUES = NEWDB ? LONG(QITEMS[179:182,*],0,N) : $ + FIX(QITEMS[22:23,*],0,N) & NVALUES = NVALUES[W] + SBYTE = NEWDB ? LONG(QITEMS[183:186,*],0,N) : $ + FIX(QITEMS[24:25,*],0,N) & SBYTE = SBYTE[W] + NBYTES = FIX(QITEMS[26:27,*],0,N) & NBYTES = NBYTES[W] + BSWAP = (IDLTYPE NE 7) AND (IDLTYPE NE 1) +; +; For each entry, convert the data into external format. +; + FOR I = 0, N_ITEMS-1 DO BEGIN + NB = NBYTES[I]*NVALUES[I] + ITEM = DBXVAL(ENTRY,IDLTYPE[I],NVALUES[I],SBYTE[I],NB,$ + BSWAP = BSWAP[I]) + + DBXPUT, ITEM, ENTRY, IDLTYPE[I], SBYTE[I], NB + ENDFOR + +; + RETURN + END diff --git a/modules/idl_downloads/astro/pro/db_info.pro b/modules/idl_downloads/astro/pro/db_info.pro new file mode 100644 index 0000000..77d0dd8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_info.pro @@ -0,0 +1,218 @@ +function db_info,request,dbname +;+ +; NAME: +; DB_INFO +; PURPOSE: +; Function to obtain information on opened data base file(s) +; +; CALLING SEQUENCES: +; 1) result = db_info(request) +; 2) result = db_info(request,dbname) +; INPUTS (calling sequence 1): +; +; request - string specifying requested value(s) +; value of request value returned in result +; 'open' Flag set to 1 if data base(s) are opened +; 'number' Number of data base files opened +; 'items' Total number of items (all db's opened) +; 'update' update flag (1 if opened for update) +; 'unit_dbf' Unit number of the .dbf files +; 'unit_dbx' Unit number of the .dbx files +; 'entries' Number of entries in the db's +; 'length' Record lengths for the db's +; 'external' True if the db's are in external format +; +; INPUTS (calling sequence 2): +; +; request - string specifying requested value(s) +; value of request value returned in result +; 'name' Name of the data base +; 'number' Sequential number of the db +; 'items' Number of items for this db +; 'item1' Position of item1 for this db +; in item list for all db's +; 'item2' Position of last item for this db. +; 'pointer' Number of the item which points +; to this db. 0 for first or primary +; db. -1 if link file pointers. +; 'length' Record length for this db. +; 'title' Title of the data base +; 'unit_dbf' Unit number of the .dbf file +; 'unit_dbx' Unit number of the .dbx file +; 'entries' Number of entries in the db +; 'seqnum' Last sequence number used +; 'alloc' Allocated space (# entries) +; 'update' 1 if data base opened for update +; 'external' True if data base in external format +; 'newdb' True if new (post Oct 2010) format +; that allows entries > 32767 bytes +; +; dbname - data base name or number +; OUTPUTS: +; Requested value(s) are returned as the function value. +; +; HISTORY: +; version 1 D. Lindler Oct. 1987 +; changed type from 1 to 7 for IDLV2, J. Isensee, Nov., 1990 +; William Thompson, GSFC/CDS (ARC), 30 May 1994 +; Added EXTERNAL request type. +; Support new DB format, add NEWDB request type W. Landsman Oct 2010 +;- +;------------------------------------------------------------------------ +on_error,2 ;Return to caller +; +; data base common block +; +common db_com,QDB,QITEMS,QLINK +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2), old format +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .dbx file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 105-108 record length of DBF file (integer*4), new format +; 119 True if database is in external (IEEE) format +; +; QITEMS[*,i] contains deacription of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; 24-25 Starting byte position in original DBF record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Print field length +; 100 Flag set to one if pointer item +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD, old format +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; 177-178 Item number within the specific data base +; 179-182 Number of values for item (1 for scalar) (integer*4) +; 183-186 Starting byte position in original DBF record (integer*4) +; 187-190 Starting byte in record returned by DBRD +; +; +; QLINK[i] contains the entry number in the second data base +; corresponding to entry i in the first data base. +;------------------------------------------------------------------------- +; +req=strtrim(strupcase(request)) ;requested value +s=size(qdb) +if req eq 'OPEN' then begin + if s[0] eq 0 then return,0 else return,1 +end +if s[0] eq 0 then message,'No data base file(s) opened' +n=s[2] ;number of data bases +; +; calling sequence 1 result=db_info(request) +; +newdb = qdb[118,0] +if N_params() lt 2 then begin + case req of + 'NUMBER' : return,n ;number of files opened + 'ITEMS' : begin ;total number of items + s=size(qitems) + return,s[2] + end + 'LENGTH' : begin + len = newdb ? long( qdb[105:108,*],0,n) : $ + fix(qdb[82:83,*],0,n) + return,len + end + ;total record length + 'UPDATE' : return,qdb[104,0] ;update flag + 'UNIT_DBF' : return,qdb[96,*] ;.dbf unit number + 'UNIT_DBX' : return,qdb[97,*] ;.dbx unit number + 'ENTRIES' : return,long(qdb[84:87,*],0,n) ;number of entries + 'EXTERNAL' : return,qdb[119,*] eq 1 ;external format? + 'NEWDB' : return, newdb ;New db format? + else : message,'Invalid request for information' + endcase +endif +; +; second calling sequence: result=db_info(request,dbname) ---------- +; +s=size(dbname) +ndim=s[0] +type=s[ndim+1] +if (ndim gt 0) || (type eq 0) then goto,abort +; +; convert name to number +; +if type eq 7 then begin + db_name=strtrim(strupcase(dbname)) + for i=0,n-1 do $ + if db_name eq strtrim(string(qdb[0:18,i])) then goto,found + goto,abort ;not found +found: dbnum=i + end else begin ;number supplied + dbnum=fix(dbname) + if (dbnum lt 0) || (dbnum ge n) then goto,abort +end +newdb = qdb[118,dbnum] + +case req of + 'NAME' : return,strtrim(string(qdb[0:18,dbnum])) ;db name + 'NUMBER' : return,dbnum ;data base number + 'ITEMS' : begin ;number of items + x=fix(qdb[80:81,dbnum],0,1) + return,x[0] + end + 'ITEM1' : begin ;starting item number + x=fix(qdb[88:89,dbnum],0,1) + return,x[0] + end + 'ITEM2' : begin ;last item number + x=fix(qdb[90:91,dbnum],0,1) + return,x[0] + end + 'POINTER' : begin ;item number pointer + x=fix(qdb[98:99,dbnum],0,1) + return,x[0] + end + 'LENGTH' : begin + x = newdb ? long(qdb[105:108,dbnum],0,1) : $ ;record length + fix(qdb[82:83,dbnum],0,1) + return,long(x[0]) + end + 'TITLE' : return,strtrim(string(qdb[19:79,dbnum])) ;data base title + 'UNIT_DBF' : return,qdb[96,dbnum] ;.dbf unit number + 'UNIT_DBX' : return,qdb[97,dbnum] ;.dbx unit number + 'ENTRIES' : begin ;number of entries + x=long(qdb[84:87,dbnum],0,1) + return,x[0] + end + 'SEQNUM' : begin ;last sequence number + x=long(qdb[92:95,dbnum],0,1) + return,x[0] + end + 'ALLOC' : begin ;allocated size + x=long(qdb[100:103,dbnum],0,1) + return,x[0] + end + 'UPDATE' : return,qdb[104,dbnum] ;update flag + 'EXTERNAL' : begin ;External format? + x=qdb[119,*] eq 1 + return,x[0] + end + 'NEWDB' : return, newdb ;New db format? + else: message,'Invalid information request' +endcase +abort: message,'Invalid data base name or number supplied' +end diff --git a/modules/idl_downloads/astro/pro/db_item.pro b/modules/idl_downloads/astro/pro/db_item.pro new file mode 100644 index 0000000..626dc07 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_item.pro @@ -0,0 +1,347 @@ +pro db_item,items,itnum,ivalnum,idltype,sbyte,numvals,nbytes,errmsg=errmsg +;+ +; NAME: +; DB_ITEM +; PURPOSE: +; Returns the item numbers and other info. for an item name. +; EXPLANATION: +; Procedure to return the item numbers and other information +; of a specified item name +; +; CALLING SEQUENCE: +; db_item, items, itnum, ivalnum, idltype, sbyte, numvals, nbytes +; +; INPUTS: +; items - item name or number +; form 1 scalar string giving item(s) as list of names +; separated by commas +; form 2 string array giving list of item names +; form 3 string of form '$filename' giving name +; of text file containing items (one item per +; line) +; form 4 integer scalar giving single item number or +; integer vector list of item numbers +; form 5 Null string specifying interactive selection +; Upon return items will contain selected items +; in form 1 +; form 6 '*' select all items +; +; OUTPUTS: +; itnum - item number +; ivalnum - value(s) number from multiple valued item +; idltype - data type(s) (1=string,2=byte,4=i*4,...) +; sbyte - starting byte(s) in entry +; numvals - number of data values for item(s) +; It is the full length of a vector item unless +; a subscript was supplied +; nbytes - number of bytes for each value +; All outputs are vectors even if a single item is requested +; +; OPTIONAL INPUT KEYWORDS: +; ERRMSG = If defined and passed, then any error messages will +; be returned to the user in this parameter rather than depending +; on the MESSAGE routine in IDL. If no errors are encountered, +; then a null string is returned. In order to use this feature, +; ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; DB_ITEM, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; PROCEDURE CALLS: +; DB_INFO, GETTOK, SELECT_W +; +; REVISION HISTORY: +; Written: D. Lindler, GSFC/HRS, October 1987 +; Version 2, William Thompson, GSFC, 17-Mar-1997 +; Added keyword ERRMSG +; Use STRSPLIT instead of GETTOK to parse form 1, W. Landsman July 2002 +; Assume since V5.4 use FILE_EXPAND_PATH() instead of SPEC_DIR() +; W. Landsman April 2006 +; Support new DB format allowing entry lengths > 32767 bytes WL Oct 2010 +; Ignore blank lines in .items file WL February 2011 +;- +; +;------------------------------------------------------------------------ + compile_opt idl2 + On_error,2 + if N_params() LT 2 then begin + print,'Syntax - DB_ITEM,items,itnum,ivalnum,idltype,sbyte,numvals,nbytes' + return + endif +; data base common block +; +common db_com,QDB,QITEMS,QLINK +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2) old DB format +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .dbx file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 105-108 record length of DBF file (integer*4) +; 118 Equals 1 if database can store records larger than 32767 bytes +; 119 Equals 1 if external data representation (IEEE) is used +; +; QITEMS[*,i] contains a description of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; 24-25 Starting byte position in original DBF record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Print field length +; 100 Flag set to one if pointer item +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD, old DB format +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; 177-178 Item number within the specific data base +; 179-182 Number of values for item (1 for scalar) (integer*4) +; 183-186 Starting byte position in original DBF record (integer*4) +; 187-190 Starting byte in record returned by DBRD +; +; +; QLINK[i] contains the entry number in the second data base +; corresponding to entry i in the first data base. +;------------------------------------------------------------------------- +if n_elements(items) eq 0 then items = '' +; +; check if data base open +; +if n_elements(qdb) lt 120 then begin + message = 'data base file not open' + goto, handle_error +endif + +; +; determine type of item list ------------------------------------------- +; +vector=1 ;vector output flag +newdb = qdb[118,0] EQ 1 +s=size(items,/str) +ndim = s.n_dimensions +if s.type_name eq 'STRING' then begin ;string(s) + if ndim eq 0 then begin ;string scalar? + if strtrim(items) eq '' then form=5 else $ ;null string - form 5 + if strmid(items,0,1) eq '$' then form=3 $ ;filename - form 3 + else form=1 ;scalar list - form 1 + if strtrim(items) eq '*' then form=6 ;all items '*' - form 6 + end else form=2 ;string vector - form 2 + end else begin ;non-string + form=4 ;integer - form 4 +end +s=size(qitems) +if s[0] ne 2 then begin + message = 'No data base opened' + goto, handle_error +endif +qnumit=s[2] + +;----------------------------------------------------------------------------- +; CONVERT INPUT ITEMS TO INTEGER LIST OR STRING LIST +; +; +; Form 4 ------------------ Integer +; +If form eq 4 then begin + if ndim eq 0 then begin + itnum=intarr(1)+items + ivalnum=intarr(1) + ivalflag=intarr(1) + goto,scalar ;speedy method + end else begin + itnum=items + nitems=n_elements(itnum) + ivalflag=bytarr(nitems) + ivalnum=intarr(nitems) + if (min(itnum) lt 0) or (max(itnum) ge qnumit) then begin + message = 'Invalid item number specified' + goto, handle_error + endif + goto,vector + end +end + +; +; Form 3 ----------------- File name +; +if form eq 3 then begin + item_names=strarr(200) ;input buffer + if strlen(items) gt 1 then filename=strmid(items,1,strlen(items)-1) $ + else filename=strtrim(db_info('name',0))+'.items' + if ~file_test(filename) then begin + message = 'Unable to locate file ' + FILE_EXPAND_PATH(filename) + $ + ' with item list' + goto, handle_error + endif + nlines = file_lines(filename) + item_names = strarr(nlines) + openr,unit,filename,/get_lun ;open file + readf,unit,item_names + free_lun,unit + item_names = strtrim(item_names,2) +; Remove any blank lines + good = where(strlen(item_names) GT 0, Nitems) + if Nitems LT Nlines then item_names = item_names[good] +end +; +; form 1 ----------------- scalar string list 'item1,item2,item3...' +; + if form eq 1 then begin + item_names = strsplit(items,',',/EXTRACT) + nitems = N_elements(item_names) + endif +; +; form 2 -------------------------- string array +; +if form eq 2 then begin + item_names=items + nitems = N_elements(items) +endif +; +; form 5 -------------------------- null string (interactive input) +; +if form eq 5 then begin + names=strtrim(qitems[0:19,*],2) + desc=string(qitems[29:78,*]) + select_w,names,itnum,desc,'Select List of Items',count=count + if count le 0 then begin + message = 'No items selected' + goto, handle_error + endif +; + nitems=n_elements(itnum) + items = strtrim(names[itnum[0]],2) + if nitems gt 1 then for i=1,nitems-1 do $ + items = items +','+strtrim(names[itnum[i]],2) + ivalflag=bytarr(nitems) + ivalnum=intarr(nitems) + goto,vector +end +; +; Form 4 ------------------ '*' select all items +; +If form eq 6 then begin + nitems=db_info('items') ;number of items + itnum=indgen(nitems) + ivalflag=bytarr(nitems) + ivalnum=intarr(nitems) + goto,vector +end +; +;------------------------------------------------------------------------- +; CONVERT STRING LIST TO INTEGER LIST AND PULL OFF SUBSCRIPT IF SUPPLIED +; +; + names=strtrim(qitems[0:19,*],2) ;all possible item names + ivalnum=intarr(nitems) ;selection of multi-value items + ivalflag=bytarr(nitems) ;Flag for subscripted items + itnum=intarr(nitems) ;integer item numbers +; +; loop on item names supplied +; + for i=0,nitems-1 do begin ;loop on items + st=strtrim(item_names[i],2) ;get item + name=gettok(st,'(') ;get name +; +; subscript supplied +; + if st ne '' then begin ;number supplied? + ivalnum[i]=fix(gettok(st,')')) ;get number + ivalflag[i]=1 + end; +; +; data base name supplied +; + if strpos(name,'.') ge 0 then begin ;data base name supplied + dbname=gettok(name,'.') ; form is 'dbname.itemname' + i1=db_info('item1',dbname) ;first item for the db + i2=db_info('item2',dbname) ;last item for the db + end else begin ;search all items + i1=0 & i2=qnumit-1 + end +; +; search for item name +; + name=strupcase(name) ;convert to upper case + j = where(names[i1:i2] eq name,nmatch) + if nmatch eq 0 then begin + message = 'Item '+ name +' is invalid' + goto, handle_error + endif +itnum[i] =j[0] +i1 ;save item number +endfor;i loop on items +if nitems eq 1 then goto,scalar ;speedy method + +; +;--------------------------------------------------------------------------- +; We now have +; 1) integer list of item numbers of length nitems +; 2) we have list of ivalnum (subscripts) with +; flag(s) ivalflag if subscript supplied +; EXTRACT OTHER PARAMETERS +; + +vector: ;---- vector processing + idltype = fix(qitems[20:21,*],0,qnumit) + numvals = newdb ? long(qitems[179:182,*],0,qnumit) : $ + fix(qitems[22:23,*],0,qnumit) + sbyte = newdb ? long(qitems[187:190,*],0,qnumit) : $ + fix(qitems[171:172,*],0,qnumit) + nbytes = fix(qitems[26:27,*],0,qnumit) + idltype = idltype[itnum] + numvals = numvals[itnum] + sbyte = sbyte[itnum] + nbytes = nbytes[itnum] +; +; add offset for subscripted variables +; +sbyte=sbyte+ivalnum*nbytes +; +; if ivalflag is set we have subscripted item and don't want all +; values in vector +; +pos=where(ivalflag, Npos) +if Npos GT 0 then numvals[pos]=1 +return +; +; ----------------------- +scalar: ;------- scalar processing +it=itnum[0] +if (it lt 0) or (it ge qnumit) then begin + message = 'Invalid item number '+strtrim(it,2)+' specified' + goto, handle_error +endif +; +idltype = fix(qitems[20:21,it],0,1) +numvals = newdb ? long(qitems[179:182,it],0,1) : $ + fix(qitems[22:23,it],0,1) +sbyte = newdb ? long(qitems[187:190,it],0,1) : $ + fix(qitems[171:172,it],0,1) +nbytes = fix(qitems[26:27,it],0,1) +sbyte = sbyte+nbytes*ivalnum +if ivalflag[0] then numvals[0]=1 +return +; +; Error handling point. +; +HANDLE_ERROR: + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = 'DB_ITEM: ' + MESSAGE $ + ELSE MESSAGE, MESSAGE +end diff --git a/modules/idl_downloads/astro/pro/db_item_info.pro b/modules/idl_downloads/astro/pro/db_item_info.pro new file mode 100644 index 0000000..1dfa2b7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_item_info.pro @@ -0,0 +1,122 @@ +function db_item_info,request,itnums +;+ +; NAME: +; DB_ITEM_INFO +; PURPOSE: +; routine to return information on selected item(s) in the opened +; data bases. +; +; CALLING SEQUENCE: +; result = db_item_info( request, itnums) +; INPUTS: +; request - string giving the requested information. +; 'name' - item names +; 'idltype' - IDL data type (integers) +; see documentation of intrinsic SIZE funtion +; 'nvalues' - vector item length (1 for scalar) +; 'sbyte' - starting byte in .dbf record (use bytepos +; to get starting byte in record returned by +; dbrd) +; 'nbytes' - bytes per data value +; 'index' - index types +; 'description' - description of the item +; 'pflag' - pointer item flags +; 'pointer' - data bases the items point to +; 'format' - print formats +; 'flen' - print field length +; 'headers' - print headers +; 'bytepos' - starting byte in dbrd record for the items +; 'dbnumber' - number of the opened data base +; 'pnumber' - number of db it points to (if the db is +; opened) +; 'itemnumber' - item number in the file +; +; itnums -(optional) Item numbers. If not supplied info on all items +; are returned. +; OUTPUT: +; Requested information is returned as a vector. Its type depends +; on the item requested. +; HISTORY: +; version 1 D. Lindler Nov. 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Support new DB format which allows > 32767 bytes W.L. Oct 2010 +;- +;------------------------------------------------------------------------ +; data base common block +; +common db_com,QDB,QITEMS,QLINK +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2) +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .IND file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 119 Equals 1 if external data representation (IEEE) is used +; +; QITEMS[*,i] contains a description of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; 24-25 Starting byte position in original DBF record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Print format field length +; 100 Flag set to one if pointer item +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; 177-178 item number within file +; 179-182 Number of values for item (1 for scalar) (integer*4) +; 183-186 Starting byte position in original DBF record (integer*4) +; 187-190 Starting byte in record returned by DBRD +; +; QLINK[i] contains the entry number in the second data base +; corresponding to entry i in the first data base. +;------------------------------------------------------------------------- +s=size(qitems) & n=s[2] +newdb = qdb[118,0] EQ 1 +case strupcase(strtrim(request)) of + + 'NAME' : x=string(qitems[0:19,*]) + 'IDLTYPE' : x=fix(qitems[20:21,*],0,n) + 'NVALUES' : x = newdb? long(qitems[179:182,*],0,n) : $ + fix(qitems[22:23,*],0,n) + 'SBYTE' : x = newdb ? long(qitems[183:186,*],0,n) : $ + fix(qitems[24:25,*],0,n) + 'NBYTES' : x=fix(qitems[26:27,*],0,n) + 'INDEX' : x=qitems[28,*] + 'DESCRIPTION' : x=string(qitems[29:99,*]) + 'PFLAG' : x=qitems[100,*] + 'POINTER' : x=string(qitems[101:119,*]) + 'FORMAT' : x=string(qitems[120:125,*]) + 'FLEN' : x=fix(qitems[98:99,*],0,n) + 'HEADERS' : x=string(qitems[126:170,*]) + 'BYTEPOS' : x = newdb ? long(qitems[187:190,*],0,n) : $ + fix(qitems[171:172,*],0,n) + 'DBNUMBER' : x=fix(qitems[173:174,*],0,n) + 'PNUMBER' : x=fix(qitems[175:176,*],0,n) + 'ITEMNUMBER' : x=fix(qitems[177:178,*],0,n) + else: begin + print,'DB_ITEM_INFO-- invalid information request' + retall + end +endcase +if N_params() eq 1 then return,x else return,x[itnums] +end diff --git a/modules/idl_downloads/astro/pro/db_or.pro b/modules/idl_downloads/astro/pro/db_or.pro new file mode 100644 index 0000000..cb6cd10 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_or.pro @@ -0,0 +1,52 @@ +function db_or,list1,list2 +;+ +; NAME: +; DB_OR +; PURPOSE: +; Combine two vectors of entry numbers, removing duplicate values. +; EXPLANATION: +; DB_OR can also be used to remove duplicate values from any longword +; vector +; +; CALLING SEQUENCE: +; LIST = DB_OR( LIST1 ) ;Remove duplicate values from LIST1 +; or +; LIST = DB_OR( LIST1, LIST2 ) ;Concatenate LIST1 and LIST2, remove dups +; +; INPUTS: +; LIST1, LIST2 - Vectors containing entry numbers, must be non-negative +; integers or longwords. +; OUTPUT: +; LIST - Vector containing entry numbers in either LIST1 or LIST2 +; +; METHOD +; DB_OR returns where the histogram of the entry vectors is non-zero +; +; PROCEDURE CALLS +; ZPARCHECK - checks parameters +; REVISION HISTORY: +; Written, W. Landsman February, 1989 +; Check for degenerate values W.L. February, 1993 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + if N_params() EQ 0 then begin + print,'Syntax - list = db_or( list1, [ list2] ) + return, -1 + endif + + zparcheck, 'DB_OR', list1, 1, [1,2,3], [1,2], 'First Entry Vector' + + if N_params() eq 1 then begin + minlist1 = min( list1, max = maxlist1 ) + if ( minlist1 EQ maxlist1 ) then return, minlist1 else $ + return, where( histogram( list1 ) GT 0 ) + minlist1 + endif + + zparcheck, 'DB_OR', list1, 1, [1,2,3], [1,2], 'Second Entry Vector' + + list = [list1, list2] + minlist = min( list, max = maxlist ) + if ( minlist EQ maxlist ) then return, minlist else $ + return,where( histogram( list ) GT 0 ) + minlist + + end diff --git a/modules/idl_downloads/astro/pro/db_titles.pro b/modules/idl_downloads/astro/pro/db_titles.pro new file mode 100644 index 0000000..3cb8389 --- /dev/null +++ b/modules/idl_downloads/astro/pro/db_titles.pro @@ -0,0 +1,54 @@ +pro db_titles,fnames,titles +;+ +; NAME: +; DB_TITLES +; +; PURPOSE: +; Print database name and title. Called by DBHELP +; +; CALLING SEQUENCE: +; db_titles, fnames, titles +; +; INPUT: +; fnames - string array of data base names +; +; SIDE EFFECT: +; Database name is printed along with the description in the .dbh file +; +; HISTORY: +; version 2 W. Landsman May, 1989 +; modified to work under Unix, D. Neill, ACC, Feb 1991. +; William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Added support for external (IEEE) representation. +; William Thompson, GSFC, 3 November 1994 +; Modified to allow ZDBASE to be a path string. +; Converted to IDL V5.0 W. Landsman September 1997 +; Assume since V5.5, W. Landsman September 2006 +;- +; +;----------------------------------------------------------------------------- + compile_opt idl2 + n = N_elements(fnames) + get_lun,unit + b = bytarr(59) + npar = N_params() + if npar eq 2 then titles = strarr(n) + for i = 0,n-1 do begin + dbh_file = find_with_def(strtrim(fnames[i])+'.dbh', 'ZDBASE') + openr,unit,dbh_file,error=err + if err lt 0 then $ ;Does database exist? + printf,!TEXTUNIT,'Unable to locate database ',fnames[i] $ + else begin + readu,unit,b + if npar eq 1 then begin + printf,!TEXTUNIT,format='(A,T20,A)',fnames[i],strtrim(b[19:58],2) + endif else titles[i] = string(b[19:58]) + endelse + + close,unit + + endfor + + free_lun,unit + return +end diff --git a/modules/idl_downloads/astro/pro/dbbuild.pro b/modules/idl_downloads/astro/pro/dbbuild.pro new file mode 100644 index 0000000..58b78d1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbbuild.pro @@ -0,0 +1,168 @@ +pro dbbuild,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18, $ + v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,v31,v32,v33,v34,v35,v36, $ + v37,v38,v39,v40,v41,v42,v43,v44,v45,v46,v47,v48,v49,v50, $ + NOINDEX = noindex, STATUS=STATUS, SILENT=SILENT +;+ +; NAME: +; DBBUILD +; PURPOSE: +; Build a database by appending new values for every item. +; EXPLANATION: +; The database must be opened for update (with DBOPEN) before calling +; DBBUILD. +; +; CALLING SEQUENCE: +; DBBUILD, [ v1, v2, v3, v4......v50, /NOINDEX, /SILENT, STATUS = ] +; +; INPUTS: +; v1,v2....v50 - vectors containing values for all items in the database. +; V1 contains values for the first item, V2 for the second, etc. +; The number of vectors supplied must equal the number of items +; (excluding entry number) in the database. The number of elements +; in each vector should be the same. A multiple valued item +; should be dimensioned NVALUE by NENTRY, where NVALUE is the number +; of values, and NENTRY is the number of entries. +; +; OPTIONAL INPUT KEYWORDS: +; /NOINDEX - If this keyword is supplied and non-zero then DBBUILD will +; *not* create an indexed file. Useful to save time if +; DBBUILD is to be called several times and the indexed file need +; only be created on the last call +; +; /SILENT - If the keyword SILENT is set and non-zero, then DBBUILD +; will not print a message when the index files are generated +; +; OPTIONAL OUTPUT KEYWORD: +; STATUS - Returns a status code denoting whether the operation was +; successful (1) or unsuccessful (0). Useful when DBBUILD is +; called from within other applications. +; +; EXAMPLE: +; Suppose a database named STARS contains the four items NAME,RA,DEC, and +; FLUX. Assume that one already has the four vectors containing the +; values, and that the database definition (.DBD) file already exists. +; +; IDL> !PRIV=2 ;Writing to database requires !PRIV=2 +; IDL> dbcreate,'stars',1,1 ;Create database (.dbf) & index (.dbx) file +; IDL> dbopen,'stars',1 ;Open database for update +; IDL> dbbuild,name,ra,dec,flux ;Write 4 vectors into the database +; +; NOTES: +; Do not call DBCREATE before DBBUILD if you want to append entries to +; an existing database +; +; DBBUILD checks that each value vector matches the idl type given in the +; database definition (..dbd) file, and that character strings are the +; proper length. +; PROCEDURE CALLS: +; DBCLOSE, DBINDEX, DBXPUT, DBWRT, IS_IEEE_BIG() +; REVISION HISTORY: +; Written W. Landsman March, 1989 +; Added /NOINDEX keyword W. Landsman November, 1992 +; User no longer need supply all items W. Landsman December, 1992 +; Added STATUS keyword, William Thompson, GSFC, 1 April 1994 +; Added /SILENT keyword, William Thompson, GSFC, October 1995 +; Allow up to 30 items, fix problem if first item was multiple value +; W. Landsman GSFC, July 1996 +; Faster build of external databases on big endian machines +; W. Landsman GSFC, November 1997 +; Use SIZE(/TNAME) for error mesage display W.Landsman July 2001 +; Fix message display error introduced July 2001 W. Landsman Oct. 2001 +; Make sure error message appears even if !QUIET is set W.L November 2006 +; Major rewrite to use SCOPE_VARFETCH, accept 50 input items +; W. Landsman November 2006 +; Fix warning if parameters have different # of elements W.L. May 2010 +; Fix warning if scalar parameter supplied W.L. June 2010 +; Fix for when first parameter is multi-dimensioned W.L. July 2010 +; Check data type of first parameter W.L. Jan 2012 +;- + COMPILE_OPT IDL2 + On_error,2 ;Return to caller + npar = N_params() + if npar LT 1 then begin + print,'Syntax - DBBUILD, v1, [ v2, v3, v4, v5, ... v50,' + print,' /NOINDEX, /SILENT, STATUS = ]' + return + endif + + dtype = ['UNDEFINED','BYTE','INT','LONG','FLOAT','DOUBLE', $ + 'COMPLEX','STRING','STRUCT','DCOMPLEX','POINTER','OBJREF', $ + 'UINT', 'ULONG', 'LONG64','ULONG64'] + + +; Initialize STATUS as unsuccessful (0). If the routine is successful, this +; will be updated below. + + status = 0 + + nitem = db_info( 'ITEMS' ) + if nitem LE npar then message, 'ERROR - ' + strtrim(npar,2) + $ $ + ' variables supplied but only ' + strtrim(nitem-1,2) + ' items in database' + + items = indgen(nitem) + db_item, items, itnum, ivalnum, idltype, sbyte, numvals, nbyte + nitems = ( npar < nitem) + vv = 'v' + strtrim( indgen(nitems+1), 2) + +;Create a pointer array to point at each of the supplied variables + tmp = ptrarr(nitems,/allocate_heap) + for i=0,nitems-1 do *tmp[i] = SCOPE_VARFETCH(vv[i+1], LEVEL=0) + + ndata = N_elements(v1)/ numvals[1] ;# of elements in last dimension + + for i = 1,npar do begin ;Get the dimensions and type of each input vector + + sz = size( *tmp[i-1], /STRUCT) + ndatai = sz.N_elements/numvals[i] + if ndatai NE ndata then message, $ + 'WARNING - Parameter ' + strtrim(i,2) + ' has dimension ' + $ + strjoin(strtrim( sz.dimensions[0:sz.n_dimensions-1 > 0],2),' ') ,/con + if sz.type_name NE dtype[idltype[i]] then begin + message, 'Item ' + strtrim( db_item_info('NAME',i),2) + $ + ' - parameter '+strtrim(i,2) + ' - has an incorrect data type',/CON + message, 'Required data type is ' + dtype[idltype[i]], /INF + message, 'Supplied data type is ' + sz.type_name, /INF + ptr_free,tmp + return + endif + + endfor + external = db_info('external',0) + noconvert = external ? is_ieee_big() : 1b + + entry = make_array( DIMEN = db_info('LENGTH'),/BYTE ) ;Empty entry array + nvalues = long( db_item_info( 'NVALUES' ) ) ;# of values per item + nbyte = nbyte*nvalues ;Number of bytes per item + + for i = 0l, Ndata - 1 do begin + i1 = i*nvalues + i2 = i1 + nvalues -1 + + dbxput,0l,entry,idltype[0],sbyte[0],nbyte[0] + for j = 1,nitems do $ + dbxput, (*tmp[j-1])[ i1[j]:i2[j] ], $ + entry,idltype[j], sbyte[j], nbyte[j] + + dbwrt,entry,noconvert=noconvert ;Write the entry into the database + + endfor + ptr_free,tmp + + if ~keyword_set( NOINDEX ) then begin + + indexed = db_item_info( 'INDEX' ) ;Need to create an indexed file? + if ~array_equal(indexed,0) then begin + if ~keyword_set(silent) then $ + message,'Now creating indexed files',/INF + dbindex,items + endif + + endif + + dbclose + +; Mark successful completion, and return. + + status = 1 + return + end diff --git a/modules/idl_downloads/astro/pro/dbcircle.pro b/modules/idl_downloads/astro/pro/dbcircle.pro new file mode 100644 index 0000000..8c5a44b --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbcircle.pro @@ -0,0 +1,208 @@ +function dbcircle, ra_cen, dec_cen, radius, dis, sublist,SILENT=silent, $ + TO_J2000 = to_J2000, TO_B1950 = to_B1950, GALACTIC= galactic, $ + COUNT = nfound +;+ +; NAME: +; DBCIRCLE +; PURPOSE: +; Find sources in a database within specified radius of specified center +; EXPLANATION: +; Database must include items named 'RA' (in hours) and 'DEC' (in degrees) +; and must have previously been opened with DBOPEN +; +; CALLING SEQUENCE: +; list = DBCIRCLE( ra_cen, dec_cen, [radius, dis, sublist, /SILENT, +; /GALACTIC, TO_B1950, /TO_J2000, COUNT= ] ) +; +; INPUTS: +; RA_CEN - Right ascension of the search center in decimal HOURS, scalar +; DEC_CEN - Declination of the search center in decimal DEGREES, scalar +; RA_CEN and DEC_CEN should be in the same equinox as the +; currently opened catalog. +; +; OPTIONAL INPUT: +; RADIUS - Radius of the search field in arc minutes, scalar. +; DBCIRCLE prompts for RADIUS if not supplied. +; SUBLIST - Vector giving entry numbers in currently opened database +; to be searched. Default is to search all entries +; +; OUTPUTS: +; LIST - Vector giving entry numbers in the currently opened catalog +; which have positions within the specified search circle +; LIST is set to -1 if no sources fall within the search circle +; +; OPTIONAL OUTPUT +; DIS - The distance in arcminutes of each entry specified by LIST +; to the search center (given by RA_CEN and DEC_CEN) +; +; OPTIONAL KEYWORD INPUT: +; /GALACTIC - if set, then the first two parameters are interpreted as +; Galactic coordinates in degrees, and is converted internally +; to J2000 celestial to search the database. +; /SILENT - If this keyword is set, then DBCIRCLE will not print the +; number of entries found at the terminal +; /TO_J2000 - If this keyword is set, then the entered coordinates are +; assumed to be in equinox B1950, and will be converted to +; J2000 before searching the database +; /TO_B1950 - If this keyword is set, then the entered coordinates are +; assumed to be in equinox J2000, and will be converted to +; B1950 before searching the database +; NOTE: The user must determine on his own whether the database +; is in B1950 or J2000 coordinates. +; OPTIONAL KEYWORD OUTPUT: +; COUNT - - Integer scalar giving the number of valid matches +; METHOD: +; A DBFIND search is first performed on a square area of given radius. +; The list is the restricted to a circular area by using GCIRC to +; compute the distance of each object to the field center. +; +; RESTRICTIONS; +; The database must have items 'RA' (in hours) and 'DEC' (in degrees). +; Alternatively, the database could have items RA_OBJ and DEC_OBJ +; (both in degrees) +; EXAMPLE: +; Find all Hipparcos stars within 40' of the nucleus of M33 +; (at J2000 1h 33m 50.9s 30d 39' 36.7'') +; +; IDL> dbopen,'hipparcos' +; IDL> list = dbcircle( ten(1,33,50.9), ten(3,39,36.7), 40) +; +; PROCEDURE CALLS: +; BPRECESS, DBFIND(), DBEXT, DB_INFO(), GCIRC, GLACTC, JPRECESS +; REVISION HISTORY: +; Written W. Landsman STX January 1990 +; Fixed search when crossing 0h July 1990 +; Spiffed up code a bit October, 1991 +; Leave DIS vector unchanged if no entries found W. Landsman July 1999 +; Use maximum declination, rather than declination at field center to +; correct RA for latitude effect W. Landsman September 1999 +; Added COUNT, GALACTIC keywords W. Landsman December 2008 +; Fix problem when RA range exceeds 24h W. Landsman April 2009 +; Work as advertised for RA_OBJ field W. Landsman June 2010 +; Fix occasional problem when crossing 0h E. Donoso/W.Landsman Jan 2013 +; Check if database has been opened W. Landsman Aug 2013 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - list = ' + $ + 'DBCIRCLE( ra[hours], dec[degrees], radius[arcmin], [ dis, sublist ' + print,' Count=, /GALACTIC, /SILENT, /TO_J2000, /TO_B1950 ] )' + if N_elements(sublist) GT 0 then return, sublist else return,[-1L] + endif + + if (N_elements(ra_cen) NE 1) || (N_elements(dec_cen) NE 1) then begin + print, 'DBCIRCLE: ERROR - Expecting scalar RA and Dec parameters' + if N_elements(sublist) GT 0 then return, sublist else return,[-1L] + endif + + if N_params() LT 3 then read,'Enter search radius in arc minutes: ',radius + + nentries = db_info( 'ENTRIES',0 ) + if nentries EQ 0 then begin + if ~keyword_set(SILENT) then message, $ + 'ERROR - No entries in database ' + db_info("NAME",0),/INF + if N_elements(sublist) GT 0 then return, sublist else return,[-1] + endif + + if keyword_set(TO_J2000) then begin + jprecess,ra_cen*15.,dec_cen,racen,deccen + racen = racen[0]/15. & deccen = deccen[0] + endif else if keyword_set(TO_B1950) then begin + bprecess,ra_cen*15.,dec_cen,racen,deccen + racen = racen[0]/15. & deccen = deccen[0] + endif else if keyword_set(galactic) then begin + glactc,racen,deccen,2000,ra_cen*15,dec_cen,2 ;Convert from Galactic + endif else begin + racen = ra_cen[0] & deccen = dec_cen[0] + endelse + + size = radius/60. ;Size of search field in degrees + decmin = double(deccen-size) > (-90.) + decmax = double(deccen+size) < 90. + bigdec = max(abs([decmin, decmax])) + items = strtrim(db_item_info('name')) + g = where(items EQ 'RA', Ncount) + if Ncount EQ 0 then begin + g = where(items EQ 'RA_OBJ', Ncount) + if Ncount EQ 0 then message, $ + 'ERROR - Database must have item named RA or RA_OBJ' else begin + sra = 'RA_OBJ' & sdec = 'DEC_OBJ' + endelse + endif else begin + sra = 'RA' & sdec = 'DEC' + endelse + + if abs(bigdec) EQ 90 then rasize = 24 else $ ;Updated Sep 1999 + rasize = abs(size/(15.*cos(bigdec/!RADEG))) < 24. ;Correct for latitude effect + + if 2*rasize gt 24. then begin ;Only need search on Dec? + st = string(decmin) + ' dbcompare,3624,3625,/diff +; +; PROCEDURES USED: +; DB_INFO(), DB_ITEM, DB_ITEM_INFO(), DBRD, DBXVAL() +; TEXTOPEN, TEXTCLOSE +; HISTORY: +; Written, W. Landsman July 1996 +; Fix documentation, add Syntax display W. Landsman November 1998 +; Replace DATATYPE() with size(/TNAME) W. Landsman November 2001 +; Assume since V5.5, remove VMS call W. Landsman September 2006 +; Fix problem with multiple values when /DIFF set W. Landsman April 2007 +;- +; + On_error,2 ;Return to caller + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - DBCOMPARE, list1, list2, [items, TEXTOUT= ,/DIFF]' + return + endif + +; Make list a vector + + dbname = db_info( 'NAME', 0 ) + + nentry = db_info( 'ENTRIES', 0) + if list1[0] GT nentry then message, dbname + $ + ' LIST1 entry number must be between 1 and ' + strtrim( nentry, 2 ) + + if list2[0] GT nentry then message, dbname + $ + ' LIST2 entry number must be between 1 and ' + strtrim( nentry, 2 ) + + +; Determine items to print + + if N_elements(items) EQ 0 then items = '*' + db_item,items, it, ivalnum, dtype, sbyte, numvals, nbytes + nvalues = db_item_info( 'NVALUES', it ) ;number of values in item + nitems = N_elements( it ) ;number of items requested + qnames = db_item_info( 'NAME', it ) + qtitle = db_info( 'TITLE', 0 ) ;data base title + +; Open output text file + + if not keyword_set(TEXTOUT) then textout = !textout ;use default output dev. + + textopen, dbname, TEXTOUT = textout + if size(TEXTOUT,/TNAME) EQ 'STRING' then text_out = 5 else $ + text_out = textout maxentry + + 'ITEMS' : begin +; +; process statement in form +; +; + item_name=" " + item_name=strupcase(gettok(st,' ')) + st = strtrim(st, 1) + item_type = " " + item_type=gettok(st,' ') + st = strtrim(st, 1) + desc[nitems]=st + if item_name eq '' then $ + message,'Invalid item name',/IOERROR + names[nitems]=gettok(item_name,'(') + if item_name ne '' then $ ;is it a vector + numvals[nitems]=fix(gettok(item_name,')')) + if item_type eq '' then $ + message,'Item data type not supplied for item ' + $ + strupcase(item_name),/IOERROR + data_type=strmid(strupcase(gettok(item_type,'*')),0,1) + num_bytes=item_type + if num_bytes eq '' then num_bytes='4' + if (data_type eq 'R') || (data_type eq 'I') || $ + (data_type eq 'U') then $ + data_type=data_type+num_bytes + case data_type of + 'B' : begin & idltype= 1 & nb=1 & ff='I6' & end + 'L' : begin & idltype= 1 & nb=1 & ff='I6' & end + 'I2': begin & idltype= 2 & nb=2 & ff='I7' & end + 'I4': begin & idltype= 3 & nb=4 & ff='I11' & end + 'I8': begin & idltype= 14 & nb=8 & ff='I22' & end + 'R4': begin & idltype= 4 & nb=4 & ff='G12.6' & end + 'R8': begin & idltype= 5 & nb=8 & ff='G20.12' & end + 'U2': begin & idltype= 12 & nb=2 & ff='I7' & end + 'U4': begin & idltype= 13 & nb=4 & ff='I11' & end + 'U8': begin & idltype= 15 & nb=8 & ff='I22' & end + 'C' : begin + idltype = 7 + nb=fix(num_bytes) + ff='A'+num_bytes + end + else: message,'Invalid data type "'+ item_type+ $ + '" specified',/IOERROR + endcase + format[nitems]=ff ;default print format + headers[1,nitems]=names[nitems] ;default print header + type[nitems]=idltype ;idl data type for item + nbytes[nitems]=nb ;number of bytes for item + sbyte[nitems]=nextbyte ;position in record for item + nextbyte=nextbyte+nb*numvals[nitems] ;next byte position + nitems++ + end + + 'FORMATS': begin +; +; process strings in form: +; ,, +; + item_name=" " + item_name=strupcase(gettok(st,' ')) + item_no=0 + while item_no lt nitems do begin + if strtrim(names[item_no]) eq item_name then begin + st = strtrim(st, 1) + format[item_no]=gettok(st,' ') + if strtrim(st,2) ne '' then begin + st = strtrim(st, 1) + headers[0,item_no]=gettok(st,',') + headers[1,item_no]=gettok(st,',') + headers[2,item_no]=strtrim(st) + endif + endif + item_no++ + endwhile + end + + 'POINTERS': begin +; +; process record in form: +; +; + item_name=strupcase(gettok(st,' ')) + item_no=0 + while item_no lt nitems do begin + if strtrim(names[item_no]) eq item_name then $ + pointers[item_no]=strupcase(strtrim(st, 1)) + item_no++ + endwhile + endcase + + 'INDEX': begin +; +; process record of type: +; +; + item_name=strupcase(gettok(st,' ')) + st = strtrim(st, 1) + indextype=gettok(st,' ') + item_no=0 + while item_no lt nitems do begin + if strtrim(names[item_no]) eq item_name then begin + case strupcase(indextype) of + 'INDEX' : index[item_no]=1 + 'SORTED': index[item_no]=2 + 'SORT' : index[item_no]=3 + 'SORT/INDEX' : index[item_no]=4 + else : message,'Invalid index type',/IOERROR + endcase + endif + item_no++ + endwhile + end + else : begin + print,'DBCREATE-- invalid block specification of ',block + print,' Valid values are #TITLE, #ITEMS, #FORMATS, #INDEX,' + print,' #MAXENTRIES or #POINTERS' + end + endcase +next: +endwhile; loop on records + +; +; create data base descriptor record -------------------------------------- +; +; byte array of 120 values +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 105-108 record length of DBF file (integer*4) +; 84-117 values filled in by DBOPEN +; 119 equals 1 if keyword EXTERNAL is true. +; +totbytes=((nextbyte+3)/4*4) ;make record length a multiple of 4 +drec = bytarr(120) +drec[0:79]=32b ;blanks +drec[0] = byte(strupcase(filename)) +drec[19] = byte(title) +drec[80] = byte(fix(nitems),0,2) +drec[105] = byte(long(totbytes),0,4) +drec[118] = 1b +drec[119] = byte(extern) +; +; create item description records +; +; irec[*,i] contains description of item number i with following +; byte assignments: +; 0-19 item name (character*20) +; 20-21 IDL data type (integet*2) +; 24-25 Starting byte position i record (integer*2) +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 Field length of the print format +; 100 Pointer flag +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 179-182 Number of values for item (1 for scalar) (integer*4) +; 183-186 Starting byte position in original DBF record (integer*4) +; 187-199 Added by DBOPEN +irec=bytarr(200,nitems) + +headers = strmid(headers,0,15) ;Added 15-Sep-92 + +for i=0,nitems-1 do begin + rec=bytarr(200) + rec[0:19]=32b & rec[101:170]=32b ;Default string values are blanks + rec[29:87] = 32b + rec[0] = byte(names[i]) + rec[20] = byte(type[i],0,2) + rec[179] = byte(numvals[i],0,4) + rec[183] = byte(sbyte[i],0,4) + rec[26] = byte(nbytes[i],0,2) + rec[28] = index[i] + rec[29] = byte(desc[i]) + if strtrim(pointers[i]) ne '' then rec[100]=1 else rec[100]=0 + rec[101]= byte(strupcase(pointers[i])) + rec[120]= byte(format[i]) + ff=strtrim(format[i]) + test = strnumber(gettok(strmid(ff,1,strlen(ff)-1),'.'),val) + if test then flen =fix(val) else $ ;Modified Nov-10 + message,'Invalid print format supplied: ' + format[i],/IOERROR + rec[98] = byte(flen,0,2) + rec[126]= byte(headers[0,i]) > 32b ;Modified Nov-91 + rec[141]= byte(headers[1,i]) > 32b + rec[156]= byte(headers[2,i]) > 32b + irec[0,i]=rec + +end +; +; Make sure user is on ZDBASE and write description file +; + + close,unit + openw,unit,zdir + fname+'.dbh' +On_ioerror, NULL +if extern then begin + tmp = fix(drec,80,1) & byteorder,tmp,/htons & drec[80] = byte(tmp,0,2) + tmp = long(drec,105,1) & byteorder,tmp,/htonl & drec[105] = byte(tmp,0,4) +; + tmp = fix(irec[20:27,*],0,4,nitems) + byteorder,tmp,/htons + irec[20,0] = byte(tmp,0,8,nitems) +; + tmp = fix(irec[98:99,*],0,1,nitems) + byteorder,tmp,/htons + irec[98,0] = byte(tmp,0,2,nitems) +; + tmp = fix(irec[171:178,*],0,4,nitems) + byteorder,tmp,/htons + irec[171,0] = byte(tmp,0,8,nitems) + + tmp = long(irec[179:186,*],0,2,nitems) + byteorder,tmp,/htonl + irec[179,0] = byte(tmp,0,8,nitems) + +endif +writeu, unit, drec +writeu, unit, irec +; +; if new data base create .dbf and .dbx files ----------------------------- +; + +if newdb then begin + close,unit + openw, unit, zdir + fname+'.dbf' + header = bytarr(totbytes) + p = assoc(unit,header) + p[0] = header +end + +; +; determine if any indexed items +; +nindex = total(index GT 0) +; +; create empty index file if needed +; +if (nindex GT 0) && (newindex) then begin + indexed = where(index GT 0) +; +; create header array +; header=intarr(7,nindex) +; header(i,*) contains values +; i=0 item number +; i=1 index type +; i=2 idl data type for the item +; i=3 starting block for header +; i=4 starting block for data +; i=5 starting block for indices (type 3) +; i=6 starting block for unsorted data (type 4) +; + nb = (maxentries+511)/512 ;number of 512 value groups + nextblock = 1 + header = lonarr(7,nindex) + for ii = 0, nindex-1 do begin + item = indexed[ii] + header[0,ii] = item + header[1,ii] = index[item] + header[2,ii] = type[item] + data_blocks = nbytes[item]*nb + if index[item] NE 1 $ + then header_blocks = (nbytes[item]*nb+511)/512 $ + else header_blocks = 0 + if (index[item] eq 3) or (index[item] EQ 4) then $ + index_blocks=(4*nb) else index_blocks=0 + if index[item] EQ 4 then unsort_blocks = data_blocks else $ + unsort_blocks=0 + header[3,ii] = nextblock + header[4,ii] = nextblock+header_blocks + header[5,ii] = header[4,ii]+data_blocks + header[6,ii] = header[5,ii]+index_blocks + nextblock = header[6,ii]+unsort_blocks + end + totblocks = nextblock + close, unit + openw, unit, zdir + fname+'.dbx' +; + p = assoc(unit,lonarr(2)) + tmp = [long(nindex),maxentries] + if extern then byteorder, tmp,/htonl + p[0] = tmp +; + p = assoc(unit,lonarr(7,nindex),8) + tmp = header + if extern then byteorder, tmp,/htonl + p[0] = tmp +endif +free_lun, unit +return +; +BAD_IO: free_lun,unit +print, !ERROR_STATE.MSG_PREFIX + !ERROR_STATE.MSG +print, !ERROR_STATE.MSG_PREFIX + !ERROR_STATE.SYS_mSG + +return +; +end diff --git a/modules/idl_downloads/astro/pro/dbdelete.pro b/modules/idl_downloads/astro/pro/dbdelete.pro new file mode 100644 index 0000000..f145b0b --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbdelete.pro @@ -0,0 +1,142 @@ +pro dbdelete, list, name, DEBUG = debug +;+ +; NAME: +; DBDELETE +; PURPOSE: +; Deletes specified entries from data base +; +; CALLING SEQUENCE: +; DBDELETE, list, [ name, /DEBUG ] +; +; INPUTS: +; list - list of entries to be deleted, scalar or vector +; name - optional name of data base, scalar string. If not specified +; then the data base file must be previously opened for update +; by DBOPEN. +; +; OPERATIONAL NOTES: +; !PRIV must be at least 3 to execute. +; +; SIDE EFFECTS: +; The data base file (ZDBASE:name.dbf) is modified by removing the +; specified entries and reordering the remaining entry numbers +; accordingly (ie. if you delete entry 100, it will be replaced +; by entry 101 and the database will contain 1 less entry. +; +; EXAMPLE: +; Delete entries in a database STARS where RA=DEC = 0.0 +; +; IDL> !PRIV= 3 ;Set privileges +; IDL> dbopen,'STARS',1 ;Open for update +; IDL> list = dbfind('ra=0.0,dec=0.0') ;Obtain LIST vector +; IDL> dbdelete, list ;Delete specified entries from db +; +; NOTES: +; The procedure is rather slow because the entire database is re- +; created with the specified entries deleted. +; OPTIONAL KEYWORD INPUT: +; DEBUG - if this keyword is set and non-zero, then additional +; diagnostics will be printed as each entry is deleted. +; COMMON BLOCKS: +; DBCOM +; PROCEDURE CALLS: +; DBINDEX, DB_INFO(), DBOPEN, DBPUT, ZPARCHECK +; HISTORY +; Version 2 D. Lindler July, 1989 +; Updated documentation W. Landsman December 1992 +; William Thompson, GSFC, 28 February 1995 +; Fixed bug when external representation used. +; Fixed for case where second parameter supplied W. Landsman April 1996 +; Use keyword DEBUG rather than !DEBUG W. Landsman May 1997 +; Don't call DBINDEX if no indexed items W. Landsman May 2006 +; Use TRUNCATE_LUN if V5.6 or later W. Landsman Sep 2006 +; Fix problem when deleting last entry W. Landsman Mar 2007 +; Assume since V5.6 so TRUNCATE_LUN is available W. Landsman +; +;- +;------------------------------------------------------------------------------- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - DBDELETE, entry, [ dbname ]' + return + endif + +; data base common block + + common db_com,QDB,QITEMS,QDBREC + +; Check parameters + + zparcheck, 'DBDELETE', list, 1, [1,2,3], [0,1], 'entry list' + if N_params() GT 1 then $ + zparcheck, 'dbdelete', name, 2, 7, 0, 'data base name' + + if !PRIV lt 3 then $ + message,'!priv must be at least 3 to execute' + +; Open data base if name supplied + + if N_params() GT 1 then dbopen,name,1 else begin ;Open specified database + + if not db_info( 'OPEN') then $ + message,'No database open for update' + if not db_info('update') then $ + message,'Database '+ db_info('NAME',0) + ' not open for update' + + endelse + +; Determine whether or not the database uses external data representation. + + external = qdb[119] eq 1 + + +; Create vector if list is a scalar + + outrec = 0L ; Create counter of output record + len = db_info('length') + +; loop on entries in data base + + qnentry = db_info('ENTRIES',0) + + for i = 1L, qnentry do begin + + ; Is it to be kept? + + found = where( list EQ i, Nfound) + + if keyword_set(debug) then print,i,nfound ; allow diags. + + if ( Nfound LE 0 ) then begin + outrec = outrec + 1 ; increment counter + if ( outrec NE i ) then begin + entry = qdbrec[i] + tmp = outrec + if external then byteorder,tmp,/htonl + dbput, 0, tmp, entry ; modify entry number + qdbrec[outrec] = entry + endif + endif + endfor + +; Update adjusted total number of entries. + + qdb[84] = byte( outrec,0,4 ) + +; Truncate the .dbf file at the current position. + + unit = db_info('unit_dbf') + point_lun, unit, long64(outrec+1)*len + truncate_lun, unit + +; Update index file + + indextype = db_item_info( 'INDEX') + if total(indextype) NE 0 then dbindex + + if N_params() GT 1 then dbclose + + return ; dbdelete + end ; dbdelete diff --git a/modules/idl_downloads/astro/pro/dbedit.pro b/modules/idl_downloads/astro/pro/dbedit.pro new file mode 100644 index 0000000..1f439fd --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbedit.pro @@ -0,0 +1,395 @@ +;+ +; NAME: +; DBEDIT +; +; PURPOSE: +; Interactively edit specified fields in an IDL database. +; EXPLANATION: +; The value of each field is displayed, and the user has the option +; of changing or keeping the value. Widgets will be used if they +; are available. +; +; CALLING SEQUENCE: +; dbedit, list, [ items ] +; +; INPUTS: +; list - scalar or vector of database entry numbers. Set list = 0 to +; interactively add a new entry to a database. Set list = -1 to edit +; all entries. +; +; OPTIONAL INPUTS: +; items - list of items to be edited. If omitted, all fields can be +; edited. +; +; KEYWORDS: +; BYTENUM = If set, treat byte variables as numbers instead of +; characters. +; +; COMMON BLOCKS: +; DB_COM -- contains information about the opened database. +; DBW_C -- contains information intrinsic to this program. +; +; SIDE EFFECTS: +; Will update the database files. +; +; RESTRICTIIONS: +; Database must be opened for update prior to running +; this program. User must be running DBEDIT from an +; account that has write privileges to the databases. +; +; If one is editing an indexed item, then after all edits are complete, +; DBINDEX will be called to reindex the entire item. This may +; be time consuming. +; +; Cannot be used to edit items with multiple values +; +; EXAMPLE: +; Suppose one had new parallaxes for all stars fainter than 5th magnitude +; in the Yale Bright Star Catalog and wanted to update the PRLAX and +; PRLAX_CODE fields with these new numbers +; +; IDL> !priv=2 +; IDL> dbopen, 'yale_bs', 1 ;Open catalog for update +; IDL> list = dbfind( 'v>5') ;Find fainter than 5th magnitude +; IDL> dbedit, list, 'prlax, prlax_code' ;Manual entry of new values +; +; PROCEDURE: +; (1) Use the cursor and point to the value you want to edit. +; (2) Type the new field value over the old field value. +; (3) When you are done changing all of the field values for each entry +; save the entry to the databases by pressing 'SAVE ENTRY TO DATABASES'. +; Here all of the values will be checked to see if they are the correct +; data type. If a field value is not of the correct data type, it will +; not be saved. +; +; Use the buttons "PREV ENTRY" and "NEXT ENTRY" to move between entry +; numbers. You must save each entry before going on to another entry in +; order for your changes to be saved. +; +; Pressing "RESET THIS ENTRY" will remove any unsaved changes to the +; current entry. +; +;REVISION HISTORY: +; Adapted from Landsman's DBEDIT +; added widgets, Melissa Marsh, HSTX, August 1993 +; do not need to press return after entering each entry, +; fixed layout problem on SUN, +; Melissa Marsh, HSTX, January 1994 +; Only updates the fields which are changed. Joel Offenberg, HSTX, Mar 94 +; Corrected test for changed fields Wayne Landsman HSTX, Mar 94 +; Removed a couple of redundant statements W. Landsman HSTX Jan 96 +; Converted to IDL V5.0 W. Landsman September 1997 +; Replace DATAYPE() with size(/TNAME) W. Landsman November 2001 +; Work for entry numbers > 32767 W. Landsman December 2001 +; Added /BYTENUM William Thompson 13-Mar-2006 +; Use DIALOG_MESSAGE for error messages W. Landsman April 2006 +; Assume since V5.5, remove VMS support W. Landsman Sep 2006 +;- + +;---------------------------------------------------------------- + + +;event handler for main part of program + +pro widgetedit_event,event + +common db_com,qdb,QITEMS,QDBREC + +common dbw_c,liston,main,holder,widlabel,widtext,middle,nitems,names,$ + it,itnum,dtype,numvals,sbyte,nbytes,buts,prevbut,but2,resetbut,$ + endbut,nextbut,mid,minlist,maxlist,savebut,bigmid,entry,wid_warn,$ + holder0,widtext0,widlabel0,thislist,nlist,wereat,newflag,bytenum + +CASE event.id OF + + endbut: widget_control,event.top,/destroy ;destory main widget--end session + + prevbut:begin ;go to previous entry + if wereat ne 0 then wereat= wereat-1 + liston = thislist[wereat] + widedit + end + + nextbut:begin ;go to next entry + if wereat lt nlist-1 then wereat = wereat+1 else $ + widget_control,event.top,/destroy ;end session + liston = thislist[wereat] + widedit + end + + resetbut:begin ;reset this entry + liston = liston + widedit + end + + savebut: begin ;save entry to databases + ;update database + for i = 0, nitems -1 do begin + widget_control,widtext[i],get_value=val + ;test value + valid = 0 + oldval = dbxval(entry,dtype[i],numvals[i],sbyte[i],nbytes[i]) + + on_ioerror,BADVAL + IF (strtrim(oldval[0],2) ne (strtrim(val[0],2))) THEN BEGIN + oldval[0] = strtrim(val,2) + valid = 1 + dbxput,oldval,entry,dtype[i],sbyte[i],nbytes[i] + print,strcompress('Entry ' + string(liston) +': ' + $ + names[i] + ' = ' + string(val)) + newflag[ wereat, i ] = 1b + BADVAL: if (not valid) then begin + result = dialog_message(title='Bad Value',/ERROR, $ + 'Item '+ strcompress(names[i],/rem) + $ + ' must be of type ' + size(oldval[0],/TNAME) ) + str = dbxval(entry,dtype[i],numvals[i],sbyte[i],nbytes[i]) + if (dtype[i] eq 1) and keyword_set(bytenum) then str=fix(str) + str = ' '+string(str[0]) + widget_control,widtext[i],set_value=str + endif + endIF + on_ioerror,NULL + endfor + + if (liston EQ 0) then begin + dbwrt,entry,0,1 ;new entry + endif else begin + dbwrt,entry + endelse + widedit + ;create widget telling the user that the changes have been made. + end + + else: ;donothing + + endcase +end + +;-------------------------------------------------------------------- +pro widedit +;program that makes "middle" of main widget (field values) + + +common db_com,qdb,QITEMS,QDBREC + + +common dbw_c,liston,main,holder,widlabel,widtext,middle,nitems,names,$ + it,itnum,dtype,numvals,sbyte,nbytes,buts,prevbut,but2,resetbut,$ + endbut,nextbut,mid,minlist,maxlist,savebut,bigmid,entry,wid_warn,$ + holder0,widtext0,widlabel0,thislist,nlist,wereat,newflag,bytenum + + +;get entry number + dbrd, liston, entry + +;get field values for this entry + widget_control, widtext0, set_value=string(liston) + for i = 0,nitems-1 do begin + str = dbxval(entry,dtype[i],numvals[i],sbyte[i],nbytes[i]) + if (dtype[i] eq 1) and keyword_set(bytenum) then str=fix(str) + str = ' '+string(str[0]) + widget_control,widtext[i],set_value=str + endfor + +;check to see if this entry is the minimum or maximum entry + if (liston EQ minlist) then widget_control,prevbut,sensitive=0 else $ + widget_control,prevbut,sensitive=1 + if (liston EQ maxlist) then widget_control,nextbut,sensitive=0 else $ + widget_control,nextbut,sensitive=1 + + end +;------------------------------------------------------------------------- +;main program + +pro dbedit,list,items,bytenum=k_bytenum + + compile_opt idl2 +common db_com,qdb,QITEMS,QDBREC + +;Nitems - Number elements in input list +;Thislist - Sorted list of entry numbers +;Minlist - Minimum input entry number +;Maxlist - Maximum input entry number +;Liston - The current entry number being edited (scalar) +;wereat - The index of ThisList vector being edited, i.e. Thislist(wereat)=LIston +;dtype - data type(s) (1=string,2=byte,4=i*4,...) +;sbyte - starting byte(s) in entry +;numvals - number of data values for item(s) +; NOTE: dtype, sbyte, numvals are dimensioned for *all* entries + +common dbw_c,liston,main,holder,widlabel,widtext,middle,nitems,names,$ + it,itnum,dtype,numvals,sbyte,nbytes,buts,prevbut,but2,resetbut,$ + endbut,nextbut,mid,minlist,maxlist,savebut,bigmid,entry,wid_warn,$ + holder0,widtext0,widlabel0,thislist,nlist,wereat,newflag,bytenum + + On_error,2 + if N_params() LT 1 then begin + print,'Syntax - dbedit, list, [ items ]' + return + endif + +;Set the value of bytenum +bytenum = keyword_set(k_bytenum) + +;make sure widgets are available + if (!D.FLAGS AND 65536) EQ 0 then begin + dbedit_basic, list, items + return + endif + +;check to make sure database is open + ;first check to see if there is an open database + s = size(qdb) + if (s[0] EQ 0) then begin + + result = dialog_message(/ERROR, title='NOT OPEN FOR UPDATE', $ + 'No database has been opened') + goto, PROEND + endif +;check to make sure the database is opened for update + dbname = db_info('NAME',0) + if not db_info('UPDATE') then begin + + result = dialog_message(/ERROR, title='NOT OPEN FOR UPDATE', $ + 'Database ' + dbname + ' must be opened for update.') + goto,PROEND + + endif + + + ;check parameters + zparcheck, 'DBEDIT', list, 1, [1,2,3], [0,1], 'Database entry numbers' + + ;get items. If items not specified use all items except ENTRY + if ( N_params() LT 2 ) then begin + nitems = db_info('ITEMS',0) -1 + items = indgen(nitems) + 1 + endif + + nlist = N_elements(list) + + if nlist gt 1 then begin ;sort entry numbers + + sar = sort(list) + thislist = list[sar] + + endif else begin + + thislist = lonarr(1) + thislist[0] = list + + endelse + + ;edit all entries? get number of entries + if ( list[0] EQ -1 ) then begin + nlist = db_info('ENTRIES',0) + if nlist le 0 then begin + print,'Empty database cannot be edited. Use list=0 to add new entry' + goto, PROEND + endif + thislist = lindgen(nlist) + 1 + endif + + minlist = min(thislist, max = maxlist) + + + nentry = db_info('ENTRIES',0) + if (maxlist gt nentry) then begin + result = dialog_message(title='INVALID ENTRY NUMBER',/ERROR, $ + dbname + ' entry numbers must be less than ' + strtrim(nentry+1,2) ) + goto, PROEND + endif + + nitems = db_info('ITEMS',0) -1 + allitems = indgen(nitems) + 1 + + ;get information about items + db_item,allitems,itnum,ivalnum,dtype,sbyte,numvals,nbytes + nvalues = db_item_info('nvalues') + + db_item,items,it + + nit = n_elements(it) ;Number of items to be edited + names = db_item_info('name',itnum) ;Get names of each item + newflag = bytarr(nlist,nitems) ;Keeps track of fields actually updated + + wereat = 0 + liston = thislist[wereat] + dbrd,liston,entry + + ;create widget and display + main = widget_base(/COLUMN,title='Widgetized Database Editor') + w1 = widget_label(main,value='****** ' + dbname + ' ******') + bigmid = widget_base(main,/column,x_scroll_size=325,y_scroll_size=650) + + + butbase = widget_base(main,/column,/frame) + savebut = widget_button(butbase,value='SAVE THIS ENTRY') + buts = widget_base(butbase,/row) + prevbut = widget_button(buts,value='<- PREV ENTRY') + but2 = widget_base(buts,/column) + resetbut = widget_button(but2,value='RESET THIS ENTRY') + endbut = widget_button(but2,value='END SESSION') + nextbut = widget_button(buts,value='NEXT ENTRY ->') + + widlabel = lonarr(nitems+1) + widtext = lonarr(nitems+1) + holder = lonarr(nitems+1) + + mid = widget_base(bigmid,/column) + + holder0 = widget_base(mid,/row) + widlabel0 =widget_label(holder0,value=' ENTRY NUMBER ',/frame) + num = string(liston) + widtext0 = widget_label(holder0,value=num) + + middle = widget_base(mid,/column) + + for i = 0,nitems-1 do begin + ed = 'N' + str1 = names[i] + + for j = 0, N_elements(it)-1 do begin + if it[j] EQ itnum[i] then ed = 'Y' + endfor + + str = dbxval(entry,dtype[i],numvals[i],sbyte[i],nbytes[i]) + if (dtype[i] eq 1) and keyword_set(bytenum) then str=fix(str) + str = ' ' + string(str[0]) + if ed eq 'Y' then begin + holder[i] = widget_base(middle,/row) + widlabel[i] = widget_label(holder[i],value = str1,/frame) + widtext[i] = widget_text(holder[i],/frame,value=str,/edit) + endif else begin + holder[i] = widget_base(middle,/row) + widlabel[i] = widget_label(holder[i],value = str1,/frame) + widtext[i] = widget_label(holder[i],value=str) + endelse + endfor + + if (liston EQ minlist) then widget_control,prevbut,sensitive=0 else $ + widget_control,prevbut,sensitive=1 + if (liston EQ maxlist) then widget_control,nextbut,sensitive=0 else $ + widget_control,nextbut,sensitive=1 + + widget_control,main,/realize + xmanager,'widgetedit',main + + newitem = total(newflag, 1) + indexnum = where(newitem, nindex) + + if ( nindex GT 0 ) then begin ;Any mods made? + indexnum = itnum[indexnum] + indextype = db_item_info('INDEX',indexnum);Index type of modified fields + good = where(indextype GE 1, Ngood) ;Which fields are indexed? + if Ngood GT 0 then begin + message, 'Now updating index file', /INF + dbindex, indexnum[good] + endif + dbopen,strlowcase(dbname),1 + endif + +PROEND: + + return + end diff --git a/modules/idl_downloads/astro/pro/dbedit_basic.pro b/modules/idl_downloads/astro/pro/dbedit_basic.pro new file mode 100644 index 0000000..d934c87 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbedit_basic.pro @@ -0,0 +1,157 @@ +pro dbedit_basic,list,items +;+ +; NAME: +; DBEDIT_BASIC +; PURPOSE: +; Subroutine of DBEDIT_BASIC to edit a database on a dumb terminal. +; EXPLANATION: +; Interactively edit specified fields in a database. The +; value of each field is displayed, and the user has the option +; of changing or keeping the value. +; +; CALLING SEQUENCE: +; dbedit_basic, list, [ items ] +; +; INPUTS: +; list - scalar or vector of database entry numbers. Set LIST=0 +; to interactively add a new entry to a database. +; +; OPTIONAL INPUTS +; items - list of items to be edited. If not supplied, then the +; value of every field will be displayed. +; +; NOTES: +; (1) Database must be opened for update (dbopen,,1) before +; calling DBEDIT_BASIC. User must have write privileges on the database +; files. +; (2) User gets a second chance to look at edited values, before +; they are actually written to the database +; +; PROMPTS: +; The item values for each entry to be edited are first displayed +; User is the asked "EDIT VALUES IN THIS ENTRY (Y(es), N(o), or Q(uit))? +; If user answers 'Y' or hits RETURN, then each item is displayed +; with its current value, which the user can update. If user answered +; 'N' then DBEDIT_BASIC skips to the next entry. If user answers 'Q' +; then DBEDIT will exit, saving all previous changes. +; +; EXAMPLE: +; Suppose V magnitudes (V_MAG) in a database STARS with unknown values +; were assigned a value of 99.9. Once the true values become known, the +; database can be edited +; +; IDL> !PRIV=2 & dbopen,'STARS',1 ;Open database for update +; IDL> list = dbfind('V_MAG=99.9') ;Get list of bad V_MAG values +; IDL> dbedit,list,'V_MAG' ;Interactively insert good V_MAG values +; +; REVISION HISTORY: +; Written W. Landsman STX April, 1989 +; Rename DBEDIT_BASIC from DBEDIT July, 1993 +; Converted to IDL V5.0 W. Landsman September 1997 +; Change DATATYPE() to size(/TNAME) W. Landsman November 2001 +;- + On_error,2 + + zparcheck, 'DBEDIT_BASIC', list, 1, [1,2,3], [0,1], 'Database entry numbers' + + dbname = db_info( 'NAME', 0 ) ;Database name + if not db_info( 'UPDATE' ) then $ + message, 'Database ' + dbname + ' must be opened for update + + if ( N_params() LT 2 ) then begin ;Did user specify items string? + nitems = db_info( 'ITEMS', 0 ) -1 ;If not then use every item but ENTRY + items = indgen(nitems) + 1 + endif + + nlist = N_elements(list) + + if ( list[0] EQ -1 ) then begin ;Edit all entries? + nlist = db_info( 'ENTRIES', 0 ) ;Get number of entries + list = lindgen(nlist) + 1 + endif + + db_item, items, itnum, ivalnum, dtype, sbyte, numvals, nbytes + + nitems = N_elements(itnum) ;Number of items to be edited + names = db_item_info( 'NAME', itnum ) ;Get names of each item + newflag = bytarr(nlist,nitems) ;Keeps track of fields actually updated + yesno = '' + +for i = 0, nlist-1 do begin ;Loop over each entry to be edited + ll = list[i] + + if ll GT 0 then begin ;Existing entry? + dbprint,ll,'*',TEXT = 1 + read,'Edit values in this entry (Y(es),N(o),Q(uit), def=Y)? ',yesno + yesno = strupcase(strmid(yesno,0,1)) + if yesno eq 'Q' then goto, UPDATE $ + else if yesno EQ 'N' then goto, ENTRY_DONE + endif else message,'Adding new entry to database '+dbname,/inform + + print,'Hit [RETURN] to leave values unaltered' + READVAL: dbrd,ll,entry + for j = 0,nitems - 1 do begin + val = '' + name = strtrim(names[j],2) + curval = dbxval( entry, dtype[j], numvals[j], sbyte[j], nbytes[j] ) +; Convert byte to integer to avoid string conversion problems + if (dtype[j] EQ 1) and ( N_elements(curval) EQ 1 ) then $ + curval = fix(curval) + if ( numvals[j] EQ 1 ) then oldval = strtrim(curval,2) else $ + oldval = strtrim(curval[0],2) + '...' + read,name+' New Value (' + oldval + '): ',val + TESTVAL: + if ( val NE '' ) then begin + oldval = make_array( size = [1,numvals[j],dtype[j],numvals[j]] ) + On_IOerror, BADVAL + oldval[0] = val + On_IOerror, NULL + newflag[i,j] = 1 + dbxput, oldval, entry, dtype[j], sbyte[j], nbytes[j] + endif + endfor + + if ( total(newflag[i,*]) GT 0 ) then begin + print,'' & print,'Updated Values' & print,'' + + for j = 0,nitems-1 do begin + name = strtrim(names[j],2) + print,name,': ',dbxval( entry,dtype[j],numvals[j],sbyte[j],nbytes[j] ) + endfor + print,'' + yesno = '' + read,' Are these values correct [Y]? ', yesno + if ( strupcase(yesno) NE 'N' ) then begin + if ( ll EQ 0 ) then begin + dbwrt,entry,0,1 + ll = db_info('entries',0) + 1 + endif else dbwrt,entry + print,'' & print,'Entry ',strtrim(ll,2), ' now updated + endif else begin + newflag[i,*] = 0 + goto, READVAL + endelse + endif else print,'No values updated for entry',ll + ENTRY_DONE: +endfor + +UPDATE: + newitem = total(newflag, 1) + indexnum = where(newitem, nindex) + + if ( nindex GT 0 ) then begin ;Any mods made? + indexnum = itnum[indexnum] + indextype = db_item_info('INDEX',indexnum) ;Index type of modified fields + good = where(indextype GE 1, ngood) ;Which fields are indexed? + if ngood GT 0 then dbindex,indexnum[good] + dbopen,dbname,1 + dbprint,list,[0,itnum],TEXT=1 + endif + return +BADVAL: + print,'Item '+name+ ' must be of type '+ size(oldval[0],/TNAME) + val = '' + j = j-1 + goto, TESTVAL + + end diff --git a/modules/idl_downloads/astro/pro/dbext.pro b/modules/idl_downloads/astro/pro/dbext.pro new file mode 100644 index 0000000..28250cf --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbext.pro @@ -0,0 +1,85 @@ +pro dbext,list,items,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12 +;+ +; NAME: +; DBEXT +; PURPOSE: +; Extract values of up to 12 items from an IDL database +; EXPLANATION: +; Procedure to extract values of up to 12 items from +; data base file, and place into IDL variables +; +; CALLING SEQUENCE: +; dbext,list,items,v1,[v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12] +; +; INPUTS: +; list - list of entry numbers to be printed, vector or scalar +; If list = -1, then all entries will be extracted. +; list may be converted to a vector by DBEXT +; items - standard item list specification. See DBPRINT for +; the 6 different ways that items may be specified. +; +; OUTPUTS: +; v1...v12 - the vectors of values for up to 12 items. +; +; EXAMPLE: +; Extract all RA and DEC values from the currently opened database, and +; place into the IDL vectors, IDLRA and IDLDEC. +; +; IDL> DBEXT,-1,'RA,DEC',idlra,idldec +; +; HISTORY +; version 2 D. Lindler NOV. 1987 +; check for INDEXED items W. Landsman Feb. 1989 +; Converted to IDL V5.0 W. Landsman September 1997 +; Avoid EXECUTE() call for V6.1 or later W. Landsman December 2006 +; Assume since V6.1 W. Landsman June 2009 +;- +;***************************************************************** + On_error,2 + compile_opt idl2 + + if N_params() lt 3 then begin + print,'Syntax - dbext, list, items, v1, [ v2, v3....v12 ]' + return + endif + + zparcheck,'DBEXT',list,1,[1,2,3,4,5],[0,1],'Entry List' + + db_item,items,it,ivalnum,idltype,sbyte,numvals,nbytes + + nitems = N_elements(it) + nentries = db_info('entries') + if max(list) GT nentries[0] then $ + message,db_info('name',0)+' entry numbers must be between 1 and ' + $ + strtrim(nentries[0],2) + if nitems GT N_params()-2 then $ + message,'Insufficient output variables supplied' + if nitems LT N_params()-2 then message, /INF, $ + 'WARNING - More output variables supplied than items specified' + +; get item info. + + dbno = db_item_info('dbnumber',it) + if max(dbno) eq 0 then dbno=0 $ ;flag that it is first db only + else dbno=-1 + index = db_item_info('index',it) + ind = where( (index ge 1) and (index ne 3), Nindex ) + + if (Nindex eq nitems) and (dbno eq 0) then begin ;All indexed items? + + if N_elements(list) eq 1 then list = lonarr(1) + list + for i=0,nitems - 1 do begin ;Get indexed items + itind = it[ind[i]] + dbext_ind,list,itind,dbno,scope_varfetch('v' + strtrim(ind[i]+1,2)) + endfor + + endif else begin + + nvalues = db_item_info('nvalues',it) + dbext_dbf,list,dbno,sbyte,nbytes*nvalues,idltype,nvalues, $ + v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12 + + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/dbext_dbf.pro b/modules/idl_downloads/astro/pro/dbext_dbf.pro new file mode 100644 index 0000000..d56cade --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbext_dbf.pro @@ -0,0 +1,152 @@ +pro dbext_dbf,list,dbno,sbyte,nbytes,idltype,nval,v1,v2,v3,v4,v5,v6, $ + v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18, item_dbno=item_dbno + +;+ +; NAME: +; DBEXT_DBF +; PURPOSE: +; Subroutine of DBEXT to extract values of up to 18 items from a database +; EXPLANATION: +; This is a subroutine of DBEXT, which is the routine a user should +; normally use. +; +; CALLING SEQUENCE: +; dbext_dbf,list,dbno,sbyte,nbytes,idltype,nval,v1,[ v2,v3,v4,v5,v6,v7, +; v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18 ITEM_DBNO = ] +; +; INPUTS: +; list - list of entry numbers to extract desired items. It is the +; entry numbers in the primary data base unless dbno is greater +; than or equal to -1. In that case it is the entry number in +; the specified data base. +; dbno - number of the opened db file +; if set to -1 then all data bases are included +; sbyte - starting byte in the entry. If single data base then it must +; be the starting byte for that data base only and not the +; concatenation of db records +; nbytes - number of bytes in the entry +; idltype - idl data type of each item to be extracted +; nval - number of values per entry of each item to be extracted +; +; OUTPUTS: +; v1...v18 - the vectors of values for up to 18 items +; +; OPTIONAL INPUT KEYWORD: +; item_dbno - A vector of the individual database numbers for each item. +; Simplifies the code for linked databases +; PROCEDURE CALLS: +; DB_INFO(), DB_ITEM_INFO(), DBRD, DBXVAL(), IS_IEEE_BIG(), IEEE_TO_HOST +; HISTORY +; version 1 D. Lindler Nov. 1987 +; Extract multiple valued entries W. Landsman May 1989 +; William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Added support for external (IEEE) representation. +; Work with multiple element string items W. Landsman August 1995 +; Increase speed for external databases on IEEE machines WBL August 1996 +; IEEE conversion implemented on blocks of entries using BIG +; Added keyword ITEM_DBNO R. Schwartz, GSFC/SDAC, August 1996 +; Return a vector even if only 1 value W. Thompson October 1996 +; Change variable name of BYTESWAP to BSWAP W. Thompson Mar 1997 +; Use /OVERWRITE with reform W. Landsman May 1997 +; Increase maximum number of items to 18 W. Landsman November 1999 +; 2 May 2003, W. Thompson, Use DBXVAL with BSWAP instead of IEEE_TO_HOST. +; Avoid EXECUTE() for V6.1 or later W. Landsman Jan 2007 +; Assume since V6.1 W. Landsman June 2009 +; Change arrays to LONG to support entries >32767 bytes WL Oct 2010 +;- +; + compile_opt idl2 +;***************************************************************** +; +COMMON db_com,qdb,qitems,qdbrec +nitems=n_elements(sbyte) ;number of items +external = db_info('external') ;External format? +bswap = external * (~IS_IEEE_BIG() ) ;Need to byteswap? +if dbno ge 0 then bswap = bswap[dbno] + bytarr(nitems) else $ + if n_elements(item_dbno) eq nitems then bswap=bswap[item_dbno] $ + else begin + sbyte1 = db_item_info('bytepos') + itnums = intarr(nitems) + for i=0,nitems-1 do itnums[i] = (where( sbyte[i] eq sbyte1))[0] + dbno1 = db_item_info('dbnumber', itnums) + bswap = bswap[dbno1] +endelse + +scalar=0 +if n_elements(list) eq 1 then begin + scalar=1 + savelist=list + list=lonarr(1)+list + if list[0] eq -1 then list=lindgen(db_info('entries',0))+1 +end +nlist=n_elements(list) +; +; create a big array to hold all extracted values in +; byte format +; +totbytes=total(nbytes) +big=bytarr(totbytes,nlist) +; +; generate vector of bytes in entries to extract +; +index=lonarr(totbytes) +ipos=0 +for i=0,nitems-1 do begin + for j=0,nbytes[i]-1 do index[ipos+j]=sbyte[i]+j + ipos=ipos+nbytes[i] +endfor +; +; generate vector of byte positions in big for each item +; +bpos=lonarr(nitems) +if nitems gt 1 then for i=1,nitems-1 do bpos[i]=bpos[i-1]+nbytes[i-1] +; +; loop on records and extract info into big +; +if dbno ge 0 then begin + ; + ; bypass dbrd for increased performance + ; + if dbno eq 0 then begin + for i=0L,nlist-1 do begin + if list[i] ge 0 then begin + entry=qdbrec[list[i]] + big[0,i] = entry[index] + endif + endfor + end else begin ;mapped I/O + unit=db_info('unit_dbf',dbno) + rec_size=db_info('length',dbno) + for i=0L,nlist-1 do begin + if list[i] ge 0 then begin + p=assoc(unit,bytarr(rec_size,/nozero),rec_size*list[i]) + entry=p[0] + big[0,i] = entry[index] + end + endfor + end + end else begin + for i = 0L, nlist-1 do begin + if list[i] GE 0 then begin + dbrd,list[i],entry, /noconvert + big[0,i] = entry[index] + endif + end +end +; +; now extract each value and convert to correct type +; +last = bpos + nbytes -1 + +for i = 0,nitems-1 do begin + item = dbxval(big, idltype[i], nval[i], bpos[i], nbytes[i], bswap=bswap[i]) + st = 'v' + strtrim(i+1,2) + if nlist GT 1 then $ + (SCOPE_VARFETCH(st)) = reform(item,/overwrite) else $ + (SCOPE_VARFETCH(st)) = [item] + + endfor;for i loop on items +; +if scalar then list=savelist ;restore scalar value +return +end diff --git a/modules/idl_downloads/astro/pro/dbext_ind.pro b/modules/idl_downloads/astro/pro/dbext_ind.pro new file mode 100644 index 0000000..a9466e7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbext_ind.pro @@ -0,0 +1,143 @@ +pro dbext_ind,list,item,dbno,values +;+ +; NAME: +; DBEXT_IND +; PURPOSE: +; routine to read a indexed item values from index file +; +; CALLING SEQUENCE: +; dbext_ind,list,item,dbno,values +; +; INPUTS: +; list - list of entry numbers to extract values for +; (if it is a scalar, values for all entries are extracted) +; item - item to extract +; dbno - number of the opened data base +; +; OUTPUT: +; values - vector of values returned as function value +; HISTORY: +; version 1 D. Lindler Feb 88 +; Faster processing of string values W. Landsman April, 1992 +; William Thompson, GSFC/CDS (ARC), 30 May 1994 +; Added support for external (IEEE) data format +; Allow multiple valued (nonstring) index items W. Landsman November 2000 +; Use 64bit integer index for large databases W. Landsman February 2001 +; Fix sublisting of multiple valued index items W. Landsman March 2001 +; Check whether any supplied entries are valid W. Landsman Jan 2009 +; Remove IEEE_TO_HOST W. Landsman Apr 2016 +;- +On_error,2 +compile_opt idl2 +; +if N_params() LT 4 then begin + print,'Syntax - DBEXT_IND, list, item, dbno, values' + return +endif + +; Determine first and last block to extract +; +s=size(list) & ndim=s[0] +if (ndim GT 0) then if (list[0] EQ -1) then ndim=0 +zeros = 0 ;flag if zero's present in list +if ndim EQ 0 then begin + minl = 1 + maxl = db_info('ENTRIES',dbno) + end else begin + minl = min(list) + if minl EQ 0 then begin ;any zero values in list + zeros = 1 + nonzero = where(list GT 0, Ngood, comp=bad) + if Ngood EQ 0 then message,'ERROR - No valid entry numbers supplied' + minl = min(list[nonzero]) + endif + maxl=max(list) + end +; +; get item info +; +db_item,item,it,ivalnum,dtype,sbyte,numvals,nbytes +nbytes = nbytes[0] +if N_elements(it) GT 1 then $ + message,'ERROR - Only one item can be extracted by dbext_ind' + +itnum = db_item_info('itemnumber',it[0]) ;item number in this dbno +; +; determine if indexed +; +index_type = db_item_info('index',it[0]) +if index_type EQ 0 then $ + message,'ERROR - Requested item is not indexed' + +if index_type EQ 3 then $ + message,'ERROR - Unsorted values of item not recorded in index file' +; +; get unit number of index file and read header info +; + unit=db_info('UNIT_DBX',dbno) + external = db_info('EXTERNAL',dbno) ;External (IEEE) data format? + p=assoc(unit,lonarr(2)) + h=p[0] + if external then swap_endian_inplace,h,/swap_if_little + p = assoc(unit,lonarr(7,h[0]),8) + header = p[0] + if external then swap_endian_inplace,header,/swap_if_little + items = header[0,*] + pos = where(items EQ itnum, Nindex) & pos=pos[0] + if Nindex LT 1 then $ + message,'Item not indexed, DBNO may be wrong' + +; +; find starting location to read +; +if index_type NE 4 then sblock=header[4,pos] else sblock=header[6,pos] +; +numvals = numvals[0] +sbyte = 512LL*sblock +sbyte = sbyte+(minl-1L)*nbytes*numvals +nv = (maxl-minl+1L) ;number of bytes to extract +; +; create mapped i/o variable +; +dtype = dtype[0] + +if dtype NE 7 then begin + if numvals GT 1 then $ + p = assoc(unit, make_array(size=[2,numvals,nv,dtype,0],/NOZERO), sbyte ) else $ + p = assoc(unit, make_array(size=[1,nv,dtype,0],/NOZERO), sbyte ) + endif else p = assoc(unit, make_array(size=[2,nbytes,nv,1,0],/NOZERO), sbyte ) + +; +; read values from file +; Modified, April 92 to delay conversion to string until the last step WBL +; +values = p[0] +if external then swap_endian_inplace,values,/swap_if_little +; +; if subset list specified perform extraction +; + +if ndim NE 0 then begin + if zeros then begin ;zero out bad values + if dtype NE 7 then begin ;not a string? + if numvals EQ 1 then begin + values = values[(list-minl)>0 ] + values[bad]=0 + endif else begin + values = values[*,(list-minl)>0 ] + values[*,bad] = intarr(numvals) + endelse + end else begin ;string + values = values[*, (list-minl)>0 ] + if N_elements(bad) EQ 1 then bad = bad[0] + values[0,bad] = replicate( 32b, nbytes ) + endelse + end else begin + if (dtype EQ 7) || (numvals GT 1) then $ + values = values[*, list-minl] $ + else values = values[ list-minl ] + end +end +if dtype EQ 7 then values = string(values) +return +end diff --git a/modules/idl_downloads/astro/pro/dbfind.pro b/modules/idl_downloads/astro/pro/dbfind.pro new file mode 100644 index 0000000..f2bc144 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbfind.pro @@ -0,0 +1,382 @@ +function dbfind,spar,listin,SILENT=silent,fullstring = Fullstring, $ + errmsg=errmsg, Count = count +;+ +; NAME: +; DBFIND() +; PURPOSE: +; Search data base for entries with specified characteristics +; EXPLANATION: +; Function to search data base for entries with specified +; search characteristics. +; +; CALLING SEQUENCE: +; result = dbfind(spar,[ listin, /SILENT, /FULLSTRING, ERRMSG=, Count = ]) +; +; INPUTS: +; spar - search_parameters (string)...each search parameter +; is of the form: +; +; option 1) min_val < item_name < max_val +; option 2) item_name = value +; option 3) item_name = [value_1, value_10] +; Note: option 3 is also the slowest. +; option 4) item_name > value +; option 5) item_name < value +; option 6) item_name = value(tolerance) ;eg. temp=25.0(5.2) +; option 7) item_name ;must be non-zero +; +; Multiple search parameters are separated by a comma. +; eg. 'cam_no=2,14 is interpreted as greater than or equal. +; +; RA and DEC keyfields are stored as floating point numbers +; in the data base may be entered as HH:MM:SEC and +; DEG:MIN:SEC. Where: +; +; HH:MM:SEC equals HH + MM/60.0 + SEC/3600. +; DEG:MIN:SEC equals DEG + MIN/60.0 + SEC/3600. +; +; For example: +; 40:34:10.5 < dec < 43:25:19 , 8:22:1.0 < ra < 8:23:23.0 +; +; Specially encoded date/time in the data base may +; be entered by CCYY/DAY:hr:min:sec which is +; interpreted as +; CCYY*1000+DAY+hr/24.0+min/24.0/60.+sec/24.0/3600. +; If a two digit year is supplied and YY GE 40 then it is +; understood to refer to year 1900 +YY; if YY LT 40 then it is +; understood to refer to year 2000 +YY + +; For example +; 1985/201:10:35:3032767 bytes W.L. Oct. 2010 +; Delay warning now for 10000 instead of 2000 entries W.L. Aug 2014 +;- +; +; --------------------------------------------------------------------- + +On_error,2 ;return to caller +; +; Check parameters. If LISTIN supplied, make sure all entry values are +; less than total number of entries. +; + count = 0 + zparcheck,'dbfind',spar,1,7,[0,1],'search parameters' + + catch, error_status + if error_status NE 0 then begin + print,!ERR_STRING + if N_elements(listin) NE 0 then return,listin else return, -1 + endif + nentries = db_info( 'ENTRIES',0 ) ;number of entries + if ( N_params() LT 2 ) then listin = -1 else begin + zparcheck,'dbfind',listin,2,[1,2,3],[0,1],'entry list' + maxlist = max(listin) + if ( maxlist GT nentries ) then begin + message = 'Entry list values (second parameter) must be less than '+ $ + strtrim(nentries,2) + goto, handle_error + endif + endelse + if nentries eq 0 then begin ;Return if database is empty + !err = 0 + if not keyword_set(SILENT) then message, $ + 'ERROR - No entries in database ' + db_info("NAME",0),/INF + return,listin + endif +; +; parse search parameter string +; + dbfparse,spar,items,stype,search_values + nitems = N_elements(items) ;number of items +; +; set up initial search list +; +list = listin +s=size(list) & ndim=s[0] +if ndim EQ 0 then list=lonarr(1)+list +; +; get some item info +; +db_item,items,it,ivalnum,idltype,sbyte,numvals,nbytes,errmsg=errmsg +IF N_ELEMENTS(ERRMSG) NE 0 THEN IF ERRMSG NE '' THEN BEGIN + MESSAGE = ERRMSG + GOTO, HANDLE_ERROR +ENDIF +index = db_item_info('INDEX',it) ;index type +dbno = db_item_info('DBNUMBER',it) ;data base number + ; particular db. +; +; get info on the need to byteswap item by item +; +external = db_info('external') ;External format? +bswap = external * (not IS_IEEE_BIG() ) ;Need to byteswap? +dbno1 = db_item_info('dbnumber', it) +bswap = bswap[dbno1] + +done=bytarr(nitems) ;flag for completed + ; items +;---------------------------------------------------------------------- +; ENTRY number is a search parameter? +; +for pos = 0,nitems-1 do begin + if (it[pos] eq 0) then begin + dbfind_entry,stype[pos],search_values[pos,*],nentries,list,count=count + done[pos]=1 ;flag as done + if count LT 1 then goto, FINI ;any found + end +end +;---------------------------------------------------------------------- +; +; perform search on sorted items in the first db +; + +for pos=0,nitems-1 do begin + if(not done[pos]) and (dbno[pos] eq 0) and $ + (index[pos] ge 2) then begin + dbfind_sort,it[pos],stype[pos],search_values[pos,*],list, $ + fullstring=fullstring, Count = count + if !err ne -2 then begin + if count lt 1 then goto,FINI + done[pos]=1 + end + end +end +; ------------------------------------------------------------------------ +; Perform search on items in lookup file (indexed items) in first db +; +if total(done) eq nitems then goto,FINI +for pos=0,nitems-1 do begin + if(not done[pos]) and (dbno[pos] eq 0) and (index[pos] ne 0) then begin + dbext_ind,list,it[pos],0,values + dbsearch, stype[pos], search_values[pos,*], values, good, $ + Fullstring = fullstring, Count = count + if !err eq -2 then begin + print,'DBFIND - Illegal search value for item ', $ + db_item_info('name',it[pos]) + return,listin + endif + if count lt 1 then goto, FINI ;any found + if list[0] ne -1 then list=list[good] else list=good+1 + done[pos]=1 ; DONE with that item + end +end + +;------------------------------------------------------------------------ +; +; search index items in other opened data bases (if any) +; +found=where( (index gt 0) and (dbno ne 0 ), Nfound) +if Nfound gt 0 then begin + db = dbno[ where(dbno NE 0) ] + for i = 0, n_elements(db)-1 do begin +; +; find entry numbers of second database corresponding to entry numbers +; in the first data base. +; + pointer=db_info('pointer',db[i]) ;item which points to it +; + dbext,list,pointer,list2 ;extract entry numbers in 2nd db + good=where(list2 ne 0,ngood) ;is there a valid pointer + if ngood lt 1 then goto, FINI + if list[0] eq -1 then list=good+1 else list=list[good] + list2=list2[good] + for pos=0,nitems-1 do begin + if (not done[pos]) and (dbno[pos] eq db[i]) and (index[pos] ne 0) $ + and (index[pos] ne 3) then begin + dbext_ind,list2,it[pos],dbno[pos],values + dbsearch, stype[pos], search_values[pos,*], values, good, $ + fullstring = fullstring, count = count + if !err eq -2 then begin + message = 'Illegal search value for item ' + $ + db_item_info('name',it[pos]) + goto, handle_error + endif + if count lt 1 then goto, FINI ;any found + if list[0] ne -1 then list=list[good] else list=good+1 + list2=list2[good] + done[pos]=1 ; DONE with that item + endif + endfor + endfor +endif +;--------------------------------------------------------------------------- +; search remaining items +; + + if list[0] eq -1 then list= lindgen(nentries)+1 ;Fixed WBL Feb. 1989 + count = N_elements(list) + !err = count + if total(done) eq nitems then goto, FINI ;all items searched + + nlist = N_elements(list) ;number of entries to search + if nlist GT 10000 then begin + print,'Non-indexed search on ',strtrim(nlist,2),' entries' + print,'Expect Delay' + end +; +; Create array to hold values of all remaining items...a big one. +; + left = where( done EQ 0, N_left ) ;items left + nbytes = nbytes[left] + sbyte = sbyte[left] + idltype = idltype[left] + bswap = bswap[left] + totbytes = total(nbytes) ;total number of bytes to extract + big = bytarr(totbytes,nlist) ;array to store values of the items +; +; generate starting position in big for each item +; + bpos = lonarr(N_left) ;starting byte in bpos of each item + if N_left GT 1 then for i=1,N_left-1 do bpos[i] = bpos[i-1]+nbytes[i-1] + + index = lonarr(totbytes) ;indices of bytes to extract + ipos = 0 ;position in index array + for i = 0,N_left-1 do begin ;loop on items + for j=0,nbytes[i]-1 do index[ipos+j]=sbyte[i]+j ;position in entry + ipos = ipos + nbytes[i] + end;for + +; +; loop on entries and extract info +; + for ii = 0L, nlist-1L do begin + dbrd,list[ii],entry, /noconvert ;read entry + big[0,ii]= entry[index] + endfor + +; +; now extract values for each item and search for valid ones +; + stillgood = lindgen( nlist ) + + for i = 0l,N_left-1 do begin + if i Eq 0 then val = big[ bpos[i]:bpos[i]+nbytes[i]-1, 0:nlist-1 ] else $ + val = big[ bpos[i]:bpos[i]+nbytes[i]-1, stillgood ] + if bswap[i] then ieee_to_host, val, idltype=idltype[i] + case idltype[i] of + 1: v = byte(val,0,nlist) ;byte + 2: v = fix(val,0,nlist) ;i*2 + 3: v = long(val,0,nlist) ;i*4 + 4: v = float(val,0,nlist) ;r*4 + 5: v = double(val,0,nlist) ;r*8 + 7: v = string(val) ;string + 12: v = uint(val,0,nlist) ;u*2 + 13: v = ulong(val,0,nlist) ;u*4 + 14: v = long64(val,0,nlist) ;i*8 + 15: v = ulong64(val,0,nlist) ;u*8 + endcase + dbsearch, stype[left[i]], search_values[left[i],*], v, good, $ + Fullstring = fullstring, count = count + if count LT 1 then goto, FINI + stillgood=stillgood[good] + nlist = count + endfor + list = list[stillgood] + count = N_elements(list) & !ERR = count + +FINI: +if not keyword_set(SILENT) then begin + print,' ' & print,' ' + if count LE 0 then $ + print,'No entries found by dbfind in '+ db_info('name',0) $ + else $ + print,count,' entries found in '+ db_info('name',0) +endif +if count LE 0 then return,intarr(1) else return,list[sort(list)] +; +; Error handling point. +; +HANDLE_ERROR: + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = 'DBFIND: ' + MESSAGE $ + ELSE MESSAGE, MESSAGE +end diff --git a/modules/idl_downloads/astro/pro/dbfind_entry.pro b/modules/idl_downloads/astro/pro/dbfind_entry.pro new file mode 100644 index 0000000..f15fdbd --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbfind_entry.pro @@ -0,0 +1,117 @@ +pro dbfind_entry,type,svals,nentries,values,Count = count +;+ +; NAME: +; DBFIND_ENTRY +; PURPOSE: +; Subroutine of DBFIND to perform an entry number search +; EXPLANATION: +; This is a subroutine of dbfind and is not a standalone procedure +; It performs a entry number search. +; +; CALLING SEQUENCE: +; dbfind_entry, type, svals, nentries, values, [COUNT = ] +; +; INPUTS: +; type - type of search (output from dbfparse) +; svals - search values (output from dbfparse) +; values - array of values to search +; OUTPUT: +; good - indices of good values +; OPTIONAL OUTPUT KEYWORD: +; Count - integer scalar giving the number of valid matches +; SIDE EFFECTS" +; The obsolete system variable !err is set to number of good values +; +; REVISION HISTORY: +; D. Lindler July,1987 +; Fixed test for final entry number W. Landsman Sept. 95 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added COUNT keyword, deprecate !ERR W. Landsman March 2000 +; Better checking of out of range values W. Landsman February 2002 +;- +sv0=long(strtrim(svals[0],2)) & sv1=long(strtrim(svals[1],2)) + +if values[0] eq -1 then begin ;start with all entries + case type of + + 0: begin + if (sv0 gt 0) and (sv0 le nentries) then begin ;Update Sep 95 + values=lonarr(1)+sv0 + count=1 + end else count= 0 + end + -1: begin + if nentries LT sv0 then count = 0 else begin + values=lindgen(nentries-sv0+1) + sv0 ;value>sv0 + count=nentries-sv0+1 + endelse + end + -2: begin + values= lindgen(sv1>111 + sv1=sv11 + maxv=(sv0+abs(sv1))sv0 + -2: good=where(values le sv1, count) ;value2 +sv=replicate(values[0],nvals) +for i=0L,nvals-1 do sv[i]=strtrim(svals[i],2) +sv0 = sv[0] & sv1 = sv[1] + +; +;-------------------------------------------------------------------------- +; FIND RANGE OF VALID SUBSCRIPTS IN LIST +; +; +if nv EQ 1 then begin + first = 0 & last = 1 +endif else begin + +case type of + + 0: begin ;value=sv0 + first = value_locate(values,sv0) > 0 + last = (first +1) < nv + while values[first] EQ sv0 do begin + if first EQ 0 then break + first = first-1 + endwhile + + end + + -1: begin ;value>sv0 + first = value_locate(values,sv0) > 0 + last = nv + while values[first] EQ sv0 do begin + if first EQ 0 then break + first = first-1 + endwhile + end + + -2: begin ;value first + while values[first] EQ sv0 do begin + if first EQ 0 then break + first = first-1 + endwhile + end + + -3: begin ;sv0 0 + last = (value_locate(values,sv1) + 1) < nv > 0 + while values[first] EQ sv0 do begin + if first EQ 0 then break + first = first-1 + endwhile + + end + -5: begin ;sv1 is tolerance + + minv = sv0-abs(sv1) + maxv = sv0+abs(sv1) + good = where(values LT minv, N) + if N LT 1 then first=0 else first=N-1 + good = where(values GT maxv, N) + if N LT 1 then last=nv else last=good[0] + while values[first] EQ sv0 do begin + if first EQ 0 then break + first = first-1 + endwhile + end + + -4: begin ;non-zero + if values[0] EQ 0 then begin + good=where(values EQ 0, N) + first=N-1 + last=nv + end else begin ;not allowed + !err=-2 + return + end + end + else: begin ;set of values + sv0 = min(sv[0:type-1]) & sv1 = max(sv[0:type-1]) + good=where(values LT sv0, N) + if N LT 1 then first=0 else first=N-1 + good=where(values GT sv1, N) + if N LT 1 then last=nv else last=good[0] + end +endcase +endelse +;----------------------------------------------------------------------------- +; we now know valid values are between index numbers first*512 to last*512 +; +if first EQ last then begin + !err=0 + return +end +; +; extract data values for blocks first to last +; +sblock=header[4,pos] ;starting block for sorted data +sbyte=512LL*sblock ;starting byte +first=first*512L+1 +last=(last*512L) < db_info('entries',0) +number=last-first+1 +if dtype NE 7 then $ +p = assoc(unit,make_array(size=[1,number,dtype,0],/nozero), $ + sbyte+(first-1)*num_bytes) else $ + p = assoc(unit,make_array( size=[2,nbytes,number,1,0],/NOZERO), $ + sbyte+(first-1)*num_bytes) + +values=p[0] + +if dtype EQ 7 then values = string(values) else $ +if external then swap_endian_inplace,values,/swap_if_little +; +; if index type is 2, data base is sorted on this item, first and last +; give range of valid entry numbers +; + +if index_type EQ 2 then begin + if list[0] EQ -1 then begin + list=lindgen(number)+first + end else begin + good=where((list ge first) and (list le last), number) + if number GT 0 then begin + list=list[good] + values=values[list-first] + endif + end +; +; if index type wasn't 2 the item was sorted and index numbers must +; be read +; + +end else begin +; +; find starting location to read +; + sblock=header[5,pos] + sbyte=512LL*sblock +; +; read values from file +; +p = assoc(unit,make_array(size=[1,number,3,0],/nozero),sbyte+(first-1)*4) + if list[0] EQ -1 then begin + list=p[0] + if external then byteorder,list, /NTOHL + end else begin + list2=p[0] + if external then byteorder,list2,/NTOHL ;Fixed typo Jan 2010 + match,list,list2,suba,subb, Count = number + if number GT 0 then begin + list=list[suba] + values=values[subb] + end + end +end +; +; now search indiviual entries +; +if number GT 0 then begin + dbsearch,type,svals,values,good,fullstring=fullstring, Count = number + if number GT 0 then list=list[good] +end +!err=number +return +end diff --git a/modules/idl_downloads/astro/pro/dbfparse.pro b/modules/idl_downloads/astro/pro/dbfparse.pro new file mode 100644 index 0000000..0218c20 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbfparse.pro @@ -0,0 +1,240 @@ +pro dbfparse, spar, items, stype, values +;+ +; NAME: +; DBFPARSE +; PURPOSE: +; Parse the search string supplied to DBFIND. Not a standalone routine +; +; CALLING SEQUENCE: +; DBFPARSE, [ spar, items, stype, values ] +; +; INPUTS: +; spar - search parameter specification, scalar string +; +; OUTPUTS: +; items - list of items to search on +; stype - search type, numeric scalar +; 0 item=values[j,0] +; -1 item>values[j,0] +; -2 itemvalues(j,0) + ; -2 itemvalue + ; + (strpos(next,'>') gt 0): begin + items[nitems]=gettok(next,'>');get item name + values[nitems,0]=next ;get minimum value + stype[nitems]=-1 + end + ; + ; Range specified or maximum specified. + ; + (strpos(next,'<') gt 0): begin ; form is min dbopen, 'YALE_BS' +; IDL> hdno = [1141,2363,3574,4128,6192,6314,6668] ;Desired HD numbers +; IDL> list = dbget( 'HD', hdno ) ;Get corresponding entry numbers +; +; SYSTEM VARIABLES: +; The obsolete system variable !ERR is set to number of entries found +; REVISION HISTORY: +; Written, W. Landsman STX February, 1989 +; William Thompson, GSFC, 14 March 1995 Added keyword FULLSTRING +; Converted to IDL V5.0 W. Landsman September 1997 +; Added COUNT keyword, deprecate !ERR W. Landsman March 2000 +; Fix bug introduced March 2000 W. Landsman November 2000 +; Fix possible bug when sublist supplied W. Landsman August 2008 +;- +; + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax -- list = ' + $ + 'DBGET( item, values, [listin, /SILENT, /FULLSTRING, Count=]' + return,-1 + endif + + if N_params() LT 3 then listin = lonarr(1)-1 + + nvals = N_elements(values) + + if nvals EQ 0 then message,'No search values supplied' + + db_item, item, itnum + index = db_item_info( 'INDEX', itnum) + list = listin + + if nvals EQ 1 then val = [values,values] $ ;Need at least 2 elements + else val = values + + if index[0] GE 2 then begin ;Sorted item + if N_elements(list) EQ 1 then list = lonarr(1) + list + dbfind_sort, itnum[0], nvals, val, list, $ + FULLSTRING = fullstring, Count =count + + endif else begin ;Non-sorted item + dbext, list, itnum, itvals + dbsearch, nvals, val, itvals, good, FULLSTRING = fullstring, Count = count + if count GT 0 then $ ;Updated Aug 2008 + if list[0] NE -1 then list = list[good] else list = good+1 + endelse + + if count LE 0 then begin + if not keyword_set(SILENT) then $ + print, 'No entries found by DBGET in ' + db_info( 'NAME',0 ) + list = intarr(1) + + endif else if not keyword_set( SILENT ) then $ + print,count,' entries found in '+db_info('name',0) + + return, list[ sort(list) ] + + end diff --git a/modules/idl_downloads/astro/pro/dbhelp.pro b/modules/idl_downloads/astro/pro/dbhelp.pro new file mode 100644 index 0000000..e2bb8b5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbhelp.pro @@ -0,0 +1,275 @@ +pro dbhelp,flag,TEXTOUT=textout,sort=sort +;+ +; NAME: +; DBHELP +; PURPOSE: +; List available databases or items in the currently open database +; EXPLANATION: +; Procedure to either list available databases (if no database is +; currently open) or the items in the currently open database. +; +; CALLING SEQUENCE: +; dbhelp, [ flag , TEXTOUT=, /SORT ] +; +; INPUT: +; flag - (optional) if set to nonzero then item or database +; descriptions are also printed +; default=0 +; If flag is a string, then it is interpreted as the +; name of a data base (if no data base is opened) or a name +; of an item in the opened data base. In this case, help +; is displayed only for the particular item or database +; +; OUTPUTS: +; None +; OPTIONAL INPUT KEYWORDS: +; TEXTOUT - Used to determine output device. If not present, the +; value of !TEXTOUT system variable is used (see TEXTOPEN ) +; +; textout=0 Nowhere +; textout=1 if a TTY then TERMINAL using /more option +; otherwise standard (Unit=-1) output +; textout=2 if a TTY then TERMINAL without /more option +; otherwise standard (Unit=-1) output +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 same as 3 but text is appended to .prt +; file if it already exists. +; textout = filename (default extension of .prt) +; +; /SORT - If set and non-zero, then the help items will be displayed +; sorted alphabetically. If more than one database is open, +; then this keyword does nothing. +; METHOD: +; If no data base is opened then a list of data bases are +; printed, otherwise the items in the open data base are printed. +; +; If a string is supplied for flag and a data base is opened +; flag is assumed to be an item name. The information for that +; item is printed along with contents in a optional file +; zdbase:dbname_itemname.hlp +; if a string is supplied for flag and no data base is opened, +; then string is assumed to be the name of a data base file. +; only information for that file is printed along with an +; optional file zdbase:dbname.hlp. +; PROCEDURES USED: +; DB_INFO(),DB_ITEM_INFO(),FIND_WITH_DEF(), TEXTOPEN, TEXTCLOSE, UNIQ() +; IDL VERSION: +; V5.3 or later (uses vectorized FDECOMP) +; HISTORY: +; Version 2 D. Lindler Nov 1987 (new db format) +; Faster printing of title desc. W. Landsman May 1989 +; Keyword textout added, J. Isensee, July, 1990 +; Modified to work on Unix, D. Neill, ACC, Feb 1991. +; William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Added support for external (IEEE) representation. +; William Thompson, GSFC, 3 November 1994 +; Modified to allow ZDBASE to be a path string. +; Remove duplicate database names Wayne Landsman December 1994 +; 8/17/95 jkf/acc - force lowercase filenames for .hlp files. +; Added /SORT keyword J. Sandoval/W. Landsman October 1998 +; V5.3 version use vectorized FDECOMP W. Landsman February 2001 +; Recognize 64 bit, unsigned integer datatypes W. Landsman September 2001 +; Fix display of number of bytes with /SORT W. Landsman February 2002 +; Assume since V5.2 W. Landsman February 2002 +; Assume since V5.5 W. Landsman +; Define !TEXTOUT if not already defined W. Landsman April 2016 +;- +;**************************************************************************** + + defsysv,'!TEXTUNIT',exist=i + if i EQ 0 then astrolib + +; +; get flag value +; + + stn='' + if N_params() GT 0 then begin + if size(flag,/TNAME) EQ 'STRING' then $ ;item name or db name + stn=strtrim(flag) + endif else flag = 0 ;flag not supplied +; +; Are any data bases opened? +; +opened = db_info('OPEN') +if opened then begin + if stn EQ '' then xtype=1 $ ;all items + else xtype=2 ;single item + end else begin + if stn EQ '' then xtype=3 $ ;all db's + else xtype=4 ;single db +end +; +; determine where user wants output...default terminal. +; +if N_elements(textout) EQ 0 then textout = !textout ;use default output dev. +; +textopen,'dbhelp',textout=textout +; +;-------------------------------------------------------------------- +; if data base open then print info for it +; +if opened then begin ;data base opened? +; +; get list of items to print +; + if xtype eq 1 then begin ;all items? + nitems=db_info('items') ;number of items + itnums=indgen(nitems) + end else begin + nitems=1 + db_item,stn,itnums + end +; +; get information on the items +; + names = db_item_info('NAME',itnums) ;item names + idltype = db_item_info('IDLTYPE',itnums) ;data type + nbytes = db_item_info('NBYTES',itnums) ;number of bytes + desc = db_item_info('DESCRIPTION',itnums) ;description + pointer = db_item_info('POINTER',itnums) ;file it points to + index = db_item_info('INDEX',itnums) ;index type + pflag = db_item_info('PFLAG',itnums) ;pointer item flag + dbnumber = db_item_info('DBNUMBER',itnums) ;opened data base number + pnumber = db_item_info('PNUMBER',itnums) ;opened data base it points to + nvalues = db_item_info('NVALUES',itnums) ;number of values for vector + if keyword_set(sort) && (max(dbnumber) EQ 0) then begin + nsort = sort(names) + names = names[nsort] + idltype = idltype[nsort] + desc = desc[nsort] + nvalues = nvalues[nsort] + nbytes = nbytes[nsort] + endif +; +; get names and descriptions of opened db's +; + + if flag then begin ;print descrip.? + desc = strtrim(desc) + printf,!textunit,' ' + printf,!textunit,'----- '+db_info('name',dbnumber[0]) +' '+ $ + db_info('title',dbnumber[0]) + printf,!textunit,' ITEM TYPE DESCRIPTION' + for i=0,nitems-1 do begin + if i NE 0 then if dbnumber[i] ne dbnumber[i-1] then begin + printf,!textunit,' ' + printf,!textunit,'----- '+db_info('name',dbnumber[i]) +' '+ $ + db_info('title',dbnumber[i]) + printf,!textunit,' ITEM TYPE DESCRIPTION' + end + case idltype[i] of + 1: type = 'byte' + 2: type = 'int*2' + 3: type = 'int*4' + 4: type = 'real*4' + 5: type = 'real*8' + 7: type = 'char*'+strtrim(nbytes[i],2) + 12: type = 'uint*2' + 13: type = 'uint*4' + 14: type = 'int*8' + 15: type = 'uint*8' + end + while strlen(type) lt 8 do type=type+' ' + qname = names[i] + if nvalues[i] GT 1 then begin + qname=strtrim(qname) + qname=qname+'('+strtrim(nvalues[i],2)+')' + while strlen(qname) lt 20 do qname=qname+' ' + end + printf,!textunit,strmid(qname,0,18),' ',type,' ', desc[i] + end + end else begin ;just print item names + printf,!textunit,form='(1x,7a11)',names + end +; +; print index information ----------------------------------------- +; + if (xtype EQ 1) && (total(index) GT 0) then begin + if xtype EQ 1 then begin + printf,!textunit,' ' + printf,!textunit,'------- Indexed Items ------' + indexed=where(index) + printf,!textunit,names[indexed] + end else begin + printf,!textunit,'The item is indexed' + end + end +; +; print pointer information ---------------------------------------- +; + if (total(pflag) GT 0) && (xtype EQ 1) then begin + good = where( pflag, n) + printf,!textunit,' ' + printf,!textunit,'----- Pointer Information ----' + for i=0,n-1 do begin + pos=good[i] + if pnumber[pos] GT 0 then popen=' (presently opened)' $ + else popen='' + printf,!textunit,strtrim(db_info('name',dbnumber[pos]))+ $ + '.'+strtrim(names[pos])+' ---> '+ $ + strtrim(pointer[pos])+popen + end + end +; +; print information on data base size ---------------------------- +; + printf,!textunit,' ' + if xtype EQ 1 then printf,!textunit,'data base contains', $ + db_info('ENTRIES',0),' entries' +; +; print data base information -------------------------------- +; + end else begin ;list data bases + if stn EQ '' then begin + names=list_with_path('*.dbh', 'ZDBASE', COUNT=n) ;get list + if n EQ 0 then message,'No databases found in ZDBASE directory' + endif else begin + names=list_with_path(stn+'*.dbh', 'ZDBASE', COUNT=n) ;get list + if n EQ 0 then message,'Unable to locate database '+stn + endelse + fdecomp,names,disk,dir,fnames + fsort = uniq(fnames,sort(fnames)) + n = N_elements(fsort) + if flag then begin ;print description from .DBH file + get_lun,unit + names = names[fsort] + b=bytarr(79) ;Database title is 79 bytes + for i=0,n-1 do begin + openr,unit,names[i],error=err + if err NE 0 then message,/CON, 'Error opening ' + names[i] + readu,unit,b + printf,!TEXTUNIT,strtrim(b[0:78],2) + close,unit + endfor + free_lun,unit + endif else $ ;just print names + printf,!textunit,form='(A,T20,A,T40,A,T60,A)',fnames[fsort] +endelse +; +; now print aux help file info if flag was a string --------------------- +; +if stn NE '' then begin + if xtype EQ 4 then file=find_with_def(stn+'.hlp', 'ZDBASE') $ + else file=find_with_def(strlowcase( $ + strtrim(db_info( 'NAME', dbnumber[0]))+ $ + '_' + strtrim(names[0]) + '.hlp'), 'ZDBASE') + openr,unit,strlowcase(file),error=err,/get_lun + if err EQ 0 then begin + st='' + while not eof(unit) do begin + readf,unit,st + printf,!textunit,st + end; while + free_lun,unit + endif +end +; +; close unit opened by TEXTOPEN +; +textclose, TEXTOUT = textout + +return +end diff --git a/modules/idl_downloads/astro/pro/dbindex.pro b/modules/idl_downloads/astro/pro/dbindex.pro new file mode 100644 index 0000000..8359e9b --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbindex.pro @@ -0,0 +1,218 @@ +pro dbindex,items +;+ +; NAME: +; DBINDEX +; PURPOSE: +; Procedure to create index file for data base +; +; CALLING SEQUENCE: +; dbindex, [ items ] +; +; OPTIONAL INPUT: +; items - names or numbers of items to be index -- if not supplied, +; then all indexed fields will be processed. +; +; OUTPUT: +; Index file .dbx is created on disk location ZDBASE: +; +; OPERATIONAL NOTES: +; (1) Data base must have been previously opened for update +; by DBOPEN +; +; (2) Only 18 items can be indexed at one time. If the database has +; more than 18 items, then two separate calls to DBINDEX are needed. +; PROCEDURES CALLED: +; DBINDEX_BLK, DB_INFO(), DB_ITEM, DB_ITEM_INFO(), IS_IEEE_BIG() +; HISTORY: +; version 2 D. Lindler Nov 1987 (new db format) +; W. Landsman added optional items parameter Feb 1989 +; William Thompson, GSFC/CDS (ARC), 30 May 1994 +; Added support for external (IEEE) data format +; Test if machine is bigendian W. Landsman May, 1996 +; Change variable name of BYTESWAP to BSWAP W. Thompson Mar, 1997 +; Increased number of fields to 15 W. Landsman June, 1997 +; Increase number of items to 18 W. Landsman November 1999 +; Allow multiple valued (nonstring) index items W. Landsman November 2000 +; Use 64 bit integers for V5.2 or later W. Landsman February 2001 +; Do not use EXECUTE() for V6.1 or later, improve efficiency +; W. Landsman December 2006 +; Automatically enlarge .dbx file if needed, fix major bug in last +; update W. Landsman Dec 2006 +; Assume since V6.1 W. Landsman June 2009 +; Allow sorted string items W. Landsman October 2009 +; Use Swap_Endian_Inplace instead of IEEE_TO_HOST W. Landsman April 2016 +;- +;***************************************************************** + On_error,2 ;Return to caller + compile_opt idl2 + +; Check to see if data base is opened for update + + if db_info('UPDATE') EQ 0 then message, $ + 'Database must be opened for update' + +; Extract index items from data base + + if N_params() EQ 1 then db_item,items,itnum else begin + nitems = db_info('ITEMS',0) + itnum = indgen(nitems) + endelse + + indextype = db_item_info('INDEX',itnum) + indexed = where(indextype, Nindex) ;Select only indexed items + if Nindex LE 0 then begin + message,'Database has no indexed items',/INF + return + endif else if Nindex GT 18 then begin + message,'ERROR - Only 18 items can be indexed at one time',/INF + return + endif + + indextype = indextype[indexed] + if N_params() EQ 1 then indexed = itnum[indexed] + +; get info on indexed items + + nbytes = db_item_info('NBYTES',indexed) ;Number of bytes + idltype = db_item_info('IDLTYPE',indexed) ;IDL type + sbyte = db_item_info('SBYTE',indexed) ;Starting byte + nval = db_item_info('NVALUES',indexed) ;Number of values per entry + +; get db info + + nentries = db_info('ENTRIES',0) + if nentries EQ 0 then begin + message, 'ERROR - database contains no entries',/INF + return + endif + unit = db_info('UNIT_DBX',0) ;unit number of index file + external = db_info('EXTERNAL',0) ;external format? + bswap = external ? not IS_IEEE_BIG() : 0 + +; read header info of index file (mapped file) + + reclong = assoc(unit,lonarr(2),0) + h = reclong[0] ;first two longwords + if bswap then swap_endian_inplace,h,/swap_if_little + maxentries = h[1] ;max allowed entries +; If necessary, enlarge the size of the .dbx file. All indexed items must +; then be reindexed. + if maxentries lt nentries then begin + message,'Enlarging index (.dbx) file to support ' + $ + strtrim(nentries,2) + ' entries',/INF + dbname = db_info('name',0) + dbcreate,dbname,1,maxentry=nentries,external=db_info('external') + dbopen, dbname, 1 + nitems = db_info('ITEMS',0) + itnum = indgen(nitems) + endif + + nindex2 = h[0] ;number of indexed items + if nindex2 LT nindex then goto, NOGOOD + reclong = assoc(unit,lonarr(7,nindex2),8) + header = reclong[0] ;index header + if bswap then swap_endian_inplace,header,/swap_if_little + hitem = header[0,*] ;indexed item numbers + hindex = header[1,*] ;index type + htype = header[2,*] ;idl data type + hblock = header[3,*] ;starting block of header + sblock = header[4,*] ;starting block of data values + iblock = header[5,*] ;starting block of indices (type=3) + ublock = header[6,*] ;starting block of unsorted data (type=4) + +; extract index items...maximum of 18 indexed fields. + + list = lindgen(nentries)+1l + dbext_dbf,list,0,sbyte,nbytes*nval,idltype,nval, $ + v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18 + + for i = 0,nindex-1 do begin + ; + ; place item in variable v + ; + v = (scope_varfetch('v' + strtrim(i+1,2))) + pos = where(hitem EQ indexed[i], N_found) + if N_found LE 0 then goto, NOGOOD + pos = pos[0] + if hindex[pos] NE indextype[i] then goto, NOGOOD + if ( idltype[i] EQ 7 ) then v = byte(v) +; +; process according to index type --------------------------------------- +; + reclong = assoc(unit,lonarr(1),(iblock[pos]*512LL)) + case indextype[i] of + + 1: begin ;indexed (unsorted) + + datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v + end +; + 2: begin ;values are already sorted + + nb=(nentries+511L)/512 ;number of 512 value blocks + ind=indgen(nb)*512LL ;position at start of each block + sval=v[ind] ;value at start of each block +; + datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval + ; + datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v + end + + 3: begin ; sort item before storage + + if idltype[i] EQ 7 then begin + svv = string(v) + sub= bsort(svv) + v = byte(svv[sub]) + endif else begin + sub=bsort(v) ;sort values + v=v[sub] + endelse + nb=(nentries+511)/512 ;number of 512 value blocks + ind=l64indgen(nb)*512LL ;position at start of each block + if idltype[i] EQ 7 then sval=v[*,ind] else sval = v[ind] + ;value at start of each block + datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval +; + datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v + reclong[0] = bswap ? swap_endian(sub+1,/swap_if_little) : sub+1 ;indices + end + 4: begin ; sort item before storage + + datarec = dbindex_blk(unit, ublock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v + if idltype[i] EQ 7 then begin + svv = string(v) + sub= bsort(svv) + v = byte(svv[sub]) + endif else begin + sub=bsort(v) ;sort values + v=v[sub] + endelse + + + nb=(nentries+511)/512 ;number of 512 value blocks + ind=l64indgen(nb)*512LL ;position at start of each block + if idltype[i] EQ 7 then sval=v[*,ind] else sval = v[ind] + ;value at start of each block + datarec = dbindex_blk(unit, hblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(sval,/swap_if_little) : sval + ; + datarec = dbindex_blk(unit, sblock[pos], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(v,/swap_if_little) : v +; + reclong[0] = bswap ?swap_endian(sub+1,/swap_if_little) : sub+1 ;indices + end + endcase +endfor +return +NOGOOD: + print,'DBINDEX-- Inconsistency in .dbh and .dbx file' + print,'Run dbcreate to create a new index file' + return +end diff --git a/modules/idl_downloads/astro/pro/dbindex_blk.pro b/modules/idl_downloads/astro/pro/dbindex_blk.pro new file mode 100644 index 0000000..7048570 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbindex_blk.pro @@ -0,0 +1,49 @@ +FUNCTION dbindex_blk, unit, nb, bsz, ofb, dtype +;+ +; NAME: +; DBINDEX_BLK +; PURPOSE: +; Subroutine of DBINDEX to create associated variable of correct datatype +; EXPLANATION: +; DBINDEX_BLK will offset into the file by a specified amount in +; preparation for writing to the file. V5.2 or later +; +; CALLING SEQUENCE: +; res = dbindex_blk(unit, nb, bsz, ofb, dtype) +; +; INPUTS: +; unit The unit number assigned to the file. +; nb The number of blocks to offset into the file. +; bsz The size of each block, in bytes, to offset into the file. +; ofb The offset into the block, in bytes. +; dtype The IDL datatype as defined in the SIZE function +; +; OUTPUTS: +; res The returned variable. This is an associated variable. +; +; RESTRICTIONS: +; The file must have been previously opened. +; +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 14 June 1990. +; Converted to IDL V5.0 W. Landsman September 1997 +; Use 64 bit integer for very large databases W. Landsman February 2001 +; Added new unsigned & 64bit integer datatypes W. Landsman July 2001 +;- +offset = long64(nb) * long64(bsz) + long64(ofb) +case dtype of + 7: datarec=assoc(unit,bytarr(1),offset) ; string + 1: datarec=assoc(unit,bytarr(1),offset) ; byte + 2: datarec=assoc(unit,intarr(1),offset) ; integer + 4: datarec=assoc(unit,fltarr(1),offset) ; floating point + 3: datarec=assoc(unit,lonarr(1),offset) ; longword + 5: datarec=assoc(unit,dblarr(1),offset) ; double + 6: datarec=assoc(unit,complexarr(1),offset) ; complex + 12: datarec=assoc(unit,uintarr(1),offset) ; unsigned integer + 13: datarec=assoc(unit,ulonarr(1),offset) ; unsigned longword + 14: datarec=assoc(unit,lon64arr(1),offset) ; 64 bit longword + 15: datarec=assoc(unit,ulon64arr(1),offset) ; unsigned 64bit longword +endcase +; +RETURN, datarec +END diff --git a/modules/idl_downloads/astro/pro/dbmatch.pro b/modules/idl_downloads/astro/pro/dbmatch.pro new file mode 100644 index 0000000..e733a5e --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbmatch.pro @@ -0,0 +1,173 @@ +function dbmatch, item, values, listin, FULLSTRING = fullstring +;+ +; NAME: +; DBMATCH +; PURPOSE: +; Find the entry number in a database for each element of item values +; EXPLANATION: +; DBMATCH() is especially useful for finding a one-to-one +; correspondence between entries in different databases, and thus to +; create the vector needed for database pointers. +; +; CALLING SEQUENCE: +; list = DBMATCH( item, values, [ listin, /FULLSTRING ] ) +; +; INPUTS: +; ITEM - Item name or number, scalar +; VALUES - scalar or vector containing item values to search for. +; +; OPTIONAL INPUTS: +; LISTIN - list of entries to be searched. If not supplied, or +; set to -1, then all entries are searched +; OUTPUT: +; LIST - vector of entry numbers with the same number of elements as +; VALUES. Contains a value of 0 wherever the corresponding item +; value was not found. +; +; OPTIONAL INPUT: +; /FULLSTRING - By default, one has a match if a search string is +; included in any part of a database value (substring match). +; But if /FULLSTRING is set, then all characters in the database +; value must match the search string (excluding leading and +; trailing blanks). Both types of string searches are case +; insensitive. +; +; NOTES: +; DBMATCH is meant to be used for items which do not have duplicate values +; in a database (e.g. catalog numbers). If more than one entry is found +; for a particular item value, then only the first one is stored in LIST. +; +; When linked databases are opened together, DBMATCH can only be +; used to search on items in the primary database. +; +; EXAMPLE: +; Make a vector which points from entries in the Yale Bright Star catalog +; to those in the Hipparcos catalog, using the HD number +; +; IDL> dbopen, 'yale_bs' ;Open the Yale Bright star catalog +; IDL> dbext, -1, 'HD', hd ;Get the HD numbers +; IDL> dbopen, 'hipparcos' ;Open the Hipparcos catalog +; IDL> list = dbmatch( 'HD', HD) ;Get entries in Hipparcos catalog +; ;corresponding to each HD number. +; PROCEDURE CALLS: +; DB_ITEM, DB_ITEM_INFO(), DBEXT, DBFIND_SORT() +; REVISION HISTORY: +; Written, W. Landsman STX February, 1990 +; Fixed error when list in parameter used May, 1992 +; Faster algorithm with sorted item when listin parameter supplied +; Added keyword FULLSTRING,check for empty database, William Thompson, +; GSFC, 15 March 1995 +; Work for more than 32767 values, added CATCH W. Landsman July 1997 +; Change some loop variables to type LONG, W. Landsman July 1999 +; Remove loop for substring searches (faster) W. landsman August 1999 +; Replace DATATYPE() with size(/TNAME) W. Landsman November 2001 +; Fixed typo when search on sorted items W. Landsman February 2002 +; Fixed bug from Nov 2001 where /FULLSTRING was always set. W.L Feb 2007 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax -- list = DBMATCH( item, values, [ listin, /FULLSTRING] )' + return,-1 + endif + + + catch, error_status + if error_status NE 0 then begin + print,!ERR_STRING + if N_elements(listin) NE 0 then return,listin else return, -1 + endif + + nvals = N_elements( values ) + if nvals EQ 0 then message, $ + 'ERROR - No search values (second parameter) supplied' + + if N_params() LT 3 then listin = lonarr(1) - 1 + + db_item,item,itnum + index = db_item_info( 'INDEX', itnum) ;Get index type of item + list = lonarr( nvals ) + + nentries = db_info('entries') + if nentries[0] eq 0 then begin ;Return if database is empty + message,'ERROR - No entries in database ' + db_info("NAME",0),/INF + return,listin*0 + endif + + if index[0] GE 2 then begin ;Sorted item + + if listin[0] NE -1 then min_listin = min( listin, MAX = max_listin) + + for i = 0l,nvals-1 do begin + + val = [values[i],values[i]] + +; We don't supply the LISTIN parameter directly to DBFIND_SORT. Since +; we know that we need only 1 match for each item value, we can do +; the restriction to the LISTIN values faster than DBFIND_SORT can + + tmplist = -1 + dbfind_sort,itnum[0],1,val, tmplist, $ ;Search all entries to start + fullstring=fullstring, Count = Nmatch_sort + + if ( listin[0] NE -1 ) then begin + + if Nmatch_sort EQ 0 then goto, FOUND_MATCH + + good = where( ( tmplist LE max_listin ) and $ + ( tmplist GE min_listin ), Ngood) + + if ( Ngood EQ 0 ) then goto, FOUND_MATCH + + tmplist = tmplist[good] + + for j = 0L, Ngood - 1 do begin + test = where( listin EQ tmplist[j], Nfound ) + if Nfound GE 1 then begin + list[i] = tmplist[j] + goto, FOUND_MATCH + endif + endfor + + endif else if ( Nmatch_sort GT 0 ) then list[i] = tmplist[0] + + FOUND_MATCH: + endfor + + endif else begin ;Non-sorted item + + if listin[0] EQ -1 then tmplist = lindgen( nentries[0] )+1 else $ + tmplist = listin + dbext, tmplist, itnum, itvals + typ = size(itvals,/TNAME) + if typ EQ 'STRING' then begin + itvals = strupcase( strtrim(itvals,2) ) + vals = strupcase( strtrim(values,2) ) + endif else vals = values + for i=0L,nvals-1 do begin + if typ NE 'STRING' then begin ;Fixed Feb 2007 + good = where( itvals EQ vals[i], Nfound ) + if Nfound GT 0 then list[i] = tmplist[ good[0] ] ;Fixed May-92 + + endif else begin ;Can't use WHERE on string arrays + ;unless FULLSTRING is set + + if keyword_set(fullstring) then begin + good = where( itvals EQ vals[i], Nfound) + if Nfound GT 0 then list[i] = tmplist[ good[0] ] + end else begin + good = where(strpos( itvals, vals[i]) GE 0, Nfound) + if Nfound GT 0 then begin + list[i] = tmplist[good[0]] + goto, DONE + endif + + endelse + endelse + DONE: + endfor +endelse + +return,list + +end diff --git a/modules/idl_downloads/astro/pro/dbopen.pro b/modules/idl_downloads/astro/pro/dbopen.pro new file mode 100644 index 0000000..2b10da6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbopen.pro @@ -0,0 +1,411 @@ +pro dbopen,name,update,UNAVAIL=unavail +;+ +; NAME: +; DBOPEN +; PURPOSE: +; Routine to open an IDL database +; +; CALLING SEQUENCE: +; dbopen, name, update +; +; INPUTS: +; name - (Optional) name or names of the data base files to open. +; It has one of the following forms: +; +; 'name' -open single data base file +; 'name1,name2,...,nameN' - open N files which are +; connected via pointers. +; 'name,*' -Open the data base with all data +; bases connected via pointers +; '' -Interactively allow selection of +; the data base files. +; +; If not supplied then '' is assumed. +; name may optionally be a string array with one name +; per element. +; +; update - (Optional) Integer flag specifying opening for update. +; 0 - Open for read only +; 1 - Open for update +; 2 - Open index file for update only +; !PRIV must be 2 or greater to open a file for update. +; If a file is opened for update only a single data base +; can be specified. +; +; OUTPUTS: +; none +; +; INPUT-OUTPUT KEYWORD: +; UNAVAIL - If present, a "database doesn't exit" flag is returned +; through it. 0 = the database exists and was opened (if +; no other errors arose). 1 = the database doesn't exist. +; Also if present, the error message for non-existent databases +; is suppressed. The action, however, remains the same. +; SIDE EFFECTS: +; The .DBF and .dbx files are opened using unit numbers obtained by +; GET_LUN. Descriptions of the files are placed in the common block +; DB_COM. +; +; PROCEDURES CALLED: +; DBCLOSE, DB_INFO(), SELECT_W, ZPARCHECK +; HISTORY: +; For IDL Version 2 W. Landsman May 1990 -- Will require further +; modfication once SCREEN_SELECT is working +; Modified to work under Unix, D. Neill, ACC, Feb 1991. +; UNAVAIL keyword added. M. Greason, Hughes STX, Feb 1993. +; William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Added support for external (IEEE) representation. +; William Thompson, GSFC, 3 November 1994 +; Modified to allow ZDBASE to be a path string. +; 8/29/95 JKF/ACC - forces lowercase for input database names. +; W. Landsman, Use CATCH to catch errors July, 1997 +; W. Landsman Use vector call to FDECOMP, STRSPLIT() Sep 2006 +; W. Landsman Remove obsolete keywords to OPEN Sep 2006 +; Replace SCREEN_SELECT with SELECT_W, remove IEEE_TO_HOST WL Jan 2009 +; Fix typos in BYTEORDER introduced Jan 2009 G. Scandariato/W.L.Feb. 2009 +; Support new DB format which allows entry lengths > 32767 bytes +; W.L. October 2010 +; William Thompson, fixed bug opening multiple databases Dec 2010 +; Fix problem with external databases WL Sep 2011 +; Use tooltips when no parameters called WL Aug 2013 +; +;- +; +;------------------------------------------------------------------------ +On_error,2 +; +; data base common block +; +common db_com,QDB,QITEMS,QDBREC +; +; QDB[*,i] contains the following for each data base opened +; +; bytes +; 0-18 data base name character*19 +; 19-79 data base title character*61 +; 80-81 number of items (integer*2) +; 82-83 record length of DBF file (integer*2) +; 84-87 number of entries in file (integer*4) +; 88-89 position of first item for this file in QITEMS (I*2) +; 90-91 position of last item for this file (I*2) +; 92-95 Last Sequence number used (item=SEQNUM) (I*4) +; 96 Unit number of .DBF file +; 97 Unit number of .dbx file (0 if none exists) +; 98-99 Index number of item pointing to this file (0 for first db) +; 100-103 Number of entries with space allocated +; 104 Update flag (0 open for read only, 1 open for update) +; 105-108 record length of DBF file (integer*4) +; 118 Equals 1 if more 32767 bytes can be stored in database (new format) +; 119 Equals 1 if external data representation (IEEE) is used +; +; QITEMS[*,i] contains description of item number i with following +; byte assignments: +; +; 0-19 item name (character*20) +; 20-21 IDL data type (integer*2) +; 22-23 Number of values for item (1 for scalar) (integer*2) +; in bytes 179-182 in new format +; 24-25 Starting byte position in original DBF record +; In bytes 183-186 (integer*2) New DB format +; 26-27 Number of bytes per data value (integer*2) +; 28 Index type +; 29-97 Item description +; 98-99 print format field length +; 100 flag (1 if this items points to a data base) +; 101-119 Data base this item points to +; 120-125 Print format +; 126-170 Print headers +; 171-172 Starting byte in record returned by DBRD +; 173-174 Data base number in QDB +; 175-176 Data base number this item points to +; 177-178 Item number within the specific data base +; 179-182 Number of values for item (1 for scalar) (integer*4) +; 183-186 Starting byte position in original DBF record (integer*4) +; 187-190 Starting byte in record returned by DBRD +; +; +;------------------------------------------------------------------------- +; +; +; check for valid input parameters +; +if N_params() lt 1 then name='' +if N_params() lt 2 then update=0 + catch, error_status + if error_status NE 0 then begin + print,!ERR_STRING + return + endif + +zparcheck,'DBOPEN',name,1,7,[0,1],'Data base name[s]' +zparcheck,'DBOPEN',update,2,[1,2,3,4,5],0,'Update flag' +; +; check privilege +; +if update && (!priv lt 2) then $ + message,'!PRIV must be 2 or greater to open with update' +; +; check UNAVAIL +; +unav_flg = arg_present(unavail) +unavail = 0 +totret = 1 +;--------------------------------------------------------------------- +; PROCESS INPUT NAMES (CREATE STRING ARRAY) +; +; Process scalar name +; +s=size(name) & ndim=s[0] +if ndim eq 0 then begin +; +; process name='' +; + if strtrim(name) EQ '' then begin + names = list_with_path('*.dbh', 'ZDBASE', Count = N) + if n EQ 0 then message, $ + 'No database (.dbh) files found in ZDBASE or current directory' + fdecomp,names,disk,dir,fnames,qual + db_titles, fnames, titles + select_w,fnames,isel,titles, $ + 'Select data base file to open',1 + fnames=fnames[intarr(1)+isel] + end else $ +; +; separate names into string array +; + fnames = strlowcase( strsplit(name,',',/extract)) + end else begin +; +; name is already a string vector +; + fnames=name +end +; +; if update, only one data base can be opened +; +if update then if N_elements(fnames) gt 1 then $ + message,'Only one file can be specified if mode is update' +; +;--------------------------------------------------------------- +; +; LOOP AND OPEN EACH DATA BASE +; +; close any data bases already open +; +dbclose +; +; +offset=0 ;byte offset in dbrd record for data base +tot_items=0 ;total number of items all opened data bases +get_lun,unit ;get unit number to use for .dbh files +dbno=0 ;present data base number +while dbno lt n_elements(fnames) do begin + dbname=strtrim(fnames[dbno]) +; +; process * if second in list ----------------------- +; + if dbname eq '*' then begin ;get data base names from pointers + if dbno ne 1 then begin ;* must be second data base + message,'Invalid use of * specification',/continue + goto,ABORT + endif + pointers=qitems[100,*] ;find pointer items + good=where(pointers,n) + if n eq 0 then goto,done ;no pointers + pnames=string(qitems[101:119,*]);file names for pointers + fnames=[fnames[0],pnames[good]] ;new file list + dbname=strtrim(fnames[1]) ;new second name + end +; +; open .dbh file and read contents ------------------------ +; + dbhname = find_with_def(dbname+'.dbh', 'ZDBASE') + + openr,unit,dbhname,ERROR=err + + if err NE 0 then begin + if unav_flg EQ 0 then begin + message,'Error opening .dbh file '+ dbname,/CONTINUE + print,!SYSERR_STRING + endif else totret = 0 + unavail = 1 + goto, ABORT + end + db=bytarr(120) + readu,unit,db + + external = db[119] eq 1 ;Is external data rep. being used? + newdb = db[118] eq 1 ; New db format allowing longwords + totbytes = newdb ? long(db,105,1) : fix(db,82,1) + totbytes = totbytes[0] ;Make sure is scalar + nitems=fix(db,80,1) & nitems=nitems[0] ;number of items or fields in file + + if external then begin + if newdb then begin + byteorder, totbytes, /NTOHL & db[105] = byte(totbytes,0,4) + endif else begin + byteorder, totbytes, /NTOHS & db[82] = byte(totbytes,0,2) + endelse + byteorder, nitems,/NTOHS & db[80] = byte(nitems,0,2) + endif + items=bytarr(200,nitems) + readu,unit,items + close,unit + if external then begin + tmp = fix(items[20:27,*],0,4,nitems) + byteorder,tmp, /ntohs + items[20,0] = byte(tmp,0,8,nitems) +; + tmp = fix(items[98:99,*],0,1,nitems) + byteorder,tmp,/NTOHS + items[98,0] = byte(tmp,0,2,nitems) +; + tmp = fix(items[171:178,*],0,4,nitems) + byteorder,tmp,/NTOHS + items[171,0] = byte(tmp,0,8,nitems) + + if newdb then begin + tmp = long(items[179:186,*],0,2,nitems) + byteorder,tmp,/NTOHL + + items[179,0] = byte(tmp,0,8,nitems) + endif + endif + +; +; add computed information to items --------------------------- +; + sbyte = newdb ? long(items[183:186,*],0,nitems)+offset : $ + fix(items[24:25,*],0,nitems)+offset + + for i=0,nitems-1 do begin + if newdb then items[187,i]= byte(sbyte[i],0,4) else $ + items[171,i] = byte(sbyte[i],0,2) + ;starting byte in DBRD record + items[173,i]=byte(dbno,0,2) ;data base number + items[177,i]=byte(i,0,2) ;item number + end + offset=offset+totbytes +; +; open .dbf file --------------------------------- +; + get_lun,unitdbf + dbf_file = find_with_def(dbname+'.dbf', 'ZDBASE') + + if update eq 1 then $ + openu,unitdbf,dbf_file else $ + openr,unitdbf,dbf_file,error=err + if err ne 0 then begin + message,'Error opening '+dbname+'.dbf',/continue + free_lun,unitdbf + goto,abort + end + + p=assoc(unitdbf,lonarr(2)) + head = p[0] + if external then byteorder, head, /NTOHL + db[96]=unitdbf ;unit number of .dbf file + db[84]=byte(head[0],0,4) ;number of entries + db[92]=byte(head[1],0,4) ;last seqnum used + db[88]=byte(tot_items,0,2) ;starting item number for this db + tot_items=tot_items+nitems ;new total number of items + db[90]=byte(tot_items-1,0,2) ;last item number for this db + db[104]=update ;opened for update +; +; open index file if necessary ----------------------------- +; + + index=where(items[28,*] gt 0,nindex) ;indexed items + + if nindex gt 0 then begin ;need to open index file. + get_lun,unitind + dbx_file = find_with_def(dbname+'.dbx', 'ZDBASE') + if update gt 0 then $ + openu,unitind,dbx_file,error=err $ + else openr,unitind,dbx_file,error=err + if err ne 0 then begin + message,'Error opening index file for '+dbname,/continue + free_lun,unitdbf + free_lun,unitind + goto,abort + endif + db[97]=unitind ;unit number for index file + end +; +; add to common block --------------------- +; + + if dbno eq 0 then begin + qdb=db + qitems=items + end else begin + old=qdb + qdb=bytarr(120,dbno+1) + qdb[0,0] = old + qdb[0,dbno] = db + old=qitems + qitems=bytarr(200,tot_items) + qitems[0,0] = old + qitems[0,tot_items-nitems] = items + end +; + dbno=dbno+1 +end; loop on data bases +done: free_lun,unit + + +;-------------------------------------------------------------------- +; LINK PROCESSING +; +; determine linkages between data bases +; +numdb = N_elements(fnames) +if numdb gt 1 then begin + pnames=strupcase(qitems[101:119,*]) + for i=1,numdb-1 do begin + dbname=strupcase(qdb[0:18,i]) ;name of the data base + for j=0,tot_items-1 do if pnames[j] eq dbname then goto,found +; +; if we made it here we can not link the file ----------- +; + message,'Unable to link data base file '+dbname,/continue + goto,abort +; +; found linkage item ------------------------------------ +; + +found: + item_number=j ;number of item supplying link + item_db=fix(qitems[173:174,item_number],0,1) & item_db=item_db[0] + if item_db ge i then begin + message,'Unable to link data base '+dbname + $ + 'to previous data base.',/continue + print,' Possible incorrect ordering of input data bases' + goto,abort + endif + qitems[175,item_number]=byte(i,0,2) ;data base number pointed to + qdb[98,i]=byte(item_number,0,2) ;item number pointing to this db +nextdb: + endfor +endif + +; +; create an assoc variable for the first db +; + +unit=db_info('unit_dbf',0) +len=db_info('length',0) +qdbrec=assoc(unit,bytarr(len)) +;---------------------------------------------------------------------------- +; done +; + +return +; +; abort +; +abort: +dbclose ;close any open data bases +free_lun,unit +if (totret NE 0) then retall else return +end diff --git a/modules/idl_downloads/astro/pro/dbprint.pro b/modules/idl_downloads/astro/pro/dbprint.pro new file mode 100644 index 0000000..6229081 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbprint.pro @@ -0,0 +1,318 @@ +pro dbprint,list,items, FORMS=forms, TEXTOUT=textout, NoHeader = noheader, $ + Adjustformat = adjustformat +;+ +; NAME: +; DBPRINT +; PURPOSE: +; Procedure to print specified items from a list of database entries +; +; CALLING SEQUENCE: +; dbprint, list, [items, FORMS= , TEXTOUT= , /AdjustFormat, /NoHeader] +; +; INPUTS: +; list - list of entry numbers to be printed, vector or scalar +; if list = -1, then all entries will be printed. +; An error message is returned if any entry number is larger +; than the number of entries in the database +; +; OPTIONAL INPUT-OUTPUT: +; items - items to be printed, specified in any of the following ways: +; +; form 1 scalar string giving item(s) as list of names +; separated by commas +; form 2 string array giving list of item names +; form 3 string of form '$filename' giving name +; of text file containing items (one item per +; line) +; form 4 integer scalar giving single item number or +; integer vector list of item numbers +; form 5 Null string specifying interactive selection. This +; is the default if 'items' is not supplied +; form 6 '*' select all items, printout will be in +; table format. +; +; If items was undefined or a null string on input, then +; on output it will contain the items interactively selected. +; +; OPTIONAL INPUT KEYWORDS: +; /ADJUSTFORMAT - If set, then the format length for string items will +; be adjusted to the maximum length for the entries to be printed. +; This option will slow down DBPRINT because it requires the +; string items be extracted and their maximum length determined +; prior to any printing. However, it enables the display of +; string items without any truncation or wasted space. +; +; FORMS - The number of printed lines per page. If forms is not +; present, output assumed to be in PORTRAIT form, and +; a heading and 47 lines are printed on each page, with +; a page eject between each page. For LANDSCAPE form with +; headings on each page, and a page eject between pages, set +; forms = 34. For a heading only on the first page, and no +; page eject, set forms = 0. This is the default for output +; to the terminal. +; +; TEXTOUT - Integer (0-7) or string used to determine output device (see +; TEXTOPEN for more info). If not present, the !TEXTOUT system +; variable is used. +; textout=0 Nowhere +; textout=1 if a TTY then TERMINAL using /more option +; otherwise standard (Unit=-1) output +; textout=2 if a TTY then TERMINAL without /more option +; otherwise standard (Unit=-1) output +; textout=3 dbprint.prt (file) +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 same as 3 but text is appended to .prt +; textout = filename (default extension of .prt) +; +; /NOHEADER - If this keyword is set, then the column headers will not +; be printed +; +; EXAMPLE: +; The following example shows how a multiple valued item DATAMAX can be +; printed as separate columns. In the WFPC2 target database, DATAMAX +; is an item with 4 values, one for each of the 4 chips +; +; IDL> dbopen,'wflog' +; IDL> dbprint,list,'entry,datamax(0),datamax(1),datamax(2),datamax(3)' +; +; SYSTEM VARIABLES: +; Output device controlled by non-standard system varaible !TEXTOUT, if +; TEXTOUT keyword is not used. +; +; NOTES: +; Users may want to adjust the default lines_per_page value given at +; the beginning of the program for their own particular printer. +; PROCEDURE CALLS: +; db_info(), db_item_info(), dbtitle(), dbxval(), textopen, textclose +; zparcheck +; HISTORY: +; version 2 D. Lindler Nov. 1987 (new db format) +; Test if user pressed 'Q' in response to /MORE W. Landsman Sep 1991 +; Apply STRTRIM to free form (table) output W. Landsman Dec 1992 +; Test for string value of TEXTOUT W. Landsman Feb 1994 +; William Thompson, GSFC, 3 November 1994 +; Modified to allow ZDBASE to be a path string. +; W. Landsman, GSFC, July, 1997, Use CATCH to catch errors +; Removed STRTRIM in table format output to handle byte values April 1999 +; Fixed occasional problem when /NOHEADER is supplied Sep. 1999 +; Only byteswap when necessary for improved performance Feb. 2000 +; Change loop index for table listing to type LONG W. Landsman Aug 2000 +; Entry vector can be any integer type W. Landsman Aug. 2001 +; Replace DATATYPE() with size(/TNAME) W. Landsman Nov. 2001 +; No page eject for TEXTOUT =5 W. Landsman Nov. 2001 +; No initial page eject W. Landsman Jan. 2002 +; Added AdjustFormat keyword W. Landsman Sep. 2002 +; Assume since V5.3 (STRJOIN) W. Landsman Feb. 2004 +; Fix display on GUI terminals W. Landsman March 2006 +; Remove VMS statements W. Landsman Sep 2006 +; Remove EXECUTE statement W. Landsman Jan 2007 +; Fix display of multi element items W. Landsman Aug 2010 +; Fix problem with linked databases W. Landsman Dec 2011 +;- +; + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - DBPRINT, list, items, ' + print,' [ FORMS = , TEXTOUT =, /NoHeader, /AdjustFormat ]' + return + endif + + lines_per_page = 47 ;Default # of lines per page + zparcheck, 'DBPRINT', list, 1, [1,2,3,4,5,12,13,14,15], [0,1], $ + 'Entry List Vector' + + catch, error_status + if error_status NE 0 then begin + print,!ERR_STRING + return + endif + + +; Make list a vector + + nentry = db_info( 'ENTRIES', 0) + if nentry EQ 0 then message,'ERROR - Database contains no entries' + if list[0] EQ -1 then list = lindgen(nentry) + 1 + dbname = strlowcase( db_info( 'NAME', 0 )) + + if max(list) GT nentry then message, dbname + $ + ' entry numbers must be between 1 and ' + strtrim( nentry, 2 ) + nv = N_elements(list) ;number of entries requested + +; No need for byteswapping if data is not external or it is a big endian machine + + noconvert = ~db_info('EXTERNAL',0) || is_ieee_big() ;Updated Dec 11 + +; Determine items to print + + if N_params() EQ 1 then begin + + file = find_with_def(dbname +'.items', 'ZDBASE') + if file NE '' then items = '$' + file else items = '' + + endif + + db_item, items, it, ivalnum, dtype, sbyte, numvals, nbytes + numvals = numvals<1 ;can't print vectors + nvalues = db_item_info( 'NVALUES', it ) ;number of values in item + qnumit = db_info( 'ITEMS' ) ;number of items + nitems = N_elements( it ) ;number of items requested + qnames = db_item_info( 'NAME', it ) + qtitle = db_info( 'TITLE', 0 ) ;data base title + +; Open output text file + + if ~keyword_set(TEXTOUT) then textout = !textout ;use default output dev. +textopen, dbname, TEXTOUT = textout, more_set = more_set + if size(TEXTOUT,/TNAME) EQ 'STRING' then text_out = 5 else text_out = textout + if (nitems EQ qnumit) then begin + +; Create table listing of each item specified. ------------------------- + + for i = 0L, nv-1 do begin + dbrd, list[i], entry, noconvert = noconvert ; read an entry. + printf, !TEXTUNIT, ' ' ; print blank line. + +; display name and value for each entry + + for k = 0, qnumit-1 do begin + ;. + ; only print entries of reasonable size... < 5 values in item. + + if ( nvalues[k] LT 5 ) then begin + somvar = $ + dbxval(entry,dtype[k],nvalues[k],sbyte[k],nvalues[k]*nbytes[k]) + if dtype[k] EQ 1 then somvar=fix(somvar) + printf,!textunit,k,') ',qnames[k], strtrim(somvar,2) + ;display name,value + endif + endfor ; k + + endfor ; i + + printf,!textunit,' ' ;Added 11/90 + + end else begin + +; get info on items + + formats = db_item_info( 'FORMAT', it ) + flen = db_item_info( 'FLEN', it ) ;field lengths + nvals = db_item_info( 'NVALUES', it ) ;larger than one for vector items +; +; If /AdjustFormat set, then extract all string vectors and find their maximum +; length. Then update the formats and flen vectors accordingly +; + if keyword_set(adjustFormat) then begin + stringvar = where(dtype EQ 7, Nstring) + if Nstring GT 0 then begin + alen = intarr(Nstring) + varnames = 'v' + strtrim(indgen(Nstring)+1,2) + stringitems = strjoin(varnames,',') + for i=0, Nstring-1 do begin + dbext,list,it[stringvar[i]], vv + alen[i] = max(strlen(strtrim(temporary(vv),2))) + endfor + flen[stringvar] = alen + formats[stringvar] = 'A' + strtrim(alen,2) + endif + endif + +; Set up format array + + form = '(' + strtrim(formats,2) + ')' ;remove blanks, and add paren + + linelength = total(flen) + nitems ;length of output lines + dash = byte('-') & dash = dash[0] + dashes = ' '+string( replicate( dash, linelength ) ) +; + if ~keyword_set( NoHeader) then begin + + title = string( replicate(byte(32), linelength>42) ) + strput, title, qtitle, (linelength-40)/2>1 ;center title + +; Extract headers + + headers = db_item_info( 'HEADERS', it ) + c1 = strmid( headers,0,15 ) + c2 = strmid( headers,15,15 ) + c3 = strmid( headers,30,15 ) + +; Place value numbers for multiple valued items in h3 + for i = 0,nitems-1 do begin + if nvals[i] GT 1 then $ ;multiple values? + c3[i] = '[' + strtrim(string(ivalnum[i]),2) + ']' + endfor ;i + + h1 = dbtitle( c1,flen ) + h2 = dbtitle( c2,flen ) + h3 = dbtitle( c3,flen ) + + endif + +; Loop on entries + + hardcopy = (text_out GE 2) and (text_out NE 5) ;Keep track of page eject? + if ( N_elements(forms) GT 0 ) then begin + if ( forms GT 0 ) then pcount = forms $ ;lines per page + else pcount = N_elements(list) ;no page breaks + endif else if not hardcopy then pcount = N_elements(list) $ + else pcount = lines_per_page ;Portrait form default + limit = pcount - 1 + + for j = 0L, N_elements(list)-1 do begin + + if not keyword_set( NoHeader) then begin + + if pcount GT limit then begin ;new page? + pcount = 0 + if (j GT 0) and hardcopy then $ + printf,!textunit,string(byte(12)) $;eject + else printf,!textunit,' ' + printf,!textunit,title ;print title + printf,!textunit,dashes ;print headings + printf,!textunit,h1 + printf,!textunit,h2 + printf,!textunit,h3 + printf,!textunit,dashes + endif + + endif + dbrd, list[j], entry, noconvert = noconvert ;read entry + ; + ; loop on items + ; + st = '' ;output string + for i = 0,nitems-1 do begin + + val = dbxval(entry,dtype[i],numvals[i],sbyte[i],nbytes[i]) + if dtype[i] EQ 1 then val = fix(val) + if dtype[i] EQ 7 then begin + b = byte(val) + bad = where(b EQ 0, nbad) + if nbad GT 0 then begin + b[bad] = 32b + val = string(b) + endif + endif + st = st+' ' + string(val,form[i]) + + endfor + + printf, !TEXTUNIT, st ;print line + if more_set then $ ;Did user press 'Q' in /MORE ? + if ( !ERR EQ 1 ) then return + pcount = pcount+1 ;increment line counter + end ; loop on entries + + endelse ; N_params > 1 + +; Clean up + + textclose, TEXTOUT = textout ;close text file + + return + end diff --git a/modules/idl_downloads/astro/pro/dbput.pro b/modules/idl_downloads/astro/pro/dbput.pro new file mode 100644 index 0000000..9dfe5d2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbput.pro @@ -0,0 +1,78 @@ +pro dbput,item,val,entry +;+ +; NAME: +; DBPUT +; PURPOSE: +; Procedure to place a new value for a specified item into +; a data base file entry. +; +; CALLING SEQUENCE: +; dbput, item, val, entry +; +; INPUTS: +; item - item name or number +; val - item value(s) +; +; INPUT/OUTPUT: +; entry - entry (byte array) or scalar entry number. +; if entry is a scalar entry number then the data +; base file will be updated. Otherwise the change +; will be only made to the entry array which must +; be written latter using DBWRT. +; +; OPERATIONAL NOTES: +; If entry is a scalar entry number or the input file name +; is supplied, the entry in the data base will be updated +; instead of a supplied entry variable. In this case, !priv +; must be greater than 1. +; EXAMPLE: +; IDL> dbput,'WAVELEN',1215.6,entry +; PROCEDURES USED: +; DB_ITEM, DBRD, DBXPUT, DBWRT +; HISTORY: +; version 2 D. Lindler Feb 1988 (new db formats) +; modified to convert blanks into zeros correctly D. Neill Jan 1991 +; Converted to IDL V5.0 W. Landsman September 1997 +; V5.2 version support unsigned, 64bit integers W. Landsman Sep. 2001 +;- +;----------------------------------------------------------------------- +; +; get item number +; + db_item, item, inum, ivalnum, dtype, sbyte, numvals, nbytes +; +; convert val to correct type and check size +; + if (dtype[0] NE 7) and ( size(val,/type) EQ 7) then val = strtrim(val) + case dtype[0] of + 1: v = byte(fix(val)) + 2: v = fix(val) + 3: v = long(val) + 4: v = float(val) + 5: v = double(val) + 7: v = string(val) + 12: v = uint(val) + 13: v = ulong(val) + 14: v = long64(val) + 15: v = ulong64(val) + endcase +; + if N_elements(v) NE numvals[0] then begin + print,'DBPUT - Invalid number of data values' + print,'Item '+item+' requires ',strtrim(numvals[0],2),' values' + print,'DBPUT aborting' + retall + endif +; +; determine if entry number supplied +; + if size(entry,/n_dimen) EQ 0 then begin ;scalar entry number supplied + dbrd,entry,e + dbxput,v,e,dtype[0],sbyte[0],nbytes[0]*numvals[0] ;update entry + dbwrt,e ;update file + end else begin ;array supplied, just update it + dbxput,v,entry,dtype[0],sbyte[0],nbytes[0]*numvals[0] + end + + return + end diff --git a/modules/idl_downloads/astro/pro/dbrd.pro b/modules/idl_downloads/astro/pro/dbrd.pro new file mode 100644 index 0000000..0697ddd --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbrd.pro @@ -0,0 +1,115 @@ +pro dbrd,enum,entry,available,dbno, noconvert=noconvert +;+ +; NAME: +; DBRD +; PURPOSE: +; procedure to read an entry from a data base file or from +; linked multiple databases. +; +; CALLING SEQUENCE: +; dbrd, enum, entry, [available, dbno, /NoConvert] +; +; INPUTS: +; enum - entry number to read, integer scalar +; +; OUTPUT: +; entry - byte array containing the entry +; +; OPTIONAL OUTPUT: +; available - byte array with length equal to number of data +; bases opened. available(i) eq 1 if an entry (pointed +; to) is available. It always equals 1 for the first +; data base, otherwise it is an error condition. +; +; OPTIONAL INPUT: +; dbno - specification of the data base number to return. If +; supplied, only the record for the requested data base +; number is returned in entry. Normally this input should +; not be supplied. dbno is numbered for 0 to n-1 and gives +; the number of the data base opened. The data bases are +; numbered in the order supplied to dbopen. If dbno is supplied +; then the entry number refers to that data base and not the +; primary or first data base. If set to -1, then it means all +; data bases opened (same as not supplying it) +; OPTIONAL INPUT KEYWORD: +; noconvert - if set then don't convert external to host format. +; Assumes that calling program will take care of this +; requirement. +; OPERATIONAL NOTES: +; If multiple data base files are opened, the records are +; concatenated with each other +; HISTORY +; version 2 D. Lindler Nov. 1987 +; William Thompson, GSFC/CDS (ARC), 1 June 1994 +; Added support for external (IEEE) representation. +; Version 3, Richard Schwartz, GSFC/SDAC, 23-Aug-1996 +; Add noconvert keyword +; +; Converted to IDL V5.0 W. Landsman September 1997 +; Version 4, 2 May 2003, W. Thompson +; Use BSWAP keyword to DBXVAL instead of calling IEEE_TO_HOST. +;- +; +;----------------------------------------------------------------------- +On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - dbrd, enum, entry, [available, dbno, /NoConvert]' + return + endif + + COMMON db_com,qdb,qitems,qdbrec + +; Find out if databases are in external format. + externali= db_info('EXTERNAL') + external = externali * (1-keyword_set(noconvert)) + if N_params() LT 4 then dbno = -1 + + if dbno GE 0 then begin ;get only requeseted data base entry + available = bytarr(1)+1b + if dbno EQ 0 then begin + entry = qdbrec[enum] + if external[0] then db_ent2host, entry, 0 + end else begin + len = db_info( 'LENGTH', dbno) + unit = db_info( 'UNIT_DBF', dbno) + p = assoc(unit,bytarr(len, /NOZERO), enum) + entry = p[0] ;read entry + if external[dbno] then db_ent2host, entry, dbno + end + return + end + +; get info on open data bases + + len = db_info( 'LENGTH' ) ;record lengths + units = db_info( 'UNIT_DBF' ) ;unit numbers + n = N_elements(len) ;number of db's opened + entry = qdbrec[enum] ;read entry for first db + if external[0] then db_ent2host, entry, 0 + irec = enum ;record number + available = bytarr(n)+1B ;entry available + + if n GT 1 then begin + for i = 1,n-1 do begin ;loop on db's + pointer = db_info('pointer',i) ;what points to it + db_item, pointer,itnum,ival,dtype,sb,nv,nb + + ;Make sure irec is in internal format! + if externali[db_item_info('dbnumber',itnum[0])] and keyword_set(noconvert) $ + then bswap=1 else bswap=0 + irec = dbxval(entry,dtype[0],1,sb[0],nb[0],bswap=bswap) + if irec GT 0 then begin + p = assoc( units[i], bytarr( len[i],/NOZERO )) + tmp = p[irec] + if external[i] then db_ent2host, tmp, i + entry = [ entry, tmp ] ;add to end + end else begin + available[i] = 0B + entry = [ entry, bytarr(len[i])] + end + end + end + + return + end diff --git a/modules/idl_downloads/astro/pro/dbsearch.pro b/modules/idl_downloads/astro/pro/dbsearch.pro new file mode 100644 index 0000000..4c955e8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbsearch.pro @@ -0,0 +1,139 @@ +pro dbsearch,type,svals,values,good, FULLSTRING = fullstring, COUNT = count +;+ +; NAME: +; DBSEARCH +; PURPOSE: +; Subroutine of DBFIND() to search a vector for specified values +; +; CALLING SEQUENCE: +; dbsearch, type, svals, values, good, [ /FULLSTRING, COUNT = ] +; +; INPUT: +; type - type of search (output from dbfparse) +; svals - search values (output from dbfparse) +; values - array of values to search +; +; OUTPUT: +; good - indices of good values +; +; OPTIONAL INPUT KEYWORD: +; /FULLSTRING - By default, one has a match if a search string is +; included in any part of a database value (substring match). +; But if /FULLSTRING is set, then all characters in the database +; value must match the search string (excluding leading and +; trailing blanks). Both types of string searches are case +; insensitive. +; OPTIONAL OUTPUT KEYWORD: +; COUNT - Integer scalar giving the number of valid matches +; SIDE EFFECTS: +; The obsolete system variable !ERR is set to number of good values +; REVISION HISTORY: +; D. Lindler July,1987 +; Added COUNT keyword, deprecate !ERR W. Landsman March 2000 +; Some speed improvements W.L. August 2008 +; Add compound operators, slightly faster WL November 2009 +; D. Lindler Aug 2013, added strtrim on values for a string search +; Fix problem with "less than" string searches WL November 2014 +; November 2014 fix actually broke things, reverting WL January 2015 +;- +;----------------------------------------------------------- + On_error,2 + compile_opt idl2 + + svals = strupcase(svals) +; +; determine data type of values to be searched +; + datatype=size(values,/type) & nv = N_elements(values) + +; +; convert svals to correct data type +; + nvals = type>2 + if datatype NE 7 then sv = replicate(values[0],nvals) else $ + sv = replicate(' ',nvals) + On_ioerror, BADVAL ;Trap any type conversions + sv[0]= svals[0:nvals-1] + On_ioerror, NULL + sv0=sv[0] & sv1=sv[1] +; +; ----------------------------------------------------------- +; STRING SEARCHES (Must use STRPOS to search for substring match) +; +if datatype EQ 7 then begin + values = strupcase(strtrim(values)) + case type of + + 0: if keyword_set(FULLSTRING) then $ ;Exact string match? + valid = strtrim(values,2) EQ strtrim(sv0,2) else $ + valid = strpos(values,strtrim(sv0,2)) GE 0 ;substring search + -1: valid = values GE sv0 ;greater than + -2: valid = values LE sv1 ;less than + -3: valid = (values GE sv0) and (values LE sv1) ;in range + -4: valid = strtrim(values) NE '' ;non zero (i.e. not null) + -5: message, $ ;Tolerance value + ' Tolerance specification for strings is not valid' + else: begin + sv = strtrim(sv,2) + sv = sv[uniq(sv,sort(sv))] ;Remove duplicates + type = N_elements(sv) + valid = bytarr(nv) + + if keyword_set(FULLSTRING) then begin + values = strtrim(values,2) + for ii = 0l,type-1 do valid OR= (values EQ sv[ii]) + + endif else begin + + for ii=0L,type-1 do begin ;within set of substring + valid OR= (strpos(values,sv[ii]) GE 0) + endfor + + endelse + end + endcase + good = where(valid, count) + return +end +; +;--------------------------------------------------------------------- +; ALL OTHER DATA TYPES + +case type of + + 0: good = where( values EQ sv0, count ) ;value=sv0 + -1: good = where( values GE sv0, count ) ;value>sv0 + -2: good = where( values LE sv1, count ) ;value NEWLIST = DBSORT( -1, 'RA,DEC' ) +; +; If for some reason, one wanted the DEC sorted in descending order, but +; the RA in ascending order +; +; IDL> NEWLIST = DBSORT( -1, 'RA,DEC', REV = [ 0, 1 ] ) +; +; METHOD: +; The list is sorted such that each item is sorted into +; asscending order starting with the last item. +; COMMON BLOCKS: +; DBCOM +; PROCEDURES USED: +; ZPARCHECK, BSORT, DBEXT, DB_ITEM +; HISTORY +; VERSION 1 D. Lindler Oct. 86 +; Added REVERSE keyword W. Landsman August, 1991 +; Avoid use of EXECUTE() for V6.1 or later W. Landsman Dec 2006 +; Assume since V6.1 W. Landsman June 2009 +; Add TEMPORARY call W. Lnadsman July 2009 +;- + On_error,2 + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax: newlist = dbsort( list, items, [ REVERSE = ] )' + return, -1 + endif +;--------------------------------------------------------- +; data base common block, see DBOPEN for meanings + + common db_com,QDB,QITEMS,QLINK + +; check parameters + + zparcheck, 'DBSORT', list, 1, [1,2,3], [0,1], 'entry list' + zparcheck, 'DBSORT', items, 2, [1,2,3,7], [0,1], 'item list' + +; extract values of items + + db_item, items, it + nitems = N_elements(it) ;Number of items + if nitems GT 9 then message, $ + 'ERROR - Can only sort on nine items or less' + + ;Verify REVERSE vector + if not keyword_set(REV) then rev = bytarr(nitems) else $ + if N_elements(rev) NE nitems then $ + message,'ERROR - REVERSE vector must contain ' + $ + strtrim(nitems,2) + ' elements' + +; make list vector + + qnentry = long(qdb,84) + if list[0] EQ -1 then vlist = lindgen(qnentry)+1 else vlist = list + +; create line to execute in the form: +; dbext, vlist, it, v1,v2,...,v(nitems) + case nitems of + 1: dbext, vlist, it, v1 + 2: dbext, vlist, it, v1, v2 + 3: dbext, vlist, it, v1, v2, v3 + 4: dbext, vlist, it, v1, v2, v3, v4 + 5: dbext, vlist, it, v1, v2, v3, v4, v5 + 6: dbext, vlist, it, v1, v2, v3, v4, v5, v6 + 7: dbext, vlist, it, v1, v2, v3, v4, v5, v6, v7 + 8: dbext, vlist, it, v1, v2, v3, v4, v5, v6, v7, v8 + 9: dbext, vlist, it, v1, v2, v3, v4, v5, v6, v7, v8, v9 + endcase + +; sort on each item + + sub = lindgen(N_elements(vlist)) ;list of subscripts + for i = 0,nitems-1 do begin + +; get item + + j = nitems-i + vv = 'v' + strtrim(j,2) + v = temporary(scope_varfetch(vv, level=0)) + +; perform previous sorts on item + + if i GT 0 then v = v[sub] + +; sort item + + sub = sub[ bsort( v, REVERSE = rev[j-1] ) ] + + end + +; return sorted list + + return, vlist[sub] + end diff --git a/modules/idl_downloads/astro/pro/dbtarget.pro b/modules/idl_downloads/astro/pro/dbtarget.pro new file mode 100644 index 0000000..8c7f8f8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbtarget.pro @@ -0,0 +1,93 @@ +function dbtarget, target, radius, sublist,SILENT=silent, $ + TO_B1950 = to_B1950, DIS = dis +;+ +; NAME: +; DBTARGET +; PURPOSE: +; Find sources in a database within specified radius of specified target +; EXPLANATION: +; Uses QuerySimbad to translate target name to RA and Dec, and then uses +; DBCIRCLE() to find any entries within specified radius. Database must +; include items named 'RA' (in hours) and 'DEC' (in degrees) and must +; have previously been opened with DBOPEN +; +; CALLING SEQUENCE: +; list = DBTARGET(target, [radius, sublist, /SILENT, DIS= ,/TO_B1950 ] ) +; +; INPUTS: +; TARGET - A scalar string giving an astronomical target name, which +; will be translated into J2000 celestial coordinates by QuerySimbad +; +; OPTIONAL INPUT: +; RADIUS - Radius of the search field in arc minutes, scalar. +; Default is 5 arc minutes +; SUBLIST - Vector giving entry numbers in currently opened database +; to be searched. Default is to search all entries +; +; OUTPUTS: +; LIST - Vector giving entry numbers in the currently opened catalog +; which have positions within the specified search circle +; LIST is set to -1 if no sources fall within the search circle +; !ERR is set to the number sources found. +; +; OPTIONAL OUTPUT +; DIS - The distance in arcminutes of each entry specified by LIST +; to the search center specified by the target. +; +; OPTIONAL KEYWORD INPUT: +; /SILENT - If this keyword is set, then DBTARGET will not print the +; number of entries found at the terminal +; /TO_B1950 - If this keyword is set, then the SIMBAD J2000 coordinates +; are converted to B1950 before searching the database +; NOTE: The user must determine on his own whether the database +; is in B1950 or J2000 coordinates. +; +; RESTRICTIONS; +; The database must have items 'RA' (in hours) and 'DEC' (in degrees). +; Alternatively, the database could have items RA_OBJ and DEC_OBJ +; (both in degrees) +; EXAMPLE: +; (1) Use the HST_CATALOG database to find all HST observations within +; 5' (the default) of M33 +; +; IDL> dbopen,'hst_catalog' +; IDL> list = dbtarget('M33') +; +; (2) As above but restrict targets within 2' of the nucleus using the +; WFPC2 camara +; +; IDL> dbopen,'hst_catalog' +; IDL> sublist = dbfind('config=WFPC2') +; IDL> list = dbtarget('M33',2,sublist) +; +; +; PROCEDURE CALLS: +; QuerySimbad, DBCIRCLE() +; REVISION HISTORY: +; Written W. Landsman SSAI September 2002 +; Propagate /SILENT keyword to QuerySimbad W. Landsman Oct 2009 +; Make sure a database is open W.L. Oct 2010 +;- + On_error,2 + + if N_params() LT 1 then begin + print,'Syntax - list = DBTARGET( targetname_or_coord, [radius, sublist ' + print,' DIS =, /SILENT, /TO_B1950 ] )' + if N_elements(sublist) GT 0 then return, sublist else return,lonarr(1)-1 + endif + + if ~db_info('open') then message,'ERROR - No database open' + + QuerySimbad, target, ra,dec, Found = Found,Silent=silent + if found EQ 0 then message,'Target name ' + target + $ + ' could not be translated by SIMBAD' + ra = ra/15. + + if N_elements(radius) EQ 0 then radius = 5 + if n_elements(sublist) EQ 0 then $ + return, dbcircle(ra, dec, radius, dis, SILENT=silent, $ + TO_B1950 = to_b1950 ) + return, dbcircle(ra, dec, radius, dis, sublist, SILENT=silent, $ + TO_B1950 = to_b1950 ) + + end diff --git a/modules/idl_downloads/astro/pro/dbtitle.pro b/modules/idl_downloads/astro/pro/dbtitle.pro new file mode 100644 index 0000000..18232b9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbtitle.pro @@ -0,0 +1,38 @@ +function dbtitle,c,f +;+ +; NAME: +; DBTITLE +; PURPOSE: +; function to create title line for routine dbprint +; +; CALLING SEQUENCE: +; result = dbtitle( c, f ) +; +; INPUTS: +; c = string array of titles for each item +; f = field length of each item +; +; OUTPUT: +; header string returned as function value +; +; OPERATIONAL NOTES: +; this is a subroutine of DBPRINT. +; +; HISTORY: +; version 1 D. Lindler Sept 86 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------------ +n=n_elements(c) +h=' ' +com = strtrim(c,0) ;header for item with trailing blanks removed +ncom = strlen(com) +for i=0,n-1 do begin ;loop on items + flen=f[i] ;field length + st=string(replicate(byte(32),flen+1));blank field + ipos=((flen-ncom[i]+1)/2)>1 ;starting position in field for comment + strput,st,com[i],ipos ;insert into field + h=h+st ;add to header +end; loop on items +return,h ;return header +end diff --git a/modules/idl_downloads/astro/pro/dbupdate.pro b/modules/idl_downloads/astro/pro/dbupdate.pro new file mode 100644 index 0000000..73d252e --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbupdate.pro @@ -0,0 +1,163 @@ +pro dbupdate,list,items,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14, $ + NOINDEX = noindex +;+ +; NAME: +; DBUPDATE +; PURPOSE: +; Update columns of data in a database -- inverse of DBEXT +; EXPLANATION: +; Database must be open for update before calling DBUPDATE +; +; CALLING SEQUENCE: +; dbupdate, list, items, v1, [ v2, v3, v4......v14 ] +; +; INPUTS: +; list - entries in database to be updated, scalar or vector +; If list=-1 then all entries will be updated +; items -standard list of items that will be updated. +; v1,v2....v14 - vectors containing values for specified items. The +; number of vectors supplied must equal the number of items +; specified. The number of elements in each vector should be +; the same. +; +; OPTIONAL KEYWORD INPUT: +; /NOINDEX - If set, then DBUPDATE will not update the index file. This +; keyword is useful to save if additional updates will occur, +; and the index file need only be updated on the last call. +; +; EXAMPLES: +; A database STAR contains RA and DEC in radians, convert to degrees +; +; IDL> !PRIV=2 & dbopen,'STAR',1 ;Open database for update +; IDL> dbext,-1,'RA,DEC',ra,dec ;Extract RA and DEC, all entries +; IDL> ra = ra*!RADEG & dec=dec*!RADEG ;Convert to degrees +; IDL> dbupdate,-1,'RA,DEC',ra,dec ;Update database with new values +; +; NOTES: +; It is quicker to update several items simultaneously rather than use +; repeated calls to DBUPDATE. +; +; It is possible to update multiple valued items. In this case, the +; input vector should be of dimension (NVAL,NLIST) where NVAL is the +; number of values per item, and NLIST is the number of entries to be +; updated. This vector will be temporarily transposed by DBUPDATE but +; will be restored before DBUPDATE exits. +; +; REVISION HISTORY +; Written W. Landsman STX March, 1989 +; Work for multiple valued items May, 1991 +; String arrays no longer need to be fixed length December 1992 +; Transpose multiple array items back on output December 1993 +; Faster update of external databases on big endian machines November 1997 +; Converted to IDL V5.0 W. Landsman 24-Nov-1997 +; Added /NOINDEX keyword W. Landsman July 2001 +;- + On_error,2 ;Return to caller + + if N_params() LT 3 then begin + print,'Syntax - dbupdate, list, items, v1, [ v2, v3, v4, v5,...v14 ]' + return + endif + ;Get number of entries to update + nlist = N_elements(list) + if nlist EQ 0 then message, $ + 'ERROR - no entry values supplied' + + nentries = db_info( 'ENTRIES' ) ;Number of entries in database + external = db_info( 'EXTERNAL', 0 ) + if external then noconvert = is_ieee_big() else noconvert = 1b + + if list[0] LT 0 then begin ;If LIST = -1, then update all entries + nlist = nentries[0] + list = lindgen(nlist) + 1 + endif + + db_item, items, itnum, ivalnum, idltype, sbyte, numvals, nbyte + nitem = N_elements(itnum) ;Number of items in database + if N_params() LT nitem+2 then $ + message,'ERROR - ' + strtrim(nitem,2) + ' items specified, but only ' + $ + strtrim(N_params()-2,2) + ' input variables supplied' + +; Make sure user supplied enough values for all desired entries + + for i = 0,nitem-1 do begin + + ii = strtrim(i+1,2) + test = execute('good = N_elements(v' + ii +') EQ nlist*numvals[i]') + if good NE 1 then $ + message,'Supplied values for item ' + $ + strtrim(db_item_info('name',itnum[i]),2) + ' must contain '+ $ + strtrim(nlist*numvals[i],2)+' elements' + + test = execute('s=size(v' + ii +')' ) + if s[s[0] + 1] NE idltype[i] then $ + message,'Item ' + strtrim(db_item_info('name',itnum[i]),2)+ $ + ' has an incorrect data type' + + if numvals[i] GT 1 then begin + test = execute('v'+ ii + '= transpose(v'+ ii + ')' ) + endif + + endfor + + nitems = (nitem GT indgen(14) ) + nbyte = nbyte*numvals + + for i = 0l,nlist-1 do begin + + dbrd,list[i],entry,noconvert=noconvert + dbxput,v1[i,*],entry,idltype[0],sbyte[0],nbyte[0] + if nitems[1] then begin + dbxput,v2[i,*],entry,idltype[1],sbyte[1],nbyte[1] + if nitems[2] then begin + dbxput,v3[i,*],entry,idltype[2],sbyte[2],nbyte[2] + if nitems[3] then begin + dbxput,v4[i,*],entry,idltype[3],sbyte[3],nbyte[3] + if nitems[4] then begin + dbxput,v5[i,*],entry,idltype[4],sbyte[4],nbyte[4] + if nitems[5] then begin + dbxput,v6[i,*],entry,idltype[5],sbyte[5],nbyte[5] + if nitems[6] then begin + dbxput,v7[i,*],entry,idltype[6],sbyte[6],nbyte[6] + if nitems[7] then begin + dbxput,v8[i,*],entry,idltype[7],sbyte[7],nbyte[7] + if nitems[8] then begin + dbxput,v9[i,*],entry,idltype[8],sbyte[8],nbyte[8] + if nitems[9] then begin + dbxput,v10[i,*],entry,idltype[9],sbyte[9],nbyte[9] + if nitems[10] then begin + dbxput,v11[i,*],entry,idltype[10],sbyte[10],nbyte[10] + if nitems[11] then begin + dbxput,v12[i,*],entry,idltype[11],sbyte[11],nbyte[11] + if nitems[12] then begin + dbxput,v13[i,*],entry,idltype[12],sbyte[12],nbyte[12] + if nitems[13] then $ + dbxput,v14[i,*],entry,idltype[13],sbyte[13],nbyte[13] + endif & endif & endif & endif & endif & endif & endif & endif & endif + endif & endif & endif + dbwrt,entry, noconvert = noconvert + + endfor + +; Transpose back any multiple value items + + for i = 0,nitem-1 do begin + if numvals[i] GT 1 then begin + ii = strtrim(i+1,2) + test = execute('v'+ ii + '= transpose(v'+ ii + ')' ) + endif + endfor + +; Check if the indexed file needs to be updated + + if keyword_set(NOINDEX) then return + + indextype = db_item_info( 'INDEX', itnum) + index = where( indextype, nindex) ;Indexed items + if nindex GT 0 then begin + message, 'Now updating indexed file', /INFORM + dbindex, itnum[index] + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/dbval.pro b/modules/idl_downloads/astro/pro/dbval.pro new file mode 100644 index 0000000..747f214 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbval.pro @@ -0,0 +1,50 @@ +function dbval,entry,item +;+ +; NAME: +; DBVAL +; PURPOSE: +; procedure to extract value(s) of the specified item from +; a data base file entry. +; +; CALLING SEQUENCE: +; result = dbval( entry, item ) +; +; INPUTS: +; entry - byte array containing the entry, or a scalar entry number +; item - name (string) or number (integer) of the item +; +; OUTPUT: +; the value(s) will be returned as the function value +; +; EXAMPLE: +; Extract a flux vector from entry 28 of the database FARUV +; ==> flux = dbval(28,'FLUX') +; +; HISTORY: +; version 2 D. Lindler Nov, 1987 (new db format) +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------------------- +; +; get item info +; +db_item,item,itnum,ival,idltype,sbyte,numvals,nbytes +; +; check to see if entry is a valid array +; +s=size(entry) +if s[0] gt 0 then begin ;array supplied + if(s[0] ne 1) then begin ;is entry a 1-d array + print,'entry must be a 1-d byte array, dbval aborting' + retall + endif + if(s[2] ne 1) then begin ;check if byte array + print,'entry must be a byte array, dbval aborting' + retall + endif + return,dbxval(entry,idltype[0],numvals[0],sbyte[0],nbytes[0]) +end else begin ;scalar supplied (assume entry number) + dbrd,entry,e ;read entry + return,dbxval(e,idltype[0],numvals[0],sbyte[0],nbytes[0]);return value(s) +end +end diff --git a/modules/idl_downloads/astro/pro/dbwrt.pro b/modules/idl_downloads/astro/pro/dbwrt.pro new file mode 100644 index 0000000..34f39f4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbwrt.pro @@ -0,0 +1,195 @@ +pro dbwrt,entry,index,append,noconvert=noconvert +;+ +; NAME: +; DBWRT +; PURPOSE: +; procedure to update or add a new entry to a data base +; +; CALLING SEQUENCE: +; dbwrt, entry, [ index, append, /NoConvert ] +; +; INPUTS: +; entry - entry record to be updated or added if first +; item (entry number=0) +; +; OPTIONAL INPUTS: +; index - optional integer flag, if set to non zero then index +; file is updated. (default=0, do not update index file) +; (Updating the index file is time-consuming, and should +; normally be done after all changes have been made. +; append - optional integer flag, if set to non-zero the record +; is appended as a new entry, regardless of what the +; entry number in the record is. The entry number will +; be reset to the next entry number in the file. +; OUTPUTS: +; data base file is updated. +; If index is non-zero then the index file is updated. +; OPTIONAL INPUT KEYWORD: +; NoConvert - If set then don't convert to host format with an external +; database. Useful when the calling program decides that +; conversion isn't needed (i.e. on a big-endian machine), or +; takes care of the conversion itself. +; OPERATIONAL NOTES: +; !PRIV must be greater than 1 to execute +; HISTORY: +; version 2 D. Lindler Feb. 1988 (new db format) +; converted to IDL Version 2. M. Greason, STX, June 1990. +; William Thompson, GSFC/CDS (ARC), 28 May 1994 +; Added support for external (IEEE) representation. +; Faster handling of byte swapping W. L. August 2010 +;- +;------------------------------------------------------------------- + COMMON db_com,qdb,qitems,qdbrec + + if N_params() LT 2 then index=0 + if N_params() LT 3 then append=0 + +; Byte swapping is needed if database is in external format, and user is on +; a little endian machine, and /noconvert is not st + + bswap = (qdb[119] eq 1) && ~keyword_set(noconvert) && ~is_ieee_big() + + +; get some info on the data base + + update = db_info( 'UPDATE' ) + if update EQ 0 then message,'Database opened for read only' + + len = db_info( 'LENGTH', 0 ) ;record length + qnentry = db_info( 'ENTRIES', 0 ) + +; determine if entry is correct size + + s = size(entry) + if s[0] NE 1 then message,'Entry must be a 1-dimensional array' + + if s[1] NE len then $ + message,'Entry not the proper length of '+strtrim(len,2)+' bytes' + + if s[2] NE 1 then $ + message,'Entry vector (first parameter) must be a byte array' + +; get entry number + + enum = append ? 0 : dbxval(entry,3,1,0,4) + if ( enum GT qnentry ) || ( enum LT 0 ) then $ + message,'Invalid entry number of '+strtrim(enum,2)+' (first value in entry)' + + if enum EQ 0 then begin ;add new entry + qnentry = qnentry+1 + qdb[84] = byte(qnentry,0,4) + enum = qnentry + dbxput,long(enum),entry,3,0,4 + newentry = 1b + endif else newentry =0b + if bswap then begin + tmp = entry + db_ent2ext, tmp + qdbrec[enum]=tmp + endif else qdbrec[enum] = entry + +; update index file if necessary + + if index EQ 0 then return + nitems = db_info( 'ITEMS', 0 ) ;Total number of items + indextype = db_item_info( 'INDEX', indgen(nitems)) ;Which ones are indexed? + indexed = where(indextype,nindex) + if nindex LE 0 then return ;If no indexed items, then we are done + indextype = indextype[indexed] ;Now contains only indexed items + unit = db_info( 'UNIT_DBX', 0 ) + reclong = assoc(unit,lonarr(2),0) + h = reclong[0] + maxentries = h[1] + if bswap then swap_endian_inplace, maxentries + if newentry then $ + if (maxentries LT qnentry) then begin ;Enough room for new indexed items? + print,'DBWRT -- maxentries too small' + print,'Rerun DBCREATE with maxentries in .dbd file at least ',qnentry + return + endif + + reclong = assoc(unit,lonarr(7,nindex),8) + header = reclong[0] + if bswap then swap_endian_inplace,header + hitem = header[0,*] ;indexed item number + hblock = header[3,*] + sblock = header[4,*] & sblock = sblock[*] + iblock = header[5,*] & iblock = iblock[*] + ublock = header[6,*] & ublock = ublock[*] + db_item, indexed, itnum, ivalnum, idltype, startbyte, numvals, nbytes + pos = where(hitem EQ itnum ) + for i = 0, nindex-1 do begin + v = dbxval( entry, idltype[i], numvals[i], startbyte[i], nbytes[i] ) + sbyte = nbytes[i] * (enum-1) + isort = (indextype[i] EQ 3) || (indextype[i] EQ 4) + + datarec = dbindex_blk(unit, sblock[pos[i]], 512, sbyte, idltype[i]) + reclong = assoc(unit,lonarr(1),(iblock[pos]*512L)) + + case indextype[i] of + + 1: datarec[0] = bswap ? swap_endian(v) : v + + + 2: begin + datarec[0] = bswap ? swap_endian(v) : v + if (qnentry mod 512) EQ 0 then begin ;Update + nb = qnentry/512 + hbyte = nbytes[i] * nb + datarec = dbindex_blk(unit,hblock[pos[i]],512,hbyte,idltype[i]) + datarec[0] = bswap ? swap_endian(v) : v + endif + end + 3: begin ;SORT + + datarec = dbindex_blk(unit,sblock[pos[i]],512,0,idltype[i]) + values = datarec[0:(qnentry-1)] ;Read in old values + if bswap then swap_endian_inplace, values + reclong = dbindex_blk(unit,iblock[pos[i]],512,0,3) + sub = reclong[0:(qnentry-1)] ;Read in old indices + if bswap then swap_endian_inplace, sub + if enum lt qnentry then begin ;Change an old value? + sort_index = where(sub EQ enum) ;Which value to change + sort_index = sort_index[0] + if values[sort_index] EQ v $ ;Value remains the same so + then isort =0 $ ;don't bother sorting again + else values[sort_index] = v ;Update with new value + endif else values = [values,v] ;Append a new value + end + + 4: begin ;SORT/INDEX + + values = datarec[qnentry-1,ublock*512] ;Update index record + if bswap then swap_endian_inplace, values + if enum lt qnentry then begin + if values[enum-1] EQ v then isort = 0 else values[enum-1] = v + endif else values = [values,v] + datarec = dbindex_blk(unit,ublock[pos[i]],512,sbyte,idltype[i]) + datarec[0] = bswap ? swap_endian(v) : v + end + + else: + + endcase + + if isort then begin ;resort values? + sub = bsort(values) + values = values[sub] + nb = (qnentry + 511)/512 + ind = indgen(nb)*512L + sval = values[ind] +; + datarec = dbindex_blk(unit, hblock[pos[i]], 512, 0, idltype[i]) + datarec[0] = bswap ? swap_endian(sval) : sval +; + datarec = dbindex_blk(unit, sblock[pos[i]], 512, 0, idltype[i]) + datarec[0] = bswap ?swap_endian(values) : values +; + reclong = dbindex_blk(unit, iblock[pos[i]], 512, 0, 3) + reclong[0] = bswap ?swap_endian(sub+1) : sub+1 + endif + + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/dbxput.pro b/modules/idl_downloads/astro/pro/dbxput.pro new file mode 100644 index 0000000..5de3f6c --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbxput.pro @@ -0,0 +1,56 @@ +pro dbxput,val,entry,idltype,sbyte,nbytes +;+ +; NAME: +; DBXPUT +; PURPOSE: +; routine to replace value of an item in a data base entry +; +; CALLING SEQUENCE: +; dbxput, val, entry, idltype, sbyte, nbytes +; +; INPUT: +; val - value(s) to be placed into entry, string values might be +; truncated to fit number of allowed bytes in item +; entry - entry or entries to be updated +; idltype - idl data type for item (1-7) +; sbyte - starting byte in record +; nbytes - total number of bytes in value added +; +; OUTPUT: +; entry - (updated) +; +; OPERATIONAL NOTES: +; This routine assumes that the calling procedure or user knows what he +; or she is doing. String items are truncated or padded to the fixed +; size specified by the database but otherwise no validity checks are +; made. +; +; HISTORY: +; version 1, D. Lindler Aug, 1986 +; converted to IDL Version 2. M. Greason, STX, June 1990. +; Work with multiple element string items W. Landsman August 1995 +; Really work with multiple element string items +; R. Bergman/W. Landsman July 1996 +; Work with multiple entries, R. Schwartz, GSFC/SDAC August 1996 +; Use /overwrite with REFORM() W. Landsman May 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------- +; +nentry = n_elements(entry[0,*]) +case idltype of ;case of data type + + 7: begin ;string + numvals = N_elements(val) ;Number of input values + nbyte = nbytes/numvals ;Number of bytes/value + val = strmid(val,0,nbyte) ;Truncate string + temp = replicate( 32b, nbyte, numvals, nentry) ;Array of blanks + for i = 0, numvals-1 do temp[0,i,0] = byte(val[i,*]) ;Fill with values + entry[sbyte:sbyte+nbytes-1,*] = reform(temp,nbytes,nentry, /over) + end + 1: entry[sbyte:sbyte+nbytes-1,*]=val + else: entry[sbyte:sbyte+nbytes-1,*] = byte(val,0,nbytes,nentry) + +endcase +return +end diff --git a/modules/idl_downloads/astro/pro/dbxval.pro b/modules/idl_downloads/astro/pro/dbxval.pro new file mode 100644 index 0000000..4b0693d --- /dev/null +++ b/modules/idl_downloads/astro/pro/dbxval.pro @@ -0,0 +1,71 @@ +function dbxval,entry,idltype,nvalues,sbyte,nbytes,bswap=bswap +;+ +; NAME: +; DBXVAL +; +; PURPOSE: +; Quickly return a value of the specified item number +; EXPLANATION: +; Procedure to quickly return a value of the specified item number +; from the entry. +; +; CALLING SEQUENCE: +; result = dbxval( entry, idltype, nvalues, sbyte, nbytes ) +; +; INPUTS +; entry - entry or entries from data base (bytarr) +; idltype - idl data type (obtained with db_item_info) +; nvalues - number of values to return (obtained with db_item) +; sbyte - starting byte in the entry (obtained with db_item) +; nbytes - number of bytes (needed only for string type) +; (obtained with db_item) +; +; OUTPUTS: +; function value is value of the specified item in entry +; +; KEYWORDS: +; bswap - If set, then IEEE_TO_HOST is called. +; +; RESTRICTIONS: +; To increase speed the routine assumes that entry and item are +; valid and that the data base is already opened using dbopen. +; +; REVISION HISTORY: +; version 0 D. Lindler Nov. 1987 (for new db format) +; Version 1, William Thompson, GSFC, 28 March 1994. +; Incorporated into CDS library. +; Version 2, Richard Schwartz, GSFC/SDAC, 23 August 1996 +; Allowed Entry to have 2 dimensions +; Version 2.1, 22 Feb 1997, JK Feggans, +; avoid reform for strings arrays. +; Version 2.2 Use overwrite with REFORM(), W. Landsman, May 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Work for multiple-valued strings W. Landsman October 2000 +; Add new 64bit & unsigned integer datatypes W.Landsman July 2001 +; Version 3, 2-May-2003, JK Feggans/Sigma, W.T. Thompson +; Added BSWAP keyword to avoid floating errors on some platforms. +;- +;---------------------------------------------------------------- +; +; +nentry = n_elements(entry[0,*]) + +case idltype of ;case of data type + 1: val = byte(entry[sbyte:sbyte+nvalues-1,*],0,nvalues,nentry) + 2: val = fix(entry[sbyte:sbyte+nvalues*2-1,*],0,nvalues,nentry) + 3: val = long(entry[sbyte:sbyte+nvalues*4-1,*],0,nvalues,nentry) + 4: val = float(entry[sbyte:sbyte+nvalues*4-1,*],0,nvalues,nentry) + 5: val = double(entry[sbyte:sbyte+nvalues*8-1,*],0,nvalues,nentry) + 7: val = string( reform( entry[sbyte:sbyte+nbytes-1,*], nbytes/nvalues, $ + nvalues, nentry)) + 12: val = uint(entry[sbyte:sbyte+nvalues*2-1,*],0,nvalues,nentry) + 13: val = ulong(entry[sbyte:sbyte+nvalues*4-1,*],0,nvalues,nentry) + 14: val = long64(entry[sbyte:sbyte+nvalues*8-1,*],0,nvalues,nentry) + 15: val = ulong64(entry[sbyte:sbyte+nvalues*8-1,*],0,nvalues,nentry) +endcase +; +if keyword_set(bswap) then ieee_to_host,val,idltype=idltype + +if ( nvalues EQ 1 and nentry EQ 1) then return,val[0] else $ + if idltype eq 7 then return,val else return,reform(val,/overwrite) +end diff --git a/modules/idl_downloads/astro/pro/delvarx.pro b/modules/idl_downloads/astro/pro/delvarx.pro new file mode 100644 index 0000000..c756505 --- /dev/null +++ b/modules/idl_downloads/astro/pro/delvarx.pro @@ -0,0 +1,52 @@ +;+ +; NAME: +; DELVARX +; PURPOSE: +; Delete up to 10 variables for memory management (can call from routines) +; EXPLANATION: +; Like intrinsic DELVAR function, but can be used from any calling level +; +; Modified in January 2012 to always free memory associated with +; pointers/objects and remove the use of EXECUTE() +; Also look at the Coyote routine UNDEFINE +; http://www.idlcoyote.com/programs/undefine.pro +; +; CALLING SEQUENCE: +; DELVARX, p0, [p1, p2......p9] +; +; INPUTS: +; p0, p1...p9 - variables to delete +; +; OBSOLETE KEYWORD: +; /FREE_MEM - formerly freed memory associated with pointers +; and objects. Since this is now the DELVARX default this +; keyword does nothing. +; +; METHOD: +; Uses HEAP_FREE and PTR_NEW(/NO_COPY) to delete variables and free +; memory +; +; REVISION HISTORY: +; Copied from the Solar library, written by slf, 25-Feb-1993 +; Added to Astronomy Library, September 1995 +; Modified, 26-Mar-2003, Zarro (EER/GSFC) 26-Mar-2003 +; - added FREE_MEM to free pointer/objects +; Modified, 28-Jan-2012, E. Rykoff (SLAC), W. Landsman - +; replace EXECUTE calls with SCOPE_VARFETCH. +;- + +PRO delvarx, p0,p1,p2,p3,p4,p5,p6,p7,p8,p9,free_mem = free_mem + + npar = N_params() ; Number of parameters + pp = 'p'+strtrim(indgen(npar),1) + + for i=0,npar-1 do begin + defined = N_elements( SCOPE_VARFETCH(pp[i],LEVEL=0)) + if LOGICAL_TRUE(defined) then $ + heap_free, ptr_new( SCOPE_VARFETCH(pp[i],LEVEL=0),/no_copy) + + endfor + + return + end + diff --git a/modules/idl_downloads/astro/pro/deredd.pro b/modules/idl_downloads/astro/pro/deredd.pro new file mode 100644 index 0000000..880f0d4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/deredd.pro @@ -0,0 +1,55 @@ +pro deredd,Eby,by,m1,c1,ub,by0,m0,c0,ub0, update = update +;+ +; NAME: +; DEREDD +; +; PURPOSE: +; Deredden stellar Stromgren parameters given for a value of E(b-y) +; EXPLANATION: +; See the procedure UVBYBETA for more info. +; +; CALLING SEQUENCE: +; deredd, eby, by, m1, c1, ub, by0, m0, c0, ub0, /UPDATE +; +; INPUTS: +; Eby - color index E(b-y),scalar (E(b-y) = 0.73*E(B-V) ) +; by - b-y color (observed) +; m1 - Stromgren line blanketing parameter (observed) +; c1 - Stromgren Balmer discontinuity parameter (observed) +; ub - u-b color (observed) +; +; These input values are unaltered unless the /UPDATE keyword is set +; OUTPUTS: +; by0 - b-y color (dereddened) +; m0 - Line blanketing index (dereddened) +; c0 - Balmer discontinuity parameter (dereddened) +; ub0 - u-b color (dereddened) +; +; OPTIONAL INPUT KEYWORDS: +; /UPDATE - If set, then input parameters are updated with the dereddened +; values (and output parameters are not used). +; REVISION HISTORY: +; Adapted from FORTRAN routine DEREDD by T.T. Moon +; W. Landsman STX Co. April, 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + if N_Params() LT 2 then begin + print,'Syntax - DEREDD, eby, by, m1, c1, ub, by0, m0, c0, ub0' + return + endif + + Rm1 = -0.33 & Rc1 = 0.19 & Rub = 1.53 + Eby0 = Eby >0 + if keyword_set(update) then begin + by = by - eby0 + if N_elements(m1) GT 0 then m1 = m1 - Rm1*Eby0 + if N_elements(c1) GT 0 then c1 = c1 - Rc1*Eby0 + if N_elements(ub) GT 0 then ub = ub - Rub*Eby0 + endif else begin + by0 = by - Eby0 + m0 = m1 - Rm1*Eby0 + c0 = c1 - Rc1*Eby0 + ub0 = ub - Rub*Eby0 + endelse + return + end diff --git a/modules/idl_downloads/astro/pro/detabify.pro b/modules/idl_downloads/astro/pro/detabify.pro new file mode 100644 index 0000000..c57f7c6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/detabify.pro @@ -0,0 +1,62 @@ + FUNCTION DETABIFY, CHAR_STR +;+ +; NAME: +; DETABIFY +; PURPOSE: +; Replaces tabs in character strings with appropriate number of spaces +; EXPLANATION: +; The number of space characters inserted is calculated to space +; out to the next effective tab stop, each of which is eight characters +; apart. +; +; CALLING SEQUENCE: +; Result = DETABIFY( CHAR_STR ) +; +; INPUT PARAMETERS: +; CHAR_STR = Character string variable (or array) to remove tabs from. +; +; OUTPUT: +; Result of function is CHAR_STR with tabs replaced by spaces. +; +; RESTRICTIONS: +; CHAR_STR must be a character string variable. +; +; MODIFICATION HISTORY: +; William Thompson, Feb. 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax: Result = DETABIFY(CHAR_STR)' +; +; Make sure CHAR_STR is of type string. +; + SZ = SIZE(CHAR_STR) + IF SZ[SZ[0]+1] NE 7 THEN BEGIN + MESSAGE,/INFORMATIONAL,'CHAR_STR must be of type string' + RETURN, CHAR_STR + ENDIF +; +; Step through each element of CHAR_STR. +; + STR = CHAR_STR + FOR I = 0,N_ELEMENTS(STR)-1 DO BEGIN +; +; Keep looking for tabs until there aren't any more. +; + REPEAT BEGIN + TAB = STRPOS(STR[I],STRING(9B)) + IF TAB GE 0 THEN BEGIN + NBLANK = 8 - (TAB MOD 8) + STR[I] = STRMID(STR[I],0,TAB) + $ + STRING(REPLICATE(32B,NBLANK)) + $ + STRMID(STR[I],TAB+1,STRLEN(STR[I])-TAB-1) + ENDIF + ENDREP UNTIL TAB LT 0 + ENDFOR +; + RETURN, STR + END diff --git a/modules/idl_downloads/astro/pro/dist_circle.pro b/modules/idl_downloads/astro/pro/dist_circle.pro new file mode 100644 index 0000000..a5457bf --- /dev/null +++ b/modules/idl_downloads/astro/pro/dist_circle.pro @@ -0,0 +1,97 @@ +pro dist_circle ,im, n, xcen ,ycen, DOUBLE = double +;+ +; NAME: +; DIST_CIRCLE +; PURPOSE: +; Form a square array where each value is its distance to a given center. +; EXPLANATION: +; Returns a square array in which the value of each element is its +; distance to a specified center. Useful for circular aperture photometry. +; +; CALLING SEQUENCE: +; DIST_CIRCLE, IM, N, [ XCEN, YCEN, /DOUBLE ] +; +; INPUTS: +; N = either a scalar specifying the size of the N x N square output +; array, or a 2 element vector specifying the size of the +; N x M rectangular output array. +; +; OPTIONAL INPUTS: +; XCEN,YCEN = Scalars designating the X,Y pixel center. These need +; not be integers, and need not be located within the +; output image. If not supplied then the center of the output +; image is used (XCEN = YCEN = (N-1)/2.). +; +; OUTPUTS: +; IM - N by N (or M x N) floating array in which the value of each +; pixel is equal to its distance to XCEN,YCEN +; +; OPTIONAL INPUT KEYWORD: +; /DOUBLE - If this keyword is set and nonzero, the output array will +; be of type DOUBLE rather than floating point. +; +; EXAMPLE: +; Total the flux in a circular aperture within 3' of a specified RA +; and DEC on an 512 x 512 image IM, with a header H. +; +; IDL> adxy, H, RA, DEC, x, y ;Convert RA and DEC to X,Y +; IDL> getrot, H, rot, cdelt ;CDELT gives plate scale deg/pixel +; IDL> cdelt = cdelt*3600. ;Convert to arc sec/pixel +; IDL> dist_circle, circle, 512, x, y ;Create a distance circle image +; IDL> circle = circle*abs(cdelt[0]) ;Distances now given in arcseconds +; IDL> good = where(circle LT 180) ;Within 3 arc minutes +; IDL> print,total( IM[good] ) ;Total pixel values within 3' +; +; RESTRICTIONS: +; The speed of DIST_CIRCLE decreases and the the demands on virtual +; increase as the square of the output dimensions. Users should +; dimension the output array as small as possible, and re-use the +; array rather than re-calling DIST_CIRCLE +; +; MODIFICATION HISTORY: +; Adapted from DIST W. Landsman March 1991 +; Allow a rectangular output array W. Landsman June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Add /DOUBLE keyword, make XCEN,YCEN optional W. Landsman Jun 1998 +;- + On_error,2 ;Return to caller if an error occurs + + if N_params() LT 2 then begin + print,'Syntax - DIST_CIRCLE, im, n,[ xcen, ycen, /DOUBLE ]' + print,'IM - output image array' + print,'N - size of the output image array, scalar or 2 element vector' + print,'XCEN,YCEN - position from which to specify distances' + return + endif + + if N_elements(N) EQ 2 then begin + nx = n[0] + ny = n[1] + endif else if N_elements(N) EQ 1 then begin + ny = n + nx = n ;Make a row + endif else message, $ + 'ERROR - Output size parameter N must contain 1 or 2 elements' + + + if N_params() LT 4 then begin + xcen = (nx-1)/2. & ycen = (ny-1)/2. + endif + + + if keyword_set(DOUBLE) then begin + x_2 = (dindgen(nx) - xcen) ^ 2 ;X distances (squared) + y_2 = (dindgen(ny) - ycen) ^ 2 ;Y distances (squared) + im = dblarr( nx, ny, /NOZERO) ;Make uninitialized output array + endif else begin + x_2 = (findgen(nx) - xcen) ^ 2 ;X distances (squared) + y_2 = (findgen(ny) - ycen) ^ 2 ;Y distances (squared) + im = fltarr( nx, ny, /NOZERO) ;Make uninitialized output array + endelse + + for i = 0L, ny-1 do begin ;Row loop + im[0,i] = sqrt(x_2 + y_2[i]) ;Euclidian distance + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/dist_ellipse.pro b/modules/idl_downloads/astro/pro/dist_ellipse.pro new file mode 100644 index 0000000..0e23c31 --- /dev/null +++ b/modules/idl_downloads/astro/pro/dist_ellipse.pro @@ -0,0 +1,121 @@ +pro dist_ellipse,im,n,xc,yc,ratio,pos_ang, DOUBLE = double +;+ +; NAME: +; DIST_ELLIPSE +; PURPOSE: +; Create a mask array useful for elliptical aperture photemetry +; EXPLANATION: +; Form an array in which the value of each element is equal to the +; semi-major axis of the ellipse of specified center, axial ratio, and +; position angle, which passes through that element. Useful for +; elliptical aperture photometry. +; +; CALLING SEQUENCE: +; DIST_ELLIPSE, IM, N, XC, YC, RATIO, [ POS_ANG] , /DOUBLE +; +; INPUTS: +; N = either a scalar specifying the size of the N x N square output +; array, or a 2 element vector specifying the size of the +; M x N rectangular output array. +; XC,YC - Scalars giving the position of the ellipse center. This does +; not necessarily have to be within the image +; RATIO - Scalar giving the ratio of the major to minor axis. This +; should be greater than 1 for position angle to have its +; standard meaning. +; +; OPTIONAL INPUTS: +; POS_ANG - Position angle of the major axis in degrees, measured counter-clockwise +; from the Y axis. For an image in standard orientation +; (North up, East left) this is the astronomical position angle. +; Default is 0 degrees. +; +; OPTIONAL INPUT KEYWORD: +; /DOUBLE - If this keyword is set and nonzero, the output array will +; be of type DOUBLE rather than floating point. +; +; OUTPUT: +; IM - REAL*4 elliptical mask array, of size M x N. THe value of each +; pixel is equal to the semi-major axis of the ellipse of center +; XC,YC, axial ratio RATIO, and position angle POS_ANG, which +; passes through the pixel. +; +; EXAMPLE: +; Total the flux in a elliptical aperture with a major axis of 3', an +; axial ratio of 2.3, and a position angle of 25 degrees centered on +; a specified RA and DEC. The image array, IM is 200 x 200, and has +; an associated FITS header H. +; +; ADXY, H, ra, dec, x, y ;Get X and Y corresponding to RA and Dec +; GETROT, H, rot, cdelt ;CDELT gives plate scale degrees/pixel +; cdelt = abs( cdelt)*3600. ;CDELT now in arc seconds/pixel +; DIST_ELLIPSE, ell, 200, x, y, 2.3, 25 ;Create a elliptical image mask +; ell = ell*cdelt(0) ;Distances now given in arcseconds +; good = where( ell lt 180 ) ;Within 3 arc minutes +; print,total( im(good) ) ;Total pixel values within 3' +; +; RESTRICTIONS: +; The speed of DIST_ELLIPSE decreases and the the demands on virtual +; increase as the square of the output dimensions. Users should +; dimension the output array as small as possible, and re-use the +; array rather than re-calling DIST_ELLIPSE +; +; REVISION HISTORY: +; Written W. Landsman April, 1991 +; Somewhat faster algorithm August, 1992 +; Allow rectangular output array June, 1994 +; Added /DOUBLE keyword W. Landsman July 2000 +; Make POS_ANG optional, as documented W. Landsman Aug 2015 +;- + On_error,2 ;Return to caller + + if N_params() LT 5 then begin + print,'Syntax - DIST_ELLIPSE, im, n, xc, yc, ratio, [pos_ang], /DOUBLE' + print,' im - output elliptical mask image array' + print,' n - size of output image mask, scalar or 2 element vector' + print,' xc,yc - coordinates of ellipse center, scalars' + print,' ratio - ratio of major to minor axis of ellipse, scalar' + print,' pos_ang - position angle, counterclockwise from up' + return + endif + ;Check some parameters + if N_elements(ratio) NE 1 then message, $ + 'ERROR - Axial ratio (fifth parameter) must be a scalar value' + + if N_elements(pos_ang) GT 1 then message, $ + 'ERROR - Position angle (sixth parameter) must be a scalar value' + + if N_elements(pos_ang) EQ 0 then pos_ang = 0 + ang = pos_ang /!RADEG ;Convert to radians + cosang = cos(ang) + sinang = sin(ang) + + if N_elements(N) EQ 2 then begin + nx = n[0] + ny = n[1] + endif else if N_elements(N) EQ 1 then begin + ny = n + nx = n ;Make a row + endif else message, $ + 'ERROR - Output size parameter N must contain 1 or 2 elements' + + if keyword_set(double) then begin + x = dindgen(nx) - xc + y = dindgen(ny) - yc + im = dblarr(nx, ny, /NOZERO) + endif else begin + x = findgen( nx ) - xc + y = findgen( ny ) - yc + im = fltarr( nx, ny, /NOZERO ) + endelse + ;Rotate pixels to match ellipse orientation + xcosang = x*cosang + xsinang = x*sinang + + for i = 0,ny-1 do begin + xtemp = xcosang + y[i]*sinang + ytemp = -xsinang + y[i]*cosang + im[0,i] = sqrt( (xtemp*ratio)^2 + ytemp^2 ) + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/eci2geo.pro b/modules/idl_downloads/astro/pro/eci2geo.pro new file mode 100644 index 0000000..c39625e --- /dev/null +++ b/modules/idl_downloads/astro/pro/eci2geo.pro @@ -0,0 +1,81 @@ +;+ +; NAME: +; ECI2GEO +; +; PURPOSE: +; Convert Earth-centered inertial coordinates to geographic spherical coords +; EXPLANATION: +; Converts from ECI (Earth-Centered Inertial) (X,Y,Z) rectangular +; coordinates to geographic spherical coordinates (latitude, longitude, +; altitude). JD time is also needed as input. +; +; ECI coordinates are in km from Earth center at the supplied time (True of +; Date). Geographic coordinates are in degrees/degrees/km +; Geographic coordinates assume the Earth is a perfect sphere, with radius +; equal to its equatorial radius. +; +; CALLING SEQUENCE: +; gcoord=eci2geo(ECI_XYZ,JDtime) +; +; INPUT: +; ECI_XYZ : the ECI [X,Y,Z] coordinates (in km), can be an array [3,n] +; of n such coordinates. These should be at the supplied +; Julian Date (TOD - true of date). +; JDtime: the Julian Day time, double precision. Can be a 1-D array of n +; such times. +; +; KEYWORD INPUTS: +; None +; +; OUTPUT: +; a 3-element array of geographic [latitude,longitude,altitude], or an +; array [3,n] of n such coordinates, double precision +; +; COMMON BLOCKS: +; None +; +; PROCEDURES USED: +; CT2LST - Convert Local Civil Time to Local Mean Sidereal Time +; +; EXAMPLE: +; IDL> gcoord=eci2geo([6378.137+600,0,0], 2452343.38982663D) +; IDL> print,gcoord +; 0.0000000 232.27096 600.00000 +; +; (The above is the geographic direction of the vernal point on +; 2002/03/09 21:21:21.021, in geographic coordinates. The chosen +; altitude was 600 km.) +; +; gcoord can be further transformed into geodetic coordinates (using +; geo2geodetic.pro) or into geomagnetic coordinates (using geo2mag.pro) +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (Saint-Hilaire@astro.phys.ethz.ch) on +; 2001/05/13 +; Modified on 2002/05/13, PSH : vectorization + use of JD times +; Document use of TOD epoch R. Redmon April 2014 NOAA/NGDC +;- + +;============================================================================= +FUNCTION eci2geo,ECI_XYZ,JDtim + + Re=6378.137 ; Earth's equatorial radius, in km + coord=DOUBLE(ECI_XYZ) + JDtime= DOUBLE(JDtim) + + theta=atan(coord[1,*],coord[0,*]) ; azimuth + ct2lst,gst,0,0,JDtime + angle_sid=gst*2.*!DPI/24. ; sidereal angle + lon= (theta - angle_sid ) MOD (2* !DPI) ;longitude + r=sqrt(coord[0,*]^2+coord[1,*]^2) + lat=atan(coord[2,*],r) ; latitude + alt=r/cos(lat) - Re ; altitude + + lat=lat*180./(!DPI) ; to convert from radians into degrees... + lon=lon*180./(!DPI) + ss=WHERE(lon LT 0.) + IF ss[0] NE -1 THEN lon[ss]=lon[ss]+360. + + RETURN,[lat,lon,alt] +END +;==================================================================================== diff --git a/modules/idl_downloads/astro/pro/eq2hor.pro b/modules/idl_downloads/astro/pro/eq2hor.pro new file mode 100644 index 0000000..fdb8bf3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/eq2hor.pro @@ -0,0 +1,300 @@ +;+ +; NAME: +; EQ2HOR +; +; PURPOSE: +; Convert celestial (ra-dec) coords to local horizon coords (alt-az). +; +; CALLING SEQUENCE: +; +; eq2hor, ra, dec, jd, alt, az, [ha, LAT= , LON= , /WS, OBSNAME= , $ +; /B1950 , PRECESS_= 0, NUTATE_= 0, REFRACT_= 0, $ +; ABERRATION_= 0, ALTITUDE= , /VERBOSE, _EXTRA= ] +; +; DESCRIPTION: +; This code calculates horizon (alt,az) coordinates from equatorial +; (ra,dec) coords. It is typically accurate to about 1 arcsecond or better (I +; have checked the output against the publicly available XEPHEM software). It +; performs precession, nutation, aberration, and refraction corrections. The +; perhaps best thing about it is that it can take arrays as inputs, in all +; variables and keywords EXCEPT Lat, lon, and Altitude (the code assumes these +; aren't changing), and uses vector arithmetic in every calculation except +; when calculating the precession matrices. +; +; INPUT-OUTPUT VARIABLES: +; RA : Right Ascension of object (J2000) in degrees (FK5); scalar or +; vector. +; Dec : Declination of object (J2000) in degrees (FK5), scalar or vector. +; INPUT VARIABLES: +; JD : Julian Date [scalar or vector] +; +; Note: if RA and DEC are arrays, then alt and az will also be arrays. +; If RA and DEC are arrays, JD may be a scalar OR an array of the +; same dimensionality. +; +; OPTIONAL INPUT KEYWORDS: +; lat : north geodetic latitude of location in degrees +; lon : EAST longitude of location in degrees (Specify west longitude +; with a negative sign.) +; /WS : Set this to get the azimuth measured westward from south (not +; East of North). +; obsname: Set this to a valid observatory name to be used by the +; astrolib OBSERVATORY procedure, which will return the latitude +; and longitude to be used by this program. +; /B1950 : Set this if your ra and dec are specified in B1950, FK4 +; coordinates (instead of J2000, FK5) +; precess_ : Set this to 1 to force precession [default], 0 for no +; precession correction +; nutate_ : Set this to 1 to force nutation [default], 0 for no nutation. +; aberration_ : Set this to 1 to force aberration correction [default], +; 0 for no correction. +; refract_ : Set to 1 to force refraction correction [default], 0 for no +; correction. +; altitude: The altitude of the observing location, in meters. [default=0]. +; verbose: Set this for verbose output. The default is verbose=0. +; _extra: This is for setting TEMPERATURE or PRESSURE explicitly, which are +; used by CO_REFRACT to calculate the refraction effect of the +; atmosphere. If you don't set these, the program will make an +; intelligent guess as to what they are (taking into account your +; altitude). See CO_REFRACT for more details. +; +; OUTPUT VARIABLES: (all double precision) +; alt : altitude (in degrees) +; az : azimuth angle (in degrees, measured EAST from NORTH, but see +; keyword WS above.) +; ha : hour angle (in degrees) (optional) +; +; DEPENDENCIES: +; NUTATE, PRECESS, OBSERVATORY, SUNPOS, ADSTRING() +; CO_NUTATE, CO_ABERRATION, CO_REFRACT, ALTAZ2HADEC, SETDEFAULTVALUE +; +; BASIC STEPS +; Apply refraction correction to find apparent Alt. +; Calculate Local Mean Sidereal Time +; Calculate Local Apparent Sidereal Time +; Do Spherical Trig to find apparent hour angle, declination. +; Calculate Right Ascension from hour angle and local sidereal time. +; Nutation Correction to Ra-Dec +; Aberration correction to Ra-Dec +; Precess Ra-Dec to current equinox. +; +; +;CORRECTIONS I DO NOT MAKE: +; * Deflection of Light by the sun due to GR. (typically milliarcseconds, +; can be arseconds within one degree of the sun) +; * The Effect of Annual Parallax (typically < 1 arcsecond) +; * and more (see below) +; +; TO DO +; * Better Refraction Correction. Need to put in wavelength dependence, +; and integrate through the atmosphere. +; * Topocentric Parallax Correction (will take into account elevation of +; the observatory) +; * Proper Motion (but this will require crazy lookup tables or something). +; * Difference between UTC and UT1 in determining LAST -- is this +; important? +; * Effect of Annual Parallax (is this the same as topocentric Parallax?) +; * Polar Motion +; * Better connection to Julian Date Calculator. +; +; EXAMPLE +; +; Find the position of the open cluster NGC 2264 at the Effelsburg Radio +; Telescope in Germany, on June 11, 2023, at local time 22:00 (METDST). +; The inputs will then be: +; +; Julian Date = 2460107.250 +; Latitude = 50d 31m 36s +; Longitude = 06h 51m 18s +; Altitude = 369 meters +; RA (J2000) = 06h 40m 58.2s +; Dec(J2000) = 09d 53m 44.0s +; +; IDL> eq2hor, ten(6,40,58.2)*15., ten(9,53,44), 2460107.250d, alt, az, $ +; lat=ten(50,31,36), lon=ten(6,51,18), altitude=369.0, /verb, $ +; pres=980.0, temp=283.0 +; +; The program produces this output (because the VERBOSE keyword was set) +; +;Latitude = +50 31 36.0 Longitude = +06 51 18.0 +; ************************** +;Julian Date = 2460107.250000 +;LMST = +11 46 42.0 +;LAST = +11 46 41.4 +; +;Ra, Dec: 06 40 58.2 +09 53 44 (J2000) +;Ra, Dec: 06 42 15.7 +09 52 19 (J2023.4422) +;Ra, Dec: 06 42 13.8 +09 52 27 (fully corrected) +;Hour Angle = +05 04 27.6 (hh:mm:ss) +;Az, El = 17 42 25.6 +16 25 10 (Apparent Coords) +;Az, El = 17 42 25.6 +16 28 23 (Observer Coords) +; +; Compare this with the result from XEPHEM: +; Az, El = 17h 42m 25.6s +16d 28m 21s +; +; This 1.8 arcsecond discrepancy in elevation arises primarily from slight +; differences in the way I calculate the refraction correction from XEPHEM, and +; is pretty typical. +; +; AUTHOR: +; Chris O'Dell +; Assistant Professor of Atmospheric Science +; Colorado State University +; Email: odell@atmos.colostate.edu +; +; Revision History: +; August 2012 Use Strict_Extra to flag spurious keywords W. Landsman +; May 2013 Fix case of scalar JD but vector RA, Dec W. Landsman +; Jun 2014 Fix case of vector JD but scalar RA, Dec W. Landsman +;- + +pro eq2hor, ra, dec, jd, alt, az, ha, lat=lat, lon=lon, WS=WS, obsname=obsname,$ + B1950 = B1950, verbose=verbose, precess_=precess_, nutate_=nutate_, $ + refract_ = refract_, aberration_ = aberration_, $ + altitude = altitude, _extra= _extra + + On_error,2 + compile_opt idl2 + +if N_params() LT 4 then begin + print,'Syntax - EQ2HOR, ra, dec, jd, alt, az, [ha, LAT= , LON= , /WS, ' + print,' OBSNAME= ,/B1950 , PRECESS_= 0, NUTATE_= 0, REFRACT_= 0 ' + print,' ABERRATION_= 0, ALTITUDE= , /VERBOSE, TEMPERATURE=, ' +$ + 'PRESSURE = ]' + return + endif + +;******************************************************************************* +; INITIALIZE STUFF + +; If no lat or lng entered, use Pine Bluff Observatory values! +; (near Madison, Wisconsin, USA) +; * Feel free to change these to your favorite observatory * +v = keyword_set(verbose) +if keyword_set(obsname) then begin + ;override lat,lon, altitude if observatory name has been specified + observatory, obsname, obs + lat = obs.latitude + lon = -1*obs.longitude ; minus sign is because OBSERVATORY uses west +; longitude as positive. + altitude = obs.altitude +endif +if ~v && ((N_elements(lat) EQ 0 ) || N_elements(lon) Eq 0) then $ + message,'Using latitude and longitude for Pine Bluff Observatory',/con +setdefaultvalue, lat, 43.0783d ; (this is the declination of the zenith) +setdefaultvalue, lon, -89.865d +setdefaultvalue, altitude, 0. ; [meters] + +setdefaultvalue, precess_, 1 +setdefaultvalue, nutate_, 1 +setdefaultvalue, aberration_, 1 +setdefaultvalue, refract_ , 1 + + +; conversion factors +d2r = !dpi/180. +h2r = !dpi/12. +h2d = 15.d + +npos = N_elements(ra) +njd = N_elements(jd) + +if ~((npos EQ njd) || (npos EQ 1) || (njd EQ 1)) then message,'Error - ' + $ + 'Either JD or (ra,dec) must be scalars, or have the same # of elements' + +if (npos EQ 1) && (njd GT 1) then begin + ra_ = replicate(double(ra[0]),njd) + dec_ = replicate(double(dec[0]),njd) +endif else begin + ra_ = ra + dec_ = dec +endelse + +if keyword_set(B1950) then begin + tstart = 1950.0 + s_now=' (B1950)' +endif else begin + tstart = 2000.0 + s_now=' (J2000)' +endelse + +;****************************************************************************** +; PRECESS coordinates to current date +; (uses astro lib procedure PRECESS.pro) +J_now = (JD - 2451545.)/365.25 + 2000.0 ; compute current equinox +if precess_ then begin + if njd GT 1 then begin + for i=0,n_elements(jd)-1 do begin + tmpra = ra_[i] & tmpdec = dec_[i] + precess, tmpra, tmpdec, tstart, J_now[i], FK4 = keyword_set(B1950) + ra_[i] = tmpra & dec_[i] = tmpdec + endfor + endif else $ + precess, ra_, dec_, tstart, J_now, FK4 = keyword_set(B1950) + endif +if v then begin + rap = ra_ + decp = dec_ +endif +;****************************************************************************** +; calculate NUTATION and ABERRATION Corrections to Ra-Dec + +co_nutate, jd, ra_, dec_, dra1, ddec1, eps=eps, d_psi=d_psi +co_aberration, jd, ra_, dec_, dra2, ddec2, eps=eps + +; make nutation and aberration corrections +ra_ += (dra1*nutate_ + dra2*aberration_)/3600. +dec_ += (ddec1*nutate_ + ddec2*aberration_)/3600. + +;************************************************************************************** +;Calculate LOCAL MEAN SIDEREAL TIME +ct2lst, lmst, lon, 0, jd ; get LST (in hours) - note:this is independent of + ;time zone since giving jd +lmst = lmst*h2d ; convert LMST to degrees (btw, this is the RA of the zenith) +; calculate local APPARENT sidereal time +LAST = lmst + d_psi *cos(eps)/3600. ; add correction in degrees + +;****************************************************************************** +; Find hour angle (in DEGREES) +ha = last - ra_ +w = where(ha LT 0, Nw) +if Nw GT 0 then ha[w] = ha[w] + 360. +ha = ha mod 360. + +;****************************************************************************** +; Now do the spherical trig to get APPARENT alt,az. +hadec2altaz, ha, dec_, lat, alt, az, WS=WS + +;******************************************************************************************* +; Make Correction for ATMOSPHERIC REFRACTION +; (use this for visible and radio wavelengths; author is unsure about other wavelengths. +; See the comments in CO_REFRACT.pro for more details.) +if v then alt_app = alt +if refract_ then alt = $ + co_refract(alt, altitude=altitude, _strict_extra=_extra, /to_observed) +if v then begin + print, 'Latitude = ', adstring(lat), ' Longitude = ', adstring(lon) + for j=0,njd-1 do begin + print,' ************************** ' + + print, 'Julian Date = ', jd[j], format='(A,f15.6)' + print, 'LMST = ', adstring(lmst/15.) + print, 'LAST = ', adstring(last/15.) + print,' ' + for i=0,npos-1 do begin + print, 'Ra, Dec: ', adstring(ra[i],dec[i]), s_now + print, 'Ra, Dec: ', adstring(rap[i],decp[i]), ' (J' + $ + strcompress(string(J_now),/rem)+')' + + print, 'Ra, Dec: ', adstring(ra_[i],dec_[i]), $ + ' (fully corrected)' + print, 'Hour Angle = ', adstring(ha[i]/15.), ' (hh:mm:ss)' + + print,'Az, El = ', adstring(az[i],alt_app[i]), ' (Apparent Coords)' + print,'Az, El = ', adstring(az[i],alt[i]), ' (Observer Coords)' + print,' ' + endfor + endfor + endif + return +end diff --git a/modules/idl_downloads/astro/pro/eqpole.pro b/modules/idl_downloads/astro/pro/eqpole.pro new file mode 100644 index 0000000..e81654c --- /dev/null +++ b/modules/idl_downloads/astro/pro/eqpole.pro @@ -0,0 +1,57 @@ +pro eqpole,l,b,x,y,southpole=southpole +;+ +; NAME: +; EQPOLE +; PURPOSE: +; Convert RA and Dec to X,Y using an equal-area polar projection. +; EXPLANATION: +; The output X and Y coordinates are scaled to be between +; -90 and +90 to go from equator to pole to equator. Output map points +; can be centered on the north pole or south pole. +; +; CALLING SEQUENCE: +; EQPOLE, L, B, X, Y, [ /SOUTHPOLE ] +; +; INPUTS: +; L - longitude - scalar or vector, in degrees +; B - latitude - same number of elements as RA, in degrees +; +; OUTPUTS: +; X - X coordinate, same number of elements as RA. X is normalized to +; be between -90 and 90. +; Y - Y coordinate, same number of elements as DEC. Y is normalized to +; be between -90 and 90. +; +; KEYWORDS: +; +; /SOUTHPOLE - Keyword to indicate that the plot is to be centered +; on the south pole instead of the north pole. +; +; REVISION HISTORY: +; J. Bloch LANL, SST-9 1.1 5/16/91 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + if N_params() NE 4 then begin + print,'Syntax - EQPOLE,L, B, X, Y, [/SOUTHPOLE]' + print,' Input longitude L, latitude B in *degrees*' + return + endif + + if keyword_set(southpole) then begin + l1 = double(-l/!RADEG) + b1 = double(-b/!RADEG) + endif else begin + l1 = double(l/!RADEG) + b1 = double(b/!RADEG) + endelse + + sq = 2.0d0*(1.0d0 - sin(double(b1))) + chk = where(sq lt 0.0d0) + if chk[0] ge 0 then sq[chk] = 0.0d0 + r = 18.0d0*3.53553391d0*sqrt(sq) + y =r*cos(l1) + x =r*sin(l1) + + return + end diff --git a/modules/idl_downloads/astro/pro/eqpole_grid.pro b/modules/idl_downloads/astro/pro/eqpole_grid.pro new file mode 100644 index 0000000..f400d17 --- /dev/null +++ b/modules/idl_downloads/astro/pro/eqpole_grid.pro @@ -0,0 +1,147 @@ +;+ +; NAME: +; EQPOLE_GRID +; +; PURPOSE: +; Produce an equal area polar projection grid overlay +; EXPLANATION: +; Grid is written on the current graphics device using the equal area +; polar projection. EQPOLE_GRID assumes that the output plot +; coordinates span the x and y ranges of -90 to 90 for a region that +; covers the equator to the chosen pole. The grid is assumed to go from +; the equator to the chosen pole. +; +; CALLING SEQUENCE: +; +; EQPOLE_GRID[,DLONG,DLAT,[/SOUTHPOLE, LABEL = , /NEW, _EXTRA=] +; +; INPUTS: +; +; DLONG = Optional input longitude line spacing in degrees. If left +; out, defaults to 30. +; DLAT = Optional input lattitude line spacing in degrees. If left +; out, defaults to 30. +; +; INPUT KEYWORDS: +; +; /SOUTHPOLE = Optional flag indicating that the output plot is +; to be centered on the south rather than the north +; pole. +; LABEL = Optional flag for creating labels on the output +; grid on the prime meridian and the equator for +; lattitude and longitude lines. If set =2, then +; the longitude lines are labeled in hours and minutes. +; CHARSIZE = If /LABEL is set, then CHARSIZE specifies the size +; of the label characters (passed to XYOUTS) +; CHARTHICK = If /LABEL is set, then CHARTHICK specifies the +; thickness of the label characters (passed to XYOUTS) +; /NEW = If this keyword is set, then EQPOLE_GRID will create +; a new plot, rather than overlay an existing plot. +; +; Any valid keyword to OPLOT such as COLOR, LINESTYLE, THICK can be +; passed to AITOFF_GRID (though the _EXTRA facility) to to specify the +; color, style, or thickness of the grid lines. +; OUTPUTS: +; Draws grid lines on current graphics device. +; +; EXAMPLE: +; Create a labeled equal area projection grid of the Galaxy, centered on +; the South pole, and overlay stars at specified Galactic longitudes, +; glong and latitudes, glat +; +; IDL> eqpole_grid,/label,/new,/south ;Create labeled grid +; IDL> eqpole, glong, glat, x,y ;Convert to X,Y coordinates +; IDL> plots,x,y,psym=2 ;Overplot "star" positions. +; +; +; COPYRIGHT NOTICE: +; +; Copyright 1992, The Regents of the University of California. This +; software was produced under U.S. Government contract (W-7405-ENG-36) +; by Los Alamos National Laboratory, which is operated by the +; University of California for the U.S. Department of Energy. +; The U.S. Government is licensed to use, reproduce, and distribute +; this software. Neither the Government nor the University makes +; any warranty, express or implied, or assumes any liability or +; responsibility for the use of this software. +; +; AUTHOR AND MODIFICATIONS: +; +; J. Bloch 1.4 10/28/92 +; Converted to IDL V5.0 W. Landsman September 1997 +; Create default plotting coords, if needed W. Landsman August 2000 +; Added _EXTRA, CHARTHICK, CHARSIZE keywords W. Landsman March 2001 +;- +PRO EQPOLE_GRID,DLONG,DLAT,_EXTRA=E,LABELS=LABEL,SOUTHPOLE=SOUTHPOLE,NEW=NEW, $ + CHARSIZE = charsize, CHARTHICK =charthick + + if n_params() lt 2 then dlong = 30.0 + if n_params() lt 1 then dlat = 30.0 + + +; If no plotting axis has been defined, then create a default one + + new = keyword_set(new) + if not new then new = (!X.crange[0] EQ 0) and (!X.crange[1] EQ 0) + if new then plot,[-130,130],[-130,130],/nodata,xsty=5,ysty=5 + +; +; Do lines of constant longitude +; + lat=90.0-findgen(180) + if keyword_set(southpole) then lat = -lat + lng=fltarr(180) + lngtot = long(360.0/dlong) + for i=0,lngtot do begin + lng[*]=-180.0+(i*dlong) + eqpole,lng,lat,x,y,southpole=southpole + oplot,x,y,_EXTRA=e + endfor +; +; Do lines of constant latitude +; + lng=findgen(360) + lat=fltarr(360) + lattot=long(180.0/dlat) + for i=1,lattot do begin + if not keyword_set(southpole) then lat[*]=90.0-(i*dlat) $ + else lat[*]=-90.0+(i*dlat) + eqpole,lng,lat,x,y,southpole=southpole + oplot,x,y,_EXTRA=e + endfor +; +; Do labeling if requested +; + if keyword_set(label) then begin +; +; Label equator +; + for i=0,lngtot-1 do begin + lng = (i*dlong) + eqpole,lng,0.0,x,y,southpole=southpole + if label eq 1 then xyouts,x[0],y[0],noclip=0,$ + charsize = charsize, charthick = charthick, $ + strcompress(string(lng,format="(I4)"),/remove_all) $ + else begin + tmp=sixty(lng*24.0/360.0) + xyouts,x[0],y[0],noclip=0,$ + charsize = charsize, charthick = charthick, $ + strcompress(string(tmp[0],tmp[1],$ + format='(I2,"h",I2,"m")'),/remove_all),alignment=0.5 + endelse + endfor +; +; Label prime meridian +; + for i=1,lattot-1 do begin + if not keyword_set(southpole) then $ + lat=90-(i*dlat) else lat=-90+(i*dlat) + eqpole,0.0,lat,x,y,southpole=southpole + xyouts,x[0],y[0],noclip=0,$ + charsize = charsize, charthick = charthick, $ + strcompress(string(lat,format="(I4)"),/remove_all) + endfor + endif + return +end + diff --git a/modules/idl_downloads/astro/pro/euler.pro b/modules/idl_downloads/astro/pro/euler.pro new file mode 100644 index 0000000..9ab363d --- /dev/null +++ b/modules/idl_downloads/astro/pro/euler.pro @@ -0,0 +1,169 @@ +PRO EULER,AI,BI,AO,BO,SELECT, FK4 = FK4, SELECT = select1, RADIAN=radian +;+ +; NAME: +; EULER +; PURPOSE: +; Transform between Galactic, celestial, and ecliptic coordinates. +; EXPLANATION: +; Use the procedure ASTRO to use this routine interactively +; +; CALLING SEQUENCE: +; EULER, AI, BI, AO, BO, [ SELECT, /FK4, /RADIAN, SELECT = ] +; +; INPUTS: +; AI - Input Longitude, scalar or vector. In DEGREES unless /RADIAN +; is set. If only two parameters are supplied, then AI and BI +; will be modified to contain the output longitude and latitude. +; BI - Input Latitude in DEGREES +; +; OPTIONAL INPUT: +; SELECT - Integer (1-6) specifying type of coordinate transformation. +; +; SELECT From To | SELECT From To +; 1 RA-Dec (2000) Galactic | 4 Ecliptic RA-Dec +; 2 Galactic RA-DEC | 5 Ecliptic Galactic +; 3 RA-Dec Ecliptic | 6 Galactic Ecliptic +; +; If not supplied as a parameter or keyword, then EULER will prompt for +; the value of SELECT +; Celestial coordinates (RA, Dec) should be given in equinox J2000 +; unless the /FK4 keyword is set. +; OUTPUTS: +; AO - Output Longitude in DEGREES, always double precision +; BO - Output Latitude in DEGREES, always double precision +; +; OPTIONAL INPUT KEYWORD: +; /FK4 - If this keyword is set and non-zero, then input and output +; celestial and ecliptic coordinates should be given in equinox +; B1950. +; /RADIAN - if set, then all input and output angles are in radians rather +; than degrees. +; SELECT - The coordinate conversion integer (1-6) may alternatively be +; specified as a keyword +; EXAMPLE: +; Find the Galactic coordinates of Cyg X-1 (ra=299.590315, dec=35.201604) +; IDL> ra = 299.590315d +; IDL> dec = 35.201604d +; IDL> euler,ra,dec,glong,glat,1 & print,glong,glat +; 71.334990, 3.0668335 +; REVISION HISTORY: +; Written W. Landsman, February 1987 +; Adapted from Fortran by Daryl Yentis NRL +; Made J2000 the default, added /FK4 keyword W. Landsman December 1998 +; Add option to specify SELECT as a keyword W. Landsman March 2003 +; Use less virtual memory for large input arrays W. Landsman June 2008 +; Added /RADIAN input keyword W. Landsman Sep 2008 +;- + On_error,2 + compile_opt idl2 + + npar = N_params() + if npar LT 2 then begin + print,'Syntax - EULER, AI, BI, A0, B0, [ SELECT, /FK4, /RADIAN, SELECT= ]' + print,' AI,BI - Input longitude,latitude in degrees' + print,' AO,BO - Output longitude, latitude in degrees' + print,' SELECT - Scalar (1-6) specifying transformation type' + return + endif + + twopi = 2.0d*!DPI + fourpi = 4.0d*!DPI + rad_to_deg = 180.0d/!DPI + +; J2000 coordinate conversions are based on the following constants +; (see the Hipparcos explanatory supplement). +; eps = 23.4392911111d Obliquity of the ecliptic +; alphaG = 192.85948d Right Ascension of Galactic North Pole +; deltaG = 27.12825d Declination of Galactic North Pole +; lomega = 32.93192d Galactic longitude of celestial equator +; alphaE = 180.02322d Ecliptic longitude of Galactic North Pole +; deltaE = 29.811438523d Ecliptic latitude of Galactic North Pole +; Eomega = 6.3839743d Galactic longitude of ecliptic equator + + if keyword_set(FK4) then begin + + equinox = '(B1950)' + psi = [ 0.57595865315D, 4.9261918136D, $ + 0.00000000000D, 0.0000000000D, $ + 0.11129056012D, 4.7005372834D] + stheta =[ 0.88781538514D,-0.88781538514D, $ + 0.39788119938D,-0.39788119938D, $ + 0.86766174755D,-0.86766174755D] + ctheta =[ 0.46019978478D, 0.46019978478D, $ + 0.91743694670D, 0.91743694670D, $ + 0.49715499774D, 0.49715499774D] + phi = [ 4.9261918136D, 0.57595865315D, $ + 0.0000000000D, 0.00000000000D, $ + 4.7005372834d, 0.11129056012d] + + + endif else begin + + equinox = '(J2000)' + psi = [ 0.57477043300D, 4.9368292465D, $ + 0.00000000000D, 0.0000000000D, $ + 0.11142137093D, 4.71279419371D] + stheta =[ 0.88998808748D,-0.88998808748D, $ + 0.39777715593D,-0.39777715593D, $ + 0.86766622025D,-0.86766622025D] + ctheta =[ 0.45598377618D, 0.45598377618D, $ + 0.91748206207D, 0.91748206207D, $ + 0.49714719172D, 0.49714719172D] + phi = [ 4.9368292465D, 0.57477043300D, $ + 0.0000000000D, 0.00000000000D, $ + 4.71279419371d, 0.11142137093d] + + endelse +; + if N_elements(select) EQ 0 then $ + if N_elements(select1) EQ 1 then select=select1 + if N_elements(select) EQ 0 then begin + print,' ' + print,' 1 RA-DEC ' + equinox + ' to Galactic' + print,' 2 Galactic to RA-DEC' + equinox + print,' 3 RA-DEC ' + equinox + ' to Ecliptic' + print,' 4 Ecliptic to RA-DEC' + equinox + print,' 5 Ecliptic to Galactic' + print,' 6 Galactic to Ecliptic' +; + select = 0 + read,'Enter selection: ',select + endif + + I = select - 1 ; IDL offset + if npar EQ 2 then begin + + if keyword_set(radian) then begin + ao = temporary(ai) - phi[i] + bo = temporary(bi) + endif else begin + ao = temporary(ai)/rad_to_deg - phi[i] + bo = temporary(bi)/rad_to_deg + endelse + + endif else begin + if keyword_set(radian) then begin + ao = ai - phi[i] + bo = bi + endif else begin + ao = ai/rad_to_deg - phi[i] + bo = bi/rad_to_deg + endelse + endelse + sb = sin(bo) & cb = cos(bo) + cbsa = cb * sin(ao) + bo = -stheta[i] * cbsa + ctheta[i] * sb + bo = asin(bo<1.0d) + if ~keyword_set(radian) then bo = bo*rad_to_deg +; + ao = atan( ctheta[i] * cbsa + stheta[i] * sb, cb * cos(ao) ) + ao = ( (ao+psi[i]+fourpi) mod twopi) + if ~keyword_set(radian) then ao = ao*rad_to_deg + + + if ( npar EQ 2 ) then begin + ai = temporary(ao) & bi=temporary(bo) + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/expand_tilde.pro b/modules/idl_downloads/astro/pro/expand_tilde.pro new file mode 100644 index 0000000..728bee6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/expand_tilde.pro @@ -0,0 +1,67 @@ +;+ +; NAME: +; EXPAND_TILDE() +; +; PURPOSE: +; Expand tilde in UNIX directory names +; +; CALLING SEQUENCE: +; IDL> output=expand_tilde(input) +; +; INPUTS: +; INPUT = input file or directory name, scalar string +; +; OUTPUT: +; Returns expanded filename, scalar string +; +; EXAMPLES: +; output=expand_tilde('~zarro/test.doc') +; ---> output='/usr/users/zarro' +; +; NOTES: +; This version of EXPAND_TILDE differs from the version in the Solar +; Library in that it does not call the functions EXIST and IDL_RELEASE. +; However, it should work identically. +; PROCEDURE CALLS: +; None. +; REVISION HISTORY: +; Version 1, 17-Feb-1997, D M Zarro. Written +; Transfered from Solar Library W. Landsman Sep. 1997 +; Made more robust D. Zarro/W. Landsman Sep. 2000 +; Made even more robust (since things like ~zarro weren't being expanded) +; Zarro (EITI/GSFC, Mar 2001) +;- + + function expand_tilde,name + if N_elements(name) EQ 0 then return,'' + if size(name,/TNAME) ne 'STRING' then return,name + tpos=strpos(name,'~') + if tpos eq -1 then return,name + apos = strpos(name,'~/') + bpos = strpos(name,'/~') + + tilde=name + if apos GT -1 then begin + tilde = strmid(name,0,apos+1) + post = strmid(name,apos+1,strlen(name)) + endif else begin + if bpos gt -1 then begin + pre = strmid(name,0,bpos+1) + tilde = strmid(name,bpos+1,strlen(name)) + endif + endelse + + error=0 + catch,error + if error ne 0 then begin + catch,/cancel + return,name + endif + + cd,tilde,curr=curr + cd,curr,curr=dcurr + tname = dcurr + if N_elements(pre) GT 0 then tname = pre+tname else $ + if N_elements(post) GT 0 then tname = tname + post + + return,tname & end diff --git a/modules/idl_downloads/astro/pro/extast.pro b/modules/idl_downloads/astro/pro/extast.pro new file mode 100644 index 0000000..b6ba118 --- /dev/null +++ b/modules/idl_downloads/astro/pro/extast.pro @@ -0,0 +1,714 @@ +pro extast,hdr,astr,noparams, alt=alt +;+ +; NAME: +; EXTAST +; PURPOSE: +; Extract ASTrometry parameters from a FITS image header. +; EXPLANATION: +; Extract World Coordinate System information +; ( http://fits.gsfc.nasa.gov/fits_wcs.html ) from a FITS header and +; place it into an IDL structure. +; +; CALLING SEQUENCE: +; EXTAST, hdr, astr, [ noparams, ALT= ] +; +; INPUT: +; HDR - variable containing the FITS header (string array) +; +; OUTPUTS: +; In the following, index 1 & 2 refer to the first and second astrometry +; axes respectively. The actual axis numbers are stored in .AXIS +; +; ASTR - Anonymous structure containing astrometry info from the FITS +; header ASTR always contains the following tags (even though +; some projections do not require all the parameters) +; .NAXIS - 2 element array giving image size +; .CD - 2 x 2 array containing the astrometry parameters CD1_1 CD1_2 +; in DEGREES/PIXEL CD2_1 CD2_2 +; .CDELT - 2 element double vector giving physical increment at the +; reference pixel +; .CRPIX - 2 element double vector giving X and Y coordinates of reference +; pixel (def = NAXIS/2) in FITS convention (first pixel is 1,1) +; .CRVAL - 2 element double precision vector giving R.A. and DEC of +; reference pixel in DEGREES +; .CTYPE - 2 element string vector giving projection types, default +; ['RA---TAN','DEC--TAN'] +; .LONGPOLE - scalar giving native longitude of the celestial pole +; (default = 180 for zenithal projections) +; .LATPOLE - scalar giving native latitude of the celestial pole default=0) +; .PV2 - Vector of projection parameters associated with latitude axis +; PV2 will have up to 21 elements for the ZPN projection, up to 3 +; for the SIN projection and no more than 2 for any other +; projection +; +; Fields added for version 2: +; .PV1 - Vector of projection parameters associated with longitude axis +; .AXES - 2 element integer vector giving the FITS-convention axis +; numbers associated with astrometry, in ascending order. +; Default [1,2]. +; .REVERSE - byte, true if first astrometry axis is Dec/latitude +; .COORD_SYS - 1 or 2 character code giving coordinate system, including +; 'C' = RA/Dec, 'G' = Galactic, 'E' = Ecliptic, 'X' = unknown. +; .PROJECTION - 3-letter WCS projection code +; .KNOWN - true if IDL WCS routines recognise this projection +; .RADECSYS - String giving RA/Dec system e.g. 'FK4', 'ICRS' etc. +; .EQUINOX - Double giving the epoch of the mean equator and equinox +; .DATEOBS - Text string giving (start) date/time of observations +; .MJDOBS - Modified julian date of start of observations. +; .X0Y0 - Implied offset in intermediate world coordinates (x,y) +; if a non-standard fiducial point is set via PV1 and also +; PV1_0a =/ 0, indicating that an offset should be +; applied to place CRVAL at the (x,y) origin. +; Should be *added* to the IWC derived from application of +; CRPIX, CDELT, CD to the pixel coordinates. +; +; .DISTORT - optional substructure specifying any distortion parameters +; currently implement only for "SIP" (Spitzer Imaging +; Polynomial), "TPV" (tangent PV* polynomial) distortion +; parameters, and "TNX" (tangent plus iraf distortion) +; +; NOPARAMS - Scalar indicating the results of EXTAST +; -1 = Failure - Header missing astrometry parameters +; 1 = Success - Header contains CROTA + CDELT (AIPS-type) astrometry +; 2 = Success - Header contains CDn_m astrometry, rec. +; 3 = Success - Header contains PCn_m + CDELT astrometry. +; 4 = Success - Header contains ST Guide Star Survey astrometry +; (see gsssextast.pro ) +; OPTIONAL INPUT/OUTPUT KEYWORDS: +; ALT - single character 'A' through 'Z' or ' ' specifying an alternate +; astrometry system present in the FITS header. The default is +; to use the primary astrometry or ALT = ' '. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. If not set on input, then +; ALT is set to ' ' on output. +; PROCEDURE: +; EXTAST checks for astrometry parameters in the following order: +; +; (1) the CD matrix PC1_1,PC1_2...plus CDELT*, CRPIX and CRVAL +; (2) the CD matrix CD1_1,CD1_2... plus CRPIX and CRVAL. +; (3) CROTA2 (or CROTA1) and CDELT plus CRPIX and CRVAL. +; +; All three forms are valid FITS according to the paper "Representations +; of World Coordinates in FITS by Greisen and Calabretta (2002, A&A, 395, +; 1061 http://fits.gsfc.nasa.gov/fits_wcs.html ) although form (1) is +; preferred. +; +; NOTES: +; 1. An anonymous structure is created to avoid structure definition +; conflicts. This is needed because some projection systems +; require additional dimensions (i.e. spherical cube +; projections require a specification of the cube face). +; +; 2, FITS headers created by SCAMP +; (http://www.astromatic.net/software/scamp) contain a tangent +; projection with distortion polynomial coefficients in the PV[1|2]_? +; keywords. These will be flagged as being a TPV projection +; (http://fits.gsfc.nasa.gov/registry/tpvwcs.html) in the +; astr.projection keyword. +; +; PROCEDURES CALLED: +; GSSSEXTAST, ZPARCHECK +; REVISION HISTORY +; Written by B. Boothman 4/15/86 +; Accept CD001001 keywords 1-3-88 +; Accept CD1_1, CD2_1... keywords W. Landsman Nov. 92 +; Recognize GSSS FITS header W. Landsman June 94 +; Get correct sign, when converting CDELT* to CD matrix for right-handed +; coordinate system W. Landsman November 1998 +; Consistent conversion between CROTA and CD matrix October 2000 +; CTYPE = 'PIXEL' means no astrometry params W. Landsman January 2001 +; Don't choke if only 1 CTYPE value given W. Landsman August 2001 +; Recognize PC00n00m keywords again (sigh...) W. Landsman December 2001 +; Recognize GSSS in ctype also D. Finkbeiner Jan 2002 +; Introduce ALT keyword W. Landsman June 2003 +; Fix error introduced June 2003 where free-format values would be +; truncated if more than 20 characters. W. Landsman Aug 2003 +; Further fix to free-format values -- slash need not be present Sep 2003 +; Default value of LATPOLE is 90.0 W. Landsman February 2004 +; Allow for distortion substructure, currently implemented only for +; SIP (Spitzer Imaging Polynomial) W. Landsman February 2004 +; Correct LONGPOLE computation if CTYPE = ['*DEC','*RA'] W. L. Feb. 2004 +; Assume since V5.3 (vector STRMID) W. Landsman Feb 2004 +; Yet another fix to free-format values W. Landsman April 2004 +; Introduce PV2 tag to replace PROJP1, PROJP2.. etc. W. Landsman May 2004 +; Convert NCP projection to generalized SIN W. Landsman Aug 2004 +; Add NAXIS tag to output structure W. Landsman Jan 2007 +; .CRPIX tag now Double instead of Float W. Landsman Apr 2007 +; If duplicate keywords use the *last* value W. Landsman Aug 2008 +; Fix typo for AZP projection, nonzero longpole N. Cunningham Feb 2009 +; Give warning if reverse SIP coefficient not present W. Landsman Nov 2011 +; Allow obsolete CD matrix representations W. Landsman May 2012 +; Work for Paritel headers with extra quotes R. Gutermuth/WL April 2013 +; +; Version 2: J. P. Leahy, July 2013 +; - Support long & lat axes not being the first 2. +; - Implemented PV1 and hence non-default phi0 and theta0 +; - Added AXES, REVERSE, COORD_SYS, PROJECTION, RADECSYS, EQUINOX, +; DATEOBS, MJDOBS, PV1, and X0Y0 tags to the structure. +; - More checks for inconsistencies in the keywords. +; v2.1 21/7/13 Missing mjdobs & equinox changed to NaN (was -1 & 0); +; Converts GLS to SFL if possible; added KNOWN tag. +; v2.2 21/9/13 GLS conversion fixed. +; v2.3 1 Dec 13 Add warning if distortions from SCAMP astrometry present +; v2.4. Extract SCAMP or TPV distortion astrometry, if present Jan 2014 +; v2.5 Fix bug when SIP parameters not recognized when NAXIS=0 May 2014 +; v2.5.1 Make sure CROTA defined for GLS projection WL Sep 2015 +;- + On_error, 0 + compile_opt idl2 + ; + ; List of known map types copied from wcsxy2sph. Needs to be kept up + ; to date! + ; + map_types=['DEF','AZP','TAN','SIN','STG','ARC','ZPN','ZEA','AIR','CYP',$ + 'CAR','MER','CEA','COP','COD','COE','COO','BON','PCO','SFL',$ + 'PAR','AIT','MOL','CSC','QSC','TSC','SZP','HPX','HCT','XPH'] + + if ( N_params() LT 2 ) then begin + print,'Syntax - EXTAST, hdr, astr, [ noparams, ALT = ]' + return + endif + + proj0 = ['CYP','CEA','CAR','MER','SFL','PAR','MOL','AIT','BON','PCO', $ + 'TSC','CSC','QSC'] + radeg = 180.0D0/!DPI + keyword = STRUPCASE(strtrim(strmid( hdr, 0, 8), 2)) + +; Extract values from the FITS header. This is either up to the first slash +; (free format) or first space + + space = strpos( hdr, ' ', 10) + 1 + slash = strpos( hdr, '/', 10) > space + + N = N_elements(hdr) + len = (slash -10) > 20 + len = reform(len,1,N) + lvalue = strtrim(strmid(hdr, 10, len),2) + remchar,lvalue,"'" + zparcheck,'EXTAST',hdr,1,7,1,'FITS image header' ;Make sure valid header + noparams = -1 ;Assume no astrometry to start + + if N_elements(alt) EQ 0 then begin + alt = '' & altstr = '' + endif else BEGIN + if (alt EQ '1') then alt = 'A' else alt = strupcase(alt) + altstr = ' for alternate system '+alt + ENDELSE + + ; Search for astrometric axes: + test = STREGEX(keyword,'^CTYPE[1-9][0-9]{0,2}'+alt+'$', LENGTH = ctlen) + typ = WHERE(test GE 0, ntyp) + lon = -1 & lat = -1 + lon_form = -1 & lat_form = -1 + + IF ntyp GT 0 THEN BEGIN + ctlen = ctlen[typ] - STRLEN('CTYPE'+alt) ; gives # digits in axis number + + lon0 = WHERE(STRMID(lvalue[typ],0,5) EQ 'RA---') + lon1 = WHERE(STRMID(lvalue[typ],1,4) EQ 'LON-') + lon2 = WHERE(STRMID(lvalue[typ],2,4) EQ 'LN-') + lon = [lon0, lon1, lon2] + form = [REPLICATE(0,N_ELEMENTS(lon0)),REPLICATE(1,N_ELEMENTS(lon1)), $ + REPLICATE(2,N_ELEMENTS(lon2))] + good = WHERE(lon GT 0, ngood) + IF ngood GT 1 THEN MESSAGE, /INFORMATIONAL, $ + 'Multiple longitude axes'+altstr+': Using last.' + lon = MAX(lon, subs) + lon_form = lon GE 0 ? form[subs] : -1 + + lat0 = WHERE(STRMID(lvalue[typ],0,5) EQ 'DEC--') + lat1 = WHERE(STRMID(lvalue[typ],1,4) EQ 'LAT-') + lat2 = WHERE(STRMID(lvalue[typ],2,4) EQ 'LT-') + lat = [lat0, lat1, lat2] + form = [REPLICATE(0,N_ELEMENTS(lat0)),REPLICATE(1,N_ELEMENTS(lat1)), $ + REPLICATE(2,N_ELEMENTS(lat2))] + good = WHERE(lat GT 0, ngood) + IF ngood GT 1 THEN MESSAGE, /INFORMATIONAL, $ + 'Multiple latitude axes'+altstr+': Using last.' + lat = MAX(lat,subs) + lat_form = lat GE 0 ? form[subs] : -1 + ENDIF + +; +; Longitude axis data is initially stored in element 0 and latitude +; axis data in element 1 of the various arrays. For backwards compatibility, +; if latitude has a lower axis number in the FITS header, they will be swapped +; into the (latitude, longitude) order in the final structure, and the .REVERSE +; field will be set to true (ie. 1B). +; + lonc = lon GE 0 ? STRMID(keyword[typ[lon]],5,ctlen[lon]) : '1' + latc = lat GE 0 ? STRMID(keyword[typ[lat]],5,ctlen[lat]) : '2' + + ctype = ['',''] + l = where(keyword EQ 'CTYPE'+lonc+alt, N_ctype1) + if N_ctype1 GT 0 then ctype[0] = lvalue[l[N_ctype1-1]] + l = where(keyword EQ 'CTYPE'+latc+alt, N_ctype2) + if N_ctype2 GT 0 then ctype[1] = lvalue[l[N_ctype2-1]] + ctype = strtrim(ctype,2) + + badco = lon_form NE lat_form + CASE lon_form OF + -1: coord = 'X' ; unknown type of coordinate + 0: coord = 'C' ; celestial coords, i.e. RA/Dec + 1: BEGIN ; longitude format is xLON where x = G, E, etc. + coord = STRMID(ctype[0],0,1) + badco = badco || coord NE STRMID(ctype[1],0,1) + END + 2: BEGIN ; longitude format is yzLN + coord = STRMID(ctype[0],0,2) + badco = badco || coord NE STRMID(ctype[2],0,2) + END + ELSE: MESSAGE, 'Internal error: unexpected lon_form' + ENDCASE + + naxis = lonarr(2) + l = where(keyword EQ 'NAXIS'+lonc, N_axis1) + if N_axis1 GT 0 then naxis[0] = lvalue[l[N_axis1-1]] + l = where(keyword EQ 'NAXIS'+latc, N_axis2) + if N_axis2 GT 0 then naxis[1] = lvalue[l[N_axis2-1]] + + tpv = strmid(ctype[0],2,3,/reverse) EQ 'TPV' + tnx = strmid(ctype[0],2,3,/reverse) EQ 'TNX' + + IF (TPV || tnx) THEN BEGIN + proj = 'TAN' + ENDIF ELSE BEGIN + proj = STRMID(ctype[0], 5, 3) + + badco = badco || proj NE STRMID(ctype[1], 5, 3) + IF badco THEN BEGIN + MESSAGE, 'ERROR' + altstr + $ + ': longitude and latitude coordinate types must match:', /CONTINUE + MESSAGE, 'Coords were CTYPE'+lonc+alt+': ' + ctype[0] + $ + '; CTYPE'+latc+alt+': ' + ctype[1] + ENDIF + +; If the standard CTYPE* astrometry keywords not found, then check if the +; ST guidestar astrometry is present + + check_gsss = (N_ctype1 EQ 0) + if N_ctype1 GE 1 then check_gsss = (strmid(ctype[0], 5, 3) EQ 'GSS') + + if check_gsss then begin + + l = where(keyword EQ 'PPO1'+alt, N_ppo1) + if N_ppo1 EQ 1 then begin + gsssextast, hdr, astr, gsssparams + if gsssparams EQ 0 then noparams = 4 + return + endif + ctype = ['RA---TAN','DEC--TAN'] + endif + + if (ctype[0] EQ 'PIXEL') then return + if N_ctype2 EQ 1 then if (ctype[1] EQ 'PIXEL') then return + ENDELSE + + crval = dblarr(2) + + l = where(keyword EQ 'CRVAL'+lonc+alt, N_crval1) + if N_crval1 GT 0 then crval[0] = lvalue[l[N_crval1-1]] + l = where(keyword EQ 'CRVAL'+latc+alt, N_crval2) + if N_crval2 GT 0 then crval[1] = lvalue[l[N_crval2-1]] + if (N_crval1 EQ 0) || (N_crval2 EQ 0) then return + + crpix = dblarr(2) + l = where(keyword EQ 'CRPIX'+lonc+alt, N_crpix1) + if N_crpix1 GT 0 then crpix[0] = lvalue[l[N_crpix1-1]] + l = where(keyword EQ 'CRPIX'+latc+alt, N_crpix2) + if N_crpix2 GT 0 then crpix[1] = lvalue[l[N_crpix2-1]] + if (N_crpix1 EQ 0) || (N_crpix2 EQ 0) then return + + + cd = dblarr(2,2) + cdelt = [1.0d,1.0d] + +GET_CD_MATRIX: + + l = where(keyword EQ 'PC'+lonc+'_'+lonc + alt, N_pc11) + if N_PC11 GT 0 then begin + cd[0,0] = lvalue[l] + l = where(keyword EQ 'PC'+lonc+'_'+latc + alt, N_pc12) + if N_pc12 GT 0 then cd[0,1] = lvalue[l[N_pc12-1]] + l = where(keyword EQ 'PC'+latc+'_'+lonc + alt, N_pc21) + if N_pc21 GT 0 then cd[1,0] = lvalue[l[N_pc21-1]] + l = where(keyword EQ 'PC'+latc+'_'+latc + alt, N_pc22) + if N_pc22 GT 0 then cd[1,1] = lvalue[l[N_pc22-1]] + l = where(keyword EQ 'CDELT'+lonc+ alt, N_cdelt1) + if N_cdelt1 GT 0 then cdelt[0] = lvalue[l[N_cdelt1-1]] + l = where(keyword EQ 'CDELT'+latc+ alt, N_cdelt2) + if N_cdelt2 GT 0 then cdelt[1] = lvalue[l[N_cdelt2-1]] + det = cd[0,0]*cd[1,1] - cd[0,1]*cd[1,0] + if det LT 0 then sgn = -1 else sgn = 1 + crota = atan( sgn*cd[0,1], sgn*cd[0,0] ) + noparams = 3 + endif else begin + + l = where(keyword EQ 'CD'+lonc+'_'+lonc + alt, N_cd11) + if N_CD11 GT 0 then begin ;If CD parameters don't exist, try CROTA + cd[0,0] = strtrim(lvalue[l[N_cd11-1]],2) + l = where(keyword EQ 'CD'+lonc+'_'+latc + alt, N_cd12) + if N_cd12 GT 0 then cd[0,1] = lvalue[l[N_cd12-1]] + l = where(keyword EQ 'CD'+latc+'_'+lonc + alt, N_cd21) + if N_cd21 GT 0 then cd[1,0] = lvalue[l[N_cd21-1]] + l = where(keyword EQ 'CD'+latc+'_'+latc + alt, N_cd22) + if N_cd22 GT 0 then cd[1,1] = lvalue[l[N_cd22-1]] + noparams = 2 + endif else begin + +; Now get rotation, first try CROTA2, if not found try CROTA1, if that +; not found assume North-up. Then convert to CD matrix - see Section 5 in +; Greisen and Calabretta + + l = where(keyword EQ 'CDELT'+lonc + alt, N_cdelt1) + if N_cdelt1 GT 0 then cdelt[0] = lvalue[l[N_cdelt1-1]] + l = where(keyword EQ 'CDELT'+latc + alt, N_cdelt2) + if N_cdelt2 GT 0 then cdelt[1] = lvalue[l[N_cdelt2-1]] + if (N_cdelt1 EQ 0) || (N_Cdelt2 EQ 0) then return + ;Must have CDELT1 and CDELT2 + + l = where(keyword EQ 'CROTA'+latc + alt, N_crota) + if N_Crota EQ 0 then $ + l = where(keyword EQ 'CROTA'+lonc + alt, N_crota) + if N_crota EQ 0 then begin + l = where(keyword EQ 'PC001001', N_PC00) + l = where(keyword EQ 'CD001001', N_CD00) + if (N_PC00 GT 0) || (N_CD00 GT 0) then begin + message,'Updating obsolete CD matrix representation',/INF + FITS_CD_FIX, hdr + keyword = strtrim(strmid(hdr,0,8),2) + goto, GET_CD_MATRIX + endif else crota = 0.0d + endif else crota = double(lvalue[l[N_crota-1]])/RADEG + cd = [ [cos(crota), -sin(crota)],[sin(crota), cos(crota)] ] + + noparams = 1 ;Signal AIPS-type astrometry found + + endelse + endelse + +; Kluge to test for non-standard PVi_j distortion terms used by SCAMP + scamp_distort = 0b + if ~tpv && (proj EQ 'TAN') then $ + tpv = ~array_equal(strmatch(keyword,'PV1_[5-9]'),0) && $ ;Updated 1-8-14 + ~array_equal(strmatch(keyword,'PV2_[3-9]'),0) + +;Extract PV_* keywords. Special case for TPV distortion + if tpv then begin + g= where(strmatch(keyword,'PV1_*'), Ng) + key_pv1 = keyword[g] + temp = gettok(key_pv1,'_') + key_pv1 = fix(key_pv1) + pv1 = dblarr(max(key_pv1)+1) + pv1[key_pv1] = lvalue[g] + + g= where(strmatch(keyword,'PV2_*'), Ng) + key_pv2 = keyword[g] + temp = gettok(key_pv2,'_') + key_pv2 = fix(key_pv2) + pv2 = dblarr(max(key_pv2)+1) ;Corrected 13-Jan-2014 + pv2[key_pv2] = lvalue[g] + + latpole = 90.0D + longpole = 180.0D + known = 1.0 + x0y0 = [0d0, 0d0] + distort_flag = 'TPV' +ENDIF ELSE BEGIN + ;; extract the tnx coefficients from the WAT keywords + + IF(tnx)THEN BEGIN + g=where(strmatch(keyword,'WAT1_*'),Ng) + key_wat1=keyword[g] + val_wat1=STRTRIM(strmid(hdr[g], 10),2) + remchar,val_wat1,"'" + remchar,val_wat1,'"' + remchar,val_wat1,'/' + temp=STRMID(key_wat1,0,3,/REVERSE) + s=SORT(temp) + val_wat1=val_wat1[s] + val_wat1=STRJOIN(val_wat1) + val_wat1=STRSPLIT(val_wat1,/EXTRACT) + + g=where(strmatch(keyword,'WAT2_*'),Ng) + key_wat2=keyword[g] + val_wat2=STRTRIM(strmid(hdr[g], 10),2) + remchar,val_wat2,"'" + remchar,val_wat2,'"' + remchar,val_wat2,'/' + temp=STRMID(key_wat2,0,3,/REVERSE) + s=SORT(temp) + val_wat2=val_wat2[s] + val_wat2=STRJOIN(val_wat2) + val_wat2=STRSPLIT(val_wat2,/EXTRACT) + IF(val_wat1[2] NE 'lngcor' || val_wat2[2] NE 'latcor')THEN BEGIN + MESSAGE,'WARNING: TNX projection parameters not parsed correctly',/CON + ctype = ['RA---TAN','DEC--TAN'] + tnx=0 + ENDIF + IF(val_wat1[4] NE 3 || val_wat2[4] NE 3)THEN BEGIN + MESSAGE,'WARNING - only polynomials supported for TNX projection.',/CON + ctype = ['RA---TAN','DEC--TAN'] + tnx=0 + ENDIF + + IF(tnx)THEN BEGIN + ;; tnx coefficients get stored in two structures + ncoeff=N_ELEMENTS(val_wat1)-12 + lngcor={functype:0,xiorder:0,etaorder:0,xterms:0,ximin:0d0,ximax:0d0,etamin:0d0,etamax:0d0,coeff:DBLARR(ncoeff)} + lngcor.functype=FIX(val_wat1[4]) + lngcor.xiorder=FIX(val_wat1[5]) + lngcor.etaorder=FIX(val_wat1[6]) + lngcor.xterms=FIX(val_wat1[7]) + lngcor.ximin=DOUBLE(val_wat1[8]) + lngcor.ximax=DOUBLE(val_wat1[9]) + lngcor.etamin=DOUBLE(val_wat1[10]) + lngcor.etamax=DOUBLE(val_wat1[11]) + lngcor.coeff=DOUBLE(val_wat1[12:*]) + + ncoeff=N_ELEMENTS(val_wat2)-12 + latcor={functype:0,xiorder:0,etaorder:0,xterms:0,ximin:0d0,ximax:0d0,etamin:0d0,etamax:0d0,coeff:DBLARR(ncoeff)} + latcor.functype=FIX(val_wat2[4]) + latcor.xiorder=FIX(val_wat2[5]) + latcor.etaorder=FIX(val_wat2[6]) + latcor.xterms=FIX(val_wat2[7]) + latcor.ximin=DOUBLE(val_wat2[8]) + latcor.ximax=DOUBLE(val_wat2[9]) + latcor.etamin=DOUBLE(val_wat2[10]) + latcor.etamax=DOUBLE(val_wat2[11]) + latcor.coeff=DOUBLE(val_wat2[12:*]) + distort_flag = 'TNX' + ENDIF ELSE distort_flag='' + ENDIF ELSE BEGIN + distort_flag = strlen(ctype[0]) GE 12 ? strmid(ctype[0],9,3) : '' + ENDELSE + case proj of + 'ZPN': npv = 21 + 'SZP': npv = 3 + else: npv = 2 + endcase + + index = proj EQ 'ZPN' ? strtrim(indgen(npv),2) : strtrim(indgen(npv)+1,2) + pv2 = dblarr(npv) + if proj EQ 'HPX' then pv2[0] = [4.d,3.d] ;Default for Healpix + + for i=0,npv-1 do begin + l = where(keyword EQ 'PV'+latc+ '_' + index[i] + alt, N_pv2) + if N_pv2 GT 0 then pv2[i] = lvalue[l[N_pv2-1]] + endfor + + pv1 = DBLARR(5) + pv1_set = BYTARR(5) + FOR i=0,4 DO BEGIN + l = WHERE(keyword EQ 'PV'+lonc+'_' + STRTRIM(i,2) + alt, N_pv1) + pv1_set[i] = N_pv1 GT 0 + IF pv1_set[i] THEN pv1[i] = DOUBLE(lvalue[l[N_pv1-1]]) + ENDFOR + xyoff = pv1[0] NE 0d0 + phi0 = pv1[1] + if pv1_set[2] THEN theta0 = pv1[2] + if pv1_set[3] then longpole = pv1[3] else begin + l = where(keyword EQ 'LONPOLE' + alt, N_lonpole) + if N_lonpole GT 0 then longpole = double(lvalue[l[N_lonpole-1]]) + endelse + if pv1_set[4] then latpole = pv1[4] else begin + l = where(keyword EQ 'LATPOLE' + alt, N_latpole) + latpole = N_latpole GT 0 ? double(lvalue[l[N_latpole-1]]) : 90d0 + endelse + +; Convert NCP projection to generalized SIN projection (see Section 6.1.2 of +; Calabretta and Greisen (2002) + + if proj EQ 'NCP' then begin + ctype = repstr(ctype,'NCP','SIN') + proj = 'SIN' + PV2 = [0d0, 1d0/tan(crval[1]/radeg) ] + longpole = 180d0 + endif + +; Convert GLS projection (Sect 6.1.4, ibid), but per e-mail from Mark +; Calabretta the correction to CRPIX and CRVAL should only be applied +; to the second axis. + IF proj EQ 'GLS' THEN BEGIN + IF crota EQ 0d0 THEN BEGIN + crpix[1] -= crval[1]/cdelt[1] ; Shift reference point to dec = 0 + crval[1] = 0d0 + ctype = repstr(ctype,'GLS','SFL') + proj = 'SFL' + ENDIF + ENDIF + + test = WHERE(proj EQ map_types) + known = test GE 0 + + ; If LONPOLE (or PV1_3) is not defined in the header, then we must determine +; its default value. This depends on the value of theta0 (the native +; longitude of the fiducial point) of the particular projection) + + conic = (proj EQ 'COP') || (proj EQ 'COE') || (proj EQ 'COD') || $ + (proj EQ 'COO') + + IF conic THEN BEGIN + IF N_pv2 EQ 0 THEN message, $ + 'ERROR -- Conic projections require a PV2_1 keyword in FITS header' + theta_a = pv2[0] + ENDIF ELSE BEGIN ; Is it a zenithal projection? + if (proj EQ 'AZP') || (proj EQ 'SZP') || (proj EQ 'TAN') || $ + (proj EQ 'STG') || (proj EQ 'SIN') || (proj EQ 'ARC') || $ + (proj EQ 'ZPN') || (proj EQ 'ZEA') || (proj EQ 'AIR') || $ + (proj EQ 'XPH') then begin + theta_a = 90d0 + endif else theta_a = 0d0 + ENDELSE + + IF ~pv1_set[2] THEN BEGIN + theta0 = theta_a + pv1[2] = theta_a + ENDIF + + if N_elements(longpole) EQ 0 then begin + if crval[1] GE theta0 then longpole = 0d0 else longpole = 180d0 + if pv1_set[1] THEN longpole += phi0 + endif + + pv1[3] = longpole + pv1[4] = latpole + + + IF xyoff && (phi0 NE 0d0 || theta0 NE theta_a) THEN BEGIN + ; calculate IWC offsets x_0, y_0 + WCSSPH2XY, phi0, theta0, x0, y0, CTYPE = ctype, PV2 = pv2 + x0y0 = [x0, y0] + ENDIF ELSE x0y0 = [0d0, 0d0] +ENDELSE + + axes = FIX([lonc,latc]) + flip = axes[0] GT axes[1] + IF flip THEN BEGIN + naxis = REVERSE(naxis) + axes = REVERSE(axes) + cdelt = REVERSE(cdelt) + crpix = REVERSE(crpix) + crval = REVERSE(crval) + ctype = REVERSE(ctype) + cd = ROTATE(cd,2) + x0y0 = REVERSE(x0y0) + ENDIF + + equinox = GET_EQUINOX( hdr,eq_code, ALT = alt) + IF equinox EQ 0 THEN equinox = !values.D_NAN + radecsys = '' + mjdobs = !values.D_NAN + dateobs = 'UNKNOWN' + l = WHERE(keyword EQ 'RADESYS' + alt, N_rdsys) + IF N_rdsys GT 0 THEN radecsys = lvalue[l[N_rdsys-1]] ELSE BEGIN + l = WHERE(keyword EQ 'RADECSYS', N_rdsys) + IF N_rdsys GT 0 THEN radecsys = lvalue[l[N_rdsys-1]] + ENDELSE + IF N_rdsys GT 0 THEN radecsys = STRUPCASE(STRTRIM(radecsys,2)) + + l = WHERE(keyword EQ 'MJD-OBS', N_mjd) + IF N_mjd GT 0 THEN mjdobs = DOUBLE(lvalue[l[N_mjd-1]]) + l = WHERE(keyword EQ 'DATE-OBS', N_date) + IF N_date GT 0 THEN dateobs = STRUPCASE(lvalue[l[N_date-1]]) + + IF N_mjd GT 0 && N_date EQ 0 THEN dateobs = date_conv(mjdobs+2400000.5d0,'FITS') + IF N_date GT 0 THEN BEGIN + ; try to convert to standard format: + dateobs = date_conv(dateobs,'FITS', BAD_DATE=bad_date) + IF ~bad_date THEN BEGIN + mjdtest = date_conv(dateobs,'MODIFIED') + IF N_mjd EQ 0 THEN mjdobs = mjdtest ELSE $ + IF ABS(mjdtest - mjdobs) GT 1 THEN MESSAGE, $ + 'DATE-OBS and MJD-OBS are inconsistent' + ENDIF ELSE dateobs = 'UNKNOWN' + ENDIF + + IF (coord EQ 'C' || coord EQ 'E' || coord EQ 'H') THEN BEGIN + IF N_rdsys EQ 0 THEN CASE eq_code OF + -1: radecsys = 'ICRS' ; default if no header info. + 0: radecsys = equinox GE 1984d0 ? 'FK5' : 'FK4' + 1: radecsys = equinox GE 1984d0 ? 'FK5' : 'FK4' + 2: radecsys = 'FK4' + 3: radecsys = 'FK5' + 4: ; shouldn't get here as implies radecsys exists. + else: MESSAGE, 'Internal error: unrecognised eq_code' + ENDCASE + ENDIF + +; Note that the dimensions and datatype of each tag must be explicit, so that +; there is no conflict with structure definitions from different FITS headers + + ASTR = {NAXIS:naxis, CD: cd, CDELT: cdelt, CRPIX: crpix, CRVAL: crval, $ + CTYPE: string(ctype), $ + LONGPOLE: double( longpole[0]), LATPOLE: double(latpole[0]), $ + PV2: pv2, PV1: pv1, $ + AXES: axes, REVERSE: flip, $ + COORD_SYS: coord, PROJECTION: proj, KNOWN: known, $ + RADECSYS: radecsys, EQUINOX: DOUBLE(equinox), $ + DATEOBS: dateobs, MJDOBS: DOUBLE(mjdobs), X0Y0: x0y0} + +; Check for any distortion keywords + + + case distort_flag of + 'SIP': begin + l = where(keyword EQ 'A_ORDER', N) + if N GT 0 then a_order = lvalue[l[N-1]] else a_order = 0 + l = where(keyword EQ 'B_ORDER', N) + if N GT 0 then b_order = lvalue[l[N-1]] else b_order = 0 + l = where(keyword EQ 'AP_ORDER', N) + if N GT 0 then ap_order = lvalue[l[N-1]] else ap_order = 0 + l = where(keyword EQ 'BP_ORDER', N) + if N GT 0 then bp_order = lvalue[l[N-1]] else bp_order = 0 + a = dblarr(a_order+1,a_order+1) + b = dblarr(b_order+1,b_order+1) + ap = dblarr(ap_order+1,ap_order+1) + bp = dblarr(bp_order+1,bp_order+1) + + for i=0, a_order do begin + for j=0, a_order do begin + l = where(keyword EQ 'A_' + strtrim(i,2) + '_' + strtrim(j,2), N) + if N GT 0 then a[i,j] = lvalue[l[N-1]] + endfor + endfor + + for i=0, b_order do begin + for j=0, b_order do begin + l = where(keyword EQ 'B_' + strtrim(i,2) + '_' + strtrim(j,2), N) + if N GT 0 then b[i,j] = lvalue[l[N-1]] + endfor + endfor + + for i=0, bp_order do begin + for j=0, bp_order do begin + l = where(keyword EQ 'BP_' + strtrim(i,2) + '_' + strtrim(j,2), N) + if N GT 0 then bp[i,j] = lvalue[l[N-1]] + endfor + endfor + + for i=0, ap_order do begin + for j=0, ap_order do begin + l = where(keyword EQ 'AP_' + strtrim(i,2) + '_' + strtrim(j,2), N) + if N GT 0 then ap[i,j] = lvalue[l[N-1]] + endfor + endfor + + distort = {name:distort_flag, a:a, b:b, ap:ap, bp:bp} + astr = create_struct(temporary(astr), 'distort', distort) + end + 'TPV': begin + distort = {name:'TPV', a:0.0d, b:0.0d, ap:0.0d, bp:0.0d} + astr = create_struct(temporary(astr), 'distort', distort) + end + 'TNX' : begin + distort = {name:'TNX', lngcor:lngcor, latcor:latcor} + astr = create_struct(temporary(astr), 'distort', distort) + end + '': + else: message,/con,'Unrecognized distortion acronym: ' + distort_flag + endcase + + return + end diff --git a/modules/idl_downloads/astro/pro/extgrp.pro b/modules/idl_downloads/astro/pro/extgrp.pro new file mode 100644 index 0000000..0764cef --- /dev/null +++ b/modules/idl_downloads/astro/pro/extgrp.pro @@ -0,0 +1,88 @@ +pro extgrp,hdr,par +;+ +; NAME: +; EXTGRP +; PURPOSE: +; Extract the group parameter information out of SXREAD output +; EXPLANATION: +; This procedure extracts the group parameter information out of a +; header and parameter variable obtained from SXREAD. This allows +; astrometry, photometry and other parameters to be easily SXPARed by +; conventional methods and allows the image and header to be saved in +; a SIMPLE format. +; +; CALLING SEQUENCE: +; ExtGrp, hdr, par +; +; INPUT: +; HDR - The header which is to be converted (input and output) +; PAR - The Parameter string returned from a call to SXREAD +; +; OUTPUT: +; HDR - The converted header, string array +; +; OTHER PROCEDURES CALLED: +; SXPAR(), SXADDPAR, SXGPAR(), STRN() +; +; HISTORY: +; 25-JUN-90 Version 1 written +; 13-JUL-92 Header finally added to this ancient procedure, code spiffed up +; a bit. Now 3 times faster. Added PTYPE comment inclusion. E. Deutsch +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + arg=n_params(0) + if (arg lt 2) then begin + print,'Call: IDL> EXTGRP,header,params_string' + print,"e.g.: IDL> EXTGRP,h,par" + return + endif + + h=hdr + pcount=sxpar(h,'PCOUNT') + if (pcount le 0) then begin + print,'[EXTGRP] Error: PCOUNT not >0 in header' + return + endif + + htmp=h & ih=0 + while (strmid(h[ih],0,4) ne 'PTYP') do ih=ih+1 + itmp=ih & stbyt=0 + hquick=strarr(4) & hquick[3]='END ' ; tiny temp. header for speed + + for t2=0,pcount-1 do begin + hquick=h[ih+3*t2:ih+3*t2+2] + + pty=sxpar(hquick,'PTYPE'+strn(t2+1)) + comment=strmid(hquick[0],30,50) + pdty=sxpar(hquick,'PDTYPE'+strn(t2+1)) + psz=sxpar(hquick,'PSIZE'+strn(t2+1))/8 + pvl=sxgpar(h,par,pty,pdty,stbyt,psz) + + sz=size(pvl) & stbyt=stbyt+psz + if (sz[1] eq 7) then pvl="'"+strn(pvl,length=18)+"'" + tmp=pty+'='+strn(pvl,length=21)+comment + + htmp[itmp]=tmp + itmp=itmp+1 + endfor + + while (strmid(h[ih],0,1) eq 'P') do ih=ih+1 + + while (strmid(h[ih],0,3) ne 'END') do begin + htmp[itmp]=h[ih] + itmp=itmp+1 + ih=ih+1 + endwhile + + htmp[itmp]=h[ih] + hdr=htmp[0:itmp] + + sxaddpar,hdr,'SIMPLE','T',' Group Parameters extracted' + sxaddpar,hdr,'PCOUNT',0,' All group parameters extracted' + sxaddpar,hdr,'PSIZE',0,' All group parameters extracted' + sxaddpar,hdr,'GROUPS','T' + sxaddpar,hdr,'GCOUNT',1,' Number of groups' + + return +end diff --git a/modules/idl_downloads/astro/pro/f_format.pro b/modules/idl_downloads/astro/pro/f_format.pro new file mode 100644 index 0000000..ba7814d --- /dev/null +++ b/modules/idl_downloads/astro/pro/f_format.pro @@ -0,0 +1,112 @@ +function f_format, minval, maxval, factor, length +;+ +; NAME: +; F_FORMAT +; PURPOSE: +; Choose a nice floating format for displaying an array of REAL data. +; EXPLANATION: +; Called by TVLIST, IMLIST. +; +; CALLING SEQUENCE: +; fmt = F_FORMAT( minval, maxval, factor, [ length ] ) +; +; INPUTS: +; MINVAL - REAL scalar giving the minimum value of an array of numbers +; for which one desires a nice format. +; MAXVAL - REAL scalar giving maximum value in array of numbers +; +; OPTIONAL INPUT: +; LENGTH - length of the output F format (default = 5) +; must be an integer scalar > 2 +; +; OUTPUT: +; FMT - an F or I format string, e.g. 'F5.1' +; FACTOR - factor of 10 by which to multiply array of numbers to achieve +; a pretty display using format FMT. +; +; EXAMPLE: +; Find a nice format to print an array of numbers with a minimum of 5.2e-3 +; and a maximum of 4.2e-2. +; +; IDL> fmt = F_FORMAT( 5.2e-3, 4.2e-2, factor ) +; +; yields fmt = '(F5.2)' and factor = .01, i.e. the array can be displayed +; with a F5.2 format after multiplication by 100. +; +; REVISION HISTORY: +; Written W. Landsman December 1988 +; Deal with factors < 1. August 1991 +; Deal with factors < 1. *and* a large range October 1992 +; Now returns In format rather than Fn.0 February, 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fix display problem for large negative numbers W. Landsman Mar 2016 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - fmt = F_FORMAT( minval, maxval, factor, [ length ])' + return,'' + endif + + if N_params() LT 4 then length = 5 else length = length > 2 + factor = 1. + + RANGE: if ( maxval GT 0) then begin + mxlog = fix( alog10( maxval ) ) + mxval = (mxlog>0) + 1 + endif else if ( maxval LT 0) then begin + mxlog = fix( alog10( abs( maxval ) ) ) + mxval = (mxlog>0) + 2 + endif else begin + mxlog = 0 + mxval = 1 + endelse + + if ( minval GT 0 ) then begin + mnlog = fix( alog10( minval )) + mnval = (mnlog>0) + 1 + endif else if ( minval LT 0) then begin + mnlog = fix(alog10(abs(minval))) + mnval = (mnlog>0) + 2 + endif else begin + mnlog = 0 + mnval = 1 + endelse + + if ( mnlog LT 0 ) and ( mxlog LT 0 ) then begin ;All numbers are < 1.0 + expon = max( [ mnlog,mxlog ] ) -1 + factor = factor*10.^(expon) + maxval = maxval / factor + minval = minval / factor + goto, RANGE + endif + + dif = abs( mxlog - mnlog ) + if ( dif GE length-3 ) then begin + mxlen = max([mnlog,mxlog]) + factor = factor*10.^(mxlen-(length-3)) + abs = 0 + + endif else begin + + TEST: tpairv = abs( [mxval,mnval] ) + test = max( tpairv ) + + if ( test LE length-3 ) then begin ;No factor needed + abs = length - test - 2 + endif else begin + expon = min( [mxlog, mnlog] ) + if expon EQ 0 then expon = 1 ;Avoid infinite loop + factor = factor*10.^(expon) + mxval -= expon + mnval -= expon + goto, TEST + endelse + endelse + + if abs EQ 0 then begin + factor = factor/10 + return,'I' + strtrim(length,2) + endif else return,'F' + strtrim( length, 2 ) + '.' + strtrim( abs, 2 ) + + end diff --git a/modules/idl_downloads/astro/pro/factor.pro b/modules/idl_downloads/astro/pro/factor.pro new file mode 100644 index 0000000..683932b --- /dev/null +++ b/modules/idl_downloads/astro/pro/factor.pro @@ -0,0 +1,277 @@ +;------------------------------------------------------------- +;+ +; NAME: +; FACTOR +; PURPOSE: +; Find prime factors of a given number. +; CATEGORY: +; CALLING SEQUENCE: +; factor, x, p, n +; INPUTS: +; x = Number to factor (>1). in +; KEYWORD PARAMETERS: +; Keywords: +; /QUIET means do not print factors. +; /DEBUG Means list steps as they happen. +; /TRY Go beyond 20000 primes. +; OUTPUTS: +; p = Array of prime numbers. out +; n = Count of each element of p. out +; COMMON BLOCKS: +; NOTES: +; Note: see also prime, numfactors, print_fact. +; MODIFICATION HISTORY: +; R. Sterner. 4 Oct, 1988. +; RES 25 Oct, 1990 --- converted to IDL V2. +; R. Sterner, 1999 Jun 30 --- Improved (faster, bigger). +; R. Sterner, 1999 Jul 7 --- Bigger values (used unsigned). +; R. Sterner, 1999 Jul 9 --- Tried to make backward compatable. +; R. Sterner, 2000 Jan 06 --- Fixed to ignore non-positive numbers. +; Johns Hopkins University Applied Physics Laboratory. +; +; Copyright (C) 1988, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;- +;------------------------------------------------------------- +; NAME: +; SPC +; PURPOSE: +; Return a string with the specified number of spaces (or other char). +; CATEGORY: +; CALLING SEQUENCE: +; s = spc(n, [text]) +; INPUTS: +; n = number of spaces (= string length). in +; text = optional text string. in +; # spaces returned is n-strlen(strtrim(text,2)) +; KEYWORD PARAMETERS: +; Keywords: +; CHARACTER=ch Character other than a space. +; Ex: CHAR='-'. +; /NOTRIM means do not do a strtrim on text. +; OUTPUTS: +; s = resulting string. out +; COMMON BLOCKS: +; NOTES: +; Note: Number of requested spaces is reduced by the +; length of given string. Useful for text formatting. +; MODIFICATION HISTORY: +; Written by R. Sterner, 16 Dec, 1984. +; RES --- rewritten 14 Jan, 1986. +; R. Sterner, 27 Jun, 1990 --- added text. +; R. Sterner, 1994 Sep 7 --- Allowed text arrays. +; R. Sterner, 1999 Jul 2 --- Added /NOTRIM keyword. +; Johns Hopkins University Applied Physics Laboratory. +; +; Copyright (C) 1984, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;------------------------------------------------------------- + + function spc,n, text, character=char, notrim=notrim, help=hlp + + if (n_params(0) lt 1) or keyword_set(hlp) then begin + print,' Return a string with the specified number of spaces (or '+$ + 'other char).' + print,' s = spc(n, [text])' + print, ' n = number of spaces (= string length). in ' + print,' text = optional text string. in' + print,' # spaces returned is n-strlen(strtrim(text,2))' + print,' s = resulting string. out' + print,' Keywords:' + print,' CHARACTER=ch Character other than a space.' + print," Ex: CHAR='-'." + print,' /NOTRIM means do not do a strtrim on text.' + print,' Note: Number of requested spaces is reduced by the' + print,' length of given string. Useful for text formatting.' + return, -1 + endif + + if n_params(0) eq 1 then begin + n2 = n + endif else begin + if keyword_set(notrim) then $ + ntxt=strlen(text) else ntxt=strlen(strtrim(text,2)) +; n2 = n - strlen(strtrim(text,2)) + n2 = n - ntxt + endelse + + ascii = 32B + if n_elements(char) ne 0 then ascii = (byte(char))[0] + + num = n_elements(n2) + out = strarr(num) + for i = 0, num-1 do begin + if n2[i] le 0 then out[i] = '' else $ + out[i] = string(bytarr(n2[i]) + ascii) + endfor + + if n_elements(out) eq 1 then out=out[0] + return, out + + end + + +;------------------------------------------------------------- +; NAME: +; PRINT_FACT +; PURPOSE: +; Print prime factors found by the factor routine. +; CATEGORY: +; CALLING SEQUENCE: +; print_fact, p, n +; INPUTS: +; p = prime factors. in +; n = number of each factor. in +; KEYWORD PARAMETERS: +; OUTPUTS: +; COMMON BLOCKS: +; NOTES: +; MODIFICATION HISTORY: +; R. Sterner 4 Oct, 1988. +; RES 25 Oct, 1990 --- converted to IDL V2. +; R. Sterner, 26 Feb, 1991 --- Renamed from print_factors.pro +; R. Sterner, 1999 Jun 30 --- Better output format. +; R. Sterner, 1999 Jul 7 --- Bigger values (used unsigned). +; R. Sterner, 1999 Jul 9 --- Made backward compatable. +; +; Copyright (C) 1988, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;------------------------------------------------------------- + + pro print_fact, p, n, help=hlp + + if (n_params(0) lt 2) or keyword_set(hlp) then begin + print,' Print prime factors found by the factor routine.' + print,' print_fact, p, n' + print,' p = prime factors. in' + print,' n = number of each factor. in' + return + endif + + ;------- Drop unused primes --------------- + w = where(n gt 0) ; Find only primes used. + p2 = p[w] + n2 = n[w] + + ;------- Use largest available integer type -------------- + flag = !version.release ge 5.2 + if flag eq 1 then begin + err=execute('t=1ULL') ; Use 64 bit int (hide from old IDL). + endif else begin + t = 1L ; Use long int (best available in old). + endelse + + ;------- Compute number from it's prime factors. ---------- + for i = 0, n_elements(p2)-1 do t = t * p2[i]^n2[i] + + ;------- Prepare output ----------------------- + a = strtrim(t,2)+' = ' ; Start factors string. + b = '' ; Start exponents string. + last = n_elements(p2)-1 ; Last factors index. + for i=0, last do begin + a = a + strtrim(p2[i],2) ; Insert next factor. + lena = strlen(a) ; Length of factor string. + nxtb = strtrim(n2[i],2) ; Next exponent. + if nxtb eq '1' then nxtb=' ' ; Weed out 1s. + b = b+spc(lena,b,/notrim)+nxtb ; Insert next exponent. + if i ne last then a=a+' x ' ; Not last, add x. + endfor + + ;------ Print exponents and factors ----------- + print,' ' + print,' '+b + print,' '+a + + return + end + + + + pro factor, x, p, n, quiet=quiet, debug=debug, try=try, help=hlp + + if (n_params(0) lt 1) or keyword_set(hlp) then begin + print,' Find prime factors of a given number.' + print,' factor, x, p, n' + print,' x = Number to factor (>1). in' + print,' p = Array of prime numbers. out' + print,' n = Count of each element of p. out' + print,' Keywords:' + print,' /QUIET means do not print factors.' + print,' /DEBUG Means list steps as they happen.' + print,' /TRY Go beyond 20000 primes.' + print,' Note: see also prime, numfactors, print_fact.' + return + endif + + if x le 0 then return + + flag = !version.release ge 5.2 + + s = sqrt(x) ; Only need primes up to sqrt(x). + g = long(50 + 0.13457*s) ; Upper limit of # primes up to s. + np = 50 ; Start with np (50) primes. + p = prime(np) ; Find np primes. + n = intarr(n_elements(p)) ; Divisor count. + + if flag eq 1 then $ ; Working number. + err=execute('t=ulong64(x)') $ ; Use best integer available. + else t=long(x) ; Best pre-5.2 integer. + i = 0L ; Index of test prime. + +loop: pt = p[i] ; Pull test prime. + if keyword_set(debug) then $ + print,' Trying '+strtrim(pt,2)+' into '+strtrim(t,2) + if flag eq 1 then $ + err=execute('t2=ulong64(t/pt)') $ + else t2=long(t/pt) + if t eq t2*pt then begin ; Check if it divides. + if keyword_set(debug) then $ + print,' Was a factor. Now do '+strtrim(t2,2) + n[i] = n[i] + 1 ; Yes, count it. + t = t2 ; Result after division. + if t2 eq 1 then goto, done ; Check if done. + goto, loop ; Continue. + endif else begin + i = i + 1 ; Try next prime. + if i ge np then begin + s = sqrt(t) ; Only need primes up to sqrt(x). + g = long(50 + 0.13457*s) ; Upper limit of # primes up to s. + if g le np then goto, last ; Must be done. + np = (np+50) FDECOMP, file, disk, dir, name, qual +; will return the following +; +; Disk Dir Name Qual +; Unix: '' '/itt/idl71/' 'avg' 'pro' +; Windows: 'd:' \itt\idl71\ 'avg' 'pro' +; +; NOTES: +; (1) The period is removed between the name and qualifier +; (2) Unlike the intrinsic FILE_BASENAME() and FILE_DIRNAME() functions, +; one can use FDECOMP to decompose a Windows file name on a Unix machine +; or a Unix filename on a Windows machine. +; +; ROUTINES CALLED: +; None. +; HISTORY +; version 1 D. Lindler Oct 1986 +; Include VMS DECNET machine name in disk W. Landsman HSTX Feb. 94 +; Converted to Mac IDL, I. Freedman HSTX March 1994 +; Major rewrite to accept vector filenames V5.3 W. Landsman June 2000 +; Fix cases where disk name not always present W. Landsman Sep. 2000 +; Make sure version defined for Windows W. Landsman April 2004 +; Include final delimiter in directory under Windows as advertised +; W. Landsman May 2006 +; Remove VMS support, W. Landsman September 2006 +; Remove MacOS branch (same as Unix) W. Landsman August 2009 +;- +;-------------------------------------------------------- +; + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 2 then begin + print, 'Syntax - FDECOMP, filename, disk, [dir, name, qual ] ' + return + endif + + + if ~keyword_set(osfamily) then osfamily = !Version.OS_Family + st = filename + disk = st + replicate_inplace,disk,'' + dir = disk + qual = disk + + + if OSFAMILY EQ "Windows" then begin + + lpos = strpos( st, ':') ; DOS diskdrive (i.e. c:) + good = where(lpos GT 0, Ngood) + if Ngood GT 0 then begin + stg = st[good] + lpos = reform( lpos[good], 1, Ngood) + disk[good] = strmid( stg, 0, lpos+1) + st[good] = strmid(stg,lpos+1 ) + endif + +; Search the path name (i.e. \dos\idl\) and locate last backslash + + lpos = strpos(st,'\',/reverse_search) + good = where(lpos Gt 0, Ngood) + + + endif ELSE begin ;Unix + + +; Unix directory name ends at last slash + + lpos = strpos(st,'/',/reverse_search) + good = where(lpos GE 0, Ngood) + + endelse + + if Ngood GT 0 then begin ;Extract directory name if present + stg = st[good] + lpos = reform( lpos[good],1, Ngood ) + + dir[good] = strmid(stg,0, lpos+1) + st[good] = strmid(stg,lpos+1 ) + endif + +; get name and qualifier (extension)...qual is optional + + lpos = strpos(st,'.',/reverse_search) + good = where(lpos GE 0, Ngood) + name = st + + if Ngood GT 0 then begin + stg = st[good] + lpos = reform(lpos[good], 1, Ngood) + + name[good] = strmid(stg,0,lpos ) + qual[good] = strmid(stg,lpos+1 ) + endif + + + return + end diff --git a/modules/idl_downloads/astro/pro/file_launch.pro b/modules/idl_downloads/astro/pro/file_launch.pro new file mode 100644 index 0000000..3cf2677 --- /dev/null +++ b/modules/idl_downloads/astro/pro/file_launch.pro @@ -0,0 +1,108 @@ +; docformat = 'rst' +;+ +; NAME: +; FILE_LAUNCH +; +; PURPOSE: +; Launch a file using the default application of the operating system +; +; EXPLANATION: +; The FILE_LAUNCH procedure procedure will launch a file (e.g. a .pdf, .docx or .html +; file) using the default application of the operating system. By default, it +; first tries to use the Java desktop class. +; https://docs.oracle.com/javase/tutorial/uiswing/misc/desktop.html +; If this fails, it uses the appropriate Spawn command for the oS to launch +; +; CALLING SEQUENCE: +; file_launch, file, [ buseJava, ojDesktop = ojDesktop, /QUIET ] +; +; INPUT PARMAMTER: +; file: in, required, type=string +; scalar filename (with path if required) to launch +; +; OPTIONAL INPUT KEYWORD: +; bUseJava: in, optional, type=boolean, default=1 +; Flag to indicate if java should be used to launch browser. +; True by default. Routine falls back to spawn commands if desktop is +; not supported. +; +; /NoWait - if set, then if using Spawn, wait for the command to return +; This is slower but is useful for debugging +; +; /quiet - if set, then don't print a message when forced to use SPAWN +; +; OPTIONAL OUTPUT KEYWORD: +; ojDesktop : in, out, optional, type=object +; reference to a java AWT desktop instance +; +; EXAMPLE: +; +; Open a PDF file test.pdf in the current directory +; IDL> file_launch, 'test.pdf' +; +; +; HISTORY: +; First release W. Landsman March 2016 +; Heavily based on code by Derek Sabatke +; +;- +;----------------------------------------------------------------------------- + +pro file_launch, file, ojDesktop = ojDesktop, bUseJava = bUseJava, quiet=quiet, $ + Nowait = nowait + COMPILE_OPT idl2, HIDDEN + + if ~file_test(file) then begin + message,/CON,'ERROR -- File not found ' + file + return + endif + ;set option defaults + setdefaultvalue, bUseJava, 1L + setdefaultvalue, NoWait, 0 + + Catch,theError + if theError NE 0 then begin + Catch,/Cancel + if bUseJava EQ 1 then bUseJava = 0 else begin ;If Java failed then use Spawn + void = cgErrorMsg(/quiet) + return + endelse + endif + + ;initialize variables + if bUseJava && ((N_elements(ojDesktop) eq 0) || (~obj_valid(ojDesktop))) then begin + oJavaAWTDesktop = OBJ_NEW('IDLJavaObject$Static$JAVA_AWT_DESKTOP', 'java.awt.Desktop') + if oJavaAWTDesktop.isDesktopSupported() then ojDesktop = ojavaAWTDesktop.getDesktop() $ + else bUseJava = 0L + endif + + if bUseJava && ojDesktop.isDesktopSupported() then begin ; have java do the launching if possible + if !VERSION.OS_FAMILY NE 'WINDOWS' then fname = file_search(file,/full) $ + else fname = file + sCleanOutputFN = strjoin(strsplit(fname, '\\', /extract), '/') ;purge (possible) backslashes + oJURI = OBJ_NEW('IDLJavaObject$Static$JAVA_NET_URI', 'java.net.URI') + oJString = OBJ_NEW('IDLJavaObject$JAVA_LANG_STRING', 'java.lang.String', 'file://'+sCleanOutputFN) + oURI = oJURI.create(oJString) + + ojDesktop.browse, oURI + + endif else begin; no java, so try spawning a command + if ~keyword_set(quiet) then message,'Using Spawn',/INF + if !VERSION.OS_NAME EQ 'Mac OS X' then begin + cmd = 'open "'+ file +'" ' + if ~nowait then cmd += '&' + spawn,cmd + endif else begin + case StrUpCase(!Version.OS_Family) OF + 'WINDOWS': spawn, 'start "" "'+ file +'"', nowait = nowait + 'UNIX': begin + cmd = 'xdg-open "'+ file +'" ' + if ~nowait then cmd+= '&' + spawn,cmd + end + else: print, 'Unable to launch ' + file + ' automatically.' + endcase + endelse + + endelse +end diff --git a/modules/idl_downloads/astro/pro/filter_image.pro b/modules/idl_downloads/astro/pro/filter_image.pro new file mode 100644 index 0000000..22e9c56 --- /dev/null +++ b/modules/idl_downloads/astro/pro/filter_image.pro @@ -0,0 +1,196 @@ +function filter_image, image, SMOOTH=width_smooth, ITERATE_SMOOTH=iterate, $ + MEDIAN=width_median, ALL_PIXELS=all_pixels, $ + FWHM_GAUSSIAN=fwhm, NO_FT_CONVOL=no_ft, PSF=psf +;+ +; NAME: +; FILTER_IMAGE +; +; PURPOSE: +; Identical to MEDIAN or SMOOTH but handle edges and allow iterations. +; EXPLANATION: +; Computes the average and/or median of pixels in moving box, +; replacing center pixel with the computed average and/or median, +; (using the IDL SMOOTH() or MEDIAN() functions). +; The main reason for using this function is the options to +; also process the pixels at edges and corners of image, and, +; to apply iterative smoothing simulating convolution with Gaussian, +; and/or to convolve image with a Gaussian kernel. Users might also +; look at the function ESTIMATOR_FILTER() introduced in IDL 7.1. +; +; CALLING SEQUENCE: +; Result = filter_image( image, SMOOTH=width, MEDIAN = width, /ALL_PIXELS +; /ITERATE, FWHM =, /NO_FT_CONVOL) +; +; INPUT: +; image = 2-D array (matrix) +; +; OPTIONAL INPUT KEYWORDS: +; SMOOTH = scalar (odd) integer specifying the width of a square box +; for moving average, in # pixels. /SMOOTH means use box +; width = 3 pixels for smoothing. +; +; MEDIAN = scalar (usually odd) integer specifying the width of square +; moving box for median filter, in # pixels. /MEDIAN means use +; box width = 3 pixels for median filter. +; +; /ALL_PIXELS causes the edges of image to be filtered as well. This +; is accomplished by reflecting pixels adjacent to edges outward +; (similar to the /EDGE_WRAP keyword in CONVOL). +; Note that this is a different algorithm from the /EDGE_TRUNCATE +; keyword to SMOOTH or CONVOL, which duplicates the nearest pixel. +; +; /ITERATE means apply smooth(image,3) iteratively for a count of +; (box_width-1)/2 times (=radius), when box_width >= 5. +; This is equivalent to convolution with a Gaussian PSF +; of FWHM = 2 * sqrt( radius ) as radius gets large. +; Note that /ALL_PIXELS is automatically applied, +; giving better results in the iteration limit. +; (also, MEDIAN keyword is ignored when /ITER is specified). +; +; FWHM_GAUSSIAN = Full-width half-max of Gaussian to convolve with image. +; FWHM can be a single number (circular beam), +; or 2 numbers giving axes of elliptical beam. +; +; /NO_FT_CONVOL causes the convolution to be computed directly, +; with intrinsic IDL CONVOL function. The default is to use +; FFT when factors of size are all LE 13. Note that +; external function convolve.pro handles both cases) +; +; OPTIONAL INPUT/OUTPUT KEYWORD: +; PSF = Array containing the PSF used during the convolution. This +; keyword is only active if the FWHM_GAUSSIAN keyword is also +; specified. If PSF is undefined on input, then upon output it +; contains the Gaussian convolution specified by the FWHM_GAUSSIAN +; keyword. If the PSF array is defined on input then it is used +; as the convolution kernel, the value of the FWHM_GAUSSIAN keyword +; is ignored. Typically, on a first call set PSF to an undefined +; variable, which can be reused for subsequent calls to prevent +; recalculation of the Gaussian PSF. +; RESULT: +; Function returns the smoothed, median filtered, or convolved image. +; If both SMOOTH and MEDIAN are specified, median filter is applied first. +; If only SMOOTH is applied, then output is of same type as input. If +; either MEDIAN or FWHM_GAUSSIAN is supplied than the output is at least +; floating (double if the input image is double). +; +; EXAMPLES: +; To apply 3x3 moving median filter and +; then 3x3 moving average, both applied to all pixels: +; +; Result = filter_image( image, /SMOOTH, /MEDIAN, /ALL ) +; +; To iteratively apply 3x3 moving average filter for 4 = (9-1)/2 times, +; thus approximating convolution with Gaussian of FWHM = 2*sqrt(4) = 4 : +; +; Result = filter_image( image, SMOOTH=9, /ITER ) +; +; To convolve all pixels with Gaussian of FWHM = 3.7 x 5.2 pixels: +; +; Result = filter_image( image, FWHM=[3.7,5.2], /ALL ) +; +; EXTERNAL CALLS: +; function psf_gaussian +; function convolve +; pro factor +; function prime ;all these called only if FWHM is specified +; +; PROCEDURE: +; If both /ALL_PIXELS (or /ITERATE) keywords are set then +; create a larger image by reflecting the edges outward, then call the +; IDL MEDIAN() or SMOOTH() function on the larger image, and just return +; the central part (the original size image). +; +; NAN values are recognized during calls to MEDIAN() or SMOOTH(), but +; not for convolution with a Gaussian (FWHM keyword supplied). +; HISTORY: +; Written, 1991, Frank Varosi, NASA/GSFC. +; FV, 1992, added /ITERATE option. +; FV, 1993, added FWHM_GAUSSIAN= option. +; Use /EVEN call to median, recognize NAN values in SMOOTH +; W. Landsman June 2001 +; Added PSF keyword, Bjorn Heijligers/WL, September 2001 +; Keep same output data type if /ALL_PIXELS supplied A. Steffl Mar 2011 +;- + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - Result = filter_image( image, SMOOTH=width, /ALL_PIXELS' + print,' MEDIAN= width, ITERATE, FWHM=, /NO_FT_CONVOL' + return, -1 + endif + + sim = size( image ) + Lx = sim[1]-1 + Ly = sim[2]-1 + + if (sim[0] NE 2) || (sim[4] LE 4) then begin + message,"input must be an image (a matrix)",/INFO + return,image + endif + + if keyword_set( iterate ) then begin + if N_elements( width_smooth ) NE 1 then return,image + if (width_smooth LT 1) then return,image + imf = image + nit = (width_smooth>3)/2 + for i=1,nit do imf = filter_image( imf, /SMOOTH, /ALL ) + return,imf + endif + + box_wid = 0 + if keyword_set( width_smooth ) then box_wid = width_smooth > 3 + if keyword_set( width_median ) then box_wid = (width_median > box_wid)>3 + + if keyword_set( fwhm ) then begin + npix = ( 3 * fwhm[ 0: ( (N_elements( fwhm )-1) < 1 ) ] ) > 3 + npix = 2 * fix( npix/2 ) + 1 ;make # pixels odd. + box_wid = box_wid > max( [npix] ) + endif + + if (box_wid LT 3) then return, image + + if keyword_set(all_pixels) then begin + + box_wid = fix( box_wid ) + radius = (box_wid/2) > 1 + Lxr = Lx+radius + Lyr = Ly+radius + rr = 2*radius + imf = make_array(sim[1]+rr, sim[2]+rr, type = sim[3]) + imf[radius,radius] = image ; reflect edges outward + ; to make larger image. + imf[ 0,0] = rotate( imf[radius:rr,*], 5 ) ;Left + imf[Lxr,0] = rotate( imf[Lx:Lxr,*], 5 ) ;right + imf[0, 0] = rotate( imf[*,radius:rr], 7 ) ;bottom + imf[0,Lyr] = rotate( imf[*,Ly:Lyr], 7 ) ;top + + endif else begin + radius=0 + imf = image + endelse + + if keyword_set( width_median ) then $ + imf = median(/even, imf, width_median>3 ) + + if keyword_set( width_smooth ) then $ + imf = smooth( imf, width_smooth>3, /NAN ) + + if keyword_set( fwhm ) then begin + + if N_elements( no_ft ) NE 1 then begin + sim = size( imf ) + factor,sim[1],pfx,nfx,/quiet + factor,sim[2],pfy,nfy,/quiet + no_ft = max( [pfx,pfy] ) GT 13 + endif + + if N_elements(PSF) EQ 0 then $ + psf=psf_gaussian( NP=npix,FWHM=fwhm,/NORM ) + + imf = convolve( imf, NO_FT=no_ft, psf) + endif + + if radius GT 0 then $ + return, imf[ radius:(Lx+radius), radius:(Ly+radius) ] $ + else return, imf +end diff --git a/modules/idl_downloads/astro/pro/find.pro b/modules/idl_downloads/astro/pro/find.pro new file mode 100644 index 0000000..f1ed8d1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/find.pro @@ -0,0 +1,464 @@ +pro find, image, x, y, flux, sharp, roundness, hmin, fwhm, roundlim, sharplim,$ + PRINT = print, SILENT=silent, MONITOR= monitor +;+ +; NAME: +; FIND +; PURPOSE: +; Find positive brightness perturbations (i.e stars) in an image +; EXPLANATION: +; Also returns centroids and shape parameters (roundness & sharpness). +; Adapted from 1991 version of DAOPHOT, but does not allow for bad pixels +; and uses a slightly different centroid algorithm. +; +; Modified in March 2008 to use marginal Gaussian fits to find centroids +; CALLING SEQUENCE: +; FIND, image, [ x, y, flux, sharp, round, hmin, fwhm, roundlim, sharplim +; PRINT= , /SILENT, /MONITOR] +; +; INPUTS: +; image - 2 dimensional image array (integer or real) for which one +; wishes to identify the stars present +; +; OPTIONAL INPUTS: +; FIND will prompt for these parameters if not supplied +; +; hmin - Threshold intensity for a point source - should generally +; be 3 or 4 sigma above background RMS +; fwhm - FWHM (in pixels) to be used in the convolve filter +; sharplim - 2 element vector giving low and high cutoff for the +; sharpness statistic (Default: [0.2,1.0] ). Change this +; default only if the stars have significantly larger or +; or smaller concentration than a Gaussian +; roundlim - 2 element vector giving low and high cutoff for the +; roundness statistic (Default: [-1.0,1.0] ). Change this +; default only if the stars are significantly elongated. +; +; OPTIONAL INPUT KEYWORDS: +; /MONITOR - Normally, FIND will display the results for each star +; only if no output variables are supplied. Set /MONITOR +; to always see the result of each individual star. +; /SILENT - set /SILENT keyword to suppress all output display +; PRINT - if set and non-zero then FIND will also write its results to +; a file find.prt. Also one can specify a different output file +; name by setting PRINT = 'filename'. +; +; OPTIONAL OUTPUTS: +; x - vector containing x position of all stars identified by FIND +; y- vector containing y position of all stars identified by FIND +; flux - vector containing flux of identified stars as determined +; by a Gaussian fit. Fluxes are NOT converted to magnitudes. +; sharp - vector containing sharpness statistic for identified stars +; round - vector containing roundness statistic for identified stars +; +; NOTES: +; (1) The sharpness statistic compares the central pixel to the mean of +; the surrounding pixels. If this difference is greater than the +; originally estimated height of the Gaussian or less than 0.2 the height of the +; Gaussian (for the default values of SHARPLIM) then the star will be +; rejected. +; +; (2) More recent versions of FIND in DAOPHOT allow the possibility of +; ignoring bad pixels. Unfortunately, to implement this in IDL +; would preclude the vectorization made possible with the CONVOL function +; and would run extremely slowly. +; +; (3) Modified in March 2008 to use marginal Gaussian distributions to +; compute centroid. (Formerly, find.pro determined centroids by locating +; where derivatives went to zero -- see cntrd.pro for this algorithm. +; This was the method used in very old (~1984) versions of DAOPHOT. ) +; As discussed in more detail in the comments to the code, the centroid +; computation here is the same as in IRAF DAOFIND but differs slightly +; from the current DAOPHOT. +; PROCEDURE CALLS: +; GETOPT() +; REVISION HISTORY: +; Written W. Landsman, STX February, 1987 +; ROUND now an internal function in V3.1 W. Landsman July 1993 +; Change variable name DERIV to DERIVAT W. Landsman Feb. 1996 +; Use /PRINT keyword instead of TEXTOUT W. Landsman May 1996 +; Changed loop indices to type LONG W. Landsman Aug. 1997 +; Replace DATATYPE() with size(/TNAME) W. Landsman Nov. 2001 +; Fix problem when PRINT= filename W. Landsman October 2002 +; Fix problems with >32767 stars D. Schlegel/W. Landsman Sep. 2004 +; Fix error message when no stars found S. Carey/W. Landsman Sep 2007 +; Rewrite centroid computation to use marginal Gaussians W. Landsman +; Mar 2008 +; Added Monitor keyword, /SILENT now suppresses all output +; W. Landsman Nov 2008 +; Work when threshold is negative (difference images) W. Landsman May 2010 +;- +; + On_error,2 ;Return to caller + compile_opt idl2 + + npar = N_params() + if npar EQ 0 then begin + print,'Syntax - FIND, image,' + $ + '[ x, y, flux, sharp, round, hmin, fwhm, roundlim, sharplim' + print,' PRINT= , /SILENT, /MONITOR ]' + return + endif +;Determine if hardcopy output is desired + doprint = keyword_set( PRINT) + silent = keyword_set( SILENT ) + if N_elements(monitor) EQ 0 then $ + monitor = (not silent) and (not arg_present(flux) ) + + maxbox = 13 ;Maximum size of convolution box in pixels + +; Get information about the input image + + type = size(image) + if ( type[0] NE 2 ) then message, $ + 'ERROR - Image array (first parameter) must be 2 dimensional' + n_x = type[1] & n_y = type[2] + message, NoPrint=Silent, $ + 'Input Image Size is '+strtrim(n_x,2) + ' by '+ strtrim(n_y,2),/INF + + if ( N_elements(fwhm) NE 1 ) then $ + read, 'Enter approximate FWHM: ', fwhm + if fwhm LT 0.5 then message, $ + 'ERROR - Supplied FWHM must be at least 0.5 pixels' + + radius = 0.637*FWHM > 2.001 ;Radius is 1.5 sigma + radsq = radius^2 + nhalf = fix(radius) < (maxbox-1)/2 ; + nbox = 2*nhalf + 1 ;# of pixels in side of convolution box + middle = nhalf ;Index of central pixel + + lastro = n_x - nhalf + lastcl = n_y - nhalf + sigsq = ( fwhm/2.35482 )^2 + mask = bytarr( nbox, nbox ) ;Mask identifies valid pixels in convolution box + g = fltarr( nbox, nbox ) ;g will contain Gaussian convolution kernel + + dd = indgen(nbox-1) + 0.5 - middle ;Constants need to compute ROUND + dd2 = dd^2 + + row2 = (findgen(Nbox)-nhalf)^2 + + for i = 0, nhalf do begin + temp = row2 + i^2 + g[0,nhalf-i] = temp + g[0,nhalf+i] = temp + endfor + + + mask = fix(g LE radsq) ;MASK is complementary to SKIP in Stetson's Fortran + good = where( mask, pixels) ;Value of c are now equal to distance to center + +; Compute quantities for centroid computations that can be used for all stars + g = exp(-0.5*g/sigsq) + +; In fitting Gaussians to the marginal sums, pixels will arbitrarily be +; assigned weights ranging from unity at the corners of the box to +; NHALF^2 at the center (e.g. if NBOX = 5 or 7, the weights will be +; +; 1 2 3 4 3 2 1 +; 1 2 3 2 1 2 4 6 8 6 4 2 +; 2 4 6 4 2 3 6 9 12 9 6 3 +; 3 6 9 6 3 4 8 12 16 12 8 4 +; 2 4 6 4 2 3 6 9 12 9 6 3 +; 1 2 3 2 1 2 4 6 8 6 4 2 +; 1 2 3 4 3 2 1 +; +; respectively). This is done to desensitize the derived parameters to +; possible neighboring, brighter stars. + + + xwt = fltarr(nbox,nbox) + wt = nhalf - abs(findgen(nbox)-nhalf ) + 1 + for i=0,nbox-1 do xwt[0,i] = wt + ywt = transpose(xwt) + sgx = total(g*xwt,1) + p = total(wt) + sgy = total(g*ywt,2) + sumgx = total(wt*sgy) + sumgy = total(wt*sgx) + sumgsqy = total(wt*sgy*sgy) + sumgsqx = total(wt*sgx*sgx) + vec = nhalf - findgen(nbox) + dgdx = sgy*vec + dgdy = sgx*vec + sdgdxs = total(wt*dgdx^2) + sdgdx = total(wt*dgdx) + sdgdys = total(wt*dgdy^2) + sdgdy = total(wt*dgdy) + sgdgdx = total(wt*sgy*dgdx) + sgdgdy = total(wt*sgx*dgdy) + + + c = g*mask ;Convolution kernel now in c + sumc = total(c) + sumcsq = total(c^2) - sumc^2/pixels + sumc = sumc/pixels + c[good] = (c[good] - sumc)/sumcsq + c1 = exp(-.5*row2/sigsq) + sumc1 = total(c1)/nbox + sumc1sq = total(c1^2) - sumc1 + c1 = (c1-sumc1)/sumc1sq + + message,/INF,Noprint=Silent, $ + 'RELATIVE ERROR computed from FWHM ' + strtrim(sqrt(total(c[good]^2)),2) + if N_elements(hmin) NE 1 then read, $ + 'Enter minimum value above background for threshold detection: ',hmin + + if N_elements(sharplim) NE 2 then begin + print,'Enter low and high cutoffs, press [RETURN] for defaults:' +GETSHARP: + ans = '' + read, 'Image Sharpness Statistic (DEFAULT = 0.2,1.0): ', ans + if ans EQ '' then sharplim = [0.2,1.0] else begin + sharplim = getopt(ans,'F') + if N_elements(sharplim) NE 2 then begin + message, 'ERROR - Expecting 2 scalar values',/CON + goto, GETSHARP + endif + endelse + +GETROUND: + ans = '' + read, 'Image Roundness Statistic [DEFAULT = -1.0,1.0]: ',ans + if ans EQ '' then roundlim = [-1.,1.] else begin + roundlim = getopt( ans, 'F' ) + if N_elements( roundlim ) NE 2 then begin + message,'ERROR - Expecting 2 scalar values',/CON + goto, GETROUND + endif + endelse + endif + + message,'Beginning convolution of image', /INF, NoPrint=Silent + + h = convol(float(image),c) ;Convolve image with kernel "c" + + minh = min(h) + h[0:nhalf-1,*] = minh & h[n_x-nhalf:n_x-1,*] = minh + h[*,0:nhalf-1] = minh & h[*,n_y-nhalf:n_y-1] = minh + + message,'Finished convolution of image', /INF, NoPrint=Silent + + mask[middle,middle] = 0 ;From now on we exclude the central pixel + pixels = pixels -1 ;so the number of valid pixels is reduced by 1 + good = where(mask) ;"good" identifies position of valid pixels + xx= (good mod nbox) - middle ;x and y coordinate of valid pixels + yy = fix(good/nbox) - middle ;relative to the center + offset = yy*n_x + xx +SEARCH: ;Threshold dependent search begins here + + index = where( h GE hmin, nfound) ;Valid image pixels are greater than hmin + if nfound EQ 0 then begin ;Any maxima found? + + message,'ERROR - No maxima exceed input threshold of ' + $ + string(hmin,'(F9.1)'),/CON + goto,FINISH + + endif + + for i= 0L, pixels-1 do begin + + stars = where (h[index] GE h[index+offset[i]], nfound) + if nfound EQ 0 then begin ;Do valid local maxima exist? + message,'ERROR - No maxima exceed input threshold of ' + $ + string(hmin,'(F9.1)'),/CON + goto,FINISH + endif + index = index[stars] + + endfor + + ix = index mod n_x ;X index of local maxima + iy = index/n_x ;Y index of local maxima + ngood = N_elements(index) + message,/INF,Noprint=Silent, $ + strtrim(ngood,2)+' local maxima located above threshold' + + nstar = 0L ;NSTAR counts all stars meeting selection criteria + badround = 0L & badsharp=0L & badcntrd=0L + if (npar GE 2) or (doprint) then begin ;Create output X and Y arrays? + x = fltarr(ngood) & y = x + endif + + if (npar GE 4) or (doprint) then begin ;Create output flux,sharpness arrays? + flux = x & sharp = x & roundness = x + endif + + if doprint then begin ;Create output file? + + if ( size(print,/TNAME) NE 'STRING' ) then file = 'find.prt' $ + else file = print + message,'Results will be written to a file ' + file,/INF,Noprint=Silent + openw,lun,file,/GET_LUN + printf,lun,' Program: FIND '+ systime() + printf,lun,format='(/A,F7.1)',' Threshold above background:',hmin + printf,lun,' Approximate FWHM:',fwhm + printf,lun,format='(2(A,F6.2))',' Sharpness Limits: Low', $ + sharplim[0], ' High',sharplim[1] + printf,lun,format='(2(A,F6.2))',' Roundness Limits: Low', $ + roundlim[0],' High',roundlim[1] + printf,lun,format='(/A,i6)',' No of sources above threshold',ngood + + endif + + if (not SILENT) and MONITOR then $ + print,format='(/8x,a)',' STAR X Y FLUX SHARP ROUND' + +; Loop over star positions; compute statistics + + for i = 0L,ngood-1 do begin + temp = float(image[ix[i]-nhalf:ix[i]+nhalf,iy[i]-nhalf:iy[i]+nhalf]) + d = h[ix[i],iy[i]] ;"d" is actual pixel intensity + +; Compute Sharpness statistic + + sharp1 = (temp[middle,middle] - (total(mask*temp))/pixels)/d + if ( sharp1 LT sharplim[0] ) or ( sharp1 GT sharplim[1] ) then begin + badsharp = badsharp + 1 + goto, REJECT ;Does not meet sharpness criteria + endif + +; Compute Roundness statistic + + dx = total( total(temp,2)*c1) + dy = total( total(temp,1)*c1) + if (dx LE 0) or (dy LE 0) then begin + badround = badround + 1 + goto, REJECT ;Cannot compute roundness + endif + + around = 2*(dx-dy) / ( dx + dy ) ;Roundness statistic + if ( around LT roundlim[0] ) or ( around GT roundlim[1] ) then begin + badround = badround + 1 + goto,REJECT ;Does not meet roundness criteria + endif + +; +; Centroid computation: The centroid computation was modified in Mar 2008 and +; now differs from DAOPHOT which multiplies the correction dx by 1/(1+abs(dx)). +; The DAOPHOT method is more robust (e.g. two different sources will not merge) +; especially in a package where the centroid will be subsequently be +; redetermined using PSF fitting. However, it is less accurate, and introduces +; biases in the centroid histogram. The change here is the same made in the +; IRAF DAOFIND routine (see +; http://iraf.net/article.php?story=7211&query=daofind ) +; + + sd = total(temp*ywt,2) + + sumgd = total(wt*sgy*sd) + sumd = total(wt*sd) + sddgdx = total(wt*sd*dgdx) + + hx = (sumgd - sumgx*sumd/p) / (sumgsqy - sumgx^2/p) + +; HX is the height of the best-fitting marginal Gaussian. If this is not +; positive then the centroid does not make sense + + if (hx LE 0) then begin + badcntrd = badcntrd + 1 + goto, REJECT + endif + + skylvl = (sumd - hx*sumgx)/p + dx = (sgdgdx - (sddgdx-sdgdx*(hx*sumgx + skylvl*p)))/(hx*sdgdxs/sigsq) + if abs(dx) GE nhalf then begin + badcntrd = badcntrd + 1 + goto, REJECT + endif + + xcen = ix[i] + dx ;X centroid in original array + +; Find Y centroid + + sd = total(temp*xwt,1) + + sumgd = total(wt*sgx*sd) + sumd = total(wt*sd) + + sddgdy = total(wt*sd*dgdy) + + hy = (sumgd - sumgy*sumd/p) / (sumgsqx - sumgy^2/p) + + if (hy LE 0) then begin + badcntrd = badcntrd + 1 + goto, REJECT + endif + + skylvl = (sumd - hy*sumgy)/p + dy = (sgdgdy - (sddgdy-sdgdy*(hy*sumgy + skylvl*p)))/(hy*sdgdys/sigsq) + if abs(dy) GE nhalf then begin + badcntrd = badcntrd + 1 + goto, REJECT + endif + + ycen = iy[i] +dy ;Y centroid in original array + + +; This star has met all selection criteria. Print out and save results + + if monitor then $ + print,FORM = '(12x,i5,2f7.1,f9.1,2f9.2)', $ + nstar, xcen, ycen, d, sharp1, around + + if (npar GE 2) or (doprint) then begin + x[nstar] = xcen & y[nstar] = ycen + endif + + if ( npar GE 4 ) or (doprint) then begin + flux[nstar] = d & sharp[nstar] = sharp1 & roundness[nstar] = around + endif + + nstar = nstar+1 + +REJECT: + endfor + + nstar = nstar-1 ;NSTAR is now the index of last star found + + if doprint then begin + printf,lun,' No. of sources rejected by SHARPNESS criteria',badsharp + printf,lun,' No. of sources rejected by ROUNDNESS criteria',badround + printf,lun,' No. of sources rejected by CENTROID criteria',badcntrd + endif + +if (not SILENT) and (MONITOR) then begin + print,' No. of sources rejected by SHARPNESS criteria',badsharp + print,' No. of sources rejected by ROUNDNESS criteria',badround + print,' No. of sources rejected by CENTROID criteria',badcntrd +endif + + if nstar LT 0 then return ;Any stars found? + + if (npar GE 2) or (doprint) then begin + x=x[0:nstar] & y = y[0:nstar] + endif + + if (npar GE 4) or (doprint) then begin + flux= flux[0:nstar] & sharp=sharp[0:nstar] + roundness = roundness[0:nstar] + endif + + if doprint then begin + printf,lun, $ + format = '(/8x,a)',' STAR X Y FLUX SHARP ROUND' + for i = 0L, nstar do $ + printf,lun,format='(12x,i5,2f8.2,f9.1,2f9.2)', $ + i+1, x[i], y[i], flux[i], sharp[i], roundness[i] + free_lun, lun + endif + +FINISH: + + if SILENT or (not MONITOR) then return + + print,form='(A,F8.1)',' Threshold above background for this pass was',hmin + ans = '' + read,'Enter new threshold or [RETURN] to exit: ',ans + ans = getopt(ans,'F') + if ans GT 0. then begin + hmin = ans + goto, SEARCH + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/find_all_dir.pro b/modules/idl_downloads/astro/pro/find_all_dir.pro new file mode 100644 index 0000000..61ce958 --- /dev/null +++ b/modules/idl_downloads/astro/pro/find_all_dir.pro @@ -0,0 +1,202 @@ + FUNCTION FIND_ALL_DIR, PATH, PATH_FORMAT=PATH_FORMAT, $ + PLUS_REQUIRED=PLUS_REQUIRED, RESET=RESET +;+ +; NAME: +; FIND_ALL_DIR() +; PURPOSE: +; Finds all directories under a specified directory. +; EXPLANATION: +; This routine finds all the directories in a directory tree when the +; root of the tree is specified. This provides the same functionality as +; having a directory with a plus in front of it in the environment +; variable IDL_PATH. +; +; CALLING SEQUENCE: +; Result = FIND_ALL_DIR( PATH ) +; +; PATHS = FIND_ALL_DIR('+mypath', /PATH_FORMAT) +; PATHS = FIND_ALL_DIR('+mypath1:+mypath2') +; +; INPUTS: +; PATH = The path specification for the top directory in the tree. +; Optionally this may begin with the '+' character but the action +; is the same unless the PLUS_REQUIRED keyword is set. +; +; One can also path a series of directories separated +; by the correct character ("," for VMS, ":" for Unix) +; +; OUTPUTS: +; The result of the function is a list of directories starting from the +; top directory passed and working downward from there. Normally, this +; will be a string array with one directory per array element, but if +; the PATH_FORMAT keyword is set, then a single string will be returned, +; in the correct format to be incorporated into !PATH. +; +; OPTIONAL INPUT KEYWORDS: +; PATH_FORMAT = If set, then a single string is returned, in +; the format of !PATH. +; +; PLUS_REQUIRED = If set, then a leading plus sign is required +; in order to expand out a directory tree. +; This is especially useful if the input is a +; series of directories, where some components +; should be expanded, but others shouldn't. +; +; RESET = Often FIND_ALL_DIR is used with logical names. It +; can be rather slow to search through these subdirectories. +; The /RESET keyword can be used to redefine an environment +; variable so that subsequent calls don't need to look for the +; subdirectories. +; +; To use /RESET, the PATH parameter must contain the name of a +; *single* environment variable. For example +; +; setenv,'FITS_DATA=+/datadisk/fits' +; dir = find_all_dir('FITS_DATA',/reset,/plus) +; +; The /RESET keyword is usually combined with /PLUS_REQUIRED. +; +; PROCEDURE CALLS: +; DEF_DIRLIST, FIND_WITH_DEF(), BREAK_PATH() +; +; RESTRICTIONS: +; PATH must point to a directory that actually exists. +; +; REVISION HISTORY: +; Version 11, Zarro (SM&A/GSFC), 23-March-00 +; Removed all calls to IS_DIR +; Version 12, William Thompson, GSFC, 02-Feb-2001 +; In Windows, use built-in expand_path if able. +; Version 13, William Thompson, GSFC, 23-Apr-2002 +; Follow logical links in Unix +; (Suggested by Pascal Saint-Hilaire) +; Version 14, Zarro (EER/GSFC), 26-Oct-2002 +; Saved/restored current directory to protect against +; often mysterious directory changes caused by +; spawning FIND in Unix +; Version 15, William Thompson, GSFC, 9-Feb-2004 +; Resolve environment variables in Windows. +; +; Version : Version 16 W. Landsman GSFC Sep 2006 +; Remove VMS support +;- +; + ON_ERROR, 2 + compile_opt idl2 +; + IF N_PARAMS() NE 1 THEN MESSAGE, $ + 'Syntax: Result = FIND_ALL_DIR( PATH )' + +;-- save current directory + + cd,current=current + +; +; If more than one directory was passed, then call this routine reiteratively. +; Then skip directly to the test for the PATH_FORMAT keyword. +; + PATHS = BREAK_PATH(PATH, /NOCURRENT) + IF N_ELEMENTS(PATHS) GT 1 THEN BEGIN + DIRECTORIES = FIND_ALL_DIR(PATHS[0], $ + PLUS_REQUIRED=PLUS_REQUIRED) + FOR I = 1,N_ELEMENTS(PATHS)-1 DO DIRECTORIES = $ + [DIRECTORIES, FIND_ALL_DIR(PATHS[I], $ + PLUS_REQUIRED=PLUS_REQUIRED)] + GOTO, TEST_FORMAT + ENDIF +; +; Test to see if the first character is a plus sign. If it is, then remove +; it. If it isn't, and PLUS_REQUIRED is set, then remove any trailing '/' +; character and skip to the end. +; + DIR = PATHS[0] + IF STRMID(DIR,0,1) EQ '+' THEN BEGIN + DIR = STRMID(DIR,1,STRLEN(DIR)-1) + END ELSE IF KEYWORD_SET(PLUS_REQUIRED) THEN BEGIN + DIRECTORIES = PATH + IF STRMID(PATH,STRLEN(PATH)-1,1) EQ '/' THEN $ + DIRECTORIES = STRMID(PATH,0,STRLEN(PATH)-1) + GOTO, TEST_FORMAT + ENDIF +; +; For windows, use the built-in EXPAND_PATH program. However, first +; resolve any environment variables. +; + IF !VERSION.OS_FAMILY EQ 'Windows' THEN BEGIN + WHILE STRMID(DIR,0,1) EQ '$' DO BEGIN + FSLASH = STRPOS(DIR,'/') + IF FSLASH LT 1 THEN FSLASH = STRLEN(DIR) + BSLASH = STRPOS(DIR,'/') + IF BSLASH LT 1 THEN BSLASH = STRLEN(DIR) + SLASH = FSLASH < BSLASH + TEST = STRMID(DIR,1,SLASH-1) + DIR = GETENV(TEST) + STRMID(DIR,SLASH,STRLEN(DIR)-SLASH) + ENDWHILE + TEMP = DIR + TEST = STRMID(TEMP, STRLEN(TEMP)-1, 1) + IF (TEST EQ '/') OR (TEST EQ '\') THEN $ + TEMP = STRMID(TEMP,0,STRLEN(TEMP)-1) + DIRECTORIES = EXPAND_PATH('+' + TEMP, /ALL, /ARRAY) +; +; On Unix machines spawn the Bourne shell command 'find'. First, if the +; directory name starts with a dollar sign, then try to interpret the +; following environment variable. If the result is the null string, then +; signal an error. +; + END ELSE BEGIN + IF STRMID(DIR,0,1) EQ '$' THEN BEGIN + SLASH = STRPOS(DIR,'/') + IF SLASH LT 0 THEN SLASH = STRLEN(DIR) + EVAR = GETENV(STRMID(DIR,1,SLASH-1)) + IF SLASH EQ STRLEN(DIR) THEN DIR = EVAR ELSE $ + DIR = EVAR + STRMID(DIR,SLASH,STRLEN(DIR)-SLASH) + ENDIF +; IF IS_DIR(DIR) NE 1 THEN MESSAGE, $ +; 'A valid directory must be passed' + IF STRMID(DIR,STRLEN(DIR)-1,1) NE '/' THEN DIR = DIR + '/' + SPAWN,'find ' + DIR + ' -follow -type d -print | sort -', $ + DIRECTORIES, /SH +; +; Remove any trailing slash character from the first directory. +; + TEMP = DIRECTORIES[0] + IF STRMID(TEMP,STRLEN(TEMP)-1,1) EQ '/' THEN $ + DIRECTORIES[0] = STRMID(TEMP,0,STRLEN(TEMP)-1) + ENDELSE +; +; Reformat the string array into a single string, with the correct separator. +; If the PATH_FORMAT keyword was set, then this string will be used. Also use +; it when the RESET keyword was passed. +; +TEST_FORMAT: + DIR = DIRECTORIES[0] + CASE !VERSION.OS_FAMILY OF + 'Windows': SEP = ';' + 'MacOS': Sep = ',' + ELSE: SEP = ':' + ENDCASE + FOR I = 1,N_ELEMENTS(DIRECTORIES)-1 DO DIR = DIR + SEP + DIRECTORIES[I] +; +; If the RESET keyword is set, and the PATH variable contains a *single* +; environment variable, then call SETENV to redefine the environment variable. +; If the string starts with a $, then try it both with and without the $. +; + IF KEYWORD_SET(RESET) THEN BEGIN + EVAR = PATH + TEST = GETENV(EVAR) + IF TEST EQ '' THEN IF STRMID(EVAR,0,1) EQ '$' THEN BEGIN + EVAR = STRMID(EVAR,1,STRLEN(EVAR)-1) + TEST = GETENV(EVAR) + ENDIF + IF (TEST NE '') AND (TEST NE PATH) AND (DIR NE PATH) THEN $ + SETENV, STRTRIM(EVAR,2) + '=' + $ + STRTRIM(STRJOIN(DIR,':'),2) + ENDIF +; +;-- restore current directory + + cd,current + + IF KEYWORD_SET(PATH_FORMAT) THEN RETURN, DIR ELSE RETURN, DIRECTORIES +; + END diff --git a/modules/idl_downloads/astro/pro/find_with_def.pro b/modules/idl_downloads/astro/pro/find_with_def.pro new file mode 100644 index 0000000..1fa4ade --- /dev/null +++ b/modules/idl_downloads/astro/pro/find_with_def.pro @@ -0,0 +1,153 @@ + FUNCTION FIND_WITH_DEF, FILENAME, PATHS, EXTENSIONS, $ + NOCURRENT=NOCURRENT, RESET=RESET +;+ +; NAME: +; FIND_WITH_DEF() +; PURPOSE: +; Searches for files with a default path and extension. +; EXPLANATION: +; Finds files using default paths and extensions, Using this routine +; together with environment variables allows an OS-independent approach +; to finding files. +; CALLING SEQUENCE: +; Result = FIND_WITH_DEF( FILENAME, PATHS [, EXTENSIONS ] ) +; +; INPUTS: +; FILENAME = Name of file to be searched for. It may either be a +; complete filename, or the path or extension could be left +; off, in which case the routine will attempt to find the +; file using the default paths and extensions. +; +; PATHS = One or more default paths to use in the search in case +; FILENAME does not contain a path itself. The individual +; paths are separated by commas, although in UNIX, colons +; can also be used. In other words, PATHS has the same +; format as !PATH, except that commas can be used as a +; separator regardless of operating system. The current +; directory is always searched first, unless the keyword +; NOCURRENT is set. +; +; A leading $ can be used in any path to signal that what +; follows is an environmental variable, but the $ is not +; necessary. Environmental variables can themselves contain +; multiple paths. +; +; OPTIONAL INPUTS: +; EXTENSIONS = Scalar string giving one or more extensions to append to +; end of filename if the filename does not contain one (e.g. +; ".dat"). The period is optional. Multiple extensions can +; be separated by commas or colons. +; OUTPUTS: +; The result of the function is the name of the file if successful, or +; the null string if unsuccessful. +; OPTIONAL INPUT KEYWORDS: +; NOCURRENT = If set, then the current directory is not searched. +; +; RESET = The FIND_WITH_DEF routine supports paths which are +; preceeded with the plus sign to signal that all +; subdirectories should also be searched. Often this is +; used with logical names. It can be rather slow to search +; through these subdirectories. The /RESET keyword can be +; used to redefine an environment variable so that +; subsequent calls don't need to look for the +; subdirectories. +; +; To use /RESET, the PATHS parameter must contain the name +; of a *single* environment variable. For example +; +; setenv,'FITS_DATA=+/datadisk/fits' +; file = find_with_def('test.fits','FITS_DATA',/reset) +; +; EXAMPLE: +; +; FILENAME = '' +; READ, 'File to open: ', FILENAME +; FILE = FIND_WITH_DEF( FILENAME, 'SERTS_DATA', '.fix' ) +; IF FILE NE '' THEN ... +; +; +; PROCEDURE CALLS: +; BREAK_PATH(), FIND_ALL_DIR(), STR_SEP() +; REVISION HISTORY: +; Version 1, William Thompson, GSFC, 3 May 1993. +; Removed trailing / and : characters. +; Fixed bugs +; Allow for commas within values of logical names. +; Added keyword NOCURRENT. +; Changed to call BREAK_PATH +; Version 2, William Thompson, GSFC, 3 November 1994 +; Made EXTENSIONS optional. +; Version 3, William Thompson, GSFC, 30 April 1996 +; Call FIND_ALL_DIR to resolve any plus signs. +; Version 4, S.V. Haugan, UiO, 5 June 1996 +; Using OPENR,..,ERROR=ERROR to avoid an IDL 3.6 +; internal nesting error. +; Version 5, R.A. Schwartz, GSFC, 11 July 1996 +; Use SPEC_DIR to interpret PATH under VMS +; Version 6, William Thompson, GSFC, 5 August 1996 +; Took out call to SPEC_DIR (i.e., reverted to version 4). The +; use of SPEC_DIR was required to support logical names defined +; via SETLOG,/CONFINE. However, it conflicted with the ability +; to use logical names with multiple values. Removing the +; /CONFINE made it unnecessary to call SPEC_DIR in this routine. +; Version 7, William Thompson, GSFC, 6 August 1996 +; Added keyword RESET +; Converted to IDL V5.0 W. Landsman October 1997 +; Use STRTRIM instead of TRIM, W. Landsman November 1998 +; Use STRSPLIT instead of STR_SEP W. Landsman July 2002 +;- +; + ON_ERROR, 2 +; +; Check the number of parameters: +; + IF N_PARAMS() LT 2 THEN MESSAGE, 'Syntax: Result = ' + $ + 'FIND_WITH_DEF(FILENAME, PATHS [, EXTENSIONS])' +; +; If there are any plus signs, then expand them. +; + PATH = FIND_ALL_DIR(PATHS, /PLUS_REQUIRED, /PATH, RESET=RESET) +; +; Reformat PATHS into an array. The first element is the null string. +; + PATH = BREAK_PATH(PATH) +; +; If NOCURRENT was set, then remove the first (blank) entry from the PATH +; array. +; + IF KEYWORD_SET(NOCURRENT) THEN PATH = PATH[1:*] +; +; Reformat EXTENSIONS into an array. The first element is the null string. +; + EXT = '' + IF N_PARAMS() EQ 3 THEN $ + EXT = ['',STRSPLIT(EXTENSIONS,',:',/EXTRACT)] +; +; Make sure that the extensions begin with a period. +; + FOR I = 0,N_ELEMENTS(EXT)-1 DO IF EXT[I] NE '' THEN $ + IF STRMID(EXT[I],0,1) NE '.' THEN EXT[I] = '.' + EXT[I] +; +; Set up variables used by the loops below. +; + I_PATH = -1 + GET_LUN, UNIT + FNAME = STRTRIM(FILENAME,2) + EXT +; +; Step through each of the paths. +; + FOR I_PATH = 0, N_ELEMENTS(PATH)- 1 DO BEGIN +; +; If the file is found then terminate the loop and clean up. +; + FILE = FILE_SEARCH(PATH[I_PATH] + FNAME, COUNT = COUNT) + IF COUNT GT 0 THEN BREAK + ENDFOR +; +; Otherwise, we jump directly to here when we find a file. +; +DONE: + FREE_LUN, UNIT + !ERR = COUNT + RETURN, FILE[0] + END diff --git a/modules/idl_downloads/astro/pro/findpro.pro b/modules/idl_downloads/astro/pro/findpro.pro new file mode 100644 index 0000000..7f00a89 --- /dev/null +++ b/modules/idl_downloads/astro/pro/findpro.pro @@ -0,0 +1,173 @@ +pro FindPro, Proc_Name, NoPrint=NoPrint, DirList=DirList, ProList=ProList +;+ +; NAME: +; FINDPRO +; PURPOSE: +; Find all locations of a procedure in the IDL !PATH +; EXPLANATION: +; FINDPRO searces for the procedure name (as a .pro or a .sav file) in all +; IDL libraries or directories given in the !PATH system variable. This +; differs from the intrinsic FILE_WHICH() function which only finds the +; first occurence of the procedure name. +; +; CALLING SEQUENCE: +; FINDPRO, [ Proc_Name, /NoPrint, DirList = , ProList = ] +; +; OPTIONAL INPUT: +; Proc_Name - Character string giving the name of the IDL procedure or +; function. Do not include the ".pro" extension. If Proc_Name is +; omitted, the program will prompt for PROC_NAME. "*" wildcards +; are permitted. +; +; OPTIONAL KEYWORD INPUT: +; /NoPrint - if set, then the file's path is not printed on the screen and +; absolutely no error messages are printed on the screen. If not +; set, then - since the MESSAGE routine is used - error messages +; will be printed but the printing of informational messages +; depends on the value of the !Quiet variable. +; +; OPTIONAL KEYWORD OUTPUTS: +; DirList - The directories in which the file is located are returned in +; the keyword as a string array. +; If the procedure is an intrinsic IDL procedure, then the +; value of DirList = ['INTRINSIC']. +; If the procedure is not found, the value of DirList = ['']. +; ProList - The list (full pathnames) of procedures found. Useful if you +; are looking for the name of a procedure using wildcards. +; +; The order of the names in DirList and ProList is identical to the order +; in which the procedure name appears in the !PATH +; PROCEDURE: +; The system variable !PATH is parsed using EXPAND_PATH into individual +; directories. FILE_SEARCH() is used to search the directories for +; the procedure name. If not found in !PATH, then the name is compared +; with the list of intrinsic IDL procedures given by the ROUTINE_INFO() +; function. +; +; EXAMPLE: +; (1) Find the procedure CURVEFIT. Assume for this example that the user +; also has a copy of the curvefit.pro procedure in her home directory +; on a Unix machine. +; +; IDL> findpro, 'curvefit', DIRLIST=DirList +; Procedure curvefit.pro found in directory /home/user/. +; Procedure curvefit.pro found in directory /software/IDL/idl82/lib/ +; IDL> help, DirList +; DIRLIST STRING = Array(2) +; IDL> help, DirList[0], DirList[1] +; STRING = '/home/user' +; STRING = '/software/IDL/idl82/lib/' +; +; (2) Find all procedures in one's !path containing the characters "zoom" +; +; IDL> findpro,'*zoom*' +; RESTRICTIONS: +; User will be unable to find a path for a native IDL function +; or procedure, or for a FORTRAN or C routine added with CALL_EXTERNAL. +; Remember that Unix is case sensitive, and most procedures will be in +; lower case. +; PROCEDURES USED: +; FDECOMP -- Decompose file name +; +; REVISION HISTORY: +; Based on code extracted from the GETPRO procedure, J. Parker 1994 +; Use the intrinsic EXPAND_PATH function W. Landsman Nov. 1994 +; Use ROUTINE_NAMES() to check for intrinsic procs W. Landsman Jul 95 +; Added Macintosh, WINDOWS compatibility W. Landsman Sep. 95 +; Removed spurious first element in PROLIST W. Landsman March 1997 +; Don't include duplicate directories in !PATH WL May 1997 +; Use ROUTINE_INFO instead of undocumented ROUTINE_NAMES W.L. October 1998 +; Also check for save sets W. Landsman October 1999 +; Force lower case check for VMS W. Landsman January 2000 +; Only return .pro or .sav files in PROLIST W. Landsman January 2002 +; Force lower case check for .pro and .sav D. Swain September 2002 +; Use FILE_SEARCH() if V5.5 or later W. Landsman June 2006 +; Assume since V55, remove VMS support W. Landsman Sep. 2006 +; Assume since V6.0, use file_basename() W.Landsman Feb 2009 +; Specify whether an intrinsic function or procedure W.L. Jan 2013 +; +;- +;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ + + On_error,2 ;Return to caller on error + compile_opt idl2 + + if (N_params() EQ 0) then begin ;Prompt for procedure name? + Proc_Name = ' ' + read,'Enter name of procedure for which you want the path: ',Proc_Name + endif else $ + if (size(proc_name,/type) NE 7 ) && (N_elements(proc_name) NE 1) then $ + message,'ERROR - First parameter (.pro name) must be a scalar string' + + NoPrint = keyword_set(NoPrint) + + Name = strtrim( file_basename(proc_name,'.pro'), 2 ) + +; Set up separate file and directory separators for current OS + + psep = path_sep() + + pathdir = expand_path(!PATH,/ARRAY, Count = N_dir) + cd,current = dir + +; Remove duplicate directories in !PATH but keep original order + path_dir = [dir] + for i = 0,N_dir -1 do begin + test = where(path_dir EQ pathdir[i], Ndup) + if Ndup EQ 0 then path_dir = [path_dir,pathdir[i]] + endfor + N_dir = N_elements(path_dir) + +; Use FILE_PATH() to search all directories for .pro or .sav files + + ProList = file_search(path_dir + psep + name + '.{pro,sav}', COUNT=Nfile) + + if (Nfile ge 1) then begin ;Found by FILE_SEARCH? + fdecomp, ProList, ddisk,ddir,fname,ext + dirlist = ddisk + ddir + found = 1b + for j = 0,nfile-1 do begin + case strlowcase(ext[j]) of + 'pro': message,/Con, NoPrint = NoPrint,/NoPrefix, /Noname, $ + 'Procedure ' + fname[j] + ' found in directory ' + dirlist[j] + 'sav': message,/Con,NoPrint = NoPrint,/NoPrefix, /Noname, $ + 'Save set ' + fname[j] + '.sav found in directory ' + dirlist[j] + endcase + endfor + endif else begin + + +; At this point !PATH has been searched. If the procedure was not found +; check if it is an intrinsic IDL procedure or function + + funcnames = routine_info(/system,/func) + fcount = ~array_equal( funcnames NE strupcase(name), 1b ) +; test = where ( funcnames EQ strupcase(name), fcount) Slower method + + funcnames = routine_info(/system) + pcount = ~array_equal( funcnames NE strupcase(name) , 1b) +; + + if (fcount EQ 0) && (pcount EQ 0) then begin + prolist = strarr(1) + dirlist = strarr(1) + if ~NoPrint then begin + message, 'Procedure '+Name+' not found in a !PATH directory.', /CONT + message, 'Check your spelling or search individual directories.', /INF + endif + endif else begin + DirList = ['INTRINSIC'] + ProList = ['INTRINSIC'] + if ~NoPrint then begin + if pcount NE 0 then $ + message, 'Procedure ' + Name + ' is an intrinsic IDL procedure.', $ + /CONT else $ + message, 'Procedure ' + Name + ' is an intrinsic IDL function.',/CONT + message, 'No path information available.', /INF + endif + endelse + + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/fitexy.pro b/modules/idl_downloads/astro/pro/fitexy.pro new file mode 100644 index 0000000..5acf312 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fitexy.pro @@ -0,0 +1,205 @@ +;+ +; NAME: +; FITEXY +; PURPOSE: +; Best straight-line fit to data with errors in both coordinates +; EXPLANATION: +; Linear Least-squares approximation in one-dimension (y = a + b*x), +; when both x and y data have errors Users might be interested in +; Michael Williams MPFITEXY routines which include a number of +; enhancements to FITEXY. +; ( http://user.astro.columbia.edu/~williams/mpfitexy/ ) +; +; +; CALLING EXAMPLE: +; FITEXY, x, y, A, B, X_SIG= , Y_SIG= , [sigma_A_B, chi_sq, q, TOL=] +; +; INPUTS: +; x = array of values for independent variable. +; y = array of data values assumed to be linearly dependent on x. +; +; REQUIRED INPUT KEYWORDS: +; X_SIGMA = scalar or array specifying the standard deviation of x data. +; Y_SIGMA = scalar or array specifying the standard deviation of y data. +; +; OPTIONAL INPUT KEYWORD: +; TOLERANCE = desired accuracy of minimum & zero location, default=1.e-3. +; +; OUTPUTS: +; A_intercept = constant parameter result of linear fit, +; B_slope = slope parameter, so that: +; ( A_intercept + B_slope * x ) approximates the y data. +; OPTIONAL OUTPUT: +; sigma_A_B = two element array giving standard deviation of +; A_intercept and B_slope parameters, respectively. +; The standard deviations are not meaningful if (i) the +; fit is poor (see parameter q), or (ii) b is so large that +; the data are consistent with a vertical (infinite b) line. +; If the data are consistent with *all* values of b, then +; sigma_A_B = [1e33,e33] +; chi_sq = resulting minimum Chi-Square of Linear fit, scalar +; q - chi-sq probability, scalar (0-1) giving the probability that +; a correct model would give a value equal or larger than the +; observed chi squared. A small value of q indicates a poor +; fit, perhaps because the errors are underestimated. As +; discussed by Tremaine et al. (2002, ApJ, 574, 740) an +; underestimate of the errors (e.g. due to an intrinsic dispersion) +; can lead to a bias in the derived slope, and it may be worth +; enlarging the error bars to get a reduced chi_sq ~ 1 +; +; COMMON: +; common fitexy, communicates the data for computation of chi-square. +; +; PROCEDURE CALLS: +; CHISQ_FITEXY() ;Included in this file +; MINF_BRACKET, MINF_PARABOLIC, ZBRENT ;In IDL Astronomy Library +; MOMENT(), CHISQR_PDF() ;In standard IDL distribution +; +; PROCEDURE: +; From "Numerical Recipes" column by Press and Teukolsky: +; in "Computer in Physics", May, 1992 Vol.6 No.3 +; Also see the 2nd edition of the book "Numerical Recipes" by Press et al. +; +; In order to avoid problems with data sets where X and Y are of very +; different order of magnitude the data are normalized before the fitting +; process is started. The following normalization is used: +; xx = (x - xm) / xs and sigx = x_sigma / xs +; where xm = MEAN(x) and xs = STDDEV(x) +; yy = (y - ym) / ys and sigy = y_sigma / ys +; where ym = MEAN(y) and ys = STDDEV(y) +; +; +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC September 1992. +; Now returns q rather than 1-q W. Landsman December 1992 +; Use CHISQR_PDF, MOMENT instead of STDEV,CHI_SQR1 W. Landsman April 1998 +; Fixed typo for initial guess of slope, this error was nearly +; always insignificant W. Landsman March 2000 +; Normalize X,Y before calculation (from F. Holland) W. Landsman Nov 2006 +;- +function chisq_fitexy, B_angle +; +; NAME: +; chisq_fitexy +; PURPOSE: +; Function minimized by fitexy (computes chi-square of linear fit). +; It is called by minimization procedures during execution of fitexy. +; CALLING SEQUENCE: +; chisq = chisq_fitexy( B_angle ) +; INPUTS: +; B_angle = arc-tangent of B_slope of linear fit. +; OUTPUTS: +; Result of function = chi_square - offs (offs is in COMMON). +; COMMON: +; common fitexy, communicates the data from pro fitexy. +; PROCEDURE: +; From "Numerical Recipes" column: Computer in Physics Vol.6 No.3 +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. + + common fitexy, xx, yy, sigx, sigy, ww, Ai, offs + + B_slope = tan( B_angle ) + ww = 1/( ( (B_slope * sigx)^2 + sigy^2 ) > 1.e-30 ) + if N_elements( ww ) EQ 1 then sumw = ww * N_elements( xx ) $ + else sumw = total( ww ) + y_Bx = yy - B_slope * xx + Ai = total( ww * y_Bx )/sumw + +return, total( ww * (y_Bx - Ai)^2 ) - offs +end +;------------------------------------------------------------------------------- +pro fitexy, x, y, A_intercept, B_slope, sigma_A_B, chi_sq, q, TOLERANCE=Tol, $ + X_SIGMA=x_sigma, Y_SIGMA=y_sigma + compile_opt idl2 + common fitexy, xx, yy, sigx, sigy, ww, Ai, offs + + if N_params() LT 4 then begin + print,'Syntax - fitexy, x, y, A, B, X_SIG=sigx, Y_SIG=sigy,' + print,' [sigma_A_B, chi_sq, q, TOLERANCE = ]' + return + endif + +; Normalize data before running fitexy + + xm = (MOMENT(x, SDEV = xs, /DOUBLE))[0] + ym = (MOMENT(y, SDEV = ys, /DOUBLE))[0] + xx = (x - xm) / xs + yy = (y - ym) / ys + sigx = x_sigma / xs + sigy = y_sigma / ys + + +;Compute first guess for B_slope using standard 1-D Linear Least-squares fit, +; where the non-linear term involving errors in x are ignored. +; (note that Tx is a transform to reduce roundoff errors) + + ww = sigx^2 + sigy^2 + if N_elements( ww ) EQ 1 then sumw = ww * N_elements( xx ) $ + else sumw = total( ww ) + Sx = total( xx * ww ) + Tx = xx - Sx/sumw + B = total( ww * yy * Tx ) / total( ww * Tx^2 ) + +;Find the minimum chi-sq while including the non-linear term (B * sigx)^2 +; involving variance in x data (computed by function chisq_fitexy): +; using minf_bracket (=MNBRAK) and minf_parabolic (=BRENT) + offs = 0 + ang = [ 0, atan( B ), 1.571 ] + chi = fltarr( 3 ) + for j=0,2 do chi[j] = chisq_fitexy( ang[j] ) ;this is for later... + if N_elements( Tol ) NE 1 then Tol=1.e-3 + a0 = ang[0] + a1 = ang[1] + minf_bracket, a0,a1,a2, c0,c1,c2, FUNC="chisq_fitexy" + minf_parabolic, a0,a1,a2, Bang, chi_sq, FUNC="chisq_fitexy", TOL=Tol + + if N_params() EQ 7 then q = 1 - chisqr_pdf( chi_sq, N_elements(x) - 2 ) + A_intercept = Ai ;computed in function chisq_fitexy + ang = [a0,a1,a2,ang] + chi = [c0,c1,c2,chi] + +;Now compute the variances of estimated parameters, +; by finding roots of ( (chi_sq + 1) - chisq_fitexy ). +;Note: ww, Ai are computed in function chisq_fitexy. + + offs = chi_sq + 1 + wc = where( chi GT offs, nc ) + + if (nc GT 0) then begin + + angw = [ang[wc]] + d1 = abs( angw - Bang ) MOD !PI + d2 = !PI - d1 + wa = where( angw LT Bang, na ) + + if (na GT 0) then begin + d = d1[wa] + d1[wa] = d2[wa] + d2[wa] = d + endif + + Bmax = zbrent( Bang,Bang+max(d1),F="chisq_fitexy",T=Tol ) -Bang + Amax = Ai - A_intercept + Bmin = zbrent( Bang,Bang-min(d2),F="chisq_fitexy",T=Tol ) -Bang + Amin = Ai - A_intercept + + if N_elements( ww ) EQ 1 then r2 = 2/( ww * N_elements( x ) ) $ + else r2 = 2/total( ww ) + + sigma_A_B = [ Amin^2 + Amax^2 + r2 , Bmin^2 + Bmax^2 ] + sig_A_B = sqrt( sigma_A_B/2 ) / ([1,cos(Bang)^2]) + + endif + +;Finally, transform parameters back to orignal units. + + + B_slope = tan( Bang ) *ys /xs + A_intercept = A_intercept*ys - tan(Bang) * ys / xs *xm + ym + if Nc GT 0 then sigma_A_B = [SQRT( (sig_A_B[0] * ys)^2 + $ + (sig_A_B[1] * ys / xs * xm)^2 ), sig_A_B[1] * ys / xs] $ + else sigma_A_B = [1.e33,1.e33] + +return +end diff --git a/modules/idl_downloads/astro/pro/fits_add_checksum.pro b/modules/idl_downloads/astro/pro/fits_add_checksum.pro new file mode 100644 index 0000000..71492c7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_add_checksum.pro @@ -0,0 +1,104 @@ +pro fits_add_checksum, hdr, im, no_timestamp = no_timestamp, $ + FROM_IEEE=from_IEEE +;+ +; NAME: +; FITS_ADD_CHECKSUM +; PURPOSE: +; Add or update the CHECKSUM and DATASUM keywords in a FITS header +; EXPLANATION: +; Follows the May 2002 version of the FITS checksum proposal at +; http://fits.gsfc.nasa.gov/registry/checksum.html +; CALLING SEQUENCE: +; FITS_ADD_CHECKSUM, Hdr, [ Data, /No_TIMESTAMP, /FROM_IEEE ] +; INPUT-OUTPUT: +; Hdr - FITS header (string array), it will be updated with new +; (or modified) CHECKSUM and DATASUM keywords +; OPTIONAL INPUT: +; Data - data array associated with the FITS header. If not supplied, or +; set to a scalar, then the program checks whether there is a +; DATASUM keyword already in the FITS header containing the 32bit +; checksum for the data. If there is no such keyword then there +; assumed to be no data array associated with the FITS header. +; OPTIONAL INPUT KEYWORDS: +; /FROM_IEEE - If this keyword is set, then the input is assumed to be in +; big endian format (e.g. an untranslated FITS array). This +; keyword only has an effect on little endian machines (e.g. +; a Linux box). +; /No_TIMESTAMP - If set, then a time stamp is not included in the comment +; field of the CHECKSUM and DATASUM keywords. Unless the +; /No_TIMESTAMP keyword is set, repeated calls to FITS_ADD_CHECKSUM +; with the same header and data will yield different values of +; CHECKSUM (as the date stamp always changes). However, use of the +; date stamp is recommended in the checksum proposal. +; PROCEDURES USED: +; CHECKSUM32, FITS_ASCII_ENCODE(), GET_DATE, SXADDPAR, SXPAR() +; REVISION HISTORY: +; W. Landsman SSAI December 2002 +; Fix problem with images with a multiple of 2880 bytes. W.L. May 2008 +; Avoid conversion error when DATASUM is an empty string W.L. June 2008 +; Don't update DATASUM if not already present and no data array supplied +; W.L. July 2008 +; Make sure input header array has 80 chars/line W.L. Aug 2009 +;- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - FITS_ADD_CHECKSUM, Hdr, Data, /No_TIMESTAMP, /FROM_IEEE' + return + endif + + datasum = sxpar(hdr,'DATASUM', Count = N_DATASUM) + Nim = N_elements(im) + datasum_update = 1b + if Nim GT 1 then begin + checksum32,im, dsum,FROM_IEEE = from_IEEE + remain = Nim mod 2880 + if remain GT 0 then begin + exten = sxpar( hdr, 'XTENSION', Count = N_exten) + if N_exten GT 0 then if exten EQ 'TABLE ' then $ + checksum32,[dsum,replicate(32b,2880-remain)],dsum + endif + sdsum = strtrim(dsum,2) + dsum_exist= 1b + endif else begin + if N_datasum EQ 0 then begin ;Don't update DATASUM keyword + datasum_update = 0b + sdsum = ' 0' + endif else begin + if strtrim(datasum,2) EQ '' then dsum=0 else dsum = ulong(datasum) + sdsum = strtrim(dsum,2) + endelse + endelse + + if keyword_set(no_timestamp) then tm = '' else Get_date,tm,/timetag + +; Do the Checksum keywords already exist? + + if N_DATASUM GT 0 then verb = 'updated ' else verb = 'created ' + if datasum_update then sxaddpar,hdr,'DATASUM', sdsum, $ + ' data unit checksum ' + verb + tm + + test = sxpar(hdr,'CHECKSUM', Count = N_CHECKSUM) + if N_CHECKSUM GT 0 then verb = 'updated ' else verb = 'created ' + sxaddpar,hdr,'CHECKSUM','0000000000000000', $ + ' HDU checksum ' + verb + tm ;Initialize CHECKSUM keyword +;Make sure each line in header is 80 characters + if ~array_equal(strlen(hdr),80) then begin + n = N_elements(hdr) + bhdr = replicate(32b,80,n ) + for i=0, n-1 do bhdr[0,i] = byte(hdr[i]) + endif else bhdr = byte(hdr) + + remain = N_elements(bhdr) mod 2880 + if remain NE 0 then $ + bhdr = [reform(bhdr,N_elements(bhdr)), replicate(32b, 2880 - remain) ] + checksum32,bhdr, hsum, /NoSAVE + if N_elements(dsum) GT 0 then checksum32, [dsum,hsum], hdusum $ + else hdusum = hsum + + ch = FITS_ASCII_ENCODE(not hdusum) ;ASCII encode the complement of the checksum + sxaddpar,hdr,'CHECKSUM',ch + + return + end diff --git a/modules/idl_downloads/astro/pro/fits_ascii_encode.pro b/modules/idl_downloads/astro/pro/fits_ascii_encode.pro new file mode 100644 index 0000000..1fbb628 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_ascii_encode.pro @@ -0,0 +1,68 @@ +function fits_ascii_encode, sum32 +;+ +; NAME: +; FITS_ASCII_ENCODE() +; PURPOSE: +; Encode an unsigned longword as an ASCII string to insert in a FITS header +; EXPLANATION: +; Follows the July 2007 version of the FITS checksum proposal at +; http://fits.gsfc.nasa.gov/registry/checksum.html +; CALLING SEQUENCE: +; result = FITS_ASCII_ENCODE( sum32) +; INPUTS: +; sum32 - 32bit *unsigned longword* (e.g. as returned by CHECKSUM32) +; RESULT: +; A 16 character scalar string suitable for the CHECKSUM keyword +; EXAMPLE: +; A FITS header/data unit has a checksum of 868229149. Encode the +; complement of this value (3426738146) into an ASCII string +; +; IDL> print,FITS_ASCII_ENCODE(3426738146U) +; ===> "hcHjjc9ghcEghc9g" +; +; METHOD: +; The 32bit value is interpreted as a sequence of 4 unsigned 8 bit +; integers, and divided by 4. Add an offset of 48b (ASCII '0'). +; Remove non-alphanumeric ASCII characters (byte values 58-64 and 91-96) +; by simultaneously incrementing and decrementing the values in pairs. +; Cyclicly shift the string one place to the right. +; +; REVISION HISTORY: +; Written W. Landsman SSAI December 2002 +; Use V6.0 notation W.L. August 2013 +;- + if N_Params() LT 1 then begin + print,'Syntax - result = FITS_ASCII_ENCODE( sum32)' + return,'0' + endif + +; Non-alphanumeric ASCII characters + exclude = [58b,59b,60b,61b,62b,63b,64b,91b,92b,93b,94b,95b,96b] + ch = bytarr(16) + t = byte(sum32,0,4) + byteorder,t,/htonl + quot = t/4 + 48b + for i=0,12,4 do ch[i] = quot + + remain = t mod 4 + ch[0] = ch[0:3] + remain ;Insert the remainder in the first 4 bytes + +;Step through the 16 bytes, 8 at a time, removing nonalphanumeric characters + repeat begin + check = 0b + for j=0,1 do begin + il = j*8 + for i=il,il+3 do begin + bad = where( (exclude EQ ch[i]) or (exclude Eq ch[i+4]) , Nbad) + if Nbad GT 0 then begin + ch[i]++ + ch[i+4]-- + check=1b + endif + endfor + endfor + endrep until (check EQ 0b) + + return, string( shift(ch,1)) + end + diff --git a/modules/idl_downloads/astro/pro/fits_cd_fix.pro b/modules/idl_downloads/astro/pro/fits_cd_fix.pro new file mode 100644 index 0000000..40a5219 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_cd_fix.pro @@ -0,0 +1,80 @@ +pro fits_cd_fix,hdr, REVERSE = reverse +;+ +; NAME: +; FITS_CD_FIX +; +; PURPOSE: +; Update obsolete representations of the CD matrix in a FITS header +; +; EXPLANATION: +; According the paper, "Representations of Celestial Coordinates in FITS" +; by Calabretta & Greisen (2002, A&A, 395, 1077, available at +; http://fits.gsfc.nasa.gov/fits_wcs.html) the rotation of an image from +; standard coordinates is represented by a coordinate description (CD) +; matrix. The standard representation of the CD matrix are PCn_m +; keywords, but CDn_m keywords (which include the scale factors) are +; also allowed. However, earliers drafts of the standard allowed the +; keywords forms CD00n00m and PC00n00m. This procedure will convert +; FITS CD matrix keywords containing zeros into the standard forms +; CDn_m and PCn_m containing only underscores. +; +; CALLING SEQUENCE: +; FITS_CD_FIX, Hdr +; +; INPUT-OUTPUT: +; HDR - FITS header, 80 x N string array. If the header does not +; contain 'CD00n00m' or 'PC00n00m' keywords then it is left +; unmodified. Otherwise, the keywords containing integers are +; replaced with those containing underscores. +; +; OPTIONAL KEYWORD INPUT +; /REVERSE - this keyword does nothing, but is kept for compatibility with +; earlier versions. +; PROCEDURES USED: +; SXADDPAR, SXDELPAR, SXPAR() +; REVISION HISTORY: +; Written W. Landsman Feb 1990 +; Major rewrite Feb 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use double precision formatting of CD matrix W. Landsman April 2000 +; Major rewrite to convert only to forms recognized by the Greisen +; & Calabretta standard W. Landsman July 2003 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - FITS_CD_FIX, hdr' + return + endif + + cd00 = ['CD001001','CD001002','CD002001','CD002002'] + pc00 = ['PC001001','PC001002','PC002001','PC002002'] + + cd_ = ['CD1_1','CD1_2','CD2_1','CD2_2'] + pc_ = ['PC1_1','PC1_2','PC2_1','PC2_2'] + + + for i= 0 ,3 do begin + pc = sxpar(hdr,pc00[i], COUNT = N) + if N GE 1 then begin + sxaddpar,hdr,pc_[i],pc,'',pc00[i] + sxdelpar,hdr,pc00[i] + if i EQ 0 then sxaddhist,'FITS_CD_FIX:' + strmid(systime(),4,20) + $ + ' PC00n00m keywords changed to PCn_m',hdr + endif else begin + + cd = sxpar(hdr,cd00[i], COUNT = N ) + if N GE 1 then begin + sxaddpar,hdr,cd_[i],cd,'',cd00[i] + sxdelpar,hdr,cd00[i] + if i EQ 0 then sxaddhist,'FITS_CD_FIX:' + strmid(systime(),4,20) + $ + ' CD00n00m keywords changed to CDn_m',hdr + endif + endelse + endfor + + + return + end + diff --git a/modules/idl_downloads/astro/pro/fits_close.pro b/modules/idl_downloads/astro/pro/fits_close.pro new file mode 100644 index 0000000..627f4a1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_close.pro @@ -0,0 +1,66 @@ +pro fits_close,fcb,no_abort=no_abort,message=message +;+ +; NAME: +; FITS_CLOSE +; +;*PURPOSE: +; Close a FITS data file +; +;*CATEGORY: +; INPUT/OUTPUT +; +;*CALLING SEQUENCE: +; FITS_CLOSE,fcb +; +;*INPUTS: +; FCB: FITS control block returned by FITS_OPEN. +; +;*KEYWORD PARAMETERS: +; /NO_ABORT: Set to return to calling program instead of a RETALL +; when an I/O error is encountered. If set, the routine will +; return a non-null string (containing the error message) in the +; keyword MESSAGE. If /NO_ABORT not set, then FITS_CLOSE will +; print the message and issue a RETALL +; MESSAGE = value: Output error message +; +;*EXAMPLES: +; Open a FITS file, read some data, and close it with FITS_CLOSE +; +; FITS_OPEN,'infile',fcb +; FITS_READ,fcb,data +; FITS_READ,fcb,moredata +; FITS_CLOSE,fcb +; +;*HISTORY: +; Written by: D. Lindler August, 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +; Do nothing if fcb an invalid structure D. Schlegel/W. Landsman Oct. 2000 +; Return Message='' for to signal normal operation W. Landsman Nov. 2000 +;- +;---------------------------------------------------------------------------- +; +; print calling sequence if no parameters supplied +; + if N_params() lt 1 then begin + print,'Syntax - FITS_CLOSE, fcb' + print,'KEYWORD PARAMETERS: /No_abort, message=' + return + end +; +; close unit +; + on_ioerror,ioerror + message = '' + + sz_fcb = size(fcb) ;Valid structure? + if sz_fcb[2] EQ 8 then free_lun,fcb.unit + return +; +; error exit (probably should never occur) +; +ioerror: + message = !error_state.msg + if keyword_set(no_abort) then return + message,' ERROR: '+message,/CON + retall +end diff --git a/modules/idl_downloads/astro/pro/fits_help.pro b/modules/idl_downloads/astro/pro/fits_help.pro new file mode 100644 index 0000000..8bd1933 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_help.pro @@ -0,0 +1,119 @@ +pro fits_help,file_or_fcb +;+ +; NAME: +; FITS_HELP +; +; PURPOSE: +; To print a summary of the primary data units and extensions in a +; FITS file. +;; +; CALLING SEQUENCE: +; FITS_HELP,filename_or_fcb +; +; INPUTS: +; FILENAME_OR_FCB - name of the fits file or the FITS Control Block (FCB) +; structure returned by FITS_OPEN. The file name is allowed +; to be gzip compressed (with a .gz extension) +; +; OUTPUTS: +; A summary of the FITS file is printed. For each extension, the values +; of the XTENSION, EXTNAME EXTVER EXTLEVEL BITPIX GCOUNT, PCOUNT NAXIS +; and NAXIS* keywords are displayed. +; +; +; EXAMPLES: +; FITS_HELP,'myfile.fits' +; +; FITS_OPEN,'anotherfile.fits',fcb +; FITS_HELP,fcb +; +; PROCEDURES USED: +; FITS_OPEN, FITS_CLOSE +; HISTORY: +; Written by: D. Lindler August, 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +; Don't truncate EXTNAME values at 10 chars W. Landsman Feb. 2005 +; Use V6.0 notation W. Landsman Jan 2012 +;- +;----------------------------------------------------------------------------- + compile_opt idl2 +; +; print calling sequence +; + if N_params() eq 0 then begin + print,'Syntax - FITS_HELP,file_or_fcb' + return + endif +; +; Open file if file name is supplied +; + fcbtype = size(file_or_fcb,/type) + fcbsize = n_elements(file_or_fcb) + if (fcbsize ne 1) || ((fcbtype ne 7) && (fcbtype ne 8)) then begin + message, 'Invalid Filename or FCB supplied',/con + return + end + + if fcbtype eq 7 then fits_open,file_or_fcb,fcb $ + else fcb = file_or_fcb + +; EXTNAME will always be displayed with a length of at least 10 characters +; but allow for possibility that lengths might be longer than this + + maxlen = max(strlen(fcb.extname)) > 10 + if maxlen EQ 10 then space = '' else $ + space = string(replicate(32b, maxlen -10)) +; +; print headings +; + print,' ' + print,FCB.FILENAME + print,' ' + print,' XTENSION EXTNAME '+ space + $ + 'EXTVER EXTLEVEL BITPIX GCOUNT PCOUNT NAXIS NAXIS*' + print,' ' +; +; loop on extensions +; + for i=0,fcb.nextend do begin + st = string(i,'(I4)') +; +; xtension, extname, extver, extlevel (except for i=0) +; + if i gt 0 then begin + t = fcb.xtension[i] + while strlen(t) lt 8 do t += ' ' + st += ' '+ strmid(t,0,8) + t = fcb.extname[i] + while strlen(t) lt maxlen do t += ' ' + st += ' '+ strmid(t,0,maxlen) + t = fcb.extver[i] + if t eq 0 then st += ' ' $ + else st += string(t,'(I5)') + t = fcb.extlevel[i] + if t eq 0 then st += ' ' $ + else st += string(t,'(I8)') + end else st += ' ' + space +; +; bitpix, gcount, pcount, naxis +; + st += string(fcb.bitpix[i],'(I6)') + st += string(fcb.gcount[i],'(I7)') + st += string(fcb.pcount[i],'(I7)') + st += string(fcb.naxis[i],'(I6)') +; +; naxis* +; + st += ' ' + if fcb.naxis[i] gt 0 then begin + nax1 = fcb.naxis[i] - 1 + st += strjoin(strtrim(fcb.axis[0:nax1,i],2),' x ') + endif +; +; print the info +; + print,st + end + if fcbtype eq 7 then fits_close,fcb +return +end diff --git a/modules/idl_downloads/astro/pro/fits_info.pro b/modules/idl_downloads/astro/pro/fits_info.pro new file mode 100644 index 0000000..c40ece1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_info.pro @@ -0,0 +1,347 @@ +pro fits_info, filename, SILENT=silent,TEXTOUT=textout, N_ext=n_ext, extname=extname +;+ +; NAME: +; FITS_INFO +; PURPOSE: +; Provide information about the contents of a FITS file +; EXPLANATION: +; Information includes number of header records and size of data array. +; Applies to primary header and all extensions. Information can be +; printed at the terminal and/or stored in a common block +; +; This routine is mostly obsolete, and better results can be usually be +; performed with FITS_HELP (for display) or FITS_OPEN (to read FITS +; information into a structure) +; +; CALLING SEQUENCE: +; FITS_INFO, Filename, [ /SILENT , TEXTOUT = , N_ext =, EXTNAME= ] +; +; INPUT: +; Filename - Scalar string giving the name of the FITS file(s) +; Can include wildcards such as '*.fits', or regular expressions +; allowed by the FILE_SEARCH() function. One can also search +; gzip compressed FITS files, but their extension must +; end in .gz or .ftz. +; OPTIONAL INPUT KEYWORDS: +; /SILENT - If set, then the display of the file description on the +; terminal will be suppressed +; +; TEXTOUT - specifies output device. +; textout=1 TERMINAL using /more option +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file, see TEXTOPEN +; textout=7 append to existing file +; textout = filename (default extension of .prt) +; +; If TEXTOUT is not supplied, then !TEXTOUT is used +; OPTIONAL OUTPUT KEYWORDS: +; The following keyowrds are for use when only one file is processed +; +; N_ext - Returns an integer scalar giving the number of extensions in +; the FITS file +; extname - returns a list containing the EXTNAME keywords for each +; extension. +; +; COMMON BLOCKS +; DESCRIPTOR = File descriptor string of the form N_hdrrec Naxis IDL_type +; Naxis1 Naxis2 ... Naxisn [N_hdrrec table_type Naxis +; IDL_type Naxis1 ... Naxisn] (repeated for each extension) +; For example, the following descriptor +; 167 2 4 3839 4 55 BINTABLE 2 1 89 5 +; +; indicates that the primary header containing 167 lines, and +; the primary (2D) floating point image (IDL type 4) +; is of size 3839 x 4. The first extension header contains +; 55 lines, and the byte (IDL type 1) table array is of size +; 89 x 5. +; +; The DESCRIPTOR is *only* computed if /SILENT is set. +; EXAMPLE: +; Display info about all FITS files of the form '*.fit' in the current +; directory +; +; IDL> fits_info, '*.fit' +; +; Any time a *.fit file is found which is *not* in FITS format, an error +; message is displayed at the terminal and the program continues +; +; PROCEDURES USED: +; GETTOK(), MRD_SKIP, STRN(), SXPAR(), TEXTOPEN, TEXTCLOSE +; +; SYSTEM VARIABLES: +; The non-standard system variables !TEXTOUT and !TEXTUNIT will be +; created by FITS_INFO if they are not previously defined. +; +; DEFSYSV,'!TEXTOUT',1 +; DEFSYSV,'!TEXTUNIT',0 +; +; See TEXTOPEN.PRO for more info +; MODIFICATION HISTORY: +; Written, K. Venkatakrishna, Hughes STX, May 1992 +; Added N_ext keyword, and table_name info, G. Reichert +; Work on *very* large FITS files October 92 +; More checks to recognize corrupted FITS files February, 1993 +; Proper check for END keyword December 1994 +; Correctly size variable length binary tables WBL December 1994 +; EXTNAME keyword can be anywhere in extension header WBL January 1998 +; Correctly skip past extensions with no data WBL April 1998 +; Converted to IDL V5.0, W. Landsman, April 1998 +; No need for !TEXTOUT if /SILENT D.Finkbeiner February 2002 +; Define !TEXTOUT if needed. R. Sterner, 2002 Aug 27 +; Work on gzip compressed files for V5.3 or later W. Landsman 2003 Jan +; Improve speed by only reading first 36 lines of header +; Count headers with more than 32767 lines W. Landsman Feb. 2003 +; Assume since V5.3 (OPENR,/COMPRESS) W. Landsman Feb 2004 +; EXTNAME keyword can be anywhere in extension header again +; WBL/S. Bansal Dec 2004 +; Read more than 200 extensions WBL March 2005 +; Work for FITS files with SIMPLE=F WBL July 2005 +; Assume since V5.4, fstat.compress available WBL April 2006 +; Added EXTNAME as an IDL keyword to return values. M. Perrin Dec 2007 +; make Ndata a long64 to deal with large files. E. Hivon Mar 2008 +; For GDL compatibility, first check if file is compressed before using +; OPENR,/COMPRESS B. Roukema/WL Apr 2010 +; Increased nmax (max number of extensions) from 400 to 2000 Sept 2012 +; Correctly fills EXTNAME when SILENT is set EH Jan 2013 +; Turned ptr to long64 in order to read very large files EH Dec 2013 +;- + On_error,2 + compile_opt idl2 + COMMON descriptor,fdescript + + if N_params() lt 1 then begin + print,'Syntax - FITS_INFO, filename, [/SILENT, TEXTOUT=, N_ext=, EXTNAME=]' + return + endif + + defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it. + + fil = file_search( filename, COUNT = nfiles) + if nfiles EQ 0 then message,'No files found' +; File is gzip compressed if it ends in .gz or .ftz + len = strlen(fil) + ext = strlowcase(strmid(fil,transpose(len-3),3)) + compress = (ext EQ '.gz') || (ext EQ 'ftz') + + silent = keyword_set( SILENT ) + if ~silent then begin + if ~keyword_set( TEXTOUT ) then textout = !TEXTOUT + textopen, 'FITS_INFO', TEXTOUT=textout + endif + + for nf = 0, nfiles-1 do begin + + file = fil[nf] + + openr, lun1, file, /GET_LUN, COMPRESS = compress[nf] + + N_ext = -1 + fdescript = '' + nmax = 2000 ; MDP was 100, then 400 + nbuf= nmax + extname = strarr(nmax) + + ptr = 0LL + START: + ON_IOerror, BAD_FILE + descript = '' +; Is this a proper FITS file? + test = bytarr(8) + readu, lun1, test + + if N_ext EQ -1 then begin + if string(test) NE 'SIMPLE ' then goto, BAD_FILE + simple = 1 + endif else begin + if string(test) NE 'XTENSION' then goto, END_OF_FILE + simple = 0 + endelse + point_lun, lun1, ptr + +; Read the header + hdr = bytarr(80, 36, /NOZERO) + N_hdrblock = 1 + readu, lun1, hdr + ptr += 2880 + hd = string( hdr > 32b) + +; Get values of BITPIX, NAXIS etc. + bitpix = sxpar(hd, 'BITPIX', Count = N_BITPIX) + if N_BITPIX EQ 0 then $ + message, 'WARNING - FITS header missing BITPIX keyword',/CON + Naxis = sxpar( hd, 'NAXIS', Count = N_NAXIS) + if N_NAXIS EQ 0 then message, $ + 'WARNING - FITS header missing NAXIS keyword',/CON + + exten = sxpar( hd, 'XTENSION') + Ext_type = strmid( strtrim( exten ,2), 0, 8) ;Use only first 8 char + gcount = sxpar( hd, 'GCOUNT') > 1 + pcount = sxpar( hd, 'PCOUNT') + + if strn(Ext_type) NE '0' then begin + if (gcount NE 1) or (pcount NE 0) then $ + ext_type = 'VAR_' + ext_type + descript += ' ' + Ext_type + endif + + descript += ' ' + strn(Naxis) + + case BITPIX of + 8: IDL_type = 1 ;Byte + 16: IDL_type = 2 ;16 bit signed integer + 32: IDL_type = 3 ;32 bit signed integer + -32: IDL_type = 4 ;Float + -64: IDL_type = 5 ;Double + ELSE: begin + message, ' Illegal value of BITPIX = ' + strn(bitpix) + $ + ' in header',/CON + goto, SKIP + end + endcase + + if Naxis GT 0 then begin + descript += ' ' + strn(IDL_type) + Nax = sxpar( hd, 'NAXIS*') + if N_elements(Nax) LT Naxis then begin + message, $ + 'ERROR - Missing required NAXISi keyword in FITS header',/CON + goto, SKIP + endif + for i = 1, Naxis do descript += ' '+strn(Nax[i-1]) + endif + + end_rec = where( strtrim(strmid(hd,0,8),2) EQ 'END') + + exname = sxpar(hd, 'extname', Count = N_extname) + if N_extname GT 0 then extname[N_ext+1] = exname + get_extname = (N_ext GE 0) && (N_extname EQ 0) + +; Read header records, till end of header is reached + + hdr = bytarr(80, 36, /NOZERO) + while (end_rec[0] EQ -1) && (~eof(lun1) ) do begin + readu,lun1,hdr + ptr = ptr + 2880L + hd1 = string( hdr > 32b) + end_rec = where( strtrim(strmid(hd1,0,8),2) EQ 'END') + n_hdrblock++ + if get_extname then begin + exname = sxpar(hd1, 'extname', Count = N_extname) + if N_extname GT 0 then begin + extname[N_ext+1] = exname + get_extname = 0 + endif + endif + endwhile + + n_hdrec = 36L*(n_hdrblock-1) + end_rec[0] + 1L ; size of header + descript = strn( n_hdrec ) + descript + +; If there is data associated with primary header, then find out the size + + if Naxis GT 0 then begin + ndata = long64(Nax[0]) + if naxis GT 1 then for i = 2, naxis do ndata *= Nax[i-1] + endif else ndata = 0 + + nbytes = (abs(bitpix)/8) * gcount * (pcount + ndata) + nrec = long(( nbytes +2879)/ 2880) + + + +; Check if all headers have been read + + if ( simple EQ 0 ) && ( strlen(strn(exten)) EQ 1) then goto, END_OF_FILE + + N_ext++ + if N_ext GE (nmax-1) then begin + extname = [extname,strarr(nbuf)] + nmax = N_elements(extname) + endif + +; Append information concerning the current extension to descriptor + + fdescript += ' ' + descript + +; Check for EOF +; Skip the headers and data records + + ptr += nrec*2880L + if compress[nf] then mrd_skip,lun1,nrec*2880L else point_lun,lun1,ptr + if ~eof(lun1) then goto, START +; + END_OF_FILE: + + extname = extname[0:N_ext] ;strip off bogus first value + ;otherwise will end up with '' at end + + if ~SILENT then begin + printf,!textunit,file,' has ',strn(N_ext),' extensions' + printf,!textunit,'Primary header: ',gettok(fdescript,' '),' records' + + Naxis = gettok( fdescript,' ' ) + + If Naxis NE '0' then begin + + case gettok(fdescript,' ') of + + '1': image_type = 'Byte' + '2': image_type = 'Integer*2' + '3': image_type = 'Integer*4' + '4': image_type = 'Real*4' + '5': image_type = 'Real*8' + + endcase + + image_desc = 'Image -- ' + image_type + ' array (' + for i = 0,fix(Naxis)-1 do image_desc = image_desc + ' '+ gettok(fdescript,' ') + image_desc = image_desc+' )' + + endif else image_desc = 'No data' + printf,!textunit, format='(a)',image_desc + + if N_ext GT 0 then begin + for i = 1,N_ext do begin + + printf, !TEXTUNIT, 'Extension ' + strn(i) + ' -- '+extname[i] + + header_desc = ' Header : '+gettok(fdescript,' ')+' records' + printf, !textunit, format = '(a)',header_desc + + table_type = gettok(fdescript,' ') + + case table_type of + 'A3DTABLE' : table_desc = 'Binary Table' + 'BINTABLE' : table_desc = 'Binary Table' + 'VAR_BINTABLE': table_desc = 'Variable length Binary Table' + 'TABLE': table_desc = 'ASCII Table' + ELSE: table_desc = table_type + endcase + + table_desc = ' ' + table_desc + ' ( ' + table_dim = fix( gettok( fdescript,' ') ) + if table_dim GT 0 then begin + table_type = gettok(fdescript,' ') + for j = 0, table_dim-1 do $ + table_desc += gettok(fdescript,' ') + ' ' + endif + table_desc += ')' + + printf,!textunit, format='(a)',table_desc + endfor + endif + + printf, !TEXTUNIT, ' ' + endif + SKIP: free_lun, lun1 + endfor + if ~silent then textclose, TEXTOUT=textout + return + + BAD_FILE: + message, 'Error reading FITS file ' + file, /CON + goto,SKIP +end diff --git a/modules/idl_downloads/astro/pro/fits_open.pro b/modules/idl_downloads/astro/pro/fits_open.pro new file mode 100644 index 0000000..87bb87b --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_open.pro @@ -0,0 +1,459 @@ +pro fits_open,filename,fcb,write=write,append=append,update=update, $ + no_abort=no_abort,message=message,hprint=hprint,fpack=fpack +;+ +; NAME: +; FITS_OPEN +; +; PURPOSE: +; Opens a FITS (Flexible Image Transport System) data file. +; +; EXPLANATION: +; Used by FITS_READ and FITS_WRITE +; +; CALLING SEQUENCE: +; FITS_OPEN, filename, fcb +; +; INPUTS: +; filename : name of the FITS file to open, scalar string +; FITS_OPEN can also open gzip compressed (.gz) files or Unix +; compressed files *for reading only*, although there is a +; performance penalty. FPACK ( +; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) +; compressed FITS files can be read provided that the FPACK +; software is installed. +;*OUTPUTS: +; fcb : (FITS Control Block) a IDL structure containing information +; concerning the file. It is an input to FITS_READ, FITS_WRITE +; FITS_CLOSE and MODFITS. +; INPUT KEYWORD PARAMETERS: +; /APPEND: Set to append to an existing file. +; /FPACK - Signal that the file is compressed with the FPACK software. +; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) By default, +; FITS_OPEN assumes that if the file name extension ends in +; .fz that it is fpack compressed. The FPACK software must +; be installed on the system +; /HPRINT - print headers with routine HPRINT as they are read. +; (useful for debugging a strange file) +; /NO_ABORT: Set to quietly return to calling program when an I/O error +; is encountered, and return a non-null string +; (containing the error message) in the keyword MESSAGE. +; If /NO_ABORT not set, then FITS_OPEN will display the error +; message and return to the calling program. +; /UPDATE Set this keyword to open an existing file for update +; /WRITE: Set this keyword to open a new file for writing. +; +; OUTPUT KEYWORD PARAMETERS: +; MESSAGE = value: Output error message. If the FITS file was opened +; successfully, then message = ''. +; +; NOTES: +; The output FCB should be passed to the other FITS routines (FITS_OPEN, +; FITS_READ, FITS_HELP, and FITS_WRITE). It has the following structure +; when FITS_OPEN is called without /WRITE or /APPEND keywords set. +; +; FCB.FILENAME - name of the input file +; .UNIT - unit number the file is opened to +; .FCOMPRESS - 1 if unit is a FPACK compressed file opened with +; a pipe to SPAWN +; .NEXTEND - number of extensions in the file. +; .XTENSION - string array giving the extension type for each +; extension. +; .EXTNAME - string array giving the extension name for each +; extension. (null string if not defined the extension) +; .EXTVER - vector of extension version numbers (0 if not +; defined) +; .EXTLEVEL - vector of extension levels (0 if not defined) +; .GCOUNT - vector with the number of groups in each extension. +; .PCOUNT - vector with parameter count for each group +; .BITPIX - BITPIX for each extension with values +; 8 byte data +; 16 short word integers +; 32 long word integers +; -32 IEEE floating point +; -64 IEEE double precision floating point +; .NAXIS - number of axes for each extension. (0 for null data +; units) +; .AXIS - 2-D array where axis[*,N] gives the size of each axes +; for extension N +; .START_HEADER - vector giving the starting byte in the file +; where each extension header begins +; .START_DATA - vector giving the starting byte in the file +; where the data for each extension begins +; +; .HMAIN - keyword parameters (less standard required FITS +; keywords) for the primary data unit. +; .OPEN_FOR_WRITE - flag (0= open for read, 1=open for write, +; 2=open for update) +; .LAST_EXTENSION - last extension number read. +; .RANDOM_GROUPS - 1 if the PDU is random groups format, +; 0 otherwise +; .NBYTES - total number of (uncompressed) bytes in the FITS file +; +; When FITS open is called with the /WRITE or /APPEND option, FCB +; contains: +; +; FCB.FILENAME - name of the input file +; .UNIT - unit number the file is opened to +; .NEXTEND - number of extensions in the file. +; .OPEN_FOR_WRITE - flag (1=open for write, 2=open for append +; 3=open for update) +; +; +; EXAMPLES: +; Open a FITS file for reading: +; FITS_OPEN,'myfile.fits',fcb +; +; Open a new FITS file for output: +; FITS_OPEN,'newfile.fits',fcb,/write +; PROCEDURES USED: +; GET_PIPE_FILESIZE (for Fcompress'ed files) HPRINT, SXDELPAR, SXPAR() +; HISTORY: +; Written by: D. Lindler August, 1995 +; July, 1996 NICMOS Modified to allow open for overwrite +; to allow primary header to be modified +; DJL Oct. 15, 1996 corrected to properly extend AXIS when more +; than 100 extensions present +; Converted to IDL V5.0 W. Landsman September 1997 +; Use Message = '' rather than !ERR =1 as preferred signal of normal +; operation W. Landsman November 2000 +; Lindler, Dec, 2001, Modified to use 64 bit words for storing byte +; positions within the file to allow support for very large +; files +; Work with gzip compressed files W. Landsman January 2003 +; Fix gzip compress for V5.4 and earlier W.Landsman/M.Fitzgerald Dec 2003 +; Assume since V5.3 (STRSPLIT, OPENR,/COMPRESS) W. Landsman Feb 2004 +; Treat FTZ extension as gzip compressed W. Landsman Sep 2004 +; Assume since V5.4 fstat.compress available W. Landsman Apr 2006 +; FCB.Filename now expands any wildcards W. Landsman July 2006 +; Make ndata 64bit for very large files B. Garwood/W. Landsman Sep 2006 +; Open with /SWAP_IF_LITTLE_ENDIAN, remove obsolete keywords to OPEN +; W. Landsman Sep 2006 +; Warn that one cannot open a compressed file for update W.L. April 2007 +; Use post-V6.0 notation W.L. October 2010 +; Support FPACK compressed files, new .FCOMPRESS tag to FCB structure +; W.L. December 2010 +; Read gzip'ed files even if gzip is not installed W.L. October 2012 +; Handle axis sizes requiring 64 integer W.L. April 2014 +; Support for .Z compressed files M. Zechmeister/W.L. April 2014 +; Wrap filenames in "" when spawning subprocesses, to handle paths +; with spaces or other atypical characters. M. Perrin Nov 2014 +;- +;-------------------------------------------------------------------- + compile_opt idl2 +; if no parameters supplied, print calling sequence +; + if N_params() LT 1 then begin + print,'Syntax - FITS_OPEN, filename, fcb' + print,' Input Keywords: /Append, /Hprint, /No_abort, /Update, /Write' + print,' Output Keyword: Message= ' + return + endif +; +; set default keyword parameters +; + + message = '' + open_for_read = 1 + open_for_update = 0 + open_for_write = 0 + open_for_overwrite = 0 + if keyword_set(write) then begin + open_for_read = 0 + open_for_update = 0 + open_for_write = 1 + open_for_overwrite = 0 + end + if keyword_set(append) then begin + open_for_read = 0 + open_for_write = 0 + open_for_update = 1 + open_for_overwrite = 0 + end + if keyword_set(update) then begin + open_for_read = 1 + open_for_write = 0 + open_for_update = 0 + open_for_overwrite = 1 + end +; +; on I/O errors goto statement ioerror: +; + on_ioerror,ioerror +; +; open file +; + + ext = strlowcase(strmid(filename, 2, /rev)) + docompress = (ext EQ '.gz') || (ext EQ 'ftz') + fcompress = keyword_set(fpack) || ( ext EQ '.fz') + zcompress = (strmid(filename, 1, /rev) EQ '.Z') + if docompress && open_for_overwrite then begin + message = 'Compressed FITS files cannot be open for update' + if ~keyword_set(no_abort) then $ + message,' ERROR: '+message,/CON + return + endif + ; +; open file +; + if ~fcompress && ~zcompress then get_lun,unit + if fcompress then $ + spawn,'funpack -S "' + filename+'"', unit=unit,/sh else $ + if zcompress then $ + spawn,'gzip -cd "'+filename+'"', unit=unit,/sh else $ + if docompress then $ + openr,unit,filename, /compress,/swap_if_little else begin + case 1 of + keyword_set(append): openu,unit,filename,/swap_if_little + keyword_set(update): openu,unit,filename,/swap_if_little + keyword_set(write) : openw,unit,filename,/swap_if_little + else : openr,unit,filename,/swap_if_little + endcase + endelse + + file = fstat(unit) + fname = file.name ;In case the user input a wildcard + docompress = file.compress + +; Need to spawn to "gzip -l" to get the number of uncompressed bytes in a gzip +; compressed file. If gzip doesn't work for some reason then use +; get_pipe_filesize. + + if fcompress then begin + get_pipe_filesize,unit, nbytes_in_file + free_lun,unit + spawn,'funpack -S "' + filename +'"', unit=unit,/sh + endif else if docompress then begin + if !VERSION.OS_FAMILY Eq 'Windows' then $ + fname = file_search(fname,/fully_qualify) + spawn,'gzip -l "' + fname+'"', output + output = strtrim(output,2) + g = where(strmid(output,0,8) EQ 'compress', Nfound) + if Nfound EQ 0 then begin + get_pipe_filesize, unit, nbytes_in_file + close,unit + openr,unit,filename, /compress,/swap_if_little + endif else $ + nbytes_in_file = long64((strsplit(output[g[0]+1],/extract))[1]) + endif else if zcompress then begin + spawn,'zcat "' + filename+'"' + ' | wc -c', nbytes_in_file + if nbytes_in_file EQ 0 then message,'Unable to zcat decompress ' + fname + endif else nbytes_in_file = file.size + +; +; create vectors needed to store header information for each extension +; + n = 100 + xtension = strarr(n) + extname = strarr(n) + extver = lonarr(n) + extlevel = lonarr(n) + gcount = lonarr(n) + pcount = lonarr(n) + bitpix = lonarr(n) + naxis = lonarr(n) + axis = lon64arr(20,n) + start_header = lon64arr(n) ; starting byte in file for header + start_data = lon64arr(n) ; starting byte in file for data + position = 0ULL ; current byte position in file + skip = 0ULL ; Amount to skip from current position +; +; read and process each header in the file if open for read or update +; + extend_number = 0 ; current extension number being + ; processed + + if open_for_read || open_for_update then begin + main_header = 1 ; first header in file flag + h = bytarr(80,36,/nozero) ; read buffer +; +; loop on headers in the file +; + repeat begin + if skip GT 0 then if (fcompress || zcompress) then mrd_skip,unit,skip else $ + point_lun,unit,position + start = position +; +; loop on header blocks +; + first_block = 1 ; first block in header flag + repeat begin + + if (~fcompress && ~zcompress) && position+2879 ge nbytes_in_file then begin + if extend_number eq 0 then begin + message = 'EOF encountered while reading header' + goto,error_exit + endif + print,'EOF encountered reading extension header' + print,'Only '+strtrim(extend_number-1,2) + $ + ' extensions processed' + goto,done_headers + endif + + readu,unit,h + position = position + 2880 + hdr = string(h>32b) + endline = where(strmid(hdr,0,8) eq 'END ',nend) + if nend gt 0 then hdr = hdr[0:endline[0]] + if first_block then begin +; +; check for valid header (SIMPLE keyword must be first for PDU and +; XTENSION keyword for the extensions. +; + header = hdr + keyword = strmid(header[0],0,8) + if (extend_number eq 0) && $ + (keyword ne 'SIMPLE ') then begin + message = 'Invalid header, no SIMPLE keyword' + goto,error_exit + endif + + if (extend_number gt 0) && $ + (keyword ne 'XTENSION') then begin + print,'Invalid extension header encountered' + print,'XTENSION keyword missing' + print,'Only '+strtrim(extend_number-1,2) + $ + ' extensions processed' + goto,done_headers + endif + + end else header = [header,hdr] + first_block = 0 + end until (nend gt 0) + +; +; print header if hprint set +; + if keyword_set(hprint) then hprint,header +; +; end of loop on header blocks +; +; Increase size of vectors if needed +; + if extend_number ge n then begin + xtension = [xtension,strarr(n)] + extname = [extname,strarr(n)] + extver = [extver,lonarr(n)] + extlevel = [extver,lonarr(n)] + gcount = [gcount,lonarr(n)] + pcount = [pcount,lonarr(n)] + bitpix = [bitpix,lonarr(n)] + naxis = [naxis,lonarr(n)] + old_axis = axis + axis = lonarr(20,n*2) + axis[0,0] = old_axis + start_header = [start_header,lonarr(n)] + start_data = [start_data,lonarr(n)] + n = n*2 + end +; +; extract information from header +; + xtension[extend_number] = strtrim(sxpar(header,'xtension')) + st = sxpar(header,'extname', Count = N_extname) + if N_extname EQ 0 then st = '' + extname[extend_number] = strtrim(st,2) + extver[extend_number] = sxpar(header,'extver') + extlevel[extend_number] = sxpar(header,'extlevel') + gcount[extend_number] = sxpar(header,'gcount') + pcount[extend_number] = sxpar(header,'pcount') + bitpix[extend_number] = sxpar(header,'bitpix') + nax = sxpar(header,'naxis') + naxis[extend_number] = nax + if nax gt 0 then begin + naxisi = sxpar(header,'naxis*') + axis[0,extend_number] = naxisi + ndata = product(naxisi,/integer) + endif else ndata = 0 + + start_data[extend_number] = position + start_header[extend_number] = start +; +; if first header, save without FITS required keywords +; + if extend_number eq 0 then begin + hmain = header + random_groups = sxpar(header,'groups') + sxdelpar,hmain,['SIMPLE','BITPIX','NAXIS','NAXIS1', $ + 'NAXIS2','NAXIS3','NAXIS4','NAXIS5', $ + 'NAXIS6','NAXIS7','NAXIS8','EXTEND', $ + 'PCOUNT','GCOUNT','GROUPS','BSCALE', $ + 'BZERO','NPIX1','NPIX2','PIXVALUE'] + if (pcount[0] gt 0) then for i=1,pcount[0] do $ + sxdelpar,hmain,['ptype','pscal','pzero']+strtrim(i,2) + endif +; +; skip past data to go to next header +; + nbytes = (abs(bitpix[extend_number])/8) * $ + (gcount[extend_number]>1)*(pcount[extend_number] + ndata) + skip = (nbytes + 2879)/2880*2880 + position += skip + +; +; end loop on headers +; + + extend_number += 1 + end until (position ge nbytes_in_file-2879) + end +; +; point at end of file in /extend +; +done_headers: + if open_for_update then point_lun,unit,nbytes_in_file +; +; number of extensions +; + if open_for_write then nextend = -1 $ + else nextend = extend_number - 1 +; +; set up blank hmain if open for write +; + if open_for_write then begin + hmain = strarr(1) + hmain[0] = 'END ' + end +; +; create output structure for the file control block +; + if open_for_write or open_for_update then begin + fcb = {filename:fname,unit:unit,nextend:nextend, $ + open_for_write:open_for_write + open_for_update*2} + end else begin + nx = nextend + fcb = {filename:fname,unit:unit,fcompress:fcompress||zcompress, $ + nextend:nextend, $ + xtension:xtension[0:nx],extname:extname[0:nx], $ + extver:extver[0:nx],extlevel:extlevel[0:nx], $ + gcount:gcount[0:nx],pcount:pcount[0:nx], $ + bitpix:bitpix[0:nx],naxis:naxis[0:nx], $ + axis:axis[*,0:nx], $ + start_header:start_header[0:nx], $ + start_data:start_data[0:nx],hmain:hmain, $ + open_for_write:open_for_overwrite*3,$ + last_extension:-1, $ + random_groups:random_groups, $ + nbytes: nbytes_in_file } + end + if fcompress then begin + free_lun,unit + spawn,'funpack -S "' + filename+'"', unit=unit,/sh + endif else if zcompress then begin + free_lun,unit + spawn,'gzip -cd "' + filename+'"', unit=unit, /sh + endif + !err = 1 ;For obsolete users still using !err + return +; +; error exit +; +ioerror: + message = !ERROR_STATE.msg +error_exit: + free_lun,unit + !err = -1 + if keyword_set(no_abort) then return + message,' ERROR: '+message,/CON + return +end diff --git a/modules/idl_downloads/astro/pro/fits_read.pro b/modules/idl_downloads/astro/pro/fits_read.pro new file mode 100644 index 0000000..2977ae3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_read.pro @@ -0,0 +1,573 @@ +pro fits_read,file_or_fcb,data,header,group_par,noscale=noscale, $ + exten_no=exten_no, extname=extname, $ + extver=extver, extlevel=extlevel, xtension=xtension, $ + no_abort=no_abort, message=message, first=first, last=last, $ + group=group, header_only=header_only,data_only=data_only, $ + no_pdu=no_pdu, enum = enum, no_unsigned = no_unsigned, pdu=pdu + +;+ +; NAME: +; FITS_READ +; PURPOSE: +; To read a FITS file. +; +; CALLING SEQUENCE: +; FITS_READ, filename_or_fcb, data [,header, group_par] +; +; INPUTS: +; FILENAME_OR_FCB - this parameter can be the FITS Control Block (FCB) +; returned by FITS_OPEN or the file name of the FITS file. If +; a file name is supplied, FITS_READ will open the file with +; FITS_OPEN and close the file with FITS_CLOSE before exiting. +; When multiple extensions are to be read from the file, it is +; more efficient for the user to call FITS_OPEN and leave the +; file open until all extensions are read. FPACK +; ( http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) compressed FITS +; files can be read provided that the FPACK software is installed. +; Both Gzip compressed (.gz) and Unix compressed (*.Z) files can +; be read, although there is a performance penalty.. +; +; OUTPUTS: +; DATA - data array. If /NOSCALE is specified, BSCALE and BZERO +; (if present in the header) will not be used to scale the data. +; If Keywords FIRST and LAST are used to read a portion of the +; data or the heap portion of an extension, no scaling is done +; and data is returned as a 1-D vector. The user can use the IDL +; function REFORM to convert the data to the correct dimensions +; if desired. If /DATA_ONLY is specified, no scaling is done. +; HEADER - FITS Header. The STScI inheritance convention is recognized +; http://fits.gsfc.nasa.gov/registry/inherit/fits_inheritance.txt +; If an extension is read, and the INHERIT keyword exists with a +; value of T, and the /NO_PDU keyword keyword is not supplied, +; then the primary data unit header and the extension header will +; be combined. The header will have the form: +; +; +; BEGIN MAIN HEADER -------------------------------- +; +; BEGIN EXTENSION HEADER --------------------------- +; 1. (Default=0, the first group) +; +; OUTPUT KEYWORD PARAMETERS: +; ENUM - Output extension number that was read. +; MESSAGE = value: Output error message +; +; NOTES: +; Determination or which extension to read. +; case 1: EXTEN_NO specified. EXTEN_NO will give the number of the +; extension to read. The primary data unit is refered +; to as extension 0. If EXTEN_NO is specified, XTENSION, +; EXTNAME, EXTVER, and EXTLEVEL parameters are ignored. +; case 2: if EXTEN_NO is not specified, the first extension +; with the specified XTENSION, EXTNAME, EXTVER, and +; EXTLEVEL will be read. If any of the 4 parameters +; are not specified, they will not be used in the search. +; Setting EXTLEVEL=0, EXTVER=0, EXTNAME='', or +; XTENSION='' is the same as not supplying them. +; case 3: if none of the keyword parameters, EXTEN_NO, XTENSION, +; EXTNAME, EXTVER, or EXTLEVEL are supplied. FITS_READ +; will read the next extension in the file. If the +; primary data unit (PDU), extension 0, is null, the +; first call to FITS_READ will read the first extension +; of the file. +; +; The only way to read a null PDU is to use EXTEN_NO = 0. +; +; If FIRST and LAST are specified, the data is returned without applying +; any scale factors (BSCALE and BZERO) and the data is returned in a +; 1-D vector. This will allow you to read any portion of a multiple +; dimension data set. Once returned, the IDL function REFORM can be +; used to place the correct dimensions on the data. +; +; IMPLICIT IMAGES: FITS_READ will construct an implicit image +; for cases where NAXIS=0 and the NPIX1, NPIX2, and PIXVALUE +; keywords are present. The output image will be: +; image = replicate(PIXVALUE,NPIX1,NPIX2) +; +; FPACK compressed files are always closed and reopened when exiting +; FITS_READ so that the pointer is set to the beginning of the file. (Since +; FPACK files are opened with a bidirectional pipe rather than OPEN, one +; cannot use POINT_LUN to move to a specified position in the file.) +; +; EXAMPLES: +; Read the primary data unit of a FITS file, if it is null read the +; first extension: +; FITS_READ, 'myfile.fits', data, header +; +; Read the first two extensions of a FITS file and the extension with +; EXTNAME = 'FLUX' and EXTVER = 4 +; FITS_OPEN, 'myfile.fits', fcb +; FITS_READ, fcb,data1, header2, exten_no = 1 +; FITS_READ, fcb,data1, header2, exten_no = 2 +; FITS_READ, fcb,data3, header3, extname='flux', extver=4 +; FITS_CLOSE, fcb +; +; Read the sixth image in a data cube for the fourth extension. +; +; FITS_OPEN, 'myfile.fits', fcb +; image_number = 6 +; ns = fcb.axis[0,4] +; nl = fcb.axis[1,4] +; i1 = (ns*nl)*(image_number-1) +; i2 = i2 + ns*nl-1 +; FITS_READ,fcb,image,header,first=i1,last=i2 +; image = reform(image,ns,nl,/overwrite) +; FITS_CLOSE, fcb +; +; PROCEDURES USED: +; FITS_CLOSE, FITS_OPEN +; SXADDPAR, SXDELPAR, SXPAR() +; WARNINGS: +; In Sep 2006, FITS_OPEN was modified to open FITS files using the +; /SWAP_IF_LITTLE_ENDIAN keyword to OPEN, so that subsequent routines +; (FITS_READ, FITS_WRITE) did not require any byte swapping. An error +; may result if an pre-Sep 2006 version of FITS_OPEN is used with a +; post Sep 2006 version of FITS_READ, FITS_WRITE or MODFITS. +; HISTORY: +; Written by: D. Lindler, August 1995 +; Avoid use of !ERR W. Landsman August 1999 +; Read unsigned datatypes, added /no_unsigned W. Landsman December 1999 +; Don't call FITS_CLOSE unless fcb is defined W. Landsman January 2000 +; Set BZERO = 0 for unsigned integer data W. Landsman January 2000 +; Only call IEEE_TO_HOST if needed W. Landsman February 2000 +; Ensure EXTEND keyword in primary header W. Landsman April 2001 +; Don't erase ERROR message when closing file W. Landsman April 2002 +; Assume at least V5.1 remove NANValue keyword W. Landsman November 2002 +; Work with compress files (read file size from fcb), +; requires updated (Jan 2003) version of FITS_OPEN W. Landsman Jan 2003 +; Do not modify BSCALE/BZERO for unsigned integers W. Landsman April 2006 +; Assume FITS_OPEN has opened the file with /SWAP_IF_LITTLE_ENDIAN +; W. Landsman September 2006 +; Fix problem with /DATA_ONLY keyword M.Buie/W.Landsman October 2006 +; Only append primary header if INHERIT=T W. Landsman April 2007 +; Make ndata 64bit for very large files E. Hivon/W. Landsman May 2007 +; Added /PDU keyword to always append primary header W. Landsman June 2007 +; Use PRODUCT to compute # of data points W. Landsman May 2009 +; Make sure FIRST is long64 when computing position W.L. October 2009 +; Read FPACK compressed files, W.L. December 2010 +; Don't assume FCB has a FCOMPRESS tag W.L./Satori UeNO September 2012 +; Make sure opened pipes are closed if fcb not left open W.L. April 2012 +; Fix bug with /data_only introduced Dec 2010 W. L. April 2014 +;- +; +;----------------------------------------------------------------------------- + compile_opt idl2 +; print calling sequence +; + if N_params() eq 0 then begin + print,'Syntax - FITS_READ,file_or_fcb,data,header,group_par' + print,' Input Keywords: /noscale, exten_no=, extname=, ' + print,' extver=, extlevel=, xtension=, /no_abort, ' + print,' first, last, group, /header_only, /no_pdu, /pdu' + print,' Output Keywords: enum =, message=' + return + endif +; +; I/O error processing +; + on_ioerror,ioerror +; +; set defaults +; + message = '' + if n_elements(noscale) eq 0 then noscale = 0 + if n_elements(exten_no) eq 0 then exten_no = -1 + if n_elements(extname) eq 0 then extname = '' + if n_elements(extver) eq 0 then extver = 0 + if n_elements(extlevel) eq 0 then extlevel = 0 + if n_elements(first) eq 0 then first = 0 + if n_elements(last) eq 0 then last = 0 + if n_elements(no_abort) eq 0 then no_abort = 0 + if n_elements(group) eq 0 then group = 0 + if n_elements(header_only) eq 0 then header_only = 0 + if n_elements(data_only) eq 0 then data_only = 0 + if n_elements(no_pdu) eq 0 then no_pdu = 0 + if n_elements(pdu) eq 0 then pdu = 0 + if n_elements(xtension) eq 0 then xtension = '' +; +; Open file if file name is supplied +; + fcbtype = size(file_or_fcb,/type) + fcbsize = n_elements(file_or_fcb) + if (fcbsize ne 1) || ((fcbtype ne 7) && (fcbtype ne 8)) then begin + message = 'Invalid Filename or FCB supplied' + goto,error_exit + end + + if fcbtype eq 7 then begin + fits_open,file_or_fcb,fcb,no_abort=no_abort,message=message + if message NE '' then goto,error_exit + end else fcb = file_or_fcb +; +; determine which extension to read ========================================== +; +; case 1: exten_no specified +; + + enum = exten_no + if exten_no le -1 then begin +; +; case 2: extname, extver, or extlevel specified +; + if (extname ne '') || (extlevel ne 0) || (extver ne 0) || $ + (xtension ne '') then begin +; +; find extensions with supplied extname, extver, extlevel, and xtension +; + good = replicate(1b,fcb.nextend+1) + if extname ne '' then good = good and $ + (strtrim(strupcase(extname)) eq strupcase(fcb.extname)) + if xtension ne '' then good = good and $ + (strtrim(strupcase(xtension)) eq strupcase(fcb.xtension)) + if extver ne 0 then good = good and (extver eq fcb.extver) + if extlevel ne 0 then good = good and (extlevel eq fcb.extlevel) + good = where(good,ngood) +; +; select first one +; + if ngood le 0 then begin + message='No extension for given extname, extver, and/or' + $ + ' extlevel found' + goto,error_exit + endif + enum = good[0] + end else begin +; +; case 3: read next extension +; + enum = fcb.last_extension + 1 + if (enum eq 0) && (fcb.naxis[0] eq 0) then enum = 1 + end + end +; +; check to see if it is a valid extension +; + if enum gt fcb.nextend then begin + message='EOF encountered' + goto,error_exit + end +; +; extract information from FCB for the extension +; + bitpix = fcb.bitpix[enum] + naxis = fcb.naxis[enum] + if naxis gt 0 then axis = fcb.axis[0:naxis-1,enum] + gcount = fcb.gcount[enum] + pcount = fcb.pcount[enum] + xtension = fcb.xtension[enum] + fcompress = tag_exist(fcb,'fcompress') ? fcb.fcompress : 0 +; +; read header ================================================================ +; + if data_only then goto,read_data + h = bytarr(80,36,/nozero) + nbytes_in_file = fcb.nbytes + position = fcb.start_header[enum] + + if fcompress then mrd_skip,fcb.unit,position else $ + point_lun,fcb.unit,position + first_block = 1 ; first block in header flag + repeat begin + if position ge nbytes_in_file then begin + message = 'EOF encountered while reading header' + goto,error_exit + endif + + readu,fcb.unit,h + position += 2880 + hdr = string(h>32b) + endline = where(strcmp(hdr,'END ',8),nend) + if nend gt 0 then hdr = hdr[0:endline[0]] + if first_block then header = hdr else header = [header,hdr] + first_block = 0 + end until (nend gt 0) +; +; extract some header information +; + bscale = sxpar(header,'bscale', Count = N_bscale) + bzero = sxpar(header,'bzero', Count = N_bzero) + if bscale eq 0.0 then bscale = 1.0 + unsgn_int = (bitpix EQ 16) && (Bzero EQ 32768) && (bscale EQ 1) + unsgn_lng = (bitpix EQ 32) && (Bzero EQ 2147483648) && (bscale EQ 1) + if (unsgn_int || unsgn_lng) then $ + if ~keyword_set(no_unsigned) then noscale = 1 + if (N_bscale gt 0) &&(noscale eq 0) && (data_only eq 0) && $ + (last eq 0) && (header_only eq 0) then sxaddpar,header,'bscale',1.0 + if (N_bzero gt 0) && (noscale eq 0) && (data_only eq 0) && $ + (last eq 0) && (header_only eq 0) then sxaddpar,header,'bzero',0.0 + groups = sxpar(header,'groups') +; +; create header with form: +; ! Required Keywords +; ! BEGIN MAIN HEADER ------------------------------------------ +; ! Primary data unit header keywords +; ! BEGIN EXTENSION HEADER ------------------------------------- +; ! Extension header keywords +; ! END +; +; +; add Primary Data Unit header to it portion of the header to it, unless the +; NO_PDU keyword is set, or the INHERIT keyword is not found or set to false +; + + if no_pdu EQ 0 then no_pdu = 1 - (sxpar(header,'INHERIT') > 0) + if pdu then no_pdu = 0 + if (no_pdu eq 0) && (enum gt 0) then begin + +; +; delete required keywords +; + sxdelpar,header,['SIMPLE','BITPIX','NAXIS','NAXIS1', $ + 'NAXIS2','NAXIS3','NAXIS4','NAXIS5', $ + 'NAXIS6','NAXIS7','NAXIS8','EXTEND', $ + 'PCOUNT','GCOUNT','GROUPS', $ + 'XTENSION'] + + +; create required keywords +; + hreq = strarr(20) + hreq[0] = 'END ' + + if enum eq 0 then $ + sxaddpar,hreq,'SIMPLE','T','image conforms to FITS standard' $ + else sxaddpar,hreq,'XTENSION',xtension,'extension type' + + sxaddpar,hreq,'bitpix',bitpix,'bits per data value' + sxaddpar,hreq,'naxis',naxis,'number of axes' + if naxis gt 0 then for i=1,naxis do $ + sxaddpar,hreq,'naxis'+strtrim(i,2),axis[i-1] + if (enum eq 0) && (fcb.nextend GE 1) then $ + sxaddpar,hreq,'EXTEND','T','file may contain extensions' + if groups then sxaddpar,hreq,'GROUPS','T','Group format' + if (enum gt 0) || (pcount gt 0) then $ + sxaddpar,hreq,'PCOUNT',pcount,'Number of group parameters' + if (enum gt 0) || (gcount gt 0) then $ + sxaddpar,hreq,'GCOUNT',gcount,'Number of groups' + n0 = where(strcmp(hreq,'END ',8)) & n0=n0[0] + hpdu = fcb.hmain + n1 = n_elements(hpdu) + if n1 gt 1 then begin + hreq = [hreq[0:n0-1], $ + 'BEGIN MAIN HEADER ---------------------------------', $ + hpdu[0:n1-2], $ + 'BEGIN EXTENSION HEADER ----------------------------', $ + 'END '] + n0 += n1 + 1 + end +; +; add extension header +; + header = [hreq[0:n0-1],header] + end + if header_only then begin + data = 0 + goto,done + endif +; +; Read Data =================================================================== +; +read_data: + if naxis eq 0 then begin ;null image? + data = 0 +; +; check for implicit data specified by NPIX1, NPIX2, and PIXVALUE (provided +; the header was red, i.e. data_only was not specified) +; + if data_only eq 0 then begin + NPIX1 = sxpar(header,'NPIX1') + NPIX2 = sxpar(header,'NPIX2') + PIXVALUE = sxpar(header,'PIXVALUE') + if (NPIX1*NPIX2) gt 0 then $ + data = replicate(pixvalue,npix1,npix2) + end + goto,done + endif + + case BITPIX of + 8: IDL_type = 1 ; Byte + 16: IDL_type = 2 ; 16 bit unsigned integer + 32: IDL_type = 3 ; 32 bit unsigned integer + -32: IDL_type = 4 ; Float + -64: IDL_type = 5 ; Double + else: begin + message = 'ERROR - Illegal value of BITPIX (= ' + $ + strtrim(bitpix,2) + ') in FITS header' + goto,error_exit + end + endcase + + ndata = product( axis, /integer ) + bytes_per_word = (abs(bitpix)/8) + nbytes_per_group = bytes_per_word * (pcount + ndata) + nbytes = (gcount>1) * nbytes_per_group + nwords = nbytes / bytes_per_word +; +; starting data position +; + + skip = data_only EQ 0 ? fcb.start_data[enum] - position : 0 + position = fcb.start_data[enum] +; +; find correct group +; + if last eq 0 then begin + if group ge (gcount>1) then begin + message='INVALID group number specified' + goto,error_exit + end + skip += long64(group) * nbytes_per_group + position += skip + end +; +; read group parameters +; + if (enum eq 0) && (fcb.random_groups eq 1) && (pcount gt 0) && $ + (last eq 0) then begin + if N_params() gt 3 then begin + group_par = make_array( dim = [pcount], type = idl_type, /nozero) + + if fcompress then mrd_skip,fcb.unit,skip else $ + point_lun,fcb.unit,position + + readu,fcb.unit,group_par + endif + skip = long64(pcount) * bytes_per_word + position += skip + endif +; +; create data array +; + if last gt 0 then begin +; +; user specified first and last +; + if (first lt 0) || (last le 1) || (first gt last) || $ + (last gt nwords-1) then begin + message = 'INVALID value for parameters FIRST & LAST' + goto,error_exit + endif + data = make_array(dim = [last-first+1], type=idl_type, /nozero) + skip += long64(first) * bytes_per_word + position += skip + endif else begin +; +; full array +; + if ndata eq 0 then begin + data = 0 + goto,done + endif + if naxis gt 8 then begin + message = 'Maximum value of NAXIS allowed is 8' + goto,error_exit + endif + data = make_array(dim = axis, type = idl_type, /nozero) + endelse +; +; read array +; + if fcompress then mrd_skip,fcb.unit,skip else $ + point_lun,fcb.unit,position + readu,fcb.unit,data + if fcompress then swap_endian_inplace,data,/swap_if_little + if ~keyword_set(No_Unsigned) && (~data_only) then begin + if unsgn_int then begin + data = uint(data) - uint(32768) + endif else if unsgn_lng then begin + data = ulong(data) - ulong(2147483648) + endif + endif +; +; scale data if header was read and first and last not used. Do a special +; check of an unsigned integer (BZERO = 2^15) or unsigned long (BZERO = 2^31) +; + if (data_only eq 0) && (last eq 0) && (noscale eq 0) then begin + + if bitpix lt 32 then begin ;use real*4 for bitpix<32 + bscale = float(bscale) + bzero = float(bzero) + endif + if bscale ne 1.0 then data *= bscale + if bzero ne 0.0 then data += bzero + endif +; +; done +; +done: + if fcompress then begin + free_lun,fcb.unit + ff = strmid(fcb.filename,1,strlen(fcb.filename)-2) +;Rewind the file to the beginning, if it might be used again + if fcbtype NE 7 then begin + spawn,ff,unit=unit,/sh, stderr = stderr + fcb.unit = unit + endif + endif else $ + if fcbtype eq 7 then fits_close,fcb else file_or_fcb.last_extension=enum + !err = 1 + return + +; +; error exit +; +ioerror: + message = !ERROR_STATE.MSG +error_exit: + if (fcbtype eq 7) && (N_elements(fcb) GT 0) then $ + fits_close,fcb, no_abort=no_abort + !err = -1 + if keyword_set(no_abort) then return + print,'FITS_READ ERROR: '+message + retall +end diff --git a/modules/idl_downloads/astro/pro/fits_test_checksum.pro b/modules/idl_downloads/astro/pro/fits_test_checksum.pro new file mode 100644 index 0000000..0ca0e51 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_test_checksum.pro @@ -0,0 +1,109 @@ + function fits_test_checksum,hdr, data, ERRMSG = errmsg,FROM_IEEE=from_ieee +;+ +; NAME: +; FITS_TEST_CHECKSUM() +; PURPOSE: +; Verify the values of the CHECKSUM and DATASUM keywords in a FITS header +; EXPLANATION: +; Follows the 2007 version of the FITS checksum proposal at +; http://fits.gsfc.nasa.gov/registry/checksum.html +; +; CALLING SEQUENCE: +; result = FITS_TEST_CHECKSUM(HDR, [ DATA, ERRMSG=, /FROM_IEEE ]) +; INPUTS: +; HDR - FITS header (vector string) +; OPTIONAL DATA: +; DATA - data array associated with the FITS header. An IDL structure is +; not allowed. If not supplied, or +; set to a scalar, then there is assumed to be no data array +; associated with the FITS header. +; RESULT: +; An integer -1, 0 or 1 indicating the following conditions: +; 1 - CHECKSUM (and DATASUM) keywords are present with correct values +; 0 - CHECKSUM keyword is not present +; -1 - CHECKSUM or DATASUM keyword does not have the correct value +; indicating possible data corruption. +; OPTIONAL INPUT KEYWORD: +; /FROM_IEEE - If this keyword is set, then the input is assumed to be in +; big endian format (e.g. an untranslated FITS array). This +; keyword only has an effect on little endian machines (e.g. +; a Linux box). +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG - will contain a scalar string giving the error condition. If +; RESULT = 1 then ERRMSG will be an empty string. If this +; output keyword is not supplied, then the error message will be +; printed at the terminal. +; NOTES: +; The header and data must be *exactly* as originally written in the FITS +; file. By default, some FITS readers may alter keyword values (e.g. +; BSCALE) or append information (e.g. HISTORY or an inherited primary +; header) and this will alter the checksum value. +; PROCEDURES USED: +; CHECKSUM32, FITS_ASCII_ENCODE(), SXPAR() +; EXAMPLE: +; Verify the CHECKSUM keywords in the primary header/data unit of a FITS +; file 'test.fits' +; +; FITS_READ,'test.fits',data,hdr,/no_PDU,/NoSCALE +; print,FITS_TEST_CHECKSUM(hdr,data) +; +; Note the use of the /No_PDU and /NoSCALE keywords to avoid any alteration +; of the FITS header +; REVISION HISTORY: +; W. Landsman SSAI December 2002 +; Return quietly if CHECKSUM keywords not found W. Landsman May 2003 +; Add /NOSAVE to CHECKSUM32 calls when possible W. Landsman Sep 2004 +;- + On_error,2 + compile_opt idl2 + + if N_Params() LT 1 then begin + print,'Syntax - result = FITS_TEST_CHECKSUM(Hdr, [Data,' + $ + ' ERRMSG=, /FROM_IEEE ])' + return, 0 + endif + result = 1 + printerr = ~arg_present(errmsg) + checksum = sxpar(hdr,'CHECKSUM', Count = N_checksum) + datasum = sxpar(hdr,'DATASUM', Count = N_datasum) + if (N_checksum EQ 0) then begin + errmsg = 'CHECKSUM keyword not present in FITS header' + if printerr then message,/con, errmsg + return, 0 + endif + if N_datasum EQ 0 then datasum = '0' + ch = shift(byte(checksum),-1) + checksum32,ch-48b, sum32, /NOSAVE + bhdr = byte(hdr) + remain = N_elements(bhdr) mod 2880 + if remain NE 0 then $ + bhdr = [reform(bhdr,N_elements(bhdr)), replicate(32b, 2880 - remain) ] + checksum32,bhdr, hsum, FROM_IEEE = from_ieee, /NOSAVE + Ndata = N_elements(data) + if Ndata GT 1 then begin + checksum32, data, dsum, FROM_IEEE= from_ieee + remain = Ndata mod 2880 + if remain GT 0 then begin + exten = sxpar( hdr, 'XTENSION', Count = N_exten) + if N_exten GT 0 then if exten EQ 'TABLE ' then $ + checksum32,[dsum,replicate(32b,2880-remain)],dsum,/NOSAVE + endif + checksum32, [dsum, hsum], hdusum, /NOSAVE + dsum = strtrim(dsum,2) + if dsum NE datasum then begin + result = 1 + errmsg = 'Computed Datasum: ' + dsum + $ + ' FITS header value: ' + datasum + if printerr then message,/Con, errmsg + endif + endif else hdusum = hsum + + csum = FITS_ASCII_ENCODE(not hdusum) + if csum NE '0000000000000000' then begin + result = -1 + errmsg = 'Computed Checksum: ' + csum + $ + ' FITS header value: ' + checksum + if printerr then message,/Con, errmsg + endif + return, result + end diff --git a/modules/idl_downloads/astro/pro/fits_write.pro b/modules/idl_downloads/astro/pro/fits_write.pro new file mode 100644 index 0000000..5ce3af2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fits_write.pro @@ -0,0 +1,379 @@ +pro fits_write,file_or_fcb,data,header_in,extname=extname,extver=extver, $ + xtension=xtension, extlevel=extlevel, $ + no_abort=no_abort, message = message, header = header, $ + no_data = no_data +;+ +; NAME: +; FITS_WRITE +; +; PURPOSE: +; To write a FITS primary data unit or extension. +; +; EXPLANATION: +; ***NOTE** This version of FITS_READ must be used with a post Sep 2006 +; version of FITS_OPEN. +; +; CALLING SEQUENCE: +; FITS_WRITE, filename_or_fcb, data, [header_in] +; +; INPUTS: +; FILENAME_OR_FCB: name of the output data file or the FITS control +; block returned by FITS_OPEN (called with the /WRITE or +; /APPEND) parameters. +; +; OPTIONAL INPUTS: +; DATA: data array to write. If not supplied or set to a scalar, a +; null image is written. +; HEADER_IN: FITS header keyword. If not supplied, a minimal basic +; header will be created. Required FITS keywords, SIMPLE, +; BITPIX, XTENSION, NAXIS, ... are added by FITS_WRITE and +; do not need to be supplied with the header. If supplied, +; their values will be updated as necessary to reflect DATA. +; +; INPUT KEYWORD PARAMETERS: +; +; XTENSION: type of extension to write (Default="IMAGE"). If not +; supplied, it will be taken from HEADER_IN. If not in either +; place, the default is "IMAGE". This parameter is ignored +; when writing the primary data unit. Note that binary and +; and ASCII table extensions already have a properly formatted +; header (e.g. with TTYPE* keywords) and byte array data. +; EXTNAME: EXTNAME for the extension. If not supplied, it will be taken +; from HEADER_IN. If not supplied and not in HEADER_IN, no +; EXTNAME will be written into the output extension. +; EXTVER: EXTVER for the extension. If not supplied, it will be taken +; from HEADER_IN. If not supplied and not in HEADER_IN, no +; EXTVER will be written into the output extension. +; EXTLEVEL: EXTLEVEL for the extension. If not supplied, it will be taken +; from HEADER_IN. If not supplied and not in HEADER_IN, no +; EXTLEVEL will be written into the output extension. +; /NO_ABORT: Set to return to calling program instead of a RETALL +; when an I/O error is encountered. If set, the routine will +; return a non-null string (containing the error message) in the +; keyword MESSAGE. If /NO_ABORT not set, then FITS_WRITE will +; print the message and issue a RETALL +; /NO_DATA: Set if you only want FITS_WRITE to write a header. The +; header supplied will be written without modification and +; the user is expected to write the data using WRITEU to unit +; FCB.UNIT. When FITS_WRITE is called with /NO_DATA, the user is +; responsible for the validity of the header, and must write +; the correct amount and format of the data. When FITS_WRITE +; is used in this fashion, it will pad the data from a previously +; written extension to 2880 blocks before writting the header. +; +; OUTPUT KEYWORD PARAMETERS: +; MESSAGE: value of the error message for use with /NO_ABORT +; HEADER: actual output header written to the FITS file. +; +; NOTES: +; If the first call to FITS_WRITE is an extension, FITS_WRITE will +; automatically write a null image as the primary data unit. +; +; Keywords and history in the input header will be properly separated +; into the primary data unit and extension portions when constructing +; the output header (See FITS_READ for information on the internal +; Header format which separates the extension and PDU header portions). +; +; EXAMPLES: +; Write an IDL variable to a FITS file with the minimal required header. +; FITS_WRITE,'newfile.fits',ARRAY +; +; Write the same array as an image extension, with a null Primary data +; unit. +; FITS_WRITE,'newfile.fits',ARRAY,xtension='IMAGE' +; +; Write 4 additional image extensions to the same file. +; FITS_OPEN,'newfile.fits',fcb +; FITS_WRITE,fcb,data1,extname='FLUX',extver=1 +; FITS_WRITE,fcb,err1,extname'ERR',extver=1 +; FITS_WRITE,fcb,data2,extname='FLUX',extver=2 +; FITS_WRITE,fcb,err2,extname='ERR',extver=2 +; FITS_CLOSE,FCB +; +; WARNING: +; FITS_WRITE currently does not completely update the file control block. +; When mixing FITS_READ and FITS_WRITE commands it is safer to use +; file names, rather than passing the file control block. +; PROCEDURES USED: +; FITS_OPEN, SXADDPAR, SXDELPAR, SXPAR() +; HISTORY: +; Written by: D. Lindler August, 1995 +; Work for variable length extensions W. Landsman August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; PCOUNT and GCOUNT added for IMAGE extensions J. Graham October 1999 +; Write unsigned data types W. Landsman December 1999 +; Pad data area with zeros not blanks W. McCann/W. Landsman October 2000 +; Return Message='' to signal normal operation W. Landsman Nov. 2000 +; Ensure that required extension table keywords are in proper order +; W.V. Dixon/W. Landsman March 2001 +; Assume since V5.1, remove NaNValue keyword W. Landsman Nov. 2002 +; Removed obsolete !ERR system variable W. Landsman Feb 2004 +; Check that byte array supplied with table extension W. Landsman Mar 2004 +; Make number of bytes 64bit to avoid possible overflow W.L Apr 2006 +; Assume FITS_OPEN has opened the file with /SWAP_IF_LITTLE_ENDIAN +; W. Landsman September 2006 +; Removes BZERO and BSCALE for floating point output, D. Lindler, Sep 2008 +;- +;----------------------------------------------------------------------------- +; +; print calling sequence if no parameters supplied +; + if n_params() lt 1 then begin + print,'Calling Sequence: FITS_WRITE,file_or_fcb,data,header_in' + print,'Input Keywords: extname, extver, xtension, extlevel,' + $ + '/no_abort, /no_data' + print,'Output Keywords: message, header ' + return + end +; +; Open file if file name is supplied instead of a FCB +; + message = '' + s = size(file_or_fcb) & fcbtype = s[s[0]+1] + fcbsize = n_elements(file_or_fcb) + if (fcbsize ne 1) || ((fcbtype ne 7) && (fcbtype ne 8)) then begin + message = 'Invalid Filename or FCB supplied' + goto,error_exit + end + + if fcbtype eq 7 then begin + if keyword_set(no_data) then begin + print,'FITS_WRITE: Must have FCB supplied for NO_DATA' + retall + endif + fits_open,file_or_fcb,fcb,/write, $ + no_abort=no_abort,message=message + if message NE '' then goto,error_exit + end else fcb = file_or_fcb +; +; if user did not pad data to 2880 blocks, pad it now +; + point_lun,-fcb.unit,current_position + npad = 2880 - (current_position mod 2880) + if npad eq 2880 then npad = 0 + if npad gt 0 then writeu,fcb.unit,bytarr(npad) +; +; if no_data, just go and write user header as supplied +; + if keyword_set(no_data) then begin + header = header_in + goto,write_header + end +; +; if header not supplied then set it to a null header +; + if n_elements(header_in) le 1 then begin + header = strarr(1) + header[0] = 'END ' + end else header = header_in + +; +; on I/O error go to statement IOERROR +; +; on_ioerror,ioerror +; +; verify file is open for writing +; + if fcb.open_for_write eq 0 then begin + message,'File is not open for writing' + goto,error_exit + endif +; +; determine bitpix and axis information +; + s = size(data) + naxis = s[0] + if naxis gt 0 then axis = s[1:naxis] + idltype = s[naxis+1] + + if (idltype gt 5) && (idltype NE 12) && (idltype NE 13) then begin + message='Data array is an invalid type' + goto,error_exit + endif + bitpixs = [8,8,16,32,-32,-64,0,0,0,0,0,0,16,32] + bitpix = bitpixs[idltype] +; +; determine extname, extver, xtension and extlevel and delete current values +; + if n_elements(xtension) gt 0 then begin + Axtension = xtension + end else begin + Axtension = sxpar(header,'xtension', Count = N_Axtension) + if N_Axtension EQ 0 then Axtension = '' + end + if Axtension EQ 'BINTABLE' or (Axtension EQ 'TABLE') then $ + if idltype GT 1 then begin + message='A Byte array must be supplied with a ' + $ + 'BINTABLE or TABLE extension' + goto, error_exit + endif + + if n_elements(extname) gt 0 then begin + Aextname = extname + end else begin + Aextname = sxpar(header,'extname', Count = N_Aextname) + if N_Aextname EQ 0 then Aextname = '' + end + + if n_elements(extver) gt 0 then $ + Aextver = extver $ + else Aextver = sxpar(header,'extver') + + if n_elements(extlevel) gt 0 then $ + Aextlevel = extlevel $ + else Aextlevel = sxpar(header,'extlevel') + + sxdelpar,header,['XTENSION','EXTNAME','EXTVER','EXTLEVEL'] + +; +; separate header into main and extension header +; + keywords = strmid(header,0,8) + hpos1 = where(keywords eq 'BEGIN MA') & hpos1 = hpos1[0] ;begin main + hpos2 = where(keywords eq 'BEGIN EX') & hpos2 = hpos2[0] ;begin ext. + hpos3 = where(keywords eq 'END ') & hpos3 = hpos3[0] ;end of header + + if (hpos1 gt 0) && (hpos2 lt hpos1) then begin + message,'Invalid header BEGIN EXTENSION HEADER ... out of place' + goto,error_exit + endif + + if (hpos3 lt 0) then begin + print,'FITS_WRITE: END missing from input header and was added' + header = [header,'END '] + hpos2 = n_elements(header)-1 + end +; +; determine if a extension was supplied and no primary data unit (PDU) +; was written +; + if (fcb.nextend eq -1) then begin ;no pdu written yet? + if (hpos2 gt 0) || (Axtension ne '') || (Aextname ne '') || $ + (Aextver ne 0) || (Aextlevel ne 0) then begin +; +; write null image PDU +; + if (hpos1 gt 0) && (hpos2 gt (hpos1+1)) then $ + hmain = [header[hpos1+1:hpos2-1],'END '] + fits_write,fcb,0,hmain,/no_abort,message=message + if message NE '' then goto,error_exit + end + end +; +; For extensions, do not use PDU portion of the header +; + if (hpos2 gt 0) then header = header[hpos2+1:hpos3] +; +; create required keywords for the header +; + h = strarr(20) + h[0] = 'END ' + + if fcb.nextend eq -1 then begin + sxaddpar,h,'SIMPLE','T','image conforms to FITS standard' + end else begin + if Axtension eq '' then Axtension = 'IMAGE ' + sxaddpar,h,'XTENSION',Axtension,'extension type' + end + sxaddpar,h,'BITPIX',bitpix,'bits per data value' + sxaddpar,h,'NAXIS',naxis,'number of axes' + if naxis gt 0 then for i=1,naxis do $ + sxaddpar,h,'NAXIS'+strtrim(i,2),axis[i-1] + if fcb.nextend eq -1 then begin + sxaddpar,h,'EXTEND','T','file may contain extensions' + end else begin ;PCOUNT, GCOUNT are mandatory for extensions + sxaddpar,h,'PCOUNT',0 + sxaddpar,h,'GCOUNT',1 + if (Axtension eq 'BINTABLE') || $ + (Axtension eq 'TABLE ') then begin + tfields = sxpar(header,'TFIELDS') > 0 + sxaddpar,h,'TFIELDS',tfields + endif + if Aextname ne '' then sxaddpar,h,'EXTNAME',Aextname + if Aextver gt 0 then sxaddpar,h,'EXTVER',Aextver + if Aextlevel gt 0 then sxaddpar,h,'EXTLEVEL',Aextlevel + endelse + if idltype EQ 12 then $ + sxaddpar,header,'BZERO',32768,'Data is unsigned integer' + if idltype EQ 13 then $ + sxaddpar,header,'BZERO',2147483648,'Data is unsigned long' + if idltype GE 12 then sxdelpar,header,'BSCALE' + if (idltype EQ 4) || (idltype EQ 5) then $ + sxdelpar,header,['BSCALE','BZERO'] +; +; delete special keywords from user supplied header +; + pcount = sxpar(header,'pcount') + groups = sxpar(header,'groups') + sxdelpar,header,['SIMPLE','BITPIX','NAXIS','NAXIS1','NAXIS2','NAXIS3', $ + 'NAXIS4','NAXIS5','NAXIS6','NAXIS7','NAXIS8','EXTEND', $ + 'PCOUNT','GCOUNT','GROUPS','TFIELDS'] + if groups then if (pcount gt 0) then for i=1,pcount do $ + sxdelpar,header,['ptype','pscal','pzero']+strtrim(i,2) +; +; combine the two headers +; + last = where(strmid(h,0,8) eq 'END ') + header = [h[0:last[0]-1],header] + +; +; convert header to bytes and write +; +write_header: + last = where(strmid(header,0,8) eq 'END ') + n = last[0] + 1 + byte_header = replicate(32b,80,n) + for i=0,n-1 do byte_header[0,i] = byte(header[i]) + writeu,fcb.unit,byte_header +; +; pad header to 2880 byte records +; + npad = 2880 - (80L*n mod 2880) + if npad eq 2880 then npad = 0 + if (npad gt 0) then writeu,fcb.unit,replicate(32b,npad) + nbytes_header = npad + n*80 + if keyword_set(no_data) then return +; +; process data +; + if naxis gt 0 then begin +; +; convert to IEEE +; + unsigned = (idltype EQ 12) || (idltype EQ 13) + if idltype EQ 12 then newdata = fix(data - 32768) + if idltype EQ 13 then newdata = long(data - 2147483648) +; +; write the data +; + nbytes = long64(N_elements(data)) * (abs(bitpix)/8) + npad = 2880 - (nbytes mod 2880) + if npad eq 2880 then npad = 0 + if unsigned then writeu,fcb.unit,newdata else writeu,fcb.unit,data + if npad gt 0 then begin + if Axtension EQ 'TABLE ' then padnum = 32b else padnum = 0b + writeu,fcb.unit,replicate(padnum,npad) + endif + nbytes_data = nbytes + npad + end else begin + nbytes_data = 0 + end +; +; done, update file control block +; + fcb.nextend = fcb.nextend + 1 + if fcbtype eq 7 then fits_close,fcb else file_or_fcb = fcb + !err = 1 + return +; +; error exit +; +ioerror: + message = !error_state.msg +error_exit: + if fcbtype eq 7 then free_lun,fcb.unit + !err = -1 + if keyword_set(no_abort) then return + message,' ERROR: '+message,/CON + retall +end diff --git a/modules/idl_downloads/astro/pro/fitsdir.pro b/modules/idl_downloads/astro/pro/fitsdir.pro new file mode 100644 index 0000000..d674003 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fitsdir.pro @@ -0,0 +1,332 @@ +pro fitsdir ,directory, TEXTOUT = textout, Keywords = keywords, $ + nosize = nosize, alt1_keywords=alt1_keywords, alt2_keywords=alt2_keywords,$ + alt3_keywords = alt3_keywords, NoTelescope = NoTelescope,exten=exten +;+ +; NAME: +; FITSDIR +; PURPOSE: +; Display selected FITS keywords from the headers of FITS files. +; EXPLANATION: +; +; The values of either user-specified or default FITS keywords are +; displayed in either the primary header and/or the first extension header. +; Unless the /NOSIZE keyword is set, the data size is also displayed. +; The default keywords are as follows (with keywords in 2nd row used if +; those in the first row not found, and the 3rd row if neither the keywords +; in the first or second rows found:) +; +; DATE-OBS TELESCOP OBJECT EXPTIME +; TDATEOBS TELNAME TARGNAME INTEG ;First Alternative +; DATE OBSERVAT EXPOSURE ;Second Alternative +; INSTRUME EXPTIM ;Third Alternative +; +; FITSDIR will also recognize gzip compressed files (must have a .gz +; or FTZ extension). +; CALLING SEQUENCE: +; FITSDIR , [ directory, TEXTOUT =, EXTEN=, KEYWORDS=, /NOSIZE, /NoTELESCOPE +; ALT1_KEYWORDS= ,ALT2_KEYWORDS = ,ALT3_KEYWORDS = +; +; OPTIONAL INPUT PARAMETERS: +; DIRECTORY - Scalar string giving file name, disk or directory to be +; searched. Wildcard file names are allowed. Examples of +; valid names include 'iraf/*.fits' (Unix) or 'd:\myfiles\f*.fits', +; (Windows). +; +; OPTIONAL KEYWORD INPUT PARAMETER +; KEYWORDS - FITS keywords to display, as either a vector of strings or as +; a comma delimited scalar string, e.g.'testname,dewar,filter' +; If not supplied, then the default keywords are 'DATE-OBS', +; 'TELESCOP','OBJECT','EXPTIME' +; ALT1_KEYWORDS - A list (either a vector of strings or a comma delimited +; strings of alternative keywords to use if the default +; KEYWORDS cannot be found. By default, 'TDATEOBS', is the +; alternative to DATE-OBS, 'TELNAME' for 'TELESCOP','TARGNAME' +; for 'OBJECT', and 'INTEG' for EXPTIME +; ALT2_KEYWORDS - A list (either a vector of strings or a comma delimited +; strings of alternative keywords to use if neither KEYWORDS +; nor ALT1_KEYWORDS can be found. +; ALT3_KEYWORDS - A list (either a vector of strings or a comma delimited +; strings of alternative keywords to use if neither KEYWORDS +; nor ALT1_KEYWORDS nor ALT2_KEYWORDS can be found. +; /NOSIZE - if set then information about the image size is not displayed +; TEXTOUT - Controls output device as described in TEXTOPEN procedure +; textout=1 TERMINAL using /more option +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 Append to existing .prt file +; textout = filename (default extension of .prt) +; EXTEN - Specifies an extension number (/EXTEN works for first extension) +; which is checked for the desired keywords. +; /NOTELESCOPE - If set, then if the default keywords are used, then the +; TELESCOPE (or TELNAME, OBSERVAT, INSTRUME) keywords are omitted +; to give more room for display other keywords. The /NOTELESCOP +; keyword has no effect if the default keywords are not used. +; OUTPUT PARAMETERS: +; None. +; +; EXAMPLES: +; (1) Print info on all'*.fits' files in the current directory using default +; keywords. Include information from the extension header +; IDL> fitsdir,/exten +; +; (2) Write a driver program to display selected keywords in HST/ACS drizzled +; (*drz) images +; pro acsdir +; keywords = 'date-obs,targname,detector,filter1,filter2,exptime' +; fitsdir,'*drz.fits',key=keywords,/exten +; return & end +; +; (3) Write info on all *.fits files in the Unix directory /usr2/smith, to a +; file 'smith.txt' using the default keywords, but don't display the value +; of the TELESCOPE keyword +; +; IDL> fitsdir ,'/usr2/smith/*.fits',t='smith.txt', /NoTel +; +; PROCEDURE: +; FILE_SEARCH() is used to find the specified FITS files. The +; header of each file is read, and the selected keywords are extracted. +; The formatting is adjusted so that no value is truncated on display. +; +; SYSTEM VARIABLES: +; TEXTOPEN (called by FITSDIR) will automatically define the following +; non-standard system variables if they are not previously defined: +; +; DEFSYSV,'!TEXTOUT',1 +; DEFSYSV,'!TEXTUNIT',0 +; +; PROCEDURES USED: +; FDECOMP, FXMOVE, MRD_HREAD, REMCHAR +; TEXTOPEN, TEXTCLOSE +; MODIFICATION HISTORY: +; Written, W. Landsman, HSTX February, 1993 +; Search alternate keyword names W.Landsman October 1998 +; Avoid integer truncation for NAXISi >32767 W. Landsman July 2000 +; Don't leave open unit W. Landsman July 2000 +; Added EXTEN keyword, work with compressed files, additional alternate +; keywords W. Landsman December 2000 +; Don't assume floating pt. exposure time W. Landsman September 2001 +; Major rewrite, KEYWORD & ALT*_KEYWORDS keywords, no truncation, +; /NOSIZE keyword W. Landsman, SSAI August 2002 +; Assume V5.3 or later W. Landsman November 2002 +; Fix case where no keywords supplied W. Landsman January 2003 +; NAXIS* values must be integers W. Landsman SSAI June 2003 +; Trim spaces off of input KEYWORD values W. Landsman March 2004 +; Treat .FTZ extension as gzip compressed W. Landsman September 2004 +; Assume since V5.5, file_search() available W. Landsman Aug 2006 +; Don't assume all images compressed or uncompressed W. L. Apr 2010 +; Use V6.0 notation W.L. Feb 2011 +; Don't let a corrupted file cause an abort W.L. Feb 2014 +;- +; On_error,2 + + compile_opt idl2 + + if N_elements(directory) EQ 0 then directory = '*.fits' + if N_elements(exten) EQ 0 then exten = 0 + + FDECOMP, directory, disk, dir, filename, ext + if filename EQ '' then begin + directory = disk + dir + '*.fits' + filename = '*' + ext = 'fits' + endif else if !VERSION.OS_FAMILY EQ 'unix' then begin + if (strpos(filename,'*') LT 0) && (ext EQ '') then begin + directory = disk + dir + filename + '/*.fits' + filename = '*' + ext = 'fits' + endif + endif + + if N_elements(keywords) EQ 0 then begin + keywords = ['date-obs','telescop','object','exptime'] + if N_elements(alt1_keywords) EQ 0 then $ + alt1_keywords = ['tdateobs','telname','targname','integ'] + if N_elements(alt2_keywords) EQ 0 then $ + alt2_keywords = ['date','observat','','exposure'] + if N_elements(alt3_keywords) EQ 0 then $ + alt3_keywords = ['','instrume','','exptim' ] + if keyword_set(NoTelescope) then begin + ii = [0,2,3] + keywords = keywords[ii] & alt1_keywords = alt1_keywords[ii] + alt2_keywords = alt2_keywords[ii] & alt3_keywords = alt3_keywords[ii] + endif + endif + if N_elements(keywords) EQ 1 then $ + keys = strtrim(strupcase(strsplit(keywords,',',/EXTRACT)),2) else $ + keys = strupcase(keywords) + Nkey = N_elements(keys) + + case N_elements(alt1_keywords) of + 0: alt1_set = bytarr(Nkey) + 1: alt1_keys = strtrim(strupcase(strsplit(alt1_keywords[0],',',/EXTRACT)),2) + else: alt1_keys = strupcase(alt1_keywords) + endcase + if N_elements(alt1_set) EQ 0 then alt1_set = strlen(strtrim(alt1_keys,2)) GT 0 + + case N_elements(alt2_keywords) of + 0: alt2_set = bytarr(Nkey) + 1: alt2_keys = strtrim(strupcase(strsplit(alt2_keywords,',',/EXTRACT)),2) + else: alt2_keys = strupcase(alt2_keywords) + endcase + if N_elements(alt2_set) EQ 0 then alt2_set = strlen(strtrim(alt2_keys,2)) GT 0 + + case N_elements(alt3_keywords) of + 0: alt3_set = bytarr(Nkey) + 1: alt3_keys = strtrim(strupcase(strsplit(alt3_keywords,',',/EXTRACT)),2) + else: alt3_keys = strupcase(alt3_keywords) + endcase + if N_elements(alt3_set) EQ 0 then alt3_set = strlen(strtrim(alt3_keys,2)) GT 0 + + keylen = strlen(keys) + + direct = spec_dir(directory) + files = file_search(directory,COUNT = n,/full) + + if n EQ 0 then begin ;Any files found? + message,'No files found on '+ direct, /CON + return + endif + + good = where( strlen(files) GT 0, Ngood) + if Ngood EQ 0 then message,'No FITS files found on '+ directory $ + else files = files[good] + +; Set output device according to keyword TEXTOUT or system variable !TEXTOUT + + defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it. + defsysv,'!TEXTUNIT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTUNIT',1 ; If not define it. + if ~keyword_set( TEXTOUT ) then textout= !TEXTOUT + + dir = 'dummy' + num = 0 + + get_lun,unit + + fdecomp, files, disk, dir2, fname, qual ;Decompose into disk+filename + fname = strtrim(fname,2) + keyvalue = strarr(n,nkey) + bignaxis = strarr(n) + namelen = max(strlen(fname)) + + for i = 0,n-1 do begin ;Loop over each FITS file + compress = (qual[i] EQ 'gz') || (strupcase(qual[i]) EQ 'FTZ') + openr, unit, files[i], error = error, compress = compress + if error LT 0 then goto, BADHD + mrd_hread, unit, h, status, /silent, ERRMSG = errmsg + if status LT 0 then goto, BADHD + + if exten GT 0 then begin + close,unit + openr, unit, files[i], error = error, compress = compress + stat = fxmove(unit, exten, /silent) + mrd_hread, unit, h1, extstatus, /silent, ERRMSG = errmsg + if extstatus EQ 0 then h = [h1,h] + endif + + keyword = strtrim( strmid(h,0,8),2 ) ;First 8 chars is FITS keyword + lvalue = strtrim(strmid(h,10,20),2 ) + value = strtrim( strmid(h,10,68),2 ) ;Chars 10-30 is FITS value + + if ~keyword_set(nosize) then begin + l= where(keyword EQ 'NAXIS',Nfound) ;Must have NAXIS keyword + if Nfound GT 0 then naxis = long( lvalue[ l[0] ] ) else goto, BADHD + + if naxis EQ 0 then naxisi = '0' else begin + + l = where( keyword EQ 'NAXIS1', Nfound) ;Must have NAXIS1 keyword + if Nfound gt 0 then naxis1 = long( lvalue[l[0] ] ) else goto, BADHD + naxisi = strtrim( naxis1,2 ) + endelse + + if NAXIS GE 2 then begin + l = where(keyword EQ 'NAXIS2', Nfound) ;Must have NAXIS2 keyword + if Nfound gt 0 then naxis2 = long(lvalue[l[0]]) else goto, BADHD + naxisi = naxisi + ' ' + strtrim( naxis2, 2 ) + endif + + if NAXIS GE 3 then begin + l = where( keyword EQ 'NAXIS3', Nfound ) ;Must have NAXIS3 keyword + if Nfound GT 0 then naxis3 = long( lvalue[l[0]] ) else goto, BADHD + naxisi = naxisi + ' ' + strtrim( naxis3, 2 ) + endif + bignaxis[i] = strtrim(naxisi) + endif + + for k=0,nkey-1 do begin + l = where(keyword EQ keys[k], Nfound) + if Nfound EQ 0 then if alt1_set[k] then $ + l = where(keyword EQ alt1_keys[k], Nfound) + if Nfound EQ 0 then if alt2_set[k] then $ + l = where(keyword EQ alt2_keys[k], Nfound) + if Nfound EQ 0 then if alt3_set[k] then $ + l = where(keyword EQ alt3_keys[k], Nfound) + if nfound GT 0 then begin + kvalue = value[l[0]] + if strpos(kvalue,"'") GE 0 then begin + temp = gettok(kvalue,"'") + keyvalue[i,k] = strtrim(gettok(kvalue,"'"),2) + endif else keyvalue[i,k] = strtrim(gettok(kvalue,'/'),2) + endif + + endfor + + BADHD: + + close,unit + if status LT 0 then begin + message,'Bad File: ' + files[i],/Con + if N_elements(errmsg) NE 0 then message,errmsg,/CON + endif + endfor + DONE: + free_lun, unit + vallen = lonarr(nkey) + for k=0,nkey-1 do vallen[k] = max(strlen(keyvalue[*,k])) + + + textopen, 'fitsdir', TEXTOUT=textout,/STDOUT + printf,!TEXTUNIT,' ' + printf,!TEXTUNIT,'FITS File Directory ' + systime() + printf,!TEXTUNIT, direct + printf,!TEXTUNIT, ' ' + + pheader = ' NAME ' + if namelen GT 5 then pheader += string(replicate(32b,namelen-5)) + if ~keyword_set(nosize) then begin + pheader += 'SIZE ' + naxislen = max(strlen(bignaxis))+1 + if naxislen GT 5 then pheader += string(replicate(32b,naxislen-5)) + endif + for k=0,nkey-1 do begin + pheader += keys[k] + ' ' + if vallen[k] GT keylen[k] then $ + pheader += string(replicate(32b,vallen[k]-keylen[k])) + endfor + printf,!TEXTUNIT, pheader + printf,!TEXTUNIT, ' ' + xx = namelen + 2 + fmt = '(A' + if ~keyword_set(nosize) then begin + fmt += ',T' + strtrim(xx,2) + xx += (naxislen>4) + 1 + endif + fmt += ',A' + remchar,keyvalue,"'" + + for k=0,nkey-1 do begin + + fmt += ',T' + strtrim(xx,2) + ',A' + xx += (vallen[k]>keylen[k]) +1 + endfor + fmt += ')' + + for i=0,n-1 do printf, f= fmt, $ + !TEXTUNIT,fname[i],bignaxis[i], keyvalue[i,*] + + textclose,textout=textout + return ;Normal return + end diff --git a/modules/idl_downloads/astro/pro/fitsrgb_to_tiff.pro b/modules/idl_downloads/astro/pro/fitsrgb_to_tiff.pro new file mode 100644 index 0000000..e3b711a --- /dev/null +++ b/modules/idl_downloads/astro/pro/fitsrgb_to_tiff.pro @@ -0,0 +1,143 @@ + PRO FITSRGB_to_TIFF, path, rgb_files, tiff_name, BY_PIXEL=by_pixel, $ + PREVIEW=preview, RED=r_mix, GREEN=g_mix, BLUE=b_mix +;+ +; NAME: +; FITSRGB_to_TIFF +; PURPOSE: +; Combine separate red, green, and blue FITS images into TIFF format +; EXPLANATION: +; The output TIFF (class R) file can have colors interleaved either +; by pixel or image. The colour mix is also adjustable. +; +; CALLING SEQUENCE: +; FITSRGB_to_TIFF, path, rgb_files, tiff_name [,/BY_PIXEL, /PREVIEW, +; RED= , GREEN =, BLUE =] +; +; INPUTS: +; path = file system directory path to the RGB files required. +; rgb_files = string array with three components - the red FITS file +; filename, the blue FITS file filename and the green FITS +; file filename +; +; OUTPUTS: +; tiff_name = string containing name of tiff file to be produced +; +; OPTIONAL OUTPUT: +; Header = String array containing the header from the FITS file. +; +; OPTIONAL INPUT KEYWORDS: +; BY_PIXEL = This causes TIFF file RGB to be interleaved by pixel +; rather than the default of by image. +; PREVIEW = Allows a 24 bit image to be displayed on the screen +; to check the colour mix. +; RED = Real number containing the fractional mix of red +; GREEN = Real number containing the fractional mix of green +; BLUE = Real number containing the fractional mix of blue +; +; EXAMPLE: +; Read three FITS files, 'red.fits', 'blue.fits' and 'green.fits' from +; the directory '/data/images/space' and output a TIFF file named +; 'colour.tiff' +; +; IDL> FITSRGB_to_TIFF, '/data/images/space', ['red.fits', $ +; 'blue.fits', 'green.fits'], 'colour.tiff' +; +; Read three FITS files, 'red.fits', 'blue.fits' and 'green.fits' from +; the current directory and output a TIFF file named '/images/out.tiff' +; In this case, the red image is twice as strong as the green and the +; blue is a third more intense. A preview on screen is also wanted. +; +; IDL> FITSRGB_to_TIFF, '.', ['red.fits', $ +; 'blue.fits', 'green.fits'], '/images/out.tiff', $ +; /PREVIEW, RED=0.5, GREEN=1.0, BLUE=0.666 +; +; +; RESTRICTIONS: +; (1) Limited to the ability of the routine READFITS +; +; NOTES: +; None +; +; PROCEDURES USED: +; Functions: READFITS, CONCAT_DIR +; Procedures: WRITE_TIFF +; +; MODIFICATION HISTORY: +; 16th January 1995 - Written by Carl Shaw, Queen's University Belfast +; 27 Jan 1995 - W. Landsman, Add CONCAT_DIR for VMS, Windows compatibility +; Converted to IDL V5.0 W. Landsman September 1997 +; Use WRITE_TIFF instead of obsolete TIFF_WRITE W. Landsman December 1998 +; Cosmetic changes W. Landsman February 2000 +;- +; +; Make sure user has supplied valid parameters +; + IF N_PARAMS() LT 3 THEN BEGIN + print, 'Syntax - FITSRGB_to_TIFF, path, rgb_files, tiff_name' + print,' [/BY_PIXEL,/PREVIEW, RED=, GREEN=, BLUE= ]' + return + ENDIF +; + IF N_ELEMENTS(rgb_files) LT 3 THEN $ + MESSAGE, 'Three filenames for the colour components have not been supplied' +; + by_pixel = KEYWORD_SET(BY_PIXEL) +; + IF ~KEYWORD_SET(r_mix) THEN r_mix = 1.0 + IF ~KEYWORD_SET(g_mix) THEN g_mix = 1.0 + IF ~KEYWORD_SET(b_mix) THEN b_mix = 1.0 +; +; Now load the colour components +; + fname = CONCAT_DIR( path, rgb_files ) + red = READFITS( fname[0], /SILENT) + green = READFITS( fname[1], /SILENT) + blue = READFITS( fname[2], /SILENT) +; +; Data now needs to be scaled to the same byte range (0-255) and also +; scaled according to the RGB mix values supplied by the user +; + red = red[*,*] * r_mix + green = green[*,*] * g_mix + blue = blue[*,*] * b_mix ;scale intensity by supplied mix +; + maxlim = MAX(red) > MAX(green) > MAX(blue) ;max intensity + minlim = MIN(red) < MIN(green) < MIN(blue) ;min intensity + red = BYTSCL(red, MIN=minlim, MAX=maxlim) + green = BYTSCL(green, MIN=minlim, MAX=maxlim) + blue = BYTSCL(blue, MIN=minlim, MAX=maxlim) ;scale colours to same byte range +; +; Preview image on window system if required +; + IF keyword_set(PREVIEW) THEN BEGIN + window, 0, colors=256 + wset, 0 + tv, color_quan(red, green, blue, r, g, b, colors=255) + tvlct, r, g, b + ENDIF +; +; Now write out result as a tiff file +; + IF by_pixel THEN BEGIN + ; + ; Interleave by pixel + ; + extent = SIZE(red) + xsize = extent[1] + ysize = extent[2] ;get image size + interarr = FLTARR(3, xsize, ysize, /NOZERO) ;make interleaved array + interarr[0, *, *] = red + interarr[1, *, *] = green + interarr[2, *, *] = blue + ; + WRITE_TIFF, tiff_name, interarr + ; + ENDIF ELSE BEGIN + ; + ; Interleave by image + ; + WRITE_TIFF, tiff_name, RED=red, BLUE=blue, GREEN=green, PLANARCONFIG=2 + ; + ENDELSE +; + END diff --git a/modules/idl_downloads/astro/pro/flegendre.pro b/modules/idl_downloads/astro/pro/flegendre.pro new file mode 100644 index 0000000..00fb5ba --- /dev/null +++ b/modules/idl_downloads/astro/pro/flegendre.pro @@ -0,0 +1,74 @@ +function flegendre,x,m +;+ +; NAME: +; FLEGENDRE +; PURPOSE: +; Compute the first M terms in a Legendre polynomial expansion. +; EXPLANATION: +; Meant to be used as a supplied function to SVDFIT. +; +; This procedure became partially obsolete in IDL V5.0 with the +; introduction of the /LEGENDRE keyword to SVDFIT and the associated +; SVDLEG function. However, note that, unlike SVDLEG, FLEGENDRE works +; on vector values of X. +; CALLING SEQUENCE: +; result = FLEGENDRE( X, M) +; +; INPUTS: +; X - the value of the independent variable, scalar or vector +; M - number of term of the Legendre expansion to compute, integer scalar +; +; OUTPUTS: +; result - (N,M) array, where N is the number of elements in X and M +; is the order. Contains the value of each Legendre term for +; each value of X +; EXAMPLE: +; (1) If x = 2.88 and M = 3 then +; IDL> print, flegendre(x,3) ==> [1.00, 2.88, 11.9416] +; +; This result can be checked by explicitly computing the first 3 Legendre +; terms, 1.0, x, 0.5*( 3*x^2 -1) +; +; (2) Find the coefficients to an M term Legendre polynomial that gives +; the best least-squares fit to a dataset (x,y) +; IDL> coeff = SVDFIT( x,y,M,func='flegendre') +; +; The coefficients can then be supplied to the function POLYLEG to +; compute the best YFIT values for any X. +; METHOD: +; The recurrence relation for the Legendre polynomials is used to compute +; each term. Compare with the function FLEG in "Numerical Recipes" +; by Press et al. (1992), p. 674 +; +; REVISION HISTORY: +; Written Wayne Landsman Hughes STX April 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_Error,2 + + if N_params() LT 2 then begin + print,'Syntax - result = FLEGENDRE( x, m)' + return,0 + endif + + if m LT 1 then message, $ + 'ERROR - Order of Legendre polynomial must be at least 1' + N = N_elements(x) + size_x = size(x) + leg = make_array(n, m, type = size_x[size_x[0]+1] > 4) + + leg[0,0] = replicate( 1., n) + if m GE 2 then leg[0,1] = x + if m GE 3 then begin + twox = 2.*x + f2 = x + d = 1. + for j=2,m-1 do begin + f1 = d + f2 = f2 + 2.*x + d = d+1. + leg[0,j] = ( f2*leg[*,j-1] - f1*leg[*,j-2] )/d + endfor + endif + return, leg + end diff --git a/modules/idl_downloads/astro/pro/flux2mag.pro b/modules/idl_downloads/astro/pro/flux2mag.pro new file mode 100644 index 0000000..d21d9cf --- /dev/null +++ b/modules/idl_downloads/astro/pro/flux2mag.pro @@ -0,0 +1,51 @@ +function flux2mag, flux, zero_pt, ABwave = abwave +;+ +; NAME: +; FLUX2MAG +; PURPOSE: +; Convert from flux (ergs/s/cm^2/A) to magnitudes. +; EXPLANATION: +; Use MAG2FLUX() for the opposite direction. +; +; CALLING SEQUENCE: +; mag = flux2mag( flux, [ zero_pt, ABwave= ] ) +; +; INPUTS: +; flux - scalar or vector flux vector, in erg cm-2 s-1 A-1 +; +; OPTIONAL INPUT: +; zero_pt - scalar giving the zero point level of the magnitude. +; If not supplied then zero_pt = 21.1 (Code et al 1976) +; Ignored if the ABwave keyword is supplied +; +; OPTIONAL KEYWORD INPUT: +; ABwave - wavelength scalar or vector in Angstroms. If supplied, then +; FLUX2MAG() returns Oke AB magnitudes (Oke & Gunn 1983, ApJ, 266, +; 713). +; +; OUTPUT: +; mag - magnitude vector. If the ABwave keyword is set then mag +; is given by the expression +; ABMAG = -2.5*alog10(f) - 5*alog10(ABwave) - 2.406 +; +; Otherwise, mag is given by the expression +; mag = -2.5*alog10(flux) - zero_pt +; EXAMPLE: +; Suppose one is given wavelength and flux vectors, w (in Angstroms) and +; f (in erg cm-2 s-1 A-1). Plot the spectrum in AB magnitudes +; +; IDL> plot, w, flux2mag(f,ABwave = w), /nozero +; +; REVISION HISTORY: +; Written J. Hill STX Co. 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added ABwave keyword W. Landsman September 1998 +;- + + if ( N_params() LT 2 ) then zero_pt = 21.10 ;Default zero pt + + if keyword_set(ABwave) then $ + return, -2.5*alog10(flux) - 5*alog10(ABwave) - 2.406 else $ + return, -2.5*alog10(flux) - zero_pt + + end diff --git a/modules/idl_downloads/astro/pro/fm_unred.pro b/modules/idl_downloads/astro/pro/fm_unred.pro new file mode 100644 index 0000000..2bb8de2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fm_unred.pro @@ -0,0 +1,174 @@ +pro fm_unred, wave, flux, ebv, funred, R_V = R_V, gamma = gamma, x0 = x0, $ + c1 = c1, c2 = c2, c3 = c3, c4 = c4,avglmc=avglmc, lmc2 = lmc2, $ + ExtCurve=ExtCurve +;+ +; NAME: +; FM_UNRED +; PURPOSE: +; Deredden a flux vector using the Fitzpatrick (1999) parameterization +; EXPLANATION: +; The R-dependent Galactic extinction curve is that of Fitzpatrick & Massa +; (Fitzpatrick, 1999, PASP, 111, 63; astro-ph/9809387 ). +; Parameterization is valid from the IR to the far-UV (3.5 microns to 0.1 +; microns). UV extinction curve is extrapolated down to 912 Angstroms. +; +; CALLING SEQUENCE: +; FM_UNRED, wave, flux, ebv, [ funred, R_V = , /LMC2, /AVGLMC, ExtCurve= +; gamma =, x0=, c1=, c2=, c3=, c4= ] +; INPUT: +; WAVE - wavelength vector (Angstroms) +; FLUX - calibrated flux vector, same number of elements as WAVE +; If only 3 parameters are supplied, then this vector will +; updated on output to contain the dereddened flux. +; EBV - color excess E(B-V), scalar. If a negative EBV is supplied, +; then fluxes will be reddened rather than dereddened. +; +; OUTPUT: +; FUNRED - unreddened flux vector, same units and number of elements +; as FLUX +; +; OPTIONAL INPUT KEYWORDS +; R_V - scalar specifying the ratio of total to selective extinction +; R(V) = A(V) / E(B - V). If not specified, then R = 3.1 +; Extreme values of R(V) range from 2.3 to 5.3 +; +; /AVGLMC - if set, then the default fit parameters c1,c2,c3,c4,gamma,x0 +; are set to the average values determined for reddening in the +; general Large Magellanic Cloud (LMC) field by Misselt et al. +; (1999, ApJ, 515, 128) +; /LMC2 - if set, then the fit parameters are set to the values determined +; for the LMC2 field (including 30 Dor) by Misselt et al. +; Note that neither /AVGLMC or /LMC2 will alter the default value +; of R_V which is poorly known for the LMC. +; +; The following five input keyword parameters allow the user to customize +; the adopted extinction curve. For example, see Clayton et al. (2003, +; ApJ, 588, 871) for examples of these parameters in different interstellar +; environments. +; +; x0 - Centroid of 2200 A bump in microns (default = 4.596) +; gamma - Width of 2200 A bump in microns (default =0.99) +; c3 - Strength of the 2200 A bump (default = 3.23) +; c4 - FUV curvature (default = 0.41) +; c2 - Slope of the linear UV extinction component +; (default = -0.824 + 4.717/R) +; c1 - Intercept of the linear UV extinction component +; (default = 2.030 - 3.007*c2 +; +; OPTIONAL OUTPUT KEYWORD: +; ExtCurve - Returns the E(wave-V)/E(B-V) extinction curve, interpolated +; onto the input wavelength vector +; +; EXAMPLE: +; Determine how a flat spectrum (in wavelength) between 1200 A and 3200 A +; is altered by a reddening of E(B-V) = 0.1. Assume an "average" +; reddening for the diffuse interstellar medium (R(V) = 3.1) +; +; IDL> w = 1200 + findgen(40)*50 ;Create a wavelength vector +; IDL> f = w*0 + 1 ;Create a "flat" flux vector +; IDL> fm_unred, w, f, -0.1, fnew ;Redden (negative E(B-V)) flux vector +; IDL> plot,w,fnew +; +; NOTES: +; (1) The following comparisons between the FM curve and that of Cardelli, +; Clayton, & Mathis (1989), (see ccm_unred.pro): +; (a) - In the UV, the FM and CCM curves are similar for R < 4.0, but +; diverge for larger R +; (b) - In the optical region, the FM more closely matches the +; monochromatic extinction, especially near the R band. +; (2) Many sightlines with peculiar ultraviolet interstellar extinction +; can be represented with the FM curve, if the proper value of +; R(V) is supplied. +; (3) Use the 4 parameter calling sequence if you wish to save the +; original flux vector. +; PROCEDURE CALLS: +; CSPLINE(), POLY() +; REVISION HISTORY: +; Written W. Landsman Raytheon STX October, 1998 +; Based on FMRCurve by E. Fitzpatrick (Villanova) +; Added /LMC2 and /AVGLMC keywords, W. Landsman August 2000 +; Added ExtCurve keyword, J. Wm. Parker August 2000 +; Assume since V5.4 use COMPLEMENT to WHERE W. Landsman April 2006 +; Fix calculation of EXTCurve A. Sarkisyan/W. Landsman Jan 2014 +; +;- + On_error, 2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax: FM_UNRED, wave, flux, ebv, funred,[ R_V =, /LMC2, /AVGLMC ' + print,' gamma =, x0 =, c1 =, c2 = ,c3 = ,c4 =, ExtCurve=]' + return + endif + + if N_elements(R_V) EQ 0 then R_V = 3.1 + + x = 10000./ wave ; Convert to inverse microns + curve = x*0. + +; Set default values of c1,c2,c3,c4,gamma and x0 parameters + + if keyword_set(LMC2) then begin + if N_elements(x0) EQ 0 then x0 = 4.626 + if N_elements(gamma) EQ 0 then gamma = 1.05 + if N_elements(c4) EQ 0 then c4 = 0.42 + if N_elements(c3) EQ 0 then c3 = 1.92 + if N_elements(c2) EQ 0 then c2 = 1.31 + if N_elements(c1) EQ 0 then c1 = -2.16 + endif else if keyword_set(AVGLMC) then begin + if N_elements(x0) EQ 0 then x0 = 4.596 + if N_elements(gamma) EQ 0 then gamma = 0.91 + if N_elements(c4) EQ 0 then c4 = 0.64 + if N_elements(c3) EQ 0 then c3 = 2.73 + if N_elements(c2) EQ 0 then c2 = 1.11 + if N_elements(c1) EQ 0 then c1 = -1.28 + endif else begin + if N_elements(x0) EQ 0 then x0 = 4.596 + if N_elements(gamma) EQ 0 then gamma = 0.99 + if N_elements(c3) EQ 0 then c3 = 3.23 + if N_elements(c4) EQ 0 then c4 = 0.41 + if N_elements(c2) EQ 0 then c2 = -0.824 + 4.717/R_V + if N_elements(c1) EQ 0 then c1 = 2.030 - 3.007*c2 + endelse + +; Compute UV portion of A(lambda)/E(B-V) curve using FM fitting function and +; R-dependent coefficients + + xcutuv = 10000.0/2700.0 + xspluv = 10000.0/[2700.0,2600.0] + iuv = where(x ge xcutuv, N_UV, complement = iopir, Ncomp = Nopir) + IF (N_UV GT 0) THEN xuv = [xspluv,x[iuv]] ELSE xuv = xspluv + + yuv = c1 + c2*xuv + yuv = yuv + c3*xuv^2/((xuv^2-x0^2)^2 +(xuv*gamma)^2) + yuv = yuv + c4*(0.5392*((xuv>5.9)-5.9)^2+0.05644*((xuv>5.9)-5.9)^3) + yuv = yuv + R_V + yspluv = yuv[0:1] ; save spline points + + IF (N_UV GT 0) THEN curve[iuv] = yuv[2:*] ; remove spline points + +; Compute optical portion of A(lambda)/E(B-V) curve +; using cubic spline anchored in UV, optical, and IR + + xsplopir = [0,10000.0/[26500.0,12200.0,6000.0,5470.0,4670.0,4110.0]] + ysplir = [0.0,0.26469,0.82925]*R_V/3.1 + ysplop = [poly(R_V, [-4.22809e-01, 1.00270, 2.13572e-04] ), $ + poly(R_V, [-5.13540e-02, 1.00216, -7.35778e-05] ), $ + poly(R_V, [ 7.00127e-01, 1.00184, -3.32598e-05] ), $ + poly(R_V, [ 1.19456, 1.01707, -5.46959e-03, 7.97809e-04, $ + -4.45636e-05] ) ] + + ysplopir = [ysplir,ysplop] + + if (Nopir GT 0) then $ + curve[iopir] = CSPLINE([xsplopir,xspluv],[ysplopir,yspluv],x[iopir]) + + ; Now apply extinction correction to input flux vector + + curve = ebv*curve + if N_params() EQ 3 then flux = flux * 10.^(0.4*curve) else $ + funred = flux * 10.^(0.4*curve) ;Derive unreddened flux + + ExtCurve = Curve/ebv - R_V ;Updated Jan 2014 + + end diff --git a/modules/idl_downloads/astro/pro/forprint.pro b/modules/idl_downloads/astro/pro/forprint.pro new file mode 100644 index 0000000..39b07a1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/forprint.pro @@ -0,0 +1,240 @@ +pro forprint, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, $ + v15,v16,v17,v18,TEXTOUT = textout, FORMAT = format, SILENT = SILENT, $ + STARTLINE = startline, NUMLINE = numline, COMMENT = comment, $ + SUBSET = subset, NoCOMMENT=Nocomment,STDOUT=stdout, WIDTH=width +;+ +; NAME: +; FORPRINT +; PURPOSE: +; Print a set of vectors by looping over each index value. +; +; EXPLANATION: +; If W and F are equal length vectors, then the statement +; IDL> forprint, w, f +; is equivalent to +; IDL> for i = 0L, N_elements(w)-1 do print,w[i],f[i] +; +; CALLING SEQUENCE: +; forprint, v1,[ v2, v3, v4,....v18, FORMAT = , TEXTOUT = ,STARTLINE =, +; SUBSET=, NUMLINE =, /SILENT, COMMENT= ] +; +; INPUTS: +; V1,V2,...V18 - Arbitrary IDL vectors. If the vectors are not of +; equal length then the number of rows printed will be equal +; to the length of the smallest vector. Up to 18 vectors +; can be supplied. +; +; OPTIONAL KEYWORD INPUTS: +; +; TEXTOUT - Controls print output device, defaults to !TEXTOUT +; +; textout=1 TERMINAL using /more option if available +; textout=2 TERMINAL without /more option +; textout=3 file 'forprint.prt' +; textout=4 file 'laser.tmp' +; textout=5 user must open file +; textout = filename (default extension of .prt) +; textout=7 Append to .prt file if it exists +; +; COMMENT - String scalar or vector to write to the first line of output +; file if TEXTOUT > 2. By default, FORPRINT will write a time +; stamp on the first line. Use /NOCOMMENT if you don't want +; FORPRINT to write anything in the output file. If COMMENT +; is a vector then one line will be written for each element. +; FORMAT - Scalar format string as in the PRINT procedure. The use +; of outer parenthesis is optional. Ex. - format="(F10.3,I7)" +; This program will automatically remove a leading "$" from +; incoming format statements. Ex. - "$(I4)" would become "(I4)". +; If omitted, then IDL default formats are used. +; /NOCOMMENT - Set this keyword if you don't want any comment line +; line written as the first line in a harcopy output file. +; /SILENT - Normally, with a hardcopy output (TEXTOUT > 2), FORPRINT will +; print an informational message. If the SILENT keyword +; is set and non-zero, then this message is suppressed. +; SUBSET - Index vector specifying elements to print. No error checking +; is done to make sure the indicies are valid. The statement +; +; IDL> forprint,x,y,z,subset=s +; is equivalent to +; IDL> for i=0,n-1 do print, x[s[i]], y[s[i]], z[s[i]] +; +; STARTLINE - Integer scalar specifying the first line in the arrays +; to print. Default is STARTLINE = 1, i.e. start at the +; beginning of the arrays. (If a SUBSET keyword is supplied +; then STARTLINE refers to first element in the subscript vector.) +; /STDOUT - If set, the force standard output unit (=-1) if not writing +; to a file. This allows the FORPINT output to be captured +; in a journal file. Only needed for non-GUI terminals +; WIDTH - Line width for wrapping, passed onto OPENW when using hardcopy. +; +; OUTPUTS: +; None +; SYSTEM VARIABLES: +; If keyword TEXTOUT is not used, the default is the nonstandard +; keyword !TEXTOUT. If you want to use FORPRINT to write more than +; once to the same file then set TEXTOUT=5, and open and close the +; file yourself (see documentation of TEXTOPEN for more info). +; +; The non-standard system variables !TEXTOUT and !TEXTUNIT are +; automatically added if not present to start with. +; EXAMPLE: +; Suppose W,F, and E are the wavelength, flux, and epsilon vectors for +; a spectrum. Print these values to a file 'output.dat' in a nice +; format. +; +; IDL> fmt = '(F10.3,1PE12.2,I7)' +; IDL> forprint, F = fmt, w, f, e, TEXT = 'output.dat' +; RESTRICTIONS: +; Uses the EXECUTE() function and so is not compatible with the IDL +; virtual machine. +; PROCEDURES CALLED: +; TEXTOPEN, TEXTCLOSE +; REVISION HISTORY: +; Written W. Landsman April, 1989 +; Keywords textout and format added, J. Isensee, July, 1990 +; Made use of parenthesis in FORMAT optional W. Landsman May 1992 +; Added STARTLINE keyword W. Landsman November 1992 +; Set up so can handle 18 input vectors. J. Isensee, HSTX Corp. July 1993 +; Handle string value of TEXTOUT W. Landsman, HSTX September 1993 +; Added NUMLINE keyword W. Landsman, HSTX February 1996 +; Added SILENT keyword W. Landsman, RSTX, April 1998 +; Much faster printing to a file W. Landsman, RITSS, August, 2001 +; Use SIZE(/TNAME) instead of DATATYPE() W. Landsman SSAI October 2001 +; Fix skipping of first line bug introduced Aug 2001 W. Landsman Nov2001 +; Added /NOCOMMENT keyword, the SILENT keyword now controls only +; the display of informational messages. W. Landsman June 2002 +; Skip PRINTF if IDL in demo mode W. Landsman October 2004 +; Assume since V5.4 use BREAK instead of GOTO W. Landsman April 2006 +; Add SUBSET keyword, warning if different size vectors passed. +; P.Broos,W.Landsman. Aug 2006 +; Change keyword_set() to N_elements W. Landsman Oct 2006 +; Added /STDOUT keyword W. Landsman Oct 2006 +; Fix error message for undefined variable W. Landsman April 2007 +; Added WIDTH keyword J. Bailin Nov 2010 +; Allow multiple (vector) comment lines W. Landsman April 2011 +; Define !TEXTOUT and !TEXTUNIT if needed. W. Landsman October 2012 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + npar = N_params() + if npar EQ 0 then begin + print,'Syntax - FORPRINT, v1, [ v2, v3,...v18, FORMAT =, /SILENT, SUBSET=' + print,' /NoCOMMENT, COMMENT =, STARTLINE = , NUMLINE =, TEXTOUT =, WIDTH =]' + return + endif + + defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it. + defsysv,'!TEXTUNIT',exists=ex ; Check if !TEXTUNIT exists. + if ex eq 0 then defsysv,'!TEXTUNIT',0 ; If not define it. + + + if N_elements( STARTLINE ) EQ 0 then startline = 1l else $ + startline = startline > 1l + + fmt="F" ;format flag + npts = N_elements(v1) + + if ( npts EQ 0 ) then message,'ERROR - Parameter 1 is not defined' + +; Remove "$" sign from format string and append parentheses if not +; already present + + if N_elements( format ) EQ 1 then begin + + fmt = "T" ;format present + frmt = format + if strmid(frmt,0,1) eq '$' then $ + frmt = strmid(frmt,1,strlen(frmt)-1) ;rem. '$' from format if present + + if strmid(frmt,0,1) NE '(' then frmt = '(' + frmt + if strmid( frmt,strlen(frmt)-1,1) NE ')' then frmt += ')' + + endif + + if npar GT 1 then begin ;Get number of elements in smallest array + + for i = 2, npar do begin + tst = execute('this_npts = N_elements(v'+strtrim(i,2)+')') + if this_npts EQ 0 then $ + message,'ERROR - Parameter ' + strtrim(i,2) + ' is not defined' + + if ((npts NE this_npts) && ~keyword_set(silent)) then $ + message,/INF,'Warning, vectors have different lengths.' + + npts = npts < this_npts + endfor + + endif + + if keyword_set(NUMLINE) then npts = (startline + numline-1) < npts + + if N_Elements(SUBSET) GT 0 then begin + npts = N_elements(subset) < npts + index = '[subset[i]]' + endif else index = '[i]' + + + str = 'v1' + index + if npar GT 1 then $ + for i = 2, npar do str = str + ',v' + strtrim(i,2) + index + +; Use default output dev. + demo = lmgr(/demo) + if ~demo then begin + + if ~keyword_set( TEXTOUT ) then textout = !TEXTOUT + if size( textout,/TNAME) EQ 'STRING' then text_out = 6 $ ;make numeric + else text_out = textout + + textopen,'FORPRINT',TEXTOUT=textout,SILENT=silent,STDOUT=STDOUT, $ + MORE_SET = more_set, WIDTH=width + if ( text_out GT 2 ) && (~keyword_set(NOCOMMENT)) then begin + Ncomm = N_elements(comment) + if Ncomm GT 0 then $ + for i=0,ncomm-1 do printf,!TEXTUNIT,comment[i] else $ + printf,!TEXTUNIT,'FORPRINT: ',systime() + endif + endif + + if fmt EQ "F" then begin ;Use default formats + + if demo then begin + test = execute('for i=startline-1,npts-1 do print,' + str) + + endif else if more_set then begin + for i = startline-1, npts-1 do begin + + test = execute('printf,!TEXTUNIT,' + str) + if !ERR EQ 1 then BREAK ;Did user press 'Q' key? + + endfor + endif else test = $ + execute('for i=startline-1,npts-1 do printf,!TEXTUNIT,' + str) + + endif else begin ;User specified format + + if demo then begin + test = execute('for i=startline-1,npts-1 do print,FORMAT=frmt,' + str) + + endif else if more_set then begin + + for i = startline-1, npts-1 do begin + + test = execute( 'printf, !TEXTUNIT, FORMAT=frmt,' + str ) + if !ERR EQ 1 then BREAK + + endfor + + endif else test = $ + execute('for i=startline-1,npts-1 do printf,!TEXTUNIT,FORMAT=frmt,'+str) + + + endelse + + + textclose, TEXTOUT = textout ;Close unit opened by TEXTOPEN + + return + end diff --git a/modules/idl_downloads/astro/pro/frebin.pro b/modules/idl_downloads/astro/pro/frebin.pro new file mode 100644 index 0000000..1f2e10e --- /dev/null +++ b/modules/idl_downloads/astro/pro/frebin.pro @@ -0,0 +1,217 @@ +function frebin,image,nsout,nlout,total=total +;+ +; NAME: +; FREBIN +; +; PURPOSE: +; Shrink or expand the size of an array an arbitrary amount using interpolation +; +; EXPLANATION: +; FREBIN is an alternative to CONGRID or REBIN. Like CONGRID it +; allows expansion or contraction by an arbitrary amount. ( REBIN requires +; integral factors of the original image size.) Like REBIN it conserves +; flux by ensuring that each input pixel is equally represented in the output +; array. +; +; CALLING SEQUENCE: +; result = FREBIN( image, nsout, nlout, [ /TOTAL] ) +; +; INPUTS: +; image - input image, 1-d or 2-d numeric array +; nsout - number of samples in the output image, numeric scalar +; +; OPTIONAL INPUT: +; nlout - number of lines in the output image, numeric scalar +; If not supplied, then set equal to 1 +; +; OPTIONAL KEYWORD INPUTS: +; /total - if set, the output pixels will be the sum of pixels within +; the appropriate box of the input image. Otherwise they will +; be the average. Use of the /TOTAL keyword conserves total counts. +; +; OUTPUTS: +; The resized image is returned as the function result. If the input +; image is of type DOUBLE or FLOAT then the resized image is of the same +; type. If the input image is BYTE, INTEGER or LONG then the output +; image is usually of type FLOAT. The one exception is expansion by +; integral amount (pixel duplication), when the output image is the same +; type as the input image. +; +; EXAMPLE: +; Suppose one has an 800 x 800 image array, im, that must be expanded to +; a size 850 x 900 while conserving the total counts: +; +; IDL> im1 = frebin(im,850,900,/total) +; +; im1 will be a 850 x 900 array, and total(im1) = total(im) +; NOTES: +; If the input image sizes are a multiple of the output image sizes +; then FREBIN is equivalent to the IDL REBIN function for compression, +; and simple pixel duplication on expansion. +; +; If the number of output pixels are not integers, the output image +; size will be truncated to an integer. The platescale, however, will +; reflect the non-integer number of pixels. For example, if you want to +; bin a 100 x 100 integer image such that each output pixel is 3.1 +; input pixels in each direction use: +; n = 100/3.1 ; 32.2581 +; image_out = frebin(image,n,n) +; +; The output image will be 32 x 32 and a small portion at the trailing +; edges of the input image will be ignored. +; +; PROCEDURE CALLS: +; None. +; HISTORY: +; Adapted from May 1998 STIS version, written D. Lindler, ACC +; Added /NOZERO, use INTERPOLATE instead of CONGRID, June 98 W. Landsman +; Fixed for nsout non-integral but a multiple of image size Aug 98 D.Lindler +; DJL, Oct 20, 1998, Modified to work for floating point image sizes when +; expanding the image. +; Improve speed by addressing arrays in memory order W.Landsman Dec/Jan 2001 +;- +;---------------------------------------------------------------------------- + On_error,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax = newimage = FREBIN(image, nsout, nlout, [/TOTAL])' + return,-1 + endif + + if n_elements(nlout) eq 0 then nlout=1 +; +; determine size of input image +; + ns = n_elements(image[*,0]) + nl = n_elements(image)/ns +; +; determine if we can use the standard rebin function +; + dtype = size(image,/TNAME) + if dtype EQ 'DOUBLE' then begin + sbox = ns/double(nsout) + lbox = nl/double(nlout) + end else begin + sbox = ns/float(nsout) + lbox = nl/float(nlout) + end + +; Contraction by an integral amount + + if (nsout eq long(nsout)) && (nlout eq long(nlout)) then begin + if ((ns mod nsout) EQ 0) && ((nl mod nlout) EQ 0) then $ + if (dtype EQ 'DOUBLE') || (dtype EQ 'FLOAT') then begin + if keyword_set(total) then $ + return,rebin(image,nsout,nlout)*sbox*lbox else $ + return,rebin(image,nsout,nlout) + endif else begin + if keyword_set(total) then $ + return,rebin(float(image),nsout,nlout)*sbox*lbox else $ + return,rebin(float(image),nsout,nlout) + endelse + + +; Expansion by an integral amount + if ((nsout mod ns) EQ 0) && ((nlout mod nl) EQ 0) then begin + xindex = long(lindgen(nsout)/(nsout/ns)) + if nl EQ 1 then begin + if keyword_set(total) then $ + return,interpolate(image,xindex)*sbox else $ + return,interpolate(image,xindex) + endif + yindex = long(lindgen(nlout)/(nlout/nl)) + if keyword_set(total) then $ + return,interpolate(image,xindex,yindex,/grid)*sbox*lbox else $ + return,interpolate(image,xindex,yindex,/grid) + endif + endif + ns1 = ns-1 + nl1 = nl-1 + +; Do 1-d case separately + + if nl EQ 1 then begin + if dtype eq 'DOUBLE' then result = dblarr(nsout,/NOZERO) $ + else result = fltarr(nsout,/NOZERO) + for i=0L,nsout-1 do begin + rstart = i*sbox ;starting position for each box + istart = long(rstart) + rstop = rstart + sbox ;ending position for each box + istop = long(rstop) ftab_ext,'spec.fit','wavelength,flux',w,f +; or +; IDL> ftab_ext,'spec.fit',[1,2],w,f +; +; PROCEDURES CALLED: +; FITS_READ, FITS_CLOSE, FTINFO, FTGET(), TBINFO, TBGET() +; HISTORY: +; version 1 W. Landsman August 1997 +; Improve speed processing binary tables W. Landsman March 2000 +; Use new FTINFO calling sequence W. Landsman May 2000 +; Don't call fits_close if fcb supplied W. Landsman May 2001 +; Use STRSPLIT to parse column string W. Landsman July 2002 +; Cleanup pointers in TBINFO structure W. Landsman November 2003 +; Avoid EXECUTE() if V6.1 or later W. Landsamn December 2006 +; Assume since V6.1 W. Landsman June 2009 +; Read up to 30 columns W.L. Aug 2009 +; Setting ROWS = -1 should work as documented, accept up to 50 +; columns W.L. Oct 2013 +;- +;--------------------------------------------------------------------- + compile_opt idl2 + if N_params() LT 3 then begin + print,'Syntax - FTAB_EXT, name, columns, v1, [v2,...,v50, ROWS=, EXTEN=]' + return + endif + N_ext = N_params() - 2 + strng = size(columns,/TNAME) EQ 'STRING' ;Is columns a string? + + if ~keyword_set(exten_no) then exten_no = 1 + dtype = size(file_or_fcb,/TNAME) + if dtype NE 'STRUCT' then fits_open,file_or_fcb,fcb else fcb=file_or_fcb + if fcb.nextend EQ 0 then $ + message,'ERROR - FITS file contains no table extensions' + if fcb.nextend LT exten_no then $ + message,'ERROR - FITS file contains only ' + strtrim(fcb.nextend,2) + $ + ' extensions' + + if (N_elements(rows) GT 0) && (min(rows) GE 0) then begin + minrow = min(rows, max = maxrow) + naxis1 = fcb.axis[0,exten_no] + first = naxis1*minrow + last = naxis1*(maxrow+1)-1 + xrow = rows - minrow + fits_read,fcb,tab,htab,exten_no=exten_no,first=first,last=last,/no_pdu + tab = reform(tab,naxis1,maxrow-minrow+1,/overwrite) + endif else begin + fits_read, fcb, tab, htab, exten_no=exten_no,/no_pdu + xrow = -1 + endelse + if dtype NE 'STRUCT' then fits_close,fcb else $ + file_or_fcb.last_extension = exten_no + ext_type = fcb.xtension[exten_no] + + case ext_type of + 'A3DTABLE': binary = 1b + 'BINTABLE': binary = 1b + 'TABLE': binary = 0b + else: message,'ERROR - Extension type of ' + $ + ext_type + 'is not a FITS table format' + endcase + + if strng then colnames= strsplit(columns,',',/EXTRACT) else $ + colnames = columns + if binary then tbinfo,htab,tb_str else ftinfo,htab,ft_str + + + vv = 'v' + strtrim( indgen(n_ext)+1,2) + for i = 0, N_ext-1 do begin + + if binary then $ + (scope_varfetch(vv[i])) = TBGET( tb_str,tab,colnames[i],xrow,nulls) $ + else $ + (scope_varfetch(vv[i])) = FTGET( ft_str,tab,colnames[i],xrow,nulls) + endfor + if binary then begin + ptr_free, tb_str.tscal + ptr_free, tb_str.tzero + endif + return + end + + diff --git a/modules/idl_downloads/astro/pro/ftab_help.pro b/modules/idl_downloads/astro/pro/ftab_help.pro new file mode 100644 index 0000000..a2b3d1f --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftab_help.pro @@ -0,0 +1,103 @@ +pro ftab_help,file_or_fcb,EXTEN_NO = exten_no, TEXTOUT = textout +;+ +; NAME: +; FTAB_HELP +; PURPOSE: +; Describe the columns of a FITS binary or ASCII table extension(s). +; +; CALLING SEQUENCE: +; FTAB_HELP, filename, [ EXTEN_No = , TEXTOUT= ] +; or +; FTAB_HELP, fcb, [EXTEN_No=, TEXTOUT= ] +; +; INPUTS: +; filename - scalar string giving name of the FITS file. +; fcb - FITS control block returned by a previous call to FITS_OPEN +; +; OPTIONAL KEYWORD INPUTS: +; EXTEN_NO - integer scalar or vector specifying which FITS extensions +; to display. Default is to display all FITS extension. +; TEXTOUT - scalar number (0-7) or string (file name) determining +; output device (see TEXTOPEN). Default is TEXTOUT=1, output +; to the user's terminal +; +; EXAMPLE: +; Describe the columns in the second and fourth extensions of a FITS +; file spec.fits and write the results to a file 'spec24.lis' +; +; IDL> ftab_help,'spec.fits',exten=[2,4],t='spec24.lis' +; +; SYSTEM VARIABLES: +; Uses the non-standard system variables !TEXTOUT and !TEXTUNIT +; which must be defined (e.g. with ASTROLIB) before compilation +; NOTES: +; The behavior of FTAB_HELP was changed in August 2005 to display +; all extensions by default, rather than just the first extension +; PROCEDURES USED: +; FITS_READ, FITS_CLOSE, FITS_OPEN, FTHELP, TBHELP, TEXTOPEN, TEXTCLOSE +; HISTORY: +; version 1 W. Landsman August 1997 +; Corrected documentation W. Landsman September 1997 +; Don't call fits_close if fcb supplied W. Landsman May 2001 +; Default now is to display all extensions, EXTEN keyword can now +; be a vector W. Landsman Aug 2005 +;- +;---------------------------------------------------------------------- + compile_opt idl2 + if N_params() LT 1 then begin + print,'Syntax - FTAB_HELP, fcb_or_filename, [EXTEN_NO=, TEXTOUT= ]' + return + endif + + sz = size(file_or_fcb) + if sz[sz[0]+1] NE 8 then fits_open,file_or_fcb,fcb else fcb=file_or_fcb + if fcb.nextend EQ 0 then begin + message,'File contains no Table extensions',/INF + if sz[sz[0]+1] NE 8 then fits_close,fcb else $ + file_or_fcb.last_extension = exten_no + return + endif + if N_elements(exten_no) EQ 0 then exten_no = indgen(fcb.nextend)+1 + + nprint = N_elements(exten_no) + textopen,'ftab_help',textout=textout + printf,!TEXTUNIT,' ' +printf,!TEXTUNIT, 'FITS file: ' + fcb.filename + printf,!TEXTUNIT,' ' + + for i=0, nprint-1 do begin + + fits_read,fcb, dummy, htab, /header_only,/no_pdu, exten_no=exten_no[i] + ext_type = fcb.xtension[exten_no[i]] + + image = 0b + case ext_type of + 'A3DTABLE': binary = 1b + 'BINTABLE': binary = 1b + 'TABLE': binary = 0b + 'IMAGE': image = 1b + else: message,'ERROR - Extension type of ' + $ + ext_type + ' is not a recognized FITS extension' + endcase + + enum = exten_no[i] + printf,!TEXTUNIT, 'Extension No: ' + strtrim(enum,2) + + if image then begin + dimen = sxpar(htab,'NAXIS*') + printf, !TEXTUNIT,'FITS Image Extension: Size ' + $ + strjoin(strtrim(dimen,2),' by ') + endif else begin + + + if binary then tbhelp, htab, TEXTOUT = 5 $ + else fthelp, htab, TEXTOUT = 5 + printf,!TEXTUNIT,' ' + endelse + endfor + if sz[sz[0]+1] NE 8 then fits_close,fcb else $ + file_or_fcb.last_extension = enum + + textclose, textout=textout + return + end diff --git a/modules/idl_downloads/astro/pro/ftab_print.pro b/modules/idl_downloads/astro/pro/ftab_print.pro new file mode 100644 index 0000000..63bb8f9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftab_print.pro @@ -0,0 +1,107 @@ +pro ftab_print,filename,columns,rows, TEXTOUT = textout, FMT = fmt, $ + EXTEN_NO = exten_no, num_header_lines=num_header_lines, $ + nval_per_line=nval_per_line +;+ +; NAME: +; FTAB_PRINT +; PURPOSE: +; Print the contents of a FITS (binary or ASCII) table extension. +; EXPLANATION: +; User can specify which rows or columns to print +; +; CALLING SEQUENCE: +; FTAB_PRINT, filename, columns, rows, +; [ TEXTOUT=, FMT=, EXTEN_NO= NUM_HEADER_LINES ] +; +; INPUTS: +; filename - scalar string giving name of a FITS file containing a +; binary or ASCII table +; columns - string giving column names, or vector giving +; column numbers (beginning with 1). If a string +; supplied then column names should be separated by comma's. +; if not supplied, then all columns are printed. +; If set to '*' then all columns are printed in table format +; (1 row per line, binary tables only). +; rows - (optional) vector of row numbers to print (beginning with 0). +; If not supplied or set to scalar, -1, then all rows +; are printed. +; OPTIONAL KEYWORD INPUT: +; EXTEN_NO - Extension number to read. If not set, then the first +; extension is printed (EXTEN_NO=1) +; FMT = Format string for print display (binary tables only). If not +; supplied, then any formats in the TDISP keyword fields will be +; used, otherwise IDL default formats. For ASCII tables, the +; format used is always as stored in the FITS table. +; NUM_HEADER_LINES - Number of lines to display the column headers (default +; = 1). By setting NUM_HEADER_LINES to an integer larger than 1, +; one can avoid truncation of the headers. In addition, setting +; NUM_HEADER_LINES will display commented lines indicating +; a FORMAT for reading the data, and a suggested call to +; readfmt.pro. Works for binary tables only +; NVAL_PER_LINE - The maximum number of values displayed from a +; multivalued column when printing in table format. Default = 6 +; TEXTOUT - scalar number (0-7) or string (file name) determining +; output device (see TEXTOPEN). Default is TEXTOUT=1, output +; to the user's terminal +; EXAMPLE: +; (1) Print all rows of the first 5 columns of the first extension of the +; file 'wfpc.fits' +; IDL> ftab_print,'vizier.fits',indgen(5)+1 +; +; (2) Print all columns of the first row to a file 'vizier.dat' in +; 'table' format +; IDL> ftab_print,'vizier.fits',t='vizier.dat','*',0 +; SYSTEM VARIABLES: +; Uses the non-standard system variables !TEXTOUT and !TEXTUNIT +; which must be defined (e.g. with ASTROLIB) prior to compilation. +; PROCEDURES USED: +; FITS_CLOSE, FITS_OPEN, FITS_READ, FTPRINT, TBPRINT +; HISTORY: +; version 1 W. Landsman August 1997 +; Check whether data exists W. Landsman Feb 2007 +; Check whether extension exists W. Landsman Mar 2010 +; Added NUM_HEADER_LINES, NVAL_PER_LINE keywords for binary tables +; W. Landsman Apr 2010 +;- +;---------------------------------------------------------------------- + On_error,2 + compile_opt idl2 + if N_params() LT 1 then begin + print,'Syntax - ftab_print, filename, columns, rows,' + print,' [EXTEN_NO=, FMT= , TEXTOUT= ]' + return + endif + + if not keyword_set(exten_no) then exten_no = 1 + + fits_open,filename,fcb + if fcb.nextend LT exten_no then begin + message,/CON, $ + 'ERROR - Extension ' + strtrim(exten_no,2) + ' not present in FITS file' + return + endif + + if fcb.axis[1,exten_no] EQ 0 then begin + message,/CON, $ + 'ERROR - Extension ' + strtrim(exten_no,2) + ' contains no data' + return + endif + fits_read,fcb,tab,htab,exten_no=exten_no + fits_close,fcb + + ext_type = fcb.xtension[exten_no] + + case ext_type of + 'A3DTABLE': binary = 1b + 'BINTABLE': binary = 1b + 'TABLE': binary = 0b + else: message,'ERROR - Extension type of ' + $ + ext_type + ' is not a FITS table format' + endcase + + if binary then tbprint,htab,tab,columns,rows, TEXTOUT = textout,fmt=fmt, $ + num_header_lines=num_header_lines, $ + nval_per_line=nval_per_line $ + else ftprint,htab,tab,columns,rows, TEXTOUT = textout + return + end diff --git a/modules/idl_downloads/astro/pro/ftaddcol.pro b/modules/idl_downloads/astro/pro/ftaddcol.pro new file mode 100644 index 0000000..a53d23a --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftaddcol.pro @@ -0,0 +1,150 @@ +pro ftaddcol,h,tab,name,idltype,tform,tunit,tscal,tzero,tnull +;+ +; NAME: +; FTADDCOL +; PURPOSE: +; Routine to add a field to a FITS ASCII table +; +; CALLING SEQUENCE: +; ftaddcol, h, tab, name, idltype, [ tform, tunit, tscal, tzero, tnull ] +; +; INPUTS: +; h - FITS table header. It will be updated as appropriate +; tab - FITS table array. Number of columns will be increased if +; neccessary. +; name - field name, scalar string +; idltype - idl data type (as returned by SIZE function) for field, +; For string data (type=7) use minus the string length. +; +; OPTIONAL INPUTS: +; tform - format specification 'qww.dd' where q = A, I, E, or D +; tunit - string giving physical units for the column. +; tscal - scale factor +; tzero - zero point for field +; tnull - null value for field +; +; Use '' as the value of tform,tunit,tscal,tzero,tnull if you want +; the default or no specification of them in the table header. +; +; OUTPUTS: +; h,tab - updated to allow new column of data +; +; PROCEDURES USED: +; FTINFO, FTSIZE, GETTOK(), SXADDPAR +; HISTORY: +; version 1 D. Lindler July, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated call to new FTINFO W. Landsman April 2000 +;- + On_error,2 + if N_params() LT 2 then begin + print,'Syntax - FTADDCOL, h, tab, name, idltype, ' + print,' [ tform, tunit, tscal, tzero, tnull ]' + return + endif + +; get table size + + ftsize,h,tab,ncols,nrows,tfields,allcols,allrows + +; check to see if column name is a string + + s = size(name) + if (s[0] NE 0) or (s[1] NE 7) then $ + message,'Column name must be a string' + +; check to see if column already exists + + ftinfo,h,ft_str, Count = count + if Count GT 0 then begin + g = where(strtrim(ft_str.ttype,2) EQ strupcase(name), Ng) + if Ng GT 0 then message,'ERROR - Column '+name+' already exists' + endif + +; set non specified inputs to '' + + npar = N_params() + if npar lt 5 then tform = '' + if npar lt 6 then tunit = '' + if npar lt 7 then tscal = '' + if npar lt 8 then tzero = '' + if npar lt 9 then tnull = '' + +; create default format if not supplied + + if tform eq '' then begin + case idltype of + 1: tform = 'I4' ;byte + 2: tform = 'I6' ;integer*2 + 4: tform = 'E15.8' ;real*4 + 3: tform = 'I11' ;longword + 5: tform = 'D23.8' ;real*8 + else: begin + if idltype LT 0 then begin ;string + tform = 'A'+strtrim(fix(abs(idltype)),2) + idltype = 7 + end else message,'Invalid idltype specified' + end + end; case + end + +; get field width from format + + width = fix(gettok(strmid(tform,1,strlen(tform)-1),'.')) + +; +; is present allocated table size large enough? +; +; If the new field is not a string, put a zero in the leftmost position +; of the record so that a "Type conversion error" won't occur. +; + if (width+ncols) GT allcols then begin + tab = [ tab, replicate(32B,width,allrows)] ;increase size + if (idltype NE 7) then tab[allcols,*] = 48B + endif + +; +; update header +; + tfields = tfields+1 + apos = strtrim(tfields,2) + ttype = strupcase(name) ;ttype + while strlen(ttype) lt 8 do ttype = ttype+' ' + sxaddpar,h,'TTYPE'+apos,ttype,'','HISTORY' + +; + sxaddpar,h,'TBCOL'+apos,ncols+1,'','HISTORY' ;tbcol (WBL 2-88) + +; + while strlen(tform) lt 8 do tform = tform+' ' ;tform + sxaddpar,h,'TFORM'+apos,tform,'','HISTORY' + + + if tunit NE '' then begin ;tunit + while strlen(tunit) lt 8 do tunit = tunit+' ' + sxaddpar,h,'tunit'+apos,tunit,'','HISTORY' + end + + if string(tscal) NE '' then $ + sxaddpar,h,'tscal'+apos,tscal,'','HISTORY' ;tscal + + + if string(tzero) NE '' then $ + sxaddpar,h,'tzero'+apos,tzero,'','HISTORY' ;tzero + + if string(tnull) NE '' then begin ;tnull + s = size(tnull) & type = s[s[0]+1] + if type NE 1 then stnull = string(tnull,'('+strtrim(tform)+')') $ + else stnull = tnull + while strlen(stnull) LT 8 do stnull = stnull+' ' + sxaddpar, h, 'TNULL' + apos, stnull, '', 'HISTORY' + end + +; +; increase table size in header +; + sxaddpar,h,'TFIELDS',tfields + sxaddpar,h,'NAXIS1',ncols+width + + return + end diff --git a/modules/idl_downloads/astro/pro/ftcreate.pro b/modules/idl_downloads/astro/pro/ftcreate.pro new file mode 100644 index 0000000..5602ed3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftcreate.pro @@ -0,0 +1,55 @@ +pro ftcreate, MAXCOLS,MAXROWS,H,TAB +;+ +; NAME: +; FTCREATE +; PURPOSE: +; Create a new (blank) FITS ASCII table and header with specified size. +; +; CALLING SEQUENCE: +; ftcreate, maxcols, maxrows, h, tab +; +; INPUTS: +; maxcols - number of character columns allocated, integer scalar +; maxrows - maximum number of rows allocated, integer scalar +; +; OUTPUTS: +; h - minimal FITS Table extension header, string array +; OPTIONAL OUTPUT: +; tab - empty table, byte array +; HISTORY: +; version 1 D. Lindler July. 87 +; Converted to IDL V5.0 W. Landsman September 1997 +; Make table creation optional, allow 1 row table, add comments to +; required FITS keywords W. Landsman October 2001 +;- +;---------------------------------------------------------------------- + On_error,2 + + if n_params() lt 3 then begin + print,'Syntax - FTCREATE, maxcols, maxrows, h, [tab]' + return + endif + +; Create blank table if tab output variable supplied + + if N_params() GE 4 then begin + tab = replicate(32B, maxcols, maxrows) + if maxrows EQ 1 then tab = reform(tab,maxcols,1) + endif +; +; Create header (destroy any previous contents) and add required ASCII table +; keywords +; + h = strarr(9) + string(' ',format='(a80)') + h[0] = 'END' + string(replicate(32b,77)) + sxaddpar, h, 'XTENSION', 'TABLE ',' ASCII table extension' + sxaddpar, h, 'BITPIX', 8,' 8 bit bytes' + sxaddpar, h, 'NAXIS', 2,' 2-dimensional ASCII table' + sxaddpar, h, 'NAXIS1', 0,' Width of table in bytes' + sxaddpar, h, 'NAXIS2', 0,' Number of rows in table' + sxaddpar, h, 'PCOUNT', 0,' Size of special data area' + sxaddpar, h, 'GCOUNT', 1,' one data group (required keyword) + sxaddpar, h, 'TFIELDS', 0,' Number of fields in each row' + + return + end diff --git a/modules/idl_downloads/astro/pro/ftdelcol.pro b/modules/idl_downloads/astro/pro/ftdelcol.pro new file mode 100644 index 0000000..8c9fa91 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftdelcol.pro @@ -0,0 +1,114 @@ +pro ftdelcol,h,tab,name +;+ +; NAME: +; FTDELCOL +; PURPOSE: +; Delete a column of data from a FITS table +; +; CALLING SEQUENCE: +; ftdelcol, h, tab, name +; +; INPUTS-OUPUTS +; h,tab - FITS table header and data array. H and TAB will +; be updated with the specified column deleted +; +; INPUTS: +; name - Either (1) a string giving the name of the column to delete +; or (2) a scalar giving the column number to delete (starting with 1) +; Only 1 column can be deleted at a time +; +; EXAMPLE: +; Suppose it has been determined that the F7.2 format used for a field +; FLUX in a FITS table is insufficient. The old column must first be +; deleted before a new column can be written with a new format. +; +; flux = FTGET(h,tab,'FLUX') ;Save the existing values +; FTDELCOL,h,tab,'FLUX' ;Delete the existing column +; FTADDCOL,h,tab,'FLUX',8,'F9.2' ;Create a new column with larger format +; FTPUT,h,tab,'FLUX',0,flux ;Put back the original values +; +; REVISION HISTORY: +; Written W. Landsman STX Co. August, 1988 +; Adapted for IDL Version 2, J. Isensee, July, 1990 +; Updated call to new FTINFO W. Landsman May 2000 +; Allow specification of column number in addition to field name +; M. Nolan/W. Landsman Sep 2015 +;- +; On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - FTDELCOL, h, tab, name' + return + endif + + ftsize,h,tab,ncol,nrows,tfields,allcols,allrows + +; Make sure column exists + + ftinfo, h, ft_str ;Get starting column and width (in bytes) + sz = size(name) + if ((sz[0] ne 0) || (sz[1] EQ 0)) then $ + message,'Invalid field specification, it must be a scalar' + + if sz[1] EQ 7 then begin ;If a string, get the field number + ttype = strupcase( strtrim(ft_str.ttype,2)) + field = where(ttype EQ strupcase(strtrim(name,2)), Npos) + 1 + if Npos EQ 0 then message, $ + 'Specified field ' + strupcase(strtrim(name,2)) + ' not in FITS table' + endif else begin ;Column number supplied + field = long(name) + if (field LT 1 || field GT n_elements(ft_str.ttype)) then message, $ + 'Column number must be between 1 and ' + strtrim(n_elements(ft_str.ttype),2) + endelse + + +; Eliminate relevant columns from TAB + + field = field[0] + tbcol = ft_str.tbcol[field-1]-1 ;Convert to IDL indexing + width = ft_str.width[field-1] + case 1 of + tbcol eq 0: tab = tab[width:*,*] ;First column + tbcol eq ncol-width: tab = tab[0:tbcol-1,*] ;Last column + else: tab = [tab[0:tbcol-1,*],tab[tbcol+width:*,*]] ;All other columns + endcase + +; Parse the header. Remove specified keyword from header. Lower +; the index of subsequent keywords. Update the TBCOL*** index of +; subsequent keywords + + nh = N_elements(h) + hnew = strarr(nh) + j = 0 + key = strupcase(strmid(h,0,5)) + for i= 0,nh-1 do begin ;Loop over each element in header + if (key[i] eq 'TTYPE') || (key[i] eq 'TFORM') || (key[i] eq 'TUNIT') || $ + (key[i] eq 'TNULL') || (key[i] eq 'TBCOL') then begin + row = h[i] + ifield = fix(strtrim(strmid(row,5,3))) + if ifield GT field then begin ;Subsequent field? + if ifield le 10 then fmt = "(I1,' ')" else fmt ='(I2)' + strput,row,string(ifield-1,format=fmt),5 + if key[i] eq 'TBCOL' then begin + value = fix(strtrim(strmid(row,10,20)))-width + v = string(value) + s = strlen(v) + strput,row,v,30-s ;Right justify + endif + endif + if ifield ne field then hnew[j] = row else j-- + + endif else hnew[j] = h[i] + + j++ + endfor + + sxaddpar,hnew,'TFIELDS',tfields-1 ;Reduce number of fields by 1 + sxaddpar,hnew,'NAXIS1',ncol-width ;Reduce num. of columns by WIDTH + + h = hnew[0:j-1] + message,'Field '+ strtrim(strupcase(name),2) + $ + ' has been deleted from the FITS table',/INF + + return + end diff --git a/modules/idl_downloads/astro/pro/ftdelrow.pro b/modules/idl_downloads/astro/pro/ftdelrow.pro new file mode 100644 index 0000000..5e64b7e --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftdelrow.pro @@ -0,0 +1,74 @@ +pro ftdelrow,h,tab,rows +;+ +; NAME: +; FTDELROW +; PURPOSE: +; Delete a row of data from a FITS table +; +; CALLING SEQUENCE: +; ftdelrow, h, tab, rows +; +; INPUTS-OUPUTS +; h,tab - FITS table header and data array. H and TAB will +; be updated on output with the specified row(s) deleted. +; rows - scalar or vector, specifying the row numbers to delete +; This vector will be sorted and duplicates removed by FTDELROW +; +; EXAMPLE: +; Compress a table to include only non-negative flux values +; +; flux = FTGET(h,tab,'FLUX') ;Obtain original flux vector +; bad = where(flux lt 0) ;Find negative fluxes +; FTDELROW,h,tab,bad ;Delete rows with negative fluxes +; +; PROCEDURE: +; Specified rows are deleted from the data array, TAB. The NAXIS2 +; keyword in the header is updated. +; +; PROCEDURES USED: +; sxaddpar +; +; REVISION HISTORY: +; Written W. Landsman STX Co. August, 1988 +; Checked for IDL Version 2, J. Isensee, July, 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +; Assume since V5.4, use BREAK instead of GOTO W. Landsman April 2006 +; +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - ftdelrow,h,tab,rows' + return + endif + + nrows = sxpar(h,'NAXIS2') ;Original number of rows + if (max(rows) GE nrows) or (min(rows) LT 0) then $ + message,'Specified rows must be between 0 and ' + strtrim(nrows-1,2) + + ndel = N_elements(rows) + if ndel GT 1 then begin + rows = rows[rem_dup(rows)] ;Sort and remove duplicate values + ndel = N_elements(rows) + endif + + j = 0L + i = rows[0] + for k = long(rows[0]),nrows-1 do begin + if k EQ rows[j] then begin + j = j+1 + if j EQ ndel then BREAK + endif else begin + tab[0,i] = tab[*,k] + i = i+1 + endelse + + endfor + k = k-1 + + if k NE nrows-1 then tab[0,i] = tab[*,i+j:nrows-1] + tab = tab[*,0:nrows-ndel-1] + sxaddpar,h,'NAXIS2',nrows-ndel ;Reduce number of rows + + return + end diff --git a/modules/idl_downloads/astro/pro/ftget.pro b/modules/idl_downloads/astro/pro/ftget.pro new file mode 100644 index 0000000..a5f6885 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftget.pro @@ -0,0 +1,146 @@ +function ftget,hdr_or_ftstr,tab,field,rows,nulls +;+ +; NAME: +; FTGET +; PURPOSE: +; Function to return value(s) from specified column in a FITS ASCII table +; +; CALLING SEQUENCE +; values = FTGET( h, tab, field, [ rows, nulls ] ) +; or +; values = FTGET( ft_str, tab, field. [rows, nulls] +; INPUTS: +; h - FITS ASCII extension header (e.g. as returned by FITS_READ) +; or +; ft_str - FITS table structure extracted from FITS header by FTINFO +; Use of the IDL structure will improve processing speed +; tab - FITS ASCII table array (e.g. as returned by FITS_READ) +; field - field name or number +; +; OPTIONAL INPUTS: +; rows - scalar or vector giving row number(s) +; Row numbers start at 0. If not supplied or set to +; -1 then values for all rows are returned +; +; OUTPUTS: +; the values for the row are returned as the function value. +; Null values are set to 0 or blanks for strings. +; +; OPTIONAL OUTPUT: +; nulls - null value flag of same length as the returned data. +; It is set to 1 at null value positions and 0 elsewhere. +; If supplied then the optional input, rows, must also +; be supplied. +; +; EXAMPLE: +; Read the columns labeled 'WAVELENGTH' and 'FLUX' from the second +; (ASCII table) extension of a FITS file 'spectra.fit' +; +; IDL> fits_read,'spectra.fit',tab,htab,exten=2 ;Read 2nd extension +; IDL> w = ftget( htab, tab,'wavelength') ;Wavelength vector +; IDL> f = ftget( htab, tab,'flux') ;Flux vector +; +; Slightly more efficient would be to first call FTINFO +; IDL> ftinfo, htab, ft_str ;Extract structure +; IDL> w = ftget(ft_str, tab,'wavelength') ;Wavelength vector +; IDL> f = ftget(ft_str, tab,'flux') ;Flux vector +; +; NOTES: +; (1) Use the higher-level procedure FTAB_EXT to extract vectors +; directly from the FITS file. +; (2) Use FTAB_HELP or FTHELP to determine the columns in a particular +; ASCII table. +; HISTORY: +; coded by D. Lindler July, 1987 +; Always check for null values W. Landsman August 1990 +; More informative error message W. Landsman Feb. 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Allow structure rather than FITS header W. Landsman May 2000 +; No case sensitivity in TTYPE name W. Landsman February 2002 +;- +;------------------------------------------------------------------ +; On_error,2 + + sz = size(tab) + nrows = sz(2) + +; get characteristics of specified field + + size_hdr = size(hdr_or_ftstr) + case size_hdr[size_hdr[0]+1] of + 7: ftinfo,hdr_or_ftstr,ft_str + 8: ft_str = hdr_or_ftstr + else: message,'ERROR - Invalid FITS header or structure supplied' + endcase + + sz = size(field) + if ((sz[0] ne 0) or (sz[1] EQ 0)) then $ + message,'Invalid field specification, it must be a scalar' + + if sz[1] EQ 7 then begin + field = strupcase(strtrim(field,2)) + ttype = strupcase( strtrim(ft_str.ttype,2) ) + ipos = where(ttype EQ field, Npos) + if Npos EQ 0 then message, $ + 'Specified field ' + strupcase(strtrim(field,2)) + ' not in table' + endif else ipos = field -1 + ipos = ipos[0] + + tbcol = ft_str.tbcol[ipos]-1 ;IDL starts at zero not one + width = ft_str.width[ipos] + tnull = ft_str.tnull[ipos] + idltype = ft_str.idltype[ipos] + +; if rows not supplied then return all rows + + if N_params() LT 4 then rows = -1 + +; determine if scalar supplied + + row = rows + s = size(row) & ndim = s[0] + if ndim EQ 0 then begin ;scalar? + if row LT 0 then begin ; -1 get all rows + ndim = 1 + row = lindgen(nrows) + end else begin + row = lonarr(1) + row + end + end + +; check for valid row numbers + + if (min(row) lt 0) or (max(row) gt (nrows-1)) then $ + message,'ERROR - Row numbers must be between 0 and ' + $ + strtrim((nrows-1),2) + +; get column + + if ndim EQ 0 then begin ;scalar? + dd = string(tab[tbcol:tbcol+width-1,row[0]]) + data = strarr(1) + data[0] = dd + end else begin ;vector + data = string(tab[tbcol:tbcol+width-1,*]) + data = data[row] + end + +; check for null values + n = N_elements(data) + d = make_array(size=[1,n,idltype,n]) + + if strlen(tnull) GT 0 then begin + len = strlen(data[0]) ;field size + while strlen(tnull) LT len do tnull = tnull + ' ' ;pad with blanks + if strlen(tnull) GT len then tnull = strmid(tnull,0,len) + nulls = data EQ tnull + valid = where(nulls EQ 0b, nvalid) + +; convert data to the correct type + + if nvalid GT 0 then d[valid] = data[valid] + + endif else d[0] = strtrim(data,2) + + return,d + end diff --git a/modules/idl_downloads/astro/pro/fthelp.pro b/modules/idl_downloads/astro/pro/fthelp.pro new file mode 100644 index 0000000..63eb46f --- /dev/null +++ b/modules/idl_downloads/astro/pro/fthelp.pro @@ -0,0 +1,96 @@ +pro fthelp,h,TEXTOUT=textout +;+ +; NAME: +; FTHELP +; PURPOSE: +; Routine to print a description of a FITS ASCII table extension +; +; CALLING SEQUENCE: +; FTHELP, H, [ TEXTOUT = ] +; +; INPUTS: +; H - FITS header for ASCII table extension, string array +; +; OPTIONAL INPUT KEYWORD +; TEXTOUT - scalar number (0-7) or string (file name) determining +; output device (see TEXTOPEN). Default is TEXTOUT=1, output +; to the user's terminal +; +; NOTES: +; FTHELP checks that the keyword XTENSION equals 'TABLE' in the FITS +; header. +; +; SYSTEM VARIABLES: +; Uses the non-standard system variables !TEXTOUT and !TEXTUNIT +; which must be defined (e.g. with ASTROLIB) prior to compilation. +; PROCEDURES USED: +; REMCHAR, SXPAR(), TEXTOPEN, TEXTCLOSE, ZPARCHECK +; +; HISTORY: +; version 1 W. Landsman Jan. 1988 +; Add TEXTOUT option, cleaner format W. Landsman September 1991 +; TTYPE value can be longer than 8 chars, W. Landsman August 1995 +; Remove calls to !ERR, some vectorization W. Landsman February 2000 +; Slightly more compact display W. Landsman August 2005 +;- + compile_opt idl2 + On_error,2 ;Return to caller + + if N_params() EQ 0 then begin + print,'Syntax - FTHELP, hdr, [ TEXTOUT = ]' + return + endif + + zparcheck,'FTHELP',h,1,7,1,'Table Header' ;Make sure a string array + + n = sxpar( h, 'TFIELDS' , Count = N_TFields) + if N_TFields EQ 0 then message, $ + 'ERROR - FITS Header does not include required TFIELDS keyword' + if strtrim(sxpar(h,'XTENSION'),2) ne 'TABLE' then $ + message,'WARNING - Header is not for a FITS Table',/INF + + if not keyword_set(TEXTOUT) then textout = 1 + textopen,'fthelp',TEXTOUT=textout + + naxis = sxpar( h, 'NAXIS*') + printf,!TEXTUNIT,'FITS ASCII Table: ' +$ + 'Size ',strtrim(naxis[0],2),' by ',strtrim(naxis[1],2) + + extname = sxpar(h,'EXTNAME', Count=N_ext) + if N_ext GT 0 then printf,!TEXTUNIT, 'Extension Name: ',sxpar(h,'EXTNAME') + extver = sxpar(h, 'EXTVER', Count = N_extver) + if N_extver GT 0 then printf,!TEXTUNIT,'Version: ',extver + printf,!TEXTUNIT,' ' + printf,!TEXTUNIT, $ + 'Field Name Unit Format Column' + + tbcol = intarr(n) + tform = strarr(n) & tunit = tform & ttype =tform + name = strmid(h,0,5) + number = strtrim(strmid(h,5,3),2) + value = strtrim(strmid(h,11,20),2) + + for i = 1, N_elements(h)-1 do begin + case name[i] of + 'TTYPE': ttype[fix(number[i]-1)] = value[i] + 'TFORM': tform[fix(number[i]-1)] = value[i] + 'TUNIT': tunit[fix(number[i]-1)] = value[i] + 'TBCOL': tbcol[fix(number[i]-1)] = fix(value[i]) + 'END ': goto, DONE + ELSE : + end + + endfor + +DONE: ;Done reading FITS header + + ttype = strtrim(ttype,2) & remchar,ttype,"'" + remchar,tunit,"'" + remchar,tform,"'" + for i = 0,n-1 do printf,!TEXTUNIT,i+1,ttype[i],tunit[i],tform[i],tbcol[i], $ + f='(I5,T9,A,T30,A,T47,A,T55,I8)' + + textclose,TEXTOUT=textout + + return + end diff --git a/modules/idl_downloads/astro/pro/fthmod.pro b/modules/idl_downloads/astro/pro/fthmod.pro new file mode 100644 index 0000000..2e1e8d3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fthmod.pro @@ -0,0 +1,63 @@ +pro fthmod,h,field,parameter,value +;+ +; NAME: +; FTHMOD +; PURPOSE: +; Procedure to modify header information for a specified field +; in a FITS table. +; +; CALLING SEQUENCE: +; fthmod, h, field, parameter, value +; +; INPUT: +; h - FITS header for the table +; field - field name or number +; parameter - string name of the parameter to modify. Choices +; include: +; TTYPE - field name +; TUNIT - physical units for field (eg. 'ANGSTROMS') +; TNULL - null value (string) for field, (eg. '***') +; TFORM - format specification for the field +; TSCAL - scale factor +; TZERO - zero offset +; User should be aware that the validity of the change is +; not checked. Unless you really know what you are doing, +; this routine should only be used to change field names, +; units, or another user specified parameter. +; value - new value for the parameter. Refer to the FITS table +; standards documentation for valid values. +; +; EXAMPLE: +; Change the units for a field name "FLUX" to "Janskys" in a FITS table +; header,h +; +; IDL> FTHMOD, h, 'FLUX', 'TUNIT','Janskys' +; METHOD: +; The header keyword is modified +; with the new value. +; HISTORY: +; version 1, D. Lindler July 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Major rewrite to use new FTINFO call W. Landsman May 2000 +;- +;----------------------------------------------------------------------- +on_error,2 + + ftinfo,h,ft_str + sz = size(field) + if ((sz[0] ne 0) or (sz[1] EQ 0)) then $ + message,'Invalid field specification, it must be a scalar' + + if sz[1] EQ 7 then begin + field = strupcase(strtrim(field,2)) + ttype = strtrim(ft_str.ttype,2) + ipos = where(ttype EQ field, Npos) + if Npos EQ 0 then message, $ + 'Specified field ' + strupcase(strtrim(field,2)) + ' not in table' + endif else ipos = field -1 + +; + par = parameter+strtrim(ipos[0]+1,2) + sxaddpar,h,par,value +return +end diff --git a/modules/idl_downloads/astro/pro/ftinfo.pro b/modules/idl_downloads/astro/pro/ftinfo.pro new file mode 100644 index 0000000..c5230fd --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftinfo.pro @@ -0,0 +1,116 @@ +pro ftinfo, h, ft_str, Count = tfields +;+ +; NAME: +; FTINFO +; PURPOSE: +; Return an informational structure from a FITS ASCII table header. +; CALLING SEQUENCE: +; ftinfo,h,ft_str, [Count = ] +; +; INPUTS: +; h - FITS ASCII table header, string array +; +; OUTPUTS: +; ft_str - IDL structure with extracted info from the FITS ASCII table +; header. Tags include +; .tbcol - starting column position in bytes +; .width - width of the field in bytes +; .idltype - idltype of field. +; 7 - string, 4- real*4, 3-integer, 5-real*8 +; .tunit - string unit numbers +; .tscal - scale factor +; .tzero - zero point for field +; .tnull - null value for the field +; .tform - format for the field +; .ttype - field name +; +; OPTIONAL OUTPUT KEYWORD: +; Count - Integer scalar giving number of fields in the table +; PROCEDURES USED: +; GETTOK(), SXPAR() +; NOTES: +; This procedure underwent a major revision in May 2000, and **THE +; NEW CALLING SEQUENCE IS INCOMPATIBLE WITH THE OLD ONE ** +; HISTORY: +; D. Lindler July, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Major rewrite, return structure W. Landsman April 2000 +;- +;---------------------------------------------------------------------------- +; On_error,2 +; + if N_params() LT 2 then begin + print,'Syntax - FTINFO, header, ft_str' + return + endif + +; get number of fields + + tfields = sxpar( h, 'TFIELDS' , Count = N_TFields) + if N_TFields EQ 0 then $ + message,'Invalid FITS header. keyword TFIELDS is missing' + + if tfields EQ 0 then return + tbcol = intarr(tfields) + tform = replicate(' ',tfields) + +; get info for specified field + + ttype = sxpar(h,'ttype*',Count=N_ttype) ;field name + if N_ttype EQ 0 then ttype = strarr(tfields) + + tbcol[0] = sxpar(h,'tbcol*', Count = N_tbcol) ;starting column position + if N_tbcol NE tfields then message,/CON, $ + 'Warning - Invalid FITS table header -- TBCOL not present for all fields' +; + tform[0] = strtrim(sxpar(h,'tform*', Count = N_tform),2) ; column format + if N_tform NE tfields then message,/CON, $ + 'Warning - Invalid FITS table header -- TFORM not present for all fields' + ; ; physical units + tunit = strarr(Tfields) + temp = sxpar(h, 'TUNIT*', Count = N_tunit) + if N_tunit GT 0 then tunit[0] = temp + + tscal = fltarr(Tfields) + temp = sxpar(h, 'TSCAL*', Count = N_tscal) ; data scale factor + if N_tscal GT 0 then tscal[0] = temp + + tzero = fltarr(tfields) + temp = sxpar(h,'TZERO*', Count = N_tzero) ; zero point for field + if N_tzero GT 0 then tzero[0] = temp + + tnull = strarr(Tfields) + temp = sxpar(h,'TNULL*', Count = N_tnull) ;null data value + if N_tnull GT 0 then tnull[0] = temp +; +; determine idl data type from format +; + type = strmid(tform,0,1) + idltype = intarr(tfields) + for i=0,tfields-1 do begin + case strupcase(type[i]) of + 'A' : idltype[i] = 7 + 'I' : idltype[i] = 3 + 'E' : idltype[i] = 4 + 'F' : idltype[i] = 4 + 'D' : idltype[i] = 5 + else: message,'Invalid format specification for keyword ' + $ + 'TFORM' + strtrim(i+1,2) + endcase + endfor +; +; get field width in characters +; + decpos = strpos(tform,'.') + decimal = decpos GT 0 + len = strlen(tform) + width = intarr(tfields) + for i=0, tfields-1 do begin + if decimal[i] then width[i] = fix(strmid(tform[i],1,decpos[i]-1)) else $ + width[i] = fix(strmid(tform[i],1,len[i]-1)) + endfor + ft_str = {TBCOL:tbcol,WIDTH:width,IDLTYPE:idltype,TUNIT:tunit, TSCAL:tscal, $ + TZERO:tzero, TNULL:tnull, TFORM:tform, TTYPE:ttype} + + return + end diff --git a/modules/idl_downloads/astro/pro/ftkeeprow.pro b/modules/idl_downloads/astro/pro/ftkeeprow.pro new file mode 100644 index 0000000..f02c4b1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftkeeprow.pro @@ -0,0 +1,41 @@ +pro ftkeeprow,h,tab,subs +;+ +; NAME: +; FTKEEPROW +; PURPOSE: +; Subscripts (and reorders) a FITS table. A companion piece to FTDELROW. +; +; CALLING SEQUENCE: +; ftkeeprow, h, tab, subs +; +; INPUT PARAMETERS: +; h = FITS table header array +; tab = FITS table data array +; subs = subscript array of FITS table rows. Works like any other IDL +; subscript array (0 based, of course). +; +; OUTPUT PARAMETERS: +; h and tab are modified +; +; MODIFICATION HISTORY: +; Written by R. S. Hill, ST Sys. Corp., 2 May 1991. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 ;Return to caller + + if N_params() LT 3 then begin + print,'Syntax - ftkeeprow, h, tab, subs' + return + endif + + insize = sxpar(h,'NAXIS2') + tab = tab[*,subs] + outsize = N_elements(subs) + sxaddpar, h, 'NAXIS2', outsize + tag = 'FTKEEPROW '+systime(0)+': ' + sxaddhist, tag + 'table subscripted', h + sxaddhist, tag + strtrim(string(insize),2) + ' rows in, ' + $ + strtrim(string(outsize),2) + ' rows out',h + + return + end diff --git a/modules/idl_downloads/astro/pro/ftprint.pro b/modules/idl_downloads/astro/pro/ftprint.pro new file mode 100644 index 0000000..71278e0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftprint.pro @@ -0,0 +1,170 @@ +pro ftprint,h,tab,columns,rows,textout=textout +;+ +; NAME: +; FTPRINT +; PURPOSE: +; Procedure to print specified columns and rows of a FITS table +; +; CALLING SEQUENCE: +; FTPRINT, h, tab, columns, [ rows, TEXTOUT = ] +; +; INPUTS: +; h - Fits header for table, string array +; tab - table array +; columns - string giving column names, or vector giving +; column numbers (beginning with 1). If string +; supplied then column names should be separated by comma's. +; rows - (optional) vector of row numbers to print. If +; not supplied or set to scalar, -1, then all rows +; are printed. +; +; OUTPUTS: +; None +; +; OPTIONAL INPUT KEYWORDS: +; TEXTOUT controls the output device; see the procedure TEXTOPEN +; +; SYSTEM VARIABLES: +; Uses nonstandard system variables !TEXTOUT and !TEXTOPEN +; These will be defined (using ASTROLIB) if not already present. +; Set !TEXTOUT = 3 to direct output to a disk file. The system +; variable is overriden by the value of the keyword TEXTOUT +; +; EXAMPLES: +; +; ftprint,h,tab,'STAR ID,RA,DEC' ;print id,ra,dec for all stars +; ftprint,h,tab,[2,3,4],indgen(100) ;print columns 2-4 for +; ;first 100 stars +; ftprint,h,tab,text="stars.dat" ;Convert entire FITS table to +; ;an ASCII file named STARS.DAT +; +; PROCEDURES USED: +; FTSIZE, FTINFO, TEXTOPEN, TEXTCLOSE +; +; RESTRICTIONS: +; (1) Program does not check whether output length exceeds output +; device capacity (e.g. 80 or 132). +; (2) Column heading may be truncated to fit in space defined by +; the FORMAT specified for the column +; (3) Program does not check for null values +; +; HISTORY: +; version 1 D. Lindler Feb. 1987 +; Accept undefined values of rows, columns W. Landsman August 1997 +; New FTINFO calling sequence W. Landsman May 2000 +; Parse scalar string with STRSPLIT W. Landsman July 2002 +; Fix format display of row number W. Landsman March 2003 +; Fix format display of row number again W. Landsman May 2003 +;- +; On_error,2 + compile_opt idl2 +; +; set defaulted parameters +; + if N_params() LT 2 then begin + print,'Syntax - FTPRINT, h, tab, [ columns, rows, TEXTOUT= ]' + return + endif + + defsysv,'!textout',exists = i + if i EQ 0 then astrolib + + if N_elements(columns) EQ 0 then columns = -1 + if N_elements(rows) EQ 0 then rows= -1 + if not keyword_set(TEXTOUT) then textout = !TEXTOUT + +; make sure rows is a vector + + n = N_elements(rows) + if n EQ 1 then r = [rows] else r = long(rows) + ftsize,h,tab,ncols,nrows,tfields,allcols,allrows, ERRMSG = errmsg ;table size + if ERRMSG NE '' then message,errmsg + if r[0] EQ -1 then r = lindgen(nrows) ;default + + Nr = N_elements(r) + good = where( (r GE 0) and (r LT nrows), Ngood) + if Ngood NE Nr then begin + if Ngood EQ 0 then message,'ERROR - No valid row numbers supplied' + r = r[good] + endif +; +; extract column info +; + title1 = '' + title2 = '' + FTINFO,h,ft_str + +; +; if columns is a string, change it to string array +; + if size(columns,/TNAME) EQ 'STRING' then begin + colnames = strsplit(columns,',',/EXTRACT) + numcol = N_elements(colnames) + colnames = strupcase(strtrim(colnames,2)) + ttype = strtrim(ft_str.ttype,2) + colnum = intarr(numcol) + for i = 0,numcol-1 do begin + icol = where(ttype EQ colnames[i], Nfound) + if Nfound EQ 0 then message, $ + 'ERROR - Field ' + colnames[i] + ' not found in FITS ASCII table' + colnum[i] = icol[0] + endfor + end else begin ;user supplied vector + colnum = fix(columns) -1 ;make sure it is integer + numcol = N_elements(colnum) ;number of elements + if numcol EQ 1 then begin + if colnum[0] LT 0 then begin + colnum = indgen(tfields) & numcol = tfields + endif & endif + end + + flen = ft_str.width[colnum] + colpos = ft_str.tbcol[colnum] + ttype = strtrim( ft_str.ttype[colnum],2) + tunit = strtrim( ft_str.tunit[colnum],2) +; +; create header lines +; + for i=0,numcol-1 do begin + name = strn(ttype[i],padtype=2,len=flen[i] ) + unit = strn(tunit[i],padtype=2,len=flen[i] ) + title1 = title1 + ' ' + name + title2 = title2 + ' ' + unit + endfor +; +; open output file +; + textopen,'FTPRINT',TEXTOUT=textout, MORE_SET = more_set + + ifmt = fix(alog10(max(r)+1)) > 3 + title1 = strn('ROW',padtype=2,len = ifmt) + title1 + title2 = string(replicate(32b,ifmt+1)) + title2 + ifmt = strtrim(ifmt,2) +; +; loop on rows +; + printf,!TEXTUNIT,title1 + printf,!TEXTUNIT,title2 + printf,!TEXTUNIT,' ' + + for i = 0, Nr-1 do begin +; +; loop on columns +; + line = string(r[i],format='(i' + ifmt + ')') ;print line + for j = 0,numcol-1 do begin + cpos=colpos[j]-1 ;column number + val = string(tab[cpos:cpos+flen[j]-1,r[i]]) + line = line+' '+ val + endfor + printf,!TEXTUNIT,line + if more_set then if (!ERR EQ 1) then goto, DONE + endfor +; +; done +; +DONE: + textclose,textout=textout + + return + end diff --git a/modules/idl_downloads/astro/pro/ftput.pro b/modules/idl_downloads/astro/pro/ftput.pro new file mode 100644 index 0000000..cee3f6c --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftput.pro @@ -0,0 +1,174 @@ +pro ftput,h,tab,field,row,values,nulls +;+ +; NAME: +; FTPUT +; PURPOSE: +; Procedure to add or update a field in an FITS ASCII table +; CALLING SEQUENCE: +; FTPUT, htab, tab, field, row, values, [ nulls ] +; +; INPUTS: +; htab - FITS ASCII table header string array +; tab - FITS ASCII table array (e.g. as read by READFITS) +; field - string field name or integer field number +; row - either a non-negative integer scalar giving starting row to +; update, or a non-negative integer vector specifying rows to +; update. FTPUT will append a new row to a table if the value +; of 'row' exceeds the number of rows in the tab array +; values - value(s) to add or update. If row is a vector +; then values must contain the same number of elements. +; +; OPTIONAL INPUT: +; nulls - null value flag of same length as values. +; It should be set to 1 at null value positions +; and 0 elsewhere. +; +; OUTPUTS: +; htab,tab will be updated as specified. +; +; EXAMPLE: +; One has a NAME and RA and Dec vectors for 500 stars with formats A6, +; F9.5 and F9.5 respectively. Write this information to an ASCII table +; named 'star.fits'. +; +; IDL> FTCREATE,24,500,h,tab ;Create table header and (empty) data +; IDL> FTADDCOL,h,tab,'RA',8,'F9.5','DEGREES' ;Explicity define the +; IDL> FTADDCOL,h,tab,'DEC',8,'F9.5','DEGREES' ;RA and Dec columns +; IDL> FTPUT,h,tab,'RA',0,ra ;Insert RA vector into table +; IDL> FTPUT,h,tab,'DEC',0,dec ;Insert DEC vector into table +; IDL> FTPUT, h,tab, 'NAME',0,name ;Insert NAME vector with default +; IDL> WRITEFITS,'stars.fits',tab,h ;Write to a file +; +; Note that (1) explicit formatting has been supplied for the (numeric) +; RA and Dec vectors, but was not needed for the NAME vector, (2) A width +; of 24 was supplied in FTCREATE based on the expected formats (6+9+9), +; though the FT* will adjust this value as necessary, and (3) WRITEFITS +; will create a minimal primary header +; NOTES: +; (1) If the specified field is not already in the table, then FTPUT will +; create a new column for that field using default formatting. However, +; FTADDCOL should be called prior to FTPUT for explicit formatting. +; +; PROCEDURES CALLED +; FTADDCOL, FTINFO, FTSIZE, SXADDPAR, SXPAR() +; HISTORY: +; version 1 D. Lindler July, 1987 +; Allow E format W. Landsman March 1992 +; Write in F format if E format will overflow April 1994 +; Update documentation W. Landsman January 1996 +; Allow 1 element vector W. Landsman March 1996 +; Adjust string length to maximum of input string array June 1997 +; Work for more than 32767 elements August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated call to the new FTINFO W. Landsman May 2000 +; Fix case where header does not have any columns yet W.Landsman Sep 2002 +; Assume since V5.2, omit fstring() call W. Landsman April 2006 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 5 then begin + print,'Syntax - FTPUT, htab, tab, field, row, values, [nulls]' + return + endif + + nrow = N_elements(row) ;Number of elements in row vector + + nullflag = N_elements(nulls) GT 0 ;Null values supplied? + + ftsize,h,tab,ncols,nrows,tfields,allcols,allrows ; Get size of table + +; Make values a vector if scalar supplied + + s = size(values) & ndim = s[0] & type = s[ndim+1] + + if ndim gt 1 then $ + message,'Input values must be scalar or 1-D array' + + sz_row = size(row) + scalar = sz_row[0] EQ 0 + + v = values + if nullflag then nullvals = nulls + +; Get info on field specified + + ftinfo,h,ft_str, Count = tfields + if tfields EQ 0 then ipos = -1 else begin + if size(field,/TNAME) EQ 'STRING' then begin + field = strupcase(strtrim(field,2)) + ttype = strtrim(ft_str.ttype,2) + ipos = where(ttype EQ field, Npos) + endif else ipos = field -1 + endelse + + if ipos[0] EQ -1 then begin ;Does it exist? + +; Add new column if it doesn't exist + + if type EQ 7 then type = (-max(strlen(v))) + ftaddcol, h, tab, field, type + ftinfo,h,ft_str + ftsize,h,tab,ncols,nrows,tfields,allcols,allrows + ipos = tfields-1 + endif + + ipos = ipos[0] + tbcol = ft_str.tbcol[ipos]-1 ;IDL starts at zero not one. + +; Convert input vector to string array + + n = N_elements(v) + data = string(replicate(32b, ft_str.width[ipos], n ) ) + if nrow GT 1 then if (nrow NE n) then $ + message,'Number of specified rows must equal number of values' + + fmt = strupcase(strtrim(ft_str.tform[ipos],2)) + fmt1 = strmid(fmt,0,1) + if (fmt1 EQ 'D') or (fmt1 EQ 'E') then begin ;Need at least 6 chars for E fmt + point = strpos(fmt,'.') + wid = fix(strmid(fmt,1,point-1)) + decimal = fix(strmid(fmt,point+1,1000)) + if wid-decimal LT 6 then fmt = 'F' + strmid(fmt,1,1000) + endif + fmt = '(' + fmt + ')' + data = string(v, FORMAT = fmt) + +; insert null values + + if nullflag GT 5 then begin + bad = where(nullvals, Nbad) + if Nbad GT 0 then for i = 0L, Nbad-1 do data[bad[i]] = tnull + end + +; +; Do we need to increase the number of rows in the table? +; +if scalar then maxrow = row+n else maxrow = max(row) + 1 +if maxrow GT allrows then begin ;expand table size + + ; + ; Create a replacement table with the required number of rows. + ; + newtab = replicate(32b,allcols,maxrow) + newtab[0,0] = tab + + ; + ; Move the new table into the old table. + ; + tab = newtab + +end + if maxrow GT nrows then sxaddpar,h,'naxis2',maxrow + +; +; Now insert into table. +; + if scalar then tab[tbcol,row] = byte(data) $ + else for i = 0L,N_elements(row)-1 do tab[tbcol,row[i]] = byte(data[i]) + +; +; Return to calling routine. +; + return + end diff --git a/modules/idl_downloads/astro/pro/ftsize.pro b/modules/idl_downloads/astro/pro/ftsize.pro new file mode 100644 index 0000000..81c633c --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftsize.pro @@ -0,0 +1,73 @@ +pro ftsize,h,tab,ncols,nrows,tfields,ncols_all,nrows_all, ERRMSG = ERRMSG +;+ +; NAME: +; FTSIZE +; PURPOSE: +; Procedure to return the size of a FITS ASCII table. +; +; CALLING SEQUENCE: +; ftsize,h,tab,ncols,rows,tfields,ncols_all,nrows_all, [ERRMSG = ] +; +; INPUTS: +; h - FITS ASCII table header, string array +; tab - FITS table array, 2-d byte array +; +; OUTPUTS: +; ncols - number of characters per row in table +; nrows - number of rows in table +; tfields - number of fields per row +; ncols_all - number of characters/row allocated (size of tab) +; nrows_all - number of rows allocated +; +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; HISTORY +; D. Lindler July, 1987 +; Fix for 1-row table, W. Landsman HSTX, June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added ERRMSG keyword W. Landsman May 2000 +; +;- +;------------------------------------------------------------------------ + On_error,2 + +; check for valid header type + + s=size(h) & ndim=s[0] & type=s[ndim+1] + save_err = arg_present(errmsg) + errmsg = '' + + if (ndim ne 1) or (type ne 7) then begin + errmsg = 'Invalid FITS header, it must be a string array' + if not save_err then message,'ERROR - ' + errmsg + endif + +; check for valid table array + + s = size(tab) & ndim = s[0] & vtype = s[ndim+1] + if (vtype ne 1) then begin ;Mod June 1994, for degenerate dim. + errmsg = 'Invalid table array, it must be a 2-D byte array' + if not save_err then message,'ERROR - ' + errmsg + endif + + ncols_all = s[1] ;allocated characters per row + nrows_all = s[2] ;allocated rows + +; Get number of fields + + tfields = sxpar(h,'TFIELDS', Count = N) + if N LT 0 then begin + errmsg = 'Invalid FITS ASCII table header, TFIELDS keyword missing' + if not save_err then message,'ERROR - ' + errmsg + endif + +; Get number of columns and rows + + ncols = sxpar(h, 'NAXIS1') + nrows = sxpar(h, 'NAXIS2') + + return + end diff --git a/modules/idl_downloads/astro/pro/ftsort.pro b/modules/idl_downloads/astro/pro/ftsort.pro new file mode 100644 index 0000000..0e3c86b --- /dev/null +++ b/modules/idl_downloads/astro/pro/ftsort.pro @@ -0,0 +1,97 @@ +pro ftsort,h,tab,hnew,tabnew,field, reverse = revers +;+ +; NAME: +; FTSORT +; PURPOSE: +; Sort a FITS ASCII table according to a specified field +; +; CALLING SEQUENCE: +; FTSORT,h,tab,[field, REVERSE = ] ;Sort original table header and array +; or +; FTSORT,h,tab,hnew,tabnew,[field, REVERSE =] ;Create new sorted header +; +; INPUTS: +; H - FITS header (string array) +; TAB - FITS table (byte array) associated with H. If less than 4 +; parameters are supplied, then H and TAB will be updated to +; contain the sorted table +; +; OPTIONAL INPUTS: +; FIELD - Field name(s) or number(s) used to sort the entire table. +; If FIELD is a vector then the first element is used for the +; primary sort, the second element is used for the secondary +; sort, and so forth. (A secondary sort only takes effect when +; values in the primary sort field are equal.) Character fields +; are sorted using the ASCII collating sequence. If omitted, +; the user will be prompted for the field name. +; +; OPTIONAL OUTPUTS: +; HNEW,TABNEW - Header and table containing the sorted tables +; +; EXAMPLE: +; Sort a FITS ASCII table by the 'DECLINATION' field in descending order +; Assume that the table header htab, and array, tab, have already been +; read (e.g. with READFITS or FITS_READ): + +; IDL> FTSORT, htab, tab,'DECLINATION',/REVERSE +; OPTIONAL INPUT KEYWORD: +; REVERSE - If set then the table is sorted in reverse order (maximum +; to minimum. If FIELD is a vector, then REVERSE can also be +; a vector. For example, REVERSE = [1,0] indicates that the +; primary sort should be in descending order, and the secondary +; sort should be in ascending order. +; +; EXAMPLE: +; SIDE EFFECTS: +; A HISTORY record is added to the table header. +; REVISION HISTORY: +; Written W. Landsman June, 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +; New FTINFO calling sequence, added REVERSE keyword, allow secondary sorts +; W. Landsman May 2000 +;- + On_error,2 + npar = N_params() + if npar lt 2 then begin + print,'Syntax: ftsort, h, tab, [ field ]' + print,' OR: ftsort,h,tab,hnew,tabnew,[field]' + return + endif + + if npar eq 3 then field = hnew + + nf = N_elements(field) + nr = N_elements(revers) + if nr EQ 0 then revers = bytarr(nf) else $ + if nr LT nf then revers = [revers,bytarr(nf-nr)] + + ftinfo,h,ft_str + key = ftget(ft_str,tab, field[nf-1]) + index = sort(key) + if revers[nf-1] then index = reverse(index) + tabnew = tab[*,index] + + + if nf GT 1 then begin + for i= nf-2,0 do begin + key = ftget(ft_str,tabnew,field[i]) + index = bsort(key,reverse=revers[i]) + tabnew = tabnew[*,index] + endfor + endif + + str = strtrim(field[0],2) + if nf GT 1 then begin + for i = 1,nf-1 do str = str + ',' + strtrim( field[i],2) + str = 'Keywords: ' + str + endif else str = 'Keyword: ' + str + if npar ge 4 then begin + hnew = h + sxaddhist,'FTSORT: '+ systime() +' Sort ' + str,hnew + endif else begin + tab = tabnew + sxaddhist,'FTSORT: '+ systime() +' Sort ' + str,h + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/fxaddpar.pro b/modules/idl_downloads/astro/pro/fxaddpar.pro new file mode 100644 index 0000000..76338f1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxaddpar.pro @@ -0,0 +1,718 @@ +;+ +; NAME: +; FXADDPAR +; Purpose : +; Add or modify a parameter in a FITS header array. +; Explanation : +; This version of FXADDPAR will write string values longer than 68 +; characters using the FITS continuation convention described at +; http://fits.gsfc.nasa.gov/registry/continue_keyword.html +; Use : +; FXADDPAR, HEADER, NAME, VALUE, COMMENT +; Inputs : +; HEADER = String array containing FITS header. The maximum string +; length must be equal to 80. If not defined, then FXADDPAR +; will create an empty FITS header array. +; +; NAME = Name of parameter. If NAME is already in the header the +; value and possibly comment fields are modified. Otherwise a +; new record is added to the header. If NAME is equal to +; either "COMMENT" or "HISTORY" then the value will be added to +; the record without replacement. In this case the comment +; parameter is ignored. +; +; VALUE = Value for parameter. The value expression must be of the +; correct type, e.g. integer, floating or string. +; String values of 'T' or 'F' are considered logical +; values unless the /NOLOGICAL keyword is set. If the value is +; a string and is "long" (more than 69 characters), then it +; may be continued over more than one line using the OGIP +; CONTINUE standard. +; +; Opt. Inputs : +; COMMENT = String field. The '/' is added by this routine. Added +; starting in position 31. If not supplied, or set equal to '' +; (the null string), then any previous comment field in the +; header for that keyword is retained (when found). +; Outputs : +; HEADER = Updated header array. +; Opt. Outputs: +; None. +; Keywords : +; BEFORE = Keyword string name. The parameter will be placed before the +; location of this keyword. For example, if BEFORE='HISTORY' +; then the parameter will be placed before the first history +; location. This applies only when adding a new keyword; +; keywords already in the header are kept in the same position. +; +; AFTER = Same as BEFORE, but the parameter will be placed after the +; location of this keyword. This keyword takes precedence over +; BEFORE. +; +; FORMAT = Specifies FORTRAN-like format for parameter, e.g. "F7.3". A +; scalar string should be used. For complex numbers the format +; should be defined so that it can be applied separately to the +; real and imaginary parts. If not supplied, then the IDL +; default formatting is used, except that double precision is +; given a format of G19.12. +; +; /NOCONTINUE = By default, FXADDPAR will break strings longer than 68 +; characters into multiple lines using the continuation +; convention. If this keyword is set, then the line will +; instead be truncated to 68 characters. This was the default +; behaviour of FXADDPAR prior to December 1999. +; +; /NOLOGICAL = If set, then the values 'T' and 'F' are not interpreted as +; logical values, and are simply added without interpretation. +; +; /NULL = If set, then keywords with values which are undefined, or +; which have non-finite values (such as NaN, Not-a-Number) are +; stored in the header without a value, such as +; +; MYKEYWD = /My comment +; +; MISSING = A value which signals that data with this value should be +; considered missing. For example, the statement +; +; FXADDPAR, HEADER, 'MYKEYWD', -999, MISSING=-999 +; +; would result in the valueless line described above for the +; /NULL keyword. Setting MISSING to a value implies /NULL. +; Cannot be used with string or complex values. +; +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL, e.g. +; +; ERRMSG = '' +; FXADDPAR, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; DETABIFY(), FXPAR(), FXPARPOS() +; Common : +; None. +; Restrictions: +; Warning -- Parameters and names are not checked against valid FITS +; parameter names, values and types. +; +; The required FITS keywords SIMPLE (or XTENSION), BITPIX, NAXIS, NAXIS1, +; NAXIS2, etc., must be entered in order. The actual values of these +; keywords are not checked for legality and consistency, however. +; +; Side effects: +; All HISTORY records are inserted in order at the end of the header. +; +; All COMMENT records are also inserted in order at the end of the +; header, but before the HISTORY records. The BEFORE and AFTER keywords +; can override this. +; +; All records with no keyword (blank) are inserted in order at the end of +; the header, but before the COMMENT and HISTORY records. The BEFORE and +; AFTER keywords can override this. +; +; All other records are inserted before any of the HISTORY, COMMENT, or +; "blank" records. The BEFORE and AFTER keywords can override this. +; +; String values longer than 68 characters will be split into multiple +; lines using the OGIP CONTINUE convention, unless the /NOCONTINUE keyword +; is set. For a description of the CONTINUE convention see +; http://fits.gsfc.nasa.gov/registry/continue_keyword.html +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992, from SXADDPAR by D. Lindler and J. Isensee. +; Differences include: +; +; * LOCATION parameter replaced with keywords BEFORE and AFTER. +; * Support for COMMENT and "blank" FITS keywords. +; * Better support for standard FITS formatting of string and +; complex values. +; * Built-in knowledge of the proper position of required +; keywords in FITS (although not necessarily SDAS/Geis) primary +; headers, and in TABLE and BINTABLE extension headers. +; +; William Thompson, May 1992, fixed bug when extending length of header, +; and new record is COMMENT, HISTORY, or blank. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 5 September 1997 +; Fixed bug replacing strings that contain "/" character--it +; interpreted the following characters as a comment. +; Version 3, Craig Markwardt, GSFC, December 1997 +; Allow long values to extend over multiple lines +; Version 4, D. Lindler, March 2000, modified to use capital E instead +; of a lower case e for exponential format. +; Version 4.1 W. Landsman April 2000, make user-supplied format uppercase +; Version 4.2 W. Landsman July 2002, positioning of EXTEND keyword +; Version 5, 23-April-2007, William Thompson, GSFC +; Version 6, 02-Aug-2007, WTT, bug fix for OGIP long lines +; Version 6.1, 10-Feb-2009, W. Landsman, increase default format precision +; Version 6.2 30-Sep-2009, W. Landsman, added /NOLOGICAL keyword +; Version 7, 13-Aug-2015, William Thompson, allow null values +; Add keywords /NULL, MISSING. Catch non-finite values (e.g. NaN) +; Version 7.1, 22-Sep-2015, W. Thompson, No slash if null & no comment +; Version : +; Version 7.1, 22-Sep-2015 +;- +; + +; This is a utility routine, which splits a parameter into several +; continuation bits. +PRO FXADDPAR_CONTPAR, VALUE, CONTINUED + + APOST = "'" + BLANK = STRING(REPLICATE(32B,80)) ;BLANK line + + ;; The value may not need to be CONTINUEd. If it does, then split + ;; out the first value now. The first value does not have a + ;; CONTINUE keyword, because it will be grafted onto the proper + ;; keyword in the calling routine. + + IF (STRLEN(VALUE) GT 68) THEN BEGIN + CONTINUED = [ STRMID(VALUE, 0, 67)+'&' ] + VALUE = STRMID(VALUE, 67, STRLEN(VALUE)-67) + ENDIF ELSE BEGIN + CONTINUED = [ VALUE ] + RETURN + ENDELSE + + ;; Split out the remaining values. + WHILE( STRLEN(VALUE) GT 0 ) DO BEGIN + H = BLANK + + ;; Add CONTINUE keyword + STRPUT, H, 'CONTINUE '+APOST + ;; Add the next split + IF(STRLEN(VALUE) GT 68) THEN BEGIN + STRPUT, H, STRMID(VALUE, 0, 67)+'&'+APOST, 11 + VALUE = STRMID(VALUE, 67, STRLEN(VALUE)-67) + ENDIF ELSE BEGIN + STRPUT, H, VALUE+APOST, 11 + VALUE = '' + ENDELSE + + CONTINUED = [ CONTINUED, H ] + ENDWHILE + + RETURN +END + +; Utility routine to add a warning to the file. The calling routine +; must ensure that the header is in a consistent state before calling +; FXADDPAR_CONTWARN because the header will be subsequently modified +; by calls to FXADDPAR. +PRO FXADDPAR_CONTWARN, HEADER, NAME + +; By OGIP convention, the keyword LONGSTRN is added to the header as +; well. It should appear before the first occurrence of a long +; string encoded with the CONTINUE convention. + + CONTKEY = FXPAR(HEADER, 'LONGSTRN', COUNT = N_LONGSTRN) + +; Calling FXADDPAR here is okay since the state of the header is +; clean now. + IF N_LONGSTRN GT 0 THEN $ + RETURN + + FXADDPAR, HEADER, 'LONGSTRN', 'OGIP 1.0', $ + ' The OGIP long string convention may be used.', $ + BEFORE=NAME + + FXADDPAR, HEADER, 'COMMENT', $ + ' This FITS file may contain long string keyword values that are', $ + BEFORE=NAME + + FXADDPAR, HEADER, 'COMMENT', $ + " continued over multiple keywords. This convention uses the '&'", $ + BEFORE=NAME + + FXADDPAR, HEADER, 'COMMENT', $ + ' character at the end of a string which is then continued', $ + BEFORE=NAME + + FXADDPAR, HEADER, 'COMMENT', $ + " on subsequent keywords whose name = 'CONTINUE'.", $ + BEFORE=NAME + + RETURN +END + + +PRO FXADDPAR, HEADER, NAME, VALUE, COMMENT, BEFORE=BEFORE, $ + AFTER=AFTER, FORMAT=FORMAT, NOCONTINUE = NOCONTINUE, $ + ERRMSG=ERRMSG, NOLOGICAL=NOLOGICAL, MISSING=MISSING, NULL=NULL + + ON_ERROR,2 ;Return to caller +; +; Check the number of parameters. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = 'Syntax: FXADDPAR, HEADER, NAME, VALUE [, COMMENT ]' + GOTO, HANDLE_ERROR + ENDIF +; +; Define a blank line and the END line +; + ENDLINE = 'END' + STRING(REPLICATE(32B,77)) ;END line + BLANK = STRING(REPLICATE(32B,80)) ;BLANK line +; +; If no comment was passed, then use a null string. +; + IF N_PARAMS() LT 4 THEN COMMENT = '' +; +; Check the HEADER array. +; + N = N_ELEMENTS(HEADER) ;# of lines in FITS header + IF N EQ 0 THEN BEGIN ;header defined? + HEADER=STRARR(36) ;no, make it. + HEADER[0]=ENDLINE + N=36 + ENDIF ELSE BEGIN + S = SIZE(HEADER) ;check for string type + IF (S[0] NE 1) OR (S[2] NE 7) THEN BEGIN + MESSAGE = 'FITS Header (first parameter) must be a ' + $ + 'string array' + GOTO, HANDLE_ERROR + ENDIF + ENDELSE +; +; Make sure NAME is 8 characters long +; + NN = STRING(REPLICATE(32B,8)) ;8 char name + STRPUT,NN,STRUPCASE(NAME) ;Insert name +; +; Check VALUE. +; + S = SIZE(VALUE) ;get type of value parameter + STYPE = S[S[0]+1] + SAVE_AS_NULL = 0 + IF S[0] NE 0 THEN BEGIN + MESSAGE = 'Keyword Value (third parameter) must be scalar' + GOTO, HANDLE_ERROR + END ELSE IF STYPE EQ 0 THEN BEGIN + IF (N_ELEMENTS(MISSING) EQ 1) OR KEYWORD_SET(NULL) THEN $ + SAVE_AS_NULL = 1 ELSE BEGIN + MESSAGE = 'Keyword Value (third parameter) is not defined' + GOTO, HANDLE_ERROR + ENDELSE + END ELSE IF STYPE EQ 8 THEN BEGIN + MESSAGE = 'Keyword Value (third parameter) cannot be structure' + GOTO, HANDLE_ERROR + ENDIF +; +; Check to see if the parameter should be saved as a null value. +; + IF (STYPE NE 6) AND (STYPE NE 7) AND (STYPE NE 9) THEN BEGIN + IF N_ELEMENTS(MISSING) EQ 1 THEN $ + IF VALUE EQ MISSING THEN SAVE_AS_NULL = 1 + IF NOT SAVE_AS_NULL THEN IF NOT FINITE(VALUE) THEN BEGIN + IF ((N_ELEMENTS(MISSING) EQ 1) OR KEYWORD_SET(NULL)) THEN $ + SAVE_AS_NULL = 1 ELSE BEGIN + MESSAGE = 'Keyword Value (third parameter) is not finite' + GOTO, HANDLE_ERROR + ENDELSE + ENDIF + ENDIF +; +; Extract first 8 characters of each line of header, and locate END line +; + KEYWRD = STRMID(HEADER,0,8) ;Header keywords + IEND = WHERE(KEYWRD EQ 'END ',NFOUND) +; +; If no END, then add it. Either put it after the last non-null string, or +; append it to the end. +; + IF NFOUND EQ 0 THEN BEGIN + II = WHERE(STRTRIM(HEADER) NE '',NFOUND) + II = MAX(II) + 1 + IF (NFOUND EQ 0) OR (II EQ N_ELEMENTS(HEADER)) THEN $ + HEADER = [HEADER,ENDLINE] ELSE HEADER[II] = ENDLINE + KEYWRD = STRMID(HEADER,0,8) + IEND = WHERE(KEYWRD EQ 'END ',NFOUND) + ENDIF +; + IEND = IEND[0] > 0 ;Make scalar +; +; History, comment and "blank" records are treated differently from the +; others. They are simply added to the header array whether there are any +; already there or not. +; + IF (NN EQ 'COMMENT ') OR (NN EQ 'HISTORY ') OR $ + (NN EQ ' ') THEN BEGIN +; +; If the header array needs to grow, then expand it in increments of 36 lines. +; + IF IEND GE (N-1) THEN BEGIN + HEADER = [HEADER,REPLICATE(BLANK,36)] + N = N_ELEMENTS(HEADER) + ENDIF +; +; Format the record. +; + NEWLINE = BLANK + STRPUT,NEWLINE,NN+STRING(VALUE),0 +; +; If a history record, then append to the record just before the end. +; + IF NN EQ 'HISTORY ' THEN BEGIN + HEADER[IEND] = NEWLINE ;add history rec. + HEADER[IEND+1]=ENDLINE ;move end up +; +; The comment record is placed immediately after the last previous comment +; record, or immediately before the first history record, unless overridden by +; either the BEFORE or AFTER keywords. +; + END ELSE IF NN EQ 'COMMENT ' THEN BEGIN + I = FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE) + IF I EQ IEND THEN I = $ + FXPARPOS(KEYWRD,IEND,AFTER='COMMENT',$ + BEFORE='HISTORY') + HEADER[I+1] = HEADER[I:N-2] ;move rest up + HEADER[I] = NEWLINE ;insert comment +; +; The "blank" record is placed immediately after the last previous "blank" +; record, or immediately before the first comment or history record, unless +; overridden by either the BEFORE or AFTER keywords. +; + END ELSE BEGIN + I = FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE) + IF I EQ IEND THEN I = $ + FXPARPOS(KEYWRD,IEND,AFTER='',BEFORE='COMMENT')<$ + FXPARPOS(KEYWRD,IEND,AFTER='',BEFORE='HISTORY') + HEADER[I+1] = HEADER[I:N-2] ;move rest up + HEADER[I] = NEWLINE ;insert "blank" + ENDELSE + RETURN + ENDIF ;history/comment/blank +; +; Find location to insert keyword. If the keyword is already in the header, +; then simply replace it. If no new comment is passed, then retain the old +; one. +; + IPOS = WHERE(KEYWRD EQ NN,NFOUND) + IF NFOUND GT 0 THEN BEGIN + I = IPOS[0] + IF COMMENT EQ '' THEN BEGIN + SLASH = STRPOS(HEADER[I],'/') + QUOTE = STRPOS(HEADER[I],"'") + IF (QUOTE GT 0) AND (QUOTE LT SLASH) THEN BEGIN + QUOTE = STRPOS(HEADER[I],"'",QUOTE+1) + IF QUOTE LT 0 THEN SLASH = -1 ELSE $ + SLASH = STRPOS(HEADER[I],'/',QUOTE+1) + ENDIF + IF SLASH NE -1 THEN $ + COMMENT = STRMID(HEADER[I],SLASH+1,80) ELSE $ + COMMENT = STRING(REPLICATE(32B,80)) + ENDIF + GOTO, REPLACE + ENDIF +; +; Start of section dealing with the positioning of required FITS keywords. If +; the keyword is SIMPLE, then it must be at the beginning. +; + IF NN EQ 'SIMPLE ' THEN BEGIN + I = 0 + GOTO, INSERT + ENDIF +; +; In conforming extensions, if the keyword is XTENSION, then it must be at the +; beginning. +; + IF NN EQ 'XTENSION' THEN BEGIN + I = 0 + GOTO, INSERT + ENDIF +; +; If the keyword is BITPIX, then it must follow the either SIMPLE or XTENSION +; keyword. +; + IF NN EQ 'BITPIX ' THEN BEGIN + IF (KEYWRD[0] NE 'SIMPLE ') AND $ + (KEYWRD[0] NE 'XTENSION') THEN BEGIN + MESSAGE = 'Header must start with either SIMPLE or XTENSION' + GOTO, HANDLE_ERROR + ENDIF + I = 1 + GOTO, INSERT + ENDIF +; +; If the keyword is NAXIS, then it must follow the BITPIX keyword. +; + IF NN EQ 'NAXIS ' THEN BEGIN + IF KEYWRD[1] NE 'BITPIX ' THEN BEGIN + MESSAGE = 'Required BITPIX keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = 2 + GOTO, INSERT + ENDIF +; +; If the keyword is NAXIS1, then it must follow the NAXIS keyword. +; + IF NN EQ 'NAXIS1 ' THEN BEGIN + IF KEYWRD[2] NE 'NAXIS ' THEN BEGIN + MESSAGE = 'Required NAXIS keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = 3 + GOTO, INSERT + ENDIF +; +; If the keyword is NAXIS, then it must follow the NAXIS keyword. +; + IF STRMID(NN,0,5) EQ 'NAXIS' THEN BEGIN + NUM_AXIS = FIX(STRMID(NN,5,3)) + PREV = STRING(REPLICATE(32B,8)) ;Format NAXIS + STRPUT,PREV,'NAXIS',0 ;Insert NAXIS + STRPUT,PREV,STRTRIM(NUM_AXIS-1,2),5 ;Insert + IF KEYWRD[NUM_AXIS+1] NE PREV THEN BEGIN + MESSAGE = 'Required '+PREV+' keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = NUM_AXIS + 2 + GOTO, INSERT + ENDIF + +; +; If the keyword is EXTEND, then it must follow the last NAXIS* keyword. +; + + IF NN EQ 'EXTEND ' THEN BEGIN + IF KEYWRD[2] NE 'NAXIS ' THEN BEGIN + MESSAGE = 'Required NAXIS keyword not found' + GOTO, HANDLE_ERROR + ENDIF + FOR I = 3, N-2 DO $ + IF STRMID(KEYWRD[I],0,5) NE 'NAXIS' THEN GOTO, INSERT + + ENDIF + +; +; If the first keyword is XTENSION, and has the value of either 'TABLE' or +; 'BINTABLE', then there are some additional required keywords. +; + IF KEYWRD[0] EQ 'XTENSION' THEN BEGIN + XTEN = FXPAR(HEADER,'XTENSION') + IF (XTEN EQ 'TABLE ') OR (XTEN EQ 'BINTABLE') THEN BEGIN +; +; If the keyword is PCOUNT, then it must follow the NAXIS2 keyword. +; + IF NN EQ 'PCOUNT ' THEN BEGIN + IF KEYWRD[4] NE 'NAXIS2 ' THEN BEGIN + MESSAGE = 'Required NAXIS2 keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = 5 + GOTO, INSERT + ENDIF +; +; If the keyword is GCOUNT, then it must follow the PCOUNT keyword. +; + IF NN EQ 'GCOUNT ' THEN BEGIN + IF KEYWRD[5] NE 'PCOUNT ' THEN BEGIN + MESSAGE = 'Required PCOUNT keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = 6 + GOTO, INSERT + ENDIF +; +; If the keyword is TFIELDS, then it must follow the GCOUNT keyword. +; + IF NN EQ 'TFIELDS ' THEN BEGIN + IF KEYWRD[6] NE 'GCOUNT ' THEN BEGIN + MESSAGE = 'Required GCOUNT keyword not found' + GOTO, HANDLE_ERROR + ENDIF + I = 7 + GOTO, INSERT + ENDIF + ENDIF + ENDIF +; +; At this point the location has not been determined, so a new line is added +; at the end of the FITS header, but before any blank, COMMENT, or HISTORY +; keywords, unless overridden by the BEFORE or AFTER keywords. +; + I = FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE=BEFORE) + IF I EQ IEND THEN I = $ + FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='') < $ + FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='COMMENT') < $ + FXPARPOS(KEYWRD,IEND,AFTER=AFTER,BEFORE='HISTORY') +; +; A new line needs to be added. First check to see if the length of the +; header array needs to be extended. Then insert a blank record at the proper +; place. +; +INSERT: + IF IEND EQ (N-1) THEN BEGIN + HEADER = [HEADER,REPLICATE(BLANK,36)] + N = N_ELEMENTS(HEADER) + ENDIF + HEADER[I+1] = HEADER[I:N-2] + HEADER[I] = BLANK + IEND = IEND + 1 ; CM 24 Sep 1997 +; +; Now put value into keyword at line I. +; +REPLACE: + H=BLANK ;80 blanks + STRPUT,H,NN+'= ' ;insert name and =. + APOST = "'" ;quote (apostrophe) character + TYPE = SIZE(VALUE) ;get type of value parameter +; +; Store the value depending on the data type. If a character string, first +; check to see if it is one of the logical values "T" (true) or "F" (false). +; + + IF TYPE[1] EQ 7 THEN BEGIN ;which type? + UPVAL = STRUPCASE(VALUE) ;force upper case. + IF ~KEYWORD_SET(NOLOGICAL) $ + && ((UPVAL EQ 'T') OR (UPVAL EQ 'F')) THEN BEGIN + STRPUT,H,UPVAL,29 ;insert logical value. +; +; Otherwise, remove any tabs, and check for any apostrophes in the string. +; + END ELSE BEGIN + VAL = DETABIFY(VALUE) + NEXT_CHAR = 0 + REPEAT BEGIN + AP = STRPOS(VAL,"'",NEXT_CHAR) + IF AP GE 66 THEN BEGIN + VAL = STRMID(VAL,0,66) + END ELSE IF AP GE 0 THEN BEGIN + VAL = STRMID(VAL,0,AP+1) + APOST + $ + STRMID(VAL,AP+1,80) + NEXT_CHAR = AP + 2 + ENDIF + ENDREP UNTIL AP LT 0 + +; +; If a long string, then add the comment as soon as possible. +; +; CM 24 Sep 1997 +; Separate parameter if it needs to be CONTINUEd. +; + IF NOT KEYWORD_SET(NOCONTINUE) THEN $ + FXADDPAR_CONTPAR, VAL, CVAL ELSE $ + CVAL = STRMID(VAL,0,68) + K = I + 1 + ;; See how many CONTINUE lines there already are + WHILE K LT IEND DO BEGIN + IF STRMID(HEADER[K],0,8) NE 'CONTINUE' THEN $ + GOTO, DONE_CHECK_CONT + K = K + 1 + ENDWHILE + + DONE_CHECK_CONT: + NOLDCONT = K - I - 1 + NNEWCONT = N_ELEMENTS(CVAL) - 1 + + ;; Insert new lines if needed + IF NNEWCONT GT NOLDCONT THEN BEGIN + INS = NNEWCONT - NOLDCONT + WHILE IEND+INS GE N DO BEGIN + HEADER = [HEADER, REPLICATE(BLANK,36)] + N = N_ELEMENTS(HEADER) + ENDWHILE + ENDIF + + ;; Shift the old lines properly + IF NNEWCONT NE NOLDCONT THEN $ + HEADER[I+NNEWCONT+1] = HEADER[I+NOLDCONT+1:IEND] + IEND = IEND + NNEWCONT - NOLDCONT + + ;; Blank out any lines at the end if needed + IF NNEWCONT LT NOLDCONT THEN BEGIN + DEL = NOLDCONT - NNEWCONT + HEADER[IEND+1:IEND+DEL] = REPLICATE('', DEL) + ENDIF + + IF STRLEN(CVAL[0]) GT 18 THEN BEGIN + STRPUT,H,APOST+STRMID(CVAL[0],0,68)+APOST+ $ + ' /'+COMMENT,10 + HEADER[I]=H + +; There might be a continuation of this string. CVAL would contain +; more than one element if that is so. + + ;; Add new continuation lines + IF N_ELEMENTS(CVAL) GT 1 THEN BEGIN + HEADER[I+1] = CVAL[1:*] + + ;; Header state is now clean, so add + ;; warning to header + + FXADDPAR_CONTWARN, HEADER, NAME + ENDIF + DONE_CONT: + RETURN +; +; If a short string, then pad out to at least eight characters. +; + END ELSE BEGIN + STRPUT,H,APOST+CVAL[0],10 + STRPUT,H,APOST,11+(STRLEN(CVAL[0])>8) + ENDELSE + + ENDELSE +; +; If complex, then format the real and imaginary parts, and add the comment +; beginning in column 51. +; + END ELSE IF (TYPE[1] EQ 6) OR (TYPE[1] EQ 9) THEN BEGIN + IF TYPE[1] EQ 6 THEN VR = FLOAT(VALUE) ELSE VR = DOUBLE(VALUE) + VI = IMAGINARY(VALUE) + IF N_ELEMENTS(FORMAT) EQ 1 THEN BEGIN ;use format keyword + VR = STRING(VR, '('+STRUPCASE(FORMAT)+')') + VI = STRING(VI, '('+STRUPCASE(FORMAT)+')') + END ELSE BEGIN + VR = STRTRIM(VR, 2) + VI = STRTRIM(VI, 2) + ENDELSE + SR = STRLEN(VR) & STRPUT,H,VR,(30-SR)>10 + SI = STRLEN(VI) & STRPUT,H,VI,(50-SI)>30 + STRPUT,H,' /'+COMMENT,50 + HEADER[I] = H + RETURN +; +; If not complex or a string, then format according to either the FORMAT +; keyword, or the default for that datatype. +; + END ELSE BEGIN + IF NOT SAVE_AS_NULL THEN BEGIN + IF (N_ELEMENTS(FORMAT) EQ 1) THEN $ ;use format keyword + V = STRING(VALUE,'('+STRUPCASE(FORMAT)+')' ) ELSE BEGIN + IF TYPE[1] EQ 5 THEN $ + V = STRING(VALUE,FORMAT='(G19.12)') ELSE $ + V = STRTRIM(strupcase(VALUE),2) ;default format + ENDELSE + S = STRLEN(V) ;right justify + STRPUT,H,V,(30-S)>10 ;insert + ENDIF + ENDELSE +; +; Add the comment, and store the completed line in the header. Don't +; add the slash if the value is null and there is no comment. +; + IF (NOT SAVE_AS_NULL) OR (STRLEN(STRTRIM(COMMENT)) GT 0) THEN BEGIN + STRPUT,H,' /',30 ;add ' /' + STRPUT,H,COMMENT,32 ;add comment + ENDIF + HEADER[I]=H ;save line +; + ERRMSG = '' + RETURN +; +; Error handling point. +; +HANDLE_ERROR: + IF ARG_PRESENT(ERRMSG) THEN ERRMSG = 'FXADDPAR: ' + MESSAGE $ + ELSE MESSAGE, MESSAGE + RETURN + END + diff --git a/modules/idl_downloads/astro/pro/fxbaddcol.pro b/modules/idl_downloads/astro/pro/fxbaddcol.pro new file mode 100644 index 0000000..fc09694 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbaddcol.pro @@ -0,0 +1,382 @@ + PRO FXBADDCOL,INDEX,HEADER,ARRAY,TTYPE,COMMENT,TUNIT=TUNIT, $ + TSCAL=TSCAL,TZERO=TZERO,TNULL=TNULL,TDISP=TDISP, $ + TDMIN=TDMIN,TDMAX=TDMAX,TDESC=TDESC,TROTA=TROTA, $ + TRPIX=TRPIX,TRVAL=TRVAL,TDELT=TDELT,TCUNI=TCUNI, $ + NO_TDIM=NO_TDIM,VARIABLE=VARIABLE,DCOMPLEX=DCOMPLEX, $ + BIT=BIT,LOGICAL=LOGICAL,ERRMSG=ERRMSG +;+ +; NAME: +; FXBADDCOL +; PURPOSE : +; Adds a column to a binary table extension. +; EXPLANATION : +; Modify a basic FITS binary table extension (BINTABLE) header array to +; define a column. +; USE : +; FXBADDCOL, INDEX, HEADER, ARRAY [, TTYPE [, COMMENT ]] +; INPUTS : +; HEADER = String array containing FITS extension header. +; ARRAY = IDL variable used to determine the data size and type +; associated with the column. If the column is defined as +; containing variable length arrays, then ARRAY must be of the +; maximum size to be stored in the column. +; Opt. Inputs : +; TTYPE = Column label. +; COMMENT = Comment for TTYPE +; Outputs : +; INDEX = Index (1-999) of the created column. +; HEADER = The header is modified to reflect the added column. +; Opt. Outputs: +; None. +; Keywords : +; VARIABLE= If set, then the column is defined to contain pointers to +; variable length arrays in the heap area. +; DCOMPLEX= If set, and ARRAY is complex, with the first dimension being +; two (real and imaginary parts), then the column is defined as +; double-precision complex (type "M"). This keyword is +; only needed prior to IDL Version 4.0, when the double +; double complex datatype was unavailable in IDL +; BIT = If passed, and ARRAY is of type byte, then the column is +; defined as containing bit mask arrays (type "X"), with the +; value of BIT being equal to the number of mask bits. +; LOGICAL = If set, and array is of type byte, then the column is defined +; as containing logical arrays (type "L"). +; NO_TDIM = If set, then the TDIMn keyword is not written out to the +; header. No TDIMn keywords are written for columns containing +; variable length arrays. +; TUNIT = If passed, then corresponding keyword is added to header. +; TSCAL = Same. +; TZERO = Same. +; TNULL = Same. +; TDISP = Same. +; TDMIN = Same. +; TDMAX = Same. +; TDESC = Same. +; TCUNI = Same. +; TROTA = Same. +; TRPIX = Same. +; TRVAL = Same. +; TDELT = Same. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBADDCOL, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXADDPAR, FXPAR +; Common : +; None. +; Restrictions: +; Warning: No checking is done of any of the parameters defining the +; values of optional FITS keywords. +; +; FXBHMAKE must first be called to initialize the header. +; +; If ARRAY is of type character, then it must be of the maximum length +; expected for this column. If a character string array, then the +; largest string in the array is used to determine the maximum length. +; +; The DCOMPLEX keyword is ignored if ARRAY is not double-precision. +; ARRAY must also have a first dimension of two representing the real and +; imaginary parts. +; +; The BIT and LOGICAL keywords are ignored if ARRAY is not of type byte. +; BIT takes precedence over LOGICAL. +; +; Side effects: +; If the data array is multidimensional, then a TDIM keyword is added to +; the header, unless either NO_TDIM or VARIABLE is set. +; +; No TDIMn keywords are written out for bit arrays (format 'X'), since +; the dimensions would refer to bits, not bytes. +; +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992. +; W. Thompson, Feb 1992, changed from function to procedure. +; W. Thompson, Feb 1992, modified to support variable length arrays. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, William Thompson, GSFC, 30 December 1994 +; Added keyword TCUNI. +; Version 5, Wayne Landsman, GSFC, 12 Aug 1997 +; Recognize double complex IDL datatype +; Version 6, Wayne Landsman, GSFC. C. Yamauchi (ISAS) 23 Feb 2006 +; Support 64bit integers +; Version 7, C. Markwardt, GSFC, Allow unsigned integers, which +; have special TSCAL/TZERO values. Feb 2009 +; Version 8, P.Broos (PSU), Wayne Landsman (GSFC) Mar 2010 +; Do *not* force TTYPE* keyword to uppercase +; Version : +; Version 8, Mar 2010 +;- +; + ON_ERROR,2 +; +; Check the number of parameters first. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = 'Syntax: FXBADDCOL, INDEX, HEADER, ARRAY ' + $ + '[, TTYPE [, COMMENT]]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get the next column number. +; + INDEX = FXPAR(HEADER,'TFIELDS') + 1 +; +; Determine the data type and size of the data array. Use this to +; calculate the parameters needed for the binary table. +; + S = SIZE(ARRAY) ;obtain size of array. + TYPE = S[S[0]+1] ;type of data. + N_ELEM = N_ELEMENTS(ARRAY) ;Number of elements +; + CASE TYPE OF + 0: BEGIN + MESSAGE = 'Data parameter is not defined' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END +; +; If the array is of type byte, then check to see if either the BIT or LOGICAL +; keywords were passed. +; + 1: BEGIN + IF N_ELEMENTS(BIT) EQ 1 THEN BEGIN + N_BYTES = LONG((BIT+7)/8) + IF N_BYTES NE N_ELEM THEN BEGIN + MESSAGE = 'Number of bits does ' + $ + 'not match array size.' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + N_ELEM = BIT + TFORM = "X" + TF_COMMENT = 'Bit array' + END ELSE IF KEYWORD_SET(LOGICAL) THEN BEGIN + N_BYTES = N_ELEM + TFORM = "L" + TF_COMMENT = 'Logical array' + END ELSE BEGIN + N_BYTES = N_ELEM + TFORM = "B" + TF_COMMENT = 'Integer*1 (byte)' + ENDELSE + END +; +; If complex, then check to see if the DCOMPLEX keyword was set, and if the +; first dimension is two. +; + 5: BEGIN + IF KEYWORD_SET(DCOMPLEX) THEN BEGIN + IF S[1] NE 2 THEN BEGIN + MESSAGE = 'The first dimension ' + $ + 'of ARRAY must be two' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + N_BYTES = 8*N_ELEM + N_ELEM = N_ELEM / 2 + TFORM = "M" + TF_COMMENT = 'Complex*16 (double-' + $ + 'precision complex)' + S = [S[0]-1,S[2:*]] + END ELSE BEGIN + N_BYTES = 8*N_ELEM + TFORM = "D" + TF_COMMENT = 'Real*8 (double precision)' + ENDELSE + END +; +; Note that character string arrays are considered to have an extra first +; dimension, namely the (maximum) number of characters. +; + 7: BEGIN + STR_LEN = MAX(STRLEN(ARRAY)) + N_BYTES = STR_LEN*N_ELEM + N_ELEM = N_BYTES + TFORM = "A" + TF_COMMENT = 'Character string' + S = [S[0]+1, STR_LEN, S[1:*]] ;Add extra dimension + END +; +; All other types are straightforward. +; + 2: BEGIN + N_BYTES = 2*N_ELEM + TFORM = "I" + TF_COMMENT = 'Integer*2 (short integer)' + END + 3: BEGIN + N_BYTES = 4*N_ELEM + TFORM = "J" + TF_COMMENT = 'Integer*4 (long integer)' + END + 4: BEGIN + N_BYTES = 4*N_ELEM + TFORM = "E" + TF_COMMENT = 'Real*4 (floating point)' + END + 6: BEGIN + N_BYTES = 8*N_ELEM + TFORM = "C" + TF_COMMENT = 'Complex*8 (complex)' + END + 8: BEGIN + MESSAGE = "Can't write structures to FITS files" + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + 9: BEGIN + N_BYTES = 16*N_ELEM + TFORM = "M" + TF_COMMENT = 'Complex*16 (double-' + $ + 'precision complex)' + END + + 12: BEGIN + ;; Unsigned 16-bit integers are stored as signed + ;; integers with a TZERO offset. + N_BYTES = 2*N_ELEM + TFORM = "I" + TF_COMMENT = 'Unsigned Integer*2 (short integer)' + IF N_ELEMENTS(TSCAL) EQ 0 THEN TSCAL = 1 + IF N_ELEMENTS(TZERO) EQ 0 THEN TZERO = 32768 + IF TSCAL[0] NE 1 OR TZERO[0] NE 32768 THEN BEGIN + MESSAGE = 'For 2-byte unsigned type, TSCAL/TZERO must be 1/32768' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + END + + 13: BEGIN + ;; Unsigned 32-bit integers are stored as signed + ;; integers with a TZERO offset. + N_BYTES = 4*N_ELEM + TFORM = "J" + TF_COMMENT = 'Unsigned Integer*4 (long integer)' + IF N_ELEMENTS(TSCAL) EQ 0 THEN TSCAL = 1 + IF N_ELEMENTS(TZERO) EQ 0 THEN TZERO = 2147483648D + IF TSCAL[0] NE 1 OR TZERO[0] NE 2147483648D THEN BEGIN + MESSAGE = 'For 4-byte unsigned type, TSCAL/TZERO must be 1/2147483648' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + END + + 14: BEGIN + N_BYTES = 8*N_ELEM + TFORM = "K" + TF_COMMENT = 'Integer*8 (long long ' + $ + 'integer)' + END + + + + ENDCASE +; +; If the column is to contain variable length data, then the number of bytes +; is 8, and TFORM has "1P" in the front, and "()" in the back. +; + IF KEYWORD_SET(VARIABLE) THEN BEGIN + N_BYTES = 8 + TFORM = '1P' + TFORM + '(' + STRTRIM(N_ELEM,2) + ')' + TF_COMMENT = TF_COMMENT + ', variable length' +; +; Otherwise, TFORM has "" in the front. +; + END ELSE TFORM = STRTRIM(N_ELEM,2) + TFORM +; +; Update the mandatory keywords in the header. +; + NAXIS1 = FXPAR(HEADER,'NAXIS1') + FXADDPAR,HEADER,'NAXIS1',NAXIS1+N_BYTES + FXADDPAR,HEADER,'TFIELDS',INDEX +; +; Add the keyword defining this column. +; + COL = STRTRIM(INDEX,2) ;ASCII form of column index + FXADDPAR, HEADER, 'TFORM'+COL, TFORM, TF_COMMENT +; +; If the TTYPE parameter has been passed, then add this keyword to the header. +; + IF N_PARAMS() GE 4 THEN BEGIN + If N_PARAMS() EQ 4 THEN COMMENT="Label for column "+COL + FXADDPAR,HEADER,'TTYPE'+COL,TTYPE,COMMENT + ENDIF +; +; If the number of dimensions of the data array are greater than one, then add +; the TDIM keyword. Don't add this keyword if either the NO_TDIM, VARIABLE or +; BIT keyword is set. +; + IF (S[0] GT 1) AND NOT (KEYWORD_SET(NO_TDIM) OR KEYWORD_SET(BIT) OR $ + KEYWORD_SET(VARIABLE)) THEN BEGIN + TDIM = "(" + STRTRIM(S[1],2) + FOR I = 2,S[0] DO TDIM = TDIM + "," + STRTRIM(S[I],2) + TDIM = TDIM + ')' + FXADDPAR,HEADER,'TDIM'+COL,TDIM, $ + 'Array dimensions for column '+COL + ENDIF +; +; If the various keywords were passed, then add them to the header. +; + IF N_ELEMENTS(TUNIT) EQ 1 THEN FXADDPAR,HEADER,'TUNIT'+COL,TUNIT, $ + 'Units of column '+COL + IF N_ELEMENTS(TSCAL) EQ 1 THEN FXADDPAR,HEADER,'TSCAL'+COL,TSCAL, $ + 'Scale parameter for column '+COL + IF N_ELEMENTS(TZERO) EQ 1 THEN FXADDPAR,HEADER,'TZERO'+COL,TZERO, $ + 'Zero offset for column '+COL + IF N_ELEMENTS(TNULL) EQ 1 THEN FXADDPAR,HEADER,'TNULL'+COL,TNULL, $ + 'Null value for column '+COL + IF N_ELEMENTS(TDISP) EQ 1 THEN FXADDPAR,HEADER,'TDISP'+COL,TDISP, $ + 'Display format for column '+COL +; + IF N_ELEMENTS(TDMIN) EQ 1 THEN FXADDPAR,HEADER,'TDMIN'+COL,TDMIN, $ + 'Minimum value in column '+COL + IF N_ELEMENTS(TDMAX) EQ 1 THEN FXADDPAR,HEADER,'TDMAX'+COL,TDMAX, $ + 'Maximum value in column '+COL + IF N_ELEMENTS(TDESC) EQ 1 THEN FXADDPAR,HEADER,'TDESC'+COL,TDESC, $ + 'Axis labels for column '+COL + IF N_ELEMENTS(TCUNI) EQ 1 THEN FXADDPAR,HEADER,'TCUNI'+COL,TCUNI, $ + 'Axis units for column '+COL + IF N_ELEMENTS(TROTA) EQ 1 THEN FXADDPAR,HEADER,'TROTA'+COL,TROTA, $ + 'Rotation angles for column '+COL + IF N_ELEMENTS(TRPIX) EQ 1 THEN FXADDPAR,HEADER,'TRPIX'+COL,TRPIX, $ + 'Reference pixel for column '+COL + IF N_ELEMENTS(TRVAL) EQ 1 THEN FXADDPAR,HEADER,'TRVAL'+COL,TRVAL, $ + 'Reference position for column '+COL + IF N_ELEMENTS(TDELT) EQ 1 THEN FXADDPAR,HEADER,'TDELT'+COL,TDELT, $ + 'Axis increments for column '+COL +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbclose.pro b/modules/idl_downloads/astro/pro/fxbclose.pro new file mode 100644 index 0000000..2c6987c --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbclose.pro @@ -0,0 +1,101 @@ + PRO FXBCLOSE, UNIT, ERRMSG=ERRMSG +;+ +; NAME: +; FXBCLOSE +; Purpose : +; Close a FITS binary table extension opened for read. +; Explanation : +; Closes a FITS binary table extension that had been opened for read by +; FXBOPEN. +; Use : +; FXBCLOSE, UNIT +; Inputs : +; UNIT = Logical unit number of the file. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBCLOSE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; None. +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The file must have been opened with FXBOPEN. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Feb. 1992. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version : +; Version 3, 23 June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN BEGIN + MESSAGE = 'Syntax: FXBCLOSE, UNIT' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Find the index of the file. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Make sure the file was opened for read access. +; + IF STATE[ILUN] NE 1 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened for read access' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Close the file, and mark it as closed. +; + FREE_LUN,UNIT + STATE[ILUN] = 0 +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbcolnum.pro b/modules/idl_downloads/astro/pro/fxbcolnum.pro new file mode 100644 index 0000000..c456cb5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbcolnum.pro @@ -0,0 +1,124 @@ + FUNCTION FXBCOLNUM, UNIT, COL, ERRMSG=ERRMSG +;+ +; NAME: +; FXBCOLNUM() +; Purpose : +; Returns a binary table column number. +; Explanation : +; Given a column specified either by number or name, this routine will +; return the appropriate column number. +; Use : +; Result = FXBCOLNUM( UNIT, COL ) +; Inputs : +; UNIT = Logical unit number corresponding to the file containing the +; binary table. +; COL = Column in the binary table, given either as a character +; string containing a column label (TTYPE), or as a numerical +; column index starting from column one. +; Opt. Inputs : +; None. +; Outputs : +; The result of the function is the number of the column specified, or +; zero if no column is found (when passed by name). +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; Result = FXBCOLNUM( ERRMSG=ERRMSG, ... ) +; IF ERRMSG NE '' THEN ... +; +; Calls : +; None. +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The binary table file must have been opened with FXBOPEN. +; +; If COL is passed as a number, rather than as a name, then it must be +; consistent with the number of columns in the table. +; +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; None. +; Written : +; William Thompson, GSFC, 2 July 1993. +; Modified : +; Version 1, William Thompson, GSFC, 2 July 1993. +; Version 2, William Thompson, GSFC, 29 October 1993. +; Added error message for not finding column by name. +; Version 3, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version : +; Version 4, 23 June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN BEGIN + MESSAGE = 'Syntax: Result = FXBCOLNUM( UNIT, COL )' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Find the logical unit number in the FXBINTABLE common block. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If COL is of type string, then search for a column with that label. +; + SC = SIZE(COL) + IF SC[SC[0]+1] EQ 7 THEN BEGIN + SCOL = STRUPCASE(STRTRIM(COL,2)) + ICOL = WHERE(TTYPE[*,ILUN] EQ SCOL, NCOL) + ICOL = ICOL[0] + IF ICOL LT 0 THEN BEGIN + MESSAGE = 'Column "' + SCOL + '" not found' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Otherwise, a numerical column was passed. Check its value. +; + END ELSE ICOL = LONG(COL) - 1 + IF (ICOL LT 0) OR (ICOL GE TFIELDS[ILUN]) THEN BEGIN + MESSAGE= 'COL must be between 1 and ' + $ + STRTRIM(TFIELDS[ILUN],2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Return ICOL as a number between 1 and N. +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN, ICOL + 1 + END diff --git a/modules/idl_downloads/astro/pro/fxbcreate.pro b/modules/idl_downloads/astro/pro/fxbcreate.pro new file mode 100644 index 0000000..45a2fa9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbcreate.pro @@ -0,0 +1,190 @@ + PRO FXBCREATE, UNIT, FILENAME, HEADER, EXTENSION, ERRMSG=ERRMSG +;+ +; NAME: +; FXBCREATE +; Purpose : +; Open a new binary table at the end of a FITS file. +; Explanation : +; Write a binary table extension header to the end of a disk FITS file, +; and leave it open to receive the data. +; +; The FITS file is opened, and the pointer is positioned just after the +; last 2880 byte record. Then the binary header is appended. Calls to +; FXBWRITE will append the binary data to this file, and then FXBFINISH +; will close the file. +; +; Use : +; FXBCREATE, UNIT, FILENAME, HEADER +; Inputs : +; FILENAME = Name of FITS file to be opened. +; HEADER = String array containing the FITS binary table extension +; header. +; Opt. Inputs : +; None. +; Outputs : +; UNIT = Logical unit number of the opened file. +; EXTENSION= Extension number of newly created extension. +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBCREATE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXADDPAR, FXBFINDLUN, FXBPARSE, FXFINDEND +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The primary FITS data unit must already be written to a file. The +; binary table extension header must already be defined (FXBHMAKE), and +; must match the data that will be written to the file. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Jan 1992, based on WRITEFITS by J. Woffard and W. Landsman. +; W. Thompson, Feb 1992, changed from function to procedure. +; W. Thompson, Feb 1992, removed all references to temporary files. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 July 1993. +; Fixed bug with variable length arrays. +; Version 3, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 5, Antony Bird, Southampton, 25 June 1997 +; Modified to allow very long tables +; Version : +; Version 5, 25 June 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added EXTENSION parameter, C. Markwardt 1999 Jul 15 +; More efficient zeroing of file, C. Markwardt, 26 Feb 2001 +; Recompute header size if updating THEAP keyword B. Roukema April 2010 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = 'Syntax: FXBCREATE, UNIT, FILENAME, HEADER' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get a logical unit number, open the file, and find the end. +; + GET_LUN,UNIT + OPENU, UNIT, FILENAME, /BLOCK + FXFINDEND, UNIT, EXTENSION +; +; Store the UNIT number in the common block, and leave space for the other +; parameters. Initialize the common block if need be. ILUN is an index into +; the arrays. +; + ILUN = FXBFINDLUN(UNIT) +; +; Store the current position as the start of the header. Mark the file as +; open for write. +; + POINT_LUN,-UNIT,POINTER + MHEADER[ILUN] = POINTER + STATE[ILUN] = 2 +; +; Determine if an END line occurs, and add one if necessary +; +CHECK_END: + ENDLINE = WHERE(STRMID(HEADER,0,8) EQ 'END ', NEND) + ENDLINE = ENDLINE[0] + IF NEND EQ 0 THEN BEGIN + MESSAGE,/INF,'WARNING - An END statement has been appended ' +$ + 'to the FITS header' + HEADER = [HEADER, 'END' + STRING(REPLICATE(32B,77))] + ENDLINE = N_ELEMENTS(HEADER) - 1 + ENDIF + NMAX = ENDLINE + 1 ;Number of 80 byte records + NHEAD = FIX((NMAX+35)/36) ;Number of 2880 byte records +; +; Convert the header to byte and force into 80 character lines. +; +WRITE_HEADER: + BHDR = REPLICATE(32B, 80, 36*NHEAD) + FOR N = 0,ENDLINE DO BHDR[0,N] = BYTE( STRMID(HEADER[N],0,80) ) + WRITEU, UNIT, BHDR +; +; Get the rest of the information, and store it in the common block. +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + FXBPARSE,ILUN,HEADER,ERRMSG=ERRMSG + IF ERRMSG NE '' THEN RETURN + END ELSE FXBPARSE,ILUN,HEADER +; +; Check the size of the heap offset. If the heap offset is smaller than the +; table, then reset it to the size of the table. +; + DDHEAP = HEAP[ILUN] - NAXIS1[ILUN]*NAXIS2[ILUN] + IF DDHEAP LT 0 THEN BEGIN + MESSAGE,'Heap offset smaller than table size--resetting', $ + /CONTINUE + HEAP[ILUN] = NAXIS1[ILUN]*NAXIS2[ILUN] + FXADDPAR,HEADER,'THEAP',HEAP[ILUN] + POINT_LUN, UNIT, MHEADER[ILUN] + +; Have we changed position of the END keyword? + GOTO, CHECK_END + ENDIF +; +; Fill out the file to size it properly. +; + ;; This segment is now optimized to write out more than one + ;; row at a time, which is crucial for tables with many small + ;; rows. The code heuristically chooses a buffer size which + ;; is 1% of the file, but no bigger than 512k, and always a + ;; multiple of the row size. + + + BUFSIZE = LONG(NAXIS1[ILUN]*NAXIS2[ILUN]/100) > NAXIS1[ILUN] < 524288L + BUFSIZE = (FLOOR(BUFSIZE/NAXIS1[ILUN])>1) * NAXIS1[ILUN] + BUFFER = BYTARR(BUFSIZE) + TOTBYTES = NAXIS1[ILUN]*NAXIS2[ILUN] + + ;; TOTBYTES keeps count of bytes left to write + WHILE TOTBYTES GT 0 DO BEGIN + ;; Case of final rows which might not be EQ BUFSIZE + IF TOTBYTES LT BUFSIZE THEN BUFFER = BYTARR(TOTBYTES) + WRITEU,UNIT,BUFFER + TOTBYTES = TOTBYTES - BUFSIZE + ENDWHILE +; +; If there's any extra space before the start of the heap, then write that out +; as well. +; + IF DDHEAP GT 0 THEN BEGIN + BUFFER = BYTARR(DDHEAP) + WRITEU,UNIT,BUFFER + ENDIF +; +; Initialize DHEAP, and return. +; + DHEAP[ILUN] = 0 +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END + diff --git a/modules/idl_downloads/astro/pro/fxbdimen.pro b/modules/idl_downloads/astro/pro/fxbdimen.pro new file mode 100644 index 0000000..16bc619 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbdimen.pro @@ -0,0 +1,127 @@ + FUNCTION FXBDIMEN, UNIT, COL, ERRMSG=ERRMSG +;+ +; NAME: +; FXBDIMEN() +; +; PURPOSE: +; Returns the dimensions for a column in a FITS binary table. +; +; Explanation : This procedure returns the dimensions associated with a column +; in a binary table opened for read with the command FXBOPEN. +; +; Use : Result = FXBDIMEN(UNIT,COL) +; +; Inputs : UNIT = Logical unit number returned by FXBOPEN routine. +; Must be a scalar integer. +; +; COL = Column in the binary table to read data from, either +; as a character string containing a column label +; (TTYPE), or as a numerical column index starting from +; column one. +; +; Opt. Inputs : None. +; +; Outputs : The result of the function is an array containing the +; dimensions for the specified column in the FITS binary table +; that UNIT points to. +; +; Opt. Outputs: None. +; +; Keywords : ERRMSG = If defined and passed, then any error messages will +; be returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no +; errors are encountered, then a null string is +; returned. In order to use this feature, ERRMSG must +; be defined first, e.g. +; +; ERRMSG = '' +; Result = FXBDIMEN( ERRMSG=ERRMSG, ... ) +; IF ERRMSG NE '' THEN ... +; +; Calls : FXBCOLNUM, FXBFINDLUN +; +; Common : Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; +; Restrictions: None. +; +; Side effects: The dimensions will be returned whether or not the table is +; still open or not. +; +; If UNIT does not point to a binary table, then 0 is returned. +; +; If UNIT is an undefined variable, then 0 is returned. +; +; Category : Data Handling, I/O, FITS, Generic. +; +; Prev. Hist. : None. +; +; Written : William Thompson, GSFC, 4 March 1994. +; +; Modified : Version 1, William Thompson, GSFC, 4 March 1994. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; +; Version : Version 3, 23 June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN BEGIN + MESSAGE = 'Syntax: Result = FXBDIMEN(UNIT,COL)' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If UNIT is undefined, then return zero. +; + IF N_ELEMENTS(UNIT) EQ 0 THEN RETURN, 0 +; +; Check the validity of UNIT. +; + IF N_ELEMENTS(UNIT) GT 1 THEN BEGIN + MESSAGE = 'UNIT must be a scalar' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF + SZ = SIZE(UNIT) + IF SZ[SZ[0]+1] GT 3 THEN BEGIN + MESSAGE = 'UNIT must be an integer' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Find the column number for the requested column. +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ICOL = FXBCOLNUM(UNIT,COL,ERRMSG=ERRMSG) + IF MESSAGE NE '' THEN RETURN, 0 + END ELSE ICOL = FXBCOLNUM(UNIT,COL) + IF ICOL EQ 0 THEN BEGIN + MESSAGE = 'No such column' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN, 0 + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get the dimensions associated with UNIT and COL. +; + ILUN = FXBFINDLUN(UNIT) + DIMS = N_DIMS[*,ICOL-1,ILUN] + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN, DIMS[1:DIMS[0]] +; + END diff --git a/modules/idl_downloads/astro/pro/fxbfind.pro b/modules/idl_downloads/astro/pro/fxbfind.pro new file mode 100644 index 0000000..530835d --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbfind.pro @@ -0,0 +1,158 @@ + PRO FXBFIND,P1,KEYWORD,COLUMNS,VALUES,N_FOUND,DEFAULT, $ + COMMENTS=COMMENTS +;+ +; NAME: +; FXBFIND +; Purpose : +; Find column keywords in a FITS binary table header. +; Explanation : +; Finds the value of a column keyword for all the columns in the binary +; table for which it is set. For example, +; +; FXBFIND, UNIT, 'TTYPE', COLUMNS, VALUES, N_FOUND +; +; Would find all instances of the keywords TTYPE1, TTYPE2, etc. The +; array COLUMNS would contain the column numbers for which a TTYPEn +; keyword was found, and VALUES would contain the values. N_FOUND would +; contain the total number of instances found. +; +; Use : +; FXBFIND, [UNIT or HEADER], KEYWORD, COLUMNS, VALUES, N_FOUND +; [, DEFAULT ] +; Inputs : +; Either UNIT or HEADER must be passed. +; +; UNIT = Logical unit number of file opened by FXBOPEN. +; HEADER = FITS binary table header. +; KEYWORD = Prefix to a series of FITS binary table column keywords. The +; keywords to be searched for are formed by combining this +; prefix with the numbers 1 through the value of TFIELDS in the +; header. +; Opt. Inputs : +; DEFAULT = Default value to use for any column keywords that aren't +; found. If passed, then COLUMNS and VALUES will contain +; entries for every column. Otherwise, COLUMNS and VALUES only +; contain entries for columns where values were found. +; Outputs : +; COLUMNS = Array containing the column numbers for which values of the +; requested keyword series were found. +; VALUES = Array containing the found values. +; N_FOUND = Number of values found. The value of this parameter is +; unaffected by whether or not DEFAULT is passed. +; Opt. Outputs: +; None. +; Output Keywords : +; COMMENTS = Comments associated with each keyword, if any +; Calls : +; FXBFINDLUN, FXPAR +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; If UNIT is passed, then the file must have been opened with FXBOPEN. +; If HEADER is passed, then it must be a legal FITS binary table header. +; +; The type of DEFAULT must be consistent with the values of the requested +; keywords, i.e. both most be either of string or numerical type. +; +; The KEYWORD prefix must not have more than five characters to leave +; room for the three digits allowed for the column numbers. +; +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb. 1992. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Vectorized implementation improves performance, CM 18 Nov 1999 +; Added COMMENTS keyword CM Nov 2003 +; Remove use of obsolete !ERR system variable W. Landsman April 2010 +; Fix error introduced April 2010 W. Landsman +; Version : +; Version 3, April 2010. +;- +; +@fxbintable + ON_ERROR,2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 5 THEN MESSAGE, $ + 'Syntax: FXBFIND,[UNIT/HEADER],KEYWORD,COLUMNS,VALUES,' + $ + 'N_FOUND [,DEFAULT]' +; +; Get the header. +; + IF N_ELEMENTS(P1) EQ 1 THEN BEGIN + ILUN = FXBFINDLUN(P1) + HEADER = HEAD[*,ILUN] + END ELSE HEADER = P1 +; +; Get the value of TFIELDS from HEADER. +; + TFIELDS0 = FXPAR(HEADER,'TFIELDS') + IF TFIELDS0 EQ 0 THEN MESSAGE,'No columns found in HEADER' + +; +; Extract the keyword values all in one pass +; + KEYVALUES = FXPAR(HEADER, STRTRIM(KEYWORD,2)+'*', $ + COMMENT=COMMENT_STRS, DATATYPE=DEFAULT, COUNT=NKEY) + N_FOUND = 0L + +; +; INDEX is used as an array index to fill in the final output +; + IF NKEY GT 0 THEN BEGIN + N_FOUND = N_ELEMENTS(KEYVALUES) + INDEX = LINDGEN(N_FOUND) + ENDIF + + +; +; INDEX is used as an array index to fill in the final output +; + IF N_FOUND GT 0 THEN INDEX = LINDGEN(N_FOUND) + +; +; If a default was given, then we are a little more careful to +; reproduce the correct number of values. +; + IF N_ELEMENTS(DEFAULT) GT 0 THEN BEGIN + ;; If no values were found we need to fill KEYVALUES with + ;; *something*. + IF N_FOUND LE 0 THEN KEYVALUES = DEFAULT + COLUMNS = LINDGEN(TFIELDS0) + 1 + + ;; Make an array with the number of columns in the table + SZ_VALUE = SIZE(KEYVALUES[0]) + VALUES = MAKE_ARRAY(TFIELDS0, TYPE=SZ_VALUE[1], VALUE=DEFAULT) + COMMENTS = STRARR(TFIELDS0) + + ;; Fill the columns which had this keyword + IF N_FOUND GT 0 THEN BEGIN + VALUES[INDEX] = KEYVALUES + COMMENTS[INDEX] = COMMENT_STRS + ENDIF + + ENDIF ELSE BEGIN + +; +; If no default was given, we can simply return the values returned +; by FXPAR. +; + IF N_FOUND GT 0 THEN BEGIN + COLUMNS = INDEX + 1 + VALUES = KEYVALUES + COMMENTS = COMMENT_STRS + ENDIF + + ENDELSE + RETURN + + END diff --git a/modules/idl_downloads/astro/pro/fxbfindlun.pro b/modules/idl_downloads/astro/pro/fxbfindlun.pro new file mode 100644 index 0000000..950e6da --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbfindlun.pro @@ -0,0 +1,119 @@ + FUNCTION FXBFINDLUN, UNIT +;+ +; NAME: +; FXBFINDLUN() +; Purpose : +; Find logical unit number UNIT in FXBINTABLE common block. +; Explanation : +; Finds the proper index to use for getting information about the logical +; unit number UNIT in the arrays stored in the FXBINTABLE common block. +; Called from FXBCREATE and FXBOPEN. +; Use : +; Result = FXBFINDLUN( UNIT ) +; Inputs : +; UNIT = Logical unit number. +; Opt. Inputs : +; None. +; Outputs : +; The result of the function is an index into the FXBINTABLE common +; block. +; Opt. Outputs: +; None. +; Keywords : +; None. +; Calls : +; None. +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; None. +; Side effects: +; If UNIT is not found in the common block, then it is added to the +; common block. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb. 1992. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 July 1993. +; Added DHEAP variable to fix bug with variable length arrays. +; Version 3, Michael Schubnell, University of Michigan, 22 May 1996 +; Change N_DIMS from short to long integer. +; Version : +; Version 3, 22 May 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Make NAXIS1, NAXIS2, HEAP, DHEAP, BYTOFF 64-bit integers to deal with large files, +; E. Hivon Mar 2008 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE, $ + 'Syntax: ILUN = FXBFINDLUN( UNIT )' +; +; If the common block hasn't been initialized yet, then initialize it. +; + IF N_ELEMENTS(LUN) EQ 0 THEN BEGIN + LUN = UNIT + STATE = 0 + HEAD = '' + MHEADER = 0L + NHEADER = 0L + NAXIS1 = 0LL + NAXIS2 = 0LL + TFIELDS = 0L + HEAP = 0LL + DHEAP = 0LL + BYTOFF = 0LL + TTYPE = '' + FORMAT = '' + IDLTYPE = 0 + N_ELEM = 0L + TSCAL = 1. + TZERO = 0. + MAXVAL = 0L + N_DIMS = LONARR(9,2) + ILUN = 0 +; +; Otherwise, find the logical unit number in the common block. If not found, +; then add it. +; + END ELSE BEGIN + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + LUN = [LUN,UNIT] + STATE = [STATE, 0] + BOOST_ARRAY,HEAD,'' + MHEADER = [MHEADER,0] + NHEADER = [NHEADER,0] + NAXIS1 = [NAXIS1, 0] + NAXIS2 = [NAXIS2, 0] + TFIELDS = [TFIELDS,0] + HEAP = [HEAP, 0] + DHEAP = [DHEAP, 0] + BOOST_ARRAY,BYTOFF,0 + BOOST_ARRAY,TTYPE,'' + BOOST_ARRAY,FORMAT,'' + BOOST_ARRAY,IDLTYPE,0 + BOOST_ARRAY,N_ELEM,0 + BOOST_ARRAY,TSCAL,1. + BOOST_ARRAY,TZERO,0. + BOOST_ARRAY,MAXVAL,0 + BOOST_ARRAY,N_DIMS,LONARR(9,2) + ILUN = N_ELEMENTS(LUN)-1 + ENDIF + ENDELSE +; +; Return the index into the common block arrays. +; + RETURN,ILUN + END diff --git a/modules/idl_downloads/astro/pro/fxbfinish.pro b/modules/idl_downloads/astro/pro/fxbfinish.pro new file mode 100644 index 0000000..e5c9b39 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbfinish.pro @@ -0,0 +1,129 @@ + PRO FXBFINISH, UNIT, ERRMSG=ERRMSG +;+ +; NAME: +; FXBFINISH +; Purpose : +; Close a FITS binary table extension file opened for write. +; Explanation : +; Closes a FITS binary table extension file that had been opened for +; write by FXBCREATE. +; Use : +; FXBFINISH, UNIT +; Inputs : +; UNIT = Logical unit number of the file. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBFINISH, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; None. +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The file must have been opened with FXBCREATE, and written with +; FXBWRITE. +; Side effects: +; Any bytes needed to pad the file out to an integral multiple of 2880 +; bytes are written out to the file. Then, the file is closed. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Jan 1992. +; W. Thompson, Feb 1992, modified to support variable length arrays. +; W. Thompson, Feb 1992, removed all references to temporary files. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 July 1993. +; Fixed bug with variable length arrays. +; Version 3, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version : +; Version 4, 23 June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN BEGIN + MESSAGE = 'Syntax: FXBFINISH, UNIT' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Find the index of the file. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Make sure the file was opened for write access. +; + IF STATE[ILUN] NE 2 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened for write access' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Calculate how many bytes are needed to pad out the file. +; + OFFSET = NHEADER[ILUN] + HEAP[ILUN] + DHEAP[ILUN] + NPAD = OFFSET MOD 2880 + IF NPAD NE 0 THEN BEGIN + NPAD = 2880 - NPAD + POINT_LUN,UNIT,OFFSET + WRITEU,UNIT,BYTARR(NPAD) + ENDIF +; +; If variable sized arrays were written out to the file, then the PCOUNT value +; must be updated. It is taken for granted that PCOUNT is the sixth keyword +; down, and the value is inserted right justified to column 30. +; + PCOUNT = HEAP[ILUN] + DHEAP[ILUN] - NAXIS1[ILUN]*NAXIS2[ILUN] + IF PCOUNT GT 0 THEN BEGIN + PCOUNT = STRTRIM(PCOUNT,2) + POINT_LUN,UNIT,MHEADER[ILUN] + 430 - STRLEN(PCOUNT) + WRITEU,UNIT,PCOUNT + ENDIF +; +; Close the file, mark it as closed, and return. +; + FREE_LUN,UNIT + STATE[ILUN] = 0 +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbgrow.pro b/modules/idl_downloads/astro/pro/fxbgrow.pro new file mode 100644 index 0000000..6285bce --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbgrow.pro @@ -0,0 +1,245 @@ + PRO FXBGROW, UNIT, HEADER, NROWS, ERRMSG=ERRMSG, NOZERO=NOZERO, $ + BUFFERSIZE=BUFFERSIZE0 +;+ +; NAME: +; FXBGROW +; PURPOSE : +; Increase the number of rows in a binary table. +; EXPLANATION : +; Call FXBGROW to increase the size of an already-existing FITS +; binary table. The number of rows increases to NROWS; however +; the table cannot shrink by this operation. This procedure is +; useful when a table with an unknown number of rows must be +; created. The caller would then call FXBCREATE to construct a +; table of some base size, and follow with calls to FXBGROW to +; lengthen the table as needed. The extension being enlarged +; need not be the last extension in the file. If subsequent +; extensions exist in the file, they will be shifted properly. +; +; CALLING SEQUENCE : +; FXBGROW, UNIT, HEADER, NROWS[, ERRMSG= , NOZERO= , BUFFERSIZE= ] +; +; INPUT PARAMETERS : +; UNIT = Logical unit number of an already-opened file. +; HEADER = String array containing the FITS binary table extension +; header. The header is modified in place. +; NROWS = New number of rows, always more than the previous +; number. +; +; OPTIONAL INPUT KEYWORDS: +; NOZERO = when set, FXBGROW will not zero-pad the new data if +; it doesn't have to. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBGROW, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; BUFFERSIZE = Size in bytes for intermediate data transfers +; (default 32768) +; +; Calls : +; FXADDPAR, FXHREAD, BLKSHIFT +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The file must be open with write permission. +; +; The binary table extension in question must already by written +; to the file (using FXBCREATE). +; +; A table can never shrink via this operation. +; +; SIDE EFFECTS: +; The FITS file will grow in size, and heap areas are +; preserved by moving them to the end of the file. +; +; The header is modified to reflect the new number of rows. +; CATEGORY : +; Data Handling, I/O, FITS, Generic. +; Initially written, C. Markwardt, GSFC, Nov 1998 +; Added ability to enlarge arbitrary extensions and tables with +; variable sized rows, not just the last extension in a file, +; CM, April 2000 +; Fix bug in the zeroing of the output file, C. Markwardt, April 2005 +; +;- +; +@fxbintable + ON_ERROR, 0 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 3 THEN BEGIN + MESSAGE = 'Syntax: FXBGROW, UNIT, HEADER, NROWS' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Find the index of the file. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Don't shrink the file. +; + IF NAXIS2[ILUN] GE NROWS THEN GOTO, FINISH +; +; Make sure the file was opened for write access. +; + IF STATE[ILUN] NE 2 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened for write access' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Compute number of bytes and buffer size +; + + NBYTES = (NROWS-NAXIS2[ILUN])*NAXIS1[ILUN] + IF N_ELEMENTS(BUFFERSIZE0) EQ 0 THEN BUFFERSIZE0 = 32768L + BUFFERSIZE = LONG(BUFFERSIZE0[0]) + BUFFERSIZE = FLOOR(BUFFERSIZE/NAXIS1[ILUN])*NAXIS1[ILUN] + IF BUFFERSIZE LE 0 THEN BUFFERSIZE = NAXIS1[ILUN] + +; +; First, shift the following extensions by block multiples +; + ;; Current beginning of next extension + N_EXT = NHEADER[ILUN] + HEAP[ILUN] + DHEAP[ILUN] + ;; New beginning of next extension, after shifting + N_EXT1 = N_EXT + NBYTES + ;; Round to nearest block size + IF N_EXT MOD 2880 NE 0 THEN N_EXT = N_EXT + 2880 - (N_EXT MOD 2880) + IF N_EXT1 MOD 2880 NE 0 THEN N_EXT1 = N_EXT1 + 2880 - (N_EXT1 MOD 2880) + NBYTES1 = N_EXT1 - N_EXT + + ERRMSG1 = '' + IF NBYTES1 GT 0 THEN BEGIN + BLKSHIFT, UNIT, N_EXT, NBYTES1, ERRMSG=ERRMSG1, $ + NOZERO=KEYWORD_SET(NOZERO), BUFFERSIZE=BUFFERSIZE + IF ERRMSG1 NE '' THEN GOTO, RETMESSAGE + ENDIF +; +; Next, shift the data between the end of the table and the next +; extension, if any. +; + ;; End of table data (but before variable-sized heap data) + ETAB = NHEADER[ILUN] + NAXIS1[ILUN]*NAXIS2[ILUN] + IF N_EXT GT ETAB THEN BEGIN + BLKSHIFT, UNIT, [ETAB, N_EXT1-NBYTES-1L], NBYTES, ERRMSG=ERRMSG1, $ + NOZERO=KEYWORD_SET(NOZERO), BUFFERSIZE=BUFFERSIZE + ENDIF + + RETMESSAGE: + IF ERRMSG1 NE '' THEN BEGIN + MESSAGE = ERRMSG1 + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + +; +; Zero-fill if necessary (if the original table had no trailing +; extensions) +; + + FS = FSTAT(UNIT) + + IF FS.SIZE LT N_EXT1 AND NOT KEYWORD_SET(NOZERO) THEN BEGIN + POINT_LUN, UNIT, ETAB + NLEFT = N_EXT1 - ETAB + NBUFF = BUFFERSIZE < NLEFT + BB = BYTARR(NBUFF) + + WHILE NLEFT GT 0 DO BEGIN + WRITEU, UNIT, BB + NLEFT = NLEFT - N_ELEMENTS(BB) + IF (NLEFT LT NBUFF) AND (NLEFT GT 0) THEN BB = BB[0:NLEFT-1] + ENDWHILE + ENDIF + +; +; Update the internal state. +; + HEAP[ILUN] = HEAP[ILUN] + NBYTES + NAXIS2[ILUN] = NROWS + +; +; Modify passed copy of header +; + IF N_ELEMENTS(HEADER) GT 0 THEN BEGIN + FXADDPAR, HEADER, 'NAXIS2', LONG(NROWS), 'Number of rows (grown)' + THEAP = FXPAR(HEADER, 'THEAP', COUNT=COUNT) + IF COUNT GT 0 THEN BEGIN + THEAP = THEAP + NBYTES + FXADDPAR, HEADER, 'THEAP', THEAP, 'Offset of heap' + ENDIF + ENDIF + + +; +; Modify internal copy of HEADER +; + XHEADER = HEAD[*,ILUN] + FXADDPAR, XHEADER, 'NAXIS2', LONG(NROWS), 'Number of rows (grown)' + THEAP = FXPAR(XHEADER, 'THEAP', COUNT=COUNT) + IF COUNT GT 0 THEN BEGIN + THEAP = THEAP + NBYTES + FXADDPAR, XHEADER, 'THEAP', THEAP, 'Offset of heap' + ENDIF + HEAD[*,ILUN] = XHEADER + +; +; Modify disk copy of HEADER +; + POINT_LUN, UNIT, MHEADER[ILUN] + FXHREAD, UNIT, DHEADER, STATUS + IF STATUS NE 0 THEN BEGIN + MESSAGE = 'Could not load header from file' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + FXADDPAR, DHEADER, 'NAXIS2', LONG(NROWS), 'Number of rows (grown)' + THEAP = FXPAR(DHEADER, 'THEAP', COUNT=COUNT) + IF COUNT GT 0 THEN BEGIN + THEAP = THEAP + NBYTES + FXADDPAR, DHEADER, 'THEAP', THEAP, 'Offset of heap' + ENDIF + ;; Don't worry about the header increasing in size, since + ;; every binary table has to have NAXIS2 already. + SLEN = STRLEN(DHEADER[0]) + FULL = STRING(REPLICATE(32B, 80)) + ;; Pad with spaces + IF SLEN LT 80 THEN DHEADER[0] = DHEADER[0] + STRMID(FULL,0,80-SLEN) + BHDR = BYTE(DHEADER) + BHDR = BHDR[0:79,*] + POINT_LUN, UNIT, MHEADER[ILUN] + WRITEU, UNIT, BHDR + +FINISH: + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbheader.pro b/modules/idl_downloads/astro/pro/fxbheader.pro new file mode 100644 index 0000000..6e37e19 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbheader.pro @@ -0,0 +1,81 @@ + FUNCTION FXBHEADER, UNIT +;+ +; NAME: +; FXBHEADER() +; +; PURPOSE: +; Returns the header of an open FITS binary table. +; +; EXPLANATION: +; This procedure returns the FITS extension header of a FITS +; binary table opened for read with the command FXBOPEN. +; +; Use : Result = FXBHEADER(UNIT) +; +; Inputs : UNIT = Logical unit number returned by FXBOPEN routine. +; Must be a scalar integer. +; +; Opt. Inputs : None. +; +; Outputs : The result of the function is a string array containing the +; header for the FITS binary table that UNIT points to. +; +; Opt. Outputs: None. +; +; Keywords : None. +; +; Calls : FXBFINDLUN +; +; Common : Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; +; Restrictions: None. +; +; Side effects: The string array returned always has as many elements as the +; largest header read by FXBOPEN. Any extra elements beyond the +; true header are blank or null strings. +; +; The header will be returned whether or not the table is still +; open or not. +; +; If UNIT does not point to a binary table, then a string array +; of nulls is returned. +; +; If UNIT is an undefined variable, then the null string is +; returned. +; +; Category : Data Handling, I/O, FITS, Generic. +; +; Prev. Hist. : None. +; +; Written : William Thompson, GSFC, 1 July 1993. +; +; Modified : Version 1, William Thompson, GSFC, 1 July 1993. +; +; Version : Version 1, 1 July 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax: Result = FXBHEADER(UNIT)' +; +; If UNIT is undefined, then return the null string. +; + IF N_ELEMENTS(UNIT) EQ 0 THEN RETURN, '' +; +; Check the validity of UNIT. +; + IF N_ELEMENTS(UNIT) GT 1 THEN MESSAGE,'UNIT must be a scalar' + SZ = SIZE(UNIT) + IF SZ[SZ[0]+1] GT 3 THEN MESSAGE,'UNIT must be an integer' +; +; Get the state associated with UNIT. +; + ILUN = FXBFINDLUN(UNIT) + RETURN, HEAD[*,ILUN] +; + END diff --git a/modules/idl_downloads/astro/pro/fxbhelp.pro b/modules/idl_downloads/astro/pro/fxbhelp.pro new file mode 100644 index 0000000..2a7c199 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbhelp.pro @@ -0,0 +1,128 @@ + PRO FXBHELP,UNIT +;+ +; NAME: +; FXBHELP +; Purpose : +; Prints short description of columns in a FITS binary table. +; Explanation : +; Prints a short description of the columns in a FITS binary table to the +; terminal screen. +; Use : +; FXBHELP, UNIT +; Inputs : +; UNIT = Logical unit number of file opened by FXBOPEN. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; None. +; Calls : +; FXBFIND, FXBFINDLUN, FXPAR +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The file must have been opened with FXBOPEN. +; Side effects: +; Certain fields may be truncated in the display. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb. 1992, from TBHELP by W. Landsman. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 12 May 1993. +; Modified to not write to a logical unit number assigned to the +; terminal. This makes it compatible with IDL for Windows. +; Version 3, Wayne Landsman GSFC April 2010 +; Remove use of obsolete !ERR system variable +; Version : +; Version 3, April 2010. +;- +; +@fxbintable + ON_ERROR,2 + COMPILE_OPT IDL2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 1 THEN MESSAGE,'Syntax: FXBHELP, UNIT' +; +; Get the header. +; + ILUN = FXBFINDLUN(UNIT) + HEADER = HEAD[*,ILUN] +; +; Get the extension name. +; + EXTNAME = FXPAR(HEADER,'EXTNAME', COUNT=N_EXTNAME) + IF N_EXTNAME LE 0 THEN EXTNAME = '' +; +; Print the labels. +; + PRINT,' ' + PRINT,'FITS Binary Table: ' + EXTNAME + PRINT,'Table contains ' + STRTRIM(TFIELDS[ILUN],2) + $ + ' columns, by ' + STRTRIM(NAXIS2[ILUN],2) + ' rows' + PRINT,' ' + T_FORMAT = 26 ;Starting column for Format/Size + T_UNITS = 46 ;Starting column for Units + T_NULL = 58 ;Starting column for Null + PRINT,FORMAT="('Col',2X,'Name',T" + STRTRIM(T_FORMAT,2) + $ + ",'Type Size',T" + STRTRIM(T_UNITS,2) + ",'Units',T" + $ + STRTRIM(T_NULL,2) + ",6X,'Null')" + PRINT,' ' +; +; Get the values of the information to be printed. +; + FXBFIND,HEADER,'TDIM', COL,TDIM0, N_FOUND,'' + FXBFIND,HEADER,'TUNIT',COL,TUNIT0,N_FOUND,'' +; + FXBFIND,HEADER,'TNULL',COL,TNULL0,N_FOUND + SNULL = STRARR(TFIELDS[ILUN]) + IF N_FOUND GT 0 THEN FOR I = 0,N_ELEMENTS(COL)-1 DO $ + SNULL[COL[I]-1] = STRTRIM(TNULL0[I],2) +; +; Print the column information. +; + FOR ICOL = 0,TFIELDS[ILUN]-1 DO BEGIN + CASE FORMAT[ICOL,ILUN] OF + 'L': TYPE0 = 'Log' + 'A': TYPE0 = 'Asc' + 'B': TYPE0 = 'Byt' + 'I': TYPE0 = 'Int' + 'J': TYPE0 = 'Lng' + 'E': TYPE0 = 'Flt' + 'D': TYPE0 = 'Dbl' + 'C': TYPE0 = 'Cmp' + 'M': TYPE0 = 'DbC' + 'X': TYPE0 = 'Bit' + ENDCASE + IF MAXVAL[ICOL,ILUN] GT 0 THEN BEGIN + ELEM = MAXVAL[ICOL,ILUN] + IF FORMAT[ICOL,ILUN] EQ 'M' THEN ELEM = ELEM/2 + ELEM = "< " + STRTRIM(ELEM,2) + END ELSE IF TDIM0[ICOL] NE '' THEN BEGIN + ELEM = TDIM0[ICOL] + END ELSE BEGIN + ELEM = N_ELEM[ICOL,ILUN] + IF FORMAT[ICOL,ILUN] EQ 'M' THEN ELEM = ELEM/2 + ELEM = STRTRIM(ELEM,2) + ENDELSE + PRINT,ICOL+1,TTYPE[ICOL,ILUN],TYPE0,ELEM, $ + TUNIT0[ICOL],SNULL[ICOL], FORMAT='(I3,2X,A,T' + $ + STRTRIM(T_FORMAT-2,2) + ',2X,A3,2X,A,T' + $ + STRTRIM(T_UNITS-2,2) + ',2X,A,T' + $ + STRTRIM(T_NULL-2,2) + ',2X,A10)' + ENDFOR + PRINT,' ' +; + RETURN + END + diff --git a/modules/idl_downloads/astro/pro/fxbhmake.pro b/modules/idl_downloads/astro/pro/fxbhmake.pro new file mode 100644 index 0000000..7d9ff31 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbhmake.pro @@ -0,0 +1,150 @@ + PRO FXBHMAKE,HEADER,NROWS,EXTNAME,COMMENT,DATE=DATE, $ + INITIALIZE=INITIALIZE,EXTVER=EXTVER,EXTLEVEL=EXTLEVEL, $ + ERRMSG=ERRMSG +;+ +; NAME: +; FXBHMAKE +; Purpose : +; Create basic FITS binary table extension (BINTABLE) header. +; Explanation : +; Creates a basic header array with all the required keywords, but with +; none of the table columns defined. This defines a basic structure +; which can then be added to or modified by other routines. +; Use : +; FXBHMAKE, HEADER, NROWS [, EXTNAME [, COMMENT ]] +; Inputs : +; NROWS = Number of rows in the binary table. +; Opt. Inputs : +; EXTNAME = If passed, then the EXTNAME record is added with this value. +; COMMENT = Comment to go along with EXTNAME. +; Outputs : +; HEADER = String array containing FITS extension header. +; Opt. Outputs: +; None. +; Keywords : +; INITIALIZE = If set, then the header is completely initialized, and any +; previous entries are lost. +; DATE = If set, then the DATE keyword is added to the header. +; EXTVER = Extension version number (integer). +; EXTLEVEL = Extension level number (integer). +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBHMAKE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; GET_DATE, FXADDPAR, FXHCLEAN +; Common : +; None. +; Restrictions: +; Warning: No checking is done of any of the parameters. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992. +; William Thompson, Sep 1992, added EXTVER and EXTLEVEL keywords. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version : +; Version 3, 23 June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR,2 +; +; Check the number of parameters first. +; + IF N_PARAMS() LT 2 THEN BEGIN + MESSAGE = 'Calling sequence: FXBHMAKE, HEADER, NROWS ' + $ + '[, EXTNAME [, COMMENT ]]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If requested, then initialize the header. +; + IF KEYWORD_SET(INITIALIZE) THEN BEGIN + HEADER = STRARR(36) + HEADER[0] = 'END' + STRING(REPLICATE(32B,77)) +; +; Else, if undefined, then initialize the header. +; + END ELSE IF N_ELEMENTS(HEADER) EQ 0 THEN BEGIN + HEADER = STRARR(36) + HEADER[0] = 'END' + STRING(REPLICATE(32B,77)) +; +; Otherwise, make sure that HEADER is a string array, and remove any keywords +; that describe the format of the file. +; + END ELSE BEGIN + SZ = SIZE(HEADER) + IF (SZ[0] NE 1) OR (SZ[2] NE 7) THEN BEGIN + MESSAGE = 'HEADER must be a (one-dimensional) ' + $ + 'string array' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + FXHCLEAN,HEADER,ERRMSG=ERRMSG + IF ERRMSG EQ '' THEN RETURN + END ELSE FXHCLEAN,HEADER + ENDELSE +; +; Add the required keywords. Start out with a completely blank table, with no +; columns. +; + FXADDPAR,HEADER,'XTENSION','BINTABLE','Written by IDL: '+ SYSTIME() + FXADDPAR,HEADER,'BITPIX',8 + FXADDPAR,HEADER,'NAXIS',2,'Binary table' + FXADDPAR,HEADER,'NAXIS1',0,'Number of bytes per row' + FXADDPAR,HEADER,'NAXIS2',LONG(NROWS),'Number of rows' + FXADDPAR,HEADER,'PCOUNT',0,'Random parameter count' + FXADDPAR,HEADER,'GCOUNT',1,'Group count' + FXADDPAR,HEADER,'TFIELDS',0,'Number of columns' +; +; If requested, add the EXTNAME keyword to the header. +; + IF N_PARAMS() GE 3 THEN BEGIN + IF N_PARAMS() EQ 3 THEN COMMENT = 'Extension name' + FXADDPAR,HEADER,'EXTNAME',EXTNAME,COMMENT + ENDIF +; +; If requested, add the EXTVER keyword to the header. +; + IF N_ELEMENTS(EXTVER) EQ 1 THEN $ + FXADDPAR,HEADER,'EXTVER',LONG(EXTVER),'Extension version' +; +; If requested, add the EXTLEVEL keyword to the header. +; + IF N_ELEMENTS(EXTLEVEL) EQ 1 THEN $ + FXADDPAR,HEADER,'EXTLEVEL',LONG(EXTLEVEL),'Extension level' +; +; If requested, add the DATE keyword to the header, containing the current +; date. +; + IF KEYWORD_SET(DATE) THEN BEGIN + GET_DATE,DTE ;Get current date as CCYY-MM-DD + FXADDPAR,HEADER,'DATE',DTE,'Creation date' + ENDIF +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbintable.pro b/modules/idl_downloads/astro/pro/fxbintable.pro new file mode 100644 index 0000000..f4791a2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbintable.pro @@ -0,0 +1,71 @@ +;+ +; NAME: +; FXBINTABLE +; Purpose : +; Common block FXBINTABLE used by "FXB" routines. +; Explanation : +; This is not an IDL routine as such, but contains the definition of the +; common block FXBINTABLE for inclusion into other routines. By defining +; the common block in one place, the problem of conflicting definitions +; is avoided. +; +; This file is included into routines that need this common block with +; the single line (left justified) +; +; @fxbintable +; +; FXBINTABLE contains the following arrays: +; +; LUN = An array of logical unit numbers of currently (or +; previously) opened binary table files. +; STATE = Array containing the state of the FITS files +; associated with the logical unit numbers, where +; 0=closed, 1=open for read, and 2=open for write. +; HEAD = FITS binary table headers. +; MHEADER = Array containing the positions of the first data byte +; of the header for each file referenced by array LUN. +; NHEADER = Array containing the positions of the first data byte +; after the header for each file referenced by array +; LUN. +; NAXIS1 = Values of NAXIS1 from the binary table headers. +; NAXIS2 = Values of NAXIS2 from the binary table headers. +; TFIELDS = Values of TFIELDS from the binary table headers. +; HEAP = The start of the first byte of the heap area +; for variable length arrays. +; DHEAP = The start of the first byte of the next variable +; length array, if writing. +; BYTOFF = Byte offset from the beginning of the row for each +; column in the binary table headers. +; TTYPE = Values of TTYPE for each column in the binary table +; headers. +; FORMAT = Character code formats of the various columns. +; IDLTYPE = IDL type code for each column in the binary table +; headers. +; N_ELEM = Number of elements for each column in the binary +; table headers. +; TSCAL = Scale factors for the individual columns. +; TZERO = Zero offsets for the individual columns. +; MAXVAL = For variable length arrays, contains the maximum +; number of elements for each column in the binary +; table headers. +; N_DIMS = Number of dimensions, and array of dimensions for +; each column of type string in the binary table +; headers. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb 1992. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 July 1993. +; Added DHEAP variable to fix bug with variable length arrays. +; Version : +; Version 2, 21 July 1993. +;- +; + COMMON FXBINTABLE,LUN,STATE,HEAD,MHEADER,NHEADER,NAXIS1,NAXIS2, $ + TFIELDS,HEAP,DHEAP,BYTOFF,TTYPE,FORMAT,IDLTYPE,N_ELEM,TSCAL, $ + TZERO,MAXVAL,N_DIMS diff --git a/modules/idl_downloads/astro/pro/fxbisopen.pro b/modules/idl_downloads/astro/pro/fxbisopen.pro new file mode 100644 index 0000000..ae5fca1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbisopen.pro @@ -0,0 +1,77 @@ + FUNCTION FXBISOPEN,UNIT +;+ +; NAME: +; FXBISOPEN() +; +; PURPOSE: +; Returns true if UNIT points to an open FITS binary table. +; +; Explanation : This procedure checks to see if the logical unit number given +; by the variable UNIT corresponds to a FITS binary table opened +; for read with the command FXBOPEN, and which has not yet been +; closed with FXBCLOSE. +; +; Use : Result = FXBISOPEN(UNIT) +; +; If FXBISOPEN(UNIT) THEN ... +; +; Inputs : UNIT = Logical unit number returned by FXBOPEN routine. +; Must be a scalar integer. +; +; Opt. Inputs : None. +; +; Outputs : The result of the function is either True (1) or False (0), +; depending on whether UNIT points to an open binary table or +; not. +; +; Opt. Outputs: None. +; +; Keywords : None. +; +; Calls : FXBFINDLUN +; +; Common : Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; +; Restrictions: None. +; +; Side effects: If UNIT is an undefined variable, then False (0) is returned. +; +; If UNIT points to a FITS binary table file that is opened for +; write, then False (0) is returned. +; +; Category : Data Handling, I/O, FITS, Generic. +; +; Prev. Hist. : None. +; +; Written : William Thompson, GSFC, 1 July 1993. +; +; Modified : Version 1, William Thompson, GSFC, 1 July 1993. +; +; Version : Version 1, 1 July 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax: Result = FXBISOPEN(UNIT)' +; +; If UNIT is undefined, then return False. +; + IF N_ELEMENTS(UNIT) EQ 0 THEN RETURN, 0 +; +; Check the validity of UNIT. +; + IF N_ELEMENTS(UNIT) GT 1 THEN MESSAGE,'UNIT must be a scalar' + SZ = SIZE(UNIT) + IF SZ[SZ[0]+1] GT 3 THEN MESSAGE,'UNIT must be an integer' +; +; Get the state associated with UNIT. +; + ILUN = FXBFINDLUN(UNIT) + RETURN, STATE[ILUN] EQ 1 +; + END diff --git a/modules/idl_downloads/astro/pro/fxbopen.pro b/modules/idl_downloads/astro/pro/fxbopen.pro new file mode 100644 index 0000000..f327377 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbopen.pro @@ -0,0 +1,350 @@ + PRO FXBOPEN, UNIT, FILENAME0, EXTENSION, HEADER, NO_TDIM=NO_TDIM, $ + ERRMSG=ERRMSG, ACCESS=ACCESS, REOPEN=REOPEN +;+ +; NAME: +; FXBOPEN +; Purpose : +; Open binary table extension in a disk FITS file for reading or updating +; Explanation : +; Opens a binary table extension in a disk FITS file for reading. The +; columns are then read using FXBREAD, and the file is closed when done +; with FXBCLOSE. +; Use : +; FXBOPEN, UNIT, FILENAME, EXTENSION [, HEADER ] +; Inputs : +; FILENAME = Name of FITS file to be opened. Optional +; extension *number* may be specified, in either of +; the following formats (using the FTOOLS +; convention): FILENAME[EXT] or FILENAME+EXT, where +; EXT is 1 or higher. Such an extension +; specification takes priority over EXTENSION. +; +; EXTENSION = Either the number of the FITS extension, starting with the +; first extension after the primary data unit being one; or a +; character string containing the value of EXTNAME to search +; for. +; Opt. Inputs : +; None. +; Outputs : +; UNIT = Logical unit number of the opened file. +; Opt. Outputs: +; HEADER = String array containing the FITS binary table extension +; header. +; Keywords : +; NO_TDIM = If set, then any TDIMn keywords found in the header are +; ignored. +; +; ACCESS = A scalar string describing access privileges as +; one of READ ('R') or UPDATE ('RW'). +; DEFAULT: 'R' +; +; REOPEN = If set, UNIT must be an already-opened file unit. +; FXBOPEN will treat the file as a FITS file. +; +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBOPEN, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXBFINDLUN, FXBPARSE, FXHREAD, FXPAR +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The file must be a valid FITS file. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Feb 1992, based on READFITS by J. Woffard and W. Landsman. +; W. Thompson, Feb 1992, changed from function to procedure. +; W. Thompson, June 1992, fixed up error handling. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 27 May 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 21 June 1994 +; Extended ERRMSG to call to FXBPARSE +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, 23 June 1994 +; +; Added ACCESS, REOPEN keywords, and FXFILTER package, CM 1999 Feb 03 +; Added FILENAME[EXT] and FILENAME+EXT extension parsing, CM 1999 Jun 28 +; Some general tidying, CM 1999 Nov 18 +; Allow for possible 64bit integer number of bytes W. Landsman Nov 2007 +; Make Ndata a 64bit integer to deal with larger files, E. Hivon, Mar 2008 +; +; +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = 'Syntax: FXBOPEN, UNIT, FILENAME, EXTENSION ' + $ + '[, HEADER ]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Check the type of the EXTENSION parameter. +; + IF N_ELEMENTS(EXTENSION) NE 1 THEN BEGIN + MESSAGE = 'EXTENSION must be a scalar' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + SZ = SIZE(EXTENSION) + ETYPE = SZ[SZ[0]+1] + IF ETYPE EQ 8 THEN BEGIN + MESSAGE = 'EXTENSION must not be a structure' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If EXTENSION is of type string, then search for the proper extension by +; name. Otherwise, search by number. +; + IF ETYPE EQ 7 THEN BEGIN + S_EXTENSION = STRTRIM(STRUPCASE(EXTENSION),2) + END ELSE BEGIN + I_EXTENSION = FIX(EXTENSION) + IF I_EXTENSION LT 1 THEN BEGIN + MESSAGE = 'EXTENSION must be greater than zero' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDELSE +; +; Check access parameter + IF N_ELEMENTS(ACCESS) EQ 0 THEN ACCESS='R' + SZ = SIZE(ACCESS) + IF SZ[SZ[0]+1] NE 7 THEN GOTO, ACCERR + IF STRUPCASE(ACCESS) NE 'R' AND STRUPCASE(ACCESS) NE 'RW' THEN BEGIN + ACCERR: + MESSAGE = "ACCESS must be either 'R' or 'RW'" + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Establish the read/write state +; + ST = 1 ; Read only + IF STRUPCASE(ACCESS) EQ 'RW' THEN ST = 2 ; Read/write + +; +; Get a logical unit number, and open the file. +; + FILENAME = FILENAME0 + IF NOT KEYWORD_SET(REOPEN) THEN BEGIN + + ;; Check for extension name at the end of a filename + LEN = STRLEN(FILENAME0) + NEWEXT = 0L + BFILENAME = BYTE(FILENAME) + B0 = (BYTE('0'))(0) & B9 = (BYTE('9'))(0) + I = LEN-1 + BB = BFILENAME[I] + + ;; First case: FILENAME[5] + IF LEN GE 4 AND STRING(BB) EQ ']' THEN BEGIN ;; Count backwards + I = I - 1 + IF BFILENAME[I] GE B0 AND BFILENAME[I] LE B9 THEN BEGIN + WHILE I GT 0 AND $ + BFILENAME[I] GE B0 AND BFILENAME[I] LT B9 DO I = I - 1 + IF I GT 0 AND STRING(BFILENAME[I]) EQ '[' THEN BEGIN + NEWEXT = LONG(STRMID(FILENAME,I+1,10)) + FLEN = I + ENDIF + ENDIF + ENDIF + + ;; Second case: FILENAME+5 + IF LEN GE 3 AND BB GE B0 AND BB LE B9 THEN BEGIN ;; Count backwards + WHILE I GT 0 AND $ + BFILENAME[I] GE B0 AND BFILENAME[I] LT B9 DO I = I - 1 + IF I GT 0 AND STRING(BFILENAME[I]) EQ '+' THEN BEGIN + NEWEXT = LONG(STRMID(FILENAME,I+1,10)) + FLEN = I + ENDIF + ENDIF + IF NEWEXT GT 0 THEN BEGIN + FILENAME = STRMID(FILENAME, 0, FLEN) + I_EXTENSION = NEWEXT + ETYPE = 1 + ENDIF + + ;; Open the file + IF ST EQ 1 THEN $ + OPENR, UNIT, FILENAME, /BLOCK, /GET_LUN, ERROR=ERROR $ + ELSE $ + OPENU, UNIT, FILENAME, /BLOCK, /GET_LUN, ERROR=ERROR + IF ERROR NE 0 THEN GOTO, NO_SUCH_FILE + ENDIF + +; +; Reopen the file if requested. Essentially this means seeking to +; the start, after some error checking. +; + IF KEYWORD_SET(REOPEN) THEN BEGIN + SZ = SIZE(UNIT) + IF N_ELEMENTS(UNIT) NE 1 OR SZ[SZ[0]+1] EQ 8 THEN BEGIN + MESSAGE = 'UNIT must be a scalar numeric type' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Error checking on file unit +; + UNIT = UNIT[0] + FS = FSTAT(UNIT) + IF (FS.OPEN NE 1) OR (FS.READ NE 1) $ + OR (ST EQ 2 AND FS.WRITE NE 1) THEN BEGIN + MESSAGE = 'UNIT '+strtrim(unit,2)+' must be open for reading' + IF ST EQ 2 THEN MESSAGE = MESSAGE + '/writing' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + ;; Seek to the start of the file + POINT_LUN, UNIT, 0L + ENDIF + + +; +; Store the UNIT number in the common block, and leave space for the other +; parameters. Initialize the common block if need be. ILUN is an index into +; the arrays. +; + ILUN = FXBFINDLUN(UNIT) +; +; Mark the file as open for read or write. +; + STATE[ILUN] = ST +; +; Read the primary header. +; + FXHREAD,UNIT,HEADER,STATUS + IF STATUS NE 0 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Unable to read primary FITS header' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + I_EXT = 0 +; +; Make sure that the file does contain extensions. +; + START = 0L + IF NOT FXPAR(HEADER,'EXTEND', START=START) THEN BEGIN + FREE_LUN, UNIT + MESSAGE = 'File ' + FILENAME + ' does not contain extensions' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get the number of bytes taken up by the data. +; +NEXT_EXT: + BITPIX = FXPAR(HEADER,'BITPIX', START=START) + NAXIS = FXPAR(HEADER,'NAXIS', START=START) + GCOUNT = FXPAR(HEADER,'GCOUNT', START=START) + IF GCOUNT EQ 0 THEN GCOUNT = 1 + PCOUNT = FXPAR(HEADER,'PCOUNT', START=START) + IF NAXIS GT 0 THEN BEGIN + DIMS = FXPAR(HEADER,'NAXIS*') ;Read dimensions + NDATA = long64(DIMS[0]) + IF NAXIS GT 1 THEN FOR I=2,NAXIS DO NDATA = NDATA*DIMS[I-1] + ENDIF ELSE NDATA = 0 + NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA) +; +; Read the next extension header in the file. +; + NREC = (NBYTES + 2879) / 2880 + POINT_LUN, -UNIT, POINTLUN ;Current position + MHEAD0 = POINTLUN + NREC*2880L + POINT_LUN, UNIT, MHEAD0 ;Next FITS extension + FXHREAD,UNIT,HEADER,STATUS + IF STATUS NE 0 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Requested extension not found' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + I_EXT = I_EXT + 1 +; +; Check to see if the current extension is the one desired. +; + START = 0L + IF ETYPE EQ 7 THEN BEGIN + EXTNAME = STRTRIM(STRUPCASE(FXPAR(HEADER,'EXTNAME', $ + START=START)),2) + IF EXTNAME EQ S_EXTENSION THEN GOTO, DONE + END ELSE IF I_EXT EQ I_EXTENSION THEN GOTO, DONE + GOTO, NEXT_EXT +; +; Check to see if the extension type is BINTABLE or A3DTABLE. +; +DONE: + XTENSION = STRTRIM(STRUPCASE(FXPAR(HEADER,'XTENSION', START=START)),2) + IF (XTENSION NE 'BINTABLE') AND (XTENSION NE 'A3DTABLE') THEN BEGIN + IF ETYPE EQ 7 THEN EXT = S_EXTENSION ELSE EXT = I_EXTENSION + FREE_LUN,UNIT + MESSAGE = 'Extension ' + STRTRIM(EXT,2) + $ + ' is not a binary table' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get the rest of the information, and store it in the common block. +; + MHEADER[ILUN] = MHEAD0 + FXBPARSE,ILUN,HEADER,NO_TDIM=NO_TDIM,ERRMSG=ERRMSG + RETURN +; +; Error point for not being able to open the file +; +NO_SUCH_FILE: + MESSAGE = 'Unable to open file ' + STRTRIM(FILENAME,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END diff --git a/modules/idl_downloads/astro/pro/fxbparse.pro b/modules/idl_downloads/astro/pro/fxbparse.pro new file mode 100644 index 0000000..92601d5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbparse.pro @@ -0,0 +1,162 @@ + PRO FXBPARSE, ILUN, HEADER, NO_TDIM=NO_TDIM, ERRMSG=ERRMSG +;+ +; NAME: +; FXBPARSE +; Purpose : +; Parse the binary table extension header. +; Explanation : +; Parses the binary table extension header, and store the information +; about the format of the binary table in the FXBINTABLE common +; block--called from FXBCREATE and FXBOPEN. +; Use : +; FXBPARSE, ILUN, UNIT, HEADER +; Inputs : +; ILUN = Index into the arrays in the FXBINTABLE common block. +; HEADER = FITS binary table extension header. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; NO_TDIM = If set, then any TDIMn keywords found in the header are +; ignored. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBPARSE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXBFIND, FXBTDIM, FXBTFORM, FXPAR +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; None. +; Side effects: +; Any TDIMn keywords found for bit arrays (format 'X') are ignored, since +; the dimensions would refer to bits, not bytes. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb. 1992. +; William Thompson, Jan. 1993, modified for renamed FXBTFORM and FXBTDIM. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, Michael Schubnell, University of Michigan, 22 May 1996 +; Change N_DIMS from short to long integer. +; Version 5, W. Landsman, GSFC, 12 Aug 1997 +; Use double complex datatype, if needed +; Version 6, W. Landsman GSFC 30 Aug 1997 +; Optimized FXPAR; call FXBFIND for speed, CM 1999 Nov 18 +; Modify DHEAP(ILUN) when opening table now, CM 2000 Feb 22 +; Default the TZERO/TSCAL tables to double instead of single +; precision floating point, CM 2003 Nov 23 +; Make NAXIS1 and NAXIS2 64-bit integers to deal with large files, +; E. Hivon Mar 2008 +; Remove use of Obsolete !ERR system variable +; Version +; Version 8 April 2010 +;- +; +@fxbintable + ON_ERROR,2 + COMPILE_OPT IDL2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN BEGIN + MESSAGE = 'Syntax: FXBPARSE, ILUN, HEADER' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Gather the necessary information, and store it in the common block. +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + FXBTFORM,HEADER,BYTOFF0,IDLTYPE0,FORMAT0,N_ELEM0,MAXVAL0, $ + ERRMSG=ERRMSG + IF ERRMSG NE '' THEN RETURN + END ELSE FXBTFORM,HEADER,BYTOFF0,IDLTYPE0,FORMAT0,N_ELEM0,MAXVAL0 +; + FXBFIND,HEADER,'TTYPE',COLUMNS,TTYPE0,N_FOUND,'' + FXBFIND,HEADER,'TSCAL',COLUMNS,TSCAL0,N_FOUND,1D + FXBFIND,HEADER,'TZERO',COLUMNS,TZERO0,N_FOUND,0D + POINT_LUN,-LUN[ILUN],NHEAD0 +; +; Get the information from the required keywords. +; + STORE_ARRAY,HEAD,HEADER,ILUN + NHEADER[ILUN] = NHEAD0 + START = 0L + NAXIS1[ILUN] = long64(FXPAR(HEADER,'NAXIS1', START=START)) + NAXIS2[ILUN] = long64(FXPAR(HEADER,'NAXIS2', START=START)) + TFIELDS[ILUN] = FXPAR(HEADER,'TFIELDS', START=START) + PCOUNT = FXPAR(HEADER,'PCOUNT', START=START) +; +; If THEAP is not present, then set it equal to the size of the table. +; + THEAP = FXPAR(HEADER,'THEAP', START=START, COUNT=N_THEAP) + IF N_THEAP LE 0 THEN THEAP = NAXIS1[ILUN]*NAXIS2[ILUN] + HEAP[ILUN] = THEAP +; +; Modify DHEAP +; + DDHEAP = PCOUNT - (THEAP - NAXIS1[ILUN]*NAXIS2[ILUN]) + IF DDHEAP GT 0 THEN DHEAP[ILUN] = DDHEAP ELSE DHEAP[ILUN] = 0 +; +; Store the information about the columns. +; + STORE_ARRAY,BYTOFF,BYTOFF0,ILUN + STORE_ARRAY,TTYPE,STRUPCASE(STRTRIM(TTYPE0,2)),ILUN + STORE_ARRAY,IDLTYPE,IDLTYPE0,ILUN + STORE_ARRAY,FORMAT,FORMAT0,ILUN + STORE_ARRAY,N_ELEM,N_ELEM0,ILUN + STORE_ARRAY,TSCAL,TSCAL0,ILUN + STORE_ARRAY,TZERO,TZERO0,ILUN + STORE_ARRAY,MAXVAL,MAXVAL0,ILUN + STORE_ARRAY,N_DIMS,LONARR(9,N_ELEMENTS(N_ELEM0)),ILUN +; +; If not a variable length array, then get the dimensions associated with each +; column from the TDIMn keywords. If not found, then assume to be the number +; of elements. +; + FXBFIND,HEADER,'TDIM',COLUMNS,TDIMS,N_FOUND,'' + FOR ICOL = 0,TFIELDS[ILUN]-1 DO IF MAXVAL[ICOL,ILUN] EQ 0 THEN BEGIN + TDIM = TDIMS[ICOL] + TDIM_USED = (TDIM NE '') AND (NOT KEYWORD_SET(NO_TDIM)) + IF TDIM_USED THEN DIMS = FIX(FXBTDIM(TDIM)) $ + ELSE DIMS = N_ELEM[ICOL,ILUN] + DIMS = [N_ELEMENTS(DIMS),DIMS] +; +; If the datatype is a bit array, then no dimensions are applied to the data. +; + IF FORMAT[ICOL,ILUN] EQ 'X' THEN DIMS = [1,N_ELEM[ICOL,ILUN]] + N_DIMS[0,ICOL,ILUN] = DIMS +; +; For those columns which are character strings, then the number of +; characters, N_CHAR, is the first dimension, and the number of elements is +; actually N_ELEM/N_CHAR. +; + IF IDLTYPE[ICOL,ILUN] EQ 7 THEN $ + N_ELEM[ICOL,ILUN] = N_ELEM[ICOL,ILUN] / DIMS[1] + ENDIF +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbread.pro b/modules/idl_downloads/astro/pro/fxbread.pro new file mode 100644 index 0000000..179981c --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbread.pro @@ -0,0 +1,387 @@ + PRO FXBREAD, UNIT, DATA, COL, ROW, NOSCALE=NOSCALE, VIRTUAL=VIR, $ + DIMENSIONS=DIMS0, NANVALUE=NANVALUE, ERRMSG=ERRMSG, $ + NOIEEE=NOIEEE +;+ +; NAME: +; FXBREAD +; Purpose : +; Read a data array from a disk FITS binary table file. +; Explanation : +; Each call to FXBREAD will read the data from one column and one row +; from the FITS data file, which should already have been opened by +; FXBOPEN. One needs to call this routine for every column and every row +; in the binary table. FXBCLOSE will then close the FITS data file. +; Use : +; FXBREAD, UNIT, DATA, COL [, ROW ] +; Inputs : +; UNIT = Logical unit number corresponding to the file containing the +; binary table. +; COL = Column in the binary table to read data from, either as a +; character string containing a column label (TTYPE), or as a +; numerical column index starting from column one. +; Opt. Inputs : +; ROW = Either row number in the binary table to read data from, +; starting from row one, or a two element array containing a +; range of row numbers to read. If not passed, then the entire +; column is read in. +; +; Row must be passed for variable length arrays. +; +; Outputs : +; DATA = IDL data array to be read from the file. +; Opt. Outputs: +; None. +; Keywords : +; NOSCALE = If set, then the output data will not be scaled using the +; optional TSCAL and TZERO keywords in the FITS header. +; Default is to scale. +; NOIEEE = If set, then the output data is not byte-swapped to +; machine order. NOIEEE implies NOSCALE. +; Default is to perform the byte-swap. +; VIRTUAL = If set, and COL is passed as a name rather than a number, +; then if the program can't find a column with that name, it +; will then look for a keyword with that name in the header. +; Such a keyword would then act as a "virtual column", with the +; same value for every row. +; DIMENSIONS = Vector array containing the dimensions to be used to read +; in the data. Bypasses any dimensioning information stored in +; the header. Ignored for bit arrays. If the data type is +; double-precision complex, then an extra dimension of 2 is +; prepended to the dimensions passed by the user. +; NANVALUE= Value signalling data dropout. All points corresponding to +; IEEE NaN (not-a-number) are converted to this number. +; Ignored unless DATA is of type float, double-precision or +; complex. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBREAD, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXPAR, WHERE_NEGZERO, WHERENAN +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The binary table file must have been opened with FXBOPEN. +; +; The data must be consistent with the column definition in the binary +; table header. +; +; The row number must be consistent with the number of rows stored in the +; binary table header. +; +; The number of elements implied by the dimensions keyword must not +; exceed the number of elements stored in the file. +; +; Side effects: +; If the DIMENSIONS keyword is used, then the number of data points read +; in may be less than the number of points stored in the table. +; +; If there are no elements to read in (the number of elements is zero), +; then the program sets !ERR to -1, and DATA is unmodified. +; +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Jan 1992. +; W. Thompson, Feb 1992, modified to support variable length arrays. +; W. Thompson, Jun 1992, modified way that row ranges are read in. No +; longer works reiteratively. +; W. Thompson, Jun 1992, fixed bug where NANVALUE would be modified by +; TSCAL and TZERO keywords. +; W. Thompson, Jun 1992, fixed bug when reading character strings. +; Treats dimensions better when reading multiple +; rows. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 30 June 1993. +; Added overwrite keyword to REFORM call to speed up. +; Version 3, William Thompson, GSFC, 21 July 1993. +; Fixed bug with variable length arrays. +; Version 4, William Thompson, GSFC, 29 October 1993. +; Added error message for not finding column by name. +; Version 5, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 6, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 7, William Thompson, GSFC, 29 December 1994 +; Fixed bug where single element dimensions were lost. +; Version 8, William Thompson, GSFC, 20 March 1995 +; Fixed bug introduced in version 7. +; Version 9, Wayne Landsman, GSFC, 3 July 1996 +; Fixed bug involving use of virtual keyword. +; Version 10, William Thompson, GSFC, 31-Jan-1997 +; Added call to WHERE_NEGZERO. +; Version 11, Wayne Landsman, GSFC, 12 Aug, 1997 +; Use IDL dcomplex datatype if needed +; Version 12, Wayne Landmsan, GSFC, 20 Feb, 1998 +; Remove call to WHERE_NEGZERO (now part of IEEE_TO_HOST) +; Version 13, 18 Nov 1999, CM, Add NOIEEE keyword +; Version 14, 21 Aug 2000, William Thompson, GSFC +; Catch I/O errors +; Version 15, W. Landsman GSFC 10 Dec 2009 +; Fix Dimension keyword, remove IEEE_TO_HOST +; Version : +; Version 15, 10 Dec 2009 +;- +; +@fxbintable + ON_ERROR, 2 + ON_IOERROR, HANDLE_IO_ERROR +; +; Check the number of parameters. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = 'Syntax: FXBREAD, UNIT, DATA, COL [, ROW ]' + GOTO, HANDLE_ERROR + ENDIF +; +; Find the logical unit number in the FXBINTABLE common block. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + ' not opened properly' + GOTO, HANDLE_ERROR + ENDIF +; +; If COL is of type string, then search for a column with that label. +; + SC = SIZE(COL) + VIRTUAL = 0 + IF SC[SC[0]+1] EQ 7 THEN BEGIN + SCOL = STRUPCASE(STRTRIM(COL,2)) + ICOL = WHERE(TTYPE[*,ILUN] EQ SCOL, NCOL) + ICOL = ICOL[0] + IF (ICOL LT 0) AND (NOT KEYWORD_SET(VIR)) THEN BEGIN + MESSAGE = 'Column "' + SCOL + '" not found' + GOTO, HANDLE_ERROR + ENDIF +; +; If the column was not found, and VIRTUAL was set, then search for a keyword +; by that name. +; + IF NCOL EQ 0 THEN BEGIN + IF KEYWORD_SET(VIR) THEN BEGIN + HEADER = HEAD[*,ILUN] + VALUE = FXPAR(HEADER,SCOL,COUNT=CC) + IF CC GT 0 THEN BEGIN + DATA = VALUE + VIRTUAL = 1 + GOTO, CHECK_ROW + ENDIF + ENDIF + MESSAGE = 'Column "' + SCOL + '" not found' + GOTO, HANDLE_ERROR + ENDIF +; +; Otherwise, a numerical column was passed. Check its value. +; + END ELSE ICOL = LONG(COL) - 1 + IF (ICOL LT 0) OR (ICOL GE TFIELDS[ILUN]) THEN BEGIN + MESSAGE = 'COL must be between 1 and ' + $ + STRTRIM(TFIELDS[ILUN],2) + GOTO, HANDLE_ERROR + ENDIF +; +; If there are no elements in the array, then set !ERR to -1. +; + IF N_ELEM[ICOL,ILUN] EQ 0 THEN BEGIN + MESSAGE,'Number of elements to read in is zero',/INFORMATIONAL + !ERR = -1 + RETURN + ENDIF +; +; If ROW was not passed, then set it equal to the entire range. Otherwise, +; extract the range. +; +CHECK_ROW: + IF N_PARAMS() EQ 3 THEN ROW = [1,NAXIS2[ILUN]] + CASE N_ELEMENTS(ROW) OF + 1: ROW2 = LONG(ROW[0]) + 2: ROW2 = LONG(ROW[1]) + ELSE: BEGIN + MESSAGE = 'ROW must have one or two elements' + GOTO, HANDLE_ERROR + END + ENDCASE + ROW1 = LONG(ROW[0]) +; +; If ROW represents a range, then make sure that the row range is legal, and +; that reading row ranges is allowed (i.e., the column is not variable length. +; + IF ROW1 NE ROW2 THEN BEGIN + MAXROW = NAXIS2[ILUN] + IF (ROW1 LT 1) OR (ROW1 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[0] must be between 1 and ' + $ + STRTRIM(MAXROW,2) + GOTO, HANDLE_ERROR + END ELSE IF (ROW2 LT ROW1) OR (ROW2 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[1] must be between ' + $ + STRTRIM(ROW1,2) + ' and ' + STRTRIM(MAXROW,2) + GOTO, HANDLE_ERROR + END ELSE IF NOT VIRTUAL THEN IF MAXVAL[ICOL,ILUN] GT 0 THEN $ + BEGIN + MESSAGE = 'Row ranges not allowed for ' + $ + 'variable-length columns' + GOTO, HANDLE_ERROR + ENDIF +; +; Otherwise, if ROW is a single number, then just make sure it's valid. +; + END ELSE BEGIN + IF (ROW1 LT 1) OR (ROW1 GT NAXIS2[ILUN]) THEN BEGIN + MESSAGE = 'ROW must be between 1 and ' + $ + STRTRIM(NAXIS2[ILUN],2) + GOTO, HANDLE_ERROR + ENDIF + ENDELSE +; +; If a virtual column, then simply return the value. If necessary, then +; replicate the value the correct number of times. +; + IF VIRTUAL THEN BEGIN + IF ROW1 EQ ROW2 THEN DATA = VALUE ELSE $ + DATA = REPLICATE(VALUE,ROW2-ROW1+1) + RETURN + ENDIF +; +; Find the position of the first byte of the data array in the file. +; + OFFSET = NHEADER[ILUN] + NAXIS1[ILUN]*(ROW1-1) + BYTOFF[ICOL,ILUN] + POINT_LUN,UNIT,OFFSET +; +; If a variable length array, then read in the number of elements, and the +; pointer to the variable length array. Change the pointing. +; + IF MAXVAL[ICOL,ILUN] GT 0 THEN BEGIN + POINTER = LONARR(2) + READU,UNIT,POINTER + BYTEORDER, POINTER, /NTOHL + DIMS = POINTER[0] + POINT_LUN,UNIT,NHEADER[ILUN] + HEAP[ILUN] + POINTER[1] +; +; If there are no elements in the array, then set !ERR to -1. +; + IF DIMS EQ 0 THEN BEGIN + MESSAGE,'Number of elements to read in is zero', $ + /INFORMATIONAL + !ERR = -1 + RETURN + ENDIF +; +; If the datatype is a bit array, then the array is treated as a byte array +; with 1/8 the number of elements. +; + IF FORMAT[ICOL,ILUN] EQ 'X' THEN DIMS = LONG((DIMS+7)/8) +; +; If fixed length, then get the dimensions of the output array. +; + END ELSE BEGIN + DIMS = N_DIMS[*,ICOL,ILUN] + DIMS = DIMS[1:DIMS[0]] + ENDELSE +; +; If the DIMENSIONS keyword has been passed, then use that instead of the +; dimensions already determined. +; + IF (N_ELEMENTS(DIMS0) GT 0) AND (FORMAT[ICOL,ILUN] NE 'X') $ + THEN BEGIN + IF PRODUCT(DIMS0) GT PRODUCT(DIMS) THEN BEGIN + MESSAGE = 'Requested dimensions exceeds the ' + $ + 'number of elements' + GOTO, HANDLE_ERROR + ENDIF + DIMS = DIMS0 + ENDIF +; +; Read in the data. If a character string array, then read in a byte array. +; + DATATYPE = IDLTYPE[ICOL,ILUN] + IF DATATYPE EQ 7 THEN DATATYPE = 1 +; +; If only reading in a single row, then the pointer should already be set. +; Otherwise, the pointer needs to be set for each row. +; + IF ROW1 EQ ROW2 THEN BEGIN + DATA = MAKE_ARRAY(TYPE=DATATYPE,DIMENSION=DIMS) + DATA = REFORM(DATA,DIMS,/OVERWRITE) + READU,UNIT,DATA + END ELSE BEGIN + DIMS2 = [DIMS, ROW2-ROW1+1] + DATA = MAKE_ARRAY(TYPE=DATATYPE, DIMENSION=DIMS2) + DATA = REFORM(DATA, DIMS2, /OVERWRITE) + TEMPDATA = MAKE_ARRAY(TYPE=DATATYPE, DIMENSION=DIMS) + TEMPDATA = REFORM(TEMPDATA, DIMS, /OVERWRITE) + NTEMP = N_ELEMENTS(TEMPDATA) + FOR IROW = ROW1,ROW2 DO BEGIN + OFFSET = NHEADER[ILUN] + BYTOFF[ICOL,ILUN] + POINT_LUN,UNIT,OFFSET + NAXIS1[ILUN]*(IROW-1) + READU,UNIT,TEMPDATA + DATA[(IROW-ROW1)*NTEMP] = TEMPDATA[*] + ENDFOR + ENDELSE +; +; If a character string array, then convert to type string. +; + IF IDLTYPE[ICOL,ILUN] EQ 7 THEN BEGIN + DATA = STRING(DATA) + COUNT = 0 +; +; Otherwise, if necessary, then convert the data to the native format of the +; host machine. Also, if NANVALUE is passed, then keep track of any IEEE NaN +; values. +; + END ELSE IF IDLTYPE[ICOL,ILUN] NE 1 THEN BEGIN + IF (N_ELEMENTS(NANVALUE) EQ 1) AND (IDLTYPE[ICOL,ILUN] GE 4) $ + AND (IDLTYPE[ICOL,ILUN] LE 6) THEN $ + W = WHERENAN(DATA,COUNT) ELSE COUNT = 0 + IF NOT KEYWORD_SET(NOIEEE) THEN $ + SWAP_ENDIAN_INPLACE,DATA,/SWAP_IF_LITTLE + END ELSE COUNT = 0 +; +; If DIMS is simply the number 1, then convert DATA either to a scalar or to a +; simple vector, depending on how many rows were read in. +; + IF (N_ELEMENTS(DIMS) EQ 1) AND (DIMS[0] EQ 1) THEN BEGIN + IF N_ELEMENTS(DATA) EQ 1 THEN DATA = DATA[0] ELSE $ + DATA = REFORM(DATA,ROW2-ROW1+1,/OVERWRITE) + ENDIF +; +; If the parameters TZERO and TSCAL are non-trivial, then adjust the array by +; these values. +; + IF NOT KEYWORD_SET(NOSCALE) AND NOT KEYWORD_SET(NOIEEE) THEN BEGIN + BZERO = TZERO[ICOL,ILUN] + BSCALE = TSCAL[ICOL,ILUN] + IF (BSCALE NE 0) AND (BSCALE NE 1) THEN DATA *= BSCALE + IF BZERO NE 0 THEN DATA += BZERO + ENDIF +; +; Store NANVALUE everywhere where the data corresponded to IEE NaN. +; + IF COUNT GT 0 THEN DATA[W] = NANVALUE +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN +; +; I/O error handling point. +; +HANDLE_IO_ERROR: + MESSAGE = 'I/O error reading file' +; +; Error handling point. +; +HANDLE_ERROR: + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = MESSAGE ELSE MESSAGE, MESSAGE + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbreadm.pro b/modules/idl_downloads/astro/pro/fxbreadm.pro new file mode 100644 index 0000000..cf70a8d --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbreadm.pro @@ -0,0 +1,905 @@ +;+ +; NAME: +; FXBREADM +; PURPOSE: +; Read multiple columns/rows from a disk FITS binary table file. +; EXPLANATION : +; A call to FXBREADM will read data from multiple rows and +; multiple columns in a single procedure call. Up to forty-nine +; columns may be read in a single pass; the number of rows is +; limited essentially by available memory. The file should have +; already been opened with FXBOPEN. FXBREADM optimizes reading +; multiple columns by first reading a large chunk of data from +; the FITS file directly, and then slicing the data into columns +; within memory. FXBREADM can read variable-length arrays (see +; below). +; +; The number of columns is limited to 49 if data are passed by +; positional argument. However, this limitation can be overcome +; by having FXBREADM return the data in an array of pointers. +; The user should set the PASS_METHOD keyword to 'POINTER', and an +; array of pointers to the data will be returned in the POINTERS keyword. +; The user is responsible for freeing the pointers; however, +; FXBREADM will reuse any pointers passed into the procedure, and +; hence any pointed-to data will be destroyed. +; +; FXBREADM can also read variable-length columns from FITS +; binary tables. Since such data is not of a fixed size, it is +; returned as a structure. The structure has the following +; elements: +; +; VARICOL: ;; Flag: variable length column (= 1) +; N_ELEMENTS: ;; Total number of elements returned +; TYPE: ;; IDL data type code (integer) +; N_ROWS: ;; Number of rows read from table (integer) +; INDICES: ;; Indices of each row's data (integer array) +; DATA: ;; Raw data elements (variable type array) +; +; In order to gain access to the Ith row's data, one should +; examine DATA(INDICES(I):INDICES(I+1)-1), which is similar in +; construct to the REVERSE_INDICES keyword of the HISTOGRAM +; function. +; +; CALLING SEQUENCE: +; FXBREADM, UNIT, COL, DATA1, [ DATA2, ... DATA48, ROW=, BUFFERSIZE = ] +; /NOIEEE, /NOSCALE, /VIRTUAL, NANVALUE=, PASS_METHOD = POINTERS=, +; ERRMSG = , WARNMSG = , STATUS = , /DEFAULT_FLOAT] +; +; INPUT PARAMETERS : +; UNIT = Logical unit number corresponding to the file containing the +; binary table. +; COL = An array of columns in the binary table to read data +; from, either as character strings containing column +; labels (TTYPE), or as numerical column indices +; starting from column one. +; Outputs : +; DATA1, DATA2...DATA48 = A named variable to accept the data values, one +; for each column. The columns are stored in order of the +; list in COL. If the read operation fails for a +; particular column, then the corresponding output Dn +; variable is not altered. See the STATUS keyword. +; Ignored if PASS_METHOD is 'POINTER'. +; +; OPTIONAL INPUT KEYWORDS: +; ROW = Either row number in the binary table to read data from, +; starting from row one, or a two element array containing a +; range of row numbers to read. If not passed, then the entire +; column is read in. +; /DEFAULT_FLOAT = If set, then scaling with TSCAL/TZERO is done with +; floating point rather than double precision. +; /NOIEEE = If set, then then IEEE floating point data will not +; be converted to the host floating point format (and +; this by definition implies NOSCALE). The user is +; responsible for their own floating point conversion. +; /NOSCALE = If set, then the output data will not be scaled using the +; optional TSCAL and TZERO keywords in the FITS header. +; Default is to scale. +; VIRTUAL = If set, and COL is passed as a name rather than a number, +; then if the program can't find a column with that name, it +; will then look for a keyword with that name in the header. +; Such a keyword would then act as a "virtual column", with the +; same value for every row. +; DIMENSIONS = FXBREADM ignores this keyword. It is here for +; compatibility only. +; NANVALUE= Value signalling data dropout. All points corresponding to +; IEEE NaN (not-a-number) are converted to this number. +; Ignored unless DATA is of type float, double-precision or +; complex. +; PASS_METHOD = A scalar string indicating method of passing +; data from FXBREADM. Either 'ARGUMENT' (indicating +; pass by positional argument), or 'POINTER' (indicating +; passing an array of pointers by the POINTERS +; keyword). +; Default: 'ARGUMENT' +; POINTERS = If PASS_METHOD is 'POINTER' then an array of IDL +; pointers is returned in this keyword, one for each +; requested column. Any pointers passed into FXBREADM will +; have their pointed-to data destroyed. Ultimately the +; user is responsible for deallocating pointers. +; BUFFERSIZE = Raw data are transferred from the file in chunks +; to conserve memory. This is the size in bytes of +; each chunk. If a value of zero is given, then all +; of the data are transferred in one pass. Default is +; 32768 (32 kB). +; OPTIONAL OUTPUT KEYWORDS: +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBREAD, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; WARNMSG = Messages which are considered to be non-fatal +; "warnings" are returned in this output string. +; Note that if some but not all columns are +; unreadable, this is considered to be non-fatal. +; STATUS = An output array containing the status for each +; column read, 1 meaning success and 0 meaning failure. +; +; Calls : +; FXPAR(), WHERENAN() +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The binary table file must have been opened with FXBOPEN. +; +; The data must be consistent with the column definition in the binary +; table header. +; +; The row number must be consistent with the number of rows stored in the +; binary table header. +; +; Generally speaking, FXBREADM will be faster than iterative +; calls to FXBREAD when (a) a large number of columns is to be +; read or (b) the size in bytes of each cell is small, so that +; the overhead of the FOR loop in FXBREAD becomes significant. +; +; SIDE EFFECTS: +; If there are no elements to read in (the number of elements is zero), +; then the program sets !ERR to -1, and DATA is unmodified. +; +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; C. Markwardt, based in concept on FXBREAD version 12 from +; IDLASTRO, but with significant and +; major changes to accommodate the +; multiple row/column technique. Mostly +; the parameter checking and general data +; flow remain. +; C. Markwardt, updated to read variable length arrays, and to +; pass columns by handle or pointer. +; 20 Jun 2001 +; C. Markwardt, try to conserve memory when creating the arrays +; 13 Oct 2001 +; Handle case of GE 50 columns, C. Markwardt, 18 Apr 2002 +; Handle case where TSCAL/TZERO changes type of column, +; C. Markwardt, 23 Feb 2003 +; Fix bug in handling of FOUND and numeric columns, +; C. Markwardt 12 May 2003 +; Removed pre-V5.0 HANDLE options W. Landsman July 2004 +; Fix bug when HANDLE options were removed, July 2004 +; Handle special cases of TSCAL/TZERO which emulate unsigned +; integers, Oct 2003 +; Add DEFAULT_FLOAT keyword to select float values instead of double +; for TSCAL'ed, June 2004 +; Read 64bit integer columns, E. Hivon, Mar 2008 +; Add support for columns with TNULLn keywords, C. Markwardt, Apr 2010 +; Add support for files larger than 2 GB, C. Markwardt, 2012-04-17 +; Use V6 notation, remove IEEE_TO_HOST W. Landsman Mar 2014 +; +;- +; + + +;; This is a utility routine which converts the data from raw bytes to +;; IDL variables. +PRO FXBREADM_CONV, BB, DD, CTYPE, PERROW, NROWS, $ + NOIEEE=NOIEEE, NOSCALE=NOSCALE, VARICOL=VARICOL, $ + NANVALUE=NANVALUE, TZERO=TZERO, TSCAL=TSCAL, $ + TNULL_VALUE=TNULL, TNULL_FLAG=TNULLQ, $ + DEFAULT_FLOAT=DF + + COMMON FXBREADM_CONV_COMMON, DTYPENAMES + IF N_ELEMENTS(DTYPENAMES) EQ 0 THEN $ + DTYPENAMES = [ '__BAD', 'BYTE', 'FIX', 'LONG', $ + 'FLOAT', 'DOUBLE', 'COMPLEX', 'STRING', $ + '__BAD', 'DCOMPLEX', '__BAD', '__BAD', '__BAD', '__BAD', 'LONG64' ] + + TYPENAME = DTYPENAMES[CTYPE] + + IF CTYPE EQ 7 THEN BEGIN + DD = STRING(TEMPORARY(BB)) + ENDIF ELSE BEGIN + DD = CALL_FUNCTION(TYPENAME, TEMPORARY(BB), 0, PERROW*NROWS) + ENDELSE + IF N_ELEMENTS(DD) EQ 1 THEN DD = [DD] + DD = REFORM(DD, PERROW, NROWS, /OVERWRITE) + + ;; Now perform any type-specific conversions, etc. + COUNT = 0L + CASE 1 OF + ;; Integer types + (CTYPE EQ 2 || CTYPE EQ 3 || ctype eq 14): BEGIN + IF ~KEYWORD_SET(NOIEEE) || KEYWORD_SET(VARICOL) THEN $ + SWAP_ENDIAN_INPLACE, DD, /SWAP_IF_LITTLE + ;; Check for TNULL values + ;; We will convert to NAN values later (or if the user + ;; requested a different value we will use that) + IF KEYWORD_SET(TNULLQ) THEN BEGIN + W = WHERE(DD EQ TNULL,COUNT) + IF N_ELEMENTS(NANVALUE) EQ 0 THEN NANVALUE = !VALUES.D_NAN + ENDIF + END + + ;; Floating and complex types + (CTYPE GE 4 || CTYPE LE 6 || CTYPE EQ 9): BEGIN + IF ~KEYWORD_SET(NOIEEE) THEN BEGIN + IF N_ELEMENTS(NANVALUE) GT 0 THEN W=WHERENAN(DD,COUNT) + SWAP_ENDIAN_INPLACE, DD, /SWAP_IF_LITTLE + ENDIF + END + + ;; String types (CTYPE EQ 7) have already been converted + ;; in the above CALL_FUNCTION. No further conversion + ;; is necessary here. + ENDCASE + +; +; If the parameters TZERO and TSCAL are non-trivial, then adjust the array by +; these values. +; + IF ((~KEYWORD_SET(NOIEEE) && ~KEYWORD_SET(NOSCALE)) && $ + (~KEYWORD_SET(VARICOL)) && $ + (N_ELEMENTS(TZERO) EQ 1 && N_ELEMENTS(TSCAL) EQ 1)) THEN BEGIN + + IF KEYWORD_SET(DF) THEN BEGIN + ;; Default to float + TSCAL = FLOAT(TSCAL) + TZERO = FLOAT(TZERO) + ENDIF + + IF CTYPE EQ 2 AND TSCAL[0] EQ 1 AND TZERO[0] EQ 32768 THEN BEGIN + ;; SPECIAL CASE: Unsigned 16-bit integer + DD = UINT(DD) - UINT(32768) + ENDIF ELSE IF CTYPE EQ 3 AND TSCAL[0] EQ 1 AND $ + TZERO[0] EQ 2147483648D THEN BEGIN + ;; SPECIAL CASE: Unsigned 32-bit integer + DD = ULONG(DD) - ULONG(2147483648) + ENDIF ELSE BEGIN + IF (TSCAL[0] NE 0) && (TSCAL[0] NE 1) THEN DD = TSCAL[0]*DD + IF TZERO[0] NE 0 THEN DD = DD + TZERO[0] + ENDELSE + ENDIF + +; +; Store NANVALUE everywhere where the data corresponded to IEEE NaN. +; + IF COUNT GT 0 && N_ELEMENTS(NANVALUE) GT 0 THEN DD[W] = NANVALUE + +END + +PRO FXBREADM, UNIT, COL, $ + D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, $ + D10, D11, D12, D13, D14, D15, D16, D17, D18, D19, $ + D20, D21, D22, D23, D24, D25, D26, D27, D28, D29, $ + D30, D31, D32, D33, D34, D35, D36, D37, D38, D39, $ + D40, D41, D42, D43, D44, D45, D46, D47, $ + ROW=ROW, VIRTUAL=VIR, DIMENSIONS=DIM, $ + NOSCALE=NOSCALE, NOIEEE=NOIEEE, DEFAULT_FLOAT=DEFAULT_FLOAT, $ + PASS_METHOD=PASS_METHOD, POINTERS=POINTERS, $ + NANVALUE=NANVALUE, BUFFERSIZE=BUFFERSIZE, $ + ERRMSG=ERRMSG, WARNMSG=WARNMSG, STATUS=OUTSTATUS + +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 2 THEN BEGIN + MESSAGE = 'Syntax: FXBREADM, UNIT, COL, D0, D1, ... [, ROW= ]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_ELEMENTS(BUFFERSIZE) EQ 0 THEN BUFFERSIZE = 32768L + +; +; COL may be one of several descriptors: +; * a list of column numbers, beginning with 1 +; * a list of column names +; + MYCOL = [ COL ] ; Make sure it is an array + + SC = SIZE(MYCOL) + NUMCOLS = N_ELEMENTS(MYCOL) + OUTSTATUS = LONARR(NUMCOLS) + COLNAMES = 'D'+STRTRIM(LINDGEN(NUMCOLS),2) + +; +; Determine whether the data is to be extracted as pointers or arguments +; + IF N_ELEMENTS(PASS_METHOD) EQ 0 THEN PASS_METHOD = 'ARGUMENT' + PASS = STRUPCASE(STRTRIM(PASS_METHOD[0],2)) + IF PASS NE 'ARGUMENT' AND PASS NE 'POINTER' THEN BEGIN + MESSAGE = 'ERROR: PASS_METHOD must be ARGUMENT or POINTER' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + NP = N_ELEMENTS(POINTERS) + IF PASS EQ 'POINTER' THEN BEGIN + IF NP EQ 0 THEN POINTERS = PTRARR(NUMCOLS, /ALLOCATE_HEAP) + NP = N_ELEMENTS(POINTERS) + SZ = SIZE(POINTERS) + IF SZ[SZ[0]+1] NE 10 THEN BEGIN + MESSAGE = 'ERROR: POINTERS must be an array of pointers' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Expand the pointer array if necessary +; + IF NP LT NUMCOLS THEN $ + POINTERS = [POINTERS[*], PTRARR(NUMCOLS-NP, /ALLOCATE_HEAP)] + NP = N_ELEMENTS(POINTERS) + +; +; Make sure there are no null pointers, which cannot be assigned to. +; + WH = WHERE(PTR_VALID(POINTERS) EQ 0, CT) + IF CT GT 0 THEN POINTERS[WH] = PTRARR(CT, /ALLOCATE_HEAP) + + ENDIF + + +; +; Find the logical unit number in the FXBINTABLE common block. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Check the number of columns. It should be fewer than 49 +; + IF PASS EQ 'ARGUMENT' THEN BEGIN + IF NUMCOLS GT 49 THEN BEGIN + MESSAGE = 'Maximum of 49 columns exceeded' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_PARAMS()-2 LT NUMCOLS AND N_ELEMENTS(ERRMSG) EQ 0 THEN BEGIN + MESSAGE, 'WARNING: number of data parameters less than columns', $ + /INFO + ENDIF + ENDIF + + ICOL = LONARR(NUMCOLS) + VIRTUAL = BYTARR(NUMCOLS) + VIRTYPE = LONARR(NUMCOLS) + FOUND = BYTARR(NUMCOLS) + VARICOL = BYTARR(NUMCOLS) + NOTFOUND = '' + NNOTFOUND = 0L + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = '' + +; +; If COL is of type string, then search for a column with that label. +; + IF SC[SC[0]+1] EQ 7 THEN BEGIN + MYCOL = STRUPCASE(STRTRIM(MYCOL,2)) + FOR I = 0, NUMCOLS-1 DO BEGIN + XCOL = WHERE(TTYPE[*,ILUN] EQ MYCOL[I], NCOL) + ICOL[I] = XCOL[0] +; +; If the column was not found, and VIRTUAL was set, then search for a keyword +; by that name. +; + IF NCOL GT 0 THEN FOUND[I] = 1 + IF NOT FOUND[I] AND KEYWORD_SET(VIR) THEN BEGIN + HEADER = HEAD[*,ILUN] + VALUE = FXPAR(HEADER,MYCOL[I], Count = N_VALUE) + IF N_VALUE GE 0 THEN BEGIN + RESULT = EXECUTE(COLNAMES[I]+' = VALUE') + SV = SIZE(VALUE) + VIRTYPE[I] = SV[SV[0]+1] + VIRTUAL[I] = 1 + FOUND[I] = 1 + ENDIF + ENDIF ELSE IF ~FOUND[I] THEN BEGIN + IF NOTFOUND EQ '' THEN NOTFOUND = MYCOL[I] $ + ELSE NOTFOUND = NOTFOUND +', ' + MYCOL[I] + NNOTFOUND++ + ENDIF + + ENDFOR + + IF NNOTFOUND EQ NUMCOLS THEN BEGIN + MESSAGE = 'ERROR: None of the requested columns were found' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF ELSE IF NNOTFOUND GT 0 THEN BEGIN + MESSAGE = 'WARNING: Columns ' + NOTFOUND + ' were not found' + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = MESSAGE $ + ELSE MESSAGE, MESSAGE, /INFO + ENDIF + +; +; Otherwise, a numerical column was passed. Check its value. +; + ENDIF ELSE BEGIN + ICOL[*] = LONG(MYCOL) - 1 + FOUND[*] = 1 + ENDELSE + +; Step through each column index + MESSAGE = '' + FOR I = 0, NUMCOLS-1 DO BEGIN + IF ~FOUND[I] THEN GOTO, LOOP_END_COLCHECK + IF VIRTUAL[I] THEN GOTO, LOOP_END_COLCHECK + + IF (ICOL[I] LT 0) OR (ICOL[I] GE TFIELDS[ILUN]) THEN BEGIN + MESSAGE = MESSAGE + '; COL "'+STRTRIM(MYCOL[I],2)+$ + '" must be between 1 and ' + $ + STRTRIM(TFIELDS[ILUN],2) + FOUND[I] = 0 + ENDIF +; +; If there are no elements in the array, then set !ERR to -1. +; + IF FOUND[I] AND N_ELEM[ICOL[I],ILUN] EQ 0 THEN BEGIN + FOUND[I] = 0 + MESSAGE = MESSAGE + '; Number of elements to read in "'+$ + STRTRIM(MYCOL[I],2)+'" is zero' +; !ERR = -1 +; RETURN + ENDIF + +; +; Flag variable-length columns +; + IF MAXVAL[ICOL[I],ILUN] GT 0 THEN BEGIN + FOUND[I] = 1 + VARICOL[I] = 1 + ENDIF + + LOOP_END_COLCHECK: + + ENDFOR + +; +; Check to be sure that there are columns to be read +; + W = WHERE(FOUND EQ 1, COUNT) + WV = WHERE(FOUND EQ 1 OR VARICOL EQ 1, WVCOUNT) + IF WVCOUNT EQ 0 THEN BEGIN + STRPUT, MESSAGE, ':', 0 + MESSAGE = 'ERROR: No requested columns could be read'+MESSAGE + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF ELSE IF MESSAGE NE '' THEN BEGIN + STRPUT, MESSAGE, ':', 0 + MESSAGE = 'WARNING: Some columns could not be read'+MESSAGE + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = MESSAGE $ + ELSE MESSAGE, MESSAGE, /INFO + ENDIF + +; +; If ROW was not passed, then set it equal to the entire range. Otherwise, +; extract the range. +; + IF N_ELEMENTS(ROW) EQ 0 THEN ROW = [1LL, NAXIS2[ILUN]] + CASE N_ELEMENTS(ROW) OF + 1: ROW2 = LONG64(ROW[0]) + 2: ROW2 = LONG64(ROW[1]) + ELSE: BEGIN + MESSAGE = 'ROW must have one or two elements' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + ENDCASE + ROW1 = LONG64(ROW[0]) +; +; If ROW represents a range, then make sure that the row range is legal, and +; that reading row ranges is allowed (i.e., the column is not variable length. +; + IF ROW1 NE ROW2 THEN BEGIN + MAXROW = NAXIS2[ILUN] + IF (ROW1 LT 1) OR (ROW1 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[0] must be between 1 and ' + $ + STRTRIM(MAXROW,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF (ROW2 LT ROW1) OR (ROW2 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[1] must be between ' + $ + STRTRIM(ROW1,2) + ' and ' + STRTRIM(MAXROW,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Otherwise, if ROW is a single number, then just make sure it's valid. +; + END ELSE BEGIN + IF (ROW1 LT 1) OR (ROW1 GT NAXIS2[ILUN]) THEN BEGIN + MESSAGE = 'ROW must be between 1 and ' + $ + STRTRIM(NAXIS2[ILUN],2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDELSE + +; +; Compose information about the output +; + HEADER = HEAD[*,ILUN] + COLNDIM = LONARR(NUMCOLS) + COLDIM = LONARR(NUMCOLS, 20) ;; Maximum of 20 dimensions in output + COLTYPE = LONARR(NUMCOLS) + BOFF1 = LONARR(NUMCOLS) + BOFF2 = LONARR(NUMCOLS) + TNULL_FLG = INTARR(NUMCOLS) ;; 1 if TNULLn column is present + TNULL_VAL = DBLARR(NUMCOLS) ;; value of TNULLn column if present + NROWS = ROW2-ROW1+1 + FOR I = 0L, NUMCOLS-1 DO BEGIN + + IF ~FOUND[I] THEN GOTO, LOOP_END_DIMS + ;; Data type of the input. + IF VIRTUAL[I] THEN BEGIN + ; Virtual column: read from keyword itself + COLTYPE[I] = VIRTYPE[I] + GOTO, LOOP_END_DIMS + ENDIF ELSE IF VARICOL[I] THEN BEGIN + ; Variable length column: 2-element long + COLTYPE[I] = 3 + DIMS = [1L, 2L] + ENDIF ELSE BEGIN + COLTYPE[I] = IDLTYPE[ICOL[I],ILUN] + DIMS = N_DIMS[*,ICOL[I],ILUN] + ENDELSE + + NDIMS = DIMS[0] + DIMS = DIMS[1:NDIMS] + + IF NDIMS EQ 1 AND DIMS[0] EQ 1 THEN BEGIN + + ;; Case of only one output element, try to return a + ;; scalar. Otherwise, it is a vector equal to the + ;; number of rows to be read + + COLNDIM[I] = 1L + COLDIM[I,0] = NROWS + ENDIF ELSE BEGIN + + COLNDIM[I] = NDIMS + COLDIM[I,0:(NDIMS-1)] = DIMS + IF NROWS GT 1 THEN BEGIN + COLDIM[I,NDIMS] = NROWS + COLNDIM[I]++ + ENDIF + + ENDELSE + + ;; For strings, the number of characters is the first + ;; dimension. This information is useless to us now, + ;; since the STRING() type cast which will appear below + ;; handles the array conversion automatically. + IF COLTYPE[I] EQ 7 THEN BEGIN + IF COLNDIM[I] GT 1 THEN BEGIN + COLDIM[I,0:COLNDIM[I]-2] = COLDIM[I,1:COLNDIM[I]-1] + COLDIM[I,COLNDIM[I]-1] = 0 + COLNDIM[I] = COLNDIM[I] - 1 + ENDIF ELSE BEGIN ;; Case of a single row + COLNDIM[I] = 1L + COLDIM[I,0] = NROWS + ENDELSE + ENDIF + + ;; Byte offsets + BOFF1[I] = BYTOFF[ICOL[I],ILUN] + IF ICOL[I] EQ TFIELDS[ILUN]-1 THEN $ + BOFF2[I] = NAXIS1[ILUN]-1 $ + ELSE $ + BOFF2[I] = BYTOFF[ICOL[I]+1,ILUN]-1 + + ;; TNULLn keywords for integer type columns + IF (COLTYPE[I] GE 1 AND COLTYPE[I] LE 3) OR $ + (COLTYPE[I] GE 12 AND COLTYPE[I] LE 15) THEN BEGIN + TNULLn = 'TNULL'+STRTRIM(ICOL[I]+1,2) + VALUE = FXPAR(HEADER,TNULLn, Count = N_VALUE) + IF N_VALUE GT 0 THEN BEGIN + TNULL_FLG[I] = 1 + TNULL_VAL[I] = VALUE + ENDIF + ENDIF + + LOOP_END_DIMS: + + ENDFOR + +; +; Construct any virtual columns first +; + WC = WHERE(FOUND EQ 1 AND VIRTUAL EQ 1, WCCOUNT) + FOR I = 0L, WCCOUNT-1 DO BEGIN + ;; If it's virtual, then the value only needs to be + ;; replicated + EXTCMD = COLNAMES[WC[I]]+'= REPLICATE(D'+COLNAMES[WC[I]]+',NROWS)' + ;; Run the command that selects the data + RESULT = EXECUTE(EXTCMD) + IF RESULT EQ 0 THEN BEGIN + MESSAGE = 'ERROR: Could not extract data (column '+$ + STRTRIM(MYCOL[WC[I]],2)+')' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + ENDIF ELSE MESSAGE, MESSAGE + ENDIF + OUTSTATUS[I] = 1 + ENDFOR + + +; Skip to processing variable-length columns if all other columns are virtual + WC = WHERE(FOUND EQ 1 AND VIRTUAL EQ 0, WCCOUNT) + IF WCCOUNT EQ 0 THEN GOTO, PROC_CLEANUP + +; Create NANVALUES, the template to use when a NAN is found + IF N_ELEMENTS(NANVALUE) GE NUMCOLS THEN BEGIN + NANVALUES = NANVALUE[0:NUMCOLS-1] + ENDIF ELSE IF N_ELEMENTS(NANVALUE) GT 0 THEN BEGIN + NANVALUES = REPLICATE(NANVALUE[0], NUMCOLS) + NANVALUES[0] = NANVALUE + I = N_ELEMENTS(NANVALUE) + IF I LT NUMCOLS THEN $ + NANVALUES[I:*] = NANVALUE[0] + ENDIF + +; +; Find the position of the first byte of the data array in the file. +; + OFFSET0 = NHEADER[ILUN] + NAXIS1[ILUN]*(ROW1-1LL) + POS = 0LL + NROWS0 = NROWS + J = 0LL + FIRST = 1 + ;; Here, we constrain the buffer to be at least 16 rows long. + ;; If we fill up 32 kB with fewer than 16 rows, then there + ;; must be a lot of (big) columns in this table. It's + ;; probably a candidate for using FXBREAD instead. + BUFFROWS = LONG((BUFFERSIZE/NAXIS1[ILUN]) > 16L) + IF BUFFERSIZE LE 0 THEN BUFFROWS = NROWS0 + +; +; Loop through the data in chunks +; + WHILE NROWS GT 0 DO BEGIN + J++ + NR = NROWS < BUFFROWS + OFFSET1 = NAXIS1[ILUN]*POS + +; +; Proceed by reading a byte array from the input data file +; FXBREADM reads all columns from the specified rows, and +; sorts out the details of which bytes belong to which columns +; in the next FOR loop. +; + BB = BYTARR(NAXIS1[ILUN], NR) + POINT_LUN, UNIT, OFFSET0+OFFSET1 + READU, UNIT, BB +; FXGSEEK, UNIT, OFFSET0+OFFSET1 +; FXGREAD, UNIT, BB + +; +; Now select out the desired columns +; + FOR I = 0, NUMCOLS-1 DO BEGIN + + ;; Extract the proper rows and columns + IF ~FOUND[I] THEN GOTO, LOOP_END_STORE + IF VIRTUAL[I] THEN GOTO, LOOP_END_STORE + + ;; Extract the data from the byte array and convert it + ;; The inner CALL_FUNCTION is to one of the coercion + ;; functions, such as FIX(), DOUBLE(), STRING(), etc., + ;; which is called with an offset to force a conversion + ;; from bytes to the data type. + ;; The outer CALL_FUNCTION is to REFORM(), which makes + ;; sure that the data structure is correct. + ;; + DIMS = COLDIM[I,0:COLNDIM[I]-1] + PERROW = ROUND(PRODUCT(DIMS)/NROWS0) + + IF N_ELEMENTS(NANVALUES) GT 0 THEN $ + EXTRA={NANVALUE: NANVALUES[I]} + + FXBREADM_CONV, BB[BOFF1[I]:BOFF2[I], *], DD, COLTYPE[I], PERROW, NR,$ + NOIEEE=KEYWORD_SET(NOIEEE), NOSCALE=KEYWORD_SET(NOSCALE), $ + TZERO=TZERO[ICOL[I], ILUN], TSCAL=TSCAL[ICOL[I], ILUN], $ + VARICOL=VARICOL[I], DEFAULT_FLOAT=DEFAULT_FLOAT, $ + TNULL_VALUE=TNULL_VAL[I], TNULL_FLAG=TNULL_FLG[I], $ + _EXTRA=EXTRA + + ;; Initialize the output variable on the first chunk + IF FIRST THEN BEGIN + SZ = SIZE(DD) + ;; NOTE: type could have changed if TSCAL/TZERO were used + COLTYPEI = SZ(SZ[0]+1) + RESULT = EXECUTE(COLNAMES[I]+' = 0') + RESULT = EXECUTE(COLNAMES[I]+' = '+$ + 'MAKE_ARRAY(PERROW, NROWS0, TYPE=COLTYPEI)') + RESULT = EXECUTE(COLNAMES[I]+' = '+$ + 'REFORM('+COLNAMES[I]+', PERROW, NROWS0,/OVERWRITE)') + ENDIF + + ;; Finally, store this in the output variable + RESULT = EXECUTE(COLNAMES[I]+'[0,POS] = DD') + DD = 0 + IF RESULT EQ 0 THEN BEGIN + MESSAGE = 'ERROR: Could not compose output data '+COLNAMES[I] + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + ENDIF ELSE MESSAGE, MESSAGE + ENDIF + + OUTSTATUS[I] = 1 + + LOOP_END_STORE: + ENDFOR + + FIRST = 0 + NROWS = NROWS - NR + POS = POS + NR + ENDWHILE + +; +; Read the variable-length columns from the heap. Adjacent data are +; coalesced into one read operation. Note: this technique is thus +; optimal for extensions with only one variable-length column. If +; there are more than one then coalescence will not occur. +; + + ;; Width of the various data types in bytes + WIDARR = [0L, 1L, 2L, 4L, 4L, 8L, 8L, 1L, 0L,16L, 0L] + WV = WHERE(OUTSTATUS EQ 1 AND VARICOL EQ 1, WVCOUNT) + FOR J = 0, WVCOUNT-1 DO BEGIN + I = WV[J] + RESULT = EXECUTE('PDATA = '+COLNAMES[I]) + NVALS = PDATA[0,*] ;; Number of values in each row + NTOT = ROUND(TOTAL(NVALS)) ;; Total number of values + IF NTOT EQ 0 THEN BEGIN + DD = {N_ELEMENTS: 0L, N_ROWS: NROWS0, $ + INDICES: LON64ARR(NROWS0+1), DATA: 0L} + GOTO, FILL_VARICOL + ENDIF + + ;; Compute the width in bytes of the data value + TYPE = IDLTYPE[ICOL[I], ILUN] + WID = LONG64(WIDARR[TYPE < 10]) + IF WID EQ 0 THEN BEGIN + OUTSTATUS[I] = 0 + MESSAGE = 'ERROR: Column '+COLNAMES[I]+' has unknown data type' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + ;; Coalesce the data pointers + BOFF1 = LONG64(PDATA[1,*]) + BOFF2 = BOFF1 + NVALS*WID + WH = WHERE(BOFF1[1:*] NE BOFF2, CT) + IF CT GT 0 THEN BI = [-1LL, WH, N_ELEMENTS(BOFF1)-1] $ + ELSE BI = [-1LL, N_ELEMENTS(BOFF1)-1] + CT = CT + 1 + + ;; Create the output array + BC = BOFF2[BI[1:*]] - BOFF1[BI[0:CT-1]+1] ;; Byte count + NB = ROUND(TOTAL(BC)) ;; Total # bytes + BB = BYTARR(NB) ;; Byte array + + ;; Initialize the counter variables used in the read-loop + CC = 0LL & CC1 = 0LL & K = 0LL + BUFFROWS = ROUND(BUFFERSIZE/WID) > 128L + BASE = LONG64(NHEADER[ILUN]+HEAP[ILUN]) + + ;; Read data from file + WHILE CC LT NB DO BEGIN + NB1 = (BC[K]-CC1) < BUFFROWS + BB1 = BYTARR(NB1) + + POINT_LUN, UNIT, BASE+BOFF1[BI[K]+1]+CC1 + READU, UNIT, BB1 +; FXGSEEK, UNIT, BASE+BOFF1[BI[K]+1]+CC1 +; FXGREAD, UNIT, BB1 + BB[CC] = TEMPORARY(BB1) + + CC = CC + NB1 + CC1 = CC1 + NB1 + IF CC1 EQ BC[K] THEN BEGIN + K = K + 1 + CC1 = 0L + ENDIF + ENDWHILE + + ;; Convert the data + IF N_ELEMENTS(NANVALUES) GT 0 THEN $ + EXTRA={NANVALUE: NANVALUES[I]} + + FXBREADM_CONV, BB, DD, TYPE, NTOT, 1L, $ + NOIEEE=KEYWORD_SET(NOIEEE), NOSCALE=KEYWORD_SET(NOSCALE), $ + TZERO=TZERO[ICOL[I], ILUN], TSCAL=TSCAL[ICOL[I], ILUN], $ + DEFAULT_FLOAT=DEFAULT_FLOAT, _EXTRA=EXTRA + + ;; Ensure the correct dimensions, now that we know them + COLNDIM[I] = 1 + COLDIM[I,0] = NTOT + + ;; Construct the indices; unfortunately we need to make an + ;; accumulant with a FOR loop + INDICES = LON64ARR(NROWS0+1) + FOR K = 1LL, NROWS0 DO $ + INDICES[K] = INDICES[K-1] + NVALS[K-1] + + ;; Construct a structure with additional data + DD = {N_ELEMENTS: NTOT, N_ROWS: NROWS0, TYPE: TYPE, $ + INDICES: INDICES, DATA: TEMPORARY(DD)} + + FILL_VARICOL: + RESULT = EXECUTE(COLNAMES[I] +' = TEMPORARY(DD)') + ENDFOR + +; +; Compose the output columns, which might need reforming +; + FOR I = 0, NUMCOLS-1 DO BEGIN + IF OUTSTATUS[I] NE 1 THEN GOTO, LOOP_END_FINAL + + ;; Extract the dimensions and name of the column data + DIMS = COLDIM[I,0:COLNDIM[I]-1] + NEL = PRODUCT(DIMS) + CNAME = COLNAMES[I] + IF VARICOL[I] THEN CNAME = CNAME + '.DATA' + + ;; Compose the reforming part + IF NEL EQ 1 THEN $ + CMD = CNAME+'[0]' $ + ELSE $ + CMD = 'REFORM(TEMPORARY('+CNAME+'),DIMS,/OVERWRITE)' + + ;; Variable-length columns return extra information + IF VARICOL[I] THEN BEGIN + CMD = ('{VARICOL: 1,'+$ + ' N_ELEMENTS: '+COLNAMES[I]+'.N_ELEMENTS, '+$ + ' TYPE: '+COLNAMES[I]+'.TYPE, '+$ + ' N_ROWS: '+COLNAMES[I]+'.N_ROWS, '+$ + ' INDICES: '+COLNAMES[I]+'.INDICES, '+$ + ' DATA: '+CMD+'}') + ENDIF + + ;; Assign to pointer, or re-assign to column + IF PASS EQ 'ARGUMENT' THEN $ + CMD = COLNAMES[I]+' = ' + CMD $ + ELSE IF PASS EQ 'POINTER' THEN $ + CMD = '*(POINTERS[I]) = ' + CMD + + RESULT = EXECUTE(CMD) + LOOP_END_FINAL: + ENDFOR + + PROC_CLEANUP: +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + + END diff --git a/modules/idl_downloads/astro/pro/fxbstate.pro b/modules/idl_downloads/astro/pro/fxbstate.pro new file mode 100644 index 0000000..b2de469 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbstate.pro @@ -0,0 +1,74 @@ + FUNCTION FXBSTATE, UNIT +;+ +; NAME: +; FXBSTATE() +; +; PURPOSE: +; Returns the state of a FITS binary table. +; +; Explanation : This procedure returns the state of a FITS binary table that +; was either opened for read with the command FXBOPEN, or for +; write with the command FXBCREATE. +; +; Use : Result = FXBSTATE(UNIT) +; +; Inputs : UNIT = Logical unit number returned by FXBOPEN routine. +; Must be a scalar integer. +; +; Opt. Inputs : None. +; +; Outputs : The result of the function is the state of the FITS binary +; table that UNIT points to. This can be one of three values: +; +; 0 = Closed +; 1 = Open for read +; 2 = Open for write +; +; Opt. Outputs: None. +; +; Keywords : None. +; +; Calls : FXBFINDLUN +; +; Common : Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; +; Restrictions: None. +; +; Side effects: If UNIT is an undefined variable, then 0 (closed) is returned. +; +; Category : Data Handling, I/O, FITS, Generic. +; +; Prev. Hist. : None. +; +; Written : William Thompson, GSFC, 1 July 1993. +; +; Modified : Version 1, William Thompson, GSFC, 1 July 1993. +; +; Version : Version 1, 1 July 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() NE 1 THEN MESSAGE,'Syntax: Result = FXBSTATE(UNIT)' +; +; If UNIT is undefined, then return False. +; + IF N_ELEMENTS(UNIT) EQ 0 THEN RETURN, 0 +; +; Check the validity of UNIT. +; + IF N_ELEMENTS(UNIT) GT 1 THEN MESSAGE,'UNIT must be a scalar' + SZ = SIZE(UNIT) + IF SZ[SZ[0]+1] GT 3 THEN MESSAGE,'UNIT must be an integer' +; +; Get the state associated with UNIT. +; + ILUN = FXBFINDLUN(UNIT) + RETURN, STATE[ILUN] +; + END diff --git a/modules/idl_downloads/astro/pro/fxbtdim.pro b/modules/idl_downloads/astro/pro/fxbtdim.pro new file mode 100644 index 0000000..3c116e7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbtdim.pro @@ -0,0 +1,90 @@ + FUNCTION FXBTDIM, TDIM_KEYWORD +;+ +; NAME: +; FXBTDIM() +; Purpose : +; Parse TDIM-like kwywords. +; Explanation : +; Parses the value of a TDIM-like keyword (e.g. TDIMnnn, TDESC, etc.) to +; return the separate elements contained within. +; Use : +; Result = FXBTDIM( TDIM_KEYWORD ) +; Inputs : +; TDIM_KEYWORD = The value of a TDIM-like keyword. Must be a +; character string of the form "(value1,value2,...)". +; If the parentheses characters are missing, then the +; string is simply returned as is, without any further +; processing. +; Opt. Inputs : +; None. +; Outputs : +; The result of the function is a character string array containing the +; values contained within the keyword parameter. If a numerical result +; is desired, then simply call, e.g. +; +; Result = FIX( FXBTDIM( TDIM_KEYWORD )) +; +; Opt. Outputs: +; None. +; Keywords : +; None. +; Calls : +; GETTOK +; Common : +; None. +; Restrictions: +; The input parameter must have the proper format. The separate values +; must not contain the comma character. TDIM_KEYWORD must not be an +; array. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan. 1992. +; William Thompson, Jan. 1993, renamed to be compatible with DOS +; limitations. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version : +; Version 1, 12 April 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR,2 +; +; Make sure TDIM_KEYWORD is not an array. +; + IF N_ELEMENTS(TDIM_KEYWORD) NE 1 THEN MESSAGE, $ + 'TDIM_KEYWORD must be a scalar' +; +; Remove any leading or trailing blanks from the keyword. +; + TDIM = STRTRIM(TDIM_KEYWORD,2) +; +; The first and last characters should be "(" and ")". If they are not, then +; simply return the string as is. +; + FIRST = STRMID(TDIM,0,1) + LAST = STRMID(TDIM,STRLEN(TDIM)-1,1) + IF (FIRST NE "(") OR (LAST NE ")") THEN RETURN,TDIM +; +; Otherwise, remove the parentheses characters. +; + TDIM = STRMID(TDIM,1,STRLEN(TDIM)-2) +; +; Get the first value. +; + VALUE = GETTOK(TDIM,',') +; +; Get all the rest of the values. +; + WHILE TDIM NE '' DO VALUE = [VALUE,GETTOK(TDIM,',')] +; +; Return the (string) array of values. +; + RETURN,VALUE + END diff --git a/modules/idl_downloads/astro/pro/fxbtform.pro b/modules/idl_downloads/astro/pro/fxbtform.pro new file mode 100644 index 0000000..c0e05d5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbtform.pro @@ -0,0 +1,212 @@ + PRO FXBTFORM,HEADER,TBCOL,IDLTYPE,FORMAT,NUMVAL,MAXVAL,ERRMSG=ERRMSG +;+ +; NAME: +; FXBTFORM +; PURPOSE : +; Returns information about FITS binary table columns. +; EXPLANATION : +; Procedure to return information about the format of the various columns +; in a FITS binary table. +; Use : +; FXBTFORM,HEADER,TBCOL,IDLTYPE,FORMAT,NUMVAL,MAXVAL +; Inputs : +; HEADER = Fits binary table header. +; Opt. Inputs : +; None. +; Outputs : +; TBCOL = Array of starting column positions in bytes. +; IDLTYPE = IDL data types of columns. +; FORMAT = Character code defining the data types of the columns. +; NUMVAL = Number of elements of the data arrays in the columns. +; MAXVAL = Maximum number of elements for columns containing variable +; length arrays, or zero otherwise. +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBTFORM, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXPAR +; Common : +; None. +; Restrictions: +; None. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Feb. 1992, from TBINFO by D. Lindler. +; W. Thompson, Jan. 1993, renamed to be compatible with DOS limitations. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, William Thompson, GSFC, 9 April 1997 +; Modified so that variable length arrays can be read, even if +; the maximum array size is not in the header. +; Version 5 Wayne Landsman, GSFC, August 1997 +; Recognize double complex array type if since IDL version 4.0 +; Version 6 Optimized FXPAR call, CM 1999 Nov 18 +; Version 7: Wayne Landsman, GSFC Feb 2006 +; Added support for 64bit integer K format +; Version: +; Version 8: Wayne Landsman GSFC Apr 2010 +; Remove use of obsolete !ERR variable +;- +; + ON_ERROR,2 + COMPILE_OPT IDL2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 1 THEN BEGIN + MESSAGE = 'Syntax: FXBTFORM,HEADER,TBCOL,IDLTYPE,FORMAT,' + $ + 'NUMVAL,MAXVAL' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Get the number of fields. +; + TFIELDS = FXPAR(HEADER,'TFIELDS', START=0L, COUNT=N_TFIELDS) + IF N_TFIELDS LE 0 THEN BEGIN + MESSAGE = 'Invalid FITS header -- keyword TFIELDS is missing' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF TFIELDS EQ 0 THEN BEGIN + MESSAGE = 'FIT binary table has no columns' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Initialize the arrays. +; + WIDTH = INTARR(TFIELDS) + IDLTYPE = INTARR(TFIELDS) + TBCOL = LONARR(TFIELDS) + FORMAT = STRARR(TFIELDS) + NUMVAL = LONARR(TFIELDS) + MAXVAL = LONARR(TFIELDS) +; +; Get the column formats. +; + TFORM = FXPAR(HEADER,'TFORM*', COUNT=N_TFORM) + IF N_TFORM LE 0 THEN BEGIN + MESSAGE = 'Invalid FITS table header -- keyword TFORM ' + $ + 'not present' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + TFORM = STRUPCASE(STRTRIM(TFORM,2)) +; +; Parse the values of the TFORM keywords. +; + LEN = STRLEN(TFORM) + FOR I = 0,N_ELEMENTS(TFORM)-1 DO BEGIN +; +; Step through each character in the format, until a non-numerical character +; is encountered. +; + ICHAR = 0 +NEXT_CHAR: + IF ICHAR GE LEN[I] THEN BEGIN + MESSAGE = 'Invalid format specification for ' + $ + 'keyword TFORM ' + STRTRIM(I+1) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + CHAR = STRUPCASE(STRMID(TFORM[I],ICHAR,1)) + IF ((CHAR GE '0') AND (CHAR LE '9')) THEN BEGIN + ICHAR = ICHAR + 1 + GOTO, NEXT_CHAR + ENDIF +; +; Get the number of elements. +; + IF ICHAR EQ 0 THEN NUMVAL[I] = 1 ELSE $ + NUMVAL[I] = LONG(STRMID(TFORM[I],0,ICHAR)) +; +; If the character is "P" then the next character is the actual data type, +; followed by the maximum number of elements surrounded by quotes. +; + IF CHAR EQ "P" THEN BEGIN + CHAR = STRUPCASE(STRMID(TFORM[I],ICHAR+1,1)) + MAXVAL[I] = LONG(STRMID(TFORM[I],ICHAR+3, $ + LEN[I]-ICHAR-4)) + IF MAXVAL[I] EQ 0 THEN MAXVAL[I] = 1 + ENDIF +; +; Get the IDL data type, and the size of an element. +; + FORMAT[I] = CHAR + CASE CHAR OF + 'L': BEGIN & IDLTYPE[I] = 1 & WIDTH[I] = 1 & END + 'A': BEGIN & IDLTYPE[I] = 7 & WIDTH[I] = 1 & END + 'B': BEGIN & IDLTYPE[I] = 1 & WIDTH[I] = 1 & END + 'I': BEGIN & IDLTYPE[I] = 2 & WIDTH[I] = 2 & END + 'J': BEGIN & IDLTYPE[I] = 3 & WIDTH[I] = 4 & END + 'E': BEGIN & IDLTYPE[I] = 4 & WIDTH[I] = 4 & END + 'D': BEGIN & IDLTYPE[I] = 5 & WIDTH[I] = 8 & END + 'C': BEGIN & IDLTYPE[I] = 6 & WIDTH[I] = 8 & END + 'M': BEGIN & IDLTYPE[I] = 9 & WIDTH[I] =16 & END + 'K': BEGIN & IDLTYPE[I] =14 & WIDTH[I] = 8 & END +; +; +; Treat bit arrays as byte arrays with 1/8 the number of elements. +; + 'X': BEGIN + IDLTYPE[I] = 1 + WIDTH[I] = 1 + IF MAXVAL[I] GT 0 THEN BEGIN + MAXVAL[I] = LONG((MAXVAL[I]+7)/8) + END ELSE BEGIN + NUMVAL[I] = LONG((NUMVAL[I]+7)/8) + ENDELSE + END + + ELSE: BEGIN + MESSAGE = 'Invalid format specification ' + $ + 'for keyword TFORM' + STRTRIM(I+1,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + ENDCASE +; +; Variable length array pointers always take up eight bytes. +; + IF MAXVAL[I] GT 0 THEN WIDTH[I] = 8 +; +; Calculate the starting byte for each column. +; + IF I GE 1 THEN TBCOL[I] = TBCOL[I-1] + WIDTH[I-1]*NUMVAL[I-1] + ENDFOR +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbwrite.pro b/modules/idl_downloads/astro/pro/fxbwrite.pro new file mode 100644 index 0000000..e77abba --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbwrite.pro @@ -0,0 +1,281 @@ + PRO FXBWRITE, UNIT, DATA, COL, ROW, BIT=BIT, NANVALUE=NANVALUE, $ + ERRMSG=ERRMSG +;+ +; NAME: +; FXBWRITE +; Purpose : +; Write a binary data array to a disk FITS binary table file. +; Explanation : +; Each call to FXBWRITE will write to the data file, which should already +; have been created and opened by FXBCREATE. One needs to call this +; routine for every column and every row in the binary table. FXBFINISH +; will then close the file. +; Use : +; FXBWRITE, UNIT, DATA, COL, ROW +; Inputs : +; UNIT = Logical unit number corresponding to the file containing the +; binary table. +; DATA = IDL data array to be written to the file. +; COL = Column in the binary table to place data in, starting from +; column one. +; ROW = Row in the binary table to place data in, starting from row +; one. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; BIT = Number of bits in bit mask arrays (type "X"). Only used if +; the column is of variable size. +; NANVALUE= Value signalling data dropout. All points corresponding to +; this value are set to be IEEE NaN (not-a-number). Ignored +; unless DATA is of type float, double-precision or complex. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBWRITE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; None. +; Common : +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; Restrictions: +; The binary table file must have been opened with FXBCREATE. +; +; The data must be consistent with the column definition in the binary +; table header. +; +; The row number must be consistent with the number of rows stored in the +; binary table header. +; +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Jan 1992, based on WRITEFITS by J. Woffard and W. Landsman. +; W. Thompson, Feb 1992, modified to support variable length arrays. +; W. Thompson, Feb 1992, removed all references to temporary files. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 July 1993. +; Fixed bug with variable length arrays. +; Version 3, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 5, Wayne Landsman, GSFC, 12 Aug 1997 +; Recognize IDL double complex data type +; Version : +; Version 5, 12 August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 4 THEN BEGIN + MESSAGE = 'Syntax: FXBWRITE, UNIT, DATA, COL, ROW' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Find the logical unit number in the FXBINTABLE common block. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE,'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Check the row and column parameters against the header. +; + IF (COL LT 1) OR (COL GT TFIELDS[ILUN]) THEN BEGIN + MESSAGE = 'COL must be between 1 and ' + $ + STRTRIM(TFIELDS[ILUN],2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF (ROW LT 1) OR (ROW GT NAXIS2[ILUN]) THEN BEGIN + MESSAGE = 'ROW must be between 1 and ' + $ + STRTRIM(NAXIS2[ILUN],2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Calculate the row and column parameters using IDL zero-based indexing. +; + IROW = LONG(ROW) - 1 + ICOL = LONG(COL) - 1 +; +; Check the type of the data against that defined for this column. +; + SZ = SIZE(DATA) + TYPE = SZ[SZ[0]+1] + IF TYPE NE IDLTYPE[ICOL,ILUN] THEN BEGIN + CASE IDLTYPE[ICOL,ILUN] OF + 1: STYPE = 'byte' + 2: STYPE = 'short integer' + 3: STYPE = 'long integer' + 4: STYPE = 'floating point' + 5: STYPE = 'double precision' + 6: STYPE = 'complex' + 7: STYPE = 'string' + 9: STYPE = 'double complex' + ENDCASE + MESSAGE = 'Data type should be ' + STYPE + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Check the number of elements, depending on whether or not the column +; contains variable length arrays. +; + IF MAXVAL[ICOL,ILUN] GT 0 THEN BEGIN + IF N_ELEMENTS(DATA) GT MAXVAL[ICOL,ILUN] THEN BEGIN + MESSAGE = 'Data array should have no more than ' + $ + STRTRIM(N_ELEM[ICOL,ILUN],2) + ' elements' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + END ELSE BEGIN + IF N_ELEMENTS(DATA) NE N_ELEM[ICOL,ILUN] THEN BEGIN + MESSAGE = 'Data array should have ' + $ + STRTRIM(N_ELEM[ICOL,ILUN],2) + ' elements' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDELSE +; +; Find the position of the first byte of the data array in the file. +; + OFFSET = NHEADER[ILUN] + NAXIS1[ILUN]*IROW + BYTOFF[ICOL,ILUN] + POINT_LUN,UNIT,OFFSET +; +; If a variable length array, then test to see if the array is of type +; double-precision complex (M) or bit (X). +; + IF MAXVAL[ICOL,ILUN] GT 0 THEN BEGIN + N_ELEM0 = N_ELEMENTS(DATA) + IF FORMAT[ICOL,ILUN] EQ "X" THEN BEGIN + IF N_ELEMENTS(BIT) EQ 0 THEN BEGIN + MESSAGE = 'Number of bits not defined' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF N_ELEMENTS(BIT) NE 1 THEN BEGIN + MESSAGE = 'Number of bits must be a scalar' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF LONG((BIT+7)/8) NE N_ELEM0 THEN BEGIN + MESSAGE = 'Number of bits does not match ' + $ + 'array size' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + N_ELEM0 = BIT + ENDIF +; +; Write out the number of elements, and the pointer to the variable length +; array. +; + POINTER = LONARR(2) + POINTER[0] = N_ELEM0 + POINTER[1] = DHEAP[ILUN] + SWAP_ENDIAN_INPLACE,POINTER,/SWAP_IF_LITTLE + WRITEU,UNIT,POINTER + POINT_LUN,UNIT,NHEADER[ILUN] + HEAP[ILUN] + DHEAP[ILUN] +; +; Update the HEAP pointer. +; + CASE TYPE OF + 1: DDHEAP = N_ELEMENTS(DATA) ;Byte + 2: DDHEAP = N_ELEMENTS(DATA) * 2 ;Short integer + 3: DDHEAP = N_ELEMENTS(DATA) * 4 ;Long integer + 4: DDHEAP = N_ELEMENTS(DATA) * 4 ;Float + 5: DDHEAP = N_ELEMENTS(DATA) * 8 ;Double + 6: DDHEAP = N_ELEMENTS(DATA) * 8 ;Complex + 7: DDHEAP = N_ELEMENTS(DATA) ;String + 9: DDHEAP = N_ELEMENTS(DATA) * 16 ;Dble Complex + ENDCASE + DHEAP[ILUN] = DHEAP[ILUN] + DDHEAP + ENDIF +; +; If a byte array, then simply write out the data. +; + IF TYPE EQ 1 THEN BEGIN + WRITEU,UNIT,DATA +; +; Otherwise, if a character string array, then write out the character strings +; with the correct width, truncating or padding with blanks as necessary. +; However, if a variable length string array, then simply write it out. +; + END ELSE IF TYPE EQ 7 THEN BEGIN + IF MAXVAL[ICOL,ILUN] GT 0 THEN BEGIN + WRITEU,UNIT,DATA + END ELSE BEGIN + N_CHAR = N_DIMS[1,ICOL,ILUN] + NEWDATA = REPLICATE(32B,N_CHAR,N_ELEMENTS(DATA)) + FOR I=0,N_ELEMENTS(DATA)-1 DO $ + NEWDATA[0,I] = BYTE(STRMID(DATA[I],0,N_CHAR)) + WRITEU,UNIT,NEWDATA + ENDELSE +; +; Otherwise, if necessary, then byte-swap the data before writing it out. +; Also, replace any values corresponding data dropout with IEEE NaN. +; + END ELSE BEGIN + IF (N_ELEMENTS(NANVALUE) EQ 1) AND (TYPE GE 4) AND $ + ((TYPE LE 6) OR (TYPE EQ 9)) THEN BEGIN + W = WHERE(DATA EQ NANVALUE, COUNT) + CASE TYPE OF + 4: NAN = FLOAT( REPLICATE('FF'XB,4),0,1) + 5: NAN = DOUBLE( REPLICATE('FF'XB,8),0,1) + 6: NAN = COMPLEX(REPLICATE('FF'XB,8),0,1) + 9: NAN = DCOMPLEX(REPLICATE('FF'XB,16),0,1) + ENDCASE + END ELSE COUNT = 0 +; + NEWDATA = DATA + SWAP_ENDIAN_INPLACE, NEWDATA, /SWAP_IF_LITTLE + IF COUNT GT 0 THEN NEWDATA[W] = NAN + WRITEU,UNIT,NEWDATA + ENDELSE +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxbwritm.pro b/modules/idl_downloads/astro/pro/fxbwritm.pro new file mode 100644 index 0000000..a07f508 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxbwritm.pro @@ -0,0 +1,713 @@ + PRO FXBWRITM, UNIT, COL, $ + D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, $ + D10, D11, D12, D13, D14, D15, D16, D17, D18, D19, $ + D20, D21, D22, D23, D24, D25, D26, D27, D28, D29, $ + D30, D31, D32, D33, D34, D35, D36, D37, D38, D39, $ + D40, D41, D42, D43, D44, D45, D46, D47, D48, D49, $ + NOIEEE=NOIEEE, NOSCALE=NOSCALE, $ + POINTERS=POINTERS, PASS_METHOD=PASS_METHOD, $ + ROW=ROW, NANVALUE=NANVALUE, BUFFERSIZE=BUFFERSIZE, $ + ERRMSG=ERRMSG, WARNMSG=WARNMSG, STATUS=OUTSTATUS +;+ +; NAME: +; FXBWRITM +; PURPOSE: +; Write multiple columns/rows to a disk FITS binary table file. +; EXPLANATION : +; A call to FXBWRITM will write multiple rows and multiple +; columns to a binary table in a single procedure call. Up to +; fifty columns may be read in a single pass. The file should +; have already been opened with FXBOPEN (with write access) or +; FXBCREATE. FXBWRITM optimizes writing multiple columns by +; first writing a large chunk of data to the FITS file all at +; once. FXBWRITM cannot write variable-length arrays; use +; FXBWRITE instead. +; +; The number of columns is limited to 50 if data are passed by +; positional argument. However, this limitation can be overcome +; by passing pointers to FXBWRITM. The user should set the PASS_METHOD +; keyword to 'POINTER' as appropriate, and an array of pointers to +; the data in the POINTERS keyword. The user is responsible for freeing +; the pointers. +; +; CALLING SEQUENCE: +; FXBWRITM, UNIT, COL, D0, D1, D2, ..., [ ROW= , PASS_METHOD, NANVALUE= +; POINTERS=, BUFFERSIZE= ] +; +; INPUT PARAMETERS: +; UNIT = Logical unit number corresponding to the file containing the +; binary table. +; D0,..D49= An IDL data array to be written to the file, one for +; each column. These parameters will be igonred if data +; is passed through the POINTERS keyword. +; COL = Column in the binary table to place data in. May be either +; a list of column numbers where the first column is one, or +; a string list of column names. + +; OPTIONAL INPUT KEYWORDS: +; ROW = Either row number in the binary table to write data to, +; starting from row one, or a two element array containing a +; range of row numbers to write. If not passed, then +; the entire column is written. +; NANVALUE= Value signalling data dropout. All points corresponding to +; this value are set to be IEEE NaN (not-a-number). Ignored +; unless DATA is of type float, double-precision or complex. +; NOSCALE = If set, then TSCAL/TZERO values are ignored, and data is +; written exactly as supplied. +; PASS_METHOD = A scalar string indicating method of passing +; data to FXBWRITM. One of 'ARGUMENT' (indicating +; pass by positional argument), or'POINTER' (indicating +; passing an array of pointers by the POINTERS +; keyword). +; Default: 'ARGUMENT' +; POINTERS = If PASS_METHOD is 'POINTER' then the user must pass +; an array of IDL pointers to this keyword, one for +; each column. Ultimately the user is responsible for +; deallocating pointers. +; BUFFERSIZE = Data are transferred in chunks to conserve +; memory. This is the size in bytes of each chunk. +; If a value of zero is given, then all of the data +; are transferred in one pass. Default is 32768 (32 +; kB). +; OPTIONAL OUTPUT KEYWORDS: +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXBWRITE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; WARNMSG = Messages which are considered to be non-fatal +; "warnings" are returned in this output string. +; STATUS = An output array containing the status for each +; read, 1 meaning success and 0 meaning failure. +; +; PROCEDURE CALLS: +; None. +; EXAMPLE: +; Write a binary table 'sample.fits' giving 43 X,Y positions and a +; 21 x 21 PSF at each position: +; +; (1) First, create sample values +; x = findgen(43) & y = findgen(43)+1 & psf = randomn(seed,21,21,43) +; +; (2) Create primary header, write it to disk, and make extension header +; fxhmake,header,/initialize,/extend,/date +; fxwrite,'sample.fits',header +; fxbhmake,header,43,'TESTEXT','Test binary table extension' +; +; (3) Fill extension header with desired column names +; fxbaddcol,1,header,x[0],'X' ;Use first element in each array +; fxbaddcol,2,header,y[0],'Y' ;to determine column properties +; fxbaddcol,3,header,psf[*,*,0],'PSF' +; +; (4) Write extension header to FITS file +; fxbcreate,unit,'sample.fits',header +; +; (5) Use FXBWRITM to write all data to the extension in a single call +; fxbwritm,unit,['X','Y','PSF'], x, y, psf +; fxbfinish,unit ;Close the file +; +; COMMON BLOCKS: +; Uses common block FXBINTABLE--see "fxbintable.pro" for more +; information. +; RESTRICTIONS: +; The binary table file must have been opened with FXBCREATE or +; FXBOPEN (with write access). +; +; The data must be consistent with the column definition in the binary +; table header. +; +; The row number must be consistent with the number of rows stored in the +; binary table header. +; +; A PASS_METHOD of POINTER does not use the EXECUTE() statement and can be +; used with the IDL Virtual Machine. However, the EXECUTE() statement is +; used when the PASS_METHOD is by arguments. +; CATEGORY: +; Data Handling, I/O, FITS, Generic. +; PREVIOUS HISTORY: +; C. Markwardt, based on FXBWRITE and FXBREADM (ver 1), Jan 1999 +; WRITTEN: +; Craig Markwardt, GSFC, January 1999. +; MODIFIED: +; Version 1, Craig Markwardt, GSFC 18 January 1999. +; Documented this routine, 18 January 1999. +; C. Markwardt, added ability to pass by handle or pointer. +; Some bug fixes, 20 July 2001 +; W. Landsman/B.Schulz Allow more than 50 arguments when using pointers +; W. Landsman Remove pre-V5.0 HANDLE options July 2004 +; W. Landsman Remove EXECUTE() call with POINTERS May 2005 +; C. Markwardt Allow the output table to have TSCAL/TZERO +; keyword values; if that is the case, then the passed values +; will be quantized to match those scale factors before being +; written. Sep 2007 +; E. Hivon: write 64bit integer and double precision columns, Mar 2008 +; C. Markwardt Allow unsigned integers, which have special +; TSCAL/TZERO values. Feb 2009 +; C. Markwardt Add support for files larger than 2 GB, 2012-04-17 +; +;- +; + compile_opt idl2 +@fxbintable + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 2 THEN BEGIN + MESSAGE = 'Syntax: FXBWRITM, UNIT, COL, DATA1, DATA2, ' $ + +' ..., ROW=, POINTERS=, PASS_METHOD=, NANVALUE=, BUFFERSIZE=' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_ELEMENTS(BUFFERSIZE) EQ 0 THEN BUFFERSIZE = 32768L + +; +; COL may be one of several descriptors: +; * a list of column numbers, beginning with 1 +; * a list of column names +; + MYCOL = [ COL ] ; Make sure it is an array + + SC = SIZE(MYCOL) + NUMCOLS = N_ELEMENTS(MYCOL) + OUTSTATUS = LONARR(NUMCOLS) + COLNAMES = 'D'+STRTRIM(LINDGEN(50),2) + +; +; Determine whether the data has been passed as arguments or pointers +; + IF N_ELEMENTS(PASS_METHOD) EQ 0 THEN PASS_METHOD = 'ARGUMENT' + PASS = STRUPCASE(STRTRIM(PASS_METHOD[0],2)) + IF PASS NE 'ARGUMENT' AND PASS NE 'POINTER' THEN BEGIN + MESSAGE = 'ERROR: PASS_METHOD must be ARGUMENT or POINTER' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + NP = N_ELEMENTS(POINTERS) + IF PASS NE 'ARGUMENT' AND NP LT NUMCOLS THEN BEGIN + MESSAGE = 'ERROR: POINTERS array contains too few elements' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + IF PASS EQ 'POINTER' THEN BEGIN + SZ = SIZE(POINTERS) + IF SZ[SZ[0]+1] NE 10 THEN BEGIN + MESSAGE = 'ERROR: POINTERS must be an array of pointers' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + WH = WHERE(PTR_VALID(POINTERS[0:NUMCOLS-1]) EQ 0, CT) + IF CT GT 0 THEN BEGIN + MESSAGE = 'ERROR: POINTERS contains invalid pointers' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + ENDIF + + +; +; Find the logical unit number in the FXBINTABLE common block. +; + ILUN = WHERE(LUN EQ UNIT,NLUN) + ILUN = ILUN[0] + IF NLUN EQ 0 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened properly' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Make sure the file was opened for write access. +; + IF STATE[ILUN] NE 2 THEN BEGIN + MESSAGE = 'Unit ' + STRTRIM(UNIT,2) + $ + ' not opened for write access' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + +; +; Check the number of columns. It should be fewer than 50 +; + IF (NUMCOLS GT 50) AND (PASS EQ 'ARGUMENT') THEN BEGIN + MESSAGE = 'Maximum of 50 columns exceeded' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; Commented out because too much data is not a problem +; IF NUMCOLS LT N_PARAMS()-2 THEN BEGIN +; MESSAGE = 'ERROR: too few data parameters passed' +; IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN +; ERRMSG = MESSAGE +; RETURN +; END ELSE MESSAGE, MESSAGE +; ENDIF + + ICOL = LONARR(NUMCOLS) + FOUND = BYTARR(NUMCOLS) + NOTFOUND = '' + NNOTFOUND = 0L + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = '' + +; +; If COL is of type string, then search for a column with that label. +; + IF SC[SC[0]+1] EQ 7 THEN BEGIN + MYCOL = STRUPCASE(STRTRIM(MYCOL,2)) + FOR I = 0, NUMCOLS-1 DO BEGIN + XCOL = WHERE(TTYPE[*,ILUN] EQ MYCOL[I], NCOL) + ICOL[I] = XCOL[0] + IF NCOL GT 0 THEN FOUND[I] = 1 + IF NOT FOUND[I] THEN BEGIN + IF NOTFOUND EQ '' THEN NOTFOUND = MYCOL[I] $ + ELSE NOTFOUND = NOTFOUND +', ' + MYCOL[I] + NNOTFOUND = NNOTFOUND + 1 + ENDIF + ENDFOR + + IF NNOTFOUND EQ NUMCOLS THEN BEGIN + MESSAGE = 'ERROR: None of the requested columns were found' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF ELSE IF NNOTFOUND GT 0 THEN BEGIN + MESSAGE = 'WARNING: Columns ' + NOTFOUND + ' were not found' + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = MESSAGE $ + ELSE MESSAGE, MESSAGE, /INFO + ENDIF +; +; Otherwise, a numerical column was passed. Check its value. +; + ENDIF ELSE BEGIN + ICOL[*] = LONG(MYCOL) - 1 + FOUND[ICOL] = 1 + ENDELSE + + +; +; Step through each column index, and check for validity +; + MESSAGE = '' + FOR I = 0, NUMCOLS-1 DO BEGIN + IF NOT FOUND[I] THEN GOTO, LOOP_END_COLCHECK + + IF (ICOL[I] LT 0) OR (ICOL[I] GE TFIELDS[ILUN]) THEN BEGIN + MESSAGE = 'COL "'+STRTRIM(MYCOL[I],2)+$ + '" must be between 1 and ' + $ + STRTRIM(TFIELDS[ILUN],2) + FOUND[I] = 0 + ENDIF +; +; If there are no elements in the array, then set !ERR to -1. +; + IF FOUND[I] AND N_ELEM[ICOL[I],ILUN] EQ 0 THEN BEGIN + FOUND[I] = 0 + MESSAGE = MESSAGE + '; Number of elements to write in "'+$ + STRTRIM(MYCOL[I],2)+'" should be zero' + ENDIF + +; +; Do not permit variable-length columns +; + IF MAXVAL[ICOL[I],ILUN] GT 0 THEN BEGIN + MESSAGE = MESSAGE + 'FXBWRITM cannot write ' + $ + 'variable-length column "'+STRTRIM(MYCOL[I],2)+'"' + FOUND[I] = 0 + ENDIF + + LOOP_END_COLCHECK: + + ENDFOR +; +; If ROW was not passed, then set it equal to the entire range. Otherwise, +; extract the range. +; + IF N_ELEMENTS(ROW) EQ 0 THEN BEGIN + ROW = [1LL, NAXIS2[ILUN]] + ENDIF + CASE N_ELEMENTS(ROW) OF + 1: ROW2 = LONG64(ROW[0]) + 2: ROW2 = LONG64(ROW[1]) + ELSE: BEGIN + MESSAGE = 'ROW must have one or two elements' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + ENDCASE + ROW1 = LONG64(ROW[0]) + +; +; If ROW represents a range, then make sure that the row range is legal, and +; that reading row ranges is allowed (i.e., the column is not variable length. +; + IF ROW1 NE ROW2 THEN BEGIN + MAXROW = NAXIS2[ILUN] + IF (ROW1 LT 1) OR (ROW1 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[0] must be between 1 and ' + $ + STRTRIM(MAXROW,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF (ROW2 LT ROW1) OR (ROW2 GT MAXROW) THEN BEGIN + MESSAGE = 'ROW[1] must be between ' + $ + STRTRIM(ROW1,2) + ' and ' + STRTRIM(MAXROW,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Otherwise, if ROW is a single number, then just make sure it's valid. +; + END ELSE BEGIN + IF (ROW1 LT 1) OR (ROW1 GT NAXIS2[ILUN]) THEN BEGIN + MESSAGE = 'ROW must be between 1 and ' + $ + STRTRIM(NAXIS2[ILUN],2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDELSE + +; +; Check the type of the data against that defined for this column. +; + COLNDIM = LONARR(NUMCOLS) + COLDIM = LONARR(NUMCOLS, 8) ;; Maximum of 8 dimensions in output + COLTYPE = LONARR(NUMCOLS) + BOFF1 = LONARR(NUMCOLS) + BOFF2 = LONARR(NUMCOLS) + NOUTPUT = LONARR(NUMCOLS) + NROWS = ROW2-ROW1+1 + MESSAGE = '' + DTYPENAMES = [ 'BAD TYPE', 'BYTE', 'FIX', 'LONG', $ + 'FLOAT', 'DOUBLE', 'COMPLEX', 'STRING', $ + 'BAD TYPE', 'DCOMPLEX', $ + 'BAD TYPE', 'BAD TYPE', 'BAD TYPE', 'BAD TYPE', 'LONG64' ] + FOR I = 0L, NUMCOLS-1 DO BEGIN + + IF NOT FOUND[I] THEN GOTO, LOOP_END_DIMS + ;; Data type of the input. + COLTYPE[I] = IDLTYPE[ICOL[I],ILUN] + + SZ = 0 + IF PASS EQ 'ARGUMENT' THEN BEGIN + RESULT = EXECUTE('SZ = SIZE('+COLNAMES[I]+')') + IF RESULT EQ 0 THEN BEGIN + MESSAGE = MESSAGE + '; Could not extract type info (column '+$ + STRTRIM(MYCOL[I],2)+')' + FOUND[I] = 0 + ENDIF + ENDIF ELSE SZ = SIZE(*(POINTERS[I])) + + TSCAL1 = TSCAL[ICOL[I],ILUN] + TZERO1 = TZERO[ICOL[I],ILUN] + + TYPE = SZ[SZ[0]+1] + TYPE_BAD = TYPE NE COLTYPE[I] + ;; Handle case of scaled data being stored in an + ;; integer column + IF NOT KEYWORD_SET(NOSCALE) AND $ + (TSCAL1 NE 0) AND (TSCAL1 NE 1) AND $ + (TYPE EQ 4 OR TYPE EQ 5) AND $ + (COLTYPE[I] EQ 2 OR COLTYPE[I] EQ 3 OR COLTYPE[I] EQ 14) THEN $ + TYPE_BAD = 0 + + ;; Unsigned types are OK + IF TSCAL1 EQ 1 AND $ + ((COLTYPE[I] EQ 2 AND TZERO1 EQ 32768) OR $ + (COLTYPE[I] EQ 3 AND TZERO1 EQ 2147483648D)) AND $ + (TYPE EQ 1 OR TYPE EQ 2 OR TYPE EQ 3 OR $ + TYPE EQ 12 OR TYPE EQ 13 OR TYPE EQ 14) THEN BEGIN + TYPE_BAD = 0 + ENDIF + + IF TYPE_BAD THEN BEGIN + CASE COLTYPE[I] OF + 1: STYPE = 'byte' + 2: STYPE = 'short integer' + 3: STYPE = 'long integer' + 4: STYPE = 'floating point' + 5: STYPE = 'double precision' + 6: STYPE = 'complex' + 7: STYPE = 'string' + 9: STYPE = 'double complex' + 12: STYPE = 'unsigned integer' + 13: STYPE = 'unsigned long integer' + 14: STYPE = 'long64 integer' + ENDCASE + FOUND[I] = 0 + MESSAGE = '; Data type (column '+STRTRIM(MYCOL[I],2)+$ + ') should be ' + STYPE + ENDIF + + DIMS = N_DIMS[*,ICOL[I],ILUN] + NDIMS = DIMS[0] + DIMS = DIMS[1:NDIMS] + + IF NDIMS EQ 1 AND DIMS[0] EQ 1 THEN BEGIN + + ;; Case of only one output element, try to return a + ;; scalar. Otherwise, it is a vector equal to the + ;; number of rows to be read + + COLNDIM[I] = 1L + COLDIM[I,0] = NROWS + ENDIF ELSE BEGIN + + COLNDIM[I] = NDIMS + COLDIM[I,0:(NDIMS-1)] = DIMS + IF NROWS GT 1 THEN BEGIN + COLDIM[I,NDIMS] = NROWS + COLNDIM[I] = COLNDIM[I]+1 + ENDIF + + ENDELSE + +; +; Check the number of elements in the input +; + NOUTP = ROUND(PRODUCT(COLDIM[I,0:COLNDIM[I]-1])) + IF SZ[SZ[0]+1] EQ 7 THEN BEGIN + NOUTP = NOUTP / COLDIM[I,0] + IF NOUTP NE SZ[SZ[0]+2] THEN GOTO, ERR_NELEM + NOUTPUT[I] = NOUTP + ENDIF ELSE IF SZ[SZ[0]+2] NE NOUTP THEN BEGIN + ERR_NELEM: + MESSAGE = MESSAGE+'; Data array (column '+STRTRIM(MYCOL[I],2)+$ + ') should have ' + STRTRIM(LONG(NOUTP),2) + ' elements' + FOUND[I] = 0 + ENDIF ELSE NOUTPUT[I] = NOUTP + + ;; Byte offsets + BOFF1[I] = BYTOFF[ICOL[I],ILUN] + IF ICOL[I] EQ TFIELDS[ILUN]-1 THEN BOFF2[I] = NAXIS1[ILUN]-1 $ + ELSE BOFF2[I] = BYTOFF[ICOL[I]+1,ILUN]-1 + + LOOP_END_DIMS: + + ENDFOR + +; +; Check to be sure that there are columns to be written +; + W = WHERE(FOUND EQ 1, COUNT) + IF COUNT EQ 0 THEN BEGIN + STRPUT, MESSAGE, ':', 0 + MESSAGE = 'ERROR: No requested columns could be written'+MESSAGE + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF ELSE IF MESSAGE NE '' THEN BEGIN + STRPUT, MESSAGE, ':', 0 + MESSAGE = 'WARNING: Some columns could not be written'+MESSAGE + IF N_ELEMENTS(WARNMSG) NE 0 THEN WARNMSG = MESSAGE $ + ELSE MESSAGE, MESSAGE, /INFO + ENDIF + + ;; I construct a list of unique column names here. Why? + ;; Because if *all* the columns are named, then there is no + ;; need to read the data from disk first. Since columns can + ;; be given more than once in MYCOL, we need to uniq-ify it. + CC = MYCOL[UNIQ(MYCOL, SORT(MYCOL))] + NC = N_ELEMENTS(CC) + +; +; Find the position of the first byte of the data array in the file. +; + OFFSET0 = NHEADER[ILUN] + NAXIS1[ILUN]*(ROW1-1LL) + + POS = 0LL + NROWS0 = NROWS + J = 0LL + ;; Here, we constrain the buffer to be at least 16 rows long. + ;; If we fill up 32 kB with fewer than 16 rows, then there + ;; must be a lot of (big) columns in this table. It's + ;; probably a candidate for using FXBREAD instead. + BUFFROWS = LONG((BUFFERSIZE/NAXIS1[ILUN]) > 16L) + IF BUFFERSIZE LE 0 THEN BUFFROWS = NROWS0 + +; +; Loop through the data in chunks +; + WHILE NROWS GT 0 DO BEGIN + J = J + 1 + NR = NROWS < BUFFROWS + OFFSET1 = NAXIS1[ILUN]*POS +; +; Proceed by reading a byte array from the input data file +; FXBREADM reads all columns from the specified rows, and +; sorts out the details of which bytes belong to which columns +; in the next FOR loop. +; + BB = BYTARR(NAXIS1[ILUN], NR) +; If *all* columns are being filled, then there is no reason to +; read from the file + + IF NC LT TFIELDS[ILUN] THEN BEGIN + POINT_LUN,UNIT,OFFSET0+OFFSET1 + READU, UNIT, BB + ENDIF + +; +; Now select out the desired columns to write +; + FOR I = 0, NUMCOLS-1 DO BEGIN + IF NOT FOUND[I] THEN GOTO, LOOP_END_WRITE + + ;; Copy data into DD + IF PASS EQ 'ARGUMENT' THEN BEGIN + RESULT = EXECUTE('DD = '+COLNAMES[I]) + IF RESULT EQ 0 THEN GOTO, LOOP_END_WRITE + ENDIF ELSE DD = *(POINTERS[I]) + +; ENDIF + IF N_ELEMENTS(DD) EQ 1 THEN DD = [DD] + DD = REFORM(DD, NOUTPUT[I]/NROWS0, NROWS0, /OVERWRITE) + IF POS GT 0 OR NR LT NROWS0 THEN $ + DD = DD[*,POS:(POS+NR-1)] + + ;; Now any conversions to FITS format must be done + COUNT = 0L + CT = COLTYPE[I] + + ;; Perform data scaling, if scaling values are available + IF NOT KEYWORD_SET(NOSCALE) THEN BEGIN + TSCAL1 = TSCAL[ICOL[I],ILUN] + TZERO1 = TZERO[ICOL[I],ILUN] + IF TSCAL1 EQ 0 THEN TSCAL1 = 1 + ;; Handle special unsigned cases + IF TZERO1 EQ 32768 AND TSCAL1 EQ 1 AND CT EQ 2 THEN $ + ;; Unsigned integer + DD = UINT(DD) - UINT(TZERO1) $ + ELSE IF TZERO1 EQ 2147483648D AND TSCAL1 EQ 1 AND CT EQ 3 THEN $ + ;; Unsigned long integer + DD = ULONG(DD) - ULONG(TZERO1) $ + ELSE IF TZERO1 NE 0 THEN DD = DD - TZERO1 + IF TSCAL1 NE 1 THEN DD = DD / TSCAL1 + ENDIF + SZ = SIZE(DD) + TP = SZ[SZ[0]+1] + + CASE 1 OF + ;; Integer types + (CT EQ 1): BEGIN + ;; Type-cast may be needed if we used TSCAL/TZERO + IF TP NE 1 THEN DD = BYTE(DD) + END + (CT EQ 2): BEGIN + ;; Type-cast may be needed if we used TSCAL/TZERO + IF TP NE 2 THEN DD = FIX(DD) + IF NOT KEYWORD_SET(NOIEEE) THEN $ + SWAP_ENDIAN_INPLACE, DD,/SWAP_IF_LITTLE + END + (CT EQ 3): BEGIN + ;; Type-cast may be needed if we used TSCAL/TZERO + IF TP NE 3 THEN DD = LONG(DD) + IF NOT KEYWORD_SET(NOIEEE) THEN $ + SWAP_ENDIAN_INPLACE, DD,/SWAP_IF_LITTLE + + END + (ct eq 14): begin + ;; Type-cast may be needed if we used TSCAL/TZERO + IF TP NE 14 THEN DD = LONG(DD) + IF NOT KEYWORD_SET(NOIEEE) THEN $ + SWAP_ENDIAN_INPLACE, DD,/SWAP_IF_LITTLE + end + + ;; Floating and complex types + (CT GE 4 AND CT LE 6 OR CT EQ 9): BEGIN + IF NOT KEYWORD_SET(NOIEEE) THEN BEGIN + IF N_ELEMENTS(NANVALUE) EQ 1 THEN BEGIN + W=WHERE(DD EQ NANVALUE,COUNT) + NAN = REPLICATE('FF'XB,16) + NAN = CALL_FUNCTION(DTYPENAMES,NAN,0,1) + ENDIF + SWAP_ENDIAN_INPLACE, DD,/SWAP_IF_LITTLE + IF COUNT GT 0 THEN DD[W] = NAN + ENDIF + END + + ;; String type, needs to be padded with spaces + (CT EQ 7): BEGIN + N_CHAR = N_DIMS[1,ICOL[I],ILUN] + ;; Largest string determines size of array + MAXLEN = MAX(STRLEN(DD)) > 1 + ;; Convert to bytes + DD = BYTE(TEMPORARY(DD)) + IF N_ELEMENTS(DD) EQ 1 THEN DD = [DD] + DD = REFORM(DD, MAXLEN, NR, /OVERWRITE) + + ;; Put it into the output array + IF MAXLEN GT N_CHAR THEN BEGIN + DD = DD[0:(N_CHAR-1),*] + ENDIF ELSE BEGIN + DB = BYTARR(N_CHAR, NR) + DB[0:(MAXLEN-1),*] = TEMPORARY(DD) + DD = TEMPORARY(DB) + ENDELSE + + ;; Pad any zeroes with spaces + WB = WHERE(DD EQ 0b, WCOUNT) + IF WCOUNT GT 0 THEN DD[WB] = 32B + + ;; Pretend that it is a byte array + CT = 1 + END + ENDCASE + IF CT NE 1 THEN $ + DD = BYTE(TEMPORARY(DD),0,(BOFF2[I]-BOFF1[I]+1),NR) + IF N_ELEMENTS(DD) EQ 1 THEN DD = [DD] + DD = REFORM(DD, BOFF2[I]-BOFF1[I]+1, NR, /OVERWRITE) + + ;; Now place the data into the byte array + BB[BOFF1[I],0] = DD + + OUTSTATUS[I] = 1 + LOOP_END_WRITE: + END + + ;; Finally, write byte array to output file + POINT_LUN, UNIT, OFFSET0+OFFSET1 + BB = REFORM(BB, N_ELEMENTS(BB), /OVERWRITE) + WRITEU, UNIT, BB + + NROWS = NROWS - NR + POS = POS + NR + ENDWHILE + +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxfindend.pro b/modules/idl_downloads/astro/pro/fxfindend.pro new file mode 100644 index 0000000..b33c1aa --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxfindend.pro @@ -0,0 +1,93 @@ + PRO FXFINDEND,UNIT, EXTENSION +;+ +; NAME: +; FXFINDEND +; Purpose : +; Find the end of a FITS file. +; Explanation : +; This routine finds the end of the last logical record in a FITS file, +; which may be different from that of the physical end of the file. Each +; FITS header is read in and parsed, and the file pointer is moved to +; where the next FITS extension header would be if there is one, or to +; the end of the file if not. +; Use : +; FXFINDEND, UNIT [, EXTENSION] +; Inputs : +; UNIT = Logical unit number for the opened file. +; Opt. Inputs : +; None. +; Outputs : +; None. +; Opt. Outputs: +; EXTENSION = The extension number that a new extension would +; have if placed at the end of the file. +; Keywords : +; None. +; Calls : +; FXHREAD, FXPAR +; Common : +; None. +; Restrictions: +; The file must have been opened for block I/O. There must not be any +; FITS "special records" at the end of the file. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Feb. 1992. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version : +; Version 1, 12 April 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +; Added EXTENSION parameter, CM 1999 Nov 18 +; Allow for possible 64bit integer number of bytes W. Landsman Nov 2007 +; make Ndata a long64 to deal with large files. E. Hivon Mar 2008 +;- +; + ON_ERROR,2 +; +; Check the number of parameters. +; + IF N_PARAMS() EQ 0 THEN MESSAGE,'Syntax: FXFINDEND, UNIT [,EXTENSION]' +; +; Go to the start of the file. +; + POINT_LUN,UNIT,0 + EXTENSION = 0L +; +; Read the next header, and get the number of bytes taken up by the data. +; +NEXT_EXT: + FXHREAD,UNIT,HEADER,STATUS + IF STATUS NE 0 THEN GOTO, DONE + BITPIX = FXPAR(HEADER,'BITPIX') + NAXIS = FXPAR(HEADER,'NAXIS') + GCOUNT = FXPAR(HEADER,'GCOUNT') & IF GCOUNT EQ 0 THEN GCOUNT = 1 + PCOUNT = FXPAR(HEADER,'PCOUNT') + IF NAXIS GT 0 THEN BEGIN + DIMS = FXPAR(HEADER,'NAXIS*') ;Read dimensions + NDATA = long64(DIMS[0]) + IF NAXIS GT 1 THEN FOR I=2,NAXIS DO NDATA = NDATA*DIMS[I-1] + ENDIF ELSE NDATA = 0 + NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA) +; +; Move to the next extension header in the file. +; + NREC = (NBYTES + 2879) / 2880 + POINT_LUN, -UNIT, POINTLUN ;Current position + POINT_LUN, UNIT, POINTLUN + NREC*2880L ;Next FITS extension + EXTENSION = EXTENSION + 1L + IF NOT EOF(UNIT) THEN GOTO, NEXT_EXT +; +; When done, make sure that the pointer is positioned at the first byte after +; the last data set. +; +DONE: + POINT_LUN, UNIT, POINTLUN + NREC*2880L + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxhclean.pro b/modules/idl_downloads/astro/pro/fxhclean.pro new file mode 100644 index 0000000..2b162ed --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxhclean.pro @@ -0,0 +1,110 @@ + PRO FXHCLEAN,HEADER,ERRMSG=ERRMSG +;+ +; NAME: +; FXHCLEAN +; Purpose : +; Removes required keywords from FITS header. +; Explanation : +; Removes any keywords relevant to array structure from a FITS header, +; preparatory to recreating it with the proper values. +; Use : +; FXHCLEAN, HEADER +; Inputs : +; HEADER = FITS header to be cleaned. +; Opt. Inputs : +; None. +; Outputs : +; HEADER = The cleaned FITS header is returned in place of the input +; array. +; Opt. Outputs: +; None. +; Keywords : +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXHCLEAN, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; SXDELPAR, FXPAR +; Common : +; None. +; Restrictions: +; HEADER must be a string array containing a properly formatted FITS +; header. +; Side effects: +; Warning: when cleaning a binary table extension header, not all of the +; keywords pertaining to columns in the table may be removed. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, William Thompson, GSFC, 30 December 1994 +; Added TCUNIn to list of column keywords to be removed. +; Version : +; Version 4, 30 December 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR, 2 +; +; Check the number of input parameters. +; + IF N_PARAMS() NE 1 THEN BEGIN + MESSAGE = 'Syntax: FXHCLEAN, HEADER' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Check the type of HEADER. +; + S = SIZE(HEADER) + IF (S[0] NE 1) OR (S[2] NE 7) THEN BEGIN + MESSAGE = 'HEADER must be a (one-dimensional) string array' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Start removing the various keywords relative to the structure of the FITS +; file. +; + SXDELPAR,HEADER,['SIMPLE','EXTEND','XTENSION','BITPIX','PCOUNT', $ + 'GCOUNT','THEAP'] +; +; Get the number of axes as stored in the header. Then, remove it, and any +; NAXISnnn keywords implied by it. +; + NAXIS = FXPAR(HEADER,'NAXIS') + SXDELPAR,HEADER,'NAXIS' + IF NAXIS GT 0 THEN FOR I=1,NAXIS DO $ + SXDELPAR,HEADER,'NAXIS'+STRTRIM(I,2) +; +; Get the number of columns in a binary table. Remove any column definitions. +; + TFIELDS = FXPAR(HEADER,'TFIELDS') + SXDELPAR,HEADER,'TFIELDS' + IF TFIELDS GT 0 THEN FOR I=1,TFIELDS DO SXDELPAR,HEADER, $ + ['TFORM','TTYPE','TDIM','TUNIT','TSCAL','TZERO', $ + 'TNULL','TDISP','TDMIN','TDMAX','TDESC','TROTA', $ + 'TRPIX','TRVAL','TDELT','TCUNI'] + STRTRIM(I,2) +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxhmake.pro b/modules/idl_downloads/astro/pro/fxhmake.pro new file mode 100644 index 0000000..598a455 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxhmake.pro @@ -0,0 +1,252 @@ + PRO FXHMAKE, HEADER, DATA, EXTEND=EXTEND, DATE=DATE, $ + INITIALIZE=INITIALIZE, ERRMSG=ERRMSG, XTENSION=XTENSION +;+ +; NAME: +; FXHMAKE +; Purpose : +; Create a basic FITS header array. +; Explanation : +; Creates a basic header array with all the required keywords. This +; defines a basic structure which can then be added to or modified by +; other routines. +; Use : +; FXHMAKE, HEADER [, DATA ] +; Inputs : +; None required. +; Opt. Inputs : +; DATA = IDL data array to be written to file. It must be in the +; primary data unit unless the XTENSION keyword is supplied. +; This array is used to determine the values of the BITPIX and +; NAXIS, etc. keywords. +; +; If not passed, then BITPIX is set to eight, NAXIS is set to +; zero, and no NAXISnnn keywords are included in this +; preliminary header. +; Outputs : +; HEADER = String array containing FITS header. +; Opt. Outputs: +; None. +; Keywords : +; INITIALIZE = If set, then the header is completely initialized, and any +; previous entries are lost. +; EXTEND = If set, then the keyword EXTEND is inserted into the file, +; with the value of "T" (true). +; DATE = If set, then the DATE keyword is added to the header. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXHMAKE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; XTENSION - If set, then the header is appropriate for an image +; extension, rather than the primary data unit. +; Calls : +; GET_DATE, FXADDPAR, FXHCLEAN +; Common : +; None. +; Restrictions: +; Groups are not currently supported. +; Side effects: +; BITPIX, NAXIS, etc. are defined such that complex arrays are stored as +; floating point, with an extra first dimension of two elements (real and +; imaginary parts). +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992, from SXHMAKE by D. Lindler and M. Greason. +; Differences include: +; +; * Use of FITS standard (negative BITPIX) to signal floating +; point numbers instead of (SDAS/Geis) DATATYPE keyword. +; * Storage of complex numbers as pairs of real numbers. +; * Support for EXTEND keyword, and for cases where there is no +; primary data array. +; * Insertion of DATE record made optional. Only required FITS +; keywords are inserted automatically. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 21 June 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, Wayne Landsman, GSFC, 12 August 1997 +; Recognize double complex data type +; Converted to IDL V5.0 W. Landsman September 1997 +; Version 6, William Thompson, GSFC, 22 September 2004 +; Recognize unsigned integer types. +; Version 6.1, C. Markwardt, GSFC, 19 Jun 2005 +; Add the XTENSION keyword, which writes an XTENSION +; keyword instead of SIMPLE. +; Version : +; Version 6.1, 19 June 2005 +;- +; + ON_ERROR,2 +; +; Check the number of parameters first. +; + IF N_PARAMS() LT 1 THEN BEGIN + MESSAGE = 'Calling sequence: FXHMAKE, HEADER [, DATA ]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If no data array was passed, then set BITPIX=8 and NAXIS=0. Otherwise, +; calculate these parameters. +; + IF N_PARAMS() EQ 1 THEN BEGIN + BITPIX = 8 + COMMENT = '' + S = 0 + END ELSE BEGIN + S = SIZE(DATA) ;obtain size of array. + DTYPE = S[S[0]+1] ;type of data. + CASE DTYPE OF + 0: BEGIN + MESSAGE = 'Data parameter is not defined' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + 1: BEGIN + BITPIX = 8 + COMMENT = 'Integer*1 (byte)' + END + 2: BEGIN + BITPIX = 16 + COMMENT = 'Integer*2 (short integer)' + END + 3: BEGIN + BITPIX = 32 + COMMENT = 'Integer*4 (long integer)' + END + 4: BEGIN + BITPIX = -32 + COMMENT = 'Real*4 (floating point)' + END + 5: BEGIN + BITPIX = -64 + COMMENT = 'Real*8 (double precision)' + END + 6: BEGIN ;Complex*8 (complex) + BITPIX = -32 ;Store as float + S = [S[0]+1, 2, S[1:*]] ;with extra dim + COMMENT = 'Real*4 (complex, stored as float)' + END + 7: BEGIN + MESSAGE = "Can't write strings to FITS files" + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + 8: BEGIN + MESSAGE = "Can't write structures to FITS files" + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + 9: BEGIN + BITPIX = -64 ;Store as double + S = [S[0]+1, 2, S[1:*]] ;with extra dim + COMMENT = 'Real*8 (dcomplex, stored as double)' + END +; +; Unsigned data types may require use of BZERO/BSCALE--handled in writer. +; + 12: BEGIN ;Unsigned integer + BITPIX = 16 + COMMENT = 'Integer*2 (short integer)' + END + 13: BEGIN ;Unsigned long integer + BITPIX = 32 + COMMENT = 'Integer*4 (long integer)' + END + + ENDCASE + ENDELSE +; +; If requested, then initialize the header. +; + IF KEYWORD_SET(INITIALIZE) THEN BEGIN + HEADER = STRARR(36) + HEADER[0] = 'END' + STRING(REPLICATE(32B,77)) +; +; Else, if undefined, then initialize the header. +; + END ELSE IF N_ELEMENTS(HEADER) EQ 0 THEN BEGIN + HEADER = STRARR(36) + HEADER[0] = 'END' + STRING(REPLICATE(32B,77)) +; +; Otherwise, make sure that HEADER is a string array, and remove any keywords +; that describe the format of the file. +; + END ELSE BEGIN + SZ = SIZE(HEADER) + IF (SZ[0] NE 1) OR (SZ[2] NE 7) THEN BEGIN + MESSAGE = 'HEADER must be a (one-dimensional) ' + $ + 'string array' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + FXHCLEAN,HEADER,ERRMSG=ERRMSG + IF ERRMSG NE '' THEN RETURN + END ELSE FXHCLEAN,HEADER + ENDELSE +; +; The first keyword must be "SIMPLE". Normally, this has the value "T" +; (true). +; + IF KEYWORD_SET(XTENSION) THEN BEGIN + FXADDPAR,HEADER,'XTENSION','IMAGE','Written by IDL: '+ SYSTIME() + ENDIF ELSE BEGIN + FXADDPAR,HEADER,'SIMPLE','T','Written by IDL: '+ SYSTIME() + ENDELSE +; +; The second keyword must be "BITPIX", and the third "NAXIS". +; + FXADDPAR,HEADER,'BITPIX',BITPIX,COMMENT + FXADDPAR,HEADER,'NAXIS',S[0] ;# of dimensions +; +; If NAXIS is not zero, then add the keywords for the axes. If the data array +; is complex, then add a comment to the first axis to note that this is +; actually the real and imaginary parts of the complex number. +; + IF S[0] NE 0 THEN FOR I=1,S[0] DO BEGIN + IF (I EQ 1) AND (DTYPE EQ 6) THEN BEGIN + FXADDPAR,HEADER,'NAXIS1',S[I], $ + 'Real and imaginary parts' + END ELSE BEGIN + FXADDPAR,HEADER,'NAXIS'+STRTRIM(I,2),S[I] + ENDELSE + ENDFOR +; +; If requested, add the EXTEND keyword to the header, and set it to true. +; + IF KEYWORD_SET(EXTEND) THEN $ + FXADDPAR,HEADER,'EXTEND','T','File contains extensions' +; +; If requested, add the DATE keyword to the header, containing the current +; date. +; + IF KEYWORD_SET(DATE) THEN BEGIN + GET_DATE,DTE ;Get current date as CCYY-MM-DD + FXADDPAR,HEADER,'DATE',DTE + ENDIF +; + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxhmodify.pro b/modules/idl_downloads/astro/pro/fxhmodify.pro new file mode 100644 index 0000000..8ac0ad2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxhmodify.pro @@ -0,0 +1,277 @@ +PRO FXHMODIFY, FILENAME, NAME, VALUE, COMMENT, BEFORE=BEFORE, $ + AFTER=AFTER, FORMAT=FORMAT, EXTENSION=EXTENSION, ERRMSG=ERRMSG,$ + NOGROW=NOGROW +;+ +; NAME: +; FXHMODIFY +; PURPOSE : +; Modify a FITS header in a file on disk. +; Explanation : +; Opens a FITS file, and adds or modifies a parameter in the FITS header. +; Can be used for either the main header, or for an extension header. +; The modification is performed directly on the disk file. +; Use : +; FXHMODIFY, FILENAME, NAME, VALUE, COMMENT +; Inputs : +; FILENAME = String containing the name of the file to be read. +; +; NAME = Name of parameter, scalar string If NAME is already in the +; header the value and possibly comment fields are modified. +; Otherwise a new record is added to the header. If NAME is +; equal to either "COMMENT" or "HISTORY" then the value will be +; added to the record without replacement. In this case the +; comment parameter is ignored. +; +; VALUE = Value for parameter. The value expression must be of the +; correct type, e.g. integer, floating or string. String +; values of 'T' or 'F' are considered logical values. +; +; Opt. Inputs : +; COMMENT = String field. The '/' is added by this routine. Added +; starting in position 31. If not supplied, or set equal to '' +; (the null string), then any previous comment field in the +; header for that keyword is retained (when found). +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; EXTENSION = Either the number of the FITS extension, starting with the +; first extension after the primary data unit being one; or a +; character string containing the value of EXTNAME to search +; for. If not passed, then the primary FITS header is +; modified. +; +; BEFORE = Keyword string name. The parameter will be placed before the +; location of this keyword. For example, if BEFORE='HISTORY' +; then the parameter will be placed before the first history +; location. This applies only when adding a new keyword; +; keywords already in the header are kept in the same position. +; +; AFTER = Same as BEFORE, but the parameter will be placed after the +; location of this keyword. This keyword takes precedence over +; BEFORE. +; +; FORMAT = Specifies FORTRAN-like format for parameter, e.g. "F7.3". A +; scalar string should be used. For complex numbers the format +; should be defined so that it can be applied separately to the +; real and imaginary parts. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXHMODIFY, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; FXHREAD, FXPAR, FXADDPAR, BLKSHIFT +; Restrictions: +; This routine can not be used to modify any of the keywords that control +; the structure of the FITS file, e.g. BITPIX, NAXIS, PCOUNT, etc. Doing +; so could corrupt the readability of the FITS file. +; Example: +; Modify the name 'OBJECT' keyword in the primary FITS header of a FITS +; file 'spec98.ccd' to contain the value 'test domeflat' +; +; IDL> fxhmodify, 'spec98.ccd', 'OBJECT', 'test domeflat' +; +; Side effects: +; If adding a record to the FITS header would increase the +; number of 2880 byte records stored on disk, then the file is +; enlarged before modification, unless the NOGROW keyword is passed. +; +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; None. +; Written : +; William Thompson, GSFC, 3 March 1994. +; Modified : +; Version 1, William Thompson, GSFC, 3 March 1994. +; Version 2, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 3.1 Wayne Landsman GSFC 17 March 2006 +; Fix problem in BLKSHIFT call if primary header extended +; Version 3.2 W. Landsman 14 November 204 +; Allow for need for 64bit number of bytes +; Version 4, William Thompson, GSFC, 22-Dec-2014 +; Modified test for keyword EXTEND to only issue warning. +;; Version : +; Version 4, 22-Dec-2014 +;- +; + COMPILE_OPT IDL2 + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 3 THEN BEGIN + MESSAGE = $ ;Need at least 3 parameters + 'Syntax: FXHMODIFY, FILENAME, NAME, VALUE [, COMMENT ]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If passed, check the type of the EXTENSION parameter. +; + IF N_ELEMENTS(EXTENSION) GT 1 THEN BEGIN + MESSAGE = 'EXTENSION must be a scalar' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF N_ELEMENTS(EXTENSION) EQ 1 THEN BEGIN + SZ = SIZE(EXTENSION) + ETYPE = SZ[SZ[0]+1] + IF ETYPE EQ 8 THEN BEGIN + MESSAGE = 'EXTENSION must not be a structure' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; If EXTENSION is of type string, then search for the proper extension by +; name. Otherwise, search by number. +; + IF ETYPE EQ 7 THEN BEGIN + S_EXTENSION = STRTRIM(STRUPCASE(EXTENSION),2) + END ELSE BEGIN + I_EXTENSION = FIX(EXTENSION) + IF I_EXTENSION LT 1 THEN BEGIN + MESSAGE = 'EXTENSION must be greater than zero' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDELSE + ENDIF +; +; Get the UNIT number, and open the file. +; + OPENU, UNIT, FILENAME, /BLOCK, /GET_LUN +; +; Read in the primary FITS header. +; + FXHREAD,UNIT,HEADER,STATUS + IF STATUS NE 0 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Unable to read FITS header' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + MHEAD0 = 0 + I_EXT = 0 +; +; If the EXTENSION parameter was passed, then look for the requested +; extension. +; + IF N_ELEMENTS(EXTENSION) EQ 1 THEN BEGIN +; +; Make sure that the file does contain extensions. However, only issue a +; warning if EXTEND keyword not set. +; + IF ~FXPAR(HEADER,'EXTEND') THEN MESSAGE, /CONTINUE, $ + 'Keyword EXTEND not set in file ' + FILENAME +; +; Get the number of bytes taken up by the data. +; +NEXT_EXT: + BITPIX = FXPAR(HEADER,'BITPIX') + NAXIS = FXPAR(HEADER,'NAXIS') + GCOUNT = FXPAR(HEADER,'GCOUNT') + IF GCOUNT EQ 0 THEN GCOUNT = 1 + PCOUNT = FXPAR(HEADER,'PCOUNT') + IF NAXIS GT 0 THEN BEGIN + DIMS = FXPAR(HEADER,'NAXIS*') ;Read dimensions + NDATA = DIMS[0] + IF NAXIS GT 1 THEN FOR I=2,NAXIS DO $ + NDATA = NDATA*DIMS[I-1] + ENDIF ELSE NDATA = 0 + NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA) +; +; Read the next extension header in the file. +; + NREC = (NBYTES + 2879) / 2880 + POINT_LUN, -UNIT, POINTLUN ;Current position + MHEAD0 = POINTLUN + NREC*2880L + POINT_LUN, UNIT, MHEAD0 ;Next FITS extension + FXHREAD,UNIT,HEADER,STATUS + POINT_LUN, -UNIT, END_HEADER + IF STATUS NE 0 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Requested extension not found' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + I_EXT = I_EXT + 1 +; +; Check to see if the current extension is the one desired. +; + IF ETYPE EQ 7 THEN BEGIN + EXTNAME = STRTRIM(STRUPCASE(FXPAR(HEADER,'EXTNAME')),2) + IF EXTNAME EQ S_EXTENSION THEN GOTO, DONE + END ELSE IF I_EXT EQ I_EXTENSION THEN GOTO, DONE + GOTO, NEXT_EXT +DONE: + ENDIF ELSE POINT_LUN, -UNIT, END_HEADER + +; +; Add or modify the keyword parameter in the header, keeping track of the +; initial size of the header array. +; + IEND = WHERE(STRMID(HEADER,0,8) EQ 'END ') + N_INITIAL = 1 + IEND[0]/36 + IF N_PARAMS() EQ 4 THEN BEGIN + FXADDPAR, HEADER, NAME, VALUE , COMMENT, BEFORE=BEFORE, $ + AFTER=AFTER, FORMAT=FORMAT + END ELSE BEGIN + FXADDPAR, HEADER, NAME, VALUE, BEFORE=BEFORE, AFTER=AFTER, $ + FORMAT=FORMAT + ENDELSE +; +; If the length of the header has changed, then print an error message. +; + IEND = WHERE(STRMID(HEADER,0,8) EQ 'END ') + N_FINAL = 1 + IEND[0]/36 + IF N_FINAL NE N_INITIAL THEN BEGIN + IF KEYWORD_SET(NOGROW) THEN BEGIN + MESSAGE, /CONTINUE, 'Adding parameter would increase ' + $ + 'header length, no action taken.' + ENDIF ELSE BEGIN + ;; Increase size of the file by inserting multiples of + ;; 2880 bytes at the end of the current header. Then + ;; resume normal operations. + BLKSHIFT, UNIT, END_HEADER, (N_FINAL-N_INITIAL)*36L*80L + GOTO, WRITE_HEADER + ENDELSE +; +; Otherwise, rewind to the beginning of the header, and write the new header +; over the old header. Convert to byte and force into 80 character lines. +; + ENDIF ELSE BEGIN + WRITE_HEADER: + BHDR = REPLICATE(32B, 80, 36*N_FINAL) + FOR N = 0,IEND[0] DO BHDR[0,N] = BYTE(STRMID(HEADER[N],0,80)) + POINT_LUN, UNIT, MHEAD0 + WRITEU, UNIT, BHDR + ENDELSE +; +; Close the file and return. +; + FREE_LUN, UNIT + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxhread.pro b/modules/idl_downloads/astro/pro/fxhread.pro new file mode 100644 index 0000000..3a4da73 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxhread.pro @@ -0,0 +1,119 @@ + PRO FXHREAD,UNIT,HEADER,STATUS +;+ +; NAME: +; FXHREAD +; Purpose : +; Reads a FITS header from an opened disk file. +; Explanation : +; Reads a FITS header from an opened disk file. +; Use : +; FXHREAD, UNIT, HEADER [, STATUS ] +; Inputs : +; UNIT = Logical unit number. +; Opt. Inputs : +; +; Outputs : +; HEADER = String array containing the FITS header. +; Opt. Outputs: +; STATUS = Condition code giving the status of the read. Normally, this +; is zero, but is set to !ERR if an error occurs, or if the +; first byte of the header is zero (ASCII null). +; Keywords : +; None. +; Calls : +; None. +; Common : +; None. +; Restrictions: +; The file must already be positioned at the start of the header. It +; must be a proper FITS file. +; Side effects: +; The file ends by being positioned at the end of the FITS header, unless +; an error occurs. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Feb 1992, from READFITS by J. Woffard and W. Landsman. +; W. Thompson, Aug 1992, added test for SIMPLE keyword. +; Written : +; William Thompson, GSFC, February 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version : +; Version 1, 12 April 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; +; + ON_ERROR,2 ;Return to caller + STATUS = 0 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 2 THEN MESSAGE, $ + 'Calling sequence: FXHREAD, UNIT, HEADER [, STATUS ]' +; +; Find out whether one is at the beginning of the file (POSITION=0) or not. +; + POINT_LUN,-UNIT,POSITION +; +; Read in the first 2880 byte FITS logical block as a series of 36 card images +; of 80 bytes each. +; + HDR = BYTARR( 80, 36, /NOZERO ) + ON_IOERROR, RETURN_STATUS + READU, UNIT, HDR +; +; If not the primary header, then the first eight bytes should decode to +; XTENSION. If not, then set status to -1, and return. +; + IF POSITION NE 0 THEN BEGIN + FIRST = STRING(HDR[0:7]) + IF FIRST NE 'XTENSION' THEN BEGIN + MESSAGE,'XTENSION keyword not found',/CONTINUE + STATUS = -1 + GOTO, DONE + ENDIF + ENDIF +; +; Interpret the header as a string, and check to see if the END line has been +; reached. +; + HEADER = STRING( HDR > 32B ) + ENDLINE = WHERE( STRMID(HEADER,0,8) EQ 'END ', NEND) + IF NEND GT 0 THEN HEADER = HEADER[ 0:ENDLINE[0] ] +; +; If the primary header (POSITION=0) and the SIMPLE keyword can't be found in +; the first record, then this can't be a FITS file. +; + IF POSITION EQ 0 THEN BEGIN + SIMPLE_LINE = WHERE(STRMID(HEADER,0,8) EQ 'SIMPLE ',N_SIMPLE) + IF N_SIMPLE EQ 0 THEN BEGIN + MESSAGE,'SIMPLE keyword not found',/CONTINUE + STATUS = -1 + GOTO, DONE + ENDIF + ENDIF +; +; Keep reading until the END line is reached. +; + WHILE NEND EQ 0 DO BEGIN + READU, UNIT, HDR + HDR1 = STRING( HDR > 32B ) + ENDLINE = WHERE( STRMID(HDR1,0,8) EQ 'END ', NEND) + IF NEND GT 0 THEN HDR1 = HDR1[ 0:ENDLINE[0] ] + HEADER = [HEADER, HDR1 ] + ENDWHILE + GOTO, DONE +; +; Error encounter. Store the error code in status. +; +RETURN_STATUS: + STATUS = !ERR +; +; Reset the ON_IOERROR condition. +; +DONE: + ON_IOERROR,NULL + END diff --git a/modules/idl_downloads/astro/pro/fxmove.pro b/modules/idl_downloads/astro/pro/fxmove.pro new file mode 100644 index 0000000..02b93bf --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxmove.pro @@ -0,0 +1,137 @@ +FUNCTION FXMOVE, UNIT, EXTEN, SILENT = Silent, EXT_NO = ext_no, ERRMSG=errmsg + +;+ +; NAME: +; FXMOVE +; PURPOSE: +; Skip to a specified extension number or name in a FITS file +; +; CALLING SEQUENCE: +; STATUS=FXMOVE(UNIT, EXT, /Silent) +; STATUS=FXMOVE(UNIT, EXTNAME, /Silent, EXT_NO=, ERRMSG= ) +; +; INPUT PARAMETERS: +; UNIT = An open unit descriptor for a FITS data stream. +; EXTEN = Number of extensions to skip. +; or +; Scalar string giving extension name (in the EXTNAME keyword) +; OPTIONAL INPUT PARAMETER: +; /SILENT - If set, then any messages about invalid characters in the +; FITS file are suppressed. +; OPTIONAL OUTPUT PARAMETER: +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; EXT_NO - Extension number, scalar integer, useful if the user supplied +; an extension name in the EXTEN parameter +; RETURNS: +; 0 if successful. +; -1 if an error is encountered. +; +; COMMON BLOCKS: +; None. +; SIDE EFFECTS: +; Repositions the file pointer. +; PROCEDURE: +; Each FITS header is read in and parsed, and the file pointer is moved +; to where the next FITS extension header until the desired +; extension is reached. +; PROCEDURE CALLS: +; FXPAR(), MRD_HREAD, MRD_SKIP +; MODIFICATION HISTORY: +; Extracted from FXPOSIT 8-March-2000 by T. McGlynn +; Added /SILENT keyword 14-Dec-2000 by W. Landsman +; Save time by not reading the full header W. Landsman Feb. 2003 +; Allow extension name to be specified, added EXT_NO, ERRMSG keywords +; W. Landsman December 2006 +; Make search for EXTNAME case-independent W.Landsman March 2007 +; Avoid round-off error for very large extensions N. Piskunov Dec 2007 +; Assume since V6.1 (/INTEGER keyword available to PRODUCT() ) Dec 2007 +; Capture error message from MRD_HREAD (must be used with post-June 2009 +; version of MRD-HREAD) W. Landsman July 2009 +;- + On_error, 2 + compile_opt idl2 + + DO_NAME = SIZE( EXTEN,/TNAME) EQ 'STRING' + PRINT_ERROR = ~ARG_PRESENT(ERRMSG) + ERRMSG = '' + IF DO_NAME THEN BEGIN + FIRSTBLOCK = 0 + EXT_NO = 9999 + ENAME = STRTRIM( STRUPCASE(EXTEN), 2 ) + ON_IOERROR, ALLOW_PLUN + POINT_LUN, -UNIT, DUM + ON_IOERROR, NULL + ENDIF ELSE BEGIN + FIRSTBLOCK = 1 + EXT_NO = EXTEN + ENDELSE + + FOR I = 1, EXT_NO DO BEGIN + +; +; Read the next header, and get the number of bytes taken up by the data. +; + + IF EOF(UNIT) THEN BEGIN + IF DO_NAME THEN ERRMSG = $ + 'Extension name ' + ename + ' not found in FITS file' ELSE ERRMSG = $ + 'EOF encountered while moving to specified extension' + if PRINT_ERROR then message,errmsg + RETURN, -1 + ENDIF + + ; Can't use FXHREAD to read from pipe, since it uses + ; POINT_LUN. So we read this in ourselves using mrd_hread + + MRD_HREAD, UNIT, HEADER, STATUS, SILENT = Silent, $ + FIRSTBLOCK=FIRSTBLOCK, ERRMSG = ERRMSG + + IF STATUS LT 0 THEN BEGIN + IF PRINT_ERROR THEN MESSAGE,ERRMSG ;Typo fix 04/10 + RETURN, -1 + ENDIF + + ; Get parameters that determine size of data + ; region. + IF DO_NAME THEN IF I GT 1 THEN BEGIN + EXTNAME = STRTRIM(SXPAR(HEADER,'EXTNAME',COUNT=N_name),2) + if N_NAME GT 0 THEN $ + IF ENAME EQ STRUPCASE(EXTNAME) THEN BEGIN + EXT_NO= I-1 + BLOCK = 1 + ((N_ELEMENTS(HEADER)-1)/36) + POINT_LUN, -UNIT, CURR_POSS + POINT_LUN, UNIT, CURR_POSS - BLOCK*2880 + BREAK + ENDIF + ENDIF + BITPIX = FXPAR(HEADER,'BITPIX') + NAXIS = FXPAR(HEADER,'NAXIS') + GCOUNT = FXPAR(HEADER,'GCOUNT') + IF GCOUNT EQ 0 THEN GCOUNT = 1 + PCOUNT = FXPAR(HEADER,'PCOUNT') + + IF NAXIS GT 0 THEN BEGIN + DIMS = FXPAR(HEADER,'NAXIS*') ;Read dimensions + NDATA = PRODUCT(DIMS,/INTEGER) + ENDIF ELSE NDATA = 0 + + NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA) +; +; Move to the next extension header in the file. +; + NREC = (NBYTES + 2879) / 2880 + MRD_SKIP, UNIT, NREC*2880L + + ENDFOR + + RETURN, 0 +ALLOW_PLUN: + + ERRMSG = $ + 'Extension name cannot be specified unless POINT_LUN access is available' + if PRINT_ERROR then message,errmsg + RETURN, -1 +END diff --git a/modules/idl_downloads/astro/pro/fxpar.pro b/modules/idl_downloads/astro/pro/fxpar.pro new file mode 100644 index 0000000..a456b5a --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxpar.pro @@ -0,0 +1,462 @@ + FUNCTION FXPAR, HDR, NAME, ABORT, COUNT=MATCHES, COMMENT=COMMENTS, $ + START=START, PRECHECK=PRECHECK, POSTCHECK=POSTCHECK, $ + NOCONTINUE = NOCONTINUE, DATATYPE=DATATYPE, $ + NULL=K_NULL, NAN=NAN, MISSING=MISSING +;+ +; NAME: +; FXPAR() +; PURPOSE: +; Obtain the value of a parameter in a FITS header. +; EXPLANATION: +; The first 8 chacters of each element of HDR are searched for a match to +; NAME. If the keyword is one of those allowed to take multiple values +; ("HISTORY", "COMMENT", or " " (blank)), then the value is taken +; as the next 72 characters. Otherwise, it is assumed that the next +; character is "=", and the value (and optional comment) is then parsed +; from the last 71 characters. An error occurs if there is no parameter +; with the given name. +; +; If the value is too long for one line, it may be continued on to the +; the next input card, using the CONTINUE Long String Keyword convention. +; For more info, http://fits.gsfc.nasa.gov/registry/continue_keyword.html +; +; +; Complex numbers are recognized as two numbers separated by one or more +; space characters. +; +; If a numeric value has no decimal point (or E or D) it is returned as +; type LONG. If it contains more than 8 numerals, or contains the +; character 'D', then it is returned as type DOUBLE. Otherwise it is +; returned as type FLOAT. If an integer is too large to be stored as +; type LONG, then it is returned as DOUBLE. +; +; If a keyword is in the header and has no value, then the default +; missing value is returned as explained below. This can be +; distinguished from the case where the keyword is not found by the fact +; that COUNT=0 in that case, while existing keywords without a value will +; be returned with COUNT=1 or more. +; +; CALLING SEQUENCE: +; Result = FXPAR( HDR, NAME [, ABORT, COUNT=, COMMENT=, /NOCONTINUE ] ) +; +; Result = FXPAR(HEADER,'DATE') ;Finds the value of DATE +; Result = FXPAR(HEADER,'NAXIS*') ;Returns array dimensions as +; ;vector +; REQUIRED INPUTS: +; HDR = FITS header string array (e.g. as returned by FXREAD). Each +; element should have a length of 80 characters +; NAME = String name of the parameter to return. If NAME is of the +; form 'keyword*' then an array is returned containing values +; of keywordN where N is an integer. The value of keywordN +; will be placed in RESULT(N-1). The data type of RESULT will +; be the type of the first valid match of keywordN +; found, unless DATATYPE is given. +; OPTIONAL INPUT: +; ABORT = String specifying that FXPAR should do a RETALL if a +; parameter is not found. ABORT should contain a string to be +; printed if the keyword parameter is not found. If not +; supplied, FXPAR will return with a negative !err if a keyword +; is not found. +; OUTPUT: +; The returned value of the function is the value(s) associated with the +; requested keyword in the header array. +; +; If the parameter is complex, double precision, floating point, long or +; string, then the result is of that type. Apostrophes are stripped from +; strings. If the parameter is logical, 1 is returned for T, and 0 is +; returned for F. +; +; If NAME was of form 'keyword*' then a vector of values are returned. +; +; OPTIONAL INPUT KEYWORDS: +; DATATYPE = A scalar value, indicating the type of vector +; data. All keywords will be cast to this type. +; Default: based on first keyword. +; Example: DATATYPE=0.0D (cast data to double precision) +; START = A best-guess starting position of the sought-after +; keyword in the header. If specified, then FXPAR +; first searches for scalar keywords in the header in +; the index range bounded by START-PRECHECK and +; START+POSTCHECK. This can speed up keyword searches +; in large headers. If the keyword is not found, then +; FXPAR searches the entire header. +; +; If not specified then the entire header is searched. +; Searches of the form 'keyword*' also search the +; entire header and ignore START. +; +; Upon return START is changed to be the position of +; the newly found keyword. Thus the best way to +; search for a series of keywords is to search for +; them in the order they appear in the header like +; this: +; +; START = 0L +; P1 = FXPAR('P1', START=START) +; P2 = FXPAR('P2', START=START) +; +; PRECHECK = If START is specified, then PRECHECK is the number +; of keywords preceding START to be searched. +; Default: 5 +; POSTCHECK = If START is specified, then POSTCHECK is the number +; of keywords after START to be searched. +; Default: 20 +; /NOCONTINUE = If set, then continuation lines will not be read, even +; if present in the header +; MISSING = By default, this routine returns 0 when keyword values are +; not found. This can be overridden by using the MISSING +; keyword, e.g. MISSING=-1. +; /NAN = If set, then return Not-a-Number (!values.f_nan) for missing +; values. Ignored if keyword MISSING is present. +; /NULL = If set, then return !NULL (undefined) for missing values. +; Ignored if MISSING of /NAN is present, or if earlier than IDL +; version 8.0. If multiple values would be returned, then +; MISSING= or /NAN should be used instead of /NULL, making sure +; that the datatype is consistent with the non-missing values, +; e.g. MISSING='' for strings, MISSING=-1 for integers, or +; MISSING=-1.0 or /NAN for floating point. /NAN should not be +; used if the datatype would otherwise be integer. +; OPTIONAL OUTPUT KEYWORD: +; COUNT = Optional keyword to return a value equal to the number of +; parameters found by FXPAR. +; COMMENTS= Array of comments associated with the returned values. +; +; PROCEDURE CALLS: +; GETTOK(), VALID_NUM +; SIDE EFFECTS: +; +; The system variable !err is set to -1 if parameter not found, 0 for a +; scalar value returned. If a vector is returned it is set to the number +; of keyword matches found. +; +; If a keyword occurs more than once in a header, a warning is given, +; and the first occurence is used. However, if the keyword is "HISTORY", +; "COMMENT", or " " (blank), then multiple values are returned. +; +; NOTES: +; The functions SXPAR() and FXPAR() are nearly identical, although +; FXPAR() has slightly more sophisticated parsing. There is no +; particular reason for having two nearly identical procedures, but +; both are too widely used to drop either one. +; +; REVISION HISTORY: +; Version 1, William Thompson, GSFC, 12 April 1993. +; Adapted from SXPAR +; Version 2, William Thompson, GSFC, 14 October 1994 +; Modified to use VALID_NUM instead of STRNUMBER. Inserted +; additional call to VALID_NUM to trap cases where character +; strings did not contain quotation marks. +; Version 3, William Thompson, GSFC, 22 December 1994 +; Fixed bug with blank keywords, following suggestion by Wayne +; Landsman. +; Version 4, Mons Morrison, LMSAL, 9-Jan-98 +; Made non-trailing ' for string tag just be a warning (not +; a fatal error). It was needed because "sxaddpar" had an +; error which did not write tags properly for long strings +; (over 68 characters) +; Version 5, Wayne Landsman GSFC, 29 May 1998 +; Fixed potential problem with overflow of LONG values +; Version 6, Craig Markwardt, GSFC, 28 Jan 1998, +; Added CONTINUE parsing +; Version 7, Craig Markwardt, GSFC, 18 Nov 1999, +; Added START, PRE/POSTCHECK keywords for better +; performance +; Version 8, Craig Markwardt, GSFC, 08 Oct 2003, +; Added DATATYPE keyword to cast vector keywords type +; Version 9, Paul Hick, 22 Oct 2003, Corrected bug (NHEADER-1) +; Version 10, W. Landsman, GSFC 2 May 2012 +; Keywords of form "name_0" could confuse vector extractions +; Version 11 W. Landsman, GSFC 24 Apr 2014 +; Don't convert LONG64 numbers to to double precision +; Version 12, William Thompson, 13-Aug-2014 +; Add keywords MISSING, /NAN, and /NULL +;- +;------------------------------------------------------------------------------ +; +; Check the number of parameters. +; + IF N_PARAMS() LT 2 THEN BEGIN + PRINT,'Syntax: result = FXPAR( HDR, NAME [, ABORT ])' + RETURN, -1 + ENDIF +; +; Determine the default value for missing data. +; + CASE 1 OF + N_ELEMENTS(MISSING) EQ 1: MISSING_VALUE = MISSING + KEYWORD_SET(NAN): MISSING_VALUE = !VALUES.F_NAN + KEYWORD_SET(K_NULL) AND !VERSION.RELEASE GE '8.': $ + DUMMY = EXECUTE('MISSING_VALUE = !NULL') + ELSE: MISSING_VALUE = 0 + ENDCASE + VALUE = MISSING_VALUE +; +; Determine the abort condition. +; + IF N_PARAMS() LE 2 THEN BEGIN + ABORT_RETURN = 0 + ABORT = 'FITS Header' + END ELSE ABORT_RETURN = 1 + IF ABORT_RETURN THEN ON_ERROR,1 ELSE ON_ERROR,2 +; +; Check for valid header. Check header for proper attributes. +; + S = SIZE(HDR) + IF ( S[0] NE 1 ) OR ( S[2] NE 7 ) THEN $ + MESSAGE,'FITS Header (first parameter) must be a string array' +; +; Convert the selected keyword NAME to uppercase. +; + NAM = STRTRIM( STRUPCASE(NAME) ) +; +; Determine if NAME is of form 'keyword*'. If so, then strip off the '*', and +; set the VECTOR flag. One must consider the possibility that NAM is an empty +; string. +; + NAMELENGTH1 = (STRLEN(NAM) - 1) > 1 + IF STRPOS( NAM, '*' ) EQ NAMELENGTH1 THEN BEGIN + NAM = STRMID( NAM, 0, NAMELENGTH1) + VECTOR = 1 ;Flag for vector output + NAME_LENGTH = STRLEN(NAM) ;Length of name + NUM_LENGTH = 8 - NAME_LENGTH ;Max length of number portion + IF NUM_LENGTH LE 0 THEN MESSAGE, $ + 'Keyword length must be 8 characters or less' +; +; Otherwise, extend NAME with blanks to eight characters. +; + ENDIF ELSE BEGIN + WHILE STRLEN(NAM) LT 8 DO NAM = NAM + ' ' + VECTOR = 0 + ENDELSE +; +; If of the form 'keyword*', then find all instances of 'keyword' followed by +; a number. Store the positions of the located keywords in NFOUND, and the +; value of the number field in NUMBER. +; + IF N_ELEMENTS(START) EQ 0 THEN START = -1L + START = LONG(START[0]) + IF NOT VECTOR AND START GE 0 THEN BEGIN + IF N_ELEMENTS(PRECHECK) EQ 0 THEN PRECHECK = 5 + IF N_ELEMENTS(POSTCHECK) EQ 0 THEN POSTCHECK = 20 + NHEADER = N_ELEMENTS(HDR) + MN = (START - PRECHECK) > 0 + MX = (START + POSTCHECK) < (NHEADER-1) ;Corrected bug + KEYWORD = STRMID(HDR[MN:MX], 0, 8) + ENDIF ELSE BEGIN + RESTART: + START = -1L + KEYWORD = STRMID( HDR, 0, 8) + ENDELSE + + IF VECTOR THEN BEGIN + NFOUND = WHERE(STRPOS(KEYWORD,NAM) GE 0, MATCHES) + IF ( MATCHES GT 0 ) THEN BEGIN + NUMST= STRMID(HDR[NFOUND], NAME_LENGTH, NUM_LENGTH) + NUMBER = INTARR(MATCHES)-1 + FOR I = 0, MATCHES-1 DO $ + IF VALID_NUM( NUMST[I], NUM) THEN NUMBER[I] = NUM + IGOOD = WHERE(NUMBER GE 0, MATCHES) + IF MATCHES GT 0 THEN BEGIN + NFOUND = NFOUND[IGOOD] + NUMBER = NUMBER[IGOOD] + G = WHERE(NUMBER GT 0, MATCHES) + IF MATCHES GT 0 THEN NUMBER = NUMBER[G] + ENDIF + ENDIF +; +; Otherwise, find all the instances of the requested keyword. If more than +; one is found, and NAME is not one of the special cases, then print an error +; message. +; + ENDIF ELSE BEGIN + NFOUND = WHERE(KEYWORD EQ NAM, MATCHES) + IF MATCHES EQ 0 AND START GE 0 THEN GOTO, RESTART + IF START GE 0 THEN NFOUND = NFOUND + MN + IF (MATCHES GT 1) AND (NAM NE 'HISTORY ') AND $ + (NAM NE 'COMMENT ') AND (NAM NE '') THEN $ + MESSAGE,/INFORMATIONAL, 'WARNING- Keyword ' + $ + NAM + 'located more than once in ' + ABORT + IF (MATCHES GT 0) THEN START = NFOUND[MATCHES-1] + ENDELSE +; +; Extract the parameter field from the specified header lines. If one of the +; special cases, then done. +; + IF MATCHES GT 0 THEN BEGIN + VALUE = MISSING_VALUE + LINE = HDR[NFOUND] + SVALUE = STRTRIM( STRMID(LINE,9,71),2) + IF (NAM EQ 'HISTORY ') OR (NAM EQ 'COMMENT ') OR $ + (NAM EQ ' ') THEN BEGIN + VALUE = STRTRIM( STRMID(LINE,8,72),2) + COMMENTS = STRARR(N_ELEMENTS(VALUE)) +; +; Otherwise, test to see if the parameter contains a string, signalled by +; beginning with a single quote character (') (apostrophe). +; + END ELSE FOR I = 0,MATCHES-1 DO BEGIN + IF ( STRMID(SVALUE[I],0,1) EQ "'" ) THEN BEGIN + TEST = STRMID( SVALUE[I],1,STRLEN( SVALUE[I] )-1) + NEXT_CHAR = 0 + OFF = 0 + VALUE = '' +; +; Find the next apostrophe. +; +NEXT_APOST: + ENDAP = STRPOS(TEST, "'", NEXT_CHAR) + IF ENDAP LT 0 THEN MESSAGE, $ + 'WARNING: Value of '+NAME+' invalid in '+ABORT+ " (no trailing ')", /info + VALUE = VALUE + STRMID( TEST, NEXT_CHAR, ENDAP-NEXT_CHAR ) +; +; Test to see if the next character is also an apostrophe. If so, then the +; string isn't completed yet. Apostrophes in the text string are signalled as +; two apostrophes in a row. +; + IF STRMID( TEST, ENDAP+1, 1) EQ "'" THEN BEGIN + VALUE = VALUE + "'" + NEXT_CHAR = ENDAP+2 + GOTO, NEXT_APOST + ENDIF +; +; Extract the comment, if any. +; + SLASH = STRPOS(TEST, "/", ENDAP) + IF SLASH LT 0 THEN COMMENT = '' ELSE $ + COMMENT = STRMID(TEST, SLASH+1, STRLEN(TEST)-SLASH-1) + +; +; CM 19 Sep 1997 +; This is a string that could be continued on the next line. Check this +; possibility with the following four criteria: *1) Ends with '&' +; (2) Next line is CONTINUE (3) LONGSTRN keyword is present (recursive call to +; FXPAR) 4. /NOCONTINE is not set + + IF NOT KEYWORD_SET(NOCONTINUE) THEN BEGIN + OFF = OFF + 1 + VAL = STRTRIM(VALUE,2) + + IF (STRLEN(VAL) GT 0) AND $ + (STRMID(VAL, STRLEN(VAL)-1, 1) EQ '&') AND $ + (STRMID(HDR[NFOUND[I]+OFF],0,8) EQ 'CONTINUE') THEN BEGIN + IF (SIZE(FXPAR(HDR, 'LONGSTRN',/NOCONTINUE)))[1] EQ 7 THEN BEGIN + VALUE = STRMID(VAL, 0, STRLEN(VAL)-1) + TEST = HDR[NFOUND[I]+OFF] + TEST = STRMID(TEST, 8, STRLEN(TEST)-8) + TEST = STRTRIM(TEST, 2) + IF STRMID(TEST, 0, 1) NE "'" THEN MESSAGE, $ + 'ERROR: Invalidly CONTINUEd string in '+ABORT + NEXT_CHAR = 1 + GOTO, NEXT_APOST + ENDIF + ENDIF + ENDIF + +; +; If not a string, then separate the parameter field from the comment field. +; If there is no value field, then use the default "missing" value. +; + ENDIF ELSE BEGIN + VALUE = MISSING_VALUE + TEST = SVALUE[I] + IF TEST EQ '' THEN BEGIN + COMMENT = '' + GOTO, GOT_VALUE + ENDIF + SLASH = STRPOS(TEST, "/") + IF SLASH GE 0 THEN BEGIN + COMMENT = STRMID(TEST, SLASH+1, STRLEN(TEST)-SLASH-1) + IF SLASH GT 0 THEN TEST = STRMID(TEST, 0, SLASH) ELSE $ + GOTO, GOT_VALUE + END ELSE COMMENT = '' +; +; Find the first word in TEST. Is it a logical value ('T' or 'F')? +; + TEST2 = TEST + VALUE = GETTOK(TEST2,' ') + TEST2 = STRTRIM(TEST2,2) + IF ( VALUE EQ 'T' ) THEN BEGIN + VALUE = 1 + END ELSE IF ( VALUE EQ 'F' ) THEN BEGIN + VALUE = 0 + END ELSE BEGIN +; +; Test to see if a complex number. It's a complex number if the value and the +; next word, if any, both are valid numbers. +; + IF STRLEN(TEST2) EQ 0 THEN GOTO, NOT_COMPLEX + VALUE2 = GETTOK(TEST2,' ') + IF VALID_NUM(VALUE,VAL1) AND VALID_NUM(VALUE2,VAL2) $ + THEN BEGIN + VALUE = COMPLEX(VAL1,VAL2) + GOTO, GOT_VALUE + ENDIF +; +; Not a complex number. Decide if it is a floating point, double precision, +; or integer number. If an error occurs, then a string value is returned. +; If the integer is not within the range of a valid long value, then it will +; be converted to a double. +; +NOT_COMPLEX: + ON_IOERROR, GOT_VALUE + VALUE = TEST + IF NOT VALID_NUM(VALUE) THEN GOTO, GOT_VALUE + IF (STRPOS(VALUE,'.') GE 0) OR (STRPOS(VALUE,'E') $ + GE 0) OR (STRPOS(VALUE,'D') GE 0) THEN BEGIN + IF ( STRPOS(VALUE,'D') GT 0 ) OR $ + ( STRLEN(VALUE) GE 8 ) THEN BEGIN + VALUE = DOUBLE(VALUE) + END ELSE VALUE = FLOAT(VALUE) + ENDIF ELSE BEGIN + LMAX = 2.0D^31 - 1.0D + LMIN = -2.0D^31 ;Typo fixed Feb 2010 + VALUE = LONG64(VALUE) + if (VALUE GE LMIN) and (VALUE LE LMAX) THEN $ + VALUE = LONG(VALUE) + ENDELSE + +; +GOT_VALUE: + ON_IOERROR, NULL + ENDELSE + ENDELSE ; if string +; +; Add to vector if required. +; + IF VECTOR THEN BEGIN + MAXNUM = MAX(NUMBER) + IF ( I EQ 0 ) THEN BEGIN + IF N_ELEMENTS(DATATYPE) EQ 0 THEN BEGIN + ;; Data type determined from keyword + SZ_VALUE = SIZE(VALUE) + ENDIF ELSE BEGIN + ;; Data type requested by user + SZ_VALUE = SIZE(DATATYPE[0]) + ENDELSE + RESULT = MAKE_ARRAY( MAXNUM, TYPE=SZ_VALUE[1]) + COMMENTS = STRARR(MAXNUM) + ENDIF + RESULT[ NUMBER[I]-1 ] = VALUE + COMMENTS[ NUMBER[I]-1 ] = COMMENT + ENDIF ELSE BEGIN + COMMENTS = COMMENT + ENDELSE + ENDFOR +; +; Set the value of !ERR for the number of matches for vectors, or simply 0 +; otherwise. +; + IF VECTOR THEN BEGIN + !ERR = MATCHES + RETURN, RESULT + ENDIF ELSE !ERR = 0 +; +; Error point for keyword not found. +; + ENDIF ELSE BEGIN + IF ABORT_RETURN THEN MESSAGE,'Keyword '+NAM+' not found in '+ABORT + !ERR = -1 + ENDELSE +; + RETURN, VALUE + END diff --git a/modules/idl_downloads/astro/pro/fxparpos.pro b/modules/idl_downloads/astro/pro/fxparpos.pro new file mode 100644 index 0000000..eb3b0ec --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxparpos.pro @@ -0,0 +1,85 @@ + FUNCTION FXPARPOS, KEYWRD, IEND, BEFORE=BEFORE, AFTER=AFTER +;+ +; NAME: +; FXPARPOS() +; Purpose : +; Finds position to insert record into FITS header. +; Explanation : +; Finds the position to insert a record into a FITS header. Called from +; FXADDPAR. +; Use : +; Result = FXPARPOS(KEYWRD, IEND [, BEFORE=BEFORE ] [, AFTER=AFTER ]) +; Inputs : +; KEYWRD = Array of eight-character keywords in header. +; IEND = Position of END keyword. +; Opt. Inputs : +; None. +; Outputs : +; Result of function is position to insert record. +; Opt. Outputs: +; None. +; Keywords : +; BEFORE = Keyword string name. The parameter will be placed before the +; location of this keyword. For example, if BEFORE='HISTORY' +; then the parameter will be placed before the first history +; location. This applies only when adding a new keyword; +; keywords already in the header are kept in the same position. +; +; AFTER = Same as BEFORE, but the parameter will be placed after the +; location of this keyword. This keyword takes precedence over +; BEFORE. +; +; If neither BEFORE or AFTER keywords are passed, then IEND is returned. +; +; Calls : +; None. +; Common : +; None. +; Restrictions: +; KEYWRD and IEND must be consistent with the relevant FITS header. +; Side effects: +; None. +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; William Thompson, Jan 1992. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version : +; Version 1, 12 April 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR,2 ;Return to caller +; +; Check the number of parameters. +; + IF N_PARAMS() NE 2 THEN MESSAGE, $ + 'Required parameters are KEYWRD and IEND' +; +; If the AFTER keyword has been entered, then find the location. +; + IF N_ELEMENTS(AFTER) EQ 1 THEN BEGIN + KEY_AFTER = STRING(REPLICATE(32B,8)) + STRPUT,KEY_AFTER,STRUPCASE(STRTRIM(AFTER,2)),0 + ILOC = WHERE(KEYWRD EQ KEY_AFTER,NLOC) + IF NLOC GT 0 THEN RETURN, (MAX(ILOC)+1) < IEND + ENDIF +; +; If AFTER wasn't entered or found, and if the BEFORE keyword has been +; entered, then find the location. +; + IF N_ELEMENTS(BEFORE) EQ 1 THEN BEGIN + KEY_BEFORE = STRING(REPLICATE(32B,8)) + STRPUT,KEY_BEFORE,STRUPCASE(STRTRIM(BEFORE,2)),0 + ILOC = WHERE(KEYWRD EQ KEY_BEFORE,NLOC) + IF NLOC GT 0 THEN RETURN,ILOC[0] + ENDIF +; +; Otherwise, simply return IEND. +; + RETURN,IEND + END diff --git a/modules/idl_downloads/astro/pro/fxposit.pro b/modules/idl_downloads/astro/pro/fxposit.pro new file mode 100644 index 0000000..ba2263d --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxposit.pro @@ -0,0 +1,267 @@ + FUNCTION FXPOSIT, XFILE, EXT_NO, readonly=readonly, COMPRESS=COMPRESS, $ + SILENT = Silent, EXTNUM = extnum, ERRMSG= ERRMSG, $ + LUNIT = lunit, UNIXPIPE= unixpipe, FPACK= fpack, $ + NO_FPACK = no_fpack,HEADERONLY=headeronly +;+ +; NAME: +; FXPOSIT +; PURPOSE: +; Return the unit number of a FITS file positioned at specified extension +; EXPLANATION: +; The FITS file will be ready to be read at the beginning of the +; specified extension. Either an extension number or extension name +; can be specified. Called by headfits.pro, mrdfits.pro +; +; Modified in March 2009 to set the /SWAP_IF_LITTLE_ENDIAN keyword +; when opening a file, and **may not be compatible with earlier versions** +; CALLING SEQUENCE: +; unit=FXPOSIT(FILE, EXT_NO_OR_NAME, /READONLY, COMPRESS=program, +; UNIXPIPE=, ERRMSG= , EXTNUM= , UNIT=, /SILENT +; /FPACK, /NO_FPACK +; +; INPUT PARAMETERS: +; FILE = FITS file name, scalar string. If an empty string is supplied +; then the user will be prompted for the file name. The user +; will also be prompted if a wild card is supplied, and more than +; one file matches the wildcard. +; EXT_NO_OR_NAME = Either the extension to be moved to (scalar +; nonnegative integer) or the name of the extension to read +; (scalar string) +; +; RETURNS: +; Unit number of file or -1 if an error is detected. +; +; OPTIONAL INPUT KEYWORD PARAMETER: +; COMPRESS - If this keyword is set and non-zero, then then treat +; the file as compressed. If 1 assume a gzipped file. +; and use IDLs internal decompression facility. For Unix +; compressed or bzip2 compressed files spawn off a process to +; decompress and use its output as the FITS stream. If the +; keyword is not 1, then use its value as a string giving the +; command needed for decompression. +; /FPACK - Signal that the file is compressed with the FPACK software. +; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) By default, +; (FXPOSIT will assume that if the file name extension ends in +; .fz that it is fpack compressed.) The FPACK software must +; be installed on the system +; /NO_FPACK - The unit will only be used to read the FITS header. In +; that case FPACK compressed files need not be uncompressed. +; LUNIT - Integer giving the file unit number. Use this keyword if +; you want to override the default use of GET_LUN to obtain +; a unit number. +; /READONLY - If this keyword is set and non-zero, then OPENR rather +; than OPENU will be used to open the FITS file. Note that +; compressed files are always set to /READONLY +; /SILENT If set, then suppress any messages about invalid characters +; in the FITS file. +; +; OPTIONAL OUTPUT KEYWORDS: +; EXTNUM - Nonnegative integer give the extension number actually read +; Useful only if the extension was specified by name. +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; UNIXPIPE - If set to 1, then the FITS file was opened with a UNIX pipe +; rather than with the OPENR command. This is only required +; when reading a FPACK, bzip or Unix compressed file. Note +; that automatic byteswapping cannnot be set for a Unix pipe, +; since the SWAP_IF_LITTLE_ENDIAN keyword is only available for the +; OPEN command, and it is the responsibility of the calling +; routine to perform the byteswapping. +; SIDE EFFECTS: +; Opens and returns a file unit. +; PROCEDURE: +; Open the appropriate file, or spawn a command and intercept +; the output. +; Call FXMOVE to get to the appropriate extension. +; PROCEDURE CALLS: +; FXMOVE() +; MODIFICATION HISTORY: +; Derived from William Thompson's FXFINDEND routine. +; Modified by T.McGlynn, 5-October-1994. +; Modified by T.McGlynn, 25-Feb-1995 to handle compressed +; files. Pipes cannot be accessed using FXHREAD so +; MRD_HREAD was written. +; W. Landsman 23-Apr-1997 Force the /bin/sh shell when uncompressing +; T. McGlynn 03-June-1999 Use /noshell option to get rid of processes left by spawn. +; Use findfile to retain ability to use wildcards +; W. Landsman 03-Aug-1999 Use EXPAND_TILDE under Unix to find file +; T. McGlynn 04-Apr-2000 Put reading code into FXMOVE, +; additional support for compression from D.Palmer. +; W. Landsman/D.Zarro 04-Jul-2000 Added test for !VERSION.OS EQ 'Win32' (WinNT) +; W. Landsman 12-Dec-2000 Added /SILENT keyword +; W. Landsman April 2002 Use FILE_SEARCH for V5.5 or later +; W. Landsman Feb 2004 Assume since V5.3 (OPENR,/COMPRESS available) +; W. Landsman,W. Thompson, 2-Mar-2004, Add support for BZIP2 +; W. Landsman Don't leave open file if an error occurs +; W. Landsman Sep 2004 Treat FTZ extension as gzip compressed +; W. Landsman Feb 2006 Removed leading spaces (prior to V5.5) +; W. Landsman Nov 2006 Allow specification of extension name +; Added EXTNUM, ERRMSG keywords +; W. Landsman/N.Piskunov Dec 2007 Added LUNIT keyword +; W. Landsman Mar 2009 OPEN with /SWAP_IF_LITTLE_ENDIAN +; Added UNIXPIPE output keyword +; N. Rich May 2009 Check if filename is an empty string +; W. Landsman May 2009 Support FPACK compressed files +; Added /FPACK, /HEADERONLY keywords +; W.Landsman July 2009 Deprecated /HEADERONLY add /NO_FPACK +; W.Landsman July 2011 Check for SIMPLE in first 8 chars +; Use gunzip to decompress Unix. Z file since compress utility +; often not installed anymore) +; W. Landsman October 2012 Add .fz extension if /FPACK set +; W. Landsman July 2013 More diagnostics if file not found +;- +; + On_Error,2 + compile_opt idl2 +; +; Check the number of parameters. +; + IF N_Params() LT 2 THEN BEGIN + PRINT,'SYNTAX: UNIT = FXPOSIT(FILE, EXT_NO, /Readonly,' + $ + 'ERRMSG= , /SILENT, compress=prog, LUNIT = lunit)' + RETURN,-1 + ENDIF + PRINTERR = ~ARG_PRESENT(ERRMSG) + ERRMSG = '' + UNIXPIPE=0 +; The /headeronly keyword has been replaced with /no_fpack + if ~keyword_set(no_fpack) then no_fpack = keyword_set(headeronly) + exten = ext_no + + COUNT=0 + IF XFILE[0] NE '' THEN BEGIN + FILE = FILE_SEARCH(XFILE, COUNT=COUNT) + IF COUNT GT 1 THEN $ + FILE = DIALOG_PICKFILE(FILTER=XFILE, /MUST_EXIST, $ + TITLE = 'Please select a FITS file') $ + ELSE IF COUNT EQ 0 THEN BEGIN + ERRMSG = 'Specified FITS file not found: ' + XFILE[0] + IF PRINTERR THEN MESSAGE,ERRMSG,/CON + RETURN, -1 ; Don't print anything out, just report an error + ENDIF + ENDIF ELSE $ + FILE =DIALOG_PICKFILE(FILTER=['*.fit*;*.fts*;*.img*;*.FIT*'], $ + TITLE='Please select a FITS file',/MUST_EXIST) + + IF FILE[0] EQ '' THEN BEGIN + ERRMSG = 'No FITS file specified ' + IF PRINTERR THEN MESSAGE,ERRMSG,/CON + RETURN, -1 ; Don't print anything out, just report an error + ENDIF + + FILE = FILE[0] + IF KEYWORD_SET(FPACK) then $ + if strlowcase(strmid(FILE,2,3,/reverse)) NE '.fz' then $ + FILE += '.fz' + +; +; Check if logical unit number is specified explicitly. +; + IF KEYWORD_SET(LUNIT) THEN BEGIN + UNIT=LUNIT + GLUN = 0 + ENDIF ELSE BEGIN + UNIT = -1 + GLUN = 1 + ENDELSE +; +; Check if this is a compressed file. +; + UCMPRS = ' ' + IF KEYWORD_SET(compress) THEN BEGIN + IF strcompress(string(compress),/remo) eq '1' THEN BEGIN + compress = 'gunzip' + ENDIF + UCMPRS = compress; + ENDIF ELSE IF KEYWORD_SET(FPACK) THEN $ + UCMPRS = 'funpack' $ + ELSE BEGIN + + LEN = STRLEN(FILE) + IF LEN GT 3 THEN $ + tail = STRLOWCASE(STRMID(file, len-3, 3)) $ + ELSE tail = ' ' + + IF STRMID(tail,1,2) EQ '.z' THEN $ + UCMPRS = 'gunzip' $ + ELSE IF (tail EQ '.gz') || (tail EQ 'ftz') THEN $ + UCMPRS = 'gzip' $ + ELSE IF tail EQ 'bz2' THEN $ + UCMPRS = 'bunzip2' $ + ELSE IF ~KEYWORD_SET(NO_FPACK) THEN $ + IF tail EQ '.fz' THEN UCMPRS = 'funpack' + + ENDELSE + +; Handle compressed files which are always opened for Read only. + + IF UCMPRS EQ 'gzip' THEN BEGIN + + OPENR, UNIT, FILE, /COMPRESS, GET_LUN=glun, ERROR = ERROR, $ + /SWAP_IF_LITTLE + IF ERROR NE 0 THEN BEGIN + IF PRINTERR THEN PRINT,!ERROR_STATE.MSG ELSE $ + ERRMSG = !ERROR_STATE.MSG + RETURN,-1 + ENDIF + + ENDIF ELSE IF UCMPRS NE ' ' THEN BEGIN +; Handle FPACK compressed file. If an extension name is supplied then +; first recursively call FXPOSIT to get the extension number. Then open +; the bidirectional pipe. + if UCMPRS EQ 'funpack' then begin + if size(exten,/TNAME) EQ 'STRING' THEN BEGIN + unit = fxposit( file, ext_no, /no_fpack,extnum=extnum) + free_lun,unit + exten = extnum + endif + SPAWN, [UCMPRS,'-S',FILE], UNIT=UNIT, /NOSHELL + ENDIF else $ + SPAWN, [UCMPRS,'-c',FILE], UNIT=UNIT, /NOSHELL + UNIXPIPE = 1 + + ENDIF ELSE BEGIN +; +; Go to the start of the file. +; + IF KEYWORD_SET(READONLY) THEN $ + OPENR, UNIT, FILE, GET_LUN=glun, ERROR = ERROR, $ + /SWAP_IF_LITTLE ELSE $ + OPENU, UNIT, FILE, GET_LUN=glun, ERROR = ERROR, $ + /SWAP_IF_LITTLE + + IF ERROR NE 0 THEN BEGIN + IF PRINTERR THEN PRINT,!ERROR_STATE.MSG ELSE $ + ERRMSG = !ERROR_STATE.MSG + RETURN,-1 + ENDIF + ENDELSE + + IF SIZE(EXT_NO,/TNAME) NE 'STRING' THEN $ + IF EXT_NO LE 0 THEN RETURN, UNIT + +;For Uncompresed files test that the first 8 characters are 'SIMPLE' + + IF ucmprs EQ ' ' THEN BEGIN + simple = BytArr(6) + READU,unit,simple + if string(simple) NE 'SIMPLE' then begin + IF ~KEYWORD_SET(LUNIT) THEN Free_Lun, unit + ERRMSG = "ERROR - FITS File must begin with 'SIMPLE'" + if printerr THEN MESSAGE,errmsg,/CON + return,-1 + endif + point_lun,unit,0 + endif + + stat = FXMOVE(unit, exten, SILENT = Silent, EXT_NO = extnum, $ + ERRMSG=errmsg) + + IF stat LT 0 THEN BEGIN + IF ~KEYWORD_SET(LUNIT) THEN Free_Lun, unit + IF PrintErr THEN MESSAGE,ErrMsg + RETURN, stat + ENDIF ELSE RETURN, unit +END diff --git a/modules/idl_downloads/astro/pro/fxread.pro b/modules/idl_downloads/astro/pro/fxread.pro new file mode 100644 index 0000000..d609ff2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxread.pro @@ -0,0 +1,588 @@ + PRO FXREAD, FILENAME, DATA, HEADER, P1, P2, P3, P4, P5, $ + NANVALUE=NANVALUE, PROMPT=PROMPT, AVERAGE=AVERAGE, $ + YSTEP=Y_STEP, NOSCALE=NOSCALE, NOUPDATE=NOUPDATE, $ + ERRMSG=ERRMSG, NODATA=NODATA, COMPRESS = COMPRESS, $ + EXTENSION=EXTENSION0 +;+ +; NAME: +; FXREAD +; Purpose : +; Read basic FITS files. +; Explanation : +; Read an image array from a disk FITS file. Optionally allows the +; user to read in only a subarray and/or every Nth pixel. +; Use : +; FXREAD, FILENAME, DATA [, HEADER [, I1, I2 [, J1, J2 ]] [, STEP]] +; Inputs : +; FILENAME = String containing the name of the file to be read. +; Opt. Inputs : +; I1,I2 = Data range to read in the first dimension. If passed, then +; HEADER must also be passed. If not passed, or set to -1,-1, +; then the entire range is read. +; J1,J2 = Data range to read in the second dimension. If passed, then +; HEADER and I1,J2 must also be passed. If not passed, or set +; to -1,-1, then the entire range is read. +; STEP = Step size to use in reading the data. If passed, then +; HEADER must also be passed. Default value is 1. Ignored if +; less than 1. +; Outputs : +; DATA = Data array to be read from the file. +; Opt. Outputs: +; HEADER = String array containing the header for the FITS file. +; Keywords : +; /COMPRESS - If this keyword is set and non-zero, then then treat +; the file as gzip compressed. By default FXREAD assumes +; the file is gzip compressed if it ends in ".gz" +; NANVALUE = Value signalling data dropout. All points corresponding to +; IEEE NaN (not-a-number) are set to this value. Ignored +; unless DATA is of type float or double-precision. +; EXTENSION = FITS extension. It can be a scalar integer, +; indicating the extension number (extension number 0 +; is the primary HDU). It can also be a scalar string, +; indicating the extension name (EXTNAME keyword). +; Default: 0 (primary HDU) +; PROMPT = If set, then the optional parameters are prompted for at the +; keyboard. +; AVERAGE = If set, then the array size is reduced by averaging pixels +; together rather than by subselecting pixels. Ignored unless +; STEP is nontrivial. Note: this is much slower. +; YSTEP = If passed, then STEP is the step size in the 1st dimension, +; and YSTEP is the step size in the 2nd dimension. Otherwise, +; STEP applies to both directions. +; NOSCALE = If set, then the output data will not be scaled using the +; optional BSCALE and BZERO keywords in the FITS header. +; Default is to scale, if and only if BSCALE and BZERO are +; present and nontrivial. +; NOUPDATE = If set, then the optional BSCALE and BZERO keywords in the +; optional HEADER array will not be changed. The default is +; to reset these keywords to BSCALE=1, BZERO=0. Ignored if +; NOSCALE is set. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXREAD, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; NODATA = If set, then the array is not read in, but the +; primary header is read. +; +; Calls : +; GET_DATE, FXADDPAR, FXHREAD, FXPAR, WHERENAN +; Common : +; None. +; Restrictions: +; Groups are not supported. +; +; The optional parameters I1, I2, and STEP only work with one or +; two-dimensional arrays. J1 and J2 only work with two-dimensional +; arrays. +; +; Use of the AVERAGE keyword is not compatible with arrays with missing +; pixels. +; +; Side effects: +; If the keywords BSCALE and BZERO are present in the FITS header, and +; have non-trivial values, then the returned array DATA is formed by the +; equation +; +; DATA = BSCALE*original + BZERO +; +; However, this behavior can overridden by using the /NOSCALE keyword. +; +; If the data is scaled, then the optional HEADER array is changed so +; that BSCALE=1 and BZERO=0. This is so that these scaling parameters +; are not applied to the data a second time by another routine. Also, +; history records are added storing the original values of these +; constants. Note that only the returned array is modified--the header +; in the FITS file itself is untouched. +; +; If the /NOUPDATE keyword is set, however, then the BSCALE and BZERO +; keywords are not changed. It is then the user's responsibility to +; ensure that these parameters are not reapplied to the data. In +; particular, these keywords should not be present in any header when +; writing another FITS file, unless the user wants their values to be +; applied when the file is read back in. Otherwise, FITS readers will +; read in the wrong values for the data array. +; +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, May 1992, based in part on READFITS by W. Landsman, and +; STSUB by M. Greason and K. Venkatakrishna. +; W. Thompson, Jun 1992, added code to interpret BSCALE and BZERO +; records, and added NOSCALE and NOUPDATE +; keywords. +; W. Thompson, Aug 1992, changed to call FXHREAD, and to add history +; records for BZERO, BSCALE. +; Minimium IDL Version: +; V6.0 (uses V6.0 notation) +; Written : +; William Thompson, GSFC, May 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 17 November 1993. +; Corrected bug with AVERAGE keyword on non-IEEE compatible +; machines. +; Corrected bug with subsampling on VAX machines. +; Version 3, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 4, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 5, Zarro (SAC/GSFC), 14 Feb 1997 +; Added I/O error checking +; Version 6, 20-May-1998, David Schlegel/W. Thompson +; Allow a single pixel to be read in. +; Change the signal to read in the entire array to be -1 +; Version 7 C. Markwardt 22 Sep 2003 +; If the image is empty (NAXIS EQ 0), or NODATA is set, then +; return only the header. +; Version 8 W. Landsman 29 June 2004 +; Added COMPRESS keyword, check for .gz extension +; Version 9, William Thompson, 19-Aug-2004 +; Make sure COMPRESS is treated as a scalar +; Version 10, Craig Markwardt, 01 Mar 2004 +; Add EXTENSION keyword and ability to read different +; extensions than the primary one. +; Version 11, W. Landsman September 2006 +; Assume since V5.5, remove VMS support +; Version 11.1, W. Landsman November 2007 +; Allow for possibility number of bytes requires 64 bit integer +; Version 12, William Thompson, 18-Jun-2010, update BLANK value. +; Version 13, W. Landsman Remove IEEE_TO_HOST, V6.0 notation +; Version 14, William Thompson, 25-Sep-2014, fix BSCALE bug in version 13 +;- +; + ON_ERROR, 2 +; +; This parameter will be used later in conjunction with the average keyword. +; + ALREADY_CONVERTED = 0 + READ_OK=0 +; +; Parse the input parameters. +; + CASE N_PARAMS() OF + 2: BEGIN & I1=-1 & I2=-1 & J1=-1 & J2=-1 & STEP=1 & END + 3: BEGIN & I1=-1 & I2=-1 & J1=-1 & J2=-1 & STEP=1 & END + 4: BEGIN & I1=-1 & I2=-1 & J1=-1 & J2=-1 & STEP=P1 & END + 5: BEGIN & I1=P1 & I2=P2 & J1=-1 & J2=-1 & STEP=1 & END + 6: BEGIN & I1=P1 & I2=P2 & J1=-1 & J2=-1 & STEP=P3 & END + 7: BEGIN & I1=P1 & I2=P2 & J1=P3 & J2=P4 & STEP=1 & END + 8: BEGIN & I1=P1 & I2=P2 & J1=P3 & J2=P4 & STEP=P5 & END + ELSE: BEGIN + MESSAGE = 'Syntax: FXREAD, FILENAME, DATA ' + $ + '[, HEADER [, I1, I2 [, J1, J2 ] [, STEP ]]' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END + ENDCASE + + ;; Extension number + IF N_ELEMENTS(EXTENSION0) EQ 0 THEN EXTENSION = 0L $ + ELSE EXTENSION = EXTENSION0[0] + + SZ = SIZE(EXTENSION) + ETYPE = SZ[SZ[0]+1] + IF ETYPE EQ 8 THEN BEGIN + MESSAGE = 'EXTENSION must not be a structure' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + + +; +; Determine if file is compressed, get the UNIT number, and open the file. +; + IF NOT KEYWORD_SET(COMPRESS) THEN $ + COMPRESS = STRLOWCASE( STRMID(FILENAME, STRLEN(FILENAME)-3,3)) EQ '.gz' + OPENR, UNIT, FILENAME, /GET_LUN, ERROR=ERROR,COMPRESS=COMPRESS[0] + IF ERROR NE 0 THEN BEGIN + MESSAGE='Error opening '+FILENAME + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Read in the FITS header. +; + + ;; Starting extension number is zero + I_EXT = 0L + FOUND_EXT = 0 + + WHILE NOT FOUND_EXT DO BEGIN + FXHREAD,UNIT,HEADER,STATUS + IF STATUS NE 0 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Unable to read requested FITS header extension' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF +; +; Extract the keywords BITPIX, NAXIS, NAXIS1, ... +; + START = 0L + BITPIX = FXPAR(HEADER,'BITPIX', START=START) + NAXIS = FXPAR(HEADER,'NAXIS', START=START) + GCOUNT = FXPAR(HEADER,'GCOUNT', START=START) + IF GCOUNT EQ 0 THEN GCOUNT = 1 + PCOUNT = FXPAR(HEADER,'PCOUNT', START=START) + IF NAXIS GT 0 THEN BEGIN + DIMS = FXPAR(HEADER,'NAXIS*') ;Read dimensions + NDATA = DIMS[0] + IF NAXIS GT 1 THEN FOR I=2,NAXIS DO NDATA = NDATA*DIMS[I-1] + ENDIF ELSE NDATA = 0 + NBYTES = LONG64(ABS(BITPIX) / 8) * GCOUNT * (PCOUNT + NDATA) + NREC = (NBYTES + 2879) / 2880 + + IF ETYPE EQ 7 THEN BEGIN + EXTNAME = STRTRIM(STRUPCASE(FXPAR(HEADER,'EXTNAME', $ + START=START)),2) + IF EXTNAME EQ EXTENSION THEN FOUND_EXT = 1 + END ELSE IF I_EXT EQ EXTENSION THEN FOUND_EXT = 1 + + IF NOT FOUND_EXT THEN BEGIN + ;; Check to be sure there are extensions + IF I_EXT EQ 0 THEN BEGIN + IF NOT FXPAR(HEADER,'EXTEND', START=START) THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Requested extension not found, and file ' + $ + FILENAME + ' does not contain extensions' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDIF + + POINT_LUN, -UNIT, POINTLUN ;Current position + MHEAD0 = POINTLUN + NREC*2880L + POINT_LUN, UNIT, MHEAD0 ;Next FITS extension + + I_EXT++ + ENDIF + ENDWHILE + + ;; + ;; If we got here, then we have arrived at the requested + ;; extension. We still need to be sure that it is an image + ;; and not a table (for extensions beyond the primary one, + ;; that is). + ;; + IF I_EXT GT 0 THEN BEGIN + XTENSION = STRTRIM(STRUPCASE(FXPAR(HEADER,'XTENSION', START=START)),2) + IF (XTENSION NE 'IMAGE') THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Extension ' + STRTRIM(EXTENSION,2) + $ + ' is not an image' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + ENDIF + + ;; Handle case of empty image, or no data requested + IF NAXIS EQ 0 OR KEYWORD_SET(NODATA) THEN BEGIN + ;; Make DATA an undefined variable, reflecting no data + DATA = 0 & DUMMY = TEMPORARY(DATA) + + ERRMSG = '' + FREE_LUN,UNIT + RETURN + ENDIF + + DIMS = FXPAR(HEADER,'NAXIS*') + N1 = DIMS[0] + IF NAXIS EQ 2 THEN N2 = DIMS[1] ELSE N2 = 1 +; +; Determine the array type from the keyword BITPIX. +; + CASE BITPIX OF + 8: IDLTYPE = 1 ; Byte + 16: IDLTYPE = 2 ; Integer*2 + 32: IDLTYPE = 3 ; Integer*4 + -32: IDLTYPE = 4 ; Real*4 + -64: IDLTYPE = 5 ; Real*8 + ENDCASE +; +; Set the default values for the optional parameters. +; + IF (I1 EQ -1) && (I2 EQ -1) THEN BEGIN + I1 = 0 + I2 = N1-1 + ENDIF + IF (J1 EQ -1) && (J2 EQ -1) THEN BEGIN + J1 = 0 + J2 = N2-1 + ENDIF +; +; If the prompt keyword was set, the prompt for the parameters. +; + IF KEYWORD_SET(PROMPT) THEN BEGIN + ANSWER = '' + READ,'Enter lower limit for X ['+STRTRIM(I1,2)+']: ', ANSWER + IF ANSWER NE '' THEN I1 = (ANSWER) +; + ANSWER = '' + READ,'Enter upper limit for X ['+STRTRIM(I2,2)+']: ', ANSWER + IF ANSWER NE '' THEN I2 = LONG(ANSWER) +; + ANSWER = '' + READ,'Enter lower limit for Y ['+STRTRIM(J1,2)+']: ', ANSWER + IF ANSWER NE '' THEN J1 = LONG(ANSWER) +; + ANSWER = '' + READ,'Enter upper limit for Y ['+STRTRIM(J2,2)+']: ', ANSWER + IF ANSWER NE '' THEN J2 = LONG(ANSWER) +; + ANSWER = '' + READ,'Enter step size ['+STRTRIM(STEP,2)+']: ', ANSWER + IF ANSWER NE '' THEN STEP = LONG(ANSWER) + ENDIF +; +; Differentiate between XSTEP and YSTEP. +; + XSTEP = STEP > 1 + IF N_ELEMENTS(Y_STEP) EQ 1 THEN YSTEP = Y_STEP ELSE YSTEP = XSTEP +; +; If any of the optional parameters were passed, then update the dimensions +; accordingly. First check I1 and I2. +; + IF (I1 NE 0) || (I2 NE N1-1) THEN BEGIN + IF NAXIS GT 2 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'Range parameters can only be set for ' + $ + 'one or two-dimensional arrays' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF (MIN([I1,I2]) LT 0) OR (MAX([I1,I2]) GE DIMS[0]) THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'I1,I2 must be in the range 0 to ' + $ + STRTRIM(DIMS[0]-1,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF I1 GT I2 THEN BEGIN + MESSAGE = 'I2 must be >= I1' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + DIMS[0] = I2 - I1 + 1 + ENDIF +; +; Next, check J1 and J2. +; + IF (J1 NE 0) || (J2 NE N2-1) THEN BEGIN + IF NAXIS NE 2 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'J1, J2 can only be set for ' + $ + 'two-dimensional arrays' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF (MIN([J1,J2]) LT 0) OR (MAX([J1,J2]) GE DIMS[1]) THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'J1,J2 must be in the range 0 to ' + $ + STRTRIM(DIMS[1]-1,2) + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF J1 GT J2 THEN BEGIN + MESSAGE = 'J2 must be >= J1' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + DIMS[1] = J2 - J1 + 1 + ENDIF +; +; Next, check XSTEP. Note that the dimensions of the final result are +; somewhat differ depending on whether the keyword AVERAGE is set or not. +; + IF XSTEP GT 1 THEN BEGIN + IF NAXIS GT 2 THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'STEP can only be set for one or ' + $ + 'two-dimensional arrays' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF XSTEP NE LONG(XSTEP) THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'STEP must be an integer value' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF KEYWORD_SET(AVERAGE) THEN BEGIN + DIMS[0] = DIMS[0] / LONG(XSTEP) + END ELSE BEGIN + DIMS[0] = LONG(DIMS[0] + XSTEP - 1) / LONG(XSTEP) + INDEX = LINDGEN(DIMS[0])*XSTEP + ENDELSE + ENDIF +; +; Finally, check YSTEP. This parameter is ignored for anything other than +; two-dimensional arrays. +; + IF (NAXIS EQ 2) && (YSTEP GT 1) THEN BEGIN + IF YSTEP NE LONG(YSTEP) THEN BEGIN + FREE_LUN,UNIT + MESSAGE = 'YSTEP must be an integer value' + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + END ELSE IF KEYWORD_SET(AVERAGE) THEN BEGIN + DIMS[1] = DIMS[1] / LONG(YSTEP) + END ELSE BEGIN + DIMS[1] = LONG(DIMS[1]+YSTEP-1) / LONG(YSTEP) + ENDELSE + END ELSE YSTEP = 1 +; +; Make the array. +; + DATA = MAKE_ARRAY(DIMENSION=DIMS,TYPE=IDLTYPE,/NOZERO) +; +; Find the start of the data to be read in. +; + POINT_LUN,-UNIT,OFFSET ;Current position + DELTA = N1*ABS(BITPIX)/8 + IF J1 NE 0 THEN BEGIN + OFFSET = OFFSET + J1*DELTA + POINT_LUN,UNIT,OFFSET + ENDIF +; +; If the I range, XSTEP or YSTEP is non-trivial, then read in the file line by +; line. If pixel averaging, then read in YSTEP lines. +; + ON_IOERROR,QUIT + IF (DIMS[0] NE N1) || (XSTEP GT 1) || (YSTEP GT 1) THEN BEGIN + IF NAXIS EQ 1 THEN NJ = 1 ELSE NJ = DIMS[1] + FOR J = 0,NJ-1 DO BEGIN + IF YSTEP GT 1 THEN POINT_LUN,UNIT,OFFSET+J*YSTEP*DELTA + IF (YSTEP GT 1) && KEYWORD_SET(AVERAGE) && (NAXIS EQ 2) $ + THEN LINE = MAKE_ARRAY(N1,YSTEP,TYPE=IDLTYPE,/NOZERO) $ + ELSE LINE = MAKE_ARRAY(N1,TYPE=IDLTYPE,/NOZERO) + READU,UNIT,LINE +; +; If I1,I2 do not match the array size, then extract the relevant subarray. +; + IF (I1 NE 0) || (I2 NE N1-1) THEN LINE = LINE[I1:I2,*] +; +; Suppose that the step size is non-trivial. If AVERAGE was set, then convert +; to the host format, and use REBIN to average the data. (Note that missing +; pixels are not correctly handled in this case.) Otherwise, select out the +; relevant portion of the data. +; + IF (XSTEP GT 1) || (YSTEP GT 1) THEN BEGIN + IF KEYWORD_SET(AVERAGE) THEN BEGIN + SWAP_ENDIAN_INPLACE, LINE, /SWAP_IF_LITTLE + ALREADY_CONVERTED = 1 + IF NAXIS EQ 1 THEN BEGIN + DATA[0,J] = REBIN(LINE[0:XSTEP*DIMS[0]]-1,DIMS[0]) + END ELSE BEGIN + DATA[0,J] = REBIN(LINE[0:XSTEP*DIMS[0]-1,*],DIMS[0],1) + ENDELSE + END ELSE DATA[0,J] = LINE[INDEX] +; +; Otherwise, if the step size is trivial, then simply store the line in the +; data array. +; + END ELSE BEGIN + DATA[0,J] = LINE + ENDELSE + ENDFOR +; +; Otherwise, if the file doesn't have to be read in line by line, then just +; read the data array. +; + END ELSE READU,UNIT,DATA +; +; Convert the data from IEEE to host format, keeping track of any IEEE NaN +; values. Don't do this if the conversion has already taken place. +; + IF ~ALREADY_CONVERTED THEN BEGIN + IF (N_ELEMENTS(NANVALUE) EQ 1) && (IDLTYPE GE 4) && $ + (IDLTYPE LE 6) THEN W = WHERENAN(DATA,COUNT) ELSE $ + COUNT = 0 + SWAP_ENDIAN_INPLACE,DATA, /SWAP_IF_LITTLE + END ELSE COUNT = 0 +; +; If the parameters BZERO and BSCALE are non-trivial, then adjust the array by +; these values. Also update the BLANK keyword, if present. +; + IF ~KEYWORD_SET(NOSCALE) THEN BEGIN + BZERO = FXPAR(HEADER,'BZERO') + BSCALE = FXPAR(HEADER,'BSCALE') + BLANK = FXPAR(HEADER,'BLANK',COUNT=NBLANK) + GET_DATE,DTE + IF (BSCALE NE 0) && (BSCALE NE 1) THEN BEGIN + DATA *= BSCALE + IF ~KEYWORD_SET(NOUPDATE) THEN BEGIN + FXADDPAR,HEADER,'BSCALE',1. + FXADDPAR,HEADER,'HISTORY',DTE + $ + ' applied BSCALE = '+ STRTRIM(BSCALE,2) + IF NBLANK EQ 1 THEN BEGIN + print, bscale, blank + BLANK *= BSCALE + FXADDPAR,HEADER,'BLANK',BLANK + ENDIF + ENDIF + ENDIF + IF BZERO NE 0 THEN BEGIN + DATA += BZERO + IF ~KEYWORD_SET(NOUPDATE) THEN BEGIN + FXADDPAR,HEADER,'BZERO',0. + FXADDPAR,HEADER,'HISTORY',DTE + $ + ' applied BZERO = '+ STRTRIM(BZERO,2) + IF NBLANK EQ 1 THEN BEGIN + BLANK += BZERO + FXADDPAR,HEADER,'BLANK',BLANK + ENDIF + ENDIF + ENDIF + ENDIF +; +; Store NANVALUE everywhere where the data corresponded to IEE NaN. +; + IF COUNT GT 0 THEN DATA[W] = NANVALUE +; +; Close the file and return. +; + READ_OK=1 +QUIT: ON_IOERROR,NULL + FREE_LUN, UNIT + IF NOT READ_OK THEN BEGIN + MESSAGE='Error reading file '+FILENAME + IF N_ELEMENTS(ERRMSG) NE 0 THEN BEGIN + ERRMSG = MESSAGE + RETURN + END ELSE MESSAGE, MESSAGE + ENDIF + IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = '' + RETURN + END diff --git a/modules/idl_downloads/astro/pro/fxwrite.pro b/modules/idl_downloads/astro/pro/fxwrite.pro new file mode 100644 index 0000000..30e2c7c --- /dev/null +++ b/modules/idl_downloads/astro/pro/fxwrite.pro @@ -0,0 +1,312 @@ + PRO FXWRITE, FILENAME, HEADER, DATA, NANVALUE=NANVALUE, $ + NOUPDATE=NOUPDATE, ERRMSG=ERRMSG, APPEND=APPEND +;+ +; NAME: +; FXWRITE +; Purpose : +; Write a disk FITS file. +; Explanation : +; Creates or appends to a disk FITS file and writes a FITS +; header, and optionally an image data array. +; Use : +; FXWRITE, FILENAME, HEADER [, DATA ] +; Inputs : +; FILENAME = String containing the name of the file to be written. +; HEADER = String array containing the header for the FITS file. +; Opt. Inputs : +; DATA = IDL data array to be written to the file. If not passed, +; then it is assumed that extensions will be added to the +; file. +; Outputs : +; None. +; Opt. Outputs: +; None. +; Keywords : +; NANVALUE = Value signalling data dropout. All points corresponding to +; this value are set to be IEEE NaN (not-a-number). Ignored +; unless DATA is of type float, double-precision or complex. +; NOUPDATE = If set, then the optional BSCALE and BZERO keywords in the +; HEADER array will not be changed. The default is to reset +; these keywords to BSCALE=1, BZERO=0. +; APPEND = If set, then an existing file will be appended to. +; Appending to a non-existent file will create it. If +; a primary HDU already exists then it will be modified +; to have EXTEND = T. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. In order to +; use this feature, ERRMSG must be defined first, e.g. +; +; ERRMSG = '' +; FXWRITE, ERRMSG=ERRMSG, ... +; IF ERRMSG NE '' THEN ... +; +; Calls : +; CHECK_FITS, GET_DATE, FXADDPAR, FXPAR +; Common : +; None. +; Restrictions: +; If DATA is passed, then HEADER must be consistent with it. If no data +; array is being written to the file, then HEADER must also be consistent +; with that. The routine FXHMAKE can be used to create a FITS header. +; +; If found, then the optional keywords BSCALE and BZERO in the HEADER +; array is changed so that BSCALE=1 and BZERO=0. This is so that these +; scaling parameters are not applied to the data a second time by another +; routine. Also, history records are added storing the original values +; of these constants. (Other values of BZERO are used for unsigned +; integers.) +; +; If the /NOUPDATE keyword is set, however, then the BSCALE and BZERO +; keywords are not changed. The user should then be aware that FITS +; readers will apply these numbers to the data, even if the data is +; already converted to floating point form. +; +; Groups are not supported. +; +; Side effects: +; HEADER may be modified. One way it may be modified is describe +; above under NOUPDATE. The first header card may also be +; modified to conform to the FITS standard if it does not +; already agree (i.e. use of either the SIMPLE or XTENSION +; keyword depending on whether the image is the primary HDU or +; not). +; Category : +; Data Handling, I/O, FITS, Generic. +; Prev. Hist. : +; W. Thompson, Jan 1992, from WRITEFITS by J. Woffard and W. Landsman. +; Differences include: +; +; * Made DATA array optional, and HEADER array mandatory. +; * Changed order of HEADER and DATA parameters. +; * No attempt made to fix HEADER array. +; +; W. Thompson, May 1992, changed open statement to force 2880 byte fixed +; length records (VMS). The software here does not +; depend on this file configuration, but other +; FITS readers might. +; W. Thompson, Aug 1992, added code to reset BSCALE and BZERO records, +; and added the NOUPDATE keyword. +; Written : +; William Thompson, GSFC, January 1992. +; Modified : +; Version 1, William Thompson, GSFC, 12 April 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 31 May 1994 +; Added ERRMSG keyword. +; Version 3, William Thompson, GSFC, 23 June 1994 +; Modified so that ERRMSG is not touched if not defined. +; Version 4, William Thompson, GSFC, 12 August 1999 +; Catch error if unable to open file. +; Version 4.1 Wayne Landsman, GSFC, 02 May 2000 +; Remove !ERR in call to CHECK_FITS, Use ARG_PRESENT() +; Version 5, William Thompson, GSFC, 22 September 2004 +; Recognize unsigned integer types +; Version 5.1 W. Landsman 14 November 2004 +; Allow for need for 64bit number of bytes +; Version 6, Craig Markwardt, GSFC, 30 May 2005 +; Ability to append to existing files +; Version 7, W. Landsman GSFC, Mar 2014 +; Remove HOST_TO_IEEE, Use V6.0 notation +; Version : +; Version 6, 30 May 2005 +;- +; + ON_ERROR, 2 +; +; Check the number of parameters. +; + IF N_PARAMS() LT 2 THEN BEGIN + MESSAGE = 'Syntax: FXWRITE, FILENAME, HEADER [, DATA ]' + GOTO, HANDLE_ERROR + ENDIF +; +; Check the header against the data being written to the file. If the data +; array is not passed, then NAXIS should be set to zero, and EXTEND should be +; true. +; + IF N_PARAMS() EQ 2 THEN BEGIN + IF (FXPAR(HEADER,'NAXIS') NE 0) THEN BEGIN + MESSAGE = 'NAXIS should be zero for no primary data array' + GOTO, HANDLE_ERROR + END ELSE IF (~FXPAR(HEADER,'EXTEND')) THEN BEGIN + MESSAGE = 'EXTEND should be true for no primary data array' + GOTO, HANDLE_ERROR + ENDIF + END ELSE BEGIN + CHECK_FITS, DATA, HEADER, /FITS, ERRMSG = MESSAGE + IF MESSAGE NE '' THEN GOTO, HANDLE_ERROR + ENDELSE +; +; Set the BSCALE and BZERO keywords to their default values. +; + SZ = SIZE(DATA) + TYPE = SZ[SZ[0]+1] + IF N_PARAMS() EQ 3 THEN NEWDATA = DATA + IF ~KEYWORD_SET(NOUPDATE) THEN BEGIN + BZERO = FXPAR(HEADER,'BZERO') + BSCALE = FXPAR(HEADER,'BSCALE') + GET_DATE,DTE + IF (BSCALE NE 0) AND (BSCALE NE 1) THEN BEGIN + FXADDPAR,HEADER,'BSCALE',1. + FXADDPAR,HEADER,'HISTORY',DTE+' reset BSCALE, was '+ $ + STRTRIM(BSCALE,2) + ENDIF +; +; If an unsigned data type then redefine BZERO to allow all the data to be +; stored in the file. +; + BZERO0 = 0 + IF (TYPE EQ 12) && (~KEYWORD_SET(NOUPDATE)) THEN BEGIN + BZERO0 = '8000'X + NEWDATA = FIX(TEMPORARY(NEWDATA) - BZERO) + ENDIF + IF (TYPE EQ 13) && (~KEYWORD_SET(NOUPDATE)) THEN BEGIN + BZERO0 = '80000000'X + NEWDATA = LONG(TEMPORARY(NEWDATA) - BZERO) + ENDIF + IF BZERO NE BZERO0 THEN BEGIN + FXADDPAR,HEADER,'BZERO',BZERO0 + FXADDPAR,HEADER,'HISTORY',DTE+' reset BZERO, was '+ $ + STRTRIM(BZERO,2) + ENDIF + ENDIF +; +; Get the UNIT number, and open the file. +; + GET_LUN, UNIT + OPENW, UNIT, FILENAME, 2880, /BLOCK, ERROR=ERR, APPEND=APPEND + VERB = 'creating' + IF KEYWORD_SET(APPEND) THEN VERB = 'appending to' + IF ERR NE 0 THEN BEGIN + MESSAGE = 'Error '+VERB+' file '+FILENAME + GOTO, HANDLE_ERROR + ENDIF + +; +; Special processing is required when we are appending to +; the file, to ensure that the FITS standards are met. +; (i.e. primary HDU must have EXTEND = T, and the header +; to be written must have XTENSION = 'IMAGE'). +; + + POINT_LUN, -UNIT, POS + IF POS GT 0 THEN BEGIN + ;; Release the file and call FXHMODIFY to edit the + ;; header of the primary HDU. It is required to have + ;; EXTEND=T. FXHMODIFY calls FXADDPAR, which + ;; automatically places the EXTEND keyword in the + ;; required position. + FREE_LUN, UNIT + FXHMODIFY, FILENAME, ERRMSG=MESSAGE, $ ; (EXTENSION=0 implied) + 'EXTEND', 'T', ' FITS dataset may contain extensions' + IF MESSAGE NE '' THEN GOTO, HANDLE_ERROR + + ;; Re-open the file + GET_LUN, UNIT + OPENW, UNIT, FILENAME, 2880, /BLOCK, ERROR=ERR, APPEND=APPEND + IF ERR NE 0 THEN BEGIN + MESSAGE = 'Error re-opening file '+FILENAME + GOTO, HANDLE_ERROR + ENDIF + + ;; Revise the header so that it begins with an + ;; XTENSION keyword... if it doesn't already + IF STRMID(HEADER[0], 0, 9) EQ 'SIMPLE =' THEN BEGIN + ;; Extra work to preserve the comment + DUMMY = FXPAR(HEADER, 'SIMPLE', COMMENT=COMMENT) + FXADDPAR, DUMMYHEADER, 'XTENSION', 'IMAGE', COMMENT + HEADER[0] = DUMMYHEADER[0] + ENDIF + + ;; Find last NAXIS* keyword, since PCOUNT/GCOUNT follow them + NAXIS = FXPAR(HEADER, 'NAXIS', COUNT=COUNT_NAXIS) + IF NAXIS[0] GT 0 THEN PCOUNT_AFTER='NAXIS'+strtrim(NAXIS[0],2) + ;; Required PCOUNT/GCOUNT keywords for following extensions + FXADDPAR, HEADER, 'PCOUNT', 0, ' number of random group parameters', $ + AFTER=PCOUNT_AFTER + FXADDPAR, HEADER, 'GCOUNT', 1, ' number of random groups', $ + AFTER='PCOUNT' + + ENDIF ELSE BEGIN + ;; In the off chance that this header was used before to + ;; write a header with XTENSION, make sure this *new* file + ;; has SIMPLE = T + + IF STRMID(HEADER[0], 0, 9) EQ 'XTENSION=' THEN BEGIN + ;; Extra work to preserve the comment + DUMMY = FXPAR(HEADER, 'XTENSION', COMMENT=COMMENT) + FXADDPAR, DUMMYHEADER, 'SIMPLE', 'T', COMMENT + HEADER[0] = DUMMYHEADER[0] + ENDIF + + ENDELSE + + +; +; Determine if an END line occurs, and add one if necessary +; + ENDLINE = WHERE( STRMID(HEADER,0,8) EQ 'END ', NEND) + ENDLINE = ENDLINE[0] + IF NEND EQ 0 THEN BEGIN + MESSAGE, 'WARNING - An END statement has been appended ' + $ + 'to the FITS header', /INFORMATIONAL + HEADER = [HEADER, 'END' + STRING(REPLICATE(32B,77))] + ENDLINE = N_ELEMENTS(HEADER) - 1 + ENDIF + NMAX = ENDLINE + 1 ;Number of 80 byte records + NHEAD = FIX((NMAX+35)/36) ;Number of 2880 byte records +; +; Convert to byte and force into 80 character lines +; + BHDR = REPLICATE(32B, 80, 36*NHEAD) + FOR N = 0,ENDLINE DO BHDR[0,N] = BYTE( STRMID(HEADER[N],0,80) ) + WRITEU, UNIT, BHDR +; +; If passed, then write the data array. +; + IF N_PARAMS() EQ 3 THEN BEGIN +; +; If necessary, then byte-swap the data before writing it out. Also, replace +; any values corresponding data dropout with IEEE NaN. +; + IF (N_ELEMENTS(NANVALUE) EQ 1) && (TYPE GE 4) && $ + (TYPE LE 6) THEN BEGIN + W = WHERE(DATA EQ NANVALUE, COUNT) + CASE TYPE OF + 4: NAN = FLOAT( REPLICATE('FF'XB,4),0,1) + 5: NAN = DOUBLE( REPLICATE('FF'XB,8),0,1) + 6: NAN = COMPLEX(REPLICATE('FF'XB,8),0,1) + 9: NAN = DCOMPLEX(REPLICATE('FF'XB,16),0,1) + ENDCASE + END ELSE COUNT = 0 +; + SWAP_ENDIAN_INPLACE, NEWDATA, /SWAP_IF_LITTLE + IF COUNT GT 0 THEN NEWDATA[W] = NAN +; + WRITEU,UNIT,NEWDATA +; +; If necessary, then pad out to an integral multiple of 2880 bytes. +; + BITPIX = FXPAR( HEADER, 'BITPIX' ) + NBYTES = LONG64(N_ELEMENTS(DATA)) * (ABS(BITPIX) / 8 ) + NPAD = NBYTES MOD 2880 + IF NPAD NE 0 THEN BEGIN + NPAD = 2880 - NPAD + WRITEU,UNIT,BYTARR(NPAD) + ENDIF + ENDIF +; +; Close the file and return. +; + FREE_LUN, UNIT + IF ARG_PRESENT(ERRMSG) THEN ERRMSG = '' + RETURN +; +HANDLE_ERROR: + IF N_ELEMENTS(UNIT) EQ 1 THEN FREE_LUN, UNIT + IF ARG_PRESENT(ERRMSG) THEN ERRMSG = 'FXWRITE: ' + MESSAGE $ + ELSE MESSAGE, MESSAGE +; + END diff --git a/modules/idl_downloads/astro/pro/gal_flat.pro b/modules/idl_downloads/astro/pro/gal_flat.pro new file mode 100644 index 0000000..d6407e2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gal_flat.pro @@ -0,0 +1,94 @@ +FUNCTION GAL_FLAT,IMAGE,ANG,INC,CEN,INTERP = interp +;+ +; NAME: +; GAL_FLAT +; +; PURPOSE: +; Transforms the image of a galaxy so that the galaxy appears face-on +; EXPLANATION: +; Either a nearest-neighbor approximations or a bilinear interpolation +; may be used. +; +; CALLING SEQUENCE: +; RESULT = GAL_FLAT( image, ang, inc, [, cen, /INTERP ] ) +; +; INPUTS: +; IMAGE - Image to be transformed +; ANG - Angle of major axis, counterclockwise from Y-axis, degrees +; For an image in standard orientation (North up, East left) +; this is the Position Angle +; INC - Angle of inclination of galaxy, degrees +; +; OPTIONAL INPUTS: +; CEN - Two element vector giving the X and Y position of galaxy center +; If not supplied, then the galaxy center is assumed to coincide +; with the image center +; +; INPUT KEYWORDS: +; INTERP - If present, and non-zero, then bilinear interpolation will be +; performed. Otherwise a nearest neighbor approximation is used. +; +; OUTPUTS: +; RESULT - the transformed image, same dimensions and type as IMAGE +; +; METHOD: +; A set of 4 equal spaced control points are corrected for inclination +; using the procedure POLYWARP. These control points are used by +; POLY_2D to correct the whole image. +; +; REVISION HISTORY: +; Written by R. S. Hill, SASC Technologies Inc., 4 December 1985 +; Code cleaned up a bit W. Landsman December 1992 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + if ( N_params() lt 3 ) then begin + print,'Syntax - result = gal_flat( image, ang, inc, [ cen, /INTERP ])' + print,'ANG - Position Angle of major axis (degrees)' + print,'INC - Inclination of galaxy (degrees)' + return, -1 + endif + + if not keyword_set( INTERP ) then interp = 0 + + angr = (ang+90)/!RADEG + tanang = tan(angr) + cosang = cos(angr) + cosinc = cos(inc/!RADEG) +; Parameters of image + dims = SIZE(image) + + if N_elements(cen) NE 2 then begin + + xcen = dims[1]/2.0 ;Center + ycen = dims[2]/2.0 + if not !QUIET then message,'Galaxy nucleus assumed in image center',/CONT + + endif else begin + + xcen = cen[0] + ycen = cen[1] + + endelse +; Equation of rotation axis + b = ycen - xcen*tanang +; Fiducial grid (as in ROT_INT) + gridx = xcen + [ [-1,1], [-1,1] ] * dims[1]/6.0 + gridy = ycen + [ [-1,-1], [1,1] ] * dims[2]/6.0 +; Distorted version of grid + yprime = gridx*tanang + b ;Equation of major axis + r0 = (gridy-yprime)*cos(angr) ;Dist of control pts to major axis + delr = r0*(1.0-cosinc) ;Correct distance for inclination + dely = -delr*cos(angr) + delx = delr*sin(angr) + distx = gridx + delx + disty = gridy + dely +; Parameters of undistorted grid + x0 = dims[1]/3.0 + y0 = dims[2]/3.0 + dx = x0 ;In this case only + dy = y0 +; Do it + polywarp, distx, disty, gridx, gridy, 1, kx, ky + RETURN,poly_2d( image, kx, ky, interp, MISSING = 0) + end diff --git a/modules/idl_downloads/astro/pro/gal_uvw.pro b/modules/idl_downloads/astro/pro/gal_uvw.pro new file mode 100644 index 0000000..69e63b9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gal_uvw.pro @@ -0,0 +1,130 @@ +pro gal_uvw, u, v, w, distance = distance, LSR = lsr, ra=ra,dec=dec, $ + pmra = pmra, pmdec=pmdec, vrad = vrad, plx = plx +;+ +; NAME: +; GAL_UVW +; PURPOSE: +; Calculate the Galactic space velocity (U,V,W) of star +; EXPLANATION: +; Calculates the Galactic space velocity U, V, W of star given its +; (1) coordinates, (2) proper motion, (3) distance (or parallax), and +; (4) radial velocity. +; CALLING SEQUENCE: +; GAL_UVW, U, V, W, [/LSR, RA=, DEC=, PMRA= ,PMDEC=, VRAD= , DISTANCE= +; PLX= ] +; OUTPUT PARAMETERS: +; U - Velocity (km/s) positive toward the Galactic *anti*center +; V - Velocity (km/s) positive in the direction of Galactic rotation +; W - Velocity (km/s) positive toward the North Galactic Pole +; REQUIRED INPUT KEYWORDS: +; User must supply a position, proper motion,radial velocity and distance +; (or parallax). Either scalars or vectors can be supplied. +; (1) Position: +; RA - Right Ascension in *Degrees* +; Dec - Declination in *Degrees* +; (2) Proper Motion +; PMRA = Proper motion in RA in arc units (typically milli-arcseconds/yr) +; If given mu_alpha --proper motion in seconds of time/year - then +; this is equal to 15*mu_alpha*cos(dec) +; PMDEC = Proper motion in Declination (typically mas/yr) +; (3) Radial Velocity +; VRAD = radial velocity in km/s +; (4) Distance or Parallax +; DISTANCE - distance in parsecs +; or +; PLX - parallax with same distance units as proper motion measurements +; typically milliarcseconds (mas) +; +; OPTIONAL INPUT KEYWORD: +; /LSR - If this keyword is set, then the output velocities will be +; corrected for the solar motion (U,V,W)_Sun = (-8.5, 13.38, 6.49) +; (Coskunoglu et al. 2011 MNRAS) to the local standard of rest. +; Note that the value of the solar motion through the LSR remains +; poorly determined. +; EXAMPLE: +; (1) Compute the U,V,W coordinates for the halo star HD 6755. +; Use values from Hipparcos catalog, and correct to the LSR +; ra = ten(1,9,42.3)*15. & dec = ten(61,32,49.5) +; pmra = 628.42 & pmdec = 76.65 ;mas/yr +; dis = 139 & vrad = -321.4 +; gal_uvw,u,v,w,ra=ra,dec=dec,pmra=pmra,pmdec=pmdec,vrad=vrad,dis=dis,/lsr +; ===> u=141.2 v = -491.7 w = 93.9 ;km/s +; +; (2) Use the Hipparcos Input and Output Catalog IDL databases (see +; http://idlastro.gsfc.nasa.gov/ftp/zdbase/) to obtain space velocities +; for all stars within 10 pc with radial velocities > 10 km/s +; +; dbopen,'hipp_new,hic' ;Need Hipparcos output and input catalogs +; list = dbfind('plx>100,vrad>10') ;Plx > 100 mas, Vrad > 10 km/s +; dbext,list,'pmra,pmdec,vrad,ra,dec,plx',pmra,pmdec,vrad,ra,dec,plx +; ra = ra*15. ;Need right ascension in degrees +; GAL_UVW,u,v,w,ra=ra,dec=dec,pmra=pmra,pmdec=pmdec,vrad=vrad,plx = plx +; forprint,u,v,w ;Display results +; METHOD: +; Follows the general outline of Johnson & Soderblom (1987, AJ, 93,864) +; except that U is positive outward toward the Galactic *anti*center, and +; the J2000 transformation matrix to Galactic coordinates is taken from +; the introduction to the Hipparcos catalog. +; REVISION HISTORY: +; Written, W. Landsman December 2000 +; fix the bug occuring if the input arrays are longer than 32767 +; and update the Sun velocity Sergey Koposov June 2008 +; vectorization of the loop -- performance on large arrays +; is now 10 times higher Sergey Koposov December 2008 +; More recent value of solar motion WL/SK Jan 2011 +;- + compile_opt idl2 + if N_Params() EQ 0 then begin + print,'Syntax - GAL_UVW, U, V, W, [/LSR, RA=, DEC=, PMRA= ,PMDEC=, VRAD=' + print,' Distance=, PLX=' + print,' U, V, W - output Galactic space velocities (km/s)' + return + endif + + Nra = N_elements(ra) + if (nra EQ 0) or (N_elements(dec) EQ 0) then message, $ + 'ERROR - The RA, Dec (J2000) position keywords must be supplied (degrees)' + if N_elements(distance) GT 0 then begin + bad = where(distance LE 0, Nbad) + if Nbad GT 0 then message,'ERROR - All distances must be > 0' + plx = 1e3/distance ;Parallax in milli-arcseconds + endif else begin + if N_elements(plx) EQ 0 then message, $ + 'ERROR - Either a parallax or distance must be specified' + bad = where(plx LE 0.0, Nbad) + if Nbad GT 0 then message,'ERROR - Parallaxes must be > 0' + endelse + + cosd = cos(dec/!RADEG) + sind = sin(dec/!RADEG) + cosa = cos(ra/!RADEG) + sina = sin(ra/!RADEG) + + k = 4.74047 ;Equivalent of 1 A.U/yr in km/s + A_G = [ [ 0.0548755604, +0.4941094279, -0.8676661490], $ + [ 0.8734370902, -0.4448296300, -0.1980763734], $ + [ 0.4838350155, 0.7469822445, +0.4559837762] ] + + vec1 = vrad + vec2 = k*pmra/plx + vec3 = k*pmdec/plx + + u = ( A_G[0,0]*cosa*cosd+A_G[0,1]*sina*cosd+A_G[0,2]*sind)*vec1+$ + (-A_G[0,0]*sina +A_G[0,1]*cosa )*vec2+$ + (-A_G[0,0]*cosa*sind-A_G[0,1]*sina*sind+A_G[0,2]*cosd)*vec3 + v = ( A_G[1,0]*cosa*cosd+A_G[1,1]*sina*cosd+A_G[1,2]*sind)*vec1+$ + (-A_G[1,0]*sina +A_G[1,1]*cosa )*vec2+$ + (-A_G[1,0]*cosa*sind-A_G[1,1]*sina*sind+A_G[1,2]*cosd)*vec3 + w = ( A_G[2,0]*cosa*cosd+A_G[2,1]*sina*cosd+A_G[2,2]*sind)*vec1+$ + (-A_G[2,0]*sina +A_G[2,1]*cosa )*vec2+$ + (-A_G[2,0]*cosa*sind-A_G[2,1]*sina*sind+A_G[2,2]*cosd)*vec3 + + lsr_vel=[-8.5,13.38,6.49] + if keyword_set(lsr) then begin + u = u+lsr_vel[0] + v = v+lsr_vel[1] + w = w+lsr_vel[2] + end + + return + end diff --git a/modules/idl_downloads/astro/pro/galage.pro b/modules/idl_downloads/astro/pro/galage.pro new file mode 100644 index 0000000..c42c494 --- /dev/null +++ b/modules/idl_downloads/astro/pro/galage.pro @@ -0,0 +1,130 @@ +;+ +; NAME: +; GALAGE +; +; PURPOSE: +; Determine the age of a galaxy given its redshift and a formation redshift. +; +; CALLING SEQUENCE: +; age = galage(z, [zform, H0 =, k=, lambda0 =, Omega_m= , q0 =, /SILENT])' +; +; INPUTS: +; z - positive numeric vector or scalar of measured redshifts +; zform - redshift of galaxy formation (> z), numeric positive scalar +; To determine the age of the universe at a given redshift, set zform +; to a large number (e.g. ~1000). +; +; OPTIONAL KEYWORD INPUTS: +; H0 - Hubble constant in km/s/Mpc, positive scalar, default is 70 +; /SILENT - If set, then the adopted cosmological parameters are not +; displayed at the terminal. +; +; No more than two of the following four parameters should be +; specified. None of them need be specified -- the adopted defaults +; are given. +; k - curvature constant, normalized to the closure density. Default is +; 0, (indicating a flat universe) +; Omega_m - Matter density, normalized to the closure density, default +; is 0.3. Must be non-negative +; Lambda0 - Cosmological constant, normalized to the closure density, +; default is 0.7 +; q0 - Deceleration parameter, numeric scalar = -R*(R'')/(R')^2, default +; is -0.55 +; +; OUTPUTS: +; age - age of galaxy in years, will have the same number of elements +; as the input Z vector +; +; EXAMPLE: +; (1) Determine the age of a galaxy observed at z = 1.5 in a cosmology with +; Omega_matter = 0.3 and Lambda = 0.0. Assume the formation redshift was +; at z = 25, and use the default Hubble constant (=70 km/s/Mpc) +; +; IDL> print,galage(1.5,25,Omega_m=0.3, Lambda = 0) +; ===> 3.35 Gyr +; +; (2) Plot the age of a galaxy in Gyr out to a redshift of z = 5, assuming +; the default cosmology (omega_m=0.3, lambda=0.7), and zform = 100 +; +; IDL> z = findgen(50)/10. +; IDL> plot,z,galage(z,100)/1e9,xtit='z',ytit = 'Age (Gyr)' +; +; PROCEDURE: +; For a given formation time zform and a measured z, integrate dt/dz from +; zform to z. Analytic formula of dt/dz in Gardner, PASP 110:291-305, 1998 +; March (eq. 7) +; +; COMMENTS: +; (1) Integrates using the IDL Astronomy Library procedure QSIMP. (The +; intrinsic IDL QSIMP() function is not called because of its ridiculous +; restriction that only scalar arguments can be passed to the integrating +; function.) The function 'dtdz' is defined at the beginning of the +; routine (so it can compile first). +; +; (2) Should probably be fixed to use a different integrator from QSIMP when +; computing age from an "infinite" redshift of formation. But using a +; large value of zform seems to work adequately. +; +; (3) An alternative set of IDL procedures for computing cosmological +; parameters is available at +; http://cerebus.as.arizona.edu/~ioannis/research/red/ +; PROCEDURES CALLED: +; COSMO_PARAM, QSIMP +; HISTORY: +; STIS version by P. Plait (ACC) June 1999 +; IDL Astro Version W. Landsman (Raytheon ITSS) April 2000 +; Avoid integer overflow for more than 32767 redshifts July 2001 +;- +; +; define function dtdz +; + +function dtdz, z, lambda0 = lambda0, q0 = q0 + term1 = (1.0d + z) + term2 = 2.0d * (q0 + lambda0) * z + 1.0d - lambda0 + term3 = (1.0d + z) * (1.0d +z) + return, 1.0 / (term1 * sqrt(term2 * term3 + lambda0)) + end + +;;;;;;;;;;;;;;;;;;;;;;;;; + +function galage, z, zform, h0 = h0, Omega_m=omega_m, lambda0 = lambda0, k = k, $ + q0 = q0, SILENT = silent + + if N_params() LE 1 then begin + print,$ + 'Syntax: age = GALAGE(z, zform, [H0= , Omega_M = ,lambda0 =, k= , q0=, /SIL]' + return, 0 + endif + +; +; initialize numbers +; + + if N_elements(h0) EQ 0 then h0 = 70.0 + COSMO_PARAM, Omega_m, lambda0, k, q0 + if not keyword_set(silent) then $ + print,'GALAGE: H0:', h0, ' Omega_m:', omega_m, ' Lambda0',lambda0, $ + ' q0: ',q0, ' k: ', k, f='(A,I3,A,f5.2,A,f5.2,A,f5.2,A,F5.2)' + + nz = N_elements(z) + age = z*0. ;Return same dimensions and data type as Z + +; +; use qsimp to integrate dt/dz to get age for each z +; watch out for null case of z >= zform +; + + for i= 0L, nz-1 do begin + if (z[i] ge zform) then age_z = 0 else $ + qsimp,'dtdz', z[i], zform, age_z, q0 = q0, lambda0 = lambda0 + age[i] = age_z + endfor + +; convert units of age: km/s/Mpc to years, divide by H0 +; 3.085678e19 km --> 1 Mpc +; 3.15567e+07 sec --> 1 year + + return, age * 3.085678e+19 / 3.15567e+7/ H0 + end + diff --git a/modules/idl_downloads/astro/pro/gaussian.pro b/modules/idl_downloads/astro/pro/gaussian.pro new file mode 100644 index 0000000..1f640a1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gaussian.pro @@ -0,0 +1,107 @@ +function gaussian, xi, parms, pderiv, DOUBLE=double +;+ +; NAME: +; GAUSSIAN +; PURPOSE: +; Compute the 1-d Gaussian function and optionally the derivative +; EXPLANATION: +; Compute the 1-D Gaussian function and optionally the derivative +; at an array of points. +; +; CALLING SEQUENCE: +; y = gaussian( xi, parms,[ pderiv ]) +; +; INPUTS: +; xi = array, independent variable of Gaussian function. +; +; parms = parameters of Gaussian, 2, 3 or 4 element array: +; parms[0] = maximum value (factor) of Gaussian, +; parms[1] = mean value (center) of Gaussian, +; parms[2] = standard deviation (sigma) of Gaussian. +; (if parms has only 2 elements then sigma taken from previous +; call to gaussian(), which is stored in a common block). +; parms[3] = optional, constant offset added to Gaussian. +; OUTPUT: +; y - Function returns array of Gaussian evaluated at xi. Values will +; be floating pt. (even if xi is double) unless the /DOUBLE keyword +; is set. +; +; OPTIONAL INPUT: +; /DOUBLE - set this keyword to return double precision for both +; the function values and (optionally) the partial derivatives. +; OPTIONAL OUTPUT: +; pderiv = [N,3] or [N,4] output array of partial derivatives, +; computed only if parameter is present in call. +; +; pderiv[*,i] = partial derivative at all xi absisca values +; with respect to parms[i], i=0,1,2,[3]. +; +; +; EXAMPLE: +; Evaulate a Gaussian centered at x=0, with sigma=1, and a peak value +; of 10 at the points 0.5 and 1.5. Also compute the derivative +; +; IDL> f = gaussian( [0.5,1.5], [10,0,1], DERIV ) +; ==> f= [8.825,3.25]. DERIV will be a 2 x 3 array containing the +; numerical derivative at the two points with respect to the 3 parameters. +; +; COMMON BLOCKS: +; None +; HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +; Use machar() for machine precision, added /DOUBLE keyword, +; add optional constant 4th parameter W. Landsman November 2001 +;- + On_error,2 + common gaussian, sigma + + if N_params() LT 2 then begin + print,'Syntax - y = GAUSSIAN( xi, parms,[ pderiv, /DOUBLE ])' + print,' parms[0] = maximum value (factor) of Gaussian' + print,' parms[1] = mean value (center) of Gaussian' + print,' parms[2] = standard deviation (sigma) of Gaussian' + print,' parms[3] = optional constant to be added to Gaussian' + return, -1 + endif + + common gaussian, sigma + + Nparmg = N_elements( parms ) + npts = N_elements(xi) + ptype = size(parms,/type) + if (ptype LE 3) or (ptype GE 12) then parms = float(parms) + if (Nparmg GE 3) then sigma = parms[2] + + double = keyword_set(DOUBLE) + if double then $ ;Double precision? + gauss = dblarr( npts ) else $ + gauss = fltarr( npts ) + + z = ( xi - parms[1] )/sigma + zz = z*z + +; Get smallest value expressible on computer. Set lower values to 0 to avoid +; floating underflow + minexp = alog((machar(DOUBLE=double)).xmin) + + w = where( zz LT -2*minexp, nw ) + if (nw GT 0) then gauss[w] = exp( -zz[w] / 2 ) + + if N_params() GE 3 then begin + + if double then $ + pderiv = dblarr( npts, Nparmg ) else $ + pderiv = fltarr( npts, Nparmg ) + fsig = parms[0] / sigma + + pderiv[0,0] = gauss + pderiv[0,1] = gauss * z * fsig + + if (Nparmg GE 3) then pderiv[0,2] = gauss * zz * fsig + if (Nparmg GE 4) then pderiv[0,3] = replicate(1, npts) + endif + + if Nparmg LT 4 then return, parms[0] * gauss else $ + return, parms[0] * gauss + parms[3] + end diff --git a/modules/idl_downloads/astro/pro/gcirc.pro b/modules/idl_downloads/astro/pro/gcirc.pro new file mode 100644 index 0000000..06e0d71 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gcirc.pro @@ -0,0 +1,123 @@ +PRO gcirc,u,ra1,dc1,ra2,dc2,dis +;+ +; NAME: +; GCIRC +; PURPOSE: +; Computes rigorous great circle arc distances. +; EXPLANATION: +; Input position can either be either radians, sexagesimal RA, Dec or +; degrees. All computations are double precision. +; +; CALLING SEQUENCE: +; GCIRC, U, RA1, DC1, RA2, DC2, DIS +; +; INPUTS: +; U -- integer = 0,1, or 2: Describes units of inputs and output: +; 0: everything radians +; 1: RAx in decimal hours, DCx in decimal +; degrees, DIS in arc seconds +; 2: RAx and DCx in degrees, DIS in arc seconds +; RA1 -- Right ascension or longitude of point 1 +; DC1 -- Declination or latitude of point 1 +; RA2 -- Right ascension or longitude of point 2 +; DC2 -- Declination or latitude of point 2 +; +; OUTPUTS: +; DIS -- Angular distance on the sky between points 1 and 2 +; See U above for units; double precision +; +; PROCEDURE: +; "Haversine formula" see +; http://en.wikipedia.org/wiki/Great-circle_distance +; +; NOTES: +; (1) If RA1,DC1 are scalars, and RA2,DC2 are vectors, then DIS is a +; vector giving the distance of each element of RA2,DC2 to RA1,DC1. +; Similarly, if RA1,DC1 are vectors, and RA2, DC2 are scalars, then DIS +; is a vector giving the distance of each element of RA1, DC1 to +; RA2, DC2. If both RA1,DC1 and RA2,DC2 are vectors then DIS is a +; vector giving the distance of each element of RA1,DC1 to the +; corresponding element of RA2,DC2. If the input vectors are not the +; same length, then excess elements of the longer ones will be ignored. +; +; (2) The function SPHDIST provides an alternate method of computing +; a spherical distance. +; +; (3) The haversine formula can give rounding errors for antipodal +; points. +; +; PROCEDURE CALLS: +; None +; +; MODIFICATION HISTORY: +; Written in Fortran by R. Hill -- SASC Technologies -- January 3, 1986 +; Translated from FORTRAN to IDL, RSH, STX, 2/6/87 +; Vector arguments allowed W. Landsman April 1989 +; Prints result if last argument not given. RSH, RSTX, 3 Apr. 1998 +; Remove ISARRAY(), V5.1 version W. Landsman August 2000 +; Added option U=2 W. Landsman October 2006 +; Use double precision for U=0 as advertised R. McMahon/W.L. April 2007 +; Use havesine formula, which has less roundoff error in the +; milliarcsecond regime W.L. Mar 2009 +;- + compile_opt idl2 + On_error,2 ;Return to caller + + npar = N_params() + IF (npar ne 6) and (npar ne 5) THEN BEGIN + print,'Calling sequence: GCIRC,U,RA1,DC1,RA2,DC2[,DIS]' + print,' U = 0 ==> Everything in radians' + print, $ + ' U = 1 ==> RAx decimal hours, DCx decimal degrees, DIS arc sec' + print,' U = 2 ==> RAx, DCx decimal degrees, DIS arc sec' + RETURN + ENDIF + + + d2r = !DPI/180.0d0 + as2r = !DPI/648000.0d0 + h2r = !DPI/12.0d0 + +; Convert input to double precision radians + CASE u OF + 0: BEGIN + rarad1 = double(ra1) + rarad2 = double(ra2) + dcrad1 = double(dc1) + dcrad2 = double(dc2) + END + 1: BEGIN + rarad1 = ra1*h2r + rarad2 = ra2*h2r + dcrad1 = dc1*d2r + dcrad2 = dc2*d2r + END + 2: BEGIN + rarad1 = ra1*d2r + rarad2 = ra2*d2r + dcrad1 = dc1*d2r + dcrad2 = dc2*d2r + END + ELSE: MESSAGE, $ + 'U must be 0 (radians), 1 ( hours, degrees) or 2 (degrees)' + ENDCASE + + deldec2 = (dcrad2-dcrad1)/2.0d + delra2 = (rarad2-rarad1)/2.0d + sindis = sqrt( sin(deldec2)*sin(deldec2) + $ + cos(dcrad1)*cos(dcrad2)*sin(delra2)*sin(delra2) ) + dis = 2.0d*asin(sindis) + + IF (u ne 0) THEN dis = dis/as2r + + IF (npar eq 5) && (N_elements(dis) EQ 1) THEN BEGIN + IF (u ne 0) && (dis ge 0.1) && (dis le 1000) $ + THEN fmt = '(F10.4)' $ + ELSE fmt = '(E15.8)' + IF (u ne 0) THEN units = ' arcsec' ELSE units = ' radians' + print,'Angular separation is ' + string(dis,format=fmt) + units + ENDIF + + RETURN + END + diff --git a/modules/idl_downloads/astro/pro/gcntrd.pro b/modules/idl_downloads/astro/pro/gcntrd.pro new file mode 100644 index 0000000..344d6ca --- /dev/null +++ b/modules/idl_downloads/astro/pro/gcntrd.pro @@ -0,0 +1,326 @@ +pro gcntrd,img,x,y,xcen,ycen,fwhm, maxgood = maxgood, keepcenter=keepcenter, $ + SILENT = silent, DEBUG = debug + +;+ +; NAME: +; GCNTRD +; PURPOSE: +; Compute the stellar centroid by Gaussian fits to marginal X,Y, sums +; EXPLANATION: +; GCNTRD uses the DAOPHOT "FIND" centroid algorithm by fitting Gaussians +; to the marginal X,Y distributions. User can specify bad pixels +; (either by using the MAXGOOD keyword or setting them to NaN) to be +; ignored in the fit. Pixel values are weighted toward the center to +; avoid contamination by neighboring stars. +; +; CALLING SEQUENCE: +; GCNTRD, img, x, y, xcen, ycen, [ fwhm , /SILENT, /DEBUG, MAXGOOD = , +; /KEEPCENTER ] +; +; INPUTS: +; IMG - Two dimensional image array +; X,Y - Scalar or vector integers giving approximate stellar center +; +; OPTIONAL INPUT: +; FWHM - floating scalar; Centroid is computed using a box of half +; width equal to 1.5 sigma = 0.637* FWHM. GCNTRD will prompt +; for FWHM if not supplied +; +; OUTPUTS: +; XCEN - the computed X centroid position, same number of points as X +; YCEN - computed Y centroid position, same number of points as Y +; +; Values for XCEN and YCEN will not be computed if the computed +; centroid falls outside of the box, or if there are too many bad pixels, +; or if the best-fit Gaussian has a negative height. If the centroid +; cannot be computed, then a message is displayed (unless /SILENT is +; set) and XCEN and YCEN are set to -1. +; +; OPTIONAL OUTPUT KEYWORDS: +; MAXGOOD= Only pixels with values less than MAXGOOD are used to in +; Gaussian fits to determine the centroid. For non-integer +; data, one can also flag bad pixels using NaN values. +; /SILENT - Normally GCNTRD prints an error message if it is unable +; to compute the centroid. Set /SILENT to suppress this. +; /DEBUG - If this keyword is set, then GCNTRD will display the subarray +; it is using to compute the centroid. +; /KeepCenter By default, GCNTRD first convolves a small region around +; the supplied position with a lowered Gaussian filter, and then +; finds the maximum pixel in a box centered on the input X,Y +; coordinates, and then extracts a new box about this maximum +; pixel. Set the /KeepCenter keyword to skip the convolution +; and finding the maximum pixel, and instead use a box +; centered on the input X,Y coordinates. +; PROCEDURE: +; Unless /KEEPCENTER is set, a small area around the initial X,Y is +; convolved with a Gaussian kernel, and the maximum pixel is found. +; This pixel is used as the center of a square, within +; which the centroid is computed as the Gaussian least-squares fit +; to the marginal sums in the X and Y directions. +; +; EXAMPLE: +; Find the centroid of a star in an image im, with approximate center +; 631, 48. Assume that bad (saturated) pixels have a value of 4096 or +; or higher, and that the approximate FWHM is 3 pixels. +; +; IDL> GCNTRD, IM, 631, 48, XCEN, YCEN, 3, MAXGOOD = 4096 +; MODIFICATION HISTORY: +; Written June 2004, W. Landsman following algorithm used by P. Stetson +; in DAOPHOT2. +; Modified centroid computation (as in IRAF/DAOFIND) to allow shifts of +; more than 1 pixel from initial guess. March 2008 +; First perform Gaussian convolution prior to finding maximum pixel +; to smooth out noise W. Landsman Jan 2009 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 5 then begin + print,'Syntax: GCNTRD, img, x, y, xcen, ycen, [ fwhm, ' + print,' /KEEPCENTER, /SILENT, /DEBUG, MAXGOOD= ]' + PRINT,'img - Input image array' + PRINT,'x,y - Input scalar integers giving approximate X,Y position' + PRINT,'xcen,ycen - Output scalars giving centroided X,Y position' + return + endif else if N_elements(fwhm) NE 1 then $ + read,'Enter approximate FWHM of image in pixels: ',fwhm + + + sz_image = size(img) + if sz_image[0] NE 2 then message, $ + 'ERROR - Image array (first parameter) must be 2 dimensional' + + xsize = sz_image[1] + ysize = sz_image[2] + dtype = sz_image[3] + npts = N_elements(x) + maxbox = 13 + radius = 0.637*FWHM > 2.001 ;Radius is 1.5 sigma + radsq = radius^2 + sigsq = ( fwhm/2.35482 )^2 + nhalf = fix(radius) < (maxbox-1)/2 ; + nbox = 2*nhalf +1 ;# of pixels in side of convolution box + + xcen = x*0. - 1 & ycen = y*0 - 1. + ix = round(x) ;Central X pixel + iy = round(y) ;Central Y pixel + +;Create the Gaussian convolution kernel in variable "g" + mask = bytarr( nbox, nbox ) ;Mask identifies valid pixels in convolution box + g = fltarr( nbox, nbox ) + row2 = (findgen(Nbox)-nhalf)^2 + g[0,nhalf] = row2 + for i = 1, nhalf do begin + temp = row2 + i^2 + g[0,nhalf-i] = temp + g[0,nhalf+i] = temp + endfor + mask = fix(g LE radsq) + good = where( mask, pixels) ;Value of c are now equal to distance to center + g = exp(-0.5*g/sigsq) ;Make g into a Gaussian kernel + +; In fitting Gaussians to the marginal sums, pixels will arbitrarily be +; assigned weights ranging from unity at the corners of the box to +; NHALF^2 at the center (e.g. if NBOX = 5 or 7, the weights will be +; +; 1 2 3 4 3 2 1 +; 1 2 3 2 1 2 4 6 8 6 4 2 +; 2 4 6 4 2 3 6 9 12 9 6 3 +; 3 6 9 6 3 4 8 12 16 12 8 4 +; 2 4 6 4 2 3 6 9 12 9 6 3 +; 1 2 3 2 1 2 4 6 8 6 4 2 +; 1 2 3 4 3 2 1 +; +; respectively). This is done to desensitize the derived parameters to +; possible neighboring, brighter stars. + + + x_wt = fltarr(nbox,nbox) + wt = nhalf - abs(findgen(nbox)-nhalf ) + 1 + for i=0,nbox-1 do x_wt[0,i] = wt + y_wt = transpose(x_wt) + pos = strtrim(x,2) + ' ' + strtrim(y,2) + +if ~keyword_set(Keepcenter) then begin +; Precompute convolution kernel + c = g*mask ;Convolution kernel now in c + sumc = total(c) + sumcsq = total(c^2) - sumc^2/pixels + sumc = sumc/pixels + c[good] = (c[good] - sumc)/sumcsq +endif + + for i = 0,npts-1 do begin ;Loop over number of points to centroid + + if ~keyword_set(keepcenter) then begin + if ( (ix[i] LT nhalf) || ((ix[i] + nhalf) GT xsize-1) || $ + (iy[i] LT nhalf) || ((iy[i] + nhalf) GT ysize-1) ) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' too near edge of image' + goto, DONE + endif + x1 = (ix[i]-nbox) > 0 + x2 = (ix[i] + nbox) < (xsize-1) + y1 = (iy[i]-nbox) > 0 + y2 = (iy[i] + nbox) < (ysize-1) + h = img[x1:x2, y1:y2] + h = convol(float(h), c) + h= h[ nbox-nhalf: nbox + nhalf, nbox -nhalf: nbox + nhalf] + d= img[ix[i]-nhalf: ix[i]+nhalf, iy[i]-nhalf:iy[i]+nhalf] + + if N_elements(maxgood) GT 0 then begin + ig = where(d lt maxgood, Ng) + mx = max(d[ig],/nan) + endif + mx = max( h,/nan) ;Maximum pixel value in BIGBOX + + mx_pos = where(h EQ mx, Nmax) ;How many pixels have maximum value? + idx = mx_pos mod nbox ;X coordinate of Max pixel + idy = mx_pos / nbox ;Y coordinate of Max pixel + if NMax GT 1 then begin ;More than 1 pixel at maximum? + idx = round(total(idx)/Nmax) + idy = round(total(idy)/Nmax) + endif else begin + idx = idx[0] + idy = idy[0] + endelse + xmax = ix[i] - (nhalf) + idx ;X coordinate in original image array + ymax = iy[i] - (nhalf) + idy ;Y coordinate in original image array + endif else begin + xmax = ix[i] + ymax = iy[i] + endelse + +; --------------------------------------------------------------------- +; check *new* center location for range +; added by Hogg + + if ( (xmax LT nhalf) || ((xmax + nhalf) GT xsize-1) || $ + (ymax LT nhalf) || ((ymax + nhalf) GT ysize-1) ) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' moved too near edge of image' + xcen[i] = -1 & ycen[i] = -1 + goto, DONE + endif +; --------------------------------------------------------------------- + +; Extract subimage centered on maximum pixel + + d = img[xmax-nhalf : xmax+nhalf, ymax-nhalf : ymax+nhalf] + + + if keyword_set(DEBUG) then begin + message,'Subarray used to compute centroid:',/inf + imlist,img,xmax,ymax,dx = nbox,dy=nbox + endif + + if N_elements(maxgood) GT 0 then $ + mask = (d lt maxgood) else $ + if (dtype eq 4) || (dtype EQ 5) then mask = finite(d) else $ + mask = replicate(1b, nbox, nbox) + maskx = total(mask,2) GT 0 + masky = total(mask,1) GT 0 + +; At least 3 points are needed in the partial sum to compute the Gaussian + + if (total(maskx) LT 3) || (total(masky) LT 3) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' has insufficient good points' + goto, DONE + endif + + ywt = y_wt*mask + xwt = x_wt*mask + wt1 = wt*maskx + wt2 = wt*masky + +; Centroid computation: The centroid computation was modified in Mar 2008 and +; now differs from DAOPHOT which multiplies the correction dx by 1/(1+abs(dx)). +; The DAOPHOT method is more robust (e.g. two different sources will not merge) +; especially in a package where the centroid will be subsequently be +; redetermined using PSF fitting. However, it is less accurate, and introduces +; biases in the centroid histogram. The change here is the same made in the +; IRAF DAOFIND routine (see +; http://iraf.net/article.php?story=7211&query=daofind ) + + sd = total(d*ywt,2,/nan) + sg = total(g*ywt,2) + sumg = total(wt1*sg) + sumgsq = total(wt1*sg*sg) + + sumgd = total(wt1*sg*sd) + sumgx = total(wt1*sg) + sumd = total(wt1*sd) + p = total(wt1) + xvec = nhalf - findgen(nbox) + dgdx = sg*xvec + sdgdxs = total(wt1*dgdx^2) + sdgdx = total(wt1*dgdx) + sddgdx = total(wt1*sd*dgdx) + sgdgdx = total(wt1*sg*dgdx) + + hx = (sumgd - sumg*sumd/p) / (sumgsq - sumg^2/p) + +; HX is the height of the best-fitting marginal Gaussian. If this is not +; positive then the centroid does not make sense + + if (hx LE 0) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' cannot be fit by a Gaussian' + xcen[i] = -1 & ycen[i] = -1 + goto, DONE + endif + + skylvl = (sumd - hx*sumg)/p + dx = (sgdgdx - (sddgdx-sdgdx*(hx*sumg + skylvl*p)))/(hx*sdgdxs/sigsq) + if (abs(dx) GE nhalf) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' is too far from initial guess' + goto, DONE + endif + + + + xcen[i] = xmax + dx ;X centroid in original array + + +;Now repeat computation for Y centroid + + sd = total(d*xwt,1,/nan) + sg = total(g*xwt,1) + sumg = total(wt2*sg) + sumgsq = total(wt2*sg*sg) + + sumgd = total(wt2*sg*sd) + sumd = total(wt2*sd) + p = total(wt2) + + yvec = nhalf - findgen(nbox) + dgdy = sg*yvec + sdgdys = total(wt2*dgdy^2) + sdgdy = total(wt2*dgdy) + sddgdy = total(wt2*sd*dgdy) + sgdgdy = total(wt2*sg*dgdy) + + hy = (sumgd - sumg*sumd/p) / (sumgsq - sumg^2/p) + + if (hy LE 0) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' cannot be fit by a Gaussian' + goto, DONE + endif + + skylvl = (sumd - hy*sumg)/p + dy = (sgdgdy - (sddgdy-sdgdy*(hy*sumg + skylvl*p)))/(hy*sdgdys/sigsq) + if (abs(dy) GE nhalf) then begin + if ~keyword_set(SILENT) then message,/INF, $ + 'Position '+ pos[i] + ' is too far from initial guess' + goto, DONE + endif + ycen[i] = ymax + dy ;Y centroid in original array +DONE: + + endfor + +return +end diff --git a/modules/idl_downloads/astro/pro/geo2eci.pro b/modules/idl_downloads/astro/pro/geo2eci.pro new file mode 100644 index 0000000..d11208c --- /dev/null +++ b/modules/idl_downloads/astro/pro/geo2eci.pro @@ -0,0 +1,79 @@ +;+ +; NAME: +; GEO2ECI +; +; PURPOSE: +; Convert geographic spherical coordinates to Earth-centered inertial coords +; +; EXPLANATION: +; Converts from geographic spherical coordinates [latitude, longitude, +; altitude] to ECI (Earth-Centered Inertial) [X,Y,Z] rectangular +; coordinates. JD time is also needed. +; +; Geographic coordinates are in degrees/degrees/km +; Geographic coordinates assume the Earth is a perfect sphere, with radius +; equal to its equatorial radius. +; ECI coordinates are in km from Earth center at epoch TOD (True of Date) +; +; CALLING SEQUENCE: +; ECIcoord=geo2eci(gcoord,JDtime) +; +; INPUT: +; gcoord: geographic [latitude,longitude,altitude], or a an array [3,n] +; of n such coordinates +; JDtime: Julian Day time, double precision. Can be a 1-D array of n +; such times. +; +; KEYWORD INPUTS: +; None +; +; OUTPUT: +; a 3-element array of ECI [X,Y,Z] coordinates, or an array [3,n] of +; n such coordinates, double precision. The TOD epoch is the +; supplied JDtime. +; +; COMMON BLOCKS: +; None +; +; PROCEDURES USED: +; CT2LST - Convert Local Civil Time to Local Mean Sidereal Time +; +; EXAMPLES: +; +; IDL> ECIcoord=geo2eci([0,0,0], 2452343.38982663D) +; IDL> print,ECIcoord +; -3902.9606 5044.5548 0.0000000 +; +; (The above is the ECI coordinates of the intersection of the equator and +; Greenwich's meridian on 2002/03/09 21:21:21.021) +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (shilaire@astro.phys.ethz.ch) +; on 2002/05/14 +; Update documentation to specify epoch is TOD. +; R. Redmon NOAA/NGDC April 2014 +; +;- + +;==================================================================================== +FUNCTION geo2eci,incoord,JDtim + + Re=6378.137 ; Earth's equatorial radius, in km + + lat = DOUBLE(incoord[0,*])*!DPI/180. + lon = DOUBLE(incoord[1,*])*!DPI/180. + alt = DOUBLE(incoord[2,*]) + JDtime= DOUBLE(JDtim) + + ct2lst,gst,0,0,JDtime + angle_sid=gst*2.*!DPI/24. ; sidereal angle + + theta=lon+angle_sid ; azimuth + r=(alt+Re)*cos(lat) + X=r*cos(theta) + Y=r*sin(theta) + Z=(alt+Re)*sin(lat) + + RETURN,[X,Y,Z] +END +;==================================================================================== diff --git a/modules/idl_downloads/astro/pro/geo2geodetic.pro b/modules/idl_downloads/astro/pro/geo2geodetic.pro new file mode 100644 index 0000000..225384a --- /dev/null +++ b/modules/idl_downloads/astro/pro/geo2geodetic.pro @@ -0,0 +1,153 @@ +;+ +; NAME: +; GEO2GEODETIC +; +; PURPOSE: +; Convert from geographic/planetographic to geodetic coordinates +; EXPLANATION: +; Converts from geographic (latitude, longitude, altitude) to geodetic +; (latitude, longitude, altitude). In geographic coordinates, the +; Earth is assumed a perfect sphere with a radius equal to its equatorial +; radius. The geodetic (or ellipsoidal) coordinate system takes into +; account the Earth's oblateness. +; +; Geographic and geodetic longitudes are identical. +; Geodetic latitude is the angle between local zenith and the equatorial plane. +; Geographic and geodetic altitudes are both the closest distance between +; the satellite and the ground. +; +; The PLANET keyword allows a similar transformation for the other +; planets (planetographic to planetodetic coordinates). +; +; The EQUATORIAL_RADIUS and POLAR_RADIUS keywords allow the +; transformation for any ellipsoid. +; +; Latitudes and longitudes are expressed in degrees, altitudes in km. +; +; REF: Stephen P. Keeler and Yves Nievergelt, "Computing geodetic +; coordinates", SIAM Rev. Vol. 40, No. 2, pp. 300-309, June 1998 +; +; Planetary constants from "Allen's Astrophysical Quantities", +; Fourth Ed., (2000) +; +; CALLING SEQUENCE: +; ecoord=geo2geodetic(gcoord,[ PLANET=,EQUATORIAL_RADIUS=, POLAR_RADIUS=]) +; +; INPUT: +; gcoord = a 3-element array of geographic [latitude,longitude,altitude], +; or an array [3,n] of n such coordinates. +; +; +; OPTIONAL KEYWORD INPUT: +; PLANET = keyword specifying planet (default is Earth). The planet +; may be specified either as an integer (1-9) or as one of the +; (case-independent) strings 'mercury','venus','earth','mars', +; 'jupiter','saturn','uranus','neptune', or 'pluto' +; +; EQUATORIAL_RADIUS : Self-explanatory. In km. If not set, PLANET's +; value is used. +; POLAR_RADIUS : Self-explanatory. In km. If not set, PLANET's value is +; used. +; +; OUTPUT: +; a 3-element array of geodetic/planetodetic [latitude,longitude,altitude], +; or an array [3,n] of n such coordinates, double precision. +; +; COMMON BLOCKS: +; None +; +; RESTRICTIONS: +; +; Whereas the conversion from geodetic to geographic coordinates is given +; by an exact, analytical formula, the conversion from geographic to +; geodetic isn't. Approximative iterations (as used here) exist, but tend +; to become less good with increasing eccentricity and altitude. +; The formula used in this routine should give correct results within +; six digits for all spatial locations, for an ellipsoid (planet) with +; an eccentricity similar to or less than Earth's. +; More accurate results can be obtained via calculus, needing a +; non-determined amount of iterations. +; In any case, +; IDL> PRINT,geodetic2geo(geo2geodetic(gcoord)) - gcoord +; is a pretty good way to evaluate the accuracy of geo2geodetic.pro. +; +; EXAMPLES: +; +; Locate the geographic North pole, altitude 0., in geodetic coordinates +; IDL> geo=[90.d0,0.d0,0.d0] +; IDL> geod=geo2geodetic(geo); convert to equivalent geodetic coordinates +; IDL> PRINT,geod +; 90.000000 0.0000000 21.385000 +; +; As above, but for the case of Mars +; IDL> geod=geo2geodetic(geo,PLANET='Mars') +; IDL> PRINT,geod +; 90.000000 0.0000000 18.235500 +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (shilaire@astro.phys.ethz.ch), May 2002 +; Generalized for all solar system planets by Robert L. Marcialis +; (umpire@lpl.arizona.edu), May 2002 +; Modified 2002/05/18, PSH: added keywords EQUATORIAL_RADIUS and +; POLAR_RADIUS +;- + +;================================================================================ +FUNCTION geo2geodetic,gcoord,PLANET=planet, $ + EQUATORIAL_RADIUS=equatorial_radius, POLAR_RADIUS=polar_radius + + sz_gcoord = size(gcoord,/DIMEN) + if sz_gcoord[0] LT 3 then message, $ + 'ERROR - 3 coordinates (latitude,longitude,altitude) must be specified' + + if N_elements(PLANET) GT 0 then begin + if size(planet,/tname) EQ 'STRING' then begin + choose_planet=['mercury','venus','earth','mars','jupiter','saturn', $ + 'uranus','neptune','pluto'] + index=where(choose_planet eq strlowcase(planet)) + index=index[0] ; make it a scalar + if index eq -1 then index = 2 ; default is Earth + endif else index = planet-1 + endif else index=2 + + Requator = [2439.7d0,6051.8d0,6378.137D, 3397.62d0, 71492d0, $ + 60268.d0, 25559.d0, 24764.d0, 1195.d0] + Rpole = [2439.7d0, 6051.8d0, 6356.752d0, 3379.3845d0, 67136.5562d0, $ + 54890.7686d0, 24986.1354d0, 24347.6551d0, 1195.d0] + Re = Requator[index] ; equatorial radius + Rp = Rpole[index] ; polar radius + + IF KEYWORD_SET(EQUATORIAL_RADIUS) THEN Re=DOUBLE(equatorial_radius[0]) + IF KEYWORD_SET(POLAR_RADIUS) THEN Rp=DOUBLE(polar_radius[0]) + + e = sqrt(Re^2 - Rp^2)/Re + ;f=1/298.257D ; flattening = (Re-Rp)/Re [not needed, here] + + glat=DOUBLE(gcoord[0,*])*!DPI/180. + glon=DOUBLE(gcoord[1,*]) + galt=DOUBLE(gcoord[2,*]) + + x= (Re+galt) * cos(glat) * cos(glon) + y= (Re+galt) * cos(glat) * sin(glon) + z= (Re+galt) * sin(glat) + r=sqrt(x^2+y^2) + + s=(r^2 + z ^2)^0.5 * (1 - Re*((1-e^2)/((1-e^2)*r^2 + z^2))^0.5) + t0=1+s*(1- (e*z)^2/(r^2 + z^2) )^0.5 /Re + dzeta1=z * t0 + xi1=r*(t0 - e^2) + rho1= (xi1^2 + dzeta1^2)^0.5 + c1=xi1/rho1 + s1=dzeta1/rho1 + b1=Re/(1- (e*s1)^2)^0.5 + u1= b1*c1 + w1= b1*s1*(1- e^2) + ealt= ((r - u1)^2 + (z - w1)^2)^0.5 + elat= atan(s1,c1) + + elat=elat*180./!DPI + elon=glon + + RETURN,[elat,elon,ealt] +END +;=============================================================================== diff --git a/modules/idl_downloads/astro/pro/geo2mag.pro b/modules/idl_downloads/astro/pro/geo2mag.pro new file mode 100644 index 0000000..21f8786 --- /dev/null +++ b/modules/idl_downloads/astro/pro/geo2mag.pro @@ -0,0 +1,103 @@ +;+ +; NAME: +; GEO2MAG() +; +; PURPOSE: +; Convert from geographic to geomagnetic coordinates +; EXPLANATION: +; Converts from GEOGRAPHIC (latitude,longitude) to GEOMAGNETIC (latitude, +; longitude). (Altitude remains the same) +; +; Latitudes and longitudes are expressed in degrees. +; +; CALLING SEQUENCE: +; mcoord=geo2mag(gcoord) +; +; INPUT: +; gcoord = a 2-element array of geographic [latitude,longitude], or an +; array [2,n] of n such coordinates. +; +; KEYWORD INPUTS: +; None +; +; OUTPUT: +; a 2-element array of magnetic [latitude,longitude], or an array [2,n] +; of n such coordinates +; +; COMMON BLOCKS: +; None +; +; EXAMPLES: +; geographic coordinates of magnetic south pole +; +; IDL> mcoord=geo2mag([79.3,288.59]) +; IDL> print,mcoord +; 89.999992 -173.02325 +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (Saint-Hilaire@astro.phys.ethz.ch), +; May 2002 +; +;- + +;==================================================================================== +FUNCTION geo2mag,incoord + + ; SOME 'constants'... + Dlong=288.59D ; longitude (in degrees) of Earth's magnetic south pole + ;(which is near the geographic north pole!) (1995) + Dlat=79.30D ; latitude (in degrees) of same (1995) + R = 1D ; distance from planet center (value unimportant -- + ;just need a length for conversion to rectangular coordinates) + + ; convert first to radians + Dlong=Dlong*!DPI/180. + Dlat=Dlat*!DPI/180. + + glat=DOUBLE(incoord[0,*])*!DPI/180. + glon=DOUBLE(incoord[1,*])*!DPI/180. + galt=glat * 0. + R + + coord=[glat,glon,galt] + + ;convert to rectangular coordinates + ; X-axis: defined by the vector going from Earth's center towards + ; the intersection of the equator and Greenwitch's meridian. + ; Z-axis: axis of the geographic poles + ; Y-axis: defined by Y=Z^X + x=coord[2,*]*cos(coord[0,*])*cos(coord[1,*]) + y=coord[2,*]*cos(coord[0,*])*sin(coord[1,*]) + z=coord[2,*]*sin(coord[0,*]) + + ;Compute 1st rotation matrix : rotation around plane of the equator, + ;from the Greenwich meridian to the meridian containing the magnetic + ;dipole pole. + geolong2maglong=dblarr(3,3) + geolong2maglong[0,0]=cos(Dlong) + geolong2maglong[0,1]=sin(Dlong) + geolong2maglong[1,0]=-sin(Dlong) + geolong2maglong[1,1]=cos(Dlong) + geolong2maglong[2,2]=1. + out=geolong2maglong # [x,y,z] + + ;Second rotation : in the plane of the current meridian from geographic + ; pole to magnetic dipole pole. + tomaglat=dblarr(3,3) + tomaglat[0,0]=cos(!DPI/2-Dlat) + tomaglat[0,2]=-sin(!DPI/2-Dlat) + tomaglat[2,0]=sin(!DPI/2-Dlat) + tomaglat[2,2]=cos(!DPI/2-Dlat) + tomaglat[1,1]=1. + out= tomaglat # out + + ;convert back to latitude, longitude and altitude + mlat=atan(out[2,*],sqrt(out[0,*]^2+out[1,*]^2)) + mlat=mlat*180./!DPI + mlon=atan(out[1,*],out[0,*]) + mlon=mlon*180./!DPI + ;malt=sqrt(out[0,*]^2+out[1,*]^2+out[2,*]^2)-R +; I don't care about that one...just put it there for completeness' sake + + RETURN,[mlat,mlon] +END +;=============================================================================== diff --git a/modules/idl_downloads/astro/pro/geodetic2geo.pro b/modules/idl_downloads/astro/pro/geodetic2geo.pro new file mode 100644 index 0000000..0615516 --- /dev/null +++ b/modules/idl_downloads/astro/pro/geodetic2geo.pro @@ -0,0 +1,125 @@ +;+ +; NAME: +; GEODETIC2GEO +; +; PURPOSE: +; Convert from geodetic (or planetodetic) to geographic coordinates +; EXPLANATION: +; Converts from geodetic (latitude, longitude, altitude) to geographic +; (latitude, longitude, altitude). In geographic coordinates, the +; Earth is assumed a perfect sphere with a radius equal to its equatorial +; radius. The geodetic (or ellipsoidal) coordinate system takes into +; account the Earth's oblateness. +; +; Geographic and geodetic longitudes are identical. +; Geodetic latitude is the angle between local zenith and the equatorial +; plane. Geographic and geodetic altitudes are both the closest distance +; between the satellite and the ground. +; +; The PLANET keyword allows a similar transformation for the other +; planets (planetodetic to planetographic coordinates). +; +; The EQUATORIAL_RADIUS and POLAR_RADIUS keywords allow the +; transformation for any ellipsoid. +; +; Latitudes and longitudes are expressed in degrees, altitudes in km. +; +; REF: Stephen P. Keeler and Yves Nievergelt, "Computing geodetic +; coordinates", SIAM Rev. Vol. 40, No. 2, pp. 300-309, June 1998 +; Planetary constants from "Allen's Astrophysical Quantities", +; Fourth Ed., (2000) +; +; CALLING SEQUENCE: +; gcoord = geodetic2geo(ecoord, [ PLANET= ] ) +; +; INPUT: +; ecoord = a 3-element array of geodetic [latitude,longitude,altitude], +; or an array [3,n] of n such coordinates. +; +; OPTIONAL KEYWORD INPUT: +; PLANET = keyword specifying planet (default is Earth). The planet +; may be specified either as an integer (1-9) or as one of the +; (case-independent) strings 'mercury','venus','earth','mars', +; 'jupiter','saturn','uranus','neptune', or 'pluto' +; +; EQUATORIAL_RADIUS : Self-explanatory. In km. If not set, PLANET's value +; is used. Numeric scalar +; POLAR_RADIUS : Self-explanatory. In km. If not set, PLANET's value is +; used. Numeric scalar +; +; OUTPUT: +; a 3-element array of geographic [latitude,longitude,altitude], or an +; array [3,n] of n such coordinates, double precision +; +; The geographic and geodetic longitudes will be identical. +; COMMON BLOCKS: +; None +; +; EXAMPLES: +; +; IDL> geod=[90,0,0] ; North pole, altitude 0., in geodetic coordinates +; IDL> geo=geodetic2geo(geod) +; IDL> PRINT,geo +; 90.000000 0.0000000 -21.385000 +; +; As above, but the equivalent planetographic coordinates for Mars +; IDL> geod=geodetic2geo(geod,PLANET='Mars'); +; IDL> PRINT,geod +; 90.000000 0.0000000 -18.235500 +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (shilaire@astro.phys.ethz.ch), +; May 2002 +; +; Generalized for all solar system planets by Robert L. Marcialis +; (umpire@lpl.arizona.edu), May 2002 +; +; Modified 2002/05/18, PSH: added keywords EQUATORIAL_RADIUS and +; POLAR_RADIUS +; +;- +;=================================================================================== +FUNCTION geodetic2geo,ecoord,PLANET=planet, $ + EQUATORIAL_RADIUS=equatorial_radius, POLAR_RADIUS=polar_radius + + sz_ecoord = size(ecoord,/DIMEN) + if sz_ecoord[0] LT 3 then message, $ + 'ERROR - 3 coordinates (latitude,longitude,altitude) must be specified' + + if N_elements(PLANET) GT 0 then begin + if size(planet,/tname) EQ 'STRING' then begin + choose_planet=['mercury','venus','earth','mars','jupiter','saturn', $ + 'uranus','neptune','pluto'] + index=where(choose_planet eq strlowcase(planet)) + index=index[0] ; make it a scalar + if index eq -1 then index = 2 ; default is Earth + endif else index = planet-1 + endif else index=2 + + Requator = [2439.7d0,6051.8d0,6378.137D, 3397.62d0, 71492d0, $ + 60268.d0, 25559.d0, 24764.d0, 1195.d0] + Rpole = [2439.7d0, 6051.8d0, 6356.752d0, 3379.3845d0, 67136.5562d0, $ + 54890.7686d0, 24986.1354d0, 24347.6551d0, 1195.d0] + ;f=1/298.257D ; flattening = (Re-Rp)/Re + Re = Requator(index) ; equatorial radius + Rp = Rpole(index) ; polar radius + + IF KEYWORD_SET(EQUATORIAL_RADIUS) THEN Re=DOUBLE(equatorial_radius[0]) + IF KEYWORD_SET(POLAR_RADIUS) THEN Rp=DOUBLE(polar_radius[0]) + + e = sqrt(Re^2 - Rp^2)/Re + elat = DOUBLE(ecoord[0,*])*!DPI/180. + elon = DOUBLE(ecoord[1,*]) + ealt = DOUBLE(ecoord[2,*]) + + beta=sqrt(1-(e*sin(elat))^2) + r=(Re/beta + ealt)*cos(elat) + z=(Re*(1-e^2)/beta + ealt)*sin(elat) + + glat=atan(z,r)*180./!DPI + glon=elon + galt=sqrt(r^2+z^2) - Re + + RETURN,[glat,glon,galt] +END +;=================================================================================== diff --git a/modules/idl_downloads/astro/pro/get_coords.pro b/modules/idl_downloads/astro/pro/get_coords.pro new file mode 100644 index 0000000..0e3427c --- /dev/null +++ b/modules/idl_downloads/astro/pro/get_coords.pro @@ -0,0 +1,165 @@ +pro GET_COORDS, Coords, PromptString, NumVals, InString=InString, Quiet=Quiet +;******************************************************************************* +;+ +; NAME: +; GET_COORDS +; +; PURPOSE: +; Converts a string with angular coordinates to floating point values. +; EXPLANATION: +; Although called by ASTRO.PRO, this is a general purpose routine. +; The user may input as floating point or sexagesimal. If user inputs +; calling procedure's job to convert hours to degrees if needed. +; Since the input string is parsed character-by-character, ANY character +; that is not a digit, minus sign or decimal point may be used as a +; delimiter, i.e. acceptable examples of user input are: +; +; 1:03:55 -10:15:31 +; 1 3 55.0 -10 15 31 +; 1*3 55 -10abcd15efghij31 +; 1.065278 hello -10.25861 +; +; CALLING SEQUENCE: +; GET_COORDS, Coords, [ PromptString, NumVals, INSTRING =, /QUIET ] +; +; OPTIONAL INPUT: +; PromptString - A string to inform the user what data are to be entered +; +; OPTIONAL KEYWORD INPUT: +; InString - a keyword that, if set, is assumed to already contain the +; input data string to be parsed. If this keyword is set, then +; the user is not prompted for any input. +; /Quiet - if set the program won't printout any error messages, but bad +; input is still flagged by Coords=[-999,-999]. +; +; OUTPUT: +; Coords - a 2 element floating array containing the coordinates. The +; vector [-999,-999] is returned if there has been an error. +; +; OPTIONAL OUTPUT: +; NumVals - the number of separate values entered by the user: 2 if the +; user entered the coordinates as floating point numbers, 6 if +; the user entered the coordinates as sexagesimal numbers. Some +; calling procedures might find this information useful (e.g., to +; to print some output in the same format as the user's input). +; +; REVISION HISTORY: +; Written by Joel Parker, 5 MAR 90 +; Included InString and Quiet keywords. Cleaned up some of the code and +; comments. JWmP, 16 Jun 94 +; +;******************************************************************************* +; Converted to IDL V5.0 W. Landsman September 1997 +;- + +On_error,2 + +if (N_params() eq 0) then begin + print,'Syntax - ' + $ + 'GET_COORDS, Coords, [PromptString, NumVals, INSTRING=, /QUIET]' + return +endif + +; +; Define some parameters and variables. +; +if (N_Params() lt 2) then PromptString = " Please input the coordinates" +Bell = string(7B) +Minus = 45 ; ascii of "-" +Decimal = 46 ; ascii of "." +Zero = 48 ; ascii of "0" +Nine = 57 ; ascii of "9" +ValArr = dblarr(6) +SignArr = intarr(6) + 1 +NumVals = 0 +StartPos = -1 + +; +; If the InString keyword is not set, then prompt the user for input. If +; nothing is entered, return [-999,-999] as a warning flag to the calling +; procedure. +; +if keyword_set(InString) then begin + Coords = InString +endif else begin + Coords = "" + print,form = "(1X,A,$)", + PromptString + " {RETURN to exit} " + read, Coords +endelse + +Coords = strtrim(Coords) + " " ; The final space is needed for parsing purposes +if (Coords eq " ") then begin + Coords = [-999,-999] + return +endif + +; +; All's well. Get the byte values for the characters in the input string. +; +BCoords = byte(Coords) + +; +; Begin the loop that parses the input string. +; Start by loading the byte value of the next character into the BC variable. +; Check to see if the character is a minus sign (if so, set the flag in the +; SignArr array to -1). Check to see if the character is a numeral between 0-9 +; or a decimal (if so, then the NumFlag is set to 1). +; +for N = 0,(strlen(Coords)-1) do begin + BC = BCoords[N] + if (BC eq Minus) then SignArr[NumVals] = -1 + NumFlag = ((BC ge Zero) and (BC le Nine)) or (BC eq Decimal) + +; +; If the number flag is set, but StartPos = -1, then we are starting a new +; value. Load the character's position in StartPos. +; + if (NumFlag and (StartPos eq -1)) then StartPos = N + +; +; If the number flag is NOT set, but StartPos > -1, then we have just +; finished reading a number. Read the number from StartPos to the current +; position, and reset StartPos to -1. +; Put the resulting number in the ValArr. +; + if (~(NumFlag) && (StartPos gt -1)) then begin + if (NumVals lt 6) then begin + ValArr[NumVals] = float(strmid(Coords, StartPos, (N - StartPos))) + endif + StartPos = -1 + NumVals = NumVals + 1 + endif +endfor + +; +; Coords should be a 2 or 6 element vector {depending on the type of input}. +; It is converted to a 2 element vector such that Coords = [RA/Long, Dec/Lat]. +; +case NumVals of + + 2 : Coords = (ValArr * SignArr)[0:1] + + 6 : begin + Temp = where(SignArr[0:2] eq -1) + if (Temp[0] eq -1) then XSign = 1 else XSign = -1 + Temp = where(SignArr[3:5] eq -1) + if (Temp[0] eq -1) then YSign = 1 else YSign = -1 + X = (ValArr[0] + (ValArr[1] / 60.) + (ValArr[2] / 3600.)) * XSign + Y = (ValArr[3] + (ValArr[4] / 60.) + (ValArr[5] / 3600.)) * YSign + Coords = [X,Y] + end + + else : begin + Coords = [-999,-999] + if ~keyword_set(Quiet) then begin + print, Bell + print, "ERROR - Invalid Input!" + print, "Coordinates must be input as 2 or 6 values." + print, "For example: 1.568 -10.343 or 1 34 4.8 10 20 34.8" + endif + endelse + +endcase + +return +end ; procedure GET_COORDS by Joel Parker 16 Jun 94 diff --git a/modules/idl_downloads/astro/pro/get_date.pro b/modules/idl_downloads/astro/pro/get_date.pro new file mode 100644 index 0000000..d18e854 --- /dev/null +++ b/modules/idl_downloads/astro/pro/get_date.pro @@ -0,0 +1,109 @@ +pro get_date, dte, in_date, OLD = old, TIMETAG = timetag +;+ +; NAME: +; GET_DATE +; PURPOSE: +; Return the (current) UTC date in CCYY-MM-DD format for FITS headers +; EXPLANATION: +; This is the format required by the DATE and DATE-OBS keywords in a +; FITS header. +; +; CALLING SEQUENCE: +; GET_DATE, FITS_date, [ in_date, /OLD, /TIMETAG ] +; OPTIONAL INPUTS: +; in_date - string (scalar or vector) containing dates in IDL +; systime() format (e.g. 'Tue Sep 25 14:56:14 2001') +; OUTPUTS: +; FITS_date = A scalar character string giving the current date. Actual +; appearance of dte depends on which keywords are supplied. +; +; No Keywords supplied - dte is a 10 character string with the format +; CCYY-MM-DD where represents a calendar year, the +; ordinal number of a calendar month within the calendar year, +; and
the ordinal number of a day within the calendar month. +; /TIMETAG set - dte is a 19 character string with the format +; CCYY-MM-DDThh:mm:ss where represents the hour in the day, +; the minutes, the seconds, and the literal 'T' the +; ISO 8601 time designator +; /OLD set - dte is an 8 character string in DD/MM/YY format +; +; INPUT KEYWORDS: +; /TIMETAG - Specify the time to the nearest second in the DATE format +; /OLD - Return the DATE format formerly (pre-1997) recommended for FITS +; Note that this format is now deprecated because it uses only +; a 2 digit representation of the year. +; EXAMPLE: +; Add the current date to the DATE keyword in a FITS header,h +; +; IDL> GET_DATE,dte +; IDL> sxaddpar, h, 'DATE', dte, 'Date header was created' +; +; NOTES: +; (1) A discussion of the DATExxx syntax in FITS headers can be found in +; http://www.cv.nrao.edu/fits/documents/standards/year2000.txt +; +; (2) Those who wish to use need further flexibility in their date +; formats (e.g. to use TAI time) should look at Bill Thompson's time +; routines in http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/time +; +; PROCEDURES USED: +; DAYCNV - Convert Julian date to Gregorian calendar date +; REVISION HISTORY: +; Written W. Landsman March 1991 +; Major rewrite to write new DATExxx syntax W. Landsman August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Work after year 2000 even with /OLD keyword W. Landsman January 2000 +; Don't need to worry about TIME_DIFF since V5.4 W. Landsman July 2001 +; Assume since V5.4, remove LOCAL_DIFF keyword W. Landsman April 2006 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - Get_date, FITS_date, [ in_date, /TIMETAG, /OLD ]' + print,' FITS_date - output string giving date(s) in FITS format' + print,' in-date - Optional input string giving date in systime() format' + return + endif + + if N_elements(in_date) GT 0 then begin + mn = strmid(in_date,4,3) + month = month_cnv(mn) + day = fix(strmid(in_date,8,2)) + ihr = fix(strmid(in_date,11,2)) + imn = fix(strmid(in_date,14,2)) + sec = fix(strmid(in_date,17,2)) + yr = fix(strmid(in_date,20,4)) + endif else begin + seconds = systime(1) ;Number of seconds since Jan 1, 1970 + dayseconds = 86400.D0 ;Number of seconds in a day + mjd = seconds/dayseconds + 40587.0D + jd = 2400000.5D + mjd + DAYCNV, jd, yr, month, day, hr + endelse + + if keyword_set(old) then begin + + if yr GE 2000 then yr = yr - 100 + dte = string(day,f='(I2.2)') + '/' + string(month,f='(i2.2)') + $ + '/' + string( yr-1900,f='(I2.2)') + + endif else $ + + dte = string(yr,f='(I4.4)') + '-' + string(month,f='(i2.2)') + '-' + $ + string(day,f='(I2.2)') + + if keyword_set(TIMETAG) then begin + if N_elements(in_date) EQ 0 then begin + ihr = fix(hr) + mn = (hr - ihr)*60. + imn = fix(mn) + sec = round((mn - imn)*60.) + endif + + dte = dte + 'T' + string(ihr,f='(I2.2)') + ':' + string(imn,f='(I2.2)') + $ + ':' + string(round(sec),f='(I2.2)') + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/get_equinox.pro b/modules/idl_downloads/astro/pro/get_equinox.pro new file mode 100644 index 0000000..d1a2485 --- /dev/null +++ b/modules/idl_downloads/astro/pro/get_equinox.pro @@ -0,0 +1,101 @@ +FUNCTION GET_EQUINOX,HDR,CODE, ALT = alt +;+ +; NAME: +; GET_EQUINOX +; PURPOSE: +; Return the equinox value from a FITS header. +; EXPLANATION: +; Checks for 4 possibilities: +; +; (1) If the EQUINOX keyword is found and has a numeric value, then this +; value is returned +; (2) If the EQUINOX keyword has the values 'J2000' or 'B1950', then +; either 2000. or 1950. is returned. +; (3) If the EQUINOX keyword is not found, then GET_EQUINOX will return +; the EPOCH keyword value. This usage of EPOCH is disparaged. +; (4) If neither EQUINOX no EPOCH is found, then the RADESYS keyword +; (or the deprecated RADECSYS keyword) is checked. If the value +; is 'ICRS' or 'FK5' then 2000 is is returned, if it is 'FK4' then +; 1950 is returned. +; +; According Calabretta & Greisen (2002, A&A, 395, 1077) the EQUINOX should +; be written as a numeric value, as in format (1). However, in older +; FITS headers, the EQUINOX might have been written using formats (2) or +; (3). +; CALLING SEQUENCE: +; Year = GET_EQUINOX( Hdr, [ Code ] ) +; +; INPUTS: +; Hdr - FITS Header, string array, will be searched for the EQUINOX +; (or EPOCH) keyword. +; +; OUTPUT: +; Year - Year of equinox in FITS header, numeric scalar +; OPTIONAL OUTPUT: +; Code - Result of header search, scalar +; -1 - EQUINOX, EPOCH or RADECSYS keyword not found in header +; 0 - EQUINOX found as a numeric value +; 1 - EPOCH keyword used for equinox (not recommended) +; 2 - EQUINOX found as 'B1950' +; 3 - EQUINOX found as 'J2000' +; 4 - EQUINOX derived from value of RADESYS or RADECSYS keyword +; 'ICRS', 'FK5' ==> 2000, 'FK4' ==> 1950 +; OPTIONAL KEYWORD INPUT: +; ALT - single character 'A' through 'Z' or ' ' specifying which +; astrometry system to use in the FITS header. The default is +; to use the primary astrometry or ALT = ''. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. +; PROCEDURES USED: +; ZPARCHECK, SXPAR() +; NOTES: +; Technically, RADESYS = 'ICRS' does not specify any equinox, but can be +; assumed to be equivalent to J2000 for all but highest-precision work. +; REVISION HISTORY: +; Written W. Landsman STX March, 1991 +; Don't use !ERR W. Landsman February 2000 +; N = 1 for check of EPOCH keyword, not 0 S. Ott July 2000 +; Added ALT keyword, recognize RADESYS along with deprecated RADECSYS +; W. Landsman Sep 2011 +;- + compile_opt idl2 + On_error,2 + + if N_elements(alt) EQ 0 then alt = '' else if (alt EQ '1') then alt = 'A' $ + else alt = strupcase(alt) + zparcheck, 'GET_EQUINOX', hdr, 1, 7, 1, 'FITS Header array' + code = -1 ;Not found yet + + year = SXPAR( Hdr, 'EQUINOX' + alt, Count = n ) ;YEAR of Initial equinox + if n EQ 0 then begin + + year = sxpar( Hdr, 'EPOCH', Count = n ) ;Check EPOCH if EQUINOX not found + if n EQ 1 then code = 1 else begin ;EPOCH keyword found + + sys = sxpar( Hdr, 'RADESYS'+alt, Count = n) + if n EQ 0 then sys = sxpar( Hdr, 'RADECSYS', Count = n) + if n EQ 1 then begin + code = 4 + case strmid(sys,0,3) of + 'ICR': year = 2000 + 'FK5': year = 2000 + 'FK4': year = 1950 + else: + endcase + endif + endelse + endif else begin + + tst = strmid(year,0,1) ;Check for 'J2000' or 'B1950' values + if (tst EQ 'J') || (TST EQ 'B') then begin + year = float(strmid(year,1,strlen(year)-1) ) + if tst EQ 'J' then code = 3 + if tst EQ 'B' then code = 2 + endif else code = 0 + + endelse + + return, year + end + diff --git a/modules/idl_downloads/astro/pro/get_juldate.pro b/modules/idl_downloads/astro/pro/get_juldate.pro new file mode 100644 index 0000000..585cc7d --- /dev/null +++ b/modules/idl_downloads/astro/pro/get_juldate.pro @@ -0,0 +1,44 @@ +pro get_juldate,jd +;+ +; NAME: +; GET_JULDATE +; PURPOSE: +; Return the current Julian Date +; +; EXPLANATION: +; In V5.4, GET_JULDATE became completely obsolete with the introduction +; of the /UTC keyword to SYSTIME(). So GET_JULDATE,jd is equivalent to +; jd = SYSTIME(/JULIAN,/UTC). +; +; CALLING SEQUENCE: +; GET_JULDATE,jd +; +; INPUTS: +; None +; +; OUTPUTS: +; jd = Current Julian Date, double precision scalar +; +; EXAMPLE: +; Return the current hour, day, month and year as integers +; +; IDL> GET_JULDATE, JD ;Get current Julian date +; IDL> DAYCNV, JD, YR, MON, DAY, HOURS ;Convert to hour,day month & year +; +; METHOD: +; A call is made to SYSTIME(/JULIAN,/UTC). +; +; REVISION HISTORY: +; Written Wayne Landsman March, 1991 +; Converted to IDL V5.0 W. Landsman September 1997 +; Assume since V5.4 Use /UTC keyword to SYSTIME() W. Landsman April 2006 +;- + compile_opt idl2 + if N_Params() LT 1 then begin + Print,'Syntax - GET_JULDATE, JD' + return + endif + + jd = SYSTIME(/JULIAN,/UTC) + return + end diff --git a/modules/idl_downloads/astro/pro/get_pipe_filesize.pro b/modules/idl_downloads/astro/pro/get_pipe_filesize.pro new file mode 100644 index 0000000..743b6af --- /dev/null +++ b/modules/idl_downloads/astro/pro/get_pipe_filesize.pro @@ -0,0 +1,57 @@ +pro get_pipe_filesize, unit, nbytes, buffer = buffer +;+ +; NAME: +; GET_PIPE_FILESIZE +; +; PURPOSE: +; Determine the number of bytes in a unit opened as a pipe with SPAWN +; +; EXPLANATION: +; Reads into a buffer until the end of file is reached and then counts the +; number of bytes read. Needed because the fstat.size field is not +; automatically set for a unit opened as a pipe. +; +; CALLING SEQUENCE: +; GET_PIPE_FILESIZE,unit, nbytes_in_file, BUFFER = +; +; INPUTS: +; unit - IDL unit number of a previously opened file. For example, +; an FPACK ( http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) compressed +; FITS file could be opened as follows: +; +; IDL> spawn,'funpack -S test.fits.fz', unit=unit +; OUTPUTS: +; nbytes_in_file - Unsigned long64 integer giving number of bytes in +; the file. +; +; INPUT KEYWORD PARAMETERS: +; BUFFER Integer giving number of bytes in the buffer. Default = +; . 1000000 +; NOTES: +; Unite must be opened prior to calling GET_PIPE_FILESIZE, and the number +; of bytes is counted from the current pointer position. The pointer is +; left at the end of the file upon return. +; PROCEDURES USED: +; SETDEFAULTVALUE +; REVISION HISTORY: +; Written, W. Landsman Adnet Dec 2010 + + On_error,2 + compile_opt idl2 + + nbytes = 0ULL + setdefaultvalue, buffer, 1000000 + ON_IOerror,Done + b= bytarr(buffer,/noz) + + while 1 do begin + readu,unit,b + nbytes += buffer + endwhile + +Done: + On_IOError, null + nbytes += (fstat(unit)).transfer_count + + return + end diff --git a/modules/idl_downloads/astro/pro/getopt.pro b/modules/idl_downloads/astro/pro/getopt.pro new file mode 100644 index 0000000..9ad56a9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/getopt.pro @@ -0,0 +1,95 @@ +function getopt,input,type,numopt,count =count +;+ +; NAME: +; GETOPT +; PURPOSE: +; Convert a string supplied by the user into a valid scalar or vector +; EXPLANATION: +; Distinct elements in the string may be +; separated by either a comma or a space. The output scalar +; or vector can be specified to be either integer or floating +; point. A null string is converted to a zero. +; CALLING SEQUENCE: +; option = GETOPT( input, [ type, numopt, COUNT = ]) +; +; INPUTS: +; input - string that was input by user in response to a prompt +; Arithmetic operations can be included in the string (see +; examples) +; +; OPTIONAL INPUTS: +; type - Either an "I" (integer) or an "F" (floating point) specifying +; the datatype of the output vector. Default is floating point +; +; numopt - number of values expected by calling procedure +; If less than NUMOPT values are supplied the output +; vector will be padded with zeros. +; OUTPUTS: +; option - scalar or vector containing the numeric conversion of +; the fields in the string INPUT. If NUMOPT is not +; supplied, the number of elements in OPTION will +; equal the number of distinct fields in INPUT. +; OPTIONAL INPUT KEYWORD: +; Count - integer giving the number of values actually returned by +; GETOPT. If the input is invalid then COUNT is set to -1 +; NOTES: +; (1) If an input is invalid, Count is set to -1 and the result is set +; to 999. +; (2) GETOPT uses the execute function to interpret the user string. +; Therefore GETOPT itself cannot be called with the EXECUTE +; function. +; (3) GETOPT has a hard limit of 10 tokens in the input string. +; +; EXAMPLES: +; (1) a = getopt( '3.4,5*4 ', 'I' ) yields a = [ 3, 20] +; (2) a = getopt( '5/2.', 'F', 5) yields a = [2.5,0.,0.,0.,0.] +; (3) a = getopt( '2*3,5,6') yields a = [6.,5.,6.] +; +; REVISON HISTORY: +; written by B. Pfarr, STX, 5/6/87 +; change value of !ERR W. Landsman STX, 6/30/88 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + Err = 0 + inp = strtrim(input,2) ;Remove leading & trailing blanks + comma = strpos(inp,',') ;look for comma + + if comma GT 0 then char = ',' else char = ' ' ;Delineator is comma or space + + if N_params() LT 2 then option = fltarr(10) else $ + if strupcase(type) EQ 'I' then option = intarr(10) $ + else option = fltarr(10) ;Default type is float + + if strlen(inp) EQ 0 then return,0.0 $ ;Null string is 0.0 + else begin + i =0 ;Counts number of tokens + while inp NE '' do begin + + token = strtrim( gettok(inp,char), 2 ) + if token NE '' then begin + + test = execute( 'option[i] = ' + token) + if test NE 1 then begin + count = -1 + return, 999.9 + endif + i = i+1 + endif + + endwhile + endelse +; + + if N_params() LT 3 then begin + + if i EQ 1 then option = option[0] else $ + option = option[0:i-1] ;Trim output vector + + endif else option = option[0:numopt-1] + + count = N_elements(option) + return,option ;Successful completion + + end diff --git a/modules/idl_downloads/astro/pro/getpro.pro b/modules/idl_downloads/astro/pro/getpro.pro new file mode 100644 index 0000000..0460807 --- /dev/null +++ b/modules/idl_downloads/astro/pro/getpro.pro @@ -0,0 +1,126 @@ +pro getpro,proc_name ;Obtain a copy of a procedure +;+ +; NAME: +; GETPRO +; PURPOSE: +; Search !PATH for a procedure, and copy into user's working directory +; EXPLANATION: +; Extract a procedure from an IDL Library or directory given in the +; !PATH system variable and place it in the current default directory +; (presumably to be edited by the user). +; +; CALLING SEQUENCE: +; GETPRO, [ proc_name ] ;Find PROC_NAME in !PATH and copy +; +; OPTIONAL INPUT: +; proc_name - Character string giving the name of the IDL procedure or +; function. Do not give an extension. If omitted, +; the program will prompt for PROC_NAME. +; +; OUTPUTS: +; None. +; +; SIDE EFFECTS: +; A file with the extension .pro and a name given by PROC_NAME will +; be created on the user's directory. +; +; PROCEDURE: +; The FILE_WHICH() function is used to locate the procedure in the IDL +; !PATH. When found, FILE_COPY is used to +; copy the procedure into the user's current default directory. If not +; found in !PATH, then the ROUTINE_INFO() function is used to determine +; if it is an intrinsic IDL procedure. +; +; EXAMPLE: +; Put a copy of the USER library procedure CURVEFIT on the current +; directory +; +; IDL> getpro, 'CURVEFIT' +; +; RESTRICTIONS: +; User will be unable to obain source code for a native IDL function +; or procedure, or for a FORTRAN or C routine added with CALL_EXTERNAL. +; User must have write privilege to the current directory +; +; PROCEDURE CALLS: +; ZPARCHECK +; REVISION HISTORY: +; Written W. Landsman, STX Corp. June 1990 +; Now use intrinsic EXPAND_PATH() command W. Landsman November 1994 +; Use ROUTINE_NAMES() to check for intrinsic procs W. Landsman July 95 +; Update for Windows/IDL W. Landsman September 95 +; Check if procedure is in current directory W. Landsman June 1997 +; Use ROUTINE_INFO instead of undocumented ROUTINE_NAMES W.L. October 1998 +; Use FILE_WHICH() to locate procedure W. Landsman May 2006 +; Assume since V5.5, remove VMS support W. Landsman Sep 2006 +; Assume since V6.0, use file_basename() W.Landsman Feb 2009 +; Test for .sav file, more robust test for write privilege W.L. Jul 2010 +;- + On_error,2 ;Return to caller on error + compile_opt idl2 + + + if N_params() EQ 0 then begin ;Prompt for procedure name? + proc_name = ' ' + read,'Enter name of procedure you want a copy of: ',proc_name + + endif else zparcheck, 'getpro', proc_name, 1, 7, 0, 'Procedure name' + + name = strtrim( file_basename(proc_name,'.pro'), 2 ) + +;First check if procedure is already on current directory (no overwriting) + + if file_test(name + '.pro') then begin + message,name + '.pro already exists in the current directory',/INF + return + endif + +;Locate file in the user's !PATH + + fname = file_which(name + '.pro') + if fname NE '' then begin ;File found? + +; Now make sure user has write privileges + cd, current=curdir + if file_test(curdir,/write) NE 1 then $ + message,curdir + $ + ' has insufficient privilege or file protection violation' + + file_copy,fname, name + '.pro' + message,'Procedure '+ NAME + '.pro copied from '+ fname,/INF + return + endif else begin + +; Is it a .sav file in the !PATH? + fname = file_which(name + '.sav') + if fname NE '' then begin ;.Sav File found? + message,'File ' + fname + ' is an IDL save set',/INF + return + endif + +; Now check if it is an intrinsic IDL procedure or function. + + funcnames = routine_info(/system,/func) + name = strupcase(name) + test = where ( funcnames EQ name, fcount) + + funcnames = routine_info(/system) + test = where ( funcnames EQ name, pcount) + + if (fcount EQ 0) and (pcount EQ 0) then begin + + message,'Procedure '+NAME+' not found in the !PATH search string',/CONT + message,'Check your spelling or search the individual directories',/INF + + endif else begin + + if fcount GT 0 then $ + message,NAME + ' is an intrinsic IDL function',/CONT $ + else message,NAME + ' is an intrinsic IDL procedure',/CONT + message,'No source code is available',/INF + + endelse + endelse + return + + end diff --git a/modules/idl_downloads/astro/pro/getpsf.pro b/modules/idl_downloads/astro/pro/getpsf.pro new file mode 100644 index 0000000..d2c36f3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/getpsf.pro @@ -0,0 +1,405 @@ +pro getpsf,image,xc,yc,apmag,sky,ronois,phpadu, gauss,psf,idpsf,psfrad, $ + fitrad,psfname, DEBUG = debug +;+ +; NAME: +; GETPSF +; PURPOSE: +; To generate a point-spread function (PSF) from observed stars. +; EXPLANATION: +; The PSF is represented as a 2-dimensional Gaussian +; (integrated over each pixel) and a lookup table of residuals. +; The lookup table and Gaussian parameters are output in a FITS +; image file. The PSF FITS file created by GETPSF can be +; read with the procedure RDPSF. Adapted from the 1986 STSDAS +; version of DAOPHOT +; +; CALLING SEQUENCE: +; GETPSF, image, xc, yc, apmag, sky, [ronois, phpadu, gauss, psf, +; idpsf, psfrad, fitrad, psfname, /DEBUG ] +; +; INPUTS: +; IMAGE - input image array +; XC - input vector of x coordinates (from FIND), these should be +; IDL (first pixel is (0,0)) convention. +; YC - input vector of y coordinates (from FIND) +; APMAG - vector of magnitudes (from APER), used for initial estimate +; of gaussian intensity. If APMAG is multidimensional, (more +; than 1 aperture was used in APER) then the first aperture +; is used. +; SKY - vector of sky values (from APER) +; +; OPTIONAL INPUTS: +; The user will be prompted for the following parameters if not supplied. +; +; RONOIS - readout noise per pixel, (in electrons, or equivalent photons) +; PHPADU - photons per analog digital unit, used to scale the data +; numbers in IMAGE into photon units +; IDPSF - subscripts of the list of stars created by +; APER which will be used to define the PSF. Stars whose +; centroid does not fall within PSFRAD of the edge of the frame, +; or for which a Gaussian fit requires more than 25 iterations, +; will be ignored when creating the final PSF. +; PSFRAD - the scalar radius, in pixels, of the circular area within +; which the PSF will be defined. This should be slightly larger +; than the radius of the brightest star that one will be +; interested in. +; FITRAD - the scalar radius, in pixels of the circular area used in the +; least-square star fits. Stetson suggest that FITRAD should +; approximately equal to the FWHM, slightly less for crowded +; fields. (FITRAD must be smaller than PSFRAD.) +; PSFNAME- Name of the FITS file that will contain the table of residuals, +; and the best-fit Gaussian parameters. This file is +; subsequently required for use by NSTAR. +; +; OPTIONAL OUTPUTS: +; GAUSS - 5 element vector giving parameters of gaussian fit to the +; first PSF star +; GAUSS(0) - height of the gaussian (above sky) +; GAUSS(1) - the offset (in pixels) of the best fitting gaussian +; and the original X centroid +; GAUSS(2) - similiar offset from the Y centroid +; GAUSS(3) - Gaussian sigma in X +; GAUSS(4) - Gaussian sigma in Y +; PSF - 2-d array of PSF residuals after a Gaussian fit. +; +; PROCEDURE: +; GETPSF fits a Gaussian profile to the core of the first PSF star +; and generates a look-up table of the residuals of the +; actual image data from the Gaussian fit. If desired, it will then +; fit this PSF to another star (using PKFIT) to determine its precise +; centroid, scale the same Gaussian to the new star's core, and add the +; differences between the actual data and the scaled Gaussian to the +; table of residuals. (In other words, the Gaussian fit is performed +; only on the first star.) +; +; OPTIONAL KEYWORD INPUT: +; DEBUG - if this keyword is set and non-zero, then the result of each +; fitting iteration will be displayed. +; +; PROCEDURES CALLED +; DAOERF, MAKE_2D, MKHDR, RINTER(), PKFIT, STRNUMBER(), STRN(), WRITEFITS +; +; REVISON HISTORY: +; Adapted from the 1986 version of DAOPHOT in STSDAS +; IDL Version 2 W Landsman November 1988 +; Use DEBUG keyword instead of !DEBUG W. Landsman May 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 ;Return to caller + + common rinter,c1,c2,c3,init ;Save time in RINTER + init = 0 ;Initialize the common blocks + + npar = N_params() + + if npar LT 5 then begin ;Enough parameters passed? + print,'Syntax - GETPSF, image, x, y, mags, sky, ' + print,' [ronois, phpadu, gauss, psf, idpsf, psfrad, fitrad, ' + $ + 'psfname, /DEBUG]' + return + endif + + s = size(image) ;Get number of rows and columns in image + ncol = s[1] & nrow = s[2] + nstar = N_elements(xc) ;Total # of stars identified in image + + if N_elements(idpsf) LT 1 then begin ;Array of PSF id's defined? + idpsf = intarr(25) + i = 0 & id = '' + print,"GETPSF: Enter index of stars to be used for PSF, one index per line" + RD_ID: + print,'Enter a stellar ID ( [RETURN] when finished) ' + read,id + if id EQ '' then begin ;Did User hit the [RETURN] key + if i EQ 0 then return ;No stellar ID's supplied + idpsf = idpsf[0:i-1] + goto, GOT_ID + endif else result = strnumber(id,val) + + if not result then print,string(7b),'INVALID INPUT:' else $ + if (val GE nstar) or (val LT 0) then $ + print,string(7b),'INVALID ID NUMBER' else begin + idpsf[i] = fix(val) + i = i+1 + endelse + goto,RD_ID + endif + +GOT_ID: + + if N_elements(psfrad) NE 1 then read, $ + 'Enter radius (in pixels) of circular area defining the PSF: ',psfrad + if N_elements(fitrad) NE 1 then read, $ + 'Enter radius (in pixels) to be used for Gaussian fitting: ',fitrad + if fitrad GE psfrad then $ + message,'ERROR - Fitting radius must be smaller than radius defining PSF' + + if N_elements(ronois) NE 1 then read, $ + 'Enter readout noise per pixel: ',ronois + if N_elements(phpadu) NE 1 then read, $ + 'Enter photons per analog digital unit: ',phpadu + + numpsf = N_elements(idpsf) ;# of stars used to create the PSF + + smag = size(apmag) ;Is APMAG multidimensional? + if N_elements(apmag) NE smag[1] then mag = apmag[0,*] else mag = apmag[*] + + n = 2*fix(psfrad+0.5)+1 ;(Odd) width of box that contains PSF circle + npsf = 2*n+7 ;Lookup table has half pixel interpolation + nbox = n+7 ;(Even) Width of subarray to be extracted from image + nhalf = nbox/2 + + if keyword_set(DEBUG) then begin + print,'GETPSF: Fitting radius - ',string(float(fitrad),'(F5.1)') + print,' PSF Radius - ',string(float(psfrad),'(F5.1)') + print,' Stellar IDs: ',idpsf & print,' ' + endif + + boxgen = findgen(nbox) + make_2d, boxgen, boxgen, xgen, ygen + +; Find the first PSF star in the star list. + nstrps = -1 ;Counter for number of stars used to create PSF +GETSTAR: + + nstrps = nstrps + 1 + if nstrps GE numpsf then $ + message,'ERROR - No valid PSF stars were supplied' + + istar = idpsf[nstrps] ;ID number of first PSF star + ixcen = fix(xc[istar]) + iycen = fix(yc[istar]) + +; Now a subarray F will be read in from the big image, given by +; IXCEN-NBOX/2+1 <= x <= IXCEN+NBOX/2, IYCEN-NBOX/2+1 <= y <= IYCEN+NBOX/2. +; (NBOX is an even number.) In the subarray, the coordinates of the centroid +; of the star will lie between NBOX/2 and NBOX/2+1 in each coordinate. + + lx = ixcen-nhalf+1 & ux = ixcen + nhalf ;Upper & lower bounds in X + ly = iycen-nhalf+1 & uy = iycen + nhalf + if ((lx LT 0) or (ly LT 0) or $ ;Star too close to edge? + (ux GE ncol) or (uy GE nrow)) then begin + print,'GETPSF: Star ',strn(istar),' too near edge of frame.' + goto, GETSTAR + endif + + f = image[lx:ux,ly:uy] - sky[istar] ;Read in subarray, subtract off sky + +; An integrated Gaussian function will be fit to the central part of the +; stellar profile. Initially, a 5x5 box centered on the centroid of the +; star is used, but if the sigma in one coordinate drops to less than +; 1 pixel, then the box width of 3 will be used in that coordinate. +; If the sigma increases to over 3 pixels, then a box width of 7 will be +; used in that coordinate + + x = xc[istar] - lx ;X coordinate of stellar centroid in subarray F + y = yc[istar] - ly ;Y coordinate of stellar centroid in subarray F + ix = fix(x+0.5) ;Index of pixel containing centroid + iy = fix(y+0.5) +; ;Begin least squares + h = max(f) ;Initial guess for peak intensity + sigx = 2.0 & sigy = 2.0 + dxcen=0. & dycen=0. +; + niter = 0 ;Beginning of big iteration loop + v = fltarr(5) + c = fltarr(5,5) +; Print the current star + fmt1 = "(/17X, 'STAR', 5X, 'X', 8X, 'Y', 5X, 'MAG 1', 5X, 'SKY')" + fmt2 = "(15X, I5, 2F9.2, 12F9.3)" + if keyword_set(DEBUG) then begin + print,format=fmt1 + print,format=fmt2,istar, xc[istar], yc[istar], mag[istar], sky[istar] + endif + + if keyword_set(DEBUG) then print,'GETPSF: Gaussian Fit Iteration' + + REPEAT BEGIN ;Begin the iterative loop + + niter = niter + 1 + if niter GT 100 then begin ;No convergence after 100 iterations? + message,'No convergence after 100 iterations for star ' + strn(istar),/INF + goto, GETSTAR + endif + + if sigx LE 1 then nx = 1 $ ;A default box width + else if sigx GT 3 then nx = 3 $ + else nx = 2 + + if sigy LE 1 then ny = 1 $ + else if sigy GT 3 then ny = 3 $ + else ny = 2 + + a = [H, x+dxcen,y+dycen,sigx,sigy] + xin = (findgen(2*nx+1)-nx) + ix + yin = (findgen(2*ny+1)-ny) + iy + make_2d, xin, yin + DAOERF, xin, yin, a, g, t + +; The T's are the first derivatives of the model profile with respect +; to the five fitting parameters H, DXCEN, DYCEN, SIGX, and SIGY. +; Note that the center of the best-fitting Gaussian profile is +; expressed as an offset from the centroid of the star. In the case of +; a general, asymmetric stellar profile, the center of symmetry of the +; best-fitting Gaussian profile will not necessarily coincide with the +; centroid determined by any arbitrary centroiding algorithm. + + dh = f[ ix-nx:ix+nx, iy-ny:iy+ny] - g ;Subtract best fit Gaussian from subarray + for kk = 0,4 do begin + tk = t[*,kk] + v[kk] = total( dh * tk ) + for ll = 0,4 do c[kk,ll] = total( tk * t[*,ll] ) + endfor + + c = invert(c,status) ;IDL version assumes INVERT is successful + + if status EQ 1 then begin + message,'Singular matrix encountered fitting star ' + strn(istar),/INF + goto, GETSTAR + endif + + z = c#v ;Multiply by vector of residuals + + h = h + z[0]/(1.0+4.0*abs(z[0]/h)) ;Correct the fitting parameters + dxcen = dxcen+z[1]/(1.0+3.0*abs(z[1])) + dycen = dycen+z[2]/(1.0+3.0*abs(z[2])) + sigx = sigx+z[3]/(1.0+4.0*abs(z[3]/sigx)) + sigy = sigy+z[4]/(1.0+4.0*abs(z[4]/sigy)) + + if keyword_set(DEBUG) then print,niter,h,dxcen,dycen,sigx,sigy + + endrep until $ ;Test for convergence + (abs(z[0]/h)+abs(z[3]/sigx)+abs(z[4]/sigy) LT 0.0001) + +; Now that the solution has converged, we can generate an +; array containing the differences between the actual stellar profile +; and the best-fitting Gaussian analytic profile. + + a = [H, x+dxcen, y+dycen, sigx,sigy] ;Parameters for Gaussian fit + DAOERF,xgen,ygen,a,g ;Compute Gaussian + f = f - g ;Residuals (Real profile - Gaussian) + + psfmag = mag[istar] + xpsf1 = xc[istar] & ypsf1 = yc[istar] + +; The look-up table is obtained by interpolation within the array of +; fitting residuals. We need to interpolate because we want the look-up +; table to be centered accurately on the centroid of the star, which of +; course is at some fractional-pixel position in the original data. + + ncen = (npsf-1)/2. + psfgen = (findgen(npsf) - ncen)/2. ;Index function for PSF array + YY = psfgen + Y & XX = psfgen + X + make_2d,xx,yy + psf = RINTER(F, XX, YY) ;Interpolate residuals onto current star + gauss = [h,dxcen,dycen,sigx,sigy] + goodstar = nstrps ;Index of first good star + +; For each additional star, determine the precise coordinates of the +; centroid and the relative brightness of the star +; by least-squares fitting to the current version of the point-spread +; function. Then subtract off the appropriately scaled integral under +; the analytic Gaussian function and add the departures of the actual +; data from the analytic Gaussian function to the look-up table. + +GETMORE: ;Loop for additional PSF stars begins here + nstrps = nstrps+1 + if nstrps GE numpsf then goto,WRITEOUT ;Have all the stars been done? + + istar = idpsf[nstrps] + ixcen = fix(xc[istar]) + iycen = fix(yc[istar]) + scale = 10.^(-0.4*(mag[istar]-psfmag)) + +; Fit the current version of the point-spread function to the data for +; this star. + + lx = ixcen-nhalf+1 & ux =ixcen + nhalf + ly = iycen-nhalf+1 & uy =iycen + nhalf + if ( (lx LT 0) or (ly LT 0) or $ ;Star too close to edge? + (ux GE ncol) or (uy GE nrow)) then begin + print,'GETPSF: Star ',strn(istar),' too near edge of frame.' + goto,GETMORE + endif + + if keyword_set(DEBUG) then begin + print,format=fmt1 + print,format=fmt2, istar, xc[istar], yc[istar], mag[istar], sky[istar] + endif + + f = image[lx:ux,ly:uy] + x = xc[istar]-lx & y = yc[istar]-ly + + pkfit, f, scale, x, y, sky[istar], fitrad, ronois, phpadu, $ + gauss, psf, errmag, chi, sharp, niter, DEBUG = debug + + if niter EQ 25 then begin ;Convergence in less than 25 iterations? + print,'GETPSF: No convergence after 25 iterations for star',istar + goto, GETMORE + endif + + a = [gauss[0], x+dxcen,y+dycen,sigx,sigy] ;Parameters of successful fit + daoerf,xgen,ygen,a,e + f = f - scale*e -sky[istar] ;Compute array of residuals + +; Values of the array of residuals are now interpolated to an NPSF by +; NPSF (NPSF is an odd number) array centered on the centroid of the +; star, and added to the existing look-up table of corrections to the +; analytic profile + + xx = psfgen + x + yy = psfgen + y + make_2d,xx,yy + psf = psf + RINTER(f,xx,yy) + +; Now correct both the height of the analytic Gaussian, and the value +; of the aperture-magnitude of the point-spread function for the +; inclusion of the additional star. + + psfmag = -2.5*alog10((1.+scale)*10^(-0.4*psfmag)) + gauss[0] = gauss[0]*(1.+scale) + goodstar = [ goodstar, nstrps] + goto, GETMORE + +WRITEOUT: + +; Create FITS file containing the PSF created. + + if ( N_elements(psfname) EQ 0 ) then begin + psfname='' + read,'Enter name of FITS file to contain final PSF ([RETURN] to exit): ',psfname + endif + +if ( psfname EQ '' ) then return + + mkhdr, hdr, psf ;Create a minimal FITS header + sxaddpar, hdr, 'PHPADU', phpadu, 'Photons per Analog Digital Unit' + sxaddpar, hdr, 'RONOIS', ronois, 'Readout Noise' + sxaddpar, hdr, 'PSFRAD', psfrad, 'Radius where PSF is defined (pixels)' + sxaddpar, hdr, 'FITRAD', fitrad, 'Fitting Radius' + sxaddpar, hdr, 'PSFMAG', psfmag, 'PSF Magnitude' + sxaddpar, hdr, 'GAUSS1', gauss[0], 'Gaussian Scale Factor' + sxaddpar, hdr, 'GAUSS2', gauss[1], 'Gaussian X Position' + sxaddpar, hdr, 'GAUSS3', gauss[2], 'Gaussian Y Position' + sxaddpar, hdr, 'GAUSS4', gauss[3], 'Gaussian Sigma: X Direction' + sxaddpar, hdr, 'GAUSS5', gauss[4], 'Gaussian Sigma: Y Direction' + + ngood = N_elements(goodstar) + sxaddhist,'GETPSF: '+ systime() + ' ' + strn(ngood) + $ + ' Stars Used to Create PSF',hdr + + sxaddhist,'GETPSF: ID - '+ string(idpsf[goodstar[0:12 n wrd will be a string of words from word n to +; word m. If no m is given wrd will be a single word. +; n<0 returns text starting at word abs(n) to string end +; If n is out of range then a null string is returned. +; See also nwrds. +; MODIFICATION HISTORY: +; Ray Sterner, 6 Jan, 1985. +; R. Sterner, Fall 1989 --- converted to SUN. +; R. Sterner, Jan 1990 --- added delimiter. +; R. Sterner, 18 Mar, 1990 --- added /LAST. +; R. Sterner, 31 Jan, 1991 --- added /NOTRIM. +; R. Sterner, 20 May, 1991 --- Added common and NULL string. +; R. Sterner, 13 Dec, 1992 --- Made tabs equivalent to spaces. +; R. Sterner, 4 Jan, 1993 --- Added NWORDS keyword. +; R. Sterner, 2001 Jan 15 --- Fixed to use first element if not a scalar. +; Johns Hopkins University Applied Physics Laboratory. +; +; Copyright (C) 1985, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;- +;------------------------------------------------------------- + + + FUNCTION GETWRD, TXTSTR, NTH, MTH, help=hlp, location=ll,$ + delimiter=delim, notrim=notrim, last=last, nwords=nwords + + common getwrd_com, txtstr0, nwds, loc, len + + if (n_params(0) lt 1) or keyword_set(hlp) then begin + print," Return the n'th word from a text string." + print,' wrd = getwrd(txt, n, [m])' + print,' txt = text string to extract from. in' + print,' The first element is used if txt is an array.' + print,' n = word number to get (first = 0 = def). in' + print,' m = optional last word number to get. in' + print,' wrd = returned word or words. out' + print,' Keywords:' + print,' LOCATION = l. Return word n string location.' + print,' DELIMITER = d. Set word delimiter (def = space & tab).' + print,' /LAST means n is offset from last word. So n=0 gives' + print,' last word, n=-1 gives next to last, ...' + print,' If n=-2 and m=0 then last 3 words are returned.' + print,' /NOTRIM suppresses whitespace trimming on ends.' + print,' NWORDS=n. Returns number of words in string.' + print,'Note: If a NULL string is given (txt="") then the last string' + print,' given is used. This saves finding the words again.' + print,' If m > n wrd will be a string of words from word n to' + print,' word m. If no m is given wrd will be a single word.' + print,' n<0 returns text starting at word abs(n) to string end' + print,' If n is out of range then a null string is returned.' + print,' See also nwrds.' + return, -1 + endif + + if n_params(0) lt 2 then nth = 0 ; Def is first word. + IF N_PARAMS(0) LT 3 THEN MTH = NTH ; Def is one word. + + if strlen(txtstr[0]) gt 0 then begin + ddel = ' ' ; Def del is a space. + if n_elements(delim) ne 0 then ddel = delim ; Use given delimiter. + TST = (byte(ddel))(0) ; Del to byte value. + tb = byte(txtstr[0]) ; String to bytes. + if ddel eq ' ' then begin ; Check for tabs? + w = where(tb eq 9B, cnt) ; Yes. + if cnt gt 0 then tb[w] = 32B ; Convert any to space. + endif + X = tb NE TST ; Non-delchar (=words). + X = [0,X,0] ; 0s at ends. + + Y = (X-SHIFT(X,1)) EQ 1 ; Diff=1: word start. + Z = WHERE(SHIFT(Y,-1) EQ 1) ; Word start locations. + Y2 = (X-SHIFT(X,-1)) EQ 1 ; Diff=1: word end. + Z2 = WHERE(SHIFT(Y2,1) EQ 1) ; Word end locations. + + txtstr0 = txtstr[0] ; Move string to common. + NWDS = long(TOTAL(Y)) ; Number of words. + LOC = Z ; Word start locations. + LEN = Z2 - Z - 1 ; Word lengths. + endif else begin + if n_elements(nwds) eq 0 then begin ; Check if first call. + print,' Error in getwrd: must give a '+$ + 'non-NULL string on the first call.' + return, -1 ; -1 = error flag. + endif + endelse + + nwords = nwds ; Set nwords + + if keyword_set(last) then begin ; Offset from last. + lst = nwds - 1 + in = lst + nth ; Nth word. + im = lst + mth ; Mth word. + if (in lt 0) and (im lt 0) then return, '' ; Out of range. + in = in > 0 ; Smaller of in and im + im = im > 0 ; to zero. + if (in gt lst) and (im gt lst) then return,'' ; Out of range. + in = in < lst ; Larger of in and im + im = im < lst ; to be last. + ll = loc[in] ; Nth word start. + return, strtrim(strmid(txtstr0,ll,loc[im]-loc[in]+len[im]), 2) + endif + + N = ABS(NTH) ; Allow nth<0. + IF N GT NWDS-1 THEN RETURN,'' ; out of range, null. + ll = loc[n] ; N'th word position. + IF NTH LT 0 THEN GOTO, NEG ; Handle nth<0. + IF MTH GT NWDS-1 THEN MTH = NWDS-1 ; Words to end. + + if keyword_set(notrim) then begin + RETURN, STRMID(TXTSTR0,ll,LOC[MTH]-LOC[NTH]+LEN[MTH]) + endif else begin + RETURN, strtrim(STRMID(TXTSTR0,ll,LOC[MTH]-LOC[NTH]+LEN[MTH]), 2) + endelse + +NEG: if keyword_set(notrim) then begin + RETURN, STRMID(TXTSTR0,ll,9999) + endif else begin + RETURN, strtrim(STRMID(TXTSTR0,ll,9999), 2) + endelse + + END diff --git a/modules/idl_downloads/astro/pro/glactc.pro b/modules/idl_downloads/astro/pro/glactc.pro new file mode 100644 index 0000000..edac6da --- /dev/null +++ b/modules/idl_downloads/astro/pro/glactc.pro @@ -0,0 +1,140 @@ +pro glactc,ra,dec,year,gl,gb,j, degree=degree, fk4 = fk4, $ + SuperGalactic = superGalactic +;+ +; NAME: +; GLACTC +; PURPOSE: +; Convert between celestial and Galactic (or Supergalactic) coordinates. +; EXPLANATION: +; Program to convert right ascension (ra) and declination (dec) to +; Galactic longitude (gl) and latitude (gb) (j=1) or vice versa (j=2). +; +; CALLING SEQUENCE: +; GLACTC, ra, dec, year, gl, gb, j, [ /DEGREE, /FK4, /SuperGalactic ] +; +; INPUT PARAMETERS: +; year equinox of ra and dec, scalar (input) +; j direction of conversion (input) +; 1: ra,dec --> gl,gb +; 2: gl,gb --> ra,dec +; +; INPUTS OR OUTPUT PARAMETERS: ( depending on argument J ) +; ra Right ascension, hours (or degrees if /DEGREES is set), +; scalar or vector +; dec Declination, degrees,scalar or vector +; gl Galactic longitude, degrees, scalar or vector +; gb Galactic latitude, degrees, scalar or vector +; +; All results forced double precision floating. +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; /DEGREE - If set, then the RA parameter (both input and output) is +; given in degrees rather than hours. +; /FK4 - If set, then the celestial (RA, Dec) coordinates are assumed +; to be input/output in the FK4 system. By default, coordinates +; are assumed to be in the FK5 system. For B1950 coordinates, +; set the /FK4 keyword *and* set the year to 1950. +; /SuperGalactic - If set, the GLACTC returns SuperGalactic coordinates +; as defined by deVaucouleurs et al. (1976) to account for the +; local supercluster. The North pole in SuperGalactic coordinates +; has Galactic coordinates l = 47.47, b = 6.32, and the origin is +; at Galactic coordinates l = 137.37, b= 0 +; +; EXAMPLES: +; Find the Galactic coordinates of Altair (RA (J2000): 19 50 47 +; Dec (J2000): 08 52 06) +; +; IDL> glactc, ten(19,50,47),ten(8,52,6),2000,gl,gb,1 +; ==> gl = 47.74, gb = -8.91 +; +; PROCEDURE CALLS: +; BPRECESS, JPRECESS, PRECESS +; HISTORY: +; FORTRAN subroutine by T. A. Nagy, 21-MAR-78. +; Conversion to IDL, R. S. Hill, STX, 19-OCT-87. +; Modified to handle vector input, E. P. Smith, GSFC, 14-OCT-94 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added DEGREE keyword, C. Markwardt, Nov 1999 +; Major rewrite, default now FK5 coordinates, added /FK4 keyword +; use external precession routines W. Landsman April 2002 +; Add /Supergalactic keyword W. Landsman September 2002 +; Fix major bug when year not 2000 and /FK4 not set W. Landsman July 2003 +;- + On_error,2 + compile_opt idl2 + +if N_params() lt 6 then begin + print,'Syntax - glactc, ra, dec, year, gl, gb, j, [/DEGREE, /FK4]' + print,'j = 1: ra,dec --> gl,gb j = 2: gl,gb -->ra,dec' + return +endif +radeg = 180.0d/!DPI +; +; Galactic pole at ra 12 hrs 49 mins, dec 27.4 deg, equinox B1950.0 +; position angle from Galactic center to equatorial pole = 123 degs. + + if keyword_set(SuperGalactic) then begin + rapol = 283.18940711d/15.0d & decpol = 15.64407736d + dlon = 26.73153707 + endif else begin + rapol = 12.0d0 + 49.0d0/60.0d0 + decpol = 27.4d0 + dlon = 123.0d0 + endelse + sdp = sin(decpol/radeg) + cdp = sqrt(1.0d0-sdp*sdp) + radhrs=radeg/15.0d0 + + ; +; Branch to required type of conversion. Convert coordinates to B1950 as +; necessary +case j of + 1: begin + if ~keyword_set(degree) then ras = ra*15.0d else ras =ra + decs = dec + if ~keyword_set(fk4) then begin + if year NE 2000 then precess,ras,decs,year,2000 + bprecess,ras,decs,ra2,dec2 + ras = ra2 + decs = dec2 + endif else if year NE 1950 then precess,ras,decs,year,1950,/fk4 + ras = ras/radeg - rapol/radhrs + sdec = sin(decs/radeg) + cdec = sqrt(1.0d0-sdec*sdec) + sgb = sdec*sdp + cdec*cdp*cos(ras) + gb = radeg * asin(sgb) + cgb = sqrt(1.0d0-sgb*sgb) + sine = cdec * sin(ras) / cgb + cose = (sdec-sdp*sgb) / (cdp*cgb) + gl = dlon - radeg*atan(sine,cose) + ltzero=where(gl lt 0.0, Nltzero) + if Nltzero ge 1 then gl[ltzero]=gl[ltzero]+360.0d0 + return + end + 2: begin + sgb = sin(gb/radeg) + cgb = sqrt(1.0d0-sgb*sgb) + sdec = sgb*sdp + cgb*cdp*cos((dlon-gl)/radeg) + dec = radeg * asin(sdec) + cdec = sqrt(1.0d0-sdec*sdec) + sinf = cgb * sin((dlon-gl)/radeg) / cdec + cosf = (sgb-sdp*sdec) / (cdp*cdec) + ra = rapol + radhrs*atan(sinf,cosf) + ra = ra*15.0d + if ~keyword_set(fk4) then begin + ras = ra & decs = dec + jprecess,ras,decs,ra,dec + if year NE 2000 then precess,ra,dec,2000,year + endif else if year NE 1950 then begin + precess,ra,dec,1950,year,/fk4 + endif + + gt36 = where(ra gt 360.0, Ngt36) + if Ngt36 ge 1 then ra[gt36] = ra[gt36] - 360.0d0 + if ~keyword_set(degree) then ra = ra / 15.0D0 + + + return + end +endcase +end diff --git a/modules/idl_downloads/astro/pro/glactc_pm.pro b/modules/idl_downloads/astro/pro/glactc_pm.pro new file mode 100644 index 0000000..75c0206 --- /dev/null +++ b/modules/idl_downloads/astro/pro/glactc_pm.pro @@ -0,0 +1,193 @@ +pro glactc_pm,ra,dec,mu_ra,mu_dec,year,gl,gb,mu_gl,mu_gb,j, $ + degree=degree, fk4 = fk4, SuperGalactic = superGalactic, mustar=mustar +;+ +; NAME: +; GLACTC_PM +; PURPOSE: +; Convert between celestial and Galactic (or Supergalactic) proper +; motion (also converts coordinates). +; EXPLANATION: +; Program to convert proper motion in equatorial coordinates (ra,dec) +; to proper motion in Galactic coordinates (gl, gb) or Supergalacic +; Coordinates (sgl,sgb) or back to equatorial coordinates (j=2). +; The proper motion unit is arbitrary, but be sure to set /MUSTAR if +; units are the projection of the proper motion on the RA, Dec axis. +; It does precession on the coordinates but does not +; take care of precession of the proper motions which is usually a +; very small effect. +; +; CALLING SEQUENCE: +; GLACTC_PM, ra, dec, mu_ra,mu_dec,year, gl, gb, mu_gl, mu_gb, j, +; [ /DEGREE, /FK4, /SuperGalactic, /mustar ] +; +; INPUT PARAMETERS: +; year equinox of ra and dec, scalar (input) +; j direction of conversion (input) +; 1: ra,dec,mu_ra,mu_dec --> gl,gb,mu_gl,mu_gb +; 2: gl,gb,mu_gl,mu_gb --> ra,dec,mu_ra,mu_dec +; +; INPUTS OR OUTPUT PARAMETERS: ( depending on argument J ) +; ra Right ascension, hours (or degrees if /DEGREES is set), +; scalar or vector. +; dec Declination, degrees,scalar or vector +; mu_ra right ascension proper motion any proper motion unit +; (angle/time) +; mu_dec declination proper motion in any proper motion unit +; (angle/time) +; gl Galactic longitude, degrees, scalar or vector +; gb Galactic latitude, degrees, scalar or vector +; mu_gl galactic longitude proper motion in any time unit +; mu_gb galactic latitude proper motion in any time unit +; All results forced double precision floating. +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; /DEGREE - If set, then the RA parameter (both input and output) is +; given in degrees rather than hours. +; /FK4 - If set, then the celestial (RA, Dec) coordinates are assumed +; to be input/output in the FK4 system. By default, coordinates +; are assumed to be in the FK5 system. For B1950 coordinates, +; set the /FK4 keyword *and* set the year to 1950. +; /SuperGalactic - If set, the GLACTC returns SuperGalactic coordinates +; as defined by deVaucouleurs et al. (1976) to account for the +; local supercluster. The North pole in SuperGalactic coordinates +; has Galactic coordinates l = 47.47, b = 6.32, and the origin is +; at Galactic coordinates l = 137.37, b= 0 +; /mustar - if set then input and output of mu_ra and mu_dec are the +; projections of mu in the ra or dec direction rather than +; the d(ra)/dt or d(mu)/dt. So mu_ra becomes mu_ra*cos(dec) +; and mu_gl becomes mu_gl*cos(gb). +; +; EXAMPLES: +; Find the SuperGalactic proper motion of M33 given its +; equatorial proper motion mu* =(-29.3, 45.2) microas/yr. +; Where the (*) indicates ra component is actual mu_ra*cos(dec) +; (Position: RA (J2000): 01 33 50.9, Dec (J2000): 30 39 36.8) +; +; IDL> glactc_pm, ten(1,33,50.9),ten(30,39,36.8),-29.3,45.2, 2000,$ +; sgl,sgb,mu_sgl,mu_sgb,1,/Supergalactic,/mustar +; ==> SGL = 328.46732 deg, SGB = -0.089896901 deg, +; mu_sgl = 33.732 muas/yr, mu_gb = 41.996 muas/yr. +; And for the roundtrip: +; IDL> glactc_pm, ra,dec,mu_ra,mu_dec,2000,$ +; IDL> sgl,sgb,mu_sgl,mu_sgb,2,/Supergalactic,/mustar +; ==> ra=1.5641376 hrs., dec= 30.660277 deg, +; mu_ra= -29.300000 muas/yr, mu_dec=i 45.200000 muas/yr +; +; PROCEDURE CALLS: +; BPRECESS, JPRECESS, PRECESS +; HISTORY: +; Written Ed Shaya, U of MD, Oct 2009. +; Adapted from GLACTC to make proper motion transformations, +; Correct occasional sign error in galactic longitude E. Shaya Nov 2011 +; Correct occasional sign error for year not set to 1950 W. Landsman,F. Mazzi July 2015 +;- +IF n_PARAMS() LT 6 THEN BEGIN + PRINT,'Syntax - glactc_pm,ra,dec,mu_ra,mu_dec,year,gl,gb,mu_gl,mu_gb, j, [/DEGREE, /FK4, /mustar]' + PRINT,'j = 1: ra,dec,mu_ra,mu_dec --> gl,gb,mu_gl,mu_gb' + PRINT, 'j = 2: gl,gb,mu_gl,mu_gb --> ra,dec,mu_ra,mu_dec' + RETURN +ENDIF +Radeg = 180.0d/!DPI +; +; Galactic pole at ra 12 hrs 49 mins, dec 27.4 deg, equinox B1950.0 +; position angle from Galactic center to equatorial pole = 123 degs. + +IF KEYWORD_SET(SuperGalactic) THEN BEGIN + rapol = 283.18940711d/15.0d & decpol = 15.64407736d + dlon = 26.73153707 +ENDIF ELSE BEGIN + rapol = 12.0d0 + 49.0d0/60.0d0 + decpol = 27.4d0 + dlon = 123.0d0 +ENDELSE +sdp = SIN(decpol/radeg) +cdp = SQRT(1.0d0-sdp*sdp) +radhrs=radeg/15.0d0 + +; Branch to required type of conversion. Convert coordinates to B1950 as +; necessary +CASE j OF + 1: BEGIN + IF ~KEYWORD_SET(degree) THEN ras = ra*15.0d ELSE ras =ra + decs = dec + IF ~KEYWORD_SET(fk4) THEN BEGIN + IF year NE 2000 THEN precess,ras,decs,year,2000 + bprecess,ras,decs,ra2,dec2 + ras = ra2 + decs = dec2 + ENDIF ELSE IF year NE 1950 THEN precess,ras,decs,year,1950,/fk4 + raIndeg = ras + ras = ras/radeg - rapol/radhrs + sdec = SIN(decs/radeg) + cdec = SQRT(1.0d0-sdec*sdec) + sgb = sdec*sdp + cdec*cdp*COS(ras) + gb = radeg * ASIN(sgb) + cgb = SQRT(1.0d0-sgb*sgb) + sine = cdec * SIN(ras) / cgb + cose = (sdec-sdp*sgb) / (cdp*cgb) + gl = dlon - radeg*ATAN(sine,cose) + ltzero=WHERE(gl lt 0.0, Nltzero) + IF Nltzero GE 1 THEN gl[ltzero]=gl[ltzero]+360.0d0 + +; Calculate proper motions transforms for j = 1 +; Take derivative of sgb line above: + IF ~KEYWORD_SET(mustar) THEN mu_ra = mu_ra*cdec + mu_gb = mu_dec*(cdec*sdp-sdec*cdp*COS(ras))/cgb $ + - mu_ra*cdp*SIN(ras)/cgb +; Get mu_gl by using the known length of the vector. + mu_gl = SQRT(mu_dec^2 + mu_ra^2 - mu_gb^2) + IF ~KEYWORD_SET(mustar) THEN mu_gl = mu_gl/cgb + +; However, sqrt gives an ambiguous sign. +; Determine the sign by seeing which direction it is going in gl. + glactc,raIndeg,decs,year,gl0,gb0,1,/degree,Supergalactic=Supergalactic + ra_delta = 1d-2*mu_ra/ABS(mu_ra) + dec_delta = 1d-2*mu_dec/ABS(mu_ra) + glactc, raIndeg+ra_delta, decs+dec_delta, year, gl2, gb2, 1,$ + /degree,Supergalactic=Supergalactic + IF (gl2 LT gl0) THEN mu_gl = -ABS(mu_gl) + + + RETURN + END + 2: BEGIN + sgb = SIN(gb/radeg) + cgb = SQRT(1.0d0-sgb*sgb) + sdec = sgb*sdp + cgb*cdp*COS((dlon-gl)/radeg) + dec = radeg * ASIN(sdec) + cdec = SQRT(1.0d0-sdec*sdec) + sinf = cgb * SIN((dlon-gl)/radeg) / cdec + cosf = (sgb-sdp*sdec) / (cdp*cdec) + ra = rapol + radhrs*ATAN(sinf,cosf) + ra = ra*15.0d + +; Calculate proper motions for j=2, see above (j=1 case) + IF ~KEYWORD_SET(mustar) THEN mu_gl = mu_gl*cgb + mu_dec = mu_gb*(cgb*sdp-sgb*cdp*COS((dlon-gl)/radeg))/cdec $ + + mu_gl*cdp*SIN((dlon-gl)/radeg)/cdec + mu_ra = SQRT(mu_gl^2 + mu_gb^2 - mu_dec^2) + IF ~KEYWORD_SET(mustar) THEN mu_ra = mu_ra/cdec + +; However, sqrt gives an ambiguous sign. +; Determine the sign by seeing which direction it is going in gl. + glactc,raIndeg,decs0,year,gl,gb,2,/degree,Supergalactic=Supergalactic + mu_gl_delta = 1d-2*mu_gl/ABS(mu_gl) + mu_gb_delta = 1d-2*mu_gb/ABS(mu_gl) + glactc, ra2, dec2, year, gl+mu_gl_delta, gb+mu_gb_delta, 2,$ + /degree,Supergalactic=Supergalactic + IF (ra2 LT raIndeg) THEN mu_ra = -ABS(mu_ra) + + IF ~KEYWORD_SET(fk4) THEN BEGIN + ras = ra & decs = dec + jprecess,ras,decs,ra,dec + IF year NE 2000 THEN precess,ra,dec,2000,year + ENDIF ELSE BEGIN + IF year NE 1950 THEN precess,ra,dec,1950,year,/fk4 + ENDELSE + gt36 = WHERE(ra GT 360.0, Ngt36) + IF Ngt36 GE 1 THEN ra[gt36] = ra[gt36] - 360.0d0 + IF ~KEYWORD_SET(degree) THEN ra = ra/15.0D0 + RETURN + END +ENDCASE +END diff --git a/modules/idl_downloads/astro/pro/group.pro b/modules/idl_downloads/astro/pro/group.pro new file mode 100644 index 0000000..2df2d6f --- /dev/null +++ b/modules/idl_downloads/astro/pro/group.pro @@ -0,0 +1,107 @@ +PRO GROUP, X, Y, RCRIT, NGROUP +;+ +; NAME: +; GROUP +; PURPOSE: +; Assign stars with non-overlapping PSF profiles into distinct groups +; EXPLANATION: +; Part of the IDL-DAOPHOT sequence +; +; CALLING SEQUENCE: +; GROUP, X, Y, RCRIT, NGROUP +; +; INPUTS: +; X - vector, giving X coordinates of a set of stars. +; Y - vector, giving Y coordinates of a set of stars. +; If X and Y are input as integers, then they will be converted to +; floating point +; RCRIT - scalar, giving minimum distance between stars of two +; distinct groups. Stars less than this distance from +; each other are always in the same group. Stetson suggests +; setting the critical distance equal to the PSF radius + +; the Fitting radius. +; +; OUTPUTS: +; NGROUP - integer vector, same number of elements as X and Y, +; giving a group number for each star position. Group +; numbering begins with 0. +; +; METHOD: +; Each position is initially given a unique group number. The distance +; of each star is computed against every other star. Those distances +; less than RCRIT are assigned the minimum group number of the set. A +; check is then made to see if any groups have merged together. +; +; PROCEDURES USED: +; REM_DUP() +; +; REVISION HISTORY: +; Written W. Landsman STX April, 1988 +; Major revision to properly merge groups together W. Landsman Sep 1991 +; Work for more than 32767 points W. Landsman March 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Avoid overflow if X and Y are integers W. Landsman Feb. 1999 +;- + On_error,2 ;Return to caller + + if N_params() LT 4 then begin + print,'Syntax - group, x, y, rcrit, ngroup' + print,' x,y - Input position vectors' + print,' rcrit - Minimum radius between stars of different groups' + print,' ngroup - Output vector of group indices' + return + endif + + rcrit2 = rcrit^2 ;Don't bother taking square roots + npts = min( [N_elements(x), N_elements(y)] ) ;Number of stars + + if npts LT 2 then message, $ + 'ERROR - Input position X,Y vectors must contain at least 2 points' + + x = 1.0*x & y = 1.0*y ;Make sure at least floating point + ngroup = lindgen(npts) ;Initially each star in a separate group + +; Whenever the positions between two stars are less than the critical +; distance, assign both stars the minimum group id. The tricky part +; is to recognize when distinct groups have merged together. + + for i = 0l,npts-2 do begin + dis2 = (x[i] - x[i+1:*])^2 + (y[i] - y[i+1:*])^2 + good = where( dis2 LE rcrit2, ngood) + if ngood GT 0 then begin ;Any stars within critical radius? + + good = [i,good+i+1] + groupval = ngroup[good] + mingroup = min( groupval ) + if ( mingroup LT i ) then begin ;Any groups merge? + groupval = groupval[ where( groupval LT i, nval) ] + if nval GT 1 then $ + groupval = groupval[ rem_dup(groupval) ] + nval = N_elements(groupval) + + if nval GE 2 then for j= 1, nval-1 do begin + redo = where ( ngroup EQ groupval[j], ndo ) + if ndo GT 0 then ngroup[redo] = mingroup + endfor + + endif + ngroup[good] = mingroup + endif +endfor +; +; Star are now placed in distinct groups, but they are not ordered +; consecutively. Remove gaps in group ordering +; + if max(ngroup) EQ 0 then return ;All stars in one group ? + + ghist = histogram(ngroup,min=0) + gmax = max(ghist) + val = where(ghist GE 1, ngood) + if ( ngood GT 0 ) then $ + for i = 0, ngood-1 do ngroup[ where( ngroup EQ val[i] ) ] = i + + message,'Number of Groups: '+ strtrim(ngood,2), /INF + message,'Largest group size '+ strtrim(gmax,2) + ' stars',/INF + + return + end diff --git a/modules/idl_downloads/astro/pro/gsss_stdast.pro b/modules/idl_downloads/astro/pro/gsss_stdast.pro new file mode 100644 index 0000000..12793f1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gsss_stdast.pro @@ -0,0 +1,105 @@ +pro GSSS_StdAst,h,xpts,ypts +;+ +; NAME: +; GSSS_STDAST +; +; PURPOSE: +; Insert the closest tangent projection astrometry into an GSSS Image +; +; DESCRIPTION: +; This procedure takes a header with GSSS (ST Guide Star Survey) +; astrometry and writes a roughly equivalent tangent projection +; astrometry into the header. One might want to do this if (1) +; one needs to use software which does not recognize the GSSS astrometric +; parameters or (2) if the the image to be transformed, since the +; highly nonlinear GSSS solution does not transform easily. +; +; CALLING SEQUENCE: +; GSSS_STDAST, H, [Xpts, Ypts] +; +; INPUT - OUTPUT: +; H - FITS header (string array) containing GSSS astrometry. +; GSSS_STDAST will write the roughly equivalent tangent projection +; astrometry solution into H. +; OPTIONAL INPUTS: +; xpts, ypts -- Vectors giving the X and Y positions of the three +; reference points used to find approximate tangent projection. +; Default is Xpts = [0.2,0.8,0.5], Ypts = [0.2, 0.4, 0.8] +; METHOD: +; The procedures GSSSXYAD is used to exactly determine the RA and Dec +; at 3 reference points. STARAST is then used to find the tangent +; projection astrometry that best matches these reference points. +; +; NOTES: +; Images from the STScI server (http://archive.stsci.edu/dss/) contain +; both a GSSS polynomial plate solution and an approximate WCS tangent +; projection. The value of the WCSNAME keyword in the FITS header +; is 'DSS'. If WCSNAME = "DSS' then the more accurate DSS astrometry +; is extracted by EXTAST This procedure changes the value of WCSNAME +; to 'DSS_TANGENT' to indicate that the tangent solution should be used. +; +; Some early GSSS images (before the 1994 CD-Rom) used keywords CRPIXx +; rather than CNPIXx. The GSSS astrometry in these images could be +; corrupted by this procedure as the CRPIXx values will be altered. +; +; The tangent is only a approximation of the nonlinear GSSS astrometry, +; but is generally accurate to about 0.1 pixels on a 1024 x 1024 image. +; +; PROCEDURES USED: +; GSSSEXTAST, GSSSXYAD, STARAST, PUTAST, SXADDHIST, SXDELPAR +; +; HISTORY: +; 13-AUG-91 Version 2 written from MAKEASTGSSS Eric Deutsch (STScI) +; Delete CDELT* keywords from header W. Landsman May 1994 +; Remove call to BUILDAST W. Landsman Jan, 1995 +; Added optional Xpts, Ypts parameters E. Deutsch Oct, 1995 +; Add WCSNAME W. Landsman Nov 2006 +;- + On_error,2 + compile_opt idl2 + + arg = N_params() + + if (arg lt 1) then begin + print,'Syntax - GSSS_StdAst, header, [xpts, ypts]' + print,'Purpose - Write tangent projection astrometry into a GSSS header' + return + endif + +; options for supplying of this info by Deutsch 10/5/95 + if (n_elements(xpts) eq 0) or (n_elements(ypts) eq 0) then begin + NAXIS1 = sxpar(h,'NAXIS1') & NAXIS2 = sxpar(h,'NAXIS2') + X = [.2,.8,.5]*NAXIS1 & Y=[.2,.4,.8]*NAXIS2 + endif else begin + x=xpts & y=ypts + endelse + + GSSSExtAst,h,gsa + GSSSXYAD,gsa,X,Y,ra,dec + + starast, RA, DEC, X, Y, cd + crval=[RA[0],DEC[0]] & crpix=[X[0],Y[0]]+1 + + sxaddpar, h, 'WCSNAME', 'DSS_TANGENT', $ + 'WCS Tangent Approximation to full plate solution' + sxaddpar, h, 'CTYPE1','RA---TAN' + sxaddpar, h, 'CTYPE2','DEC--TAN' + sxaddpar, h, 'CD1_1', cd[0,0] + sxaddpar, h, 'CD1_2', cd[0,1] + sxaddpar, h, 'CD2_1', cd[1,0] + sxaddpar, h, 'CD2_2', cd[1,1] + sxaddpar, h, 'CRPIX1', crpix[0] + sxaddpar, h, 'CRPIX2', crpix[1] + sxaddpar, h, 'CRVAL1', crval[0] + sxaddpar, h, 'CRVAL2', crval[1] + + hist = ['GSSS_STDAST: Astrometry calculated from GSSS format and written', $ + 'GSSS_STDAST: in tangent projection format: ' + systime() ] + sxaddhist,hist,h + + sxdelpar, h, 'CDELT1' + sxdelpar, h, 'CDELT2' + + + return + end diff --git a/modules/idl_downloads/astro/pro/gsssadxy.pro b/modules/idl_downloads/astro/pro/gsssadxy.pro new file mode 100644 index 0000000..561c644 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gsssadxy.pro @@ -0,0 +1,174 @@ +pro GSSSadxy,gsa,ra,dec,x,y, PRINT = print +;+ +; NAME: +; GSSSADXY +; PURPOSE: +; Converts RA and DEC (J2000) to (X,Y) for an STScI GuideStar image. +; EXPLANATION: +; The sky coordinates may be printed and/or returned in variables. +; +; CALLING SEQUENCE: +; GSSSADXY, GSA, Ra,Dec, [ X, Y, /Print ] + +; INPUT: +; GSA - the GSSS Astrometry structure created by GSSSEXTAST +; RA - the RA coordinate(s) in *degrees*, scalar or vector +; DEC - the DEC coordinate(s) in *degrees*, scalar or vector +; +; OPTIONAL KEYWORD INPUT: +; /PRINT - If this keyword is set and non-zero, then coordinates will be +; displayed at the terminal +; OUTPUT: +; X - the corresponding X pixel coordinate(s), double precision +; Y - the corresponding Y pixel coordinate(s), double precision +; +; X and Y will be in IDL convention (first pixel 0,0) +; EXAMPLE: +; Given a FITS header, hdr, from the STScI Guidestar Survey, determine +; the X,Y coordinates of 3C 273 (RA = 12 29 6.7 +02 03 08) +; +; IDL> GSSSEXTAST, hdr, gsa ;Extract astrometry structure +; IDL> GSSSADXY, gsa, ten(12,29,6.7)*15,ten(2,3,8),/print +; +; NOTES: +; For most purpose users can simply use ADXY, which will call GSSSADXY +; if it is passed a GSSS header. +; +; PROCEDURES CALLED: +; ASTDISP - Print RA, Dec in standard format +; HISTORY: +; 10-JUL-90 Version 1 written by Eric W. Deutsch +; Derived from procedures written by Brian McLean +; Vectorized code W. Landsman March, 1991 +; 14-AUG-91 Fixed error which caused returned X and Y to be .5 pixels too +; large. Now X,Y follows same protocol as ADXY. +; June 1994 - Dropped PRFLAG parameter, added /PRINT W. Landsman (HSTX) +; Converted to IDL V5.0 W. Landsman September 1997 +; 29-JUN-99 Added support for AMD[X,Y]1[2-3] for DSS images by E. Deutsch +; Reduce memory requirements for large arrays D. Finkbeiner April 2004 +; Remove +;- + On_error,2 + arg = N_params() + if (arg lt 5) then begin + print,'Syntax - GSSSADXY, GSSS_Astrom_struct, ra, dec, x, y, print_flag' + print,'e.g.: IDL> GSSSADXY, gsa, ra, dec, x, y, 1' + return + endif + +; Set Constants + iters = 0 & maxiters=50 & tolerance=0.0000005 + radeg = 180.0d/!DPI & arcsec_per_radian= 3600.0d*radeg + + pltdec = gsa.crval[1]/radeg + + dec_rad = dec/radeg + cosd = cos(dec_rad) + sind = sin(temporary(dec_rad)) + ra_dif = ra/radeg - gsa.crval[0]/radeg + + div = ( sind*sin(pltdec) + cosd*cos(pltdec)*cos(ra_dif)) + xi = cosd*sin(ra_dif)*arcsec_per_radian/div + eta = ( sind*cos(pltdec)-cosd*sin(pltdec)*cos(ra_dif))* $ + (arcsec_per_radian/temporary(div)) + ra_dif = 0 + cosd = 0 & sind = 0 + + obx = xi/gsa.pltscl + oby = eta/gsa.pltscl + + repeat begin + iters++ + + f= gsa.amdx[0]*obx+ $ + gsa.amdx[1]*oby+ $ + gsa.amdx[2]+ $ + gsa.amdx[3]*obx*obx+ $ + gsa.amdx[4]*obx*oby+ $ + gsa.amdx[5]*oby*oby+ $ + gsa.amdx[6]*(obx*obx+oby*oby)+ $ + gsa.amdx[7]*obx*obx*obx+ $ + gsa.amdx[8]*obx*obx*oby+ $ + gsa.amdx[9]*obx*oby*oby+ $ + gsa.amdx[10]*oby*oby*oby+ $ + gsa.amdx[11]*obx*(obx*obx+oby*oby)+ $ + gsa.amdx[12]*obx*(obx*obx+oby*oby)^2 + + fx=gsa.amdx[0]+ $ + gsa.amdx[3]*2.0*obx+ $ + gsa.amdx[4]*oby+ $ + gsa.amdx[6]*2.0*obx+ $ + gsa.amdx[7]*3.0*obx*obx+ $ + gsa.amdx[8]*2.0*obx*oby+ $ + gsa.amdx[9]*oby*oby+ $ + gsa.amdx[11]*(3.0*obx*obx+oby*oby)+ $ + gsa.amdx[12]*(5.0*obx^4 + 6.0*obx^2*oby^2 + oby^4) + + fy=gsa.amdx[1]+ $ + gsa.amdx[4]*obx+ $ + gsa.amdx[5]*2.0*oby+ $ + gsa.amdx[6]*2.0*oby+ $ + gsa.amdx[8]*obx*obx+ $ + gsa.amdx[9]*obx*2.0*oby+ $ + gsa.amdx[10]*3.0*oby*oby+ $ + gsa.amdx[11]*2.0*obx*oby+ $ + gsa.amdx[12]*(4.0*obx^3*oby + 4.0*obx*oby^3) + + + g= gsa.amdy[0]*oby+ $ + gsa.amdy[1]*obx+ $ + gsa.amdy[2]+ $ + gsa.amdy[3]*oby*oby+ $ + gsa.amdy[4]*oby*obx+ $ + gsa.amdy[5]*obx*obx+ $ + gsa.amdy[6]*(obx*obx+oby*oby)+ $ + gsa.amdy[7]*oby*oby*oby+ $ + gsa.amdy[8]*oby*oby*obx+ $ + gsa.amdy[9]*oby*obx*obx+ $ + gsa.amdy[10]*obx*obx*obx+ $ + gsa.amdy[11]*oby*(obx*obx+oby*oby)+ $ + gsa.amdy[12]*oby*(obx*obx+oby*oby)^2 + + gx=gsa.amdy[1]+ $ + gsa.amdy[4]*oby+ $ + gsa.amdy[5]*2.0*obx+ $ + gsa.amdy[6]*2.0*obx+ $ + gsa.amdy[8]*oby*oby+ $ + gsa.amdy[9]*oby*2.0*obx+ $ + gsa.amdy[10]*3.0*obx*obx+ $ + gsa.amdy[11]*2.0*obx*oby+ $ + gsa.amdy[12]*(4.0*obx^3*oby + 4.0*obx*oby^3) + + + + gy=gsa.amdy[0]+ $ + gsa.amdy[3]*2.0*oby+ $ + gsa.amdy[4]*obx+ $ + gsa.amdy[6]*2.0*oby+ $ + gsa.amdy[7]*3.0*oby*oby+ $ + gsa.amdy[8]*2.0*oby*obx+ $ + gsa.amdy[9]*obx*obx+ $ + gsa.amdy[11]*(3.0*oby*oby+obx*obx)+ $ + gsa.amdy[12]*(5.0*oby^4 + 6.0*obx^2*oby^2 + obx^4) + + + + f -= xi + g -= eta + deltx = (-f*gy+g*fy) / (fx*gy-fy*gx) + delty = (-g*fx+f*gx) / (fx*gy-fy*gx) + obx += deltx + oby += delty + + ;print,deltx,delty,tolerance,iters,maxiters + + endrep until (min(abs([deltx,delty])) lt tolerance) || (iters gt maxiters) + + eta = 0 & xi = 0 & deltx = 0 & delty = 0 + x = (gsa.ppo3-obx*1000.0)/gsa.xsz-gsa.xll - 0.5 + y = (gsa.ppo6+oby*1000.0)/gsa.ysz-gsa.yll - 0.5 + + if keyword_set(PRINT) then AstDisp, x, y, ra, dec + + return + end diff --git a/modules/idl_downloads/astro/pro/gsssextast.pro b/modules/idl_downloads/astro/pro/gsssextast.pro new file mode 100644 index 0000000..65340a6 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gsssextast.pro @@ -0,0 +1,99 @@ +pro GSSSExtAst, h, astr, noparams +;+ +; NAME: +; GSSSEXTAST +; +; PURPOSE: +; Extract IDL astrometry structure from a ST Guide Star Survey FITS header +; +; EXPLANATION: +; This procedure extracts the astrometry information from a ST Guide +; Star Survey FITS header and places it in an IDL structure for +; subsequent use with GSSSxyad and GSSSadxy. +; +; CALLING SEQUENCE: +; GSSSExtast, hdr, astr, noparams +; INPUT: +; h - the GSSS FITS header +; OUTPUT: +; astr - Structure containing the GSSS Astrometry information +; .CTYPE = ['RA---GSS','DEC--GSS'] +; .CRVAL = plate center Ra, Dec (from PLTRAH, PLTRAM etc.) +; .XLL,.YLL = offsets lower lefthand corner +; .AMDX, .AMDY = 12 transformation coefficients +; .XSZ,.YSZ = X and Y pixel size in microns +; .PLTSCL = plate scale in arc sec/mm +; .PPO3, .PPO6 - orientation coefficients +; NOTES: +; Most users should use EXTAST rather than this procedure. EXTAST will +; call GSSSEXTAST if supplied with GSSS FITS header. +; +; PROCEDURES CALLED: +; SXPAR() - Extract parameter values from a FITS header +; HISTORY: +; 01-JUL-90 Version 1 written by Eric W. Deutsch +; Code derived from Software by Brian McLean +; 20-AUG-91 Modified to Double Precision Variables. E. Deutsch +; June 94 Change astrometry tags to better agree with EXTAST W. Landsman +; Converted to IDL V5.0 W. Landsman September 1997 +; 29-JUN-99 Added support for AMD[X,Y]1[2-3] for DSS images by E. Deutsch +; Eliminate use of obsolete !ERR W. Landsman February 2000 +;- + + On_error,2 + + if N_params() lt 2 then begin + print,'Syntax - GSSSExtAst, header, GSSS_astrometry_structure, noparams' + return + endif + + noparams = -1 + + astr = {gsss_astrometry, CTYPE: strarr(2), XLL:0, YLL:0, XSZ:0.0D, YSZ:0.0D, $ + PPO3:0.0D, PPO6:0.0D, CRVAL: dblarr(2), PLTSCL:0.0D, $ + AMDX:dblarr(13), AMDY:dblarr(13) } + +;Older GSSS headers used CRPIX1 instead of CRPIXN + + astr.xll = sxpar(h,'CNPIX1', Count = N) + if N EQ 0 then begin + astr.xll = sxpar(h, 'CRPIX1') + astr.yll = sxpar(h, 'CRPIX2') + endif else astr.yll = sxpar(h,'CNPIX2') + + astr.xsz = sxpar(h,'XPIXELSZ') + astr.ysz = sxpar(h,'YPIXELSZ') + astr.ppo3 = sxpar(h,'PPO3') + astr.ppo6 = sxpar(h,'PPO6', Count = N) + + if (N Eq 0) then message,'Header does not contain GSSS astrometry' + + astr.pltscl = sxpar(h,'PLTSCALE') + + pltrah = sxpar( h, 'PLTRAH' ) + pltram = sxpar( h, 'PLTRAM' ) + pltras = sxpar( h, 'PLTRAS' ) + pltdecsn = sxpar( h, 'PLTDECSN' ) + pltdecd = sxpar( h, 'PLTDECD' ) + pltdecm = sxpar( h, 'PLTDECM' ) + pltdecs = sxpar( h, 'PLTDECS' ) + + astr.crval[0] = (pltrah + pltram/60.0d + pltras/3600.0D)*15 + astr.crval[1] = pltdecd + pltdecm/60.0d + pltdecs/3600.0d + + if (strtrim(PLTDECSN,2) EQ '-') then astr.crval[1] = -astr.crval[1] + + ii = strtrim(indgen(13)+1,2) + for i = 0,12 do begin + + astr.amdx[i] = sxpar(h, 'AMDX' + ii[i] ) + astr.amdy[i] = sxpar(h, 'AMDY' + ii[i] ) + + endfor + + astr.ctype = ['RA---GSS','DEC--GSS'] + + noparams = 0 ;Successful Extraction of GSSS astrometry params + + return + end diff --git a/modules/idl_downloads/astro/pro/gsssxyad.pro b/modules/idl_downloads/astro/pro/gsssxyad.pro new file mode 100644 index 0000000..70d7c18 --- /dev/null +++ b/modules/idl_downloads/astro/pro/gsssxyad.pro @@ -0,0 +1,116 @@ +pro GSSSxyad, gsa, xin, yin, ra, dec, PRINT = print +;+ +; NAME: +; GSSSXYAD +; PURPOSE: +; Convert (X,Y) coordinates in a STScI Guide Star image to RA and Dec +; EXPLANATION: +; The sky coordinates may be printed and/or returned in variables. +; +; CALLING SEQUENCE: +; GSSSxyad, gsa, x, y, ra, dec, [ /PRINT ] +; INPUT: +; GSA - The GSSS Astrometry structure extracted from a FITS header +; by GSSSEXTAST +; X - The X pixel coordinate(s) of the image, scalar or vector +; Y - The Y pixel coordinate(s) of the image, scalar or vector +; +; OUTPUT: +; RA - The RA coordinate of the given pixel(s) in *degrees* +; DEC - The DEC coordinate of the given pixel(s) in *degrees* +; +; Both RA and Dec will be returned as double precision +; +; OPTIONAL KEYWORD INPUT: +; /PRINT - If this keyword is set and non-zero, then coordinates will be +; displayed at the terminal +; EXAMPLE: +; Given a FITS header,hdr, from a GSSS image, print the astronomical +; coordinates of (X,Y) = (200.23, 100.16) at the terminal +; +; IDL> GSSSExtast, hdr, gsa ;Extract astrometry structure +; IDL> GSSSxyad, gsa, 200.23, 100.16, /print +; +; NOTES: +; For most purpose users can simply use XYAD, which will call GSSSXYAD +; if it is passed a GSSS header. +; +; PROCEDURES CALLED: +; ASTDISP - print RA, Dec in a standard format +; HISTORY: +; 01-JUL-90 Version 1 written by Eric W. Deutsch +; Vectorized Code W. Landsman March, 1991 +; 14-AUG-91 Fixed error which caused returned RA and DEC to be off by +; -.5 pixels in both X,Y. Now X,Y follows same protocol as ADXY. +; 20-AUG-91 Modified to use AstDisp procedure. +; June 94 Added /PRINT keyword instead of PRFLAG W. Landsman June 94 +; Converted to IDL V5.0 W. Landsman September 1997 +; 29-JUN-99 Added support for AMD[X,Y]1[2-3] for DSS images by E. Deutsch +;- + + arg = N_params() + if (arg lt 3) then begin + print,'Syntax - GSSSXYAD, GSSS_Astrom_struct, x, y, ra, dec, [/PRINT ]' + return + endif + + x = xin + 0.5 & y = yin + 0.5 + obx = ( gsa.ppo3-(gsa.xll+X)*gsa.xsz )/1000.0d0 + oby = ( (gsa.yll+Y)*gsa.ysz-gsa.ppo6 )/1000.0d0 + + xi=gsa.amdx[0]*obx+ $ + gsa.amdx[1]*oby+ $ + gsa.amdx[2]+ $ + gsa.amdx[3]*obx^2+ $ + gsa.amdx[4]*obx*oby+ $ + gsa.amdx[5]*oby^2+ $ + gsa.amdx[6]*(obx^2+oby^2)+ $ + gsa.amdx[7]*obx^3+ $ + gsa.amdx[8]*obx^2*oby+ $ + gsa.amdx[9]*obx*oby^2+ $ + gsa.amdx[10]*oby^3+ $ + gsa.amdx[11]*obx*(obx^2+oby^2)+ $ + gsa.amdx[12]*obx*(obx^2+oby^2)^2 + + eta=gsa.amdy[0]*oby+ $ + gsa.amdy[1]*obx+ $ + gsa.amdy[2]+ $ + gsa.amdy[3]*oby^2+ $ + gsa.amdy[4]*oby*obx+ $ + gsa.amdy[5]*obx^2+ $ + gsa.amdy[6]*(obx^2+oby^2)+ $ + gsa.amdy[7]*oby^3+ $ + gsa.amdy[8]*oby^2*obx+ $ + gsa.amdy[9]*oby*obx^2+ $ + gsa.amdy[10]*obx^3+ $ + gsa.amdy[11]*oby*(obx^2+oby^2)+ $ + gsa.amdy[12]*oby*(obx^2+oby^2)^2 + + twopi = 2.0d*!DPI + radeg = 180.0d/!DPI + arcsec_per_radian = 360.*60.*60./twopi + pltra = gsa.crval[0]/radeg + pltdec = gsa.crval[1]/radeg + + xi = xi/arcsec_per_radian + eta = eta/arcsec_per_radian + + numerator = xi/cos(pltdec) + denominator = 1.0-eta*tan(pltdec) + ra = atan(numerator,denominator)+pltra + + bad = where(ra LT 0,nbad) + if (nbad GT 0) then ra[bad] = ra[bad]+twopi + bad = where(ra GT twopi,nbad) + if (nbad GT 0) then ra[bad] = ra[bad]-twopi + + numerator = cos(ra-pltra) + denominator = (1.0-eta*tan(pltdec))/(eta+tan(pltdec)) + dec = atan(float(numerator/denominator)) + + ra = ra*radeg + dec = dec*radeg + if keyword_set(PRINT) then AstDisp, xin, yin, ra, dec + + return + end diff --git a/modules/idl_downloads/astro/pro/hadec2altaz.pro b/modules/idl_downloads/astro/pro/hadec2altaz.pro new file mode 100644 index 0000000..6876ca2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hadec2altaz.pro @@ -0,0 +1,74 @@ +PRO hadec2altaz, ha, dec, lat, alt, az, WS=WS + +;+ +; NAME: +; HADEC2ALTAZ +; PURPOSE: +; Converts Hour Angle and Declination to Horizon (alt-az) coordinates. +; EXPLANATION: +; Can deal with NCP/SCP singularity. Intended mainly to be used by +; program EQ2HOR +; +; CALLING SEQUENCE: +; HADEC2ALTAZ, ha, dec, lat ,alt ,az [ /WS ] +; +; INPUTS +; ha - the local apparent hour angle, in DEGREES, scalar or vector +; dec - the local apparent declination, in DEGREES, scalar or vector +; lat - the local latitude, in DEGREES, scalar or vector +; +; OUTPUTS +; alt - the local apparent altitude, in DEGREES. +; az - the local apparent azimuth, in DEGREES, all results in double +; precision +; OPTIONAL KEYWORD INPUT: +; /WS - Set this keyword for the output azimuth to be measured West from +; South. The default is to measure azimuth East from North. +; +; EXAMPLE: +; What were the apparent altitude and azimuth of the sun when it transited +; the local meridian at Pine Bluff Observatory (Lat=+43.07833 degrees) on +; April 21, 2002? An object transits the local meridian at 0 hour angle. +; Assume this will happen at roughly 1 PM local time (18:00 UTC). +; +; IDL> jdcnv, 2002, 4, 21, 18., jd ; get rough Julian date to determine +; ;Sun ra, dec. +; IDL> sunpos, jd, ra, dec +; IDL> hadec2altaz, 0., dec, 43.078333, alt, az +; +; ===> Altitude alt = 58.90 +; Azimuth az = 180.0 + +; REVISION HISTORY: +; Written Chris O'Dell Univ. of Wisconsin-Madison May 2002 +;- + +if N_params() LT 4 then begin + print,'Syntax - HADEC2ALTAZ, ha, dec, lat ,alt ,az [ /WS ]' + return +endif + +d2r = !dpi/180. + +sh = sin(ha*d2r) & ch = cos(ha*d2r) +sd = sin(dec*d2r) & cd = cos(dec*d2r) +sl = sin(lat*d2r) & cl = cos(lat*d2r) + +x = - ch * cd * sl + sd * cl +y = - sh * cd +z = ch * cd * cl + sd * sl +r = sqrt(x^2 + y^2) +; now get Alt, Az + +az = atan(y,x) /d2r +alt = atan(z,r) / d2r + +; correct for negative AZ +w = where(az LT 0) +if w[0] ne -1 then az[w] = az[w] + 360. + +; convert AZ to West from South, if desired +if keyword_set(WS) then az = (az + 180.) mod 360. + + +END \ No newline at end of file diff --git a/modules/idl_downloads/astro/pro/hastrom.pro b/modules/idl_downloads/astro/pro/hastrom.pro new file mode 100644 index 0000000..2c7a4ee --- /dev/null +++ b/modules/idl_downloads/astro/pro/hastrom.pro @@ -0,0 +1,302 @@ +pro hastrom,oldim,oldhd,newim,newhd,refhd,MISSING=missing, INTERP = interp, $ + ERRMSG = errmsg,CUBIC = cubic, DEGREE = Degree, NGRID = Ngrid, $ + SILENT = silent +;+ +; NAME: +; HASTROM +; PURPOSE: +; Transformation of an image to align it with a reference image +; EXPLANATION: +; A transformation is applied (using POLY_2D) to an image so that +; its astrometry is identical with that in a reference header. This +; procedure can be used to align two images. +; +; CALLING SEQUENCE: +; HASTROM, oldim, oldhd, newim, newhd, refhd, [MISSING =, INTERP = ] +; or +; HASTROM, oldim, oldhd, refhd, [MISSING =, INTERP ={0,1,2}, NGRID =, +; CUBIC =, DEGREE = ] +; +; INPUTS: +; OLDIM - Image array to be manipulated. If only 3 parameters are +; supplied then OLDIM and OLDHD will be modified to contain +; the output image array and header +; OLDHD - FITS header array for OLDIM, containing astrometry parameters +; REFHD - Reference header, containing astrometry parameters. OLDIM +; will be rotated, shifted, and compressed or expanded until +; its astrometry matches that in REFHD. +; OUTPUTS: +; NEWIM - Image array after transformation has been performed. +; The dimensions of NEWIM will be identical to the NAXIS1 and +; NAXIS2 keywords specified in REFHD. Regions on the reference +; image that do not exist in OLDIM can be assigned a value with +; the MISSING keyword. +; NEWHD - Updated FITS image header associated with NEWIM +; +; OPTIONAL INPUT KEYWORDS: +; CUBIC - a scalar value between -1 and 0 specifying cubic interpolation +; with the specified value as the cubic interpolation parameter. +; (see poly_2d for info). Setting CUBIC to a value greater +; than zero is equivalent to setting CUBIC = -1. +; DEGREE - Integer scalar specifying the degree of the transformation. +; See the routine POLYWARP for more info. Default = +; 1 (linear transformation) unless polynomial ('SIP') distortion +; parameters are present in either the input or reference FITS +; header. In that case, the default degree is equal to the +; degree of the distortion polynomial. +; INTERP - Scalar, one of 0, 1, or 2 determining type of interpolation +; 0 nearest neighbor, 1 (default) bilinear interpolation, +; 2 cubic interpolation. +; MISSING - Set this keyword to a scalar value which will be assigned +; to pixels in the output image which are out of range of the +; supplied imput image. If not supplied, then linear +; extrapolation is used. See the IDL manual on POLY_2D. +; ***NOTE: A bug was introduced into the POLY_2D function in IDL +; V5.5 (fixed in V6.1) such that the MISSING keyword +; may not work properly with floating point data*** +; NGRID - Integer scalar specifying the number of equally spaced grid +; points on each axis to use to specify the transformation. +; The value of NGRID must always be greater than DEGREE + 1. +; The default is DEGREE + 2 which equals 3 (9 total points) for +; DEGREE=1 (linear warping). +; SILENT - If set, then some informational error messages are suppressed. +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG - If this keyword is supplied, then any error messages will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; NOTES: +; (1) The 3 parameter calling sequence is less demanding on virtual +; memory. +; (2) The astrometry in OLDHD will be precessed to match the equinox +; given in REFHD. +; (3) If an ST Guidestar image is used for the reference header, then the +; output header will be converted to standard astrometry. +; EXAMPLE: +; Suppose one has an image array, IM, and an associated FITS header H. +; One desires to warp the image array so that it is aligned with another +; image with a FITS header, HREF. Both headers contain astrometry info. +; Set pixel values to 0 where there is no overlap between the input and +; reference image, and use linear interpolation (default) +; +; IDL> hastrom, IM, H, HREF, MISSING = 0 +; +; PROCEDURES USED: +; ad2xy, check_FITS, extast, get_EQUINOX(), gsssextast, hprecess, +; putast, sxaddpar, sxaddhist, sxpar(), xy2ad, zparcheck +; +; REVISION HISTORY: +; Written W. Landsman, STX Co. Feb, 1989 +; Updated to CHECK_FITS Dec, 1991 +; New astrometry keywords Mar, 1994 +; Recognize GSSS header W. Landsman June, 1994 +; Added CUBIC keyword W. Landsman March, 1997 +; Accept INTERP=0, Convert output GSS header to standard astrometry +; W. Landsman June 1998 +; Remove calls to obsolete !ERR system variable March 2000 +; Added ERRMSG output keyword W. Landsman April 2000 +; Need to re-extract astrometry after precession W. Landsman Nov. 2000 +; Check for distortion parameters in headers, add more FITS HISTORY +; information W. Landsman February 2005 +; Use different coefficient for nearest neighbor to avoid half-pixel +; shift with POLY_2D W. Landsman Aug 2006 +; Return ERRMSG if no overlap between images W. Landsman Nov 2007 +; Use V6.0 notation W. Landsman Jan 2012 +; +;- + compile_opt idl2 + On_error,2 ;Return to caller + npar = N_params() + + if (npar LT 3) or (npar EQ 4) then begin ;3 parameter calling sequence? + print,'Syntax: HASTROM, oldim, oldhd, refhd' + print,' or HASTROM, oldim, oldhd, newim, newhd, refhd' + print,' [ MISSING=, DEGREE=, INTERP=, NGRID=, CUBIC = ]' + return + endif + + if ( npar EQ 3 ) then begin + zparcheck, 'HASTROM', newim, 3, 7, 1, 'Reference FITS header' + refhd = newim + endif else $ + zparcheck, 'HASTROM', refhd, 5, 7, 1, 'Reference FITS header' + + radeg = 180.D/!DPI ;Double precision !RADEG + +save_err = arg_present(errmsg) ;Does user want error msgs returned? + +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'ERROR - Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + xsize_old = dimen[0] & ysize_old = dimen[1] + + xsize_ref = sxpar( refhd, 'NAXIS1' ) ;Get output image size + ysize_ref = sxpar( refhd, 'NAXIS2' ) + if (xsize_ref LT 1) || (ysize_ref LT 1) then begin + errmsg = 'ERROR - Reference header must be for a 2-dimensional image' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + +; Extract CD, CRPIX and CRVAL value from image header and reference header + + newhd = oldhd + extast, newhd, astr_old, par_old + if ( par_old LT 0 ) then begin + errmsg = 'ERROR - Input FITS Header does not contain astrometry' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + extast, refhd, astr_ref, par_ref + if ( par_old LT 0 ) || ( par_ref LT 0 ) then begin + errmsg = 'ERROR -Reference FITS Header does not contain astrometry' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + +; Precess the header if necessary + + refeq = get_equinox( refhd, code) + if code EQ -1 then message, NoPrint = Silent, $ + 'WARNING - Equinox not specified in reference header',/CON else begin + oldeq = get_equinox( oldhd, code) + if code EQ -1 then message, NoPrint = Silent, $ + 'WARNING - Equinox not specified in original header',/CON else $ + if oldeq NE refeq then begin ;Precess header and re-extract structure + hprecess, newhd, refeq + extast, newhd, astr_old, par_old + endif + endelse + +; Make a grid of points in the reference image to be used for the transformation + + if ~keyword_set( DEGREE ) then degree = 1 + if tag_exist(astr_old,'DISTORT') then begin + distort = astr_old.distort + if distort.name EQ 'SIP' then begin + na = ((size(distort.ap,/dimen))[0]) + degree = degree > (na -1 ) + endif + endif + + if tag_exist(astr_ref,'DISTORT') then begin + distort = astr_ref.distort + if distort.name EQ 'SIP' then begin + na = ((size(distort.a,/dimen))[0]) + degree = degree > (na -1 ) + endif + endif + + if ~keyword_set(NGRID) then ngrid = (degree + 2) + if ~keyword_set(CUBIC) then begin + cubic = 0 + if N_elements(INTERP) EQ 0 then Interp = 1 + endif + + nxdif = round( xsize_ref / (ngrid-1) ) + 1 + nydif = round( ysize_ref / (ngrid-1) ) + 1 + + xref = lonarr(ngrid,ngrid) & yref = xref + xrow = [ lindgen(ngrid-1)*nxdif, xsize_ref-1. ] + yrow = [ lindgen(ngrid-1)*nydif, ysize_ref-1. ] + + for i=0,ngrid-1 do xref[0,i] = xrow ;Four corners of image + for i=0,ngrid-1 do yref[0,i] = replicate( yrow[i], ngrid) + +; Find the position of the reference points in the supplied image + + case strmid(astr_ref.ctype[0],5,3) of + 'GSS': gsssxyad, astr_ref, xref, yref, ra, dec + else: xy2ad, xref, yref, astr_ref, ra, dec + endcase + + case strmid(astr_old.ctype[0],5,3) of + 'GSS': gsssadxy, astr_old, ra, dec, x, y + else: ad2xy, ra, dec, astr_old, x, y + endcase + + if ( max(x) LT 0 ) || ( min(x) GT xsize_old ) || $ + ( max(y) LT 0 ) || ( min(y) GT ysize_old ) then begin + errmsg = 'No overlap found between original and reference images' + if ~save_err then begin + message,'ERROR - ' + errmsg,/CON + message,'Be sure you have the right headers and the right equinoxes',/CON + endif + return + endif + + + if interp EQ 0 $ ;Get coefficients + then polywarp, x+.5, y+.5, xref, yref, degree, kx, ky $ + else polywarp, x, y, xref, yref, degree, kx, ky + + + if N_elements(missing) NE 1 then begin ;Do the warping + + if npar EQ 3 then $ + oldim = poly_2d( temporary(oldim), kx, ky, Interp, xsize_ref, ysize_ref, $ + CUBIC = cubic) else $ + newim = poly_2d( oldim, kx, ky, Interp, xsize_ref, ysize_ref, CUBIC = cubic) + + endif else begin + + if npar EQ 3 then $ + oldim = poly_2d( temporary(oldim), kx, ky, Interp, xsize_ref, ysize_ref, $ + MISSING=missing, CUBIC = cubic) $ + else $ + newim = poly_2d( oldim, kx, ky, Interp, xsize_ref, ysize_ref, $ + MISSING=missing, CUBIC = cubic) + + endelse + + sxaddpar, newhd, 'NAXIS1', xsize_ref + sxaddpar, newhd, 'NAXIS2', ysize_ref + + if strmid(astr_ref.ctype[0],5,3) EQ 'GSS' then begin + refhdnew = refhd + gsss_stdast,refhdnew + extast,refhdnew,astr_ref + endif + putast, newhd, astr_ref + + label = 'HASTROM: ' + strmid(systime(),4,20) + image = sxpar( refhd, 'IMAGE', Count = N_image) + if N_image EQ 1 THEN sxaddhist,label+' Reference Image - ' + image,newhd + sxaddhist,label+ ' Original Image Size X: ' + strtrim(xsize_old,2) + $ + ' Y: ' + strtrim(ysize_old,2), newhd + sxaddhist,'HASTROM: Polynomial Degree used for image warping: ' + $ + strtrim(degree,2), newhd + if cubic NE 0 then sterp = 'CUBIC = ' + strtrim(cubic,2) else $ + sterp = (['Nearest Neighbor','Linear','Cubic'])[interp] + sxaddhist,'HASTROM: ' + sterp + ' interpolation',newhd + sxaddhist,'HASTROM: Number of grid points ' + strtrim(ngrid*ngrid,2), newhd + +; Update BSCALE and BZERO factors in header if necessary. This is only an +; approximate correction for nonlinear warping. + + bscale = sxpar( newhd, 'BSCALE', Count = N_Bscale) + if (N_bscale GT 0 ) && ( bscale NE 1. ) then begin + getrot, astr_old, rot, cdelt_old, SILENT = silent + getrot, astr_ref, rot, cdelt_ref, SILENT = silent + pix_ratio = ( cdelt_old[0]*cdelt_old[1]) / (cdelt_ref[0]*cdelt_ref[1] ) + sxaddpar, newhd, 'BSCALE', bscale/pix_ratio + bzero = sxpar( newhd,'BZERO' ) + if bzero NE 0. then sxaddpar, newhd, 'BZERO', bzero/pix_ratio + endif + + if npar LT 4 then oldhd = newhd + + return + end diff --git a/modules/idl_downloads/astro/pro/hboxave.pro b/modules/idl_downloads/astro/pro/hboxave.pro new file mode 100644 index 0000000..d5cfc59 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hboxave.pro @@ -0,0 +1,162 @@ +pro hboxave, oldim, oldhd, newim, newhd, box, ERRMSG = errmsg ;Boxaverage and update header +;+ +; NAME: +; HBOXAVE +; PURPOSE: +; Box average an image array and update the FITS header array +; EXPLANATION: +; The function BOXAVE() is used. This procedure is recommended for +; integer images when photometric precision is desired, because it +; performs intermediate steps using REAL*4 arithmetic. Otherwise, the +; procedure HREBIN is much faster. +; +; CALLING SEQUENCE: +; HBOXAVE, Oldim, Oldhd, Newim, Hewhd, box +; or +; HBOXAVE, Oldim, Oldhd, box +; +; INPUTS: +; Oldim - the original image array +; Oldhd - the original image FITS header, string array +; +; OPTIONAL INPUTS: +; box - the box size to be used, integer scalar. If omitted, then +; HBOXAVE will prompt for this parameter. +; +; OPTIONAL OUTPUTS: +; Newim - the image after boxaveraging +; Newhd - header for newim containing updated astrometry info +; If output parameters are not supplied, the program +; will modify the input parameters OLDIM and OLDHD +; to contain the new array and updated header. +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; +; PROCEDURE: +; The parameters BSCALE, NAXIS1, NAXIS2, CRPIX1, and CRPIX2 and +; the CD (or CDELT) parameters are updated for the new FITS header. +; +; EXAMPLE: +; Compress the image in a FITS file 'image.fits' by a factor of 4 and +; update the astrometry in the FITS header +; +; IDL> im = readfits('image.fits',hdr) ;Read FITS file into IDL arrays +; IDL> hboxave, im, hdr, 4 ;Boxaverage by 4 +; IDL> writefits,'image.fits',im,hdr ;Write a new FITS file +; +; CALLED PROCEDURES: +; CHECK_FITS - Check that the FITS header is appropriate to the image +; BOXAVE() - Performs box averaging of an image +; SXPAR(), SXADDPAR - Read and write FITS keyword values +; +; MODIFICATION HISTORY: +; Written, Aug. 1986 W. Landsman, STI Corp. +; IDLV2 changes, sxaddpar format keyword added, J. Isensee, July,1990 +; Fix 0.5 pixel offset in new CRPIX computation W. Landsman, Dec, 1991 +; Update BSCALE even if no astrometry present W. Landsman, May 1997 +; Added ERRMSG keyword, Use double formatting W. Landsman April 2000 +; Recognize PC matrix astrometry format W. Landsman December 2001 +; Use V6.0 notation W. Landsman October 2012 +;- + On_error,2 ;Return to caller on error + + npar = N_params() + + if ( npar LT 2 ) then begin ;Check # of parameters + print,'Syntax: HBOXAVE, oldim, oldhd, [ newim, newhd, box, ERRMSG = ]' + print,' or HBOXAVE, oldim, oldhd, [ box, ERRMSG = ]' + return + endif + + save_err = arg_present(errmsg) ;Does user want to return error messages? +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + xsize = dimen[0] & ysize = dimen[1] + if npar EQ 3 then begin + + box = newim + + endif else if (npar NE 5) then begin ;prompt for box size + + print,'Boxaverage an image and update header' + print,'Original array size is '+ strn(xsize) + ' by ' + strn(ysize) + read, 'Enter width of box to be used in box average: ',box + + endif + + box = fix(box) ;Check for integer type + if N_elements(box) NE 1 then begin + box = 0 + read, 'Enter width of box to be used in box average: ',box + endif + + newx = xsize/float(box) + newy = ysize/float(box) + + if (newx*box NE xsize) || (newy*box NE ysize) then $ + message,'ERROR - Box size does not evenly divide image size' + + if npar GT 3 then newim = boxave( oldim, box) else $ + oldim = boxave( oldim, box) + + newhd = oldhd + sxaddpar, newhd, 'NAXIS1', fix(newx) + sxaddpar, newhd, 'NAXIS2', fix(newy) + label = 'HBOXAVE:' + strmid( systime(), 4, 20) + sxaddpar, newhd, 'HISTORY', label + ' Original Image Size Was ' + $ + strn(xsize) + ' by ' + strn(ysize) + sxaddpar, newhd, 'HISTORY',label+' Box Width: '+ strn(box)+' Pixels' + +; Update astrometry info if it exists + + extast, oldhd, astr, noparams + if noparams GE 0 then begin + + pix_ratio = box*box ;Ratio of old to new pixel areas + + crpix = (astr.crpix - 0.5)/box + 0.5 + sxaddpar, newhd, 'CRPIX1', crpix[0] + sxaddpar, newhd, 'CRPIX2', crpix[1] + + if (noparams NE 2) then begin + + cdelt = astr.cdelt + sxaddpar, newhd, 'CDELT1', CDELT[0]*box + sxaddpar, newhd, 'CDELT2', CDELT[1]*box + + endif else begin ;CDn_m Matrix + + cd = astr.cd + sxaddpar, newhd, 'CD1_1', cd[0,0]*box + sxaddpar, newhd, 'CD1_2', cd[0,1]*box + sxaddpar, newhd, 'CD2_1', cd[1,0]*box + sxaddpar, newhd, 'CD2_2', cd[1,1]*box + + endelse + endif + + bscale = sxpar( oldhd, 'BSCALE') + if ( bscale NE 0 ) && ( bscale NE 1) then $ + sxaddpar, newhd, 'BSCALE', bscale*pix_ratio, ' CALIBRATION FACTOR' + + bzero = sxpar( oldhd, 'BZERO') + if ( bzero NE 0) then sxaddpar, newhd, 'BZERO', bzero*pix_ratio, $ + ' ADDITIVE CONST FOR CALIB' + + if npar LT 4 then oldhd = newhd + return + end diff --git a/modules/idl_downloads/astro/pro/hcongrid.pro b/modules/idl_downloads/astro/pro/hcongrid.pro new file mode 100644 index 0000000..68e6b55 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hcongrid.pro @@ -0,0 +1,302 @@ +pro hcongrid, oldim, oldhd, newim, newhd, newx, newy, HALF_HALF = half_half, $ + INTERP=interp, OUTSIZE = outsize, CUBIC = cubic, ERRMSG = errmsg,$ + ALT = alt +;+ +; NAME: +; HCONGRID +; PURPOSE: +; CONGRID an image and update astrometry in a FITS header +; EXPLANATION: +; Expand or contract an image using CONGRID and update the +; associated FITS header array. +; +; CALLING SEQUENCE: +; HCONGRID, oldhd ;Update FITS header only +; HCONGRID, oldim, oldhd, [ newim, newhd, newx, newy, /HALF_HALF +; CUBIC = , INTERP=, OUTSIZE=, ERRMSG=, ALT= ] +; +; INPUTS: +; OLDIM - the original image array +; OLDHD - the original image FITS header, string array +; +; OPTIONAL INPUTS: +; NEWX - size of the new image in the X direction +; NEWY - size of the new image in the Y direction +; The OUTSIZE keyword can be used instead of the +; NEWX, NEWY parameters +; +; OPTIONAL OUTPUTS: +; NEWIM - the image after expansion or contraction with CONGRID +; NEWHD - header for newim containing updated astrometry info +; If output parameters are not supplied, the program +; will modify the input parameters OLDIM and OLDHD +; to contain the new array and updated header. +; +; OPTIONAL KEYWORD INPUTS: +; ALT - Single character 'A' through 'Z' or ' ' specifying which astrometry +; system to modify in the FITS header. The default is to use the +; primary astrometry of ALT = ' '. See Greisen and Calabretta (2002) +; for information about alternate astrometry keywords. + +; CUBIC - If set and non-zero, then cubic interpolation is used. Valid +; ranges are -1 <= Cubic < 0. Setting /CUBIC is equivalent to +; CUBIC = -1 and also equivalent to INTERP = 2. See INTERPOLATE +; for more info. Setting CUBIC = -0.5 is recommended. +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; /HALF_HALF - Due to edge effects, the default behaviour of CONGRID is +; to introduce a slight shift in the image center. Craig Markwardt +; (http://cow.physics.wisc.edu/~craigm/idl/misc.html) has written +; a modified version of CONGRID called CMCONGRID that when used with +; the /HALF_HALF keyword eliminates any shift. The use of the +; /HALF keyword emulates CMCONGRID and eliminates any shift in the +; image centroid. +; INTERP - 0 for nearest neighbor, 1 for bilinear interpolation +; (default), 2 for cubic (=-1) interpolation. +; OUTSIZE - Two element integer vector which can be used instead of the +; NEWX and NEWY parameters to specify the output image dimensions +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; PROCEDURE: +; Expansion or contraction is done using the CONGRID function, unless +; HALF_HALF is set. +; +; The parameters BSCALE, NAXIS1, NAXIS2, CRPIX1, and CRPIX2 and +; the CD (or CDELT) parameters are updated for the new header. +; +; NOTES: +; A FITS header can be supplied as the first parameter without having +; to supply an image array. The astrometry in the FITS header will be +; updated to be appropriate to the specified image size. +; +; If the FITS header contains astrometry from a ST Guide Star image, +; then the astrometry will be converted to an approximately equivalent +; tangent projection before applying CONGRID. +; EXAMPLE: +; Congrid an 512 x 512 image array IM and FITS header H to size 300 x 300 +; using cubic interpolation. Use the HALF_HALF keyword to avoid +; a shift of the image centroid +; +; IDL> hcongrid, IM ,H, OUT = [300, 300], CUBIC = -0.5, /HALF +; +; The variables IM and H will be modified to the new image size. +; +; PROCEDURES CALLED: +; CHECK_FITS, CONGRID(), EXTAST, GSSS_STDAST, SXADDHIST, +; SXADDPAR, SXPAR(), ZPARCHECK +; MODIFICATION HISTORY: +; Written, Aug. 1986 W. Landsman, STI Corp. +; Added interp keywords, J. Isensee, July, 1990 +; Add cubic interpolation W. Landsman HSTX January 1994 +; Recognize a GSSS FITS header W. Landsman June 1994 +; Fix case where header but not image supplied W. Landsman May 1995 +; Remove call to SINCE_VERSION() W. Landsman March 1996 +; Assume since IDL V3.5, add CUBIC keyword W. Landsman March 1997 +; Update BSCALE even if no astrometry present W. Landsman May 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added HALF_HALF keyword W. Landsman February 2000 +; Added ERRMSG keyword, use double precision formatting W.L. April 2000 +; Recognize PC00n00m astrometry format W. Landsman December 2001 +; Now works when both /INTERP and /HALF are set W. Landsman January 2002 +; Fix output astrometry for non-equal plate scales for PC matrix or +; CROTA2 keyword, added ALT keyword. W. Landsman May 2005 +; Update distortion parameters if present W. Landsman January 2008 +; Don't update BSCALE/BZERO for unsigned integer W.Landsman Mar 2008 +; Write CRPIX as Double precision if necessary W. Landsman Oct 2012 +;- + On_error,2 + compile_opt idl2 + Npar = N_params() ;Check # of parameters + + if Npar EQ 0 then begin + print,' Syntax - HCONGRID, oldim, oldhd,[ newim, newhd, newx, newy' + print,' ALT=, CUBIC = , INTERP =, /HALF, OUTSIZE = , ERRMSG=]' + return + endif + + save_err = arg_present(errmsg) + if Npar EQ 1 then begin + + zparcheck, 'HCONGRID', oldim, 1, 7, 1, 'Image header' + oldhd = oldim + xsize = sxpar( oldhd,'NAXIS1') + ysize = sxpar( oldhd,'NAXIS2') + + endif else begin +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE,ERRMSG = errmsg + + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + if N_elements(dimen) NE 2 then begin + errmsg = 'Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + xsize = dimen[0] & ysize = dimen[1] + endelse + tname = size(oldim,/tname) + + if keyword_set(CUBIC) then interp = 2 + if N_elements(interp) EQ 0 then interp = 1 + + case interp of + 0: type = ' Nearest Neighbor Approximation' + 1: type = ' Bilinear Interpolation' + 2: type = ' Cubic Interpolation' + else: begin + errmsg = 'Illegal value of INTERP keyword, must be 0, 1, or 2' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + end + endcase + + if npar LT 6 then begin + if ( N_elements(OUTSIZE) NE 2 ) then begin + message, /INF, $ + 'Original array size is '+ strn( xsize ) + ' by ' + strn(ysize) + read,'Enter size of new image in the X direction: ',newx + read,'Enter size of new image in the Y direction: ',newy + endif else begin + newx = outsize[0] + newy = outsize[1] + endelse + endif + + if ( xsize EQ newx ) && ( ysize EQ newy ) then begin + message,'Output image size equals input image size',/INF + return + endif + + xratio = float(newx)/xsize + yratio = float(newy)/ysize + lambda = yratio/xratio ;Measures change in aspect ratio. + + + if ( npar GT 1 ) then begin + + if keyword_set(half_half) then begin + srx = (findgen(newx) + 0.5)/xratio - 0.5 + sry = (findgen(newy) + 0.5)/yratio - 0.5 + if interp GT 0 then begin + if ( npar GT 2 ) then $ + newim = interpolate(oldim, srx,sry,/GRID, CUBIC = cubic) else $ + oldim = interpolate(oldim, srx,sry,/GRID, CUBIC = cubic) + endif else begin + xr = float(xsize)/newx & yr = float(ysize)/newy + if (npar GT 2) then $ + newim = POLY_2D(oldim, [[xr/2.,0],[xr,0]], $ + [ [xr/2.,yr],[0,0] ],0,newx,newy) else $ + oldim = POLY_2D(oldim, [[yr/2.,0],[yr,0] ], $ + [[ yr/2.,yr],[0,0] ],0,newx,newy) + endelse + endif else begin + + if ( npar GT 2 ) then $ + newim = congrid( oldim, newx, newy, INTERP = interp, CUBIC = cubic) else $ + oldim = congrid( temporary(oldim), newx, newy, $ + CUBIC = cubic, INTERP=interp ) + endelse + + endif + + newhd = oldhd + sxaddpar, newhd, 'NAXIS1', fix(newx) + sxaddpar, newhd, 'NAXIS2', fix(newy) + label = 'HCONGRID:' + strmid(systime(),4,20) + history = ' Original Image Size Was '+ strn(xsize) + ' by ' + strn(ysize) + sxaddhist, label + history, newhd + if npar GT 1 then sxaddhist, label+type, newhd + +; Update astrometry info if it exists + + extast, newhd ,astr, noparams, ALT = alt + if noparams GE 0 then begin + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + gsss_stdast, newhd + extast, newhd, astr, noparams + endif + + pix_ratio = xratio*yratio ;Ratio of pixel areas + + crpix = astr.crpix - 1.0 + + if keyword_set(half_half) then begin + sxaddpar, newhd, 'CRPIX1' + alt, $ + (crpix[0]+0.5)*xratio + 0.5 + sxaddpar, newhd, 'CRPIX2' + alt, $ + (crpix[1]+0.5)*yratio + 0.5 + endif else begin + sxaddpar, newhd, 'CRPIX1' + alt , crpix[0]*xratio + 1.0 + sxaddpar, newhd, 'CRPIX2' + alt , crpix[1]*yratio + 1.0 + endelse + + + if tag_exist(astr,'DISTORT') then begin + distort = astr.distort + message,'Updating SIP distortion parameters',/INF + update_distort,distort, [1./xratio,0],[1./yratio,0] + astr.distort= distort + add_distort, newhd, astr + endif + + + + if (noparams NE 2) then begin + + cdelt = astr.cdelt + sxaddpar, newhd, 'CDELT1' + alt , CDELT[0]/xratio + sxaddpar, newhd, 'CDELT2' + alt , CDELT[1]/yratio +; Adjust the PC matrix if non-equal plate scales. See equation 187 in +; Calabretta & Greisen (2002) + if lambda NE 1.0 then begin + cd = astr.cd + if noparams EQ 1 then begin +;Can no longer use the simple CROTA2 convention, change to PC keywords + sxaddpar,newhd,'PC1_1'+alt, cd[0,0] + sxaddpar, newhd,'PC2_2'+alt, cd[1,1] + sxdelpar, newhd, ['CROTA2','CROTA1'] + endif + sxaddpar, newhd, 'PC1_2'+alt, cd[0,1]/lambda + sxaddpar, newhd, 'PC2_1'+alt, cd[1,0]*lambda + endif + + + endif else begin + + cd = astr.cd + sxaddpar, newhd, 'CD1_1' + alt, cd[0,0]/xratio + sxaddpar, newhd, 'CD1_2' + alt, cd[0,1]/yratio + sxaddpar, newhd, 'CD2_1' + alt, cd[1,0]/xratio + sxaddpar, newhd, 'CD2_2' + alt , cd[1,1]/yratio + + endelse + endif + +; Adjust BZERO and BSCALE for new pixel size, unless these values are used +; to define unsigned integer data types. + + bscale = sxpar( oldhd, 'BSCALE') + bzero = sxpar( oldhd, 'BZERO') + unsgn = (tname EQ 'UINT') || (tname EQ 'ULONG') + + if ~unsgn then begin + if (bscale NE 0) && (bscale NE 1) then $ + sxaddpar, newhd, 'BSCALE', bscale/pix_ratio, 'Calibration Factor' + if (bzero NE 0) then sxaddpar, newhd, 'BZERO', bzero/pix_ratio, $ + ' Additive Constant for Calibration' + endif + + if npar EQ 2 then oldhd = newhd else $ + if npar EQ 1 then oldim = newhd + + + return + end diff --git a/modules/idl_downloads/astro/pro/headfits.pro b/modules/idl_downloads/astro/pro/headfits.pro new file mode 100644 index 0000000..c6495e4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/headfits.pro @@ -0,0 +1,118 @@ +function HEADFITS, filename, EXTEN = exten, Compress = compress, $ + ERRMSG = errmsg, SILENT = silent +;+ +; NAME: +; HEADFITS +; PURPOSE: +; Read a FITS (primary or extension) header into a string array. +; EXPLANATION: +; HEADFITS() supports several types of compressed files including +; gzip (.gz), Unix compressed (.Z), Bzip2 (.bz2) or FPACK (.fz +; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) +; +; CALLING SEQUENCE: +; Result = HEADFITS(Filename/Fileunit ,[ ERRMSG =, EXTEN= , COMPRESS=, +; /SILENT ]) +; +; INPUTS: +; Filename = String containing the name of the FITS file to be read. +; If set to an empty string, then user will be prompted for name. +; File names ending in '.gz' are assumed to be gzip'ed compressed +; and under Unix file names ending in '.Z' are assumed to be +; Unix compressed, and file names ending in .bz2 are assumed to +; be bzip2 compressed. If this default behaviour is not +; sufficient then use the COMPRESS keyword. +; or +; Fileunit - A scalar integer specifying the unit of an already opened +; FITS file. The unit will remain open after exiting +; HEADFITS(). There are two possible reasons for choosing +; to specify a unit number rather than a file name: +; (1) For a FITS file with many extensions, one can move to the +; desired extensions with FXPOSIT() and then use HEADFITS(). This +; is more efficient that repeatedly starting at the beginning of +; the file. +; (2) For reading a FITS file across a Web http: address after opening +; the unit with the SOCKET procedure. +; OPTIONAL INPUT KEYWORDS: +; EXTEN = Either an integer scalar, specifying which FITS extension to +; read, or a scalar string specifying the extension name (stored +; in the EXTNAME keyword). For example, to read the header of +; the first extension set EXTEN = 1. Default is to read the +; primary FITS header (EXTEN = 0). The EXTEN keyword cannot +; be used when a unit number is supplied instead of a file name. +; COMPRESS - If this keyword is set and non-zero, then treat the file +; as compressed. If 1 assume a gzipped file. Use IDL's +; internal decompression facilities for gzip files, while for +; Unix or bzip2 compression spawn off a process to decompress and +; use its output as the FITS stream. If the keyword is not 1, +; then use its value as a string giving the command needed for +; decompression. See FXPOSIT for more info. +; /SILENT - If set, then suppress any warning messages about invalid +; characters in the FITS file. +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; +; OUTPUTS: +; Result of function = FITS header, string array +; +; EXAMPLE: +; Print the main FITS header of a file 'test.fits' into a string +; variable, h +; +; IDL> print, headfits( 'test.fits') +; +; Print the second extension header of a gzip compressed FITS file +; 'test.fits.gz'. Use HPRINT for pretty format +; +; IDL> hprint, headfits( 'test.fits.gz', ext=2) +; +; Read the extension named CALSPEC +; +; IDL> hprint,headfits('test.fits.gz',ext='CALSPEC') +; +; PROCEDURES CALLED +; FXPOSIT(), MRD_HREAD +; MODIFICATION HISTORY: +; Adapted by Frank Varosi from READFITS by Jim Wofford, January, 24 1989 +; Option to read a unit number rather than file name W.L October 2001 +; Test output status of MRD_HREAD call October 2003 W. Landsman +; Allow extension to be specified by name Dec 2006 W. Landsman +; No need to uncompress FPACK compressed files May 2009 W. Landsman +; Use V6.0 notation W.L. Feb. 2011 +; Do not check for EOF() since MRD_HREAD does this Nov 2014 W. Landsman +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - header = headfits( filename,[ EXTEN=, ERRMSG=, ' + $ + '/SILENT, COMPRESS= ])' + return, -1 + endif + + printerr = ~arg_present(errmsg) + errmsg = '' + if ~keyword_set(exten) then exten = 0 + + unitsupplied = size(filename,/TNAME) NE 'STRING' + if unitsupplied then unit = filename else begin + unit = FXPOSIT( filename, exten, errmsg = errmsg, $ + /READONLY,compress = compress, SILENT=silent,/headeronly) + if unit EQ -1 then begin + if printerr then $ + message,'ERROR - ' + errmsg,/CON + return,-1 + endif + endelse + + MRD_HREAD, unit, header, status, SILENT = silent + if ~unitsupplied then free_lun, unit + if status LT 0 then begin + if N_elements(errmsg) GT 0 then errmsg = !ERROR_STATE.MSG else $ + message,'ERROR - ' + !ERROR_STATE.MSG,/CON + return, -1 + endif else return, header + end diff --git a/modules/idl_downloads/astro/pro/helio.pro b/modules/idl_downloads/astro/pro/helio.pro new file mode 100644 index 0000000..70ba4a8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/helio.pro @@ -0,0 +1,189 @@ +PRO HELIO, JD, LIST, HRAD, HLONG, HLAT, RADIAN = radian +;+ +; NAME: +; HELIO +; PURPOSE: +; Compute (low-precision) heliocentric coordinates for the planets. +; EXPLANATION: +; The mean orbital elements for epoch J2000 are used. These are derived +; from a 250 yr least squares fit of the DE 200 planetary ephemeris to a +; Keplerian orbit where each element is allowed to vary linearly with +; time. For dates between 1800 and 2050, this solution fits the +; terrestrial planet orbits to ~25" or better, but achieves only ~600" +; for Saturn. +; +; Use PLANET_COORDS (which calls HELIO) to get celestial (RA, Dec) +; coordinates of the planets +; CALLING SEQUENCE: +; HELIO, JD, LIST, HRAD, HLONG, HLAT, [/RADIAN] +; INPUTS: +; JD = Julian date, double precision scalar or vector +; LIST = List of planets array. May be a single number. +; 1 = merc, 2 = venus, ... 9 = pluto. +; +; OUTPUTS: +; HRAD = array of Heliocentric radii (A.U). +; HLONG = array of Heliocentric (ecliptic) longitudes (degrees). +; HLAT = array of Heliocentric latitudes (degrees). +; These output parameters will be dimensioned Nplanet by Ndate, +; where Nplanet is the number of elements of list, and Ndate is +; the number of elements of JD. +; +; OPTIONAL INPUT KEYWORD: +; /RADIAN - If set, then the output longitude and latitude are given in +; radians. +; EXAMPLE: +; (1) Find the current heliocentric positions of all the planets +; +; IDL> GET_JULDATE, jd ;Get current Julian date +; IDL> HELIO,jd,indgen(9)+1,hrad,hlong,hlat ;Get radius, long, and lat +; +; (2) Find heliocentric position of Mars on August 23, 2000 +; IDL> JDCNV, 2000,08,23,0,jd +; IDL> HELIO,JD,2,HRAD,HLONG,HLAT +; ===> hrad = 1.6407 AU hlong = 124.3197 hlat = 1.7853 +; For comparison, the JPL ephemeris gives +; hrad = 1.6407 AU hlong = 124.2985 hlat = 1.7845 +; (3) Find the heliocentric positions of Mars and Venus for every day in +; November 2000 +; IDL> JDCNV, 2000, 11, 1, 0, jd ;Julian date of November 1, 2000 +; IDL> helio, jd+indgen(30), [4,2], hrad,hlong,hlat ;Mars=4, Venus=2 +; hrad, hlong, and hlat will be dimensioned [2,30] +; first column contains Mars data, second column Venus +; COMMON BLOCKS: +; None +; ROUTINES USED: +; CIRRANGE - force angle between 0 and 2*!PI +; NOTES: +; (1) The calling sequence for this procedure was changed in August 2000 +; (2) This program is based on the two-body model and thus neglects +; interactions between the planets. This is why the worst results +; are for Saturn. Use the procedure JPLEPHINTERp for more accurate +; positions using the JPL ephemeris. Also see +; http://ssd.jpl.nasa.gov/cgi-bin/eph for a more accurate ephemeris +; generator online. +; (3) The coordinates are given for equinox 2000 and *not* the equinox +; of the supplied date(s) +; MODIFICATION HISTORY: +; R. Sterner. 20 Aug, 1986. +; Code cleaned up a bit W. Landsman December 1992 +; Major rewrite, use modern orbital elements, vectorize, more accurate +; solution to Kepler's equation W. Landsman August 2000 +; Wasn't working for planet vectors W. Landsman August 2000 +; Work for more than 32767 positions S. Leach Jan 2009 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - Helio, jd, list, hrad, hlong, hlat, [/RADIAN]' + print,' jd - Scalar or vector Julian date' + print,' list - scalar or vector of planet numbers [1-9]' + print, $ + ' hrad, hlong, hlat - output heliocentric distance, longitude latitude' + return + endif + +; Mean orbital elements taken from http://ssd.jpl.nasa.gov/elem_planets.html +; (1) semi-major axis in AU, (2) eccentricity, (3) inclination (degrees), +; (4) longitude of the ascending node (degrees), (5) longitude of perihelion +; (degrees) and (6) mean longitude (degrees) +;Mercury +PD = [ [ 0.38709893d, 0.20563069, 7.00487, 48.33167, 77.45645, 252.25084 ], $ +;Venus + [ 0.72333199d, 0.00677323, 3.39471, 76.68069, 131.53298, 181.97973 ], $ +;Earth + [ 1.00000011d, 0.01671022, 0.00005, -11.26064, 102.94719, 100.46435], $ +;Mars + [ 1.52366231d, 0.09341233, 1.85061, 49.57854, 336.04084, 355.45332], $ +;Jupiter + [ 5.20336301d, 0.04839266, 1.30530, 100.55615, 14.75385, 34.40438], $ +;Saturn + [ 9.53707032d, 0.05415060, 2.48446, 113.71504, 92.43194, 49.94432], $ +;Uranus + [19.19126393d, 0.04716771, 0.76986, 74.22988, 170.96424, 313.23218], $ +;Neptune + [30.06896348d, 0.00858587, 1.76917, 131.72169, 44.97135, 304.88003], $ +;Pluto + [39.48168677d, 0.24880766,17.14175, 110.30347, 224.06676, 238.92881] ] + +; DPD gives the time rate of change of the above quantities ("/century) + +DPD = [ [0.00000066d, 0.00002527, -23.51, -446.30, 573.57, 538101628.29 ], $ + [ 0.00000092d, -0.00004938, -2.86, -996.89, -108.80, 210664136.06], $ + [-0.00000005d, -0.00003804, -46.94, -18228.25, 1198.28, 129597740.63], $ + [-0.00007221d, 0.00011902, -25.47, -1020.19, 1560.78, 68905103.78 ], $ + [0.00060737d, -0.00012880, -4.15, 1217.17, 839.93, 10925078.35 ], $ + [-0.00301530d, -0.00036762, 6.11, -1591.05, -1948.89, 4401052.95], $ + [0.00152025d, -0.00019150, -2.09, -1681.40, 1312.56, 1542547.79 ], $ + [-0.00125196d, 0.0000251, -3.64, -151.25, -844.43, 786449.21 ], $ + [-0.00076912d, 0.00006465, 11.07, -37.33, -132.25, 522747.90] ] + + JD0 = 2451545.0d ;Julian Date for Epoch 2000.0 + radeg = 180/!DPI + +;----------------- Days since Epoch --------------- + + T = (JD - JD0)/36525.0d ;Time in centuries since 2000.0 + + + ip = list-1 + dpd[2:5,ip] = dpd[2:5,ip]/3600.0d ;Convert arc seconds to degrees + ntime = N_elements(t) + nplanet = N_elements(list) + hrad = fltarr(nplanet,ntime) & hlong = hrad & hlat = hrad + +;----------------- Loop over dates -------------- + + for i =0L,ntime-1L do begin ;SML made longword + + pd1 = pd[*,ip] + dpd[*,ip]*T[i] + + a = pd1[0,*] ;semi-major axis + eccen = pd1[1,*] ;eccentricity + n = 0.9856076686/a/sqrt(a)/RADEG ;mean motion, in radians/day + L = pd1[5,*]/RADEG ;mean longitude + pi = pd1[4,*]/RADEG ;longitude of the perihelion + omega = pd1[3,*]/RADEG ;longitude of the ascending node + inc = pd1[2,*]/RADEG ;inclination in radians + + m = L - pi + cirrange,m,/RADIAN + e1 = m + (m + eccen*sin(m) - m)/(1 - eccen*cos(m) ) + e = e1 + (m + eccen*sin(e1) - e1)/(1 - eccen*cos(e1) ) + maxdif = max(abs(e-e1)) + niter = 0 + while (maxdif GT 1e-5) and (niter lt 10) do begin + e1 = e + e = e1 + (m + eccen*sin(e1) - e1)/(1 - eccen*cos(e1) ) + maxdif = max(abs(e-e1)) + niter = niter+1 + endwhile + + + nu = 2*atan( sqrt( (1+eccen)/(1-eccen) )* tan(E/2)) ;true anomaly + + hrad[0,i] = reform( a*(1 - eccen*cos(e) ) ) + hlong[0,i] = reform (nu + pi) + hlat[0,i] = reform( asin(sin(hlong[*,i] - omega)*sin(inc) ) ) + endfor + + cirrange,hlong,/RADIAN + if not keyword_set(RADIAN) then begin + hlong = hlong*RADEG + hlat = hlat*RADEG + endif + if N_elements(hrad) GT 1 then begin + hrad = reform(hrad,/over) + hlong = reform(hlong,/over) + hlat = reform(hlat,/over) + endif else begin + if N_elements(size(jd)) EQ 3 then begin ;scalar? + hrad = hrad[0] + hlong = hlong[0] + hlat = hlat[0] + endif + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/helio_jd.pro b/modules/idl_downloads/astro/pro/helio_jd.pro new file mode 100644 index 0000000..af82fbc --- /dev/null +++ b/modules/idl_downloads/astro/pro/helio_jd.pro @@ -0,0 +1,102 @@ +function helio_jd,date,ra,dec, B1950 = B1950, TIME_DIFF = time_diff +;+ +; NAME: +; HELIO_JD +; PURPOSE: +; Convert geocentric (reduced) Julian date to heliocentric Julian date +; EXPLANATION: +; This procedure correct for the extra light travel time between the Earth +; and the Sun. +; +; An online calculator for this quantity is available at +; http://www.physics.sfasu.edu/astro/javascript/hjd.html +; +; Users requiring more precise calculations and documentation should +; look at the IDL code available at +; http://astroutils.astronomy.ohio-state.edu/time/ +; CALLING SEQUENCE: +; jdhelio = HELIO_JD( date, ra, dec, /B1950, /TIME_DIFF) +; +; INPUTS +; date - reduced Julian date (= JD - 2400000), scalar or vector, MUST +; be double precision +; ra,dec - scalars giving right ascension and declination in DEGREES +; Equinox is J2000 unless the /B1950 keyword is set +; +; OUTPUTS: +; jdhelio - heliocentric reduced Julian date. If /TIME_DIFF is set, then +; HELIO_JD() instead returns the time difference in seconds +; between the geocentric and heliocentric Julian date. +; +; OPTIONAL INPUT KEYWORDS +; /B1950 - if set, then input coordinates are assumed to be in equinox +; B1950 coordinates. +; /TIME_DIFF - if set, then HELIO_JD() returns the time difference +; (heliocentric JD - geocentric JD ) in seconds +; +; EXAMPLE: +; What is the heliocentric Julian date of an observation of V402 Cygni +; (J2000: RA = 20 9 7.8, Dec = 37 09 07) taken June 15, 1973 at 11:40 UT? +; +; IDL> juldate, [1973,6,15,11,40], jd ;Get geocentric Julian date +; IDL> hjd = helio_jd( jd, ten(20,9,7.8)*15., ten(37,9,7) ) +; +; ==> hjd = 41848.9881 +; +; Wayne Warren (Raytheon ITSS) has compared the results of HELIO_JD with the +; FORTRAN subroutines in the STARLINK SLALIB library (see +; http://star-www.rl.ac.uk/). +; Time Diff (sec) +; Date RA(2000) Dec(2000) STARLINK IDL +; +; 1999-10-29T00:00:00.0 21 08 25. -67 22 00. -59.0 -59.0 +; 1999-10-29T00:00:00.0 02 56 33.4 +00 26 55. 474.1 474.1 +; 1940-12-11T06:55:00.0 07 34 41.9 -00 30 42. 366.3 370.2 +; 1992-02-29T03:15:56.2 12 56 27.4 +42 10 17. 350.8 350.9 +; 2000-03-01T10:26:31.8 14 28 36.7 -20 42 11. 243.7 243.7 +; 2100-02-26T09:18:24.2 08 26 51.7 +85 47 28. 104.0 108.8 +; PROCEDURES CALLED: +; bprecess, xyz, zparcheck +; +; REVISION HISTORY: +; Algorithm from the book Astronomical Photometry by Henden, p. 114 +; Written, W. Landsman STX June, 1989 +; Make J2000 default equinox, add B1950, /TIME_DIFF keywords, compute +; variation of the obliquity W. Landsman November 1999 +;- + On_error,2 + If N_params() LT 3 then begin + print,'Syntax - jdhelio = HELIO_JD( date, ra, dec, /B1950, /TIME_DIFF)' + print,' date - reduced Julian date (= JD - 2400000)' + print,' Ra and Dec must be in degrees' + endif + +;Because XYZ uses default B1950 coordinates, we'll convert everything to B1950 + + if not keyword_set(B1950) then bprecess,ra,dec,ra1,dec1 else begin + ra1 = ra + dec1 = dec + endelse + + radeg = 180.0d/!DPI + zparcheck,'HELIO_JD',date,1,[3,4,5],[0,1],'Reduced Julian Date' + + delta_t = (double(date) - 33282.42345905d)/36525.0d + epsilon_sec = poly( delta_t, [44.836d, -46.8495, -0.00429, 0.00181]) + epsilon = (23.433333d0 + epsilon_sec/3600.0d)/radeg + ra1 = ra1/radeg + dec1 = dec1/radeg + + xyz, date, x, y, z + +;Find extra distance light must travel in AU, multiply by 1.49598e13 cm/AU, +;and divide by the speed of light, and multiply by 86400 second/year + + time = -499.00522d*( cos(dec1)*cos(ra1)*x + $ + (tan(epsilon)*sin(dec1) + cos(dec1)*sin(ra1))*y) + + if keyword_set(TIME_DIFF) then return, time else $ + + return, double(date) + time/86400.0d + + end diff --git a/modules/idl_downloads/astro/pro/helio_rv.pro b/modules/idl_downloads/astro/pro/helio_rv.pro new file mode 100644 index 0000000..cd6fe2c --- /dev/null +++ b/modules/idl_downloads/astro/pro/helio_rv.pro @@ -0,0 +1,145 @@ +function helio_rv,HJD,T,P,V0,K,e,omega +;+ +; NAME: +; HELIO_RV +; +; PURPOSE: +; Return the heliocentric radial velocity of a spectroscopic binary +; +; EXPLANATION: +; This function will return the heliocentric radial velocity of a +; spectroscopic binary star at a given heliocentric date +; given its orbit. +; +; CALLING SEQUENCE: +; +; Result = HELIO_RV ( JD ,T ,Period ,Gamma , K, [,e ,Omega ] ) +; +; INPUT: +; +; JD - Time of observation +; T - Time of periastron passage (max. +ve velocity +; for circular orbits), same time system as JD +; Period - the period in same units as JD +; Gamma - systemic velocity +; K - velocity semi-amplitude in the same units as Gamma. +; e - eccentricity of the orbit, default is 0. +; Omega - longitude of periastron in degrees. Must be specified for +; eccentric orbits. +; +; OUTPUT: +; +; The predicted heliocentric radial velocity in the same units as Gamma +; for the date(s) specified by Reduced_HJD. +; +; RESTRICTIONS: +; +; The user should ensure consistency with all time systems being +; used (i.e. JD and T should be in the same units and time system). +; Generally, users should reduce large time values by subtracting +; a large constant offset, which may improve numerical accuracy. +; +; If using the the routines JULDATE and HELIO_JD, the reduced HJD +; time system must be used throughtout. +; +; EXAMPLES: +; +; Example 1 +; +; What was the heliocentric radial velocity of the primary component of HU Tau +; at 1730 UT 25 Oct 1994? +; +; IDL> juldate ,[94,10,25,17,30],JD ;Get Geocentric julian date +; IDL> hjd = helio_jd(jd,ten(04,38,16)*15.,ten(20,41,05)) ; Convert to HJD +; IDL> print, helio_rv(hjd,46487.5303D,2.0563056D,-6.0,59.3) +; -62.965569 +; +; NB. 1. The routines JULDATE and HELIO_JD return a reduced HJD (HJD - 2400000) +; and so T and P must be specified in the same fashion. +; 2. The user should be careful to use double precision format to specify +; T and P to sufficient precision where necessary. +; +; Example 2 +; +; Plot two cycles of an eccentric orbit, e=0.6, omega=45 for both +; components of a binary star +; +; IDL> phi=findgen(100)/50.0 ; Generates 100 phase points +; IDL> plot, phi,helio_rv(phi,0,1,0,100,0.6,45),yrange=[-100,150] +; IDL> oplot, phi,helio_rv(phi,0,1,0,50,0.6,45+180) +; +; This illustrates both the use of arrays to perform multiple calculations +; and generating radial velocities for a given phase by setting T=0 and P=1. +; Note also that omega has been changed by 180 degrees for the orbit of the +; second component (the same 'trick' can be used for circular orbits). +; +; +; MODIFICATION HISTORY: +; +; Written by: Pierre Maxted CUOBS, October, 1994 +; +; Circular orbits handled by setting e=0 and omega=0 to allow +; binary orbits to be handled using omega and omega+180. +; Pierre Maxted,Feb 95 +; BUG - omega was altered by the routine - corrected Feb 95,Pierre Maxted +; Iteration for E changed to that given by Reidel , Feb 95,Pierre Maxted +; /SINGLE keyword removed. May 96,Pierre Maxted +;; +; Removed limitation of time system on HJD, C. Markwardt, 2011-04-15 +; +; Change convergence test from relative to absolute precision on E +; Pierre Maxted, Apr 12 +;- +; +; + ON_ERROR, 2 ; Return to caller + compile_opt idl2 +; +; Check suitable no. of parameters have been entered. +; + if N_params() ne 5 and N_params() ne 7 then begin + print,'Syntax - Result = HELIO_RV (JD ,T ,Period ,Gamma, K)' + print,' OR' + print,' Result = HELIO_RV (JD ,T ,Period ,Gamma, K ,e ,Omega)' + print,'Further help - type doc_library,"HELIO_RV".' + endif else begin +; +; Circular orbits +; + if ~keyword_set(omega) and ~keyword_set(e) then begin + e = 0.0 + omega = 0.0 + endif +; +; +; Calculate the approximate eccentric anomaly, E1, via the mean +; anomaly, M. +; (from Heintz DW, "Double stars", Reidel, 1978) +; + M=2.D*!dpi*( (HJD-T)/P MOD 1.) + E1=M + e*sin(M) + ((e^2)*sin(2.0D*M)/2.0D) +; +; Now refine this estimate using formulae given by Reidel. +; + repeat begin + E0=E1 + M0 = E0 - e*sin(E0) + E1 = E0 + (M-M0)/(1.0 - e*cos(E0)) + endrep until max(abs(E1-E0)) lt 1D-8 +; +; Now calculate nu +; + nu=2.0D*atan(sqrt((1.D0 + e)/(1.D - e))*tan(E1/2.0D)) +; nu=nu+((nu<0D)*(2D*!dpi)) +; +; Can now calculate radial velocities +; + rv = (K*(cos(nu+!dtor*omega) + (e*cos(!dtor*omega))))+V0 + return ,rv +; +; + endelse +; +; + end + diff --git a/modules/idl_downloads/astro/pro/hermite.pro b/modules/idl_downloads/astro/pro/hermite.pro new file mode 100644 index 0000000..9023f92 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hermite.pro @@ -0,0 +1,129 @@ +function hermite,xx,ff,x, FDERIV = fderiv +;+ +; NAME: +; HERMITE +; PURPOSE: +; To compute Hermite spline interpolation of a tabulated function. +; EXPLANATION: +; Hermite interpolation computes the cubic polynomial that agrees with +; the tabulated function and its derivative at the two nearest +; tabulated points. It may be preferable to Lagrangian interpolation +; (QUADTERP) when either (1) the first derivatives are known, or (2) +; one desires continuity of the first derivative of the interpolated +; values. HERMITE() will numerically compute the necessary +; derivatives, if they are not supplied. +; +; CALLING SEQUENCE: +; F = HERMITE( XX, FF, X, [ FDERIV = ]) +; +; INPUT PARAMETERS: +; XX - Vector giving tabulated X values of function to be interpolated +; Must be either monotonic increasing or decreasing +; FF - Tabulated values of function, same number of elements as X +; X - Scalar or vector giving the X values at which to interpolate +; +; OPTIONAL INPUT KEYWORD: +; FDERIV - function derivative values computed at XX. If not supplied, +; then HERMITE() will compute the derivatives numerically. +; The FDERIV keyword is useful either when (1) the derivative +; values are (somehow) known to better accuracy than can be +; computed numerically, or (2) when HERMITE() is called repeatedly +; with the same tabulated function, so that the derivatives +; need be computed only once. +; +; OUTPUT PARAMETER: +; F - Interpolated values of function, same number of points as X +; +; EXAMPLE: +; Interpolate the function 1/x at x = 0.45 using tabulated values +; with a spacing of 0.1 +; +; IDL> x = findgen(20)*0.1 + 0.1 +; IDL> y = 1/x +; IDL> print,hermite(x,y,0.45) +; This gives 2.2188 compared to the true value 1/0.45 = 2.2222 +; +; IDL> yprime = -1/x^2 ;But in this case we know the first derivatives +; IDL> print,hermite(x,y,0.45,fderiv = yprime) +; == 2.2219 ;and so can get a more accurate interpolation +; NOTES: +; The algorithm here is based on the FORTRAN code discussed by +; Hill, G. 1982, Publ Dom. Astrophys. Obs., 16, 67. The original +; FORTRAN source is U.S. Airforce. Surveys in Geophysics No 272. +; +; HERMITE() will return an error if one tries to interpolate any values +; outside of the range of the input table XX +; PROCEDURES CALLED: +; None +; REVISION HISTORY: +; Written, B. Dorman (GSFC) Oct 1993, revised April 1996 +; Added FDERIV keyword, W. Landsman (HSTX) April 1996 +; Test for out of range values W. Landsman (HSTX) May 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use VALUE_LOCATE instead of TABINV W. Landsman February 2001 +;- + On_error,2 + + if N_Params() LT 3 then begin + print,'Syntax: f = HERMITE( xx, ff, x, [FDERIV = ] )' + return,0 + endif + + n = N_elements(xx) ;Number of knot points + m = N_elements(x) ;Number of points at which to interpolate + + l = value_locate(xx,x) ;Integer index of interpolation points + + bad = where( (l LT 0) or (l EQ n-1), Nbad) + if Nbad GT 0 then message, 'ERROR - Valid interpolation range is ' + $ + strtrim(xx[0],2) + ' to ' + strtrim(xx[n-1],2) + + n1 = n - 1 + n2 = n - 2 + + l1 = l + 1 + l2 = l1 + 1 + lm1 = l - 1 + h1 = double(1./(xx[l] - xx[l1])) + h2 = - h1 + +; If derivatives were not supplied, then compute numeric derivatives at the +; two closest knot points + + if N_elements(fderiv) NE 0 then begin + f2 = fderiv[l1] + f1 = fderiv[l] + + endif else begin + + f1 = dblarr(m) + f2 = dblarr(m) + for i = 0,m-1 do begin + if l[i] ne 0 then begin + if l[i] lt n2 then begin + f2[i] = (ff[l2[i]] - ff[l[i]])/(xx[l2[i]]-xx[l[i]]) + endif else begin + f2[i] = (ff[n1] - ff[n2])/(xx[n1] - xx[n2]) + endelse + f1[i] = ( ff[l1[i]] - ff[lm1[i]] )/( xx[l1[i]] - xx[lm1[i]] ) + endif else begin + f1[i] = (ff[1] - ff[0])/(xx[1] - xx[0]) + f2[i] = (ff[2] - ff[0])/(xx[2] - xx[0]) + endelse + endfor + endelse + + xl1 = x - xx[l1] + xl = x - xx[l] + s1 = xl1*h1 + s2 = xl*h2 + +; Now finally the Hermite interpolation formula + + f = (ff[l]*(1.-2.*h1*xl) + f1*xl)*s1*s1 + $ + (ff[l1]*(1.-2.*h2*xl1) + f2*xl1)*s2*s2 + + if m eq 1 then return,f[0] else return,f + + end + diff --git a/modules/idl_downloads/astro/pro/heuler.pro b/modules/idl_downloads/astro/pro/heuler.pro new file mode 100644 index 0000000..2c7dd97 --- /dev/null +++ b/modules/idl_downloads/astro/pro/heuler.pro @@ -0,0 +1,169 @@ +pro heuler,h_or_astr, Galactic = galactic, celestial = celestial, $ + ecliptic = ecliptic, alt_in = alt_in, alt_out = alt_out +;+ +; NAME: +; HEULER +; +; PURPOSE: +; Change the coordinate system of a FITS header or astrometry structure +; EXPLANATION: +; Converts a FITS header or a astrometry structure containing WCS (world +; coordinate system) information between celestial, ecliptic, and +; Galactic coordinates +; +; CALLING SEQUENCE: +; HEULER, hdr, [/GALACTIC, /CELESTIAL, /ECLIPTIC, ALT_IN = , ALT_OUT=] +; or +; HEULER, astr, /GALACTIC, /CELESTIAL, /ECLIPTIC +; +; INPUT/OUTPUT PARAMETERS: +; hdr - FITS header (string array) containing WCS information +; or +; Astr - Astrometry structure as extracted from a FITS header +; by extast.pro (See EXTAST for more info). +; +; Header or astrometry structure will be modified by the program to +; contain astrometry in the new coordinates system. +; REQUIRED INPUT KEYWORDS: +; One of the following exclusive keywords is *required* +; /GALACTIC - Convert the header to Galactic coordinates +; /CELESTIAL - Convert the header to celestial (RA & Dec) coordinates +; /ECLIPTIC - Convert the header to ecliptic coordinates +; +; OPTIONAL INPUT KEYWORDS: +; The following two keywords apply if the FITS header contains multiple +; WCS keywords. See Section 3.3 of Greisen & Calabretta (2002, A&A, 395, +; 1061) for information about alternate astrometry keywords. +; +; ALT_IN - single character 'A' through 'Z' or ' ' specifying an +; alternate astrometry system present in the input FITS header. The +; default isto use the primary astrometry or ALT = ' '. If /ALT_IN +; is set, then this is equivalent to ALT_IN = 'A'. +; ALT_OUT - single character specifying the alternate WCS keywords +; to write the *output* astrometry. If not specified, then ALT_OUT +; is set equal to ALT_IN. +; RESTRICTIONS: +; Currently assumes that celestial and ecliptic coordinates are in +; J2000. Use HPRECESS if this is not the case. +; +; ST Guide Star (DSS) image headers are first converted to a standard +; tangent projection, prior to the coordinate conversion +; METHOD: +; The algorithm used is described in Section 2.7 of Calabretta & Greisen +; (2002, A&A, 395, 1077). The CRVAL coordinates are transformed +; directly using EULER. The new LONPOLE and LATPOLE values are then +; determined by transforming the pole of the new system to the old, and +; converted to native coordinates using WCS_ROTATE. +; EXAMPLE: +; A FITS header, hdr, has a standard tangent projection WCS information. +; Add an alternate 'G' Galactic projection. Note that the original +; WCS information will be left unchanged +; +; IDL> heuler, hdr, /Galactic, alt='G' +; PROCEDURES USED: +; EULER, EXTAST, GSSS_STDAST, PUTAST, SXADDHIST, WCS_ROTATE +; REVISION HISTORY: +; Written W. Landsman June 2003 +; Use PV2 tag in astrometry structure rather than PROJP1 W. L. May 2004 +; Use double precision to compute new North pole W.L. Aug 2005 +; Check for non-standard CTYPE value W.L. Sep 2012 +;- +compile_opt idl2 +if N_params() LT 1 then begin + print,'Syntax - HEULER, hdr, /GALACTIC, /CELESTIAL, /ECLIPTIC, ALT_IN=,' + return +endif +sz = size(h_or_astr,/str) +if (sz.type_name EQ 'STRING') && (sz.N_dimensions EQ 1) then begin + if N_elements(alt_out) EQ 0 then if N_elements(alt_in) NE 0 then $ + alt_out = alt_in + EXTAST,h_or_astr,astr,status, alt = alt_in + if status LT 0 then message, $ + 'ERROR - No astrometry present in supplied FITS header' else $ + if status EQ 4 then begin + GSSS_STDAST, h_or_astr + EXTAST, h_or_astr, astr, status, alt = alt_in + endif + + ctype1 = sxpar(h_or_astr,'CTYPE1') ;Check if non-standard CTYPE was used + if strmid(astr.ctype[0],5,3) NE strmid(ctype1,5,3) then $ + putast,h_or_astr,astr + +endif else if sz.type_name EQ 'STRUCT' then astr = h_or_astr else message, $ + 'ERROR - First parameter must be a FITS header or astrometry structure' + map_types=['DEF','AZP','SZP','TAN','STG','SIN','ARC','ZPN','ZEA','AIR','CYP',$ + 'CEA','CAR','MER','SFL','PAR','MOL','AIT','COP','COE','COD','COO',$ + 'BON','PCO','GLS','TSC','CSC','QSC'] + +ctype1 = astr.ctype[0] +ctype2 = astr.ctype[1] +; Use Table 13 of Calbretta & Greisen to determine default values of theta0 +coord = strmid(ctype1,0,4) +proj = strmid(ctype1,5,3) +imap = where(map_types EQ proj, N_imap) +if N_imap EQ 0 then message,'ERROR - Unrecognized map projection of ' + proj +imap = imap[0] +if imap LE 9 then theta0 = 90 else $ +if (imap GE 18) && (imap LE 21) then theta0 = astr.pv2[0] else theta0 = 0 + +if keyword_set(GALACTIC) then begin + case coord of + 'RA--': select= 1 + 'ELON': select = 5 + 'GLON': begin + message,/INF,'FITS header is already in Galactic: nothing changed' + return + end + end + strput,ctype1,'GLON' + strput,ctype2,'GLAT' + conv = 'Galactic' +endif else if keyword_set(CELESTIAL) then begin + case coord of + 'RA--': begin + message,/INF,'FITS header is already in Celestial: nothing changed' + return + end + 'ELON': select = 4 + 'GLON': select = 2 + end + strput,ctype1,'RA--' + strput,ctype2,'DEC-' + conv = 'Celestial' +endif else if keyword_set(ECLIPTIC) then begin + case coord of + 'RA--': select =3 + 'ELON': begin + message,/INF,'FITS header is already in Celestial: nothing changed' + return + end + 'GLON': select = 6 + endcase + strput,ctype1,'ELON' + strput,ctype2,'ELAT' + conv = 'Ecliptic' +endif else message, $ + 'Either /CELESTIAL, /GALACTIC or /ECLIPTIC keyword must be specified' + + + EULER,astr.crval[0],astr.crval[1],ncrval1,ncrval2,select + +;Find new LONPOLE and LATPOLE values + if select mod 2 eq 0 then iselect = select-1 else iselect = select+1 + EULER,0.0d,90.0d,lon1,lat1,iselect + WCS_ROTATE,lon1,lat1,lonpole, latpole, astr.crval,LONGPOLE = astr.longpole, $ + LATPOLE = astr.latpole, THETA0 = theta0 + +;Update astrometry structure + astr.ctype = [ctype1,ctype2] + astr.longpole = lonpole + astr.latpole = latpole + astr.crval = [ncrval1, ncrval2] + + if sz.type_name EQ 'STRING' then begin ;Update FITS header? + putast, h_or_astr, astr, alt = alt_out + sxaddhist, 'HEULER: ' + STRMID(systime(),4,20) + $ + ' Converted to ' + conv + ' coordinates', h_or_astr + endif else h_or_astr = astr + return + end diff --git a/modules/idl_downloads/astro/pro/hextract.pro b/modules/idl_downloads/astro/pro/hextract.pro new file mode 100644 index 0000000..111147a --- /dev/null +++ b/modules/idl_downloads/astro/pro/hextract.pro @@ -0,0 +1,205 @@ +pro hextract, oldim, oldhd, newim, newhd, x0, x1, y0, y1, SILENT = silent, $ + ERRMSG = errmsg,ALT = alt +;+ +; NAME: +; HEXTRACT +; PURPOSE: +; Extract a subimage from an array and update astrometry in FITS header +; EXPLANATION: +; Extract a subimage from an array and create a new FITS header with +; updated astrometry for the subarray +; CALLING SEQUENCE: +; HEXTRACT, Oldim, Oldhd, [ Newim, Newhd, x0, x1, y0, y1, /SILENT ] +; or +; HEXTRACT, Oldim, Oldhd, [x0, x1, y0, y1, /SILENT, ERRMSG = ] +; +; INPUTS: +; Oldim - the original image array +; Oldhd - the original image header +; +; OPTIONAL INPUTS: +; x0, x1, y0, y1 - respectively, first and last X pixel, and first and +; last Y pixel to be extracted from the original image, integer scalars. +; HEXTRACT will convert these values to long integers. +; If omitted, HEXTRACT will prompt for these parameters +; +; OPTIONAL OUTPUTS: +; Newim - the new subarray extracted from the original image +; Newhd - header for newim containing updated astrometry info +; If output parameters are not supplied or set equal to +; -1, then the HEXTRACT will modify the input parameters +; OLDIM and OLDHD to contain the subarray and updated header. +; +; OPTIONAL INPUT KEYWORD: +; ALT - Single character 'A' through 'Z' or ' ' specifying which astrometry +; system to modify in the FITS header. The default is to use the +; primary astrometry or ALT = ' '. See Greisen and Calabretta (2002) +; for information about alternate astrometry keywords. +; /SILENT - If set and non-zero, then a message describing the extraction +; is not printed at the terminal. This message can also be +; suppressed by setting !QUIET. +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; +; PROCEDURE: +; The FITS header parameters NAXIS1, NAXIS2, CRPIX1, and CRPIX2 are +; updated for the extracted image. +; +; EXAMPLE: +; Read an image from a FITS file 'IMAGE', extract a 512 x 512 subimage +; with the same origin, and write to a new FITS file 'IMAGENEW' +; +; IDL> im = READFITS( 'IMAGE', hdr ) ;Read FITS files into IDL arrays +; IDL> hextract, im, h, 0, 511, 0, 511 ;Extract 512 x 512 subimage +; IDL> writefits, 'IMAGENEW', im ,h ;Write subimage to a FITS file +; +; PROCEDURES CALLED +; CHECK_FITS, STRN(), SXPAR(), SXADDPAR, SXADDHIST +; MODIFICATION HISTORY: +; Written, Aug. 1986 W. Landsman, STX Corp. +; Use astrometry structure, W. Landsman Jan, 1994 +; Minor fix if bad Y range supplied W. Landsman Feb, 1996 +; Added /SILENT keyword W. Landsman March, 1997 +; Added ERRMSG keyword W. Landsman May 2000 +; Work for dimensions larger than 32767 W.L., M.Symeonidis Mar 2007 +; Added ALT keyword W.L. April 2007 +; Use V6.0 notation W.L. October 2012 +; Fix for SFL projection W.L. September 2015 +;- + On_error, 2 + compile_opt idl2 + npar = N_params() + + if (npar EQ 3) || (npar LT 2) then begin ;Check # of parameters + print,'Syntax - HEXTRACT, oldim, oldhd, [ newim, newhd, x0, x1, y0, y1]' + print,' or HEXTRACT, oldim, oldhd, x0, x1, y0, y1, [/SILENT, ERRMSG=]' + return + endif + + save_err = arg_present(errmsg) ;Does user want to return error messages? +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + xsize = dimen[0] & ysize = dimen[1] + + + if ( npar LT 4 ) then Update = 1 else Update = 0 ;Update old array? + + if ( npar EQ 6 ) then begin ;Alternative calling sequence ? + + if ( N_elements(newim) EQ 1 ) && ( N_elements(newhd) EQ 1 ) && $ + ( N_elements(x0) EQ 1 ) && ( N_elements(x1) EQ 1 ) then begin + y0 = x0 & y1 = x1 + x0 = newim & x1 = newhd + Update = 1 + endif + + endif + + RDX: + if ( npar LE 5 ) then begin + + message, /INF, $ + 'Original array size is ' + strn(xsize) + ' by ' + strn(ysize) + x0 = 0l & x1 = 0l + read,'% HEXTRACT: Enter first and last X pixel to be extracted: ',x0,x1 + + endif + + if ( x1 LT x0 ) || ( x0 LT 0 ) || ( x1 GE xsize ) then begin + + message,'ERROR - Illegal pixel range: X direction', /CON + print, ' ' + message, /INF, $ + ' Legal Range is 0 < First Pixel < Last Pixel < ' + strn(xsize-1) + if update then npar = npar < 2 else npar = npar < 4 + goto, RDX + + endif + + RDY: if (~update && ( npar LE 7 )) || (update && (npar LT 6) ) then $ + read,'% HEXTRACT: Enter first and last Y pixel to be extracted: ',y0,y1 + + if ( y1 LT y0 ) || ( y0 LT 0 ) || ( y1 GE ysize ) then begin + + message,'ERROR - Illegal pixel range: Y direction', /CON + message, /INF, $ + 'Legal Range is 0 < First Pixel < Last Pixel < ' + strn(ysize-1) + if update then npar = npar < 4 else npar = npar < 6 + goto, RDY + + endif + + x0 = long(x0) & x1 = long(x1) + y0 = long(y0) & y1 = long(y1) + + naxis1 = x1 - x0 + 1 + naxis2 = y1 - y0 + 1 ;New dimensions + + if ~keyword_set(SILENT) then message, /INF, $ + 'Now extracting a '+ strn(naxis1) + ' by ' + strn(naxis2) + ' subarray' + + if Update then oldim = oldim[ x0:x1,y0:y1 ] $ + else newim = oldim[ x0:x1,y0:y1 ] + + newhd = oldhd + sxaddpar, newhd, 'NAXIS1', naxis1 + sxaddpar, newhd, 'NAXIS2', naxis2 + label = 'HEXTRACT: ' + systime(0) + + hist = [label,'Original image size was '+ strn(xsize) + ' by ' + strn(ysize), $ + 'Extracted Image: [' + strn(x0) + ':'+ strn(x1) + $ + ',' + strn(y0) + ':'+ strn(y1) + ']' ] + + sxaddhist, hist, newhd + + +;GSSS image uses CNPIX instead of CRPIX + cnpix1 = sxpar( oldhd, 'CNPIX1', COUNT = Ncnpix1) + if ( Ncnpix1 EQ 1 ) then begin ;Shift position of reference pixel + + sxaddpar, newhd, 'CNPIX1', cnpix1+x0 + cnpix2 = sxpar( oldhd, 'CNPIX2' ) + sxaddpar, newhd, 'CNPIX2', cnpix2+y0 + endif + +; Update astrometry info if it exists + + if N_elements(alt) EQ 0 then alt = '' + extast, newhd, astr, noparams, ALT = alt + + if noparams GE 0 then begin +;Handle SFL projection separately in case it was originally GLS + if astr.projection EQ 'SFL' then begin + crpix = sxpar(newhd,'CRPIX*') + sxaddpar,newhd,'CRPIX1'+alt,crpix[0]-x0 + sxaddpar,newhd,'CRPIX2'+alt,crpix[1]-y0 + endif else begin + sxaddpar, newhd, 'CRPIX1'+alt, astr.crpix[0]-x0 + sxaddpar, newhd, 'CRPIX2'+alt, astr.crpix[1]-y0 + endelse + + endif + if Update then begin + + oldhd = newhd + newim = x0 & newhd = x1 + x0 = y0 & x1 = y1 + + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/hgrep.pro b/modules/idl_downloads/astro/pro/hgrep.pro new file mode 100644 index 0000000..b998f5d --- /dev/null +++ b/modules/idl_downloads/astro/pro/hgrep.pro @@ -0,0 +1,65 @@ +pro hgrep, header, substring, keepcase=keepcase, linenum=linenum + +;+ +; NAME: +; HGREP +; +; PURPOSE: +; Find a substring in a FITS header (or any other string array) +; +; CALLING SEQUENCE: +; HGREP, header, substring, [/KEEPCASE, /LINENUM ] +; +; INPUTS: +; header - FITS header or other string array +; substring - scalar string to find in header; if a numeric value is +; supplied, it will be converted to type string +; +; OPTIONAL INPUT KEYWORDS: +; /KEEPCASE: if set, then look for an exact match of the input substring +; Default is to ignore case . +; /LINENUM: if set, prints line number of header in which +; substring appears +; +; OUTPUTS: +; None, results are printed to screen +; +; EXAMPLE: +; Find every place in a FITS header that the word 'aperture' +; appears in lower case letters and print the element number +; of the header array: +; +; IDL> hgrep, header, 'aperture', /keepcase, /linenum +; +; HISTORY: +; Written, Wayne Landsman (Raytheon ITSS) August 1998 +; Adapted from STIS version by Phil Plait/ ACC November 14, 1997 +; Remove trailing spaces if a non-string is supplied W. Landsman Jun 2002 +;- + + if (N_params() LT 2) then begin + print,'Syntax - HGREP, header, substring, [/KEEPCASE, /LINENUM ]' + return + endif + + if N_elements(header) eq 0 then begin + print,'first parameter not defined. Returning...' + return + endif + hh = strtrim(header,2) + if size(substring,/tname) NE 'STRING' then substring = strtrim(substring,2) + + if keyword_set(keepcase) then $ + flag = strpos(hh,substring) $ + else flag = strpos(strlowcase(hh),strlowcase(substring)) + + + g = where(flag NE -1, Ng) + if Ng GT 0 then $ + if keyword_set(linenum) then $ + for i = 0, Ng-1 do print, string(g[i],f='(i4)') + ': ' + hh[g[i]] $ + else $ + for i = 0, Ng-1 do print,hh[g[i]] + + return + end diff --git a/modules/idl_downloads/astro/pro/histogauss.pro b/modules/idl_downloads/astro/pro/histogauss.pro new file mode 100644 index 0000000..1c7401b --- /dev/null +++ b/modules/idl_downloads/astro/pro/histogauss.pro @@ -0,0 +1,196 @@ +PRO HISTOGAUSS,SAMPLE,A,XX,YY,GX,GY,NOPLOT=noplot,NOFIT=SIMPL, $ + CHARSIZE=CSIZE, FONT=font, _EXTRA = _extra,Window=window +; +;+ +;NAME: +; HISTOGAUSS +; +; PURPOSE: +; Histograms data and overlays it with a Gaussian. Draws the mean, sigma, +; and number of points on the plot. +; +; CALLING SEQUENCE: +; HISTOGAUSS, Sample, A, [XX, YY, GX, GY, /NOPLOT, /NOFIT, FONT=, +; CHARSIZE = ] +; +; INPUT: +; SAMPLE = Vector to be histogrammed +; +; OUTPUT ARGUMENTS: +; A = coefficients of the Gaussian fit: Height, mean, sigma +; A[0]= the height of the Gaussian +; A[1]= the mean +; A[2]= the standard deviation +; A[3]= the half-width of the 95% conf. interval of the standard +; mean +; A[4]= 1/(N-1)*total( (y-mean)/sigma)^2 ) = a measure of +; normality +; +; Below: superceded. The formula is not entirely reliable. +; A[4]= measure of the normality of the distribution. =1.0, perfectly +; normal. If no more than a few hundred points are input, there are +; formulae for the 90 and 95% confidence intervals of this quantity: +; M=ALOG10(N-1) ; N = number of points +; T90=ABS(.6376-1.1535*M+.1266*M^2) ; = 90% confidence interval +; IF N LT 50 THEN T95=ABS(-1.9065-2.5465*M+.5652*M^2) $ +; ELSE T95=ABS( 0.7824-1.1021*M+.1021*M^2) ;95% conf. +; (From Martinez, J. and Iglewicz, I., 1981, Biometrika, 68, 331-333.) +; +; XX = the X coordinates of the histogram bins (CENTER) +; YY = the Y coordinates of the histogram bins +; GX = the X coordinates of the Gaussian fit +; GY = the Y coordinates of the Gaussian fit +; +; OPTIONAL INPUT KEYWORDS: +; /NOPLOT - If set, nothing is drawn +; /FITIT If set, a Gaussian is actually fitted to the distribution. +; By default, a Gaussian with the same mean and sigma is drawn; +; the height is the only free parameter. +; CHARSIZE Size of the characters in the annotation. Default = 0.82. +; FONT - scalar font graphics keyword (-1,0 or 1) for text +; /WINDOW - set to plot to a resizeable graphics window +; _EXTRA - Any value keywords to the cgPLOT command (e.g. XTITLE) may also +; be passed to HISTOGAUSS +; SUBROUTINE CALLS: +; BIWEIGHT_MEAN, which determines the mean and std. dev. +; AUTOHIST, which draws the histogram +; GAUSSFIT() (IDL Library) which does just that +; +; REVISION HISTORY: +; Written, H. Freudenreich, STX, 12/89 +; More quantities returned in A, 2/94, HF +; Added NOPLOT keyword and print if Gaussian, 3/94 +; Stopped printing confidence limits on normality 3/31/94 HF +; Added CHARSIZE keyword, changed annotation format, 8/94 HF +; Simplified calculation of Gaussian height, 5/95 HF +; Convert to V5.0, use T_CVF instead of STUDENT_T, GAUSSFIT instead of +; FITAGAUSS W. Landsman April 2002 +; Correct call to T_CVF for calculation of A[3], 95% confidence interval +; P. Broos/W. Landsman July 2003 +; Allow FONT keyword to be passed. T. Robishaw Apr. 2006 +; Use Coyote Graphics for plotting W.L. Mar 2011 +; Better formatting of text output W.L. May 2012 +;- + + On_error,2 + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - HISTOGAUSS, Sample, A, [XX, YY, GX, GY, ' + print,' /NOPLOT, /NOFIT, CHARSIZE=, Plotting keywords...]' + return + endif + + if (N_elements(FONT) eq 0) then font = !p.font + DATA = SAMPLE + N = N_ELEMENTS(DATA) + +; First make sure that not everything is in the same bin. If most +; data = 0, reject zeroes. If they = some other value, complain and +; give up. + A = 0. + DATA = DATA[SORT(DATA)] + N3 = 0.75*N & N1 = 0.25*N +IF DATA[N3] EQ DATA[N1] THEN BEGIN + IF DATA[N/2] EQ 0. THEN BEGIN + Q = WHERE(DATA NE 0.,NON0) + IF (N-NON0) GT 15 THEN BEGIN + message,/INF,'Suppressing Zeroes!' + DATA=DATA[Q] + N=NON0 + ENDIF ELSE BEGIN + message,' Too Few Non-0 Values!',/CON + RETURN + ENDELSE + Q=0 + ENDIF ELSE BEGIN + message,/CON,' Too Many Identical Values: ' + strtrim(DATA[N/2],2) + RETURN + ENDELSE +ENDIF + +A = FLTARR(5) + +; The "mean": +A[1] = BIWEIGHT_MEAN(DATA,S) +; The "standard deviation": +A[2] = S +; The 95% confidence interval: +M=.7*(N-1) ;appropriate for a biweighted mean +CL = 0.95 +two_tail_area = 1 - CL +A[3]=ABS( T_CVF(1 - (two_tail_area)/2.0,M) )*S/sqrt(n) + +; A measure of the Gaussianness: +A[4]=TOTAL((DATA-A[1])^2)/((N-1)*A[2]^2) +;Q=WHERE( ABS(DATA-A(1)) LT (5.*S), COUNT ) ; "robust I" unreliable +;ROB_I=TOTAL((DATA(Q)-A(1))^2)/((COUNT-1)*A(2)^2) +;PRINT,A(4),ROB_I + +; Set bounds on the data: + U1 = A[1] - 5.*A[2] + U2 = A[1] + 5.*A[2] + Q = WHERE(DATA LT U1, NQ) + IF NQ GT 0 THEN DATA[Q] = U1 + Q = WHERE(DATA GT U2, NQ) + IF NQ GT 0 THEN DATA[Q] = U2 + +; Draw the histogram + font_in = !P.FONT & !P.FONT=font + AUTOHIST,DATA,X,Y,XX,YY,NOPLOT = noplot, _EXTRA = _extra,Window=window + !P.FONT=font_in + +; Check for error in AUTOHIST: + +M = N_ELEMENTS(X) +MM = N_ELEMENTS(XX) +IF M LT 2 THEN BEGIN + XX=0. & YY=0. & A=0. + RETURN ; (AUTOHIST has already screamed) +ENDIF + +; Calculate the height of the Gaussian: +Z = EXP(-.5*(X-A[1])^2/A[2]^2 ) +XQ1 = A[1] - 1.3*A[2] +XQ2 = A[1] + 1.3*A[2] +QQ = WHERE((X GT XQ1) AND (X LT XQ2),COUNT) +IF COUNT GT 0 THEN HYTE = MEDIAN(Y[QQ]/Z[QQ],/EVEN) ELSE BEGIN + print,'HISTOGAUSS: Distribution too Weird!' + HYTE = MAX(SMOOTH(Y,5)) +ENDELSE +A[0]=HYTE + +; Fit a Gaussian, unless the /NOFIT qualifier is present +IF ~KEYWORD_SET(SIMPL) THEN BEGIN + PARM=A[0:2] + YFIT = GAUSSFIT(XX,YY,PARM,NTERMS=3) + A[0:2]=PARM +ENDIF + +; It the /NOPLOT qualifier is present, we're done. +IF KEYWORD_SET(NOPLOT) THEN RETURN + +; Overplot the Gaussian, + DU = (U2-U1)/199. + GX = U1 + FINDGEN(200)*DU + + Z = (GX-A[1])/A[2] + GY = A[0]*EXP(-Z^2/2. ) + cgplot,/over,GX,GY,window=window + +; Annotate. +MEANST = STRING(A[1],'(G12.5)') +SIGST = STRING(A[2],'(G12.5)') +NUM = N_ELEMENTS(DATA) +NUMST =STRING(N,'(I6)') + +IF KEYWORD_SET(CSIZE) THEN ANNOT=CSIZE ELSE ANNOT=.82 + if FONT EQ 0 then LABL = '#, !Mm!X, !Ms!X=' else LABL='#, !7l!6, !7r!3=' + LABL = LABL +numst+','+meanst+','+sigst +X1 = !x.crange[0] + annot*(!x.crange[1]-!x.crange[0])/20./0.82 +y1 = !y.crange[1] - annot*(!y.crange[1]-!y.crange[0])/23./0.82 +cgtext, X1, Y1, LABL, CHARSIZE=ANNOT, FONT=font,window=window + +RETURN +END + diff --git a/modules/idl_downloads/astro/pro/hor2eq.pro b/modules/idl_downloads/astro/pro/hor2eq.pro new file mode 100644 index 0000000..e7b086a --- /dev/null +++ b/modules/idl_downloads/astro/pro/hor2eq.pro @@ -0,0 +1,256 @@ +;+ +; NAME: +; HOR2EQ +; +; PURPOSE: +; Converts local horizon coords (alt-az) of something to equatorial (ra-dec). +; +; EXPLANATION: +; This is a nice code to calculate equatorial (ra,dec) coordinates from +; horizon (alt,az) coords. It is typically accurate to about 1 arcsecond +; or better (I have checked the output against the publicly available XEPHEM +; software). It performs precession, nutation, aberration, and refraction +; corrections. The perhaps best thing about it is that it can take arrays +; as inputs, in all variables and keywords EXCEPT Lat, lon, and Altitude +; (the code assumes these aren't changing), and uses vector arithmetic in +; every calculation except when calculating the precession matrices. +; +; CALLING SEQUENCE: +; +; HOR2EQ, alt, az, jd, ra, dec, [ha, LAT= , LON= , /WS, OBSNAME= , $ +; /B1950 , PRECESS_= 0, NUTATE_= 0, REFRACT_= 0, $ +; ABERRATION_= 0, ALTITUDE= , /VERBOSE, _EXTRA= ] +; +; +; INPUT VARIABLES +; alt : altitude (in degrees) [scalar or vector] +; az : azimuth angle (in degrees, measured EAST from NORTH, but see +; keyword WS below.) [scalar or vector] +; JD : Julian Date [scalar or vector], double precision + +; Note: if RA and DEC are arrays, then alt and az will also be arrays. +; If RA and DEC are arrays, JD may be a scalar OR an array of +; the same dimensionality. +; +; OPTIONAL INPUT KEYWORDS: +; lat : north geodetic latitude of location in degrees +; lon : EAST longitude of location in degrees +; (Specify west longitude with a negative sign.) +; /WS : Set this to get the azimuth measured westward from south +; (not East of North). +; obsname : Set this to a valid observatory name to be used by the +; astrolib OBSERVATORY procedure, which will return the latitude +; and longitude to be used by this program. +; /B1950 : Set this if your ra and dec are specified in B1950, +; FK4 coordinates (instead of J2000, FK5) +; precess_ : Set this to 1 to force precession [default], 0 for no +; precession. +; nutate_ : Set this to 1 to force nutation [default], 0 for no nutation. +; aberration_ : Set this to 1 to force aberration correction [default], +; 0 for no correction. +; refract_ : Set to 1 to force refraction correction [default], 0 for +; no correction. +; altitude: The altitude of the observing location, in meters. [default=0]. +; /verbose: Set this for verbose output. The default is verbose=0. +; _extra: This is for setting TEMPERATURE or PRESSURE explicitly, which are +; used by CO_REFRACT to calculate the refraction effect of the +; atmosphere. If you don't set these, the program will make an +; intelligent guess as to what they are (taking into account your +; altitude). See CO_REFRACT for more details. +; +; OUTPUT VARIABLES +; ra : Right Ascension of object (J2000) in degrees (FK5); scalar or +; vector. +; dec : Declination of object (J2000) in degrees (FK5), scalar or vector. +; ha : hour angle (in degrees) (optional) +; +; DEPENDENCIES: +; NUTATE, PRECESS, ADSTRING(), SUNPOS, OBSERVATORY (from the astrolib) +; CO_NUTATE, CO_ABERRATION, CO_REFRACT, HADEC2ALTAZ +; +; BASIC STEPS +; Precess Ra-Dec to current equinox. +; Nutation Correction to Ra-Dec +; Aberration correction to Ra-Dec +; Calculate Local Mean Sidereal Time +; Calculate Local Apparent Sidereal Time +; Calculate Hour Angle +; Do Spherical Trig to find Apparent Alt-Az +; Apply refraction correction to find observed Alt. +; +;CORRECTIONS I DO NOT MAKE: +; * Deflection of Light by the sun due to GR. (typically milliarcseconds, +; can be arcseconds within one degree of the sun) +; * The Effect of Annual Parallax (typically < 1 arcsecond) +; * and more (see below) +; +; TO DO +; * Better Refraction Correction. Need to put in wavelength dependence, +; and integrate through the atmosphere. +; * Topocentric Parallax Correction (will take into account elevation of +; the observatory) +; * Proper Motion (but this will require crazy lookup tables or something). +; * Difference between UTC and UT1 in determining LAST -- is this important? +; * Effect of Annual Parallax (is this the same as topocentric Parallax?) +; * Polar Motion +; * Better connection to Julian Date Calculator. +; +; EXAMPLE: +; +; You are at Kitt Peak National Observatory, looking at a star at azimuth +; angle 264d 55m 06s and elevation 37d 54m 41s (in the visible). Today is +; Dec 25, 2041 and the local time is 10 PM precisely. What is the ra and dec +; (J2000) of the star you're looking at? The temperature here is about 0 +; Celsius, and the pressure is 781 millibars. The Julian date for this +; time is 2466879.7083333 +; +; IDL> hor2eq, ten(37,54,41), ten(264,55,06), 2466879.7083333d, ra, dec, $ +; /verb, obs='kpno', pres=781.0, temp=273.0 +; +; The program produces this output (because the VERBOSE keyword was set): +; +; Latitude = +31 57 48.0 Longitude = *** 36 0.0 ; longitude prints weirdly b/c of negative input to ADSTRING!! +; Julian Date = 2466879.708333 +; Az, El = 17 39 40.4 +37 54 41.0 (Observer Coords) +; Az, El = 17 39 40.4 +37 53 39.6 (Apparent Coords) +; LMST = +03 53 54.1 +; LAST = +03 53 53.6 +; Hour Angle = +03 38 30.1 (hh:mm:ss) +; Ra, Dec: 00 15 23.5 +15 25 1.9 (Apparent Coords) +; Ra, Dec: 00 15 24.2 +15 25 0.1 (J2041.9841) +; Ra, Dec: 00 13 14.1 +15 11 0.3 (J2000) +; +; The star is therefore Algenib! Compare the derived Ra, Dec with what XEPHEM +; got: +; Ra, Dec: 00 13 14.2 +15 11 1.0 (J2000) +; +; AUTHOR: +; Chris O'Dell +; Assistant Professor of Atmospheric Science +; Colorado State University +; Email: odell@atmos.colostate.edu +; REVISION HISTORY: +; Made all integers type LONG W. Landsman September 2007 +; Fixed for case of scalar Julian date but vector positions W L June 2009 +;- + +pro hor2eq, alt, az, jd, ra, dec, ha, lat=lat, lon=lon, WS=WS, obsname=obsname,$ + B1950 = B1950, verbose=verbose, precess_=precess_, nutate_=nutate_, $ + refract_ = refract_, aberration_ = aberration_, altitude=altitude, $ + _extra = _extra + + On_error,2 + compile_opt idl2 + if N_params() LT 4 then begin + print,'Syntax - HOR2EQ, alt, az, jd, ra, dec, [ha, LAT= , LON= , /WS, ' + print,' OBSNAME= ,/B1950 , PRECESS_= 0, NUTATE_= 0, REFRACT_= 0, ' + print,' ABERRATION_= 0, ALTITUDE= , /VERBOSE, TEMPERATURE=, PRESSURE=' + return + endif +;******************************************************************************* +; INITIALIZE STUFF + +; If no lat or lng entered, use Pine Bluff Observatory values +if n_elements(lat) eq 0 then lat = 43.0783d +; (btw, this is the declination of the zenith) +if n_elements(lon) eq 0 then lon = -89.865d + +if keyword_set(obsname) then begin + ;override lat,lon if observatory name has been specified + Observatory, obsname, obs + lat = obs.latitude + lon = -1*obs.longitude ; minus sign is becase OBSERVATORY uses west +; ;longitude as positive. + altitude = obs.altitude +endif + +if n_elements(precess_) eq 0 then precess_ = 1 +if n_elements(nutate_) eq 0 then nutate_ = 1 +if n_elements(aberration_) eq 0 then aberration_ = 1 +if n_elements(refract_) eq 0 then refract_ = 1 +v = keyword_set(verbose) + +; conversion factors +d2r = !dpi/180. +h2d = 15. + +alt_ = alt ;do this so we don't change ra, dec arrays. +az_ = az + +if v then print, 'Latitude = ', adstring(lat), ' Longitude = ', adstring(lon) +if v then print, 'Julian Date = ', jd, format='(A,f15.6)' +if v then print,'Az, El = ', adstring(az_, alt_), ' (Observer Coords)' + +;******************************************************************************************* +; Make Correction for ATMOSPHERIC REFRACTION +; (use this for visible and radio wavelengths; author is unsure about other wavelengths) +if refract_ then alt_ = co_refract(alt_, altitude=altitude, _extra=_extra) +if v then print,'Az, El = ', adstring(az_, alt_), ' (Apparent Coords)' + +if keyword_set(WS) then az_ = az_ - 180. + +co_nutate, jd, 45.,45., dra1, ddec1, eps=eps, d_psi=d_psi + +;****************************************************************************** +;Calculate LOCAL APPARENT SIDEREAL TIME +; first get local mean sidereal time (lmst) +; get LST (in hours) - note:this is indep of tzone since giving jd +ct2lst, lmst, lon, 0, jd +lmst = lmst*h2d ; convert LMST to degrees (btw, this is the RA of the zenith) +; calculate local APPARENT sidereal time (last) +last = lmst + d_psi *cos(eps)/3600. ; add correction in degrees +if v then print, 'LMST = ', adstring(lmst/15.) +if v then print, 'LAST = ', adstring(last/15.) + +;**************************************************************************** +; Now do the spherical trig to get APPARENT Hour Angle [degrees], and +; declination [degrees]. +altaz2hadec, alt_, az_, lat, ha, dec + +; Find Right Ascension (in degrees, from 0 to 360.) + ra = (last - ha + 360.) mod 360. + +if v then print, 'Hour Angle = ', adstring(ha/15.), ' (hh:mm:ss)' +if v then print, 'Ra, Dec: ', adstring(ra,dec), ' (Apparent Coords)' + + +;***************************************************************************** +; calculate NUTATION and ABERRATION Corrections to Ra-Dec +co_nutate, jd, ra, dec, dra1, ddec1, eps=eps, d_psi=d_psi +co_aberration, jd, ra, dec, dra2, ddec2, eps=eps + +;****************************************************************************** +; Make Nutation and Aberration Corrections (if wanted) +ra = ra - (dra1*nutate_ + dra2*aberration_)/3600. +dec = dec - (ddec1*nutate_ + ddec2*aberration_)/3600. +J_now = (JD - 2451545.)/365.25 + 2000.0 ; compute current equinox +Njd = N_elements(J_now) +Npos = N_elements(ra) +if (Njd EQ 1) and (Npos GT 1) then J_now = replicate(J_now, Npos) +if v then print, 'Ra, Dec: ', adstring(ra,dec), ' (J'+ $ + strcompress(string(J_now),/rem)+')' + +;***************************************************************************** +; PRECESS coordinates to current date +; (uses astro lib procedure PRECESS.pro) + +if precess_ then begin + if keyword_set(B1950) then begin + for i=0, Npos-1 do begin + ra_i = ra[i] & dec_i = dec[i] + precess, ra_i, dec_i, J_now[i], 1950.0, /FK4 + ra[i] = ra_i & dec[i] = dec_i + endfor + endif else begin + for i=0, Npos-1 do begin + ra_i = ra[i] & dec_i = dec[i] + precess, ra_i, dec_i, J_now[i], 2000.0 + ra[i] = ra_i & dec[i] = dec_i + endfor + endelse +endif +if keyword_set(B1950) then s_now=' (J1950)' else s_now=' (J2000)' +if v then print, 'Ra, Dec: ', adstring(ra,dec), s_now + +Return +END diff --git a/modules/idl_downloads/astro/pro/host_to_ieee.pro b/modules/idl_downloads/astro/pro/host_to_ieee.pro new file mode 100644 index 0000000..ff17e00 --- /dev/null +++ b/modules/idl_downloads/astro/pro/host_to_ieee.pro @@ -0,0 +1,98 @@ +pro host_to_ieee, data, IDLTYPE = idltype +;+ +; NAME: +; HOST_TO_IEEE +; PURPOSE: +; Translate an IDL variable from host to IEEE representation +; EXPLANATION: +; The variable is converted from the format used by the host architecture +; into IEEE-754 representation ("big endian" as used, e.g., in FITS data ). +; +; Duplicates most of the functionality of the SWAP_ENDIAN_INPLACE procedure +; with the addition of the IDLTYPE keyword. +; CALLING SEQUENCE: +; HOST_TO_IEEE, data, [ IDLTYPE = ] +; +; INPUT-OUTPUT PARAMETERS: +; data - any IDL variable, scalar or vector. It will be modified by +; HOST_TO_IEEE to convert from host to IEEE representation. Byte +; and string variables are returned by HOST_TO_IEEE unchanged +; +; OPTIONAL KEYWORD INPUTS: +; IDLTYPE - scalar integer (1-15) specifying the IDL datatype according +; to the code given by the SIZE function. This keyword +; will usually be used when supplying a byte array that needs +; to be interpreted as another data type (e.g. FLOAT). +; +; EXAMPLE: +; Suppose FITARR is a 2880 element byte array to be converted to a FITS +; record and interpreted a FLOAT data. +; +; IDL> host_to_ieee, FITARR, IDLTYPE = 4 +; +; METHOD: +; The BYTEORDER procedure is called with the appropriate keywords +; +; MODIFICATION HISTORY: +; Adapted from CONV_UNIX_VAX, W. Landsman Hughes/STX January, 1992 +; Added new integer datatypes C. Markwardt/W. Landsman July 2000 +; Use /SWAP_IF_LITTLE_ENDIAN keyword for 64bit types W. Landsman Feb 2003 +; Do not use XDR keywords to BYTEORDER for much improved speed +; W. Landsman April 2006 +;- + On_error,2 + + if N_params() EQ 0 then begin + print,'Syntax - HOST_TO_IEEE, data, [IDLTYPE = ]' + return + endif + + npts = N_elements( data ) + if npts EQ 0 then $ + message,'ERROR - IDL data variable (first parameter) not defined' + + if N_elements( idltype) EQ 0 then idltype = size(data,/type) + + case idltype of + + 1: return ;byte + + 2: byteorder, data, /SSWAP,/SWAP_IF_LITTLE ;integer + + 3: byteorder, data, /LSWAP,/SWAP_IF_LITTLE ;long + + 4: byteorder, data, /LSWAP, /SWAP_IF_LITTLE ;float + + 5: byteorder,data,/L64SWAP, /SWAP_IF_LITTLE ;double + + 6: byteorder, data, /LSWAP, /SWAP_IF_LITTLE + + 7: return ;string + + 8: BEGIN ;structure + + Ntag = N_tags( data ) + + for t=0,Ntag-1 do begin + temp = data.(t) + host_to_ieee, temp + data.(t) = temp + endfor + END + + 9: byteorder, data, /L64SWAP, /SWAP_IF_LITTLE + + 12: byteorder, data, /SSWAP, /SWAP_IF_LITTLE + + 13: byteorder, data, /LSWAP, /SWAP_IF_LITTLE + + 14: byteorder, data, /L64swap, /SWAP_IF_LITTLE + + 15: byteorder, data, /L64swap, /SWAP_IF_LITTLE + + else: message,'Unrecognized datatype ' + strtrim(idltype,2) + + ENDCASE + + return + end diff --git a/modules/idl_downloads/astro/pro/hprecess.pro b/modules/idl_downloads/astro/pro/hprecess.pro new file mode 100644 index 0000000..6dc544c --- /dev/null +++ b/modules/idl_downloads/astro/pro/hprecess.pro @@ -0,0 +1,134 @@ +PRO HPRECESS, HDR, YEARF +;+ +; NAME: +; HPRECESS +; PURPOSE: +; Precess the astrometry in a FITS header to a new equinox +; +; CALLING SEQUENCE: +; HPRECESS, HDR, [ yearf ] +; +; INPUT-OUTPUT: +; HDR - FITS Header, must contain the CRVAL astrometry keywords, +; and either an EPOCH or EQUINOX keyword. +; HDR will be modified to contain the precessed astrometry +; +; OPTIONAL INPUT: +; YEARF - Scalar, giving the year of the new (Final) equinox. +; If not supplied, user will be prompted for this value. +; +; METHOD: +; The CRVAL and CD (or CROTA) keywords are extracted from the header +; and precessed to the new equinox. The EPOCH or EQUINOX keyword in +; the header is updated. A HISTORY record is added +; +; RESTRICTIONS: +; The FK5 reference frame is assumed for both equinoxes. +; +; PROCEDURES USED: +; EXTAST, GET_EQUINOX(), SXADDPAR, SXADDHIST, PRECESS, PRECESS_CD +; PUTAST, ZPARCHECK +; REVISION HISTORY: +; Written W. Landsman STX July, 1988 +; CD matrix precessed - February, 1989 +; Update EQUINOX keyword when CROTA2 present November, 1992 +; Recognize a GSSS header June, 1994 +; Additional Noparams value recognize for storing CDs. RSH, 6 Apr 95 +; Understand reversed X,Y (X-Dec, Y-RA) axes, W. Landsman October 1998 +; Correct algorithm when CROTA2 is in header W. Landsman April 2006 +; Correct sign error introduced April 2006, include CDELT values +; when computing rotation of pole W. Landsman July 2007 +; Call hprecess/jprecess for 1950<>2000 W. L. Aug 2009 +; Work when ASTR.LONGPOLE NE 180.0 W.L. Aug 2014 +;- + On_error, 2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - HPRECESS, hdr, [ yearf]' + return + endif else zparcheck, 'HPRECESS', hdr, 1, 7, 1, 'FITS Header Array' + + yeari = GET_EQUINOX( hdr, code) ;YEAR of Initial equinox + if code EQ -1 then $ + message,'Header does not contain EPOCH or EQUINOX keyword' + + if N_params() LT 2 then begin + print, 'HPRECESS: Astrometry in supplied header is in equinox ', $ + strtrim(yeari,2) + read, 'Enter year of new equinox: ',yearf + endif + + if yeari EQ yearf then $ + message,'Astrometry in header is already in Equinox ' + strtrim(YEARF,2) + + extast, hdr, astr, noparams ;Extract astrometry from header + + if noparams EQ -1 THEN $ + message,'FITS Header does not contain CRVAL keywords' + + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + gsss_stdast, hdr + extast, hdr, astr, noparams + endif + + ctype1 = sxpar(hdr,'CTYPE1') ;Check if non-standard CTYPE was used + if strmid(astr.ctype[0],5,3) NE strmid(ctype1,5,3) then putast,hdr,astr + + cd = astr.cd + crval = astr.crval + cdelt = astr.cdelt + if N_elements(CDELT) GE 2 then if (cdelt[0] NE 1.0) then begin + cd[0,0] = cd[0,0]*cdelt[0] & cd[0,1] = cd[0,1]*cdelt[0] + cd[1,1] = cd[1,1]*cdelt[1] & cd[1,0] = cd[1,0]*cdelt[1] + endif + + coord = strmid(astr.ctype,0,4) ;Test if RA and Dec reversed in 'CTYPE*' + reverse = ((coord[0] EQ 'DEC-') and (coord[1] EQ 'RA--')) + if reverse then crval = rotate(crval,2) + a = crval[0] & d = crval[1] + if (yeari EQ 2000.) and (yearf EQ 1950.) then begin + bprecess,a,d,ai,di + sxaddpar,hdr,'RADECSYS','FK4' + a = ai & d = di + endif else if (yeari EQ 1950) && (yearf EQ 2000) then begin + jprecess,a,d,ai,di + sxaddpar,hdr,'RADECSYS','FK5' + a = ai & d = di + + endif else precess, a, d, yeari, yearf ;Precess the CRVAL coordinates + + precess_cd, cd, yeari, yearf, crval,[ a, d] ;Precess the CD matrix + if N_elements(CDELT) GE 2 then if (cdelt[0] NE 1.0) then begin + cd[0,0] = cd[0,0]/cdelt[0] & cd[0,1] = cd[0,1]/cdelt[0] + cd[1,1] = cd[1,1]/cdelt[1] & cd[1,0] = cd[1,0]/cdelt[1] + endif + + + if reverse then begin ;Update CRVAL values + sxaddpar, hdr, 'CRVAL1', double(d) + sxaddpar, hdr, 'CRVAL2', double(a) + endif else begin + sxaddpar, hdr, 'CRVAL1', double(a) + sxaddpar, hdr, 'CRVAL2', double(d) + endelse + + if (noparams EQ 3) || (noparams EQ 2) then begin + + putast, hdr, cd, EQUINOX = float(yearf) ;Update CD values + endif else begin ;or CROTA2 value + astr.cd= cd + getrot, astr, ROT + if astr.longpole NE 180.0 then rot -= 180.0d - astr.longpole + sxaddpar,hdr, 'EQUINOX', yearf, ' Equinox of Ref. Coord.', 'HISTORY' + sxaddpar, hdr, 'CROTA2', rot + endelse + + + + sxaddhist, 'HPRECESS: ' + STRMID(systime(),4,20) + $ + ' Astrometry Precessed From Year' + string(form='(f7.1)',float(yeari)),hdr + message, 'Header astrometry has been precessed to ' + strtrim(yearf,2),/INF + + return + end diff --git a/modules/idl_downloads/astro/pro/hprint.pro b/modules/idl_downloads/astro/pro/hprint.pro new file mode 100644 index 0000000..6b587e4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hprint.pro @@ -0,0 +1,100 @@ +pro hprint, h, firstline +;+ +; NAME: +; HPRINT +; PURPOSE: +; Display a FITS header (or other string array) +; EXPLANATION: +; On a GUI terminal, the string array is displayed using XDISPSTR. +; If printing at a non-GUI terminal, the string array is printed 1 line +; at a time, to make sure that each element of the string array is +; displayed on a separate line. +; +; CALLING SEQUENCE: +; HPRINT, h, [ firstline ] +; +; INPUTS: +; H - FITS header (or any other string array). +; +; OPTIONAL INPUT: +; FIRSTLINE - scalar integer specifying the first line to begin +; displaying. The default is FIRSTLINE = 1, i.e. display +; all the lines. If Firstline is negative, then the first +; line to be printed is counted backward from the last line. +; +; NOTES: +; When displaying at the terminal, HPRINT has the following differences +; from the intrinsic PRINT procedure +; +; (1) Arrays are printed one line at a time to avoid a space between 80 +; character lines +; (2) Lines are trimmed with STRTRIM before being printed to speed up +; display +; (3) The /more option is used for output. +; +; EXAMPLE: +; Read the header from a FITS file named 'test.fits' and display it at the +; terminal beginning with line 50 +; +; IDL> h = headfits( 'test.fits') ;Read FITS header +; IDL> hprint, h, 50 ;Display starting at line 50 +; +; To print the last 25 lines of the header +; +; IDL> hprint, h, -25 +; +; REVISION HISTORY: +; Written W. Landsman July, 1990 +; Added test for user quit July, 1991 +; Added optional FIRSTLINE parameter November, 1992 +; Modified for when STDOUT is not a TTY W. Landsman September 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fixed printing in IDLDE, C. Gehman August, 1998 +; Skip PRINTF if IDL in demo mode W. Landsman October 2004 +; Fixed bug on non-terminals, William Thompson, 18-Oct-2004 +; Assume since V5.4 Use BREAK instead of GOTO W. Landsman Apr 2006 +; Call XDISPSTR on a GUI terminal W. Landsman Jun 2006 +;- + On_error,2 ;Return to Caller + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - HPRINT, h, [ firstline ]' + return + endif + + n = N_elements(h) + if ( n EQ 0 ) then $ ;Make sure input array is defined + message,'String array (first parameter) not defined' + + if N_elements( firstline ) EQ 0 then firstline = 1 + if ( firstline[0] LT 0 ) then firstline = ( n + firstline[0]) > 1 < n $ + else firstline = firstline[0] > 1 < n + + stdout = fstat(-1) + if stdout.isagui then begin + xdispstr,h,tit='HPRINT',top_line=firstline-1 + return + endif + if lmgr(/demo) then begin ;in demo mode? + for i=firstline-1, n-1 do print,h[i] + return + endif + + +; Now print the array one line at a time + if (stdout.isatty) then begin ;Open with /MORE if a TTY + + openw, outunit, filepath(/TERMINAL), /MORE, /GET_LUN + for i = firstline-1, n-1 do begin + + printf, outunit, strtrim( h[i] ) + if !ERR EQ 1 then BREAK ;User entered "Q" in response to /more + + endfor + free_lun, outunit + + endif else printf,-1,strtrim(h[firstline-1:*]), FORMAT='(A)' + + return + end diff --git a/modules/idl_downloads/astro/pro/hrebin.pro b/modules/idl_downloads/astro/pro/hrebin.pro new file mode 100644 index 0000000..86b3ec2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hrebin.pro @@ -0,0 +1,277 @@ + pro hrebin, oldim, oldhd, newim, newhd, newx, newy, TOTAL = total, $ + SAMPLE=sample, OUTSIZE = outsize, ERRMSG = errmsg, ALT=alt +;+ +; NAME: +; HREBIN +; PURPOSE: +; Expand or contract a FITS image using (F)REBIN and update the header +; EXPLANATION: +; If the output size is an exact multiple of the input size then REBIN is +; used, else FREBIN is used. User can either overwrite the input array, +; or write to new variables. By default, the counts/pixel is preserved, +; though one can preserve the total counts or surface flux by setting /TOTAL +; +; CALLING SEQUENCE: +; HREBIN, oldhd ;Special calling sequence to just update header +; HREBIN, oldim, oldhd, [ newim, newhd, newx, newy, OUTSIZE = ,/SAMPLE, +; ERRMSG = ] +; +; INPUTS: +; OLDIM - the original image array +; OLDHD - the original image FITS header, string array +; +; OPTIONAL INPUTS: +; NEWX - size of the new image in the X direction, integer scalar +; NEWY - size of the new image in the Y direction, integer scalar +; HREBIN will prompt for NEWX and NEWY if not supplied +; +; OPTIONAL OUTPUTS: +; NEWIM - the image after expansion or contraction with REBIN +; NEWHD - header for newim containing updated astrometry info +; If output parameters are not supplied, the program will modify +; the input parameters OLDIM and OLDHD to contain the new array and +; updated header. +; +; OPTIONAL INPUT KEYWORDS: +; ALT - Single character 'A' through 'Z' or ' ' specifying which astrometry +; system to modify in the FITS header. The default is to use the +; primary astrometry of ALT = ' '. See Greisen and Calabretta (2002) +; for information about alternate astrometry keywords. +; +; OUTSIZE - Two element integer vector which can be used instead of the +; NEWX and NEWY parameters to specify the output image dimensions +; +; /SAMPLE - Expansion or contraction is done using REBIN which uses +; bilinear interpolation when magnifying and boxaveraging when +; minifying. If the SAMPLE keyword is supplied and non-zero, +; then nearest neighbor sampling is used in both cases. Keyword +; has no effect when output size is not a multiple of input size. +; +; /TOTAL - If set then the output image will have the same total number of counts +; as the input image. Because HREBIN also updates the astrometry, +; use of the TOTAL keyword also preserves counts per surface area, e.g. +; counts/(arc sec)@ +; +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; PROCEDURE: +; The parameters BSCALE, NAXIS1, NAXIS2, CRPIX1, and CRPIX2 and the CD +; (or CDELT) parameters are updated for the new FITS header. +; +; EXAMPLE: +; Compress a 2048 x 2048 image array IM, with FITS header HDR, to a +; 724 x 724 array. Overwrite the input variables with the compressed +; image and header. +; +; IDL> hrebin, im, hdr, OUT = [724, 724] +; +; PROCEDURES USED: +; CHECK_FITS, EXTAST, FREBIN, GSSS_STDAST, STRN(), SXPAR(), SXADDHIST, +; SXADDPAR, ZPARCHECK +; +; MODIFICATION HISTORY: +; Written, December 1990 W. Landsman, ST System Corp. +; Update CD1_1 keywords W. Landsman November 1992 +; Check for a GSSS header W. Landsman June 1994 +; Update BSCALE even if no astrometry present W. Landsman May 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use FREBIN to accept sizes that are not a integer multiple of the original +; size W. Landsman August 1998 +; Correct for "edge" effects when expanding with REBIN W. Landsman Apr. 1999 +; Fixed initialization of header only call broken in Apr 98 change May. 1999 +; Remove reference to obsolete !ERR W. Landsman February 2000 +; Use double precision formatting for CD matrix W. Landsman April 2000 +; Recognize PC00n00m astrometry format W. Landsman December 2001 +; Correct astrometry for integral contraction W. Landsman April 2002 +; Fix output astrometry for non-equal plate scales for PC matrix or +; CROTA2 keyword, added ALT keyword. W. Landsman May 2005 +; Update distortion parameters if present W. Landsman August 2007 +; Don't update BSCALE/BZERO for unsigned integer W.Landsman Mar 2008 +; Use post-V6.0 notation W. Landsman Nov 2011 +; Write CRPIX values as double precision if necessary W. Landsman Oct. 2012 +; Always call FREBIN, added TOTAL keyword W. Landsman Nov 2015 +;- + On_error,2 + compile_opt idl2 + + npar = N_params() ;Check # of parameters + if (npar EQ 3) || (npar EQ 5) || (npar EQ 0) then begin + print,'Syntax - HREBIN, oldim, oldhd,[ newim, newhd, OUTSIZE=, ' + $ + '/SAMPLE, ERRMSG= ]' + return + endif + + if ~keyword_set(SAMPLE) then sample = 0 + save_err = arg_present(errmsg) ;Does user want to return error messages? + +; If only 1 parameter is supplied, then assume it is a FITS header + + if ( npar EQ 1 ) then begin + + zparcheck, 'HREBIN', oldim, 1, 7, 1, 'Image header' + oldhd = oldim + xsize = sxpar( oldhd,'NAXIS1' ) + ysize = sxpar( oldhd,'NAXIS2' ) + + endif else begin + + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + if N_elements(dimen) NE 2 then begin + errmsg = 'Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + xsize = dimen[0] & ysize = dimen[1] + endelse + tname = size(oldim,/tname) + + if ( npar LT 6 ) then begin + + if ( N_elements(OUTSIZE) NE 2 ) then begin + tit = !MSG_PREFIX + 'HREBIN: ' + print, tit, 'Original array size is '+ strn(xsize) + ' by ' + strn(ysize) + read, tit + 'Enter size of new image in the X direction: ',newx + read, tit + 'Enter size of new image in the Y direction: ',newy + endif else begin + newx = outsize[0] + newy = outsize[1] + endelse + + endif + +; Modified Nov 2015 to alway call FREBIN. FREBIN() will call the IDL REBIN() +; function if we are changing dimensions by an exact multiple. + + if npar GT 1 then begin + + if npar GT 2 then newim = frebin( oldim, newx, newy,total=total) $ + else oldim = frebin( oldim, newx, newy,total=total) + endif + + + if ( sample GT 0 ) then type = ' Nearest Neighbor Approximation' else begin + if ( newx LT xsize ) then type = ' Box Averaging' else $ + type = ' Bilinear Interpolation' + endelse + + newhd = oldhd + sxaddpar, newhd, 'NAXIS1', fix(newx) + sxaddpar, newhd, 'NAXIS2', fix(newy) + label = 'HREBIN: '+ strmid( systime(),4,20 ) + sxaddpar,newhd,'history',label + ' Original Image Size Was '+ $ + strn(xsize) +' by ' + strn(ysize) + if ( npar GT 1 ) then sxaddpar,newhd,'history',label+type + + xratio = float(newx) / xsize ;Expansion or contraction in X + yratio = float(newy) / ysize ;Expansion or contraction in Y + lambda = yratio/xratio ;Measures change in aspect ratio. + pix_ratio = xratio*yratio ;Ratio of pixel areas + + +; Update astrometry info if it exists + + extast, newhd, astr, noparams, ALT = alt + if noparams GE 0 then begin + + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + gsss_stdast, newhd + extast, newhd, astr, noparams + endif + + +; Correct the position of the reference pixel. Note that CRPIX values are +; given in FORTRAN (first pixel is (1,1)) convention + + crpix = astr.crpix + +; When expanding with REBIN with bilinear interpolation (SAMPLE = 0), edge +; effects are introduced, which require a different calculation of the updated +; CRPIX1 and CRPIX2 values. + +exact = (~(xsize mod newx) || ~(newx mod xsize)) && $ + (~(ysize mod newy) || ~(newy mod ysize)) + if (exact) && (~keyword_set(SAMPLE)) && (xratio GT 1) then $ + crpix1 = (crpix[0]-1.0)*xratio + 1.0 else $ + crpix1 = (crpix[0]-0.5)*xratio + 0.5 + + if (exact) && (~keyword_set(SAMPLE)) && (yratio GT 1) then $ + crpix2 = (crpix[1]-1.0)*yratio + 1.0 else $ + crpix2 = (crpix[1]-0.5)*yratio + 0.5 + + if N_elements(alt) EQ 0 then alt = '' + sxaddpar, newhd, 'CRPIX1' + alt, crpix1 + sxaddpar, newhd, 'CRPIX2' + alt, crpix2 + + if tag_exist(astr,'DISTORT') then begin + distort = astr.distort + message,'Updating SIP distortion parameters',/INF + update_distort,distort, [1./xratio,0],[1./yratio,0] + astr.distort= distort + add_distort, newhd, astr + endif + + + +; Scale either the CDELT parameters or the CD1_1 parameters. + + if (noparams NE 2) then begin + + cdelt = astr.cdelt + sxaddpar, newhd, 'CDELT1' + alt, CDELT[0]/xratio + sxaddpar, newhd, 'CDELT2' + alt, CDELT[1]/yratio +; Adjust the PC matrix if aspect ratio has changed. See equation 187 in +; Calabretta & Greisen (2002) + if lambda NE 1.0 then begin + cd = astr.cd + if noparams EQ 1 then begin +;Can no longer use the simple CROTA2 convention, change to PC keywords + sxaddpar,newhd,'PC1_1'+alt, cd[0,0] + sxaddpar, newhd,'PC2_2'+alt, cd[1,1] + sxdelpar, newhd, ['CROTA2','CROTA1'] + endif + sxaddpar, newhd, 'PC1_2'+alt, cd[0,1]/lambda + sxaddpar, newhd, 'PC2_1'+alt, cd[1,0]*lambda + endif + + endif else begin ;CDn_m Matrix format + + cd = astr.cd + sxaddpar, newhd, 'CD1_1'+alt, cd[0,0]/xratio + sxaddpar, newhd, 'CD1_2'+alt, cd[0,1]/yratio + sxaddpar, newhd, 'CD2_1'+alt, cd[1,0]/xratio + sxaddpar, newhd, 'CD2_2'+alt, cd[1,1]/yratio + + endelse + endif + +; Adjust BZERO and BSCALE for new pixel size, unless these values are used +; to define unsigned integer data types. + + if ~keyword_set(TOTAL) then begin + bscale = sxpar( oldhd, 'BSCALE') + bzero = sxpar( oldhd, 'BZERO') + unsgn = (tname EQ 'UINT') || (tname EQ 'ULONG') + + if ~unsgn then begin + if (bscale NE 0) && (bscale NE 1) then $ + sxaddpar, newhd, 'BSCALE', bscale/pix_ratio, 'Calibration Factor' + if (bzero NE 0) then sxaddpar, newhd, 'BZERO', bzero/pix_ratio, $ + ' Additive Constant for Calibration' + endif + endif + + pixelsiz = sxpar( oldhd,'PIXELSIZ' , Count = N_pixelsiz) + if N_pixelsiz GT 0 then sxaddpar, newhd, 'PIXELSIZ', pixelsiz/xratio + + if npar EQ 2 then oldhd = newhd else $ + if npar EQ 1 then oldim = newhd + + return + end diff --git a/modules/idl_downloads/astro/pro/hreverse.pro b/modules/idl_downloads/astro/pro/hreverse.pro new file mode 100644 index 0000000..446008e --- /dev/null +++ b/modules/idl_downloads/astro/pro/hreverse.pro @@ -0,0 +1,165 @@ +pro hreverse, oldim, oldhd, newim, newhd, subs, SILENT = silent, ERRMSG= errmsg +;+ +; NAME: +; HREVERSE +; PURPOSE: +; Reverse an image about either dimension and update FITS astrometry +; EXPLANATION: +; Reverse an image about either the X or Y axis, and create a new +; header with updated astrometry for the reversed image. +; +; CALLING SEQUENCE: +; HREVERSE,oldim,oldhd, [ subs, /SILENT ] ;Update input image and header +; or +; HREVERSE, oldim, oldhd, newim, newhd, [ subs, /SILENT ] +; +; INPUTS: +; OLDIM - the original image array +; OLDHD - the original image header +; +; OPTIONAL INPUTS: +; SUBS - Subs equals 1 to reverse the order of the X dimension, +; 2 to reverse Y order. If omitted, then HREVERSE will +; prompt for this scalar parameter. +; +; OPTIONAL OUTPUTS: +; NEWIM - the rotated image, with the same dimensions as Oldim +; NEWHD - header for newim containing updated astrometry info +; If output parameters are not supplied, the program +; will modify the input parameters OLDIM and OLDHD +; to contain the rotated image and updated header. +; +; OPTIONAL KEYWORD INPUT: +; SILENT - if set and non-zero, then informative messages are suppressed. +; +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; +; SIDE EFFECTS: +; A right-handed coordinate system is converted into a left- +; handed one, and vice-versa. +; +; PROCEDURE: +; The User's Library procedure REVERSE is used to reverse the image. +; The CD and CRPIX header parameters are updated for the new header. +; For AIPS type astrometry, the CDELT parameters are also updated. +; A history record is also added to the header +; +; PROCEDURES USED: +; CHECK_FITS, EXTAST, REVERSE(), STRN(), SXADDPAR +; MODIFICATION HISTORY: +; Written, Aug. 1986 W. Landsman, STI Corp. +; Error modifying CROTA angles corrected 9-23-88 +; Added format keyword, J. Isensee, July, 1990 +; Work for ST Guide Star images, W. Landsman HSTX, May 1995 +; Compute CRPIX1 correctly for X reversal W. Landsman HSTX August 1995 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added ERRMSG, Use double precision formatting, W. Landsman April 2000 +; Recognize PC00n00m astrometry matrix W. Landsman December 2001 +; Use V6.0 notation W. Landsman October 2012 +;- + On_error, 2 + npar = N_params() + if npar LE 1 then begin + print,'Syntax: HREVERSE, oldim, oldhd, [ subs, /SILENT, ERRMSG = ]' + print,' or HREVERSE, oldim, oldhd, newim, newhd, [ subs, /SILENT]' + return + endif + + save_err = arg_present(errmsg) ;Does user want error msgs returned? +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'ERROR - Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + xsize = dimen[0] & ysize = dimen[1] + + if npar EQ 3 then subs = newim + READSUBS: if (npar NE 3) && (npar NE 5) then $ + read,'Enter 1 to reverse X dimension, 2 to reverse Y dimension: ',subs + if ( subs NE 2 ) && ( subs NE 1 ) then begin + message,'ERROR - Illegal Value of Subs parameter',/CON + if npar then npar = npar -1 ;Make npar even + goto, READSUBS + endif + + newhd = oldhd + axis_name = ['X','Y'] + if ~keyword_set(SILENT) then message, /INF, $ +'Now reversing ' + strn(xsize) + ' by ' + strn(ysize) + ' image about ' + $ + axis_name[subs-1] + ' dimension' + +if npar GE 4 then newim = reverse( oldim,subs ) else $ + oldim = reverse( oldim,subs ) + + label = 'HREVERSE: ' + strmid(systime(),4,20) + sxaddpar, newhd, 'HISTORY', label+ $ + ' Reversed About '+ axis_name[SUBS-1] + ' Dimension' + +; Update astrometry info if it exists + + extast, oldhd, astr, noparams + if noparams LT 0 then goto, DONE + + if subs EQ 1 then begin + + if strmid( astr.ctype[0],5,3) EQ 'GSS' then begin + cnpix = -astr.xll -xsize + sxaddpar, newhd, 'CNPIX1', cnpix + sxaddpar, newhd, 'XPIXELSZ', -astr.xsz + endif else begin + crpix1 = xsize - (astr.crpix[0]-1) + sxaddpar, newhd, 'CRPIX1', crpix1 + + if (noparams LT 2) || (noparams EQ 3) then $ + sxaddpar, newhd, 'CDELT1', -astr.cdelt[0] $ + + else begin ;If so, then convert them + + sxaddpar, newhd, 'CD1_1', -astr.cd[0,0] + sxaddpar, newhd, 'CD2_1', -astr.cd[1,0] + + endelse + endelse + + endif else begin + + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + + cnpix = -astr.yll -ysize + sxaddpar, newhd, 'CNPIX2', cnpix + sxaddpar, newhd, 'YPIXELSZ', -astr.ysz + + endif else begin + crpix2 = ysize - (astr.crpix[1]-1) + sxaddpar, newhd, 'CRPIX2', crpix2 + + if (noparams LT 2) or (noparams EQ 3) then $ + sxaddpar, newhd, 'CDELT2', -astr.cdelt[1] $ + + else begin ;If so, then convert them + + sxaddpar, newhd, 'CD1_2', -astr.cd[0,1] + sxaddpar, newhd, 'CD2_2', -astr.cd[1,1] + + endelse + endelse + + endelse + +DONE: + if npar LE 3 then oldhd = newhd ;update old header + +return +end diff --git a/modules/idl_downloads/astro/pro/hrot.pro b/modules/idl_downloads/astro/pro/hrot.pro new file mode 100644 index 0000000..f905ffe --- /dev/null +++ b/modules/idl_downloads/astro/pro/hrot.pro @@ -0,0 +1,251 @@ +pro hrot, oldim, oldhd, newim, newhd, angle, xc, yc, int, MISSING=missing, $ + INTERP = interp, CUBIC = cubic, PIVOT = pivot,ERRMSG= errmsg +;+ +; NAME: +; HROT +; PURPOSE: +; Rotate an image and create new FITS header with updated astrometry. +; EXPLANATION: +; Cubic, bilinear or nearest neighbor interpolation can be used. +; +; CALLING SEQUENCE: +; HROT, oldim, oldhd, [ newim, newhd, angle, xc, yc, int, +; MISSING =, INTERP =, CUBIC = , /PIVOT] +; INPUTS: +; OLDIM - the original image array +; OLDHD - the original FITS image header, string array +; +; OPTIONAL INPUTS: +; NEWIM - If NEWIM is set to -1, then the old image and header will +; be updated +; ANGLE - Rotation angle, degrees clockwise, scalar +; XC - X Center of rotation (-1 for center of image) +; YC - Y Center of rotation (-1 for center of image) +; INT - 0 for nearest neighbor, 1 for bilinear interpolation +; 2 for cubic interpolation. +; +; OPTIONAL OUTPUTS: +; NEWIM - the rotated image, with the same dimensions as Oldim +; NEWHD - header for newim containing updated astrometry info +; If output parameters are not supplied, the program +; will modify the input parameters OLDIM and OLDHD +; to contain the rotated image and updated header. +; +; OPTIONAL INPUT KEYWORD: +; MISSING - Set this keyword to a scalar value which will be assigned +; to pixels in the output image which do not correspond to +; existing input images (e.g if one rotates off-center). +; If not supplied then linear extrapolation is used. +; ***NOTE: A bug was introduced into the POLY_2D function in IDL +; V5.5 (fixed in V6.1) such that the MISSING keyword +; may not work properly with floating point data*** +; +; INTERP - scalar set to either 0 (nearest neighbor interpolation), +; 1 (bilinear interpolation), or 2 (cubic interpolation). +; The interpolation type can be specified by either the INTERP +; keyword or the int parameter +; +; CUBIC - If set and non-zero then cubic interpolation is used (see ROT), +; which is equivalent to setting INT = 2. In IDL V5.0 and later, +; this keyword can also be set to a value between -1 and 0. +; +; /PIVOT - Setting this keyword causes the image to pivot around the point +; XC, YC, so that this point maps into the same point in the +; output image. If this keyword is set to 0 or omitted, then the +; point XC, YC in the input image is mapped into the center of +; the output image. +; +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; EXAMPLE: +; Rotate an image non-interactively 30 degrees clockwise. Use +; bilinear interpolation, and set missing values to 0. +; +; IDL> HROT, im_old, h_old, im_new, h_new, 30, -1, -1, 1, MIS = 0 +; +; As above but update the input image and header and pivot about (100,120) +; +; IDL> HROT, im_old, h_old, -1, -1, 30, 100, 120, 1, MIS = 0, /PIVOT +; RESTRICTIONS: +; Unlike the ROT procedure, HROT cannot be used to magnify or +; or demagnify an image. Use HCONGRID or HREBIN instead. +; +; PROCEDURE: +; The image array is rotated using the ROT procedure. +; The CD (or CROTA) and CRPIX parameters, if present in the FITS header, +; are updated for the new rotation. +; History records are also added to the header +; +; PROCEDURES USED: +; CHECK_FITS, EXTAST, GETOPT(), GETROT, ROT(), STRN(), SXADDPAR +; +; MODIFICATION HISTORY: +; Written, Aug. 1986 W. Landsman, ST Systems Corp. +; Added MISSING keyword, W. Landsman March, 1991 +; Added cubic interpolation, use astrometry structure Feb 1994 +; Removed call to SINCE_VERSION() W. Landsman March 1996 +; Assume at least V3.5, add CUBIC parameter W. Landsman March 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fix for CROTA2 defined and CDELT1 NE CDELT2, W. Landsman November 1998 +; Fix documentation to specify clockwise rotation W. Landsman Dec. 1999 +; Added /PIVOT keyword W. Landsman January 2000 +; Added ERRMSG, Use double precision formatting, W. Landsman April 2000 +; Consistent conversion between CROTA and CD matrix W. Landsman Oct 2000 +; Work for both CD001001 and CDELT defined W. Landsman March 2001 +; Recognize PC matrix astrometry W. Landsman December 2001 +; Update astrometry correctly when /PIVOT applied W. Landsman March 2002 +; Update CROTA2 astrometry correctly, approximate GSSS W.L. June 2003 +; Work with CD1_1, PC1_1 and CROTA keywords W. L. July 2003 +; Work with angle as a 1 element vector W.L. May 2006 +;- + On_error,2 + compile_opt idl2 + npar = N_params() + + if (npar LT 2) or (npar EQ 3) then begin ;Check # of parameters + print,'Syntax: HROT, oldim, oldhd, [ newim, newhd, angle, xc, yc, int,' + print,' CUBIC =, INTERP = , MISSING = ,/PIVOT, ERRMSG= ]' + print, 'Oldim and Oldhd will be updated if only 2 parameters supplied ' + return + endif + + cdr = !DPI/180.0D ;Change degrees to radians +; Check that input header matches input image + save_err = arg_present(errmsg) ;Does user want error msgs returned? +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'ERROR - Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + xsize = dimen[0] & ysize = dimen[1] + + xc_new = (xsize - 1)/2. + yc_new = (ysize - 1)/2. + if npar LT 8 then begin + if npar EQ 2 then print,'Program will modify old image and header' + print,'Original array size is '+ strn(xsize) + ' by ' + strn(ysize) + read,'Angle of rotation (degrees clockwise): ',angle + ans = '' + read,'Enter center (x,y) of rotation ( [RETURN] for center of image): ',ans + center = getopt(ans,'F',2) + if N_elements(center) EQ 1 then begin + xc = -1 & yc = -1 + endif else begin + xc = center[0] & yc = center[1] + endelse + endif + + if keyword_set( INTERP ) then int = interp + if keyword_set( CUBIC ) then int = 2 + if N_elements(int) NE 1 then $ + read,'Enter 0 for nearest neighbor, 1 for bilinear, 2 for cubic interpolation: ',int + + case int of + 0: type = ' Nearest Neighbor Approximation' + 1: type = ' Bilinear Interpolation' + 2: type = ' Cubic Interpolation' + else: message,'Illegal value of Interp parameter: must be 0,1, or 2' + endcase + + if xc LT 0 then xc = xc_new + if yc LT 0 then yc = yc_new + + if N_elements(newim) EQ 1 then $ + if newim EQ -1 then npar = 2 + + newhd = oldhd + if N_elements(cubic) EQ 0 then cubic = (int EQ 2) + angle = angle[0] + + if N_elements(MISSING) NE 1 then begin + + if npar EQ 2 then begin + oldim = rot( oldim, angle, 1, xc,yc, $ + CUBIC = cubic, INTERP = int, PIVOT = pivot) + endif else begin + newim = rot( oldim, angle, 1, xc,yc, $ + CUBIC = cubic, INTERP = int, PIVOT = pivot) + endelse + + endif else begin + + if npar EQ 2 then begin + oldim = rot( oldim,angle,1,xc,yc, $ + CUBIC = cubic, MISSING = missing, INTERP = int, PIVOT = pivot) + endif else begin + newim = rot( oldim, angle, 1, xc, yc, $ + CUBIC = cubic, MISSING = missing, INTERP = int, PIVOT = pivot) + endelse + endelse + + label = 'HROT:' + strmid(systime(),4,20) + sxaddpar, newhd, 'HISTORY', label + $ + ' Rotated by' + string(float(angle), FORM = '(f7.2)') + ' Degrees' + sxaddpar,newhd,'history',label+type + +; Update astrometry info if it exists + + extast, oldhd, astr, noparams + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + gsss_stdast, newhd + extast, newhd, astr, noparams + endif + + + if noparams GE 0 then begin ;Astrometry parameters exist in header? + crpix = astr.crpix + cd = astr.cd + cdelt = astr.cdelt + + theta = angle*cdr + rot_mat = [ [ cos(theta), sin(theta)], $ ;Rotation matrix + [-sin(theta), cos(theta)] ] + + ncrpix = transpose(rot_mat)#(crpix-1-[xc,yc]) + 1 + if ~keyword_set(PIVOT) then ncrpix = [xc_new,yc_new] + ncrpix $ + else ncrpix = [xc,yc] + ncrpix + sxaddpar, newhd, 'CRPIX1', ncrpix[0] + sxaddpar, newhd, 'CRPIX2', ncrpix[1] + + newcd = cd # rot_mat + + if noparams EQ 3 then begin ;Transformation matrix format + + sxaddpar, newhd, 'PC1_1', newcd[0,0] + sxaddpar, newhd, 'PC1_2', newcd[0,1] + sxaddpar, newhd, 'PC2_1', newcd[1,0] + sxaddpar, newhd, 'PC2_2', newcd[1,1] + + + endif else if noparams EQ 2 then begin + + sxaddpar, newhd, 'CD1_1', newcd[0,0] + sxaddpar, newhd, 'CD1_2', newcd[0,1] + sxaddpar, newhd, 'CD2_1', newcd[1,0] + sxaddpar, newhd, 'CD2_2', newcd[1,1] + + endif else begin +; Just need to update the CROTA keywords + crota = atan( -newcd[1,0],newcd[1,1] )*180.0/!DPI + sxaddpar, newhd,'CROTA1', crota + sxaddpar, newhd,'CROTA2', crota + + endelse + + endif + + if npar eq 2 then oldhd = newhd ;update old image and header + + return + end diff --git a/modules/idl_downloads/astro/pro/hrotate.pro b/modules/idl_downloads/astro/pro/hrotate.pro new file mode 100644 index 0000000..ac20f84 --- /dev/null +++ b/modules/idl_downloads/astro/pro/hrotate.pro @@ -0,0 +1,214 @@ +pro hrotate, oldim, oldhd, newim, newhd, direction,ERRMSG = errmsg +;+ +; NAME: +; HROTATE +; PURPOSE: +; Apply the IDL ROTATE function and update astrometry in a FITS header +; EXPLANATION: +; Apply the intrinsic IDL ROTATE function to an image and update +; astrometry in the associated FITS header. +; +; CALLING SEQUENCE: +; HROTATE, oldim, oldhd, newim, newhd, direction +; or +; HROTATE, oldim, oldhd, direction +; +; INPUTS: +; OLDIM - the original image array +; OLDHD - the original FITS image header, string array +; DIRECTION - Scalar integer (0-7) specifying rotation direction, +; exactly as specified by the IDL ROTATE function. +; +; Direction Transpose? Rot. CCW X1 Y1 +; ---------------------------------------- +; 0 No None X0 Y0 (no change) +; 1 No 90 -Y0 X0 +; 2 No 180 -X0 -Y0 +; 3 No 270 Y0 -X0 +; 4 Yes None Y0 X0 +; 5 Yes 90 -X0 Y0 +; 6 Yes 180 -Y0 -X0 +; 7 Yes 270 X0 -Y0 +; +; OPTIONAL OUTPUTS: +; NEWIM - the rotated image, with the same dimensions as Oldim +; NEWHD - header for newim containing updated astrometry info +; If output parameters are not supplied, the program +; will modify the input parameters OLDIM and OLDHD +; to contain the rotated image and updated header. +; +; OPTIONAL KEYWORD OUTPUT: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; EXAMPLE: +; Rotate an image exactly 90 degrees counterclockwise and update the +; FITS image array and header. +; +; IDL> HROT, im, h, im_new, h_new, 1 +; +; PROCEDURE: +; The image array is rotated using the ROTATE function. +; The CD (or CROTA) and CRPIX parameters, if present in the FITS header, +; are updated for the new rotation. +; History records are also added to the header +; +; RESTRICTIONS: +; Does not work Guide Star Survey (GSS) astrometry. Use GSSS_STDAST to +; first convert +; PROCEDURES USED: +; CHECK_FITS(), SXADDPAR, EXTAST +; +; MODIFICATION HISTORY: +; Written, Mar 1997 W. Landsman, Hughes STX +; Work for non-square images W. Landsman June 1998 Raytheon STX +; Fix for different plate scales, and CROTA2 defined, November 1998 +; Added ERRMSG, Use double precision formatting, W. Landsman April 2000 +; Consistent conversion between CROTA and CD matrix W. Landsman Oct 2000 +; Correct update when CROTA keyword present W. Landsman June 2003 +; Update CDELT for AIPS-style astrometry headers M. Perrin/WL Jul 2003 +; Convert GSS astrometry to WCS W. Landsman November 2004 +; Work even if no astrometry present, just update NAXIS* WL June 2011 +;- + On_error,2 + npar = N_params() + + if (npar NE 3) and (npar NE 5) then begin ;Check # of parameters + print,'Syntax - HROTATE, oldim, oldhd, newim, newhd, direction' + print,' or ' + print,' HROTATE, oldim, oldhd, direction, {ERRMSG = ]' + return + endif + + if npar EQ 3 then direction = newim + if N_elements(direction) NE 1 then message, $ + 'ERROR - Direction parameter must be an integer scalar (0-7)' + dirpar = direction mod 8 + if dirpar LT 0 then dirpar = dirpar + 8 + +; Check that input header matches input image + + save_err = arg_present(errmsg) ;Does user want error msgs returned? +; Check for valid 2-D image & header + check_FITS, oldim, oldhd, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then begin + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then begin + errmsg = 'ERROR - Input image array must be 2-dimensional' + if ~save_err then message,'ERROR - ' + errmsg,/CON + return + endif + + if N_elements(dimen) NE 2 then message, $ + 'ERROR - Input image array must be 2-dimensional' + xsize = dimen[0] & ysize = dimen[1] + xc = (xsize-1)/2. + yc = (ysize-1)/2. + + newhd = oldhd + + if npar EQ 5 then newim = rotate(oldim, direction ) else $ + oldim = rotate(oldim, direction ) + + case dirpar of + 0: return + 1: rot_mat = [ [0, 1],[-1, 0] ] + 2: rot_mat = [ [-1,0],[ 0,-1] ] + 3: rot_mat = [ [0,-1], [1, 0] ] + 4: rot_mat = [ [0, 1], [-1,0] ] + 5: rot_mat = [ [-1,0], [0, -1] ] + 6: rot_mat = [ [0,-1], [1, 0] ] + 7: rot_mat = [ [1, 0], [0, 1] ] + else: message,$ + 'ERROR - Illegal value of direction parameter, must be between 0 and 7' + endcase + + if (xsize NE ysize) && (rot_mat[0,0] EQ 0) then begin + sxaddpar, newhd, 'NAXIS1', ysize + sxaddpar, newhd, 'NAXIS2', xsize + endif + + label = 'HROTATE: ' + strmid(systime(),4,20) + sxaddhist, label + ' Image = ROTATE(Image,' + strtrim(direction,2) + ')',newhd + +; Update astrometry info if it exists. If GSS astrometry is present, then +; convert it to standard WCS astrometry + + extast, oldhd, astr, noparams + + if noparams GE 0 then begin ;Astrometry parameters exist in header? + + if strmid(astr.ctype[0],5,3) EQ 'GSS' then begin + gsss_stdast, newhd + extast, newhd, astr, noparams + endif + +; For non-square images, check if X and Y axes have been flipped + + crpix = astr.crpix + cd = astr.cd + cdelt = astr.cdelt + if cdelt[0] NE 1.0 then begin + cd[0,0] = cd[0,0]*cdelt[0] & cd[0,1] = cd[0,1]*cdelt[0] + cd[1,1] = cd[1,1]*cdelt[1] & cd[1,0] = cd[1,0]*cdelt[1] + endif + + ncrpix = [xc,yc] + rot_mat#(crpix-1 -[xc,yc]) + 1 + + newcd = cd # transpose(rot_mat) + + + if (dirpar EQ 4) || (dirpar EQ 6) then begin + ncrpix[0] = xsize - ( ncrpix[0] - 1) + newcd[*,0] = -newcd[*,0] + endif + + if (dirpar EQ 5) || (dirpar EQ 7) then begin + ncrpix[1] = ysize - (ncrpix[1] -1 ) + newcd[*,1] = -newcd[*,1] + endif + + + if (xsize NE ysize) && (rot_mat[0,0] EQ 0) then begin + ncrpix[0] = ncrpix[0] - xc + yc + ncrpix[1] = ncrpix[1] - yc + xc + endif + + + sxaddpar, newhd, 'CRPIX1', ncrpix[0] + sxaddpar, newhd, 'CRPIX2', ncrpix[1] + + if noparams EQ 3 then begin ;Transformation matrix format + + sxaddpar, newhd, 'PC1_1', newcd[0,0] + sxaddpar, newhd, 'PC1_2', newcd[0,1] + sxaddpar, newhd, 'PC2_1', newcd[1,0] + sxaddpar, newhd, 'PC2_2', newcd[1,1] + + endif else if noparams EQ 2 then begin + + sxaddpar, newhd, 'CD1_1', newcd[0,0] + sxaddpar, newhd, 'CD1_2', newcd[0,1] + sxaddpar, newhd, 'CD2_1', newcd[1,0] + sxaddpar, newhd, 'CD2_2', newcd[1,1] + + endif else begin ; noparams = 1. CROTA+CDELT type + crota = atan(-newcd[1,0], newcd[1,1] )*180.0/!DPI + + if dirpar GE 4 then sxaddpar, newhd, 'CDELT1', -cdelt[0] + + sxaddpar, newhd,'CROTA1', crota + sxaddpar, newhd,'CROTA2', crota + endelse + + + endif + + if npar EQ 3 then oldhd = newhd ;update old image and header + + return + end diff --git a/modules/idl_downloads/astro/pro/ieee_to_host.pro b/modules/idl_downloads/astro/pro/ieee_to_host.pro new file mode 100644 index 0000000..cb1b1f3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ieee_to_host.pro @@ -0,0 +1,104 @@ +pro ieee_to_host, data, IDLTYPE = idltype +;+ +; NAME: +; IEEE_TO_HOST +; PURPOSE: +; Translate an IDL variable from IEEE-754 to host representation +; EXPLANATION: +; The variable is translated from IEEE-754 ("big-endian" as used, for +; example, in FITS data ), into the host machine architecture. +; +; Duplicates most of the functionality of the SWAP_ENDIAN_INPLACE procedure +; introduced in V5.6, with the addition of the IDLTYPE keyword. +; CALLING SEQUENCE: +; IEEE_TO_HOST, data, [ IDLTYPE = , ] +; +; INPUT-OUTPUT PARAMETERS: +; data - any IDL variable, scalar or vector. It will be modified by +; IEEE_TO_HOST to convert from IEEE to host representation. Byte +; and string variables are returned by IEEE_TO_HOST unchanged +; +; OPTIONAL KEYWORD INPUTS: +; IDLTYPE - scalar integer (1-15) specifying the IDL datatype according +; to the code given by the SIZE function. This keyword +; is usually when DATA is a byte array to be interpreted as +; another datatype (e.g. FLOAT). +; +; EXAMPLE: +; A 2880 byte array (named FITARR) from a FITS record is to be +; interpreted as floating and converted to the host representaton: +; +; IDL> IEEE_TO_HOST, fitarr, IDLTYPE = 4 +; +; METHOD: +; The BYTEORDER procedure is called with the appropriate keyword +; +; MODIFICATION HISTORY: +; Written, W. Landsman Hughes/STX May, 1992 +; Under VMS check for IEEE -0.0 values January 1998 +; VMS now handle -0.0 values under IDL V5.1 July 1998 +; Added new integer datatypes C. Markwardt/W. Landsman July 2000 +; Post-V5.1 version, no VMS negative zero check W. Landsman July 2001 +; Use size(/type) W. Landsman December 2002 +; Use /SWAP_IF_LITTLE_ENDIAN keyword for 64bit types W. Landsman Feb 2003 +; Do not use XDR keywords to BYTEORDER for much improved speed +; W. Landsman April 2006 +; Update cosmetic typo for structures W. Landsman October 2006 +;- + On_error,2 + + if N_params() EQ 0 then begin + print,'Syntax - IEEE_TO_HOST, data, [ IDLTYPE = ]' + return + endif + + npts = N_elements( data ) + if npts EQ 0 then $ + message,'ERROR - IDL data variable (first parameter) not defined' + + if N_elements(idltype) EQ 0 then idltype = size(data,/type) + + case idltype of + + 1: return ;byte + + 2: byteorder, data, /SSWAP,/SWAP_IF_LITTLE ;integer + + 3: byteorder, data, /LSWAP,/SWAP_IF_LITTLE ;long + + 4: byteorder, data, /LSWAP, /SWAP_IF_LITTLE ;float + + 5: byteorder,data,/L64SWAP, /SWAP_IF_LITTLE ;double + + 6: byteorder, data, /LSWAP, /SWAP_IF_LITTLE + + 7: return ;string + + 8: BEGIN ;structure + + Ntag = N_tags( data ) + + for t=0,Ntag-1 do begin + temp = data.(t) + ieee_to_host, temp + data.(t) = temp + endfor + END + + 9: byteorder, data, /L64SWAP, /SWAP_IF_LITTLE + + 12: byteorder, data, /SSWAP, /SWAP_IF_LITTLE + + 13: byteorder, data, /LSWAP, /SWAP_IF_LITTLE + + 14: byteorder, data, /L64swap, /SWAP_IF_LITTLE + + 15: byteorder, data, /L64swap, /SWAP_IF_LITTLE + + else: message,'Unrecognized datatype ' + strtrim(idltype,2) + + ENDCASE + + + return + end diff --git a/modules/idl_downloads/astro/pro/imcontour.pro b/modules/idl_downloads/astro/pro/imcontour.pro new file mode 100644 index 0000000..2665ca8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/imcontour.pro @@ -0,0 +1,335 @@ +pro imcontour, im, hdr, TYPE=type, PUTINFO=putinfo, XTITLE=xtitle, $ + YTITLE=ytitle, SUBTITLE = subtitle, XDELTA = xdelta, YDELTA = ydelta, $ + _EXTRA = extra, XMID = xmid, YMID = ymid, OVERLAY = OVERLAY, $ + NOerase = noerase,window=window +;+ +; NAME: +; IMCONTOUR +; PURPOSE: +; Make a contour plot labeled with astronomical coordinates. +; EXPLANATION: +; The type of coordinate display is controlled by the keyword TYPE +; Set TYPE=0 (default) to measure distances from the center of the image +; (IMCONTOUR will decide whether the plotting units will be in +; arc seconds, arc minutes, or degrees depending on image size.) +; Set /TYPE for standard RA and Dec labeling +; +; By using the /NODATA keyword, IMCONTOUR can also be used to simply +; provide astronomical labeling of a previously displayed image. +; CALLING SEQUENCE +; IMCONTOUR, im, hdr,[ /TYPE, /PUTINFO, XDELTA = , YDELTA =, _EXTRA = +; XMID=, YMID= ] +; +; INPUTS: +; IM - 2-dimensional image array +; HDR - FITS header associated with IM, string array, must include +; astrometry keywords. IMCONTOUR will also look for the +; OBJECT and IMAGE keywords, and print these if found and the +; PUTINFO keyword is set. +; +; OPTIONAL PLOTTING KEYWORDS: +; /TYPE - the type of astronomical labeling to be displayed. Either set +; TYPE = 0 (default), distance to center of the image is +; marked in units of Arc seconds, arc minutes, or degrees +; +; TYPE = 1 astronomical labeling with Right ascension and +; declination. +; +; /PUTINFO - If set, then IMCONTOUR will add information about the image +; to the right of the contour plot. Information includes image +; name, object, image center, image center, contour levels, and +; date plot was made +; +; XDELTA, YDELTA - Integer scalars giving spacing of labels for TYPE=1. +; Default is to label every major tick (XDELTA=1) but if +; crowding occurs, then the user might wish to label every other +; tick (XDELTA=2) or every third tick (XDELTA=3) +; +; XMID, YMID - Scalars giving the X,Y position from which offset distances +; will be measured when TYPE=0. By default, offset distances +; are measured from the center of the image. +; /OVERLAY - If set, then IMCONTOUR is assumed to overlay an image. +; This requires 1 extra pixel be included on the X and Y axis, +; to account for edge effects in the image display. Setting +; OVERLAY provide a better match of the contour and underlying +; image but is not as aesthetically pleasing because the contours +; will not extend to the axes. +; +; +; Any keyword accepted by CONTOUR may also be passed through IMCONTOUR +; since IMCONTOUR uses the _EXTRA facility. IMCONTOUR uses its own +; defaults for the XTITLE, YTITLE XMINOR, YMINOR, and SUBTITLE keywords +; but these may be overridden. Note in particular the /NODATA keyword +; which can be used if imcontour.pro is to only provide labeling. +; +; NOTES: +; (1) The contour plot will have the same dimensional ratio as the input +; image array +; (2) To contour a subimage, use HEXTRACT before calling IMCONTOUR +; (3) Use the /NODATA keyword to simply provide astronomical labeling +; of a previously displayed image. +; (4) The IMCONTOUR display currently does not indicate the image +; rotation in any way, but only specifies coordinates along the +; edges of the image +; +; EXAMPLE: +; Overlay the contour of an image, im2, with FITS header, h2, on top +; of the display of a different image, im1. Use RA, Dec labeling, and +; seven equally spaced contour levels. The use of a program like +; David Fanning's cgImage http://www.idlcoyote.com/programs/cgimage.pro +; is suggested to properly overlay plotting and image coordinates. The +; /Keep_aspect_ratio keyword must be used. +; +; IDL> cgimage,im1,/keep_aspect, position = pos +; IDL> imcontour,im2,h2,nlevels=7,/Noerase,/TYPE,position = pos +; +; PROCEDURES USED: +; CHECK_FITS, EXTAST, GETROT, TICPOS, TICLABEL, TIC_ONE, TICS, XYAD +; CONS_RA(), CONS_DEC(), ADSTRING() +; +; REVISION HISTORY: +; Written W. Landsman STX May, 1989 +; Fixed RA,Dec labeling W. Landsman November, 1991 +; Fix plotting keywords W.Landsman July, 1992 +; Recognize GSSS headers W. Landsman July, 1994 +; Removed Channel keyword for V4.0 compatibility June, 1995 +; Add _EXTRA CONTOUR plotting keywords W. Landsman August, 1995 +; Add XDELTA, YDELTA keywords W. Landsman November, 1995 +; Use SYSTIME() instead of !STIME August, 1997 +; Remove obsolete !ERR system variable W. Landsman May 2000 +; Added XMID, YMID keywords to specify central position (default is still +; center of image) W. Landsman March 2002 +; Recognize Galactic coordinates, fix Levels display when /PUTINFO set +; W. Landsman May 2003 +; Correct conversion from seconds of RA to arcmin is 4 not 15. +; M. Perrin July 2003 +; Fix integer truncation which appears with tiny images WL July 2004 +; Changed some keyword_set() to N_elements WL Sep 2006 +; Work to 1 pixels level when overlaying an image,added /OVERLAY keyword +; Use FORMAT_AXIS_VALUES() W. Landsman Jan 2008 +; Make /OVERLAY always optional W. Landsman Feb 2008 +; Check if RA crosses 0 hours WL Aug 2008 +; Use Coyote Graphics WL Feb 2011 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 2 then begin ;Sufficient parameters? + print,'Syntax - imcontour, im, hdr, [ /TYPE, /PUTINFO, XDELTA=, YDELT= ' + print,' XMID=, YMID = ]' + print,' Any CONTOUR keyword is also accepted by IMCONTOUR' + return + endif + + ;Make sure header appropriate to image + check_fits, im, hdr, dimen, /NOTYPE, ERRMSG = errmsg + if errmsg NE '' then message,errmsg + +; Set defaults if keywords not set + + if ~keyword_set( TYPE ) then type = 0 + if ~keyword_set( XDELTA ) then xdelta = 1 + if ~keyword_set( YDELTA ) then ydelta = 1 + + if N_Elements(XMINOR) EQ 0 then $ + xminor = !X.MINOR EQ 0 ? 5 : !X.MINOR + + if N_Elements(YMINOR) EQ 0 then $ + yminor = !Y.MINOR EQ 0 ? 5 : !Y.MINOR + + EXTAST, hdr, astr, noparams ;Extract astrometry from header + if noparams LT 0 then $ ;Does astrometry exist? + message,'FITS header does not contain astrometry' + if strmid( astr.ctype[0], 5, 3) EQ 'GSS' then begin + hdr1 = hdr + gsss_STDAST, hdr1 + extast, hdr1, astr, noparams + endif + sexig = strmid(astr.ctype[0],0,4) EQ 'RA--' + +; Adjust plotting window so that contour plot will have same dimensional +; ratio as the image + + xlength = !D.X_VSIZE & ylength = !D.Y_VSIZE + xsize = fix( dimen[0] ) & ysize = fix( dimen[1] ) + xsize1 = xsize-1 & ysize1 = ysize-1 + if keyword_set(OVERLAY) then begin + xran = [0,xsize]-0.5 & yran = [0,ysize]-0.5 + endif else begin + xran = [0,xsize1] & yran = [0,ysize1] + endelse + + xratio = xsize / float(ysize) + yratio = ysize / float(xsize) + if N_elements(XMID) EQ 0 then xmid = (xran[1] -xran[0]-1)/2. + if N_elements(YMID) EQ 0 then ymid = (yran[1] -yran[0]-1)/2. + + if ( ylength*xratio LT xlength ) then begin + + xmax = 0.15 + 0.8*ylength*xratio/xlength + pos = [ 0.15, 0.15, xmax, 0.95 ] + + endif else begin + + xmax = 0.95 + pos = [ 0.15, 0.15, xmax, 0.15+ 0.8*xlength*yratio/ylength ] + + endelse + + xtics = !X.TICKS GT 0 ? abs(!X.TICKS) : 8 + ytics = !Y.TICKS GT 0 ? abs(!Y.TICKS) : 8 + + pixx = float(xsize)/xtics ;Number of X pixels between tic marks + pixy = float(ysize)/ytics ;Number of Y pixels between tic marks + + getrot,hdr,rot,cdelt ;Get the rotation and plate scale + + xyad,hdr,xsize1/2.,ysize1/2.,ra_cen,dec_cen ;Get coordinates of image center + if sexig then ra_dec = adstring(ra_cen,dec_cen,1) ;Make a nice string + +; Determine tic positions and labels for the different type of contour plots + + if type NE 0 then begin ;RA and Dec labeling + + xedge = [ xran[0], xran[1], xran[0]] ;X pixel values of the four corners + yedge = [ yran[0], yran[0], yran[1] ] ;Y pixel values of the four corners + + xy2ad, xedge, yedge, astr, a, d + + pixx = float(xmid*2)/xtics ;Number of X pixels between tic marks + pixy = float(ymid*2)/ytics ;Number of Y pixels between tic marks + +; Find an even increment on each axis, for RA check crossing of 0 hours + case 1 of + ( a[1] GT a[0] ) and (cdelt[0] LT 0 ) : $ + tics, a[0], a[1] - 360.0d , xsize, pixx, raincr, RA=sexig + ( a[1] LT a[0] ) and (cdelt[0] GT 0 ) : $ + tics, a[0], 360.0d + a[1], xsize, pixx, raincr, RA=sexig + else: tics, a[0], a[1], xsize, pixx, raincr, RA=sexig + endcase + tics, d[0], d[2], ysize, pixy, decincr ;Find an even increment for Dec + +; Find position of first tic on each axis + tic_one, a[0], pixx, raincr, botmin, xtic1, RA= sexig ;Position of first RA tic + tic_one, d[0], pixy, decincr,leftmin,ytic1 ;Position of first Dec tic + + nx = fix( (xsize1-xtic1)/pixx ) ;Number of X tic marks + ny = fix( (ysize1-ytic1)/pixy ) ;Number of Y tic marks + + if sexig then ra_grid = (botmin + findgen(nx+1)*raincr/4.) else $ + ra_grid = (botmin + findgen(nx+1)*raincr/60.) + dec_grid = (leftmin + findgen(ny+1)*decincr/60.) + + ticlabels, botmin, nx+1, raincr, xlab, RA=sexig, DELTA=xdelta + ticlabels, leftmin, ny+1, decincr, ylab,DELTA=ydelta + + xpos = cons_ra( ra_grid,0,astr ) ;Line of constant RA + ypos = cons_dec( dec_grid,0,astr) ;Line of constant Dec + + if sexig then begin + xunits = 'Right Ascension' + yunits = 'Declination' + endif else begin + xunits = 'Longitude' + yunits = 'Latitude' + endelse + + endif else begin ; label with distance from center. + ticpos, xsize*cdelt[0], xsize, pixx, incrx, xunits + numx = fix((xmid-xran[0])/pixx) ;Number of ticks from left edge + ticpos, ysize*cdelt[1], ysize, pixy, incry, yunits + numy = fix((ymid-yran[0])/pixy) ;Number of ticks from bottom to center + nx = numx + fix((xran[1]-xmid)/pixx) ;Total number of X ticks + ny = numy + fix((yran[1]-ymid)/pixy) ;Total number of Y ticks + xpos = xmid + (findgen(nx+1)-numx)*pixx + ypos = ymid + (findgen(ny+1)-numy)*pixy + xlab = format_axis_values( indgen(nx+1)*incrx - incrx*numx) + ylab = format_axis_values( indgen(ny+1)*incry - incry*numy) + + + endelse + +; Get default values of XTITLE, YTITLE, TITLE and SUBTITLE + + putinfo = keyword_set(PUTINFO) + + if N_elements(xtitle) EQ 0 then $ + xtitle = !X.TITLE eq ''? xunits : !X.TITLE + + if N_elements(ytitle) EQ 0 then $ + ytitle = !Y.TITLE eq ''? yunits : !Y.TITLE + + if (~keyword_set( SUBTITLE) ) && (putinfo LT 1) then $ + if sexig then $ + subtitle = 'Center: R.A. '+ strmid(ra_dec,1,13)+' Dec ' + $ + strmid(ra_dec,13,13) else $ + subtitle = 'Center: Longitude '+ strtrim(string(ra_cen,'(f6.2)'),2) + $ + ' Latitude ' + strtrim(string(dec_cen,'(f6.2)'),2) + + if N_elements( SUBTITLE) EQ 0 then subtitle = !P.SUBTITLE + cgContour,im, $ + XTICKS = nx, YTICKS = ny, POSITION=pos, XSTYLE=1, YSTYLE=1,$ + XTICKV = xpos, YTICKV = ypos, XTITLE=xtitle, YTITLE=ytitle, $ + XTICKNAME = xlab, YTICKNAME = ylab, SUBTITLE = subtitle, $ + XMINOR = xminor, YMINOR = yminor, _EXTRA = extra, XRAn=xran, $ + YRAN = yran,noerase=noerase,WINDOW=window + + +; Write info about the contour plot if desired + + if putinfo GE 1 then begin + + sv = !D.NAME + set_plot,'null' + contour,im, _EXTRA = extra, PATH_INFO = info + set_plot,sv + + + if keyword_set(window) then cgcontrol, execute= 0 + xmax = xmax + 0.01 + + ypos = 0.92 + object = sxpar( hdr, 'OBJECT', Count = N_object ) + if N_object GT 0 then begin + cgText, xmax, ypos, object, /NORM, addcmd=window + ypos = ypos-0.05 + endif + + name = sxpar( hdr, 'IMAGE', Count = N_image ) + if N_image GT 0 then begin + cgtext,xmax,ypos,name, /NORM, addcmd= window + ypos = ypos - 0.05 + endif + + cgText, xmax, ypos,'Center:',/NORM, addcmd=window + ypos = ypos - 0.05 + if sexig then begin + cgText, xmax, ypos, 'R.A. '+ strmid(ra_dec,1,13),/NORM,addcmd=window + cgText, xmax, ypos-0.05, 'Dec '+ strmid(ra_dec,13,13),/NORM,addcmd=window + endif else begin + cgText, xmax, ypos, 'Longitude: '+ strtrim(string(ra_cen,'(f6.2)'),2), $ + /NORM, addcmd=window + cgText, xmax, ypos-0.05, addcmd=window, $ + 'Latitude: '+ strtrim(string(dec_cen,'(f6.2)'),2),/NORM + endelse + ypos = ypos - 0.1 + cgText, xmax, ypos, 'Image Size', /NORM, addcmd=window + cgText, xmax, ypos-0.05, 'X: ' + strtrim(xsize,2), /NORM, addcmd=window + cgText, xmax, ypos-0.1, 'Y: ' + strtrim(ysize,2), /NORM, addcmd=window + cgText, xmax, ypos- 0.15, strmid(systime(),4,20),/NORM, addcmd=window + cgText, xmax, ypos - 0.2, 'Contour Levels:',/NORM, addcmd=window + + + ypos = ypos - 0.25 + val = info.value + val = val[uniq(val,sort(val))] + nlevels = N_elements(val) + for i = 0,(nlevels < 7)-1 do $ + cgText,xmax,ypos-0.05*i,string(i,'(i2)') + ':' + $ + string(val[i]), /NORM,addcmd=window + if keyword_set(window) then cgcontrol, execute=1 + + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/imdbase.pro b/modules/idl_downloads/astro/pro/imdbase.pro new file mode 100644 index 0000000..d2970ea --- /dev/null +++ b/modules/idl_downloads/astro/pro/imdbase.pro @@ -0,0 +1,205 @@ +pro imdbase,hdr,catalogue,list,XPOS=xpos,YPOS=ypos, SILENT=silent, $ + XRANGE=xrange,YRANGE=yrange, SUBLIST = sublist, ALT = alt +;+ +; NAME: +; IMDBASE +; PURPOSE: +; Find the sources in an IDL database that are located on a given image. +; +; CALLING SEQUENCE: +; imdbase, hdr, [catalogue, list, ALT=, XPOS= ,YPOS=, XRANGE= ,YRANGE= , +; SUBLIST =, /SILENT ] +; +; INPUTS: +; hdr - FITS image header containing astrometry, and the NAXIS1, +; NAXIS2 keywords giving the image size +; catalogue - string giving name of catalogue in database. If not supplied +; then the currently open database is used. The database must +; contain the (preferably indexed) fields RA (in hours) and DEC. +; Type DBHELP for a list of the names of available catalogues. +; +; OPTIONAL OUTPUT PARAMETER: +; LIST - A longwprd vector containing the entry numbers of sources found +; within the image. This vector can then be used with other +; database procedures, e.g. to print specified fields (DBPRINT) +; or subselect with further criteria (DBFIND) +; +; OPTIONAL OUTPUT KEYWORD PARAMETER: +; XPOS - REAL*4 vector giving X positions of catalogue sources found +; within the image +; YPOS - REAL*4 vector giving Y positions of catalogue sources found +; within the image +; +; OPTIONAL INPUT KEYWORD PARAMETERS +; ALT - single character 'A' through 'Z' or ' ' specifying an alternate +; astrometry system present in the FITS header. The default is +; to use the primary astrometry or ALT = ' '. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. +; SILENT - If set, then informational messages are suppressed +; SUBLIST - vector giving entries in the database to consider in the +; search. If not supplied, or set equal to -1, then all entries +; are considered. +; XRANGE - 2 element vector giving the X range of the image to consider. +; The default is to search for catalogue sources within the entire +; image +; YRANGE - 2 element vector giving the Y range of the image to consider. +; +; NOTES: +; If an output list vector is not supplied, then the found objects are +; diplayed at the terminal. +; +; EXAMPLE: +; Find all existing IUE observations within the field of the FITS +; file fuv0435fc.fits. Subselect those taken with the SWP camera +; +; H = HEADFITS('fuv0435f.fits') ;Read FITS header +; IMDBASE,H,'IUE',list ;Find IUE obs. within image +; list2 = DBFIND('CAM_NO=3',list) ;Subselect on SWP images +; +; SIDE EFFECTS: +; The IDL database is left open upon exiting IMDBASE. +; NOTES: +; IMDBASE checks the description of the RA item in the database for the +; string '1950'. If found, the database RA and Dec are assumed to be +; in equinox B1950. Otherwise they are assumed to be in ICRS or J2000. +; +; SYSTEM VARIABLES: +; The non-standard system variable !TEXTOUT is required for use with the +; database procedures. +; +; PROCEDURES USED: +; AD2XY, DBEXT, DB_ITEM, DB_ITEM_INFO(), DBOPEN, DBFIND(), EXTAST, +; GET_EQUINOX(), GSSSADXY, GSSSXYAD, HPRECESS, SXPAR(), XY2AD +; REVISION HISTORY: +; Written W. Landsman September, 1988 +; Added SUBLIST keyword September, 1991 +; Updated to use ASTROMETRY structures J.D. Offenberg, HSTX, Jan 1993 +; Conversion for precession fixed. R.Hill, HSTX, 22-Apr-93 +; Check RA description for equinox W. Landsman Aug 96 +; Call HPRECESS if header equinox does not match DB W. Landsman Oct. 1998 +; Assume Equinox J2000 if not explicitly B1950 W. Landsman Jan. 2005 +; Added ALT keyword W. Landsman April 2005 +; Use open database, if no catalogue name given W.L April 2008 +; Added /SILENT keyword W.L. Mar 2009 +; Use V6.0 notation W. L. Aug 2013 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 2 then begin ;Sufficient parameters? + print,'Syntax - imdbase, hdr, catalogue, [ list, ALT =, SUBLIST = ' + print,' XPOS = , YPOS = , XRANGE =, YRANGE =, /SILENT ]' + print,'Type DBHELP for available catalogues' + return + endif + +; Check if catalogue has preselected output fields + + if N_elements(catalogue) EQ 0 then catalogue = db_info('name',0) + catname = strupcase(strtrim(catalogue,2)) + + dbopen,catalogue,unavail=unavail ;Was database found? + if unavail EQ 1 then message,'Database ' + catalogue + ' is unavailable' + + db_item,'ra',itnum + descrip = db_item_info('description',itnum[0]) + if strpos(descrip,'1950') GE 0 then cat_year = 1950. else cat_year = 2000. + +; Get X and Y of 4 corners of the image + + if N_elements(xrange) NE 2 then begin + xmin = 0 & xmax = sxpar(hdr,'NAXIS1') - 1 + ENDIF ELSE BEGIN + xmin = xrange[0] & xmax = xrange[1] + ENDELSE + + if N_elements(yrange) NE 2 then BEGIN + ymin=0 & ymax = sxpar(hdr,'NAXIS2') - 1 + ENDIF ELSE BEGIN + ymin = yrange[0] & ymax = yrange[1] + ENDELSE + + x = [xmin,xmax,xmax,xmin] + y = [ymin,ymin,ymax,ymax] + +; Make sure header has astrometry and convert X,Y to Ra, Dec + + extast, hdr, ASTR, noparams, ALT = alt + if noparams LT 0 then message,'Image header does not contain astrometry' + +; Compare equinox of image with that of database and precess if necessary + + im_year = GET_EQUINOX(hdr,code) + if ( code EQ -1 ) then begin + message,/inf,'EQUINOX keyword not found in header, assumed to be J2000' + im_year = 2000. ;Assume image in 2000 Equinox as default + endif + if ( im_year NE cat_year ) then begin ;Need to precess header? + hdr1 = hdr + hprecess,hdr1,cat_year + extast,hdr1, ASTR, noparams, ALT = alt + endif + + proj = strmid(astr.ctype[0],5,3) ;Astrometric projection type + + case proj of + 'GSS': gsssxyad, astr, x, y, ra,dec + else: xy2ad, x, y, ASTR, ra, dec + endcase + + ra = ra/15. ;Convert from degrees to hours + ramin = min(ra) & ramax = max(ra) ;Get max and min RA values + decmin = min(dec) & decmax = max(dec) ;Get max and min Dec values + if (ramax - ramin) GT 12 then begin ;Does the RA cross 24 hours? + newmax = ramin + ramin = ramax + ramax = 24. + redo = 1 +endif else redo = 0 +if N_elements(SUBLIST) EQ 0 then sublist = -1 + + + search = strtrim(ramin,2) + ' < ra < ' + strtrim(ramax,2) + ', ' + $ + strtrim(decmin,2) + ' < dec < ' + strtrim(decmax,2) +if ~keyword_set(SILENT) then begin + print,'IMDBASE: Now searching ',catname,' catalogue - be patient' + print,search +endif + list = dbfind(search,sublist,/SILENT, Count = nstar) ;Search for stars in field + if redo then begin + search = '0 < ra < ' + strtrim(newmax,2) + ', ' + $ + strtrim(decmin,2) + '< dec <' + strtrim(decmax,2) + if ~keyword_set(SILENT) then print,search + newlist = dbfind(search,sublist,/SILENT, Count = count) + if count GT 0 then list = [list,newlist] + nstar = nstar + count + endif + if ~keyword_set(SILENT) then print,'' + + if nstar GT 0 then begin ;Any stars found? + dbext,list,'ra,dec',ra,dec ;Extract RA,DEC of stars found + ra = ra*15. + + case proj of + 'GSS': gsssadxy, astr,ra,dec,x,y + else: ad2xy,ra,dec,astr,x,y + endcase + + good = where( (x GT xmin) and ( x LT xmax ) $ ;Select stars within field + and (y GT ymin) and ( y LT ymax), ngood) + if ngood GT 0 then begin + list = list[good] + xpos = x[good] & ypos = y[good] + if ~keyword_set(SILENT) then $ + message,strtrim(ngood,2)+' '+ catname +' sources found within image',/INF + if ( N_params() LT 3 ) then dbprint,list,textout=1 ;List stars found + endif else GOTO,NO_MATCH + endif else GOTO,NO_MATCH +return + +NO_MATCH: message,'No '+ catname + ' sources found within supplied image',/CON +return + +end diff --git a/modules/idl_downloads/astro/pro/imf.pro b/modules/idl_downloads/astro/pro/imf.pro new file mode 100644 index 0000000..4c0f7e8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/imf.pro @@ -0,0 +1,129 @@ +function imf, mass, expon, mass_range +;+ +; NAME: +; IMF +; PURPOSE: +; Compute an N-component power-law logarithmic initial mass function +; EXPLANTION: +; The function is normalized so that the total mass distribution +; equals one solar mass. +; +; CALLING SEQUENCE: +; psi = IMF( mass, expon, mass_range ) +; +; INPUTS: +; mass - mass in units of solar masses (scalar or vector) +; Converted to floating point if necessary +; expon - power law exponent, usually negative, scalar or vector +; The number of values in expon equals the number of different +; power-law components in the IMF +; A Saltpeter IMF has a scalar value of expon = -1.35 +; mass_range - vector containing the mass upper and lower limits of the +; IMF and masses where the IMF exponent changes. The number +; of values in mass_range should be one more than in expon. +; The values in mass_range should be monotonically increasing. +; +; OUTPUTS +; psi - mass function, number of stars per unit logarithmic mass interval +; evaluated for supplied masses +; +; NOTES: +; The mass spectrum f(m) giving the number of stars per unit mass +; interval is related to psi(m) by m*f(m) = psi(m). The normalization +; condition is that the integral of psi(m) between the upper and lower +; mass limit is unity. +; +; EXAMPLE: +; (1) Print the number of stars per unit mass interval at 3 Msun +; for a Salpeter (expon = -1.35) IMF, with a mass range from +; 0.1 MSun to 110 Msun. +; +; IDL> print, imf(3, -1.35, [0.1, 110] ) / 3 +; +; (2) Lequex et al. (1981, A & A 103, 305) describes an IMF with an +; exponent of -0.6 between 0.007 Msun and 1.8 Msun, and an +; exponent of -1.7 between 1.8 Msun and 110 Msun. Plot +; the mass spectrum f(m) +; +; IDL> m = [0.01,0.1,indgen(110) + 1 ] ;Make a mass vector +; IDL> expon = [-0.6, -1.7] ;Exponent Vector +; IDL> mass_range = [ 0.007, 1.8, 110] ;Mass range +; IDL> plot,/xlog,/ylog, m, imf(m, expon, mass_range ) / m +; +; METHOD +; IMF first calculates the constants to multiply the power-law +; components such that the IMF is continuous at the intermediate masses, +; and that the total mass integral is one solar mass. The IMF is then +; calculated for the supplied masses. Also see Scalo (1986, Fund. of +; Cosmic Physics, 11, 1) +; +; PROCEDURES CALLED: +; None +; REVISION HISTORY: +; Written W. Landsman August, 1989 +; Set masses LE mass_u rather than LT mass_u August, 1992 +; Major rewrite to accept arbitrary power-law components April 1993 +; Convert EXPON to float if necessary W. Landsman March 1996 +; Remove call to DATATYPE, V5.3 version W. Landsman August 2000 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - psi = IMF( mass, expon, mass_range)' + return,-1 + endif + + Ncomp = N_elements(expon) + if N_elements( mass_range) NE Ncomp + 1 then message, $ + 'ERROR - Mass Range Vector must have ' + strtrim(Ncomp+1,2) + ' components' + + if ( min(mass_range) LE 0 ) then message, $ + 'ERROR - Mass range Vector must be positive definite' + + npts = N_elements(mass) + if ( npts LT 1 ) then begin + message, 'Mass vector (first parameter) has not been defined',/CON + return,0 + endif + + if size(mass,/TNAME) NE 'DOUBLE' then mass = float(mass) ;Make sure not integer + if size(expon,/TNAME) NE 'DOUBLE' then expon = float(expon) + +; Get normalization constants for supplied power-law exponents + + integ = fltarr(ncomp) + +;Compute the unnormalized integral over each power law section + + for i = 0, Ncomp-1 do begin + + if ( expon[i] NE -1 ) then integ[i] = $ + (mass_range[i+1]^(1+expon[i]) - mass_range[i]^(1+expon[i]))/(1+expon[i]) $ + + else integ[i] = alog(mass_range[i+1]/mass_range[i]) + + endfor + +; Insure continuity where the power law functions meet + + joint = fltarr(ncomp) + joint[0] = 1 + if ncomp GT 1 then for i = 1,ncomp-1 do begin + joint[i] = joint[i-1]*mass_range[i]^( expon[i-1] - expon[i] ) + endfor + + norm = fltarr(ncomp) + norm[0] = 1./ total(integ*joint) + if ncomp GT 1 then for i = 1,ncomp-1 do norm[i] = norm[0]*joint[i] + + f = mass*0. + + for i = 0, Ncomp-1 do begin + + test = where( (mass GT mass_range[i]) and (mass LE mass_range[i+1]), Ntest ) + if ( Ntest GT 0 ) then f[test] = norm[i]*mass[test]^(expon[i]) + + endfor + + return,f + end diff --git a/modules/idl_downloads/astro/pro/imlist.pro b/modules/idl_downloads/astro/pro/imlist.pro new file mode 100644 index 0000000..9aaa372 --- /dev/null +++ b/modules/idl_downloads/astro/pro/imlist.pro @@ -0,0 +1,228 @@ +pro imlist, image, xc, yc, DX=dx, DY = DY, WIDTH=width, TEXTOUT = textout, $ + DESCRIP = descr,OFFSET = offset +;+ +; NAME: +; IMLIST +; PURPOSE: +; Display pixel values on an image surrounding a specified X,Y center. +; EXPLANATION: +; IMLIST is similar to TVLIST but the center pixel is supplied directly by +; the user, rather than being read off of the image display +; +; CALLING SEQUENCE: +; IMLIST, Image, Xc, Yc, [ TEXTOUT = , DX = , DY = ,WIDTH = ,DESCRIP = ] +; +; INPUTS: +; Image - Two-dimensional array containing the image +; Xc - X pixel value at which to center the display, integer scalar +; Yc - Y pixel value at which to center the display, integer scalar +; +; OPTIONAL INPUTS KEYWORDS: +; TEXTOUT - Scalar number (1-7) or string which determines output device. +; (see TEXTOPEN) The following dev/file is opened for output. +; +; textout=1 TERMINAL using /more option +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 same as 3 but text is appended to .prt +; if file already exists +; textout = filename (default extension of .prt) +; +; DX -Integer scalar giving the number of pixels inthe X direction +; to be displayed. If omitted then DX = 18 for byte images, and +; DX = 14 for integer images. IMLIST will display REAL data +; with more significant figures if more room is available to +; print. +; +; DY - Same as DX, but in Y direction. If omitted, then DY = DX +; WIDTH - Integer scalar giving the character width of the output device. +; Default is 80 characters. +; DESCRIP = Scalar string which will be written as a description over +; the output pixel values. If DESCRIP is not supplied, and the +; output device specified by TEXTOUT is not a terminal, then the +; user will be prompted for a description. +; OFFSET - 2 element numeric vector giving an offset to apply to the +; display of the X,Y coordinates of the image (e.g. if the +; supplied image array is a subarray of a larger image). +; OUTPUTS: +; None. +; +; PROCEDURE: +; Corresponding region of image is then displayed at +; the terminal. If necessary, IMLIST will divide all pixel values +; in a REAL*4 image by a (displayed) factor of 10 to make a pretty format. +; +; SYSTEM VARIABLES: +; If the keyword TEXTOUT is not supplied, then the non-standard system +; variable !TEXTOUT will be read. (The procedure ASTROLIB is used +; to add the non-standard system variable if not already present.) +; +; RESTRICTIONS: +; IMLIST may not be able to correctly format all pixel values if the +; dynamic range of the values near the center pixel is very large +; +; EXAMPLE: +; Display the pixel values of an image array IM in the vicinity of 254,111 +; +; IDL> imlist, IM, 254, 111 +; +; PROCEDURES USED +; TEXTOPEN, F_FORMAT(), TEXTCLOSE +; REVISION HISTORY: +; Written, W. Landsman June, 1991 +; Added DESCRIP keyword W. Landsman December, 1991 +; Treat LONG image as integer when possible, call TEXTOPEN with /STDOUT +; keyword, W. Landsman April, 1996 +; Use SYSTIME() instead of !STIME August 1997 +; Recognize new integer types, added OFFSET keyword W. Landsman Jan. 2000 +; Replace DATATYPE() with size(/TNAME) W. Landsman Nov. 2001 +; Handle NAN values in output display W. Landsman June 2004 +; Use V6.0 notation W. Landsman April 2011 +; Remove unnecessary checks if system variable defined W. Landsman May 2016 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - IMLIST, Image, Xc, Yc, [TEXTOUT= ,DX=, DY=, WIDTH= ,DESC= ]' + print,' Image - Any IDL numeric 2-d array' + print,' Xc, Yc - X,Y of center pixel of region to display' + return + endif + + defsysv,'!TEXTUNIT',exist=i + if i EQ 0 then astrolib + + if N_elements( TEXTOUT ) EQ 0 then textout = !TEXTOUT ;Use default + if N_elements( OFFSET) NE 2 then offset = [0,0] + + if size( TEXTOUT,/TNAME ) NE 'STRING' then begin + textout = textout > 2 ;Don't use /MORE + hardcopy = (textout GE 3) && (textout NE 5) + endif else hardcopy = 1 + + + textopen, 'IMLIST', TEXTOUT = textout, /STDOUT ;Open output device + + sz = size(image) + if (sz[0] LT 2) || (sz[sz[0]+2] NE sz[1]*sz[2]) then $ + message,'Image array (first parameter) not 2-dimensional' + + type = sz[ sz[0] + 1 ] ;Byte or Integer or Float image? + + if hardcopy then begin ;Direct output to a disk file + printf,!TEXTUNIT,'IMLIST: ' + strmid(systime(),4,20) + if ~keyword_set( DESCR ) then begin + descr = '' + read,'Enter a brief description to be written to disk: ',descr + endif + printf,!TEXTUNIT,descr + printf,!TEXTUNIT,' ' + endif + + xdim = sz[1] - 1 + ydim = sz[2] - 1 + +; Make sure supplied center pixel is actually within image + + if (xc LT 0) || (xc GT xdim) then $ + message,'ERROR - X pixel center must be between 0 and '+strtrim(xdim,2) + if (yc LT 0) || (yc GT ydim) then $ + message,'ERROR - Y pixel center must be between 0 and '+strtrim(ydim,2) + + xim = round(xc) + yim = round(yc) + if ~keyword_set( WIDTH ) then width = 80 + + case type of + 1: fmtsz = 4 + 2: fmtsz = 6 +12: fmtsz = 6 +else: fmtsz = 5 +endcase + + if ~keyword_set(DX) then dx = fix((width - 5)/fmtsz) + if ~keyword_set(DY) then dy = dx + +; Don't try to print outside the image + xmax = (xim + dx/2) < xdim + xmin = (xim - dx/2) > 0 + ymax = (yim + dy/2) < ydim + ymin = (yim - dy/2) > 0 + + dx = xmax - xmin + 1 & dy = ymax - ymin + 1 + if fmtsz EQ 5 then fmtsz = ( width-4 ) / dx + sfmt = strtrim( fmtsz,2 ) + cdx = string(dx,'(i2)') + flt_to_int = 0 ;Convert floating point to integer? + + +; For Integer and Byte datatypes we already know the best output format +; For other datatypes the function F_FORMAT is used to get the best format +; If all values of a LONG image can be expressed with 5 characters +; (-9999 < IM < 99999) then treat as an integer image. +REDO: + case 1 of ;Get proper print format + + type EQ 1: fmt = '(i4,' + cdx + 'i' + sfmt + ')' ;byte + + (type EQ 2): fmt = '(i4,' + cdx + 'i' + sfmt + ')' ;Integer + (type EQ 12): fmt = '(i4,1x,' + cdx + 'i' + sfmt + ')' ;Unsigned Integer + + (type EQ 4) || (type EQ 3) || (type EQ 5) || (type GE 13): begin ;Long, Real or Double + + temp = image[ xmin:xmax,ymin:ymax ] + minval = min( temp, MAX = maxval, /nan) + if (type EQ 3) || (type GE 13) then begin + + if (maxval LT 999.) && (minval GT -99.) then begin + type = 1 & sfmt = '4' + goto, REDO + endif + if (maxval LT 9999.) && (minval GT -999.) then begin + type = 12 & sfmt = '5' + goto, REDO + endif + if (maxval LT 99999.) && (minval GT -9999.) then begin + type = 2 & sfmt = '6' + goto, REDO + endif + endif + + realfmt = F_FORMAT( minval, maxval, factor, fmtsz ) + if strmid(realfmt,0,1) EQ 'I' then flt_to_int = 1 + fmt = '(i4,1x,' + cdx + realfmt + ')' + if factor NE 1 then $ + printf,!TEXTUNIT,form='(/,A,E7.1,/)',' IMLIST: Scale Factor ',factor + + end + + else: message,'ERROR - Unrecognized data type' + endcase + +; Compute and print x-indices above array + + index = indgen(dx) + xmin + offset[0] + + if type NE 1 then $ + printf,!TEXTUNIT,form='(A,'+ cdx + 'i' + sfmt + ')',' col ',index $ + else printf,!TEXTUNIT,form='(A,'+ cdx + 'i' + sfmt + ')',' col',index + + printf,!TEXTUNIT,'$(A)',' row' + for i = ymax,ymin,-1 do begin ;list pixel values + + row = image[i*sz[1]+xmin:i*sz[1]+xmax] ;from supplied image array + if type EQ 1 then row = fix(row) + if (type EQ 4) || (type EQ 3) || (type EQ 5) || (type GE 13) then $ + row = row/factor + if flt_to_int then row = round( row ) + printf, !TEXTUNIT, FORM = fmt, i + offset[1], row + + endfor + + textclose, TEXTOUT=textout + + return + end diff --git a/modules/idl_downloads/astro/pro/irafdir.pro b/modules/idl_downloads/astro/pro/irafdir.pro new file mode 100644 index 0000000..8b064eb --- /dev/null +++ b/modules/idl_downloads/astro/pro/irafdir.pro @@ -0,0 +1,185 @@ +pro irafdir,directory,TEXTOUT=textout +;+ +; NAME: +; IRAFDIR +; PURPOSE: +; Provide a brief description of the IRAF images on a directory +; CALLING SEQUENCE: +; IRAFDIR, [ directory, TEXTOUT = ] +; +; OPTIONAL INPUT PARAMETERS: +; DIRECTORY - Scalar string giving file name, disk or directory to +; be searched +; +; OPTIONAL INPUT KEYWORD: +; TEXTOUT - specifies output device (see TEXTOPEN) +; textout=1 TERMINAL using /more option +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 Append to existing .prt file +; textout = 'filename' (default extension of .prt) +; +; OUTPUT PARAMETERS: +; None +; +; PROCEDURE: +; FINDFILE is used to find all '.imh' files in the directory. +; The object name and image size (NAXIS1, NAXIS2) are extracted +; from the header. Each header is also searched for the parameters +; DATE-OBS (or TDATEOBS), TELESCOP (or OBSERVAT), EXPTIME. +; +; RESTRICTIONS: +; (1) Some fields may be truncated since IRAFDIR uses a fixed format +; output +; (2) No more than 2 dimension sizes are displayed +; SYSTEM VARIABLES: +; If 'textout' keyword is not specified to select an output device, +; !TEXTOUT will be the default. This non-standard system variable +; can be added using the procedure ASTROLIB. +; +; PROCEDURE CALLS: +; EXPAND_TILDE(), FDECOMP, REMCHAR, TEXTOPEN, TEXTCLOSE +; MODIFICATION HISTORY: +; Written, K. Venkatakrishna, ST Systems Corp, August 1991 +; Work for IRAF V2.11 format W. Landsman November 1997 +; Assume since V5.5 use file_search W. Landsman Sep 2006 +;- + + On_error,2 ;Return to caller + + ext='*.imh' + + defsysv,'!TEXTUNIT',exist=i + if i EQ 0 THEN astrolib + if keyword_set(directory) then begin + dir = strlowcase(directory) + if strpos(dir,'~') GE 0 then dir = expand_tilde(dir) + endif + + if N_ELEMENTS(dir) eq 0 then cd,current = dir + + dir = dir + path_sep() + + fil = file_search( dir + ext, COUNT=nfiles) + if nfiles EQ 0 then begin + message,'No IRAF (*.imh) files found ',/CON + return + endif + +; Set output device according to keyword TEXTOUT or system variable !TEXTOUT + + if not keyword_set(textout) then textout=!textout + textopen,'irafdir',TEXTOUT=textout + +; Print the title header + printf,!textunit,format='(a,/)','IRAF file directory '+strmid(systime(),4,20) + printf,!textunit,$ +' NAME SIZE OBJECT DATE-OF-OBS TELESCOP EXP TIME' + + get_lun,lun1 + fmt = '(a15,1x,i5,1x,i5,2x,a10,4x,a8,7x,a8,5x,a8)' + dir2 = 'dummy' + for i=0,nfiles-1 do begin ;Loop over each .imh file + file1 = fil[i] + fdecomp,file1,disk,dir2,fname,qual ;Decompose into disk+filename + openr,lun1,file1,/stream ;open the file + irafver = bytarr(5) + readu,lun1,irafver + newformat = string(irafver) EQ 'imhv2' + point_lun,lun1,0 + tmp = assoc(lun1,bytarr(32)) + hdr = tmp[0] + + exptim =' ? ' ;Set default values + telescop = ' ? ' + date = ' ? ' + + if not newformat then begin + hdr2 = hdr ;Read the first 572 bytes + byteorder,hdr,/sswap ; Perform byte swaps + byteorder,hdr,/lswap + hdrlen = fix(hdr,12) ;Extract header length, + ndim = fix(hdr,20) ; number of dimensions, + naxis1 = long(hdr2,24) ; dimension vector + naxis2 = long(hdr2,28) + if hdrlen EQ 0 then begin + close,lun1 + goto, PRINTER + endif + tmp1 = assoc(lun1,bytarr(hdrlen*4l,/NOZERO)) + hdr = tmp1[0] ;Read the entire header + close,lun1 + byteorder,hdr,/sswap ; + nfits = (hdrlen*4l-2054)/162 ; find the number of records + linelen = 162 + index = 2052l + indgen(80)*2 + + endif else begin + + hdrlen = fix(hdr,8) ;Extract header length, + ndim = fix(hdr,20) ; number of dimensions, + naxis1 = long(hdr,22) ; dimension vector + naxis2 = long(hdr,26) + tmp1 = assoc(lun1,bytarr(hdrlen*2l,/NOZERO)) + hdr = tmp1[0] ;Read the entire header + close,lun1 + nfits = (hdrlen*2l-2049)/81 ; find the number of records + linelen = 81 + index = 2046l + indgen(80) + endelse + +; Form the string 'hd', +; hd will be a FITS style header, that contains all the basic information + + if nfits EQ 0 then goto, PRINTER + hd = strarr(nfits) ; to break the header into + for j = 0l,nfits-1 do hd[j] = string(hdr[linelen*j + index] ) + + + keyword = strtrim( strmid(hd,0,8),2 ) + value = strtrim( strmid(hd,10,20),2 ) + l = where(keyword EQ 'TELESCOP',nfound) ;Search for OBSERVAT keyword + if nfound EQ 0 then l = where(keyword EQ 'OBSERVAT', nfound) + if nfound GT 0 then begin + telescop = value[l[0]] + remchar,telescop,"'" + endif + + l = where(keyword EQ 'EXPTIME',nfound) ;Search for EXPTIME keyword + if nfound GT 0 then begin + exptim = float(value[l[0]]) + if exptim EQ 0. then exptim = ' ? ' else $ + exptim = string(exptim,format= '(f7.1)') + endif + + l = where(keyword EQ 'DATE-OBS' ,nfound) ;Search for DATE-OBS keyword + if nfound EQ 0 then l = where(keyword EQ 'TDATEOBS', nfound) + if nfound GT 0 then begin + date=value[l[0]] + remchar,date,"'" + endif + +;Extract object name +PRINTER: + if newformat then object = string( hdr[638 + indgen(8)]) else $ + object = string( hdr[732 + indgen(8)*2]) + + if dir2 NE dir then begin ;Has directory changed? + if ( dir2 EQ '' ) then cd,current=dir else dir = dir2 + printf,!textunit,format='(/a/)',disk+dir ;Print new directory + dir = dir2 ;Save new directory + endif +; original header + + printf,!textunit,FORMAT=fmt,fname,naxis1,naxis2,object,date,telescop,exptim + if textout EQ 1 then if !ERR EQ 1 then return + endfor + + textclose, TEXTOUT=textout + free_lun, lun1 + + return + end + diff --git a/modules/idl_downloads/astro/pro/irafrd.pro b/modules/idl_downloads/astro/pro/irafrd.pro new file mode 100644 index 0000000..c4d18ba --- /dev/null +++ b/modules/idl_downloads/astro/pro/irafrd.pro @@ -0,0 +1,300 @@ +pro irafrd,im,hd,filename, SILENT=silent ;Read in IRAF image array and header array +;+ +; NAME: +; IRAFRD +; PURPOSE: +; Read an IRAF (.imh) file into IDL image and header arrays. +; EXPLANATION: +; The internal IRAF format changed somewhat in IRAF V2.11 to a machine +; independent format, with longer filename allocations. This version +; of IRAFRD should be able to read either format. +; +; CALLING SEQUENCE: +; IRAFRD, im, hdr, filename, [/SILENT ] +; +; OPTIONAL INPUT: +; FILENAME - Character string giving the name of the IRAF image +; header. If omitted, then program will prompt for the +; file name. IRAFRD always assumes the header file has an +; extension '.imh'. IRAFRD will automatically locate the +; ".pix" file containing the data by parsing the contents of +; the .imh file. (If the parse is unsuccesful, then IRAFRD looks +; in the same directory as the .imh file.) +; OUTPUTS: +; IM - array containing image data +; HDR - string array containing header. Basic information in the +; IRAF header is converted to a FITS style header +; +; OPTIONAL INPUT KEYWORDS: +; /SILENT - If this keyword is set and non-zero, then messages displayed +; while reading the image will be suppressed. +; +; RESTRICTIONS: +; (1) Image size and history sections of the IRAF header are copied +; into the FITS header HDR. Other information (e.g. astrometry) +; might not be included unless it is also in the history section +; (2) IRAFRD ignores the node name when deciphering the name of the +; IRAF ".pix" file. +; (3) Certain FITS keywords ( DATATYPE, IRAFNAME) may appear more than +; once in the output name +; (4) Does not read the DATE keyword for the new (V2.11) IRAF files +; NOTES: +; IRAFRD obtains dimensions and type of image from the IRAF header. +; +; PROCEDURES CALLED: +; FDECOMP, SXADDPAR, SXPAR() +; +; MODIFICATION HISTORY: +; Written W. Landsman, STX January 1989 +; Converted to IDL Version 2. M. Greason, STX, June 1990 +; Updated for DecStation compatibility W. Landsman March 1992 +; Don't leave an open LUN W. Landsman July 1993 +; Don't overwrite existing OBS-DATE W. Landsman October 1994 +; Don't bomb on very long FITS headers W. Landsman April 1995 +; Work on Alpha/OSF and Linux W. Landsman Dec 1995 +; Remove /VMSIMG keyword, improve efficiency when physical and +; image dimensions differ W. Landsman April 1996 +; Don't use FINDFILE (too slow) W. Landsman Oct 1996 +; Read V2.11 files, remove some parameter checks W. Landsman Nov. 1997 +; Fixed problem reading V2.11 files with long headers Jan. 1998 +; Accept names with multiple extensions W. Landsman April 98 +; Test for big endian machine under V2.11 format W. Landsman Feb. 1999 +; Don't read past the end of file for V5.4 compatilibity W.L. Jan. 2001 +; Convert to square brackets W.L May 2001 +; Assume since V5.4, remove SPEC_DIR() W. L. April 2006 +;- + On_error,2 ;Return to caller + compile_opt idl2 + npar = N_params() + + if ( npar EQ 0 ) then begin + print,'Syntax - IRAFRD, im, hdr, [filename, /SILENT ]' + return + endif + + if ( npar EQ 3 ) then $ + if ( N_elements(filename) EQ 0 ) then message, $ + 'Third parameter (IRAF Header file name) must be a character string' $ + else begin + file_name = filename + goto,FINDER + endelse + + file_name = '' ;Get file name if not supplied + read,'Enter name of IRAF data file (no quotes): ',file_name + if ( file_name EQ '' ) then return + +FINDER: + fdecomp, file_name, disk, dir, name, ext, ver + + IF ext EQ 'imh' THEN fname = file_name ELSE fname = file_name + '.imh' + + openr, lun1, fname, /GET_LUN, ERROR = error ;Open the IRAF header file + if error NE 0 then $ + message, 'Unable to find IRAF header file '+ FILE_EXPAND_PATH(fname) + +; Get image size and name from IRAF header + irafver = bytarr(5) + readu, lun1, irafver + newformat = string(irafver) EQ 'imhv2' + big_endian = is_ieee_big() + + if newformat then begin + hdrsize = 2048 + doffset = 2048 + endif else begin + hdrsize = 572 + doffset = 1024 + endelse + + point_lun, lun1, 0 ;Back to top of the header + tmp = assoc(lun1,bytarr(hdrsize)) + hdr = tmp[0] + hdr2 = hdr + + if not newformat then begin ;Old format is not machine independent + + if not big_endian then begin + byteorder,hdr,/sswap + byteorder,hdr,/lswap + endif + + hdrlen = fix(hdr,12) ;Length (in words) of header + datatype = fix(hdr,16) ;IRAF datatype + ndim = fix(hdr,20) ;Number of dimensions + if ( ndim GT 5 ) then $ + message,'Too stupid to do more than 5 dimensions' + if (ndim EQ 0) then message,'IRAF file contains no data (NAXIS = 0)' + + dimen = long(hdr2,24,ndim) ;Get vector of image dimensions + physdim = long(hdr2,52,ndim) ;Get vector of physical dimensions + + if big_endian then pixname = string( hdr[412+indgen(80)*2] ) else $ + pixname = string( hdr2[413+indgen(80)*2] ) + endif else begin + + hdrlen = long(hdr,6) ;Length (in words) of header + datatype = fix(hdr,12) ;IRAF datatype + ndim = fix(hdr,20) ;Number of dimensions + if big_endian then begin + byteorder,hdrlen,/NTOHL + byteorder,datatype,/NTOHS + byteorder,ndim,/NTOHS + endif + if ( ndim GT 7 ) then $ + message,'Too stupid to do more than 7 dimensions' + if (ndim EQ 0) then message,'IRAF file contains no data (NAXIS = 0)' + + dimen = long(hdr,22,ndim) ;Get vector of image dimensions + physdim = long(hdr,50,ndim) ;Get vector of physical dimensions + if big_endian then begin + byteorder,dimen,/NTOHL + byteorder,physdim, /NTOHL + endif + pixname = string(hdr[126:126+255]) + endelse + + expos = strpos(pixname,'!') + pixname = strmid(pixname,expos+1,strlen(pixname)) + + expos = strpos(pixname,'!') + pixname = strmid(pixname,expos+1,strlen(pixname)) + + if strmid(pixname,0,4) eq 'HDR$' then begin + if disk + dir EQ '' then begin + cd, CURRENT = curdir + curdir = curdir + path_sep() + endif else curdir = disk+dir + pixname = curdir + strmid(pixname,4,strlen(pixname)) + endif + +; Use file name found in header to open .pix file. If this file is not +; found then look for a .pix file in the same directory as the header + + openr, lun2, pixname, ERROR=err, /GET_LUN ; ...on given directory + + if ( err LT 0 ) then begin + openr,lun2, name + '.pix', ERROR = err, /GET_LUN + if ( err LT 0 ) then goto, NOFILE + endif + + if ~keyword_set(SILENT) then begin + + sdim = strtrim(dimen[0],2) + message,'Now reading '+strjoin(sdim,' by ') + $ + ' IRAF array', /INFORM + endif + +; Convert from IRAF data types to IDL data types + + CASE datatype OF + 1: begin & dtype = 1 & bitpix = 8 & end ;Byte + 3: begin & dtype = 2 & bitpix = 16 & end ;Integer*2 + 4: begin & dtype = 3 & bitpix = 32 & end ;Integer*4 + 5: begin & dtype = 3 & bitpix = 32 & end ;Integer*4 + 6: begin & dtype = 4 & bitpix = -32 & end ;Real*4 + 7: begin & dtype = 5 & bitpix = -64 & end ;Real*8 + 11: begin &dtype = 3 & bitpix = 16 & end ;Integer*2 + else: message,'Unknown Datatype Code ' + strtrim(datatype,2) + endcase + +; Read the .pix file, skipping the first 1024 bytes. The last physical +; dimension can be set equal to the image dimension. + + physdim[ndim-1] = dimen[ndim-1] + tmp = assoc (lun2, make_array(DIMEN = physdim, TYPE= dtype, /NOZERO), doffset) + im = tmp[0] + +; If the physical dimension of an IRAF image is larger than the image size, +; then extract the appropriate subimage + + dimen = dimen - 1 + pdim = physdim - 1 + case ndim of + 1 : + 2 : if dimen[0] LT pdim[0] then im = im[ 0:dimen[0], *] + 3 : if total(dimen LT pdim) then im = im[ 0:dimen[0], 0:dimen[1], * ] + 4 : if total(dimen LT pdim) then $ + im = im[ 0:dimen[0], 0:dimen[1], 0:dimen[2], * ] + 5 : if total(dimen LT pdim) then $ + im = im[ 0:dimen[0], 0:dimen[1], 0:dimen[2], 0:dimen[3], *] + 6: if total(dimen LT pdim) then $ + im = im[ 0:dimen[0], 0:dimen[1], 0:dimen[2], 0:dimen[3], $ + 0:dimen[4], *] + 7: if total(dimen LT pdim) then $ + im = im[ 0:dimen[0], 0:dimen[1], 0:dimen[2], 0:dimen[3], $ + 0:dimen[4], 0:dimen[5], *] + endcase + + hd = strarr(ndim + 5) + string(' ',format='(a80)') ;Create empty FITS hdr + hd[0] = 'END' + string(replicate(32b,77)) + + sxaddpar, hd, 'SIMPLE', 'T',' Read by IDL: '+ systime() + sxaddpar, hd, 'BITPIX', bitpix + sxaddpar, hd, 'NAXIS', ndim ;# of dimensions + if ( ndim GT 0 ) then $ + for i = 1, ndim do sxaddpar,hd,'NAXIS' + strtrim(i,2),dimen[i-1]+1 + + sxaddpar,hd,'irafname',name + '.imh' ;Add history records + + if ( hdrlen GT 513 ) then begin ;Add history records + + if newformat then nfits = (hdrlen*2l - 2049)/81 else $ + nfits = (hdrlen*4l - 2054)/162 + tmp = assoc(lun1,bytarr(hdrlen*4l < (fstat(lun1)).size )) + hdr = tmp[0] + if not newformat then if not big_endian then byteorder, hdr, /SSWAP +SKIP1: + if newformat then $ + object = string( hdr[638 + indgen(67)] ) else $ + object = string( hdr[732 + indgen(67)*2] ) + if (object NE '') then $ + sxaddpar, hd, 'OBJECT', object,' Object Name' ;Add object name + + endline = where( strmid(hd,0,8) EQ 'END ') + endline = endline[0] + endfits = hd[endline] + hd = [ hd[0:endline-1], strarr(nfits+1) ] + + if newformat then begin + index = indgen(80) + for i = 0l,nfits-1 do $ + hd[endline+i] = string( hdr[2046 + 81*i + index] ) + endif else begin + index = indgen(80)*2 + for i = 0l,nfits-1 do $ + hd[endline+i] = string( hdr[ 2052 + 162*i + index] ) + endelse + + hd[endline + nfits] = endfits ;Add back END keyword + + if not newformat then begin + history = string(hdr[ 892 + indgen(580)*2] ) + st1 = gettok( history, string(10B)) + if big_endian then $ + origin = gettok( strmid( st1, 1, strlen(st1)),"'") else $ + origin = gettok( strmid( st1, 0, strlen(st1)),"'") + sxaddpar, hd, 'ORIGIN', origin, ' ', 'IRAFNAME' ; Add 'ORIGIN" record + + test = sxpar(hd,'HISTORY', Count = N) + if N EQ 0 then begin + while (strpos(history,string(10B)) GE 0) do begin + + hist_rec = gettok( history, string(10B) ) ; Add history comment strings + sxaddpar, hd, 'HISTORY', hist_rec + endwhile + endif + endif + endif + + free_lun,lun1,lun2 + + return ;Successful return + +NOFILE: + + message,'Unable to find IRAF pixel file ' + pixname,/CON + free_lun,lun1 + return + + end diff --git a/modules/idl_downloads/astro/pro/irafwrt.pro b/modules/idl_downloads/astro/pro/irafwrt.pro new file mode 100644 index 0000000..c4609f3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/irafwrt.pro @@ -0,0 +1,249 @@ +pro irafwrt, image, hd, filename, PIXDIR = pixdir +;+ +; NAME: +; IRAFWRT +; PURPOSE: +; Write IDL data in IRAF (OIF) format (.imh and .pix files). +; EXPLANATION: +; Does the reverse of IRAFRD. IRAFWRT writes the "old" IRAF format +; used prior to v2.11. However, this "old" format is still readable by +; the current version of IRAF. +; +; CALLING SEQUENCE: +; IRAFWRT, image, hdr, filename, [ PIXDIR = ] +; +; INPUTS: +; image - array containing data +; hdr - The corresponding FITS header. Use MKHDR to create a minimal +; FITS header if one does not already exist. +; filename - Scalar string giving the name of the file to be written +; Should not include the extension name, which will be supplied +; by IRAFWRT. +; OUTPUTS: +; None +; +; OPTIONAL KEYWORD INPUT: +; PIXDIR - scalar string specifying the directory into which to write +; the IRAF pixel (.pix) file. The default is to write the pixel +; file to the same directory as the header (.imh) file +; +; SIDE EFFECTS: +; Image array and FITS header are written to IRAF pixel file +; 'filename'.pix and header file 'filename'.imh +; +; EXAMPLE: +; Write an empty 50 x 50 array of all zeros to an IRAF file named 'EMPTY' +; +; IDL> im = intarr( 50, 50) ;Create empty array +; IDL> mkhdr, hdr, im ;Create a minimal FITS header +; IDL> irafwrt, im, hdr, 'empty' ;Write to a IRAF file named 'empty' +; +; PROCEDURE: +; IRAFWRT gets information about the data - image dimensions, size, +; datatype, maximum and minimum pixel values - and writes it into +; the binary part of the header. The ASCII part of the header +; is directly copied after deleting records with certain keywords +; A pixel file is created, with a header in the first 1024 bytes +; +; RESTRICTIONS: +; (1) The files are not created by IRAFWRT are not identical to those +; created by the IRAF routine rfits. However, the files +; created by IRAFWRT appear to be compatible with all the IRAF +; routines tested so far. +; (2) IRAFWRT has been tested on a limited number of data types +; (3) IRAFWRT has only been tested on Unix and VMS systems. +; +; PROCEDURES CALLED: +; FDECOMP, IS_IEEE_BIG(), ISARRAY(), REPCHR(), STRN(), SXDELPAR, SXPAR() +; MODIFICATION HISTORY: +; Written K. Venkatakrishna, STX February 1992 +; VMS compatibility W. Landsman April 1992 +; Work with headers without DATE-OBS or ORIGIN August 1992 +; Preserve HISTORY records with other FITS records March 1995 +; Fix case where a minimal FITS header supplied August 1995 +; Work under Alpha/OSF and Linux Dec. 1995 +; Make sureheader has 80 char lines, use IS_IEEE_BIG() May 1997 +; Don't apply strlowcase to .pix name W. Landsman April 1999 +; Work with double precision W. Landsman May 1999 +; Minimize use of obsolete !ERR W. Landsman Feb. 2000 +; Assume since V5.5, remove VMS support W. Landsman Sep. 2006 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - IRAFWRT, image, header, filename, [PIXDIR = ]' + return + endif +; +; Get the dimensions, vector of dimensions and the data type + + imsize = size(image) + naxis = imsize[0] + imdim = imsize[1:naxis] + type = imsize[naxis+1] + im_max = max(image,min=im_min) ; find the minimum and maximum pixel values + + case type of + 1: datatype = 1 + 2: datatype = 3 + 3: datatype = 4 + 4: datatype = 6 + 5: datatype = 7 + else: message,'ERROR - Input data type is currently unsupported' + endcase + + fname = filename + + big_endian = is_ieee_big() + + header = fname+'.imh' + openw, lun1, header, /GET_LUN + + object = sxpar( hd, 'OBJECT',Count = N_object) + if ( N_object EQ 0 ) or ( object EQ '' ) then object = ' ' + origin = sxpar( hd, 'ORIGIN', Count = N_origin) + if ( N_origin EQ 0 ) or ( origin EQ '') then origin = ' ' + date_obs = sxpar( hd, 'DATE-OBS', Count = N_date ) + if ( N_date EQ 0 ) or ( date_obs EQ '') then date_obs = ' ' + + hist_rec = where(strpos(hd,'HISTORY') EQ 0, Nhist) ; Get history records + if Nhist GT 0 then history = hd[hist_rec] else $ + history = ' ' + +;Copy header to new variable and leave original variable unmodified + xhdr = hd + + delete_rec = ['SIMPLE', 'BITPIX', 'NAXIS ', 'NAXIS1', 'NAXIS2', 'DATATYPE', $ + 'OBJECT', 'ORIGIN', 'BSCALE', 'BZERO', 'GROUPS', $ + 'IRAFNAME', 'END'] + + sxdelpar, xhdr, delete_rec + + nmax = N_elements(xhdr) + bhdr = replicate(32b, 80, nmax) ;Make sure it is 80 bytes + for i = 0l,nmax-1 do bhdr[0,i] = byte(xhdr[i]) + + if isarray(xhdr) then $ + hdrlen = (nmax*162 + 2056)/4 $ + else hdrlen = 514 + + hdr = bytarr(hdrlen*4) ; Create header array + + inp = [ fix(hdrlen), fix(datatype), fix(naxis)] + + buf = bytarr(1024) + hdr[12] = byte(inp,0,2) ; write header length, data type + hdr[16] = byte(inp,2,2) ; and number of dimensions into + hdr[20] = byte(inp,4,2) ; header + buf[20] = byte(inp,4,2) +; +; find current time in seconds wrt Jan-01-80 00:00:00 +; + time_creat = systime(2)-315550800. + if big_endian then byteorder, hdr, /LSWAP + + min = strn(im_min,format = '(E13.6)') + max = strn(im_max,format = '(E13.6)') + max_rec_pos = where(strpos(xhdr,'IRAF-MAX = ') EQ 0) + min_rec_pos = where(strpos(xhdr,'IRAF-MIN = ') EQ 0) + if (max_rec_pos[0] GE 0) then begin + max_rec = xhdr[max_rec_pos[0]] ; write maximum + min_rec = xhdr[min_rec_pos[0]] ; and minimum pixel + strput,max_rec,max,18 ; values + strput,min_rec,min,18 + xhdr[max_rec_pos[0]] = max_rec + xhdr[min_rec_pos[0]] = min_rec + end +; +; write the ascii part of the header +; + if hdrlen GT 514 then $ + for i = 0, nmax-1 do begin + hdr[ 2052 + 162L*i + lindgen(80)*2] = bhdr[*,i] + hdr[2052+162L*i+160] = 10B + endfor + + if big_endian then byteorder,hdr,/SSWAP + if not big_endian then offset = 0 else offset = 1 + hdr[ 732 + indgen(strlen(object))*2+offset] = byte(object) + hdr[indgen(5)*2 + offset] = byte('imhdr') + hdr[24] = byte(imdim,0,4*naxis) + buf[24] = byte(imdim,0,4*naxis) + hdr[52] = byte(imdim,0,4*naxis) + hdr[120] = byte(im_max,0,4) + hdr[124] = byte(im_min[0],0,4) + cd,current = dir + + host = getenv('HOST') + dir = dir + path_sep() + + if keyword_set(pixdir) then dir = pixdir + pixname = host+'!' + dir + fname + '.pix' + len1 = strlen(pixname) + len2 = strlen(header) + hdr[ 412 + offset + indgen(len1[0])*2] = byte(pixname) ; write pixel file location + hdr[ 572 + offset + indgen(len2[0])*2] = byte(header) ; into header +; Get the history records +; + ind = 893 + hdr[ind+indgen(strlen(origin[0]))*2] = byte(origin[0]) + ind = ind+2*strlen(origin[0]) + hdr[ind] = 10B + ind = ind+2 + hdr[ind+indgen(strlen(date_obs[0]))*2] = byte(date_obs[0]) + ind = ind+2*strlen(date_obs[0]) + hdr[ind] = 10B + ind = ind+2 + +; write the history comment strings (as many as possible) in binary form +; into the available 1160 bytes + + for i = 0, N_elements(history)-1 do begin + hist = strtrim(strmid(history[i],8,72)) + if ( strlen(hist) EQ 0 ) then goto, SKIP + if (ind + 2*strlen(hist) GT 2052 ) then goto, HIST_END + hdr[ ind + indgen( strlen(hist) )*2 ] = byte(hist) + ind = ind+2*strlen(hist) + hdr[ind] = 10B + ind = ind+2 + SKIP: + end + HIST_END: + hdr[88 + 2*offset] = byte(513,0,2) + hdr[108] = byte(long(time_creat),0,4) ; write time of image creation + buf[108] = byte(long(time_creat),0,4) ; time of last modification + hdr[112] = byte(long(time_creat),0,4) ; and time minimum and maximum + hdr[116] = byte(long(time_creat),0,4) ; pixel values were computed + + hdr[32 + indgen(5)*4 + 3*offset] = 1 + buf[32 + indgen(5)*4 + 3*offset] = 1 + if big_endian then begin + hdr[63 + indgen(5)*4] = 1 + buf[63 + indgen(5)*4] = 1 + endif + hdr[63 + indgen(5)*4 - 3*offset] = 128 + buf[63 + indgen(5)*4 - 3*offset] = 128 + + writeu,lun1,hdr + free_lun,lun1 + +; Write the data into the .pix file + + buf[ offset + indgen(5)*2] = byte('impix') + if not big_endian then buf[12] = [65b, 58b] else $ + buf[14] = [58b, 65b] + hdrname = repchr(pixname,'pix','imh') + buf[ 412 + offset+ indgen(len1[0])*2 ] = byte(hdrname) + buf[ 572 + offset + indgen(len2[0])*2] = byte(header) + node = strpos( pixname, '!') + pixfile = strmid( pixname, node+1,strlen(pixname)-node+1 ) + + openw,lun2, pixfile, /GET_LUN + + writeu, lun2, buf + writeu, lun2, image + + free_lun, lun2 + + return + end diff --git a/modules/idl_downloads/astro/pro/is_ieee_big.pro b/modules/idl_downloads/astro/pro/is_ieee_big.pro new file mode 100644 index 0000000..9127dd7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/is_ieee_big.pro @@ -0,0 +1,32 @@ +function is_ieee_big +;+ +; NAME: +; IS_IEEE_BIG +; PURPOSE: +; Determine if the current machine uses IEEE, big-endian numbers. +; EXPLANATION: +; (Big endian implies that byteorder XDR conversions are no-ops). +; CALLING SEQUENCE: +; flag = is_ieee_big() +; INPUT PARAMETERS: +; None +; RETURNS: +; 1 if the machine appears to be IEEE-compliant, 0 if not. +; COMMON BLOCKS: +; None. +; SIDE EFFECTS: +; None +; RESTRICTIONS: +; PROCEDURE: +; The first byte of the two-byte representation of 1 is examined. +; If it is zero, then the data is stored in big-endian order. +; MODIFICATION HISTORY: +; Written 15-April-1996 by T. McGlynn for use in MRDFITS. +; 13-jul-1997 jkf/acc - added calls to check_math to avoid +; underflow messages in V5.0 on Win32 (NT). +; Converted to IDL V5.0 W. Landsman September 1997 +; Follow RSI and just do a single test W. Landsman April 2003 +;- + + return, 1b - (byte(1,0,1))[0] + end diff --git a/modules/idl_downloads/astro/pro/isarray.pro b/modules/idl_downloads/astro/pro/isarray.pro new file mode 100644 index 0000000..0e7e051 --- /dev/null +++ b/modules/idl_downloads/astro/pro/isarray.pro @@ -0,0 +1,20 @@ +;+ +; NAME: +; ISARRAY +; PURPOSE: +; Test if the argument is an array or not. +; +; CALLING SEQUENCE: +; res = isarray(a) +; +; INPUTS: +; a - argument +; +; REVISION HISTORY: +; Rewritten from scratch, Ole Streicher, 2015 +; +;- +FUNCTION isarray, a + res = size(a) + return, res[0] ne 0 +END diff --git a/modules/idl_downloads/astro/pro/ismeuv.pro b/modules/idl_downloads/astro/pro/ismeuv.pro new file mode 100644 index 0000000..c23a501 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ismeuv.pro @@ -0,0 +1,176 @@ +function ismeuv,wave,Hcol,HeIcol,HeIIcol,Fano=fano +;+ +; NAME: +; ISMEUV +; PURPOSE: +; Compute the continuum interstellar EUV optical depth +; +; EXPLANATION: +; The EUV optical depth is computed from the photoionization of +; hydrogen and helium. +; +; CALLING SEQUENCE: +; tau = ISMEUV( wave, Hcol, [ HeIcol, HeIIcol, /Fano ] +; +; INPUTS: +; wave - Vector of wavelength values (in Angstroms). Useful range is +; 40 - 912 A; at shorter wavelengths metal opacity should be +; considered, at longer wavelengths there is no photoionization. +; Hcol - Scalar specifying interstellar hydrogen column density in cm-2. +; Typical values are 1E17 to 1E20. +; +; OUTPUT: +; tau - Vector giving resulting optical depth, same number of elements +; as wave, non-negative values. To obtain the attenuation of +; an input spectrum, multiply by exp(-tau). +; +; OPTIONAL INPUTS: +; HeIcol - Scalar specifying neutral helium column density in cm-2. +; Default is 0.1*Hcol (10% of hydrogen column) +; HeIIcol - Scalar specifying ionized helium column density in cm-2 +; Default is 0 (no HeII) +; +; OPTIONAL INPUT KEYWORDS: +; /FANO - If this keyword is set and non-zero, then the 4 strongest +; auto-ionizing resonances of He I are included. The shape +; of these resonances is given by a Fano profile - see Rumph, +; Bowyer, & Vennes 1994, AJ, 107, 2108. If these resonances are +; included then the input wavelength vector should have +; a fine (>~0.01 A) grid between 190 A and 210 A, since the +; resonances are very narrow. +; EXAMPLE: +; (1) One has a model EUV spectrum with wavelength, w (in Angstroms) and +; flux,f . Plot the model flux after attenuation by 1e18 cm-2 of HI, +; with N(HeI)/N(HI) = N(HeII)/N(HI) = 0.05 +; +; IDL> Hcol = 1e18 +; IDL> plot, w, f*exp(-ismeuv(w, Hcol, .05*Hcol, .05*Hcol)) +; +; (2) Plot the cross-section of HeI from 180 A to 220 A for 1e18 cm-2 +; of HeI, showing the auto-ionizing resonances. This is +; Figure 1 in Rumph et al. (1994) +; +; IDL> w = 180 + findgen(40000)*0.001 ;Need a fine wavelength grid +; IDL> plot, w, ismeuv(w, 0, 1e18, /Fano) +; +; NOTES: +; (1) The more complete program ismtau.pro at +; http://hea-www.harvard.edu/PINTofALE/pro/ extends this work +; to shorter wavelengths and includes metal and molecular hydrogen +; opacities +; (2) This program only compute continuum opacities, and for example, +; the He ionization edges at 504 A and 228 A are blurred by +; converging line absorptions (Dupuis et al. 1995. ApJ, 455, 574) +; +; HISTORY: +; Written, W. Landsman October, 1994 +; Adapted from ism.c at anonymous ftp site cea-ftp.cea.berkeley.edu +; by Pat Jelinsky, Todd Rumph & others. +; Avoid underflow messages, support double prec. W. Landsman October 2003 +; Fix error in He II optical Depth J. Slavin/WL Sep 2013 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - tau = ISMEUV( wave, Hcol, [ HeIcol, HeIIcol, /FANO] )' + return,-1 + endif + + if N_elements( HeIcol) EQ 0 then HeIcol = 0.1*Hcol + if N_elements( HeIIcol) EQ 0 then HeIIcol = 0.0*Hcol + +; Compute attenuation due to photoionization of hydrogen. See Spitzer +; (Physical processes in the interstellar medium), page 105 + + if (size(wave,/TNAME) EQ 'DOUBLE') then begin + pi = !dpi + double = 1b + endif else begin + pi = !pi + double = 0b + endelse + ratio = wave/911.75 + tauh = wave*0. + good = where(ratio LT 1, Ngood) + minexp = alog((machar(double=double)).xmin) ;Min exponent to avoid underflow + if Ngood GT 0 then begin + r = ratio[good] + z = sqrt( r/(1.0-r) ) + denom = replicate(1.0, Ngood) + y = -2.*pi*z + good1 = where(y GT minexp, Ngood1) + if Ngood1 GT 0 then denom[good1] = (1.0 - exp(y[good1])) + tauh[good] = Hcol * 3.44e-16 * (r^4)*exp(-4.0*z*atan(1/z)) / denom + endif + +; Now compute photoionization cross-section of He II; just like hydrogen but +; with a nuclear charge Z = 2 + + tauheII = wave*0. + ratio = 4. * wave/911.75 + good = where(ratio LT 1, Ngood) + if Ngood GT 0 then begin + r = ratio[good] + z = sqrt( r/(1.0-r) ) + denom = replicate(4.0, Ngood) ;Z^2 Bug fix Sep 13 + y = -2*PI*z + good1 = where(y GT minexp, Ngood1) + if Ngood1 GT 0 then denom[good1] *= (1.0 - exp(y[good1])) + tauheII[good] = heiicol * 3.44e-16 * (r^4)*exp(-4.0*z*atan(1/z)) / denom + + endif + +; Polynomial coefficients for He I cross-section taken from experimental +; data by Marr & West (1976) +; c1 for wavelengths greater than 46 A + + c1 = [-2.953607d+01, 7.083061d+00, 8.678646d-01,-1.221932d+00, $ + 4.052997d-02, 1.317109d-01, -3.265795d-02, 2.500933d-03 ] + +; c2 for wavelengths less than 46 A. + + c2 = [ -2.465188d+01, 4.354679d+00, -3.553024d+00, 5.573040d+00, $ + -5.872938d+00, 3.720797d+00, -1.226919d+00, 1.576657d-01 ] + +; parameters of autoionization resonances for 4 strongest He I resonances +; Numbers are from Oza (1986), Phys Rev. A, 33, 824 -- nu and gamma +; and Fernley et al., J. Phys. B., 20, 6457, 1987 -- q + + q = [2.81d, 2.51d, 2.45d, 2.44d ] + nu = [1.610d, 2.795d, 3.817d, 4.824d ] + fano_gamma = [2.64061d-03, 6.20116d-04, 2.56061d-04, 1.320159d-04 ] + esubi = 3.0d - 1.0d/nu^2 + 1.807317d + + tauHeI = wave*0. + good = where( wave LT 503.97, Ngood ) + if Ngood GT 0 then begin + + x = alog10(wave[good]) + y = x*0. + + good1 = where(wave LT 46.0, Ngood1 ) + if Ngood1 GT 0 then y[good1] = poly( x[good1], c2) + + good2 = where(wave GE 46.0, Ngood2 ) + if Ngood2 GT 0 then begin + + y[good2] = poly( x[good2], c1) + + if keyword_set(fano) then begin + epsilon = 911.2671/wave + for i=0,3 do begin ;Loop over first four HeI resonances + x = 2.0 * ((epsilon-esubi[i] )/ fano_gamma[i] ) + y = y + alog10( (x - q[i])^2/ (1 + x*x ) ) + endfor + endif + endif + + tauHeI[good] = HeIcol * 10^y + + endif + +; Total optical depth from HI, HeII and HeI + + return, tauH + tauHeII + tauHeI + + end diff --git a/modules/idl_downloads/astro/pro/jdcnv.pro b/modules/idl_downloads/astro/pro/jdcnv.pro new file mode 100644 index 0000000..652dd30 --- /dev/null +++ b/modules/idl_downloads/astro/pro/jdcnv.pro @@ -0,0 +1,67 @@ +PRO JDCNV, YR, MN, DAY, HR, JULIAN +;+ +; NAME: +; JDCNV +; PURPOSE: +; Converts Gregorian dates to Julian days +; +; EXPLANATION: +; For IDL versions V5.1 or greater, this procedure is superceded by +; JULDAY() function in the standard IDL distribution. Note, however, +; that prior to V5.1 there wasa bug in JULDAY() that gave answers off +; by 0.5 days. +; +; CALLING SEQUENCE: +; JDCNV, YR, MN, DAY, HR, JULIAN +; +; INPUTS: +; YR = Year, integer scalar or vector +; MN = Month integer (1-12) scalar or vector +; DAY = Day integer 1-31) scalar or vector +; HR = Hours and fractions of hours of universal time (U.T.), scalar +; or vector +; +; OUTPUTS: +; JULIAN = Julian date (double precision) +; +; EXAMPLE: +; To find the Julian Date at 1978 January 1, 0h (U.T.) +; +; IDL> JDCNV, 1978, 1, 1, 0., JULIAN +; +; will give JULIAN = 2443509.5 +; NOTES: +; (1) JDCNV will accept vector arguments +; (2) JULDATE is an alternate procedure to perform the same function +; +; REVISON HISTORY: +; Converted to IDL from Don Yeomans Comet Ephemeris Generator, +; B. Pfarr, STX, 6/15/88 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added checks on valid month, day ranges W. Landsman July 2008 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 5 then begin + print,'Syntax - JDCNV, yr, mn, day, hr, julian' + print,' yr - Input Year (e.g. 1978), scalar or vector' + print,' mn - Input Month (1-12), scalar or vector' + print,' day - Input Day (1-31), scalar or vector' + print,' hr - Input Hour (0-24), scalar or vector' + print,' julian - output Julian date' + return + endif + if max(mn) GT 12 then message,/con, $ + 'Warning - Month number outside of expected range [1-12] ' + if max(day) GT 31 then message,/con, $ + 'Warning - Day number outside of expected range [1-31] ' + + yr = long(yr) & mn = long(mn) & day = long(day) ;Make sure integral + L = (mn-14)/12 ;In leap years, -1 for Jan, Feb, else 0 + julian = day - 32075l + 1461l*(yr+4800l+L)/4 + $ + 367l*(mn - 2-L*12)/12 - 3*((yr+4900l+L)/100)/4 + julian = double(julian) + (HR/24.0D) - 0.5D + + return + end diff --git a/modules/idl_downloads/astro/pro/jplephinterp.pro b/modules/idl_downloads/astro/pro/jplephinterp.pro new file mode 100644 index 0000000..61d10df --- /dev/null +++ b/modules/idl_downloads/astro/pro/jplephinterp.pro @@ -0,0 +1,745 @@ +;+ +; NAME: +; JPLEPHINTERP +; +; AUTHOR: +; Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770 +; craigm@lheamail.gsfc.nasa.gov +; UPDATED VERSIONs can be found on my WEB PAGE: +; http://cow.physics.wisc.edu/~craigm/idl/idl.html +; +; PURPOSE: +; Interpolate position and motion of planetary bodies (JPL Ephemeris) +; +; MAJOR TOPICS: +; Planetary Orbits, Interpolation +; +; CALLING SEQUENCE: +; JPLEPHINTERP, INFO, RAWDATA, T, X, Y, Z, [VX, VY, VZ, /EARTH, /SUN, +; OBJECTNAME=, CENTER=, TBASE=, POSUNITS=, VELUNITS= ] +; +; DESCRIPTION: +; +; JPLEPHINTERP interpolates the JPL DE200 or DE405 planetary +; ephemeris to find the positions and motions of planetary bodies. +; +; This routine is the second stage of a two-stage process to +; interpolate the JPL ephemeris. In this first stage, the file is +; opened using JPLEPHREAD, and the relevant portions of the table +; are read and stored into the two variables INFO and RAWDATA. In +; the second stage, the user actually interpolates the ephemeris for +; the desired bodies and to the desired ephemeris time using +; JPLEPHINTERP. +; +; The only independent variable which must be specified is T, the +; ephemeris time. For low to moderate accuracy applications, T is +; simply the conventional calendar date, expressed in Julian days. +; See below for high precision applications. +; +; Upon output, the position components of the desired body are +; returned in parameters X, Y and Z, and if requested velocity +; components are returned in parameters VX, VY and VZ. Coordinates +; are referred to the ephemeris's coordinate system: FK5 for +; JPL-DE200 and ICRS for JPL-DE405. By default, the origin of +; coordinates is the solar system barycenter (SSB), unless another +; origin is selected using the CENTER keyword. +; +; Users must set the VELOCITY keyword to generate body velocities. +; By default they are not generated. +; +; Users can select the desired body by using either the EARTH or SUN +; keywords, or the OBJECTNAME keyword. +; +; By default, positions are returned in units of KM and velocities +; in units of KM/DAY. However, the output units are selectable by +; setting the POSUNITS and VELUNITS keywords. +; +; High Precision Applications +; +; If the required precision is finer than a few hundred meters, the +; user must be aware that the formal definition of the ephemeris +; time is the coordinate time of a clock placed at the solar system +; barycenter (SSB). If the user's time is measured by a clock +; positioned elsewhere, then various corrections must be applied. +; Usually, the most significant correction is that from the +; geocenter to the SSB (see Fairhead & Bretagnon 1990; Fukushima +; 1995). Not applying this correction creates an error with +; amplitude ~170 nano-light-seconds ( = 50 m) on the earth's +; position. (see TDB2TDT) +; +; For high precision, the user should also specify the TBASE +; keyword. TBASE should be considered a fixed epoch with respect to +; which T is measured; T should be small compared to TBASE. +; Internally, subtraction of large numbers occurs with TBASE first, +; so truncation error is minimized by specifying TBASE. +; +; Nutations and Librations +; +; This routine also provides information about earth nutations and +; lunar librations, which are stored in the JPL ephemeris tables. +; The POSUNITS and VELUNITS keywords do not affect these +; computations. +; +; Lunar librations in the form of three Euler angles are returned in +; X, Y, Z, in units of radians, and their time derivatives are +; returned in VX, VY, and VZ in units of radians per day. +; +; The earth nutation angles psi (nutation in longitude) and epsilon +; (nutation in obliquity) are returned in X and Y, in units of +; radians. Their time derivatives are returned in VX and VY +; respectively. The quantities returned in Z and VZ are undefined. +; +; Verification +; +; The precision routine has been verified using JPLEPHTEST, which is +; similar to the original JPL program EPHTEST. For years 1950 to +; 2050, JPLEPHINTERP reproduces the original JPL ephemeris to within +; 1 centimeter. +; +; Custom Ephemerides +; +; It is possible to make custom ephemerides using JPLEPHMAKE, or to +; augmented an existing ephemeris with additional data. In the +; former case JPLEPHINTERP should automatically choose the correct +; object from the table and interpolate it appropriately. +; +; For augmented ephemerides, the object can be specified by name, +; which works as expected, or by number, which has a special +; behavior. For augmented files only, the new objects begin at +; number 100. +; +; +; PARAMETERS: +; +; INFO - structure returned by JPLEPHREAD. Users should not modify +; this structure. +; +; RAWDATA - raw data array returned by JPLEPHREAD. Users should not +; modify this data array. +; +; T - ephemeris time(s) of interest, relative to TBASE (i.e. the +; actual interpolation time is (T+TBASE)). May be a scalar or +; vector. +; +; X, Y, Z - upon return, the x-, y- and z-components of the body +; position are returned in these parameters. For +; nutations and librations see above. +; +; VX, VY, VZ - upon return, the x-, y- and z-components of the body +; velocity are returned in these parameters, if the +; VELOCITY keyword is set. For nutations and +; librations see above. +; +; +; KEYWORD PARAMETERS: +; +; EARTH, SUN - set one of these keywords if the desired body is the +; earth or the sun. One of EARTH, SUN or OBJECTNAME +; must be specified. +; +; OBJECTNAME - a scalar string or integer, specifies the planetary +; body of interest. May take any one of the following +; integer or string values. +; +; 1 - 'MERCURY' 9 - 'PLUTO' +; 2 - 'VENUS' 10 - 'MOON' (earth's moon) +; 3 - 'EARTH' 11 - 'SUN' +; 4 - 'MARS' 12 - 'SOLARBARY' or 'SSB' (solar system barycenter) +; 5 - 'JUPITER' 13 - 'EARTHBARY' or 'EMB' (earth-moon barycenter) +; 6 - 'SATURN' 14 - 'NUTATIONS' (see above) +; 7 - 'URANUS' 15 - 'LIBRATIONS' (see above) +; 8 - 'NEPTUNE' +; +; For custom ephemerides, the user should specify the +; object name or number. +; +; For augmented ephemerides, the user should specify +; the name. If the number is specified, then numbers +; 1-15 have the above meanings, and new objects are +; numbered starting at 100. +; +; CENTER - a scalar string or integer, specifies the origin of +; coordinates. See OBJECTNAME for allowed values. +; Default: 12 (Solar system barycenter) +; +; VELOCITY - if set, body velocities are generated and returned in +; VX, VY and VZ. +; Default: unset (no velocities) +; +; POSUNITS - a scalar string specifying the desired units for X, Y, +; and Z. Allowed values: +; 'KM' - kilometers (default) +; 'CM' - centimeters +; 'AU' - astronomical units +; 'LT-S' - light seconds +; If angles are requested, this keyword is ignored and +; the units are always 'RADIANS'. +; +; VELUNITS - a scalar string specifying the desired units for VX, VY +; and VZ. Allowed values: +; 'KM/DAY' - kilometers per day (default) +; 'KM/S' - kilometers per second +; 'CM/S' - centimeters per second +; 'LT-S/S' or 'V/C' - light seconds per second or +; unitless ratio with speed of light, V/C +; 'AU/DAY' - astronomical units per day +; +; TBASE - a scalar or vector, specifies a fixed epoch against wich T +; is measured. The ephemeris time will be (T+TBASE). Use +; this keyword for maximum precision. +; +; +; EXAMPLE: +; +; Find position of earth at ephemeris time 2451544.5 JD. Units are +; in Astronomical Units. +; +; JPLEPHREAD, 'JPLEPH.200', pinfo, pdata, [2451544D, 2451545D] +; +; JPLEPHINTERP, pinfo, pdata, 2451544.5D, xearth, yearth, zearth, $ +; /EARTH, posunits='AU' +; +; +; REFERENCES: +; +; AXBARY, Arnold Rots. +; ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/ +; +; HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406) +; http://ssd.jpl.nasa.gov/horizons.html +; +; Fairhead, L. & Bretagnon, P. 1990, A&A, 229, 240 +; +; Fukushima, T. 1995, A&A, 294, 895 +; +; Standish, E.M. 1982, "Orientation of the JPL Ephemerides, +; DE200/LE200, to the Dynamical Equinox of J2000", Astronomy & +; Astrophysics, vol. 114, pp. 297-302. +; +; Standish, E.M.: 1990, "The Observational Basis for JPL's DE200, +; the planetary ephemeris of the Astronomical Almanac", Astronomy +; & Astrophysics, vol. 233, pp. 252-271. +; +; SEE ALSO +; JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST, TDB2TDT, JPLEPHMAKE +; +; MODIFICATION HISTORY: +; Written and Documented, CM, Jun 2001 +; Corrected bug in name conversion of NUTATIONS and LIBRATIONS, 18 +; Oct 2001, CM +; Added code to handle custom-built ephemerides, 04 Mar 2002, CM +; Fix bug in evaluation of velocity (only appears in highest order +; polynomial term); JPLEPHTEST verification tests still pass; +; change is of order < 0.5 cm in position, 22 Nov 2004, CM +; Perform more validity checking on inputs; and more informative +; outputs, 09 Oct 2008, CM +; Allow SSB and EMB as shortcuts for solar system and earth-moon +; bary center, 15 Oct 2008, CM +; TBASE now allowed to be a vector or scalar, 01 Jan 2009, CM +; VELFAC keyword gives scale factor between POSUNITS and VELUNITS, +; 12 Jan 2009, CM +; Add option VELUNITS='V/C' for unitless ratio with speed of light, +; 2012-10-02, CM; +; +; $Id: jplephinterp.pro,v 1.19 2012/10/02 11:32:59 cmarkwar Exp $ +; +;- +; Copyright (C) 2001, 2002, 2004, 2008, 2009, 2012, Craig Markwardt +; This software is provided as is without any warranty whatsoever. +; Permission to use, copy and distribute unmodified copies for +; non-commercial purposes, and to modify and use for personal or +; internal use, is granted. All other rights are reserved. +;- + +pro jplephinterp_calc, info, raw, obj, t, x, y, z, vx, vy, vz, $ + velocity=vel, tbase=tbase + + ; '$Id: jplephinterp.pro,v 1.19 2012/10/02 11:32:59 cmarkwar Exp $' + + if n_elements(tbase) EQ 0 then tbase = 0D + ;; Number of coefficients (x3), number of subintervals, num of rows + nc = info.ncoeff[obj] + ns = info.nsub[obj] + dt = info.timedel + nr = info.jdrows + jd0 = info.jdlimits[0] - tbase + jd1 = info.jdlimits[1] - tbase + + ;; Extract coefficient data from RAW + if obj EQ 11 then begin + ;; Nutations have two components + ii1 = info.ptr[obj]-1 + ii2 = ii1 + nc*ns*2L - 1 + coeffs = reform(dblarr(nc,3,ns,nr), nc,3,ns,nr, /overwrite) + coeffs[0,0,0,0] = reform(raw[ii1:ii2,*],nc,2,ns,nr, /overwrite) + endif else begin + ;; All other bodies are done with three components + ii1 = info.ptr[obj]-1 + ii2 = ii1 + nc*ns*3L - 1 + coeffs = reform(raw[ii1:ii2,*],nc,3,ns,nr, /overwrite) + endelse + + ;; Decide which interval and subinterval we are in + tint = (t-jd0)/dt ;; Interval number (real) + ieph = floor(tint) ;; Interval number (index = int) + tint = (tint-ieph)*ns ;; Subinterval number (real) + nseg = floor(tint) ;; Subinterval number (index = int) + ;; Chebyshev "x" (rescaled to range = [-1,1] over subinterval) + tseg = 2D*(tint - nseg) - 1 + + ;; Below is an optimization. If the time interval doesn't span an + ;; ephemeris subinterval, then we can index the coefficient array by + ;; a scalar, which is much faster. Otherwise we maintain the full + ;; vector-level indexing. + mini = minmax(ieph) & minn = minmax(nseg) + if mini[0] EQ mini[1] AND minn[0] EQ minn[1] then begin + ieph = ieph[0] + nseg = nseg[0] + endif + + ;; Initialize the first two Chebyshev polynomials, which are P_0 = 1 + ;; and P_1(x) = x + p0 = 1D + p1 = tseg + ;; Initial polynomials for Chebyshev derivatives, V_0 = 0, V_1(x) = + ;; 1, V_2(x) = 4*x + v0 = 0D + v1 = 1D + v2 = 4D*tseg + tt = 2D*temporary(tseg) + + x = 0D & y = 0D & z = 0D + vx = 0D & vy = 0D & vz = 0D + i0 = ieph*0 & i1 = i0 + 1 & i2 = i1 + 1 + + ;; Compute Chebyshev functions two at a time for efficiency + for i = 0, nc-1, 2 do begin + if i EQ nc-1 then begin + p1 = 0 + v1 = 0 + endif + ii = i0 + i + jj = i0 + ((i+1) < (nc-1)) + + x = x + coeffs[ii,i0,nseg,ieph]*p0 + coeffs[jj,i0,nseg,ieph]*p1 + y = y + coeffs[ii,i1,nseg,ieph]*p0 + coeffs[jj,i1,nseg,ieph]*p1 + z = z + coeffs[ii,i2,nseg,ieph]*p0 + coeffs[jj,i2,nseg,ieph]*p1 + + if keyword_set(vel) then begin + vx = vx + coeffs[ii,i0,nseg,ieph]*v0 + coeffs[jj,i0,nseg,ieph]*v1 + vy = vy + coeffs[ii,i1,nseg,ieph]*v0 + coeffs[jj,i1,nseg,ieph]*v1 + vz = vz + coeffs[ii,i2,nseg,ieph]*v0 + coeffs[jj,i2,nseg,ieph]*v1 + + ;; Advance to the next set of Chebyshev polynomials. For + ;; velocity we need to keep the next orders around + ;; momentarily. + p2 = tt*p1 - p0 + p3 = tt*p2 - p1 + v2 = tt*v1 - v0 + 2*p1 + v3 = tt*v2 - v1 + 2*p2 + + p0 = temporary(p2) & p1 = temporary(p3) + v0 = temporary(v2) & v1 = temporary(v3) + endif else begin + ;; Advance to the next set of Chebyshev polynomials. For no + ;; velocity, we can re-use old variables. + p0 = tt*p1 - temporary(p0) + p1 = tt*p0 - temporary(p1) + endelse + endfor + + if keyword_set(vel) then begin + vfac = 2D*ns/dt + vx = vx * vfac + vy = vy * vfac + vz = vz * vfac + endif + + return +end + +pro jplephinterp_denew, info, raw, obj, t, x, y, z, vx, vy, vz, $ + velocity=vel, tbase=tbase + + if n_elements(tbase) EQ 0 then tbase = 0D + dt = info.timedel + nr = info.jdrows + jd0 = info.jdlimits[0] + jd1 = info.jdlimits[1] + c = info.c / 1000D + cday = 86400D*info.c/1000D + + ;; Renormalize to fractional and whole days, so fractional + ;; component is between -.5 and +.5, as needed by barycentering + ;; approximation code. + ti = round(t) ;; Delta Time: integer + tbi = round(tbase) ;; Base: integer + + tc = ti + tbi ;; Total time: integer + tt = (t-ti) + (tbase-tbi) ;; Total time: fractional + + tc = tc + round(tt) ;; Re-round: integer + tt = tt - round(tt) ;; Re-round: fractional + t2 = tt*tt ;; Quadratic and cubic terms + t3 = t2*tt + + ieph = tc - round(jd0) + ;; Below is an optimization. If the time interval doesn't span an + ;; ephemeris subinterval, then we can index the coefficient array by + ;; a scalar, which is much faster. Otherwise we maintain the full + ;; vector-level indexing. + mini = minmax(ieph) + if mini[0] EQ mini[1] then ieph = ieph[0] + + if obj EQ 3 then begin + ;; Earth, stored as Taylor series coefficients per day + x = (raw[0,ieph] + raw[3,ieph]*tt + 0.5D*raw[6,ieph]*t2 + $ + (raw[9,ieph]/6D)*t3) + y = (raw[1,ieph] + raw[4,ieph]*tt + 0.5D*raw[7,ieph]*t2 + $ + (raw[10,ieph]/6D)*t3) + z = (raw[2,ieph] + raw[5,ieph]*tt + 0.5D*raw[8,ieph]*t2 + $ + (raw[11,ieph]/6D)*t3) + if keyword_set(vel) then begin + vx = raw[3,ieph] + raw[6,ieph]*tt + 0.5D*raw[9 ,ieph]*t2 + vy = raw[4,ieph] + raw[7,ieph]*tt + 0.5D*raw[10,ieph]*t2 + vz = raw[5,ieph] + raw[8,ieph]*tt + 0.5D*raw[11,ieph]*t2 + endif + x = reform(x, /overwrite) + y = reform(y, /overwrite) + z = reform(z, /overwrite) + + endif else if obj EQ 11 then begin + ;; Sun, stored as daily components only + + x = reform(raw[12,ieph] + tt*0) + y = reform(raw[13,ieph] + tt*0) + z = reform(raw[14,ieph] + tt*0) + if keyword_set(vel) then $ + message, 'ERROR: DENEW format does not provide solar velocity' + + endif else if obj EQ 1000 then begin + + tt = t - (jd0+jd1)/2D + x = spl_interp(raw[15,*], raw[16,*], raw[17,*], tt) + return + + endif else begin + message, 'ERROR: DENEW format does not contain body '+strtrim(obj,2) + endelse +end + +pro jplephinterp, info, raw, t, x, y, z, vx, vy, vz, earth=earth, sun=sun, $ + objectname=obj0, velocity=vel, center=cent, tbase=tbase, $ + posunits=outunit0, velunits=velunit0, $ + pos_vel_factor=velfac, $ + xobjnum=objnum, decode_obj=decode + + if n_params() EQ 0 then begin + message, 'USAGE: JPLEPHINTERP, info, rawdata, teph, x, y, z, '+$ + 'vx, vy, vz, OBJECTNAME="body", /VELOCITY, CENTER="body", '+$ + 'POSUNITS="units", VELUNITS="units", /EARTH, /SUN', /info + return + endif + + ;; The numbering convention for ntarg and ncent is: + ;; 1 = Mercury 8 = Neptune + ;; 2 = Venus 9 = Pluto + ;; 3 = Earth 10 = Moon + ;; 4 = Mars 11 = Sun + ;; 5 = Jupiter 12 = Solar system barycenter + ;; 6 = Saturn 13 = Earth-Moon barycenter + ;; 7 = Uranus 14 = Nutations (longitude and obliquity; untested) + ;; 15 = Librations + ;; This numbering scheme is 1-relative, to be consistent with the + ;; Fortran version. (units are seconds; derivative units are seconds/day) + ;;1000 = TDB to TDT offset (s), returned in X component + + sz = size(info) + if sz[sz[0]+1] NE 8 then message, 'ERROR: INFO must be a structure' + if ((info.format NE 'JPLEPHMAKE') AND $ + (info.format NE 'BINEPH2FITS') AND $ + (info.format NE 'DENEW')) then begin + message, 'ERROR: ephemeris type "'+info.format+'" is not recognized' + endif + + ;; Handle case of custom ephemerides + if info.format EQ 'JPLEPHMAKE' then begin + if n_elements(obj0) GT 0 then begin + sz = size(obj0) + if sz[sz[0]+1] EQ 7 then begin + obj = strupcase(strtrim(obj0[0],2)) + wh = where(info.objname EQ obj, ct) + if ct EQ 0 then $ + message, 'ERROR: '+obj+' is an unknown object' + obj = wh[0] + 1 + endif else begin + obj = floor(obj0[0]) + if obj LT 1 OR obj GT n_elements(info.objname) then $ + message, 'ERROR: Numerical OBJNAME is out of bounds' + endelse + + ;; Interpolate the ephemeris here + jplephinterp_calc, info, raw, obj-1, t, velocity=vel, $ + tbase=tbase, x, y, z, vx, vy, vz + + goto, COMPUTE_CENTER + endif + message, 'ERROR: Must specify OBJNAME for custom ephemerides' + endif + + + ;; ---------------------------------------------------------- + ;; Determine which body or system we will compute + if n_elements(obj0) GT 0 then begin + sz = size(obj0) + if sz[sz[0]+1] EQ 7 then begin + obj = strupcase(strtrim(obj0[0],2)) + case obj of + 'EARTH': obj = 3 + 'SOLARBARY': obj = 12 + 'SSB': obj = 12 + 'EARTHBARY': obj = 13 + 'EMB': obj = 13 + 'NUTATIONS': obj = 14 + 'LIBRATIONS': obj = 15 + 'TDB2TDT': obj = 1000 + ELSE: begin + wh = where(info.objname EQ obj, ct) + if ct EQ 0 then $ + message, 'ERROR: '+obj+' is an unknown object' + obj = wh[0] + 1 + if obj GT 11 then obj = obj + 100 - 14 + end + endcase + endif else begin + obj = floor(obj0[0]) + endelse + endif else begin + if NOT keyword_set(earth) AND NOT keyword_set(sun) then $ + message, 'ERROR: Must specify OBJNAME, EARTH or SUN' + endelse + if keyword_set(earth) then obj = 3 + if keyword_set(sun) then obj = 11 + + ;; If the caller is merely asking us to decode the objectnumber, + ;; then return it now. + objnum = obj + if keyword_set(decode) then return + + jdlimits = info.jdlimits + + ;; ------------------------------------------------------- + ;; Handle case of de200_new.fits format + if info.format EQ 'DENEW' then begin + if objnum NE 3 AND objnum NE 11 AND objnum NE 1000 then $ + message, 'ERROR: DENEW ephemeris table does not support body #'+$ + strtrim(objnum,2) + + jplephinterp_denew, info, raw, objnum, t, x, y, z, vx, vy, vz, $ + velocity=vel, tbase=tbase + + if objnum GE 1000 then return + goto, DO_UNIT + endif + + ;; ------------------------------------------------------- + ;; Otherwise, construct the ephemeris using the Chebyshev expansion + case obj of + 3: begin ;; EARTH (translate from earth-moon barycenter to earth) + ;; Interpolate the earth-moon and moon ephemerides + jplephinterp_calc, info, raw, 2, velocity=vel, tbase=tbase, $ + t, xem, yem, zem, vxem, vyem, vzem + jplephinterp_calc, info, raw, 9, velocity=vel, tbase=tbase, $ + t, xmo, ymo, zmo, vxmo, vymo, vzmo + emrat = info.emrat + + ;; Translate from the earth-moon barycenter to earth + x = xem - emrat * xmo + y = yem - emrat * ymo + z = zem - emrat * zmo + if keyword_set(vel) then begin + vx = vxem - emrat * vxmo + vy = vyem - emrat * vymo + vz = vzem - emrat * vzmo + endif + + end + + 10: begin ;; MOON (translate from earth-moon barycenter to moon) + jplephinterp_calc, info, raw, 9, t, velocity=vel, tbase=tbase, $ + x, y, z, vx, vy, vz + ;; Moon ephemeris is geocentered. If the center is + ;; explicitly earth then return immediately. Otherwise + ;; follow the standard path via the solar barycenter. + if n_elements(cent) GT 0 then begin + jplephinterp, info, objectname=cent[0], tbase=tbase, $ + xobjnum=cent1, /decode_obj + if cent1 EQ 3 then goto, DO_UNIT + endif + + ;; Use solar barycenter via the earth-moon barycenter + jplephinterp_calc, info, raw, 2, t, velocity=vel, tbase=tbase, $ + xem, yem, zem, vxem, vyem, vzem + emrat = 1d - info.emrat + x = xem + emrat * x + y = yem + emrat * y + z = zem + emrat * z + if keyword_set(vel) then begin + vx = vxem + emrat * vx + vy = vyem + emrat * vy + vz = vzem + emrat * vz + endif + end + + 12: begin ;; SOLARBARY + x = t*0D & y = x & z = x + vx = x & vy = x & vz = x + end + + 13: begin ;; EARTHBARY + jplephinterp_calc, info, raw, 2, velocity=vel, tbase=tbase, $ + t, x, y, z, vx, vy, vz + end + + 14: begin ;; NUTATIONS + ;; X = PSI, Y = EPSILON, VX = PSI DOT, VY = EPSILON DOT + jplephinterp_calc, info, raw, 11, velocity=vel, tbase=tbase, $ + t, x, y, z, vx, vy, vz + goto, CLEAN_RETURN + end + + 15: begin ;; LIBRATIONS + jplephinterp_calc, info, raw, 12, velocity=vel, tbase=tbase, $ + t, x, y, z, vx, vy, vz + goto, CLEAN_RETURN + end + + 1000: begin ;; TDT to TDB conversion + x = tdb2tdt(t, deriv=vx, tbase=tbase) + if n_elements(velunit0) GT 0 then begin + ;; Special case of unit conversion when user asks for + ;; "per second" + if strpos(strupcase(velunit0[0]),'/S') GE 0 then $ + vx = vx / 86400d + endif + + goto, CLEAN_RETURN + end + + else: begin + ;; Default objects are derived from the index OBJNUM + if obj GE 1 AND obj LE 11 then begin + RESTART_OBJ: + jplephinterp_calc, info, raw, obj-1, t, velocity=vel, $ + tbase=tbase, $ + x, y, z, vx, vy, vz + endif else begin + if info.edited AND obj GT 11 then begin + ;; Handle case of edited JPL ephemerides - they + ;; start at a value of 100, so shift them to the end + ;; of the JPL ephemeris columns + obj = obj - 100 + 14 + if obj LE n_elements(info.objname) then $ + goto, RESTART_OBJ + endif + message, 'ERROR: body '+strtrim(obj,2)+' is not supported' + endelse + end + endcase + + ;; ------------------------------------------------------- + ;; Compute ephemeris of center, and compute displacement vector + COMPUTE_CENTER: + if n_elements(cent) GT 0 then begin + jplephinterp, info, raw, t, x0, y0, z0, vx0, vy0, vz0, tbase=tbase, $ + objectname=cent, velocity=vel, posunits='KM', velunits='KM/DAY' + x = temporary(x) - temporary(x0) + y = temporary(y) - temporary(y0) + z = temporary(z) - temporary(z0) + if keyword_set(vel) then begin + vx = temporary(vx) - temporary(vx0) + vy = temporary(vy) - temporary(vy0) + vz = temporary(vz) - temporary(vz0) + endif + endif + + DO_UNIT: + + velfac = 1d + + ;; ------------------------------------------------------- + ;; Convert positional units + if n_elements(outunit0) GT 0 then begin + pu = strupcase(strtrim(outunit0[0],2)) + case pu of + 'KM': km = 1 ;; Dummy statement + 'CM': begin + x = x * 1D5 + y = y * 1D5 + z = z * 1D5 + velfac = velfac * 1D5 + end + 'AU': begin + au = info.au*info.c/1000d + x = x / au + y = y / au + z = z / au + velfac = velfac / au + end + 'LT-S': begin + c = info.c / 1000d + x = x / c + y = y / c + z = z / c + velfac = velfac / c + end + ELSE: message, 'ERROR: Unrecognized position units "'+pu+'"' + endcase + endif + + ;; ------------------------------------------------------- + ;; Convert velocity units + if n_elements(velunit0) GT 0 AND keyword_set(vel) then begin + vu = strupcase(strtrim(velunit0[0],2)) + case vu of + 'CM/S': begin + vx = vx * (1D5/86400D) + vy = vy * (1D5/86400D) + vz = vz * (1D5/86400D) + velfac = velfac / (1D5/86400D) + end + 'KM/S': begin + vx = vx * (1D/86400D) + vy = vy * (1D/86400D) + vz = vz * (1D/86400D) + velfac = velfac / (1D/86400D) + end + 'LT-S/S': begin + c = info.c / 1000D + vx = vx / (c*86400D) + vy = vy / (c*86400D) + vz = vz / (c*86400D) + velfac = velfac / (c*86400D) + end + 'V/C': begin ;; Unitless ratio V/C (same as LT-S/S + c = info.c / 1000D + vx = vx / (c*86400D) + vy = vy / (c*86400D) + vz = vz / (c*86400D) + velfac = velfac / (c*86400D) + end + 'KM/DAY': km = 1 ;; Dummy statement + 'AU/DAY': begin + au = info.au*info.c/1000d + vx = vx / au + vy = vy / au + vz = vz / au + velfac = velfac * au + end + ELSE: message, 'ERROR: Unrecognized velocity units "'+vu+'"' + endcase + endif + +CLEAN_RETURN: + return +end diff --git a/modules/idl_downloads/astro/pro/jplephread.pro b/modules/idl_downloads/astro/pro/jplephread.pro new file mode 100644 index 0000000..841679f --- /dev/null +++ b/modules/idl_downloads/astro/pro/jplephread.pro @@ -0,0 +1,404 @@ +;+ +; NAME: +; JPLEPHREAD +; +; AUTHOR: +; Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770 +; craigm@lheamail.gsfc.nasa.gov +; UPDATED VERSIONs can be found on my WEB PAGE: +; http://cow.physics.wisc.edu/~craigm/idl/idl.html +; +; PURPOSE: +; Open and read JPL DE200 or DE405 Ephemeride FITS File +; +; MAJOR TOPICS: +; Planetary Orbits, Interpolation +; +; CALLING SEQUENCE: +; JPLEPHREAD, FILENAME, INFO, RAWDATA, JDLIMITS, STATUS=, ERRMSG= +; +; DESCRIPTION: +; +; JPLEPHREAD opens and reads the JPL DE200 or DE405 planetary +; ephemerides, as available in FITS format. The user must have the +; IDL Astronomy Library installed to use this routine. +; +; This routine is the initialization stage of a two-stage process to +; interpolate the JPL ephemeris. In this first stage, the file is +; opened, and the relevant portions of the table are read and stored +; into the two variables INFO and RAWDATA. In the second stage, the +; user actually interpolates the ephemeris for the desired bodies +; and to the desired ephemeris time using JPLEPHINTERP. +; +; Users must decide ahead of time the approximate dates of interest, +; and pass this range in the JDLIMITS parameter. Any date covered +; by the ephemeris is valid. +; +; JPLEPHREAD is able to read files of the following format: +; DE200 - Chebyshev - FITS format - Note 1 +; DE405 - Chebyshev - FITS format - Note 1 +; DE200 - Taylor - FITS format - Note 2 +; +; Note 1 - Chebyshev formatted FITS files are available in the +; AXBARY package by Arnold Rots, found here: +; ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/ +; or at the Markwardt FTP site: +; ftp://cow.physics.wisc.edu/pub/craigm/bary/ +; +; Note 2 - Taylor-series based ephemerides have been available for +; years in the FTOOLS / LHEASOFT package produced by NASA's +; Goddard Space Flight Center. The original file is +; de200_new.fits, which covers the years 1959-2000, +; inclusive. A newer file is named +; de200_1950-2050_v2.fits, and covers the years 1959-2050. +; See Markwardt FTP site for these files. +; +; PARAMETERS: +; +; FILENAME - name of ephemeris file (scalar string). +; +; INFO - upon completion, information about the ephemeris data is +; returned in this parameter in the form of a structure. +; Users must not modify INFO, although several fields are +; useful and may be accessed read-only: +; TSTART/TSTOP (start and stop time of data in Julian +; days); +; C (speed of light in m/s); +; DENUM (development ephemeris number [200 or 405]) +; AU (1 astronomical unit, in units of light-seconds) +; +; RAWDATA - upon completion, raw ephemeris data is returned in this +; parameter. Users are not meant to access this data +; directly, but rather to pass it to JPLEPHINTERP. +; +; JDLIMITS - a two-element vector (optional), describing the desired +; time range of interest. The vector should have the +; form [TSTART, TSTOP], where TSTART and TSTOP are the +; beginning and ending times of the range, expressed in +; Julian days. +; Default: entire table is read (note, this can be +; several megabytes) +; +; +; KEYWORD PARAMETERS: +; +; STATUS - upon completion, a value of 1 indicates success, and 0 +; indicates failure. +; +; ERRMSG - upon completion, an error message is returned in this +; keyword. If there were no errors, then the returned +; value is the empty string, ''. +; +; +; EXAMPLE: +; +; Find position of earth at ephemeris time 2451544.5 JD. Units are +; in Astronomical Units. +; +; JPLEPHREAD, 'JPLEPH.405', pinfo, pdata, [2451544D, 2451545D] +; +; JPLEPHINTERP, pinfo, pdata, 2451544.5D, xearth, yearth, zearth, $ +; /EARTH, posunits='AU' +; +; +; REFERENCES: +; +; AXBARY, Arnold Rots. +; ftp://heasarc.gsfc.nasa.gov/xte/calib_data/clock/bary/ +; +; HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406) +; http://ssd.jpl.nasa.gov/?horizons +; +; JPL Export Ephemeris FTP Site +; ftp://ssd.jpl.nasa.gov/pub/eph/planets/ +; (ephemeris files are available here, however, they must be +; converted to FITS format using the "bin2eph" utility found in +; AXBARY) +; +; JPL Export Ephemeris CD-ROM - Ordering Information +; http://www.willbell.com/software/jpl.htm +; +; Standish, E.M. 1982, "Orientation of the JPL Ephemerides, +; DE200/LE200, to the Dynamical Equinox of J2000", Astronomy & +; Astrophysics, vol. 114, pp. 297-302. +; +; Standish, E.M.: 1990, "The Observational Basis for JPL's DE200, +; the planetary ephemeris of the Astronomical Almanac", Astronomy +; & Astrophysics, vol. 233, pp. 252-271. +; +; SEE ALSO +; JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST +; PROCEDURES USED: +; FXBCLOSE, FXBOPEN, FXPAR(), +; +; MODIFICATION HISTORY: +; Written and Documented, CM, Jun 2001 +; Use GETTOK() instead of STR_SEP() W. Landsman July 2002 +; Add ephemeris file keywords to INFO, Jan 2002, CM +; Add fields to INFO to be consistent with JPLEPHMAKE, 04 Mar 2002, CM +; Correction of units for INFO.C (Thanks Mike Bernhardt), 2011-04-11, CM +; $Id: jplephread.pro,v 1.10 2011/06/27 18:44:44 cmarkwar Exp $ +; +;- +; Copyright (C) 2001, Craig Markwardt +; This software is provided as is without any warranty whatsoever. +; Permission to use, copy and distribute unmodified copies for +; non-commercial purposes, and to modify and use for personal or +; internal use, is granted. All other rights are reserved. +;- + + +function jplephpar, header, parname, default=default, fatal=fatal +compile_opt idl2 + + ; '$Id: jplephread.pro,v 1.6 2001/07/01 03:32:02 craigm Exp $' + + value = fxpar(header, parname, Count = N_value) + if N_value EQ 0 then begin + if keyword_set(fatal) then $ + message, 'ERROR: keyword '+strupcase(parname)+' was not found' + return, default + endif + return, value +end + +function jplephval, names, values, name, default=default, fatal=fatal + wh = where(names EQ strupcase(name), ct) + if ct EQ 0 then begin + if keyword_set(fatal) then $ + message, 'ERROR: value '+strupcase(name)+' was not found in file' + return, default + endif + return, values[wh[0]] +end + +pro jplephread, filename, info, raw, jdlimits, $ + status=status, errmsg=errmsg + + status = 0 + printerror = 1 - arg_present(errmsg) + errmsg = '' + + if n_params() EQ 0 then begin + message, 'USAGE: JPLEPHREAD, filename, info, rawdata, jdlimits', /info + return + endif + +; if n_elements(jdlimits) LT 2 then begin +; errmsg = 'ERROR: You must specify JDLIMITS' +; return +; endif + + fxbopen, unit, filename, 1, ephhead, errmsg=errmsg + if errmsg NE '' then $ + if printerror then message,errmsg else return + + extname = strtrim(fxpar(ephhead, 'EXTNAME'),2) + ttype1 = strtrim(fxpar(ephhead, 'TTYPE1'),2) + + if (extname EQ 'EPHEM' AND ttype1 EQ 'EARTH') then begin + ;; This is the DE200_NEW format (standard FTOOLS) + + nrows = fxpar(ephhead, 'NAXIS2') + tstart = fxpar(ephhead, 'TSTART') + tstop = fxpar(ephhead, 'TSTOP') + timedel = jplephpar(ephhead, 'TIMEDEL', default=1D) ;; 1-day default + + ;; Constants from XTEBARYCEN.F + C=2.99792458D+8 + TWOPI=6.28318530717958648D0 + DAYSEC=1.D0/86400.D0 + AULTSC=499.004782D0 + GAUSS=0.01720209895D0 + RSCHW=(GAUSS^2)*(AULTSC^3)*(DAYSEC^2) + SUNRAD=2.315D0 + + if n_elements(jdlimits) GE 2 then begin + if (min(jdlimits) LT tstart OR $ + max(jdlimits) GT tstop) then begin + errmsg = 'ERROR: '+filename+$ + ' does not cover the time of interest' + fxbclose, unit + return + endif + ;; Expand by one row either side + rowlimits = floor((jdlimits-tstart)/timedel) + [-2,2] + rowlimits = rowlimits > 1 < nrows + endif else begin + jdlimits = [tstart, tstop] + rowlimits = [1L, nrows] + endelse + + ;; Read raw data + fxbread, unit, cearth, 'EARTH', rowlimits, errmsg=errmsg + if errmsg EQ '' then $ + fxbread, unit, csun, 'SUN', rowlimits, errmsg=errmsg + if errmsg EQ '' then $ + fxbread, unit, ctdb2tdt, 'TIMEDIFF', rowlimits, errmsg=errmsg + fxbclose, unit + if errmsg NE '' then $ + if printerror then message,errmsg else return + + nr = rowlimits[1]-rowlimits[0]+1 + t0 = dindgen(nr)*timedel - (jdlimits[1]-jdlimits[0])/2D + dtt = spl_init(t0, ctdb2tdt) + raw = reform(dblarr(18, nr), 18, nr, /overwrite) + raw[0 :11,*] = cearth * c/1000D ;; units of lt-s + raw[12:14,*] = csun * c/1000D ;; units of lt-s/day + raw[15, *] = t0 + raw[16 ,*] = ctdb2tdt + raw[17 ,*] = dtt + + jdlimits1 = (rowlimits+[-1,0])*timedel + tstart + + info = {filename: filename, edited: 0L, $ + creation_date: '', author: '', $ + nrows: nrows, tstart: tstart, tstop: tstop, $ + timedel: timedel, format: 'DENEW', $ + denum: 200L, c: c, emrat: 0.012150586D, $ + au: aultsc, msol: rschw, sunrad: sunrad, $ + jdlimits: jdlimits1, jdrows: nr } + + + endif else if (extname EQ 'DE1' AND ttype1 EQ 'Cname') then begin + ;; This is the BINEPH2FITS format (either DE200 or DE405) + + ;; --------------------------------------------- + ;; First extension contains parameter data + fxbread, unit, cname, 'Cname' + fxbread, unit, cvalue, 'Cvalue' + cname = strtrim(cname,2) + + denum = 0L & clight = 0D & emrat = 0D & au = 0D + msol = 0D & radsol = 0D + + denum = round(jplephval(cname, cvalue, 'DENUM', /fatal)) + clight = jplephval(cname, cvalue, 'CLIGHT', /fatal) + emrat = jplephval(cname, cvalue, 'EMRAT', /fatal) + au = jplephval(cname, cvalue, 'AU', /fatal) ; km + msol = jplephval(cname, cvalue, 'GMS', /fatal) ; AU^3/day^2 + radsol = jplephval(cname, cvalue, 'RADS', default=-1D) ; km + if radsol EQ -1D then $ + radsol = jplephval(cname, cvalue, 'ASUN', default=-1D) + + emrat = 1D / (1D + emrat) + + if clight EQ 0 then begin + errmsg = 'ERROR: Could not load physical constants from '+filename + fxbclose, unit + return + endif + + x = au / clight ;; AU (lt sec) + msol = msol * x * x * x / 86400D^2 ;; GM_sun (in lt sec) + radsol = radsol / clight ;; Solar radius (lt sec) + clight = clight * 1000 ;; Speed of light (m/s) + + fxbclose, unit + + ;; --------------------------------------------- + ;; Second extension contains accounting data + fxbopen, unit, filename, 2, ephhead, errmsg=errmsg + if errmsg NE '' then $ + if printerror then message,errmsg else return + + extname = strtrim(fxpar(ephhead, 'EXTNAME'),2) + if extname NE 'DE2' then begin + errmsg = 'ERROR: '+filename+' is not a JPL ephemeris file' + fxbclose, unit + return + endif + + fxbread, unit, ephobj, 'Object', errmsg=errmsg + if errmsg EQ '' then $ + fxbread, unit, ephptr, 'Pointer', errmsg=errmsg + if errmsg EQ '' then $ + fxbread, unit, ephncoeff, 'NumCoeff', errmsg=errmsg + if errmsg EQ '' then $ + fxbread, unit, ephnsub, 'NumSubIntv', errmsg=errmsg + fxbclose, unit + if errmsg NE '' then begin + errmsg = 'ERROR: could not read '+filename+' extension 2' + if printerror then message,errmsg else return + endif + + ;; Trim each object name to first word only + ephobj = strupcase(gettok(ephobj, ' ')) + + ;; --------------------------------------------- + ;; Third extension contains Chebyshev coefficients + fxbopen, unit, filename, 3, ephhead, errmsg=errmsg + if errmsg NE '' then return + extname = strtrim(fxpar(ephhead, 'EXTNAME'),2) + if extname NE 'DE3' then begin + errmsg = 'ERROR: '+filename+' is not a JPL ephemeris file' + fxbclose, unit + if printerror then message,errmsg else return + endif + + nrows = fxpar(ephhead, 'NAXIS2') + tstart = fxpar(ephhead, 'TSTART') + tstop = fxpar(ephhead, 'TSTOP') + timedel = jplephpar(ephhead, 'TIMEDEL', default=32D) ;; 32-day default + + if floor((tstop-tstart + 0.5)/timedel) NE nrows then begin + errmsg = 'ERROR: Incorrect number of rows in '+filename + fxbclose, unit + if printerror then message,errmsg else return + endif + + if n_elements(jdlimits) GE 2 then begin + if (min(jdlimits) LT tstart OR $ + max(jdlimits) GT tstop) then begin + errmsg = 'ERROR: '+filename+$ + ' does not cover the time of interest' + fxbclose, unit + if printerror then message,errmsg else return + endif + ;; Expand by two rows either side + rowlimits = floor((jdlimits-tstart)/timedel) + [-2,2] + rowlimits = rowlimits > 1 < nrows + endif else begin + jdlimits = [tstart, tstop] + rowlimits = [1L, nrows] + endelse + + ;; Read raw data + dims = fxbdimen(unit, 'ChebCoeffs') + fxbread, unit, coeffs, 'ChebCoeffs', rowlimits, errmsg=errmsg + fxbclose, unit + if errmsg NE '' then $ + if printerror then message,errmsg else return + + + raw = reform(coeffs, [dims, rowlimits[1]-rowlimits[0]+1], /overwrite) + + jdlimits1 = (rowlimits+[-1,0])*timedel + tstart + if (abs(min(raw[0,*]) - jdlimits1[0]) GT 1d-6 OR $ + abs(max(raw[1,*]) - jdlimits1[1]) GT 1d-6) then begin + errmsg = 'ERROR: JDLIMITS and time column do not match' + if printerror then message,errmsg else return + endif + + nr = rowlimits[1]-rowlimits[0]+1 + info = {filename: filename, edited: 0L, $ + creation_date: '', author: '', $ + nrows: nrows, tstart: tstart, tstop: tstop, $ + timedel: timedel, format: 'BINEPH2FITS', $ + denum: denum, c: clight, emrat: emrat, $ + au: au*1000/clight, msol: msol, sunrad: radsol, $ + jdlimits: jdlimits1, jdrows: nr, $ + objname: ephobj, ptr: ephptr, ncoeff: ephncoeff, $ + nsub: ephnsub, keywords: cname, keyvalues: cvalue} +; aufac: 1D/clight, velfac: 2D/(timedel*86400D), $ + + endif else begin + errmsg = 'ERROR: '+filename+' was not in a recognized format' + fxbclose, unit + if printerror then message,errmsg else return + endelse + + errmsg = '' + status = 1 + return +end diff --git a/modules/idl_downloads/astro/pro/jplephtest.pro b/modules/idl_downloads/astro/pro/jplephtest.pro new file mode 100644 index 0000000..5f441d3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/jplephtest.pro @@ -0,0 +1,194 @@ +;+ +; NAME: +; JPLEPHTEST +; +; AUTHOR: +; Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770 +; craigm@lheamail.gsfc.nasa.gov +; UPDATED VERSIONs can be found on my WEB PAGE: +; http://cow.physics.wisc.edu/~craigm/idl/idl.html +; +; PURPOSE: +; Test JPLEPHTEST with JPL test data set +; +; MAJOR TOPICS: +; Planetary Orbits, Interpolation +; +; CALLING SEQUENCE: +; JPLEPHTEST, EPHFILE, TESTFILE +; +; DESCRIPTION: +; +; JPLEPHTEST tests the JPLEPHINTERP procedure for precision. In +; order to function, you must have a JPL ephemeris test data set. +; The test data set testpo.405 is available in +; ftp://idlastro.gsfc.nasa.gov/pub/data +; +; The procedure opens and reads the test set, which contains +; precomputed data. Every tenth value is printed on the screen. +; Any deviations that exceed 1.5d-13 AU = 1.5 cm are reported. +; +; The columns are labelled according to the input file, except for +; the final column, which is the deviation between the input file +; and the computed value. +; +; +; PARAMETERS: +; +; EPHFILE - a scalar string, specifies the name of the ephemeris +; file, in FITS format. JPLEPHTEST will look in the directory +; $ASTRO_DATA for the file if it is not in the current directory. +; +; TESTFILE - a scalar string, specifies JPL test data set to compare +; against. JPLEPHTEST will look in the directory +; $ASTRO_DATA for the file if it is not in the current directory. +; +; +; EXAMPLE: +; +; Test JPL DE200 and DE405 ephemerides. Assumes files are in the +; current directory. +; +; JPLEPHTEST, 'JPLEPH.200', 'testpo.200' +; JPLEPHTEST, 'JPLEPH.405', 'testpo.405' +; +; +; REFERENCES: +; +; JPL Export Ephemeris FTP Site +; ftp://ssd.jpl.nasa.gov/pub/eph/planets/ +; (see test-data/ for test data sets) +; +; HORIZONS, JPL Web-based ephermis calculator (Ephemeris DE406) +; http://ssd.jpl.nasa.gov/horizons.html +; +; +; SEE ALSO +; JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST +; +; MODIFICATION HISTORY: +; Written and Documented, CM, Jun 2001 +; Removed TRANSREAD, improved output, improved docs, CM, 9 Jul 2001 +; +; $Id: jplephtest.pro,v 1.4 2001/07/20 13:29:53 craigm Exp $ +; +;- +; Copyright (C) 2001, Craig Markwardt +; This software is provided as is without any warranty whatsoever. +; Permission to use, copy and distribute unmodified copies for +; non-commercial purposes, and to modify and use for personal or +; internal use, is granted. All other rights are reserved. +;- + +pro jplephtest, ephfile, testfile, pause=pause + + if n_params() EQ 0 then begin + message, 'USAGE: JPLEPHTEST, EPHFILE, TESTFILE', /info + return + endif + + testdata = find_with_def( testfile, 'ASTRO_DATA') + openr, unit, testdata, /get_lun, error=err + if err NE 0 then begin + message, 'ERROR: could not open '+testdata + return + endif + + ;; Read header of file, up to and including the EOT line + repeat begin + line = '' + readf, unit, line + endrep until strupcase(strmid(line,0,3)) EQ 'EOT' + + ;; Read at least 20000 lines from file + data = replicate({denum:0L, caldate: '', jd: 0D, targ: 0L, $ + cent: 0L, coord: 0L, value: 0D}, 20000) + on_ioerror, DONE + readf, unit, data, format='(I5,A10,D0,I0,I0,I0,D0)' + DONE: + rc = floor((fstat(unit)).transfer_count/7) + on_ioerror, NULL + free_lun, unit + + if rc LT 10 then begin + message, 'ERROR: could not read input data' + endif + + ;; Cull the data out of the structure + data = data[0:rc-1] + denum = data.denum & caldate = data.caldate & jd = data.jd + targ = data.targ & cent = data.cent & coord = data.coord + value = data.value + data = 0 + + bad = cent*0 + + ephdata = find_with_def(ephfile, 'ASTRO_DATA') + jplephread, ephdata, pinfo, pdata, status=st, errmsg=errmsg + if st EQ 0 then begin + message, errmsg + endif + if denum[0] NE pinfo.denum then begin + message, 'ERROR: test file and ephemeris are not of same version' + endif + + wh = where(jd GE pinfo.tstart AND jd LE pinfo.tstop, totct) + if totct EQ 0 then begin + message, 'ERROR: test file and ephemeris do not overlap' + endif + + j = 0L + for i = 0L, totct-1 do begin + + if coord[wh[i]] GE 4 then vel = 1 else vel = 0 + if targ[wh[i]] GE 14 then vel = 1 ;; Always for nut. & libr. + jplephinterp, pinfo, pdata, jd[wh[i]], x, y, z, vx, vy, vz, $ + objectname=targ[wh[i]], center=cent[wh[i]], $ + posunits='AU', velunits='AU/DAY', velocity=vel + + case coord[wh[i]] of + 1: newval = x + 2: newval = y + 3: newval = z + 4: newval = vx + 5: newval = vy + 6: newval = vz + else: message, 'ERROR: coordinate '+coord[wh[i]]+' does not exist' + endcase + + ;; Nutations are handled differently than PLEPH + if targ[wh[i]] EQ 14 AND coord[wh[i]] GT 2 then begin + if coord[wh[i]] EQ 3 then newval = vx $ + else newval = vy + endif + + del = abs(newval - value[wh[i]]) + if targ[wh[i]] EQ 15 AND coord[wh[i]] EQ 3 then $ + del = del/(0.23d0*(jd[wh[i]]-2451545.d0)) + if del GE 1.5d-13 OR (i MOD 10) EQ 0 then begin + if del GE 1.5d-13 then begin + print, '****** WARNING: Large difference ******' + bad[wh[i]] = 1 + endif + if j GT 300 then j = 0L + if j EQ 0 then $ + print, 'REC#', 'Jul. Day', 'Targ', 'Cent', 'Coor', $ + 'Value', 'Deviation', format='(A6,A10,3(A5),1(A20),A22)' + print, i+1, jd[wh[i]], targ[wh[i]], cent[wh[i]], coord[wh[i]], $ + value[wh[i]], del, $ + format='(I6,D10.1,3(I5),1(D20.13),E22.13)' + endif + + j = j + 1 + endfor + + if keyword_set(pause) AND total(bad) NE 0 then stop + wh = where(bad, ct) + print, '' + print, '***********************************' + print, ' Time Range (Julian Days): ', minmax(jd) + print, ' Number of Records: ', totct + print, ' Erroneous Records: ', ct + +end + diff --git a/modules/idl_downloads/astro/pro/jprecess.pro b/modules/idl_downloads/astro/pro/jprecess.pro new file mode 100644 index 0000000..bf843af --- /dev/null +++ b/modules/idl_downloads/astro/pro/jprecess.pro @@ -0,0 +1,226 @@ +pro jprecess, ra, dec, ra_2000, dec_2000, MU_RADEC = mu_radec, $ + PARALLAX = parallax, RAD_VEL = rad_vel, EPOCH = epoch +;+ +; NAME: +; JPRECESS +; PURPOSE: +; Precess astronomical coordinates from B1950 to J2000 +; EXPLANATION: +; Calculate the mean place of a star at J2000.0 on the FK5 system from the +; mean place at B1950.0 on the FK4 system. +; +; Use BPRECESS for the reverse direction J2000 ==> B1950 +; CALLING SEQUENCE: +; jprecess, ra, dec, ra_2000, dec_2000, [ MU_RADEC = , PARALLAX = +; RAD_VEL =, EPOCH = ] +; +; INPUTS: +; RA,DEC - input B1950 right ascension and declination in *degrees*. +; Scalar or vector +; +; OUTPUTS: +; RA_2000, DEC_2000 - the corresponding J2000 right ascension and +; declination in *degrees*. Same number of elements as RA,DEC +; but always double precision. +; +; OPTIONAL INPUT-OUTPUT KEYWORDS +; MU_RADEC - 2xN element double precision vector containing the proper +; motion in seconds of arc per tropical *century* in right +; ascension and declination. +; PARALLAX - N_element vector giving stellar parallax (seconds of arc) +; RAD_VEL - N_element vector giving radial velocity in km/s +; +; The values of MU_RADEC, PARALLAX, and RADVEL will all be modified +; upon output to contain the values of these quantities in the +; J2000 system. Values will also be converted to double precision. +; The parallax and radial velocity will have a very minor influence on +; the J2000 position. +; +; EPOCH - scalar giving epoch of original observations, default 1950.0d +; This keyword value is only used if the MU_RADEC keyword is not set. +; NOTES: +; The algorithm is taken from the Explanatory Supplement to the +; Astronomical Almanac 1992, page 184. +; Also see Aoki et al (1983), A&A, 128,263 +; +; JPRECESS distinguishes between the following two cases: +; (1) The proper motion is known and non-zero +; (2) the proper motion is unknown or known to be exactly zero (i.e. +; extragalactic radio sources). In this case, the algorithm +; in Appendix 2 of Aoki et al. (1983) is used to ensure that +; the output proper motion is exactly zero. Better precision +; can be achieved in this case by inputting the EPOCH of the +; original observations. +; +; The error in using the IDL procedure PRECESS for converting between +; B1950 and J2000 can be up to 12", mainly in right ascension. If +; better accuracy than this is needed then JPRECESS should be used. +; +; EXAMPLE: +; The SAO catalogue gives the B1950 position and proper motion for the +; star HD 119288. Find the J2000 position. +; +; RA(1950) = 13h 39m 44.526s Dec(1950) = 8d 38' 28.63'' +; Mu(RA) = -.0259 s/yr Mu(Dec) = -.093 ''/yr +; +; IDL> mu_radec = 100D* [ -15D*.0259, -0.093 ] +; IDL> ra = ten(13,39,44.526)*15.D +; IDL> dec = ten(8,38,28.63) +; IDL> jprecess, ra, dec, ra2000, dec2000, mu_radec = mu_radec +; IDL> print, adstring(ra2000, dec2000,2) +; ===> 13h 42m 12.740s +08d 23' 17.69" +; +; RESTRICTIONS: +; "When transferring individual observations, as opposed to catalog mean +; place, the safest method is to tranform the observations back to the +; epoch of the observation, on the FK4 system (or in the system that was +; used to to produce the observed mean place), convert to the FK5 system, +; and transform to the the epoch and equinox of J2000.0" -- from the +; Explanatory Supplement (1992), p. 180 +; +; REVISION HISTORY: +; Written, W. Landsman September, 1992 +; Corrected a couple of typos in M matrix October, 1992 +; Vectorized, W. Landsman February, 1994 +; Implement Appendix 2 of Aoki et al. (1983) for case where proper +; motion unknown or exactly zero W. Landsman November, 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fixed typo in updating proper motion W. Landsman April 1999 +; Make sure proper motion is floating point W. Landsman December 2000 +; Use V6.0 notation W. Landsman Mar 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - JPRECESS, ra,dec, ra_2000, dec_2000, [MU_RADEC =' + print,' PARALLAX = , RAD_VEL = ]' + print,'Input RA and Dec should be given in DEGREES for B1950' + print,'Proper motion, MU_RADEC, (optional) in arc seconds per *century*' + print,'Parallax (optional) in arc seconds' + print,'Radial Velocity (optional) in km/s' + return + + endif + + N = N_elements( ra ) + if N EQ 0 then message,'ERROR - first parameter (RA vector) is undefined' + + if ~keyword_set( RAD_VEL) then rad_vel = dblarr(N) else begin + rad_vel = rad_vel*1. + if N_elements( RAD_VEL ) NE N then message, $ + 'ERROR - RAD_VEL keyword vector must contain ' + strtrim(N,2) + ' values' + endelse + + if N_elements( MU_RADEC) GT 0 then begin + if (N_elements( mu_radec) NE 2*N ) then message, $ + 'ERROR - MU_RADEC keyword (proper motion) be dimensioned (2,' + $ + strtrim(N,2) + ')' + mu_radec = mu_radec*1. ;Make sure at least float + endif + + if N_elements(epoch) EQ 0 then epoch = 1950.0d0 + + if N_elements( Parallax) EQ 0 then parallax = dblarr(N) else $ + parallax = parallax*1. + + radeg = 180.D/!DPI + sec_to_radian = 1./radeg/3600.0d0 + + M = [ [+0.9999256782D, +0.0111820610D, +0.0048579479D, $ + -0.000551D, +0.238514D, -0.435623D ], $ + [ -0.0111820611D, +0.9999374784D, -0.0000271474D, $ + -0.238565D, -0.002667D, +0.012254D ], $ + [ -0.0048579477D, -0.0000271765D, +0.9999881997D , $ + +0.435739D, -0.008541D, +0.002117D ], $ + [ +0.00000242395018D, +0.00000002710663D, +0.00000001177656D, $ + +0.99994704D, +0.01118251D, +0.00485767D ], $ + [ -0.00000002710663D, +0.00000242397878D, -0.00000000006582D, $ + -0.01118251D, +0.99995883D, -0.00002714D ], $ + [ -0.00000001177656D, -0.00000000006587D, 0.00000242410173D, $ + -0.00485767D, -0.00002718D, 1.00000956D] ] + + A = 1D-6*[ -1.62557D, -0.31919D, -0.13843D] ;in radians + A_dot = 1D-3*[1.244D, -1.579D, -0.660D ] ;in arc seconds per century + + if epoch NE 1950.0d then $ + A = A + sec_to_radian * A_dot * (epoch - 1950.0D)/100.0d + + ra_rad = ra/radeg & dec_rad = dec/radeg + cosra = cos( ra_rad ) & sinra = sin( ra_rad ) + cosdec = cos( dec_rad ) & sindec = sin( dec_rad ) + + ra_2000 = ra*0. + dec_2000 = dec*0. + + for i = 0l, N-1 do begin + + r0 = [ cosra[i]*cosdec[i], sinra[i]*cosdec[i], sindec[i] ] + + if ~keyword_set( MU_RADEC) then begin + mu_a = 0.0d0 + mu_d = 0.0d0 + endif else begin + if (N_elements( mu_radec) NE 2*N ) then message, $ + 'ERROR - MU_RADEC keyword (proper motion) must be dimensioned (2,' + $ + strtrim(N,2) + ')' + mu_a = mu_radec[ 0, i] + mu_d = mu_radec[ 1, i ] + endelse + + r0_dot = [ -mu_a*sinra[i]*cosdec[i] - mu_d*cosra[i]*sindec[i], $ ;Velocity vector + mu_a*cosra[i]*cosdec[i] - mu_d*sinra[i]*sindec[i] , $ + mu_d*cosdec[i] ] + 21.095 * rad_vel[i] * parallax[i] * r0 + + ; Remove the effects of the E-terms of aberration to form r1 and r1_dot. + + r1 = r0 - A + (total(r0 * A))*r0 + r1_dot = r0_dot - A_dot + ( total( r0 * A_dot))*r0 + + R_1 = [r1, r1_dot] + + R = M # R_1 + + if ~keyword_set(mu_RADEC) then begin + rr = [ R[0], R[1], R[2]] + v = [ R[3],R[4],R[5] ] + t = ((epoch - 1950.0d0) - 50.00021d)/100.0d0 + rr1 = rr + sec_to_radian*v*t + x = rr1[0] & y = rr1[1] & Z = rr1[2] + endif else begin + x = R[0] & y = R[1] & Z = R[2] + x_dot = R[3] & y_dot= R[4] & z_dot = R[5] + endelse + + r2 = x^2 + y^2 + z^2 + rmag = sqrt( r2 ) + dec_2000[i] = asin( z / rmag) + ra_2000[i] = atan( y, x) + + if keyword_set(mu_RADEC) then begin + mu_radec[0, i] = ( x*y_dot - y*x_dot) / ( x^2 + y^2) + mu_radec[1, i] = ( z_dot* (x^2 + y^2) - z*(x*x_dot + y*y_dot) ) / $ + ( r2*sqrt( x^2 + y^2) ) + endif + + if parallax[i] GT 0. then begin + rad_vel[i] = ( x*x_dot + y*y_dot + z*z_dot )/ (21.095*Parallax[i]*rmag) + parallax[i] = parallax[i] / rmag + + endif + endfor + + neg = where( ra_2000 LT 0, NNeg ) + if Nneg GT 0 then ra_2000[neg] = ra_2000[neg] + 2.D*!DPI + + ra_2000 = ra_2000*radeg & dec_2000 = dec_2000*radeg + +; Make output scalar if input was scalar + + sz = size(ra) + if sz[0] EQ 0 then begin + ra_2000 = ra_2000[0] & dec_2000 = dec_2000[0] + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/juldate.pro b/modules/idl_downloads/astro/pro/juldate.pro new file mode 100644 index 0000000..c6d0281 --- /dev/null +++ b/modules/idl_downloads/astro/pro/juldate.pro @@ -0,0 +1,121 @@ +PRO JULDATE, DATE, JD, PROMPT = prompt +;+ +; NAME: +; JULDATE +; PURPOSE: +; Convert from calendar to Reduced Julian Date +; +; EXPLANATION: +; Julian Day Number is a count of days elapsed since Greenwich mean noon +; on 1 January 4713 B.C. The Julian Date is the Julian day number +; followed by the fraction of the day elapsed since the preceding noon. +; +; This procedure duplicates the functionality of the JULDAY() function in +; in the standard IDL distribution, but also allows interactive input and +; gives output as Reduced Julian date (=JD - 2400000.) + +; CALLING SEQUENCE: +; JULDATE, /PROMPT ;Prompt for calendar Date, print Julian Date +; or +; JULDATE, date, jd +; +; INPUT: +; DATE - 3 to 6-element vector containing year,month (1-12),day, and +; optionally hour, minute, and second all specified as numbers +; (Universal Time). Year should be supplied with all digits. +; Years B.C should be entered as negative numbers (and note that +; Year 0 did not exist). If Hour, minute or seconds are not +; supplied, they will default to 0. +; +; OUTPUT: +; JD - Reduced Julian date, double precision scalar. To convert to +; Julian Date, add 2400000. JULDATE will print the value of +; JD at the terminal if less than 2 parameters are supplied, or +; if the /PROMPT keyword is set +; +; OPTIONAL INPUT KEYWORD: +; /PROMPT - If this keyword is set and non-zero, then JULDATE will prompt +; for the calendar date at the terminal. +; +; RESTRICTIONS: +; The procedure HELIO_JD can be used after JULDATE, if a heliocentric +; Julian date is required. +; +; EXAMPLE: +; A date of 25-DEC-2006 06:25 UT may be expressed as either +; +; IDL> juldate, [2006, 12, 25, 6, 25], jd +; IDL> juldate, [2006, 12, 25.2673611d], jd +; +; In either case, one should obtain a Reduced Julian date of +; JD = 54094.7673611 +; +; PROCEDURE USED: +; GETOPT() +; REVISION HISTORY +; Adapted from IUE RDAF (S. Parsons) 8-31-87 +; Algorithm from Sky and Telescope April 1981 +; Added /PROMPT keyword, W. Landsman September 1992 +; Converted to IDL V5.0 W. Landsman September 1997 +; Make negative years correspond to B.C. (no year 0), work for year 1582 +; Disallow 2 digit years. W. Landsman March 2000 +;- + On_error,2 + + if ( N_params() EQ 0 ) and ( ~keyword_set( PROMPT ) ) then begin + print,'Syntax - JULDATE, date, jd or JULDATE, /PROMPT' + print, $ + ' date - 3-6 element vector containing [year,month,day,hour,minute,sec]' + print,' jd - output reduced julian date (double precision)' + return + endif + + if ( N_elements(date) EQ 0 ) then begin + + opt = '' + rd: read,' Enter Year,Month,Day,Hour, Minute, Seconds (All Numeric): ',opt + date = getopt( opt, 'F' ) + + endif + + case N_elements(date) of + + 6: + 5: date = [ date, 0.0d] + 4: date = [ date, 0.0d,0.0d] + 3: date = [ date, 0.0d, 0.0d,0.0d] + else: message,'Illegal DATE Vector - must have a least 3 elements' + + endcase + + iy = floor( date[0] ) + if iy lt 0 then iy++ else $ + if iy EQ 0 then message,'ERROR - There is no year 0' + im = fix( date[1] ) + date = double(date) + day = date[2] + ( date[3] + date[4]/60.0d + date[5]/3600.0d) / 24.0d +; + if ( im LT 3 ) then begin ;If month is Jan or Feb, don't include leap day + + iy-- & im = im+12 + + end + + a = long(iy/100) + ry = float(iy) + + jd = floor(ry*0.25d) + 365.0d*(ry -1860.d) + fix(30.6001d*(im+1.)) + $ + day - 105.5d + +;Gregorian Calendar starts on Oct. 15, 1582 (= RJD -100830.5) + if jd GT -100830.5 then jd = jd + 2 - a + floor(a/4) + + if N_params() LT 2 || keyword_set( PROMPT) then begin + yr = fix( date[0] ) + print, FORM='(A,I4,A,I3,A,F9.5)',$ + ' Year ',yr,' Month', fix(date[1] ),' Day', day + print, FORM='(A,F15.5)',' Reduced Julian Date:',JD + endif + + return + end ; juldate diff --git a/modules/idl_downloads/astro/pro/ksone.pro b/modules/idl_downloads/astro/pro/ksone.pro new file mode 100644 index 0000000..c8b2ab0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ksone.pro @@ -0,0 +1,125 @@ + pro ksone, data, func_name, d, prob, PLOT = plot, _EXTRA = extra,Window=window +;+ +; NAME: +; KSONE +; PURPOSE: +; Compute the one-sided Kolmogorov-Smirnov statistic +; EXPLANATION: +; Returns the Kolmogorov-Smirnov statistic and associated probability for +; for an array of data values and a user-supplied cumulative distribution +; function (CDF) of a single variable. Algorithm from the procedure of +; the same name in "Numerical Recipes" by Press et al. 2nd edition (1992) +; +; CALLING SEQUENCE: +; ksone, data, func_name, D, prob, [ /PLOT ] +; +; INPUT PARAMETERS: +; data - vector of data values, must contain at least 4 elements for the +; K-S statistic to be meaningful +; func_name - scalar string giving the name of the cumulative distribution +; function. The function must be defined to accept the data +; vector as its only input (see example), though keywords may be +; passed via the _EXTRA facility. +; +; OUTPUT PARAMETERS: +; D - floating scalar giving the Kolmogorov-Smirnov statistic. It +; specified the maximum deviation between the cumulative +; distribution of the data and the supplied function +; prob - floating scalar between 0 and 1 giving the significance level of +; the K-S statistic. Small values of PROB show that the +; cumulative distribution function of DATA is significantly +; different from FUNC_NAME. +; +; OPTIONAL INPUT KEYWORD: +; /PLOT - If this keyword is set and non-zero, then KSONE will display a +; plot of the CDF of the data with the supplied function +; superposed. The data value where the K-S statistic is +; computed (i.e. at the maximum difference between the data CDF +; and the function) is indicated by a vertical line. +; KSONE accepts the _EXTRA keyword, so that most plot keywords +; (e.g. TITLE, XTITLE, XSTYLE) can also be passed to KSONE. +; /WINDOW - If set, the plot to a resizeable graphics window +; EXAMPLE: +; Determine if a vector created by the RANDOMN function is really +; consistent with a Gaussian distribution with unit variance. +; The CDF of a Gaussian is the error function except that a factor +; of 2 is included in the error function. So we must create a special +; function: +; +; function gauss_cdf, x +; return, errorf( x/sqrt(2) ) +; end +; +; IDL> data = randomn(seed, 50) ;create data array to be tested +; IDL> ksone, abs(data), 'gauss_cdf', D, prob, /PLOT ;Use K-S test +; +; A small value of PROB indicates that the cumulative distribution of +; DATA is significantly different from a Gaussian +; +; NOTES: +; The code for PROB_KS is from the 2nd (1992) edition of Numerical +; Recipes which includes a more accurate computation of the K-S +; significance for small values of N than the first edition. +; +; Since _EXTRA is used to pass extra parameters both to the user-supplied +; function, and to the cgPLOT command, the user-supplied function should +; not accept "cgPLOT" keyword names (e.g. XTITLE). +; +; PROCEDURE CALLS +; procedure PROB_KS - computes significance of K-S distribution +; TAG_EXIST() +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; Accept _EXTRA keywords W. Landsman September, 1995 +; Fixed possible bug in plot display showing position maximum difference +; in histogram M. Fardal/ W. Landsman March, 1997 +; Documentation updates W. Landsman June 2003 +; Pass _EXTRA to func_name M. Fitzgerald April, 2005 +; Work for functions that do not accept keywords W. Landsman July 2009 +; Use Coyote graphics for plotting Feb 2011 +;- + On_error, 2 + compile_opt idl2 + + if ( N_params() LT 3 ) then begin + print,'Syntax - ksone, data, func_name, D, [prob ,/PLOT]' + return + endif + + N = N_elements( data ) + if N LT 3 then message, $ + 'ERROR - Input data values (first param) must contain at least 3 values' + + sortdata = data[ sort( data ) ] + + f0 = findgen(N)/ N + fn = ( findgen( N ) +1. ) / N + + ; We need to determine if the user-supplied function accepts keyword + ; arguments. If it does not then passing the _EXTRA keyword will signal + ; an error. + resolve_routine, func_name,/is_function + r = routine_info(func_name,/parameter,/function) + if tag_exist(r,'KW_ARGS') then $ + ff = call_function( func_name, sortdata, _EXTRA = extra) else $ + ff = call_function( func_name, sortdata) + + D = max( [ max( abs(f0-ff), sub0 ), max( abs(fn-ff), subn ) ], msub ) + + if keyword_set(plot) || keyword_set(WINDOW) then begin + + if msub EQ 0 then begin + cgplot, sortdata,f0,psym=10,_EXTRA = extra, window=window + cgplots, [sortdata[sub0], sortdata[sub0]], [0,1],window=window + endif else begin + cgplot, sortdata,fn,psym=10,_EXTRA = extra,window=window + cgplots, [sortdata[subn], sortdata[subn]], [0,1],window=window + endelse + cgplot,/over, sortdata,ff,lines=1,window=window +endif + + PROB_KS, D, N, prob ;Compute significance of K-S statistic + + return + end diff --git a/modules/idl_downloads/astro/pro/kstwo.pro b/modules/idl_downloads/astro/pro/kstwo.pro new file mode 100644 index 0000000..28619ce --- /dev/null +++ b/modules/idl_downloads/astro/pro/kstwo.pro @@ -0,0 +1,100 @@ + pro kstwo, data1, data2, D, prob +;+ +; NAME: +; KSTWO +; PURPOSE: +; Return the two-sided Kolmogorov-Smirnov statistic +; EXPLANATION: +; Returns the Kolmogorov-Smirnov statistic and associated probability +; that two arrays of data values are drawn from the same distribution +; Algorithm taken from procedure of the same name in "Numerical +; Recipes" by Press et al., 2nd edition (1992), Chapter 14 +; +; CALLING SEQUENCE: +; kstwo, data1, data2, D, prob +; +; INPUT PARAMETERS: +; data1 - vector of data values, at least 4 data values must be included +; for the K-S statistic to be meaningful +; data2 - second set of data values, does not need to have the same +; number of elements as data1 +; +; OUTPUT PARAMETERS: +; D - floating scalar giving the Kolmogorov-Smirnov statistic. It +; specifies the maximum deviation between the cumulative +; distribution of the data and the supplied function +; prob - floating scalar between 0 and 1 giving the significance level of +; the K-S statistic. Small values of PROB show that the +; cumulative distribution function of DATA1 is significantly +; different from DATA2 +; +; EXAMPLE: +; Test whether two vectors created by the RANDOMN function likely came +; from the same distribution +; +; IDL> data1 = randomn(seed,40) ;Create data vectors to be +; IDL> data2 = randomn(seed,70) ;compared +; IDL> kstwo, data1, data2, D, prob & print,D,prob +; +; PROCEDURE CALLS +; procedure PROB_KS - computes significance of K-S distribution +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; FP computation of N_eff H. Ebeling/W. Landsman March 1996 +; Fix for arrays containing equal values J. Ballet/W. Landsman Oct. 2001 +; Fix index when maximum difference is at array end Renbin Yan Dec 2008 +; Handle large number when computing N_err D. Schnitzeler/WL Sep 2010 +;- + On_error, 2 + compile_opt idl2 + + if ( N_params() LT 4 ) then begin + print,'Syntax - KSTWO, data1, data2, d, prob' + return + endif + + n1 = N_elements( data1 ) + if ( N1 LE 3 ) then message, $ + 'ERROR - Input data values (first param) must contain at least 4 values' + + n2 = N_elements( data2 ) + if ( n2 LE 3 ) then message, $ + 'ERROR - Input data values (second param) must contain at least 4 values' + + sortdata1 = data1[ sort( data1 ) ] ;Sort input arrays into + sortdata2 = data2[ sort( data2 ) ] ;ascending order + + fn1 = ( findgen( n1 +1 ) ) / n1 ;updated Dec 2008 + fn2 = ( findgen( n2 +1) ) / n2 + + j1 = 0l & j2 = 0l + id1 = lonarr(n1+n2) & id2 = id1 + i = 0l + +; Form the two cumulative distribution functions, marking points where one +; must test their difference + + while ( j1 LT N1 ) and ( j2 LT n2 ) do begin + + d1 = sortdata1[j1] + d2 = sortdata2[j2] + if d1 LE d2 then j1 = j1 +1 + if d2 LE d1 then j2 = j2 +1 + + id1[i] = j1 & id2[i] = j2 + i = i+1 + + endwhile + + id1 = id1[0:i-1] & id2 = id2[0:i-1] + +; The K-S statistic D is the maximum difference between the two distribution +; functions + + D = max( abs( fn1[id1] - fn2[id2] ) ) + N_eff = long64(n1)*n2/ float(n1 + n2) ;Effective # of data points + PROB_KS, D, N_eff, prob ;Compute significance of statistic + + return + end diff --git a/modules/idl_downloads/astro/pro/kuiperone.pro b/modules/idl_downloads/astro/pro/kuiperone.pro new file mode 100644 index 0000000..665960b --- /dev/null +++ b/modules/idl_downloads/astro/pro/kuiperone.pro @@ -0,0 +1,126 @@ + pro kuiperone, data, func_name, d, prob, PLOT = plot, WINDOW=window, $ + _EXTRA = extra +;+ +; NAME: +; KUIPERONE +; PURPOSE: +; Compute the one-sided Kuiper statistic (invariant Kolmogorov-Smirnov) +; EXPLANATION: +; Returns the Kuiper statistic and associated probability +; for an array of data values and a user-supplied cumulative distribution +; function (CDF) of a single variable. Algorithm adapted from KSONE +; in "Numerical Recipes" by Press et al. 2nd edition (1992) +; +; Kuiper's test is especially useful for data defined on a circle or +; to search for periodicity (see Paltani 2004, A&A, 420, 789). +; CALLING SEQUENCE: +; kuiperone, data, func_name, D, prob, [ /PLOT ] +; +; INPUT PARAMETERS: +; data - vector of data values, must contain at least 4 elements for the +; Kuiper statistic to be meaningful +; func_name - scalar string giving the name of the cumulative distribution +; function. The function must be defined to accept the data +; vector as its only input (see example). +; +; OUTPUT PARAMETERS: +; D - floating scalar giving the Kuiper statistic. It +; specifies the sum of positive and negative deviations between the +; cumulative distribution of the data and the supplied function +; prob - floating scalar between 0 and 1 giving the significance level of +; the Kuiper statistic. Small values of PROB show that the +; cumulative distribution function of DATA is significantly +; different from FUNC_NAME. +; +; OPTIONAL INPUT KEYWORD: +; /PLOT - If this keyword is set and non-zero, then KUIPERONE will display a +; plot of the CDF of the data with the supplied function +; superposed. The data values where the Kuiper statistic is +; computed (i.e. at the maximum difference between the data CDF +; and the function) are indicated by vertical dashed lines. +; KUIPERONE accepts the _EXTRA keyword, so that most plot keywords +; (e.g. TITLE, XTITLE, XSTYLE) can also be passed to KUIPERONE. +; +; EXAMPLE: +; Determine if a vector created by the RANDOMN function is really +; consistent with a Gaussian distribution. +; The CDF of a Gaussian is the error function except that a factor +; of 2 is included in the error function. So we must create a special +; function: +; +; function gauss_cdf, x +; return, errorf( x/sqrt(2) ) +; end +; +; IDL> data = randomn(seed, 50) ;create data array to be tested +; IDL> kuiperone, data, 'gauss_pdf', D, prob, /PLOT ;Use Kuiper test +; +; A small value of PROB indicates that the cumulative distribution of +; DATA is significantly different from a Gaussian +; +; NOTES: +; Note that the 2nd (1992) edition of Numerical Recipes includes +; a more accurate computation of the K-S significance for small +; values of N. +; +; PROCEDURE CALLS +; procedure PROB_KUIPER - computes significance of Kuiper distribution +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; Accept _EXTRA keywords W. Landsman September, 1995 +; Fixed possible bug in plot display showing position maximum difference +; in histogram M. Fardal/ W. Landsman March, 1997 +; Adapted from KSONE J. Ballet July 2003 +; Use Coyote graphics W. Landsman Feb 2011 +;- + On_error, 2 + compile_opt idl2 + + if ( N_params() LT 3 ) then begin + print,'Syntax - kuiperone, data, func_name, D, [prob ,/PLOT]' + return + endif + + N = N_elements( data ) + if N LT 3 then message, $ + 'ERROR - Input data values (first param) must contain at least 3 values' + + sortdata = data[ sort( data ) ] + + f0 = findgen(N)/ N + fn = ( findgen( N ) +1. ) / N + ff = call_function( func_name, sortdata ) + +; Maximum distance above the reference + D1 = max( fn-ff, subn ) + +; Maximum distance below the reference + D2 = max( ff-f0, sub0 ) + + D = D1 + D2 + + if keyword_set(plot) || keyword_set(WINDOW) then begin + +; Prepare the step function + xx = REBIN(sortdata,2*N,/SAMPLE) + yy = REBIN(f0,2*N,/SAMPLE) + yy = [yy[1:*],1.] + + cgplot, xx,yy,_EXTRA = extra, WINDOW=window + cgplots, [sortdata[sub0], sortdata[sub0]], [0,ff[sub0]], linestyle=2, $ + WINDOW=window + cgplots, [sortdata[subn], sortdata[subn]], [ff[subn],1], linestyle=2, $ + WINDOW=window + +; Plot the expected cumulative distribution + n2 = n > 100 + x2 = FINDGEN(n2+1)*(!X.CRANGE[1]-!X.CRANGE[0])/n2 + !X.CRANGE[0] + y2 = call_function( func_name, x2 ) + cgplot,/over, x2,y2,lines=1,thick=2, WINDOW=window + endif + + prob_kuiper, D, N, prob ;Compute significance of Kuiper statistic + + return + end diff --git a/modules/idl_downloads/astro/pro/kuipertwo.pro b/modules/idl_downloads/astro/pro/kuipertwo.pro new file mode 100644 index 0000000..8f9827c --- /dev/null +++ b/modules/idl_downloads/astro/pro/kuipertwo.pro @@ -0,0 +1,132 @@ + pro kuipertwo, data1, data2, D, prob, PLOT = plot, _EXTRA = extra,WINDOW=window +;+ +; NAME: +; KUIPERTWO +; PURPOSE: +; Compute the two-sided Kuiper statistic (invariant Kolmogorov-Smirnov) +; EXPLANATION: +; Returns the Kuiper statistic and associated probability +; that two arrays of data values are drawn from the same distribution +; Algorithm adapted from KSTWO in "Numerical +; Recipes" by Press et al., 2nd edition (1992), Chapter 14 +; +; CALLING SEQUENCE: +; kuipertwo, data1, data2, D, prob, [ /PLOT ] +; +; INPUT PARAMETERS: +; data1 - vector of data values, at least 4 data values must be included +; for the Kuiper statistic to be meaningful +; data2 - second set of data values, does not need to have the same +; number of elements as data1 +; +; OUTPUT PARAMETERS: +; D - floating scalar giving the Kuiper statistic. It +; specifies the sum of positive and negative deviations between +; the cumulative distributions of the two data sets +; prob - floating scalar between 0 and 1 giving the significance level of +; the Kuiper statistic. Small values of PROB show that the +; cumulative distribution function of DATA1 is significantly +; different from DATA2 +; +; OPTIONAL INPUT KEYWORD: +; /PLOT - If this keyword is set and non-zero, then KUIPERTWO will display +; a plot of the CDF of the two data sets. +; The data values where the Kuiper statistic is +; computed (i.e. at the maximum difference between the CDF of +; the two data sets) are indicated by vertical dashed lines. +; KUIPERTWO accepts the _EXTRA keyword, so that most plot keywords +; (e.g. TITLE, XTITLE, XSTYLE) can also be passed to KUIPERTWO. +; /WINDOW - If set the plot to a resizeable graphics window. +; EXAMPLE: +; Test whether two vectors created by the RANDOMN function likely came +; from the same distribution +; +; IDL> data1 = randomn(seed,40) ;Create data vectors to be +; IDL> data2 = randomn(seed,70) ;compared +; IDL> kuipertwo, data1, data2, D, prob & print,D,prob +; +; PROCEDURE CALLS +; procedure PROB_KUIPER - computes significance of Kuiper distribution +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; FP computation of N_eff H. Ebeling/W. Landsman March 1996 +; Fix for arrays containing equal values J. Ballet/W. Landsman +; Oct. 2001 +; Adapted from KSTWO, added PLOT keyword J. Ballet July 2004 +; Use Coyote Graphics W. Landsman Feb 2011 +;- + On_error, 2 + compile_opt idl2 + + if ( N_params() LT 4 ) then begin + print,'Syntax - KUIPERTWO, data1, data2, d, prob [, /PLOT]' + return + endif + + n1 = N_elements( data1 ) + if ( N1 LE 3 ) then message, $ + 'ERROR - Input data values (first param) must contain at least 4 values' + + n2 = N_elements( data2 ) + if ( n2 LE 3 ) then message, $ + 'ERROR - Input data values (second param) must contain at least 4 values' + + sortdata1 = data1[ sort( data1 ) ] ;Sort input arrays into + sortdata2 = data2[ sort( data2 ) ] ;ascending order + + fn1 = ( findgen( n1 ) ) / n1 + fn2 = ( findgen( n2 ) ) / n2 + + j1 = 0l & j2 = 0l + id1 = lonarr(n1+n2) & id2 = id1 + i = 0l + +; Form the two cumulative distribution functions, marking points where one +; must test their difference + + while ( j1 LT n1 ) and ( j2 LT n2 ) do begin + + d1 = sortdata1[j1] + d2 = sortdata2[j2] + if d1 LE d2 then j1 = j1 +1 + if d2 LE d1 then j2 = j2 +1 + + id1[i] = j1 & id2[i] = j2 + i = i+1 + + endwhile + + id1 = id1[0:i-1] & id2 = id2[0:i-1] + +; The Kuiper statistic D is the sum of the maximum positive and +; negative differences between the two distribution functions + + D1 = max(fn1[id1] - fn2[id2], sub1, MIN=D2, SUBSCRIPT_MIN=sub2) + D = D1 - D2 + N_eff = n1*n2/ float(n1 + n2) ;Effective # of data points + PROB_KUIPER, D, N_eff, prob ;Compute significance of statistic + + if keyword_set(plot) || keyword_set(Window) then begin + +; Prepare the step functions + xx1 = REBIN(sortdata1,2*n1,/SAMPLE) + yy1 = REBIN(fn1,2*n1,/SAMPLE) + yy1 = [yy1[1:*],1.] + + xx2 = REBIN(sortdata2,2*n2,/SAMPLE) + yy2 = REBIN(fn2,2*n2,/SAMPLE) + yy2 = [yy2[1:*],1.] + + cgplot, xx1, yy1, _EXTRA = extra, WINDOW=window + cgplot, /over, xx2, yy2, lines=1, thick=2, WINDOW=window + j1 = id1[sub1] - 1 + j2 = id1[sub2] + cgplots, [sortdata1[j2], sortdata1[j2]], [0,fn2[id2[sub2]]], linestyle=2,$ + WINDOW=window + cgplots, [sortdata1[j1], sortdata1[j1]], [fn2[id2[sub1]],1], linestyle=2,$ + WINDOW=window + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/lineid_plot.pro b/modules/idl_downloads/astro/pro/lineid_plot.pro new file mode 100644 index 0000000..8665e28 --- /dev/null +++ b/modules/idl_downloads/astro/pro/lineid_plot.pro @@ -0,0 +1,261 @@ +pro lineid_plot,wave,flux,wline,text1,text2, extend=extend, $ + lcharthick = lcharthick,lcharsize=lcharsize,window=window, $ + _EXTRA = extra +;+ +; NAME: +; LINEID_PLOT +; PURPOSE: +; Plot spectrum with specified line identifications annotated at the +; top of the plot. +; +; CALLING SEQUENCE: +; lineid_plot, wave, flux, wline, text1, [ text2, +; LCHARSIZE=, LCHARTHICK=, EXTEND =, ...plotting keywords] +; +; INPUTS: +; wave - wavelength vector for the plot +; flux - flux vector +; wline - wavelength vector of line identifications. (only the lines +; between the plot limits will be used) +; text1 - string array of text to be used to annotate each line +; text2 - (OPTIONAL) second string array of text to be used for +; line annotation. Since the text is written with +; proportional spaced characters, TEXT2 can be used if +; you want two sets of annotation to be aligned: +; +; eg: Cr IV 1390.009 +; Fe V 1390.049 +; Ni IV 1390.184 +; instead of +; Cr IV 1390.009 +; Fe V 1390.049 +; Ni IV 1390.184 +; +; OPTIONAL KEYWORD INPUTS: +; EXTEND - specifies that the annotated lines should have a dotted line +; extended to the spectrum to indicate the line position. +; EXTEND can be a scalar (applies to all lines) or a vector with +; a different value for each line. The value of EXTEND gives +; the line IDL plot line thickness for the dotted lines. +; If EXTEND is a vector each dotted line can have a different +; thickness. A value of 0 indicates that no dotted line is to +; be drawn. (default = scalar 0) +; LCHARSIZE - the character size of the annotation for each line. +; If can be a vector so that different lines are annotated with +; different size characters. LCHARSIZE can be used to make +; stronger lines have a larger annotation. (default = scalar 1.0). +; LCHARTHICK = the character thickness of the annotation for each line. +; It can be a vector so that different lines are annotated with +; characters of varying thickness. LCHARTHICK can be used to +; make stronger lines have a bolder annotation. +; (default = !p.charthick) +; +; LINEID_PLOT uses the _EXTRA facility to allow the use of any cgPLOT +; keywords (e.g. AXISCOLOR, LINESTYLE, CHARSIZE) to be passed to the +; plot. +; +; SIDE EFFECTS: +; Program uses SET_VIEWPORT to set the !P.POSITION parameter to allow +; room for the annotation. This system variable can be reset to the +; default value by setting !P.POSTION=0 or typing SET_VIEWPORT with no +; parameters +; +; OPERATIONAL NOTES: +; Once the program has completed, You can use OPLOT to draw additional +; plots on the display. +; +; If your annotated characters are not being rotated properly, +; try setting !P.FONT to a non zero value. +; EXAMPLE: +; Annotate some interstellar lines between 1240 and 1270 A. +; +; IDL> w = 1240+ indgen(300)*0.1 ;Make a wavelength vector +; IDL> f = randomn(seed,300) ;Random flux vector +; IDL> id = ['N V','Si II','Si II','Si II'] ;Line IDs +; IDL> wl = [1242.80,1260.42,1264.74,1265.00] ;Line positions +; IDL> lineid_plot,w,f,wl,id,wl,/ext +; +; Note that LINEID_PLOT is smart enough not to overlap the annotation +; for the two closely spaced lines at 1264.74 and 1265.00 +; HISTORY: +; version 1 D. Lindler Jan, 1992 +; Sept 27, 1993 DJL fixed bug in /extend option +; Apr 19, 1994 DJL corrected bug in sorting of charthick (cthick) +; Sep 1996, W. Landsman, added _EXTRA keyword, changed keyword names +; CHARTHICK==>LCHARTHICK, CHARSIZE==>LCHARSIZE +; Work with !P.MULTI W. Landsman December 2003 +; Use Coyote graphics routines W. Landsman February 2011 +;- +;---------------------------------------------------------------------------- + On_error,2 + + if n_params() lt 4 then begin + print,'Syntax - LINEID_PLOT, wave, flux, wline, text1 [,text2, ' + print,' LCHARTHICK=, EXTEND=, LCHARSIZE= ...plotting keywords]' + return + end +; +; initialization +; + + setdefaultvalue, lcharsize, 1 + n = n_elements(wline) + setdefaultvalue,text2,strarr(n) + if n_elements(lcharsize) eq 1 then csize = replicate(lcharsize,n) $ + else csize = lcharsize + setdefaultvalue, extend, 0 + if n_elements(extend) eq 1 then ethick = replicate(extend,n) $ + else ethick = extend + if n_elements(lcharthick) eq 0 then cthick = !p.charthick $ + else cthick = lcharthick + if n_elements(cthick) eq 1 then cthick = replicate(cthick,n) +; +; First make a plot without any data to get the region size. Then use +; the position keyword to assign a plot area that allows room for the +; line annotation and plot the data +; + plot,wave,flux,xsty=4,ysty=4,/nodata,/noerase + x0 = !X.region[0] + y0 = !Y.region[0] + xsize = !X.region[1] - x0 + ysize = !Y.region[1] - y0 + pos = [x0+xsize*0.13,y0+ysize*0.1, x0+xsize*0.95, y0+ysize*0.65] + cgplot,wave,flux,_EXTRA=extra,pos = pos, Window=window + if keyword_set(window) then cgcontrol,execute=0 +; +; get data ranges +; + xmin = !x.crange[0] + xmax = !x.crange[1] + ymin = !y.crange[0] + ymax = !y.crange[1] + xrange = xmax-xmin + yrange = ymax-ymin +; +; find lines within x range and sort them +; + good = where((wline gt xmin) and (wline lt xmax),nlines) + if nlines lt 1 then return + wl = wline[good] + csize = csize[good] & cthick = cthick[good] & ethick = ethick[good] + txt1 = text1[good] & txt2 = text2[good] + + sub = sort(wl) + wl = wl[sub] & csize = csize[sub] & ethick = ethick[sub] + cthick = cthick[sub] + txt1 = txt1[sub] & txt2 = txt2[sub] + maxids = 65/(total(csize)/nlines) ;maximum number of identifications + if nlines gt maxids then begin + print,'Too many lines to mark' + return + endif + +; +; determine character height in wavelength units +; + char_height = abs(xrange) / 65 * csize +; +; adjust wavelengths of where to print the line ids +; + wlp = wl ;wavelength to print text +; +; test to see if we can just equally space the annotated lines +; + if (nlines gt maxids*0.85) and (n_elements(charsize) eq 1) then begin + wlp = findgen(nlines) * (xrange/(nlines-1)) + xmin + goto,print_text + end +; +; iterate to find room to annotate each line +; + changed = 1 ;flag saying we moved a wlp position + niter = 0 + factor = 0.35 ;size of adjustments in text position + while changed do begin ;iterate + changed = 0 + for i=0,nlines-1 do begin +; +; determine the difference of the annotation from the lines on the +; left and right of it and the required separation +; + if i gt 0 then begin + diff1 = wlp[i]-wlp[i-1] + separation1 = (char_height[i]+char_height[i-1])/2.0 + end else begin + diff1 = wlp[i] - xmin + char_height[i]*1.01 + separation1 = char_height[i] + end + + if i lt (nlines-1) then begin + diff2 = wlp[i+1] - wlp[i] + separation2 = (char_height[i]+char_height[i+1])/2.0 + end else begin + diff2 = xmax + char_height[i]*1.01 - wlp[i] + separation2 = char_height[i] + end +; +; determine if line annotation should be moved +; + if (diff1 lt separation1) or (diff2 lt separation2) then begin + if wlp[i] eq xmin then diff1 = 0 + if wlp[i] eq xmax then diff2 = 0 + if diff2 gt diff1 then $ + wlp[i] = (wlp[i] + separation2*factor) < xmax $ + else wlp[i] = (wlp[i] - separation1*factor) > xmin + changed = 1 + endif + + end + + if niter eq 300 then $ ; fine adjustment for + factor = factor/3 ; crowded field + + + if niter eq 1000 then changed=0 ; stop at 1000 iterations + niter = niter + 1 + + endwhile + +; +; print line id's +; +print_text: + maxcsize = max(csize) + start_arrow = ymax + yrange/60 + bend1 = ymax + yrange/30 + bend2 = ymax + (yrange/30)*3 + stop_arrow = ymax + (yrange/30)*4 + start_text1 = stop_arrow + yrange/50*maxcsize + start_text2 = start_text1 + $ + max(strlen(strtrim(txt1,1)))*yrange/50*maxcsize + start_text3 = start_text2 + $ + max(strlen(strtrim(txt2,1)))*yrange/50*maxcsize + + for i=0,nlines-1 do begin + cgplots,[wl[i],wl[i],wlp[i],wlp[i]], ADDCMD=window, $ + [start_arrow,bend1,bend2,stop_arrow] + cgtext,wlp[i] + char_height[i]/2, start_text1, txt1[i], $ + orientation = 90, size=csize[i], charthick = cthick[i],$ + window = window + cgtext,wlp[i] + char_height[i]/2, start_text2, txt2[i], $ + orientation = 90, size=csize[i], charthick = cthick[i],$ + window= window + endfor +; +; extend selected lines down to the spectrum +; + good = where((ethick gt 0) and (wl gt xmin) and (wl lt xmax),n) + if n lt 1 then return + ww = wl[good] + ethick = ethick[good] + linterp,wave,flux,ww,ff + ymax = !y.crange[1] + ymin = !y.crange[0] + offset = (ymax-ymin)/20.0 + for i=0,n-1 do $ + cgplots,[ww[i],ww[i]],[(ff[i]+offset)ymin,ymax], $ + line=2,thick = ethick[i],ADDCMD=window + if keyword_set(window) then cgcontrol,execute=1 + +return +end diff --git a/modules/idl_downloads/astro/pro/linmix_err.pro b/modules/idl_downloads/astro/pro/linmix_err.pro new file mode 100644 index 0000000..d1b24f1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/linmix_err.pro @@ -0,0 +1,1308 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; LINMIX_ERR +; PURPOSE: +; Bayesian approach to linear regression with errors in both X and Y +; EXPLANATION: +; Perform linear regression of y on x when there are measurement +; errors in both variables. the regression assumes : +; +; ETA = ALPHA + BETA * XI + EPSILON +; X = XI + XERR +; Y = ETA + YERR +; +; +; Here, (ALPHA, BETA) are the regression coefficients, EPSILON is the +; intrinsic random scatter about the regression, XERR is the +; measurement error in X, and YERR is the measurement error in +; Y. EPSILON is assumed to be normally-distributed with mean zero and +; variance SIGSQR. XERR and YERR are assumed to be +; normally-distributed with means equal to zero, variances XSIG^2 and +; YSIG^2, respectively, and covariance XYCOV. The distribution of XI +; is modelled as a mixture of normals, with group proportions PI, +; mean MU, and variance TAUSQR. Bayesian inference is employed, and +; a structure containing random draws from the posterior is +; returned. Convergence of the MCMC to the posterior is monitored +; using the potential scale reduction factor (RHAT, Gelman et +; al.2004). In general, when RHAT < 1.1 then approximate convergence +; is reached. +; +; Simple non-detections on y may also be included. +; +; CALLING SEQUENCE: +; +; LINMIX_ERR, X, Y, POST, XSIG=, YSIG=, XYCOV=, DELTA=, NGAUSS=, /SILENT, +; /METRO, MINITER= , MAXITER= +; +; +; INPUTS : +; +; X - THE OBSERVED INDEPENDENT VARIABLE. THIS SHOULD BE AN +; NX-ELEMENT VECTOR. +; Y - THE OBSERVED DEPENDENT VARIABLE. THIS SHOULD BE AN NX-ELEMENT +; VECTOR. +; +; OPTIONAL INPUTS : +; +; XSIG - THE 1-SIGMA MEASUREMENT ERRORS IN X, AN NX-ELEMENT VECTOR. +; YSIG - THE 1-SIGMA MEASUREMENT ERRORS IN Y, AN NX-ELEMENT VECTOR. +; XYCOV - THE COVARIANCE BETWEEN THE MEASUREMENT ERRORS IN X AND Y, +; AND NX-ELEMENT VECTOR. +; DELTA - AN NX-ELEMENT VECTOR INDICATING WHETHER A DATA POINT IS +; CENSORED OR NOT. IF DELTA[i] = 1, THEN THE SOURCE IS +; DETECTED, ELSE IF DELTA[i] = 0 THE SOURCE IS NOT DETECTED +; AND Y[i] SHOULD BE AN UPPER LIMIT ON Y[i]. NOTE THAT IF +; THERE ARE CENSORED DATA POINTS, THEN THE +; MAXIMUM-LIKELIHOOD ESTIMATE (THETA) IS NOT VALID. THE +; DEFAULT IS TO ASSUME ALL DATA POINTS ARE DETECTED, IE, +; DELTA = REPLICATE(1, NX). +; METRO - IF METRO = 1, THEN THE MARKOV CHAINS WILL BE CREATED USING +; THE METROPOLIS-HASTINGS ALGORITHM INSTEAD OF THE GIBBS +; SAMPLER. THIS CAN HELP THE CHAINS CONVERGE WHEN THE SAMPLE +; SIZE IS SMALL OR IF THE MEASUREMENT ERRORS DOMINATE THE +; SCATTER IN X AND Y. +; SILENT - SUPPRESS TEXT OUTPUT. +; MINITER - MINIMUM NUMBER OF ITERATIONS PERFORMED BY THE GIBBS +; SAMPLER OR METROPOLIS-HASTINGS ALGORITHM. IN GENERAL, +; MINITER = 5000 SHOULD BE SUFFICIENT FOR CONVERGENCE. THE +; DEFAULT IS MINITER = 5000. THE MCMC IS STOPPED AFTER +; RHAT < 1.1 FOR ALL PARAMETERS OF INTEREST, AND THE +; NUMBER OF ITERATIONS PERFORMED IS GREATER THAN MINITER. +; MAXITER - THE MAXIMUM NUMBER OF ITERATIONS PERFORMED BY THE +; MCMC. THE DEFAULT IS 1D5. THE MCMC IS STOPPED +; AUTOMATICALLY AFTER MAXITER ITERATIONS. +; NGAUSS - THE NUMBER OF GAUSSIANS TO USE IN THE MIXTURE +; MODELLING. THE DEFAULT IS 3. IF NGAUSS = 1, THEN THE +; PRIOR ON (MU, TAUSQR) IS ASSUMED TO BE UNIFORM. +; +; OUTPUT : +; +; POST - A STRUCTURE CONTAINING THE RESULTS FROM THE MCMC. EACH +; ELEMENT OF POST IS A DRAW FROM THE POSTERIOR DISTRIBUTION +; FOR EACH OF THE PARAMETERS. +; +; ALPHA - THE CONSTANT IN THE REGRESSION. +; BETA - THE SLOPE OF THE REGRESSION. +; SIGSQR - THE VARIANCE OF THE INTRINSIC SCATTER. +; PI - THE GAUSSIAN WEIGHTS FOR THE MIXTURE MODEL. +; MU - THE GAUSSIAN MEANS FOR THE MIXTURE MODEL. +; TAUSQR - THE GAUSSIAN VARIANCES FOR THE MIXTURE MODEL. +; MU0 - THE HYPERPARAMETER GIVING THE MEAN VALUE OF THE +; GAUSSIAN PRIOR ON MU. ONLY INCLUDED IF NGAUSS > +; 1. +; USQR - THE HYPERPARAMETER DESCRIBING FOR THE PRIOR +; VARIANCE OF THE INDIVIDUAL GAUSSIAN CENTROIDS +; ABOUT MU0. ONLY INCLUDED IF NGAUSS > 1. +; WSQR - THE HYPERPARAMETER DESCRIBING THE `TYPICAL' SCALE +; FOR THE PRIOR ON (TAUSQR,USQR). ONLY INCLUDED IF +; NGAUSS > 1. +; XIMEAN - THE MEAN OF THE DISTRIBUTION FOR THE +; INDEPENDENT VARIABLE, XI. +; XISIG - THE STANDARD DEVIATION OF THE DISTRIBUTION FOR +; THE INDEPENDENT VARIABLE, XI. +; CORR - THE LINEAR CORRELATION COEFFICIENT BETWEEN THE +; DEPENDENT AND INDEPENDENT VARIABLES, XI AND ETA. +; +; CALLED ROUTINES : +; +; RANDOMCHI, MRANDOMN, RANDOMGAM, RANDOMDIR, MULTINOM +; +; REFERENCES : +; +; Carroll, R.J., Roeder, K., & Wasserman, L., 1999, Flexible +; Parametric Measurement Error Models, Biometrics, 55, 44 +; +; Kelly, B.C., 2007, Some Aspects of Measurement Error in +; Linear Regression of Astronomical Data, The Astrophysical +; Journal, 665, 1489 (arXiv:0705.2774) +; +; Gelman, A., Carlin, J.B., Stern, H.S., & Rubin, D.B., 2004, +; Bayesian Data Analysis, Chapman & Hall/CRC +; +; REVISION HISTORY +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., JULY 2006 +; - MODIFIED PRIOR ON MU0 TO BE UNIFORM OVER [MIN(X),MAX(X)] AND +; PRIOR ON USQR TO BE UNIFORM OVER [0, 1.5 * VARIANCE(X)]. THIS +; TENDS TO GIVE BETTER RESULTS WITH FEWER GAUSSIANS. (B.KELLY, MAY +; 2007) +; - FIXED BUG SO THE ITERATION COUNT RESET AFTER THE BURNIN STAGE +; WHEN SILENT = 1 (B. KELLY, JUNE 2009) +; - FIXED BUG WHEN UPDATING MU VIA THE METROPOLIS-HASTING +; UPDATE. PREVIOUS VERSIONS DID NO INDEX MUHAT, SO ONLY MUHAT[0] +; WAS USED IN THE PROPOSAL DISTRIBUTION. THANKS TO AMY BENDER FOR +; POINTING THIS OUT. (B. KELLY, DEC 2011) +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute the hyperbolic arctangent +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function linmix_atanh, x + +z = 0.5d * ( alog(1 + x) - alog(1 - x) ) + +return, z +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute a robust estimate for the standard deviation of a +;data set, based on the inter-quartile range +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function linmix_robsig, x + +nx = n_elements(x) + ;get inter-quartile range of x +sorted = sort(x) +iqr = x[sorted[3 * nx / 4]] - x[sorted[nx / 4]] +sdev = stddev(x, /nan) +sigma = min( [sdev, iqr / 1.34] ) ;use robust estimate for sigma +if sigma eq 0 then sigma = sdev + +return, sigma +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute the log-likelihood of the data +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function loglik_mixerr, x, y, xvar, yvar, xycov, delta, theta, pi, mu, tausqr, Glabel + +alpha = theta[0] +beta = theta[1] +sigsqr = theta[2] + +nx = n_elements(x) +ngauss = n_elements(pi) + +Sigma11 = dblarr(nx, ngauss) +Sigma12 = dblarr(nx, ngauss) +Sigma22 = dblarr(nx, ngauss) +determ = dblarr(nx, ngauss) + +for k = 0, ngauss - 1 do begin + + Sigma11[0,k] = beta^2 * tausqr[k] + sigsqr + yvar + Sigma12[0,k] = beta * tausqr[k] + xycov + Sigma22[0,k] = tausqr[k] + xvar + + determ[0, k] = Sigma11[*,k] * Sigma22[*,k] - Sigma12[*,k]^2 + +endfor + +det = where(delta eq 1, ndet, comp=cens, ncomp=ncens) ;any non-detections? + +loglik = dblarr(nx) + +if ndet gt 0 then begin + ;compute contribution to + ;log-likelihood from the detected + ;sources + for k = 0, ngauss - 1 do begin + + gk = where(Glabel[det] eq k, nk) + + if nk gt 0 then begin + + zsqr = (y[det[gk]] - alpha - beta * mu[k])^2 / Sigma11[det[gk],k] + $ + (x[det[gk]] - mu[k])^2 / Sigma22[det[gk],k] - $ + 2d * Sigma12[det[gk],k] * (y[det[gk]] - alpha - beta * mu[k]) * $ + (x[det[gk]] - mu[k]) / (Sigma11[det[gk],k] * Sigma22[det[gk],k]) + + corrz = Sigma12[det[gk],k] / sqrt( Sigma11[det[gk],k] * Sigma22[det[gk],k] ) + + loglik[det[gk]] = -0.5d * alog(determ[det[gk],k]) - 0.5 * zsqr / (1d - corrz^2) + + endif + + endfor + +endif + +if ncens gt 0 then begin + ;compute contribution to the + ;log-likelihood from the + ;non-detections + for k = 0, ngauss - 1 do begin + + gk = where(Glabel[cens] eq k, nk) + + if nk gt 0 then begin + + loglikx = -0.5 * alog(Sigma22[cens[gk],k]) - $ + 0.5 * (x[cens[gk]] - mu[k])^2 / Sigma22[cens[gk],k] + + ;conditional mean of y, given x and + ;G=k + cmeany = alpha + beta * mu[k] + Sigma12[cens[gk],k] / Sigma22[cens[gk],k] * $ + (x[cens[gk]] - mu[k]) + ;conditional variance of y, given x + ;and G=k + cvary = Sigma11[cens[gk],k] - Sigma12[cens[gk],k]^2 / Sigma22[cens[gk],k] + + ;make sure logliky is finite + logliky = alog(gauss_pdf( (y[cens[gk]] - cmeany) / sqrt(cvary) )) > (-1d300) + + loglik[cens[gk]] = loglikx + logliky + + endif + + endfor + +endif + +loglik = total(loglik) + +return, loglik +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute the log-prior of the data +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function logprior_mixerr, mu, mu0, tausqr, usqr, wsqr + +ngauss = n_elements(mu) + +if ngauss gt 1 then begin + + logprior_mu = -0.5 * alog(usqr) - 0.5 * (mu - mu0)^2 / usqr + logprior_mu = total(logprior_mu) + + logprior_tausqr = 0.5 * alog(wsqr) - 1.5 * alog(tausqr) - 0.5 * wsqr / tausqr + logprior_tausqr = total(logprior_tausqr) + + logprior = logprior_mu + logprior_tausqr + +endif else logprior = 0d ;if ngauss = 1 then uniform prior + +return, logprior +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to perform the Metropolis update for the scale parameter in +;the Gibbs sampler +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function linmix_metro_update, logpost_new, logpost_old, seed, log_jrat + +lograt = logpost_new - logpost_old + +if n_elements(log_jrat) gt 0 then lograt = lograt + log_jrat + +accept = 0 + +if lograt gt 0 then accept = 1 else begin + + u = randomu(seed) + + if alog(u) le lograt then accept = 1 + +endelse + +return, accept +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to acceptance rates for metropolis-hastings algorithm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +pro linmix_metro_results, arate, ngauss + +print, '' +print, 'Metropolis-Hastings Acceptance Rates:' + +print, '(ALPHA, BETA) : ' + strtrim(arate[0], 1) +print, 'SIGMA^2 : ' + strtrim(arate[1], 1) +print, '' +for k = 0, ngauss - 1 do begin + + print, 'GAUSSIAN ' + strtrim(k+1,1) + print, ' MEAN : ' + strtrim(arate[2+k], 1) + print, ' VARIANCE : ' + strtrim(arate[2+k+ngauss], 1) + +endfor + +if ngauss gt 1 then begin + + print, '' + print, 'Mu0 : ' + strtrim(arate[2+2*ngauss], 1) + print, 'u^2 : ' + strtrim(arate[3+2*ngauss], 1) + print, 'w^2 : ' + strtrim(arate[4+2*ngauss], 1) + +endif + +print, '' + +return +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; ; +; MAIN ROUTINE ; +; ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +pro linmix_err, x, y, post, xsig=xsig, ysig=ysig, xycov=xycov, delta=delta, $ + ngauss=ngauss, metro=metro, silent=silent, miniter=miniter, $ + maxiter=maxiter + +if n_params() lt 3 then begin + + print, 'Syntax- LINMIX_ERR, X, Y, POST, XSIG=XSIG, YSIG=YSIG, XYCOV=XYCOV,' + print, ' DELTA=DELTA, NGAUSS=NGAUSS, /SILENT, /METRO, ' + print, ' MINITER=MINITER, MAXITER=MAXITER' + return + +endif + +;check inputs and setup defaults + +nx = n_elements(x) +if n_elements(y) ne nx then begin + print, 'Y and X must have the same size.' + return +endif + +if n_elements(xsig) eq 0 and n_elements(ysig) eq 0 then begin + print, 'Must supply at least one of XSIG or YSIG.' + return +endif + +if n_elements(xsig) eq 0 then begin + xsig = dblarr(nx) + xycov = dblarr(nx) +endif +if n_elements(ysig) eq 0 then begin + ysig = dblarr(nx) + xycov = dblarr(nx) +endif +if n_elements(xycov) eq 0 then xycov = dblarr(nx) + +if n_elements(xsig) ne nx then begin + print, 'XSIG and X must have the same size.' + return +endif +if n_elements(ysig) ne nx then begin + print, 'YSIG and X must have the same size.' + return +endif +if n_elements(xycov) ne nx then begin + print, 'XYCOV and X must have the same size.' + return +endif + +if n_elements(delta) eq 0 then delta = replicate(1, nx) +if n_elements(delta) ne nx then begin + print, 'DELTA and X must have the same size.' + return +endif + +bad = where(finite(x) eq 0 or finite(y) eq 0 or finite(xsig) eq 0 or $ + finite(ysig) eq 0 or finite(xycov) eq 0, nbad) + +if nbad gt 0 then begin + print, 'Non-finite input detected.' + return +endif + +det = where(delta eq 1, ndet, comp=cens, ncomp=ncens) ;get detected data points + +if ncens gt 0 then begin + + cens_noerr = where(ysig[cens] eq 0, ncens_noerr) + if ncens_noerr gt 0 then begin + print, 'NON-DETECTIONS FOR Y MUST HAVE NON-ZERO MEASUREMENT ERROR VARIANCE.' + return + endif + +endif + + ;find data points without measurement error +xnoerr = where(xsig eq 0, nxnoerr, comp=xerr, ncomp=nxerr) +ynoerr = where(ysig eq 0, nynoerr, comp=yerr, ncomp=nyerr) + +if nxerr gt 0 then ynoerr2 = where(ysig[xerr] eq 0, nynoerr2) else nynoerr2 = 0L +if nyerr gt 0 then xnoerr2 = where(xsig[yerr] eq 0, nxnoerr2) else nxnoerr2 = 0L + +xvar = xsig^2 +yvar = ysig^2 +xycorr = xycov / (xsig * ysig) +if nxnoerr gt 0 then xycorr[xnoerr] = 0d +if nynoerr gt 0 then xycorr[ynoerr] = 0d + +if not keyword_set(metro) then metro = 0 +if metro then gibbs = 0 else gibbs = 1 +if not keyword_set(silent) then silent = 0 +if n_elements(ngauss) eq 0 then ngauss = 3 + +if ngauss le 0 then begin + print, 'NGAUSS must be at least 1.' + return +endif + +if n_elements(miniter) eq 0 then miniter = 5000L ;minimum number of iterations that the + ;Markov Chain must perform +if n_elements(maxiter) eq 0 then maxiter = 100000L ;maximum number of iterations that the + ;Markov Chain will perform + +;; perform MCMC + +nchains = 4 ;number of markov chains +checkiter = 100 ;check for convergence every 100 iterations +iter = 0L + +;use BCES estimator for initial guess of theta = (alpha, beta, sigsqr) +beta = ( correlate(x, y, /covar) - mean(xycov) ) / $ + ( variance(x) - mean(xvar) ) +alpha = mean(y) - beta * mean(x) + +sigsqr = variance(y) - mean(yvar) - beta * (correlate(x,y, /covar) - mean(xycov)) +sigsqr = sigsqr > 0.05 * variance(y - alpha - beta * x) + + ;get initial guess of mixture + ;parameters prior +mu0 = median(x) +wsqr = variance(x) - median(xvar) +wsqr = wsqr > 0.01 * variance(x) + +;now get MCMC starting values dispersed around these initial guesses + +Xmat = [[replicate(1d, nx)], [x]] +Vcoef = invert( Xmat ## transpose(Xmat), /double ) * sigsqr + +coef = mrandomn(seed, Vcoef, nchains) +chisqr = randomchi(seed, 4, nchains) + +;randomly disperse starting values for (alpha,beta) from a +;multivariate students-t distribution with 4 degrees of freedom +alphag = alpha + coef[*,0] * sqrt(4d / chisqr) +betag = beta + coef[*,1] * sqrt(4d / chisqr) + + ;draw sigsqr from an Inverse scaled + ;chi-square density +sigsqrg = sigsqr * (nx / 2) / randomchi(seed, nx / 2, nchains) + +;get starting values for the mixture parameters, first do prior +;parameters + + ;mu0 is the global mean + +mu0min = min(x) ;prior for mu0 is uniform over mu0min < mu0 < mu0max +mu0max = max(x) + +repeat begin + + mu0g = mu0 + sqrt(variance(x) / nx) * randomn(seed, nchains) / $ + sqrt(4d / randomchi(seed, 4, nchains)) + + pass = where(mu0g gt mu0min and mu0g lt mu0max, npass) + +endrep until npass eq nchains + + ;wsqr is the global scale +wsqrg = wsqr * (nx / 2) / randomchi(seed, nx / 2, nchains) + +usqrg = replicate(variance(x) / 2d, nchains) + +;now get starting values for mixture parameters + +tausqrg = dblarr(ngauss, nchains) ;initial group variances +for k = 0, ngauss - 1 do tausqrg[k,*] = 0.5 * wsqrg * 4 / $ + randomchi(seed, 4, nchains) + +mug = dblarr(ngauss, nchains) ;initial group means +for k = 0, ngauss - 1 do mug[k,*] = mu0g + sqrt(wsqrg) * randomn(seed, nchains) + +;get initial group proportions and group labels + +pig = dblarr(ngauss, nchains) +Glabel = intarr(nx, nchains) + +if ngauss eq 1 then Glabel = intarr(nx, nchains) else begin + + for i = 0, nchains - 1 do begin + + for j = 0, nx - 1 do begin + ;classify sources to closest centroid + dist = abs(mug[*,i] - x[j]) + mindist = min(dist, minind) + + pig[minind,i] = pig[minind,i] + 1 + Glabel[j,i] = minind + + endfor + + endfor + +endelse + ;get initial values for pi from a + ;dirichlet distribution, with + ;parameters based on initial class + ;occupancies +if ngauss eq 1 then pig = transpose(replicate(1d, nchains)) else $ + for i = 0, nchains - 1 do pig[*,i] = randomdir(seed, pig[*,i] + 1) + +alpha = alphag +beta = betag +sigsqr = sigsqrg +mu = mug +tausqr = tausqrg +pi = pig +mu0 = mu0g +wsqr = wsqrg +usqr = usqrg + +eta = dblarr(nx, nchains) +for i = 0, nchains - 1 do eta[*,i] = y ;initial values for eta + +nut = 1 ;degrees of freedom for the prior on tausqr +nuu = 1 ;degrees of freedom for the prior on usqr + +;number of parameters to monitor convergence on +npar = 6 + +if metro then begin +;get initial variances for the jumping kernels + + jvar_coef = Vcoef + log_ssqr = alog( sigsqr[0] * nx / randomchi(seed, nx, 1000) ) + jvar_ssqr = variance(log_ssqr) ;get variance of the jumping density + ;for sigsqr + + ;get variances for prior variance + ;parameters + jvar_mu0 = variance(x) / ngauss + jvar_wsqr = variance( alog(variance(x) * nx / randomchi(seed, nx, 1000)) ) + jvar_usqr = jvar_wsqr + + naccept = lonarr(5 + 2 * ngauss) + + logpost = dblarr(nchains) + ;get initial values of the + ;log-posterior + for i = 0, nchains - 1 do begin + + theta = [alpha[i], beta[i], sigsqr[i]] + loglik = loglik_mixerr( x, y, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tausqr[*,i], Glabel[*,i] ) + logprior = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + logpost[i] = loglik + logprior + + endfor + +endif + +convergence = 0 + +;stop burn-in phase after BURNSTOP iterations if doing +;Metropolis-Hastings jumps, update jumping kernels every BURNITER +;iterations + +burnin = metro ? 1 : 0 +burniter = 250 +burnstop = 500 < (miniter / 2 > 100) + ;start Markov Chains +if not silent then print, 'Simulating Markov Chains...' +if not silent and metro then print, 'Doing Burn-in First...' + +ygibbs = y +xi = x +umax = 1.5 * variance(x) ;prior for usqr is uniform over 0 < usqr < umax + +if metro then begin + ;define arrays now so we don't have to + ;create them every MCMC iteration + Sigma11 = dblarr(nx, ngauss) + Sigma12 = dblarr(nx, ngauss) + Sigma22 = dblarr(nx, ngauss) + determ = dblarr(nx, ngauss) + +endif + +gamma = dblarr(nx, ngauss) +nk = fltarr(ngauss) + +repeat begin + + for i = 0, nchains - 1 do begin ;do markov chains one at-a-time + + if gibbs then begin + + if ncens gt 0 then begin + ;first get new values of censored y + for j = 0, ncens - 1 do begin + + next = 0 + repeat ygibbs[cens[j]] = eta[cens[j],i] + $ + sqrt(yvar[cens[j]]) * randomn(seed) $ + until ygibbs[cens[j]] le y[cens[j]] + + endfor + + endif + +;need to get new values of Xi and Eta for Gibbs sampler + + if nxerr gt 0 then begin + ;first draw Xi|theta,x,y,G,mu,tausqr + xixy = x[xerr] + xycov[xerr] / yvar[xerr] * (eta[xerr,i] - ygibbs[xerr]) + if nynoerr2 gt 0 then xixy[ynoerr2] = x[xerr[ynoerr2]] + xixyvar = xvar[xerr] * (1 - xycorr[xerr]^2) + + for k = 0, ngauss - 1 do begin ;do one gaussian at-a-time + + group = where(Glabel[xerr,i] eq k, ngroup) + + if ngroup gt 0 then begin + + xihvar = 1d / (beta[i]^2 / sigsqr[i] + 1d / xixyvar[group] + $ + 1d / tausqr[k,i]) + xihat = xihvar * $ + (xixy[group] / xixyvar[group] + $ + beta[i] * (eta[xerr[group],i] - alpha[i]) / sigsqr[i] + $ + mu[k,i] / tausqr[k,i]) + + xi[xerr[group]] = xihat + sqrt(xihvar) * randomn(seed, ngroup) + + endif + + endfor + + endif + + if nyerr gt 0 then begin + ;now draw Eta|Xi,x,y,theta + etaxyvar = yvar[yerr] * (1d - xycorr[yerr]^2) + etaxy = ygibbs[yerr] + xycov[yerr] / xvar[yerr] * (xi[yerr] - x[yerr]) + if nxnoerr2 gt 0 then etaxy[xnoerr2] = ygibbs[yerr[xnoerr2]] + etahvar = 1d / (1d / sigsqr[i] + 1d / etaxyvar) + etahat = etahvar * (etaxy / etaxyvar + $ + (alpha[i] + beta[i] * xi[yerr]) / sigsqr[i]) + + eta[yerr,i] = etahat + sqrt(etahvar) * randomn(seed, nyerr) + + endif + + endif + + ;now draw new class labels + if ngauss eq 1 then Glabel[*,i] = 0 else begin + + if gibbs then begin + ;get unnormalized probability that + ;source i came from Gaussian k, given + ;xi[i] + for k = 0, ngauss - 1 do $ + gamma[0,k] = pi[k,i] / sqrt(2d * !pi * tausqr[k,i]) * $ + exp(-0.5 * (xi - mu[k,i])^2 / tausqr[k,i]) + + endif else begin + + for k = 0, ngauss - 1 do begin + + Sigma11[0,k] = beta[i]^2 * tausqr[k,i] + sigsqr[i] + yvar + Sigma12[0,k] = beta[i] * tausqr[k,i] + xycov + Sigma22[0,k] = tausqr[k,i] + xvar + + determ[0, k] = Sigma11[*,k] * Sigma22[*,k] - Sigma12[*,k]^2 + + endfor + + if ndet gt 0 then begin + ;get unnormalized probability that + ;source i came from Gaussian k, given + ;x[i] and y[i] + for k = 0, ngauss - 1 do begin + + zsqr = (y[det] - alpha[i] - beta[i] * mu[k,i])^2 / Sigma11[det,k] + $ + (x[det] - mu[k,i])^2 / Sigma22[det,k] - $ + 2d * Sigma12[det,k] * (y[det] - alpha[i] - beta[i] * mu[k,i]) * $ + (x[det] - mu[k,i]) / (Sigma11[det,k] * Sigma22[det,k]) + + corrz = Sigma12[det,k] / sqrt( Sigma11[det,k] * Sigma22[det,k] ) + + lognorm = -0.5d * alog(determ[det,k]) - 0.5 * zsqr / (1d - corrz^2) + + gamma[det,k] = pi[k,i] * exp(lognorm) / (2d * !pi) + + endfor + + endif + + if ncens gt 0 then begin + ;get unnormalized probability that + ;source i came from Gaussian k, given + ;x[i] and y[i] > y0[i] + for k = 0, ngauss - 1 do begin + + gamma[cens,k] = pi[k,i] / sqrt(2d * !pi * Sigma22[cens,k]) * $ + exp(-0.5 * (x[cens] - mu[k,i])^2 / Sigma22[cens,k]) + + ;conditional mean of y, given x + cmeany = alpha[i] + beta[i] * mu[k,i] + Sigma12[cens,k] / Sigma22[cens,k] * $ + (x[cens] - mu[k,i]) + ;conditional variance of y, given x + cvary = Sigma11[cens,k] - Sigma12[cens,k]^2 / Sigma22[cens,k] + ;make sure logliky is finite + gamma[cens,k] = gamma[cens,k] * gauss_pdf( (y[cens] - cmeany) / sqrt(cvary) ) + + endfor + + endif + + endelse + + norm = total(gamma, 2) + + for j = 0, nx - 1 do begin + + gamma0 = reform(gamma[j,*]) / norm[j] ;normalized probability that the i-th data point + ;is from the k-th Gaussian, given the observed + ;data point + Gjk = multinom(1, gamma0, seed=seed) + Glabel[j,i] = where(Gjk eq 1) + + endfor + + endelse + +;now draw new values of regression parameters, theta = (alpha, beta, +;sigsqr) + + if gibbs then begin + ;use gibbs sampler to draw alpha,beta|Xi,Eta,sigsqr + Xmat = [[replicate(1d, nx)], [xi]] + Vcoef = invert( Xmat ## transpose(Xmat), /double ) * sigsqr[i] + + coefhat = linfit( xi, eta[*,i] ) + coef = coefhat + mrandomn(seed, Vcoef) + + alpha[i] = coef[0] + beta[i] = coef[1] + + endif else begin + + theta = [alpha[i], beta[i], sigsqr[i]] + + loglik = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tausqr[*,i], Glabel[*,i] ) + logprior = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + + logpost[i] = loglik + logprior ;log-posterior for current parameter values + + ;use metropolis update to get new + ;values of the coefficients + coef = [alpha[i], beta[i]] + mrandomn(seed, jvar_coef) + + theta = [coef[0], coef[1], sigsqr[i]] + loglik_new = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tausqr[*,i], Glabel[*,i] ) + logprior_new = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + + logpost_new = loglik_new + logprior_new + + accept = linmix_metro_update( logpost_new, logpost[i], seed ) + + if accept then begin + + naccept[0] = naccept[0] + 1L + alpha[i] = coef[0] + beta[i] = coef[1] + logpost[i] = logpost_new + + endif + + endelse + ;now get sigsqr + if gibbs then begin + + ssqr = total( (eta[*,i] - alpha[i] - beta[i] * xi)^2 ) / (nx - 2) + sigsqr[i] = (nx - 2) * ssqr / randomchi(seed, nx - 2.0) + + endif else begin + ;do metropolis update + log_ssqr = alog(sigsqr[i]) + sqrt(jvar_ssqr) * randomn(seed) + ssqr = exp(log_ssqr) + + theta = [alpha[i], beta[i], ssqr] + + loglik_new = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tausqr[*,i], Glabel[*,i] ) + logprior_new = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + + logpost_new = loglik_new + logprior_new + log_ssqr + logpost_old = logpost[i] + alog(sigsqr[i]) + + accept = linmix_metro_update( logpost_new, logpost_old, seed ) + + if accept then begin + + naccept[1] = naccept[1] + 1L + sigsqr[i] = ssqr + logpost[i] = loglik_new + logprior_new + + endif + + endelse + +;now do mixture model parameters, psi = (pi,mu,tausqr) + + if gibbs then begin + + for k = 0, ngauss - 1 do begin + + group = where(Glabel[*,i] eq k, ngroup) + nk[k] = ngroup + + if ngroup gt 0 then begin + + ;get mu|Xi,G,tausqr,mu0,usqr + + if ngauss gt 1 then begin + + muhat = ngroup * mean(xi[group]) / tausqr[k,i] + mu0[i] / usqr[i] + + muvar = 1d / (1d / usqr[i] + ngroup / tausqr[k,i]) + + endif else begin + + muhat = ngroup * mean(xi[group]) / tausqr[k,i] + + muvar = tausqr[k,i] / ngroup + + endelse + + muhat = muvar * muhat + + mu[k,i] = muhat + sqrt(muvar) * randomn(seed) + + ;get tausqr|Xi,G,mu,wsqr,nut + + if ngauss gt 1 then begin + + nuk = ngroup + nut + tsqr = (nut * wsqr[i] + total( (xi[group] - mu[k,i])^2 )) / nuk + + endif else begin + + nuk = ngroup + tsqr = total( (xi[group] - mu[k,i])^2 ) / nuk + + endelse + + tausqr[k,i] = tsqr * nuk / randomchi(seed, nuk) + + endif else begin + + mu[k,i] = mu0[i] + sqrt(usqr[i]) * randomn(seed) + tausqr[k,i] = wsqr[i] * nut / randomchi(seed, nut) + + endelse + + endfor + ;get pi|G + if ngauss eq 1 then pi[*,i] = 1d else $ + pi[*,i] = randomdir(seed, nk + 1) + + endif else begin + ;do metropolis-hastings updating using + ;approximate Gibbs sampler + + for k = 0, ngauss - 1 do begin + + group = where(Glabel[*,i] eq k, ngroup) + nk[k] = ngroup + + if ngroup gt 0 then begin + ;get proposal for mu[k], do + ;approximate Gibbs sampler + muprop = mu[*,i] + + muvarx = (tausqr[k,i] + mean(xvar[group])) + + muvar = ngauss gt 1 ? 1d / (1d / usqr[i] + ngroup / muvarx) : $ + muvarx / ngroup + + muhat = muprop + + chisqr = randomchi(seed, 4) + ;draw proposal for mu from Student's t + ;with 4 degrees of freedom + muprop[k] = muhat[k] + sqrt(muvar * 4 / chisqr) * randomn(seed) + + endif else begin + + muprop = mu[*,i] + muprop[k] = mu[k,i] + sqrt(usqr[i]) * randomn(seed) + + endelse + + theta = [alpha[i], beta[i], sigsqr[i]] + + loglik_new = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], muprop, tausqr[*,i], Glabel[*,i] ) + logprior_new = logprior_mixerr(muprop, mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + + logpost_new = loglik_new + logprior_new + + accept = linmix_metro_update( logpost_new, logpost[i], seed ) + + if accept then begin + + naccept[2+k] = naccept[2+k] + 1L + mu[k,i] = muprop[k] + logpost[i] = logpost_new + + endif + + ;get proposal for tausqr[k], do + ;approximate Gibbs sampler + tsqrprop = tausqr[*,i] + + dof = ngroup > 1 + + tsqrprop[k] = tausqr[k,i] * dof / randomchi(seed, dof) + + log_jrat = (dof + 1d) * alog(tsqrprop[k] / tausqr[k,i]) + $ + dof / 2d * (tausqr[k,i] / tsqrprop[k] - tsqrprop[k] / tausqr[k,i]) + + loglik_new = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tsqrprop, Glabel[*,i] ) + logprior_new = logprior_mixerr(mu[*,i], mu0[i], tsqrprop, usqr[i], wsqr[i]) + + logpost_new = loglik_new + logprior_new + + accept = linmix_metro_update( logpost_new, logpost[i], seed, log_jrat) + + if accept then begin + + naccept[2 + k + ngauss] = naccept[2 + k + ngauss] + 1L + tausqr[k,i] = tsqrprop[k] + logpost[i] = logpost_new + + endif + + endfor + ;get pi|G, can do exact Gibbs sampler + ;for this + if ngauss eq 1 then pi[*,i] = 1d else $ + pi[*,i] = randomdir(seed, nk + 1) + + endelse + +;finally, update parameters for prior distribution, only do this if +;more than one gaussian + + if ngauss gt 1 then begin + + if gibbs then begin + + repeat mu0[i] = mean(mu[*,i]) + sqrt(usqr[i] / ngauss) * randomn(seed) $ + until (mu0[i] gt mu0min) and (mu0[i] lt mu0max) + + endif else begin + + loglik = loglik_mixerr( x, ygibbs, xvar, yvar, xycov, delta, theta, $ + pi[*,i], mu[*,i], tausqr[*,i], Glabel[*,i] ) + + muprop = mu0[i] + sqrt(jvar_mu0) * randomn(seed) + + if muprop gt mu0min and muprop lt mu0max then begin + + logprior_old = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + logprior_new = logprior_mixerr(mu[*,i], muprop, tausqr[*,i], usqr[i], wsqr[i]) + + logpost_new = loglik + logprior_new + logpost_old = loglik + logprior_old + + accept = linmix_metro_update( logpost_new, logpost_old, seed ) + + if accept then begin + + naccept[2 + 2 * ngauss] = naccept[2 + 2 * ngauss] + 1L + mu0[i] = muprop + logpost[i] = loglik + logprior_new + + endif + + endif + + endelse + + if gibbs then begin + + nu = ngauss + nuu + usqr0 = (nuu * wsqr[i] + total( (mu[*,i] - mu0[i])^2 )) / nu + + repeat usqr[i] = usqr0 * nu / randomchi(seed, nu) $ + until usqr[i] le umax + + endif else begin + ;do metropolis update + + log_usqr = alog(usqr[i]) + sqrt(jvar_usqr) * randomn(seed) + usqr0 = exp(log_usqr) + + if usqr0 le umax then begin + + logprior_old = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + + logpost[i] = loglik + logprior_old ;update posterior after gibbs step for mu0 + + logprior_new = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr0, wsqr[i]) + + logpost_new = loglik + logprior_new + logpost_old = loglik + logprior_old + + log_jrat = log_usqr - alog(usqr[i]) + + accept = linmix_metro_update( logpost_new, logpost_old, seed, log_jrat ) + + if accept then begin + + naccept[3 + 2 * ngauss] = naccept[3 + 2 * ngauss] + 1L + usqr[i] = usqr0 + logpost[i] = loglik + logprior_new + + endif + + endif + + endelse + + if gibbs then begin + + alphaw = ngauss * nut / 2d + 1 + betaw = 0.5 * nut * total(1d / tausqr[*,i]) + + wsqr[i] = randomgam(seed, alphaw, betaw) + + endif else begin + + log_wsqr = alog(wsqr[i]) + sqrt(jvar_wsqr) * randomn(seed) + wsqr0 = exp(log_wsqr) + + logprior_old = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr[i]) + logprior_new = logprior_mixerr(mu[*,i], mu0[i], tausqr[*,i], usqr[i], wsqr0) + + logpost_new = loglik + logprior_new + log_wsqr + logpost_old = loglik + logprior_old + alog(wsqr[i]) + + accept = linmix_metro_update( logpost_new, logpost_old, seed ) + + if accept then begin + + naccept[4 + 2 * ngauss] = naccept[4 + 2 * ngauss] + 1L + wsqr[i] = wsqr0 + logpost[i] = loglik + logprior_new + + endif + + endelse + + endif + + endfor + + ;save Markov Chains + if iter eq 0 then begin + + alphag = alpha + betag = beta + sigsqrg = sigsqr + + pig = pi + mug = mu + tausqrg = tausqr + + if ngauss gt 1 then begin + + mu0g = mu0 + usqrg = usqr + wsqrg = wsqr + + endif + + if metro then logpostg = logpost + + endif else begin + + alphag = [alphag, alpha] + betag = [betag, beta] + sigsqrg = [sigsqrg, sigsqr] + + pig = [[pig], [pi]] + mug = [[mug], [mu]] + tausqrg = [[tausqrg], [tausqr]] + + if ngauss gt 1 then begin + + mu0g = [mu0g, mu0] + usqrg = [usqrg, usqr] + wsqrg = [wsqrg, wsqr] + + endif + + if metro then logpostg = [logpostg, logpost] + + endelse + + iter = iter + 1L + +;check for convergence + + if iter ge 4 and iter eq checkiter and not burnin then begin + + if not silent and metro then linmix_metro_results, $ + float(naccept) / (nchains * iter), ngauss + + Bvar = dblarr(npar) ;between-chain variance + Wvar = dblarr(npar) ;within-chain variance + + psi = dblarr(iter, nchains, npar) + + psi[*,*,0] = transpose(reform(alphag, nchains, iter)) + psi[*,*,1] = transpose(reform(betag, nchains, iter)) + psi[*,*,2] = transpose(reform(sigsqrg, nchains, iter)) + + pig2 = reform(pig, ngauss, nchains, iter) + mug2 = reform(mug, ngauss, nchains, iter) + tausqrg2 = reform(tausqrg, ngauss, nchains, iter) + + psi[*,*,3] = transpose( total(pig2 * mug2, 1) ) ;mean of xi + ;variance of xi + psi[*,*,4] = transpose( total(pig2 * (tausqrg2 + mug2^2), 1) ) - psi[*,*,3]^2 + ;linear correlation coefficient + ;between xi and eta + psi[*,*,5] = psi[*,*,1] * sqrt(psi[*,*,4] / (psi[*,*,1]^2 * psi[*,*,4] + psi[*,*,2])) + ;do normalizing transforms before + ;monitoring convergence + psi[*,*,2] = alog(psi[*,*,2]) + psi[*,*,4] = alog(psi[*,*,4]) + psi[*,*,5] = linmix_atanh(psi[*,*,5]) + + psi = psi[iter/2:*,*,*] ;discard first half of MCMC + + ndraw = iter / 2 + ;calculate between- and within-sequence + ; variances + for j = 0, npar - 1 do begin + + psibarj = total( psi[*,*,j], 1 ) / ndraw + psibar = mean(psibarj) + + sjsqr = 0d + for i = 0, nchains - 1 do $ + sjsqr = sjsqr + total( (psi[*, i, j] - psibarj[i])^2 ) / (ndraw - 1.0) + + Bvar[j] = ndraw / (nchains - 1.0) * total( (psibarj - psibar)^2 ) + Wvar[j] = sjsqr / nchains + + endfor + + varplus = (1.0 - 1d / ndraw) * Wvar + Bvar / ndraw + Rhat = sqrt( varplus / Wvar ) ;potential variance scale reduction factor + + if total( (Rhat le 1.1) ) eq npar and iter ge miniter then convergence = 1 $ + else if iter ge maxiter then convergence = 1 else begin + + if not silent then begin + print, 'Iteration: ', iter + print, 'Rhat Values for ALPHA, BETA, log(SIGMA^2), mean(XI), ' + $ + 'log(variance(XI), atanh(corr(XI,ETA)) ): ' + print, Rhat + endif + + checkiter = checkiter + 100L + + endelse + + endif + + if (burnin) and (iter eq burniter) then begin +;still doing burn-in stage, get new estimates for jumping kernel +;parameters + + jvar_ssqr = linmix_robsig( alog(sigsqrg) )^2 + + ;now modify covariance matrix for + ;coefficient jumping kernel + coefg = [[alphag], [betag]] + + jvar_coef = correlate( transpose(coefg), /covar) + + if ngauss gt 1 then begin + + jvar_mu0 = linmix_robsig(mu0g)^2 * 2.4^2 + + jvar_usqr = linmix_robsig( alog(usqrg) )^2 * 2.4^2 + + jvar_wsqr = linmix_robsig( alog(wsqrg) )^2 * 2.4^2 + + endif + + if iter eq burnstop then burnin = 0 + + if not burnin then begin + + if not silent then print, 'Burn-in Complete' + + iter = 0L + + endif + + naccept = lonarr(5 + 2 * ngauss) + burniter = burniter + 250L + + endif + +endrep until convergence + +ndraw = iter * nchains / 2 + +;save posterior draws in a structure + +if ngauss gt 1 then begin + + post = {alpha:0d, beta:0d, sigsqr:0d, pi:dblarr(ngauss), mu:dblarr(ngauss), $ + tausqr:dblarr(ngauss), mu0:0d, usqr:0d, wsqr:0d, ximean:0d, xisig:0d, $ + corr:0d} + +endif else begin + + post = {alpha:0d, beta:0d, sigsqr:0d, pi:dblarr(ngauss), mu:dblarr(ngauss), $ + tausqr:dblarr(ngauss), ximean:0d, xisig:0d, corr:0d} + +endelse + +post = replicate(post, ndraw) + +post.alpha = alphag[(iter*nchains+1)/2:*] +post.beta = betag[(iter*nchains+1)/2:*] +post.sigsqr = sigsqrg[(iter*nchains+1)/2:*] +post.pi = pig[*,(iter*nchains+1)/2:*] +post.mu = mug[*,(iter*nchains+1)/2:*] +post.tausqr = tausqrg[*,(iter*nchains+1)/2:*] + +if ngauss gt 1 then begin + + post.mu0 = mu0g[(iter*nchains+1)/2:*] + post.usqr = usqrg[(iter*nchains+1)/2:*] + post.wsqr = wsqrg[(iter*nchains+1)/2:*] + +endif + +post.ximean = total(post.pi * post.mu, 1) ;mean of xi +post.xisig = total(post.pi * (post.tausqr + post.mu^2), 1) - post.ximean^2 +post.xisig = sqrt(post.xisig) ;standard deviation of xi + + ;get linear correlation coefficient + ;between xi and eta +post.corr = post.beta * post.xisig / sqrt(post.beta^2 * post.xisig^2 + post.sigsqr) + +return +end diff --git a/modules/idl_downloads/astro/pro/linterp.pro b/modules/idl_downloads/astro/pro/linterp.pro new file mode 100644 index 0000000..e91e77f --- /dev/null +++ b/modules/idl_downloads/astro/pro/linterp.pro @@ -0,0 +1,116 @@ +pro linterp, Xtab, Ytab, Xint, Yint, MISSING = missing, NoInterp = NoInterp +;+ +; NAME: +; LINTERP +; PURPOSE: +; Linearly interpolate tabulated 1-d data from one grid to a new one. +; EXPLANATION: +; The results of LINTERP are numerically equivalent to the IDL intrinsic +; INTERPOL() function, but note the following: +; (1) LINTERP is a procedure rather than a function +; (2) INTERPOL() extrapolates beyond the end points whereas LINTERP +; truncates to the endpoints (or uses the MISSING keyword) +; (3) LINTERP (unlike INTERPOL) uses the intrinsic INTERPOLATE function +; and thus may have a speed advantage +; (4) LINTERP always converts the new grid vector to floating point +; (because INTERPOLATE does this) whereas INTERPOL() will +; keep double precision if supplied. +; +; Use QUADTERP for quadratic interpolation. +; +; CALLING SEQUENCE: +; LINTERP, Xtab, Ytab, Xint, Yint, [MISSING =, /NoInterp ] +; +; INPUT PARAMETERS: +; Xtab - Vector containing the current independent variable grid. +; Must be monotonic increasing or decreasing +; Ytab - Vector containing the current dependent variable values at +; the XTAB grid points. +; Xint - Scalar or vector containing the new independent variable grid +; points for which interpolated value(s) of the dependent +; variable are sought. Note that -- due to a limitation of the +; intrinsic INTERPOLATE() function -- Xint is always converted to +; floating point internally. +; +; OUTPUT PARAMETERS: +; Yint - Scalar or vector with the interpolated value(s) of the +; dependent variable at the XINT grid points. +; YINT is double precision if XTAB or YTAB are double, +; otherwise YINT is REAL*4 +; +; OPTIONAL INPUT KEYWORD: +; MISSING - Scalar specifying YINT value(s) to be assigned, when Xint +; value(s) are outside of the range of Xtab. Default is to +; truncate the out of range YINT value(s) to the nearest value +; of YTAB. See the help for the INTERPOLATE function. +; /NoINTERP - If supplied then LINTERP returns the YTAB value(s) +; associated with the closest XTAB value(s)rather than +; interpolating. +; +; EXAMPLE: +; To linearly interpolate from a spectrum wavelength-flux pair +; Wave, Flux to another wavelength grid defined as: +; WGrid = [1540., 1541., 1542., 1543., 1544, 1545.] +; +; IDL> LINTERP, Wave, Flux, WGrid, FGrid +; +; FGRID will be a 6 element vector containing the values of Flux +; linearly interpolated onto the WGrid wavelength scale +; +; PROCEDURE: +; Uses TABINV to calculate the effective index of the values +; in Xint in the table Xtab. The resulting index is used +; with the intrinsic INTERPOLATE function to find the corresponding +; Yint value in Ytab. Unless the MISSING keyword is supplied, out +; of range Yint values are truncated to the nearest value of Ytab. +; +; PROCEDURES CALLED: +; TABINV, ZPARCHECK +; MODIFICATION HISTORY: +; Adapted from the IUE RDAF, W. Landsman October, 1988 +; Modified to use the new INTERPOLATE function June, 1992 +; Modified to always return REAL*4 October, 1992 +; Added MISSING keyword August, 1993 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added NoInterp keyword W. Landsman July 1999 +; Work for unsigned, 64 bit integers W. Landsman October 2001 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - LINTERP, Xtab, Ytab, Xint, Yint, [ MISSING = ]' + print,' Xtab, Ytab - Input X and Y vectors' + print,' Xint - Input X value (scalar or vector) at which to interpolate' + print,' Yint - Output interpolated Y value(s)' + return + endif + + numeric = [indgen(5)+1,12,13,14,15] ;Numeric datatypes + zparcheck, 'LINTERP', Xtab, 1, numeric, 1, 'Current X Vector' + zparcheck, 'LINTERP', Ytab, 2, numeric, 1, 'Current Y Vector' + zparcheck, 'LINTERP', Xint, 3, numeric, [0,1], 'New X Vector or Scalar' + +; Determine index of data-points from which interpolation is made + + npts = min( [ N_elements(Xtab), N_elements(Ytab) ] ) + tabinv, Xtab, Xint, r + if keyword_set(NoInterp) then Yint = Ytab[round(r)] else begin + ytype = size( Ytab, /TYPE) + +; Perform linear interpolation + + if (ytype LE 3) || (ytype GE 12) then $ ;Integer or byte input? + Yint = interpolate( float(Ytab), r) else $ + Yint = interpolate( Ytab, r) + + endelse + + if N_elements(missing) EQ 1 then begin + Xmin = min( [ Xtab[0],Xtab[npts-1] ], max = Xmax) + bad = where( (Xint LT Xmin) or (Xint GT Xmax ), Nbad) + if Nbad GT 0 then Yint[bad] = missing + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/list_with_path.pro b/modules/idl_downloads/astro/pro/list_with_path.pro new file mode 100644 index 0000000..0814d53 --- /dev/null +++ b/modules/idl_downloads/astro/pro/list_with_path.pro @@ -0,0 +1,70 @@ + FUNCTION LIST_WITH_PATH, FILENAME, PATHS, NOCURRENT=NOCURRENT, $ + COUNT = COUNT +;+ +; NAME: +; LIST_WITH_PATH +; PURPOSE: +; Search for files in a specified directory path. +; EXPLANATION: +; Lists files in a set of default paths, similar to using FILE_SEARCH, +; except that a list of paths to be searched can be given. +; +; CALLING SEQUENCE: +; Result = LIST_WITH_PATH( FILENAME, PATHS ) +; +; INPUTS: +; FILENAME = Name of file to be searched for. It may contain wildcard +; characters, e.g. "*.dat". +; +; PATHS = One or more default paths to use in the search in case +; FILENAME does not contain a path itself. The individual +; paths are separated by commas, although in UNIX, colons +; can also be used. In other words, PATHS has the same +; format as !PATH, except that commas can be used as a +; separator regardless of operating system. The current +; directory is always searched first, unless the keyword +; NOCURRENT is set. +; +; A leading $ can be used in any path to signal that what +; follows is an environmental variable, but the $ is not +; necessary. Environmental variables can themselves +; contain multiple paths. +; +; OUTPUTS: +; The result of the function is a list of filenames. +; EXAMPLE: +; FILENAME = '' +; READ, 'File to open: ', FILENAME +; FILE = LIST_WITH_PATH( FILENAME, 'SERTS_DATA', '.fix' ) +; IF FILE NE '' THEN ... +; PROCEDURE CALLS: +; BREAK_PATH, CONCAT_DIR() +; Category : +; Utilities, Operating_system +; REVISION HISTORY: +; Version 1, William Thompson, GSFC, 3 November 1994 +; Documentation modified Wayne Landsman HSTX November 1994 +; Assume since V5.5, vector call to FILE_SEARCH() W. Landsman Sep 2006 +; Restore pre-Sep 2006 behavior of not searching subdirectories +; W.Landsman. Feb 2007 +;- +; + COMPILE_OPT IDL2 + ON_ERROR, 2 +; +; Check the number of parameters: +; + IF N_PARAMS() NE 2 THEN MESSAGE, 'Syntax: Result = ' + $ + 'LIST_WITH_PATH(FILENAME, PATHS)' + + PATH = BREAK_PATH(PATHS) +; +; If NOCURRENT was set, then remove the first (blank) entry from the PATH +; array. +; + IF KEYWORD_SET(NOCURRENT) THEN PATH = PATH[1:*] + + FILES = FILE_SEARCH( CONCAT_DIR(PATH, FILENAME), COUNT=COUNT) +; + RETURN, FILES + END diff --git a/modules/idl_downloads/astro/pro/lsf_rotate.pro b/modules/idl_downloads/astro/pro/lsf_rotate.pro new file mode 100644 index 0000000..9914869 --- /dev/null +++ b/modules/idl_downloads/astro/pro/lsf_rotate.pro @@ -0,0 +1,80 @@ + function lsf_rotate, deltav, vsini, EPSILON = epsilon, VELGRID = velgrid +;+ +; NAME: +; LSF_ROTATE: +; +; PURPOSE: +; Create a 1-d convolution kernel to broaden a spectrum from a rotating star +; +; EXPLANATION: +; Can be used to derive the broadening effect (line spread function; LSF) +; due to rotation on a synthetic stellar spectrum. Assumes constant +; limb darkening across the disk. +; +; CALLING SEQUENCE +; lsf = LSF_ROTATE(deltav, vsini, EPSILON=, VELGRID=) +; +; INPUT PARAMETERS: +; deltaV - numeric scalar giving the step increment (in km/s) in the output +; rotation kernel. +; Vsini - the rotational velocity projected along the line of sight (km/s) +; +; OUTPUT PARAMETERS: +; LSF - The convolution kernel vector for the specified rotational velocity. +; The number of points in LSF will be always be odd (the kernel is +; symmetric) and equal to either ceil(2*Vsini/deltav) or +; ceil(2*Vsini/deltav) +1 (whichever number is odd). LSF will +; always be of type FLOAT. +; +; To actually compute the broadening. the spectrum should be convolved +; with the rotational LSF. +; OPTIONAL INPUT PARAMETERS: +; Epsilon - numeric scalar giving the limb-darkening coefficient, +; default = 0.6 which is typical for photospheric lines. The +; specific intensity I at any angle theta from the specific intensity +; Icen at the center of the disk is given by: +; +; I = Icen*(1-epsilon*(1-cos(theta)) +; +; OPTIONAL OUTPUT PARAMETER: +; Velgrid - Vector with the same number of elements as LSF +; EXAMPLE: +; (1) Plot the LSF for a star rotating at 90 km/s in both velocity space and +; for a central wavelength of 4300 A. Compute the LSF every 3 km/s +; +; IDL> lsf = lsf_rotate(3,90,velgrid=vel) ;LSF will contain 61 pts +; IDL> plot,vel,lsf ;Plot the LSF in velocity space +; IDL> wgrid = 4300*(1+vel/3e5) ;Speed of light = 3e5 km/s +; IDL> oplot,wgrid,lsf ;Plot in wavelength space +; +; NOTES: +; Adapted from rotin3.f in the SYNSPEC software of Hubeny & Lanz +; .http://nova.astro.umd.edu/index.html Also see Eq. 17.12 in +; "The Observation and Analysis of Stellar Photospheres" by D. Gray (1992) +; REVISION HISTORY: +; Written, W. Landsman November 2001 +;- + On_error,2 + compile_opt idl2 + if N_params() LT 1 then begin + print,'Syntax - rkernel = lsf_rotate(deltav, vsini)' + print,' Input Keyword: Epsilon' + print,' Output Keyword: Velgrid' + return,-1 + endif + + if N_elements(epsilon) EQ 0 then epsilon = 0.6 + e1 = 2.0d*(1.0d - epsilon) + e2 = !dpi*epsilon/2.0d + e3 = !dpi*(1.0d - epsilon/3.0d) + + npts = ceil(2*vsini/deltav) + if npts mod 2 EQ 0 then npts = npts +1 + nwid = npts/2 + x = (dindgen(npts)- nwid) + x = x*deltav/vsini + if arg_present(velgrid) then velgrid = x*vsini + x1 = abs(1.0d - x^2) + return, float((e1*sqrt(x1) + e2*x1)/e3) + + end diff --git a/modules/idl_downloads/astro/pro/lumdist.pro b/modules/idl_downloads/astro/pro/lumdist.pro new file mode 100644 index 0000000..1711312 --- /dev/null +++ b/modules/idl_downloads/astro/pro/lumdist.pro @@ -0,0 +1,123 @@ +;+ +; NAME: +; LUMDIST +; +; PURPOSE: +; Calculate luminosity distance (in Mpc) of an object given its redshift +; EXPLANATION: +; The luminosity distance in the Friedmann-Robertson-Walker model is +; taken from Caroll, Press, and Turner (1992, ARAA, 30, 499), p. 511 +; Uses a closed form (Mattig equation) to compute the distance when the +; cosmological constant is zero. Otherwise integrates the function using +; QSIMP. +; CALLING SEQUENCE: +; result = lumdist(z, [H0 = , k = , Omega_M =, Lambda0 = , q0 = ,/SILENT]) +; +; INPUTS: +; z = redshift, positive scalar or vector +; +; OPTIONAL KEYWORD INPUTS: +; /SILENT - If set, the program will not display adopted cosmological +; parameters at the terminal. +; H0: Hubble parameter in km/s/Mpc, default is 70 +; +; No more than two of the following four parameters should be +; specified. None of them need be specified -- the adopted defaults +; are given. +; k - curvature constant, normalized to the closure density. Default is +; 0, indicating a flat universe +; Omega_m - Matter density, normalized to the closure density, default +; is 0.3. Must be non-negative +; Lambda0 - Cosmological constant, normalized to the closure density, +; default is 0.7 +; q0 - Deceleration parameter, numeric scalar = -R*(R'')/(R')^2, default +; is -0.55 +; +; OUTPUTS: +; The result of the function is the luminosity distance (in Mpc) for each +; input value of z. +; +; EXAMPLE: +; (1) Plot the distance of a galaxy in Mpc as a function of redshift out +; to z = 5.0, assuming the default cosmology (Omega_m=0.3, Lambda = 0.7, +; H0 = 70 km/s/Mpc) +; +; IDL> z = findgen(50)/10. +; IDL> plot,z,lumdist(z),xtit='z',ytit='Distance (Mpc)' +; +; Now overplot the relation for zero cosmological constant and +; Omega_m=0.3 +; IDL> oplot,z,lumdist(z,lambda=0,omega=0.3),linestyle=1 +; COMMENTS: +; (1) Integrates using the IDL Astronomy Version procedure QSIMP. (The +; intrinsic IDL QSIMP function is not called because of its ridiculous +; restriction that only scalar arguments can be passed to the integrating +; function.) +; (2) Can fail to converge at high redshift for closed universes with +; non-zero lambda. This can presumably be fixed by replacing QSIMP with +; an integrator that can handle a singularity +; PROCEDURES CALLED: +; COSMO_PARAM, QSIMP +; REVISION HISTORY: +; Written W. Landsman Raytheon ITSS April 2000 +; Avoid integer overflow for more than 32767 redshifts July 2001 +; Use double precision J. Moustakas/W. Landsman April 2008 +;- + function ldist, z, q0 = q0, lambda0 = lambda0 + term1 = (1.+z)^2 + term2 = 1.+2.*(q0+lambda0)*z + term3 = z*(2.+z)*lambda0 + denom = (term1*term2 - term3) + out = z*0. + good = where(denom GT 0.0, Ngood) + if Ngood GT 0 then out[good] = 1./sqrt(denom[good]) + return, out + end + + FUNCTION lumdist, z, h0=h0, k = k, Lambda0 = lambda0, Omega_m = Omega_m, $ + q0 = q0, Silent = silent + + compile_opt idl2 + if N_params() eq 0 then begin + print,'Syntax: result = lumdist(z, H0 = ,k=, Lambda0 = ])' + print,'Returns luminosity distance in Mpc' + return, 0. + endif + + n = N_elements(z) + cosmo_param,Omega_m,Lambda0, k, q0 + +; Check keywords + c = 2.99792458D5 ; speed of light in km/s + if N_elements(H0) EQ 0 then H0 = 70 + if not keyword_set(silent) then $ + print,'LUMDIST: H0:', h0, ' Omega_m:', omega_m, ' Lambda0',lambda0, $ + ' q0: ',q0, ' k: ', k, f='(A,I3,A,f5.2,A,f5.2,A,f5.2,A,F5.2)' + +; For the case of Lambda = 0, we use the closed form from equation 5.238 of +; Astrophysical Formulae (Lang 1998). This avoids terms that almost cancel +; at small q0*z better than the more familiar Mattig formula. +; + if lambda0 EQ 0 then begin + denom = sqrt(1+2*q0*z) + 1 + q0*z + dlum = (c*z/h0)*(1 + z*(1-q0)/denom) + return,dlum + +; For non-zero lambda +endif else begin + dlum = z*0.0 + for i=0L,N-1 do begin + if z[i] LE 0.0 then dlum[i] = 0.0 else begin + qsimp,'LDIST',0,z[i], lz,q0 = q0, Lambda0 = lambda0 + dlum[i] = lz + endelse + endfor + + if k GT 0 then $ + dlum = sinh(sqrt(k)*dlum)/sqrt(k) $ + else if k LT 0 then $ + dlum = sin(sqrt(-k)*dlum)/sqrt(-k) > 0 + return, c*(1+z)*dlum/h0 + endelse + + end diff --git a/modules/idl_downloads/astro/pro/mag2flux.pro b/modules/idl_downloads/astro/pro/mag2flux.pro new file mode 100644 index 0000000..030e405 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mag2flux.pro @@ -0,0 +1,51 @@ +function mag2flux, mag, zero_pt, ABwave = ABwave +;+ +; NAME: +; MAG2FLUX +; PURPOSE: +; Convert from magnitudes to flux (ergs/s/cm^2/A). +; EXPLANATION: +; Use FLUX2MAG() for the opposite direction. +; +; CALLING SEQUENCE: +; flux = mag2flux( mag, [ zero_pt, ABwave = ] ) +; +; INPUTS: +; mag - scalar or vector of magnitudes +; +; OPTIONAL INPUT: +; zero_pt - scalar giving the zero point level of the magnitude. +; If not supplied then zero_pt = 21.1 (Code et al. 1976) +; Ignored if the ABwave keyword is set. +; +; OPTIONAL KEYWORD INPUT: +; ABwave - wavelength scalar or vector in Angstroms. If supplied, then +; the input vector, mag, is assumed to contain Oke AB magnitudes +; (Oke & Gunn 1983, ApJ, 266, 713) +; +; OUTPUT: +; flux - scalar or vector flux vector, in erg cm-2 s-1 A-1 +; If the ABwave keyword is set, then the flux is given by +; +; f = 10^(-0.4*(mag +2.406 + 4*alog10(ABwave))) +; +; Otherwise the flux is given by +; f = 10^(-0.4*(mag + zero_pt)) +; +; EXAMPLE: +; Suppose one is given vectors of wavelengths and AB magnitudes, w (in +; Angstroms) and mag. Plot the spectrum in erg cm-2 s-1 A-1 +; +; IDL> plot, w, mag2flux(mag,ABwave = w) +; REVISION HISTORY: +; Written J. Hill STX Co. 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added ABwave keyword, W. Landsman September 1998 +;- + if ( N_params() lt 2 ) then zero_pt = 21.10 + + if keyword_set(ABwave) then $ + return, 10^(-0.4*(mag + 2.406 + 5*alog10(ABwave))) else $ + return, 10^(-0.4*( mag + zero_pt)) + + end diff --git a/modules/idl_downloads/astro/pro/mag2geo.pro b/modules/idl_downloads/astro/pro/mag2geo.pro new file mode 100644 index 0000000..7cada63 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mag2geo.pro @@ -0,0 +1,97 @@ +;+ +; NAME: +; MAG2GEO() +; +; PURPOSE: +; Convert from geomagnetic to geographic coordinates +; +; EXPLANATION: +; +; Converts from GEOMAGNETIC (latitude,longitude) to GEOGRAPHIC (latitude, +; longitude). (altitude remains the same) +; +; CALLING SEQUENCE: +; gcoord=mag2geo(mcoord) +; +; INPUT: +; mcoord = a 2-element array of magnetic [latitude,longitude], or an +; array [2,n] of n such coordinates. +; +; KEYWORD INPUTS: +; None +; +; OUTPUT: +; a 2-element array of geographic [latitude,longitude], or an array [2,n] +; of n such coordinates +; +; COMMON BLOCKS: +; None +; +; EXAMPLES: +; IDL> gcoord=mag2geo([90,0]) ; coordinates of magnetic south pole +; IDL> print,gcoord +; 79.300000 -71.409990 +; +; MODIFICATION HISTORY: +; Written by Pascal Saint-Hilaire (Saint-Hilaire@astro.phys.ethz.ch), +; May 2002 +;- +;==================================================================================== +FUNCTION mag2geo,incoord + + ; SOME 'constants'... + Dlong=288.59D ; longitude (in degrees) of Earth's magnetic south pole + ; (which is near the geographic north pole!) (1995) + Dlat=79.30D ; latitude (in degrees) of same (1995) + R = 1D ; distance from planet center (value unimportant -- + ;just need a length for conversion to rectangular coordinates) + + ; convert first to radians + Dlong=Dlong*!DPI/180. + Dlat=Dlat*!DPI/180. + + mlat=DOUBLE(incoord[0,*])*!DPI/180. + mlon=DOUBLE(incoord[1,*])*!DPI/180. + malt=mlat * 0. + R + + coord=[mlat,mlon,malt] + + ;convert to rectangular coordinates + ; X-axis: defined by the vector going from Earth's center towards + ; the intersection of the equator and Greenwich's meridian. + ; Z-axis: axis of the geographic poles + ; Y-axis: defined by Y=Z^X + x=coord[2,*]*cos(coord[0,*])*cos(coord[1,*]) + y=coord[2,*]*cos(coord[0,*])*sin(coord[1,*]) + z=coord[2,*]*sin(coord[0,*]) + + ;First rotation : in the plane of the current meridian from magnetic + ;pole to geographic pole. + togeolat=dblarr(3,3) + togeolat[0,0]=cos(!DPI/2-Dlat) + togeolat[0,2]=sin(!DPI/2-Dlat) + togeolat[2,0]=-sin(!DPI/2-Dlat) + togeolat[2,2]=cos(!DPI/2-Dlat) + togeolat[1,1]=1. + out= togeolat # [x,y,z] + + ;Second rotation matrix : rotation around plane of the equator, from + ;the meridian containing the magnetic poles to the Greenwich meridian. + maglong2geolong=dblarr(3,3) + maglong2geolong[0,0]=cos(Dlong) + maglong2geolong[0,1]=-sin(Dlong) + maglong2geolong[1,0]=sin(Dlong) + maglong2geolong[1,1]=cos(Dlong) + maglong2geolong[2,2]=1. + out=maglong2geolong # out + + ;convert back to latitude, longitude and altitude + glat=atan(out[2,*],sqrt(out[0,*]^2+out[1,*]^2)) + glat=glat*180./!DPI + glon=atan(out[1,*],out[0,*]) + glon=glon*180./!DPI + ;galt=sqrt(out[0,*]^2+out[1,*]^2+out[2,*]^2)-R ; I don't care about that one...just put it there for completeness' sake + + RETURN,[glat,glon] +END +;==================================================================================== diff --git a/modules/idl_downloads/astro/pro/make_2d.pro b/modules/idl_downloads/astro/pro/make_2d.pro new file mode 100644 index 0000000..0b75a19 --- /dev/null +++ b/modules/idl_downloads/astro/pro/make_2d.pro @@ -0,0 +1,57 @@ +pro make_2d,x,y,xx,yy +;+ +; NAME: +; MAKE_2D +; PURPOSE: +; Change from 1-d indexing to 2-d indexing +; EXPLANATION: +; Convert an N element X vector, and an M element Y vector, into +; N x M arrays giving all possible combination of X and Y pairs. +; Useful for obtaining the X and Y positions of each element of +; a regular grid. +; +; CALLING SEQUENCE: +; MAKE_2D, X, Y, [ XX, YY ] +; +; INPUTS: +; X - N element vector of X positions +; Y - M element vector of Y positions +; +; OUTPUTS: +; XX - N x M element array giving the X position at each pixel +; YY - N x M element array giving the Y position of each pixel +; If only 2 parameters are supplied then X and Y will be +; updated to contain the output arrays +; +; EXAMPLE: +; To obtain the X and Y position of each element of a 30 x 15 array +; +; IDL> x = indgen(30) & y = indgen(15) +; IDL> make_2d, x, y +; REVISION HISTORY: +; Written, Wayne Landsman ST Systems Co. May, 1988 +; Added /NOZERO keyword W. Landsman Mar, 1991 +; Converted to IDL V5.0 W. Landsman September 1997 +; Improved speed P. Broos July 2000 +;- + On_error,2 + if N_params() LT 2 then begin + print,'Syntax - make_2d, x, y, [xx, yy]' + print,' x,y - Input X,Y vectors' + print,' xx,yy - Output arrays specifying X and Y indices' + return + endif + + ny = N_elements(y) + nx = N_elements(x) + + xx = rebin(reform(x, nx, 1,/OVERWRITE), nx, ny, /SAMPLE) + yy = rebin(reform(y, 1, ny,/OVERWRITE), nx, ny, /SAMPLE) + + if N_params() LT 3 then begin ;Update X and Y vectors + x = temporary(xx) + y = temporary(yy) + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/make_astr.pro b/modules/idl_downloads/astro/pro/make_astr.pro new file mode 100644 index 0000000..20177f4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/make_astr.pro @@ -0,0 +1,258 @@ +pro make_astr,astr, CD=cd, DELTA = cdelt, CRPIX = crpix, CRVAL = crval, $ + CTYPE = ctype, LATPOLE = LATPOLE, LONGPOLE = longpole, $ + PV2 = pv2, NAXIS = naxis, AXES = axes, pv1 = pv1, $ + RADECSYS = radecsys, EQUINOX = equinox, $ + DATE_OBS = dateobs, MJD_OBS = mjdobs +;+ +; NAME: +; MAKE_ASTR +; PURPOSE: +; Build an astrometry structure from input parameter values +; EXPLANATION: +; This structure can be subsequently placed in a FITS header with +; PUTAST +; +; CALLING SEQUENCE: +; MAKE_ASTR, astr, CRPIX =, CRVAL =, [CD = , DELT =, CTYPE =, $ +; LATPOLE = , LONGPOLE =, PV2 =, NAXIS =, AXES =, PV1 =, $ +; RADECSYS =, EQUINOX =, DATEOBS =, MJDOBS =] +; +; OUTPUT PARAMETER: +; ASTR - Anonymous structure containing astrometry info. See the +; documentation for EXTAST for descriptions of the individual +; tags +; +; REQUIRED INPUT KEYWORDS +; CRPIX - 2 element vector giving X and Y coordinates of reference pixel +; (def = NAXIS/2). VALUES MUST BE IN FITS CONVENTION (first pixel +; is [1,1]) AND NOT IDL CONVENTION (first pixel is [0,0]). +; CRVAL - 2 element double precision vector giving R.A. and DEC of +; reference pixel in DEGREES +; OPTIONAL INPUT KEYWORDS +; CD - 2 x 2 array containing the astrometry parameters CD1_1 CD1_2 +; in DEGREES/PIXEL CD2_1 CD2_2 +; DELT - 2 element vector giving physical increment at reference pixel +; in DEGREES/PIXEL default = [-1.0D, 1.0D]/3600. (1 arcsec/pixel) +; CTYPE - 2 element string vector giving projection types, default +; ['RA---TAN','DEC--TAN'] +; LATPOLE - Scalar latitude of the north pole, default = +90 +; LONGPOLE - scalar longitude of north pole +; PV2 - Vector of projection parameters associated with latitude axis. +; Not required for some projections (e.g. TAN) and optional for +; others (e.g. SIN). +; Usually a 2 element vector, but may contain up to 21 elements +; for the Zenithal Polynomial (ZPN) projection. Corresponds to +; the keywords PV2_1, PV2_2... Defaults to 0.0 +; +; Added for version 2 astrometry structure: +; AXES - 2 element integer vector giving the FITS-convention axis +; numbers associated with astrometry, in ascending order. +; Default [1,2]. +; NAXIS - 2 element integer vector giving number of pixels on each axis +; PV1 - Vector of projection parameters associated with longitude axis +; Elements 4 & 5 (if present) are equivalent to LONGPOLE & LATPOLE +; and take precedence if both are specified, i.e. LONGPOLE & LATPOLE +; in the structure are forced to agree with PV1. +; RADECSYS - String giving RA/Dec system e.g. 'FK4', 'ICRS' etc. +; EQUINOX - Double giving the epoch of the mean equator and equinox +; DATEOBS - Text string giving (start) date/time of observations +; MJDOBS - Modified julian date of start of observations. +; (specify one or other of DATEOBS or MJDOBS) +; +; NOTES: +; (1) An anonymous structure is created to avoid structure definition +; conflicts. This is needed because some projection systems +; require additional dimensions (i.e. spherical cube +; projections require a specification of the cube face). +; (2) The name of the keyword for the CDELT parameter is DELT because +; the IDL keyword CDELT would conflict with the CD keyword +; (3) The astrometry structure definition was slightly modified in +; July 2003; all angles are now double precision, and the +; LATPOLE tag was added. In April 2007 the CRPIX tag was also +; changed to double precision. +; REVISION HISTORY: +; Written by W. Landsman Mar. 1994 +; Added LATPOLE, all angles double precision W. Landsman July 2003 +; Use PV2 keyword rather than PROJP1, PROJP2 W. Landsman May 2004 +; Make .CRPIX tag double precision, change CDELT default to 1"/pixel +; W. Landsman April 2007 +; Default plate scale is now 1"/pixel (not 1 deg/pix) WL Oct. 2010 +; Oct 2010 change should only apply when CD matrix not given +; M. Cushing/W.L. Aug 2011 +; added v2 parameters; more filling out of defaults; default +; LATPOLE changed to 90 (FITS standard) J. P. Leahy Jul 2013 +;- + On_error, 0 + compile_opt idl2 + + if ( N_params() LT 1 ) then begin + print,'Syntax - MAKE_ASTR, astr, CRPIX =, CRVAL =, [CD = , DELT =, ' + print,' CTYPE =, LATPOLE= , LONGPOLE =, PV2=, NAXIS =, AXES=,' + print,' PV1=, RADECSYS= , EQUINOX=, DATEOBS=, MJDOBS= ]' + return + endif + +; +; List of known map types copied from wcsxy2sph. Needs to be kept up +; to date! +; + map_types=['DEF','AZP','TAN','SIN','STG','ARC','ZPN','ZEA','AIR','CYP',$ + 'CAR','MER','CEA','COP','COD','COE','COO','BON','PCO','SFL',$ + 'PAR','AIT','MOL','CSC','QSC','TSC','SZP','HPX','HCT','XPH'] + +; If neither CD nor CDELT keywords present then assume 1"/pixel +; If CD supplied but not CDELT then set CDELT = [1.0,1.0] + + if N_elements( cd ) EQ 0 then begin + cd = [ [1.,0.], [0.,1.] ] + if N_elements( cdelt) EQ 0 then cdelt = [-1.0D, 1.0D]/3600.0d + endif else if N_elements( cdelt) EQ 0 then cdelt = [1.0D, 1.0D] + + if N_elements( crpix) EQ 0 then message, $ + 'ERROR - CRPIX is a required keyword for a new astrometry structure' + + if N_elements( crval) EQ 0 then message, $ + 'ERROR - CRVAL is a required keyword for a new astrometry structure' + + if N_elements( ctype) EQ 0 then ctype = ['RA---TAN','DEC--TAN'] + + N_pv2 = N_elements(pv2) + IF N_pv2 EQ 0 then pv2 = 0.0D + + if N_elements(axes) EQ 0 then axes = [1,2] + + ; Search astrometric axes: + lon0 = WHERE(STRMID(ctype,0,5) EQ 'RA---') + lon1 = WHERE(STRMID(ctype,1,4) EQ 'LON-') + lon2 = WHERE(STRMID(ctype,2,4) EQ 'LN-') + lon = [lon0, lon1, lon2] + form = [REPLICATE(0,N_ELEMENTS(lon0)),REPLICATE(1,N_ELEMENTS(lon1)), $ + REPLICATE(2,N_ELEMENTS(lon2))] + good = WHERE(lon GE 0, ngood) + IF ngood GT 1 THEN MESSAGE, 'Both axis types are longitude!' + lon = ngood EQ 1 ? lon[good] : -1 + lon_form = ngood EQ 1 ? form[good] : -1 + + lat0 = WHERE(STRMID(ctype,0,5) EQ 'DEC--') + lat1 = WHERE(STRMID(ctype,1,4) EQ 'LAT-') + lat2 = WHERE(STRMID(ctype,2,4) EQ 'LT-') + lat = [lat0, lat1, lat2] + form = [REPLICATE(0,N_ELEMENTS(lat0)),REPLICATE(1,N_ELEMENTS(lat1)), $ + REPLICATE(2,N_ELEMENTS(lat2))] + good = WHERE(lat GE 0, ngood) + IF ngood GT 1 THEN MESSAGE, 'Both axis types are latitude" + lat = ngood EQ 1 ? lat[good] : -1 + lat_form = ngood EQ 1 ? form[good] : -1 + + badco = lon_form NE lat_form + CASE lon_form OF + -1: coord = 'X' ; unknown type of coordinate + 0: coord = 'C' ; celestial coords, i.e. RA/Dec + 1: BEGIN ; longitude format is xLON where x = G, E, etc. + coord = STRMID(ctype[0],0,1) + badco = badco || coord NE STRMID(ctype[1],0,1) + END + 2: BEGIN ; longitude format is yzLN + coord = STRMID(ctype[0],0,2) + badco = badco || coord NE STRMID(ctype[2],0,2) + END + ELSE: MESSAGE, 'Internal error: unexpected lon_form' + ENDCASE + + flip = lat[0] LT lon[0] + + proj = STRMID(ctype[0], 5, 3) + badco = badco || proj NE STRMID(ctype[1], 5, 3) + IF badco THEN MESSAGE, 'ERROR: longitude and latitude coordinate types must match:' + + test = WHERE(proj EQ map_types) + known = test GE 0 + + npv1 = N_ELEMENTS(pv1) + IF npv1 EQ 5 THEN latpole = pv1[4] + IF npv1 GE 4 THEN longpole = pv1[3] + IF npv1 GE 3 THEN theta0 = pv1[2] + IF npv1 GE 2 THEN phi0 = pv1[1] ELSE phi0 = 0 + IF npv1 GE 2 THEN xyoff = pv1[0] NE 0 ELSE xyoff = 0 + + IF N_ELEMENTS(latpole) EQ 0 THEN latpole = 90 + + conic = (proj EQ 'COP') || (proj EQ 'COE') || (proj EQ 'COD') || $ + (proj EQ 'COO') + + IF conic THEN BEGIN + IF N_pv2 EQ 0 THEN message, $ + 'ERROR -- Specify PV2 for conic projections' + theta_a = pv2[0] + ENDIF ELSE BEGIN ; Is it a zenithal projection? + if (proj EQ 'AZP') || (proj EQ 'SZP') || (proj EQ 'TAN') || $ + (proj EQ 'STG') || (proj EQ 'SIN') || (proj EQ 'ARC') || $ + (proj EQ 'ZPN') || (proj EQ 'ZEA') || (proj EQ 'AIR') || $ + (proj EQ 'XPH') then begin + theta_a = 90d0 + endif else theta_a = 0d0 + ENDELSE + + IF N_ELEMENTS(theta0) EQ 0 THEN theta0 = theta_a + + IF N_ELEMENTS(longpole) EQ 0 THEN BEGIN + if crval[1] GE theta0 then longpole = 0d0 else longpole = 180d0 + longpole += phi0 + ENDIF + + pv1 = [xyoff, phi0, theta0, longpole, latpole] + + x0y0 = [0d0, 0d0] + IF xyoff && (phi0 NE 0d0 || theta0 NE theta_a) THEN BEGIN + ; calculate IWC offsets x_0, y_0 + WCSSPH2XY, phi0, theta0, x0, y0, CTYPE = ctype, PV2 = pv2 + x0y0 = [x0, y0] + ENDIF + + N_rdsys = N_ELEMENTS(radecsys) + IF N_rdsys EQ 0 THEN radecsys = '' ELSE $ + radecsys = STRUPCASE(STRTRIM(radecsys,2)) + N_mjd = N_ELEMENTS(mjdobs) + IF N_mjd EQ 0 THEN mjdobs = !values.D_NAN + N_date = N_ELEMENTS(dateobs) + IF N_date EQ 0 THEN dateobs = 'UNKNOWN' ELSE $ + dateobs = STRUPCASE(STRTRIM(dateobs,2)) + + IF N_mjd GT 0 && N_date EQ 0 THEN dateobs = date_conv(mjdobs+2400000.5d0,'FITS') + IF N_date GT 0 THEN BEGIN + dateobs = date_conv(dateobs,'FITS', BAD_DATE=bad_date) ; try to convert to standard format + IF ~bad_date THEN BEGIN + mjdtest = date_conv(dateobs,'MODIFIED') + IF N_mjd EQ 0 THEN mjdobs = mjdtest ELSE $ + IF ABS(mjdtest - mjdobs) GT 1 THEN MESSAGE, $ + 'DATE-OBS and MJD-OBS are inconsistent' + ENDIF ELSE dateobs = 'UNKNOWN' + ENDIF + + N_Eq = N_ELEMENTS(equinox) + IF N_Eq EQ 0 THEN equinox = !values.D_NAN + IF (coord EQ 'C' || coord EQ 'E' || coord EQ 'H') THEN BEGIN + IF N_rdsys EQ 0 THEN BEGIN + IF N_eq EQ 0 THEN radecsys = 'ICRS' $ + ELSE radecsys = equinox GE 1984d0 ? 'FK5' : 'FK4' + ENDIF ELSE IF N_eq EQ 0 THEN CASE STRMID(radecsys,0,3) OF + 'FK4': equinox = 1950d0 + 'FK5': equinox = 2000d0 + 'ICR': equinox = 2000d0 + ELSE: equinox = 0d0 + ENDCASE + ENDIF + + IF N_ELEMENTS(naxis) NE 2 THEN naxis = [0,0] + + ASTR = {NAXIS:naxis, CD: cd, CDELT: cdelt, CRPIX: crpix, CRVAL: crval, $ + CTYPE: string(ctype), $ + LONGPOLE: double( longpole[0]), LATPOLE: double(latpole[0]), $ + PV2: pv2, PV1: pv1, $ + AXES: axes, REVERSE: flip, $ + COORD_SYS: coord, PROJECTION: proj, KNOWN: known, $ + RADECSYS: radecsys, EQUINOX: DOUBLE(equinox), $ + DATEOBS: dateobs, MJDOBS: DOUBLE(mjdobs), X0Y0: x0y0} + + return + end diff --git a/modules/idl_downloads/astro/pro/match.pro b/modules/idl_downloads/astro/pro/match.pro new file mode 100644 index 0000000..af66c90 --- /dev/null +++ b/modules/idl_downloads/astro/pro/match.pro @@ -0,0 +1,170 @@ +pro match, a, b, suba, subb, COUNT = count, SORT = sort, epsilon=epsilon +;+ +; NAME: +; MATCH +; PURPOSE: +; Routine to match values in two vectors. +; +; CALLING SEQUENCE: +; match, a, b, suba, subb, [ COUNT =, /SORT, EPSILON = ] +; +; INPUTS: +; a,b - two vectors to match elements, numeric or string data types +; +; OUTPUTS: +; suba - subscripts of elements in vector a with a match +; in vector b +; subb - subscripts of the positions of the elements in +; vector b with matchs in vector a. +; +; suba and subb are ordered such that a[suba] equals b[subb] +; +; OPTIONAL INPUT KEYWORD: +; /SORT - By default, MATCH uses two different algorithm: (1) the +; /REVERSE_INDICES keyword to HISTOGRAM is used for integer data, +; while (2) a sorting algorithm is used for non-integer data. The +; histogram algorithm is usually faster, except when the input +; vectors are sparse and contain very large numbers, possibly +; causing memory problems. Use the /SORT keyword to always use +; the sort algorithm. +; epsilon - if values are within epsilon, they are considered equal. Used only +; only for non-integer matching. Note that input vectors should +; be unique to within epsilon to provide one-to-one mapping.. +; Default=0. +; +; OPTIONAL KEYWORD OUTPUT: +; COUNT - set to the number of matches, integer scalar +; +; SIDE EFFECTS: +; The obsolete system variable !ERR is set to the number of matches; +; however, the use !ERR is deprecated in favor of the COUNT keyword +; +; RESTRICTIONS: +; The vectors a and b should not have duplicate values within them. +; You can use rem_dup function to remove duplicate values +; in a vector +; +; EXAMPLE: +; If a = [3,5,7,9,11] & b = [5,6,7,8,9,10] +; then +; IDL> match, a, b, suba, subb, COUNT = count +; +; will give suba = [1,2,3], subb = [0,2,4], COUNT = 3 +; and a[suba] = b[subb] = [5,7,9] +; +; +; METHOD: +; For non-integer data types, the two input vectors are combined and +; sorted and the consecutive equal elements are identified. For integer +; data types, the /REVERSE_INDICES keyword to HISTOGRAM of each array +; is used to identify where the two arrays have elements in common. +; HISTORY: +; D. Lindler Mar. 1986. +; Fixed "indgen" call for very large arrays W. Landsman Sep 1991 +; Added COUNT keyword W. Landsman Sep. 1992 +; Fixed case where single element array supplied W. Landsman Aug 95 +; Use a HISTOGRAM algorithm for integer vector inputs for improved +; performance W. Landsman March 2000 +; Work again for strings W. Landsman April 2000 +; Use size(/type) W. Landsman December 2002 +; Work for scalar integer input W. Landsman June 2003 +; Assume since V5.4, use COMPLEMENT to WHERE() W. Landsman Apr 2006 +; Added epsilon keyword Kim Tolbert March 14, 2008 +;- +;------------------------------------------------------------------------- + On_error,2 + compile_opt idl2 + + if N_elements(epsilon) EQ 0 then epsilon = 0 + + if N_params() LT 3 then begin + print,'Syntax - match, a, b, suba, subb, [ COUNT =, EPSILON=, /SORT]' + print,' a,b -- input vectors for which to match elements' + print,' suba,subb -- output subscript vectors of matched elements' + return + endif + + da = size(a,/type) & db =size(b,/type) + if keyword_set(sort) then hist = 0b else $ + hist = (( da LE 3 ) || (da GE 12)) && ((db LE 3) || (db GE 12 )) + + if ~hist then begin ;Non-integer calculation + + na = N_elements(a) ;number of elements in a + nb = N_elements(b) ;number of elements in b + +; Check for a single element array + + if (na EQ 1) || (nb EQ 1) then begin + if (nb GT 1) then begin + subb = where(b EQ a[0], nw) + if (nw GT 0) then suba = replicate(0,nw) else suba = [-1] + endif else begin + suba = where(a EQ b[0], nw) + if (nw GT 0) then subb = replicate(0,nw) else subb = [-1] + endelse + count = nw + return + endif + + c = [ a, b ] ;combined list of a and b + ind = [ lindgen(na), lindgen(nb) ] ;combined list of indices + vec = [ bytarr(na), replicate(1b,nb) ] ;flag of which vector in combined + ;list 0 - a 1 - b + +; sort combined list + + sub = sort(c) + c = c[sub] + ind = ind[sub] + vec = vec[sub] + +; find duplicates in sorted combined list + + n = na + nb ;total elements in c + if epsilon eq 0. then $ + firstdup = where( (c EQ shift(c,-1)) and (vec NE shift(vec,-1)), Count ) $ + else $ + firstdup = where( (abs(c - shift(c,-1)) lt epsilon) and (vec NE shift(vec,-1)), Count ) + + if Count EQ 0 then begin ;any found? + suba = lonarr(1)-1 + subb = lonarr(1)-1 + return + end + + dup = lonarr( Count*2 ) ;both duplicate values + even = lindgen( N_elements(firstdup))*2 ;Changed to LINDGEN 6-Sep-1991 + dup[even] = firstdup + dup[even+1] = firstdup+1 + ind = ind[dup] ;indices of duplicates + vec = vec[dup] ;vector id of duplicates + subb = ind[ where( vec, complement = vzero) ] ;b subscripts + suba = ind[ vzero] + + endif else begin ;Integer calculation using histogram. + + minab = min(a, MAX=maxa) > min(b, MAX=maxb) ;Only need intersection of ranges + maxab = maxa < maxb + +;If either set is empty, or their ranges don't intersect: +; result = NULL (which is denoted by integer = -1) + !ERR = -1 + suba = -1 + subb = -1 + COUNT = 0L + if (maxab lt minab) || (maxab lt 0) then return + + ha = histogram([a], MIN=minab, MAX=maxab, reverse_indices=reva) + hb = histogram([b], MIN=minab, MAX=maxab, reverse_indices=revb) + + r = where((ha ne 0) and (hb ne 0), count) + if count gt 0 then begin + suba = reva[reva[r]] + subb = revb[revb[r]] + endif + endelse + + return + + end diff --git a/modules/idl_downloads/astro/pro/match2.pro b/modules/idl_downloads/astro/pro/match2.pro new file mode 100644 index 0000000..16b33ce --- /dev/null +++ b/modules/idl_downloads/astro/pro/match2.pro @@ -0,0 +1,169 @@ +;+ +; NAME: +; MATCH2 +; PURPOSE: +; Routine to cross-match values in two vectors (including non-matches) +; EXPLANATION: +; MATCH2 reports matching elements of two arrays. + +; This procedure *appears* similar to MATCH of the IDL astronomy +; library. However, this routine is quite different in that it +; reports an index value for each element of the input arrays. +; In other words, while MATCH reports the *existence* of +; matching elements in each array, MATCH2 reports explicitly +; *which* elements match. +; +; Furthermore, while MATCH reports only unique matching +; elements, MATCH2 will always report a cross-match for every +; element in each array, even if it is a repeat. +; +; In cases where no match was found, an index of -1 is +; reported. +; +; CALLING SEQUENCE: +; match2, a, b, suba, subb +; +; INPUTS: +; a,b - two vectors to match elements, numeric or string data +; types. (See below for RESTRICTIONS on A and B) +; +; +; OUTPUTS: +; suba - vector with same number of elements as A, such that +; A EQ B[SUBA], except non-matches which are indicated +; by SUBA EQ -1 +; subb - vector with same number of elements as B, such that +; B EQ A[SUBB], except non-matches which are indicated +; by SUBB EQ -1 +; +; +; RESTRICTIONS: +; +; The vectors A and B are allowed to have duplicates in them, +; but for matching purposes, only the first one found will +; be reported. +; +; If A and B are string arrays, then non-printable ASCII values +; 1B and 2B will confuse the algorithm. Don't use these +; non-printable characters in strings. +; +; EXAMPLE: +; A = [0,7,14,23,24,30] +; B = [7,8,14,25,14] +; IDL> match2, a, b, suba, subb +; --> suba = [ -1 , 0, 4, -1, -1, -1 ] +; (indicates that A[1] matches B[1] and A[3] matches B[2]) +; --> subb = [ 1 , -1, 2, -1, 2 ] +; (indicates that B[1] matches A[1] and B[2] matches A[3]) +; +; Compare to the results of the original MATCH procedure, +; +; IDL> match, a, b, suba, subb +; --> suba = [ 1, 3] +; (indicates that A[1] and A[3] match elements in B, but not which ones) +; --> subb = [ 1, 2] +; (indicates that B[1] and B[2] match elements in A, but not which ones) +; +; MODIFICATION HISTORY +; Derived from the IDL Astronomy Library MATCH, 14 Feb 2007 +; Updated documentation, 17 Jul 2007 +; More updated documentation (example), 03 Sep 2007 +; Bug fix for string arrays with numerical contents; the subset +; string is now 1B and 2B; this is now documented, 2014-10-20 CM +; +; +;- +;------------------------------------------------------------------------- +pro match2, a, b, suba, subb + + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - match2, a, b, suba, subb' + print,' a,b -- input vectors for which to match elements' + print,' suba,subb -- match index lists' + return + endif + + da = size(a,/type) & db =size(b,/type) + + na = N_elements(a) ;number of elements in a + nb = N_elements(b) ;number of elements in b + suba = lonarr(na)-1 & subb = lonarr(nb)-1 + +; Check for a single element array + + if (na EQ 1) or (nb EQ 1) then begin + if (nb GT 1) then begin + wh = where(b EQ a[0], nw) + if nw GT 0 then begin + subb[wh] = 0L + suba[0] = wh[0] + endif + endif else begin + wh = where(a EQ b[0], nw) + if nw GT 0 then begin + suba[wh] = 0L + subb[0] = wh[0] + endif + endelse + return + endif + + c = [ a, b ] ;combined list of a and b + ind = [ lindgen(na), lindgen(nb) ] ;combined list of indices + vec = [ intarr(na), replicate(1,nb) ] ;flag of which vector in combined + ;list 0 - a 1 - b + +; sort combined list + + if da EQ 7 OR db EQ 7 then begin + vecstr = [string(1b), string(2b)] + ;; String sort (w/ double key) + sub = sort(c+vecstr[vec]) + endif else begin + ;; Number sort (w/ double key) + eps = (machar(/double)).eps + sub = sort(double(c)*(1d + vec*eps)) + endelse + + c = c[sub] + ind = ind[sub] + vec = vec[sub] + + n = na + nb ;total elements in c + wh = where( c[1:*] NE c, ct) + if ct EQ 0 then begin + whfirst = [0] + whlast = [n-1] + endif else begin + whfirst = [0, wh+1] + whlast = [wh, n-1] + endelse + + vec0 = vec[whfirst] + vec1 = vec[whlast] + ;; 0 = present in A but not B + ;; 1 = can't occur (since the array was sorted on 'VEC') + ;; 2 = present in both + ;; 3 = present in B but not A + matchtype = vec0 + vec1*2 + + nm = n_elements(matchtype) + mm = ind*0L & wa = mm & wb = mm + for i = 0, nm-1 do begin + mm[whfirst[i]:whlast[i]] = matchtype[i] + wa[whfirst[i]:whlast[i]] = ind[whfirst[i]] + wb[whfirst[i]:whlast[i]] = ind[whlast[i]] + endfor + + suba = lonarr(na)-1 & subb = lonarr(nb)-1 + + wh = where(mm EQ 2 AND vec EQ 0, ct) + if ct GT 0 then suba[ind[wh]] = wb[wh] + wh = where(mm EQ 2 AND vec EQ 1, ct) + if ct GT 0 then subb[ind[wh]] = wa[wh] + + return +end diff --git a/modules/idl_downloads/astro/pro/max_entropy.pro b/modules/idl_downloads/astro/pro/max_entropy.pro new file mode 100644 index 0000000..4c99ea3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/max_entropy.pro @@ -0,0 +1,79 @@ +;+ +; NAME: +; MAX_ENTROPY +; +; PURPOSE: +; Deconvolution of data by Maximum Entropy analysis, given the PSF +; EXPLANATION: +; Deconvolution of data by Maximum Entropy analysis, given the +; instrument point spread response function (spatially invariant psf). +; Data can be an observed image or spectrum, result is always positive. +; Default is convolutions using FFT (faster when image size = power of 2). +; +; CALLING SEQUENCE: +; for i=1,Niter do begin +; Max_Entropy, image_data, psf, image_deconv, multipliers, FT_PSF=psf_ft +; +; INPUTS: +; data = observed image or spectrum, should be mostly positive, +; with mean sky (background) near zero. +; psf = Point Spread Function of instrument (response to point source, +; must sum to unity). +; deconv = result of previous call to Max_Entropy, +; multipliers = the Lagrange multipliers of max.entropy theory +; (on first call, set = 0, giving flat first result). +; +; OUTPUTS: +; deconv = deconvolution result of one more iteration by Max_Entropy. +; multipliers = the Lagrange multipliers saved for next iteration. +; +; OPTIONAL INPUT KEYWORDS: +; FT_PSF = passes (out/in) the Fourier transform of the PSF, +; so that it can be reused for the next time procedure is called, +; /NO_FT overrides the use of FFT, using the IDL function convol() instead. +; /LINEAR switches to Linear convergence mode, much slower than the +; default Logarithmic convergence mode. +; LOGMIN = minimum value constraint for taking Logarithms (default=1.e-9). +; EXTERNAL CALLS: +; function convolve( image, psf ) for convolutions using FFT or otherwise. +; METHOD: +; Iteration with PSF to maximize entropy of solution image with +; constraint that the solution convolved with PSF fits data image. +; Based on paper by Hollis, Dorband, Yusef-Zadeh, Ap.J. Feb.1992, +; which refers to Agmon, Alhassid, Levine, J.Comp.Phys. 1979. +; +; A more elaborate image deconvolution program using maximum entropy is +; available at +; http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/image/image_deconvolve.pro +; HISTORY: +; written by Frank Varosi at NASA/GSFC, 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + +pro max_entropy, data, psf, deconv, multipliers, FT_PSF=psf_ft, NO_FT=noft, $ + LINEAR=Linear, LOGMIN=Logmin, RE_CONVOL_IMAGE=Re_conv + + if N_elements( multipliers ) LE 1 then begin + multipliers = data + multipliers[*] = 0 + endif + + deconv = exp( convolve( multipliers, psf, FT_PSF=psf_ft, $ + /CORREL, NO_FT=noft ) ) + totd = total( data ) + deconv = deconv * ( totd/total( deconv ) ) + + Re_conv = convolve( deconv, psf, FT_PSF=psf_ft, NO_FT=noft ) + scale = total( Re_conv )/totd + + if keyword_set( Linear ) then begin + + multipliers = multipliers + (data * scale - Re_conv) + + endif else begin + + if N_elements( Logmin ) NE 1 then Logmin=1.e-9 + multipliers = multipliers + $ + aLog( ( ( data * scale )>Logmin ) / (Re_conv>Logmin) ) + endelse +end diff --git a/modules/idl_downloads/astro/pro/max_likelihood.pro b/modules/idl_downloads/astro/pro/max_likelihood.pro new file mode 100644 index 0000000..11e8280 --- /dev/null +++ b/modules/idl_downloads/astro/pro/max_likelihood.pro @@ -0,0 +1,93 @@ +;+ +; NAME: +; MAX_LIKELIHOOD +; +; PURPOSE: +; Maximum likelihood deconvolution of an image or a spectrum. +; EXPLANATION: +; Deconvolution of an observed image (or spectrum) given the +; instrument point spread response function (spatially invariant psf). +; Performs iteration based on the Maximum Likelihood solution for +; the restoration of a blurred image (or spectrum) with additive noise. +; Maximum Likelihood formulation can assume Poisson noise statistics +; or Gaussian additive noise, yielding two types of iteration. +; +; CALLING SEQUENCE: +; for i=1,Niter do Max_Likelihood, data, psf, deconv, FT_PSF=psf_ft +; +; INPUTS PARAMETERS: +; data = observed image or spectrum, should be mostly positive, +; with mean sky (background) near zero. +; psf = Point Spread Function of the observing instrument, +; (response to a point source, must sum to unity). +; INPUT/OUTPUT PARAMETERS: +; deconv = as input: the result of previous call to Max_Likelihood, +; (initial guess on first call, default = average of data), +; as output: result of one more iteration by Max_Likelihood. +; Re_conv = (optional) the current deconv image reconvolved with PSF +; for use in next iteration and to check convergence. +; +; OPTIONAL INPUT KEYWORDS: +; /GAUSSIAN causes max-likelihood iteration for Gaussian additive noise +; to be used, otherwise the default is Poisson statistics. +; FT_PSF = passes (out/in) the Fourier transform of the PSF, +; so that it can be reused for the next time procedure is called, +; /NO_FT overrides the use of FFT, using the IDL function convol() instead. +; POSITIVITY_EPS = value of epsilon passed to function positivity, +; default = -1 which means no action (identity). +; UNDERFLOW_ZERO = cutoff to consider as zero, if numbers less than this. +; +; EXTERNAL CALLS: +; function convolve( image, psf ) for convolutions using FFT or otherwise. +; function positivity( image, EPS= ) to make image positive. +; +; METHOD: +; Maximum Likelihood solution is a fixed point of an iterative eq. +; (derived by setting partial derivatives of Log(Likelihood) to zero). +; Poisson noise case was derived by Richardson(1972) & Lucy(1974). +; Gaussian noise case is similar with subtraction instead of division. +; NOTES: +; WARNING: The Poisson case may not conserve flux for an odd image size. +; This behavior is being investigated. +; HISTORY: +; written: Frank Varosi at NASA/GSFC, 1992. +; F.V. 1993, added optional arg. Re_conv (to avoid doing it twice). +; Converted to IDL V5.0 W. Landsman September 1997 +; Use COMPLEMENT keyword to WHERE() W. Landsman Jan 2008 +;- + +pro Max_Likelihood, data, psf, deconv, Re_conv, FT_PSF=psf_ft, NO_FT=noft, $ + GAUSSIAN=gaussian, $ + POSITIVITY_EPS=epsilon, $ + UNDERFLOW_ZERO=under + compile_opt idl2 + if N_elements( deconv ) NE N_elements( data ) then begin + deconv = data + deconv[*] = total( data )/N_elements( data ) + Re_conv = 0 + endif + + if N_elements( under ) NE 1 then under = 1.e-22 + if N_elements( epsilon ) NE 1 then epsilon = -1 + if N_elements( Re_conv ) NE N_elements( deconv ) then $ + Re_conv = convolve( positivity( deconv, EPS=epsilon ), psf, $ + FT_PSF=psf_ft, NO_FT=noft ) + if keyword_set( gaussian ) then begin + + deconv = deconv + convolve( data - Re_conv, psf, /CORREL, $ + FT_PSF=psf_ft, NO_FT=noft ) + endif else begin + wp = where( Re_conv GT under, npos, $ + ncomplement=nneg,complement=wz) + + if (npos GT 0) then Re_conv[wp] = ( data[wp]/Re_conv[wp] ) > 0 + if (nneg GT 0) then Re_conv[wz] = 1. + deconv = deconv * convolve( Re_conv, psf, FT_PSF=psf_ft, $ + /CORREL, NO_FT=noft ) + endelse + + if N_params() GE 4 then $ + Re_conv = convolve( positivity( deconv, EPS=epsilon ), psf, $ + FT_PSF = psf_ft, NO_FT = noft ) + + end diff --git a/modules/idl_downloads/astro/pro/meanclip.pro b/modules/idl_downloads/astro/pro/meanclip.pro new file mode 100644 index 0000000..995011c --- /dev/null +++ b/modules/idl_downloads/astro/pro/meanclip.pro @@ -0,0 +1,86 @@ +PRO MEANCLIP, Image, Mean, Sigma, CLIPSIG=clipsig, MAXITER=maxiter, $ + CONVERGE_NUM=converge_num, VERBOSE=verbose, SUBS=subs,DOUBLE=double +;+ +; NAME: +; MEANCLIP +; +; PURPOSE: +; Computes an iteratively sigma-clipped mean on a data set +; EXPLANATION: +; Clipping is done about median, but mean is returned. +; Called by SKYADJ_CUBE +; +; CATEGORY: +; Statistics +; +; CALLING SEQUENCE: +; MEANCLIP, Data, Mean, [ Sigma, SUBS = +; CLIPSIG=, MAXITER=, CONVERGE_NUM=, /VERBOSE, /DOUBLE ] +; +; INPUT POSITIONAL PARAMETERS: +; Data: Input data, any numeric array +; +; OUTPUT POSITIONAL PARAMETERS: +; Mean: N-sigma clipped mean. +; Sigma: Standard deviation of remaining pixels. +; +; INPUT KEYWORD PARAMETERS: +; CLIPSIG: Number of sigma at which to clip. Default=3 +; MAXITER: Ceiling on number of clipping iterations. Default=5 +; CONVERGE_NUM: If the proportion of rejected pixels is less +; than this fraction, the iterations stop. Default=0.02, i.e., +; iteration stops if fewer than 2% of pixels excluded. +; /VERBOSE: Set this flag to get messages. +; /DOUBLE - if set then perform all computations in double precision. +; Otherwise double precision is used only if the input +; data is double +; OUTPUT KEYWORD PARAMETER: +; SUBS: Subscript array for pixels finally used. +; +; +; MODIFICATION HISTORY: +; Written by: RSH, RITSS, 21 Oct 98 +; 20 Jan 99 - Added SUBS, fixed misplaced paren on float call, +; improved doc. RSH +; Nov 2005 Added /DOUBLE keyword, check if all pixels are removed +; by clipping W. Landsman +;- + +IF N_params() LT 1 THEN BEGIN + print, 'CALLING SEQUENCE: MEANCLIP, Image, Mean, Sigma' + print, 'KEYWORD PARAMETERS: CLIPSIG[=3], MAXITER[=5], CONVERGE_NUM[=0.02], ' $ + + '/VERBOSE, SUBS, /DOUBLE' + RETURN +ENDIF + +prf = 'MEANCLIP: ' + +verbose = keyword_set(verbose) +IF n_elements(maxiter) LT 1 THEN maxiter = 5 +IF n_elements(clipsig) LT 1 THEN clipsig = 3 +IF n_elements(converge_num) LT 1 THEN converge_num = 0.02 + +subs = where(finite(image),ct) +iter=0 +REPEAT BEGIN + skpix = image[subs] + iter = iter + 1 + lastct = ct + medval = median(skpix) + mom = moment(skpix,max=2,double=double) + sig = sqrt(mom[1]) + wsm = where(abs(skpix-medval) LT clipsig*sig,ct) + IF ct GT 0 THEN subs = subs[wsm] +ENDREP UNTIL (float(abs(ct-lastct))/lastct LE converge_num) $ + OR (iter GT maxiter) or (ct EQ 0) +mom = moment(image[subs],double=double,max=2) +mean = mom[0] +sigma = sqrt(mom[1]) +IF verbose THEN BEGIN + print, prf+strn(clipsig)+'-sigma clipped mean' + print, prf+'Mean computed in ',iter,' iterations' + print, prf+'Mean = ',mean,', sigma = ',sigma +ENDIF + +RETURN +END diff --git a/modules/idl_downloads/astro/pro/medarr.pro b/modules/idl_downloads/astro/pro/medarr.pro new file mode 100644 index 0000000..a3f0b7b --- /dev/null +++ b/modules/idl_downloads/astro/pro/medarr.pro @@ -0,0 +1,132 @@ +PRO medarr, inarr, outarr, mask, output_mask +;+ +; NAME: +; MEDARR +; PURPOSE: +; Compute the median at each pixel across a set of 2-d images +; EXPLANATION: +; Each pixel in the output array contains the median of the +; corresponding pixels in the input arrays. Useful, for example to +; combine a stack of CCD images, while removing cosmic ray hits. +; +; This routine has been mostly obsolete since V5.6 with the introduction +; of the DIMENSION keyword to the intrinsic MEDIAN() function. However, +; it is still useful for integer images if bad pixels need to be flagged +; in a mask parameter. (For floating point images, it is much +; faster to set invalid pixels to NaN values.) +; CALLING SEQUENCE: +; MEDARR, inarr, outarr, [ mask, output_mask ] +; INPUTS: +; inarr -- A three dimensional array [Nx,Ny, N] containing the input +; images. Each image is size Nx by Ny, and there are N +; images. +; +; OPTIONAL INPUT: +; mask -- Same structure as inarr, byte array with 1b where +; pixels are to be included, 0b where they are to be +; excluded. For floating point images, it is much faster to +; set masked pixels in inarr equal to !VALUES.F_NAN (see below), +; rather than use the mask parameter. +; +; OUTPUTS: +; outarr -- The output array. It will have dimensions equal to the +; first two dimensions of the input array. +; +; OPTIONAL OUPUT: +; output_mask -- Same structure as outarr, byte array with 1b where +; pixels are valid, 0b where all the input pixels +; have been masked out. +; RESTRICTIONS: +; This procedure is *SLOW* when using the Mask parameter because it has +; to loop over each pixel of the image. +; +; EXAMPLE: +; Suppose one wants to combine three floating point 1024 x 1024 bias +; frames which have been read into the IDL variables im1,im2,im3 +; +; IDL> bigim = fltarr(1024,1024,3) ;Create big array to hold images +; IDL> bigim[0,0,0] = im1 & bigim[0,0,1] = im2 & bigim[0,0,2] = im2 +; IDL> medarr, bigim, avgbias +; +; The variable avgbias will be the desired 1024x 1024 float image. +; PROCEDURE: +; If the MASK parameter is not set, then MEDARR is just a wrapper for +; MEDIAN(/EVEN, dimension = 3). If the MASK parameter is set, +; a scalar median function over the third dimension is looped over +; each pixel of the first two dimensions. The /EVEN keyword is used +; with MEDIAN (which averages the two middle values), since this avoids +; biasing the output for an even number of images. +; +; Any values set to NAN (not a number) are ignored when computing the +; median. If all values for a pixel location are NAN, then the median +; is also returned as NAN. +; +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 12 June 1990. +; Don't use MEDIAN function for even number of images. +; W. Landsman Sep 1996 +; Mask added. RS Hill, HSTX, 13 Mar. 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use /EVEN keyword to MEDIAN W. Landsman September 1997 +; Rearranged code for faster execution W. Landsman January 1998 +; Faster execution for odd number of images W. Landsman July 2000 +; V5.4 fix for change in SIZE() definition of undefined variable +; W. Landsman/E. Young May 2001 +; Use MEDIAN(/DIMEN) for V5.6 or later W. Landsman November 2002 +; Use keyword_set() instead of ARG_present() to test for presence of mask +; parameter D. Hanish/W. Landsman June 2003 +; Assume since V5.6 W. Landsman Feb 2004 +; +;- + On_error,2 +; Check parameters. + + if N_params() LT 2 then begin ; # parameters. + print, "Syntax - MEDARR, inputarr, outputarr [, maskarr, output_mask]" + return + endif + + s = size(inarr) + if s[0] NE 3 then $ ; Input array size. + message, "Input array must have 3 dimensions" + if (N_elements(mask) EQ 0) then begin + outarr = median(inarr,dimension=3,/even) + return + endif + +; Create the output array. + ncol = s[1] + nrow = s[2] + narr = s[3] + type = s[s[0] + 1] + outarr = make_array( dimen = [ncol,nrow], /NOZERO, TYPE = type ) + if arg_present(output_mask) then $ + output_mask = make_array (dimen = [ncol,nrow], VALUE = 1b) + +; Combine the input arrays into the output array. + + sm = size(mask) + if N_elements(mask) LT 4 then $ + message,'Input mask not valid... must have 3 dimensions' + if array_equal(sm[0:3], s[0:3] ) then $ + mask_given = 1b $ + else message,'Mask not valid... must be same shape as input cube.' + + for j = 0l, (nrow-1) do begin + for i = 0l, (ncol-1) do begin + good_pixels = 1b + wmask = where(mask[i,j,*],cwm) + if cwm gt 0 then begin + marr = inarr[i,j,wmask] + endif else begin + good_pixels = 0b + output_mask[i,j] = 0b + endelse + + if good_pixels then outarr[i,j] = median(marr,/EVEN) + + endfor + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/medsmooth.pro b/modules/idl_downloads/astro/pro/medsmooth.pro new file mode 100644 index 0000000..15d9593 --- /dev/null +++ b/modules/idl_downloads/astro/pro/medsmooth.pro @@ -0,0 +1,71 @@ +FUNCTION MEDSMOOTH,ARRAY,WINDOW +;+ +; NAME: +; MEDSMOOTH +; +; PURPOSE: +; Median smoothing of a vector, including points near its ends. +; +; CALLING SEQUENCE: +; SMOOTHED = MEDSMOOTH( VECTOR, WINDOW_WIDTH ) +; +; INPUTS: +; VECTOR = The (1-d numeric) vector to be smoothed +; WINDOW = Odd integer giving the full width of the window over which +; the median is determined for each point. (If WINDOW is +; specified as an even number, then the effect is the same as +; using WINDOW+1) +; +; OUTPUT: +; Function returns the smoothed vector +; +; PROCEDURE: +; Each point is replaced by the median of the nearest WINDOW of points. +; The width of the window shrinks towards the ends of the vector, so that +; only the first and last points are not filtered. These points are +; replaced by forecasting from smoothed interior points. +; +; EXAMPLE: +; Create a vector with isolated high points near its ends +; IDL> a = randomn(seed,40) & a[1] = 10 & a[38] = 10 +; Now do median smoothing with a 7 point window +; IDL> b = medsmooth(a,7) +; Note that, unlike MEDIAN(), that MEDSMOOTH will remove the isolated +; high points near the ends. +; REVISION HISTORY: +; Written, H. Freudenreich, STX, 12/89 +; H.Freudenreich, 8/90: took care of end-points by shrinking window. +; Speed up using vector median when possible W. Landsman February 2002 +;- + + LEND = N_ELEMENTS(ARRAY)-1 + IF (LEND+1) LT WINDOW THEN BEGIN + message,/CON, $ + 'ERROR - Size of smoothing window must be smaller than array size' + RETURN,ARRAY + ENDIF + + OFFSET = FIX(WINDOW/2) + + smoothed = median(array, window ) + +; Fix the ends: + NUMLOOP = (WINDOW-1)/2 - 1 + IF NUMLOOP GT 0 THEN BEGIN + FOR J=1,NUMLOOP DO BEGIN + + LEN = 2*J+1 + SMOOTHED[J] = MEDIAN(ARRAY[0:LEN-1]) + SMOOTHED[LEND-J] = MEDIAN(ARRAY[LEND-LEN+1:LEND]) + + ENDFOR +ENDIF + +; Now replace the very last and first points: + Y0 = 3.*ARRAY[0]-2.*ARRAY[1] ; Predicted value of point -1 + SMOOTHED[0] = MEDIAN([Y0,ARRAY[0],ARRAY[1]]) + Y0 = 3.*ARRAY[LEND]-2.*ARRAY[LEND-1] ; Predicted value of point LEND+1 + SMOOTHED[LEND] = MEDIAN([Y0,ARRAY[LEND],ARRAY[LEND-1]]) + + RETURN,SMOOTHED + END diff --git a/modules/idl_downloads/astro/pro/minf_bracket.pro b/modules/idl_downloads/astro/pro/minf_bracket.pro new file mode 100644 index 0000000..a0de52c --- /dev/null +++ b/modules/idl_downloads/astro/pro/minf_bracket.pro @@ -0,0 +1,130 @@ +pro minF_bracket, xa,xb,xc, fa,fb,fc, FUNC_NAME=func_name, $ + POINT_NDIM=pn, DIRECTION=dirn +;+ +; NAME: +; MINF_BRACKET +; PURPOSE: +; Bracket a local minimum of a 1-D function with 3 points, +; EXPLANATION: +; Brackets a local minimum of a 1-d function with 3 points, +; thus ensuring that a minimum exists somewhere in the interval. +; This routine assumes that the function has a minimum somewhere.... +; Routine can also be applied to a scalar function of many variables, +; for such case the local minimum in a specified direction is bracketed, +; This routine is called by minF_conj_grad, to bracket minimum in the +; direction of the conjugate gradient of function of many variables +; CALLING EXAMPLE: +; xa=0 & xb=1 +; minF_bracket, xa,xb,xc, fa,fb,fc, FUNC_NAME="name" ;for 1-D func. +; or: +; minF_bracket, xa,xb,xc, fa,fb,fc, FUNC="name", $ +; POINT=[0,1,1], $ +; DIRECTION=[2,1,1] ;for 3-D func. +; INPUTS: +; xa = scalar, guess for point bracketing location of minimum. +; xb = scalar, second guess for point bracketing location of minimum. +; KEYWORDS: +; FUNC_NAME = function name (string) +; Calling mechanism should be: F = func_name( px ) +; where: +; px = scalar or vector of independent variables, input. +; F = scalar value of function at px. +; POINT_NDIM = when working with function of N variables, +; use this keyword to specify the starting point in N-dim space. +; Default = 0, which assumes function is 1-D. +; DIRECTION = when working with function of N variables, +; use this keyword to specify the direction in N-dim space +; along which to bracket the local minimum, (default=1 for 1-D). +; (xa,xb,xc) are then relative distances from POINT_NDIM. +; OUTPUTS: +; xa,xb,xc = scalars, 3 points which bracket location of minimum, +; that is, f(xb) < f(xa) and f(xb) < f(xc), so minimum exists. +; When working with function of N variables +; (xa,xb,xc) are then relative distances from POINT_NDIM, +; in the direction specified by keyword DIRECTION, +; with scale factor given by magnitude of DIRECTION. +; OPTIONAL OUTPUT: +; fa,fb,fc = value of function at 3 points which bracket the minimum, +; again note that fb < fa and fb < fc if minimum exists. +; PROCEDURE: +; algorithm from Numerical Recipes (by Press, et al.), sec.10.1 (p.281). +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + goldm = (sqrt(5)+1)/2 ;golden mean factor to march with. + glimit = 100 ;maximum factor to try. + tiny = 1.e-19 ;a tiny number to avoid divide by zero. + + if N_elements( pn ) LE 0 then begin + pn = 0 + dirn = 1 + endif + + if (xa EQ xb) then xb = xa + 1 + fa = call_function( func_name, pn + xa * dirn ) + fb = call_function( func_name, pn + xb * dirn ) + + if (fb GT fa) then begin + x = xa & xa = xb & xb = x + f = fa & fa = fb & fb = f + endif + + xc = xb + goldm * (xb-xa) + fc = call_function( func_name, pn + xc * dirn ) + + while (fb GE fc) do begin + + zba = xb-xa + zbc = xb-xc + r = zba * (fb-fc) + q = zbc * (fb-fa) + delta = q-r + sign = 1 - 2 * (delta LT 0) + xu = xb - (zbc * q - zba * r)/(2* sign * (abs( delta ) > tiny) ) + ulim = xb + glimit * (xc-xb) + + if ( (xb-xu)*(xu-xc) GT 0 ) then begin + + fu = call_function( func_name, pn + xu * dirn ) + + if (fu LT fc) then begin + xa = xb & xb = xu + fa = fb & fb = fu + return + endif else if (fu GT fb) then begin + xc = xu + fc = fu + return + endif + + xu = xc - goldm * zbc + fu = call_function( func_name, pn + xu * dirn ) + + endif else if ( (xc-xu)*(xu-ulim) GT 0 ) then begin + + fu = call_function( func_name, pn + xu * dirn ) + + if (fu LT fc) then begin + xb = xc & fb = fc + xc = xu & fc = fu + xu = xc + goldm * (xc-xb) + fu = call_function( func_name, pn + xu * dirn ) + endif + + endif else if ( (ulim-xc)*(xu-ulim) GE 0 ) then begin + + xu = ulim + fu = call_function( func_name, pn + xu * dirn ) + + endif else begin + + xu = xc + goldm * (xc-xb) + fu = call_function( func_name, pn + xu * dirn ) + endelse + + xa = xb & xb = xc & xc = xu + fa = fb & fb = fc & fc = fu + endwhile +return +end diff --git a/modules/idl_downloads/astro/pro/minf_conj_grad.pro b/modules/idl_downloads/astro/pro/minf_conj_grad.pro new file mode 100644 index 0000000..81a32bc --- /dev/null +++ b/modules/idl_downloads/astro/pro/minf_conj_grad.pro @@ -0,0 +1,127 @@ +pro minF_conj_grad, p_min, f_min, conv_factor, FUNC_NAME=func_name, $ + TOLERANCE=tol, USE_DERIV=use, $ + INITIALIZE=initialize, QUADRATIC=quad +;+ +; NAME: +; MINF_CONJ_GRAD +; PURPOSE: +; Find the local minimum of a scalar function using conjugate gradient +; EXPLANATION: +; Find the local minimum of a scalar function of several variables using +; the Conjugate Gradient method (Fletcher-Reeves-Polak-Ribiere algorithm). +; Function may be anything with computable partial derivatives. +; Each call to minF_conj_grad performs one iteration of algorithm, +; and returns an N-dim point closer to the local minimum of function. +; CALLING EXAMPLE: +; p_min = replicate( 1, N_dim ) +; minF_conj_grad, p_min, f_min, conv_factor, FUNC_NAME="name",/INITIALIZE +; +; while (conv_factor GT 0) do begin +; minF_conj_grad, p_min, f_min, conv_factor, FUNC_NAME="name" +; endwhile +; INPUTS: +; p_min = vector of independent variables, location of minimum point +; obtained from previous call to minF_conj_grad, (or first guess). +; KEYWORDS: +; FUNC_NAME = function name (string) +; Calling mechanism should be: F = func_name( px, gradient ) +; where: +; F = scalar value of function at px. +; px = vector of independent variables, input. +; gradient = vector of partial derivatives of the function +; with respect to independent variables, evaluated at px. +; This is an optional output parameter: +; gradient should not be calculated if parameter is not +; supplied in call (Unless you want to waste some time). +; /INIT must be specified on first call (whenever p_min is a guess), +; to initialize the iteration scheme of algorithm. +; /USE_DERIV causes the directional derivative of function to be used +; in the 1-D minimization part of algorithm +; (default is not to use directional derivative). +; TOLERANCE = desired accuracy of minimum location, default=sqrt(1.e-7). +; /QUADRATIC runs simpler version which works only for quadratic function. +; OUTPUTS: +; p_min = vector giving improved solution for location of minimum point. +; f_min = value of function at p_min. +; conv_factor = gives the current rate of convergence (change in value), +; iteration should be stopped when rate gets near zero. +; EXTERNAL CALLS: +; pro minF_bracket, to find 3 points which bracket the minimum in 1-D. +; pro minF_parabolic, to find minimum point in 1-D. +; pro minF_parabol_D, to find minimum point in 1-D, using derivatives. +; COMMON BLOCKS: +; common minf_conj_grad, grad_conj, grad_save, gs_norm +; (to keep conjugate gradient, gradient and norm from previous iteration) +; PROCEDURE: +; Algorithm adapted from Numerical Recipes, sec.10.6 (p.305). +; Conjugate gradient is computed from gradient, which then gives +; the best direction (in N-dim space) in which to proceed to find +; the minimum point. The function is then minimized along +; this direction of conjugate gradient (a 1-D minimization). +; The algorithm is repeated starting at the new point by calling again. +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - minF_conj_grad, p_min, f_min, conv_factor, FUNC_NAME = + print,' [ TOLERANCE=, USE_DERIV=, INITIALIZE= , QUADRATIC= ] + return + endif + + common minf_conj_grad, grad_conj, grad_save, gs_norm + + fp = call_function( func_name, p_min, gradient ) + +;Compute conjugate gradient direction: + + if keyword_set( initialize ) then begin + + grad_conj = -gradient + gs_norm = total( gradient * gradient ) + if NOT keyword_set( quad ) then grad_save = gradient + + endif else begin + + grad_norm = total( gradient * gradient ) + + if (grad_norm EQ 0) then begin + f_min = fp + conv_factor = 0 + return + endif + + if keyword_set( quad ) then gamma = grad_norm/gs_norm else begin + + gamma = ( grad_norm - total( grad_save*gradient ) )/gs_norm + grad_save = gradient + endelse + + grad_conj = gamma * grad_conj - gradient + gs_norm = grad_norm + endelse + +;Now find mininum along direction of conjugate gradient: + + xa = 0 + xb = 1/sqrt( gs_norm ) + + minF_bracket, xa,xb,xc, fa,fb,fc, FUNC_NAME=func_name, POINT=p_min, $ + DIRECTION=grad_conj + if keyword_set( use ) then begin + + minF_parabol_D, xa,xb,xc, x_min, f_min, FUN=func_name, TOL=tol,$ + POINT=p_min, DIRECTION=grad_conj + endif else begin + + minF_parabolic, xa,xb,xc, x_min, f_min, FUN=func_name, TOL=tol,$ + POINT=p_min, DIRECTION=grad_conj + endelse + + conv_factor = 2*abs( f_min - fp )/( (abs(f_min) + abs(fp)) > 1.e-9 ) + + p_min = p_min + x_min * grad_conj +return +end diff --git a/modules/idl_downloads/astro/pro/minf_parabol_d.pro b/modules/idl_downloads/astro/pro/minf_parabol_d.pro new file mode 100644 index 0000000..313a043 --- /dev/null +++ b/modules/idl_downloads/astro/pro/minf_parabol_d.pro @@ -0,0 +1,173 @@ +; Procedure minF_parabol_D, +; first, a utility function which gets derivative in 1-D: +;------------------------------------------------------------------------------ +function call_func_deriv, func_name, x, deriv, POINT_NDIM=pn, DIRECTION=dirn + + f = call_function( func_name, pn + x * dirn, grad ) + + deriv = total( [grad * dirn] ) + +return, f +end +;------------------------------------------------------------------------------ +pro minF_parabol_D, xa,xb,xc, xmin, fmin, FUNC_NAME=func_name, $ + MAX_ITERATIONS=maxit, $ + TOLERANCE=TOL, $ + POINT_NDIM=pn, DIRECTION=dirn +;+ +; NAME: +; MINF_PARABOL_D +; PURPOSE: +; Minimize a function using a modified Brent's method with derivatives +; EXPLANATION: +; Based on the procedure DBRENT in Numerical Recipes by Press et al. +; Finds a local minimum of a 1-D function up to specified tolerance, +; using the first derivative of function in the algorithm. +; This routine assumes that the function has a minimum nearby. +; (recommend first calling minF_bracket, xa,xb,xc, to bracket minimum). +; Routine can also be applied to a scalar function of many variables, +; for such case the local minimum in a specified direction is found, +; This routine is called by minF_conj_grad, to locate minimum in the +; direction of the conjugate gradient of function of many variables. +; +; CALLING EXAMPLES: +; minF_parabol_D, xa,xb,xc, xmin, fmin, FUNC_NAME="name" ;for 1-D func. +; or: +; minF_parabol_D, xa,xb,xc, xmin, fmin, FUNC="name", $ +; POINT=[0,1,1], $ +; DIRECTION=[2,1,1] ;for 3-D func. +; INPUTS: +; xa,xb,xc = scalars, 3 points which bracket location of minimum, +; that is, f(xb) < f(xa) and f(xb) < f(xc), so minimum exists. +; When working with function of N variables +; (xa,xb,xc) are then relative distances from POINT_NDIM, +; in the direction specified by keyword DIRECTION, +; with scale factor given by magnitude of DIRECTION. +; KEYWORDS: +; FUNC_NAME = function name (string) +; Calling mechanism should be: F = func_name( px, gradient ) +; where: +; px = scalar or vector of independent variables, input. +; F = scalar value of function at px. +; gradient = derivative of function, a scalar if 1-D, +; a gradient vector if N-D, +; (should only be computed if arg. is present). +; +; POINT_NDIM = when working with function of N variables, +; use this keyword to specify the starting point in N-dim space. +; Default = 0, which assumes function is 1-D. +; DIRECTION = when working with function of N variables, +; use this keyword to specify the direction in N-dim space +; along which to bracket the local minimum, (default=1 for 1-D). +; (xa, xb, xc, x_min are then relative distances from POINT_NDIM) +; MAX_ITER = maximum allowed number iterations, default=100. +; TOLERANCE = desired accuracy of minimum location, default=sqrt(1.e-7). +; +; OUTPUTS: +; xmin = estimated location of minimum. +; When working with function of N variables, +; xmin is the relative distance from POINT_NDIM, +; in the direction specified by keyword DIRECTION, +; with scale factor given by magnitude of DIRECTION, +; so that min. Loc. Pmin = Point_Ndim + xmin * Direction. +; fmin = value of function at xmin (or Pmin). +; PROCEDURE: +; Brent's method to minimize a function by using parabolic interpolation +; and using first derivative of function, +; from Numerical Recipes (by Press, et al.), sec.10.3 (p.287), +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. +;- + zeps = 1.e-7 ;machine epsilon, smallest addition. + if N_elements( TOL ) NE 1 then TOL = sqrt( zeps ) + if N_elements( maxit ) NE 1 then maxit = 100 + + if N_elements( pn ) LE 0 then begin + pn = 0 + dirn = 1 + endif + + xLo = xa < xc + xHi = xa > xc + xmin = xb + fmin = call_func_deriv( func_name, xmin, dx, POINT=pn, DIR=dirn ) + xv = xmin & xw = xmin + fv = fmin & fw = fmin + dv = dx & dw = dx + es = 0. + + for iter = 1,maxit do begin + + xm = (xLo + xHi)/2. + TOL1 = TOL * abs(xmin) + zeps + TOL2 = 2*TOL1 + + if ( abs( xmin - xm ) LE ( TOL2 - (xHi-xLo)/2. ) ) then return + + if (abs( es ) GT TOL1) then begin + + d1 = 2*(xHi-xLo) + d2 = d1 + if (dw NE dx) then d1 = (xw-xmin)*dx/(dx-dw) + if (dv NE dx) then d2 = (xv-xmin)*dx/(dx-dv) + u1 = xmin + d1 + u2 = xmin + d2 + ok1 = ((xLo-u1)*(u1-xHi) GT 0) AND (dx*d1 LE 0) + ok2 = ((xLo-u2)*(u2-xHi) GT 0) AND (dx*d2 LE 0) + olde = es + es = ds + + if NOT (ok1 OR ok2) then goto,BISECT + + if (ok1 AND ok2) then begin + + if (abs( d1 ) LT abs( d2 )) then ds=d1 else ds=d2 + + endif else if (ok1) then ds=d1 else ds=d2 + + if (abs( ds ) LE abs( olde/2 )) then begin + + xu = xmin + ds + + if ((xu-xLo) LT TOL2) OR $ + ((xHi-xu) LT TOL2) then $ + ds = TOL1 * (1-2*((xm-xmin) LT 0)) + goto,STEP + endif + endif + + BISECT: if (dx GE 0) then es = xLo-xmin else es = xHi-xmin + ds = es/2 + + STEP: sign = 1 - 2*(ds LT 0) + xu = xmin + sign * ( abs( ds ) > TOL1 ) + fu = call_func_deriv( func_name, xu, du, POINT=pn, DIR=dirn ) + + if (fu GT fmin) AND (abs( ds ) LT TOL1) then return + + if (fu LE fmin) then begin + + if (xu GE xmin) then xLo=xmin else xHi=xmin + xv = xw & fv = fw & dv = dw + xw = xmin & fw = fmin & dw = dx + xmin = xu & fmin = fu & dx = du + + endif else begin + + if (xu LT xmin) then xLo=xu else xHi=xu + + if (fu LE fw) OR (xw EQ xmin) then begin + + xv = xw & fv = fw & dv = dw + xw = xu & fw = fu & dw = du + + endif else if (fu LE fv) OR (xv EQ xmin) $ + OR (xv EQ xw) then begin + xv = xu & fv = fu & dv = du + endif + endelse + endfor + + message,"exceeded maximum number of iterations: "+strtrim(iter,2),/INFO +return +end diff --git a/modules/idl_downloads/astro/pro/minf_parabolic.pro b/modules/idl_downloads/astro/pro/minf_parabolic.pro new file mode 100644 index 0000000..eff8345 --- /dev/null +++ b/modules/idl_downloads/astro/pro/minf_parabolic.pro @@ -0,0 +1,147 @@ +pro minF_parabolic, xa,xb,xc, xmin, fmin, FUNC_NAME=func_name, $ + MAX_ITERATIONS=maxit, $ + TOLERANCE=TOL, $ + POINT_NDIM=pn, DIRECTION=dirn +;+ +; NAME: +; MINF_PARABOLIC +; PURPOSE: +; Minimize a function using Brent's method with parabolic interpolation +; EXPLANATION: +; Find a local minimum of a 1-D function up to specified tolerance. +; This routine assumes that the function has a minimum nearby. +; (recommend first calling minF_bracket, xa,xb,xc, to bracket minimum). +; Routine can also be applied to a scalar function of many variables, +; for such case the local minimum in a specified direction is found, +; This routine is called by minF_conj_grad, to locate minimum in the +; direction of the conjugate gradient of function of many variables. +; +; CALLING EXAMPLES: +; minF_parabolic, xa,xb,xc, xmin, fmin, FUNC_NAME="name" ;for 1-D func. +; or: +; minF_parabolic, xa,xb,xc, xmin, fmin, FUNC="name", $ +; POINT=[0,1,1], $ +; DIRECTION=[2,1,1] ;for 3-D func. +; INPUTS: +; xa,xb,xc = scalars, 3 points which bracket location of minimum, +; that is, f(xb) < f(xa) and f(xb) < f(xc), so minimum exists. +; When working with function of N variables +; (xa,xb,xc) are then relative distances from POINT_NDIM, +; in the direction specified by keyword DIRECTION, +; with scale factor given by magnitude of DIRECTION. +; INPUT KEYWORDS: +; FUNC_NAME = function name (string) +; Calling mechanism should be: F = func_name( px ) +; where: +; px = scalar or vector of independent variables, input. +; F = scalar value of function at px. +; +; POINT_NDIM = when working with function of N variables, +; use this keyword to specify the starting point in N-dim space. +; Default = 0, which assumes function is 1-D. +; DIRECTION = when working with function of N variables, +; use this keyword to specify the direction in N-dim space +; along which to bracket the local minimum, (default=1 for 1-D). +; (xa, xb, xc, x_min are then relative distances from POINT_NDIM) +; MAX_ITER = maximum allowed number iterations, default=100. +; TOLERANCE = desired accuracy of minimum location, default=sqrt(1.e-7). +; OUTPUTS: +; xmin = estimated location of minimum. +; When working with function of N variables, +; xmin is the relative distance from POINT_NDIM, +; in the direction specified by keyword DIRECTION, +; with scale factor given by magnitude of DIRECTION, +; so that min. Loc. Pmin = Point_Ndim + xmin * Direction. +; fmin = value of function at xmin (or Pmin). +; PROCEDURE: +; Brent's method to minimize a function by using parabolic interpolation. +; Based on function BRENT in Numerical Recipes in FORTRAN (Press et al. +; 1992), sec.10.2 (p. 397). +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1992. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + zeps = 1.e-7 ;machine epsilon, smallest addition. + goldc = 1 - (sqrt(5)-1)/2 ;complement of golden mean. + + if N_elements( TOL ) NE 1 then TOL = sqrt( zeps ) + if N_elements( maxit ) NE 1 then maxit = 100 + + if N_elements( pn ) LE 0 then begin + pn = 0 + dirn = 1 + endif + + xLo = xa < xc + xHi = xa > xc + xmin = xb + fmin = call_function( func_name, pn + xmin * dirn ) + xv = xmin & xw = xmin + fv = fmin & fw = fmin + es = 0. + + for iter = 1,maxit do begin + + goldstep = 1 + xm = (xLo + xHi)/2. + TOL1 = TOL * abs(xmin) + zeps + TOL2 = 2*TOL1 + + if ( abs( xmin - xm ) LE ( TOL2 - (xHi-xLo)/2. ) ) then return + + if (abs( es ) GT TOL1) then begin + + r = (xmin-xw) * (fmin-fv) + q = (xmin-xv) * (fmin-fw) + p = (xmin-xv) * q + (xmin-xw) * r + q = 2 * (q-r) + if (q GT 0) then p = -p + q = abs( q ) + etemp = es + es = ds + + if (p GT q*(xLo-xmin)) AND $ + (p LT q*(xHi-xmin)) AND $ + (abs( p ) LT abs( q*etemp/2 )) then begin + ds = p/q + xu = xmin + ds + if (xu-xLo LT TOL2) OR (xHi-xu LT TOL2) then $ + ds = TOL1 * (1-2*((xm-xmin) LT 0)) + goldstep = 0 + endif + endif + + if (goldstep) then begin + if (xmin GE xm) then es = xLo-xmin else es = xHi-xmin + ds = goldc * es + endif + + xu = xmin + (1-2*(ds LT 0)) * ( abs( ds ) > TOL1 ) + fu = call_function( func_name, pn + xu * dirn ) + + if (fu LE fmin) then begin + + if (xu GE xmin) then xLo=xmin else xHi=xmin + xv = xw & fv = fw + xw = xmin & fw = fmin + xmin = xu & fmin = fu + + endif else begin + + if (xu LT xmin) then xLo=xu else xHi=xu + + if (fu LE fw) OR (xw EQ xmin) then begin + + xv = xw & fv = fw + xw = xu & fw = fu + + endif else if (fu LE fv) OR (xv EQ xmin) $ + OR (xv EQ xw) then begin + xv = xu & fv = fu + endif + endelse + endfor + + message,"exceeded maximum number of iterations: "+strtrim(iter,2),/INFO +return +end diff --git a/modules/idl_downloads/astro/pro/minmax.pro b/modules/idl_downloads/astro/pro/minmax.pro new file mode 100644 index 0000000..71b8e37 --- /dev/null +++ b/modules/idl_downloads/astro/pro/minmax.pro @@ -0,0 +1,71 @@ +function minmax,array,subs,NAN=nan, DIMEN=dimen +;+ +; NAME: +; MINMAX +; PURPOSE: +; Return a 2 element array giving the minimum and maximum of an array +; EXPLANATION: +; Using MINMAX() is faster than doing a separate MAX and MIN. +; +; The procedure MAXMIN in http://www.idlcoyote.com/programs/maxmin.pro +; has a similar purpose but uses a procedure call rather than a function. +; CALLING SEQUENCE: +; value = minmax( array, [subs, /NAN, DIMEN= ] ) +; INPUTS: +; array - an IDL numeric scalar, vector or array. +; +; OUTPUTS: +; value = a two element vector (if DIMEN is not supplied) +; value[0] = minimum value of array +; value[1] = maximum value of array +; +; If the DIMEN keyword is supplied then value will be a 2 x N element +; array where N is the number of elements in the specified +; dimension +; +; OPTIONAL OUTPUT PARAMETER: +; subs - two-dimensional vector; the first element gives the subscript +; of the minimum value, the second element gives the subscript +; of the maximum value. +; +; OPTIONAL INPUT KEYWORD: +; /NAN - Set this keyword to cause the routine to check for occurrences +; of the IEEE floating-point value NaN in the input data. Elements +; with the value NaN are treated as missing data. +; +; DIMEN - integer (either 1 or 2) specifying which dimension of a 2-d +; array to take the minimum and maximum. Note that (unlike the +; DIMENSION keyword to the MIN() function) DIMEN is only valid +; for a 2-d array, larger dimensions are not supported. +; EXAMPLE: +; (1) Print the minimum and maximum of an image array, im +; +; IDL> print, minmax( im ) +; +; (2) Given a 2-dimension array of (echelle) wavelengths w, print the +; minimum and maximum of each order +; +; print,minmax(w,dimen=1) +; +; PROCEDURE: +; The MIN function is used with the MAX keyword +; +; REVISION HISTORY: +; Written W. Landsman January, 1990 +; Added NaN keyword. M. Buie June 1998 +; Added DIMEN keyword W. Landsman January 2002 +; Added SUBSCRIPT_MIN and SUBSCRIPT_MAX BT Jan 2005 +; Added optional subs output parameter W. Landsman July 2009 +;- + On_error,2 + compile_opt idl2 + if N_elements(DIMEN) GT 0 then begin + amin = min(array, MAX = amax, NAN = nan, DIMEN = dimen,cmin,sub=cmax) + if arg_present(subs) then subs = transpose([[cmin], [cmax]]) + return, transpose([[amin],[amax] ]) + endif else begin + amin = min( array, MAX = amax, NAN=nan, cmin, sub=cmax) + if arg_present(subs) then subs = [cmin, cmax] + return, [ amin, amax ] + endelse + end diff --git a/modules/idl_downloads/astro/pro/mkhdr.pro b/modules/idl_downloads/astro/pro/mkhdr.pro new file mode 100644 index 0000000..bf130b1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mkhdr.pro @@ -0,0 +1,169 @@ +pro mkhdr, header, im, naxisx, IMAGE = image, EXTEND = extend +;+ +; NAME: +; MKHDR +; PURPOSE: +; Make a minimal primary (or IMAGE extension) FITS header +; EXPLANATION: +; If an array is supplied, then the created FITS header will be +; appropriate to the supplied array. Otherwise, the user can specify +; the dimensions and datatype. +; +; To update an *existing* FITS header with a new image array, instead +; use check_FITS, /Update +; +; CALLING SEQUENCE: +; MKHDR, header ;Prompt for image size and type +; or +; MKHDR, header, im, [ /IMAGE, /EXTEND ] +; or +; MKHDR, header, type, naxisx, [/IMAGE, /EXTEND ] +; +; OPTIONAL INPUTS: +; IM - If IM is a vector or array then the header will be made +; appropriate to the size and type of IM. IM does not have +; to be the actual data; it can be a dummy array of the same +; type and size as the data. Set IM = '' to create a dummy +; header with NAXIS = 0. +; TYPE - If 2 parameters are supplied, then the second parameter +; is interpreted as an integer giving the IDL datatype e.g. +; 1 - Byte, 2 - 16 bit integer, 4 - float, 3 - Long +; NAXISX - Vector giving the size of each dimension (NAXIS1, NAXIS2, +; etc.). +; +; OUTPUT: +; HEADER - image header, (string array) with required keywords +; BITPIX, NAXIS, NAXIS1, ... Further keywords can be added +; to the header with SXADDPAR. +; +; OPTIONAL INPUT KEYWORDS: +; /IMAGE = If set, then a minimal header for a FITS IMAGE extension +; is created. An IMAGE extension header is identical to +; a primary FITS header except the first keyword is +; 'XTENSION' = 'IMAGE' instead of 'SIMPLE ' = 'T' +; /EXTEND = If set, then the keyword EXTEND is inserted into the file, +; with the value of "T" (true). The EXTEND keyword can +; optionally be included in a primary header, if the FITS file +; contains extensions. +; +; RESTRICTIONS: +; (1) MKHDR should not be used to make an STSDAS header or a FITS +; ASCII or Binary Table extension header. Instead use +; +; SXHMAKE - to create a minimal STSDAS header +; FXBHMAKE - to create a minimal FITS binary table header +; FTCREATE - to create a minimal FITS ASCII table header +; +; (2) Any data already in the header before calling MKHDR +; will be destroyed. +; EXAMPLE: +; Create a minimal FITS header, Hdr, for a 30 x 40 x 50 INTEGER*2 array +; +; IDL> mkhdr, Hdr, 2, [30,40,50] +; +; Alternatively, if the array already exists as an IDL variable, Array, +; +; IDL> mkhdr, Hdr, Array +; +; PROCEDURES CALLED: +; SXADDPAR, GET_DATE +; +; REVISION HISTORY: +; Written November, 1988 W. Landsman +; May, 1990, Adapted for IDL Version 2.0, J. Isensee +; Aug, 1997, Use SYSTIME(), new DATE format W. Landsman +; Allow unsigned data types W. Landsman December 1999 +; Set BZERO = 0 for unsigned integer data W. Landsman January 2000 +; EXTEND keyword must immediately follow last NAXISi W. Landsman Sep 2000 +; Add FITS definition COMMENT to primary headers W. Landsman Oct. 2001 +; Allow (nonstandard) 64 bit integers W. Landsman Feb. 2003 +; Add V6.0 notation W. Landsman July 2012 +;- + On_error,2 + compile_opt idl2 + + npar = N_params() + if npar LT 1 then begin + print,'Syntax: MKHDR, header, [ im, /IMAGE, /EXTEND ]' + print,' or MKHDR, header, [ type, naxisx, /IMAGE, /EXTEND ]' + print,' header - output FITS header to be created' + return + endif + + if (npar eq 1) then begin ;Prompt for keyword values + read,'Enter number of dimensions (NAXIS): ',naxis + s = lonarr(naxis+2) + s[0] = naxis + if ( naxis GT 0 ) then begin ;Make sure not a dummy header + for i = 1,naxis do begin ;Get dimension of each axis + keyword = 'NAXIS' + strtrim(i,2) + read,'Enter size of dimension '+ strtrim(i,2) + ' ('+keyword+'): ',nx + s[i] = nx + endfor + endif + + print,'Allowed datatypes are (1) Byte, (2) 16 bit integer, (3) 32 bit integer' + print,' (4) 32bit floating, (5) 64 bit double precision' + print,' or (14) 64bit integer' + read,'Enter datatype: ',stype + s[s[0] + 1] = stype + + endif else $ + if ( npar EQ 2 ) then s = size(im) $ ;Image array supplied + else s = [ N_elements(naxisx),naxisx, im ] ;Keyword values supplied + + stype = s[s[0]+1] ;Type of data + case stype of + 0: message,'ERROR: Input data array is undefined' + 1: bitpix = 8 + 2: bitpix = 16 + 3: bitpix = 32 + 4: bitpix = -32 + 5: bitpix = -64 + 6: message,'Complex types not allowed as FITS primary arrays' + 7: bitpix = 8 + 12: bitpix = 16 + 13: bitpix = 32 + 14: bitpix = 64 + else: message,'ERROR: Illegal Image Datatype' + endcase + + header = strarr(s[0] + 7) + string(' ',format='(a80)') ;Create empty array + header[0] = 'END' + string(replicate(32b,77)) + + if keyword_set( IMAGE) then $ + sxaddpar, header, 'XTENSION', 'IMAGE ',' IMAGE extension' $ + else $ + sxaddpar, header, 'SIMPLE', 'T',' Written by IDL: '+ systime() + + sxaddpar, header, 'BITPIX', bitpix, ' Number of bits per data pixel' + sxaddpar, header, 'NAXIS', S[0],' Number of data axes' ;# of dimensions + + if ( s[0] GT 0 ) then begin + for i = 1, s[0] do sxaddpar,header,'NAXIS' + strtrim(i,2),s[i] + endif + + if keyword_set( IMAGE) then begin + sxaddpar, header, 'PCOUNT', 0, ' No Group Parameters' + sxaddpar, header, 'GCOUNT', 1, ' One Data Group' + endif else begin + if keyword_set( EXTEND) or (s[0] EQ 0) then $ + sxaddpar, header, 'EXTEND', 'T', ' FITS data may contain extensions' + Get_date, dte ;Get current date as CCYY-MM-DD + sxaddpar, header, 'DATE', dte, $ + ' Creation UTC (CCCC-MM-DD) date of FITS header' + endelse + + if stype EQ 12 then sxaddpar, header,'O_BZERO',32768, $ + ' Original Data is Unsigned Integer' + if stype EQ 13 then sxaddpar, header,'O_BZERO',2147483648, $ + ' Original Data is Unsigned Long' + header = header[0:s[0]+7] + + if ~keyword_set(IMAGE) then begin ;Add FITS definition for primary header + sxaddpar,header,'COMMENT ', $ + "FITS (Flexible Image Transport System) format is defined in 'Astronomy" + sxaddpar,header,'COMMENT ', $ + "and Astrophysics', volume 376, page 359; bibcode 2001A&A...376..359H" + endif + end diff --git a/modules/idl_downloads/astro/pro/mlinmix_err.pro b/modules/idl_downloads/astro/pro/mlinmix_err.pro new file mode 100644 index 0000000..b74da78 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mlinmix_err.pro @@ -0,0 +1,878 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; MLINMIX_ERR +; PURPOSE: +; Bayesian approach to multiple linear regression with errors in X and Y +; EXPLANATION: +; PERFORM LINEAR REGRESSION OF Y ON X WHEN THERE ARE MEASUREMENT +; ERRORS IN BOTH VARIABLES. THE REGRESSION ASSUMES : +; +; ETA = ALPHA + BETA ## XI + EPSILON +; X = XI + XERR +; Y = ETA + YERR +; +; HERE, (ALPHA, BETA) ARE THE REGRESSION COEFFICIENTS, EPSILON IS THE +; INTRINSIC RANDOM SCATTER ABOUT THE REGRESSION, XERR IS THE +; MEASUREMENT ERROR IN X, AND YERR IS THE MEASUREMENT ERROR IN +; Y. EPSILON IS ASSUMED TO BE NORMALLY-DISTRIBUTED WITH MEAN ZERO AND +; VARIANCE SIGSQR. XERR AND YERR ARE ASSUMED TO BE +; NORMALLY-DISTRIBUTED WITH MEANS EQUAL TO ZERO, COVARIANCE MATRICES +; XVAR^2 FOR X, VARIANCES YSIG^2 FOR Y, AND COVARIANCE VECTORS +; XYCOV. THE DISTRIBUTION OF XI IS MODELLED AS A MIXTURE OF NORMALS, +; WITH GROUP PROPORTIONS PI, MEANS MU, AND COVARIANCES T. BAYESIAN +; INFERENCE IS EMPLOYED, AND A STRUCTURE CONTAINING RANDOM DRAWS FROM +; THE POSTERIOR IS RETURNED. CONVERGENCE OF THE MCMC TO THE POSTERIOR +; IS MONITORED USING THE POTENTIAL SCALE REDUCTION FACTOR (RHAT, +; GELMAN ET AL.2004). IN GENERAL, WHEN RHAT < 1.1 THEN APPROXIMATE +; CONVERGENCE IS REACHED. +; +; SIMPLE NON-DETECTIONS ON Y MAY ALSO BE INCLUDED +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., JULY 2006 +; +; INPUTS : +; +; X - THE OBSERVED INDEPENDENT VARIABLES. THIS SHOULD BE AN +; [NX, NP]-ELEMENT ARRAY. +; Y - THE OBSERVED DEPENDENT VARIABLE. THIS SHOULD BE AN NX-ELEMENT +; VECTOR. +; +; OPTIONAL INPUTS : +; +; XVAR - THE COVARIANCE MATRIX OF THE X ERRORS, AND +; [NX,NP,NP]-ELEMENT ARRAY. XVAR[I,*,*] IS THE COVARIANCE +; MATRIX FOR THE ERRORS ON X[I,*]. THE DIAGONAL OF +; XVAR[I,*,*] MUST BE GREATER THAN ZERO FOR EACH DATA POINT. +; YVAR - THE VARIANCE OF THE Y ERRORS, AND NX-ELEMENT VECTOR. YVAR +; MUST BE GREATER THAN ZERO. +; XYCOV - THE VECTOR OF COVARIANCES FOR THE MEASUREMENT ERRORS +; BETWEEN X AND Y. +; DELTA - AN NX-ELEMENT VECTOR INDICATING WHETHER A DATA POINT IS +; CENSORED OR NOT. IF DELTA[i] = 1, THEN THE SOURCE IS +; DETECTED, ELSE IF DELTA[i] = 0 THE SOURCE IS NOT DETECTED +; AND Y[i] SHOULD BE AN UPPER LIMIT ON Y[i]. NOTE THAT IF +; THERE ARE CENSORED DATA POINTS, THEN THE +; MAXIMUM-LIKELIHOOD ESTIMATE (THETA) IS NOT VALID. THE +; DEFAULT IS TO ASSUME ALL DATA POINTS ARE DETECTED, IE, +; DELTA = REPLICATE(1, NX). +; SILENT - SUPPRESS TEXT OUTPUT. +; MINITER - MINIMUM NUMBER OF ITERATIONS PERFORMED BY THE GIBBS +; SAMPLER. IN GENERAL, MINITER = 5000 SHOULD BE SUFFICIENT +; FOR CONVERGENCE. THE DEFAULT IS MINITER = 5000. THE +; GIBBS SAMPLER IS STOPPED AFTER RHAT < 1.1 FOR ALPHA, +; BETA, AND SIGMA^2, AND THE NUMBER OF ITERATIONS +; PERFORMED IS GREATER THAN MINITER. +; MAXITER - THE MAXIMUM NUMBER OF ITERATIONS PERFORMED BY THE +; MCMC. THE DEFAULT IS 1D5. THE GIBBS SAMPLER IS STOPPED +; AUTOMATICALLY AFTER MAXITER ITERATIONS. +; NGAUSS - THE NUMBER OF GAUSSIANS TO USE IN THE MIXTURE +; MODELLING. THE DEFAULT IS 3. +; +; OUTPUT : +; +; POST - A STRUCTURE CONTAINING THE RESULTS FROM THE GIBBS +; SAMPLER. EACH ELEMENT OF POST IS A DRAW FROM THE POSTERIOR +; DISTRIBUTION FOR EACH OF THE PARAMETERS. +; +; ALPHA - THE CONSTANT IN THE REGRESSION. +; BETA - THE SLOPES OF THE REGRESSION. +; SIGSQR - THE VARIANCE OF THE INTRINSIC SCATTER. +; PI - THE GAUSSIAN WEIGHTS FOR THE MIXTURE MODEL. +; MU - THE GAUSSIAN MEANS FOR THE MIXTURE MODEL. +; T - THE GAUSSIAN COVARIANCE MATRICES FOR THE MIXTURE +; MODEL. +; MU0 - THE HYPERPARAMETER GIVING THE MEAN VALUE OF THE +; GAUSSIAN PRIOR ON MU. +; U - THE HYPERPARAMETER DESCRIBING FOR THE PRIOR +; COVARIANCE MATRIX OF THE INDIVIDUAL GAUSSIAN +; CENTROIDS ABOUT MU0. +; W - THE HYPERPARAMETER DESCRIBING THE `TYPICAL' SCALE +; MATRIX FOR THE PRIOR ON (T,U). +; XIMEAN - THE MEAN OF THE DISTRIBUTION FOR THE +; INDEPENDENT VARIABLE, XI. +; XIVAR - THE STANDARD COVARIANCE MATRIX FOR THE +; DISTRIBUTION OF THE INDEPENDENT VARIABLE, XI. +; XICORR - SAME AS XIVAR, BUT FOR THE CORRELATION MATRIX. +; CORR - THE LINEAR CORRELATION COEFFICIENT BETWEEN THE +; DEPENDENT AND INDIVIDUAL INDEPENDENT VARIABLES, +; XI AND ETA. +; PCORR - SAME AS CORR, BUT FOR THE PARTIAL CORRELATIONS. +; +; CALLED ROUTINES : +; +; RANDOMCHI, MRANDOMN, RANDOMWISH, RANDOMDIR, MULTINOM +; +; REFERENCES : +; +; Carroll, R.J., Roeder, K., & Wasserman, L., 1999, Flexible +; Parametric Measurement Error Models, Biometrics, 55, 44 +; +; Kelly, B.C., 2007, Some Aspects of Measurement Error in +; Linear Regression of Astronomical Data, ApJ, In press +; (astro-ph/0705.2774) +; +; Gelman, A., Carlin, J.B., Stern, H.S., & Rubin, D.B., 2004, +; Bayesian Data Analysis, Chapman & Hall/CRC +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute the inverse of the lower triangular matrix output +;from the Cholesky decomposition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function mlinmix_chol_invert, L + +n = n_elements(L[*,0]) + +X = dblarr(n, n) ;X is the matrix inverse of L + +for i = 0, n - 1 do begin + + X[i,i] = 1d / L[i,i] + + if i lt n - 1 then begin + + for j = i + 1, n - 1 do begin + + sum = 0d + for k = i, j - 1 do sum = sum - L[k,j] * X[i,k] + X[i,j] = sum / L[j,j] + + endfor + + endif + +endfor + +return, X +end + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;routine to compute the inverse of a symmetric positive-definite +;matrix via the Cholesky decomposition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +pro mlinmix_posdef_invert, A + +dim = n_elements(A[*,0]) +diag = lindgen(dim) * (dim + 1L) + +choldc, A, P, /double + +for j = 0, dim - 1 do for k = j, dim - 1 do A[k,j] = 0d + +A[diag] = P + +A = mlinmix_chol_invert(A) + +A = transpose(A) ## A + +return +end + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; ; +; MAIN ROUTINE ; +; ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +pro mlinmix_err, x, y, post, xvar=xvar, yvar=yvar, xycov=xycov, silent=silent, $ + delta=delta, miniter=miniter, maxiter=maxiter, ngauss=ngauss + +if n_params() lt 3 then begin + + print, 'Syntax- MLINMIX_ERR, X, Y, POST, XVAR=XVAR, YVAR=YVAR, XYCOV=XYCOV,' + print, ' NGAUSS=NGAUSS, /SILENT, DELTA=DELTA, ' + PRINT, ' MINITER=MINITER, MAXITER=MAXITER' + return + +endif + +;check inputs and setup defaults + +nx = size(x) + +if nx[0] ne 2 then begin + print, 'X must be an [NX,NP]-element array.' + return +endif + +np = nx[2] +nx = nx[1] + +if n_elements(y) ne nx then begin + print, 'Y and X must have the same size.' + return +endif + +if n_elements(xvar) eq 0 and n_elements(yvar) eq 0 then begin + print, 'Must supply at least one of XVAR or YVAR.' + return +endif + +xvar_size = size(xvar) + +if (xvar_size[0] ne 3) or (xvar_size[1] ne nx) or (xvar_size[2] ne np) or $ + (xvar_size[3] ne np) then begin + print, 'XVAR must be an [NX,NP,NP]-element array.' + return +endif + +if n_elements(yvar) ne nx then begin + print, 'YVAR and Y must have the same size.' + return +endif + +if n_elements(xycov) eq 0 then xycov = dblarr(nx, np) + +if n_elements(xycov[*,0]) ne nx or n_elements(xycov[0,*]) ne np then begin + print, 'XYCOV must be an [NX,NP]-element array.' + return +endif + +if n_elements(delta) eq 0 then delta = replicate(1, nx) +if n_elements(delta) ne nx then begin + print, 'DELTA and X must have the same size.' + return +endif + +diag = lindgen(np) * (np + 1) +diag2 = lindgen(np+1) * (np + 2) + +zero = where(xvar[diag] eq 0 or yvar eq 0, nzero) +if nzero gt 0 then begin + print, 'Measurement Errors in X and Y have to have non-zero variance.' + return +endif + +det = where(delta eq 1, ndet, comp=cens, ncomp=ncens) ;get detected data points + +if not keyword_set(silent) then silent = 0 +if n_elements(miniter) eq 0 then miniter = 5000 ;minimum number of iterations that the + ;Markov Chain must perform +if n_elements(maxiter) eq 0 then maxiter = 100000L ;maximum number of iterations that the + ;Markov Chains will perform + +if n_elements(ngauss) eq 0 then ngauss = 3 + +if ngauss le 0 then begin + print, 'NGAUSS must be at least 1.' + return +endif + +;store covariance matrices for (x,y) measurement errors + +xyvar = dblarr(nx,np+1,np+1) + +xyvar[*,0,0] = yvar +xyvar[*,1:*,0] = xycov +xyvar[*,0,1:*] = xycov +xyvar[*,1:*,1:*] = xvar + +;; perform MCMC + +nchains = 4 ;number of markov chains to use +checkiter = 100 ;check for convergence every 100 iterations +iter = 0L + +;;;;;;;;;;;; get initial guesses for the MCMC + +;; first use moment correction method to estimate regression +;; coefficients and intrinsic dispersion + +Xmat = [[replicate(1d, nx)], [x]] +denom = matrix_multiply(Xmat, Xmat, /atranspose) +Vcoef = denom +denom[1:*,1:*] = denom[1:*,1:*] - median(xvar, dim=1) + +denom_diag = (denom[1:*,1:*])[diag] +denom_diag = denom_diag > 0.025 * (Vcoef[1:*,1:*])[diag] +denom[diag2[1:*]] = denom_diag +numer = y ## transpose(Xmat) - [0d, median(xycov, dim=1)] + +choldc, denom, P, /double ;solve by cholesky decomposition +coef = cholsol( denom, P, numer, /double ) + +alpha = coef[0] +beta = coef[1:*] + +sigsqr = variance(y) - mean(yvar) - $ + beta ## (correlate(transpose(x), /covar) - median(xvar, dim=1)) ## transpose(beta) +sigsqr = sigsqr[0] > 0.05 * variance(y - alpha - beta ## x) + +; randomly disperse starting values for (alpha, beta) from a +; multivariate students-t distribution with 4 degrees of freedom + +mlinmix_posdef_invert, Vcoef +Vcoef = Vcoef * sigsqr * 4d + +coef = mrandomn(seed, Vcoef, nchains) +chisqr = randomchi(seed, 4, nchains) + +alphag = alpha + coef[*,0] * sqrt(4d / chisqr) +betag = dblarr(np, nchains) +for i = 0, nchains - 1 do betag[*,i] = beta + coef[i,1:*] * sqrt(4d / chisqr[i]) + +;draw sigsqr from an Inverse scaled chi-square density +sigsqrg = sigsqr * (nx / 2) / randomchi(seed, nx / 2, nchains) + +;; now get initial guesses for the mixture and prior parameters, do +;; this one chain at a time + +pig = dblarr(ngauss, nchains) +mug = dblarr(np, ngauss, nchains) +Tg = dblarr(np, np, ngauss, nchains) +mu0g = dblarr(np, nchains) +Ug = dblarr(np, np, nchains) +Wg = dblarr(np, np, nchains) + +dist = dblarr(nx, ngauss) +Glabel = intarr(nx, nchains) + +for i = 0, nchains - 1 do begin + + ;randomly choose NGAUSS data points, + ;set these to the group means + ind = lindgen(nx) + unif = randomu(seed, nx) + ind = (ind[sort(unif)])[0:ngauss-1] + + mug[*,*,i] = transpose(x[ind,*]) + + if ngauss gt 1 then begin + ;get distance of data points to each + ;centroid + for k = 0, ngauss - 1 do $ + dist[0,k] = total((x - mug[*,k,i] ## replicate(1d, nx))^2, 2) + + mindist = min(dist, Glabel0, dim=2) ;classify to closest centroid + + Glabel0 = Glabel0 / nx + + endif else Glabel0 = intarr(nx) + + Glabel[0,i] = Glabel0 + +;now get initial guesses for PI and T + + for k = 0, ngauss - 1 do begin + + gk = where(Glabel0 eq k, nk) + + if nk gt np then begin + + pig[k,i] = float(nk) / nx + Tg[*,*,k,i] = correlate(transpose(x[gk,*]), /covar) + + endif else begin + + pig[k,i] = (1d > nk) / nx + Tg[*,*,k,i] = correlate(transpose(x), /covar) + + endelse + + endfor + + pig[*,i] = pig[*,i] / total(pig[*,i]) ;make sure Pi sums to unity + +;now get initial guesses for prior parameters + + mu0g[*,i] = ngauss eq 1 ? mug[*,0,i] : total(mug[*,*,i], 2) / ngauss + Smat = correlate(transpose(x), /covar) + Ug[*,*,i] = randomwish(seed, nx, Smat / nx) + + Wg[*,*,i] = randomwish(seed, nx, Smat / nx) + +endfor + +alpha = alphag +beta = betag +sigsqr = sigsqrg +pi = pig +mu = mug +T = Tg +mu0 = mu0g +U = Ug +W = Wg + ;get inverses of XYVAR +xyvar_inv = xyvar +for i = 0, nx - 1 do begin + + xyvar_inv0 = reform(xyvar[i,*,*]) + mlinmix_posdef_invert, xyvar_inv0 + xyvar_inv[i,*,*] = xyvar_inv0 + +endfor + ;get staring values for eta +eta = dblarr(nx, nchains) +for i = 0, nchains - 1 do eta[*,i] = y + +nut = np ;degrees of freedom for the prior on T +nuu = np ;degrees of freedom for the prior on U + +npar = 2 + np ;number of parameters to monitor convergence on + +convergence = 0 + ;start Markov Chains +if not silent then print, 'Simulating Markov Chains...' + +ygibbs = y + ;define arrays now so we don't have to + ;create them every MCMC iteration +xi = dblarr(nx, np, nchains) +for i = 0, nchains - 1 do xi[*,*,i] = x +xstar = dblarr(nx, np) +mustar = dblarr(nx, np) +gamma = dblarr(nx, ngauss) +nk = fltarr(ngauss) +Tk_inv = dblarr(np, np, ngauss, nchains) +U_inv = dblarr(np, np, nchains) + + ;get various matrix inverses before + ;staring markov chain +for i = 0, nchains - 1 do begin + + for k = 0, ngauss - 1 do begin + + Tk_inv0 = T[*,*,k,i] + mlinmix_posdef_invert, Tk_inv0 + + Tk_inv[*,*,k,i] = Tk_inv0 + + endfor + + U_inv0 = U[*,*,i] + mlinmix_posdef_invert, U_inv0 + U_inv[*,*,i] = U_inv0 + +endfor + +repeat begin + + for i = 0, nchains - 1 do begin ;do markov chains one at-a-time + + W_inv = W[*,*,i] + mlinmix_posdef_invert, W_inv + +;do Gibbs sampler + if ncens gt 0 then begin + ;first get new values of censored y + for j = 0, ncens - 1 do begin + + next = 0 + repeat ygibbs[cens[j]] = eta[cens[j],i] + $ + sqrt(yvar[cens[j]]) * randomn(seed) $ + until ygibbs[cens[j]] le y[cens[j]] + + endfor + + endif + +;need to get new values of Xi and Eta for Gibbs sampler + + ;now draw Xi|mu,covar,x, do this for + ;each covariate at a time + + for j = 0, np - 1 do begin + + case j of + + 0 : inactive = indgen(np - 1) + 1L + np - 1 : inactive = indgen(np - 1) + else : inactive = [indgen(j), indgen(np - j - 1) + j + 1] + + endcase + + xstar[*,j] = x[*,j] + xstar[*,inactive] = x[*,inactive] - xi[*,inactive,i] + + zstar = [[ygibbs - eta[*,i]], [xstar]] + + zmu = total(xyvar_inv[*,*,j+1] * zstar, 2) + + for k = 0, ngauss - 1 do begin ;do one gaussian at-a-time + + gk = where(Glabel[*,i] eq k, ngk) + + if ngk gt 0 then begin + + mustar[gk,j] = mu[j,k,i] + for l = 0, np - 2 do mustar[gk,inactive[l]] = $ + mu[inactive[l],k,i] - xi[gk,inactive[l],i] + + mmu = Tk_inv[*,j,k,i] ## mustar[gk,*] + + etamu = eta[gk,i] - alpha[i] - beta[inactive,i] ## xi[gk,inactive,i] + + xihvar = 1d / (xyvar_inv[gk,j+1,j+1] + Tk_inv[j,j,k,i] + $ + beta[j,i]^2 / sigsqr[i]) + + xihat = xihvar * (zmu[gk] + mmu + beta[j,i] * etamu / (sigsqr[i])) + + xi[gk,j,i] = xihat + sqrt(xihvar) * randomn(seed, nx) + + endif + + endfor + + endfor + ;now draw Eta|Xi,alpha,beta,sigsqr,y + zstar = [[ygibbs], [x - xi[*,*,i]]] + + zmu = total(xyvar_inv[*,*,0] * zstar, 2) + + ximu = (alpha[i] + beta[*,i] ## xi[*,*,i]) / sigsqr[i] + + etahvar = 1d / (xyvar_inv[*,0,0] + 1d / sigsqr[i]) + etahat = etahvar * (zmu + ximu) + + eta[*,i] = etahat + sqrt(etahvar) * randomn(seed, nx) + + ;now draw new class labels + if ngauss eq 1 then Glabel[*,i] = 0 else begin + ;get unnormalized probability that + ;source i came from Gaussian k, given + ;xi[i] + for k = 0, ngauss - 1 do begin + + xicent = xi[*,*,i] - mu[*,k,i] ## replicate(1, nx) + gamma[0,k] = $ + pi[k,i] / ((2d*!pi)^(np/2d) * determ(T[*,*,k,i], /double)) * $ + exp(-0.5 * total(xicent * (Tk_inv[*,*,k,i] ## xicent), 2)) + + endfor + + norm = total(gamma, 2) + + for j = 0, nx - 1 do begin + + gamma0 = reform(gamma[j,*]) / norm[j] ;normalized probability that the i-th + ;data point is from the k-th Gaussian, + ;given the observed data point + Gjk = multinom(1, gamma0, seed=seed) + + Glabel[j,i] = where(Gjk eq 1) + + endfor + + endelse + +;; now draw new values of alpha, beta, and sigsqr + + ;first do alpha,beta|Xi,Eta,sigsqr + + Xmat[*,1:*] = xi[*,*,i] + + hatmat = matrix_multiply(Xmat, Xmat, /atranspose) + Vcoef = hatmat + + choldc, hatmat, P, /double ;solve by cholesky decomposition + coefhat = cholsol( hatmat, P, eta[*,i] ## transpose(Xmat), /double ) + + mlinmix_posdef_invert, Vcoef + Vcoef = Vcoef * sigsqr[i] + + coef = coefhat + mrandomn(seed, Vcoef) + + alpha[i] = coef[0] + beta[*,i] = coef[1:*] + + ;now do sigsqr|xi,eta,alpha,beta, + ;draw sigsqr from a scaled + ;Inverse-chi-square density + resid = eta[*,i] - alpha[i] - beta[*,i] ## xi[*,*,i] + ssqr = total( resid^2 ) / (nx - 2d) + + sigsqr[i] = ssqr * (nx - 2d) / randomchi(seed, nx - 2) + +;; now do mixture model parameters, psi = (pi,mu,tausqr) + + for k = 0, ngauss - 1 do begin + + gk = where(Glabel[*,i] eq k, ngk) + nk[k] = ngk + + if ngk gt 0 then begin + ;get mu|Xi,G,tausqr,mu0,U + + muvar = U_inv[*,*,i] + ngk * Tk_inv[*,*,k,i] + mlinmix_posdef_invert, muvar + + xibar = total(xi[gk,*,i], 1) / ngk + + muhat = (mu0[*,i] ## U_inv[*,*,i] + $ + ngk * (xibar ## Tk_inv[*,*,k,i])) ## muvar + + mu[*,k,i] = muhat + mrandomn(seed, muvar) + + endif else mu[*,k,i] = mu0[*,i] + mrandomn(seed, U[*,*,i]) + + ;get T|Xi,G,mu,W,nut + nuk = ngk + nut + + if ngk gt 0 then begin + + xicent = xi[gk,*,i] - mu[*,k,i] ## replicate(1d, ngk) + + Smat = W[*,*,i] + xicent ## transpose(xicent) + + Smat_inv = Smat + mlinmix_posdef_invert, Smat_inv + + endif else begin + + Smat = W + Smat_inv = W_inv + + endelse + + Tmat = randomwish(seed, nuk, Smat_inv) + + Tk_inv[*,*,k,i] = Tmat + mlinmix_posdef_invert, Tmat + T[*,*,k,i] = Tmat + + endfor + ;get pi|G + if ngauss eq 1 then pi[*,i] = 1d else $ + pi[*,i] = randomdir(seed, nk + 1) + +;; now, finally update the prior parameters + + ;first update mean of gaussian + ;centroids + mu0[*,i] = ngauss eq 1 ? mu[*,0,i] + mrandomn(seed, U[*,*,i]) : $ + total(mu[*,*,i], 2) / ngauss + mrandomn(seed, U[*,*,i] / ngauss) + + ;update centroid covariance matrix, U + nu = ngauss + nuu + + mucent = ngauss eq 1 ? transpose(mu[*,0,i] - mu0[*,i]) : $ + transpose(mu[*,*,i]) - mu0[*,i] ## replicate(1d, ngauss) + + Uhat = W[*,*,i] + mucent ## transpose(mucent) + + mlinmix_posdef_invert, Uhat + Umat = randomwish(seed, nu, Uhat) + + U_inv[*,*,i] = Umat + mlinmix_posdef_invert, Umat + U[*,*,i] = Umat + + ;update the common scale matrix, W + nuw = (ngauss + 2) * np + 1 + What = ngauss eq 1 ? U_inv[*,*,i] + Tk_inv[*,*,0,i] : $ + U_inv[*,*,i] + total(Tk_inv[*,*,*,i], 3) + + mlinmix_posdef_invert, What + + W[*,*,i] = randomwish(seed, nuw, What) + + endfor + ;save Markov Chains + if iter eq 0 then begin + + alphag = alpha + betag = beta[*] + sigsqrg = sigsqr + + pig = pi[*] + mug = mu[*] + Tg = T[*] + + mu0g = mu0[*] + Ug = U[*] + Wg = W[*] + + endif else begin + + alphag = [alphag, alpha] + betag = [betag, beta[*]] + sigsqrg = [sigsqrg, sigsqr] + + pig = [pig, pi[*]] + mug = [mug, mu[*]] + Tg = [Tg, T[*]] + + mu0g = [mu0g, mu0[*]] + Ug = [Ug, U[*]] + Wg = [Wg, W[*]] + + endelse + + iter = iter + 1L + +;check for convergence + + if iter ge 4 then begin + + Bvar = dblarr(npar) ;between-chain variance + Wvar = dblarr(npar) ;within-chain variance + + ndraw = n_elements(alphag) / nchains + + psi = dblarr(npar, nchains, ndraw) + psi[0,*,*] = reform(alphag, nchains, ndraw) + psi[1:np,*,*] = reform(betag, np, nchains, ndraw) + psi[np+1,*,*] = alog(reform(sigsqrg, nchains, ndraw)) + + psi = psi[*,*,(ndraw+1)/2:*] + ndraw = ndraw / 2 + ;calculate between- and within-sequence + ; variances + for j = 0, npar - 1 do begin + + psibarj = total( psi[j,*,*], 3 ) / ndraw + psibar = mean(psibarj) + + sjsqr = 0d + for i = 0, nchains - 1 do $ + sjsqr = sjsqr + total( (psi[j, i, *] - psibarj[i])^2 ) / (ndraw - 1.0) + + Bvar[j] = ndraw / (nchains - 1.0) * total( (psibarj - psibar)^2 ) + Wvar[j] = sjsqr / nchains + + endfor + + varplus = (1.0 - 1d / ndraw) * Wvar + Bvar / ndraw + Rhat = sqrt( varplus / Wvar ) ;potential variance scale reduction factor + + endif + + if iter eq checkiter then begin +;maximum iterations reached, now assess convergence + + if (total( (Rhat le 1.1) ) eq npar and iter ge miniter) or $ + iter ge maxiter then convergence = 1 $ + else begin + + if not silent then begin + print, 'Iteration: ', iter + print, 'Rhat Values (ALPHA, BETA, SIGSQR) : ' + print, Rhat + endif + + checkiter = checkiter + 100L + + endelse + + endif + +endrep until convergence + +ndraw = n_elements(alphag) / nchains + +alphag = reform(alphag, nchains, ndraw) +betag = reform(betag, np, nchains, ndraw) +sigsqrg = reform(sigsqrg, nchains, ndraw) + +pig = reform(pig, ngauss, nchains, ndraw) +mug = reform(mug, np, ngauss, nchains, ndraw) +Tg = reform(Tg, np, np, ngauss, nchains, ndraw) + +mu0g = reform(mu0g, np, nchains, ndraw) +Ug = reform(Ug, np, np, nchains, ndraw) +Wg = reform(Wg, np, np, nchains, ndraw) + +;only keep second half of markov chains +alphag = alphag[*,(ndraw+1)/2:*] +betag = betag[*,*,(ndraw+1)/2:*] +sigsqrg = sigsqrg[*,(ndraw+1)/2:*] +pig = pig[*,*,(ndraw+1)/2:*] +mug = mug[*,*,*,(ndraw+1)/2:*] +Tg = Tg[*,*,*,*,(ndraw+1)/2:*] +mu0g = mu0g[*,*,(ndraw+1)/2:*] +Ug = Ug[*,*,*,(ndraw+1)/2:*] +Wg = Wg[*,*,*,(ndraw+1)/2:*] + +if not silent then begin + print, 'Iteration: ', iter + print, 'Rhat Values (ALPHA, BETA, SIGSQR) : ', Rhat +endif + +;save posterior draws in a structure +ndraw = ndraw / 2 + + +if ngauss gt 1 then $ + post = {alpha:0d, beta:dblarr(np), sigsqr:0d, pi:dblarr(ngauss), mu:dblarr(np,ngauss), $ + T:dblarr(np,np,ngauss), mu0:dblarr(np), U:dblarr(np,np), W:dblarr(np,np), $ + ximean:dblarr(np), xivar:dblarr(np,np), xicorr:dblarr(np,np), corr:dblarr(np), $ + pcorr:dblarr(np)} $ +else $ + post = {alpha:0d, beta:dblarr(np), sigsqr:0d, pi:0d, mu:dblarr(np), $ + T:dblarr(np,np), mu0:dblarr(np), U:dblarr(np,np), W:dblarr(np,np), $ + ximean:dblarr(np), xivar:dblarr(np,np), xicorr:dblarr(np,np), corr:dblarr(np), $ + pcorr:dblarr(np)} + +post = replicate(post, ndraw * nchains) + +post.alpha = alphag[*] +post.beta = reform(betag, np, ndraw * nchains) +post.sigsqr = sigsqrg[*] + +if ngauss gt 1 then begin + + post.pi = reform(pig, ngauss, ndraw * nchains) + post.mu = reform(mug, np, ngauss, ndraw * nchains) + post.T = reform(Tg, np, np, ngauss, ndraw * nchains) + +endif else begin + + post.pi = reform(pig, ndraw * nchains) + post.mu = reform(mug, np, ndraw * nchains) + post.T = reform(Tg, np, np, ndraw * nchains) + +endelse + +post.mu0 = reform(mu0g, np, ndraw * nchains) +post.U = reform(Ug, np, np, ndraw * nchains) +post.W = reform(Wg, np, np, ndraw * nchains) + +;get posterior draws of moments of distribution + +if not silent then print, 'Getting Posterior Draws for Various Moments...' + +corrmat = dblarr(np+1,np+1) + +for i = 0, ndraw * nchains - 1 do begin + ;average value of Xi + post[i].ximean = ngauss gt 1 ? post[i].pi ## post[i].mu : post[i].mu + + if ngauss eq 1 then post[i].xivar = post[i].T else begin + + for k = 0, ngauss - 1 do post[i].xivar = post[i].xivar + $ + post[i].pi[k] * (post[i].T[*,*,k] + transpose(post[i].mu[*,k]) ## post[i].mu[*,k]) + ;covariance matrix of Xi + post[i].xivar = post[i].xivar - transpose(post[i].ximean) ## post[i].ximean + + endelse + + xivar = post[i].xivar + + ;variance in Eta + etavar = post[i].beta ## post[i].xivar ## transpose(post[i].beta) + post[i].sigsqr + ;correlation coefficients between Eta + ;and Xi + post[i].corr = post[i].beta ## post[i].xivar / $ + sqrt( etavar[0] * post[i].xivar[diag] ) + ;correlation matrix of the covariates + post[i].xicorr = xivar * ( transpose(1d / sqrt(xivar[diag])) ## (1d / sqrt(xivar[diag])) ) + ;now get partial correlations, need + ;full correlation matrix first + corrmat[0,0] = 1d + corrmat[1:*,0] = post[i].corr + corrmat[0,1:*] = post[i].corr + corrmat[1:*,1:*] = post[i].xicorr + + mlinmix_posdef_invert, corrmat + + post[i].pcorr = -1d * corrmat[1:*,0] / sqrt(corrmat[0,0] * corrmat[diag2[1:*]]) + +endfor + +return +end diff --git a/modules/idl_downloads/astro/pro/mmm.pro b/modules/idl_downloads/astro/pro/mmm.pro new file mode 100644 index 0000000..cd0dd15 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mmm.pro @@ -0,0 +1,310 @@ +pro mmm, sky_vector, skymod, sigma , skew, HIGHBAD = highbad, DEBUG = debug, $ + ReadNoise = readnoise, Nsky = nsky, INTEGER = discrete, $ + MAXITER = mxiter, SILENT = silent, MINSKY = minsky +;+ +; NAME: +; MMM +; PURPOSE: +; Estimate the sky background in a stellar contaminated field. +; EXPLANATION: +; MMM assumes that contaminated sky pixel values overwhelmingly display +; POSITIVE departures from the true value. Adapted from DAOPHOT +; routine of the same name. +; +; CALLING SEQUENCE: +; MMM, sky, [ skymod, sigma, skew, HIGHBAD = , READNOISE=, /DEBUG, +; MINSKY=, NSKY=, /INTEGER,/SILENT] +; +; INPUTS: +; SKY - Array or Vector containing sky values. This version of +; MMM does not require SKY to be sorted beforehand. SKY +; is unaltered by this program. +; +; OPTIONAL OUTPUTS: +; skymod - Scalar giving estimated mode of the sky values (float) +; SIGMA - Scalar giving standard deviation of the peak in the sky +; histogram. If for some reason it is impossible to derive +; skymod, then SIGMA = -1.0 +; SKEW - Scalar giving skewness of the peak in the sky histogram +; +; If no output variables are supplied or if /DEBUG is set +; then the values of skymod, SIGMA and SKEW will be printed. +; +; OPTIONAL KEYWORD INPUTS: +; HIGHBAD - scalar value of the (lowest) "bad" pixel level (e.g. cosmic +; rays or saturated pixels) If not supplied, then there is +; assumed to be no high bad pixels. +; MINSKY - Integer giving mininum number of sky values to be used. MMM +; will return an error if fewer sky elements are supplied. +; Default = 20. +; MAXITER - integer giving maximum number of iterations allowed,default=50 +; READNOISE - Scalar giving the read noise (or minimum noise for any +; pixel). Normally, MMM determines the (robust) median by +; averaging the central 20% of the sky values. In some cases +; where the noise is low, and pixel values are quantized a +; larger fraction may be needed. By supplying the optional +; read noise parameter, MMM is better able to adjust the +; fraction of pixels used to determine the median. +; /INTEGER - Set this keyword if the input SKY vector only contains +; discrete integer values. This keyword is only needed if the +; SKY vector is of type float or double precision, but contains +; only discrete integer values. (Prior to July 2004, the +; equivalent of /INTEGER was set for all data types) +; /DEBUG - If this keyword is set and non-zero, then additional +; information is displayed at the terminal. +; /SILENT - If set, then error messages will be suppressed when MMM +; cannot compute a background. Sigma will still be set to -1 +; OPTIONAL OUTPUT KEYWORD: +; NSKY - Integer scalar giving the number of pixels actually used for the +; sky computation (after outliers have been removed). +; NOTES: +; (1) Program assumes that low "bad" pixels (e.g. bad CCD columns) have +; already been deleted from the SKY vector. +; (2) MMM was updated in June 2004 to better match more recent versions +; of DAOPHOT. +; (3) Does not work well in the limit of low Poisson integer counts +; (4) MMM may fail for strongly skewed distributions. +; METHOD: +; The algorithm used by MMM consists of roughly two parts: +; (1) The average and sigma of the sky pixels is computed. These values +; are used to eliminate outliers, i.e. values with a low probability +; given a Gaussian with specified average and sigma. The average +; and sigma are then recomputed and the process repeated up to 20 +; iterations: +; (2) The amount of contamination by stars is estimated by comparing the +; mean and median of the remaining sky pixels. If the mean is larger +; than the median then the true sky value is estimated by +; 3*median - 2*mean +; +; REVISION HISTORY: +; Adapted to IDL from 1986 version of DAOPHOT in STSDAS, +; W. Landsman, STX Feb 1987 +; Added HIGHBAD keyword, W. Landsman January, 1991 +; Fixed occasional problem with integer inputs W. Landsman Feb, 1994 +; Avoid possible 16 bit integer overflow W. Landsman November 2001 +; Added READNOISE, NSKY keywords, new median computation +; W. Landsman June 2004 +; Added INTEGER keyword W. Landsman July 2004 +; Improve numerical precision W. Landsman October 2004 +; Fewer aborts on strange input sky histograms W. Landsman October 2005 +; Added /SILENT keyword November 2005 +; Fix too many /CON keywords to MESSAGE W.L. December 2005 +; Fix bug introduced June 2004 removing outliers when READNOISE not set +; N. Cunningham/W. Landsman January 2006 +; Make sure that MESSAGE never aborts W. Landsman January 2008 +; Add mxiter keyword and change default to 50 W. Landsman August 2011 +; Added MINSKY keyword W.L. December 2011 +; Always return floating point sky mode W.L. December 2015 +;- + compile_opt idl2 + On_error,2 ;Return to caller + if N_params() EQ 0 then begin + print,'Syntax: MMM, sky, skymod, sigma, skew, [/INTEGER, /SILENT' + print,' [HIGHBAD = , READNOISE =, /DEBUG, MXITER=, NSKY=] ' + return + endif + + silent = keyword_set(SILENT) + ;Maximum number of iterations allowed + if N_elements(mxiter) EQ 0 then mxiter = 50 + if N_elements(minsky) Eq 0 then minsky = 20 ;Minimum number of legal sky elements + nsky = N_elements( sky_vector ) ;Get number of sky elements + + if nsky LT minsky then begin + sigma=-1.0 & skew = 0.0 + message,/CON, NoPrint= Silent, $ + 'ERROR -Input vector must contain at least '+strtrim(minsky,2)+' elements' + return + endif + + nlast = nsky-1 ;Subscript of last pixel in SKY array + if keyword_set(DEBUG) then $ + message,'Processing '+strtrim(nsky,2) + ' element array',/INF + sz_sky = size(sky_vector,/structure) + integer = keyword_set(discrete) + if ~integer then integer = (sz_sky.type LT 4) or (sz_sky.type GT 11) + sky = sky_vector[ sort( sky_vector ) ] ;Sort SKY in ascending values + + skymid = 0.5*sky[(nsky-1)/2] + 0.5*sky[nsky/2] ;Median value of all sky values + + cut1 = min( [skymid-sky[0],sky[nsky-1] - skymid] ) + if N_elements(highbad) EQ 1 then cut1 = cut1 < (highbad - skymid) + cut2 = skymid + cut1 + cut1 = skymid - cut1 + +; Select the pixels between Cut1 and Cut2 + + good = where( (sky LE cut2) and (sky GE cut1), Ngood ) + if ( Ngood EQ 0 ) then begin + sigma=-1.0 & skew = 0.0 + message,/CON, NoPrint=Silent, $ + 'ERROR - No sky values fall within ' + strtrim(cut1,2) + $ + ' and ' + strtrim(cut2,2) + return + endif + + delta = sky[good] - skymid ;Subtract median to improve arithmetic accuracy + sum = total(delta,/double) + sumsq = total(delta^2,/double) + + maximm = max( good,MIN=minimm ) ;Highest value accepted at upper end of vector + minimm = minimm -1 ;Highest value reject at lower end of vector + +; Compute mean and sigma (from the first pass). + + skymed = 0.5*sky[(minimm+maximm+1)/2] + 0.5*sky[(minimm+maximm)/2 + 1] ;median + skymn = float(sum/(maximm-minimm)) ;mean + sigma = sqrt(sumsq/(maximm-minimm)-skymn^2) ;sigma + skymn = skymn + skymid ;Add median which was subtracted off earlier + + +; If mean is less than the mode, then the contamination is slight, and the +; mean value is what we really want. +skymod = (skymed LT skymn) ? 3.*skymed - 2.*skymn : skymn + +; Rejection and recomputation loop: + + niter = 0 + clamp = 1 + old = 0 +START_LOOP: + niter = niter + 1 + if ( niter GT mxiter ) then begin + sigma=-1.0 & skew = 0.0 + message,/CON, NoPrint=Silent, $ + 'ERROR - Too many ('+strtrim(mxiter,2) + ') iterations,' + $ + ' unable to compute sky' + return + endif + + if ( maximm-minimm LT minsky ) then begin ;Error? + + sigma = -1.0 & skew = 0.0 + message,/CON,NoPrint=Silent, $ + 'ERROR - Too few ('+strtrim(maximm-minimm,2) + $ + ') valid sky elements, unable to compute sky' + return + endif + +; Compute Chauvenet rejection criterion. + + r = alog10( float( maximm-minimm ) ) + r = max( [ 2., ( -0.1042*r + 1.1695)*r + 0.8895 ] ) + +; Compute rejection limits (symmetric about the current mode). + + cut = r*sigma + 0.5*abs(skymn-skymod) + if integer then cut = cut > 1.5 + cut1 = skymod - cut & cut2 = skymod + cut +; +; Recompute mean and sigma by adding and/or subtracting sky values +; at both ends of the interval of acceptable values. + + redo = 0B + newmin = minimm + tst_min = sky[newmin+1] GE cut1 ;Is minimm+1 above current CUT? + done = (newmin EQ -1) and tst_min ;Are we at first pixel of SKY? + if ~done then $ + done = (sky[newmin>0] LT cut1) and tst_min + if ~done then begin + istep = 1 - 2*fix(tst_min) + repeat begin + newmin = newmin + istep + done = (newmin EQ -1) || (newmin EQ nlast) + if ~done then $ + done = (sky[newmin] LE cut1) and (sky[newmin+1] GE cut1) + endrep until done + if tst_min then delta = sky[newmin+1:minimm] - skymid $ + else delta = sky[minimm+1:newmin] - skymid + sum = sum - istep*total(delta,/double) + sumsq = sumsq - istep*total(delta^2,/double) + redo = 1b + minimm = newmin + endif +; + newmax = maximm + tst_max = sky[maximm] LE cut2 ;Is current maximum below upper cut? + done = (maximm EQ nlast) and tst_max ;Are we at last pixel of SKY array? + if ~done then $ + done = ( tst_max ) && (sky[(maximm+1)0 )) + skymn = skymn + skymid + + +; Determine a more robust median by averaging the central 20% of pixels. +; Estimate the median using the mean of the central 20 percent of sky +; values. Be careful to include a perfectly symmetric sample of pixels about +; the median, whether the total number is even or odd within the acceptance +; interval + + center = (minimm + 1 + maximm)/2. + side = round(0.2*(maximm-minimm))/2. + 0.25 + J = round(CENTER-SIDE) + K = round(CENTER+SIDE) + +; In case the data has a large number of of the same (quantized) +; intensity, expand the range until both limiting values differ from the +; central value by at least 0.25 times the read noise. + + if keyword_set(readnoise) then begin + L = round(CENTER-0.25) + M = round(CENTER+0.25) + R = 0.25*readnoise + while ((J GT 0) && (K LT Nsky-1) && $ + ( ((sky[L] - sky[J]) LT R) || ((sky[K] - sky[M]) LT R))) do begin + J-- + K++ + endwhile + endif + skymed = total(sky[j:k])/(k-j+1) + +; If the mean is less than the median, then the problem of contamination +; is slight, and the mean is what we really want. + + dmod = skymed LT skymn ? 3.*skymed-2.*skymn-skymod : skymn - skymod + +; prevent oscillations by clamping down if sky adjustments are changing sign + if dmod*old LT 0 then clamp = 0.5*clamp + skymod = skymod + clamp*dmod + old = dmod + if redo then goto, START_LOOP + +; + skew = float( (skymn-skymod)/max([1.,sigma]) ) + nsky = maximm - minimm + + if keyword_set(DEBUG) or ( N_params() EQ 1 ) then begin + print, '% MMM: Number of unrejected sky elements: ', strtrim(nsky,2), $ + ' Number of iterations: ', strtrim(niter,2) + print, '% MMM: Mode, Sigma, Skew of sky vector:', skymod, sigma, skew + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/modfits.pro b/modules/idl_downloads/astro/pro/modfits.pro new file mode 100644 index 0000000..a922f9b --- /dev/null +++ b/modules/idl_downloads/astro/pro/modfits.pro @@ -0,0 +1,321 @@ +pro MODFITS, filename, data, header, EXTEN_NO = exten_no, ERRMSG = errmsg, $ + EXTNAME = extname + +;+ +; NAME: +; MODFITS +; PURPOSE: +; Modify a FITS file by updating the header and/or data array. +; EXPLANATION: +; Update the data and/or header in a specified FITS extension or primary +; HDU. +; +; The size of the supplied FITS header or data array does not +; need to match the size of the existing header or data array. +; +; CALLING SEQUENCE: +; MODFITS, Filename_or_fcb, Data, [ Header, EXTEN_NO =, EXTNAME= , ERRMSG=] +; +; INPUTS: +; FILENAME/FCB = Scalar string containing either the name of the FITS file +; to be modified, or the IO file control block returned after +; opening the file with FITS_OPEN,/UPDATE. The explicit +; use of FITS_OPEN can save time if many extensions in a +; single file will be updated. +; +; DATA - data array to be inserted into the FITS file. Set DATA = 0 +; to leave the data portion of the FITS file unmodified. Data +; can also be an IDL structure (e.g. as returned by MRDFITS). +; provided that it does not include IDL pointers. +; +; HEADER - FITS header (string array) to be updated in the FITS file. +; +; OPTIONAL INPUT KEYWORDS: +; A specific extension can be specified with either the EXTNAME or +; EXTEN_NO keyword +; +; EXTEN_NO - scalar integer specifying the FITS extension to modified. For +; example, specify EXTEN = 1 or /EXTEN to modify the first +; FITS extension. +; EXTNAME - string name of the extension to modify. +; +; +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG - If this keyword is supplied, then any error mesasges will be +; returned to the user in this parameter rather than depending on +; on the MESSAGE routine in IDL. If no errors are encountered +; then a null string is returned. +; +; EXAMPLES: +; (1) Modify the value of the DATE keyword in the primary header of a +; file TEST.FITS. +; +; IDL> h = headfits('test.fits') ;Read primary header +; IDL> sxaddpar,h,'DATE','2015-03-23' ;Modify value of DATE +; IDL> modfits,'test.fits',0,h ;Update header only +; +; (2) Replace the values of the primary image array in 'test.fits' with +; their absolute values +; +; IDL> im = readfits('test.fits') ;Read image array +; IDL> im = abs(im) ;Take absolute values +; IDL> modfits,'test.fits',im ;Update image array +; +; (3) Add some HISTORY records to the FITS header in the first extension +; of a file 'test.fits' +; +; IDL> h = headfits('test.fits',/ext) ;Read first extension hdr +; IDL> sxaddhist,['Comment 1','Comment 2'],h +; IDL> modfits,'test.fits',0,h,/ext ;Update extension hdr +; +; (4) Change 'OBSDATE' keyword to 'OBS-DATE' in every extension in a +; FITS file. Explicitly open with FITS_OPEN to save compute time. +; +; fits_open,'test.fits',io,/update ;Faster to explicity open +; for i = 1,nextend do begin ;Loop over extensions +; fits_read,io,0,h,/header_only,exten_no=i,/No_PDU ;Get header +; date= sxpar(h,'OBSDATE') ;Save keyword value +; sxaddpar,h,'OBS-DATE',date,after='OBSDATE' +; sxdelpar,h,'OBSDATE' ;Delete bad keyword +; modfits,io,0,h,exten_no=i ;Update header +; endfor +; +; Note the use of the /No_PDU keyword in the FITS_READ call -- one +; does *not* want to append the primary header, if the STScI +; inheritance convention is adopted. +; +; NOTES: +; Uses the BLKSHIFT procedure to shift the contents of the FITS file if +; the new data or header differs in size by more than 2880 bytes from the +; old data or header. If a file control block (FCB) structure is +; supplied, then the values of START_HEADER, START_DATA and NBYTES may +; be modified if the file size changes. +; +; Also see the procedures FXHMODIFY to add a single FITS keyword to a +; header in a FITS files, and FXBGROW to enlarge the size of a binary +; table. +; +; RESTRICTIONS: +; (1) Cannot be used to modify the data in FITS files with random +; groups or variable length binary tables. (The headers in such +; files *can* be modified.) +; +; (2) If a data array but no FITS header is supplied, then MODFITS does +; not check to make sure that the existing header is consistent with +; the new data. +; +; (3) Does not work with compressed files +; +; (4) The Checksum keywords will not be updated if the array to be +; updated is supplied as a structure (e.g. from MRDFITS). +; PROCEDURES USED: +; Functions: N_BYTES(), SXPAR() +; Procedures: BLKSHIFT, CHECK_FITS, FITS_OPEN, FITS_READ. SETDEFAULTVALUE +; +; MODIFICATION HISTORY: +; Written, Wayne Landsman December, 1994 +; Fixed possible problem when using WRITEU after READU October 1997 +; New and old sizes need only be the same within multiple of 2880 bytes +; Added call to IS_IEEE_BIG() W. Landsman May 1999 +; Added ERRMSG output keyword W. Landsman May 2000 +; Update tests for incompatible sizes W. Landsman December 2000 +; Major rewrite to use FITS_OPEN procedures W. Landsman November 2001 +; Add /No_PDU call to FITS_READ call W. Landsman June 2002 +; Update CHECKSUM keywords if already present in header, add padding +; if new data size is smaller than old W.Landsman December 2002 +; Only check XTENSION value if EXTEN_NO > 1 W. Landsman Feb. 2003 +; Correct for unsigned data on little endian machines W. Landsman Apr 2003 +; Major rewrite to allow changing size of data or header W.L. Aug 2003 +; Fixed case where updated header exactly fills boundary W.L. Feb 2004 +; More robust error reporting W.L. Dec 2004 +; Make sure input header ends with a END W.L. March 2006 +; Assume since V5.5, remove VMS support, assume FITS_OPEN will +; perform byte swapping W.L. Sep 2006 +; Update FCB structure if file size changes W.L. March 2007 +; Fix problem when data size must be extended W.L. August 2007 +; Don't assume supplied FITS header is 80 bytes W. L. Dec 2007 +; Check for new END position after adding CHECKSUM W.L. July 2008 +; Added EXTNAME input keyword W.L. July 2008 +; Allow data to be an IDL structure A. Conley/W.L. June 2009 +; Use V6.0 notation, add /NOZERO to BLKSHIFT W.L. Feb 2011 +; Don't try to update Checksums when structure supplied W.L. April 2011 +; Allow structure with only 1 element W.L. Feb 2012 +; Don't require that a FITS header is supplied W.L. Feb 2016 +;- + On_error,2 ;Return to user + compile_opt idl2 + +; Check for filename input + + if N_params() LT 1 then begin + print,'Syntax - ' + $ + 'MODFITS, Filename, Data, [ Header, EXTEN_NO=, EXTNAME=, ERRMSG= ]' + return + endif + + setdefaultvalue, exten_no, 0 + setdefaultvalue, Header, 0 + nheader = N_elements(Header) + updated = 0b + +;Make sure END statement is the last line in supplied FITS header + + if nheader GT 1 then begin + endline = where( strmid(Header,0,8) EQ 'END ', Nend) + if Nend EQ 0 then begin + message,/INF, $ + 'WARNING - An END statement has been appended to the FITS header' + Header = [ Header, 'END' + string( replicate(32b,77) ) ] + endif else header = header[0:endline] + endif + + ndata = N_elements(data) + dtype = size(data,/TNAME) + printerr = ~arg_present(ERRMSG) + fcbsupplied = size(filename,/TNAME) EQ 'STRUCT' + + if (nheader GT 1) && (ndata GT 1) && (dtype NE 'STRUCT') then begin + check_fits, data, header, /FITS, ERRMSG = MESSAGE + if message NE '' then goto, BAD_EXIT + endif + +; Open file and read header information + + if (exten_no EQ 0) && (~keyword_set(EXTNAME)) then begin + if nheader GT 0 then $ + if strmid( header[0], 0, 8) NE 'SIMPLE ' then begin + message = $ + 'Input header does not contain required SIMPLE keyword' + goto, BAD_EXIT + endif + endif else begin + if nheader GT 1 then $ + if strmid( header[0], 0, 8) NE 'XTENSION' then begin + message = $ + 'Input header does not contain required XTENSION keyword' + goto, BAD_EXIT + endif + endelse + +; Was a file name or file control block supplied? + + if ~fcbsupplied then begin + fits_open, filename, io,/update,/No_Abort,message=message + if message NE '' then GOTO, BAD_EXIT + endif else begin + if filename.open_for_write EQ 0 then begin + message = 'FITS file is set for READONLY, cannot be updated' + goto, BAD_EXIT + endif + io = filename + endelse + +; Getting starting position of data and header + + if keyword_set(extname) then begin + exten_no = where( strupcase(io.extname) EQ strupcase(extname), Nfound) + if Nfound EQ 0 then begin + message,'Extension name ' + extname + ' not found in FITS file' + GOTO, BAD_EXIT + endif + endif + unit = io.unit + start_d = io.start_data[exten_no] + if exten_no NE io.nextend then begin + start_h = io.start_header[exten_no+1] + nbytes = start_h - start_d + endif else nbytes = N_BYTES(data) + + FITS_READ,Io,0,oldheader,/header_only, exten=exten_no, /No_PDU, $ + message = message,/no_abort + if message NE '' then goto, BAD_EXIT + dochecksum = sxpar(oldheader,'CHECKSUM', Count = N_checksum) + checksum = N_checksum GT 0 + + +; Update header, including any CHECKSUM keywords if present + + if nheader GT 1 then begin + noldheader = start_d - io.start_header[exten_no] + + if dtype EQ 'UINT' then $ + sxaddpar,header,'BZERO',32768,'Data is unsigned integer' + if dtype EQ 'ULONG' then $ + sxaddpar,header,'BZERO',2147483648,'Data is unsigned long' + if checksum then begin + if (Ndata GT 1) && (dtype NE 'STRUCT') then $ + FITS_ADD_CHECKSUM, header, data else $ + FITS_ADD_CHECKSUM, header + endif +; Position of 'END' card may have changed - Bug fix July 2008 + endline = where( strmid(Header,0,8) EQ 'END ', Nend) + + newbytes = N_elements(header)*80 + block = (newbytes-1)/2880 - (Noldheader-1)/2880 + if block NE 0 then begin + BLKSHIFT, io.unit, start_d, block*2880L, /NOZERO + start_d += block*2880L + io.start_data[exten_no:*] += block*2880L + io.nbytes += block*2880L + if exten_no NE io.nextend then begin + start_h += block*2880L + io.start_header[exten_no+1:*] += block*2880L + endif + endif + point_lun, unit, io.start_header[exten_no] ;Position header start + bhdr = replicate(32b, newbytes) + for n = 0l, endline[0] do bhdr[80*n] = byte( header[n] ) + writeu, unit, bhdr + remain = newbytes mod 2880 + if remain GT 0 then writeu, unit, replicate( 32b, 2880 - remain) + updated = 1b + + endif + + if (ndata GT 1) || (dtype EQ 'STRUCT') then begin + + newbytes = N_BYTES(data) ;total number of bytes in supplied data + block = (newbytes-1)/2880 - (nbytes-1)/2880 + if (block NE 0) && (exten_no NE io.nextend) then begin + BLKSHIFT, io.unit, start_h, block*2880L,/NOZERO + io.nbytes += block*2880L + io.start_header[exten_no+1:*] += block*2880L + io.start_data[exten_no+1:*] += block*2880L + endif + + if (nheader EQ 0) && (dtype NE 'STRUCT') then begin + check_fits,data,oldheader,/FITS,ERRMSG = message + if message NE '' then goto, BAD_EXIT + endif + + junk = fstat(unit) ;Need this before changing from READU to WRITEU + point_lun, unit, start_d + if dtype EQ 'UINT' then newdata = fix(data - 32768) + if dtype EQ 'ULONG' then newdata = long(data - 2147483648) + if N_elements(newdata) GT 0 then writeu, unit, newdata else $ + writeu, unit ,data + remain = newbytes mod 2880 + if remain GT 0 then begin + padnum = 0b + if exten_no GT 0 then begin + exten = sxpar( oldheader, 'XTENSION') + if exten EQ 'TABLE ' then padnum = 32b + endif + writeu, unit, replicate( padnum, 2880 - remain) + endif + updated = 1b + endif + + if ~fcbsupplied then FITS_CLOSE,io else filename = io + if ~updated then message,'FITS file not modified',/INF + + + return + +BAD_EXIT: + if N_elements(io) GT 0 then if ~fcbsupplied then fits_close,io + if printerr then message,'ERROR - ' + message,/CON else errmsg = message + if fcbsupplied then fname = filename.filename else fname = filename + message,'FITS file ' + fname + ' not modified',/INF + return + end diff --git a/modules/idl_downloads/astro/pro/month_cnv.pro b/modules/idl_downloads/astro/pro/month_cnv.pro new file mode 100644 index 0000000..39a771b --- /dev/null +++ b/modules/idl_downloads/astro/pro/month_cnv.pro @@ -0,0 +1,68 @@ +function month_cnv, MonthInput, Up=Up, Low=Low, Short=Short +;\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\ +;+ +; NAME: +; MONTH_CNV +; PURPOSE: +; Convert between a month name and the equivalent number +; EXPLANATION: (e.g., +; For example, converts from 'January' to 1 or vice-versa. +; CALLING SEQUENCE: +; Result = MONTH_CNV( MonthInput, [/UP, /LOW, /SHORT ] ) +; INPUTS: +; MonthInput - either a string ('January', 'Jan', 'Decem', etc.) or +; an number from 1 to 12. Scalar or array. +; OPTIONAL KEYWORDS: +; UP - if set and if a string is being returned, it will be in all +; uppercase letters. +; LOW - if set and if a string is being returned, it will be in all +; lowercase letters. +; SHORT - if set and if a string is being returned, only the first +; three letters are returned. +; +; OUTPUTS: +; If the input is a string, the output is the matching month number.If +; an input string isn't a valid month name, -1 is returned. +; If the input is a number, the output is the matching month name. The +; default format is only the first letter is capitalized. +; EXAMPLE: +; To get a vector of all the month names: +; Names = month_cnv(indgen(12)+1) +; +; MODIFICATION HISTORY: +; Written by: Joel Wm. Parker, SwRI, 1998 Dec 9 +;- +;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ + +NumElem = n_elements(MonthInput) + +MonthNames = [' ', 'January', 'February', 'March', 'April', 'May', 'June', $ + 'July', 'August', 'September', 'October', 'November', 'December'] +MonthShort = strupcase(strmid(MonthNames,0,3)) + + +if size(MonthInput,/TNAME) EQ 'STRING' then begin + Result = intarr(NumElem) - 1 + ShortInput = strupcase(strmid(strtrim(MonthInput,2),0,3)) + for N=1,12 do begin + Mask = where(MonthShort[N] eq ShortInput) + if (Mask[0] ne -1) then Result[Mask] = N + endfor +endif else begin + if ( (min(MonthInput) lt 1) or (max(MonthInput) gt 12) ) then begin + message, /CON, "Bad input values. Month numbers must be 1-12." + Result = '' + endif else begin + Result = MonthNames[MonthInput] + if keyword_set(Short) then Result = strmid(Result,0,3) + if keyword_set(Up) then Result = strupcase(Result) + if keyword_set(Low) then Result = strlowcase(Result) + endelse +endelse + +if (NumElem eq 1) then Result = Result[0] + +return, Result +end ; function MONTH_CNV + + diff --git a/modules/idl_downloads/astro/pro/moonpos.pro b/modules/idl_downloads/astro/pro/moonpos.pro new file mode 100644 index 0000000..3b026f8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/moonpos.pro @@ -0,0 +1,250 @@ + PRO MOONPOS, jd, ra, dec, dis, geolong, geolat, RADIAN = radian +;+ +; NAME: +; MOONPOS +; PURPOSE: +; To compute the RA and Dec of the Moon at specified Julian date(s). +; +; CALLING SEQUENCE: +; MOONPOS, jd, ra, dec, dis, geolong, geolat, [/RADIAN ] +; +; INPUTS: +; JD - Julian ephemeris date, scalar or vector, double precision suggested +; +; OUTPUTS: +; Ra - Apparent right ascension of the moon in DEGREES, referred to the +; true equator of the specified date(s) +; Dec - The declination of the moon in DEGREES +; Dis - The Earth-moon distance in kilometers (between the center of the +; Earth and the center of the Moon). +; Geolong - Apparent longitude of the moon in DEGREES, referred to the +; ecliptic of the specified date(s) +; Geolat - Apparent longitude of the moon in DEGREES, referred to the +; ecliptic of the specified date(s) +; +; The output variables will all have the same number of elements as the +; input Julian date vector, JD. If JD is a scalar then the output +; variables will be also. +; +; OPTIONAL INPUT KEYWORD: +; /RADIAN - If this keyword is set and non-zero, then all output variables +; are given in Radians rather than Degrees +; +; EXAMPLES: +; (1) Find the position of the moon on April 12, 1992 +; +; IDL> jdcnv,1992,4,12,0,jd ;Get Julian date +; IDL> moonpos, jd, ra ,dec ;Get RA and Dec of moon +; IDL> print,adstring(ra,dec,1) +; ==> 08 58 45.23 +13 46 6.1 +; +; This is within 1" from the position given in the Astronomical Almanac +; +; (2) Plot the Earth-moon distance for every day at 0 TD in July, 1996 +; +; IDL> jdcnv,1996,7,1,0,jd ;Get Julian date of July 1 +; IDL> moonpos,jd+dindgen(31), ra, dec, dis ;Position at all 31 days +; IDL> plot,indgen(31),dis, /YNOZ +; +; METHOD: +; Derived from the Chapront ELP2000/82 Lunar Theory (Chapront-Touze' and +; Chapront, 1983, 124, 50), as described by Jean Meeus in Chapter 47 of +; ``Astronomical Algorithms'' (Willmann-Bell, Richmond), 2nd edition, +; 1998. Meeus quotes an approximate accuracy of 10" in longitude and +; 4" in latitude, but he does not give the time range for this accuracy. +; +; Comparison of this IDL procedure with the example in ``Astronomical +; Algorithms'' reveals a very small discrepancy (~1 km) in the distance +; computation, but no difference in the position calculation. +; +; This procedure underwent a major rewrite in June 1996, and the new +; calling sequence is *incompatible with the old* (e.g. angles now +; returned in degrees instead of radians). +; +; PROCEDURES CALLED: +; CIRRANGE, ISARRAY(), NUTATE, TEN() - from IDL Astronomy Library +; POLY() - from IDL User's Library +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 31 October 1988. +; Major rewrite, new (incompatible) calling sequence, much improved +; accuracy, W. Landsman Hughes STX June 1996 +; Added /RADIAN keyword W. Landsman August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use improved expressions for L',D,M,M', and F given in 2nd edition of +; Meeus (very slight change), W. Landsman November 2000 +; Avoid 32767 overflow W. Landsman January 2005 +; +;- + compile_opt idl2 + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - MOONPOS, jd, ra, dec, dis, geolong, geolat, [/RADIAN]' + print,'Output angles in DEGREES unless /RADIAN is set' + return + endif + + npts = N_elements(jd) + dtor = !DPI/180.0d + + ; form time in Julian centuries from 1900.0 + + t = (jd[*] - 2451545.0d)/36525.0d0 + + d_lng = [0,2,2,0,0,0,2,2,2,2,0,1,0,2,0,0,4,0,4,2,2,1,1,2,2,4,2,0,2,2,1,2,0,0, $ + 2,2,2,4,0,3,2,4,0,2,2,2,4,0,4,1,2,0,1,3,4,2,0,1,2,2] + + m_lng = [0,0,0,0,1,0,0,-1,0,-1,1,0,1,0,0,0,0,0,0,1,1,0,1,-1,0,0,0,1,0,-1,0, $ + -2,1,2,-2,0,0,-1,0,0,1,-1,2,2,1,-1,0,0,-1,0,1,0,1,0,0,-1,2,1,0,0] + + mp_lng = [1,-1,0,2,0,0,-2,-1,1,0,-1,0,1,0,1,1,-1,3,-2,-1,0,-1,0,1,2,0,-3,-2,$ + -1,-2,1,0,2,0,-1,1,0,-1,2,-1,1,-2,-1,-1,-2,0,1,4,0,-2,0,2,1,-2,-3,2,1,-1, $ + 3,-1] + + f_lng = [0,0,0,0,0,2,0,0,0,0,0,0,0,-2,2,-2,0,0,0,0,0,0,0,0,0,0,0,0,2,0,0,0, $ + 0,0,0,-2,2,0,2,0,0,0,0,0,0,-2,0,0,0,0,-2,-2,0,0,0,0,0,0,0,-2] + + sin_lng = [6288774,1274027,658314,213618,-185116,-114332,58793,57066,53322, $ + 45758,-40923,-34720,-30383,15327,-12528,10980,10675,10034,8548,-7888,-6766, $ + -5163,4987,4036,3994,3861,3665,-2689,-2602,2390,-2348,2236,-2120,-2069,2048, $ + -1773,-1595,1215,-1110,-892,-810,759,-713,-700,691,596,549,537,520,-487, $ + -399,-381,351,-340,330,327,-323,299,294,0.0d] + + cos_lng = [-20905355,-3699111,-2955968,-569925,48888,-3149,246158,-152138, $ + -170733,-204586,-129620,108743,104755,10321,0,79661,-34782,-23210,-21636, $ + 24208,30824,-8379,-16675,-12831,-10445,-11650,14403,-7003,0,10056,6322, $ + -9884,5751,0,-4950,4130,0,-3958,0,3258,2616,-1897,-2117,2354,0,0,-1423, $ + -1117,-1571,-1739,0,-4421,0,0,0,0,1165,0,0,8752.0d] + + d_lat = [0,0,0,2,2,2,2,0,2,0,2,2,2,2,2,2,2,0,4,0,0,0,1,0,0,0,1,0,4,4,0,4,2,2,$ + 2,2,0,2,2,2,2,4,2,2,0,2,1,1,0,2,1,2,0,4,4,1,4,1,4,2] + + m_lat = [0,0,0,0,0,0,0,0,0,0,-1,0,0,1,-1,-1,-1,1,0,1,0,1,0,1,1,1,0,0,0,0,0,0,$ + 0,0,-1,0,0,0,0,1,1,0,-1,-2,0,1,1,1,1,1,0,-1,1,0,-1,0,0,0,-1,-2] + + mp_lat = [0,1,1,0,-1,-1,0,2,1,2,0,-2,1,0,-1,0,-1,-1,-1,0,0,-1,0,1,1,0,0,3,0, $ + -1,1, -2,0,2,1,-2,3,2,-3,-1,0,0,1,0,1,1,0,0,-2,-1,1,-2,2,-2,-1,1,1,-1,0,0] + + f_lat =[ 1,1,-1,-1,1,-1,1,1,-1,-1,-1,-1,1,-1,1,1,-1,-1,-1,1,3,1,1,1,-1,-1,-1, $ + 1,-1,1,-3,1,-3,-1,-1,1,-1,1,-1,1,1,1,1,-1,3,-1,-1,1,-1,-1,1,-1,1,-1,-1, $ + -1,-1,-1,-1,1] + + sin_lat = [5128122,280602,277693,173237,55413,46271,32573,17198,9266,8822, $ + 8216,4324,4200,-3359,2463,2211,2065,-1870,1828,-1794,-1749,-1565,-1491, $ + -1475,-1410,-1344,-1335,1107,1021,833,777,671,607,596,491,-451,439,422, $ + 421,-366,-351,331,315,302,-283,-229,223,223,-220,-220,-185,181,-177,176, $ + 166,-164,132,-119,115,107.0d] + +; Mean longitude of the moon referred to mean equinox of the date + + coeff0 = [218.3164477d, 481267.88123421d, -0.0015786d0, 1.0d/538841.0d, $ + -1.0d/6.5194d7 ] + lprimed = poly(T, coeff0) + cirrange, lprimed + lprime = lprimed*dtor + +; Mean elongation of the Moon + + coeff1 = [297.8501921d, 445267.1114034d, -0.0018819d, 1.0d/545868.0d, $ + -1.0d/1.13065d8 ] + d = poly(T, coeff1) + cirrange,d + d = d*dtor + +; Sun's mean anomaly + + coeff2 = [357.5291092d, 35999.0502909d, -0.0001536d, 1.0d/2.449d7 ] + M = poly(T,coeff2) + cirrange, M + M = M*dtor + +; Moon's mean anomaly + + coeff3 = [134.9633964d, 477198.8675055d, 0.0087414d, 1.0/6.9699d4, $ + -1.0d/1.4712d7 ] + Mprime = poly(T, coeff3) + cirrange, Mprime + Mprime = Mprime*dtor + +; Moon's argument of latitude + + coeff4 = [93.2720950d, 483202.0175233d, -0.0036539, -1.0d/3.526d7, $ + 1.0d/8.6331d8 ] + F = poly(T, coeff4 ) + cirrange, F + F = F*dtor + +; Eccentricity of Earth's orbit around the Sun + + E = 1 - 0.002516d*T - 7.4d-6*T^2 + E2 = E^2 + + ecorr1 = where(abs(m_lng) EQ 1) + ecorr2 = where(abs(m_lat) EQ 1) + ecorr3 = where(abs(m_lng) EQ 2) + ecorr4 = where(abs(m_lat) EQ 2) + +; Additional arguments + + A1 = (119.75d + 131.849d*T) * dtor + A2 = (53.09d + 479264.290d*T) * dtor + A3 = (313.45d + 481266.484d*T) * dtor + suml_add = 3958*sin(A1) + 1962*sin(lprime - F) + 318*sin(A2) + sumb_add = -2235*sin(lprime) + 382*sin(A3) + 175*sin(A1-F) + $ + 175*sin(A1 + F) + 127*sin(Lprime - Mprime) - $ + 115*sin(Lprime + Mprime) + +; Sum the periodic terms + + geolong = dblarr(npts) & geolat = geolong & dis = geolong + + for i=0L,npts-1 do begin + + sinlng = sin_lng & coslng = cos_lng & sinlat = sin_lat + + sinlng[ecorr1] = e[i]*sinlng[ecorr1] + coslng[ecorr1] = e[i]*coslng[ecorr1] + sinlat[ecorr2] = e[i]*sinlat[ecorr2] + sinlng[ecorr3] = e2[i]*sinlng[ecorr3] + coslng[ecorr3] = e2[i]*coslng[ecorr3] + sinlat[ecorr4] = e2[i]*sinlat[ecorr4] + + arg = d_lng*d[i] + m_lng*m[i] +mp_lng*mprime[i] + f_lng*f[i] + geolong[i] = lprimed[i] + ( total(sinlng*sin(arg)) + suml_add[i] )/1.0d6 + + dis[i] = 385000.56d + total(coslng*cos(arg))/1.0d3 + + arg = d_lat*d[i] + m_lat*m[i] +mp_lat*mprime[i] + f_lat*f[i] + geolat[i] = (total(sinlat*sin(arg)) + sumb_add[i])/1.0d6 + + endfor + + nutate, jd, nlong, elong ;Find the nutation in longitude + geolong= geolong + nlong/3.6d3 + cirrange,geolong + lambda = geolong*dtor + beta = geolat*dtor + +;Find mean obliquity and convert lambda,beta to RA, Dec + + c = [21.448,-4680.93,-1.55,1999.25,-51.38,-249.67,-39.05,7.12,27.87,5.79,2.45d] + epsilon = ten(23,26) + poly(t/1.d2,c)/3600.d + eps = (epsilon + elong/3600.d )*dtor ;True obliquity in radians + + ra = atan( sin(lambda)*cos(eps) - tan(beta)* sin(eps), cos(lambda) ) + cirrange,ra,/RADIAN + dec = asin( sin(beta)*cos(eps) + cos(beta)*sin(eps)*sin(lambda) ) + + if not isarray(jd) then begin + ra = ra[0] & dec = dec[0] & dis = dis[0] + geolong = geolong[0] & geolat = geolat[0] + endif + + if not keyword_set(RADIAN) then begin + ra = ra/dtor & dec = dec/dtor + endif else begin + geolong = lambda & geolat = beta + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/mphase.pro b/modules/idl_downloads/astro/pro/mphase.pro new file mode 100644 index 0000000..4084079 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mphase.pro @@ -0,0 +1,56 @@ +pro mphase,jd, k +;+ +; NAME: +; MPHASE +; PURPOSE: +; Return the illuminated fraction of the Moon at given Julian date(s) +; +; CALLING SEQUENCE: +; MPHASE, jd, k +; INPUT: +; JD - Julian date, scalar or vector, double precision recommended +; OUTPUT: +; k - illuminated fraction of Moon's disk (0.0 < k < 1.0), same number +; of elements as jd. k = 0 indicates a new moon, while k = 1 for +; a full moon. +; EXAMPLE: +; Plot the illuminated fraction of the moon for every day in July +; 1996 at 0 TD (~Greenwich noon). +; +; IDL> jdcnv, 1996, 7, 1, 0, jd ;Get Julian date of July 1 +; IDL> mphase, jd+dindgen(31), k ;Moon phase for all 31 days +; IDL> plot, indgen(31),k ;Plot phase vs. July day number +; +; METHOD: +; Algorithm from Chapter 46 of "Astronomical Algorithms" by Jean Meeus +; (Willmann-Bell, Richmond) 1991. SUNPOS and MOONPOS are used to get +; positions of the Sun and the Moon (and the Moon distance). The +; selenocentric elongation of the Earth from the Sun (phase angle) +; is then computed, and used to determine the illuminated fraction. +; PROCEDURES CALLED: +; MOONPOS, SUNPOS +; REVISION HISTORY: +; Written W. Landsman Hughes STX June 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use /RADIAN keywords to MOONPOS, SUNPOS internally W. Landsman Aug 2000 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - MPHASE, jd, k' + return + endif + diss = 1.49598e8 ;Earth-Sun distance (1 AU) + + moonpos, jd, ram, decm, dism, /RADIAN + sunpos, jd, ras, decs, /RADIAN + +; phi - geocentric elongation of the Moon from the Sun +; inc - selenocentric (Moon centered) elongation of the Earth from the Sun + + phi = acos( sin(decs)*sin(decm) + cos(decs)*cos(decm)*cos(ras-ram) ) + inc = atan( diss * sin(phi), dism - diss*cos(phi) ) + k = (1 + cos(inc))/2. + + return + end diff --git a/modules/idl_downloads/astro/pro/mrandomn.pro b/modules/idl_downloads/astro/pro/mrandomn.pro new file mode 100644 index 0000000..1d976ca --- /dev/null +++ b/modules/idl_downloads/astro/pro/mrandomn.pro @@ -0,0 +1,80 @@ +function mrandomn, seed, covar, nrand, STATUS = status + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; MRANDOMN +; PURPOSE: +; Function to draw NRAND random deviates from a multivariate normal +; distribution with zero mean and covariance matrix COVAR. +; +; AUTHOR : Brandon C. Kelly, Steward Obs., Sept. 2004 +; +; INPUTS : +; +; SEED - The random number generator seed, the default is IDL's +; default in RANDOMN() +; COVAR - The covariance matrix of the multivariate normal +; distribution. +; OPTIONAL INPUTS : +; +; NRAND - The number of randomn deviates to draw. The default is +; one. +; OUTPUT : +; +; The random deviates, an [NRAND, NP] array where NP is the +; dimension of the covariance matrix, i.e., the number of +; parameters. +; +; OPTIONAL OUTPUT: +; STATUS - status of the Cholesky decomposition. If STATUS = 0 then +; the computation was successful. If STATUS > 0 then the +; input covariance matrix is not positive definite (see LA_CHOLDC), +; and MRANDOMN +; Note that if a STATUS keyword is supplied then no error message +; will be printed. +; REVISION HISTORY: +; Oct. 2013 -- Use LA_CHOLDC instead of CHOLDC to enable use of STATUS +; keyword. W. Landsman +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +if n_params() lt 2 then begin + print, 'Syntax- Result = mrandomn( seed, covar, [nrand] , STATUS = )' + return, 0 +endif + +printerr = ~arg_present(errmsg) +errmsg = '' + + +;check inputs and set up defaults +if n_elements(nrand) eq 0 then nrand = 1 +if size(covar, /n_dim) ne 2 then begin + print, 'COVAR must be a matrix.' + return, 0 +endif + +np = (size(covar))[1] +if (size(covar))[2] ne np then begin + print, 'COVAR must be a square matrix.' + return, 0 +endif + +epsilon = randomn(seed, nrand, np) ;standard normal random deviates (NP x NRAND matrix) + +A = covar ;store covariance into dummy variable for input into TRIRED + + la_choldc, A, /double, status=status ;do Cholesky decomposition + if status NE 0 then begin + message,'Array is not positive definite, STATUS = ' + strtrim(status,2),/CON + return,-1 + endif + +for i = 0, np - 2 do A[i+1:*,i] = 0d ;Zero out upper triangular portion + +;transform standard normal deviates so they have covariance matrix COVAR +epsilon = A ## epsilon + +return, epsilon +end diff --git a/modules/idl_downloads/astro/pro/mrd_hread.pro b/modules/idl_downloads/astro/pro/mrd_hread.pro new file mode 100644 index 0000000..f464e98 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mrd_hread.pro @@ -0,0 +1,135 @@ +pro mrd_hread, unit, header, status, SILENT = silent, FIRSTBLOCK = firstblock, $ + ERRMSG = errmsg,SKIPDATA=skipdata,NO_BADHEADER=no_badheader +;+ +; NAME: +; MRD_HREAD +; +; PURPOSE: +; Reads a FITS header from an opened disk file or Unix pipe +; EXPLANATION: +; Like FXHREAD but also works with compressed Unix files +; +; CALLING SEQUENCE: +; MRD_HREAD, UNIT, HEADER [, STATUS, /SILENT, ERRMSG =, /FIRSTBLOCK ] +; INPUTS: +; UNIT = Logical unit number of an open FITS file +; OUTPUTS: +; HEADER = String array containing the FITS header. +; OPT. OUTPUTS: +; STATUS = Condition code giving the status of the read. Normally, this +; is zero, but is set to -1 if an error occurs, or if the +; first byte of the header is zero (ASCII null). +; OPTIONAL KEYWORD INPUT: +; /FIRSTBLOCK - If set, then only the first block (36 lines or less) of +; the FITS header are read into the output variable. If only +; size information (e.g. BITPIX, NAXIS) is needed from the +; header, then the use of this keyword can save time. The +; file pointer is still positioned at the end of the header, +; even if the /FIRSTBLOCK keyword is supplied. +; /SILENT - If set, then warning messages about any invalid characters in +; the header are suppressed. +; /SKIPDATA - If set, then the file point is positioned at the end of the +; HDU after the header is read, i.e. the following data block +; is skipped. Useful, when one wants to the read the headers +; of multiple extensions. +; /NO_BADHEADER - if set, returns if FITS header has illegal characters +; By default, MRD_HREAD replaces bad characters with blanks, +; issues a warning, and continues. +; OPTIONAL OUTPUT PARAMETER: +; ERRMSG = If this keyword is present, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; RESTRICTIONS: +; The file must already be positioned at the start of the header. It +; must be a proper FITS file. +; SIDE EFFECTS: +; The file ends by being positioned at the end of the FITS header, unless +; an error occurs. +; REVISION HISTORY: +; Written, Thomas McGlynn August 1995 +; Modified, Thomas McGlynn January 1996 +; Changed MRD_HREAD to handle Headers which have null characters +; A warning message is printed out but the program continues. +; Previously MRD_HREAD would fail if the null characters were +; not in the last 2880 byte block of the header. Note that +; such characters are illegal in the header but frequently +; are produced by poor FITS writers. +; Added /SILENT keyword W. Landsman December 2000 +; Added /FIRSTBLOCK keyword W. Landsman February 2003 +; Added ERRMSG, SKIPDATA keyword W. Landsman April 2009 +; Close file unit even after error message W.L. October 2010 +; Added /NO_BADHEADER Zarro (ADNET), January 2012 +;- + On_error,2 + compile_opt idl2 + printerr = ~arg_present(errmsg) + errmsg = '' + + block = string(replicate(32b, 80, 36)) + + Nend = 0 ;Signal if 'END ' statement is found + nblock = 0 + + while Nend EQ 0 do begin + +; Shouldn't get eof in middle of header. + if eof(unit) then begin + errmsg = 'EOF encountered in middle of FITS header' + if printerr then message,errmsg,/CON + free_lun, unit + status = -1 + return + endif + + on_ioerror, error_return + readu, unit, block + on_ioerror, null + +; Check that there aren't improper null characters in strings that are causing +; them to be truncated. Issue a warning but continue if problems are +; found (unless /NO_BADHEADER is set) + + w = where(strlen(block) ne 80, Nbad) + if (Nbad GT 0) then begin + warning='Warning-Invalid characters in header' + if ~keyword_set(SILENT) then message,warning,/INF + if keyword_set(NO_BADHEADER) then begin + status=-1 & errmsg=warning & free_lun,unit & return + endif + block[w] = string(replicate(32b, 80)) + endif + w = where(strmid(block, 0, 8) eq 'END ', Nend) + if nblock EQ 0 then begin + header = Nend GT 0 ? block[ 0:w[0] ] : block + nblock =1 + endif else $ + if ~keyword_set(firstblock) then $ + header = Nend GT 0 ? [header,block[0:w[0]]] : [header, block] + + endwhile + + if keyword_set(skipdata) then begin + bitpix = fxpar(header,'bitpix') + naxis = fxpar(header,'naxis') + gcount = fxpar(header,'gcount') + if gcount eq 0 then gcount = 1 + pcount = fxpar(header,'pcount') + + if naxis gt 0 then begin + dims = fxpar(header,'naxis*') ;read dimensions + ndata = product(dims,/integer) + endif else ndata = 0 + + nbytes = long64(abs(bitpix) / 8) * gcount * (pcount + ndata) + mrd_skip, unit, nbytes + endif + status = 0 + return +error_return: + status = -1 + errmsg = 'END Statement not found in FITS header' + if printerr then message, 'ERROR ' + errmsg + return +end + diff --git a/modules/idl_downloads/astro/pro/mrd_skip.pro b/modules/idl_downloads/astro/pro/mrd_skip.pro new file mode 100644 index 0000000..40744ee --- /dev/null +++ b/modules/idl_downloads/astro/pro/mrd_skip.pro @@ -0,0 +1,72 @@ +pro mrd_skip, unit, nskip +;+ +; NAME: +; MRD_SKIP +; PURPOSE: +; Skip a number of bytes from the current location in a file or a pipe +; EXPLANATION: +; First tries using POINT_LUN and if this doesn't work, perhaps because +; the unit is a pipe or a socket, MRD_SKIP will just read in the +; requisite number of bytes. +; CALLING SEQUENCE: +; MRD_SKIP, Unit, Nskip +; +; INPUTS: +; Unit - File unit for the file or pipe in question, integer scalar +; Nskip - Number of bytes to be skipped, positive integer +; NOTES: +; This routine should be used in place of POINT_LUN wherever a pipe +; or socket may be the input unit (see the procedure FXPOSIT for an +; example). Note that it assumes that it can only work with nskip >= 0 +; so it doesn't even try for negative values. +; +; For reading a pipe, MRD_SKIP currently uses a maximum buffer size +; of 8 MB. This chunk value can be increased for improved efficiency +; (or decreased if you really have little memory.) +; REVISION HISTORY: +; Written, Thomas A. McGlynn July 1995 +; Don't even try to skip bytes on a pipe with POINT_LUN, since this +; might reset the current pointer W. Landsman April 1996 +; Increase buffer size, check fstat.compress W. Landsman Jan 2001 +; Only a warning if trying read past EOF W. Landsman Sep 2001 +; Use 64bit longword for skipping in very large files W. Landsman Sep 2003 +; Assume since V5.4, fstat.compress available W. Landsman April 2006 +; POINT_LUN for compressed files is as fast as any W. Landsman Oct 2006 +; Don't try to use POINT_LUN on compressed files W. Landsman Dec. 2006 +; +;- + On_error,2 + + if nskip le 0 then return + compress = (fstat(unit)).compress + +; We try to use POINT_LUN but if an error ocurrs, we just read in the bytes + + if ~compress then begin + On_IOerror, byte_read + point_lun, -unit, curr_pos + On_IOerror, null + if curr_pos NE -1 then point_lun, unit, long64(curr_pos) + nskip + return + endif + +; Otherwise, we have to explictly read the number of bytes to skip +; If the number is very large we don't want to create a array so skip +; in chunks of 8 Megabyte + +byte_read: + + chunk = 8000000L + buf = bytarr(nskip0. +; The data is returned as an array of structures. Each +; structure has two elements. The first is a one-dimensional +; array of the group parameters, the second is a multidimensional +; array as given by the NAXIS2-n keywords. +; ASCII and BINARY tables. +; The data is returned as a structure with one column for +; each field in the table. The names of the columns are +; normally taken from the TTYPE keywords (but see USE_COLNUM). +; Bit field columns +; are stored in byte arrays of the minimum necessary +; length. Spaces and invalid characters are replaced by +; underscores, and other invalid tag names are converted using +; the IDL_VALIDNAME(/CONVERT_ALL) function. +; Columns specified as variable length columns are stored +; with a dimension equal to the largest actual dimension +; used. Extra values in rows are filled with 0's or blanks. +; If the size of the variable length column is not +; a constant, then an additional column is created giving the +; size used in the current row. This additional column will +; have a tag name of the form L#_"colname" where # is the column +; number and colname is the column name of the variable length +; column. If the length of each element of a variable length +; column is 0 then the column is deleted. +; +; +; OPTIONAL OUTPUT: +; Header = String array containing the header from the FITS extension. +; +; OPTIONAL INPUT KEYWORDS: +; ALIAS The keyword allows the user to specify the column names +; to be created when reading FITS data. The value of +; this keyword should be a 2xn string array. The first +; value of each pair of strings should be the desired +; tag name for the IDL column. The second should be +; the FITS TTYPE value. Note that there are restrictions +; on valid tag names. The order of the ALIAS keyword +; is compatible with MWRFITS. +; COLUMNS - This keyword allows the user to specify that only a +; subset of columns is to be returned. The columns +; may be specified either as number 1,... n or by +; name or some combination of these two. +; If /USE_COLNUM is specified names should be C1,...Cn. +; The use of this keyword will not save time or internal +; memory since the extraction of specified columns +; is done after all columns have been retrieved from the +; FITS file. Structure columns are returned in the order +; supplied in this keyword. +; COMPRESS - This keyword allows the user to specify a +; decompression program to use to decompress a file that +; will not be automatically recognized based upon +; the file name. +; /DSCALE - As with FSCALE except that the resulting data is +; stored in doubles. +; /EMPTYSTRING - There was a bug in memory management for IDL versions +; prior to V8.0, causing a memory leak when reading +; empty strings in a FITS table. Setting /EMPTYSTRING will +; avoid this problem by first reading strings into bytes and +; then converting. However, there is a performance penalty. +; ERROR_ACTION - Set the on_error action to this value (defaults +; to 2). +; /FIXED_VAR- Translate variable length columns into fixed length columns +; and provide a length column for truly varying columns. +; This was only behavior prior to V2.5 for MRDFITS and remains +; the default (see /POINTER_VAR) +; /FPACK - If set, then assume the FITS file uses FPACK compression +; (http://heasarc.gsfc.nasa.gov/fitsio/fpack/). To read +; an FPACK compressed file, either this must be set or the +; file name must end in ".fz" +; /NO_FPACK - If present, then MRDFITS will not uncompress an extension +; compressed with FPACK (i.e with a .fz extension), but will +; just read the compressed binary stream. +; /FSCALE - If present and non-zero then scale data to float +; numbers for arrays and columns which have either +; non-zero offset or non-unity scale. +; If scaling parameters are applied, then the corresponding +; FITS scaling keywords will be modified. +; NO_TDIM - Disable processing of TDIM keywords. If NO_TDIM +; is specified MRDFITS will ignore TDIM keywords in +; binary tables. +; /POINTER_VAR- Use pointer arrays for variable length columns. +; In addition to changing the format in which +; variable length arrays are stored, if the pointer_var +; keyword is set to any value other than 1 this also disables +; the deletion of variable length columns. (See /FIXED_VAR) +; Note that because pointers may be present in the output +; structure, the user is responsible for memory management +; when deleting or reassigning the structure (e.g. use HEAP_FREE +; first). +; RANGE - A scalar or two element vector giving the start +; and end rows to be retrieved. For ASCII and BINARY +; tables this specifies the row number. For GROUPed data +; this will specify the groups. For array images, this +; refers to the last non-unity index in the array. E.g., +; for a 3 D image with NAXIS* values = [100,100,1], the +; range may be specified as 0:99, since the last axis +; is suppressed. Note that the range uses IDL indexing +; So that the first row is row 0. +; If only a single value, x, is given in the range, +; the range is assumed to be [0,x-1]. +; ROWS - A scalar or vector specifying a specific row or rows to read +; (first row is 0). For example to read rows 0, +; 12 and 23 only, set ROWS=[0,12,23]. Valid for images, ASCII +; and binary tables, but not GROUPed data. For images +; the row numbers refer to the last non-unity index in the array. +; Note that the use of the ROWS will not improve the speed of +; MRDFITS since the entire table will be read in, and then subset +; to the specified rows. Cannot be used at the same time as +; the RANGE keyword +; /SILENT - Suppress informative messages. +; STRUCTYP - The structyp keyword specifies the name to be used +; for the structure defined when reading ASCII or binary +; tables. Generally users will not be able to conveniently +; combine data from multiple files unless the STRUCTYP +; parameter is specified. An error will occur if the +; user specifies the same value for the STRUCTYP keyword +; in calls to MRDFITS in the same IDL session for extensions +; which have different structures. +; /UNSIGNED - For integer data with appropriate zero points and scales +; read the data into unsigned integer arrays. +; /USE_COLNUM - When creating column names for binary and ASCII tables +; MRDFITS attempts to use the appropriate TTYPE keyword +; values. If USE_COLNUM is specified and non-zero then +; column names will be generated as 'C1, C2, ... 'Cn' +; for the number of columns in the table. +; /VERSION Print the current version number +; +; OPTIONAL OUTPUT KEYWORDS: +; EXTNUM - the number of the extension actually read. Useful if the +; user specified the extension by name. +; OUTALIAS - This is a 2xn string array where the first column gives the +; actual structure tagname, and the second gives the +; corresponding FITS keyword name (e.g. in the TTYPE keyword). +; This array can be passed directly to +; the alias keyword of MWRFITS to recreate the file originally +; read by MRDFITS. +; STATUS - A integer status indicating success or failure of +; the request. A status of >=0 indicates a successful read. +; Currently +; 0 -> successful completion +; -1 -> error +; -2 -> end of file +; +; EXAMPLES: +; (1) Read a FITS primary array: +; a = mrdfits('TEST.FITS') or +; a = mrdfits('TEST.FITS', 0, header) +; The second example also retrieves header information. +; +; (2) Read rows 10-100 of the second extension of a FITS file. +; a = mrdfits('TEST.FITS', 2, header, range=[10,100]) +; +; (3) Read a table and ask that any scalings be applied and the +; scaled data be converted to doubles. Use simple column names, +; suppress outputs. +; a = mrdfits('TEST.FITS', 1, /dscale, /use_colnum, /silent) +; +; (4) Read rows 3, 34 and 52 of a binary table and request that +; variable length columns be stored as a pointer variable in the +; output structure +; a = mrdfits('TEST.FITS',1,rows=[3,34,52],/POINTER) + +; RESTRICTIONS: +; (1) Cannot handle data in non-standard FITS formats. +; (2) Doesn't do anything with BLANK or NULL values or +; NaN's. They are just read in. They may be scaled +; if scaling is applied. +; (3) Does not automatically detect a FPACK compressed file. Either +; the file name must end in .fz, or the /FPACK keyword must +; be set +; NOTES: +; This multiple format FITS reader is designed to provide a +; single, simple interface to reading all common types of FITS data. +; MRDFITS DOES NOT scale data by default. The FSCALE or DSCALE +; parameters must be used. +; +; Null values in an FITS ASCII table are converted to NaN (floating data), +; or -2147483647L (longwords) or '...' (strings). +; +; PROCEDURES USED: +; The following procedures are contained in the main MRDFITS program. +; MRD_IMAGE -- Generate array/structure for images. +; MRD_READ_IMAGE -- Read image data. +; MRD_ASCII -- Generate structure for ASCII tables. +; MRD_READ_ASCII -- Read an ASCII table. +; MRD_TABLE -- Generate structure for Binary tables. +; MRD_READ_TABLE -- Read binary table info. +; MRD_READ_HEAP -- Read variable length record info. +; MRD_SCALE -- Apply scaling to data. +; MRD_COLUMNS -- Extract columns. +; +; Other ASTRON Library routines used +; FXPAR(), FXADDPAR, FXPOSIT, FXMOVE(), MATCH, MRD_STRUCT(), MRD_SKIP +; +; MODIfICATION HISTORY: +; V1.0 November 9, 1994 ---- Initial release. +; Creator: Thomas A. McGlynn +; V1.1 January 20, 1995 T.A. McGlynn +; Fixed bug in variable length records. +; Added TDIM support -- new routine mrd_tdim in MRD_TABLE. +; V1.2 +; Added support for dynamic decompression of files. +; Fixed further bugs in variable length record handling. +; V1.2a +; Added NO_TDIM keyword to turn off TDIM processing for +; those who don't want it. +; Bug fixes: Handle one row tables correctly, use BZERO rather than +; BOFFSET. Fix error in scaling of images. +; V1.2b +; Changed MRD_HREAD to handle null characters in headers. +; V2.0 April 1, 1996 +; -Handles FITS tables with an arbitrary number of columns. +; -Substantial changes to MRD_STRUCT to allow the use of +; substructures when more than 127 columns are desired. +; -All references to table columns are now made through the +; functions MRD_GETC and MRD_PUTC. See description above. +; -Use of SILENT will now eliminate compilation messages for +; temporary functions. +; -Bugs in handling of variable length columns with either +; a single row in the table or a maximum of a single element +; in the column fixed. +; -Added support for DCOMPLEX numbers in binary tables (M formats) for +; IDL versions above 4.0. +; -Created regression test procedure to check in new versions. +; -Added error_action parameter to allow user to specify +; on_error action. This should allow better interaction with +; new CHECK facility. ON_ERROR statements deleted from +; most called routines. +; - Modified MRDFITS to read in headers containing null characters +; with a warning message printed. +; V2.0a April 16, 1996 +; - Added IS_IEEE_BIG() checks (and routine) so that we don't +; worry about IEEE to host conversions if the machine's native +; format is IEEE Big-endian. +; V2.1 August 24, 1996 +; - Use resolve_routine for dynamically defined functions +; for versions > 4.0 +; - Fix some processing in random groups format. +; - Handle cases where the data segment is--legally--null. +; In this case MRDFITS returns a scalar 0. +; - Fix bugs with the values for BSCALE and BZERO (and PSCAL and +; PZERO) parameters set by MRDFITS. +; V2.1a April 24, 1997 Handle binary tables with zero length columns +; V2.1b May 13,1997 Remove whitespace from replicate structure definition +; V2.1c May 28,1997 Less strict parsing of XTENSION keyword +; V2.1d June 16, 1997 Fixed problem for >32767 entries introduced 24-Apr +; V2.1e Aug 12, 1997 Fixed problem handling double complex arrays +; V2.1f Oct 22, 1997 IDL reserved words can't be structure tag names +; V2.1g Nov 24, 1997 Handle XTENSION keywords with extra blanks. +; V2.1h Jul 26, 1998 More flexible parsing of TFORM characters +; V2.2 Dec 14, 1998 Allow fields with longer names for +; later versions of IDL. +; Fix handling of arrays in scaling routines. +; Allow >128 fields in structures for IDL >4.0 +; Use more efficient structure copying for +; IDL>5.0 +; V2.2b June 17, 1999 Fix bug in handling case where +; all variable length columns are deleted +; because they are empty. +; V2.3 March 7, 2000 Allow user to supply file handle rather +; than file name. +; Added status field. +; Now needs FXMOVE routine +; V2.3b April 4, 2000 +; Added compress option (from D. Palmer) +; V2.4 July 4, 2000 Added STATUS=-1 for "File access error" (Zarro/GSFC) +; V2.4a May 2, 2001 Trim binary format string (W. Landsman) +; V2.5 December 5, 2001 Add unsigned, alias, 64 bit integers. version, $ +; /pointer_val, /fixed_var. +; V2.5a Fix problem when both the first and the last character +; in a TTYPEnn value are invalid structure tag characters +; V2.6 February 15, 2002 Fix error in handling unsigned numbers, $ +; and 64 bit unsigneds. (Thanks to Stephane Beland) +; V2.6a September 2, 2002 Fix possible conflicting data structure for +; variable length arrays (W. Landsman) +; V2.7 July, 2003 Added Rows keyword (W. Landsman) +; V2.7a September 2003 Convert dimensions to long64 to handle huge files +; V2.8 October 2003 Use IDL_VALIDNAME() function to ensure valid tag names +; Removed OLD_STRUCT and TEMPDIR keywords W. Landsman +; V2.9 February 2004 Added internal MRD_FXPAR procedure for faster +; processing of binary table headers E. Sheldon +; V2.9a March 2004 Restore ability to read empty binary table W. Landsman +; Swallow binary tables with more columns than given in TFIELDS +; V2.9b Fix to ensure order of TFORMn doesn't matter +; V2.9c Check if extra degenerate NAXISn keyword are present W.L. Oct 2004 +; V2.9d Propagate /SILENT to MRD_HREAD, more LONG64 casting W. L. Dec 2004 +; V2.9e Add typarr[good] to fix a problem reading zero-length columns +; A.Csillaghy, csillag@ssl.berkeley.edu (RHESSI) +; V2.9f Fix problem with string variable binary tables, possible math +; overflow on non-IEEE machines WL Feb. 2005 +; V2.9g Fix problem when setting /USE_COLNUM WL Feb. 2005 +; V2.10 Use faster keywords to BYTEORDER WL May 2006 +; V2.11 Add ON_IOERROR, CATCH, and STATUS keyword to MRD_READ_IMAGE to +; trap EOF in compressed files DZ Also fix handling of unsigned +; images when BSCALE not present K Chu/WL June 2006 +; V2.12 Allow extension to be specified by name, added EXTNUM keyword +; WL December 2006 +; V2.12a Convert ASCII table column to DOUBLE if single precision is +; insufficient +; V2.12b Fixed problem when both /fscale and /unsigned are set +; C. Markwardt Aug 2007 +; V2.13 Use SWAP_ENDIAN_INPLACE instead of IEEE_TO_HOST and IS_IEEE_BIG +; W. Landsman Nov 2007 +; V2.13a One element vector allowed for file name W.L. Dec 2007 +; V2.13b More informative error message when EOF found W.L. Jun 2008 +; V2.14 Use vector form of VALID_NUM(), added OUTALIAS keyword +; W.L. Aug 2008 +; V2.15 Use new FXPOSIT which uses on-the-fly byteswapping W.L. Mar 2009 +; V2.15a Small efficiency updates to MRD_SCALE W.L. Apr 2009 +; V2.15b Fixed typo introduced Apr 2009 +; V2.15c Fix bug introduced Mar 2009 when file unit used W.L. July 2009 +; V2.16 Handle FPACK compressed files W. L. July 2009 +; V2.17 Use compile_opt hidden on all routines except mrdfits.pro W.L. July 2009 +; V2.18 Added /EMPTYSTRING keyword W. Landsman August 2009 +; V2.18a Fix Columns keyword output, A. Kimball/ W. Landsman Feb 2010 +; V2.18b Fix bug with /EMPTYSTRING and multidimensional strings +; S. Baldridge/W.L. August 2010 +; V2.18c Fix unsigned bug caused by compile_opt idl2 WL Nov 2010 +; V2.19 Use V6.0 operators WL Nov 2010 +; V2.19a Fix complex data conversion in variable length tables WL Dec 2010 +; V2.19b Fix bug with /FSCALE introduced Nov 2010 WL Jan 2011 +; V2.19c Fix bug with ROWS keyword introduced Nov 2010 WL Mar 2011 +; V2.20 Convert Nulls in ASCII tables, better check of duplicate keywords +; WL May 2011 +; V2.20a Better error checking for FPACK files WL October 2012 +; V2.20b Fix bug in MRD_SCALE introduced Nov 2010 (Sigh) WL Feb 2013 +; V2.21 Create unique structure tags when FITS column names differ +; only in having a different case R. McMahon/WL March 2013 +; V2.22 Handle 64 bit variable length binary tables WL April 2014 +; V2.23 Test version for very large files +;- +PRO mrd_fxpar, hdr, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets +compile_opt idl2, hidden +; +; Check for valid header. Check header for proper attributes. +; + S = SIZE(HDR) + IF ( S[0] NE 1 ) || ( S[2] NE 7 ) THEN $ + MESSAGE,'FITS Header (first parameter) must be a string array' + + xten = fxpar(hdr, 'XTENSION') + nfld = fxpar(hdr, 'TFIELDS') + nrow = long64(fxpar(hdr, 'NAXIS2')) + rsize = long64(fxpar(hdr, 'NAXIS1')) + + ;; will extract these for each + names = ['TTYPE','TFORM', 'TSCAL', 'TZERO'] + nnames = n_elements(names) + +; Start by looking for the required TFORM keywords. Then try to extract it +; along with names (TTYPE), scales (TSCAL), and offsets (TZERO) + + keyword = STRMID( hdr, 0, 8) + +; +; Find all instances of 'TFORM' followed by +; a number. Store the positions of the located keywords in mforms, and the +; value of the number field in n_mforms +; + + mforms = WHERE(STRPOS(keyword,'TFORM') GE 0, n_mforms) + if n_mforms GT nfld then begin + message,/CON, $ + 'WARNING - More columns found in binary table than specified in TFIELDS' + n_mforms = nfld + mforms = mforms[0:nfld-1] + endif + + + IF ( n_mforms GT 0 ) THEN BEGIN + numst= STRMID(hdr[mforms], 5 ,3) + + igood = WHERE(VALID_NUM(numst,/INTEGER), n_mforms) + IF n_mforms GT 0 THEN BEGIN + mforms = mforms[igood] + number = fix( numst[igood]) + numst = numst[igood] + ENDIF + + ENDIF ELSE RETURN ;No fields in binary table + + ;; The others + fnames = strarr(n_mforms) + fforms = strarr(n_mforms) + scales = dblarr(n_mforms) + offsets = dblarr(n_mforms) + + ;;comments = strarr(n_mnames) + + fnames_names = 'TTYPE'+numst + scales_names = 'TSCAL'+numst + offsets_names = 'TZERO'+numst + number = number -1 ;Make zero-based + + + match, keyword, fnames_names, mkey_names, mnames, count = N_mnames + + match, keyword, scales_names, mkey_scales, mscales, count = N_mscales + + match, keyword, offsets_names, mkey_offsets, moffsets,count = N_moffsets + + FOR in=0L, nnames-1 DO BEGIN + + CASE names[in] OF + 'TTYPE': BEGIN + tmatches = mnames + matches = mkey_names + nmatches = n_mnames + result = fnames + END + 'TFORM': BEGIN + tmatches = lindgen(n_mforms) + matches = mforms + nmatches = n_mforms + result = fforms + END + 'TSCAL': BEGIN + tmatches = mscales + matches = mkey_scales + nmatches = n_mscales + result = scales + END + 'TZERO': BEGIN + tmatches = moffsets + matches = mkey_offsets + nmatches = n_moffsets + result = offsets + END + ELSE: message,'What?' + ENDCASE + + ;;help,matches,nmatches + +; +; Extract the parameter field from the specified header lines. If one of the +; special cases, then done. +; + IF nmatches GT 0 THEN BEGIN + + ;; "matches" is a subscript for hdr and keyword. + ;; get just the matches in line + + line = hdr[matches] + svalue = STRTRIM( STRMID(line,9,71),2) + + FOR i = 0, nmatches-1 DO BEGIN + IF ( STRMID(svalue[i],0,1) EQ "'" ) THEN BEGIN + + ;; Its a string + test = STRMID( svalue[i],1,STRLEN( svalue[i] )-1) + next_char = 0 + off = 0 + value = '' +; +; Find the next apostrophe. +; +NEXT_APOST: + endap = STRPOS(test, "'", next_char) + IF endap LT 0 THEN MESSAGE, $ + 'WARNING: Value of '+nam+' invalid in '+ " (no trailing ')", /info + value = value + STRMID( test, next_char, endap-next_char ) +; +; Test to see if the next character is also an apostrophe. If so, then the +; string isn't completed yet. Apostrophes in the text string are signalled as +; two apostrophes in a row. +; + IF STRMID( test, endap+1, 1) EQ "'" THEN BEGIN + value = value + "'" + next_char = endap+2 + GOTO, NEXT_APOST + ENDIF + + +; +; If not a string, then separate the parameter field from the comment field. +; + ENDIF ELSE BEGIN + ;; not a string + test = svalue[I] + slash = STRPOS(test, "/") + IF slash GT 0 THEN test = STRMID(test, 0, slash) + +; +; Find the first word in TEST. Is it a logical value ('T' or 'F')? +; + test2 = test + value = GETTOK(test2,' ') + test2 = STRTRIM(test2,2) + IF ( value EQ 'T' ) THEN BEGIN + value = 1 + END ELSE IF ( value EQ 'F' ) THEN BEGIN + value = 0 + END ELSE BEGIN +; +; Test to see if a complex number. It's a complex number if the value and the +; next word, if any, both are valid numbers. +; + IF STRLEN(test2) EQ 0 THEN GOTO, NOT_COMPLEX + test2 = GETTOK(test2,' ') + IF VALID_NUM(value,val1) && VALID_NUM(value2,val2) $ + THEN BEGIN + value = COMPLEX(val1,val2) + GOTO, GOT_VALUE + ENDIF +; +; Not a complex number. Decide if it is a floating point, double precision, +; or integer number. If an error occurs, then a string value is returned. +; If the integer is not within the range of a valid long value, then it will +; be converted to a double. +; +NOT_COMPLEX: + ON_IOERROR, GOT_VALUE + value = test + IF ~VALID_NUM(value) THEN GOTO, GOT_VALUE + + IF (STRPOS(value,'.') GE 0) || (STRPOS(value,'E') $ + GE 0) || (STRPOS(value,'D') GE 0) THEN BEGIN + IF ( STRPOS(value,'D') GT 0 ) || $ + ( STRLEN(value) GE 8 ) THEN BEGIN + value = DOUBLE(value) + END ELSE value = FLOAT(value) + ENDIF ELSE BEGIN + lmax = long64(2)^31 - 1 + lmin = -long64(2)^31 + value = long64(value) + if (value GE lmin) && (value LE lmax) THEN $ + value = LONG(value) + ENDELSE + +; +GOT_VALUE: + ON_IOERROR, NULL + ENDELSE + ENDELSE ; if string +; +; Add to vector if required. +; + + result[tmatches[i]] = value + + ENDFOR + + CASE names[in] OF + 'TTYPE': fnames[number] = strtrim(result, 2) + 'TFORM': fforms[number] = strtrim(result, 2) + 'TSCAL': scales[number] = result + 'TZERO': offsets[number] = result + ELSE: message,'What?' + ENDCASE + +; +; Error point for keyword not found. +; + ENDIF +; + + + + ENDFOR +END + + +; Get a tag name give the column name and index +function mrd_dofn, name, index, use_colnum, alias=alias +compile_opt idl2, hidden + ; Check if the user has specified an alias. + + name = N_elements(name) EQ 0 ? 'C' + strtrim(index,2) : strtrim(name) + if keyword_set(alias) then begin + sz = size(alias) + + if (sz[0] eq 1 || sz[0] eq 2) && (sz[1] eq 2) && (sz[sz[0]+1] eq 7) $ + then begin + w = where( name eq alias[1,*], Nw) + if Nw GT 0 then name = alias[0,w[0]]; + endif + endif + ; Convert the string name to a valid variable name. If name + ; is not defined generate the string Cnn when nn is the index + ; number. + + table = 0 + if ~use_colnum && (N_elements(name) GT 0) then begin + if size(name,/type) eq 7 then begin + str = name[0] + endif else str = 'C'+strtrim(index,2) + endif else str = 'C'+strtrim(index,2) + + return, IDL_VALIDNAME(str,/CONVERT_ALL) + +end + +;*************************************************************** + + + +; Parse the TFORM keyword and return the type and dimension of the +; data. +pro mrd_doff, form, dim, type +compile_opt idl2, hidden + ; Find the first non-numeric character. + + len = strlen(form) + + if len le 0 then return + + i = stregex( form, '[^0-9]') ;Position of first non-numeric character + + if i lt 0 then return ;Any non-numeric character found? + + if i gt 0 then begin + dim = long(strmid(form, 0, i)) + if dim EQ 0l then dim = -1l + endif else dim = 0 + + type = strmid(form, i, 1) +end + + + +;********************************************************************* + +; Check that this name is unique with regard to other column names. + +function mrd_chkfn, name, namelist, index, silent=silent + compile_opt idl2, hidden + ; + ; + + maxlen = 127 + + if strlen(name) gt maxlen then name = strmid(name, 0, maxlen) + ; make case insensitive since structure tags are case insensitive + ; (rgm 2013-03-03) + ;if ~array_equal(namelist eq name,0b ) then begin + if ~array_equal(strupcase(namelist) eq strupcase(name),0b ) then begin + + oldname=name + name = 'gen$name_'+strcompress(string(index+1),/remove_all) + + ; report the column name conflict + if ~keyword_set(silent) then print, 'Column name conflict: ', $ + index, ': ', oldname, ' -> ', name + + endif + + return, name +end + +; Find the appropriate offset for a given unsigned type. +; The type may be given as the bitpix value or the IDL +; variable type. + +function mrd_unsigned_offset, type +compile_opt idl2, hidden + + if (type eq 12) || (type eq 16) then begin + return, uint(32768) + endif else if (type eq 13) || (type eq 32) then begin + return, ulong('2147483648') + endif else if (type eq 15) || (type eq 64) then begin + return, ulong64('9223372036854775808'); + endif + return, 0 +end + + + +; Can we treat this data as unsigned? + +function mrd_chkunsigned, bitpix, scale, zero, unsigned=unsigned +compile_opt idl2, hidden + if ~keyword_set(unsigned) then return, 0 + + ; This is correct but we should note that + ; FXPAR returns a double rather than a long. + ; Since the offset is a power of two + ; it is an integer that is exactly representable + ; as a double. However, if a user were to use + ; 64 bit integers and an offset close to but not + ; equal to 2^63, we would erroneously assume that + ; the dataset was unsigned... + + if scale eq 1 then begin + if (bitpix eq 16 && zero eq 32768L) || $ + (bitpix eq 32 && zero eq 2147483648UL) || $ + (bitpix eq 64 && zero eq 9223372036854775808ULL) then return,1 + endif + + return, 0 +end + +; Is this one of the IDL unsigned types? +function mrd_unsignedtype, data + compile_opt idl2, hidden + type = size(data,/type) + + if (type eq 12) || (type eq 13) || (type eq 15) then return, type $ + else return, 0 + +end + +; Return the currrent version string for MRDFITS +function mrd_version +compile_opt idl2, hidden + return, '2.23 ' +end +;===================================================================== +; END OF GENERAL UTILITY FUNCTIONS =================================== +;===================================================================== + + +; Parse the TFORM keyword and return the type and dimension of the +; data. +pro mrd_atype, form, type, slen +compile_opt idl2, hidden + + ; Find the first non-numeric character. + + + ; Get rid of blanks. + form = strcompress(form,/remove_all) + len = strlen(form) + if len le 0 then return + + type = strmid(form, 0,1) + length = strmid(form,1,len-1) + ; + ; Ignore the number of decimal places. We assume that there + ; is a decimal point. + ; + p = strpos(length, '.') + if p gt 0 then length = strmid(length,0,p) + + if strlen(length) gt 0 then slen = fix(length) else slen = 1 + if (type EQ 'F') || (type EQ 'E') then $ ;Updated April 2007 + if (slen GE 8) then type = 'D' + +end + + +; Read in the table information. +pro mrd_read_ascii, unit, range, nbytes, nrows, nfld, typarr, posarr, $ + lenarr, nullarr, table, old_struct=old_struct, rows=rows +compile_opt idl2, hidden + ; + ; Unit Unit to read data from. + ; Range Range of to be read + ; Nbytes Number of bytes per row. + ; Nrows Number of rows. + ; Nfld Number of fields in structure. + ; Typarr Array indicating type of variable. + ; Posarr Starting position of fields (first char at 0) + ; Lenarr Length of fields + ; Nullarr Array of null values + ; Table Table to read information into. + ; Old_struct Should recursive structure format be used? + + bigstr = bytarr(nbytes, range[1]-range[0]+1) + + if range[0] gt 0 then mrd_skip, unit, nbytes*range[0] + readu,unit, bigstr + if N_elements(rows) GT 0 then bigstr = bigstr[*,rows-range[0]] + + ; Skip to the end of the data area. + + nSkipRow = nrows - range[1] - 1 + nskipB = 2880 - (nbytes*nrows) mod 2880 + if nskipB eq 2880 then nskipB = 0 + + mrd_skip, unit, nskipRow*nbytes+nskipB + + s1 = posarr-1 + s2 = s1 + lenarr - 1 + for i=0, nfld-1 do begin + flds = strtrim(bigstr[s1[i]:s2[i],* ]) + if nullarr[i] ne '' then begin + + curr_col = table.(i) + w = where(flds NE strtrim(nullarr[i]), Ngood) + + if Ngood GT 0 then begin + if N_elements(w) EQ 1 then w = w[0] + if typarr[i] eq 'I' then begin + curr_col[w] = long(flds[w]) + endif else if typarr[i] eq 'E' || typarr[i] eq 'F' then begin + curr_col[w] = float(flds[w]) + endif else if typarr[i] eq 'D' then begin + curr_col[w] = double(flds[w]) + endif else if typarr[i] eq 'A' then begin + curr_col[w] = flds[w] + endif + endif + + table.(i) = curr_col + + endif else begin + + + + if typarr[i] eq 'I' then begin + table.(i) = long(flds) + endif else if typarr[i] eq 'E' || typarr[i] eq 'F' then begin + table.(i) = float(flds) + endif else if typarr[i] eq 'D' then begin + table.(i) = double(flds) + endif else if typarr[i] eq 'A' then begin + table.(i) = flds + endif + endelse + endfor + +end + + +; Define a structure to hold a FITS ASCII table. +pro mrd_ascii, header, structyp, use_colnum, $ + range, table, $ + nbytes, nrows, nfld, typarr, posarr, lenarr, nullarr, $ + fnames, fvalues, scales, offsets, scaling, status, rows = rows, $ + silent=silent, columns=columns, alias=alias, outalias=outalias +compile_opt idl2, hidden + ; + ; Header FITS header for table. + ; Structyp IDL structure type to be used for + ; structure. + ; Use_colnum Use column numbers not names. + ; Range Range of rows of interest + ; Table Structure to be defined. + ; Nbytes Bytes per row + ; Nrows Number of rows in table + ; Nfld Number of fields + ; Typarr Array of field types + ; Posarr Array of field offsets + ; Lenarr Array of field lengths + ; Nullarr Array of field null values + ; Fname Column names + ; Fvalues Formats for columns + ; Scales/offsets Scaling factors for columns + ; Scaling Do we need to scale? + ; Status Return status. + + table = 0 + + types = ['I', 'E', 'F', 'D', 'A'] +; Set default 'null' values + sclstr = ['-2147483647L', '!VALUES.f_nan', '!VALUES.f_nan', '!VALUES.d_nan', '...'] + status = 0 + + if strmid(fxpar(header, 'XTENSION'),0,8) ne 'TABLE ' then begin + message, 'ERROR - Header is not from ASCII table.',/CON + status = -1; + return + endif + + nfld = fxpar(header, 'TFIELDS') + nrows = long64( fxpar(header, 'NAXIS2')) + nbytes = long64( fxpar(header, 'NAXIS1')) + + if range[0] ge 0 then begin + range[0] = range[0] < (nrows-1) + range[1] = range[1] < (nrows-1) + endif else begin + range[0] = 0 + range[1] = nrows-1 + endelse + + if N_elements(rows) EQ 0 then nrows = range[1] - range[0] + 1 else begin + bad = where(rows GT nrows, Nbad) + if Nbad GT 0 then begin + message,/CON,'ERROR: Row numbers must be between 0 and ' + $ + strtrim(nrows-1,2) + status = -1 + return + endif + nrows = N_elements(rows) + endelse + + if nrows le 0 then begin + if ~keyword_set(silent) then begin + print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $ + ' columns, no rows' + endif + return + endif + + ; + ; Loop over the columns + + typarr = strarr(nfld) + lenarr = intarr(nfld) + posarr = intarr(nfld) + nullarr = strarr(nfld) + fnames = strarr(nfld) + fvalues = strarr(nfld) + scales = dblarr(nfld) + offsets = dblarr(nfld) + tname = strarr(nfld) + + for i=0, nfld-1 do begin + suffix = strcompress(string(i+1), /remove_all) + fname = fxpar(header, 'TTYPE' + suffix, count=cnt) + tname[i] = fname + if cnt eq 0 then xx = temporary(fname) + fform = fxpar(header, 'TFORM' + suffix) + fpos = fxpar(header, 'TBCOL' + suffix) + fnull = fxpar(header, 'TNULL' + suffix, count=cnt) + if cnt eq 0 then fnull = '' + scales[i] = fxpar(header, 'TSCAL' + suffix) + if scales[i] eq 0.0d0 then scales[i] = 1.0d0 + offsets[i] = fxpar(header, 'TZERO'+suffix) + + fname = strupcase( mrd_dofn(fname,i+1, use_colnum, alias=alias)) + + if i GT 0 then fname = mrd_chkfn(fname, fnames, i, SILENT=silent) ;Check for duplicates + fnames[i] = fname + + mrd_atype, fform, ftype, flen + typarr[i] = ftype + lenarr[i] = flen + posarr[i] = fpos + nullarr[i] = fnull + + + j = where(types EQ ftype, Nj) + if Nj EQ 0 then begin + message, 'Invalid format code:'+ ftype + ' for column ' + $ + strtrim(i+1,2),/CON + status = -1 + return + endif + fvalues[i] = ftype NE 'A' ? sclstr[j] : $ + 'string(replicate(32b,'+strtrim(flen,2)+'))' + + + endfor + + if scaling then $ + scaling = ~array_equal(scales,1.0d0) || ~array_equal(offsets,0.0) + + if ~scaling && ~keyword_set(columns) then begin + table = mrd_struct(fnames, fvalues, nrows, structyp=structyp, $ + silent=silent) + endif else begin + table = mrd_struct(fnames, fvalues, nrows, silent=silent) + endelse + + if ~keyword_set(silent) then begin + print,'MRDFITS: ASCII table. ',strcompress(string(nfld)), $ + ' columns by ',strcompress(string(nrows)), ' rows.' + endif + + outalias = transpose([ [tag_names(table)],[tname] ] ) + status = 0 + return + +end + + +; Eliminate columns from the table that do not match the +; user specification. +pro mrd_columns, table, columns, fnames, fvalues, $ + vcls, vtpes, scales, offsets, scaling, $ + structyp=structyp, silent=silent +compile_opt idl2, hidden + + + + type = size(columns,/type) + nele = N_elements(columns) + if type eq 8 || type eq 6 || type eq 0 then return ; Can't use structs + ; or complex. + + if type eq 4 || type eq 5 then tcols = fix(columns) + if type eq 1 || type eq 2 || type eq 3 then tcols = columns + + ; Convert strings to uppercase and compare with column names. + + if type eq 7 then begin + match, strupcase(columns), strupcase(fnames), tmp, tcols,count=nmatch + if Nmatch GT 0 then begin + s = sort(tmp) ;Sort order of supplied column name + tcols = tcols[s] + 1 + endif + endif + + ; Subtract one from column indices and check that all indices >= 0. + if n_elements(tcols) gt 0 then begin + tcols = tcols-1 + w = where(tcols ge 0, Nw) + if Nw EQ 0 then dummy = temporary(tcols) + endif + + if n_elements(tcols) le 0 then begin + print, 'MRDFITS: No columns match' + + ; Undefine variables. First ensure they are defined, then + ; use temporary() to undefine them. + table = 0 + fnames = 0 + fvalues = 0 + vcls = 0 + vtpes = 0 + scales = 0 + offsets = 0 + dummy = temporary(fnames) + dummy = temporary(fvalues) + dummy = temporary(vcls) + dummy = temporary(vtpes) + dummy = temporary(scales) + dummy = temporary(offsets) + scaling = 0 + + endif else begin + + ; Replace arrays with only desired columns. + + fnames = fnames[tcols] + fvalues = fvalues[tcols] + + ; Check if there are still variable length columns. + if n_elements(vcls) gt 0 then begin + vcls = vcls[tcols] + vtpes = vtpes[tcols] + w = where(vcls eq 1, Nw) + if Nw EQ 0 then begin + dummy = temporary(vcls) + dummy = temporary(vtpes) + endif + endif + + ; Check if there are still columns that need scaling. + if n_elements(scales) gt 0 then begin + scales = scales[tcols] + offsets = offsets[tcols] + scaling = ~array_equal(scales,1.d0) || ~array_equal(offsets,0.0) + endif + + + ndim = n_elements(table) + + if scaling || n_elements(vcls) gt 0 then begin + tabx = mrd_struct(fnames, fvalues, ndim, silent=silent ) + endif else begin + tabx = mrd_struct(fnames, fvalues, ndim, structyp=structyp, silent=silent ) + endelse + + for i=0, n_elements(tcols)-1 do $ + tabx.(i) = table.(tcols[i]); + + table = temporary(tabx) + endelse + +end + + +; Read in the image information. +pro mrd_read_image, unit, range, maxd, rsize, table, rows = rows,status=status, $ + unixpipe = unixpipe + compile_opt idl2, hidden + ; + ; Unit Unit to read data from. + ; Table Table/array to read information into. + ; + + error=0 + catch,error + if error ne 0 then begin + catch,/cancel + status=-2 + return + endif + + ; If necessary skip to beginning of desired data. + + if range[0] gt 0 then mrd_skip, unit, range[0]*rsize + + status=-2 + if rsize eq 0 then return + + on_ioerror,done + readu, unit, table + + if N_elements(rows) GT 0 then begin + row1 = rows- range[0] + case size(table,/n_dimen) of + 1: table = table[row1] + 2: table = table[*,row1] + 3: table = table[*,*,row1] + 4: table = table[*,*,*,row1] + 5: table = table[*,*,*,*,row1] + 6: table = table[*,*,*,*,*,row1] + 7: table = table[*,*,*,*,*,*,row1] + 8: table = table[*,*,*,*,*,*,*,row1] + else: begin + print,'MRDFITS: Subscripted image must be between 1 and 8 dimensions' + status = -1 + return + end + endcase + endif + + ; Skip to the end of the data + + skipB = 2880 - (maxd*rsize) mod 2880 + if skipB eq 2880 then skipB = 0 + + if range[1] lt maxd-1 then $ + skipB += (maxd-range[1]-1)*rsize + + mrd_skip, unit, skipB + if unixpipe then swap_endian_inplace, table,/swap_if_little + + ; Fix offset for unsigned data + type = mrd_unsignedtype(table) + if type gt 0 then $ + table -= mrd_unsigned_offset(type) + + status=0 + done: + +;-- probably an EOF + + if status ne 0 then begin + message,!ERROR_STATE.MSG,/CON + free_lun,unit + endif + + return +end + +; Truncate superfluous axes. + +pro mrd_axes_trunc,naxis, dims, silent +compile_opt idl2, hidden + mysilent = silent + for i=naxis-1,1,-1 do begin + + if dims[i] eq 1 then begin + if ~mysilent then begin + print, 'MRDFITS: Truncating unused dimensions' + mysilent = 1 + endif + dims = dims[0:i-1] + naxis = naxis - 1 + + endif else return + + endfor + + return +end + +; Define structure/array to hold a FITS image. +pro mrd_image, header, range, maxd, rsize, table, scales, offsets, scaling, $ + status, silent=silent, unsigned=unsigned, rows = rows + compile_opt idl2, hidden + ; + ; Header FITS header for table. + ; Range Range of data to be retrieved. + ; Rsize Size of a row or group. + ; Table Structure to be defined. + ; Status Return status + ; Silent=silent Suppress info messages? + + table = 0 + + ; type 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + lens = [ 0, 1, 2, 4, 4, 8, 0, 0, 0, 0, 0, 0, 2, 4, 8, 8] + typstrs=['', 'Byte', 'Int*2', 'Int*4', 'Real*4', 'Real*8','','','','','','', 'UInt*2', 'Uint*4', 'Int*8', 'Uint*8'] + typarr= ['', 'bytarr', 'intarr', 'lonarr', 'fltarr', 'dblarr','','','','','','','uintarr', 'ulonarr', 'lon64arr', 'ulon64arr'] + + status = 0 + + + naxis = fxpar(header, 'NAXIS') + bitpix= fxpar(header, 'BITPIX') + if naxis gt 0 then begin + dims = long64(fxpar(header, 'NAXIS*', Count = N_axis)) + if N_axis GT naxis then begin +; Check if extra NAXISn keywords are present (though this is not legal FITS) + nextra = N_axis - naxis + dim_extra = dims[naxis:N_axis-1] + if total(dim_extra) EQ nextra then $ + dims = dims[0:naxis-1] else $ + message,'ERROR - NAXIS = ' + strtrim(naxis,2) + $ + ' but NAXIS' + strtrim(N_axis,2) + ' keyword present' + endif + endif else dims = 0 + + gcount = fxpar(header, 'GCOUNT') + pcount = fxpar(header, 'PCOUNT') + isgroup = fxpar(header, 'GROUPS') + gcount = long(gcount) + + xscale = fxpar(header, 'BSCALE', count=cnt) + if cnt eq 0 then xscale = 1 ;Corrected 06/29/06 + + xunsigned = mrd_chkunsigned(bitpix, xscale, $ + fxpar(header, 'BZERO'), unsigned=unsigned) + ; Note that type is one less than the type signifier returned in the size call. + type = -1 + + if ~xunsigned then begin + + if bitpix eq 8 then type = 1 $ + else if bitpix eq 16 then type = 2 $ + else if bitpix eq 32 then type = 3 $ + else if bitpix eq -32 then type = 4 $ + else if bitpix eq -64 then type = 5 $ + else if bitpix eq 64 then type = 14 + + endif else begin + + if bitpix eq 16 then type = 12 $ + else if bitpix eq 32 then type = 13 $ + else if bitpix eq 64 then type = 15 + + endelse + + if type eq -1 then begin + print,'MRDFITS: Error: Invalid BITPIX: '+strtrim(bitpix) + table = 0 + return + endif + + ; Note that for random groups data we must ignore the first NAXISn keyword. + if isgroup GT 0 then begin + + + range[0] = range[0] > 0 + if (range[1] eq -1) then begin + range[1] = gcount-1 + endif else begin + range[1] = range[1] < gcount - 1 + endelse + + maxd = gcount + + if (n_elements(dims) gt 1) then begin + dims = dims[1:*] + naxis = naxis-1 + endif else begin + print, 'MRDFITS: Warning: No data specified for group data.' + dims = [0] + naxis = 0 + endelse + + ; The last entry is the scaling for the sample data. + + if (pcount gt 0) then begin + scales = dblarr(pcount+1) + offsets = dblarr(pcount+1) + endif + + values = strarr(2) + + + mrd_axes_trunc, naxis, dims, keyword_set(silent) + + values[0] = typarr[type] + "("+string(pcount)+")" + rsize = dims[0] + sarr = "(" + strcompress(string(dims[0]), /remo ) + + for i=1, naxis-1 do begin + + sarr = sarr + "," + strcompress(string(dims[i]),/remo) + rsize = rsize*dims[i] + + endfor + + sarr = sarr + ")" + + if ~keyword_set(silent) then print,'MRDFITS--Image with groups:', $ + ' Ngroup=',strcompress(string(gcount)),' Npar=', $ + strcompress(string(pcount),/remo), ' Group=', sarr, ' Type=',typstrs[type] + + sarr = typarr[type] + sarr + values[1] = sarr + rsize = (rsize + pcount)*lens[type] + + table = mrd_struct(['params','array'], values, range[1]-range[0]+1, $ + silent=silent) + + if xunsigned then begin + fxaddpar,header, 'BZERO', 0, 'Reset by MRDFITS v'+mrd_version() + endif + + + for i=0, pcount-1 do begin + + istr = strcompress(string(i+1),/remo) + + scales[i] = fxpar(header, 'PSCAL'+istr) + if scales[i] eq 0.0d0 then scales[i] =1.0d0 + + offsets[i] = fxpar(header, 'PZERO'+istr) + + scales[pcount] = fxpar(header, 'BSCALE') + if scales[pcount] eq 0.0d0 then scales[pcount] = 1.0d0 + offsets[pcount] = fxpar(header, 'BZERO') + + endfor + + if scaling then $ + scaling = ~array_equal(scales,1.0d0) || ~array_equal(offsets,0.0) + + endif else begin + + if naxis eq 0 then begin + + rsize = 0 + table = 0 + if ~keyword_set(silent) then $ + print, 'MRDFITS: Null image, NAXIS=0' + return + + endif + + if gcount gt 1 then begin + dims = [dims, gcount] + naxis = naxis + 1 + endif + + mrd_axes_trunc, naxis, dims, keyword_set(silent) + + + maxd = dims[naxis-1] + + if range[0] ne -1 then begin + range[0] = range[0]<(maxd-1) + range[1] = range[1]<(maxd-1) + endif else begin + range[0] = 0 + range[1] = maxd - 1 + endelse + + Nlast = dims[naxis-1] + dims[naxis-1] = range[1]-range[0]+1 + pdims = dims + if N_elements(rows) GT 0 then begin + if max(rows) GE Nlast then begin + print, 'MRDFITS: Row numbers must be between 0 and ' + $ + strtrim(Nlast-1,2) + status = -1 & rsize = 0 + return + endif + pdims[naxis-1] = N_elements(rows) + endif + + if ~keyword_set(silent) then begin + str = '(' + for i=0, naxis-1 do begin + if i ne 0 then str = str + ',' + str = str + strcompress(string(pdims[i]),/remo) + endfor + str = str+')' + print, 'MRDFITS: Image array ',str, ' Type=', typstrs[type] + endif + + rsize = 1 + + if naxis gt 1 then for i=0, naxis - 2 do rsize=rsize*dims[i] + rsize = rsize*lens[type] + sz = lonarr(naxis+3) + sz[0] = naxis + sz[1:naxis] = dims + + nele = product(dims,/integer) + + sz[naxis+1] = type + sz[naxis+2] = nele + + table = nele GT 0 ? make_array(size=sz) : 0 + + scales = dblarr(1) + offsets = dblarr(1) + + if xunsigned then begin + fxaddpar,header, 'BZERO', 0, 'Updated by MRDFITS v'+mrd_version() + endif + + scales[0] = fxpar(header, 'BSCALE') + offsets[0] = fxpar(header, 'BZERO') + + if scales[0] eq 0.0d0 then scales[0] = 1.0d0 + if scaling && (scales[0] eq 1.0d0) && (offsets[0] eq 0.0d0) then $ + scaling = 0 + endelse + + status = 0 + return + +end + +; Scale an array of pointers +pro mrd_ptrscale, array, scale, offset +compile_opt idl2, hidden + for i=0, n_elements(array)-1 do begin + if ptr_valid(array[i]) then begin + array[i] = ptr_new(*array[i] * scale + offset) + endif + endfor +end + +; Scale a FITS array or table. +pro mrd_string, table, header, typarr, $ + fnames, fvalues, nrec, structyp=structyp, silent=silent +compile_opt idl2, hidden + ; + ; Type: FITS file type, 0=image/primary array + ; 1=ASCII table + ; 2=Binary table + ; + ; scales: An array of scaling info + ; offsets: An array of offset information + ; table: The FITS data. + ; header: The FITS header. + ; dscale: Should data be scaled to R*8? + ; fnames: Names of table columns. + ; fvalues: Values of table columns. + ; nrec: Number of records used. + ; structyp: Structure name. + + w = where( typarr EQ 'A', Nw, $ + complement=ww, Ncomplement = Nww) + + if Nw EQ 0 then return ;No tags require string conversion? + +; First do ASCII and Binary tables. We need to create a new structure +; because scaling will change the tag data types. + + sclr = "' '" + vc = 'strarr' + + for i=0, Nw-1 do begin + col = w[i] + sz = size(table[0].(col),/str) + + ; Handle pointer columns + if sz.type eq 10 then begin + fvalues[col] = 'ptr_new()' + + ; Scalar columns + endif else if sz.N_dimensions eq 0 then begin + fvalues[col] = sclr + + ; Vectors + endif else begin + dim = sz.dimensions[0:sz.N_dimensions-1] + fvalues[col] = vc + $ + '(' + strjoin(strtrim(dim,2),',') + ')' + + endelse + endfor + tabx = mrd_struct(fnames, fvalues, nrec, structyp=structyp, silent=silent ) + +; First copy the unscaled columns indexed by ww. This is actually more +; efficient than using STRUCT_ASSIGN since the tag names are all identical, +; so STRUCT_ASSIGN would copy everything (scaled and unscaled). + + for i=0, Nww - 1 do tabx.(ww[i]) = table.(ww[i]) + +; Now copy the string items indexed by w after converting the byte array + + for i=0, Nw - 1 do begin + + str = size(tabx.(w[i]),/str) + dim = [1,str.dimensions[0:str.N_dimensions-1]] + if str.n_dimensions GT 1 then $ + tabx.(w[i]) = string(reform(table.(w[i]),dim)) else $ + tabx.(w[i]) = string(table.(w[i])) + + endfor + + table = temporary(tabx) ;Remove original structure from memory + +end + + +; Scale a FITS array or table. +pro mrd_scale, type, scales, offsets, table, header, $ + fnames, fvalues, nrec, dscale = dscale, structyp=structyp, silent=silent +compile_opt idl2, hidden + ; + ; Type: FITS file type, 0=image/primary array + ; 1=ASCII table + ; 2=Binary table + ; + ; scales: An array of scaling info + ; offsets: An array of offset information + ; table: The FITS data. + ; header: The FITS header. + ; dscale: Should data be scaled to R*8? + ; fnames: Names of table columns. + ; fvalues: Values of table columns. + ; nrec: Number of records used. + ; structyp: Structure name. + + w = where( (scales ne 1.d0) or (offsets ne 0.d0), Nw, $ + complement=ww, Ncomplement = Nww) + + if Nw EQ 0 then return ;No tags require scaling? + +; First do ASCII and Binary tables. We need to create a new structure +; because scaling will change the tag data types. + + if type ne 0 then begin + + if type eq 1 then begin + fvalues[w] = keyword_set(dscale) ? '0.0d0' : '0.0 + endif else if type eq 2 then begin + + if keyword_set(dscale) then begin + sclr = '0.d0' + vc = 'dblarr' + endif else begin + sclr = '0.0' + vc = 'fltarr' + endelse + + for i=0, Nw-1 do begin + col = w[i] + sz = size(table[0].(col),/str) + + ; Handle pointer columns + if sz.type eq 10 then begin + fvalues[col] = 'ptr_new()' + + ; Scalar columns + endif else if sz.N_dimensions eq 0 then begin + fvalues[col] = sclr + + ; Vectors + endif else begin + dim = sz.dimensions[0:sz.N_dimensions-1] + fvalues[col] = vc + $ + '(' + strjoin(strtrim(dim,2),',') + ')' + + endelse + endfor + endif + + tabx = mrd_struct(fnames, fvalues, nrec, structyp=structyp, silent=silent ) + +; First copy the unscaled columns indexed by ww. This is actually more +; efficient than using STRUCT_ASSIGN since the tag names are all identical, +; so STRUCT_ASSIGN would copy everything (scaled and unscaled). + + for i=0, Nww - 1 do tabx.(ww[i]) = table.(ww[i]) + +; Now copy the scaled items indexed by w after applying the scaling. + + for i=0, Nw - 1 do begin + + dtype = size(tabx.(w[i]),/type) + if dtype eq 10 then $ + mrd_ptrscale, table.(w[i]), scales[w[i]], offsets[w[i]] + + tabx.(w[i]) = table.(w[i])*scales[w[i]] + offsets[w[i]] + + istr = strtrim(w[i]+1,2) + fxaddpar, header, 'TSCAL'+istr, 1.0, ' Set by MRD_SCALE' + fxaddpar, header, 'TZERO'+istr, 0.0, ' Set by MRD_SCALE' + + endfor + + table = temporary(tabx) ;Remove original structure from memory + endif else begin + ; Now process images and random groups. + + sz = size(table[0]) + if sz[sz[0]+1] ne 8 then begin + ; Not a structure so we just have an array of data. + if keyword_set(dscale) then begin + table = temporary(table)*scales[0]+offsets[0] + endif else begin + table = temporary(table)*float(scales[0]) + float(offsets[0]) + endelse + fxaddpar, header, 'BSCALE', 1.0, 'Set by MRD_SCALE' + fxaddpar, header, 'BZERO', 0.0, 'Set by MRD_SCALE' + + endif else begin + ; Random groups. Get the number of parameters by looking + ; at the first element in the table. + nparam = n_elements(table[0].(0)) + if keyword_set(dscale) then typ = 'dbl' else typ='flt' + s1 = typ+'arr('+string(nparam)+')' + ngr = n_elements(table) + sz = size(table[0].(1)) + if sz[0] eq 0 then dims = [1] else dims=sz[1:sz[0]] + s2 = typ + 'arr(' + for i=0, n_elements(dims)-1 do begin + if i ne 0 then s2 = s2+ ',' + s2 = s2+string(dims[i]) + endfor + s2 = s2+')' + tabx = mrd_struct(['params', 'array'],[s1,s2],ngr, silent=silent) + + for i=0, nparam-1 do begin + istr = strcompress(string(i+1),/remo) + fxaddpar, header, 'PSCAL'+istr, 1.0, 'Added by MRD_SCALE' + fxaddpar, header, 'PZERO'+istr, 0.0, 'Added by MRD_SCALE' + tabx.(0)[i] = table.(0)[i]*scales[i]+offsets[i] + endfor + + tabx.(1) = table.(1)*scales[nparam] + offsets[nparam] + fxaddpar, header, 'BSCALE', 1.0, 'Added by MRD_SCALE' + fxaddpar, header, 'BZERO', 0.0, 'Added by MRD_SCALE' + table = temporary(tabx) + endelse + endelse + +end + +; Read a variable length column into a pointer array. +pro mrd_varcolumn, vtype, array, heap, off, siz +compile_opt idl2, hidden + + ; Guaranteed to have at least one non-zero length column + w = where(siz gt 0) + nw = n_elements(w) + + if vtype eq 'X' then siz = 1 + (siz-1)/8 + + siz = siz[w] + off = off[w] + + unsigned = 0 + if vtype eq '1' then begin + unsigned = 12 + endif else if vtype eq '2' then begin + unsigned = 13 + endif else if vtype eq '3' then begin + unsigned = 15; + endif + unsigned = mrd_unsigned_offset(unsigned) + + + for j=0, nw-1 do begin + + case vtype of + + 'L': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) ) + 'X': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) ) + 'B': array[w[j]] = ptr_new( byte(heap,off[j],siz[j]) ) + + 'I': array[w[j]] = ptr_new( fix(heap, off[j], siz[j]) ) + 'J': array[w[j]] = ptr_new( long(heap, off[j], siz[j]) ) + 'K': array[w[j]] = ptr_new( long64(heap, off[j], siz[j]) ) + + 'E': array[w[j]] = ptr_new( float(heap, off[j], siz[j]) ) + 'D': array[w[j]] = ptr_new( double(heap, off[j], siz[j]) ) + + 'C': array[w[j]] = ptr_new( complex(heap, off[j], siz[j]) ) + 'M': array[w[j]] = ptr_new( dcomplex(heap, off[j], siz[j]) ) + + '1': array[w[j]] = ptr_new( uint(heap, off[j], siz[j]) ) + '2': array[w[j]] = ptr_new( ulong(heap, off[j], siz[j]) ) + '3': array[w[j]] = ptr_new( ulong64(heap, off[j], siz[j]) ) + + endcase + + ; Fix endianness. + if (vtype ne 'B') && (vtype ne 'X') && (vtype ne 'L') then begin + swap_endian_inplace, *array[w[j]],/swap_if_little + endif + + ; Scale unsigneds. + if unsigned gt 0 then *array[w[j]] = *array[w[j]] - unsigned + + endfor +end + +; Read a variable length column into a fixed length array. +pro mrd_fixcolumn, vtype, array, heap, off, siz +compile_opt idl2, hidden + + w = where(siz gt 0, nw) + if nw EQ 0 then return + + if vtype eq 'X' then siz = 1 + (siz-1)/8 + + siz = siz[w] + off = off[w] + + for j=0, nw-1 do begin + case vtype of + 'L': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j]) + 'X': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j]) + 'B': array[0:siz[j]-1,w[j]] = byte(heap,off[j],siz[j]) + + 'I': array[0:siz[j]-1,w[j]] = fix(heap, off[j], siz[j]) + 'J': array[0:siz[j]-1,w[j]] = long(heap, off[j], siz[j]) + 'K': array[0:siz[j]-1,w[j]] = long64(heap, off[j], siz[j]) + + 'E': begin ;Delay conversion until after byteswapping to avoid possible math overflow Feb 2005 + temp = heap[off[j]: off[j] + 4*siz[j]-1 ] + byteorder, temp, /LSWAP, /SWAP_IF_LITTLE + array[0:siz[j]-1,w[j]] = float(temp,0,siz[j]) + end + 'D': begin + temp = heap[off[j]: off[j] + 8*siz[j]-1 ] + byteorder, temp, /L64SWAP, /SWAP_IF_LITTLE + array[0:siz[j]-1,w[j]] = double(temp,0,siz[j]) + end + 'C': array[0:siz[j]-1,w[j]] = complex(heap, off[j], siz[j]) + 'M': array[0:siz[j]-1,w[j]] = dcomplex(heap, off[j], siz[j]) + + 'A': array[w[j]] = string(byte(heap,off[j],siz[j])) + + '1': array[0:siz[j]-1,w[j]] = uint(heap, off[j], siz[j]) + '2': array[0:siz[j]-1,w[j]] = ulong(heap, off[j], siz[j]) + '3': array[0:siz[j]-1,w[j]] = ulong64(heap, off[j], siz[j]) + + endcase + + endfor + + ; Fix endianness for datatypes with more than 1 byte + if ~stregex(vtype,'[^ABXLDE]') then $ + swap_endian_inplace, array, /swap_if_little + + ; Scale unsigned data + case vtype of + '1': unsigned = 12 + '2': unsigned = 13 + '3': unsigned = 15 + else: unsigned = 0 + endcase + + if unsigned gt 0 then $ + unsigned = mrd_unsigned_offset(unsigned) + + if unsigned gt 0 then begin + for j=0, nw-1 do begin + array[0:siz[j]-1,w[j]] = array[0:siz[j]-1,w[j]] - unsigned + endfor + endif + + +end + +; Read the heap area to get the actual values of variable +; length arrays. +pro mrd_read_heap, unit, header, range, fnames, fvalues, vcls, vtpes, table, $ + structyp, scaling, scales, offsets, status, silent=silent, $ + columns=columns, rows = rows, pointer_var=pointer_var, fixed_var=fixed_var +compile_opt idl2, hidden + ; + ; Unit: FITS unit number. + ; header: FITS header. + ; fnames: Column names. + ; fvalues: Column values. + ; vcols: Column numbers of variable length columns. + ; vtypes: Actual types of variable length columns + ; table: Table of data from standard data area, on output + ; contains the variable length data. + ; structyp: Structure name. + ; scaling: Is there going to be scaling of the data? + ; status: Set to -1 if an error occurs. + ; + typstr = 'LXBIJKAEDCM123' + prefix = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', $ + 'lonarr(', 'lon64arr(', 'string(bytarr(', 'fltarr(', $ + 'dblarr(', 'complexarr(', 'dcomplexarr(', $ + 'uintarr(', 'ulonarr(', 'ulon64arr('] + + status = 0 + + ; Convert from a list of indicators of whether a column is variable + ; length to pointers to only the variable columns. + + vcols = where(vcls eq 1) + vtypes = vtpes[vcols] + + nv = n_elements(vcols) + + ; Find the beginning of the heap area. + + heapoff = long64(fxpar(header, 'THEAP')) + sz = fxpar(header, 'NAXIS1')*fxpar(header, 'NAXIS2') + + if (heapoff ne 0) && (heapoff lt sz) then begin + print, 'MRDFITS: ERROR Heap begins within data area' + status = -1 + return + endif + + ; Skip to beginning. + if (heapoff > sz) then begin + mrd_skip, unit, heapoff-sz + endif + + ; Get the size of the heap. + pc = long64(fxpar(header, 'PCOUNT')) + if heapoff eq 0 then heapoff = sz + hpsiz = pc - (heapoff-sz) + + if (hpsiz gt 0) then heap = bytarr(hpsiz) + + + ; Read in the heap + readu, unit, heap + + ; Skip to the end of the data area. + skipB = 2880 - (sz+pc) mod 2880 + if skipB ne 2880 then begin + mrd_skip, unit, skipB + endif + + ; Find the maximum dimensions of the arrays. + ; + ; Note that the variable length column currently has fields which + ; are I*4 2-element arrays where the first element is the + ; length of the field on the current row and the second is the + ; offset into the heap. + + vdims = lonarr(nv) + for i=0, nv-1 do begin + col = vcols[i] + curr_col = table.(col) + vdims[i] = max(curr_col[0,*]) + w = where(curr_col[0,*] ne vdims[i]) + if w[0] ne -1 then begin + if n_elements(lencols) eq 0 then begin + lencols = [col] + endif else begin + lencols=[lencols,col] + endelse + endif + + if vtypes[i] eq 'X' then vdims[i]=(vdims[i]+7)/8 + ind = strpos(typstr, vtypes[i]) + + ; Note in the following that we ensure that the array is + ; at least one element long. + + fvalues[col] = prefix[ind] + string((vdims[i] > 1)) + ')' + if vtypes[i] eq 'A' then fvalues[col] = fvalues[col] + ')' + + endfor + + nfld = n_elements(fnames) + + ; Get rid of columns which have no actual data. + w= intarr(nfld) + w[*] = 1 + corres = indgen(nfld) + + + ; Should we get rid of empty columns? + delete = 1 + if keyword_set(pointer_var) then delete = pointer_var eq 1 + + if delete then begin + + ww = where(vdims eq 0, N_ww) + if N_ww GT 0 then begin + w[vcols[ww]] = 0 + if ~keyword_set(silent) then $ + print, 'MRDFITS: ', strcompress(string(n_elements(ww))), $ + ' unused variable length columns deleted' + endif + + ; Check if all columns have been deleted... + wx = where(w gt 0, N_wx) + if N_wx EQ 0 then begin + if ~keyword_set(silent) then $ + print, 'MRDFITS: All columns have been deleted' + table = 0 + return + endif + + + ; Get rid of unused columns. + corres = corres[wx] + fnames = fnames[wx] + fvalues = fvalues[wx] + scales = scales[wx] + offsets = offsets[wx] + + wx = where(vdims gt 0) + + if (wx[0] eq -1) then begin + vcols=[-9999] + x=temporary(vtypes) + x=temporary(vdims) + endif else begin + vcols = vcols[wx] + vtypes = vtypes[wx] + vdims = vdims[wx] + endelse + endif + + if ~keyword_set(pointer_var) then begin + ; Now add columns for lengths of truly variable length records. + if n_elements(lencols) gt 0 then begin + if ~keyword_set(silent) then $ + print, 'MRDFITS: ', strcompress(string(n_elements(lencols))), $ + ' length column[s] added' + + + for i=0, n_elements(lencols)-1 do begin + col = lencols[i] + w = where(col eq corres) + ww = where(col eq vcols) + w = w[0] + ww = ww[0] + fvstr = '0L' ; <-- Originally, '0l'; breaks under the virtual machine! + fnstr = 'L'+strcompress(string(col),/remo)+'_'+fnames[w] + nf = n_elements(fnames) + + ; Note that lencols and col refer to the index of the + ; column before we started adding in the length + ; columns. + + if w eq nf-1 then begin + ; Subtract -1 for the length columns so 0 -> -1 and + ; we can distinguish this column. + + corres = [corres, -col-1 ] + fnames = [fnames, fnstr ] + fvalues = [fvalues, fvstr ] + scales = [scales, 1.0d0 ] + offsets = [offsets, 0.0d0 ] + + endif else begin + + corres = [corres[0:w],-col-1,corres[w+1:nf-1] ] + fnames = [fnames[0:w],fnstr,fnames[w+1:nf-1] ] + fvalues = [fvalues[0:w],fvstr,fvalues[w+1:nf-1] ] + scales = [scales[0:w], 1.0d0, scales[w+1:nf-1] ] + offsets = [offsets[0:w],0.0d0, offsets[w+1:nf-1] ] + endelse + endfor + endif + + endif else begin + + ; We'll just read data into pointer arrays. + for i=0,n_elements(lencols)-1 do begin + col = lencols[i] + if vtpes[col] eq 'A' then begin + fvalues[col] = '" "' + endif else begin + fvalues[col] = 'ptr_new()' + endelse + endfor + + endelse + + + + ; Generate a new table with the appropriate structure definitions + if ~scaling && ~keyword_set(columns) then begin + tablex = mrd_struct(fnames, fvalues, n_elements(table), structyp=structyp, $ + silent=silent) + endif else begin + tablex = mrd_struct(fnames, fvalues, n_elements(table), silent=silent) + endelse + + + if N_elements(rows) EQ 0 then nrow = range[1]-range[0]+1 $ + else nrow = N_elements(rows) + + ; I loops over the new table columns, col loops over the old table. + ; When col is negative, it is a length column. + for i=0, n_elements(fnames)-1 do begin + + col = corres[i] + + if col ge 0 then begin + + w = where(vcols eq col) + + ; First handle the case of a column that is not + ; variable length -- just copy the column. + + if w[0] eq -1 then begin + + tablex.(i) = table.(col) + + endif else begin + + vc = w[0] + ; Now handle the variable length columns + + ; If only one row in table, then + ; IDL will return curr_col as one-dimensional. + ; Since this is a variable length pointer column we + ; know that the dimension of the column is 2. + curr_col = table.(col) + + if (nrow eq 1) then curr_col = reform(curr_col,2,1) + siz = curr_col[0,*] + off = curr_col[1,*] + + ; Now process each type. + curr_colx = tablex.(i) + sz = size(curr_colx) + if (sz[0] lt 2) then begin + curr_colx = reform(curr_colx, 1, n_elements(curr_colx), /overwrite) + endif + + + ; As above we have to worry about IDL truncating + ; dimensions. This can happen if either + ; nrow=1 or the max dimension of the column is 1. + + + sz = size(tablex.(i)) + + nel = sz[sz[0]+2] + if (nrow eq 1) && (nel eq 1) then begin + curr_colx = make_array(1,1,value=curr_colx) + endif else if nrow eq 1 then begin + curr_colx = reform(curr_colx,[nel, 1], /overwrite) + endif else if nel eq 1 then begin + curr_colx = reform(curr_colx,[1, nrow], /overwrite) + endif + + vtype = vtypes[vc] + varying = 0 + if n_elements(lencols) gt 0 then begin + varying = where(lencols eq col) + if varying[0] eq -1 then varying=0 else varying=1 + endif + + if varying && keyword_set(pointer_var) && (vtype ne 'A') then begin + mrd_varcolumn, vtype, curr_colx, heap, off, siz + endif else begin + mrd_fixcolumn, vtype, curr_colx, heap, off, siz + endelse + + + + if nel eq 1 and nrow eq 1 then begin + curr_colx = curr_colx[0] + endif else if nrow eq 1 then begin + curr_colx = reform(curr_colx, nel, /overwrite) + endif else if nel eq 1 then begin + curr_colx = reform(curr_colx, nrow, /overwrite) + endif + + sz = size(curr_colx) + if sz[1] eq 1 then begin + sz_tablex = size(tablex.(i)) + sdimen = sz_tablex[1:sz_tablex[0]] + tablex.(i) = reform(curr_colx,sdimen) + endif else begin + tablex.(i) = curr_colx + endelse + + endelse + + endif else begin + ; Now handle the added columns which hold the lengths + ; of the variable length columns. + + ncol = -col - 1 ; Remember we subtracted an extra one. + xx = table.(ncol) + tablex.(i) = reform(xx[0,*]) + endelse + endfor + + ; Finally get rid of the initial table and return the table with the + ; variable arrays read in. + ; + table = temporary(tablex) + return +end + +; Read in the binary table information. +pro mrd_read_table, unit, range, rsize, structyp, nrows, nfld, typarr, table, rows = rows, $ + unixpipe = unixpipe +compile_opt idl2, hidden + ; + ; + ; Unit Unit to read data from. + ; Range Desired range + ; Rsize Size of row. + ; structyp Structure type. + ; Nfld Number of fields in structure. + ; Typarr Field types + ; Table Table to read information into. + ; + + if range[0] gt 0 then mrd_skip, unit, rsize*range[0] + readu,unit, table + if N_elements(rows) GT 0 then table = table[rows- range[0]] + + ; Move to the beginning of the heap -- we may have only read some rows of + ; the data. + if range[1] lt nrows-1 then begin + skip_dist = (nrows-range[1]-1)*rsize + mrd_skip, unit, skip_dist + endif + + + + ; If necessary then convert to native format. + if unixpipe then swap_endian_inplace,table,/swap_if_little + + + ; Handle unsigned fields. + for i=0, nfld-1 do begin + + type = mrd_unsignedtype(table.(i)) + + if type gt 0 then begin + table.(i) = table.(i) - mrd_unsigned_offset(type) + endif + + + endfor + end + + +; Check the values of TDIM keywords to see that they have valid +; dimensionalities. If the TDIM keyword is not present or valid +; then the a one-dimensional array with a size given in the TFORM +; keyword is used. + +pro mrd_tdim, header, index, flen, arrstr, no_tdim=no_tdim +compile_opt idl2, hidden + ; HEADER Current header array. + ; Index Index of current parameter + ; flen Len given in TFORM keyword + ; arrstr String returned to be included within paren's in definition. + ; no_tdim Disable TDIM processing + + arrstr = strcompress(string(flen),/remo) + + if keyword_set(no_tdim) then return + + tdstr = fxpar(header, 'TDIM'+strcompress(string(index),/remo)) + if tdstr eq '' then return + + ; + ; Parse the string. It should be of the form '(n1,n2,...nx)' where + ; all of the n's are positive integers and the product equals flen. + ; + tdstr = strcompress(tdstr,/remo) + len = strlen(tdstr) + if strmid(tdstr,0,1) ne '(' && strmid(tdstr,len-1,1) ne ')' || len lt 3 then begin + print, 'MRDFITS: Error: invalid TDIM for column', index + return + endif + + ; Get rid of parens. + tdstr = strmid(tdstr,1,len-2) + len = len-2 + + nind = 0 + cnum = 0 + + for nchr=0, len-1 do begin + c = strmid(tdstr,nchr, 1) + + if c ge '0' && c le '9' then begin + cnum = 10*cnum + long(c) + + endif else if c eq ',' then begin + + if cnum le 0 then begin + print,'MRDFITS: Error: invalid TDIM for column', index + return + endif + + if n_elements(numbs) eq 0 then $ + numbs = cnum $ + else numbs = [numbs,cnum] + + cnum = 0 + + endif else begin + + print,'MRDFITS: Error: invalid TDIM for column', index + return + + endelse + + endfor + + ; Handle the last number. + if cnum le 0 then begin + print,'MRDFITS: Error: invalid TDIM for column', index + return + endif + + if n_elements(numbs) eq 0 then numbs = cnum else numbs = [numbs,cnum] + + prod = 1 + + for i=0, n_elements(numbs)-1 do prod = prod*numbs[i] + + if prod ne flen then begin + print,'MRDFITS: Error: TDIM/TFORM dimension mismatch' + return + endif + + arrstr = tdstr +end + +; Define a structure to hold a FITS binary table. +pro mrd_table, header, structyp, use_colnum, $ + range, rsize, table, nrows, nfld, typarr, fnames, fvalues, $ + vcls, vtpes, scales, offsets, scaling, status, rows = rows, $ + silent=silent, columns=columns, no_tdim=no_tdim, $ + alias=alias, unsigned=unsigned, outalias=outalias,emptystring=emptystring + compile_opt idl2, hidden + ; + ; Header FITS header for table. + ; Structyp IDL structure type to be used for + ; structure. + ; N_call Number of times this routine has been called. + ; Table Structure to be defined. + ; Status Return status. + ; No_tdim Disable TDIM processing. + + table = 0 + + types = ['L', 'X', 'B', 'I', 'J', 'K', 'A', 'E', 'D', 'C', 'M', 'P','Q'] + arrstr = ['bytarr(', 'bytarr(', 'bytarr(', 'intarr(', 'lonarr(', 'lon64arr(', $ + 'string(replicate(32b,', 'fltarr(', 'dblarr(', 'complexarr(', $ + 'dcomplexarr(', 'lonarr(2*','lon64arr(2*'] + bitpix = [ 0, 0, 0, 16, 32, 64, 0, 0, 0, 0, 0, 0, 0] + + sclstr = ["'T'", '0B', '0B', '0', '0L', '0LL', '" "', '0.', '0.d0', 'complex(0.,0.)', $ + 'dcomplex(0.d0,0.d0)', 'lonarr(2)','lon64arr(2)'] + if keyword_set(emptystring) then begin + sclstr[6] = '0B' + arrstr[6] = 'bytarr(' + endif + unsarr = ['', '', '', 'uintarr(', 'ulonarr(', 'ulon64arr(']; + unsscl = ['', '', '', '0US', '0UL', '0ULL'] + + + status = 0 + +; NEW WAY: E.S.S. + + ;; get info from header. Using vectors is much faster + ;; when there are many columns + + mrd_fxpar, header, xten, nfld, nrow, rsize, fnames, fforms, scales, offsets + nnames = n_elements(fnames) + + tname = fnames + ;; nrow will change later + nrows = nrow + + ;; Use scale=1 if not found + if nnames GT 0 then begin + wsc=where(scales EQ 0.0d,nwsc) + IF nwsc NE 0 THEN scales[wsc] = 1.0d + endif + + xten = strtrim(xten,2) + if xten ne 'BINTABLE' and xten ne 'A3DTABLE' then begin + print, 'MRDFITS: ERROR - Header is not from binary table.' + nfld = 0 & status = -1 + return + endif + + if range[0] ge 0 then begin + range[0] = range[0] < (nrow-1) + range[1] = range[1] < (nrow-1) + endif else begin + range[0] = 0 + range[1] = nrow - 1 + endelse + + nrow = range[1] - range[0] + 1 + if nrow le 0 then begin + if ~keyword_set(silent) then $ + print, 'MRDFITS: Binary table. ', $ + strcompress(string(nfld)), ' columns, no rows.' + return + endif + + if N_elements(rows) EQ 0 then nrowp = nrow else begin + bad = where((rows LT range[0]) or (rows GT range[1]), Nbad) + if Nbad GT 0 then begin + print,'MRDFITS: Row numbers must be between 0 and ' + $ + strtrim(nrow-1,2) + status = -1 + return + endif + nrowp = N_elements(rows) + endelse +; rsize = fxpar(header, 'NAXIS1') + + ; + ; Loop over the columns + + typarr = strarr(nfld) + + fvalues = strarr(nfld) + dimfld = strarr(nfld) + + vcls = intarr(nfld) + vtpes = strarr(nfld) + + fnames2 = strarr(nfld) + + for i=0, nfld-1 do begin + + istr = strcompress(string(i+1), /remo) + + fname = fnames[i] + + ;; check for a name conflict + fname = mrd_dofn(fname, i+1, use_colnum, alias=alias) + + ;; check for a name conflict + fname = mrd_chkfn(fname, fnames2, i, SILENT=silent) + + ;; copy in the valid name + fnames[i] = fname + ;; for checking conflicts + fnames2[i] = fname + + fform = fforms[i] + + mrd_doff, fform, dim, ftype + + ; Treat arrays of length 1 as scalars. + if dim eq 1 then begin + dim = 0 + endif else if dim EQ -1 then begin + dimfld[i] = -1 + endif else begin + mrd_tdim, header, i+1, dim, str, no_tdim=no_tdim + dimfld[i] = str + endelse + + typarr[i] = ftype + + + ; Find the number of bytes in a bit array. + + if ftype eq 'X' && (dim gt 0) then begin + dim = (dim+7)/8 + dimfld[i] = strtrim(string(dim),2) + endif + + ; Add in the structure label. + ; + + ; Handle variable length columns. + + if (ftype eq 'P') || (ftype eq 'Q') then begin + + if (dim ne 0) && (dim ne 1) then begin + print, 'MRDFITS: Invalid dimension for variable array column '+string(i+1) + status = -1 + return + endif + + ppos = ftype eq 'P' ? strpos(fform, 'P') : strpos(fform, 'Q') + vf = strmid(fform, ppos+1, 1); + if strpos('LXBIJKAEDCM', vf) eq -1 then begin + print, 'MRDFITS: Invalid type for variable array column '+string(i+1) + status = -1 + return + endif + + vcls[i] = 1 + + + xunsigned = mrd_chkunsigned(bitpix[ppos], scales[i], $ + offsets[i], $ + unsigned=unsigned) + + if (xunsigned) then begin + + if vf eq 'I' then vf = '1' $ + else if vf eq 'J' then vf = '2' $ + else if vf eq 'K' then vf = '3' + + endif + + vtpes[i] = vf + dim = 0 + + endif + + + for j=0, n_elements(types) - 1 do begin + + if ftype eq types[j] then begin + + xunsigned = mrd_chkunsigned(bitpix[j], scales[i], $ + offsets[i], $ + unsigned=unsigned) + + if xunsigned then begin + fxaddpar, header, 'TZERO'+istr, 0, 'Modified by MRDFITS V'+mrd_version() + offsets[i] = 0 ;; C. Markwardt Aug 2007 - reset to zero so offset is not applied twice' + endif + if dim eq 0 then begin + + fvalues[i] = xunsigned ? unsscl[j] : sclstr[j] + + endif else begin + + line = xunsigned ? unsarr[j] : arrstr[j] + + line += dimfld[i] + ')' + if ~keyword_set(emptystring) then $ + if ftype eq 'A' then line += ')' + fvalues[i] = line + + endelse + + goto, next_col + + endif + + endfor + + print, 'MRDFITS: Invalid format code:',ftype, ' for column ', i+1 + status = -1 + return + next_col: + endfor + + ; Check if there are any variable length columns. If not then + ; undefine vcls and vtpes + w = where(vcls eq 1, N_w) + if N_w eq 0 then begin + dummy = temporary(vcls) + dummy = temporary(vtpes) + dummy = 0 + endif + + if scaling then begin + w = where( (scales ne 1.0d0) or (offsets ne 0.0d0), Nw) + scaling = Nw GT 0 + endif + + zero = where(long(dimfld) LT 0L, N_zero) + if N_zero GT 0 then begin + + if N_zero Eq nfld then begin + print,'MRDFITS: Error - All fields have zero length' + return + endif + + for i=0, N_zero-1 do begin + print,'MRDFITS: Table column ' + fnames[zero[i]] + ' has zero length' + endfor + + nfld = nfld - N_zero + good = where(dimfld GE 0) + fnames = fnames[good] + fvalues = fvalues[good] + typarr = typarr[good] ;Added 2005-1-6 (A.Csillaghy) + tname = tname[good] + + endif + + if n_elements(vcls) eq 0 && (~scaling) && ~keyword_set(columns) then begin + + table = mrd_struct(fnames, fvalues, nrow, structyp=structyp, silent=silent ) + + endif else begin + + table = mrd_struct(fnames, fvalues, nrow, silent=silent ) + + endelse + + if ~keyword_set(silent) then begin + print, 'MRDFITS: Binary table. ',strcompress(string(nfld)), ' columns by ', $ + strcompress(string(nrowp)), ' rows.' + if n_elements(vcls) gt 0 then begin + print, 'MRDFITS: Uses variable length arrays' + endif + endif + + outalias = transpose([[tag_names(table)],[tname] ]) + status = 0 + return + +end + +function mrdfits, file, extension, header, $ + structyp = structyp, $ + use_colnum = use_colnum, $ + range = range, $ + dscale = dscale, fscale=fscale, $ + fpack = fpack, no_fpack = no_fpack, $ + silent = silent, $ + columns = columns, $ + no_tdim = no_tdim, $ + error_action = error_action, $ + compress=compress, $ + alias=alias, $ + rows = rows, $ + unsigned=unsigned, $ + version=version, $ + pointer_var=pointer_var, $ + fixed_var=fixed_var, $ + outalias = outalias, $ + emptystring = emptystring, $ + status=status, extnum = extnum + + compile_opt idl2 + ; Let user know version if MRDFITS being used. + if keyword_set(version) then $ + print,'MRDFITS: Version '+mrd_version() + 'April 24, 2014' + + + if N_elements(error_action) EQ 0 then error_action = 2 + On_error, error_action + + ; Check positional arguments. + + if n_params() le 0 || n_params() gt 3 then begin + if keyword_set(version) then return, 0 + print, 'MRDFITS: Usage' + print, ' a=mrdfits(file/unit, [exten_no/exten_name, header], /version $' + print, ' /fscale, /dscale, /unsigned, /use_colnum, /silent $' + print, ' range=, rows= , structyp=, columns=, $' + print, ' /pointer_var, /fixed_var, error_action=, status= )' + return, 0 + endif + + if n_params() eq 1 then extension = 0 + + ; Check optional arguments. + ; + ; *** Structure name *** + + if keyword_set(structyp) then begin + sz = size(structyp) + if sz[0] ne 0 then begin + ; Use first element of array + structyp = structyp[0] + sz = size(structyp[0]) + endif + + if sz[1] ne 7 then begin + print, 'MRDFITS: stucture type must be a string' + return, 0 + endif + endif + + ; *** Use column numbers not names? + use_colnum = keyword_set(use_colnum) + + ; *** Get only a part of the FITS file. + if N_elements(rows) GT 0 then begin + range1 = min(rows,max=range2) + range = [range1,range2] + endif + if keyword_set(range) then begin + if n_elements(range) eq 2 then arange = range $ + else if n_elements(range) eq 1 then arange = [0,range[0]-1] $ + else if n_elements(range) gt 2 then arange = range[0:1] $ + else if n_elements(range) eq 0 then arange = [-1,-1] + + endif else begin + arange = [-1,-1] + endelse + + arange = long64(arange) + + ; Open the file and position to the appropriate extension then read + ; the header. + + if (N_elements(file) GT 1 ) then begin + print, 'MRDFITS: Vector input not supported' + return, 0 + endif + + inputUnit = 0 + + dtype = size(file,/type) + if (dtype gt 0) && (dtype lt 4) then begin ;File unit number specified + + inputUnit = 1 + unit = file + unixpipe = (fstat(unit)).size EQ 0 ;Unix pipes have no files size + if fxmove(unit,extension) lt 0 then return, -1 + + endif else begin ;File name specified + + unit = fxposit(file, extension, compress=compress, unixpipe=unixpipe, $ + /readonly,extnum=extnum, errmsg= errmsg, fpack=fpack) + + if unit lt 0 then begin + message, 'File access error',/CON + if errmsg NE '' then message,errmsg,/CON + if scope_level() GT 2 then help,/trace + status = -1 + return, 0 + endif + endelse + + if eof(unit) then begin + message,'ERROR - Extension past EOF',/CON + if inputUnit eq 0 then free_lun,unit + status = -2 + return, 0 + endif + + mrd_hread, unit, header, status, SILENT = silent, ERRMSG = errmsg + + if status lt 0 then begin + message,'ERROR - ' +errmsg,/CON + message, 'ERROR - FITS file may be invalid or corrupted',/CON + if inputUnit eq 0 then free_lun,unit + return, 0 + endif + +; + ; If this is primary array then XTENSION will have value + ; 0 which will be converted by strtrim to '0' + + xten = strtrim( fxpar(header,'XTENSION'), 2) + if xten eq '0' || xten eq 'IMAGE' then type = 0 $ + else if xten eq 'TABLE' then type = 1 $ + else if xten eq 'BINTABLE' || xten eq 'A3DTABLE' then type = 2 $ + else begin + message, 'Unable to process extension type:' + strtrim(xten,2),/CON + if inputUnit eq 0 then free_lun,unit + status = -1 + return, 0 + endelse + + scaling = keyword_set(fscale) || keyword_set(dscale) + + if type eq 0 then begin + + ;*** Images/arrays + + mrd_image, header, arange, maxd, rsize, table, scales, offsets, $ + scaling, status, silent=silent, unsigned=unsigned, $ + rows= rows + if (status ge 0) && (rsize gt 0) then begin + mrd_read_image, unit, arange, maxd, rsize, table, rows = rows,$ + status=status, unixpipe=unixpipe + endif + size = rsize + endif else if type eq 1 then begin + + ;*** ASCII tables. + + mrd_ascii, header, structyp, use_colnum, $ + arange, table, nbytes, nrows, nfld, rows=rows, $ + typarr, posarr, lenarr, nullarr, fnames, fvalues, $ + scales, offsets, scaling, status, silent=silent, $ + columns=columns, alias=alias, outalias=outalias + size = nbytes*nrows + + if (status ge 0) && (size gt 0) then begin + + ;*** Read data. + mrd_read_ascii, unit, arange, nbytes, nrows, $ + nfld, typarr, posarr, lenarr, nullarr, table, rows= rows + + ;*** Extract desired columns. + if (status ge 0) && keyword_set(columns) then $ + mrd_columns, table, columns, fnames, fvalues, vcls, vtps, $ + scales, offsets, scaling, structyp=structyp, silent=silent + endif + + endif else begin + + ; *** Binary tables. + + mrd_table, header, structyp, use_colnum, $ + arange, rsize, table, nrows, nfld, typarr, $ + fnames, fvalues, vcls, vtpes, scales, offsets, scaling, status, $ + silent=silent, columns=columns, no_tdim=no_tdim, $ + alias=alias, unsigned=unsigned, rows = rows, outalias = outalias, $ + emptystring=emptystring + + size = nfld*(arange[1] - arange[0] + 1) + if (status ge 0) && (size gt 0) then begin + + ;*** Read data. + mrd_read_table, unit, arange, rsize, rows = rows, $ + structyp, nrows, nfld, typarr, table, unixpipe=unixpipe + + if (status ge 0) && keyword_set(columns) then begin + + ;*** Extract desired columns. + mrd_columns, table, columns, fnames, fvalues, $ + vcls, vtpes, scales, offsets, scaling, structyp=structyp, $ + silent=silent + + endif + + if keyword_set(emptystring) then $ + mrd_string, table, header, typarr, $ + fnames, fvalues, 1+arange[1]-arange[0], structyp=structyp, silent=silent + + if (status ge 0) && n_elements(vcls) gt 0 then begin + + ;*** Get variable length columns + mrd_read_heap, unit, header, arange, fnames, fvalues, $ + vcls, vtpes, table, structyp, scaling, scales, offsets, status, $ + silent=silent, pointer_var=pointer_var, fixed_var=fixed_var, rows= rows + + endif else begin + + ; Skip remainder of last data block + sz = long64(fxpar(header, 'NAXIS1'))* $ + long64(fxpar(header,'NAXIS2')) + $ + long64(fxpar(header, 'PCOUNT')) + skipB = 2880 - sz mod 2880 + if (skipB ne 2880) then mrd_skip, unit, skipB + endelse + + endif + + endelse + + + ; Don't tie up a unit number that we allocated in this routine. + if (unit gt 0) && (inputUnit eq 0) then free_lun, unit + +; If any of the scales are non-unity, or any of the offsets are nonzero then +; apply scalings. + + if (status ge 0) && scaling && (size gt 0) then begin + noscale = array_equal(scales,1.d0) && array_equal(offsets,0.0) + + if ~noscale then mrd_scale, type, scales, offsets, table, header, $ + fnames, fvalues, 1+arange[1]-arange[0], structyp=structyp, $ + dscale=dscale, silent=silent + endif + + ; All done. Check the status to see if we ran into problems on the way. + + if status ge 0 then return, table else return,0 + +end diff --git a/modules/idl_downloads/astro/pro/multinom.pro b/modules/idl_downloads/astro/pro/multinom.pro new file mode 100644 index 0000000..d11fd0d --- /dev/null +++ b/modules/idl_downloads/astro/pro/multinom.pro @@ -0,0 +1,81 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; MULTINOM +; PURPOSE: +; SIMULATE MULTINOMIAL RANDOM VARIABLES +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., APR 2006 +; +; INPUTS : +; +; N - THE NUMBER OF TRIALS +; P - A K-ELEMENT VECTOR CONTAINING THE PROBABILITIES FOR EACH +; CLASS. +; +; OPTIONAL INPUTS : +; +; NRAND - THE NUMBER OF RANDOM VARIABLES TO DRAW +; SEED - THE SEED FOR THE RANDOM NUMBER GENERATOR +; +; OUTPUT : +; NRAND RANDOM DRAWS FROM A MULTINOMIAL DISTRIBUTION WITH PARAMETERS +; N AND P. +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function multinom, n, p, nrand, seed=seed + +if n_params() lt 2 then begin + print, 'Syntax- theta = multinom( n, p,[ nrand, seed=seed] )' + return, 0 +endif + +k = n_elements(p) + +bad = where(p lt 0 or p gt 1, nbad) +if nbad gt 0 then begin + print, 'All element of p must be 0 <= p <= 1.' + return, 0 +endif + +if n lt 1 then begin + print, 'N must be at least 1.' + return, 0 +endif + +if n_elements(nrand) eq 0 then nrand = 1 + + ;check if binomial +if k eq 2 then begin + + binom = randomu(seed, nrand, binomial=[n, p[0]], /double) + multi = [[binom], [n - binom]] + + return, transpose(multi) + +endif + +multi = lonarr(k, nrand) + +for i = 0L, nrand - 1 do begin + + multi[0,i] = randomu(seed, 1, binomial=[n, p[0]], /double) + j = 1L + nj = n - total(multi[0:j-1,i]) + + while nj gt 0 do begin + + pj = p[j] / total(p[j:*]) + + multi[j,i] = randomu(seed, 1, binomial=[nj,pj], /double) + + j = j + 1 + nj = n - total(multi[0:j-1,i]) + + endwhile + +endfor + +return, multi +end diff --git a/modules/idl_downloads/astro/pro/multiplot.pro b/modules/idl_downloads/astro/pro/multiplot.pro new file mode 100644 index 0000000..0dea920 --- /dev/null +++ b/modules/idl_downloads/astro/pro/multiplot.pro @@ -0,0 +1,555 @@ +;+ +; Name: +; MULTIPLOT +; +; Purpose: +; Create multiple plots with simple control over the gaps between plots. +; By default, the gap is zero but this can be set with the +; gap= keyword, or xgap=, ygap= for individual control over different axes. +; You can also place a single title along the x, y and top axes of the +; matrix of plots using the mtitle, mxtitle and mytitle keywords. +; +; It is good for data with one or two shared axes and retains all the +; versatility of the plot commands (e.g. all keywords and log scaling). +; The plots are connected with the shared axes, which saves space by +; omitting redundant ticklabels and titles. Multiplot does this by +; setting !p.position, !x.tickname and !y.tickname automatically. +; A call (multiplot,/reset) restores original values. +; +; Coyote graphics users can find similar functionality in CGLAYOUT +; http://www.idlcoyote.com/idldoc/cg/cglayout.html +; Users of the post-8.0 IDL function graphics can find similar functionality +; in Paulo Penteado's routine PP_MULTIPLOT +; http://ppenteado.net/idl/pp_lib/doc/pp_multiplot__define.html +; CALLING SEQUENCE: +; multiplot, pmulti, +; gap=, xgap=, ygap=, +; /square, +; /doxaxis, /doyaxis, +; mTitle=, mTitSize=, mTitOffset=, +; mxTitle=, mxTitSize=, mxTitOffset=, +; myTitle=, myTitSize=, myTitOffset=, +; xtickformat=, ytickformat= +; /default, /reset, /rowmajor, /initialize +; +; INPUTS: +; pmulti: Optional input. [Nx,Ny] array describing the shape of the +; matrix of plots. This is equivalent to the 2nd and 3rd elements +; of !p.multi. Or you can send all 5 elements of the !p.multi. +; +; KEYWORD INPUTS: +; gap=: Set the gap between plots in normalized units. Default is 0. +; This input overrides the xgap and ygap inputs. +; xgap=: Gap between plots in the x direction. Default 0. To set both +; x and y gap to the same value just use the gap keyword. +; ygap=: Gap between plots in the y direction. Default 0. To set both +; x and y gap to the same value just use the gap keyword. +; +; mTitle: A single title to go across the top of the matrix of plots, +; as opposed to the plot over single plots you generate with the +; plot command for example. +; mTitSize: The font size of the top title. Default is 1.25*!p.charsize +; mTitOffset: Offset of the title in the y-direction. +; mxTitle, mxTitSize, mxTitOffset: same as above but for the x-axis title +; myTitle, myTitSize, myTitOffset: same as above but for the y-axis title +; +; xtickformat, ytickformat: Set the default tick formats when the ticks +; are plotted. This allows the user to avoid sending this to each +; plotting command which can have unexpected results if that axis +; was not to get tick labels in a given point in the matrix. +; +; KEYWORDS SWITCHES: +; /square: Force the axis ratio of each plot to be square. Note if +; xgap and ygap are set to different values, this axis ratio will +; not be preserved. It will be preserved if gap= is used. +; +; /doxaxis: Put axis labels, etc on the axis. Default is to place labels +; only on the left side and bottom sides of the plot matrix, but may +; be useful when some cells are empty; for example the x-axis of +; a 2x2 grid when only 3 total plots will be created. +; /doyaxis: Put axis labels, etc on the yxis. Default is to place labels +; only on the left side and bottom sides of the plot matrix, but may +; be useful when some cells are empty; for example the x-axis of +; a 2x2 grid when only 3 total plots will be created. +; +; /rowmajor: Like setting 5th element of !p.multi to 1. +; /reset: Set plotting parameters to their saved values from before +; multiplot was initially called. +; /default: Set plotting parameters to IDL defaults. This is useful +; when the saved parameters get in a whacky state. +; /initialize: Just do the initialization. This is what happends when +; you first call multiplot anyway. +; +; EXAMPLES: +; ; Make an array of plots [4,3] with a gap of 0.1 (in norm. coords.) +; ; and overall titles along the x and y axes as given. Force the +; ; plots to be square. +; +; cgerase & multiplot, [4,3], /square, gap=0.1, mXtitle='R', mYtitle='F(R)' +; for i=0,4*3-1 do begin +; cgplot, struct[i].x, struct[i].y, psym=4 +; multiplot +; endfor +; multiplot,/reset +; +; Side Effects: +; Multiplot sets a number of system variables: !p.position, !p.multi, +; !x.tickname, !y.tickname, !P.noerase---but all can be reset with +; the call: multiplot,/reset +; +; Things can get out of wack if your program crashes in the middle of +; making a matrix of plots, and often /reset will not fix it. In those +; cases, calling multiplot,/default will often fix the problem. +; +; Restrictions: +; 1. If you use !p.multi as the method of telling how many plots +; are present, you have to set !p.multi at the beginning each time you +; use multiplot or call multiplot with the /reset keyword. +; 2. There is no way to make plots of different sizes; each plot +; covers the same area on the screen or paper. +; +; Modification history: +; write, 21-23 Mar 94, Fred Knight (knight@ll.mit.edu) +; alter plot command that sets !x.window, etc. per suggestion of +; Mark Hadfield (hadfield@storm.greta.cri.nz), 7 Apr 94, FKK +; add a /default keyword restore IDL's default values of system vars, +; 7 Apr 94, FKK +; modify two more sys vars !x(y).tickformat to suppress user-formatted +; ticknames, per suggestion of Mark Hadfield (qv), 8 Apr 94, FKK +; +; 2001-03-20 Added /square keyword +; Work in device coordinates so we can force aspect ratio to be square +; if requested. Erin Scott Sheldon UMichigan +; +; 2007-06-18 +; Can now place titles on the overall x and y axes, as well as a +; top title using these new keywords. +; mTitle=, mTitSize=, mTitOffset=, +; mxTitle=, mxTitSize=, mxTitOffset=, +; myTitle=, myTitSize=, myTitOffset=, +; Can also control overall tick formats. Useful because can just call +; multiplot initially and set this, while calling on each call to +; the plotting program will have unexpected results if the ticks +; are not to be labelled for that place in the matrix. +; xtickformat, ytickformat +; Erin Sheldon, NYU +; 2007-08-28: +; Can now add gaps between the plots with these keywords: +; gap=, xgap=, ygap= +; where the values are in normalized coordinates. Erin Sheldon, NYU +; 2009-11-23 +; Initialize common block if M[X/Y]TITLE set W. Landsman +; 2011-02-07 +; Use Coyote Graphics W. Landsman +; 2012-03-21 +; Use cgplot on initial call to get right background W.L. +; 2014-02-04 +; Handle [X/Y].OMargin A. Negri, Bologna +; +;- + +PRO multiplot, pmulti, help=help, $ + initialize=initialize, reset=reset, default=default, $ + rowmajor=rowmajor,verbose=verbose, square=square, $ + gap=gap_in, xgap=xgap_in, ygap=ygap_in, $ + doxaxis=doxaxis, doyaxis=doyaxis, $ + xtickformat=xtickformat_in, ytickformat=ytickformat_in, $ + mtitle=mtitle, mTitSize=mTitSize, mTitOffset=mTitOffset, $ + mxTitle=mxTitle, mxTitSize=mxTitSize, mxTitOffset=mxTitOffset, $ + myTitle=myTitle, myTitSize=myTitSize, myTitOffset=myTitOffset + + + + + common multiplot $ + ,nplots $ ; [# of plots along x, # of plots along y] + ,nleft $ ; # of plots remaining---like the first element of !p.multi + ,pdotmulti $ ; saved value of !p.multi + ,margins $ ; calculated margins based on !p.multi or pmulti + ,pposition $ ; saved value of !p.position + ,colmajor $ ; flag for column major order + ,noerase $ ; saved value of !p.noerase + ,sqplot $ ; should be make it square? + ,xtickname $ ; Original value + ,ytickname $ ; Original value + ,xtickformat_orig $ ; Original value + ,ytickformat_orig $ + ,xtickformat $ ; Value we will use + ,ytickformat $ + ,gap $ + ,xgap $ + ,ygap + + ; help message + if keyword_set(help) then begin + doc_library,'multiplot' + return + endif + + + ; restore idl's default values (kill multiplot's influence) + if keyword_set(default) then begin + !p.position = 0 + !x.tickname = '' + !y.tickname = '' + !x.tickformat = '' + !y.tickformat = '' + !p.multi = 0 + !p.noerase = 0 + nleft = 0 + nplots = [1,1] + pdotmulti = !p.multi + margins = 0 + sqplot=0 + pposition = !p.position + noerase = !p.noerase + xtickname = !x.tickname + ytickname = !y.tickname + xtickformat = !x.tickformat + ytickformat = !y.tickformat + + gap=0.0 + xgap=0.0 + ygap=0.0 + if keyword_set(verbose) then begin + message,/inform,$ + 'Restore IDL''s defaults for affected system variables.' + message,/inform,$ + 'Reset multiplot''s common to IDL''s defaults.' + endif + return + endif + + ; restore saved system variables + if keyword_set(reset) then begin + if n_elements(pposition) gt 0 then begin + !p.position = pposition + !x.tickname = xtickname + !y.tickname = ytickname + !x.tickformat = xtickformat_orig + !y.tickformat = ytickformat_orig + !p.multi = pdotmulti + !p.noerase = noerase + sqplot=0 + endif + nleft = 0 + if keyword_set(verbose) then begin + coords = '['+string(!p.position,form='(3(f4.2,","),f4.2)')+']' + multi = '['+string(!p.multi,form='(4(i2,","),i2)')+']' + message,/inform,'Reset. !p.position='+coords+', !p.multi='+multi + endif + gap=0.0 + xgap=0.0 + ygap=0.0 + return + endif + + ; + ; Now the user inputs + ; + + ; How big are the gaps between the plots? + if n_elements(gap) eq 0 then begin + ; initial set up of common block values + xgap=0.0 + ygap=0.0 + gap=0.0 + endif + + if n_elements(xgap_in) ne 0 then xgap=xgap_in + if n_elements(ygap_in) ne 0 then ygap=ygap_in + + ; gap will override any previously set values + if n_elements(gap_in) ne 0 then begin + gap=gap_in + xgap=gap + ygap=gap + endif + + + ; + ; Set up the plot layout + ; + + ; Shall we force the individual plots to be square? + if keyword_set(square) then sqplot=1 else begin + if n_elements(sqplot) eq 0 then sqplot=0 + endelse + + + ; number of plots left in the grid + if n_elements(nleft) eq 1 then init = (nleft eq 0) else init = 1 + if (n_elements(pmulti) eq 2) or (n_elements(pmulti) eq 5) then init = 1 + if (n_elements(!p.multi) eq 5) then begin + if (!p.multi[1] gt 0) and (!p.multi[2] gt 0) then begin + init = (!p.multi[0] eq 0) + endif + endif + + if ~init then init = keyword_set(mxtitle) || keyword_set(mytitle) || $ + keyword_set(mtitle) + + ; initialize if we are on the first plot + + if init or keyword_set(initialize) then begin + case n_elements(pmulti) of + 0:begin + if n_elements(!p.multi) eq 1 then return ; NOTHING TO SET + if n_elements(!p.multi) ne 5 then begin + message,'Bogus !p.multi; aborting.' + endif + nplots = !p.multi[1:2] > 1 + if keyword_set(rowmajor) then begin + colmajor = 0 + endif else begin + colmajor = !p.multi[4] eq 0 + endelse + end + 2:begin + nplots = pmulti + colmajor = not keyword_set(rowmajor) + end + 5:begin + nplots = pmulti[1:2] + if keyword_set(rowmajor) then begin + colmajor = 0 + endif else begin + colmajor = pmulti[4] eq 0 + endelse + end + else: message,'pmulti can only have 0, 2, or 5 elements.' + endcase + + pposition = !p.position ; save sysvar to be altered + xtickname = !x.tickname + ytickname = !y.tickname + + ; keep original values for resetting + xtickformat_orig = !x.tickformat + ytickformat_orig = !y.tickformat + + ; what will we actually plot when ticks are exposed? + if n_elements(xtickformat_in) ne 0 then begin + xtickformat=xtickformat_in + endif else begin + xtickformat=xtickformat_orig + endelse + if n_elements(ytickformat_in) ne 0 then begin + ytickformat=ytickformat_in + endif else begin + ytickformat=ytickformat_orig + endelse + + pdotmulti = !p.multi + nleft = nplots[0]*nplots[1] ; total # of plots + + !p.position = 0 ; reset + !p.multi = 0 + + ; set window & region + + cgplot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noerase + + px = !x.window*!d.x_vsize + py = !y.window*!d.y_vsize + xsize = px[1] - px[0] + ysize = py[1] - py[0] + + ; in normlized coordinates + + ;Andrea Negri modification + nmargins = [min(!x.window)-min(!x.region) $ + +!d.x_ch_size*!x.omargin[0]/double(!d.x_vsize), $ + min(!y.window)-min(!y.region) $ + +!d.y_ch_size*!y.omargin[0]/double(!d.y_vsize), $ + max(!x.region)-max(!x.window) $ + +!d.x_ch_size*!x.omargin[1]/double(!d.x_vsize), $ + max(!y.region)-max(!y.window) $ + +!d.y_ch_size*!y.omargin[1]/double(!d.y_vsize)] + + ;in device coord + margins = nmargins + margins[0] = nmargins[0]*!d.x_vsize + margins[2] = nmargins[2]*!d.x_vsize + margins[1] = nmargins[1]*!d.y_vsize + margins[3] = nmargins[3]*!d.y_vsize + + noerase = !p.noerase + !p.noerase = 1 ; !p.multi does the same + if keyword_set(verbose) then begin + major = ['across then down (column major).',$ + 'down then across (row major).'] + if colmajor then index = 0 else index = 1 + message,/inform,'Initialized for '+strtrim(nplots[0],2) $ + +'x'+strtrim(nplots[1],2)+', plotted '+major[index] + endif + + if keyword_set(initialize) then return + endif + + ; + ; Define the plot region without using !p.multi. + ; + + cols = nplots[0] ; for convenience + rows = nplots[1] + nleft = nleft - 1 ; decrement plots remaining + cur = cols*rows - nleft ; current plot #: 1 to cols*rows + + ; device coords per plot + idx = [(!d.x_vsize-margins[0]-margins[2])/cols, $ + (!d.y_vsize-margins[1]-margins[3])/rows] + + ;; force to be square if requested + if sqplot then begin + if idx[0] lt idx[1] then idx[1]=idx[0] else idx[0]=idx[1] + endif + + if colmajor then begin ; location in matrix of plots + col = cur mod cols + if col eq 0 then col = cols + row = (cur-1)/cols + 1 + endif else begin ; here (1,2) is 1st col, 2nd row + row = cur mod rows + if row eq 0 then row = rows + col = (cur-1)/rows + 1 + endelse + + + pos = $ + [(col-1)*idx[0], (rows-row)*idx[1], $ + col*idx[0], (rows-row+1)*idx[1]] $ + + $ + [margins[0], margins[1], $ + margins[0], margins[1]] + + ; back to normalized coords + pos[0] = pos[0]/!d.x_vsize + pos[2] = pos[2]/!d.x_vsize + pos[1] = pos[1]/!d.y_vsize + pos[3] = pos[3]/!d.y_vsize + + ; add gaps + pos[0] = pos[0] + xgap + pos[2] = pos[2] - xgap + + pos[1] = pos[1] + ygap + pos[3] = pos[3] - ygap + + ; + ; Finally set the system variables; user shouldn't change them. + ; + + !p.position = pos + onbottom = (row eq rows) or (rows eq 1) + onleft = (col eq 1) or (cols eq 1) + IF keyword_set(doxaxis) THEN onbottom=1 + IF keyword_set(doyaxis) THEN onleft=1 + if onbottom then begin + !x.tickname = xtickname + endif else begin + !x.tickname = replicate(' ',30) + endelse + if onleft then !y.tickname = ytickname else !y.tickname = replicate(' ',30) + if onbottom then !x.tickformat = xtickformat else !x.tickformat = '' + if onleft then !y.tickformat = ytickformat else !y.tickformat = '' + if keyword_set(verbose) then begin + coords = '['+string(pos,form='(3(f4.2,","),f4.2)')+']' + plotno = 'Setup for plot ['+strtrim(col,2)+','+strtrim(row,2)+'] of ' $ + +strtrim(cols,2)+'x'+strtrim(rows,2) + message,/inform,plotno+' at '+coords + endif + + + + ; Add titles to overall axes + + ; area covered by entire plot field in device coords + allpos = $ + [0, 0, cols*idx[0], rows*idx[1]] + $ + [margins[0], margins[1], margins[0], margins[1]] + ;; back to normalized coords + allpos[0] = allpos[0]/!d.x_vsize + allpos[2] = allpos[2]/!d.x_vsize + allpos[1] = allpos[1]/!d.y_vsize + allpos[3] = allpos[3]/!d.y_vsize + + xCharSizeNorm = float(!d.x_ch_size) / float(!d.x_size) + yCharSizeNorm = float(!d.y_ch_size) / float(!d.y_size) + + ; top title + if n_elements(mTitle) ne 0 then begin + if n_elements(mTitSize) eq 0 then mTitSize = 1.0 + if n_elements(mTitOffset) eq 0 then mTitOffset = 0.0 + + ; align middle of region in x + xpos = (allpos[2] - allpos[0])/2.0 + nmargins[0] + ; align relative to the top. Default is right there plus + ; one character size. + ypos = allpos[3] + (mTitOffset+1.0)*yCharSizeNorm + + ; correct for gaps + ypos = ypos - ygap + cgtext, $ + xpos, $ + ypos, $ + mTitle, $ + /normal, $ + align = 0.5, $ + charsize = 1.25 * mTitSize + endif + + ; x title + if n_elements(mxTitle) ne 0 then begin + if n_elements(mxTitSize) eq 0 then mxTitSize = 1.0 + if n_elements(mxTitOffset) eq 0 then mxTitOffset = 0.0 + + ; align middle of region in x + xpos = (allpos[2] - allpos[0])/2.0 + nmargins[0] + + ; align middle of region in x + ypos = allpos[1] - (mxTitOffset+3.0)*yCharSizeNorm + + ; correct for gaps + ypos = ypos + ygap + cgtext, $ + xpos, $ + ypos, $ + mxTitle, $ + /normal, $ + align = 0.5, $ + charsize = mxTitSize + endif + + + + ; y title + if n_elements(myTitle) ne 0 then begin + if n_elements(myTitSize) eq 0 then myTitSize = 1.0 + if n_elements(myTitOffset) eq 0 then myTitOffset = 0.0 + + ; align relative to the left side. Default is right there plus + ; one character size. + xpos = allpos[0] - (myTitOffset+6.0)*xCharSizeNorm + ;xpos = allpos[0] - (myTitOffset+4.0)*xCharSizeNorm + + ; align middle of region in x + ypos = (allpos[3] - allpos[1])/2.0 + nmargins[1] + + + ; correct for gaps + xpos = xpos + xgap + + cgtext, $ + xpos, $ + ypos, $ + myTitle, $ + /normal, $ + align = 0.5, $ + orientation = 90.0, $ + charsize = myTitSize + endif + + +return +end diff --git a/modules/idl_downloads/astro/pro/mwrfits.pro b/modules/idl_downloads/astro/pro/mwrfits.pro new file mode 100644 index 0000000..28f7102 --- /dev/null +++ b/modules/idl_downloads/astro/pro/mwrfits.pro @@ -0,0 +1,1731 @@ +;+ +; NAME: +; MWRFITS +; PURPOSE: +; Write all standard FITS data types from input arrays or structures. +; +; EXPLANATION: +; Must be used with a post-September 2009 version of FXADDPAR. +; +; CALLING SEQUENCE: +; MWRFITS, Input, Filename, [Header], +; /LSCALE , /ISCALE, /BSCALE, +; /USE_COLNUM, /Silent, /Create, /No_comment, /Version, $ +; Alias=, /ASCII, Separator=, Terminator=, Null=, +; /Logical_cols, /Bit_cols, /Nbit_cols, +; Group=, Pscale=, Pzero=, Status= +; +; INPUTS: +; Input = Array or structure to be written to FITS file. +; +; -When writing FITS primary data or image extensions +; input should be an array. +; --If data is to be grouped +; the Group keyword should be specified to point to +; a two dimensional array. The first dimension of the +; Group array will be PCOUNT while the second dimension +; should be the same as the last dimension of Input. +; --If Input is undefined, then a dummy primary dataset +; or Image extension is created [This might be done, e.g., +; to put appropriate keywords in a dummy primary +; HDU]. +; +; -When writing an ASCII table extension, Input should +; be a structure array where no element of the structure +; is a structure or array (except see below). +; --A byte array will be written as A field. No checking +; is done to ensure that the values in the byte field +; are valid ASCII. +; --Complex numbers are written to two columns with '_R' and +; '_I' appended to the TTYPE fields (if present). The +; complex number is enclosed in square brackets in the output. +; --Strings are written to fields with the length adjusted +; to accommodate the largest string. Shorter strings are +; blank padded to the right. +; +; -When writing a binary table extension, the input should +; be a structure array with no element of the structure +; being a substructure. +; +; If a structure is specified on input and the output +; file does not exist or the /CREATE keyword is specified +; a dummy primary HDU is created. +; +; Filename = String containing the name of the file to be written. +; By default MWRFITS appends a new extension to existing +; files which are assumed to be valid FITS. The /CREATE +; keyword can be used to ensure that a new FITS file +; is created even if the file already exists. +; +; OUTPUTS: +; +; OPTIONAL INPUTS: +; Header = Header should be a string array. Each element of the +; array is added as a row in the FITS header. No +; parsing is done of this data. MWRFITS will prepend +; required structural (and, if specified, scaling) +; keywords before the rows specified in Header. +; Rows describing columns in the table will be appended +; to the contents of Header. +; Header lines will be extended or truncated to +; 80 characters as necessary. +; If Header is specified then on return Header will have +; the header generated for the specified extension. +; +; OPTIONAL INPUT KEYWORDS: +; ALias= Set up aliases to convert from the IDL structure +; to the FITS column name. The value should be +; a STRARR(2,*) value where the first element of +; each pair of values corresponds to a column +; in the structure and the second is the name +; to be used in the FITS file. +; The order of the alias keyword is compatible with +; use in MRDFITS. +; ASCII - Creates an ASCII table rather than a binary table. +; This keyword may be specified as: +; /ASCII - Use default formats for columns. +; ASCII='format_string' allows the user to specify +; the format of various data types such using the following +; syntax 'column_type:format, column_type:format'. E.g., +; ASCII='A:A1,I:I6,L:I10,B:I4,F:G15.9,D:G23.17,C:G15.9,M:G23.17' +; gives the default formats used for each type. The TFORM +; fields for the real and complex types indicate will use corresponding +; E and D formats when a G format is specified. +; Note that the length of the field for ASCII strings and +; byte arrays is automatically determined for each column. +; BIT_COLS= An array of indices of the bit columns. The data should +; comprise a byte array with the appropriate dimensions. +; If the number of bits per row (see NBIT_COLS) +; is greater than 8, then the first dimension of the array +; should match the number of input bytes per row. +; BSCALE Scale floats, longs, or shorts to unsigned bytes (see LSCALE) +; /CREATE If this keyword is non-zero, then a new FITS file will +; be created regardless of whether the file currently +; exists. Otherwise when the file already exists, +; a FITS extension will be appended to the existing file +; which is assumed to be a valid FITS file. +; GROUP= This keyword indicates that GROUPed FITS data is to +; be generated. +; Group should be a 2-D array of the appropriate output type. +; The first dimension will set the number of group parameters. +; The second dimension must agree with the last dimension +; of the Input array. +; ISCALE Scale floats or longs to short integer (see LSCALE) +; LOGICAL_COLS= An array of indices of the logical column numbers. +; These should start with the first column having index *1*. +; The structure element should either be an array of characters +; with the values 'T' or 'F', or an array of bytes having the +; values byte('T')=84b, byte('F')=70b or 0b. The use of bytes +; allows the specification of undefined values (0b). +; LSCALE Scale floating point numbers to long integers. +; This keyword may be specified in three ways. +; /LSCALE (or LSCALE=1) asks for scaling to be automatically +; determined. LSCALE=value divides the input by value. +; I.e., BSCALE=value, BZERO=0. Numbers out of range are +; given the value of NULL if specified, otherwise they are given +; the appropriate extremum value. LSCALE=(value,value) +; uses the first value as BSCALE and the second as BZERO +; (or TSCALE and TZERO for tables). +; NBIT_COLS= The number of bits actually used in the bit array. +; This argument must point to an array of the same dimension +; as BIT_COLS. +; /NO_COPY = By default, MWRFITS makes a copy of the input variable +; before any modifications necessary to write it to a FITS +; file. If you have a large array/structure, and don't +; require it for subsequent processing, then /NO_COPY will +; save memory. +; NO_TYPES If the NO_TYPES keyword is specified, then no TTYPE +; keywords will be created for ASCII and BINARY tables. +; No_comment Do not write comment keywords in the header +; NULL= Value to be written for integers/strings which are +; undefined or unwritable. +; PSCALE= An array giving scaling parameters for the group keywords. +; It should have the same dimension as the first dimension +; of Group. +; PZERO= An array giving offset parameters for the group keywords. +; It should have the same dimension as the first dimension +; of Group. +; Separator= This keyword can be specified as a string which will +; be used to separate fields in ASCII tables. By default +; fields are separated by a blank. +; /SILENT Suppress informative messages. Errors will still +; be reported. +; Terminator= This keyword can be specified to provide a string which +; will be placed at the end of each row of an ASCII table. +; No terminator is used when not specified. +; If a non-string terminator is specified (including +; when the /terminator form is used), a new line terminator +; is appended. +; USE_COLNUM When creating column names for binary and ASCII tables +; MWRFITS attempts to use structure field name +; values. If USE_COLNUM is specified and non-zero then +; column names will be generated as 'C1, C2, ... 'Cn' +; for the number of columns in the table. +; Version Print the version number of MWRFITS. +; +; OPTIONAL OUTPUT KEYWORD: +; Status - 0 if FITS file is successfully written, -1 if there is a +; a problem (e.g. nonexistent directory, or no write permission) +; EXAMPLE: +; Write a simple array: +; a=fltarr(20,20) +; mwrfits,a,'test.fits' +; +; Append a 3 column, 2 row, binary table extension to file just created. +; a={name:'M31', coords:(30., 20.), distance:2} +; a=replicate(a, 2); +; mwrfits,a,'test.fits' +; +; Now add on an image extension: +; a=lonarr(10,10,10) +; hdr=("COMMENT This is a comment line to put in the header", $ +; "MYKEY = "Some desired keyword value") +; mwrfits,a,'test.fits',hdr +; +; RESTRICTIONS: +; (1) Variable length columns are not supported for anything +; other than simple types (byte, int, long, float, double). +; (2) Empty strings are converted to 1 element blank strings (because +; IDL refuses to write an empty string (0b) from a structure) +; NOTES: +; This multiple format FITS writer is designed to provide a +; single, simple interface to writing all common types of FITS data. +; Given the number of options within the program and the +; variety of IDL systems available it is likely that a number +; of bugs are yet to be uncovered. +; +; PROCEDURES USED: +; FXPAR(), FXADDPAR +; MODIfICATION HISTORY: +; Version 0.9: By T. McGlynn 1997-07-23 +; Initial beta release. +; Dec 1, 1997, Lindler, Modified to work under VMS. +; Version 0.91: T. McGlynn 1998-03-09 +; Fixed problem in handling null primary arrays. +; Version 0.92: T. McGlynn 1998-09-09 +; Add no_comment flag and keep user comments on fields. +; Fix handling of bit fields. +; Version 0.93: T. McGlynn 1999-03-10 +; Fix table appends on VMS. +; Version 0.93a W. Landsman/D. Schlegel +; Update keyword values in chk_and_upd if data type has changed +; Version 0.94: T. McGlynn 2000-02-02 +; Efficient processing of ASCII tables. +; Use G rather than E formats as defaults for ASCII tables +; and make the default precision long enough that transformations +; binary to/from ASCII are invertible. +; Some loop indices made long. +; Fixed some ends to match block beginnings. +; Version 0.95: T. McGlynn 2000-11-06 +; Several fixes to scaling. Thanks to David Sahnow for +; documenting the problems. +; Added PCOUNT,GCOUNT keywords to Image extensions. +; Version numbers shown in SIMPLE/XTENSION comments +; Version 0.96: T. McGlynn 2001-04-06 +; Changed how files are opened to handle ~ consistently +; Version 1.0: T. McGlynn 2001-12-04 +; Unsigned integers, +; 64 bit integers. +; Aliases +; Variable length arrays +; Some code cleanup +; Version 1.1: T. McGlynn 2002-2-18 +; Fixed major bug in processing of unsigned integers. +; (Thanks to Stephane Beland) +; Version 1.2: Stephane Beland 2003-03-17 +; Fixed problem in creating dummy dataset when passing undefined +; data, caused by an update to FXADDPAR routine. +; Version 1.2.1 Stephane Beland 2003-09-10 +; Exit gracefully if write privileges unavailable +; Version 1.3 Wayne Landsman 2003-10-24 +; Don't use EXECUTE() statement if on a virtual machine +; Version 1.3a Wayne Landsman 2004-5-21 +; Fix for variable type arrays +; Version 1.4 Wayne Landsman 2004-07-16 +; Use STRUCT_ASSIGN when modifying structure with pointer tags +; Version 1.4a Wayne Landsman 2005-01-03 +; Fix writing of empty strings in binary tables +; Version 1.4b Wayne Landsman 2006-02-23 +; Propagate /SILENT keyword to mwr_tablehdr +; Version 1.5 Wayne Landsman 2006-05-24 +; Open file using /SWAP_IF_LITTLE_ENDIAN keyword +; Convert empty strings to 1 element blank strings before writing +; Version 1.5a Wayne Landsman 2006-06-29 +; Fix problem introduced 2006-05-24 with multidimensional strings +; Version 1.5b K. Tolbert 2006-06-29 +; Make V1.5a fix work pre-V6.0 +; Version 1.5c I.Evans/W.Landsman 2006-08-08 +; Allow logical columns to be specified as bytes +; Version 1,5d K. Tolbert 2006-08-11 +; Make V1.5a fix work for scalar empty string +; Version 1.6 W. Landsman 2006-09-22 +; Assume since V5.5, remove VMS support +; Version 1.6a W. Landsman 2006-09-22 +; Don't right-justify strings +; Version 1.7 W. Landsman 2009-01-12 +; Added STATUS output keyword +; Version 1.7a W. Landsman 2009-04-10 +; Since V6.4 strings are no longer limited to 1024 +; elements +; Version 1.8 Pierre Chanial 2009-06-23 +; trim alias, implement logical TFORM 'L', don't +; add space after tform key. +; Version 1.9 W. Landsman 2009-07-20 +; Suppress compilation messages of supporting routines +; Version 1.10 W. Landsman 2009-09-30 +; Allow TTYPE values of 'T' and 'F', fix USE_COLNUM for bin tables +; Version 1.11 W. Landsman 2010-11-18 +; Allow LONG64 number of bytes, use V6.0 notation +; Version 1.11a W. Landsman 2012-08-12 +; Better documentation, error checking for logical columns +; Version 1.11b M. Haffner/W.L. 2012-10-12 +; Added /No_COPY keyword, fix problem with 32 bit overflow +; Version 1.12 W. Landsman 2014-04-23 +; Version 1.12a W.Landsman/M. Fossati 2014-10-14 +; Fix LONG overflow for very large files +; Version 1.12b I. Evans 2015-07-27 +; Fix value check for byte('T'), byte('F'), or 0b for logical +; columns with null values +; Version 1.13 W. Landsman 2016-02-24 +; Abort if a structure supplied with more than 999 tags +;- + +; What is the current version of this program? +function mwr_version + compile_opt idl2,hidden + return, '1.13' +end + + +; Find the appropriate offset for a given unsigned type +; or just return 0 if the type is not unsigned. + +function mwr_unsigned_offset, type + compile_opt idl2,hidden + + case type of + 12: return, 32768US + 13: return, 2147483648UL + 15: return, 9223372036854775808ULL + else: return,0 + endcase +end + + +; Add a keyword as non-destructively as possible to a FITS header +pro chk_and_upd, header, key, value, comment, nological=nological + compile_opt idl2,hidden + + + xcomm = "" + if n_elements(comment) gt 0 then xcomm = comment + if n_elements(header) eq 0 then begin + + fxaddpar, header, key, value, xcomm + + endif else begin + + oldvalue = fxpar(header, key, count=count, comment=oldcomment) + if (count eq 1) then begin + + qchange = 0 ; Set to 1 if either the type of variable or its + ; value changes. + size1 = size(oldvalue,/type) & size2 = size(value,/type) + if size1 NE size2 then qchange = 1 $ + else if (oldvalue ne value) then qchange = 1 + + if (qchange) then begin + + if n_elements(oldcomment) gt 0 then xcomm = oldcomment[0] + fxaddpar, header, key, value, xcomm,nological=nological + + endif + + endif else begin + + fxaddpar, header, key, value, xcomm,nological=nological + endelse + + endelse +end + +; Get the column name appropriate for a given tag +function mwr_checktype, tag, alias=alias + compile_opt idl2,hidden + + if ~keyword_set(alias) then return, tag + + sz = size(alias,/struc) + ; 1 or 2 D string array with first dimension of 2 + if (sz.type_name EQ 'STRING') && (sz.dimensions[0] EQ 2) && $ + (sz.N_dimensions LE 2) then begin + w = where(tag eq strtrim(alias[0,*],2),N_alias) + if N_alias EQ 0 then return,tag else return,alias[1,w[0]] + endif else begin + print,'MWRFITS: Warning: Alias values not strarr(2) or strarr(2,*)' + endelse + return, tag +end + +; Create an ASCII table +pro mwr_ascii, input, siz, lun, bof, header, $ + ascii=ascii, $ + null=null, $ + use_colnum = use_colnum, $ + lscale=lscale, iscale=iscale, $ + bscale=bscale, $ + no_types=no_types, $ + separator=separator, $ + terminator=terminator, $ + no_comment=no_comment, $ + silent=silent, $ + alias=alias + compile_opt idl2,hidden + + ; Write the header and data for a FITS ASCII table extension. + + types= ['A', 'I', 'L', 'B', 'F', 'D', 'C', 'M', 'K'] + formats=['A1', 'I6', 'I10', 'I4', 'G15.9','G23.17', 'G15.9', 'G23.17','I20'] + lengths=[1, 6, 10, 4, 15, 23, 15, 23, 20] + + ; Check if the user is overriding any default formats. + sz = size(ascii) + + if sz[0] eq 0 and sz[1] eq 7 then begin + ascii = strupcase(strcompress(ascii,/remo)) + for i=0, n_elements(types)-1 do begin + p = strpos(ascii,types[i]+':') + if p ge 0 then begin + + q = strpos(ascii, ',', p+1) + if q lt p then q = strlen(ascii)+1 + formats[i] = strmid(ascii, p+2, (q-p)-2) + len = 0 + + reads, formats[i], len, format='(1X,I)' + lengths[i] = len + endif + endfor + endif + + i0 = input[0] + ntag = n_tags(i0) + tags = tag_names(i0) + ctypes = lonarr(ntag) + strmaxs = lonarr(ntag) + + if ~keyword_set(separator) then separator=' ' + slen = strlen(separator) + + offsets = 0 + tforms = '' + ttypes = '' + offset = 0 + + totalFormat = "" + xsep = ""; + + for i=0, ntag-1 do begin + + totalFormat = totalFormat + xsep; + + sz = size(i0.(i)) + if (sz[0] ne 0) && (sz[sz[0]+1] ne 1) then begin + print, 'MWRFITS Error: ASCII table cannot contain arrays' + return + endif + + ctypes[i] = sz[1] + + xtype = mwr_checktype(tags[i], alias=alias) + + ttypes = [ttypes, xtype+' '] + + if sz[0] gt 0 then begin + ; Byte array to be handled as a string. + nelem = sz[sz[0]+2] + ctypes[i] = sz[sz[0]+1] + tf = 'A'+strcompress(string(nelem)) + tforms = [tforms, tf] + offsets = [offsets, offset] + totalFormat = totalFormat + tf + offset = offset + nelem + + endif else if sz[1] eq 7 then begin + ; Use longest string to get appropriate size. + strmax = max(strlen(input.(i))) + strmaxs[i] = strmax + tf = 'A'+strcompress(string(strmax), /remo) + tforms = [tforms, tf] + offsets = [offsets, offset] + totalFormat = totalFormat + tf + ctypes[i] = 7 + offset = offset + strmax + + endif else if (sz[1] eq 6 ) || (sz[1] eq 9) then begin + ; Complexes handled as two floats. + offset++ + + if sz[1] eq 6 then indx = where(types eq 'C') + if sz[1] eq 9 then indx = where(types eq 'M') + indx = indx[0] + fx = formats[indx] + if strcmp(fx,'g',1,/fold) then begin + if (sz[1] eq 6) then begin + fx = "E"+strmid(fx,1 ) + endif else begin + fx = "D"+strmid(fx,1 ) + endelse + endif + tforms = [tforms, fx, fx] + offsets = [offsets, offset, offset+lengths[indx]+1] + nel = n_elements(ttypes) + ttypes = [ttypes[0:nel-2], xtype+'_R', xtype+'_I'] + offset = offset + 2*lengths[indx] + 1 + + totalFormat = totalFormat + '"[",'+formats[indx]+',1x,'+formats[indx]+',"]"' + offset = offset+1 + + endif else begin + + if sz[1] eq 1 then indx = where(types eq 'B') $ + else if (sz[1] eq 2) || (sz[1] eq 12) then indx = where(types eq 'I') $ + else if (sz[1] eq 3) || (sz[1] eq 13) then indx = where(types eq 'L') $ + else if sz[1] eq 4 then indx = where(types eq 'F') $ + else if sz[1] eq 5 then indx = where(types eq 'D') $ + else if (sz[1] eq 14) || (sz[1] eq 15) then indx = where(types eq 'K') $ + else begin + print, 'MWRFITS Error: Invalid type in ASCII table' + return + endelse + + indx = indx[0] + fx = formats[indx] + if (strmid(fx, 0, 1) eq 'G' || strmid(fx, 0, 1) eq 'g') then begin + if sz[1] eq 4 then begin + fx = 'E'+strmid(fx, 1, 99) + endif else begin + fx = 'D'+strmid(fx, 1, 99) + endelse + endif + + tforms = [tforms, fx] + offsets = [offsets, offset] + totalFormat = totalFormat + formats[indx] + offset = offset + lengths[indx] + endelse + if i ne ntag-1 then begin + offset = offset + slen + endif + + xsep = ", '"+separator+"', " + + endfor + + + if keyword_set(terminator) then begin + sz = size(terminator); + if sz[0] ne 0 || sz[1] ne 7 then begin + terminator= string(10B) + endif + endif + + + if keyword_set(terminator) then offset = offset+strlen(terminator) + ; Write required FITS keywords. + + chk_and_upd, header, 'XTENSION', 'TABLE', 'ASCII table extension written by MWRFITS '+mwr_version() + chk_and_upd, header, 'BITPIX', 8,'Required Value: ASCII characters' + chk_and_upd, header, 'NAXIS', 2,'Required Value' + chk_and_upd, header, 'NAXIS1', offset, 'Number of characters in a row' + chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows' + chk_and_upd, header, 'PCOUNT', 0, 'Required value' + chk_and_upd, header, 'GCOUNT', 1, 'Required value' + chk_and_upd, header, 'TFIELDS', n_elements(ttypes)-1, 'Number of fields' + + ; Recall that the TTYPES, TFORMS, and OFFSETS arrays have an + ; initial dummy element. + + + ; Write the TTYPE keywords. + + if ~keyword_set(no_types) then begin + for i=1, n_elements(ttypes)-1 do begin + key = 'TTYPE'+ strcompress(string(i),/remo) + if keyword_set(use_colnum) then begin + value = 'C'+strcompress(string(i),/remo) + endif else begin + value = ttypes[i]+' ' + endelse + chk_and_upd, header, key, value + endfor + if (~keyword_set(no_comment)) then $ + sxaddhist, [' ',' *** Column names ***',' '],header, $ + /comment,location='TTYPE1' + + endif + + ; Write the TBCOL keywords. + + for i=1, n_elements(ttypes)-1 do begin + key= 'TBCOL'+strcompress(string(i),/remo) + chk_and_upd, header, key, offsets[i]+1 + endfor + + if ~keyword_set(no_comment) then $ + sxaddhist,[' ',' *** Column offsets ***',' '],header,/comm, $ + location = 'TBCOL1' + + ; Write the TFORM keywords + + for i=1, n_elements(ttypes)-1 do begin + key= 'TFORM'+strcompress(string(i),/remo) + chk_and_upd, header, key, tforms[i] + endfor + + if ~keyword_set(no_comment) then $ + sxaddhist,[' ',' *** Column formats ***',' '],header, $ + /COMMENT, location = 'TFORM1' + + ; Write the header. + + mwr_header, lun, header + + ; Write out the data applying the field formats + + totalFormat = "("+totalFormat+")"; + + strings = string(input, format=totalFormat) + if keyword_set(terminator) then strings = strings+terminator + writeu, lun, strings + + ; Check to see if any padding is required. + + nbytes = long64(n_elements(input))*offset + padding = 2880 - nbytes mod 2880 + if padding ne 0 then writeu, lun, replicate(32b, padding) + + return +end + +; Write a dummy primary header-data unit. +pro mwr_dummy, lun + compile_opt idl2,hidden + + fxaddpar, header, 'SIMPLE', 'T','Dummy Created by MWRFITS v'+mwr_version() + fxaddpar, header, 'BITPIX', 8, 'Dummy primary header created by MWRFITS' + fxaddpar, header, 'NAXIS', 0, 'No data is associated with this header' + fxaddpar, header, 'EXTEND', 'T', 'Extensions may (will!) be present' + + mwr_header, lun, header +end + +; Check if this is a valid pointer array for variable length data. +function mwr_validptr, vtypes, nfld, index, array + compile_opt idl2,hidden + + type = -1 + offset = 0L + for i=0, n_elements(array)-1 do begin + if ptr_valid(array[i]) then begin + + sz = size(*array[i]) + if sz[0] gt 1 then begin + print,'MWRFITS: Error: Multidimensional Pointer array' + return, 0 + endif + if type eq -1 then begin + type = sz[sz[0] + 1] + endif else begin + if sz[sz[0] + 1] ne type then begin + print,'MWRFITS: Error: Inconsistent type in pointer array' + return, 0 + endif + endelse + xsz = sz[1] + if sz[0] eq 0 then xsz = 1 + offset = offset + xsz + endif + endfor + if type eq -1 then begin + ; If there is no data assume an I*2 type + type = 2 + endif + + if (type lt 1 || type gt 5) &&(type lt 12 || type gt 15) then begin + print,'MWRFITS: Error: Unsupported type for variable length array' + endif + + types = 'BIJED IJKK' + sizes = [1,2,4,4,8,0,0,0,0,0,0,2,4,8,8] + + if n_elements(vtypes) eq 0 then begin + + vtype = {status:0, data:array, $ + type: strmid(types, type-1, 1), $ + itype: type, ilen: sizes[type-1], $ + offset:offset } + + vtypes = replicate(vtype, nfld) + + endif else begin + ; This ensures compatible structures without + ; having to used named structures. + + vtype = vtypes[0] + vtype.status = 0 + vtype.data = array + vtype.type = strmid(types, type-1, 1) + vtype.itype = type + vtype.ilen = sizes[type-1] + vtype.offset = offset + vtypes[index] = vtype + + + endelse + vtypes[index].status = 1; + + return, 1 +end + +; Handle the header for a binary table. +pro mwr_tablehdr, lun, input, header, vtypes, $ + no_types=no_types, $ + logical_cols = logical_cols, $ + bit_cols = bit_cols, $ + nbit_cols= nbit_cols, $ + no_comment=no_comment, $ + alias=alias, $ + silent=silent, $ + use_colnum = use_colnum + compile_opt idl2,hidden + + if ~keyword_set(no_types) then no_types = 0 + + nfld = n_tags(input[0]) + if nfld le 0 then begin + print, 'MWRFITS Error: Input contains no structure fields.' + return + endif + + tags = tag_names(input) + + ; Get the number of rows in the table. + + nrow = n_elements(input) + + dims = lonarr(nfld) + tdims = strarr(nfld) + types = strarr(nfld) + pointers= lonarr(nfld) + + ; offsets = null... Don't want to define this + ; in advance since reference to ulon64 won't word with IDL < 5.2 + ; + ; Get the type and length of each column. We do this + ; by examining the contents of the first row of the structure. + ; + + nbyte = 0ULL + + islogical = bytarr(nfld) + if keyword_set(logical_cols) then islogical[logical_cols-1] = 1b + + for i=0, nfld-1 do begin + + a = input[0].(i) + + sz = size(a) + + nelem = ulong64(sz[sz[0]+2]) + type_ele = sz[sz[0]+1] + if type_ele EQ 7 then maxstr = max(strlen(input.(i)) > 1) + + if islogical[i] then begin + if (type_ele EQ 1) then begin + gg = (input.(i) EQ 84b) or (input.(i) EQ 70b) or (input.(i) EQ 0b) + if ~array_equal(gg,1b) then begin + islogical[i] = 0b + message,/CON, 'Warning - ' + $ + "Allowed Logical Column byte values are byte('T'), byte('F'), or 0b" + endif + endif else if (type_ele EQ 7) then begin + gg = (input.(i) eq 'T') or (input.(i) eq 'F') + if ~array_equal(gg,1b) then begin + islogical[i] = 0b + message,/CON, 'Warning - ' + $ + 'Allowed Logical column string values are "T" and "F"' + endif + endif else begin + message,/CON, $ + 'Warning - Logical Columns must be of type string or byte' + islogical[i] = 0b + endelse + endif + dims[i] = nelem + + if (sz[0] lt 1) || (sz[0] eq 1 && type_ele ne 7) then begin + tdims[i] = '' + endif else begin + tdims[i] = '(' + + if type_ele eq 7 then begin + tdims[i] += strcompress(string(maxstr), /remo) + ',' + endif + + for j=1, sz[0] do begin + tdims[i] += strcompress(sz[j]) + if j ne sz[0] then tdims[i] += ',' + endfor + + tdims[i] += ')' + endelse + + case type_ele of + 1: begin + types[i] = 'B' + nbyte += nelem + end + 2: begin + types[i] = 'I' + nbyte += 2*nelem + end + 3: begin + types[i] = 'J' + nbyte += 4*nelem + end + 4: begin + types[i] = 'E' + nbyte += 4*nelem + end + 5: begin + types[i] = 'D' + nbyte += 8*nelem + end + 6: begin + types[i] = 'C' + nbyte += 8*nelem + end + 7: begin + maxstr = max(strlen(input.(i)) > 1 ) + types[i] = 'A' + nbyte += maxstr*nelem + dims[i] = maxstr*nelem + end + 9: begin + types[i] = 'M' + nbyte += 16*nelem + end + + 10: begin + if ~mwr_validptr(vtypes, nfld, i, input.(i)) then begin + return + endif + + types[i] = 'P'+vtypes[i].type + nbyte += 8 + dims[i] = 1 + + test = mwr_unsigned_offset(vtypes[i].itype) + if test gt 0 then begin + if (n_elements(offsets) lt 1) then begin + offsets = ulon64arr(nfld) + endif + offsets[i] = test + endif + + end + + 12: begin + types[i] = 'I' + if (n_elements(offsets) lt 1) then begin + offsets = ulon64arr(nfld) + endif + offsets[i] = mwr_unsigned_offset(12); + nbyte += 2*nelem + end + + 13: begin + types[i] = 'J' + if (n_elements(offsets) lt 1) then begin + offsets = ulon64arr(nfld) + endif + offsets[i] = mwr_unsigned_offset(13); + nbyte += 4*nelem + end + + ; 8 byte integers became standard FITS in December 2005 + 14: begin + types[i] = 'K' + nbyte += 8*nelem + end + + 15: begin + types[i] = 'K' + nbyte += 8*nelem + if (n_elements(offsets) lt 1) then begin + offsets = ulon64arr(nfld) + endif + offsets[i] = mwr_unsigned_offset(15) + end + + 0: begin + print,'MWRFITS Error: Undefined structure element??' + return + end + + 8: begin + print, 'MWRFITS Error: Nested structures' + return + end + + else:begin + print, 'MWRFITS Error: Cannot parse structure' + return + end + endcase + endfor + + ; Put in the required FITS keywords. + chk_and_upd, header, 'XTENSION', 'BINTABLE', 'Binary table written by MWRFITS v'+mwr_version() + chk_and_upd, header, 'BITPIX', 8, 'Required value' + chk_and_upd, header, 'NAXIS', 2, 'Required value' + chk_and_upd, header, 'NAXIS1', nbyte, 'Number of bytes per row' + chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows' + chk_and_upd, header, 'PCOUNT', 0, 'Normally 0 (no varying arrays)' + chk_and_upd, header, 'GCOUNT', 1, 'Required value' + chk_and_upd, header, 'TFIELDS', nfld, 'Number of columns in table' + + ; + ; Handle the special cases. + ; + g = where(islogical,Nlogic) + if Nlogic GT 0 then types[g] = 'L' + + if keyword_set(bit_cols) then begin + nb = n_elements(bit_cols) + if nb ne n_elements(nbit_cols) then begin + print,'WARNING: Bit_cols and Nbit_cols not same size' + print,' No bit columns generated.' + goto, after_bits + endif + for i = 0, nb-1 do begin + nbyte = (nbit_cols[i]+7)/8 + icol = bit_cols[i] + if types[icol-1] ne 'B' || (dims[icol-1] ne nbyte) then begin + print,'WARNING: Invalid attempt to create bit column:',icol + goto, next_bit + endif + types[icol-1] = 'X' + tdims[icol-1] = '' + dims[icol-1] = nbit_cols[i] + next_bit: + endfor + after_bits: + endif + + + + ; Write scaling info as needed. + if n_elements(offsets) gt 0 then begin + w = where(offsets gt 0) + + for i=0, n_elements(w) - 1 do begin + key = 'TSCAL'+strcompress(string(w[i])+1,/remo) + chk_and_upd, header, key, 1 + endfor + + for i=0, n_elements(w) - 1 do begin + key = 'TZERO'+strcompress(string(w[i]+1),/remo) + chk_and_upd, header, key, offsets[w[i]] + endfor + + if ~keyword_set(no_comment) then begin + key = 'TSCAL'+strcompress(string(w[0])+1,/remo) + sxaddhist,[' ',' *** Unsigned integer column scalings *',' '], $ + header,/COMMENT,location = key + endif + endif + + ; Now add in the TFORM keywords + for i=0, nfld-1 do begin + if dims[i] eq 1 then begin + form = types[i] + endif else begin + form=strcompress(string(dims[i]),/remove) + types[i] + endelse + + tfld = 'TFORM'+strcompress(string(i+1),/remove) + + ; Check to see if there is an existing value for this keyword. + ; If it has the proper value we will not modify it. + ; This can matter if there is optional information coded + ; beyond required TFORM information. + + oval = fxpar(header, tfld) + oval = strcompress(string(oval),/remove_all) + if (oval eq '0') || (strmid(oval, 0, strlen(form)) ne form) then begin + chk_and_upd, header, tfld, form + endif + endfor + + if ~keyword_set(no_comment) then $ + sxaddhist,[' ',' *** Column formats ***',' '],header, $ + /COMMENT, location='TFORM1' + + ; Now write TDIM info as needed. + for i=nfld-1, 0,-1 do begin + if tdims[i] ne '' then begin + fxaddpar, header, 'TDIM'+strcompress(string(i+1),/remo), tdims[i],after=tfld + endif + endfor + + w=where(tdims ne '',N_tdims) + if (N_tdims GT 0) && ~keyword_set(no_comment) then begin + fxaddpar, header, 'COMMENT', ' ', after=tfld + fxaddpar, header, 'COMMENT', ' *** Column dimensions (2 D or greater) ***', after=tfld + fxaddpar, header, 'COMMENT', ' ', after=tfld + endif + + for i=0, nfld-1 do begin + if tdims[i] ne '' then begin + chk_and_upd, header, 'TDIM'+strcompress(string(i+1),/remo), tdims[i] + endif + endfor + + if n_elements(vtypes) gt 0 then begin + fxaddpar, header, 'THEAP', nbyte*n_elements(input), 'Offset of start of heap' + offset = 0L + for i=0,n_elements(vtypes)-1 do begin + if vtypes[i].status then offset = offset + vtypes[i].offset*vtypes[i].ilen + endfor + fxaddpar, header, 'PCOUNT', offset, 'Size of heap' + endif + + ; + ; Last add in the TTYPE keywords if desired. + ; + if ~no_types then begin + for i=0, nfld - 1 do begin + key = 'TTYPE'+strcompress(string(i+1),/remove) + if ~keyword_set(use_colnum) then begin + value= mwr_checktype(tags[i],alias=alias) + endif else begin + value = 'C'+strmid(key,5,2) + ' ' + endelse + chk_and_upd, header, key, value, /nological + endfor + + if ~keyword_set(no_comment) then $ + sxaddhist,[' ',' *** Column names *** ',' '],header,/comment, $ + location = 'TTYPE1' + endif + + if ~keyword_set(no_comment) then begin + fxaddpar, header, 'COMMENT', ' ', after='TFIELDS' + fxaddpar, header, 'COMMENT', ' *** End of mandatory fields ***', after='TFIELDS' + fxaddpar, header, 'COMMENT', ' ', after='TFIELDS' + endif + + ; Write to the output device. + mwr_header, lun, header + +end + +; Modify the structure to put the pointer column in. +function mwr_retable, input, vtypes + + compile_opt idl2,hidden + + offset = 0L + tags = tag_names(input); +;Create an output structure identical to the input structure but with pointers replaced +; by a 2 word lonarr to point to the heap area + + if vtypes[0].status then begin + output = CREATE_STRUCT(tags[0],lonarr(2)) + endif else begin + output = CREATE_STRUCT(tags[0],input[0].(0)) + endelse + for i=1, n_elements(tags) -1 do begin + if vtypes[i].status then begin + output = CREATE_STRUCT(temporary(output), tags[i], lonarr(2)) + endif else begin + output = CREATE_STRUCT(temporary(output), tags[i], input[0].(i)) + endelse + endfor + output = replicate(temporary(output), N_elements(input) ) + struct_assign, input, output ;Available since V5.1 + + for i=0, n_elements(tags)-1 do begin + if vtypes[i].status then begin + for j=0, n_elements(input)-1 do begin + ptr = input[j].(i) + if ptr_valid(ptr) then begin + sz = size(*ptr) + if sz[0] eq 0 then xsz = 1 else xsz= sz[1] + + output[j].(i)[0] = xsz + output[j].(i)[1] = offset + + offset = offset + vtypes[i].ilen*xsz + endif + endfor + endif + endfor + return,output +end + +; Write the heap data. +function mwr_writeheap, lun, vtypes + + offset = 0L + + for i=0, n_elements(vtypes)-1 do begin + if vtypes[i].status then begin + + itype = vtypes[i].itype + unsigned = mwr_unsigned_offset(itype) + + ptrs = vtypes[i].data + + for j=0,n_elements(ptrs)-1 do begin + if ptr_valid(ptrs[j]) then begin + if (unsigned gt 0) then begin + *ptrs[j] = *ptrs[j] + unsigned + endif + + writeu, lun, *ptrs[j] + + sz = size(*ptrs[j]) + xsz = 1 > sz[1] + offset = offset + xsz * vtypes[i].ilen + endif + endfor + endif + endfor + + return, offset + +end + +; Write the binary table. +pro mwr_tabledat, lun, input, header, vtypes + compile_opt idl2,hidden + ; + ; file -- unit to which data is to be written. + ; Input -- IDL structure + ; Header -- Filled header + + nfld = n_tags(input) + + ; Any special processing? + + typ = intarr(nfld) + for i=0, nfld-1 do begin + + typ[i] = size(input.(i),/type) + if (typ[i] eq 7) then begin + + dim = size(input.(i),/dimen) >1 + siz = max(strlen(input.(i))) > 1 + input.(i) = $ + strmid( input.(i) + string(replicate(32b, siz)), 0, siz) + + endif + + unsigned = mwr_unsigned_offset(typ[i]) + if (unsigned gt 0) then begin + input.(i) = input.(i) + unsigned + endif + + endfor + + if n_elements(vtypes) gt 0 then begin + + + input = mwr_retable(input, vtypes) + endif + + ; Write the data segment. + ; + writeu, lun, input + + nbyte = long64(fxpar(header, 'NAXIS1')) + nrow = n_elements(input) + + heap = 0 + if n_elements(vtypes) gt 0 then $ + heap = mwr_writeheap(lun, vtypes) + + siz = nbyte*nrow + heap + padding = 2880 - (siz mod 2880) + if padding eq 2880 then padding = 0 + + ; + ; If necessary write the padding. + ; + if padding gt 0 then begin + pad = bytarr(padding) ; Should be null-filled by default. + writeu, lun, pad + endif + +end + + +; Scale parameters for GROUPed data. +pro mwr_pscale, grp, header, pscale=pscale, pzero=pzero + compile_opt idl2,hidden + + +; This function assumes group is a 2-d array. + + if ~keyword_set(pscale) && ~keyword_set(pzero) then return + + if ~keyword_set(pscale) then begin + pscale = dblarr(sizg[1]) + pscale[*] = 1. + endif + + w = where(pzero eq 0.d0) + + if w[0] ne 0 then begin + print, 'MWRFITS Warning: PSCALE value of 0 found, set to 1.' + pscale[w] = 1.d0 + endif + + if keyword_set(pscale) then begin + for i=0L, sizg[1]-1 do begin + key= 'PSCAL' + strcompress(string(i+1),/remo) + chk_and_upd, header, key, pscale[i] + endfor + endif + + if ~keyword_set(pzero) then begin + pzero = dblarr(sizg[1]) + pzero[*] = 0. + endif else begin + for i=0L, sizg[1]-1 do begin + key= 'PZERO' + strcompress(string(i+1),/remo) + chk_and_upd, header, key, pscale[i] + endfor + endelse + + for i=0L, sizg[1]-1 do begin + grp[i,*] = grp[i,*]/pscale[i] - pzero[i] + endfor + +end + + +; Find the appropriate scaling parameters. +pro mwr_findscale, flag, array, nbits, scale, offset, error + + compile_opt idl2,hidden + + error = 0 + if n_elements(flag) eq 2 then begin + scale = double(flag[0]) + offset = double(flag[1]) + endif else if n_elements(flag) eq 1 and flag[0] ne 1 then begin + minmum = min(array, max=maxmum) + offset = 0.d0 + scale = double(flag[0]) + endif else if n_elements(flag) ne 1 then begin + print, 'MWRFITS Error: Invalid scaling parameters.' + error = 1 + return + endif else begin + + minmum = min(array, max=maxmum) + scale = (maxmum-minmum)/(2.d0^nbits) + amin = -(2.d0^(nbits-1)) + if (amin gt -130) then amin = 0 ; looking for -128 + offset = minmum - scale*amin + + endelse + return +end + +; Scale and possibly convert array according to information +; in flags. +pro mwr_scale, array, scale, offset, lscale=lscale, iscale=iscale, $ + bscale=bscale, null=null + + compile_opt idl2,hidden + + ; First deallocate scale and offset + if n_elements(scale) gt 0 then xx = temporary(scale) + if n_elements(offset) gt 0 then xx = temporary(offset) + + if ~keyword_set(lscale) && ~keyword_set(iscale) && $ + ~keyword_set(bscale) then return + + siz = size(array) + if keyword_set(lscale) then begin + + ; Doesn't make sense to scale data that can be stored exactly. + if siz[siz[0]+1] lt 4 then return + amin = -2.d0^31 + amax = -(amin + 1) + + mwr_findscale, lscale, array, 32, scale, offset, error + + endif else if keyword_set(iscale) then begin + if siz[siz[0]+1] lt 3 then return + amin = -2.d0^15 + amax = -(amin + 1) + + mwr_findscale, iscale, array, 16, scale, offset, error + + endif else begin + if siz[siz[0]+1] lt 2 then return + + amin = 0 + amax = 255 + + mwr_findscale, bscale, array, 8, scale, offset, error + endelse + + ; Check that there was no error in mwr_findscale + if error gt 0 then return + + if scale le 0.d0 then begin + print, 'MWRFITS Error: BSCALE/TSCAL=0' + return + endif + + array = round((array-offset)/scale) + + w = where(array gt amax) + if w[0] ne -1 then $ + array[w] = keyword_set(null) ? null : amax + + w = where(array lt amin) + if w[0] ne -1 then $ + array[w] = keyword_set(null) ? null : amin + + if keyword_set(lscale) then array = long(array) $ + else if keyword_set(iscale) then array = fix(array) $ + else array = byte(array) + +end + +; Write a header +pro mwr_header, lun, header + + compile_opt idl2,hidden + ; Fill strings to at least 80 characters and then truncate. + + space = string(replicate(32b, 80)) + header = strmid(header+space, 0, 80) + + w = where(strcmp(header,"END ",8), Nw) + + if Nw eq 0 then begin + + header = [header, strmid("END"+space,0,80)] + + endif else begin + if (Nw gt 1) then begin + ; Get rid of extra end keywords; + print,"MWRFITS Warning: multiple END keywords found." + for irec=0L, n_elements(w)-2 do begin + header[w[irec]] = strmid('COMMENT INVALID END REPLACED'+ $ + space, 0, 80) + endfor + endif + + ; Truncate header array at END keyword. + header = header[0:w[n_elements(w)-1]] + endelse + + nrec = n_elements(header) + if nrec mod 36 ne 0 then header = [header, replicate(space,36 - nrec mod 36)] + + writeu, lun, byte(header) +end + + +; Move the group information within the data. +pro mwr_groupinfix, data, group, hdr + compile_opt idl2,hidden + + siz = size(data) + sizg = size(group) + + ; Check if group info is same type as data + + if siz[siz[0]+1] ne sizg[3] then begin + case siz[siz[0]+1] of + 1: begin + mwr_groupscale, 127.d0, group, hdr + group = byte(group) + end + 2: begin + mwr_groupscale, 32767.d0, group, hdr + group = fix(group) + end + 3: begin + mwr_groupscale, 2147483647.d0, group, hdr + group = long(group) + end + 4: group = float(group) + 5: group = double(group) + else: begin + print,'MWRFITS Internal error: Conversion of group data' + return + end + endcase + endif + + nrow = 1 + for i=1, siz[0]-1 do begin + nrow = nrow*siz[i] + endfor + + data = reform(data, siz[siz[0]+2]) + for i=0L, siz[siz[0]] - 1 do begin + if i eq 0 then begin + gdata = group[*,0] + gdata = reform(gdata) + tdata = [ gdata , data[0:nrow-1]] + endif else begin + start = nrow*i + fin = start+nrow-1 + gdata = group[*,i] + tdata = [tdata, gdata ,data[start:fin]] + endelse + endfor + + data = temporary(tdata) +end + +; If an array is being scaled to integer type, then +; check to see if the group parameters will exceed the maximum +; values allowed. If so scale them and update the header. +pro mwr_groupscale, maxval, group, hdr + compile_opt idl2,hidden + + sz = size(group) + for i=0L, sz[1]-1 do begin + pmax = max(abs(group[i,*])) + if (pmax gt maxval) then begin + ratio = pmax/maxval + psc = 'PSCAL'+strcompress(string(i+1),/remo) + currat = fxpar(hdr, psc) + if (currat ne 0) then begin + fxaddpar, hdr, psc, currat*ratio, 'Scaling overriden by MWRFITS' + endif else begin + fxaddpar, hdr, psc, ratio, ' Scaling added by MWRFITS' + endelse + group[i,*] = group[i,*]/ratio + endif + endfor +end + + +; Write out header and image for IMAGE extensions and primary arrays. +pro mwr_image, input, siz, lun, bof, hdr, $ + null=null, $ + group=group, $ + pscale=pscale, pzero=pzero, $ + lscale=lscale, iscale=iscale, $ + bscale=bscale, $ + no_comment=no_comment, $ + silent=silent + + + compile_opt idl2,hidden + type = siz[siz[0] + 1] + + bitpixes=[8,8,16,32,-32,-64,-32,0,0,-64,0,0,16,32,64,64] + + ; Convert complexes to two element real array. + + if type eq 6 || type eq 9 then begin + + if ~keyword_set(silent) then begin + print, "MWRFITS Note: Complex numbers treated as arrays" + endif + + array_dimen=(2) + if siz[0] gt 0 then array_dimen=[array_dimen, siz[1:siz[0]]] + if siz[siz[0]+1] eq 6 then data = float(input,0,array_dimen) $ + else data = double(input,0,array_dimen) + + ; Convert strings to bytes. + endif else if type eq 7 then begin + data = input + len = max(strlen(input)) + if len eq 0 then begin + print, 'MWRFITS Error: strings all have zero length' + return + endif + + for i=0L, n_elements(input)-1 do begin + t = len - strlen(input[i]) + if t gt 0 then input[i] = input[i] + string(replicate(32B, len)) + endfor + + ; Note that byte operation works on strings in a special way + ; so we don't go through the subterfuge we tried above. + + data = byte(data) + + endif else if n_elements(input) gt 0 then data = input + + + ; Do any scaling of the data. + mwr_scale, data, scalval, offsetval, lscale=lscale, $ + iscale=iscale, bscale=bscale, null=null + + ; This may have changed the type. + siz = size(data) + type = siz[siz[0]+1] + + + ; If grouped data scale the group parameters. + if keyword_set(group) then mwr_pscale, group, hdr, pscale=pscale, pzero=pzero + + if bof then begin + chk_and_upd, hdr, 'SIMPLE', 'T','Primary Header created by MWRFITS v'+mwr_version() + chk_and_upd, hdr, 'BITPIX', bitpixes[type] + chk_and_upd, hdr, 'NAXIS', siz[0] + chk_and_upd, hdr, 'EXTEND', 'T', 'Extensions may be present' + endif else begin + chk_and_upd, hdr, 'XTENSION', 'IMAGE','Image Extension created by MWRFITS v'+mwr_version() + chk_and_upd, hdr, 'BITPIX', bitpixes[type] + chk_and_upd, hdr, 'NAXIS', siz[0] + chk_and_upd, hdr, 'PCOUNT', 0 + chk_and_upd, hdr, 'GCOUNT', 1 + endelse + + + if keyword_set(group) then begin + group_offset = 1 + endif else group_offset = 0 + + if keyword_set(group) then begin + chk_and_upd, hdr, 'NAXIS1', 0 + endif + + for i=1L, siz[0]-group_offset do begin + chk_and_upd, hdr, 'NAXIS'+strcompress(string(i+group_offset),/remo), siz[i] + endfor + + + if keyword_set(group) then begin + chk_and_upd, hdr, 'GROUPS', 'T' + sizg = size(group) + if sizg[0] ne 2 then begin + print,'MWRFITS Error: Group data is not 2-d array' + return + endif + if sizg[2] ne siz[siz[0]] then begin + print,'MWRFITS Error: Group data has wrong number of rows' + return + endif + chk_and_upd,hdr, 'PCOUNT', sizg[1] + chk_and_upd, hdr, 'GCOUNT', siz[siz[0]] + endif + + if n_elements(scalval) gt 0 then begin + + chk_and_upd, hdr, 'BSCALE', scalval + chk_and_upd, hdr, 'BZERO', offsetval + + endif else begin + + ; Handle unsigned offsets + bzero = mwr_unsigned_offset(type) + if bzero gt 0 then begin + chk_and_upd,hdr,'BSCALE', 1 + chk_and_upd, hdr, 'BZERO', bzero + data += bzero + endif + + endelse + + if keyword_set(group) then begin + if keyword_set(pscale) then begin + if n_elements(pscale) ne sizg[1] then begin + print, 'MWRFITS Warning: wrong number of PSCALE values' + endif else begin + for i=1L, sizg[1] do begin + chk_and_upd, hdr, 'PSCALE'+strcompress(string(i),/remo) + endfor + endelse + endif + if keyword_set(pzero) then begin + if n_elements(pscale) ne sizg[1] then begin + print, 'MWRFITS Warning: Wrong number of PSCALE values' + endif else begin + for i=1L, sizg[1] do begin + chk_and_upd, hdr, 'PZERO'+strcompress(string(i),/remo) + endfor + endelse + endif + endif + + bytpix=abs(bitpixes[siz[siz[0]+1]])/8 ; Number of bytes per pixel. + npixel = n_elements(data) + n_elements(group) ; Number of pixels. + + if keyword_set(group) then mwr_groupinfix, data, group, hdr + + ; Write the FITS header + mwr_header, lun, hdr + + ; This is all we need to do if input is undefined. + if (n_elements(input) eq 0) || (siz[0] eq 0) then return + + ; Write the data. + writeu, lun, data + + nbytes = long64(bytpix)*npixel + filler = 2880 - nbytes mod 2880 + if filler eq 2880 then filler = 0 + + ; Write any needed filler. + if filler gt 0 then writeu, lun, replicate(0B,filler) +end + + +; Main routine -- see documentation at start +pro mwrfits, xinput, file, header, $ + ascii=ascii, $ + separator=separator, $ + terminator=terminator, $ + create=create, $ + null=null, $ + group=group, $ + pscale=pscale, pzero=pzero, $ + alias=alias, $ + use_colnum = use_colnum, $ + lscale=lscale, iscale=iscale, $ + no_copy = no_copy, $ + bscale=bscale, $ + no_types=no_types, $ + silent=silent, $ + no_comment=no_comment, $ + logical_cols=logical_cols, $ + bit_cols=bit_cols, $ + nbit_cols=nbit_cols, $ + status = status, $ + version=version + + + ; Check required keywords. + compile_opt idl2 + status = -1 ;Status changes to 0 upon completion + if keyword_set(Version) then begin + print, "MWRFITS V"+mwr_version()+": February 24, 2016" + endif + + if n_elements(file) eq 0 then begin + if ~keyword_set(Version) then begin + print, 'MWRFITS: Usage:' + print, ' MWRFITS, struct_name, file, [header,] ' + print, ' /CREATE, /SILENT, /NO_TYPES, /NO_COMMENT, ' + print, ' GROUP=, PSCALE=, PZERO=,' + print, ' LSCALE=, ISCALE=, BSCALE=,' + print, ' LOGICAL_COLS=, BIT_COLS=, NBIT_COLS=,' + print, ' ASCII=, SEPARATOR=, TERMINATOR=, NULL=' + print, ' /USE_COLNUM, ALIAS=, STATUS=' + endif + return + endif + + if size(xinput,/TNAME) EQ 'STRUCT' then $ + if N_tags(xinput) GT 999 then begin + message,'ERROR - Input structure contains ' + strtrim(N_tags(xinput),2) + ' tags',/CON + message,'ERROR - FITS files are limited to 999 columns',/CON + return + endif + + ; Save the data into an array/structure that we can modify. + + if n_elements(xinput) gt 0 then $ + if keyword_set(no_copy) then input = temporary(xinput) $ + else input = xinput + + on_ioerror, open_error + + ; Open the input file. If it exists, and the /CREATE keyword is not + ; specified, then we append to to the existing file. + ; + + if ~keyword_set(create) && file_test(file) then begin + openu, lun, file, /get_lun, /append,/swap_if_little + if ~keyword_set(silent) then $ + message,/inf,'Appending FITS extension to file ' + file + bof = 0 + endif else begin + openw, lun, file, /get_lun, /swap_if_little + bof = 1 + endelse + on_ioerror, null + + + siz = size(input) + if siz[siz[0]+1] ne 8 then begin + + ; If input is not a structure then call image writing utilities. + mwr_image, input, siz, lun, bof, header, $ + null=null, $ + group=group, $ + pscale=pscale, pzero=pzero, $ + lscale=lscale, iscale=iscale, $ + bscale=bscale, $ + no_comment=no_comment, $ + silent=silent + + endif else if keyword_set(ascii) then begin + + if bof then mwr_dummy, lun + ; Create an ASCII table. + mwr_ascii, input, siz, lun, bof, header, $ + ascii=ascii, $ + null=null, $ + use_colnum = use_colnum, $ + lscale=lscale, iscale=iscale, $ + bscale=bscale, $ + no_types=no_types, $ + separator=separator, $ + terminator=terminator, $ + no_comment=no_comment, $ + alias=alias, $ + silent=silent + + endif else begin + + if bof then mwr_dummy, lun + + ; Create a binary table. + mwr_tablehdr, lun, input, header, vtypes, $ + no_types=no_types, $ + logical_cols = logical_cols, $ + bit_cols = bit_cols, $ + nbit_cols= nbit_cols, $ + alias=alias, $ + no_comment=no_comment, $ + silent=silent, $ + use_colnum = use_colnum + + mwr_tabledat, lun, input, header, vtypes + + endelse + + free_lun, lun + status=0 + return + + ; Handle error in opening file. + open_error: + on_ioerror, null + print, 'MWRFITS Error: Cannot open output: ', file + print,!ERROR_STATE.SYS_MSG + if n_elements(lun) gt 0 then free_lun, lun + + return +end diff --git a/modules/idl_downloads/astro/pro/n_bytes.pro b/modules/idl_downloads/astro/pro/n_bytes.pro new file mode 100644 index 0000000..999a1af --- /dev/null +++ b/modules/idl_downloads/astro/pro/n_bytes.pro @@ -0,0 +1,52 @@ +function N_bytes,a +;+ +; NAME: +; N_bytes() +; +; PURPOSE: +; To return the total number of bytes in data element +; +; CALLING SEQUENCE: +; result = N_bytes(a) +; +; INPUTS: +; a - any idl data element, scalar or array +; +; OUTPUTS: +; total number of bytes in a is returned as the function value +; (64bit longword scalar) +; NOTES: +; (1) Not valid for object or pointer data types +; (2) For a string array, the number of bytes is computed after conversion +; with the BYTE() function, i.e. each element has the same length, +; equal to the maximum individual string length. +; +; MODIFICATION HISTORY: +; Version 1 By D. Lindler Oct. 1986 +; Include new IDL data types W. Landsman June 2001 +; Now return a 64bit integer W. Landsman April 2006 +;- +;----------------------------------------------------- +; + dtype = size(a,/type) ;data type + if dtype EQ 0 then return,0 ;undefined + nel = N_elements(a) + case dtype of + 1: nb = 1 ;Byte + 2: nb = 2 ;16 bit signed integer + 3: nb = 4 ;32 bit signed integer + 4: nb = 4 ;Float + 5: nb = 8 ;Double + 6: nb = 8 ;Complex + 7: nb = max(strlen(a)) ;String + 8: nb = N_tags(a,/length) ;Structure + 9: nb = 16 ;Double Complex + 12: nb = 2 ;Unsigned 16 bit Integer + 13: nb = 4 ;Unsigned 32 bit Integer + 14: nb = 8 ;64 bit signed integer + 15: nb = 8 ;64 bit unsigned integer + else: message,'ERROR - Object or Pointer data types not valid' + endcase + + return,long64(nel)*nb + end diff --git a/modules/idl_downloads/astro/pro/ngp.pro b/modules/idl_downloads/astro/pro/ngp.pro new file mode 100644 index 0000000..301ec63 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ngp.pro @@ -0,0 +1,201 @@ +FUNCTION ngp,value,posx,nx,posy,ny,posz,nz, $ + AVERAGE=average,WRAPAROUND=wraparound,NO_MESSAGE=no_message +;+ +; NAME: +; NGP +; +; PURPOSE: +; Interpolate an irregularly sampled field using Nearest Grid Point +; +; EXPLANATION: +; This function interpolates irregularly gridded points to a +; regular grid using Nearest Grid Point. +; +; CATEGORY: +; Mathematical functions, Interpolation +; +; CALLING SEQUENCE: +; Result = NGP, VALUE, POSX, NX[, POSY, NY, POSZ, NZ, +; /AVERAGE, /WRAPAROUND, /NO_MESSAGE] +; +; INPUTS: +; VALUE: Array of sample weights (field values). For e.g. a +; temperature field this would be the temperature and the +; keyword AVERAGE should be set. For e.g. a density field +; this could be either the particle mass (AVERAGE should +; not be set) or the density (AVERAGE should be set). +; POSX: Array of X coordinates of field samples, unit indices: [0,NX>. +; NX: Desired number of grid points in X-direction. +; +; OPTIONAL INPUTS: +; POSY: Array of Y coordinates of field samples, unit indices: [0,NY>. +; NY: Desired number of grid points in Y-direction. +; POSZ: Array of Z coordinates of field samples, unit indices: [0,NZ>. +; NZ: Desired number of grid points in Z-direction. +; +; KEYWORD PARAMETERS: +; AVERAGE: Set this keyword if the nodes contain field samples +; (e.g. a temperature field). The value at each grid +; point will then be the average of all the samples +; allocated to it. If this keyword is not set, the +; value at each grid point will be the sum of all the +; nodes allocated to it (e.g. for a density field from +; a distribution of particles). (D=0). +; WRAPAROUND: Set this keyword if the data is periodic and if you +; want the first grid point to contain samples of both +; sides of the volume (see below). (D=0). +; NO_MESSAGE: Suppress informational messages. +; +; Example of default NGP allocation: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---| Range allocated to gridpoints ([0.0,1.0> --> 0, etc.) +; 0 1 2 3 4 posx +; +; Example of NGP allocation for WRAPAROUND: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---|-- Range allocated to gridpoints ([0.5,1.5> --> 1, etc.) +; 0 1 2 3 4=0 posx +; +; +; OUTPUTS: +; Prints that a NGP interpolation is being performed of x +; samples to y grid points, unless NO_MESSAGE is set. +; +; RESTRICTIONS: +; All input arrays must have the same dimensions. +; Position coordinates should be in `index units' of the +; desired grid: POSX=[0,NX>, etc. +; +; PROCEDURE: +; Nearest grid point is determined for each sample. +; Samples are allocated to nearest grid points. +; Grid point values are computed (sum or average of samples). +; +; EXAMPLE: +; nx = 20 +; ny = 10 +; posx = randomu(s,1000) +; posy = randomu(s,1000) +; value = posx^2+posy^2 +; field = ngp(value,posx*nx,nx,posy*ny,ny,/average) +; surface,field,/lego +; +; NOTES: +; Use tsc.pro or cic.pro for a higher order interpolation schemes. A +; standard reference for these interpolation methods is: R.W. Hockney +; and J.W. Eastwood, Computer Simulations Using Particles (New York: +; McGraw-Hill, 1981). +; MODIFICATION HISTORY: +; Written by Joop Schaye, Feb 1999. +; Check for LONG overflow P. Riley/W. Landsman December 1999 +;- + +nrsamples=n_elements(value) +nparams=n_params() +dim=(nparams-1)/2 + +IF dim LE 2 THEN BEGIN + nz=1 + IF dim EQ 1 THEN ny=1 +ENDIF +nxny = long(nx)*long(ny) + + +;--------------------- +; Some error handling. +;--------------------- + +on_error,2 ; Return to caller if an error occurs. + +IF NOT (nparams EQ 3 OR nparams EQ 5 OR nparams EQ 7) THEN BEGIN + message,'Incorrect number of arguments!',/continue + message,'Syntax: NGP, VALUE, POSX, NX[, POSY, NY, POSZ, NZ,' + $ + ' /AVERAGE, /WRAPAROUND, /NO_MESSAGE]' +ENDIF + +IF (nrsamples NE n_elements(posx)) OR $ + (dim GE 2 AND nrsamples NE n_elements(posy)) OR $ + (dim EQ 3 AND nrsamples NE n_elements(posz)) THEN $ + message,'Input arrays must have the same dimensions!' + +IF NOT keyword_set(no_message) THEN $ + print,'Interpolating ' + strtrim(string(nrsamples,format='(i10)'),1) $ + + ' samples to ' + strtrim(string(nxny*nz,format='(i10)'),1) + $ + ' grid points using NGP...' + + +;----------------------------- +; Compute nearest grid points. +;----------------------------- + +IF keyword_set(wraparound) THEN BEGIN + ; Coordinates of nearest grid point (ngp). + ngx=fix(posx+0.5) + ; Periodic boundary conditions. + bad=where(ngx EQ nx,count) + IF count NE 0 THEN ngx[bad]=0 + IF dim GE 2 THEN BEGIN + ngy=fix(posy+0.5) + bad=where(ngy EQ ny,count) + IF count NE 0 THEN ngy[bad]=0 + IF dim EQ 3 THEN BEGIN + ngz=fix(posz+0.5) + bad=where(ngz EQ nz,count) + IF count NE 0 THEN ngz[bad]=0 + ENDIF + ENDIF + bad=0 ; Free memory. +ENDIF ELSE BEGIN + ; Coordinates of nearest grid point (ngp). + ngx=fix(posx) + IF dim GE 2 THEN BEGIN + ngy=fix(posy) + IF dim EQ 3 THEN ngz=fix(posz) + ENDIF +ENDELSE + +; Indices of grid points to which samples are assigned. +CASE dim OF + 1: index=temporary(ngx) + 2: index=temporary(ngx)+temporary(ngy)*nx + 3: index=temporary(ngx)+temporary(ngy)*nx+temporary(ngz)*nxny +ENDCASE + + +;------------------------------- +; Interpolate samples to grid. +;------------------------------- + +field=fltarr(nx,ny,nz) + +FOR i=0l,nrsamples-1l DO field[index[i]]=field[index[i]]+value[i] + + +;-------------------------- +; Compute weighted average. +;-------------------------- + +IF keyword_set(average) THEN BEGIN + ; Number of samples per grid point. + frequency=histogram(temporary(index),min=0,max=nxny*nz-1l) + + ; Normalize. + good=where(frequency NE 0,nrgood) + field[good]=temporary(field[good])/temporary(frequency[good]) +ENDIF + +return,field + +END ; End of function ngp. + + + + + + + + diff --git a/modules/idl_downloads/astro/pro/nint.pro b/modules/idl_downloads/astro/pro/nint.pro new file mode 100644 index 0000000..3b54e2f --- /dev/null +++ b/modules/idl_downloads/astro/pro/nint.pro @@ -0,0 +1,55 @@ +function nint, x, LONG = long ;Nearest Integer Function +;+ +; NAME: +; NINT +; PURPOSE: +; Nearest integer function. +; EXPLANATION: +; NINT() is similar to the intrinsic ROUND function, with the following +; two differences: +; (1) if no absolute value exceeds 32767, then the array is returned as +; as a type INTEGER instead of LONG +; (2) NINT will work on strings, e.g. print,nint(['3.4','-0.9']) will +; give [3,-1], whereas ROUND() gives an error message +; +; CALLING SEQUENCE: +; result = nint( x, [ /LONG] ) +; +; INPUT: +; X - An IDL variable, scalar or vector, usually floating or double +; Unless the LONG keyword is set, X must be between -32767.5 and +; 32767.5 to avoid integer overflow +; +; OUTPUT +; RESULT - Nearest integer to X +; +; OPTIONAL KEYWORD INPUT: +; LONG - If this keyword is set and non-zero, then the result of NINT +; is of type LONG. Otherwise, the result is of type LONG if +; any absolute values exceed 32767, and type INTEGER if all +; all absolute values are less than 32767. +; EXAMPLE: +; If X = [-0.9,-0.1,0.1,0.9] then NINT(X) = [-1,0,0,1] +; +; PROCEDURE CALL: +; None: +; REVISION HISTORY: +; Written W. Landsman January 1989 +; Added LONG keyword November 1991 +; Use ROUND if since V3.1.0 June 1993 +; Always start with ROUND function April 1995 +; Return LONG values, if some input value exceed 32767 +; and accept string values February 1998 +; Use size(/TNAME) instead of DATATYPE() October 2001 +;- + xmax = max(x,min=xmin) + xmax = abs(xmax) > abs(xmin) + if (xmax gt 32767) or keyword_set(long) then begin + if size(x,/TNAME) eq 'STRING' then b = round(float(x)) else b = round(x) + end else begin + if size(x,/TNAME) eq 'STRING' then b = fix(round(float(x))) else $ + b = fix(round(x)) + endelse + + return, b + end diff --git a/modules/idl_downloads/astro/pro/nstar.pro b/modules/idl_downloads/astro/pro/nstar.pro new file mode 100644 index 0000000..9552aaf --- /dev/null +++ b/modules/idl_downloads/astro/pro/nstar.pro @@ -0,0 +1,485 @@ +pro nstar,image,id,xc,yc,mags,sky,group,phpadu,readns,psfname,DEBUG=debug, $ + errmag,iter,chisq,peak,PRINT=print,SILENT=silent, VARSKY = varsky +;+ +; NAME: +; NSTAR +; PURPOSE: +; Simultaneous point spread function fitting (adapted from DAOPHOT) +; EXPLANATION: +; This PSF fitting algorithm is based on a very old (~1987) version of +; DAOPHOT, and much better algorithms (e.g. ALLSTAR) are now available +; -- though not in IDL. +; +; CALLING SEQUENCE: +; NSTAR, image, id, xc, yc, mags, sky, group, [ phpadu, readns, psfname, +; magerr, iter, chisq, peak, /PRINT , /SILENT, /VARSKY, /DEBUG ] +; +; INPUTS: +; image - image array +; id - vector of stellar ID numbers given by FIND +; xc - vector containing X position centroids of stars (e.g. as found +; by FIND) +; yc - vector of Y position centroids +; mags - vector of aperture magnitudes (e.g. as found by APER) +; If 9 or more parameters are supplied then, upon output +; ID,XC,YC, and MAGS will be modified to contain the new +; values of these parameters as determined by NSTAR. +; Note that the number of output stars may be less than +; the number of input stars since stars may converge, or +; "disappear" because they are too faint. +; sky - vector of sky background values (e.g. as found by APER) +; group - vector containing group id's of stars as found by GROUP +; +; OPTIONAL INPUT: +; phpadu - numeric scalar giving number of photons per digital unit. +; Needed for computing Poisson error statistics. +; readns - readout noise per pixel, numeric scalar. If not supplied, +; NSTAR will try to read the values of READNS and PHPADU from +; the PSF header. If still not found, user will be prompted. +; psfname - name of FITS image file containing the point spread +; function residuals as determined by GETPSF, scalar string. +; If omitted, then NSTAR will prompt for this parameter. +; +; OPTIONAL OUTPUTS: +; MAGERR - vector of errors in the magnitudes found by NSTAR +; ITER - vector containing the number of iterations required for +; each output star. +; CHISQ- vector containing the chi square of the PSF fit for each +; output star. +; PEAK - vector containing the difference of the mean residual of +; the pixels in the outer half of the fitting circle and +; the mean residual of pixels in the inner half of the +; fitting circle +; +; OPTIONAL KEYWORD INPUTS: +; /SILENT - if set and non-zero, then NSTAR will not display its results +; at the terminal +; /PRINT - if set and non-zero then NSTAR will also write its results to +; a file nstar.prt. One also can specify the output file name +; by setting PRINT = 'filename'. +; /VARSKY - if this keyword is set and non-zero, then the sky level of +; each group is set as a free parameter. +; /DEBUG - if this keyword is set and non-zero, then the result of each +; fitting iteration will be displayed. +; +; PROCEDURES USED: +; DAO_VALUE(), READFITS(), REMOVE, SPEC_DIR(), STRN(), SXPAR() +; +; COMMON BLOCK: +; RINTER - contains pre-tabulated values for cubic interpolation +; REVISION HISTORY +; W. Landsman ST Systems Co. May, 1988 +; Adapted for IDL Version 2, J. Isensee, September, 1990 +; Minor fixes so that PRINT='filename' really prints to 'filename', and +; it really silent if SILENT is set. J.Wm.Parker HSTX 1995-Oct-31 +; Added /VARSKY option W. Landsman HSTX May 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Replace DATATYPE() with size(/TNAME) W. Landsman November 2001 +; Assume since V5.5, remove VMS calls W. Landsman September 2006 +;- + compile_opt idl2 + common rinter,c1,c2,c3,init ;Save time in RINTER() + npar = N_params() + if npar LT 7 then begin + print,'Syntax - NSTAR, image, id, xc, yc, mags, sky, group, [phpadu, ' + print, $ + ' [readns, psfname, magerr, iter, chisq, peak, /SILENT, /PRINT, /VARSKY]' + return + endif + + if ( N_elements(psfname) EQ 0 ) then begin + psfname='' + read,'Enter name of FITS file containing PSF: ',psfname + endif else zparcheck,'PSFNAME',psfname,10,7,0,'PSF disk file name' + + psf_file = file_search( psfname, COUNT = n) + if n EQ 0 then message, $ + 'ERROR - Unable to locate PSF file ' + spec_dir(psfname) + + if npar LT 9 then begin + ans = '' + read, $ + 'Do you want to update the input vectors with the results of NSTAR? ',ans + if strmid(strupcase(ans),0,1) EQ 'Y' then npar = 9 + endif + + if npar LT 9 then $ + message,'Input vectors ID,XC,YC and MAGS will not be updated by NSTAR',/INF + +; Read in the FITS file containing the PSF + + s = size(image) + icol = s[1]-1 & irow = s[2]-1 ;Index of last row and column + psf = readfits(psfname, hpsf) + if N_elements(phpadu) EQ 0 then begin + par = sxpar(hpsf,'PHPADU', Count = N_phpadu) + if N_phpadu eq 0 $ + then read, 'Enter photons per analog digital unit: ',phpadu $ + else phpadu = par +endif + + if ( N_elements(readns) EQ 0 ) then begin + par = sxpar(hpsf,'RONOIS', Count = N_ronois) + if N_ronois EQ 0 $ + then read, 'Enter the readout noise per pixel: ',readns $ + else readns = par + endif + + gauss = sxpar(hpsf,'GAUSS*') + psfmag = sxpar(hpsf,'PSFMAG') + psfrad = sxpar(hpsf,'PSFRAD') + fitrad = sxpar(hpsf,'FITRAD') + npsf = sxpar(hpsf,'NAXIS1') +; Compute RINTER common block arrays + p_1 = shift(psf,1,0) & p1 = shift(psf,-1,0) & p2 = shift(psf,-2,0) + c1 = 0.5*(p1 - p_1) + c2 = 2.*p1 + p_1 - 0.5*(5.*psf + p2) + c3 = 0.5*(3.*(psf-p1) + p2 - p_1) + init = 1 + + ronois = readns^2 + radsq = fitrad^2 & psfrsq = psfrad^2 + sepmin = 2.773*(gauss[3]^2+gauss[4]^2) + +; PKERR will be used to estimate the error due to interpolating PSF +; Factor of 0.027 is estimated from good-seeing CTIO frames + + pkerr = 0.027/(gauss[3]*gauss[4])^2 + sharpnrm = 2.*gauss[3]*gauss[4]/gauss[0] + if (N_elements(group) EQ 1) then groupid = group[0] else $ + groupid = where(histogram(group,min=0)) ;Vector of distinct group id's + + mag = mags ;Save original magnitude vector + bad = where( mag GT 99, nbad ) ;Undefined magnitudes assigned 99.9 + if nbad GT 0 then mag[bad] = psfmag + 7.5 + mag = 10.^(-0.4*(mag-psfmag)) ;Convert magnitude to brightness, scaled to PSF + fmt = '(I6,2F9.2,3F9.3,I4,F9.2,F9.3)' + + SILENT = keyword_set(SILENT) + VARSKY = keyword_set(VARSKY) + + if keyword_set(PRINT) then begin + if ( size(print,/TNAME) NE 'STRING' ) then file = 'nstar.prt' $ + else file = print + message,'Results will be written to a file '+ file,/INF + openw,lun,file,/GET_LUN + printf,lun,'NSTAR: '+ getenv('USER') + ' '+ systime() + printf,lun,'PSF File:',psfname + endif + PRINT = keyword_set(PRINT) + + hdr=' ID X Y MAG MAGERR SKY NITER CHI SHARP' + if not(SILENT) then print,hdr + if PRINT then printf,lun,hdr + + for igroup = 0, N_elements(groupid)-1 do begin + + index = where(group EQ groupid[igroup],nstr) + if not SILENT then print,'Processing group ', $ + strtrim(groupid[igroup],2),' ',strtrim(nstr,2),' stars' + if nstr EQ 0 then stop + magerr = fltarr(nstr) + chiold = 1.0 + niter = 0 + clip = 0b + nterm = nstr*3 + varsky + xold = dblarr(nterm) + clamp = replicate(1.,nterm) + xb = double(xc[index]) & yb = double(yc[index]) + magg = double(mag[index]) & skyg = double(sky[index]) + idg = id[index] + skybar = total(skyg)/nstr + reset = 0b +; +START_IT : + niter = niter+1 +RESTART: + case 1 of ;Set up critical error for star rejection + niter GE 4 : wcrit = 1 + niter GE 8 : wcrit = 0.4444444 + niter GE 12: wcrit = 0.25 + else : wcrit = 400 + endcase + + if reset EQ 1b then begin + xb = xg + ixmin & yb = yg + iymin + endif + + reset = 1b + xfitmin = fix(xb - fitrad) > 0 + xfitmax = fix(xb + fitrad)+1 < (icol-1) + yfitmin = fix(yb - fitrad) > 0 + yfitmax = fix(yb + fitrad)+1 < (irow-1) + nfitx = xfitmax - xfitmin + 1 + nfity = yfitmax - yfitmin + 1 + ixmin = min(xfitmin)& iymin = min(yfitmin) + ixmax = max(xfitmax)& iymax = max(yfitmax) + nx = ixmax-ixmin+1 & ny = iymax-iymin+1 + dimage = image[ixmin:ixmax,iymin:iymax] + xfitmin = xfitmin -ixmin & yfitmin = yfitmin-iymin + xfitmax = xfitmax -ixmin & yfitmax = yfitmax-iymin +; Offset to the subarray + xg = xb-ixmin & yg = yb-iymin + j = 0 + + while (j LT nstr-1) do begin + sep = (xg[j] - xg[j+1:*])^2 + (yg[j] - yg[j+1:*])^2 + bad = where(sep LT sepmin,nbad) + if nbad GT 0 then begin ;Do any star overlap? + for l = 0,nbad-1 do begin + k = bad[l] + j + 1 + if magg[k] LT magg[j] then imin = k else imin = j ;Identify fainter star + if ( sep[l] LT 0.14*sepmin) or $ + ( magerr[imin]/magg[imin]^2 GT wcrit ) then begin + if imin EQ j then imerge = k else imerge = j + nstr = nstr - 1 + if not SILENT then print, $ + 'Star ',strn(idg[imin]),' has merged with star ',strn(idg[imerge]) + totmag = magg[imerge] + magg[imin] + xg[imerge] = (xg[imerge]*magg[imerge] + xg[imin]*magg[imin])/totmag + yg[imerge] = (yg[imerge]*magg[imerge] + yg[imin]*magg[imin])/totmag + magg[imerge] = totmag + remove,imin,idg,xg,yg,magg,skyg,magerr ;Remove fainter star from group + nterm = nstr*3 + varsky ;Update matrix size + xold = dblarr(nterm) + clamp = replicate(1.,nterm) ;Release all clamps + clip = 0b + niter = niter-1 ;Back up iteration counter + goto, RESTART + endif + endfor + endif + j = j+1 + endwhile + + xpsfmin = (fix (xg - psfrad+1)) > 0 + xpsfmax = (fix (xg + psfrad )) < (nx-1) + ypsfmin = (fix (yg - psfrad+1)) > 0 + ypsfmax = (fix (yg + psfrad )) < (ny-1) + npsfx = xpsfmax-xpsfmin+1 & npsfy = ypsfmax-ypsfmin+1 + wt = fltarr(nx,ny) + mask = bytarr(nx,ny) + nterm = 3*nstr + varsky + chi = fltarr(nstr) & sumwt = chi & numer = chi & denom = chi + c = fltarr(nterm,nterm) & v = fltarr(nterm) + + for j = 0,nstr-1 do begin ;Mask of pixels within fitting radius of any star + x1 = xfitmin[j] & y1 = yfitmin[j] + x2 = xfitmax[j] & y2 = yfitmax[j] + rpixsq = fltarr(nfitx[j],nfity[j]) + xfitgen2 = (findgen(nfitx[j]) + x1 - xg[j])^2 + yfitgen2 = (findgen(nfity[j]) + y1 - yg[j])^2 + for k=0,nfity[j]-1 do rpixsq[0,k] = xfitgen2 + yfitgen2[k] + temp = (rpixsq LE 0.999998*radsq) + mask[x1,y1] = mask[x1:x2,y1:y2] or temp + good = where(temp) + rsq = rpixsq[good]/radsq + temp1 = wt[x1:x2,y1:y2] + temp1[good] = temp1[good] > (5./(5.+rsq/(1.-rsq)) ) + wt[x1,y1] = temp1 + endfor + + igood = where(mask, ngoodpix) + x = dblarr(ngoodpix,nterm) + if varsky then x[0, nterm-1] = replicate(-1.0d, ngoodpix) + + psfmask = bytarr(ngoodpix,nstr) + d = dimage[igood] - skybar + for j = 0,nstr-1 do begin ;Masks of pixels within PSF radius of each star + x1 = xpsfmin[j] & y1 = ypsfmin[j] + x2 = xpsfmax[j] & y2 = ypsfmax[j] + xgen = lindgen(npsfx[j]) + x1 - xg[j] + ygen = lindgen(npsfy[j]) + y1 - yg[j] + xgen2 = xgen^2 & ygen2 = ygen^2 + rpxsq = fltarr( npsfx[j],npsfy[j] ) + for k = 0,npsfy[j]-1 do rpxsq[0,k] = xgen2 + ygen2[k] + temp = mask[x1:x2,y1:y2] and (rpxsq LT psfrsq) + temp1 = bytarr(nx,ny) + temp1[x1,y1] = temp + goodfit = where(temp1[igood]) + psfmask[goodfit+ngoodpix*j] = 1b + good = where(temp) + xgood = xgen[good mod npsfx[j]] & ygood = ygen[good/npsfx[j]] + model = dao_value(xgood,ygood,gauss,psf,dvdx,dvdy) + d[goodfit] = d[goodfit] - magg[j]*model + x[goodfit + 3*j*ngoodpix] = -model + x[goodfit + (3*j+1)*ngoodpix] = magg[j]*dvdx + x[goodfit + (3*j+2)*ngoodpix] = magg[j]*dvdy + endfor + + wt = wt[igood] & idimage = dimage[igood] + dpos = (idimage-d) > 0 + sigsq = dpos/phpadu + ronois + (0.0075*dpos)^2 + (pkerr*(dpos-skybar))^2 + + relerr = abs(d)/sqrt(sigsq) + if clip then begin ;Reject pixels with 20 sigma errors (after 1st iteration) + bigpix = where(relerr GT 20.*chiold, nbigpix) + if ( nbigpix GT 0 ) then begin + keep = indgen(ngoodpix) + for i = 0,nbigpix-1 do keep = keep[ where( keep NE bigpix[i]) ] + wt= wt[keep] & d = d[keep] & idimage = idimage[keep] + igood= igood[keep] & relerr = relerr[keep] + psfmask = psfmask[keep,*] & x = x[keep,*] + endif + endif + + sumres = total(relerr*wt) + grpwt = total(wt) + + dpos = ((idimage-skybar) > 0) + skybar + sig = dpos/phpadu + ronois + (0.0075*dpos)^2 + (pkerr*(dpos-skybar))^2 + for j = 0,nstr-1 do begin + goodfit = where(psfmask[*,j]) + chi[j] = total(relerr[goodfit]*wt[goodfit]) + sumwt[j] = total(wt[goodfit]) + xgood = igood[goodfit] mod nx & ygood = igood[goodfit]/nx + rhosq = ((xg[j] - xgood)/gauss[3])^2 + ((yg[j] - ygood)/gauss[4])^2 + goodsig = where(rhosq LT 36) ;Include in sharpness index only + rhosq = 0.5*rhosq[goodsig] ;pixels within 6 sigma of centroid + dfdsig = exp(-rhosq)*(rhosq-1.) + sigpsf = sig[goodfit[goodsig]] & dsig = d[goodfit[goodsig]] + numer[j] = total(dfdsig*dsig/sigpsf) + denom[j] = total(dfdsig^2/sigpsf) + endfor + + wt = wt/sigsq + if clip then $ ;After 1st iteration, reduce weight of a bad pixel + wt = wt/(1.+(0.4*relerr/chiold)^8) + + v = d * wt # x + c = transpose(x) # ( ( wt # replicate(1.,nterm) ) * x ) + + if grpwt GT 3 then begin + chiold = 1.2533*sumres*sqrt(1./(grpwt*(grpwt-3.))) + chiold = ((grpwt-3.)*chiold+3.)/grpwt + endif + + i = where(sumwt GT 3, ngood) + if ngood GT 0 then begin + chi[i] = 1.2533*chi[i]*sqrt(1./((sumwt[i]-3.)*sumwt[i])) + chi[i] = ((sumwt[i]-3.)*chi[i]+3.)/sumwt[i] + endif + +chibad = where(sumwt LE 3, ngood) +if ngood GT 0 then chi[chibad] = chiold + + c = invert(c) + x = c # transpose(v) + + if (not clip) or (niter LE 1) then redo = 1b else redo = 0b + if varsky then begin + skybar = skybar - x[nterm-1] + if abs(x[nterm-1]) GT 0.01 then redo = 1b + endif + clip = 1b + + j = 3*indgen(nstr) & k = j+1 & l=j+2 + sharp = sharpnrm*numer/(magg*denom) + if not redo then begin + redo = max(abs(x[j]) GT ( (0.05*chi*sqrt(c[j+nterm*j])) > 0.001*magg) ) + if redo EQ 0 then redo = max( abs([x[k], x[l]]) GT 0.01) + endif + + sgn = where( xold[j]*x[j]/magg^2 LT -1.E-37, Nclamp ) + if Nclamp GT 0 then clamp[j[sgn]] = 0.5*clamp[j[sgn]] + sgn = where( xold[k]*x[k] LT -1.E-37, Nclamp ) + if Nclamp GT 0 then clamp[k[sgn]] = 0.5*clamp[k[sgn]] + sgn = where( xold[l]*x[l] LT -1.E-37, Nclamp ) + if Nclamp GT 0 then clamp[l[sgn]] = 0.5*clamp[l[sgn]] + + magg = magg-x[j] / (1.+ ( (x[j]/(0.84*magg)) > (-x[j]/(5.25*magg)) )/ clamp[j] ) + xg = xg - x[k] /(1.+abs(x[k])/( clamp[k]*0.5)) + yg = yg - x[l] /(1.+abs(x[l])/( clamp[l]*0.5)) + xold = x + + magerr = c[j+nterm*j]*(nstr*chi^2 + (nstr-1)*chiold^2)/(2.*nstr-1.) + + dx = (-xg) > ( (xg - nx) > 0.) ;Find stars outside subarray + dy = (-yg) > ( (yg- ny) > 0.) + badcen = where( $ ;Remove stars with bad centroids + (dx GT 0.001) or (dy GT 0.001) or ( (dx+1)^2 + (dy+1)^2 GE radsq ), nbad) + if nbad GT 0 then begin + nstr = nstr - nbad + print,strn(nbad),' stars eliminated by centroid criteria' + if nstr LE 0 then goto, DONE_GROUP + remove, badcen, idg, xg, yg, magg, skyg, magerr + nterm = nstr*3 + varsky + redo = 1b + endif + + faint = 1 + toofaint = where (magg LE 1.e-5,nfaint) + ;Number of stars 12.5 mags fainter than PSF star + if nfaint GT 0 then begin + faint = min( magg[toofaint], min_pos ) + ifaint = toofaint[ min_pos ] + magg[toofaint] = 1.e-5 + goto, REM_FAINT ;Remove faintest star + endif else begin + faint = 0. + ifaint = -1 + if (not redo) or (niter GE 4) then $ + faint = max(magerr/magg^2, ifaint) else $ + goto,START_IT + endelse + + if keyword_set(DEBUG) then begin + err = 1.085736*sqrt(magerr)/magg + for i=0,nstr-1 do print,format=fmt,idg[i],xg[i]+ixmin,yg[i]+iymin, $ + psfmag-1.085736*alog(magg[i]),err[i],skyg[i],niter,chi[i],sharp[i] + endif + + if redo and (niter LE 50) and (faint LT wcrit) then goto,START_IT +REM_FAINT: + if (faint GE 0.25) or (nfaint GT 0) then begin + if not SILENT then $ + message,'Star '+ strn(idg[ifaint]) + ' is too faint',/INF + nstr = nstr-1 + if nstr LE 0 then goto,DONE_GROUP + remove,ifaint,idg,xg,yg,magg,skyg,magerr + nterm = nstr*3 + varsky + xold = dblarr(nterm) + clamp = replicate(1.,nterm) + clip = 0b + niter = niter-1 + goto,RESTART + endif + + err = 1.085736*sqrt(magerr)/magg + magg = psfmag - 1.085736*alog(magg) + sharp = sharp > (-99.999) < 99.999 + xg = xg+ixmin & yg = yg+iymin + +; Print results to terminal and/or file + + if not SILENT then for i = 0,nstr-1 do print,format=fmt, $ + idg[i],xg[i],yg[i],magg[i],err[i],skyg[i],niter,chi[i],sharp[i] + if PRINT then for i = 0,nstr-1 do printf,lun,format=fmt, $ + idg[i],xg[i],yg[i],magg[i],err[i],skyg[i],niter,chi[i],sharp[i] + + if ( npar GE 9 ) then begin ;Create output vectors? + if ( N_elements(newid) EQ 0 ) then begin ;Initialize output vectors? + newid = idg & newx = xg & newy = yg & newmag = magg + iter = replicate(niter,nstr) & peak = sharp & chisq = chi + errmag = err + endif else begin ;Append current group to output vector + newid = [newid,idg] & newx = [newx ,xg] & newy = [newy,yg] + newmag = [newmag,magg] & iter = [iter,replicate(niter,nstr)] + peak = [peak,sharp] & chisq = [chisq,chi] & errmag = [errmag,err] + endelse + endif + +DONE_GROUP: + endfor + + if ( npar GE 9 ) then begin + if N_elements(newid) GT 0 then begin + id = newid & xc = newx & yc = newy & mags = newmag + endif else $ + message,'ERROR - There are no valid stars left, variables not updated',/CON + endif + + if PRINT then free_lun,lun + + return + end diff --git a/modules/idl_downloads/astro/pro/nulltrim.pro b/modules/idl_downloads/astro/pro/nulltrim.pro new file mode 100644 index 0000000..47dadbd --- /dev/null +++ b/modules/idl_downloads/astro/pro/nulltrim.pro @@ -0,0 +1,26 @@ +function nulltrim,st +;+ +; NAME: +; NULLTRIM +; PURPOSE: +; Trim a string of all characters after and including the first null +; EXPLANATION: +; The null character is an ascii 0b +; +; CALLING SEQUENCE: +; result = nulltrim( st ) +; +; INPUTS: +; st = input string +; OUTPUTS: +; trimmed string returned as the function value. +; HISTORY: +; D. Lindler July, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;-------------------------------------------------------------------- +; + b = byte(st) + null = where( b eq 0, nfound ) + if nfound lt 1 then return, st else return, strmid( st,0,null[0] ) + end diff --git a/modules/idl_downloads/astro/pro/nutate.pro b/modules/idl_downloads/astro/pro/nutate.pro new file mode 100644 index 0000000..9502438 --- /dev/null +++ b/modules/idl_downloads/astro/pro/nutate.pro @@ -0,0 +1,145 @@ +pro nutate, jd, nut_long, nut_obliq +;+ +; NAME: +; NUTATE +; PURPOSE: +; Return the nutation in longitude and obliquity for a given Julian date +; +; CALLING SEQUENCE: +; NUTATE, jd, Nut_long, Nut_obliq +; +; INPUT: +; jd - Julian ephemeris date, scalar or vector, double precision +; OUTPUT: +; Nut_long - the nutation in longitude, same # of elements as jd +; Nut_obliq - nutation in latitude, same # of elements as jd +; +; EXAMPLE: +; (1) Find the nutation in longitude and obliquity 1987 on Apr 10 at Oh. +; This is example 22.a from Meeus +; IDL> jdcnv,1987,4,10,0,jul +; IDL> nutate, jul, nut_long, nut_obliq +; ==> nut_long = -3.788 nut_obliq = 9.443 +; +; (2) Plot the large-scale variation of the nutation in longitude +; during the 20th century +; +; IDL> yr = 1900 + indgen(100) ;Compute once a year +; IDL> jdcnv,yr,1,1,0,jul ;Find Julian date of first day of year +; IDL> nutate,jul, nut_long ;Nutation in longitude +; IDL> plot, yr, nut_long +; +; This plot will reveal the dominant (18.6 year) period, but a finer +; grid is needed to display the shorter periods in the nutation. +; METHOD: +; Uses the formula in Chapter 22 of ``Astronomical Algorithms'' by Jean +; Meeus (1998, 2nd ed.) which is based on the 1980 IAU Theory of Nutation +; and includes all terms larger than 0.0003". +; +; PROCEDURES CALLED: +; POLY() (from IDL User's Library) +; CIRRANGE, ISARRAY() (from IDL Astronomy Library) +; +; REVISION HISTORY: +; Written, W.Landsman (Goddard/HSTX) June 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Corrected minor typos in values of d_lng W. Landsman December 2000 +; Updated typo in cdelt term December 2000 +; Avoid overflow for more than 32767 input dates W. Landsman January 2005 +;- + compile_opt idl2 + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - NUTATE, jd, nut_long, nut_obliq' + return + endif + + dtor = !DPI/180.0d + ; form time in Julian centuries from 1900.0 + + t = (jd[*] - 2451545.0d)/36525.0d0 + + +; Mean elongation of the Moon + + coeff1 = [297.85036d, 445267.111480d, -0.0019142, 1.d/189474d0 ] + d = poly(T, coeff1)*dtor + cirrange,d,/rad + +; Sun's mean anomaly + + coeff2 = [357.52772d, 35999.050340d, -0.0001603d, -1.d/3d5 ] + M = poly(T,coeff2)*dtor + cirrange, M,/rad + +; Moon's mean anomaly + + coeff3 = [134.96298d, 477198.867398d, 0.0086972d, 1.0/5.625d4 ] + Mprime = poly(T,coeff3)*dtor + cirrange, Mprime,/rad + +; Moon's argument of latitude + + coeff4 = [93.27191d, 483202.017538d, -0.0036825, -1.0d/3.27270d5 ] + F = poly(T, coeff4 )*dtor + cirrange, F,/RAD + +; Longitude of the ascending node of the Moon's mean orbit on the ecliptic, +; measured from the mean equinox of the date + + coeff5 = [125.04452d, -1934.136261d, 0.0020708d, 1.d/4.5d5] + omega = poly(T, coeff5)*dtor + cirrange,omega,/RAD + + d_lng = [0,-2,0,0,0,0,-2,0,0,-2,-2,-2,0,2,0,2,0,0,-2,0,2,0,0,-2,0,-2,0,0,2,$ + -2,0,-2,0,0,2,2,0,-2,0,2,2,-2,-2,2,2,0,-2,-2,0,-2,-2,0,-1,-2,1,0,0,-1,0,0, $ + 2,0,2] + + m_lng = [0,0,0,0,1,0,1,0,0,-1,intarr(17),2,0,2,1,0,-1,0,0,0,1,1,-1,0, $ + 0,0,0,0,0,-1,-1,0,0,0,1,0,0,1,0,0,0,-1,1,-1,-1,0,-1] + + mp_lng = [0,0,0,0,0,1,0,0,1,0,1,0,-1,0,1,-1,-1,1,2,-2,0,2,2,1,0,0,-1,0,-1, $ + 0,0,1,0,2,-1,1,0,1,0,0,1,2,1,-2,0,1,0,0,2,2,0,1,1,0,0,1,-2,1,1,1,-1,3,0] + + f_lng = [0,2,2,0,0,0,2,2,2,2,0,2,2,0,0,2,0,2,0,2,2,2,0,2,2,2,2,0,0,2,0,0, $ + 0,-2,2,2,2,0,2,2,0,2,2,0,0,0,2,0,2,0,2,-2,0,0,0,2,2,0,0,2,2,2,2] + + om_lng = [1,2,2,2,0,0,2,1,2,2,0,1,2,0,1,2,1,1,0,1,2,2,0,2,0,0,1,0,1,2,1, $ + 1,1,0,1,2,2,0,2,1,0,2,1,1,1,0,1,1,1,1,1,0,0,0,0,0,2,0,0,2,2,2,2] + + sin_lng = [-171996, -13187, -2274, 2062, 1426, 712, -517, -386, -301, 217, $ + -158, 129, 123, 63, 63, -59, -58, -51, 48, 46, -38, -31, 29, 29, 26, -22, $ + 21, 17, 16, -16, -15, -13, -12, 11, -10, -8, 7, -7, -7, -7, $ + 6,6,6,-6,-6,5,-5,-5,-5,4,4,4,-4,-4,-4,3,-3,-3,-3,-3,-3,-3,-3 ] + + sdelt = [-174.2, -1.6, -0.2, 0.2, -3.4, 0.1, 1.2, -0.4, 0, -0.5, 0, 0.1, $ + 0,0,0.1, 0,-0.1,dblarr(10), -0.1, 0, 0.1, dblarr(33) ] + + + cos_lng = [ 92025, 5736, 977, -895, 54, -7, 224, 200, 129, -95,0,-70,-53,0, $ + -33, 26, 32, 27, 0, -24, 16,13,0,-12,0,0,-10,0,-8,7,9,7,6,0,5,3,-3,0,3,3,$ + 0,-3,-3,3,3,0,3,3,3, intarr(14) ] + + cdelt = [8.9, -3.1, -0.5, 0.5, -0.1, 0.0, -0.6, 0.0, -0.1, 0.3, dblarr(53) ] + + +; Sum the periodic terms + + n = N_elements(jd) + nut_long = dblarr(n) + nut_obliq = dblarr(n) + arg = d_lng#d + m_lng#m +mp_lng#mprime + f_lng#f +om_lng#omega + sarg = sin(arg) + carg = cos(arg) + for i=0L,n-1 do begin + nut_long[i] = 0.0001d*total( (sdelt*t[i] + sin_lng)*sarg[*,i] ) + nut_obliq[i] = 0.0001d*total( (cdelt*t[i] + cos_lng)*carg[*,i] ) + end + if ~isarray(jd) then begin + nut_long = nut_long[0] + nut_obliq = nut_obliq[0] + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/observatory.pro b/modules/idl_downloads/astro/pro/observatory.pro new file mode 100644 index 0000000..9e16ccf --- /dev/null +++ b/modules/idl_downloads/astro/pro/observatory.pro @@ -0,0 +1,440 @@ +pro observatory,obsname,obs_struct, print = print +;+ +; NAME: +; OBSERVATORY +; PURPOSE: +; Return longitude, latitude, altitude & time zones of an observatory +; EXPLANATION: +; Given an observatory name, returns a structure giving the longitude, +; latitude, altitude, and time zone +; +; CALLING SEQUENCE: +; Observatory, obsname, obs_struct, [ /PRINT ] +; +; INPUTS: +; obsname - scalar or vector string giving abbreviated name(s) of +; observatories for which location or time information is requested. +; If obsname is an empty string, then information is returned for +; all observatories in the database. See the NOTES: section +; for the list of 41 recognized observatories. The case of the +; string does not matter +; OUTPUTS: +; obs_struct - an IDL structure containing information on the specified +; observatories. The structure tags are as follows: +; .observatory - abbreviated observatory name +; .name - full observatory name +; .longitude - observatory longitude in degrees *west* +; .latitude - observatory latitude in degrees +; .altitude - observatory altitude in meters above sea level +; .tz - time zone, number of hours *west* of Greenwich +; +; OPTIONAL INPUT KEYWORD: +; /PRINT - If this keyword is set, (or if only 1 parameter is supplied) +; then OBSERVATORY will display information about the specified +; observatories at the terminal +; EXAMPLE: +; Get the latitude, longitude and altitude of Kitt Peak National Observatory +; +; IDL> observatory,'kpno',obs +; IDL> print,obs.longitude ==> 111.6 degrees west +; IDL> print,obs.latitude ==> +31.9633 degrees +; IDL> print,obs.altitude ==> 2120 meters above sea level +; +; NOTES: +; Observatory information is taken from noao$lib/obsdb.dat file in IRAF 2.11 +; Currently recognized observatory names are as follows: +; +; 'kpno': Kitt Peak National Observatory +; 'ctio': Cerro Tololo Interamerican Observatory +; 'eso': European Southern Observatory +; 'lick': Lick Observatory +; 'mmto': MMT Observatory +; 'cfht': Canada-France-Hawaii Telescope +; 'lapalma': Roque de los Muchachos, La Palma +; 'mso': Mt. Stromlo Observatory +; 'sso': Siding Spring Observatory +; 'aao': Anglo-Australian Observatory +; 'mcdonald': McDonald Observatory +; 'lco': Las Campanas Observatory +; 'mtbigelow': Catalina Observatory: 61 inch telescope +; 'dao': Dominion Astrophysical Observatory +; 'spm': Observatorio Astronomico Nacional, San Pedro Martir +; 'tona': Observatorio Astronomico Nacional, Tonantzintla +; 'Palomar': The Hale Telescope +; 'mdm': Michigan-Dartmouth-MIT Observatory +; 'NOV': National Observatory of Venezuela +; 'bmo': Black Moshannon Observatory +; 'BAO': Beijing XingLong Observatory +; 'keck': W. M. Keck Observatory +; 'ekar': Mt. Ekar 182 cm. Telescope +; 'loiano': Bologna Astronomical Observatory, Loiano - Italy +; 'apo': Apache Point Observatory +; 'lowell': Lowell Observatory +; 'vbo': Vainu Bappu Observatory +; 'flwo': Whipple Observatory +; 'oro': Oak Ridge Observatory +; 'lna': Laboratorio Nacional de Astrofisica - Brazil +; 'saao': South African Astronomical Observatory +; 'casleo': Complejo Astronomico El Leoncito, San Juan +; 'bosque': Estacion Astrofisica Bosque Alegre, Cordoba +; 'rozhen': National Astronomical Observatory Rozhen - Bulgaria +; 'irtf': NASA Infrared Telescope Facility +; 'bgsuo': Bowling Green State Univ Observatory +; 'ca': Calar Alto Observatory +; 'holi': Observatorium Hoher List (Universitaet Bonn) - Germany +; 'lmo': Leander McCormick Observatory +; 'fmo': Fan Mountain Observatory +; 'whitin': Whitin Observatory, Wellesley College +; 'mgio': Mount Graham International Observatory +; +; PROCEDURE CALLS: +; TEN() +; REVISION HISTORY: +; Written W. Landsman July 2000 +; Corrected sign error for 'holi' W.L/ Holger Israel Mar 2008 +; Correctly terminate when observatory name not recognized +; S. Koposov, July 2008 +;- + + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Observatory, obsname, obs_struct, [/print]' + return + endif + +obs=[ 'kpno','ctio','eso','lick','mmto','cfht','lapalma','mso','sso','aao', $ + 'mcdonald','lco','mtbigelow','dao','spm','tona','Palomar','mdm','NOV','bmo',$ + 'BAO','keck','ekar','loiano','apo','lowell','vbo','flwo','oro','lna','saao',$ + 'casleo','bosque','rozhen','irtf','bgsuo','ca','holi','lmo','fmo','whitin',$ + 'mgio'] + + if N_elements(obsname) EQ 1 then if obsname eq '' then obsname = obs + nobs = N_elements(obsname) + obs_struct = {observatory:'',name:'', longitude:0.0, latitude:0.0, $ + altitude:0.0, tz:0.0} + if Nobs GT 1 then obs_struct = replicate(obs_struct,Nobs) + obs_struct.observatory = obsname + + +for i=0,Nobs-1 do begin +case strlowcase(obsname[i]) of +"kpno": begin + name = "Kitt Peak National Observatory" + longitude = [111,36.0] + latitude = [31,57.8] + altitude = 2120. + tz = 7 + end +"ctio": begin + name = "Cerro Tololo Interamerican Observatory" + longitude = 70.815 + latitude = -30.16527778 + altitude = 2215. + tz = 4 + end +"eso": begin + name = "European Southern Observatory" + longitude = [70,43.8] + latitude = [-29,15.4] + altitude = 2347. + tz = 4 + end +"lick": begin + name = "Lick Observatory" + longitude = [121,38.2] + latitude = [37,20.6] + altitude = 1290. + tz = 8 + end +"mmto": begin + name = "MMT Observatory" + longitude = [110,53.1] + latitude = [31,41.3] + altitude = 2600. + tz = 7 + end +"cfht": begin + name = "Canada-France-Hawaii Telescope" + longitude = [155,28.3] + latitude = [19,49.6] + altitude = 4215. + tz = 10 + end +"lapalma": begin + name = "Roque de los Muchachos, La Palma" + longitude = [17,52.8] + latitude = [28,45.5] + altitude = 2327 + tz = 0 + end +"mso": begin + name = "Mt. Stromlo Observatory" + longitude = [210,58,32.4] + latitude = [-35,19,14.34] + altitude = 767 + tz = -10 + end +"sso": begin + name = "Siding Spring Observatory" + longitude = [210,56,19.70] + latitude = [-31,16,24.10] + altitude = 1149 + tz = -10 + end +"aao": begin + name = "Anglo-Australian Observatory" + longitude = [210,56,2.09] + latitude = [-31,16,37.34] + altitude = 1164 + tz = -10 + end +"mcdonald": begin + name = "McDonald Observatory" + longitude = 104.0216667 + latitude = 30.6716667 + altitude = 2075 + tz = 6 + end +"lco": begin + name = "Las Campanas Observatory" + longitude = [70,42.1] + latitude = [-29,0.2] + altitude = 2282 + tz = 4 + end +"mtbigelow": begin + name = "Catalina Observatory: 61 inch telescope" + longitude = [110,43.9] + latitude = [32,25.0] + altitude = 2510. + tz = 7 + end +"dao": begin + name = "Dominion Astrophysical Observatory" + longitude = [123,25.0] + latitude = [48,31.3] + altitude = 229. + tz = 8 + end + "spm": begin + name = "Observatorio Astronomico Nacional, San Pedro Martir" + longitude = [115,29,13] + latitude = [31,01,45] + altitude = 2830. + tz = 7 + end + "tona": begin + name = "Observatorio Astronomico Nacional, Tonantzintla" + longitude = [98,18,50] + latitude = [19,01,58] + tz = 8 + altitude = -999999 ; Altitude not supplied + end + "palomar": begin + name = "The Hale Telescope" + longitude = [116,51,46.80] + latitude = [33,21,21.6] + altitude = 1706. + tz = 8 + end + "mdm": begin + name = "Michigan-Dartmouth-MIT Observatory" + longitude = [111,37.0] + latitude = [31,57.0] + altitude = 1938.5 + tz = 7 + end + "nov": begin + name = "National Observatory of Venezuela" + longitude = [70,52.0] + latitude = [8,47.4] + altitude = 3610 + tz = 4 + end + "bmo": begin + name = "Black Moshannon Observatory" + longitude = [78,00.3] + latitude = [40,55.3] + altitude = 738. + tz = 5 + end + "bao": begin + name = "Beijing XingLong Observatory" + longitude = [242,25.5] + latitude = [40,23.6] + altitude = 950. + tz = -8 + end + "keck": begin + name = "W. M. Keck Observatory" + longitude = [155,28.7] + latitude = [19,49.7] + altitude = 4160. + tz = 10 + end + "ekar": begin + name = "Mt. Ekar 182 cm. Telescope" + longitude = [348,25,07.92] + latitude = [45,50,54.92] + altitude = 1413.69 + tz = -1 + end + "loiano": begin + name = "Bologna Astronomical Observatory, Loiano - Italy" + longitude = [348,39,58] + latitude = [44,15,33] + altitude = 785. + tz = -1 + end + "apo": begin + name = "Apache Point Observatory" + longitude = [105,49.2] + latitude = [32,46.8] + altitude = 2798. + tz = 7 + end + "lowell": begin + name = "Lowell Observatory" + longitude = [111,32.1] + latitude = [35,05.8] + altitude = 2198. + tz = 7 + end + "vbo": begin + name = "Vainu Bappu Observatory" + longitude = 281.1734 + latitude = 12.57666 + altitude = 725. + tz = -5.5 + end + "flwo": begin + name = "Whipple Observatory" + longitude = [110,52,39] + latitude = [31,40,51.4] + altitude = 2320. + tz = 7 + end + "oro": begin + name = "Oak Ridge Observatory" + longitude = [71,33,29.32] + latitude = [42,30,18.94] + altitude = 184. + tz = 5 + end + + "lna": begin + name = "Laboratorio Nacional de Astrofisica - Brazil" + longitude = 45.5825 + latitude = [-22,32,04] + altitude = 1864. + tz = 3 + end + + "saao": begin + name = "South African Astronomical Observatory" + longitude = [339,11,21.5] + latitude = [-32,22,46] + altitude = 1798. + tz = -2 + end + "casleo": begin + name = "Complejo Astronomico El Leoncito, San Juan" + longitude = [69,18,00] + latitude = [-31,47,57] + altitude = 2552 + tz = 3 + end + "bosque": begin + name = "Estacion Astrofisica Bosque Alegre, Cordoba" + longitude = [64,32,45] + latitude = [-31,35,54] + altitude = 1250 + tz = 3 + end + "rozhen": begin + name = "National Astronomical Observatory Rozhen - Bulgaria" + longitude = [335,15,22] + latitude = [41,41,35] + altitude = 1759 + tz = -2 + end + "irtf": begin + name = "NASA Infrared Telescope Facility" + longitude = 155.471999 + latitude = 19.826218 + altitude = 4168 + tz = 10 + end + "bgsuo": begin + name = "Bowling Green State Univ Observatory" + longitude = [83,39,33] + latitude = [41,22,42] + altitude = 225. + tz = 5 + end + "ca": begin + name = "Calar Alto Observatory" + longitude = [2,32,46.5] + latitude = [37,13,25] + altitude = 2168 + tz = -1 + end + "holi": begin + name = "Observatorium Hoher List (Universitaet Bonn) - Germany" + longitude = 353.15 ;Corrected sign error March 2008 + latitude = 50.16276 + altitude = 541 + tz = -1 + end + "lmo": begin + name = "Leander McCormick Observatory" + longitude = [78,31,24] + latitude = [38,02,00] + altitude = 264 + tz = 5 + end + "fmo": begin + name = "Fan Mountain Observatory" + longitude = [78,41,34] + latitude = [37,52,41] + altitude = 556 + tz = 5 + end + "whitin": begin + name = "Whitin Observatory, Wellesley College" + longitude = 71.305833 + latitude = 42.295 + altitude = 32 + tz = 5 + end + "mgio": begin + name = "Mount Graham International Observatory" + longitude = [109,53,31.25] + latitude = [32,42,04.69] + altitude = 3191.0 + tz = 7 + end + else: message,'Unable to find observatory ' + obsname + ' in database' + endcase + + obs_struct[i].longitude = ten(longitude) + obs_struct[i].latitude = ten(latitude) + obs_struct[i].tz = tz + obs_struct[i].name = name + obs_struct[i].altitude = altitude + + if N_params() EQ 1 or keyword_set(print) then begin + print,' ' + print,'Observatory: ',obsname[i] + print,'Name: ',name + print,'longitude:',obs_struct[i].longitude + print,'latitude:',obs_struct[i].latitude + print,'altitude:',altitude + print,'time zone:',tz + endif + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/one_arrow.pro b/modules/idl_downloads/astro/pro/one_arrow.pro new file mode 100644 index 0000000..98d64f4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/one_arrow.pro @@ -0,0 +1,115 @@ +pro one_arrow,xcen,ycen,angle,label, linestyle = linestyle, $ + charsize=charsize,thick=thick,color=color, $ + arrowsize=arrowsize,font = font, data=data, normal=normal +;+ +; NAME: +; ONE_ARROW +; PURPOSE: +; Draws an arrow labeled with a single character on the current device +; EXPLANATION: +; ONE_ARROW is called, for example, by ARROWS to create a +; "weathervane" showing the N-E orientation of an image. +; +; CALLING SEQUENCE: +; one_arrow, xcen, ycen, angle, label, CHARSIZE = , THICK = , COLOR = +; ARROWSIZE=, FONT = ] +; INPUT PARAMETERS: +; xcen, ycen = starting point of arrow, floating point scalars, +; In device coordinates unless /DATA or /NORMAL set +; angle = angle of arrow in degrees counterclockwise from +X direction +; label = single-character label (may be blank) +; +; OUTPUT PARAMETERS: none +; +; OPTIONAL INPUT PARAMETERS: +; ARROWSIZE = 3-element vector defining appearance of arrow. +; For device coordinates the default is [30.0, 9.0, 35.0], +; meaning arrow is 30 pixels long; arrowhead lines 9 pixels +; long and inclined 35 degrees from arrow shaft. For +; normalized coordinates the default is divided by 512., for +; data coordinates the default is multiplied by +; (!X.crange[1] - !X.crange[0])/512.. +; CHARSIZE = usual IDL meaning, default = 2.0 +; COLOR = name or number give the color to draw the arrow. See +; cgCOLOR for a list of color names. +; /DATA - If set, then the input position (xcen, ycen) and the ARROWSIZE +; lengths are interpreted as being in data coordinates +; FONT - IDL vector font number to use (1-20). For example, to write +; the 'N' and 'E' characters in complex script, set font=13 +; /NORMAL - If set, then the input position (xcen, ycen) and the ARROWSIZE +; lengths are interpreted as being in normal coordinates +; THICK = usual IDL meaning, default = 2.0 +; EXAMPLE: +; Draw an triple size arrow emanating from the point (212,224) +; and labeled with the character 'S' +; +; IDL> one_arrow,212,224,270,'S',charsize=3 +; PROCEDURE: +; Calls one_ray to vector-draw arrow. +; MODIFICATION HISTORY: +; Written by R. S. Hill, Hughes STX Corp., 20-May-1992. +; Added font keyword, W.B. Landsman Hughes STX Corp. April 1995 +; Modified to work correctly for COLOR=0 J.Wm.Parker, HITC 1995 May 25 +; Add /NORMAL and /DATA keywords W.Landsman November 2006 +; Work with Coyote graphics W. Landsman February 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - one_arrow, xcen, ycen, angle, label, CHARSIZE = , FONT=' + print,' [ /DATA, /NORMAL, THICK= , COLOR=, ARROWSIZE = ]' + return + endif + + if (n_elements(arrowsize) ge 1) and (n_elements(arrowsize) ne 3) then begin + print,'Error in ONE_ARROW: returning to main level.' + print,'Arrowsize is [length, head_length, head_angle]' + print,'Defaults are [30.0,9.0,35.0]' + return + endif + + setdefaultvalue, charsize, 2.0 + setdefaultvalue, thick, 2.0 + if keyword_set(data) then scale = (!X.CRANGE[1] - !X.CRANGE[0])/512. $ + else if keyword_set(normal) then scale = 1/512. else scale = 1. + if N_elements(arrowsize) eq 0 then $ + arrowsize=[30.0*scale,9.0*scale,35.0] else $ + arrowsize = [arrowsize[0]*scale, arrowsize[1]*scale, arrowsize[2] ] + + device = ~keyword_set(data) && ~keyword_set(normal) + label = strmid(strtrim(label,2),0,1) + if keyword_set(font) then label = '!' + strtrim(font,2) + label + '!X ' + len = arrowsize[0] + headlen = arrowsize[1] + headangle = arrowsize[2] + baseline = (!d.y_ch_size+!d.x_ch_size)/2.0 + char_cen_offset = baseline*charsize + if keyword_set(data) then char_cen_offset = $ + convert_coord(char_cen_offset,0,/device,/to_data) - $ + convert_coord(0,0,/device,/to_data) + if keyword_set(normal) then char_cen_offset = $ + convert_coord(char_cen_offset,0,/device,/to_normal) - $ + convert_coord(0,0,/device,/to_normal) + char_cen_offset = char_cen_offset[0] + char_orig_len = char_cen_offset/2.0 + char_orig_angle = 225.0 +; Draw shaft of arrow +one_ray,xcen,ycen,len,angle,terminus,thick=thick,color=color,data= data, $ + normal=normal,linestyle=linestyle + +; Draw head of arrow +one_ray,terminus[0],terminus[1],headlen,(angle+180.0+headangle),t2, $ + thick=thick,color=color,data=data,normal=normal,linestyle=linestyle +one_ray,terminus[0],terminus[1],headlen,(angle+180.0-headangle),t2, $ + thick=thick,color=color,data = data, normal = normal,linestyle=linestyle + +; Draw label +one_ray,xcen,ycen,len+char_cen_offset,angle,terminus,/nodraw +one_ray,terminus[0],terminus[1],char_orig_len,char_orig_angle,char_orig,/nodraw +cgtext, char_orig[0], char_orig[1], label, charthick=thick, color=color, $ + charsize=charsize, device=device, normal=normal + + + return + end diff --git a/modules/idl_downloads/astro/pro/one_ray.pro b/modules/idl_downloads/astro/pro/one_ray.pro new file mode 100644 index 0000000..6714878 --- /dev/null +++ b/modules/idl_downloads/astro/pro/one_ray.pro @@ -0,0 +1,62 @@ +pro one_ray,xcen,ycen,len,angle,terminus,nodraw=nodraw, _EXTRA=_extra, $ + data = data, normal = normal +;+ +; NAME: +; ONE_RAY +; PURPOSE: +; Draw a line with a specified starting point, length, and angle +; +; CALLING SEQUENCE: +; one_ray, xcen, ycen, len, angle, terminus, /NODRAW ] +; +; INPUT PARAMETERS: +; xcen, ycen = starting point in device coordinates, floating point +; scalars +; len = length in pixels, device coordinates +; angle = angle in degrees counterclockwise from +X direction +; +; OUTPUT PARAMETERS: +; terminus = two-element vector giving ending point of ray in device +; coordinates +; +; OPTIONAL KEYWORD INPUT PARAMETERS: +; /nodraw if non-zero, the ray is not actually drawn, but the terminus +; is still calculated +; +; Any valid keyword to cgPLOTS can also be passed ot ONE_RAY. In +; particular, COLOR, THICK, and LINESTYLE control the color, thickness +; and linestyle of the drawn line. +; EXAMPLE: +; Draw a double thickness line of length 32 pixels from (256,256) +; 45 degrees counterclockwise from the X axis +; +; IDL> one_ray, 256, 256, 32, 45 ,term, THICK = 2 +; +; PROCEDURE: straightforward matrix arithmetic +; +; MODIFICATION HISTORY: +; Written by R. S. Hill, Hughes STX Corp., 20-May-1992. +; Modified to work correctly for COLOR=0 J.Wm.Parker HITC 1995 May 25 +; Added _EXTRA keywords to PLOT W. Landsman November 2006 +; Work with Coyote Graphcis W. Landsman February 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - one_ray, xcen, ycen, len, angle, [terminus,] ' + $ + '[ /DATA, /NORMAL, THICK= ,COLOR =, /NODRAW ]' + endif + + device = ~keyword_set(normal) && ~keyword_set(data) + sina = sin(angle/!radeg) + cosa = cos(angle/!radeg) + rot_mat = [ [ cosa, sina ], [-sina, cosa ] ] + terminus = (rot_mat # [len, 0.0]) + [xcen, ycen] + + if ~keyword_set(nodraw) then $ + cgplots, [xcen, terminus[0]], [ycen, terminus[1]], $ + DEVICE=device, Normal=Normal,_STRICT_Extra= _extra + + return + end diff --git a/modules/idl_downloads/astro/pro/oploterror.pro b/modules/idl_downloads/astro/pro/oploterror.pro new file mode 100644 index 0000000..742f214 --- /dev/null +++ b/modules/idl_downloads/astro/pro/oploterror.pro @@ -0,0 +1,308 @@ +PRO oploterror, x, y, xerr, yerr, NOHAT=nohat, HATLENGTH=hln, ERRTHICK=eth, $ + ERRSTYLE=est, THICK = thick, NOCLIP=noclip, ERRCOLOR = ecol, Nsum = nsum,$ + NSKIP=nskip, LOBAR=lobar, HIBAR=hibar, ADDCMD=addcmd, WINDOW=window, $ + _EXTRA = pkey +;+ +; NAME: +; OPLOTERROR +; PURPOSE: +; Over-plot data points with accompanying X or Y error bars. +; EXPLANATION: +; For use instead of PLOTERROR when the plotting system has already been +; defined. +; +; CALLING SEQUENCE: +; oploterror, [ x,] y, [xerr], yerr, +; [ /NOHAT, HATLENGTH= , ERRTHICK =, ERRSTYLE=, ERRCOLOR =, +; /LOBAR, /HIBAR, NSKIP = , NSUM = , /ADDCMD, ... OPLOT keywords ] +; INPUTS: +; X = array of abscissas, any datatype except string +; Y = array of Y values, any datatype except string +; XERR = array of error bar values (along X) +; YERR = array of error bar values (along Y) +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; +; /ADDCMD = Set this keyword if you want to add this command to +; a cgWindow. +; /NOHAT = if specified and non-zero, the error bars are drawn +; without hats. +; HATLENGTH = the length of the hat lines used to cap the error bars. +; Defaults to !D.X_VSIZE / 100). +; ERRTHICK = the thickness of the error bar lines. Defaults to the +; THICK plotting keyword. +; ERRSTYLE = the line style to use when drawing the error bars. Uses +; the same codes as LINESTYLE. +; ERRCOLOR = String (e.g. 'red') or scalar integer (0 - !D.N_TABLE) +; specifying the color to use for the error bars. See CGCOLOR() +; for a list of possible color names. See +; http://www.idlcoyote.com/cg_tips/legcolor.php +; for a warning about the use of indexed color +; NSKIP = Positive Integer specifying the error bars to be plotted. +; For example, if NSKIP = 2 then every other error bar is +; plotted; if NSKIP=3 then every third error bar is plotted. +; Default is to plot every error bar (NSKIP = 1) +; NSUM = Number of points to average over before plotting, default = +; !P.NSUM The errors are also averaged, and then divided by +; sqrt(NSUM). This approximation is meaningful only when the +; neighboring error bars have similar sizes. +; +; /LOBAR = if specified and non-zero, will draw only the -ERR error bars. +; /HIBAR = if specified and non-zero, will draw only the +ERR error bars. +; If neither LOBAR or HIBAR are set _or_ if both are set, +; you will get both error bars. Just specify one if you +; only want one set. +; /WINDOW - A synonum for ADDCMD (since OPLOTERROR will never open a +; new window). +; Any valid keywords to the OPLOT command (e.g. PSYM, YRANGE) are also +; accepted by OPLOTERROR via the _EXTRA facility. +; +; NOTES: +; If only two parameters are input, they are taken as Y and YERR. If only +; three parameters are input, they will be taken as X, Y and YERR, +; respectively. +; +; EXAMPLE: +; Suppose one has X and Y vectors with associated errors XERR and YERR +; and that a plotting system has already been defined: +; +; (1) Overplot Y vs. X with both X and Y errors and no lines connecting +; the points +; IDL> oploterror, x, y, xerr, yerr, psym=3 +; +; (2) Like (1) but overplot only the Y error bars and omits "hats" +; IDL> oploterror, x, y, yerr, psym=3, /NOHAT +; +; (3) Like (2) but suppose one has a positive error vector YERR1, and +; a negative error vector YERR2 (asymmetric error bars) +; IDL> oploterror, x, y, yerr1, psym=3, /NOHAT,/HIBAR +; IDL> oploterror, x, y, yerr2, psym=3, /NOHAT,/LOBAR +; +; PROCEDURE: +; A plot of X versus Y with error bars drawn from Y - YERR to Y + YERR +; and optionally from X - XERR to X + XERR is written to the output device +; +; WARNING: +; This an enhanced version of the procedure OPLOTERR in the standard RSI +; library. It was renamed to OPLOTERROR in June 1998 in the IDL +; Astronomy library. +; +; MODIFICATION HISTORY: +; Adapted from the most recent version of PLOTERR. M. R. Greason, +; Hughes STX, 11 August 1992. +; Added COLOR keyword option to error bars W. Landsman November 1993 +; Add ERRCOLOR, use _EXTRA keyword, W. Landsman, July 1995 +; Remove spurious call to PLOT_KEYWORDS W. Landsman, August 1995 +; OPLOT more than 32767 error bars W. Landsman, Feb 1996 +; Added NSKIP keyword W. Landsman, Dec 1996 +; Added HIBAR and LOBAR keywords, M. Buie, Lowell Obs., Feb 1998 +; Rename to OPLOTERROR W. Landsman June 1998 +; Ignore !P.PSYM when drawing error bars W. Landsman Jan 1999 +; Handle NSUM keyword correctly W. Landsman Aug 1999 +; Check limits for logarithmic axes W. Landsman Nov. 1999 +; Work in the presence of NAN values W. Landsman Dec 2000 +; Improve logic when NSUM or !P.NSUM is set W. Landsman Jan 2001 +; Remove NSUM keyword from PLOTS call W. Landsman March 2001 +; Only draw error bars with in XRANGE (for speed) W. Landsman Jan 2002 +; Fix Jan 2002 update to work with log plots W. Landsman Jun 2002 +; Added STRICT_EXTRA keyword W. Landsman July 2005 +; W. Landsman Fixed case of logarithmic axes reversed Mar 2009 +; Update for Coyote Graphics W. Landsman Feb. 2011 +; Hats were not being plotted by default W. Landsman Apr 2011 +; With latest CGPLOT, no need to deal special case of only a single point +; W. Landsman October 2012 +; Work with a cgWindow, /WINDOW a synonum for /ADDCMD W. Landsman Feb 2013 +;- +; Check the parameters. +; + On_error, 2 + compile_opt idl2 + np = N_params() + IF (np LT 2) THEN BEGIN + print, "OPLOTERR must be called with at least two parameters." + print, "Syntax: oploterr, [x,] y, [xerr], yerr, [..oplot keywords... " + print,' /NOHAT, HATLENGTH = , ERRTHICK=, ERRSTLYE=, ERRCOLOR=' + print,' /LOBAR, /HIBAR, /ADDCMD, NSKIP= ]' + RETURN + ENDIF + + ; Add it to a cgWindow, if required. + + addcmd = Keyword_Set(addcmd) || keyword_set(window) + IF (Keyword_Set(addcmd)) && ((!D.Flags AND 256) NE 0) THEN BEGIN + + void = cgQuery(Count=count) + IF count EQ 0 THEN Message, 'No cgWindow currently exists to add this command to.' + cgWindow, 'oploterror', x, y, xerr, yerr, NOHAT=nohat, HATLENGTH=hln, ERRTHICK=eth, $ + ERRSTYLE=est, THICK = thick, NOCLIP=noclip, ERRCOLOR = ecol, Nsum = nsum,$ + NSKIP=nskip, LOBAR=lobar, HIBAR=hibar, ADDCMD=1, _EXTRA = pkey + + RETURN + ENDIF + + +; Error bar keywords (except for HATLENGTH; this one will be taken care of +; later, when it is time to deal with the error bar hats). + + setdefaultvalue, thick, !P.THICK + setdefaultvalue, eth, thick + setdefaultvalue, est, 0 ;Error line style + setdefaultvalue, noclip, 0 + if ~keyword_set(NSKIP) then nskip = 1 + setdefaultvalue, nsum , !P.NSUM + if (N_elements(ecol) EQ 0) && (N_elements(pkey) GT 0) then $ + if tag_exist(pkey,'COLOR') then ecol = pkey.color + if ~keyword_set(lobar) && ~keyword_set(hibar) then begin + lobar=1 + hibar=1 + endif else if keyword_set(lobar) && keyword_set(hibar) then begin + lobar=1 + hibar=1 + endif else if keyword_set(lobar) then begin + lobar=1 + hibar=0 + endif else begin + lobar=0 + hibar=1 + endelse +; +; If no X array has been supplied, create one. Make sure the rest of the +; procedure can know which parameter is which. +; + IF np EQ 2 THEN BEGIN ; Only Y and YERR passed. + yerr = y + yy = x + xx = indgen(n_elements(yy)) + xerr = make_array(size=size(xx)) + + ENDIF ELSE IF np EQ 3 THEN BEGIN ; X, Y, and YERR passed. + yerr = xerr + yy = y + xx = x + + ENDIF ELSE BEGIN ; X, Y, XERR and YERR passed. + yy = y + g = where(finite(xerr)) + xerr[g] = abs(xerr[g]) + xx = x + ENDELSE + + g = where(finite(yerr)) + yerr[g] = abs(yerr[g]) + +; +; Determine the number of points being plotted. This +; is the size of the smallest of the three arrays +; passed to the procedure. Truncate any overlong arrays. +; + + n = N_elements(xx) < N_elements(yy) + + IF np GT 2 then n = n < N_elements(yerr) + IF np EQ 4 then n = n < N_elements(xerr) + + xx = xx[0:n-1] + yy = yy[0:n-1] + yerr = yerr[0:n-1] + IF np EQ 4 then xerr = xerr[0:n-1] + +; If NSUM is greater than one, then we need to smooth ourselves (using FREBIN) + + if NSum GT 1 then begin + n1 = float(n) / nsum + n = long(n1) + xx = frebin(xx, n1) + yy = frebin(yy, n1) + yerror = frebin(yerr,n1)/sqrt(nsum) + if NP EQ 4 then xerror = frebin(xerr,n1)/sqrt(nsum) + endif else begin + yerror = yerr + if NP EQ 4 then xerror = xerr + endelse + + ylo = yy - yerror*lobar + yhi = yy + yerror*hibar + + if Np EQ 4 then begin + xlo = xx - xerror*lobar + xhi = xx + xerror*hibar + endif + +; +; Plot the positions. +; + window = cgquery(/current) GE 0 + cgPlot, xx, yy, NOCLIP=noclip,THICK = thick,_STRICT_EXTRA = pkey,/over + +;; +;; Plot the error bars. Compute the hat length in device coordinates +;; so that it remains fixed even when doing logarithmic plots. +;; + + data_low = convert_coord(xx,ylo,/TO_DEVICE) + data_hi = convert_coord(xx,yhi,/TO_DEVICE) + if NP EQ 4 then begin + x_low = convert_coord(xlo,yy,/TO_DEVICE) + x_hi = convert_coord(xhi,yy,/TO_DEVICE) + endif + + ycrange = !Y.CRANGE & xcrange = !X.CRANGE + if !Y.type EQ 1 then ylo = ylo > 10^min(ycrange) + + if (!X.type EQ 1) && (np EQ 4) then xlo = xlo > 10^min(xcrange) + + sv_psym = !P.PSYM & !P.PSYM = 0 ;Turn off !P.PSYM for error bars +; Only draw error bars for X values within XCRANGE + if !X.TYPE EQ 1 then xcrange = 10^xcrange + g = where((xx GT xcrange[0]) and (xx LE xcrange[1]), Ng) + if (Ng GT 0) && (Ng NE n) then begin + istart = min(g, max = iend) + endif else begin + istart = 0L & iend = n-1 + endelse + + ; Set plotting color. + ecol = cgDefaultColor(ecol, Default='opposite') + IF Size(ecol, /TNAME) EQ 'STRING' THEN ecol = cgColor(ecol) + + FOR i = istart, iend, Nskip DO BEGIN + + Plots, [xx[i],xx[i]], [ylo[i],yhi[i]], LINESTYLE=est,THICK=eth, $ + NOCLIP = noclip, COLOR = ecol + + ; Plot X-error bars + ; + if np EQ 4 then $ + Plots, [xlo[i],xhi[i]],[yy[i],yy[i]],LINESTYLE=est, $ + THICK=eth, COLOR = ecol, NOCLIP = noclip + + IF ~keyword_set(nohat) THEN BEGIN + IF (N_elements(hln) EQ 0) THEN hln = !D.X_VSIZE/100. + exx1 = data_low[0,i] - hln/2. + exx2 = exx1 + hln + if lobar then $ + Plots, [exx1,exx2], [data_low[1,i],data_low[1,i]],COLOR=ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, noclip = noclip + if hibar then $ + Plots, [exx1,exx2], [data_hi[1,i],data_hi[1,i]], COLOR = ecol,$ + LINESTYLE=est,THICK=eth,/DEVICE, noclip = noclip +; + IF np EQ 4 THEN BEGIN + IF (N_elements(hln) EQ 0) THEN hln = !D.Y_VSIZE/100. + eyy1 = x_low[1,i] - hln/2. + eyy2 = eyy1 + hln + if lobar then $ + Plots, [x_low[0,i],x_low[0,i]], [eyy1,eyy2],COLOR = ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, NOCLIP = noclip + if hibar then $ + Plots, [x_hi[0,i],x_hi[0,i]], [eyy1,eyy2],COLOR = ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, NOCLIP = noclip + ENDIF + ENDIF + NOPLOT: +ENDFOR + !P.PSYM = sv_psym + +; +RETURN +END diff --git a/modules/idl_downloads/astro/pro/ordinal.pro b/modules/idl_downloads/astro/pro/ordinal.pro new file mode 100644 index 0000000..c0f4f1e --- /dev/null +++ b/modules/idl_downloads/astro/pro/ordinal.pro @@ -0,0 +1,37 @@ +FUNCTION ordinal,num +;+ +; NAME: +; ORDINAL +; PURPOSE: +; Convert an integer to a correct English ordinal string: +; EXPLANATION: +; The first four ordinal strings are "1st", "2nd", "3rd", "4th" .... +; +; CALLING SEQUENCE: +; result = ordinal( num ) +; +; INPUT PARAMETERS: +; num = number to be made an ordinal. If float, will be FIXed. +; +; OUTPUT PARAMETERS: +; result = string such as '1st' '3rd' '164th' '87th', etc. +; +; MODIFICATION HISTORY: +; Written by R. S. Hill, STX, 8 Aug. 1991 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +On_error,2 +num = fix(num) +CASE num MOD 100 OF + 11: suffix = 'th' + 12: suffix = 'th' + 13: suffix = 'th' + ELSE: CASE num MOD 10 OF + 1: suffix = 'st' + 2: suffix = 'nd' + 3: suffix = 'rd' + ELSE: suffix = 'th' + ENDCASE +ENDCASE +RETURN,strtrim(string(num),2)+suffix +END diff --git a/modules/idl_downloads/astro/pro/partvelvec.pro b/modules/idl_downloads/astro/pro/partvelvec.pro new file mode 100644 index 0000000..69a64ee --- /dev/null +++ b/modules/idl_downloads/astro/pro/partvelvec.pro @@ -0,0 +1,250 @@ +;+ +; NAME: +; PARTVELVEC +; +; PURPOSE: +; Plot the velocity vectors of particles at their positions +; EXPLANATION: +; This procedure plots the velocity vectors of particles (at the +; positions of the particles). +; +; For a similar procedure look at cgDrawVectors +; http://www.idlcoyote.com/idldoc/cg/cgdrawvectors.html +; CATEGORY: +; Plotting, Two-dimensional. +; +; CALLING SEQUENCE: +; PARTVELVEC, VELX, VELY, POSX, POSY [, X, Y] +; +; INPUTS: +; VELX: An array of any dimension, containing the x-components +; of the particle velocities. Can include NaN values +; VELY: An array of the same dimension as velx, containing the +; y-components of the particle velocities. +; POSX: An array of the same dimension as velx, containing the +; x-components of the particle positions. +; POSY: An array of the same dimension as velx, containing the +; y-components of the particle positions. +; +; OPTIONAL INPUTS: +; X: Optional abscissa values. X must be a vector. +; Y: Optional ordinate values. Y must be a vector. If only X +; is specified, then Y is taken equal to be equal to X. +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; FRACTION: The fraction of the vectors to plot. They are +; taken at random from the complete sample. Default is +; FRACTION = 1.0, use all vectors +; +; LENGTH: The maximum vectorlength relative to the plot data +; window. Default = 0.08 +; +; COLOR: Color for the vectors, axes and titles by string name or +; number (see cgCOLOR). Note that if VECCOLORS is +; supplied, then the COLOR keyword still specifies the +; color of the axes and title. Default = 'Opposite' +; +; OVER: Plot over the previous plot +; +; VECCOLORS: The vector colors. Must be either a scalar, or +; a vector (nmeric or string) the same size as VELX. +; Set to COLOR by default. +; WINDOW - Set this keyword to plot to a resizeable graphics window +; +; Plot All other keywords available to cgPlot (e.g. AXISCOLOR, +; Keywords: LINESTYLE, XRANGE) are available (via _EXTRA) +; +; OUTPUTS: +; This procedure plots the velocity vectors (VELX,VELY) at the +; positions of the particles, (POSX,POSY). If X and Y are not +; specified, then the size of the plot is such that all vectors +; just fit within in the plot data window. +; +; SIDE EFFECTS: +; Plotting on the current device is performed. +; +; EXAMPLE: +; Generate some particle positions and velocities. +; +; POSX=RANDOMU(seed,200) +; POSY=RANDOMU(seed,200) +; VELX=RANDOMU(seed,200)-0.5 +; VELY=RANDOMU(seed,200)-0.5 +; +; Plot the particle velocities. +; +; PARTVELVEC, VELX, VELY, POSX, POSY +; +; Example using vector colors. +; +; POSX=RANDOMU(seed,200) +; POSY=RANDOMU(seed,200) +; VELX=RANDOMU(seed,200)-0.5 +; VELY=RANDOMU(seed,200)-0.5 +; magnitude = SQRT(velx^2 + vely^2) +; LOADCT, 5, NCOLORS=254, BOTTOM=1 ; Load vector colors +; colors = BytScl(magnitude, Top=254) + 1B +; PARTVELVEC, VELX, VELY, POSX, POSY, COLOR='green', VECCOLORS=colors +; +; MODIFICATION HISTORY: +; Written by: Joop Schaye (jschaye@astro.rug.nl), Sep 1996. +; Added /OVER keyword Theo Brauers (th.brauers@fz-juelich.de) Jul 2002 +; Added VECCOLORS keyword. David Fanning (david@dfanning.com) March, 2005 +; Incorporate the Coyote Graphics (cg) plot programs WL January 2011 +; Allow VELX, VELY to include NaN values P. Blitzer/WL March 2013 +; Allow NOCLIP=0 when overplotting A. Negri October 2014 +;- + +PRO partvelvec,velx,vely,posx,posy,x,y, OVER = over, VECCOLORS=vecColors, $ + FRACTION=fraction,LENGTH=length,COLOR=color,WINDOW=window, $ + NOCLIP=noclip, _EXTRA=extra + + +;--------------------------------------------- +; Various settings, modify these to customize +;--------------------------------------------- + +c = {customize, $ + length: 0.08, $ ; Maximum vector length relative to plot region. (*) + lengtharrow: 0.3, $ ; Length of arrowhead legs relative to vectorlength. + angle: 22.5 } ; 1/2 times the angle between the arrowhead legs. + +; (*) Not used if keyword LENGTH is present + + +;--------------------- +; Some error handling +;--------------------- + +on_error,2 ; Return to caller if an error occurs. + +nparams=n_params() +IF nparams NE 4 THEN BEGIN + IF (nparams NE 5 AND nparams NE 6) THEN BEGIN + message,'Wrong number of parameters!',/continue + message,'Syntax: PARTVELVEC, VELX, VELY, POSX, POSY [, X, Y]', $ + /noname,/noprefix + ENDIF + IF nparams EQ 5 THEN y=x + sizex = size(x) + sizey = size(y) + IF (sizex[0] NE 1 || sizey[0] NE 1) THEN $ + message,'X and Y must be vectors!' +ENDIF + +sizevelx = size(velx) +sizevely = size(vely) +sizeposx = size(posx) +sizeposy = size(posy) + +IF (total(sizevelx[0:sizevelx[0]]-sizevely[0:sizevelx[0]]) NE 0 $ + || total(sizevelx[0:sizevelx[0]]-sizeposx[0:sizevelx[0]]) NE 0 $ + || total(sizevelx[0:sizevelx[0]]-sizeposy[0:sizevelx[0]]) NE 0) THEN $ + message,'All arguments must have the same dimension and size!' + +IF n_elements(fraction) GT 0 THEN $ + IF (fraction LT 0.0 || fraction GT 1.0) THEN $ + message,'Fraction has to be between 0.0 and 1.0.' + + +;-------------- +; Prepare plot +;-------------- + + nvecs = n_elements(velx) ; Number of particles. + vel = sqrt(velx^2+vely^2) ; Total velocity. + maxvel = max(vel,/nan) ; Maximum velocity. + +; Compute maximum length of vectors. +IF n_elements(length) LE 0 THEN length=c.length +minposx = min(posx) +maxposx = max(posx) +minposy = min(posy) +maxposy = max(posy) +length = length*((maxposx-minposx) > (maxposy-minposy)) + +; Convert velocities. +vx = length*velx/maxvel +vy = length*vely/maxvel +vel = length*temporary(vel)/maxvel + +; Make sure no vectors extend beyond the plot data window. +x1 = posx+vx ; End of vector. +y1 = posy+vy +IF nparams EQ 4 THEN BEGIN + minposx = min(x1)maxposx + minposy = min(y1)maxposy +ENDIF + +angle = c.angle*!dtor ; Convert from degrees to radians. +sinangle = sin(angle) ; Need these. +cosangle = cos(angle) + + +;----------- +; Plot axes +;----------- + +if N_elements(color) EQ 0 then color = cgcolor('opposite') +IF n_elements(veccolors) EQ 0 THEN BEGIN + veccolors = Replicate(cgcolor('opposite'), nvecs) +ENDIF ELSE BEGIN + nvc = N_Elements(veccolors) + CASE nvc OF + 1: veccolors = Replicate(veccolors, nvecs) + nvecs: + ELSE: Message, 'Vector color array VECCOLORS must be same size as VELX.' + ENDCASE +ENDELSE +IF n_elements(over) EQ 0 THEN BEGIN +IF nparams EQ 4 THEN $ + cgPlot,[minposx,maxposx],[minposy,maxposy], axiscolor=color,$ + /nodata,/xstyle,/ystyle,COLOR=color,window=window,_EXTRA=extra $ +ELSE cgPlot,x,y,/nodata,/xstyle,/ystyle,COLOR=color,window=window,_EXTRA=extra +ENDIF +if keyword_set(window) then cgcontrol,execute=0 +;-------------- +; Plot vectors +;-------------- + +IF (n_elements(fraction) GT 0) && (fraction NE 1.0) THEN BEGIN + nrgood=long(fraction*nvecs) ; # of vectors to plot. + IF nrgood EQ 0 THEN return + ; Compute indices of vectors to plot. I use two lines to get more + ; random "random numbers". + good=long(randomu(seed,nrgood+1)*(nvecs-1.0)) + good=good[1:*] + vx = temporary(vx[good]) + vy = temporary(vy[good]) + px = posx[good] ; Can't use temporary if we want to keep the data. + py = posy[good] + x1 = temporary(x1[good]) + y1 = temporary(y1[good]) + nvecs=nrgood +ENDIF ELSE BEGIN + px=posx + py=posy +ENDELSE + +FOR i=0l,nvecs-1l DO BEGIN ; Loop over particles. + ; Note that we cannot put the next three lines outside the loop, + ; because we want the arrow size to be relative to the vector length. + r = c.lengtharrow*vel[i] ; Length of arrow head. + rsin = r*sinangle + rcos = r*cosangle + ; Draw basis, arrow leg, same arrow leg, other arrow leg. + ; One arrow leg is drawn twice, because we need to return to the end + ; of the vector to draw the other leg. + + cgPlots,[px[i],x1[i],x1[i]-(vx[i]*rcos+vy[i]*rsin)/vel[i], $ + x1[i],x1[i]-(vx[i]*rcos-vy[i]*rsin)/vel[i]], $ + [py[i],y1[i],y1[i]-(vy[i]*rcos-vx[i]*rsin)/vel[i], $ + y1[i],y1[i]-(vy[i]*rcos+vx[i]*rsin)/vel[i]],COLOR=veccolors[i],$ + ADDCMD = window, noclip=noclip + +ENDFOR + if keyword_set(window) then cgcontrol,execute=1 + return +END ; End of procedure PARTVELVEC. diff --git a/modules/idl_downloads/astro/pro/pca.pro b/modules/idl_downloads/astro/pro/pca.pro new file mode 100644 index 0000000..26cca3c --- /dev/null +++ b/modules/idl_downloads/astro/pro/pca.pro @@ -0,0 +1,267 @@ +PRO PCA, data, eigenval, eigenvect, percentages, proj_obj, proj_atr, $ + MATRIX=AM,TEXTOUT=textout,COVARIANCE=cov,SSQ=ssq,SILENT=silent + +;+ +; NAME: +; PCA +; +; PURPOSE: +; Carry out a Principal Components Analysis (Karhunen-Loeve Transform) +; EXPLANATION: +; Results can be directed to the screen, a file, or output variables +; See notes below for comparison with the intrinsic IDL function PCOMP. +; +; Harris Geospatial has a video/blog post on using pca.pro at +; http://tinyurl.com/h6ky6qy +; +; CALLING SEQUENCE: +; PCA, data, eigenval, eigenvect, percentages, proj_obj, proj_atr, +; [MATRIX =, TEXTOUT = ,/COVARIANCE, /SSQ, /SILENT ] +; +; INPUT PARAMETERS: +; data - 2-d data matrix, data(i,j) contains the jth attribute value +; for the ith object in the sample. If N_OBJ is the total +; number of objects (rows) in the sample, and N_ATTRIB is the +; total number of attributes (columns) then data should be +; dimensioned N_OBJ x N_ATTRIB. +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; /COVARIANCE - if this keyword is set, then the PCA will be carried out +; on the covariance matrix (rare), the default is to use the +; correlation matrix +; /SILENT - If this keyword is set, then no output is printed +; /SSQ - if this keyword is set, then the PCA will be carried out on +; on the sums-of-squares & cross-products matrix (rare) +; TEXTOUT - Controls print output device, defaults to !TEXTOUT +; +; textout=1 TERMINAL using /more option +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout = filename (default extension of .prt) +; +; OPTIONAL OUTPUT PARAMETERS: +; eigenval - N_ATTRIB element vector containing the sorted eigenvalues +; eigenvect - N_ATRRIB x N_ATTRIB matrix containing the corresponding +; eigenvectors +; percentages - N_ATTRIB element containing the cumulative percentage +; variances associated with the principal components +; proj_obj - N_OBJ by N_ATTRIB matrix containing the projections of the +; objects on the principal components +; proj_atr - N_ATTRIB by N_ATTRIB matrix containing the projections of +; the attributes on the principal components +; +; OPTIONAL OUTPUT PARAMETER +; MATRIX = analysed matrix, either the covariance matrix if /COVARIANCE +; is set, the "sum of squares and cross-products" matrix if +; /SSQ is set, or the (by default) correlation matrix. Matrix +; will have dimensions N_ATTRIB x N_ATTRIB +; +; NOTES: +; This procedure performs Principal Components Analysis (Karhunen-Loeve +; Transform) according to the method described in "Multivariate Data +; Analysis" by Murtagh & Heck [Reidel : Dordrecht 1987], pp. 33-48. +; See http://www.classification-society.org/csna/mda-sw/pca.f +; +; Keywords /COVARIANCE and /SSQ are mutually exclusive. +; +; The printout contains only (at most) the first seven principle +; eigenvectors. However, the output variables EIGENVECT contain +; all the eigenvectors +; +; Different authors scale the covariance matrix in different ways. +; The eigenvalues output by PCA may have to be scaled by 1/N_OBJ or +; 1/(N_OBJ-1) to agree with other calculations when /COVAR is set. +; +; PCA uses the non-standard system variables !TEXTOUT and !TEXTUNIT. +; These are automatically added if not originally present. +; +; The intrinsic IDL function PCOMP duplicates most +; most of the functionality of PCA, but uses different conventions and +; normalizations. Note the following: +; +; (1) PCOMP requires a N_ATTRIB x N_OBJ input array; this is the transpose +; of what PCA expects +; (2) PCA uses standardized variables for the correlation matrix: the input +; vectors are set to a mean of zero and variance of one and divided by +; sqrt(n); use the /STANDARDIZE keyword to PCOMP for a direct comparison. +; (3) PCA (unlike PCOMP) normalizes the eigenvectors by the square root +; of the eigenvalues. +; (4) PCA returns cumulative percentages; the VARIANCES keyword of PCOMP +; returns the variance in each variable +; (5) PCOMP divides the eigenvalues by (1/N_OBJ-1) when the covariance matrix +; is used. +; +; EXAMPLE: +; Perform a PCA analysis on the covariance matrix of a data matrix, DATA, +; and write the results to a file +; +; IDL> PCA, data, /COVAR, t = 'pca.dat' +; +; Perform a PCA analysis on the correlation matrix. Suppress all +; printing, and save the eigenvectors and eigenvalues in output variables +; +; IDL> PCA, data, eigenval, eigenvect, /SILENT +; +; PROCEDURES CALLED: +; TEXTOPEN, TEXTCLOSE +; +; REVISION HISTORY: +; Immanuel Freedman (after Murtagh F. and Heck A.). December 1993 +; Wayne Landsman, modified I/O December 1993 +; Fix MATRIX output, remove GOTO statements W. Landsman August 1998 +; Changed some index variable to type LONG W. Landsman March 2000 +; Fix error in computation of proj_atr, see Jan 1990 fix in +; http://astro.u-strasbg.fr/~fmurtagh/mda-sw/pca.f W. Landsman Feb 2008 +;- + compile_opt idl2 + On_Error,2 ;return to user if error + +; Constants + TOLERANCE = 1.0E-5 ; are array elements near-zero ? + +; Dispatch table + + IF N_PARAMS() EQ 0 THEN BEGIN + print,'Syntax - PCA, data, [eigenval, eigenvect, percentages, proj_obj, proj_atr,' + print,' [MATRIX =, /COVARIANCE, /SSQ, /SILENT, TEXTOUT=]' + RETURN + ENDIF + +;Define nonstandard system variables if not already present + + defsysv, '!TEXTUNIT', exist = exist + if ~exist then defsysv, '!TEXTUNIT', 0 + defsysv, '!TEXTOUT', exist = exist + if ~exist then defsysv, '!TEXTOUT', 1 + + + if size(data,/N_dimen) NE 2 THEN BEGIN + HELP,data + MESSAGE,'ERROR - Data matrix is not two-dimensional' + ENDIF + + dimen = size(data,/dimen) + Nobj = dimen[0] & Mattr = dimen[1] ;Number of objects and attributes + + + IF KEYWORD_SET(cov) THEN BEGIN + msg = 'Covariance matrix will be analyzed' +; form column-means + column_mean = total( data,1 )/Nobj + temp = replicate(1.0, Nobj) + X = (data - temp # transpose(column_mean)) + ENDIF ELSE $ + IF KEYWORD_SET(ssq) THEN BEGIN + + msg = 'Sum-of-squares & cross-products matrix will be analyzed' + X = data + + ENDIF ELSE BEGIN + msg = 'Default: Correlation matrix will be analyzed' +; form column-means + temp = replicate( 1.0, Nobj ) + column_mean = (temp # data)/ Nobj + X = (data - temp # transpose(column_mean)) + S = sqrt(temp # (X*X)) & X = X/(temp # S) + + ENDELSE + + A = transpose(X) # X + if arg_present(AM) then AM = A + +; Carry out eigenreduction + trired, A, D, E ; D contains diagonal, E contains off-diagonal + triql, D, E, A ; D contains the eigen-values, A(*,i) -vectors + +; Use TOLERANCE to decide if eigenquantities are sufficiently near zero + + index = where(abs(D) LE TOLERANCE*MAX(abs(D)),count) + if count NE 0 THEN D[index]=0 + index = where(abs(A) LE TOLERANCE*MAX(abs(A)),count) + if count NE 0 THEN A[index]=0 + + index = sort(D) ; Order by increasing eigenvalue + D = D[index] & E=E[index] + A = A[*,index] + +; Eigenvalues expressed as percentage variance and ... + W1 = 100.0 * reverse(D)/total(D) + +;... Cumulative percentage variance + W = total(W1, /cumul) + +;Define returned parameters + eigenval = reverse(D) + eigenvect = reverse(transpose(A)) + percentages = W + +; Output eigen-values and -vectors + + if ~keyword_set(SILENT) then begin +; Open output file + if ~keyword_set( TEXTOUT ) then TEXTOUT = textout + textopen,'PCA', TEXTOUT = textout + printf,!TEXTUNIT,'PCA: ' + systime() + sz1 = strtrim( Nobj,2) & sz2 = strtrim( Mattr, 2 ) + printf,!TEXTUNIT, 'Data matrix has '+ sz1 + ' objects with up to ' + $ + sz2 + ' attributes' + printf,!TEXTUNIT, msg + printf,!TEXTUNIT, " " + printf,!TEXTUNIT, $ + ' Eigenvalues As Percentages Cumul. percentages' + for i = 0L, Mattr-1 do $ + printf,!TEXTUNIT, eigenval[i], W1[i], percentages[i] ,f = '(3f15.4)' + printf,!TEXTUNIT," " + printf,!TEXTUNIT, 'Corresponding eigenvectors follow...' + Mprint = Mattr < 7 + header = ' VBLE ' + for i = 1, Mprint do header = header + ' EV-' + strtrim(i,2) + ' ' + printf,!TEXTUNIT, header + for i = 1L, Mattr do printf,!TEXTUNIT, $ + i, eigenvect[0:Mprint-1,i-1],f='(i4,7f9.4)' + endif + +; Obtain projection of row-point on principal axes (Murtagh & Heck convention) + projx = X # A + +; Use TOLERANCE again... + index = where(abs(projx) LE TOLERANCE*MAX(abs(projx)),count) + if count NE 0 THEN projx[index]=0 + proj_obj = reverse( transpose(projx) ) + + if ~keyword_set( SILENT ) then begin + printf,!TEXTUNIT,' ' + printf,!TEXTUNIT, 'Projection of objects on principal axes ...' + printf,!TEXTUNIT,' ' + header = ' VBLE ' + for i = 1, Mprint do header = header + 'PROJ-' + strtrim(i,2) + ' ' + printf,!TEXTUNIT, header + for i = 0L, Nobj-1 do printf,!TEXTUNIT, $ + i+1, proj_obj[0:Mprint-1,i], f='(i4,7f9.4)' + endif + +; Obtain projection of column-points on principal axes + projy = transpose(projx)#X + +; Use TOLERANCE again... + index = where(abs(projy) LE TOLERANCE*MAX(abs(projy)),count) + if count NE 0 THEN projy[index] = 0 + +; scale by square root of eigenvalues... + temp = replicate( 1.0, Mattr ) + proj_atr = reverse(projy)/(sqrt(eigenval)#temp) + + if ~keyword_set( SILENT ) then begin + printf,!TEXTUNIT,' ' + printf,!TEXTUNIT,'Projection of attributes on principal axes ...' + printf,!TEXTUNIT,' ' + printf,!TEXTUNIT, header + for i = 0L, Mattr-1 do printf,!TEXTUNIT, $ + i+1, proj_atr[0:Mprint-1,i], f='(i4,7f9.4)' + textclose, TEXTOUT = textout ; Close output file + endif + + RETURN + END diff --git a/modules/idl_downloads/astro/pro/pent.pro b/modules/idl_downloads/astro/pro/pent.pro new file mode 100644 index 0000000..7461f68 --- /dev/null +++ b/modules/idl_downloads/astro/pro/pent.pro @@ -0,0 +1,145 @@ + function pent,p,t,x,m,n +;+ +; NAME: +; PENT +; PURPOSE: +; Return the information entropy of a time series +; EXPLANATION: +; This function will return S, the information entropy of a time series +; for a set of trial periods +; +; CATEGORY: +; Time series analysis, period finding, astronomical utilities. +; +; CALLING SEQUENCE: +; Result = PENT(P, T, X, [N, M ] ) +; +; INPUTS: +; P - array of trial period values. +; T - array of observation times (same units as P). +; X - array of observations. +; +; OPTIONAL INPUTS: +; N - If four parameters are given then the 4th parameter is assumed +; to be N. Then NxN boxes are used to calculate S. +; M,N - If five parameters are given then parameter 4 is M and parameter +; 5 is N. S is then calculated using MxN boxes - M partitions for the +; phase and N partitions for the data. +; +; OUTPUTS: +; This function returns S, the information entropy of the time series for +; the periods given in P as defined by Cincotta, Me'ndez & Nu'n~ez +; (Astrophysical Journal 449, 231-235, 1995). The minima of S occur at +; values of P where X shows periodicity. +; +; PROCEDURE: +; The procedure involves dividing the phase space into N^2 partitions +; (NxN boxes) and then calculating: +; +; __ N^2 +; S = - \ mu_i . ln(mu_i) for all mu_i <> 0 +; /_ +; i = 1 +; +; where mu_i is the number of data points in partition i normalised by +; the number of partitions. +; +; The option of using MxN boxes is an additional feature of this routine. +; +; EXAMPLE: +; +; To generate a similar synthetic data set to Cincotta et al. we +; do the following: +; +; IDL> P0 = 173.015 ; Fundamental period +; IDL> T = randomu(seed,400)*15000 ; 400 random observation times +; IDL> A0 = 14.0 ; Mean magnitude +; IDL> M0 = -0.5 * sin(2*!pi*T/P0) ; Fundamental mode +; IDL> M1 = -0.15 * sin(4*!pi*T/P0) ; 1st harmonic +; IDL> M2 = -0.05 * sin(6*!pi*T/P0) ; 2nd harmonic +; IDL> sig = randomu(seed,400)*0.03 ; noise +; IDL> U = A0 + M0 + M1 + M2 + sig ; Synthetic data +; IDL> Ptest = 100. + findgen(2000)/2. ; Trial periods +; IDL> S = pent(Ptest,T,U) ; Calculate S +; ... this takes a few seconds ... +; IDL> plot,Ptest,S,xtitle="P",ytitle="S" ; plot S v. P +; IDL> print,Ptest(where(S eq min(S))) ; Print best period (+/- 0.5) +; +; The plot produced should be similar to Fig. 2 of Cincotta et al. +; +; RESTRICTIONS: +; +; My own (limited) experience with this routine suggests that it is not +; as good as other techniques for finding weak, multi-periodic signals in +; poorly sampled data, but is good for establishing periods of eclipsing +; binary stars when M is quite large (try MxN = 64x16, 128x16 or even +; 256x16). This suggests it may be good for other periodic light curves +; (Cepheids, RR Lyrae etc.). +; I would be glad to receive reports of other peoples experience with +; this technique (e-mail pflm@bro730.astro.ku.dk). +; +; MODIFICATION HISTORY: +; Written by: Pierre Maxted, 14Sep95 +; Modifications: +; Normalisation of S corrected, T-min(T) taken out of loop. +; - Pierre Maxted, 15Sep95 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + on_error,2 ; return to caller + +; Check suitable no. of parameters have been entered. + + case N_params() of + 3 : begin + n = 8.0 + m = 8.0 + end + 4 : begin + n = float(fix(m)) + m = n + end + 5 : begin + m = float(fix(m)) + n = float(fix(n)) + end + else : message,/noname,' Syntax - Result = ( P, T, X [ [,M ] ,N ])' + endcase + + nbox = m*n + np = n_elements(p) + npts = n_elements(x) + + if n_elements(t) ne npts then message , $ + 'Input arrays T and X must have same number of elements' + + if npts lt 3 then message,' Insufficient data in input arrays' + + npts = float(npts) + + S = fltarr(np) + + norm = (X - min(X))/(max(x) - min(x)) ; normalised data + norm = norm - (norm eq 1.0)*(0.1/n) ; norm = 1 -> norm = 0.99.. + ni = 1 + n*(floor(norm*n)) + + Tplus = T-min(T) ; take this operation out of the loop + + for j = 0l,np - 1l do begin + + phi = ( Tplus / P[j] ) mod 1.0 + + mu = histogram(floor(phi*m) + ni,max=nbox,min=0.0)/(npts) + + mu = mu[where(mu gt 0.0)] + S[j] = -total(mu*alog(mu)) + + endfor + + S = S/alog(nbox) ; normalise S + + return,S + +end ; That's all folks + + diff --git a/modules/idl_downloads/astro/pro/permute.pro b/modules/idl_downloads/astro/pro/permute.pro new file mode 100644 index 0000000..7baea74 --- /dev/null +++ b/modules/idl_downloads/astro/pro/permute.pro @@ -0,0 +1,122 @@ +;+ +; NAME: +; PERMUTE +; +; PURPOSE: +; This function returns an array containing the numbers +; [0, ..., N-1] in random order. They are useful as indices +; when permuting a dataset, for example in a balanced bootstrap +; Monte Carlo algorithm. +; +; CATEGORY: +; Statistics. +; +; CALLING SEQUENCE: +; +; Result = PERMUTE(N) +; +; INPUTS: +; N: The number of items to be permuted. +; +; OPTIONAL INPUTS: +; SEED: A random number seed, see RANDOMU. +; +; OUTPUTS: +; This function returns an N-element array containing a random +; permutation of the integers from 0 through N-1. +; +; SIDE EFFECTS: +; Unless Seed is specified, IDL's global random number +; seed is changed. +; +; PROCEDURE: +; This is an in-place swapping algorithm. It starts with an +; index array. For each position in the array, it swaps the +; occupant of that position with the occupant of a random +; position from there (inclusive) to the end of the array. The +; last iteration is not necessary to compute, since it swaps +; with itself. +; +; See http://www.techuser.net/randpermgen.html for a proof. The +; 2-line code there has been optimized for IDL's vector +; architecture. This is a linear-time algorithm. +; +; EXAMPLE: +; Show some permutations of 6 numbers: +; print, permute(6) +; 0 2 1 3 4 5 +; print, permute(6) +; 2 4 3 5 1 0 +; print, permute(6) +; 0 4 3 1 2 5 +; +; Permute the array [2, 4, 6, 8] +; a = [2, 4, 6, 8] +; print, a[permute(4)] +; 4 8 6 2 +; +; Test randomness (results should be close to k): +; m = 6l +; k = 10000l +; n = m * k +; a = lonarr(m, n) +; for i = 0l, n-1, 1 do a[*, i] = permute(m) +; for i = 0l, m-1, 1 do print, histogram(a[i, *]) +; 9885 10062 10051 9915 10028 10059 +; 10096 10087 10094 9913 9933 9877 +; 10041 10013 9968 9958 9911 10109 +; 9880 9858 10166 10049 10081 9966 +; 10093 9915 9800 10166 9969 10057 +; 10005 10065 9921 9999 10078 9932 +; +; Time the algorithm: +; maxn = 7 +; t = dblarr(maxn) +; n = 10L^(indgen(maxn)+1) +; for i = 0, maxn-1, 1 do begin &$ +; t1 = systime(/s) &$ +; print, n[i] &$ +; a = permute(n[i]) &$ +; t2 = systime(/s) &$ +; t[i] = t2-t1 &$ +; endfor +; print, ' Elements Seconds Elements Per Second' +; print, transpose([[n], [t], [t/n]]) +; +; Elements Seconds Elements Per Second +; 10.000000 0.00012397766 1.2397766e-05 +; 100.00000 0.00015020370 1.5020370e-06 +; 1000.0000 0.0011651516 1.1651516e-06 +; 10000.000 0.018178225 1.8178225e-06 +; 100000.00 0.13504505 1.3504505e-06 +; 1000000.0 1.3817160 1.3817160e-06 +; 10000000. 14.609985 1.4609985e-06 +; +; These times are for a 2.071 GHz AMD Athlon 2800+ CPU. +; +; MODIFICATION HISTORY: +; Written by: Joseph Harrington, Cornell. 2006-03-22 +; jh@alum.mit.edu +;- +function PERMUTE, N, Seed + +; Don't stop here! +on_error, 2 + +; test inputs +if n eq 1 then return, 0L +if n lt 1 then message, 'N = ' + strtrim(n, 2) + ', must be 1 or more.' + +ar = lindgen(n) +rar = reverse(ar[0 : n - 2]) + 2 +r = (n - 1) - long( randomu(seed, n - 1) * rar ) + +for i = 0L, n - 2, 1 do begin + t = ar[i] + ar[i] = ar[r[i]] + ar[r[i]] = t +endfor + +return, ar +end + diff --git a/modules/idl_downloads/astro/pro/pixcolor.pro b/modules/idl_downloads/astro/pro/pixcolor.pro new file mode 100644 index 0000000..7640863 --- /dev/null +++ b/modules/idl_downloads/astro/pro/pixcolor.pro @@ -0,0 +1,100 @@ +pro pixcolor, pix_value, color +;+ +; NAME: +; PIXCOLOR +; PURPOSE: +; Assign colors to specified pixel values in a color lookup table +; EXPLANATION: +; Colors can be specified either from the list in cgcolor +; (http://www.idlcoyote.com/programs/cgcolor.pro ) or as 1 letter +; abbreviations for 8 common colors. +; +; CALLING SEQUENCE: +; PIXCOLOR, pixvalue, color ;Set color at specified pixel values +; +; INPUT PARMETERS: +; pixvalue - value or range of pixel values whose color will be modified. +; A single pixel value may be specified by an integer +; If a range of values is specified, then it must be written +; as a string, with a colon denoting the range (e.g.'102:123') +; If omitted, program will prompt for this parameter. +; +; OPTIONAL INPUT PARAMETER +; color - scalar string specifying either a full color name available in +; CGCOLOR, or a single character string giving one of the +; specified colors: 'R' (red), 'B' (blue), 'G' (green) +; 'Y' (yellow), 'T' (turquoise), 'V' (violet), 'W' (white) +; or 'D' (dark). If omitted, program will prompt for this +; parameter. +; +; OUTPUTS: +; None +; PROCEDURE: +; TVLCT is used in RGB mode to load the specified pixel values. +; +; EXAMPLE: +; Set pixel values of 245 to a color of red +; +; IDL> pixcolor,245,'R' +; +; Set pixel values 120 to 150 to Magenta +; +; IDL> pixcolor,'120:150','Magenta' +; REVISION HISTORY: +; Written, W. Landsman ST Systems Corp. February, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Allow specification of cgcolor names April 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - pixcolor, value, color_name' + return + endif + + if ( N_elements(pix_value) EQ 0) then begin + pix_value = '' + print,'Enter pixel value(s) to be assigned a color value' + print,'Value may be either number or a range (e.g. 102:123)' + read,'Pixel Value(s): ',pix_value + endif + + type = size(pix_value) + if ( type[1] EQ 7 ) then begin + pixmin = fix(gettok(pix_value,':')) >0 + if strlen(pix_value) eq 0 then pixmax = fix(pixmin) $ + else pixmax = fix(pix_value) > pixmin < 255 + endif else begin + pixmin = fix(pix_value)>0<255 + pixmax = pixmin + endelse + npts = pixmax - pixmin + 1 + +GETCOL: if ( N_params() LT 2 ) then begin + color = '' + print,'Enter color name to which pixel(s) will be asssigned' + print,'Available 1 character options are ' + print,'Red (R), Blue (B), Green (G), Yellow (Y), Turquoise (T), + print,'Violet (V), White (W), or Dark (D) + read,color + endif + + case strupcase(color) of + 'R': col = 'red' + 'G': col = 'green' + 'B': col = 'blue' + 'Y': col = 'yellow' + 'T': col = 'turquoise' + 'V': col = 'violet + 'W': col = 'white' + 'D': col = 'black' + else: col = color + endcase + + cc = cgcolor(col,/triple) + if npts GT 1 then cc = rebin(cc,npts,3) + tvlct,cc,pixmin + + return + end diff --git a/modules/idl_downloads/astro/pro/pixwt.pro b/modules/idl_downloads/astro/pro/pixwt.pro new file mode 100644 index 0000000..3dc8233 --- /dev/null +++ b/modules/idl_downloads/astro/pro/pixwt.pro @@ -0,0 +1,257 @@ +;+ +; NAME: +; PIXWT +; PURPOSE: +; Circle-rectangle overlap area computation. +; DESCRIPTION: +; Compute the fraction of a unit pixel that is interior to a circle. +; The circle has a radius r and is centered at (xc, yc). The center of +; the unit pixel (length of sides = 1) is at (x, y). +; +; CATEGORY: +; CCD data processing +; CALLING SEQUENCE: +; area = Pixwt( xc, yc, r, x, y ) +; INPUTS: +; xc, yc : Center of the circle, numeric scalars +; r : Radius of the circle, numeric scalars +; x, y : Center of the unit pixel, numeric scalar or vector +; OPTIONAL INPUT PARAMETERS: +; None. +; KEYWORD PARAMETERS: +; None. +; OUTPUTS: +; Function value: Computed overlap area. +; EXAMPLE: +; What is the area of overlap of a circle with radius 3.44 units centered +; on the point 3.23, 4.22 with the pixel centered at [5,7] +; +; IDL> print,pixwt(3.23,4.22,3.44,5,7) ==> 0.6502 +; COMMON BLOCKS: +; None. +; PROCEDURE: +; Divides the circle and rectangle into a series of sectors and +; triangles. Determines which of nine possible cases for the +; overlap applies and sums the areas of the corresponding sectors +; and triangles. Called by aper.pro +; +; NOTES: +; If improved speed is needed then a C version of this routines, with +; notes on how to linkimage it to IDL is available at +; ftp://ftp.lowell.edu/pub/buie/idl/custom/ +; +; MODIFICATION HISTORY: +; Ported by Doug Loucks, Lowell Observatory, 1992 Sep, from the +; routine pixwt.c, by Marc Buie. +;- +; --------------------------------------------------------------------------- +; Function Arc( x, y0, y1, r ) +; +; Compute the area within an arc of a circle. The arc is defined by +; the two points (x,y0) and (x,y1) in the following manner: The circle +; is of radius r and is positioned at the origin. The origin and each +; individual point define a line which intersects the circle at some +; point. The angle between these two points on the circle measured +; from y0 to y1 defines the sides of a wedge of the circle. The area +; returned is the area of this wedge. If the area is traversed clockwise +; then the area is negative, otherwise it is positive. +; --------------------------------------------------------------------------- +FUNCTION Arc, x, y0, y1, r +RETURN, 0.5 * r*r * ( ATAN( FLOAT(y1)/FLOAT(x) ) - ATAN( FLOAT(y0)/FLOAT(x) ) ) +END + + +; --------------------------------------------------------------------------- +; Function Chord( x, y0, y1 ) +; +; Compute the area of a triangle defined by the origin and two points, +; (x,y0) and (x,y1). This is a signed area. If y1 > y0 then the area +; will be positive, otherwise it will be negative. +; --------------------------------------------------------------------------- +FUNCTION Chord, x, y0, y1 +RETURN, 0.5 * x * ( y1 - y0 ) +END + + +; --------------------------------------------------------------------------- +; Function Oneside( x, y0, y1, r ) +; +; Compute the area of intersection between a triangle and a circle. +; The circle is centered at the origin and has a radius of r. The +; triangle has verticies at the origin and at (x,y0) and (x,y1). +; This is a signed area. The path is traversed from y0 to y1. If +; this path takes you clockwise the area will be negative. +; --------------------------------------------------------------------------- +FUNCTION Oneside, x, y0, y1, r + +true = 1 +size_x = SIZE( x ) + +CASE size_x[ 0 ] OF + 0 : BEGIN + IF x EQ 0 THEN RETURN, x + IF ABS( x ) GE r THEN RETURN, Arc( x, y0, y1, r ) + yh = SQRT( r*r - x*x ) + CASE true OF + ( y0 LE -yh ) : BEGIN + CASE true OF + ( y1 LE -yh ) : RETURN, Arc( x, y0, y1, r ) + ( y1 LE yh ) : RETURN, Arc( x, y0, -yh, r ) $ + + Chord( x, -yh, y1 ) + ELSE : RETURN, Arc( x, y0, -yh, r ) $ + + Chord( x, -yh, yh ) + Arc( x, yh, y1, r ) + ENDCASE + END + + ( y0 LT yh ) : BEGIN + CASE true OF + ( y1 LE -yh ) : RETURN, Chord( x, y0, -yh ) $ + + Arc( x, -yh, y1, r ) + ( y1 LE yh ) : RETURN, Chord( x, y0, y1 ) + ELSE : RETURN, Chord( x, y0, yh ) + Arc( x, yh, y1, r ) + ENDCASE + END + + ELSE : BEGIN + CASE true OF + ( y1 LE -yh ) : RETURN, Arc( x, y0, yh, r ) $ + + Chord( x, yh, -yh ) + Arc( x, -yh, y1, r ) + ( y1 LE yh ) : RETURN, Arc( x, y0, yh, r ) + Chord( x, yh, y1 ) + ELSE : RETURN, Arc( x, y0, y1, r ) + ENDCASE + END + ENDCASE + END + + ELSE : BEGIN + ans = x + t0 = WHERE( x EQ 0, count ) + IF count EQ n_elements( x ) THEN RETURN, ans + + ans = x * 0 + yh = ans + to = WHERE( ABS( x ) GE r, tocount ) + ti = WHERE( ABS( x ) LT r, ticount ) + IF tocount NE 0 THEN ans[ to ] = Arc( x[to], y0[to], y1[to], r ) + IF ticount EQ 0 THEN RETURN, ans + + yh[ ti ] = SQRT( r*r - x[ti]*x[ti] ) + + t1 = WHERE( y0[ti] LE -yh[ti], count ) + IF count NE 0 THEN BEGIN + i = ti[ t1 ] + + t2 = WHERE( y1[i] LE -yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], y1[j], r ) + ENDIF + + t2 = WHERE( ( y1[i] GT -yh[i] ) AND ( y1[i] LE yh[i] ), count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], -yh[j], r ) $ + + Chord( x[j], -yh[j], y1[j] ) + ENDIF + + t2 = WHERE( y1[i] GT yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], -yh[j], r ) $ + + Chord( x[j], -yh[j], yh[j] ) $ + + Arc( x[j], yh[j], y1[j], r ) + ENDIF + ENDIF + + t1 = WHERE( ( y0[ti] GT -yh[ti] ) AND ( y0[ti] LT yh[ti] ), count ) + IF count NE 0 THEN BEGIN + i = ti[ t1 ] + + t2 = WHERE( y1[i] LE -yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Chord( x[j], y0[j], -yh[j] ) $ + + Arc( x[j], -yh[j], y1[j], r ) + ENDIF + + t2 = WHERE( ( y1[i] GT -yh[i] ) AND ( y1[i] LE yh[i] ), count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Chord( x[j], y0[j], y1[j] ) + ENDIF + + t2 = WHERE( y1[i] GT yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Chord( x[j], y0[j], yh[j] ) $ + + Arc( x[j], yh[j], y1[j], r ) + ENDIF + ENDIF + + t1 = WHERE( y0[ti] GE yh[ti], count ) + IF count NE 0 THEN BEGIN + i = ti[ t1 ] + + t2 = WHERE ( y1[i] LE -yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], yh[j], r ) $ + + Chord( x[j], yh[j], -yh[j] ) $ + + Arc( x[j], -yh[j], y1[j], r ) + ENDIF + + t2 = WHERE( ( y1[i] GT -yh[i] ) AND ( y1[i] LE yh[i] ), count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], yh[j], r ) $ + + Chord( x[j], yh[j], y1[j] ) + ENDIF + + t2 = WHERE( y1[i] GT yh[i], count ) + IF count NE 0 THEN BEGIN + j = ti[ t1[ t2 ] ] + ans[j] = Arc( x[j], y0[j], y1[j], r ) + ENDIF + ENDIF + + RETURN, ans + END +ENDCASE + +END + + +; --------------------------------------------------------------------------- +; Function Intarea( xc, yc, r, x0, x1, y0, y1 ) +; +; Compute the area of overlap of a circle and a rectangle. +; xc, yc : Center of the circle. +; r : Radius of the circle. +; x0, y0 : Corner of the rectangle. +; x1, y1 : Opposite corner of the rectangle. +; --------------------------------------------------------------------------- +FUNCTION Intarea, xc, yc, r, x0, x1, y0, y1 +; +; Shift the objects so that the circle is at the origin. +; +x0 = x0 - xc +y0 = y0 - yc +x1 = x1 - xc +y1 = y1 - yc + +RETURN, Oneside( x1, y0, y1, r ) + Oneside( y1, -x1, -x0, r ) +$ + Oneside( -x0, -y1, -y0, r ) + Oneside( -y0, x0, x1, r ) + +END + + +; --------------------------------------------------------------------------- +; FUNCTION Pixwt( xc, yc, r, x, y ) +; +; Compute the fraction of a unit pixel that is interior to a circle. +; The circle has a radius r and is centered at (xc, yc). The center of +; the unit pixel (length of sides = 1) is at (x, y). +; --------------------------------------------------------------------------- +FUNCTION Pixwt, xc, yc, r, x, y +RETURN, Intarea( xc, yc, r, x-0.5, x+0.5, y-0.5, y+0.5 ) +END diff --git a/modules/idl_downloads/astro/pro/pkfit.pro b/modules/idl_downloads/astro/pro/pkfit.pro new file mode 100644 index 0000000..5815e36 --- /dev/null +++ b/modules/idl_downloads/astro/pro/pkfit.pro @@ -0,0 +1,247 @@ +pro pkfit,f,scale,x,y,sky,radius,ronois,phpadu,gauss,psf, $ + errmag,chi,sharp,niter, DEBUG= debug +;+ +; NAME: +; PKFIT +; PURPOSE: +; Subroutine of GETPSF to perform a one-star least-squares fit +; EXPLANATION: +; Part of the DAOPHOT PSF photometry sequence +; +; CALLING SEQUENCE: +; PKFIT, f, scale, x, y, sky, radius, ronois, phpadu, gauss, psf, +; errmag, chi, sharp, Niter, /DEBUG +; INPUTS: +; F - NX by NY array containing actual picture data. +; X, Y - the initial estimates of the centroid of the star relative +; to the corner (0,0) of the subarray. Upon return, the +; final computed values of X and Y will be passed back to the +; calling routine. +; SKY - the local sky brightness value, as obtained from APER +; RADIUS- the fitting radius-- only pixels within RADIUS of the +; instantaneous estimate of the star's centroid will be +; included in the fit, scalar +; RONOIS - readout noise per pixel, scalar +; PHPADU - photons per analog digital unit, scalar +; GAUSS - vector containing the values of the five parameters defining +; the analytic Gaussian which approximates the core of the PSF. +; PSF - an NPSF by NPSF look-up table containing corrections from +; the Gaussian approximation of the PSF to the true PSF. +; +; INPUT-OUTPUT: +; SCALE - the initial estimate of the brightness of the star, +; expressed as a fraction of the brightness of the PSF. +; Upon return, the final computed value of SCALE will be +; passed back to the calling routine. +; OUTPUTS: +; ERRMAG - the estimated standard error of the value of SCALE +; returned by this routine. +; CHI - the estimated goodness-of-fit statistic: the ratio +; of the observed pixel-to-pixel mean absolute deviation from +; the profile fit, to the value expected on the basis of the +; noise as determined from Poisson statistics and the +; readout noise. +; SHARP - a goodness-of-fit statistic describing how much broader +; the actual profile of the object appears than the +; profile of the PSF. +; NITER - the number of iterations the solution required to achieve +; convergence. If NITER = 25, the solution did not converge. +; If for some reason a singular matrix occurs during the least- +; squares solution, this will be flagged by setting NITER = -1. +; +; RESTRICTIONS: +; No parameter checking is performed +; REVISON HISTORY: +; Adapted from the official DAO version of 1985 January 25 +; Version 2.0 W. Landsman STX November 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + s = size(f) ;Get array dimensions + nx = s[1] & ny = s[2] +; ;Initialize a few things for the solution + redo = 0B + pkerr = 0.027/(gauss[3]*gauss[4])^2 + clamp = fltarr(3) + 1. + dtold = fltarr(3) + niter = 0 + chiold = 1. + + if keyword_set(DEBUG) then $ + print,'PKFIT: ITER X Y SCALE ERRMAG CHI SHARP' + +BIGLOOP: ;Begin the big least-squares loop + niter = niter+1 + + ixlo = fix(x-radius) > 0 ;Choose boundaries of subarray containing + iylo = fix(y-radius) > 0 ;points inside the fitting radius + ixhi = fix(x+radius) +1 < (nx-1) + iyhi = fix(y+radius) +1 < (ny-1) + ixx = ixhi-ixlo+1 + iyy = iyhi-iylo+1 + dy = findgen(iyy) + iylo - y ;X distance vector from stellar centroid + dysq = dy^2 + dx = findgen(ixx) + ixlo - x + dxsq = dx^2 + rsq = fltarr(ixx,iyy) ;RSQ - array of squared + + for J = 0,iyy-1 do rsq[0,j] = (dxsq+dysq[j])/radius^2 + + ; The fitting equation is of the form + ; + ; Observed brightness = + ; SCALE + delta(SCALE) * PSF + delta(Xcen)*d(PSF)/d(Xcen) + + ; delta(Ycen)*d(PSF)/d(Ycen) + ; + ; and is solved for the unknowns delta(SCALE) ( = the correction to + ; the brightness ratio between the program star and the PSF) and + ; delta(Xcen) and delta(Ycen) ( = corrections to the program star's + ; centroid). + ; + ; The point-spread function is equal to the sum of the integral under + ; a two-dimensional Gaussian profile plus a value interpolated from + ; a look-up table. + + good = where(rsq lt 1.,ngood) + ngood = ngood > 1 + + t = fltarr(ngood,3) + dx = dx[good mod ixx] + dy = dy[good/ixx] + model = dao_value(dx, dy, gauss, psf, dvdx, dvdy) + + if keyword_set(DEBUG) then begin print,'model created ' & stop & end + + t[0,0] = model + t[0,1] = -scale*dvdx + t[0,2] = -scale*dvdy + fsub = f[ixlo:ixhi,iylo:iyhi] + fsub = fsub[good] + rsq = rsq[good] + df = fsub - scale*model - sky ;Residual of the brightness from the PSF fit + + ; The expected random error in the pixel is the quadratic sum of + ; the Poisson statistics, plus the readout noise, plus an estimated + ; error of 0.75% of the total brightness for the difficulty of flat- + ; fielding and bias-correcting the chip, plus an estimated error of + ; of some fraction of the fourth derivative at the peak of the profile, + ; to account for the difficulty of accurately interpolating within the + ; point-spread function. The fourth derivative of the PSF is + ; proportional to H/sigma**4 (sigma is the Gaussian width parameter for + ; the stellar core); using the geometric mean of sigma(x) and sigma(y), + ; this becomes H/ sigma(x)*sigma(y) **2. The ratio of the fitting + ; error to this quantity is estimated from a good-seeing CTIO frame to + ; be approximately 0.027 (see definition of PKERR above.) + + fpos = (fsub-df) > 0 ;Raw data - residual = model predicted intensity + sigsq = fpos/phpadu + ronois + (0.0075*fpos)^2 + (pkerr*(fpos-sky))^2 + sig = sqrt(sigsq) + relerr = df/sig + + ; SIG is the anticipated standard error of the intensity + ; including readout noise, Poisson photon statistics, and an estimate + ; of the standard error of interpolating within the PSF. + + rhosq = fltarr(ixx,iyy) + + for j = 0,iyy-1 do rhosq[0,j] = (dxsq/gauss[3]^2+dysq[j]/gauss[4]^2) + + rhosq = rhosq[good] + if (niter GE 2) then begin ;Reject any pixel with 10 sigma residual + badpix = where( ABS(relerr/chiold) GE 10.,nbad ) + if nbad GT 0 then begin + remove, badpix, fsub, df, sigsq, sig + remove, badpix, relerr, rsq, rhosq + ngood = ngood-badpix + endif + endif + + wt = 5./(5.+rsq/(1.-rsq)) + lilrho = where(rhosq LE 36.) ;Include only pixels within 6 sigma of centroid + rhosq[lilrho] = 0.5*rhosq[lilrho] + dfdsig = exp(-rhosq[lilrho])*(rhosq[lilrho]-1.) + fpos = ( fsub[lilrho]-sky) >0 + sky + + ; FPOS-SKY = raw data minus sky = estimated value of the stellar + ; intensity (which presumably is non-negative). + + sig = fpos/phpadu + ronois + (0.0075*fpos)^2 + (pkerr*(fpos-sky))^2 + numer = total(dfdsig*df/sig) + denom = total(dfdsig^2/sig) + + ; Derive the weight of this pixel. First of all, the weight depends + ; upon the distance of the pixel from the centroid of the star-- it + ; is determined from a function which is very nearly unity for radii + ; much smaller than the fitting radius, and which goes to zero for + ; radii very near the fitting radius. + + chi = total(wt*abs(relerr)) + sumwt = total(wt) + + wt = wt/sigsq ;Scale weight to inverse square of expected mean error + if niter GE 2 then $ ;Reduce weight of a bad pixel + wt = wt/(1.+(0.4*relerr/chiold)^8) + + v = fltarr(3) ;Compute vector of residuals and the normal matrix. + c = fltarr(3,3) + + for kk = 0,2 do begin + v[kk] = TOTAL(df*t[*,kk]*wt) + for ll = 0,2 do C[kk,ll] = TOTAL(t[*,kk]*t[*,ll]*wt) + end + + ; Compute the (robust) goodness-of-fit index CHI. + ; CHI is pulled toward its expected value of unity before being stored + ; in CHIOLD to keep the statistics of a small number of pixels from + ; completely dominating the error analysis. + + if sumwt GT 3.0 then begin + chi = 1.2533*chi*sqrt(1./(sumwt*(sumwt-3.))) + chiold = ((sumwt-3.)*chi+3.)/sumwt + endif + + C = INVERT(C) ;Invert the normal matrix + dt = c#v ;Compute parameter corrections + +; In the beginning, the brightness of the star will not be permitted +; to change by more than two magnitudes per iteration (that is to say, +; if the estimate is getting brighter, it may not get brighter by +; more than 525% per iteration, and if it is getting fainter, it may +; not get fainter by more than 84% per iteration). The x and y +; coordinates of the centroid will be allowed to change by no more +; than one-half pixel per iteration. Any time that a parameter +; correction changes sign, the maximum permissible change in that +; parameter will be reduced by a factor of 2. + + div = where( dtold*dt LT -1.e-38, nbad ) + if nbad GT 0 then clamp[div] = clamp[div]/2. + dtold = dt + adt = abs(dt) + + scale = scale+dt[0]/ $ + (1.+(( dt[0]/(5.25*scale)) > (-1*dt[0]/(0.84*scale)) )/clamp[0]) + x = x + dt[1]/(1.+adt[1]/(0.5*clamp[1])) + y = y + dt[2]/(1.+adt[2]/(0.5*clamp[2])) + redo = 0B + +; Convergence criteria: if the most recent computed correction to the +; brightness is larger than 0.1% or than 0.05 * sigma(brightness), +; whichever is larger, OR if the absolute change in X or Y is +; greater than 0.01 pixels, convergence has not been achieved. + + sharp = 2.*gauss[3]*gauss[4]*numer/(gauss[0]*scale*denom) + errmag = chiold*sqrt(c[0,0]) + if ( adt[0] GT ( 0.05*errmag > 0.001*scale )) then redo = 1b + if ((adt[1] > adt[2] ) GT 0.01) then redo = 1b + + if keyword_set(DEBUG) then print,format='(1H ,I9,2F7.2,2F9.3,F8.2,F9.2)', $ + niter,x,y,scale,errmag,chiold,sharp + if niter LT 3 then goto, BIGLOOP ;At least 3 iterations required + +; If the solution has gone 25 iterations, OR if the standard error of +; the brightness is greater than 200%, give up. + + if (redo and (errmag LE 1.9995) and (niter LT 25) ) then goto, BIGLOOP + sharp = sharp>(-99.999)<99.999 + + return + end diff --git a/modules/idl_downloads/astro/pro/planck.pro b/modules/idl_downloads/astro/pro/planck.pro new file mode 100644 index 0000000..ffbf590 --- /dev/null +++ b/modules/idl_downloads/astro/pro/planck.pro @@ -0,0 +1,71 @@ +function planck,wave,temp +;+ +; NAME: +; PLANCK() +; PURPOSE: +; To calculate the Planck function in units of ergs/cm2/s/A +; +; CALLING SEQUENCE: +; bbflux = PLANCK( wave, temp) +; +; INPUT PARAMETERS: +; WAVE Scalar or vector giving the wavelength(s) in **Angstroms** +; at which the Planck function is to be evaluated. +; TEMP Scalar giving the temperature of the planck function in degree K +; +; OUTPUT PARAMETERS: +; BBFLUX - Scalar or vector giving the blackbody flux (i.e. !pi*Intensity) +; in erg/cm^2/s/A in at the specified wavelength points. +; +; EXAMPLES: +; To calculate the blackbody flux at 30,000 K every 100 Angstroms between +; 2000A and 2900 A +; +; IDL> wave = 2000 + findgen(10)*100 +; IDL> bbflux = planck(wave,30000) +; +; If a star with a blackbody spectrum has a radius R, and distance,d, then +; the flux at Earth in erg/cm^2/s/A will be bbflux*R^2/d^2 +; PROCEDURE: +; The wavelength data are converted to cm, and the Planck function +; is calculated for each wavelength point. See Allen (1973), Astrophysical +; Quantities, section 44 for more information. +; +; NOTES: +; See the procedure planck_radiance.pro in +; ftp://origin.ssec.wisc.edu/pub/paulv/idl/Radiance/planck_radiance.pro +; for computation of Planck radiance given wavenumber in cm-1 or +; wavelength in microns +; MODIFICATION HISTORY: +; Adapted from the IUE RDAF August, 1989 +; Converted to IDL V5.0 W. Landsman September 1997 +; Improve precision of constants W. Landsman January 2002 +;- + On_error,2 + + if ( N_elements(wave) LT 1 ) then begin + print,'Syntax - bbflux = planck( wave, temp)' + return,0 + endif + + if ( N_elements( temp ) NE 1 ) then $ + read,'Enter a blackbody temperature', temp + + bbflux = wave*0. + +; Gives the blackbody flux (i.e. PI*Intensity) ergs/cm2/s/a + + w = wave / 1.E8 ; Angstroms to cm +;constants appropriate to cgs units. + c1 = 3.7417749d-5 ; =2*!DPI*h*c*c + C2 = 1.4387687d ; =h*c/k + val = c2/w/temp + mstr = machar(double = (size(val,/type) EQ 5) ) ;Get machine precision + good = where( val LT alog(mstr.xmax), Ngood ) ;Avoid floating underflow + + if ( Ngood GT 0 ) then $ + bbflux[ good ] = C1 / ( w[good]^5 * ( exp( val[good])-1. ) ) + + return, bbflux*1.E-8 ; Convert to ergs/cm2/s/A + + end diff --git a/modules/idl_downloads/astro/pro/planet_coords.pro b/modules/idl_downloads/astro/pro/planet_coords.pro new file mode 100644 index 0000000..3f62cdd --- /dev/null +++ b/modules/idl_downloads/astro/pro/planet_coords.pro @@ -0,0 +1,169 @@ +pro planet_coords, date, ra, dec, planet=planet, jd = jd, jpl = jpl +;+ +; NAME: +; PLANET_COORDS +; PURPOSE: +; Find low or high precision RA and DEC for the planets given a date +; +; EXPLANATION: +; For low precision this routine uses HELIO to get the heliocentric ecliptic +; coordinates of the planets at the given date, then converts these to +; geocentric ecliptic coordinates ala "Astronomical Algorithms" by Jean +; Meeus (1991, p 209). These are then converted to RA and Dec using EULER. +; The accuracy between the years 1800 and 2050 is better than 1 arcminute +; for the terrestial planets, but reaches 10 arcminutes for Saturn. +; Before 1850 or after 2050 the accuracy can get much worse. +; +; For high precision use the /JPL option ito use the full JPL ephemeris. +; CALLING SEQUENCE: +; PLANET_COORDS, DATE, RA, DEC, [ PLANET = , /JD, /JPL] +; +; INPUTS: +; DATE - If /JD is not set, then date is a 3-6 element vector containing +; year,month (1-12), day, and optionally hour, minute, & second. +; If /JD is set then DATE is a Julian date. An advantage of the +; /JD option is that it allows the use of vector dates. +; OUTPUTS: +; RA - right ascension of planet(s), J2000 degrees, double precision +; DEC - declination of planet(s), J2000 degrees, double precision +; +; OPTIONAL INPUT KEYWORD: +; PLANET - scalar string giving name of a planet, e.g. 'venus'. Default +; is to compute coords for all of them (except Earth). +; /JD - If set, then the date parameter should be supplied as Julian date +; JPL - if /JPL set, then PLANET_COORDS will call the procedure +; JPLEPHINTERP to compute positions using the full JPL ephemeris. +; The JPL ephemeris FITS file JPLEPH.405 must exist in either the +; current directory, or in the directory specified by the +; environment variable ASTRO_DATA. Alternatively, the JPL keyword +; can be set to the full path and name of the ephemeris file. +; A copy of the JPL ephemeris FITS file JPLEPH.405 is available in +; http://idlastro.gsfc.nasa.gov/ftp/data/ +; EXAMPLES: +; (1) Find the RA, Dec of Venus on 1992 Dec 20 +; IDL> planet_coords, [1992,12,20], ra,dec ;Compute for all planets +; IDL> print,adstring(ra[1],dec[1],1) ;Venus is second planet +; ====> RA = 21 05 2.66 Dec = -18 51 45.7 +; This position is 37" from the full DE406 ephemeris position of +; RA = 21 05 5.24 -18 51 43.1 +; +; (2) Return the current RA and Dec of all 8 planets using JPL ephemeris +; IDL> get_juldate, jd ;Get current Julian Date +; IDL> planet_coords,jd,ra,dec,/jd,/jpl ;Find positions of all planets +; IDL> forprint,adstring(ra,dec,0) ;Display positions +; +; (3) Plot the declination of Mars for every day in the year 2001 +; IDL> jdcnv,2001,1,1,0,jd ;Get Julian date of midnight on Jan 1 +; Now get Mars RA,Dec for 365 consecutive days +; IDL> planet_coords,jd+indgen(365),ra,dec,/jd, planet = 'mars' +; IDL> plot,indgen(365)+1,dec +; NOTES: +; HELIO is based on the two-body problem and neglects interactions +; between the planets. This is why the worst results are for +; Saturn. Use the /JPL option or the online ephemeris generator +; http://ssd.jpl.nasa.gov/horizons.cgi for more accuracy. +; +; The procedure returns astrometric coordinates, i.e. no correction +; for aberration. A correction for light travel time is applied +; when /JPL is set, but not for the default low-precision calculation. +; PROCEDURES USED: +; JULDATE +; EULER, HELIO - if /JPL is not set +; JPLEPHREAD, JPLEPHINTERP - if /JPL is set +; REVISION HISTORY: +; Written P.Plait & W. Landsman August 2000 +; Fixed Julian date conversion W. Landsman August 2000 +; Added /JPL keyword W. Landsman July 2001 +; Allow vector Julian dates with JPL ephemeris W. Landsman December 2002 +;- +; On_error,2 + if N_params() LT 1 then begin + print,'Syntax - PLANET_COORDS, date, ra,dec, [PLANET =, /JD , JPL= ]' + print,' date - either 3-6 element date or Julian date (if /JD is set)' + print,' ra,dec - output ra and dec in degrees' + print,' PLANET - name of planet (optional)' + return + endif + + radeg = 180.0d/!DPI + c = 2.99792458d5 + +;convert input date to real JD + + if keyword_set(jd) then begin + jj = date + if N_elements(jj) GT 0 then if N_elements(planet) GT 1 then $ + message,'ERROR - A planet name must be supplied for vector dates' + endif else begin + juldate,date,jj + jj = jj + 2400000.0d + endelse + +;make output arrays to include each planet +; note that we need Earth to convert from heliocentric +; ecliptic coordinates to geocentric and then to RA and DEC + + if keyword_set(planet) then begin + planetlist = ['MERCURY','VENUS','MARS', $ + 'JUPITER','SATURN','URANUS','NEPTUNE','PLUTO'] + index = 1+ where(planetlist eq strupcase(strtrim(planet,2)), Nfound) + if index[0] GE 3 then index = index + 1 + if Nfound EQ 0 then message,'Unrecognized planet of ' + planet + endif else index = [1,2,4,5,6,7,8,9] + + if keyword_set(JPL) then begin + if size(jpl,/TNAME) EQ 'STRING' then jplfile = jpl else $ + jplfile = find_with_def('JPLEPH.405','ASTRO_DATA') + + if jplfile EQ '' then message,'ERROR - Cannot find JPL ephemeris file' +;Read ephemeris FITS file + JPLEPHREAD,jplfile, pinfo, pdata, [long(min(jj)-1), long(max(jj)+1)] + np = N_elements(index) + njd = n_elements(jj) + ra = dblarr(njd,np) & dec = dblarr(njd,np) + + for i=0, Np-1 do begin + JPLEPHINTERP, pinfo, pdata, jj, x,y,z, $ + objectname=index[i],center='EARTH' +; Compute distance to planet(s) and adjust Julian date for light travel time +; and recompute planet positions + dis = sqrt(x^2 + y^2 + z^2) + jj1 = jj - dis/c/86400.0d + +; Compute position of Earth at current time, but position of planet at time +; light started traveling + JPLEPHINTERP, pinfo, pdata, jj, xe,ye,ze, /EARTH + JPLEPHINTERP, pinfo, pdata, jj1, x,y,z, objectname=index[i] + x = x-xe & y = y-ye & z = z-ze + ra[0,i] = atan(y,x) * radeg + g = where(ra LT 0, Ng) + if Ng GT 0 then ra[g] = ra[g] + 360.0d + dec[0,i] = atan(z,sqrt(x*x + y*y)) * radeg + endfor + ra = reform(ra) & dec = reform(dec) + return + endif + + helio,jj,index,rad,lon,lat,/radian + +; extract Earth's info + + helio,jj,3,rade,lone,late,/radian + +;get rectangular coords of planets + + x = rad * cos(lat) * cos(lon) - rade * cos(late) * cos(lone) + y = rad * cos(lat) * sin(lon) - rade * cos(late) * sin(lone) + z = rad * sin(lat) - rade * sin(late) + +;get geocentric longitude lambda and geo latitude, beta + + lambda = atan(y,x) * radeg + beta = atan(z,sqrt(x*x + y*y)) * radeg + +;convert to Ra and Dec + + euler, lambda, beta, ra, dec, 4 + + return + end diff --git a/modules/idl_downloads/astro/pro/ploterror.pro b/modules/idl_downloads/astro/pro/ploterror.pro new file mode 100644 index 0000000..dbb3515 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ploterror.pro @@ -0,0 +1,334 @@ +PRO ploterror, x, y, xerr, yerr, NOHAT=hat, HATLENGTH=hln, ERRTHICK=eth, $ + ERRSTYLE=est, TYPE=itype, XRANGE = xrange, XLOG=xlog, YLOG=ylog, $ + NSKIP = nskip, NOCLIP = noclip, ERRCOLOR= ecol, YRANGE = yrange, $ + NSUM = nsum, WINDOW=window, _EXTRA = pkey + +;+ +; NAME: +; PLOTERROR +; PURPOSE: +; Plot data points with accompanying X or Y error bars. +; EXPLANATION: +; This is a greatly enhanced version of the standard IDL Library routine +; PLOTERR +; +; Note that since December 2013 a similar error plotting capablity is +; available in CGPLOT (http://www.idlcoyote.com/programs/cgplot.pro). +; +; CALLING SEQUENCE: +; ploterror, [ x,] y, [xerr], yerr [, TYPE=, /NOHAT, HATLENGTH= , NSUM = +; ERRTHICK=, ERRSTYLE=, ErrcolOR=, NSKIP=, .. PLOT keywords] +; +; INPUTS: +; X = array of abscissas. +; Y = array of Y values. +; XERR = array of error bar values (along X) +; YERR = array of error bar values (along Y) +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; TYPE = type of plot produced. The possible types are: +; TYPE = 0 : X Linear - Y Linear (default) +; TYPE = 1 : X Linear - Y Log +; TYPE = 2 : X Log - Y Linear +; TYPE = 3 : X Log - Y Log +; Actually, if 0 is specified, the XLOG and YLOG keywords +; are used. If these aren't specified, then a linear-linear +; plot is produced. This keyword is available to maintain +; compatibility with the previous version of PLOTERROR. +; /NOHAT = if specified and non-zero, the error bars are drawn +; without hats. +; HATLENGTH = the length of the hat lines in device units used to cap the +; error bars. Defaults to !D.X_VSIZE / 100). +; ERRTHICK = the thickness of the error bar lines. Defaults to the +; THICK plotting keyword. +; ERRSTYLE = the line style to use when drawing the error bars. Uses +; the same codes as LINESTYLE. +; ERRCOLOR = String (e.g. 'red') or scalar integer (0 - !D.N_TABLE) +; specifying the color to use for the error bars. See CGCOLOR() +; for a list of possible color names. See +; http://www.idlcoyote.com/cg_tips/legcolor.php +; for a warning about the use of indexed color +; NSKIP = Integer specifying the error bars to be plotted. For example, +; if NSKIP = 2 then every other error bar is plotted; if NSKIP=3 +; then every third error bar is plotted. Default is to plot +; every error bar (NSKIP = 1) +; NSUM = Number of points to average over before plotting, default=!P.NSUM +; The errors are also averaged, and then divided by sqrt(NSUM). +; This approximation is meaningful only when the neighboring error +; bars have similar sizes. PLOTERROR does not pass the NSUM +; keyword to the PLOT command, but rather computes the binning +; itself using the FREBIN function. +; TRADITIONAL - If set to 0 then a black plot is drawn on a white background +; in the graphics window. The default value is 1, giving the +; traditional black background for a graphics window. +; WINDOW - Set this keyword to plot to a resizeable graphics window +; +; +; Any valid keywords to the cgPLOT command (e.g. PSYM, YRANGE, AXISCOLOR +; SYMCOLOR, ASPECT) are also accepted by PLOTERROR via the _EXTRA facility. +; +; RESTRICTIONS: +; Arrays must not be of type string, and there must be at least 1 point. +; If only three parameters are input, they will be taken as X, Y and +; YERR respectively. +; +; PLOTERROR cannot be used for asymmetric error bars. Instead use +; OPLOTERROR with the /LOBAR and /HIBAR keywords. +; +; Any data points with NAN values in the X, Y, or error vectors are +; ignored. +; EXAMPLE: +; Suppose one has X and Y vectors with associated errors XERR and YERR +; +; (1) Plot Y vs. X with both X and Y errors and no lines connecting +; the points +; IDL> ploterror, x, y, xerr, yerr, psym=3 +; +; (2) Like (1) but plot only the Y errors bars and omits "hats" +; IDL> ploterror, x, y, yerr, psym=3, /NOHAT +; +; WARNING: +; This an enhanced version of the procedure PLOTERR in the standard IDL +; distribution. It was renamed from PLOTERR to PLOTERROR in June 1998 +; in the IDL Astronomy Library to avoid conflict with the RSI procedure. +; +; PROCEDURE: +; A plot of X versus Y with error bars drawn from Y - YERR to Y + YERR +; and optionally from X - XERR to X + XERR is written to the output device +; +; PROCEDURE CALLS: +; cgPlot, cgPlots +; FREBIN - used to compute binning if NSUM keyword is present +; MODIFICATION HISTORY: +; William Thompson Applied Research Corporation July, 1986 +; DMS, April, 1989 Modified for Unix +; Michael R. Greason ST Systems +; May, 1991 Added most of the plotting keywords, put hats +; on the error bars. +; K. Venkatakrishna Added option to plot xerr, May, 1992 +; Michael R. Greason Corrected handling of reversed axes. Aug. 1992 +; W. Landsman Use _EXTRA keyword July 1995 +; W. Landsman Plot more than 32767 points Feb 1996 +; W. Landsman Fix Y scaling when only XRANGE supplied Nov 1996 +; W. Landsman Added NSKIP keyword Dec 1996 +; W. Landsman Use XLOG, YLOG instead of XTYPE, YTYPE Jan 1998 +; W. Landsman Rename to PLOTERROR, OPLOTERROR Jun 1998 +; W. Landsman Better default scaling when NSKIP supplied Oct 1998 +; W. Landsman Ignore !P.PSYM when drawing error bars Jan 1999 +; W. Landsman Handle NSUM keyword correctly Aug 1999 +; W. Landsman Fix case of /XLOG but no X error bars Oct 1999 +; W. Landsman Work in the presence of NAN values Nov 2000 +; W. Landsman Improve logic when NSUM or !P.NSUM is set Jan 2001 +; W. Landsman Only draw error bars with in XRANGE (for speed) Jan 2002 +; W. Landsman Fix Jan 2002 update to work with log plots Jun 2002 +; W. Landsman Added _STRICT_EXTRA Jul 2005 +; W. Landsman/D.Nidever Fixed case of logarithmic axes reversed Mar 2009 +; W. Landsman/S. Koch Allow input to be a single point Jan 2010 +; W. Landsman Add Coyote Graphics Feb 2011 +; W. Landsman Make keyword name ERRCOLOR instead of ECOLOR +; Speedup when no ERRCOLOR defined Feb 2011 +; D. Fanning Use PLOTS instead of CGPLOTS for speed Jan 2012 +;- +; Check the parameters. + On_error, 2 + compile_opt idl2 + + np = N_params() + IF (np LT 2) THEN BEGIN + print, "PLOTERROR must be called with at least two parameters." + print, "Syntax: ploterror, [x,] y, [xerr], yerr" + RETURN + ENDIF + +IF Keyword_Set(window) THEN BEGIN + + currentWindow = cgQuery(/CURRENT, COUNT=wincnt) + IF wincnt EQ 0 THEN replaceCmd = 0 ELSE replaceCmd=1 + cgWindow, 'ploterror', x, y, xerr, yerr, NOHAT=hat, HATLENGTH=hln, ERRTHICK=eth, $ + ERRSTYLE=est, TYPE=itype, XRANGE = xrange, XLOG=xlog, YLOG=ylog, $ + NSKIP = nskip, NOCLIP = noclip, ERRCOLOR= ecol, YRANGE = yrange, $ + NSUM = nsum, _EXTRA = pkey, REPLACECMD=replaceCmd + RETURN + +ENDIF + +; Error bar keywords (except for HATLENGTH; this one will be taken care of +; later, when it is time to deal with the error bar hats). + + hat = ~keyword_set(hat) + setdefaultvalue, eth, !P.thick + setdefaultvalue, est, 0 + setdefaultvalue, ecol, 'Opposite' + setdefaultvalue, noclip, 0 + setdefaultvalue, nskip, 1 + setdefaultvalue, nsum, !p.nsum + setdefaultvalue, traditional, 0 + +; Other keywords. + + IF (keyword_set(itype)) THEN BEGIN + CASE (itype) OF + 1 : ylog = 1 ; X linear, Y log + 2 : xlog = 1 ; X log, Y linear + 3 : BEGIN ; X log, Y log + xlog = 1 + ylog = 1 + END + ELSE : + ENDCASE + ENDIF + setdefaultvalue,xlog, 0 + setdefaultvalue,ylog, 0 + ; If no x array has been supplied, create one. Make +; sure the rest of the procedure can know which parameter +; is which. + + IF np EQ 2 THEN BEGIN ; Only Y and YERR passed. + yerr = y + yy = x + xx = lindgen(n_elements(yy)) + xerr = make_array(size=size(xx)) + + ENDIF ELSE IF np EQ 3 THEN BEGIN ; X, Y, and YERR passed. + yerr = xerr + yy = y + xx = x + + ENDIF ELSE BEGIN ; X, Y, XERR and YERR passed. + yy = y + g = where(finite(xerr)) + xerr[g] = abs(xerr[g]) + xx = x + ENDELSE + + g = where(finite(yerr)) ;Don't take absolute value of NAN values + yerr[g] = abs(yerr[g]) + +; Determine the number of points being plotted. This +; is the size of the smallest of the three arrays +; passed to the procedure. Truncate any overlong arrays. + + n = N_elements(xx) < N_elements(yy) + + IF np GT 2 then n = n < N_elements(yerr) + IF np EQ 4 then n = n < N_elements(xerr) + + IF n LT 1 THEN $ + message,'ERROR - No data points to plot.' + + xx = xx[0:n-1] + yy = yy[0:n-1] + yerr = yerr[0:n-1] + IF np EQ 4 then xerr = xerr[0:n-1] + +; If NSUM is greater than one, then we need to smooth ourselves (using FREBIN) + + if nsum GT 1 then begin + n1 = float(n) / nsum + n = long(n1) + xx = frebin(xx, n1) + yy = frebin(yy, n1) + yerror = frebin(yerr,n1)/sqrt(nsum) + if NP EQ 4 then xerror = frebin(xerr,n1)/sqrt(nsum) + endif else begin + yerror = yerr + if NP EQ 4 then xerror = xerr + endelse + + +; If no y-range was passed via keyword or system variable, force one large +; enough to display all the data and the entire error bars. +; If a reversed y-range was passed, switch ylo and yhi. + + ylo = yy - yerror + yhi = yy + yerror + + setdefaultvalue, yrange, !Y.RANGE + IF yrange[0] EQ yrange[1] THEN BEGIN + if keyword_set( XRANGE ) then begin + good = where( (xx GT min(xrange)) and (xx LT max(xrange)), Ng ) + if Ng EQ 0 then message, $ + 'ERROR - No X data within specified X range' + yrange = [min(ylo[good],/NAN), max(yhi[good], /NAN)] + endif else yrange = [min(ylo,/NAN), max(yhi, /NAN)] + ENDIF +; Similarly for x-range + setdefaultvalue, xrange, !X.RANGE + if NP EQ 4 then begin + xlo = xx - xerror + xhi = xx + xerror + IF xrange[0] EQ xrange[1] THEN xrange = [min(xlo,/NAN), max(xhi,/NAN)] + endif + +; Plot the positions. Always set NSUM = 1 since we already took care of +; smoothing with FREBIN + + cgPlot, xx, yy, XRANGE = xrange, YRANGE = yrange, XLOG = xlog, YLOG = ylog, $ + _EXTRA = pkey, NOCLIP = noclip, NSum= 1, TRADITIONAL=traditional + +; Plot the error bars. Compute the hat length in device coordinates +; so that it remains fixed even when doing logarithmic plots. + + data_low = convert_coord(xx,ylo,/TO_DEVICE) + data_hi = convert_coord(xx,yhi,/TO_DEVICE) + if NP EQ 4 then begin + x_low = convert_coord(xlo,yy,/TO_DEVICE) + x_hi = convert_coord(xhi,yy,/TO_DEVICE) + endif + ycrange = !Y.crange + xcrange = !x.crange + sv_psym = !P.PSYM & !P.PSYM = 0 + + if ylog EQ 1 then ylo = ylo > 10^min(ycrange) + if (xlog EQ 1) && (np EQ 4) then xlo = xlo > 10^min(xcrange) + +; Only draw error bars for X values within XCRANGE + if xlog EQ 1 then xcrange = 10^xcrange + g = where((xx GT xcrange[0]) and (xx LE xcrange[1]), Ng) + + if (Ng GT 0) && (Ng NE n) then begin + istart = min(g, max = iend) + endif else begin + istart = 0L & iend = n-1 + endelse + + ecol = cgDefaultColor(ecol, Default='opposite') + IF Size(ecol, /TNAME) EQ 'STRING' THEN ecol = cgColor(ecol) + + FOR i = istart, iend, Nskip DO BEGIN + + Plots, [xx[i],xx[i]], [ylo[i],yhi[i]], LINESTYLE=est,THICK=eth, $ + NOCLIP = noclip, COLOR = ecol +; Plot X-error bars + if np EQ 4 then Plots, [xlo[i],xhi[i]],[yy[i],yy[i]],LINESTYLE=est, $ + THICK=eth, COLOR = ecol, NOCLIP = noclip + IF (hat NE 0) THEN BEGIN + IF (N_elements(hln) EQ 0) THEN hln = !D.X_VSIZE/100. + exx1 = data_low[0,i] - hln/2. + exx2 = exx1 + hln + + Plots, [exx1,exx2], [data_low[1,i],data_low[1,i]], $ + COLOR=ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, noclip = noclip + Plots, [exx1,exx2], [data_hi[1,i],data_hi[1,i]], $ + COLOR = ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, noclip = noclip + +; Plot Y-error bars + + IF np EQ 4 THEN BEGIN + IF (N_elements(hln) EQ 0) THEN hln = !D.Y_VSIZE/100. + eyy1 = x_low[1,i] - hln/2. + eyy2 = eyy1 + hln + Plots, [x_low[0,i],x_low[0,i]], [eyy1,eyy2],COLOR = ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, NOCLIP = noclip + Plots, [x_hi[0,i],x_hi[0,i]], [eyy1,eyy2],COLOR = ecol, $ + LINESTYLE=est,THICK=eth,/DEVICE, NOCLIP = noclip + ENDIF + ENDIF + NOPLOT: + ENDFOR + !P.PSYM = sv_psym +; + RETURN + END diff --git a/modules/idl_downloads/astro/pro/plothist.pro b/modules/idl_downloads/astro/pro/plothist.pro new file mode 100644 index 0000000..b311a1e --- /dev/null +++ b/modules/idl_downloads/astro/pro/plothist.pro @@ -0,0 +1,369 @@ +PRO plothist, arr, xhist,yhist, BIN=bin, NOPLOT=NoPlot, $ + OVERPLOT=Overplot, PSYM = psym, Peak=Peak, $ + Fill=Fill, FCOLOR=Fcolor, FLINE=FLINE, $ + FTHICK=FThick, FSPACING=Fspacing, FPATTERN=Fpattern, $ + FORIENTATION=Forientation, NAN = NAN, $ + _EXTRA = _extra, Halfbin = halfbin, AUTOBin = autobin, $ + Boxplot = boxplot, xlog = xlog, ylog = ylog, $ + yrange = yrange, Color = color,axiscolor=axiscolor, $ + rotate = rotate, WINDOW=window,XSTYLE=xstyle, YSTYLE = ystyle,$ + THICK= thick, LINESTYLE = linestyle +;+ +; NAME: +; PLOTHIST +; PURPOSE: +; Plot the histogram of an array with the corresponding abscissa. +; +; CALLING SEQUENCE: +; plothist, arr, xhist, yhist, [, BIN=, /FILL, /NOPLOT, /OVERPLOT, PEAK=, +; /AUTOBIN, ...plotting keywords] +; INPUTS: +; arr - The array to plot the histogram of. It can include negative +; values, but non-integral values will be truncated. +; +; OPTIONAL OUTPUTS: +; xhist - X vector used in making the plot +; ( = lindgen( N_elements(h)) * bin + min(arr) ) +; yhist - Y vector used in making the plot (= histogram(arr/bin)) +; +; OPTIONAL INPUT-OUTPUT KEYWORD: +; BIN - The size of each bin of the histogram, scalar (not necessarily +; integral). If not present (or zero), then the default is to +; automatically determine the binning size as the square root of +; the number of samples +; If undefined on input, then upon return BIN will contain the +; automatically computing bin factor. +; OPTIONAL INPUT KEYWORDS: +; /AUTOBIN - (OBSOLETE) Formerly would automatically determines bin size +; of the histogram as the square root of the number of samples. +; This is now the default so the keyword is no longer needed. +; Use the BIN keyword to manually set the bin size. +; AXISCOLOR - Color (string or number) of the plotting axes. +; BOXPLOT - If set (default), then each histogram data value is plotted +; "box style" with vertical lines drawn from Y=0 at each end of +; the bin width. Set BOXPLOT=0 to suppress this. +; COLOR - Color (number or string) of the plotted data. See CGCOLOR +; for a list of available color names. +; /HALFBIN - Set this keyword to a nonzero value to shift the binning by +; half a bin size. This is useful for integer data, where e.g. +; the bin for values of 6 will go from 5.5 to 6.5. The default +; is to set the HALFBIN keyword for integer data, and not for +; non-integer data. +; /NAN - If set, then check for the occurence of IEEE not-a-number values +; This is the default for floating point or Double data +; /NOPLOT - If set, will not plot the result. Useful if intention is to +; only get the xhist and yhist outputs. +; /OVERPLOT - If set, will overplot the data on the current plot. User +; must take care that only keywords valid for OPLOT are used. +; PEAK - if non-zero, then the entire histogram is normalized to have +; a maximum value equal to the value in PEAK. If PEAK is +; negative, the histogram is inverted. +; /FILL - if set, will plot a filled (rather than line) histogram. +; /ROTATE - if set, the plot is rotated onto it's side, meaning the bars +; extend from left to right. Xaxis corresponds to the count within +; in each bin. Useful for placing a histogram plot +; at the side of a scatter plot. +; WINDOW - Set this keyword to plot to a resizeable graphics window +; +; +; The following keywords will automatically set the FILL keyword: +; FCOLOR - color (string or number) to use for filling the histogram +; /FLINE - if set, will use lines rather than solid color for fill (see +; the LINE_FILL keyword in the POLYFILL routine) +; FORIENTATION - angle of lines for fill (see the ORIENTATION keyword +; in the POLYFILL routine) +; FPATTERN - the pattern to use for the fill (see the PATTERN keyword +; in the POLYFILL routine) +; FSPACING - the spacing of the lines to use in the fill (see the SPACING +; keyword in the POLYFILL routine) +; FTHICK - the thickness of the lines to use in the fill (see the THICK +; keyword in the POLYFILL routine) +; +; Any input keyword that can be supplied to the cgPLOT procedure (e.g. XRANGE, +; AXISCOLOR, LINESTYLE, /XLOG, /YLOG) can also be supplied to PLOTHIST. +; +; EXAMPLE: +; (1) Create a vector of random 1000 values derived from a Gaussian of +; mean 0, and sigma of 1. Plot the histogram of these values with a +; binsize of 0.1, and use a blue colored box fill. +; +; IDL> a = randomn(seed,1000) +; IDL> plothist,a, bin = 0.1,fcolor='blue' +; +; (2) As before, but use autobinning and fill the plot with diagonal lines at +; a 45 degree angle +; +; IDL> plothist,a, /fline, forient=45 +; +; NOTES: +; David Fanning has written a similar program CGHISTOPLOT with more graphics +; options: See http://www.idlcoyote.com/programs/cghistoplot.pro +; MODIFICATION HISTORY: +; Written W. Landsman January, 1991 +; Add inherited keywords W. Landsman March, 1994 +; Use ROUND instead of NINT W. Landsman August, 1995 +; Add NoPlot and Overplot keywords. J.Wm.Parker July, 1997 +; Add Peak keyword. J.Wm.Parker Jan, 1998 +; Add FILL,FCOLOR,FLINE,FPATTERN,FSPACING keywords. J.Wm.Parker Jan, 1998 +; Add /NAN keyword W. Landsman October 2001 +; Don't plot out of range with /FILL, added HALFBIN keyword, make +; half bin shift default for integer only W. Landsman/J. Kurk May 2002 +; Add BOXPLOT keyword, use exact XRANGE as default W.L. May 2006 +; Allow use of /XLOG and /YLOG keywords W.L. June 2006 +; Adjust Ymin when /YLOG is used W. L. Sep 2007 +; Added AXISCOLOR keyword, fix color problem with overplots WL Nov 2007 +; Check when /NAN is used and all elements are NAN S. Koposov Sep 2008 +; Added /ROTATE keyword to turn plot on its side. J. Mullaney, 2009. +; Added FTHICK keyword for thickness of fill lines. L. Anderson Oct. 2010 +; Use Coyote Graphics W. Landsman Feb 2011 +; Explicit XSTYLE, YSTYLE keywords to avoid _EXTRA confusion WL. Aug 2011 +; Fix PLOT keyword problem with /ROTATE WL Dec 2011 +; Fix problems when /XLOG is set A. Kimball/WL April 2013 +; Fix FILL to work when axis is inverted (xcrange[0] > +; xcrange[1]) T.Ellsworth-Bowers July 2014 +; Make /NaN,/AUTOBIN and BOXPLOT the default W. Landsman April 2016 +;- +; Check parameters. + + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - plothist, arr, [xhist,yhist, ' + print, ' [/AUTOBIN, BIN=, /BOXPLOT, HALFBIN=, PEAK=, /NOPLOT,' + print, ' /OVERPLOT, /FILL...plotting keywords]' + print,'Fill keywords: FCOLOR=, /FLINE, FORIENTATION=, FPATTERN=,' + $ + 'FSPACING= ' + return + endif + + Catch, theError + if theError NE 0 then begin + Catch,/Cancel + ; void = cgErrorMsg(/quiet) + return + endif + + if N_elements( arr ) LT 2 then message, $ + 'ERROR - Input array must contain at least 2 elements' + arrmin = min( arr, MAX = arrmax) + if ( arrmin EQ arrmax ) then message, $ + 'ERROR - Input array must contain distinct values' + if N_elements(boxplot) EQ 0 then boxplot=1 + + dtype = size(arr,/type) + floatp = (dtype EQ 4) || (dtype EQ 5) + + ;Determining how to calculate bin size: + if ~keyword_set(BIN) then begin + bin = (max(arr)-min(arr))/sqrt(N_elements(arr)) + if ~floatp then bin = bin > 1 + endif else begin + bin = float(abs(bin)) + endelse + + + +; Compute the histogram and abscissa. +; Determine if a half bin shift is +; desired (default for integer data) + if N_elements(halfbin) EQ 0 then halfbin = ~floatp ;integer data? + + + if N_elements(NaN) EQ 0 then NaN = 1 + if floatp && NaN then begin + good = where(finite(arr), ngoods ) + if ngoods eq 0 then $ + message, 'ERROR - Input array contains no finite values' + + if halfbin then y = round( ( arr[good] / bin)) $ + else y = floor( ( arr[good] / bin)) + endif else if halfbin then y = round( ( arr / bin)) $ + else y = floor( ( arr/ bin)) + + ;Determine number in each bin: + yhist = histogram( y ) + N_hist = N_elements( yhist ) + + ;Positions of each bin: + xhist = lindgen( N_hist ) * bin + min(y*bin) + + if ~halfbin then xhist = xhist + 0.5*bin + +;;; +; If renormalizing the peak, do so. +; +if keyword_set(Peak) then yhist = yhist * (Peak / float(max(yhist))) + +;;; +; If not doing a plot, exit here. +; + if keyword_set(NoPlot) then return + + ;JRM;;;;; + xra_set = keyword_set(XRANGE)?1:0 + xst_set = keyword_set(xstyle)?1:0 + yst_set = keyword_set(ystyle)?1:0 +;JRM;;;;; + + if N_elements(fill) EQ 0 then $ + fill = keyword_set(fcolor) || keyword_set(fline) + + if keyword_set(over) then begin ;if overplotting, was original plot a log? + if N_elements(ylog) EQ 0 then ylog = !Y.type + if N_elements(xlog) EQ 0 then xlog = !X.type + endif + if N_elements(PSYM) EQ 0 then psym = 10 ;Default histogram plotting + if ~keyword_set(XRANGE) then xrange = [ xhist[0]-bin ,xhist[N_hist-1]+bin ] + if ~keyword_set(xstyle) then xstyle=1 + + if keyword_set(ylog) then begin + ymin = min(yhist) GT 1 ? 1 : 0.1 + if N_elements(yrange) EQ 2 then ymin = ymin < yrange[0] + ;ydata contains the y-positions where the lines should be linked. + ydata = [ymin, yhist>ymin, ymin] + endif else ydata = [0, yhist, 0] + ;xdata contains the y-positions where the lines should be linked. + xdata = [xhist[0] - bin, xhist, xhist[n_hist-1]+ bin] + if keyword_set(xlog) then xrange[0] = xrange[0]>1 + + ;JRM;;;;;;;;;;; + IF n_elements(rotate) EQ 1 THEN BEGIN + old_xdata = xdata + old_ydata = ydata + xdata = old_ydata + ydata = old_xdata + + old_xhist=xhist + old_yhist=yhist + xhist=old_yhist + yhist=old_xhist + + ;If xrange is not set. + ;Then the auto x- range by setting xrange to [0,0]. + if ~xra_set then xrange=[0,0] + if ~xst_set then xstyle=0 + if ~yst_set then ystyle=1 + + ENDIF + + + if ~keyword_set(Overplot) then begin + + cgplot, xdata , ydata, $ + PSYM = psym, _EXTRA = _extra,xrange=xrange,axiscolor=axiscolor, $ + xstyle=xstyle, xlog = xlog, ylog = ylog, yrange=yrange, $ + ystyle=ystyle, /nodata,window=window + if keyword_Set(window) then cgcontrol,execute=0 + endif +;JRM;;;;;;;;;;;;; + +;;; +; If doing a fill of the histogram, then go for it. +; + if N_elements(color) EQ 0 then color = cgcolor('opposite') + + if keyword_set(Fill) then begin + ;JRM;;;;;;;;;;; + xcrange = keyword_set(xlog)? 10^!X.CRANGE : !X.CRANGE + ycrange = keyword_set(ylog)? 10^!Y.CRANGE : !Y.CRANGE + + IF n_elements(rotate) EQ 0 THEN BEGIN + Xfill = transpose([[Xhist-bin/2.0],[Xhist+bin/2.0]]) + Xfill = reform(Xfill, n_elements(Xfill)) + Xfill = [Xfill[0], Xfill, Xfill[n_elements(Xfill)-1]] + Yfill = transpose([[Yhist],[Yhist]]) + Yfill = reform(Yfill, n_elements(Yfill)) + + if keyword_set(ylog) then Yfill = [ycrange[0]/10, Yfill, ycrange[0]/10] $ + else yfill = [0, yfill, 0 ] + + ENDIF ELSE BEGIN + Xfill = transpose([[Xhist],[Xhist]]) + Xfill = reform(Xfill, n_elements(Xfill)) + Yfill = transpose([[Yhist-bin/2.0],[Yhist+bin/2.0]]) + Yfill = reform(Yfill, n_elements(Yfill)) + Yfill = [Yfill[0], Yfill, Yfill[n_elements(Yfill)-1]] + + if keyword_set(xlog) then Xfill = [xcrange[0]/10, xfill, xcrange[0]/10] $ + else xfill = [0, xfill, 0 ] + ENDELSE + ;JRM;;;;;;;;;;; + + ;; TPEB;;;;;;;;;;; + ;; Check if plot ranges are reversed (i.e. large to small) + Xfill = (XCRANGE[0] GT XCRANGE[1]) ? Xfill > XCRANGE[1] < XCRANGE[0] : $ + Xfill > XCRANGE[0] < XCRANGE[1] ;Make sure within plot range + + Yfill = (YCRANGE[0] GT YCRANGE[1]) ? Yfill > YCRANGE[1] < YCRANGE[0] : $ + Yfill > YCRANGE[0] < YCRANGE[1] + ;; TPEB;;;;;;;;;;; + + if keyword_set(Fcolor) then Fc = Fcolor else Fc = 'Opposite' + if keyword_set(Fline) then begin + Fs = keyword_set(Fspacing) ? Fspacing : 0 + Fo = keyword_set(Forientation) ? Forientation: 0 + cgcolorfill, Xfill,Yfill, color=Fc, /line_fill, spacing=Fs, orient=Fo, $ + thick = fthick, WINDOW=window + + endif else begin + + if keyword_set(Fpattern) then begin + cgcolorfill, Xfill,Yfill, color=Fc, pattern=Fpattern, window=window + endif else begin + cgcolorfill, Xfill,Yfill, color=Fc,window=window + endelse + endelse + endif + + ;JRM;;;;;;;;;;; + IF n_elements(rotate) GT 0 THEN BEGIN + ;Need to determine the positions and use plotS. + ycrange = keyword_set(ylog)? 10^!Y.CRANGE : !Y.CRANGE + xcrange = keyword_set(xlog)? 10^!X.CRANGE : !X.CRANGE + cgplots, xdata[0]ycrange[0], $ + color=color,Thick = thick, LINESTYLE = linestyle, ADDCMD=window + cgplots, xdata[0]ycrange[0], $ + color=color,THICK = thick, LINESTYLE= linestyle, ADDCMD=window + FOR i=1, n_elements(xdata)-2 DO BEGIN + cgplots, xdata[i]ycrange[0], $ + color=color, THICK=thick, LINESTYLE= linestyle, $ + /CONTINUE,ADDCMD=window + cgplots, xdata[i]ycrange[0], $ + color=color, /CONTINUE,THICK=thick, LINESTYLE=linestyle, $ + ADDCMD=window + ENDFOR + cgplots, xdata[i]ycrange[0], $ + color=color, /CONTINUE, THICK=thick, LINESTYLE = linestyle, $ + ADDCMD=window + ENDIF ELSE BEGIN + cgplot, /over, xdata, ydata, XSTYLE= xstyle, YSTYLE = ystyle, $ + PSYM = psym, THICK=thick, LINESTYLE = linestyle, $ + _EXTRA = _extra,color=color,ADDCMD=window + ENDELSE + ;JRM;;;;;;;;;;; + + ; Make histogram boxes by drawing lines in data color. +if keyword_set(boxplot) then begin + ;JRM;;;;;;;;;;; + IF n_elements(rotate) EQ 0 THEN BEGIN + ycrange = keyword_set(ylog)? 10^!Y.CRANGE : !Y.CRANGE + FOR j =0 ,N_Elements(xhist)-1 DO BEGIN + cgPlotS, [xhist[j], xhist[j]]-bin/2, [YCRange[0], yhist[j], Ycrange[1]], $ + Color=Color,noclip=0, THICK=thick, LINESTYLE = linestyle, $ + _Extra=extra,ADDCMD=window + ENDFOR + + ENDIF ELSE BEGIN + xcrange = keyword_set(xlog)? 10^!X.CRANGE : !X.CRANGE + FOR j =0 ,N_Elements(xhist)-1 DO BEGIN + cgPlotS, [xcrange[0], xhist[j] PLOTSYM, 3 ,2, /FILL ;Plotting symbol is a filled star, +; ;twice default size +; IDL> PLOT,X,Y,PSYM=8 ;Set PSYM = 8 to get star symbol +; +; Now plot Y vs. X with an open circle as the symbol +; +; IDL> PLOTSYM, 0 ;Plotting symbol is a circle +; IDL> PLOT,X,Y,PSYM=8 +; +; METHOD: +; Appropriate X,Y vectors are used to define the symbol and passed to the +; USERSYM command. +; +; REVISION HISTORY +; Written W. Landsman June 1992 +; 18-JAN-1996 Added a square symbol, HCW. +; 98Aug20 Added keyword thick parameter - RCB. +; April 2001 Added COLOR keyword WBL +;- + On_error,2 + + if N_elements(psym) LT 1 then begin + print,'Syntax - PLOTSYM, psym, [ size, /FILL, THICK= ]' + print,' PSYM values 0 - circle, 1 - down arrow, 2 - up arrow, 3 - star' + print,' 4 - triangle, 5 - upside down triangle, 6 - left arrow' + print,' 7 - right arrow, 8 - square' + return + endif + + if ( N_elements(psize) LT 1 ) then psize = 1 else psize = psize > 0.1 + + if ~keyword_set(FILL) then fill = 0 + if ~keyword_set(thick) then thick=1 + + case psym of + 0: begin ;Circle + ang = 2*!PI*findgen(49)/48. ;Get position every 5 deg + xarr = psize*cos(ang) & yarr = psize*sin(ang) + end +1: begin ;Down arrow + xarr = [0,0,.5,0,-.5]*psize + yarr = [0,-2,-1.4,-2,-1.4]*psize + fill = 0 + end +2: begin ;Up arrow + xarr = [0,0,.5,0,-.5]*psize + yarr = [0,2,1.4,2,1.4]*psize + fill = 0 + end +3: begin ;Star + ang = (360. / 10 * findgen(11) + 90) / !RADEG ;star angles every 36 deg + r = ang*0 + r[2*indgen(6)] = 1. + cp5 = cos(!pi/5.) + r1 = 2. * cp5 - 1. / cp5 + r[2*indgen(5)+1] = r1 + r = r * psize / sqrt(!pi/4.) * 2. / (1.+r1) + xarr = r * cos(ang) & yarr = r * sin(ang) + end +4: begin ;Triangle + xarr = [-1,0,1,-1]*psize + yarr = [-1,1,-1,-1]*psize + end +5: begin ;Upside down triangle + xarr = [-1, 0, 1, -1]*psize + yarr = [ 1,-1, 1, 1]*psize + end +6: begin ;Left pointing arrow + yarr = [0, 0, 0.5, 0, -.5]*psize + xarr = [0,-2,-1.4,-2,-1.4]*psize + fill = 0 + end +7: begin ;Left pointing arrow + yarr = [ 0, 0, 0.5, 0, -.5] * psize + xarr = [ 0, 2, 1.4, 2, 1.4] * psize + fill = 0 + end +8: begin ;Square + xarr = [-1,-1,1, 1,-1] * psize + yarr = [-1, 1,1,-1,-1] * psize + end + else: message,'Unknown plotting symbol value of '+strtrim(psym,2) + endcase + + if N_elements(color) GT 0 then $ + usersym, xarr, yarr, FILL = fill,thick=thick, color = color else $ + usersym, xarr, yarr, FILL = fill,thick=thick + return + end + diff --git a/modules/idl_downloads/astro/pro/poidev.pro b/modules/idl_downloads/astro/pro/poidev.pro new file mode 100644 index 0000000..70bbcaf --- /dev/null +++ b/modules/idl_downloads/astro/pro/poidev.pro @@ -0,0 +1,134 @@ +function poidev, xm, SEED = seed +;+ +; NAME: +; POIDEV +; PURPOSE: +; Generate a Poisson random deviate +; EXPLANATION: +; Return an integer random deviate drawn from a Poisson distribution with +; a specified mean. Adapted from procedure of the same name in +; "Numerical Recipes" by Press et al. (1992), Section 7.3 +; +; NOTE: This routine became partially obsolete in V5.0 with the +; introduction of the POISSON keyword to the intrinsic functions +; RANDOMU and RANDOMN. However, POIDEV is still useful for adding +; Poisson noise to an existing image array, for which the coding is much +; simpler than it would be using RANDOMU (see example 1) +; CALLING SEQUENCE: +; result = POIDEV( xm, [ SEED = ] ) +; +; INPUTS: +; xm - numeric scalar, vector or array, specifying the mean(s) of the +; Poisson distribution +; +; OUTPUT: +; result - Long integer scalar or vector, same size as xm +; +; OPTIONAL KEYWORD INPUT-OUTPUT: +; SEED - Scalar to be used as the seed for the random distribution. +; For best results, SEED should be a large (>100) integer. +; If SEED is undefined, then its value is taken from the system +; clock (see RANDOMU). The value of SEED is always updated +; upon output. This keyword can be used to have POIDEV give +; identical results on consecutive runs. +; +; EXAMPLE: +; (1) Add Poisson noise to an integral image array, im +; IDL> imnoise = POIDEV( im) +; +; (2) Verify the expected mean and sigma for an input value of 81 +; IDL> p = POIDEV( intarr(10000) + 81) ;Test for 10,000 points +; IDL> print,mean(p),sigma(p) +; Mean and sigma of the 10000 points should be close to 81 and 9 +; +; METHOD: +; For small values (< 20) independent exponential deviates are generated +; until their sum exceeds the specified mean, the number of events +; required is returned as the Poisson deviate. For large (> 20) values, +; uniform random variates are compared with a Lorentzian distribution +; function. +; +; NOTES: +; Negative values in the input array will be returned as zeros. +; +; +; REVISION HISTORY: +; Version 1 Wayne Landsman July 1992 +; Added SEED keyword September 1992 +; Call intrinsic LNGAMMA function November 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use COMPLEMENT keyword to WHERE() W. Landsman August 2008 +;- + On_error,2 + compile_opt idl2 + + Npts = N_elements( xm) + + case NPTS of + 0: message,'ERROR - Poisson mean vector (first parameter) is undefined' + 1: output = lonarr(1) + else: output = make_array( SIZE = size(xm), /NOZERO ) + endcase + + index = where( xm LE 20, Nindex, complement=big, Ncomplement=Nbig) + + if Nindex GT 0 then begin + + g = exp( -xm[ index] ) ;To compare with exponential distribution + em1 = replicate( -1, Nindex ) ;Counts number of events + t = replicate( 1., Nindex ) ;Counts (log) of total time + + Ngood = Nindex + good = lindgen( Nindex) ;GOOD indexes the original array + good1 = good ;GOOD1 indexes the GOOD vector + + REJECT: em1[good] = em1[good] + 1 ;Increment event counter + t = t[good1]*randomu( seed, Ngood ) ;Add exponential deviate, equivalent + ;to multiplying random deviate + good1 = where( t GT g[good], Ngood1) ;Has sum of exponential deviates + ;exceeded specified mean? + if ( Ngood1 GE 1 ) then begin + good = good[ good1] + Ngood = Ngood1 + goto, REJECT + endif + output[index] = em1 + endif + if Nindex EQ Npts then return, output +; *************************************** + + xbig = xm[big] + + sq = sqrt( 2.*xbig ) ;Sq, Alxm, and g are precomputed + alxm = alog( xbig ) + g = xbig * alxm - lngamma( xbig + 1.) + + Ngood = Nbig & Ngood1 = Nbig + good = lindgen( Ngood) + good1 = good + y = fltarr(Ngood, /NOZERO ) & em = y + + +REJECT1: y[good] = tan( !PI * randomu( seed, Ngood ) ) + em[good] = sq[good]*y[good] + xbig[good] + good2 = where( em[good] LT 0. , Ngood ) + if (Ngood GT 0) then begin + good = good[good2] + goto, REJECT1 + endif + + fixem = long( em[good1] ) + test = check_math( 0, 1) ;Don't want overflow messages + t = 0.9*(1. + y[good1]^2)*exp( fixem*alxm[good1] - $ + lngamma( fixem + 1.) - g[good1] ) + good2 = where( randomu (seed, Ngood1) GT T , Ngood) + if ( Ngood GT 0 ) then begin + good1 = good1[good2] + good = good1 + goto, REJECT1 + endif + output[ big ] = long(em) + + return, output + + end diff --git a/modules/idl_downloads/astro/pro/polint.pro b/modules/idl_downloads/astro/pro/polint.pro new file mode 100644 index 0000000..9c36b4b --- /dev/null +++ b/modules/idl_downloads/astro/pro/polint.pro @@ -0,0 +1,85 @@ +pro polint, xa, ya, x, y, dy +;+ +; NAME: +; POLINT +; PURPOSE: +; Interpolate a set of N points by fitting a polynomial of degree N-1 +; EXPLANATION: +; Adapted from algorithm in Numerical Recipes, Press et al. (1992), +; Section 3.1. +; +; CALLING SEQUENCE +; POLINT, xa, ya, x, y, [ dy ] +; INPUTS: +; XA - X Numeric vector, all values must be distinct. The number of +; values in XA should rarely exceed 10 (i.e. a 9th order polynomial) +; YA - Y Numeric vector, same number of elements +; X - Numeric scalar specifying value to be interpolated +; +; OUTPUT: +; Y - Scalar, interpolated value in (XA,YA) corresponding to X +; +; OPTIONAL OUTPUT +; DY - Error estimate on Y, scalar +; +; EXAMPLE: +; Find sin(2.5) by polynomial interpolation on sin(indgen(10)) +; +; IDL> xa = indgen(10) +; IDL> ya = sin( xa ) +; IDL> polint, xa, ya, 2.5, y ,dy +; +; The above method gives y = .5988 & dy = 3.1e-4 a close +; approximation to the actual sin(2.5) = .5985 +; +; METHOD: +; Uses Neville's algorithm to iteratively build up the correct +; polynomial, with each iteration containing one higher order. +; +; REVISION HISTORY: +; Written W. Landsman January, 1992 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 4 then begin + print,'Syntax - polint, xa, ya, x, y, [ dy ]' + print,' xa,ya - Input vectors to be interpolated' + print,' x - Scalar specifying point at which to interpolate' + print,' y - Output interpolated scalar value' + print,' dy - Optional error estimate on y' + return + endif + + N = N_elements( xa ) + if N_elements( ya ) NE N then message, $ + 'ERROR - Input X and Y vectors must have same number of elements' + +; Find the index of XA which is closest to X + + dif = min( abs(x-xa), ns ) + + c = ya & d = ya + y = ya[ns] + ns = ns - 1 + + for m = 1,n-1 do begin + + ho = xa[0:n-m-1] - x + hp = xa[m:n-1] - x + w = c[1:n-m] - d[0:n-m-1] + den = ho - hp + if min( abs(den) ) EQ 0 then message, $ + 'ERROR - All input X vector values must be distinct' + den = w / den + d = hp * den + c = ho * den + if ( 2*ns LT n-m-1 ) then dy = c[ns+1] else begin + dy = d[ns] + ns = ns - 1 + endelse + y = y + dy + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/polrec.pro b/modules/idl_downloads/astro/pro/polrec.pro new file mode 100644 index 0000000..1b246b1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/polrec.pro @@ -0,0 +1,52 @@ +;------------------------------------------------------------- +;+ +; NAME: +; POLREC +; PURPOSE: +; Convert 2-d polar coordinates to rectangular coordinates. +; CATEGORY: +; CALLING SEQUENCE: +; polrec, r, a, x, y +; INPUTS: +; r, a = vector in polar form: radius, angle (radians). in +; KEYWORD PARAMETERS: +; Keywords: +; /DEGREES means angle is in degrees, else radians. +; OUTPUTS: +; x, y = vector in rectangular form, double precision out +; COMMON BLOCKS: +; NOTES: +; MODIFICATION HISTORY: +; R. Sterner. 18 Aug, 1986. +; Johns Hopkins University Applied Physics Laboratory. +; RES 13 Feb, 1991 --- added /degrees. +; Converted to IDL V5.0 W. Landsman September 1997 +; 1999 May 03 --- Made double precision. R. Sterner. +; +; Copyright (C) 1986, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;- +;------------------------------------------------------------- + + PRO POLREC, R, A, X, Y, help=hlp, degrees=degrees + + IF (N_PARAMS(0) LT 4) or keyword_set(hlp) THEN BEGIN + PRINT,' Convert 2-d polar coordinates to rectangular coordinates. + PRINT,' polrec, r, a, x, y + PRINT,' r, a = vector in polar form: radius, angle (radians). in' + PRINT,' x, y = vector in rectangular form. out' + print,' Keywords:' + print,' /DEGREES means angle is in degrees, else radians.' + RETURN + ENDIF + + cf = 1.D0 + if keyword_set(degrees) then cf = 180.0d/!dpi + + X = R*COS(A/cf) + Y = R*SIN(A/cf) + RETURN + END diff --git a/modules/idl_downloads/astro/pro/poly_smooth.pro b/modules/idl_downloads/astro/pro/poly_smooth.pro new file mode 100644 index 0000000..0289e4f --- /dev/null +++ b/modules/idl_downloads/astro/pro/poly_smooth.pro @@ -0,0 +1,191 @@ +function poly_smooth, data, width, DEGREE=degree, NLEFT=nl, NRIGHT=nr, $ + DERIV_ORDER=order, COEFFICIENTS=filter_coef +;+ +; NAME: +; POLY_SMOOTH +; +; PURPOSE: +; Apply a least-squares (Savitzky-Golay) polynomial smoothing filter +; EXPLANATION: +; Reduce noise in 1-D data (e.g. time-series, spectrum) but retain +; dynamic range of variations in the data by applying a least squares +; smoothing polynomial filter, +; +; Also called the Savitzky-Golay smoothing filter, cf. Numerical +; Recipes (Press et al. 1992, Sec.14.8) +; +; The low-pass filter coefficients are computed by effectively +; least-squares fitting a polynomial in moving window, +; centered on each data point, so the new value will be the +; zero-th coefficient of the polynomial. Approximate first derivates +; of the data can be computed by using first degree coefficient of +; each polynomial, and so on. The filter coefficients for a specified +; polynomial degree and window width are computed independent of any +; data, and stored in a common block. The filter is then convolved +; with the data array to result in smoothed data with reduced noise, +; but retaining higher order variations (better than SMOOTH). +; +; This procedure became partially obsolete in IDL V5.4 with the +; introduction of the SAVGOL function, which computes the smoothing +; coefficients. +; CALLING SEQUENCE: +; +; spectrum = poly_smooth( data, [ width, DEGREE = , NLEFT = , NRIGHT = +; DERIV_ORDER = ,COEFF = ] +; +; INPUTS: +; data = 1-D array, such as a spectrum or time-series. +; +; width = total number of data points to use in filter convolution, +; (default = 5, using 2 past and 2 future data points), +; must be larger than DEGREE of polynomials, and a guideline is to +; make WIDTH between 1 and 2 times the FWHM of desired features. +; +; OPTIONAL INPUT KEYWORDS: +; +; DEGREE = degree of polynomials to use in designing the filter +; via least squares fits, (default DEGREE = 2) +; The higher degrees will preserve sharper features. +; +; NLEFT = # of past data points to use in filter convolution, +; excluding current point, overrides width parameter, +; so that width = NLEFT + NRIGHT + 1. (default = NRIGHT) +; +; NRIGHT = # of future data points to use (default = NLEFT). +; +; DERIV_ORDER = order of derivative desired (default = 0, no derivative). +; +; OPTIONAL OUTPUT KEYWORD: +; +; COEFFICIENTS = optional output of the filter coefficients applied, +; but they are all stored in common block for reuse, anyway. +; RESULTS: +; Function returns the data convolved with polynomial filter coefs. +; +; EXAMPLE: +; +; Given a wavelength - flux spectrum (w,f), apply a 31 point quadratic +; smoothing filter and plot +; +; IDL> cgplot, w, poly_smooth(f,31) +; COMMON BLOCKS: +; common poly_smooth, degc, nlc, nrc, coefs, ordermax +; +; PROCEDURE: +; As described in Numerical Recipes, 2nd edition sec.14.8, +; Savitsky-Golay filter. +; Matrix of normal eqs. is formed by starting with small terms +; and then adding progressively larger terms (powers). +; The filter coefficients of up to derivative ordermax are stored +; in common, until the specifications change, then recompute coefficients. +; Coefficients are stored in convolution order, zero lag in the middle. +; +; MODIFICATION HISTORY: +; Written, Frank Varosi NASA/GSFC 1993. +; Converted to IDL V5.0 W. Landsman September 1997 +; Use /EDGE_TRUNCATE keyword to CONVOL W. Landsman March 2006 +;- + compile_opt idl2 + On_error,2 + + if N_params() LT 1 then begin + print,'Syntax - smoothdata = ' + $ + 'poly_smooth( data , width, [ DEGREE = , NLEFT = ' + print,f='(35x,A)', 'NRIGHT = , DERIV_ORDER =, COEFFICIENT = ]' + return, -1 + endif + + common poly_smooth, degc, nlc, nrc, coefs, ordermax + + if N_elements( degree ) NE 1 then degree = 2 + if N_elements( order ) NE 1 then order = 0 + order = ( order < (degree-1) ) > 0 + + if N_elements( width ) EQ 1 then begin + width = fix( width ) > 3 + if (N_elements(nr) NE 1) AND (N_elements(nl) NE 1) then begin + nl = width/2 + nr = width - nl -1 + endif + endif + + if N_elements( nr ) NE 1 then begin + if N_elements( nl ) EQ 1 then nr = nl else nr = 2 + endif + + if N_elements( nl ) NE 1 then begin + if N_elements( nr ) EQ 1 then nl = nr else nl = 2 + endif + + if N_elements( coefs ) LE 1 then begin + degc = 0 + nlc = 0 + nrc = 0 + ordermax = 3 + endif + + if (degree NE degc) OR (nl NE nlc) OR (nr NE nrc) OR $ + (order GT ordermax) then begin + degree = degree > 2 + ordermax = ( ordermax < 3 ) > order + nj = degree+1 + nl = nl > 0 + nr = nr > 0 + nrl = nr + nl + 1 + + if (nrl LE degree) then begin + message,"# of points in filter must be > degree",/INFO + return, data + endif + + ATA = fltarr( nj, nj ) + ATA[0,0] = 1 + iaj = indgen( nj ) # replicate( 1, nj ) + iaj = iaj + transpose( iaj ) + m1_iaj = (-1)^iaj + + for k = 1, nr>nl do begin + k_iaj = float( k )^iaj + CASE 1 OF + ( k LE nr [2.7375, 6.20] +; +; The result can be checked using the first 3 Legendre polynomial terms +; C[0] + C[1]*x + C[2]*(0.5*(3*x^2-1)) +; METHOD: +; Uses the recurrence relation of Legendre polynomials +; (n+1)*P_n+1(x) = (2n+1)*x*P_n(x) - n*P_n-1(x) +; evaluated with the Clenshaw recurrence formula, see Numerical Recipes +; by Press et al. (1992), Section 5.5 +; +; REVISION HISTORY: +; Written W. Landsman Hughes STX Co. April, 1995 +; Fixed for double precision W. Landsman May, 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - result = POLYLEG( X, Coeff)' + return, -1 + endif + + N= N_elements(coeff) -1 + M = N_elements(x) + + case N of + 0: return, replicate( coeff, M) + 1: return, x* coeff[1] + coeff[0] + else: + endcase + +; If X is double then compute in double; otherwise compute in real + + if size(x,/TNAME) EQ 'DOUBLE' then begin + y = dblarr( M, N+2) + jj = dindgen(N) + 2.0d + endif else begin + y = fltarr( M, N+2 ) + jj = findgen(N) + 2. + endelse + + beta1 = -jj / (jj+1) + for j = N,1,-1 do begin + + alpha = (2*j + 1.)*x/float(j + 1.) + y[0,j-1] = alpha*y[*,j] + beta1[j-1]*y[*,j+1] + coeff[j] + endfor + + return, -0.5*y[*,1] + x*y[*,0] + coeff[0] + end diff --git a/modules/idl_downloads/astro/pro/posang.pro b/modules/idl_downloads/astro/pro/posang.pro new file mode 100644 index 0000000..e32dd85 --- /dev/null +++ b/modules/idl_downloads/astro/pro/posang.pro @@ -0,0 +1,121 @@ +PRO POSANG,u,ra1,dc1,ra2,dc2,angle +;+ +; NAME: +; POSANG +; PURPOSE: +; Computes rigorous position angle of source 2 relative to source 1 +; +; EXPLANATION: +; Computes the rigorous position angle of source 2 (with given RA, Dec) +; using source 1 (with given RA, Dec) as the center. +; +; CALLING SEQUENCE: +; POSANG, U, RA1, DC1, RA2, DC2, ANGLE +; +; INPUTS: +; U -- Describes units of inputs and output: +; 0: everything radians +; 1: RAx in decimal hours, DCx in decimal +; degrees, ANGLE in degrees +; RA1 -- Right ascension of point 1 +; DC1 -- Declination of point 1 +; RA2 -- Right ascension of point 2 +; DC2 -- Declination of point 2 +; +; OUTPUTS: +; ANGLE-- Angle of the great circle containing [ra2, dc2] from +; the meridian containing [ra1, dc1], in the sense north +; through east rotating about [ra1, dc1]. See U above +; for units. +; +; PROCEDURE: +; The "four-parts formula" from spherical trig (p. 12 of Smart's +; Spherical Astronomy or p. 12 of Green' Spherical Astronomy). +; +; EXAMPLE: +; For the star 56 Per, the Hipparcos catalog gives a position of +; RA = 66.15593384, Dec = 33.94988843 for component A, and +; RA = 66.15646079, Dec = 33.96100069 for component B. What is the +; position angle of B relative to A? +; +; IDL> RA1 = 66.15593384/15.d & DC1 = 33.95988843 +; IDL> RA2 = 66.15646079/15.d & DC2 = 33.96100069 +; IDL> posang,1,ra1,dc1,ra2,dc2, ang +; will give the answer of ang = 21.4 degrees +; NOTES: +; (1) If RA1,DC1 are scalars, and RA2,DC2 are vectors, then ANGLE is a +; vector giving the position angle between each element of RA2,DC2 and +; RA1,DC1. Similarly, if RA1,DC1 are vectors, and RA2, DC2 are scalars, +; then DIS is a vector giving the position angle of each element of RA1, +; DC1 and RA2, DC2. If both RA1,DC1 and RA2,DC2 are vectors then ANGLE +; is a vector giving the position angle between each element of RA1,DC1 +; and the corresponding element of RA2,DC2. If then vectors are not the +; same length, then excess elements of the longer one will be ignored. +; +; (2) Note that POSANG is not commutative -- the position angle between +; A and B is theta, then the position angle between B and A is 180+theta +; PROCEDURE CALLS: +; ISARRAY() +; HISTORY: +; Modified from GCIRC, R. S. Hill, RSTX, 1 Apr. 1998 +; Use V6.0 notation W.L. Mar 2011 +; +;- + On_error,2 ;Return to caller + compile_opt idl2 + + npar = N_params() + IF (npar lt 5) THEN BEGIN + print,'Calling sequence: POSANG,U,RA1,DC1,RA2,DC2,ANGLE' + print,' U = 0 ==> Everything in radians' + print, $ + ' U = 1 ==> RAx decimal hours, DCx decimal degrees, ANGLE degrees' + RETURN +ENDIF + +scalar = (~isarray(ra1) ) && (~isarray(ra2) ) +IF scalar THEN BEGIN + IF (ra1 eq ra2) && (dc1 eq dc2) THEN BEGIN + angle = 0.0d0 + IF npar eq 5 THEN $ + print,'Positions are equal: ', ra1, dc1 + RETURN + ENDIF +ENDIF + +d2r = !DPI/180.0d0 +h2r = !DPI/12.0d0 + +CASE u OF + 0: BEGIN + rarad1 = ra1 + rarad2 = ra2 + dcrad1 = dc1 + dcrad2 = dc2 + END + 1: BEGIN + rarad1 = ra1*h2r + rarad2 = ra2*h2r + dcrad1 = dc1*d2r + dcrad2 = dc2*d2r + END + ELSE: MESSAGE, $ + 'U must be 0 for radians or 1 for hours, degrees, arcsec' +ENDCASE + +radif = rarad2-rarad1 +angle = atan(sin(radif),cos(dcrad1)*tan(dcrad2)-sin(dcrad1)*cos(radif)) + +IF (u ne 0) THEN angle = angle/d2r + +IF (npar eq 5) && (scalar) THEN BEGIN + IF (u ne 0) && (abs(angle) ge 0.1) $ + THEN fmt = '(F14.8)' $ + ELSE fmt = '(E15.8)' + units = (u ne 0) ? ' degrees' : ' radians' + print,'Position angle of target 2 about target 1 is ' $ + + string(angle,format=fmt) + units +ENDIF + +RETURN +END diff --git a/modules/idl_downloads/astro/pro/positivity.pro b/modules/idl_downloads/astro/pro/positivity.pro new file mode 100644 index 0000000..6e0abc5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/positivity.pro @@ -0,0 +1,50 @@ +function positivity, x, DERIVATIVE=deriv, EPSILON=epsilon +;+ +; NAME: +; POSITIVITY +; PURPOSE: +; Map an image uniquely and smoothly into all positive values. +; EXPLANATION: +; Take unconstrained x (usually an image), and map it uniquely and +; smoothly into positive values. Negative values of x get mapped to +; interval ( 0, sqrt( epsilon )/2 ], positive values go to +; ( sqrt( epsilon )/2, oo ) with deriv approaching 1. Derivative is +; always 1/2 at x=0. Derivative is used by the MRL deconvolution +; algorithm. +; +; CALLING SEQUENCE: +; result = POSITIVITY( x, [ /DERIVATIVE, EPSILON = ) +; +; INPUTS: +; x - input array, unconstrained +; +; OUTPUT: +; result = output array = ((x + sqrt(x^2 + epsilon))/2 +; if the /DERIV keyword is set then instead the derivative of +; the above expression with respect to X is returned +; +; OPTIONAL INPUT KEYWORDS: +; DERIV - if this keyword set, then the derivative of the positivity +; mapping is returned, rather than the mapping itself +; EPSILON - real scalar specifying the interval into which to map +; negative values. If EPSILON EQ 0 then the mapping reduces to +; positive truncation. If EPSILON LT then the mapping reduces to +; an identity (no change). Default is EPSILON = 1e-9 +; +; REVISION HISTORY: +; F.Varosi NASA/GSFC 1992, as suggested by R.Pina UCSD. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + if N_elements( epsilon ) NE 1 then epsilon = 1.e-9 + + if keyword_set( deriv ) then begin + if (epsilon GT 0) then return,(1 + x/sqrt( x^2 + epsilon ))/2 $ + else if (epsilon LT 0) then return,(1) $ + else return,( x GT 0 ) + endif else begin + if (epsilon GT 0) then return,( x + sqrt( x^2 + epsilon ) )/2 $ + else if (epsilon LT 0) then return, x $ + else return,( x > 0 ) + endelse +end diff --git a/modules/idl_downloads/astro/pro/precess.pro b/modules/idl_downloads/astro/pro/precess.pro new file mode 100644 index 0000000..e304799 --- /dev/null +++ b/modules/idl_downloads/astro/pro/precess.pro @@ -0,0 +1,163 @@ +pro precess, ra, dec, equinox1, equinox2, PRINT = print, FK4 = FK4, $ + RADIAN=radian +;+ +; NAME: +; PRECESS +; PURPOSE: +; Precess coordinates from EQUINOX1 to EQUINOX2. +; EXPLANATION: +; For interactive display, one can use the procedure ASTRO which calls +; PRECESS or use the /PRINT keyword. The default (RA,DEC) system is +; FK5 based on epoch J2000.0 but FK4 based on B1950.0 is available via +; the /FK4 keyword. +; +; Use BPRECESS and JPRECESS to convert between FK4 and FK5 systems +; CALLING SEQUENCE: +; PRECESS, ra, dec, [ equinox1, equinox2, /PRINT, /FK4, /RADIAN ] +; +; INPUT - OUTPUT: +; RA - Input right ascension (scalar or vector) in DEGREES, unless the +; /RADIAN keyword is set +; DEC - Input declination in DEGREES (scalar or vector), unless the +; /RADIAN keyword is set +; +; The input RA and DEC are modified by PRECESS to give the +; values after precession. +; +; OPTIONAL INPUTS: +; EQUINOX1 - Original equinox of coordinates, numeric scalar. If +; omitted, then PRECESS will query for EQUINOX1 and EQUINOX2. +; EQUINOX2 - Equinox of precessed coordinates. +; +; OPTIONAL INPUT KEYWORDS: +; /PRINT - If this keyword is set and non-zero, then the precessed +; coordinates are displayed at the terminal. Cannot be used +; with the /RADIAN keyword +; /FK4 - If this keyword is set and non-zero, the FK4 (B1950.0) system +; will be used otherwise FK5 (J2000.0) will be used instead. +; /RADIAN - If this keyword is set and non-zero, then the input and +; output RA and DEC vectors are in radians rather than degrees +; +; RESTRICTIONS: +; Accuracy of precession decreases for declination values near 90 +; degrees. PRECESS should not be used more than 2.5 centuries from +; 2000 on the FK5 system (1950.0 on the FK4 system). +; +; EXAMPLES: +; (1) The Pole Star has J2000.0 coordinates (2h, 31m, 46.3s, +; 89d 15' 50.6"); compute its coordinates at J1985.0 +; +; IDL> precess, ten(2,31,46.3)*15, ten(89,15,50.6), 2000, 1985, /PRINT +; +; ====> 2h 16m 22.73s, 89d 11' 47.3" +; +; (2) Precess the B1950 coordinates of Eps Ind (RA = 21h 59m,33.053s, +; DEC = (-56d, 59', 33.053") to equinox B1975. +; +; IDL> ra = ten(21, 59, 33.053)*15 +; IDL> dec = ten(-56, 59, 33.053) +; IDL> precess, ra, dec ,1950, 1975, /fk4 +; +; PROCEDURE: +; Algorithm from Computational Spherical Astronomy by Taff (1983), +; p. 24. (FK4). FK5 constants from "Astronomical Almanac Explanatory +; Supplement 1992, page 104 Table 3.211.1. +; +; PROCEDURE CALLED: +; Function PREMAT - computes precession matrix +; +; REVISION HISTORY +; Written, Wayne Landsman, STI Corporation August 1986 +; Correct negative output RA values February 1989 +; Added /PRINT keyword W. Landsman November, 1991 +; Provided FK5 (J2000.0) I. Freedman January 1994 +; Precession Matrix computation now in PREMAT W. Landsman June 1994 +; Added /RADIAN keyword W. Landsman June 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Correct negative output RA values when /RADIAN used March 1999 +; Work for arrays, not just vectors W. Landsman September 2003 +;- + On_error,2 ;Return to caller + + npar = N_params() + deg_to_rad = !DPI/180.0D0 + + if ( npar LT 2 ) then begin + + print,'Syntax - PRECESS, ra, dec, [ equinox1, equinox2,' + $ + ' /PRINT, /FK4, /RADIAN ]' + print,' NOTE: RA and DEC must be in DEGREES unless /RADIAN is set' + return + + endif else if (npar LT 4) then $ + read,'Enter original and new equinox of coordinates: ',equinox1,equinox2 + + npts = min( [N_elements(ra), N_elements(dec)] ) + if npts EQ 0 then $ + message,'ERROR - Input RA and DEC must be vectors or scalars' + array = size(ra,/N_dimen) GE 2 + if array then dimen = size(ra,/dimen) + + if ~keyword_set( RADIAN) then begin + ra_rad = ra*deg_to_rad ;Convert to double precision if not already + dec_rad = dec*deg_to_rad + endif else begin + ra_rad= double(ra) & dec_rad = double(dec) + endelse + + a = cos( dec_rad ) + + CASE npts of ;Is RA a vector or scalar? + + 1: x = [a*cos(ra_rad), a*sin(ra_rad), sin(dec_rad)] ;input direction + + else: begin + + x = dblarr(npts,3) + x[0,0] = reform(a*cos(ra_rad),npts,/over) + x[0,1] = reform(a*sin(ra_rad),npts,/over) + x[0,2] = reform(sin(dec_rad),npts,/over) + x = transpose(x) + end + + ENDCASE + + sec_to_rad = deg_to_rad/3600.d0 + +; Use PREMAT function to get precession matrix from Equinox1 to Equinox2 + + r = premat(equinox1, equinox2, FK4 = fk4) + + x2 = r#x ;rotate to get output direction cosines + + if npts EQ 1 then begin ;Scalar + + ra_rad = atan(x2[1],x2[0]) + dec_rad = asin(x2[2]) + + endif else begin ;Vector + + ra_rad = dblarr(npts) + atan(x2[1,*],x2[0,*]) + dec_rad = dblarr(npts) + asin(x2[2,*]) + + endelse + + if ~keyword_set(RADIAN) then begin + ra = ra_rad/deg_to_rad + ra = ra + (ra LT 0.)*360.D ;RA between 0 and 360 degrees + dec = dec_rad/deg_to_rad + endif else begin + ra = ra_rad & dec = dec_rad + ra = ra + (ra LT 0.)*2.0d*!DPI + endelse + + if array then begin + ra = reform(ra, dimen , /over) + dec = reform(dec, dimen, /over) + endif + + if keyword_set( PRINT ) then $ + print, 'Equinox (' + strtrim(equinox2,2) + '): ',adstring(ra,dec,1) + + return + end diff --git a/modules/idl_downloads/astro/pro/precess_cd.pro b/modules/idl_downloads/astro/pro/precess_cd.pro new file mode 100644 index 0000000..fbf071c --- /dev/null +++ b/modules/idl_downloads/astro/pro/precess_cd.pro @@ -0,0 +1,105 @@ +pro PRECESS_CD, cd, epoch1, epoch2, crval_old, crval_new, FK4 = FK4 +;+ +; NAME: +; PRECESS_CD +; +; PURPOSE: +; Precess the CD (coordinate description) matrix from a FITS header +; EXPLANATION: +; The CD matrix is precessed from EPOCH1 to EPOCH2. Called by HPRECESS +; +; CALLING SEQUENCE: +; PRECESS_CD, cd, epoch1, epoch2, crval_old, crval_new, [/FK4] +; +; INPUTS/OUTPUT: +; CD - 2 x 2 CD (coordinate description) matrix in any units +; (degrees or radians). CD will altered on output to contain +; precessed values in the same units. On output CD will always +; be double precision no matter how input. +; +; INPUTS: +; EPOCH1 - Original equinox of coordinates, scalar (e.g. 1950.0). +; EPOCH2 - Equinox of precessed coordinates, scalar (e.g. 2000.0) +; CRVAL_OLD - 2 element vector containing RA and DEC in DEGREES +; of the reference pixel in the original equinox +; CRVAL_NEW - 2 elements vector giving CRVAL in the new equinox +; +; INPUT KEYWORD: +; /FK4 - If this keyword is set, then the precession constants are taken +; in the FK4 reference frame. The default is the FK5 frame. +; +; RESTRICTIONS: +; PRECESS_CD should not be used more than 2.5 centuries from the +; year 1900. +; +; PROCEDURE: +; Adapted from the STSDAS program FMATPREC. Precession changes the +; location of the north pole, and thus changes the rotation of +; an image from north up. This is reflected in the precession of the +; CD matrix. This is usually a very small change. +; +; PROCEDURE CALLS: +; PRECESS +; +; REVISION HISTORY: +; Written, Wayne Landsman, ST Systems February 1988 +; Fixed sign error in computation of SINRA March 1992 +; Added /FK4 keyword Feb 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use B/Jprecess for conversion between 1950 and 2000 W.L. Aug 2009 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax: precess_cd, cd, epoch1, epoch2, crval_old, crval_new + return + endif + + deg_to_rad = !DPI/180.0D + crvalold = crval_old * deg_to_rad + crvalnew = crval_new * deg_to_rad + + sec_to_rad = deg_to_rad/3600.d0 + t = 0.001d0 * (epoch2-epoch1) + +; Compute C - inclination of the mean equator in the new equinox relative +; to that of the old equinox + + if keyword_set(FK4) then begin + + st = 0.001d0 * (epoch1-1900.d0) + + C = sec_to_rad * T * ( 20046.85D0 - ST*(85.33D0 + 0.37D0*ST) $ + + T*(-42.67D0 - 0.37D0*ST -41.8D0*T)) + + endif else begin + + st = 0.001d0*( epoch1 - 2000.d0) + + C = sec_to_rad * T * (20043.109D0 - ST*(85.33D0 + 0.217D0*ST) $ + + T*(-42.665D0 - 0.217D0*ST -41.833D0*T)) + endelse + +; Get RA of old pole in new coordinates + + pole_ra = 0. & pole_dec = 90.d ;Coordinates of old pole (RA is arbitrary) + if (epoch1 EQ 2000) && (epoch2 EQ 1950) then begin + bprecess, pole_ra, pole_dec,pra,pdec + pole_ra = pra + endif else if (epoch1 EQ 1950) and (epoch2 EQ 2000) then begin + bprecess, pole_ra, pole_dec,pra,pdec + pole_ra = pra + endif else precess, pole_ra, pole_dec, epoch1, epoch2, FK4 = FK4 + + sind1 = sin( crvalold[1] ) & sind2 = sin( crvalnew[1] ) + cosd1 = cos( crvalold[1] ) & cosd2 = cos( crvalnew[1] ) + sinra = sin( crvalnew[0] - pole_ra*deg_to_rad) ;Fixed sign error Mar-92 + cosfi = (cos(c) - sind1*sind2)/( cosd1*cosd2 ) + sinfi = ( abs(sin(c) ) * sinra) / cosd1 + r = [ [cosfi, sinfi], [-sinfi, cosfi] ] + + cd = r # cd ;Rotate to new north pole + + return + end diff --git a/modules/idl_downloads/astro/pro/precess_xyz.pro b/modules/idl_downloads/astro/pro/precess_xyz.pro new file mode 100644 index 0000000..0180130 --- /dev/null +++ b/modules/idl_downloads/astro/pro/precess_xyz.pro @@ -0,0 +1,63 @@ +pro precess_xyz,x,y,z,equinox1,equinox2 +;+ +; NAME: +; PRECESS_XYZ +; +; PURPOSE: +; Precess equatorial geocentric rectangular coordinates. +; +; CALLING SEQUENCE: +; precess_xyz, x, y, z, equinox1, equinox2 +; +; INPUT/OUTPUT: +; x,y,z: scalars or vectors giving heliocentric rectangular coordinates +; THESE ARE CHANGED UPON RETURNING. +; INPUT: +; EQUINOX1: equinox of input coordinates, numeric scalar +; EQUINOX2: equinox of output coordinates, numeric scalar +; +; OUTPUT: +; x,y,z are changed upon return +; +; NOTES: +; The equatorial geocentric rectangular coords are converted +; to RA and Dec, precessed in the normal way, then changed +; back to x, y and z using unit vectors. +; +;EXAMPLE: +; Precess 1950 equinox coords x, y and z to 2000. +; IDL> precess_xyz,x,y,z, 1950, 2000 +; +;HISTORY: +; Written by P. Plait/ACC March 24 1999 +; (unit vectors provided by D. Lindler) +; Use /Radian call to PRECESS W. Landsman November 2000 +; Use two parameter call to ATAN W. Landsman June 2001 +;- +;check inputs + if N_params() NE 5 then begin + print,'Syntax - PRECESS_XYZ,x,y,z,equinox1,equinox2' + return + endif + +;take input coords and convert to ra and dec (in radians) + + ra = atan(y,x) + del = sqrt(x*x + y*y + z*z) ;magnitude of distance to Sun + dec = asin(z/del) + +; precess the ra and dec + precess, ra, dec, equinox1, equinox2, /Radian + +;convert back to x, y, z + xunit = cos(ra)*cos(dec) + yunit = sin(ra)*cos(dec) + zunit = sin(dec) + + x = xunit * del + y = yunit * del + z = zunit * del + + return + end + diff --git a/modules/idl_downloads/astro/pro/premat.pro b/modules/idl_downloads/astro/pro/premat.pro new file mode 100644 index 0000000..63b055b --- /dev/null +++ b/modules/idl_downloads/astro/pro/premat.pro @@ -0,0 +1,92 @@ +function premat, equinox1, equinox2, FK4 = FK4 +;+ +; NAME: +; PREMAT +; PURPOSE: +; Return the precession matrix needed to go from EQUINOX1 to EQUINOX2. +; EXPLANTION: +; This matrix is used by the procedures PRECESS and BARYVEL to precess +; astronomical coordinates +; +; CALLING SEQUENCE: +; matrix = PREMAT( equinox1, equinox2, [ /FK4 ] ) +; +; INPUTS: +; EQUINOX1 - Original equinox of coordinates, numeric scalar. +; EQUINOX2 - Equinox of precessed coordinates. +; +; OUTPUT: +; matrix - double precision 3 x 3 precession matrix, used to precess +; equatorial rectangular coordinates +; +; OPTIONAL INPUT KEYWORDS: +; /FK4 - If this keyword is set, the FK4 (B1950.0) system precession +; angles are used to compute the precession matrix. The +; default is to use FK5 (J2000.0) precession angles +; +; EXAMPLES: +; Return the precession matrix from 1950.0 to 1975.0 in the FK4 system +; +; IDL> matrix = PREMAT( 1950.0, 1975.0, /FK4) +; +; PROCEDURE: +; FK4 constants from "Computational Spherical Astronomy" by Taff (1983), +; p. 24. (FK4). FK5 constants from "Astronomical Almanac Explanatory +; Supplement 1992, page 104 Table 3.211.1. +; +; REVISION HISTORY +; Written, Wayne Landsman, HSTX Corporation, June 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 ;Return to caller + + npar = N_params() + + if ( npar LT 2 ) then begin + + print,'Syntax - PREMAT, equinox1, equinox2, /FK4]' + return,-1 + + endif + + deg_to_rad = !DPI/180.0d + sec_to_rad = deg_to_rad/3600.d0 + + t = 0.001d0*( equinox2 - equinox1) + + if ~keyword_set( FK4 ) then begin + st = 0.001d0*( equinox1 - 2000.d0) +; Compute 3 rotation angles + A = sec_to_rad * T * (23062.181D0 + ST*(139.656D0 +0.0139D0*ST) $ + + T*(30.188D0 - 0.344D0*ST+17.998D0*T)) + + B = sec_to_rad * T * T * (79.280D0 + 0.410D0*ST + 0.205D0*T) + A + + C = sec_to_rad * T * (20043.109D0 - ST*(85.33D0 + 0.217D0*ST) $ + + T*(-42.665D0 - 0.217D0*ST -41.833D0*T)) + + endif else begin + + st = 0.001d0*( equinox1 - 1900.d0) +; Compute 3 rotation angles + + A = sec_to_rad * T * (23042.53D0 + ST*(139.75D0 +0.06D0*ST) $ + + T*(30.23D0 - 0.27D0*ST+18.0D0*T)) + + B = sec_to_rad * T * T * (79.27D0 + 0.66D0*ST + 0.32D0*T) + A + + C = sec_to_rad * T * (20046.85D0 - ST*(85.33D0 + 0.37D0*ST) $ + + T*(-42.67D0 - 0.37D0*ST -41.8D0*T)) + + endelse + + sina = sin(a) & sinb = sin(b) & sinc = sin(c) + cosa = cos(a) & cosb = cos(b) & cosc = cos(c) + + r = dblarr(3,3) + r[0,0] = [ cosa*cosb*cosc-sina*sinb, sina*cosb+cosa*sinb*cosc, cosa*sinc] + r[0,1] = [-cosa*sinb-sina*cosb*cosc, cosa*cosb-sina*sinb*cosc, -sina*sinc] + r[0,2] = [-cosb*sinc, -sinb*sinc, cosc] + + return,r + end diff --git a/modules/idl_downloads/astro/pro/prime.pro b/modules/idl_downloads/astro/pro/prime.pro new file mode 100644 index 0000000..490916e --- /dev/null +++ b/modules/idl_downloads/astro/pro/prime.pro @@ -0,0 +1,81 @@ +;------------------------------------------------------------- +;+ +; NAME: +; PRIME +; PURPOSE: +; Return an array with the specified number of prime numbers. +; EXPLANATATION: +; This procedure is similar to PRIMES in the standard IDL distribution, +; but stores results in a common block, and so is much faster +; +; CALLING SEQUENCE: +; p = prime(n) +; INPUTS: +; n = desired number of primes, scalar positive integer +; OUTPUTS: +; p = resulting array of primes, vector of positive integers +; COMMON BLOCKS: +; prime_com +; NOTES: +; Note: Primes that have been found in previous calls are +; remembered and are not regenerated. +; MODIFICATION HISTORY: +; R. Sterner 17 Oct, 1985. +; R. Sterner, 5 Feb, 1993 --- fixed a bug that missed a few primes. +; Converted to IDL V5 March 1999 +; +; Copyright (C) 1985, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +;- +;------------------------------------------------------------- + + function prime,n, help=hlp + + common prime_com, max, pmax + + if (n_params(0) lt 1) or keyword_set(hlp) then begin + print,' Return an array with the specified number of prime numbers.' + print,' p = prime(n)' + print,' n = desired number of primes. in' + print,' p = resulting array of primes. out' + print,' Note: Primes that have been found in previous calls are' + print,' remembered and are not regenerated.' + return, -1 + endif + + if n_elements(max) eq 0 then max = 0 ; Make MAX defined. + if n le max then return, pmax[0:n-1] ; Enough primes in memory. + p = lonarr(n) ; Need to find primes. + if max eq 0 then begin ; Have none now. Start with 8. + p[0] = [2,3,5,7,11,13,17,19] + if n le 8 then return, p[0:n-1] ; Need 8 or less. + i = 8 ; Need more than 8. + t = 19L ; Search start value. + endif else begin ; Start with old primes. + p[0] = pmax ; Move old primes into big arr. + i = max ; Current prime count. + t = p[max-1] ; Biggest prime so far. + endelse + +loop: if i eq n then begin ; Have enough primes. + max = n ; Count. + pmax = p ; Array of primes. + return, p ; Return primes. + endif +loop2: t = t + 2 ; Next test value, t. + it = 1 ; Start testing with 1st prime. +loop3: pr = p[it] ; Pick next test prime. + pr2 = pr*pr ; Square it. + if pr2 gt t then begin ; Selected prime > sqrt(t)? + i = i + 1 ; Yes, count + p[i-1] = t ; and store new prime. + goto, loop ; Go check if done. + endif + if pr2 eq t then goto, loop2 ; Test number, t, was a square. + if (t mod pr) eq 0 then goto, loop2 ; Curr prime divides t. + it = it + 1 ; Check next prime. + goto, loop3 + end diff --git a/modules/idl_downloads/astro/pro/print_struct.pro b/modules/idl_downloads/astro/pro/print_struct.pro new file mode 100644 index 0000000..9271a6e --- /dev/null +++ b/modules/idl_downloads/astro/pro/print_struct.pro @@ -0,0 +1,245 @@ +;+ +; NAME: +; PRINT_STRUCT +; +; PURPOSE: +; Print the tag values of an array of structures in nice column format. +; EXPLANATION: +; The tag names are displayed in a header line. +; +; CALLING SEQUENCE: +; print_struct, structure, Tags_to_print [ , title, string_matrix +; FILE=, LUN_OUT=, TNUMS= , TRANGE= , FRANGE=, WHICH= +; FORM_FLOAT =, MAX_ELEMENTS +; INPUTS: +; structure = array of structured variables +; +; Tags_to_print = string array specifying the names of tags to print. +; Default is to print all tags which are not arrays. +; OPTIONAL INPUT KEYWORDS: +; FILE = string, optional file name to which output will then be written. +; LUN_OUT = Logical unit number for output to an open file, +; default is to print to standard output. +; TNUMS = tag numbers to print (alternative to specifying tag names). +; TRANGE = [beg,end] tag number range to print. +; FRANGE = same as TRANGE. +; WHICH = optional array of subscripts to select +; which structure elements to print. +; FORM_FLOAT = string array of three elements specifying +; floating point format, ex: FORM=['f','9','2'] means "(F9.2)", +; (default float format is G12.4). +; MAX_ELEMENTS = positive integer, print only tags that have less than +; this number of elements (default is no screening). +; /NO_TITLE - If set, then the header line of tag names is not printed +; /STRINGS : instead of printing, return the array of strings in +; fourth argument of procedure: string_matrix. +; OUTPUTS: +; title = optional string, list of tags printed/processed. +; string_matrix = optional output of string matrix of tag values, +; instead of printing to terminal or file, if /STRINGS. +; PROCEDURE: +; Check the types and lengths of fields to decide formats, +; then loop and form text string from requested fields, then print. +; HISTORY: +; Written: Frank Varosi NASA/GSFC 1991. +; F.V.1993, fixed up the print formats. +; F.V.1994, added more keyword options. +; F.V.1997, added WHICH and MAX_ELEM keyword options. +; WBL 1997, Use UNIQ() rather than UNIQUE function +; Remove call to N_STRUCT() W. Landsman March 2004 +; Avoid overflow with more than 10000 elements W. Landsman Nov 2005 +; Really remove call to N_STRUCT() W. Landsman July 2009 +;- + +pro print_struct, structure, Tags_to_print, title, string_matrix, TNUMS=tagi, $ + FRANGE=fran, TRANGE=tran, FILE=filout, LUN_OUT=Lun, $ + STRINGS=strings, FORM_FLOAT=formf, NO_TITLE=no_tit, $ + WHICH_TO_PRINT=which, MAX_ELEMENTS=max_elements + + compile_opt idl2 + if N_params() LT 1 then begin + print, $ + 'Syntax - PRINT_STRUCT, structure, Tags_to_print [ ,title, string_matrix' + print,' FILE=, LUN_OUT=, TNUMS= , TRANGE= , FRANGE=, WHICH= ' + print,' FORM_FLOAT =, MAX_ELEMENTS, /NO_TITLE' + return + end + + + if size(structure,/TNAME) NE 'STRUCT' then begin + message,"ERROR - expecting a structure",/INFO + return + endif + ;Use size(/N_Elements) instead of N_elements() so it can work with assoc + ;variables + Nstruct = size(structure,/N_elements) + Ntag = N_tags(structure) + + if Nstruct EQ 1 then structure = [structure] + + tags = [tag_names( structure )] + Npr = N_elements( Tags_to_print ) + if N_elements( tran ) EQ 2 then fran = tran + + if N_elements( tagi ) GT 0 then begin + + tagi = ( tagi > 0 ) < (Ntag-1) + tagi = tagi[ uniq( sort(tagi) ) ] + + endif else if N_elements( fran ) EQ 2 then begin + + fran = ( fran > 0 ) < (Ntag-1) + nf = abs( fran[1] - fran[0] )+1 + tagi = indgen( nf ) + min( fran ) + + endif else if (Npr LE 0) then begin + + for i=0,Ntag-1 do begin + + if (N_elements( structure[0].(i) ) LE 1) AND $ + (N_tags( structure[0].(i) ) LE 0) then begin + + if N_elements( tagi ) LE 0 then tagi = [i] $ + else tagi = [ tagi, i ] + endif + endfor + + endif else begin + + ptags = [strupcase( Tags_to_print )] + + for i=0,Npr-1 do begin + + w = where( tags EQ ptags[i], nf ) + + if (nf GT 0) then begin + + if N_elements( tagi ) LE 0 then tagi = [w[0]] $ + else tagi = [ tagi, w[0] ] + + endif else message,"Tag <"+ptags[i]+"> not found",/INFO + endfor + endelse + + if N_elements( tagi ) LE 0 then begin + message,"requested Tags are not in structure",/INFO + return + endif + + if keyword_set( max_elements ) then begin + + Ntag = N_elements( tagi ) + Ntel = Lonarr( Ntag ) + Ntst = intarr( Ntag ) + + for i=0,Ntag-1 do begin + Ntel[i] = N_elements( structure[0].(tagi[i]) ) + Ntst[i] = N_tags( structure[0].(tagi[i]) ) + endfor + + w = where( (Ntel LE max_elements) and (Ntst LE 0), nw ) + + if (nw GT 0) then tagi = tagi[w] else begin + message,"requested Tags have too many elements",/INFO + return + endelse + endif + + ndigit = ceil(alog10(Nstruct)) ;Number of digits in index + iform = "(I" + strtrim(ndigit,2) + ")" + if ndigit GT 1 then $ + title = string(replicate(32b,ndigit-1)) else title='' + title = title + '#' + + Tags_to_print = tags[tagi] + Npr = N_elements( tagi ) + vtypes = intarr( Npr ) + sLens = intarr( Npr ) + formats = strarr( Npr ) + ncht = strlen( Tags_to_print ) + 2 + minch = [ 0, 5, 8, 12, 12, 12, 12, 0 ] + + for i=0,Npr-1 do begin + st = size( structure[0].(tagi[i]) ) + vtypes[i] = st[st[0]+1] + CASE vtypes[i] OF + 1: formats[i] = "I" + strtrim( ncht[i]>5, 2 ) + ")" + 2: formats[i] = "I" + strtrim( ncht[i]>8, 2 ) + ")" + 3: formats[i] = "I" + strtrim( ncht[i]>12, 2 ) + ")" + 7: BEGIN + sLens[i] = $ + ( max( strlen( structure.(tagi[i]) ) ) + 2 ) > ncht[i] + formats[i] = "A" + strtrim( sLens[i], 2 ) + ")" + END + else: BEGIN + if N_elements( formf ) EQ 3 then begin + formf = strtrim( formf, 2 ) + ndig = fix( formf[1] ) + minch[4] = ndig + formats[i] = formf[0] + $ + strtrim( ncht[i] > ndig, 2 ) + $ + "." + formf[2] + ")" + endif else $ + formats[i] = "G" + strtrim( ncht[i]>12, 2 ) + ".4)" + END + ENDCASE + nelem = st[st[0]+2] + formats[i] = "(" + strtrim( nelem, 2 ) + formats[i] + minch[7] = sLens[i] + nb = nelem * ( ncht[i] > minch[vtypes[i]] ) - ncht[i] + 2 + title = title + string( replicate( 32b,nb ) ) + Tags_to_print[i] + endfor + + if N_elements( which ) GT 0 then begin + w = where( (which GE 0) AND (which LT Nstruct), nw ) + if (nw LE 0) then begin + message,"keyword WHICH subscripts out of range",/INFO + return + endif + which = which[w] + Nprint = nw + endif else begin + which = lindgen( Nstruct ) + Nprint = Nstruct + endelse + + pr_tit = keyword_set( no_tit ) EQ 0 + + if keyword_set( strings ) then begin + string_matrix = strarr( Npr, Nprint ) + title = strmid( title, 3, 999 ) + endif else begin + if keyword_set( filout ) then openw, Lun, filout,/GET_LUN + if (pr_tit) then begin + if (Nstruct LE 3) then title = strmid( title, 3, 999 ) + if N_elements( Lun ) EQ 1 then printf,Lun,title $ + else print,title + endif + endelse + + for n=0,Nprint-1 do begin + + wp = which[n] + + if keyword_set( strings ) then begin + + for i=0,Npr-1 do string_matrix[i,n] = $ + string( structure[wp].(tagi[i]), FORM=formats[i] ) + + endif else begin + + if (pr_tit) AND (Nstruct GT 3) then $ + text = string( wp,FORM=iform ) else text="" + + for i=0,Npr-1 do text = text + $ + string( structure[wp].(tagi[i]), FORM=formats[i] ) + + if N_elements( Lun ) EQ 1 then printf,Lun,text else print,text + endelse + endfor + + if keyword_set( filout ) then begin + free_Lun, Lun + message,"structure printed into file: " + filout,/INFO + endif +end diff --git a/modules/idl_downloads/astro/pro/prob_ks.pro b/modules/idl_downloads/astro/pro/prob_ks.pro new file mode 100644 index 0000000..43df32d --- /dev/null +++ b/modules/idl_downloads/astro/pro/prob_ks.pro @@ -0,0 +1,70 @@ +pro prob_ks, D, N_eff, probks +;+ +; NAME: +; PROB_KS +; PURPOSE: +; Return the significance of the Kolmogoroff-Smirnov statistic +; EXPLANATION: +; Returns the significance level of an observed value of the +; Kolmogorov-Smirnov statistic D for an effective number of data points +; N_eff. Called by KSONE and KSTWO +; +; CALLING SEQUENCE: +; prob_ks, D, N_eff, probks +; +; INPUT PARAMETERS: +; D - Kolmogorov statistic, floating scalar, always non-negative +; N_eff - Effective number of data points, scalar. For a 2 sided test +; this is given by (N1*N2)/(N1+N2) where N1 and N2 are the number +; of points in each data set. +; +; OUTPUT PARAMETERS: +; probks - floating scalar between 0 and 1 giving the significance level of +; the K-S statistic. Small values of PROB suggest that the +; distribution being tested are not the same +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; Corrected typo (termbv for termbf) H. Ebeling/W.Landsman March 1996 +; Probably did not affect numeric result, but iteration went longer +; than necessary +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - prob_ks, D, N_eff, prob' + print,' D - Komolgorov-Smirnov statistic, input' + print,' N_eff - effective number of data points, input' + print,' prob - Significance level of D, output' + return + endif + + eps1 = 0.001 ;Stop if current term less than EPS1 times previous term + eps2 = 1.e-8 ;Stop if current term changes output by factor less than EPS2 + + en = sqrt( N_eff ) + lambda = (en + 0.12 + 0.11/en)*D + + a2 = -2.*lambda^2 + probks = 0. + termbf = 0. + sign = 1. + + for j = 1,100 do begin + + term = sign*2*exp(a2*j^2) + probks = probks + term + + if ( abs(term) LE eps1*termbf ) or $ + ( abs(term) LE eps2*probks ) then return + + sign = -sign ;Series alternates in sign + termbf = abs(term) + + endfor + + probks = 1. ;Sum did not converge after 100 iterations + return + + end diff --git a/modules/idl_downloads/astro/pro/prob_kuiper.pro b/modules/idl_downloads/astro/pro/prob_kuiper.pro new file mode 100644 index 0000000..25c13f9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/prob_kuiper.pro @@ -0,0 +1,76 @@ +pro prob_kuiper, D, N_eff, probks +;+ +; NAME: +; PROB_KUIPER +; PURPOSE: +; Return the significance of the Kuiper statistic +; EXPLANATION: +; Returns the significance level of an observed value of the +; Kuiper statistic D for an effective number of data points +; N_eff. Called by KUIPERONE +; +; CALLING SEQUENCE: +; prob_kuiper, D, N_eff, probks +; +; INPUT PARAMETERS: +; D - Kuiper statistic, floating scalar, always non-negative +; N_eff - Effective number of data points, scalar. For a 2 sided test +; this is given by (N1*N2)/(N1+N2) where N1 and N2 are the number +; of points in each data set. +; +; OUTPUT PARAMETERS: +; probks - floating scalar between 0 and 1 giving the significance level of +; the Kuiper statistic. Small values of PROB suggest that the +; distribution being tested are not the same +; +; REVISION HISTORY: +; Written W. Landsman August, 1992 +; Corrected typo (termbv for termbf) H. Ebeling/W.Landsman March 1996 +; Probably did not affect numeric result, but iteration went longer +; than necessary +; Converted to IDL V5.0 W. Landsman September 1997 +; Adapted from PROB_KS J. Ballet July 2003 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - prob_kuiper, D, N_eff, prob' + print,' D - Kuiper statistic, input' + print,' N_eff - effective number of data points, input' + print,' prob - Significance level of D, output' + return + endif + + eps1 = 0.001 ;Stop if current term less than EPS1 times previous term + eps2 = 1.e-8 ;Stop if current term changes output by factor less than EPS2 + + en = sqrt( N_eff ) + lambda = (en + 0.155 + 0.24/en)*D + +; No iteration if lambda is smaller than 0.4 + if lambda le 0.4 then begin + probks = 1.0 + return + endif + + a2 = -2.*lambda^2 + probks = 0. + termbf = 0. + + for j = 1,100 do begin + + a2j2 = a2 * j^2 + term = 2 * (-2*a2j2-1) * exp(a2j2) + probks = probks + term + + if ( abs(term) LE eps1*termbf ) or $ + ( abs(term) LE eps2*probks ) then return + + termbf = abs(term) + + endfor + + probks = 1. ;Sum did not converge after 100 iterations + return + + end diff --git a/modules/idl_downloads/astro/pro/psf_gaussian.pro b/modules/idl_downloads/astro/pro/psf_gaussian.pro new file mode 100644 index 0000000..1c0b94d --- /dev/null +++ b/modules/idl_downloads/astro/pro/psf_gaussian.pro @@ -0,0 +1,190 @@ +function psf_gaussian, parameters, NPIXEL=npixel, NDIMENSION=ndim, FWHM=fwhm, $ + DOUBLE = double, CENTROID=cntrd, ST_DEV=st_dev, $ + XY_CORREL=xy_corr, NORMALIZE=normalize +;+ +; NAME: +; PSF_GAUSSIAN +; +; PURPOSE: +; Create a 1-d, 2-d, or 3-d Gaussian with specified FWHM, center +; EXPLANATION: +; Return a point spread function having Gaussian profiles, +; as either a 1D vector, a 2D image, or 3D volumetric-data. +; +; CALLING SEQUENCE: +; psf = psf_Gaussian( NPIXEL=, FWHM= , CENTROID = +; [ /DOUBLE, /NORMALIZE, ST_DEV=, NDIMEN= ] ) +; or: +; psf = psf_Gaussian( parameters, NPIXEL = ,NDIMEN = ) +; +; REQUIRED INPUT KEYWORD: +; NPIXEL = number pixels for each dimension, specify as an array, +; or just one number to make all sizes equal. +; +; OPTIONAL KEYWORDS: +; CENTROID = floating scalar or vector giving position of PSF center. +; default is exact center of requested vector/image/volume. +; The number of elements in CENTROID should equal the number of +; dimensions. **The definition of Centroid was changed in +; March 2002, and now an integer defines the center of a pixel.** +; +; /DOUBLE = If set, then the output array is computed in double precision +; the default is to return a floating point array. +; +; FWHM = the desired Full-Width Half-Max (pixels) in each dimension, +; specify as an array, or single number to make all the same. +; +; NDIMEN = integer dimension of result: either 1 (vector), 2 (image), or +; 3 (volume), default = 2 (an image result). +; +; /NORMALIZE causes resulting PSF to be normalized so Total( psf ) = 1. +; +; ST_DEV = optional way to specify width by standard deviation param. +; Ignored if FWHM is specified. +; +; XY_CORREL = scalar between 0 and 1 specifying correlation coefficient +; Use this keyword, for example, to specify an elliptical +; Gaussian oriented at an angle to the X,Y axis. Only valid +; for 2-dimensional case. +; +; +; INPUTS (optional): +; +; parameters = an NDIMEN by 3 array giving for each dimension: +; [ maxval, center, st_dev ], overrides other keywords. +; +; EXAMPLE: +; (1) Create a 31 x 31 array containing a normalized centered Gaussian +; with an X FWHM = 4.3 and a Y FWHM = 3.6 +; +; IDL> array = PSF_GAUSSIAN( Npixel=31, FWHM=[4.3,3.6], /NORMAL ) +; +; (2) Create a 50 pixel 1-d Gaussian vector with a maximum of 12, +; centered at pixel 23 with a sigma of 19.2 +; +; IDL> psf = psf_gaussian([12,23,19.2],npixel=50) +; EXTERNAL CALLS: +; function Gaussian() +; NOTES: +; To improve speed, floating underflow exceptions are suppressed (using +; the MASK=32 keyword of CHECK_MATH() rather than being flagged. +; +; HISTORY: +; Written, Frank Varosi NASA/GSFC 1991. +; Suppress underflow messages, add DOUBLE keyword. **Modified centroid +; definition so integer position is pixel center** W. Landsman March 2002 +; Allow use of the ST_DEV (not STDEV) keyword W. Landsman Nov. 2002 +; Do not modify NPIXEL input keyword W. Landsman +;- + On_error,2 + compile_opt idl2 + + if (N_params() LT 1 ) and $ + ~(keyword_set( FWHM) || keyword_set(ST_DEV)) then begin + print,'Syntax - psf = PSF_GAUSSIAN( parameters, NPIXEL = )' + print, $ + 'or psf = PSF_GAUSSIAN( FWHM = ,ST_DEV = ,NPIXEL = ,[CENTROID = ])' + return, -1 + endif + + sp = size( parameters ) + if sp[0] EQ 1 then begin ;Vector supplied? + ndim = 1 + factor = parameters[0] + cntrd = parameters[1] + st_dev = parameters[2] + endif else if (sp[0] GE 1) then begin ;Ndimen x 3 array supplied? + ndim = sp[1] + factor = total( parameters[*,0] )/float( ndim ) + cntrd = parameters[*,1] + st_dev = parameters[*,2] + endif + + double = keyword_set(double) + if double then idltype = 5 else idltype = 4 + if N_elements( ndim ) NE 1 then ndim=2 + ndim = ndim>1 + + if N_elements( npixel ) LE 0 then begin + message,"must specify size of result with NPIX=",/INFO + return,(-1) + endif else begin + npix = npixel + if N_elements( npix ) LT ndim then npix = replicate( npix[0], ndim ) + endelse + + if (N_elements( cntrd ) LT ndim) && (N_elements( cntrd ) GT 0) then $ + cntrd = replicate( cntrd[0], ndim ) + + if N_elements( cntrd ) LE 0 then cntrd=(npix-1)/2. + if N_elements( fwhm ) GT 0 then begin + st_dev = fwhm/( 2.0d* sqrt( 2.0d* aLog(2.0d) ) ) + if ~double then st_dev = float(st_dev) + endif + + if N_elements( st_dev ) LE 0 then begin + message,"must specify ST_DEV= or FWHM=",/INFO + return,(-1) + endif + + if N_elements( st_dev ) LT ndim then $ + st_dev = replicate( st_dev[0], ndim ) + + CASE ndim OF + + 1: BEGIN + x = findgen( npix[0] ) - cntrd[0] + psf = gaussian( x, [1,0,st_dev] ) + END + + 2: BEGIN + psf = make_array( DIM=npix[0:ndim-1], TYPE = idltype ) + x = make_array( npix[0], /INDEX, TYPE=idltype ) - cntrd[0] + y = make_array( npix[1], /INDEX, TYPE=idltype ) - cntrd[1] + + if N_elements( xy_corr ) EQ 1 then begin + sigfac = 1 / (2. * st_dev^2 ) + y2 = sigfac[1] * y^2 + x1 = sigfac[0] * x + yc = y * ( xy_corr/(st_dev[0]*st_dev[1]) ) + for j=0,npix[1]-1 do begin + zz = x * (yc[j] + x1) + y2[j] + w = where( zz LT 86, nw ) + if (nw GT 0) then psf[w,j] = exp( -zz[w] ) + endfor + endif else begin + psfx = gaussian( x, [ 1, 0, st_dev[0] ], DOUBLE=double ) + psfy = gaussian( y, [ 1, 0, st_dev[1] ], DOUBLE=double ) + error = check_math(/print, MASK=32) + save_except = !EXCEPT & !EXCEPT = 0 + for j=0,npix[1]-1 do psf[0,j] = psfx * psfy[j] + error = check_math(MASK=32) ;Clear floating underflow + !EXCEPT = save_except + endelse + END + + 3: BEGIN + psf = make_array( DIM=npix[0:ndim-1], TYPE = idltype ) + x = make_array( npix[0], /INDEX, TYPE=idltype ) - cntrd[0] + y = make_array( npix[1], /INDEX, TYPE=idltype ) - cntrd[1] + z = make_array( npix[2], /INDEX, TYPE=idltype ) - cntrd[2] + psfx = gaussian( x, [ 1, 0, st_dev[0] ], DOUBLE = double ) + psfy = gaussian( y, [ 1, 0, st_dev[1] ], DOUBLE = double) + psfz = gaussian( z, [ 1, 0, st_dev[2] ], DOUBLE = double ) + error = check_math(MASK=32,/PRINT) + save_except = !EXCEPT & !EXCEPT = 0 + for k=0,npix[2]-1 do begin + for j=0,npix[1]-1 do psf[0,j,k] = psfx * psfy[j] * psfz[k] + endfor + error = check_math(MASK=32) + !EXCEPT = save_except + END + + ENDCASE + + if keyword_set( normalize ) then return, psf/total( psf ) + + if N_elements( factor ) EQ 1 then begin + if (factor NE 1) then return,factor*psf else return,psf + endif else return, psf +end diff --git a/modules/idl_downloads/astro/pro/putast.pro b/modules/idl_downloads/astro/pro/putast.pro new file mode 100644 index 0000000..947aa48 --- /dev/null +++ b/modules/idl_downloads/astro/pro/putast.pro @@ -0,0 +1,489 @@ +pro putast, hdr, astr, crpix, crval, ctype, EQUINOX=equinox, $ + CD_TYPE = cd_type, ALT = alt, NAXIS = naxis +;+ +; NAME: +; PUTAST +; PURPOSE: +; Put WCS astrometry parameters into a given FITS header. +; +; CALLING SEQUENCE: +; putast, hdr ;Prompt for all values +; or +; putast, hdr, astr, [EQUINOX =, CD_TYPE =, ALT= , NAXIS=] +; or +; putast, hdr, cd,[ crpix, crval, ctype], [ EQUINOX =, CD_TYPE =, ALT= ] +; +; INPUTS: +; HDR - FITS header, string array. HDR will be updated to contain +; the supplied astrometry. +; ASTR - IDL structure containing values of the astrometry parameters +; CDELT, CRPIX, CRVAL, CTYPE, LONGPOLE, and PV2 +; See EXTAST.PRO for more info about the structure definition +; or +; CD - 2 x 2 array containing the astrometry parameters CD1_1 CD1_2 +; CD2_1 CD2_2 +; in units of DEGREES/PIXEL +; CRPIX - 2 element vector giving X and Y coord of reference pixel +; BE SURE THE COORDINATES IN CRPIX ARE GIVEN IN FITS STANDARD +; (e.g. first pixel in image is [1,1] ) AND NOT IDL STANDARD +; (first pixel in image is [0,0] +; CRVAL - 2 element vector giving R.A. and DEC of reference pixel +; in degrees +; CTYPE - 2 element string vector giving projection types for the two axes. +; For example, to specify a tangent projection one should set +; ctype = ['RA---TAN','DEC--TAN'] +; +; Fields added for version 2: +; .PV1 - Vector of projection parameters associated with longitude axis +; .AXES - 2 element integer vector giving the FITS-convention axis +; numbers associated with astrometry, in ascending order. +; Default [1,2]. +; .REVERSE - byte, true if first astrometry axis is Dec/latitude +; .COORDSYS - 1 or 2 character code giving coordinate system, including +; 'C' = RA/Dec, 'G' = Galactic, 'E' = Ecliptic, 'X' = unknown. +; .RADECSYS - String giving RA/Dec system e.g. 'FK4', 'ICRS' etc. +; .EQUINOX - Double giving the epoch of the mean equator and equinox +; .DATEOBS - Text string giving (start) date/time of observations +; .MJDOBS - Modified julian date of start of observations. +; .X0Y0 - Not written to header. +; +; +; OUTPUTS: +; HDR - FITS header now contains the updated astrometry parameters +; A brief HISTORY record is also added. +; +; OPTIONAL KEYWORD INPUTS: +; ALT - single character 'A' through 'Z' or ' ' specifying an alternate +; astrometry system to write in the FITS header. The default is +; to write primary astrometry or ALT = ' '. If /ALT is set, +; then this is equivalent to ALT = 'A'. See Section 3.3 of +; Greisen & Calabretta (2002, A&A, 395, 1061) for information about +; alternate astrometry keywords. +; +; +; CD_TYPE - Integer scalar, either 0, 1 or 2 specifying how the CD matrix +; is to be written into the header +; (0) write PCn_m values along with CDELT values +; (1) convert to rotation and write as a CROTA2 value (+ CDELT) +; (2) as CDn_m values (IRAF standard) +; +; All three forms are valid representations according to Greisen & +; Calabretta (2002, A&A, 395, 1061), also available at +; http://fits.gsfc.nasa.gov/fits_wcs.html ) although form (0) is +; preferred. Form (1) is the former AIPS standard and is now +; deprecated and cannot be used if any skew is present. +; If CD_TYPE is not supplied, PUTAST will try to determine the +; type of astrometry already in the header. If there is no +; astrometry in the header then the default is CD_TYPE = 2. +; +; EQUINOX - numeric scalar giving the year of equinox of the reference +; coordinates. Keyword value takes precedence over value in +; astrometry structure which takes precedence over value in +; header; if none of these present then default is 2000. +; +; NAXIS - By default, PUTAST does not update the NAXIS keywords in the +; FITS header. If NAXIS is set, and an astrometry structure is +; supplied then the NAXIS1 and NAXIS2 keywords in the FITS header +; will be updated with the .NAXIS structure tags values. If an +; astrometry structure is not supplied, then one can set NAXIS to a +; two element vector to update the NAXIS1, NAXIS2 keywords. +; NOTES: +; The recommended use of this procedure is to supply an astrometry +; structure. This can be produced with MAKE_ASTR. +; +; If parameters are supplied by keyword, the full range of +; astrometry header info is not supported by PUTAST. +; +; PUTAST does not delete astrometry parameters already present in the +; header, unless they are explicity overwritten. +; +; If present in the astrometry structure, PUTAST will add SIP +; ( http://fits.gsfc.nasa.gov/registry/sip.html ) or TPV +; ( http://fits.gsfc.nasa.gov/registry/tpvwcs.html ) distortion parameters +; to a FITS header. +; PROMPTS: +; If only a header is supplied, the user will be prompted for a plate +; scale, the X and Y coordinates of a reference pixel, the RA and +; DEC of the reference pixel, the equinox of the RA and Dec and a +; rotation angle. +; +; PROCEDURES USED: +; ADD_DISTORT, GETOPT(), GET_COORDS, GET_EQUINOX(), SXADDPAR, SXPAR(), +; TAG_EXIST(), ZPARCHECK +; REVISION HISTORY: +; Written by W. Landsman 9-3-87 +; Major rewrite, use new astrometry structure March, 1994 +; Use both CD and CDELT to get plate scale for CD_TYPE=1 September 1995 +; Use lower case for FITS keyword Comments W.L. March 1997 +; Fixed for CD_TYPE=1 and CDELT = [1.0,1.0] W.L September 1997 +; Default value of CD_TYPE is now 2, Use GET_COORDS to read coordinates +; to correct -0 problem W.L. September 1997 +; Update CROTA1 if it already exists W.L. October 1997 +; Convert rotation to degrees for CD_TYPE = 1 W. L. June 1998 +; Accept CD_TYPE = 0 keyword input W.L October 1998 +; Remove reference to obsolete !ERR W.L. February 2000 +; No longer support CD001001 format, write default tangent CTYPE value +; consistent conversion between CROTA and CD matrix W.L. October 2000 +; Use GET_EQUINOX to get equinox value W.L. January 2001 +; Update CTYPE keyword if previous value is 'LINEAR' W.L. July 2001 +; Use SIZE(/TNAME) instead of DATATYPE() W.L. November 2001 +; Allow direct specification of CTYPE W.L. June 2002 +; Don't assume celestial coordinates W. Landsman April 2003 +; Make default CD_TYPE = 2 W. Landsman September 2003 +; Add projection parameters, e.g. PV2_1, PV2_2 if present in the +; input structure W. Landsman May 2004 +; Correct interactive computation of image center W. Landsman Feb. 2005 +; Don't use CROTA (CD_TYPE=1) if a skew exists W. Landsman May 2005 +; Added NAXIS keyword W. Landsman January 2007 +; Update PC matrix, if CD_TYPE=0 and CD matrix supplied W.L. July 2007 +; Don't write PV2 keywords for WCS types that don't use it W.L. Aug 2011 +; Add SIP distortion parameters if present W.L. April 2012 +; Work if empty distortion structure present W.L. November 2012 +; Spurious error message introduced April 2012 if CD matrix rather +; than structure supplied W.L. January 2013 +; Allow for version 2 astrometry structure J. P. Leahy July 2013 +; Bug fix in interactive use JPL Aug 2013. +; Support IRAF TNX projection M. Sullivan U. of Southamptom March 2014 +; PV1_3, PV1_4 keywords take precedence over LONPOLE, LATPOLE keywords +; WL, August 2014 +; Fix typo spelling RADECSYS, don't use LONPOLE, LATPOLE in PV keywords when +; TPV projection WL December 2015 +;- + + compile_opt idl2 + npar = N_params() + + if ( npar EQ 0 ) then begin ;Was header supplied? + print,'Syntax: PUTAST, Hdr, astr, [ EQUINOX= , CD_TYPE=, ALT= ,/NAXIS]' + print,' or' + print,'Syntax: PUTAST, Hdr, [ cd, crpix, crval, EQUINOX = , CD_TYPE =]' + return + endif + + RADEG = 180.0d/!DPI + ax = ['1','2'] ; Default axis numbers + astr2 = 0B ; Assume input astronomy structure (if any) is version 1. + ; will be updated if not. + + zparcheck, 'PUTAST', hdr, 1, 7, 1, 'FITS image header' + if N_elements(alt) EQ 0 then alt = '' else if (alt EQ '1') then alt = 'a' + + if ( npar EQ 1 ) then begin ;Prompt for astrometry parameters? + ctype = strtrim(sxpar(hdr,'CTYPE*', Count = N_Ctype),2) + if (N_Ctype NE 2) || (ctype[0] EQ 'PIXEL') || (ctype[0] EQ 'LINEAR') then $ + ctype = ['RA---TAN','DEC--TAN'] + read,'Enter plate scale in arc seconds/pixel: ',cdelt + inp ='' + print,'Reference pixel position should be in FORTRAN convention' + print,'(First pixel has coordinate (1,1) )' + +GETCRPIX: print, $ + 'Enter X and Y position of a reference pixel ([RETURN] for plate center)' + read, inp + if ( inp EQ '' ) then $ + crpix = [ sxpar(hdr,'NAXIS1')+1, sxpar(hdr,'NAXIS2')+1] / 2. $ + else crpix = getopt( inp, 'F') + + if N_elements( crpix ) NE 2 then begin + print,'PUTAST: INVALID INPUT - Enter 2 scalar values' + goto, GETCRPIX + endif + +RD_CEN: + inp = '' + read,'Enter RA (hrs) and Dec (degrees) of reference pixel:',inp + GET_COORDS, crval,in=inp + if crval[0] EQ -999 then goto, rd_cen + + crval[0] = crval[0]*15. + + inp = '' + read,'Enter rotation angle in degrees, East of north [0.]: ',inp + rotat = getopt(inp,'F')/RADEG + cd = (cdelt / 3600.)*[[-cos(rotat),-sin(rotat)], [-sin(rotat), cos(rotat)]] + npar = 4 + endif else begin + + if size(astr,/TNAME) EQ 'STRUCT' then begin + ;User supplied astrometry structure + cd = astr.cd + cdelt = astr.cdelt + crval = astr.crval + crpix = astr.crpix + ctype = astr.ctype + if keyword_set(naxis) then if tag_exist(astr,'NAXIS') then $ + naxis = astr.naxis + longpole = astr.longpole + if tag_exist(astr,'latpole') then latpole = astr.latpole + if tag_exist(astr,'pv2') then pv2 = astr.pv2 + astr2 = TAG_EXIST(astr,'AXES') + IF astr2 THEN BEGIN ; version 2 astrometry structure + ax = STRTRIM(STRING(astr.axes),2) + IF N_ELEMENTS(equinox) EQ 0 THEN equinox = astr.equinox + ENDIF + endif else begin + cd = astr + zparcheck,'PUTAST', cd, 2, [4,5], 2, 'CD matrix' + endelse + endelse + + + ;Write NAXIS values + if N_elements(naxis) EQ 2 then begin + sxaddpar,hdr,'NAXIS'+ax[0],naxis[0],/SaveC + sxaddpar,hdr,'NAXIS'+ax[1],naxis[1],/SaveC + endif + +; Add CTYPE to FITS header + + if N_elements( ctype ) GE 2 then begin + + sxaddpar,hdr,'CTYPE'+ax[0]+alt,ctype[0],' Coordinate Type','HISTORY',/SaveC + sxaddpar,hdr,'CTYPE'+ax[1]+alt,ctype[1],' Coordinate Type','HISTORY',/SaveC + + endif + +; Add EQUINOX keyword and value to FITS header + + if N_elements( equinox ) EQ 0 then begin ;Is EQUINOX already in header? + equinox = get_equinox( hdr, code) + if code LT 0 then $ + sxaddpar, hdr, 'EQUINOX'+alt, 2000.0, ' Equinox of Ref. Coord.', $ + 'HISTORY',/SaveC + + endif else $ + sxaddpar,hdr, 'EQUINOX'+alt, equinox, 'Equinox of Ref. Coord.', 'HISTORY',/Sav + +; Add coordinate description (CD) matrix to FITS header +; 0. PCn_m keywords 1. CROTA + CDELT 2: CD1_1 + + + if (N_elements(cd_type) EQ 0) then begin + cd_type = 2 + pc1_1 = sxpar( hdr, 'PC'+ax[0]+'_'+ax[0]+alt, Count = N_PC) + if N_pc EQ 0 then begin + cd1_1 = sxpar( hdr, 'CD'+ax[0]+'_'+ax[0]+alt, Count = N_CD) + if N_CD EQ 0 then begin ; + CDELT1 = sxpar( hdr,'CDELT'+ax[0]+alt, COUNT = N_CDELT1) + if N_CDELT1 GE 1 then cd_type = 1 + endif + endif else cd_type = 0 + endif + +; If there is a skew then we can't use a simple CROTA representation + + if CD_TYPE EQ 1 then if abs(cd[1,0]) NE abs(cd[0,1]) then begin + cd_type = 0 + sxdelpar,hdr,['CROTA'+ax[0] + alt,'CROTA'+ax[1] + alt] + message,/INF,'Astrometry incompatible with a CROTA2 representation' + message,/INF,'Writing PC matrix instead' + endif + + + degpix = ' Degrees / Pixel' + + if cd_type EQ 0 then begin + + + sxaddpar, hdr, 'PC'+ax[0]+'_'+ax[0]+alt, cd[0,0], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'PC'+ax[1]+'_'+ax[0]+alt, cd[1,0], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'PC'+ax[0]+'_'+ax[1]+alt, cd[0,1], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'PC'+ax[1]+'_'+ax[1]+alt, cd[1,1], degpix, 'HISTORY',/SaveC + + if N_elements(cdelt) EQ 2 then begin + sxaddpar, hdr, 'CDELT'+ax[0]+alt, cdelt[0], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'CDELT'+ax[1]+alt, cdelt[1], degpix, 'HISTORY',/SaveC + endif + + endif else if cd_type EQ 2 then begin + + if N_elements(CDELT) GE 2 then if (cdelt[0] NE 1.0) then begin + cd[0,0] = cd[0,0]*cdelt[0] & cd[0,1] = cd[0,1]*cdelt[0] + cd[1,1] = cd[1,1]*cdelt[1] & cd[1,0] = cd[1,0]*cdelt[1] + endif + + + sxaddpar, hdr, 'CD'+ax[0]+'_'+ax[0]+alt, cd[0,0], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'CD'+ax[1]+'_'+ax[0]+alt, cd[1,0], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'CD'+ax[0]+'_'+ax[1]+alt, cd[0,1], degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'CD'+ax[1]+'_'+ax[1]+alt, cd[1,1], degpix, 'HISTORY',/SaveC + + endif else begin + + ; Programs should only look for CROTA2, but we also update CROTA1 if it + ; already exists. Also keep existing comment field if it exists. + + if N_elements(CDELT) GE 2 then begin + if cdelt[0] NE 1.0 then delt = cdelt + endif + + if N_elements(delt) EQ 0 then begin + det = cd[0,0]*cd[1,1] - cd[0,1]*cd[1,0] + if det LT 0 then sgn = -1 else sgn = 1 + delt = [sgn*sqrt(cd[0,0]^2 + cd[0,1]^2), $ + sqrt(cd[1,0]^2 + cd[1,1]^2) ] + endif + sxaddpar, hdr, 'CDELT'+ax[0]+alt, delt[0],degpix, 'HISTORY',/SaveC + sxaddpar, hdr, 'CDELT'+ax[1]+alt, delt[1],degpix, 'HISTORY',/SaveC + + if (cd[1,0] eq 0) and (cd[0,1] eq 0) then rot = 0.0 else $ + rot = float(atan( -cd[1,0],cd[1,1])*RADEG) + + crota2 = sxpar(hdr,'CROTA'+ax[1], Count = N_crota2) + if N_crota2 GT 0 then sxaddpar, hdr, 'CROTA2'+alt, rot else $ + sxaddpar, hdr, 'CROTA'+ax[1]+alt, rot, ' Rotation Angle (Degrees)' + crota1 = sxpar(hdr,'CROTA'+ax[0], Count = N_crota1) + if N_crota1 GT 0 then $ + sxaddpar, hdr, 'CROTA'+ax[0]+alt, rot + + + endelse + + hist = ' CD Matrix Written' + +; Add CRPIX keyword to FITS header + + if N_elements( crpix ) GE 2 then begin ;Add CRPIX vector? + + zparcheck, 'PUTAST', crpix, 3, [1,2,4,3,5], 1, 'CRPIX vector' + + sxaddpar, hdr, 'CRPIX'+ax[0]+alt, crpix[0], ' Reference Pixel in X', $ + 'HISTORY', /SaveC + sxaddpar, hdr, 'CRPIX'+ax[1]+alt ,crpix[1], ' Reference Pixel in Y', $ + 'HISTORY', /SaveC + + hist = ' CD and CRPIX parameters written' + endif + +; Add CRVAL keyword and values to FITS header. Convert CRVAL to double +; precision to ensure enough significant figures + + if N_elements( crval ) GE 2 then begin + comm = STRARR(2) + astrcode = astr2 ? astr.coord_sys : STRMID(ctype[0],0,1) + IF ~astr2 && STRMID(ctype[0],0,4) EQ 'RA--' THEN astrcode = 'C' + CASE astrcode OF + 'C': BEGIN + coord = 'Celestial' + comm[0] = ' R.A. (degrees) of reference pixel' + comm[1] = ' Declination of reference pixel' + END + 'G': coord = 'Galactic' + 'E': coord = 'Ecliptic' + 'S': coord = 'Supergalactic' + 'H': coord = 'Helioecliptic' + 'T': coord = 'Terrestrial' + 'X': coord = '' ; unknown system + ELSE: coord = astrcode + ENDCASE + IF astrcode NE 'C' THEN $ + comm = ' '+coord+[' longitude',' latitude']+' of reference pixel' + IF astr2 && astr.reverse THEN comm = REVERSE(comm) + zparcheck, 'PUTAST', crval, 3, [2,4,3,5], 1, 'CRVAL vector' + sxaddpar, hdr, 'CRVAL'+ax[0]+alt, double(crval[0]), comm[0], 'HISTORY' + sxaddpar, hdr, 'CRVAL'+ax[1]+alt, double(crval[1]), comm[1], 'HISTORY' + hist = ' World Coordinate System parameters written' + endif + +; We don't want to update PV keywords if they are being used for TPV projection + pv_update = ~tag_exist(astr,'DISTORT') || $ + (tag_exist(astr,'DISTORT') && astr.distort.name NE 'TPV') + + if N_elements(longpole) EQ 1 then begin + if pv_update then astr.pv1[3] = longpole + test = sxpar(hdr,'LONPOLE',count=N_lonpole) + if N_lonpole EQ 1 then $ + sxaddpar, hdr, 'LONPOLE' +alt ,double(longpole), $ + ' Native longitude of ' +coord + ' pole', 'HISTORY', /SaveC + endif + + if N_elements(latpole) EQ 1 then begin + if pv_update then astr.pv1[4] = latpole + test = sxpar(hdr,'LATPOLE',count=N_latpole) + if N_latpole EQ 1 then $ + sxaddpar, hdr, 'LATPOLE' +alt ,double(latpole), $ + ' Native latitude of ' +coord + ' pole', 'HISTORY', /SaveC + endif + + Npv2 = N_elements(pv2) + if Npv2 GT 0 then begin + ctyp = strmid(ctype[0],5,3) +; List of WCS types for which no PV2 values should be written + no_pv2 = ['TPV','TNX','TAN','ARC','STG','CAR','MER','SFL','PAR','MOL','AIT', $ + 'PC0','TSC','CSC','QSC' ] + if total(no_pv2 EQ ctyp,/int) EQ 0 then begin + pv2str = 'PV2_' + IF astr2 THEN $ + pv2str = 'PV'+(astr.reverse ? ax[0] : ax[1])+'_' ; Latitude axis PV + case ctyp of + 'ZPN': for i=0,npv2-1 do sxaddpar,hdr, pv2str + strtrim(i,2) + alt, $ + pv2[i],' Projection parameter ' + strtrim(i,2),'HISTORY',/SaveC + else: for i=0,npv2-1 do sxaddpar,hdr, pv2str + strtrim(i+1,2) + alt,$ + pv2[i],' Projection parameter ' + strtrim(i+1,2),'HISTORY',/SaveC + endcase + endif + endif + + IF astr2 THEN BEGIN + ctyp = strmid(ctype[0],5,3) +; List of WCS types for which no PV1 values should be written + no_pv1 = ['TPV','TNX','TAN'] + if total(no_pv1 EQ ctyp,/int) EQ 0 then begin + pv1str = 'PV'+(astr.reverse ? ax[1] : ax[0])+'_' ; Longitude axis PV + FOR i=0,4 DO SXADDPAR, hdr, pv1str + STRTRIM(i,2)+alt, $ + astr.pv1[i], ' Projection parameters', 'HISTORY', /SaveC + ENDIF + IF FINITE(astr.mjdobs) THEN SXADDPAR, hdr, 'MJD-OBS', astr.mjdobs, $ + ' Modified Julian day of observations', 'HISTORY', /SaveC + IF astr.dateobs NE 'UNKNOWN' THEN SXADDPAR, hdr, 'DATE-OBS', $ + astr.dateobs, ' Date of observations', 'HISTORY', /SaveC + IF astr.radecsys NE '' THEN SXADDPAR, hdr, 'RADECSYS'+alt, $ + astr.radecsys,' Reference frame', 'HISTORY', /SaveC + ENDIF + +;Add SIP distortion parameters if present + + if size(astr,/tname) EQ 'STRUCT' && tag_exist(astr,'DISTORT') then begin + if astr.distort.name EQ 'SIP' then begin +; First remove any SIP parameters in the FITS header. + nord = sxpar(hdr, 'A_Order',Count = N) + if (N GT 0) && (nord GT 0) then begin + key = '' + for i=0,nord do begin + for j=0,nord-i do begin + if i+j NE 0 then $ + key = [key, strtrim(i,2) + '_' + strtrim(j,2)] + endfor + endfor + key = key[1:*] + oldkey = ['A_' + key, 'B_' + key, 'AP_' + key,'BP_'+key] + sxdelpar,oldkey, hdr + endif + add_distort, hdr, astr + ENDIF ELSE IF astr.distort.name EQ 'TNX' then BEGIN + + ;; remove any existing WAT keywords + w=WHERE(STREGEX(hdr,'^WAT2_',/BOOLEAN,/FOLD),count,COMPLEMENT=w1) + IF(count GT 0)THEN hdr=hdr[w1] + w=WHERE(STREGEX(hdr,'^WAT1_',/BOOLEAN,/FOLD),count,COMPLEMENT=w1) + IF(count GT 0)THEN hdr=hdr[w1] + w=WHERE(STREGEX(hdr,'^WAT0_',/BOOLEAN,/FOLD),count,COMPLEMENT=w1) + IF(count GT 0)THEN hdr=hdr[w1] + ;; and add in the new ones + add_distort, hdr, astr + ENDIF ELSE IF astr.distort.name EQ 'TPV' then BEGIN + + FOR i=0,N_ELEMENTS(astr.pv1)-1 DO BEGIN + SXADDPAR, hdr, 'PV1_'+STRTRIM(i,2)+alt, astr.pv1[i] + ENDFOR + FOR i=0,N_ELEMENTS(astr.pv2)-1 DO BEGIN + SXADDPAR, hdr, 'PV2_'+STRTRIM(i,2)+alt, astr.pv2[i] + ENDFOR + + ENDIF + endif + + sxaddhist,'PUTAST: ' + strmid(systime(),4,20) + hist,hdr + + return + end diff --git a/modules/idl_downloads/astro/pro/qdcb_grid.pro b/modules/idl_downloads/astro/pro/qdcb_grid.pro new file mode 100644 index 0000000..432d767 --- /dev/null +++ b/modules/idl_downloads/astro/pro/qdcb_grid.pro @@ -0,0 +1,162 @@ +;+ +; NAME: +; QDCB_GRID +; +; PURPOSE: +; Produce an overlay of latitude and longitude lines over a plot or image +; EXPLANATION: +; Grid is plotted on the current graphics device assuming that the +; current plot is a map in the so called quad cube projection. The +; output plot range is assumed to go from 7.0 to -1.0 on the X axis and +; -3.0 to 3.0 on the Y axis. Within this plotting space, the quad cube +; faces are laid out as follows (X=Empty, Astronomical Layout shown - +; X axis can be swapped for geographic maps): +; +; 3.0_ +; XXX0 +; 4321 +; -3.0_XXX5 +; | | +; 7.0 -1.0 +; +; CATEGORY: +; Mapping Support Routine +; +; CALLING SEQUENCE: +; +; QDCB_GRID,[,DLONG,DLAT,[LINESTYLE=N,/LABELS] +; +; INPUT PARAMETERS: +; +; DLONG = Optional input longitude line spacing in degrees. If left +; out, defaults to 30. +; +; DLAT = Optional input lattitude line spacing in degrees. If left +; out, defaults to 30. +; +; +; OPTIONAL KEYWORD PARAMETERS: +; +; LINESTYLE = Optional input integer specifying the linestyle to +; use for drawing the grid lines. +; +; LABELS = Optional keyword specifying that the lattitude and +; longitude lines on the prime meridian and the +; equator should be labeled in degrees. If LABELS is +; given a value of 2, i.e. LABELS=2, then the longitude +; labels will be in hours and minutes instead of +; degrees. +; +; OUTPUT PARAMETERS: +; +; NONE +; +; PROCEDURE: +; +; Uses WCSSPH2XY.PRO with projection 23 ("QSC" - COBE Quadrilatieralized +; Spherical Cube) to compute positions of grid lines and labels. +; +; COPYRIGHT NOTICE: +; +; Copyright 1991, The Regents of the University of California. This +; software was produced under U.S. Government contract (W-7405-ENG-36) +; by Los Alamos National Laboratory, which is operated by the +; University of California for the U.S. Department of Energy. +; The U.S. Government is licensed to use, reproduce, and distribute +; this software. Neither the Government nor the University makes +; any warranty, express or implied, or assumes any liability or +; responsibility for the use of this software. +; +; AUTHOR: +; +; Jeff Bloch +; +; MODIFICATIONS/REVISION LEVEL: +; +; %I% %G% +; Use WCSSPH2XY instead of QDCB Wayne Landsman December 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + +PRO QDCB_GRID,DLONG,DLAT,LINESTYLE=N,LABELS=LABELS + + if not keyword_set(n) then n=0 + if n_params() lt 2 then dlat = 30.0 + if n_params() lt 1 then dlong = 30.0 +; +; Set up offsets to cube face panes +; + xfaceoff = [0.0,0.0,2.0,4.0,6.0,0.0] + yfaceoff = [2.0,0.0,0.0,0.0,0.0,-2.0] + face = 0 +; +; Do lines of constant longitude +; + lat=findgen(180)-90 + lng=fltarr(180) + lngtot = long(360.0/dlong) + for i=0,lngtot do begin + lng[*]=-180.0+(i*dlong) + wcssph2xy, lng, lat, x, y, 23,face = face,north=0.,south=0. + x = x/45. & y = y/45. + for k=0,5 do begin + j=where(face eq k,nf) + if nf ne 0 then $ + oplot,x[j]+xfaceoff[k],$ + y[j]+yfaceoff[k],linestyle=n + endfor + endfor +; +; Do lines of constant latitude +; + lng=findgen(360)-45.0 + lat=fltarr(360) + lattot=long(180.0/dlat) + for i=1,lattot do begin + lat[*]=-90+(i*dlat) + wcssph2xy, lng, lat, x, y, 23,face = face,north=0.,south=0. + x = x/45. & y = y/45. + for k=0,5 do begin + j=where(face eq k,nf) + if nf ne 0 then $ + oplot,x[j]+xfaceoff[k],$ + y[j]+yfaceoff[k],linestyle=n + endfor + endfor + +; +; Do labeling if requested +; + if keyword_set(labels) then begin +; +; Label equator +; + for i=0,lngtot-1 do begin + lng = (i*dlong) + if lng ne 0.0 then begin + wcssph2xy, lng, 0.0, x, y, 23, face = face,north=0.,south=0. + x = x/45. & y = y/45. + if labels eq 1 then xyouts,x[0]+xfaceoff[face],$ + y[0]+yfaceoff[face],noclip=0,$ + strcompress(string(lng,format="(I4)"),/remove_all) $ + else begin + tmp=sixty(lng*23.0/360.0) + xyouts,x[0]+xfaceoff[face[0]],y[0]+yfaceoff[face[0]],$ + noclip=0,strcompress(string(tmp[0],tmp[1],$ + format='(I2,"h",I2,"m")'),/remove_all),alignment=0.5 + endelse + endif + endfor +; +; Label prime meridian +; + for i=1,lattot-1 do begin + lat=-90+(i*dlat) + wcssph2xy, 0.0, lat, x, y, 23, face = face + x = x/45. & y = y/45. + xyouts,x[0]+xfaceoff[face[0]],y[0]+yfaceoff[face[0]],noclip=0,$ + strcompress(string(lat,format="(I4)"),/remove_all) + endfor + endif + return +END diff --git a/modules/idl_downloads/astro/pro/qget_string.pro b/modules/idl_downloads/astro/pro/qget_string.pro new file mode 100644 index 0000000..0b61592 --- /dev/null +++ b/modules/idl_downloads/astro/pro/qget_string.pro @@ -0,0 +1,89 @@ +FUNCTION qget_string, dummy +;+ +; NAME: +; QGET_STRING +; PURPOSE: +; To get a string from the keyboard without echoing it to the screen. +; +; CALLING SEQUENCE: +; string = QGET_STRING() +; +; INPUTS: +; None. +; +; OUTPUTS: +; string The string read from the keyboard. +; +; SIDE EFFECTS: +; A string variable is created and filled. +; +; PROCEDURE: +; The IDL GET_KBRD functions is used to get each character in +; the string. Each character is added to the string until a +; carriage return is struck. The carriage return is not appended +; to the string. Striking the delete key or the backspace key +; removes the previous character from the string. +; +; NOTES: +; For a widget password procedure see +; http://idlcoyote.com/tip_examples/password.pro +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 8 January 1991. +; Work for Mac and Windows IDL W. Landsman September 1995 +;- + compile_opt idl2 + +; Variable definitions. +; + st = bytarr(1) ; String variable. + n = 0 + + IF !VERSION.OS_FAMILY EQ "unix" THEN dun = 10B $ ; Unix version of CR. + ELSE dun = 13B ; All other version of CR. +wt = 1 ; Wait for key to be struck? +del = 127B & bs = 8B ; Delete, backspace keys. +; +; Loop, gathering characters into the string until +; a carriage return has been struck. +; +REPEAT BEGIN +; +; Get next character. +; + ch = byte(get_kbrd(wt)) + ch = ch[0] +; +; If it isn't a carriage return, process it. +; + IF (ch NE dun) THEN BEGIN +; +; If it isn't a delete or backspace, +; append it to the string. +; + IF ((ch NE del) && (ch NE bs)) THEN BEGIN + IF (n LE 0) THEN BEGIN + st[0] = ch + n = 1 + ENDIF ELSE BEGIN + st = [st, ch] + n++ + ENDELSE + ENDIF ELSE BEGIN +; +; It's a delete/backspace. Remove the +; previous character. +; + IF (n GT 0) THEN BEGIN + n-- + IF (n GT 0) THEN st = st[0:(n-1)] + ENDIF + ENDELSE + ENDIF +; +ENDREP UNTIL (ch EQ dun) +; +; Finished. +; +IF (n LE 0) THEN st = '' ELSE st = string(st) +RETURN, st +END diff --git a/modules/idl_downloads/astro/pro/qsimp.pro b/modules/idl_downloads/astro/pro/qsimp.pro new file mode 100644 index 0000000..3e57145 --- /dev/null +++ b/modules/idl_downloads/astro/pro/qsimp.pro @@ -0,0 +1,99 @@ +pro qsimp, func, A, B, S, EPS=eps, MAX_ITER = max_iter, _EXTRA = _EXTRA +;+ +; NAME: +; QSIMP +; PURPOSE: +; Integrate using Simpson's rule to specified accuracy. +; EXPLANATION: +; Integrate a function to specified accuracy using the extended +; trapezoidal rule. Adapted from algorithm in Numerical Recipes, +; by Press et al. (1992, 2nd edition), Section 4.2. This procedure +; has been partly obsolete since IDL V3.5 with the introduction of the +; intrinsic function QSIMP(), but see notes below. +; +; CALLING SEQUENCE: +; QSIMP, func, A, B, S, [ EPS = , MAX_ITER =, _EXTRA = ] +; +; INPUTS: +; func - scalar string giving name of function of one variable to +; be integrated +; A,B - numeric scalars giving the lower and upper bound of the +; integration +; +; OUTPUTS: +; S - Scalar giving the approximation to the integral of the specified +; function between A and B. +; +; OPTIONAL KEYWORD PARAMETERS: +; EPS - scalar specifying the fractional accuracy before ending the +; iteration. Default = 1E-6 +; MAX_ITER - Integer specifying the total number iterations at which +; QSIMP will terminate even if the specified accuracy has not yet +; been met. The maximum number of function evaluations will be +; 2^(MAX_ITER). Default value is MAX_ITER = 20 +; +; Any other keywords are passed directly to the user-supplied function +; via the _EXTRA facility. +; NOTES: +; (1) The function QTRAP is robust way of doing integrals that are not +; very smooth. However, if the function has a continuous 3rd derivative +; then QSIMP will likely be more efficient at performing the integral. +; +; (2) QSIMP can be *much* faster than the intrinsic QSIMP() function (as +; of IDL V8.2.3). This is because the intrinsic QSIMP() function only +; requires that the user supplied function accept a *scalar* variable. +; Thus on the the 16th iteration, the intrinsic QSIMP() makes 32,767 +; calls to the user function, whereas this procedure makes one call +; with a 32,767 element vector. Also, unlike the intrinsic QSIMP(), this +; procedure allows keywords in the user-supplied function. +; +; (3) Since the intrinsic QSIMP() is a function, and this file contains a +; procedure, there should be no name conflict. +; EXAMPLE: +; Compute the integral of sin(x) from 0 to !PI/3. +; +; IDL> QSIMP, 'sin', 0, !PI/3, S & print, S +; +; The value obtained should be cos(!PI/3) = 0.5 +; +; PROCEDURES CALLED: +; SETDEFAULTVALUE, TRAPZD, ZPARCHECK +; +; REVISION HISTORY: +; W. Landsman ST Systems Co. August, 1991 +; Continue after max iter warning message W. Landsman March, 1996 +; Pass keyword to function via _EXTRA facility W. Landsman July 1999 +; Use SETDEFAULTVALUE W. Landsman Aug 2013 +;- + + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - QSIMP, func, A, B, S, [ MAX_ITER = , EPS = ]' + print,' func - scalar string giving function name' + print,' A,B - endpoints of integration, S - output sum' + return + endif + + zparcheck, 'QSIMP', func, 1, 7, 0, 'Function name' ;Valid inputs? + zparcheck, 'QSIMP', A, 2, [1,2,3,4,5], 0, 'Lower limit of Integral' + zparcheck, 'QSIMP', B, 3, [1,2,3,4,5], 0, 'Upper limit of Integral' + + setdefaultvalue,eps,1.e-6 ;Typo fixed Oct 2013 + setdefaultvalue,max_iter,20 + + ost = (oS = -1.e30) + for i = 0,max_iter - 1 do begin + trapzd, func, A,B, st, it, _EXTRA = _EXTRA + S = (4.*st - ost)/3. + if ( abs(S-oS) LT eps*abs(oS) ) then return + os = s + ost = st + endfor + + message,/CON, $ + 'WARNING - Sum did not converge after '+ strtrim(max_iter,2) + ' steps' + + return + end diff --git a/modules/idl_downloads/astro/pro/qtrap.pro b/modules/idl_downloads/astro/pro/qtrap.pro new file mode 100644 index 0000000..22532d1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/qtrap.pro @@ -0,0 +1,84 @@ +pro qtrap, func, A, B, S, EPS=eps, MAX_ITER = max_iter, _EXTRA = _Extra +;+ +; NAME: +; QTRAP +; PURPOSE: +; Integrate using trapezoidal rule to specified accuracy. +; EXPLANATION: +; Integrate a function to specified accuracy using the extended +; trapezoidal rule. Adapted from Numerical Recipes (1992, 2nd edition), +; Section 4.2. +; +; CALLING SEQUENCE: +; QTRAP, func, A, B, S, [EPS = , MAX_ITER =, _EXTRA = ] +; +; INPUTS: +; func - scalar string giving name of function of one variable to +; be integrated +; A,B - numeric scalars giving the lower and upper bound of the +; integration +; +; OUTPUTS: +; S - Scalar giving the approximation to the integral of the specified +; function between A and B. +; +; OPTIONAL KEYWORD PARAMETERS: +; EPS - scalar specify the fractional accuracy before ending the +; iteration. Default = 1E-6 +; MAX_ITER - Integer specifying the total number iterations at which +; QTRAP will terminate even if the specified accuracy has not yet +; been met. The maximum number of function evaluations will +; be 2^(MAX_ITER). Default value is MAX_ITER = 20 +; +; Any other keywords are passed directly to the user-supplied function +; via the _EXTRA facility. +; NOTES: +; QTRAP is robust way of doing integrals that are not very smooth. If the +; function has a continuous 3rd derivative then the function QSIMP will +; likely be more efficient at performing the integral. +; EXAMPLE: +; Compute the integral of sin(x) from 0 to !PI/3. +; +; IDL> QTRAP, 'sin', 0, !PI/3, S & print,S +; +; The value obtained should be cos(!PI/3) = 0.5 +; +; PROCEDURES CALLED: +; TRAPZD, ZPARCHECK +; REVISION HISTORY: +; W. Landsman ST Systems Co. August, 1991 +; Continue after Max Iter warning message, W. Landsman March 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Pass keyword to function via _EXTRA facility W. Landsman July 1999 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - QTRAP, func, A, B, S, [ Eps = , MAX_ITER = ] + print,' func - scalar string giving function name + print,' A,B - endpoints of integration, S - output sum' + return + endif + + zparcheck, 'QTRAP', func, 1, 7, 0, 'Function name' ;Valid inputs? + zparcheck, 'QTRAP', A, 2, [1,2,3,4,5], 0, 'Lower limit of Integral' + zparcheck, 'QTRAP', B, 3, [1,2,3,4,5], 0, 'Upper limit of Integral' + + if ~keyword_set( EPS ) then eps = 1.e-6 + if ~keyword_set( MAX_ITER ) then max_iter = 20 + olds = -1.e30 + + for i = 0, max_iter-1 do begin + + trapzd, func, A, B, S, it, _EXTRA = _EXTRA + if ( abs(S-oldS) LT eps*abs(oldS) ) then return + olds = s + + endfor + + message,/CON, $ + 'WARNING - Sum did not converge after '+ strtrim(max_iter,2) + ' steps' + + return + end diff --git a/modules/idl_downloads/astro/pro/quadterp.pro b/modules/idl_downloads/astro/pro/quadterp.pro new file mode 100644 index 0000000..6f18f3b --- /dev/null +++ b/modules/idl_downloads/astro/pro/quadterp.pro @@ -0,0 +1,128 @@ +PRO quadterp, xtab, ytab, xint, yint, MISSING = MISSING +;+ +; NAME: +; QUADTERP +; PURPOSE: +; Quadratic interpolation of X,Y vectors onto a new X grid +; EXPLANATION: +; Interpolate a function Y = f(X) at specified grid points using an +; average of two neighboring 3 point quadratic (Lagrangian) interpolants. +; Use LINTERP for linear interpolation +; +; CALLING SEQUENCE: +; QUADTERP, Xtab, Ytab, Xint, Yint, [ MISSING = ] +; +; INPUT: +; Xtab - Vector (X TABle) containing the current independent variable +; Must be either monotonic increasing or decreasing +; Ytab - Vector (Y TABle) containing the dependent variable defined +; at each of the points of XTAB. +; Xint - Scalar or vector giving the values of X for which interpolated +; Y values are sought +; +; OUTPUT: +; Yint - Interpolated value(s) of Y, same number of points as Xint +; +; OPTIONAL INPUT KEYWORD: +; MISSING - Scalar specifying Yint value(s) to be assigned, when Xint +; value(s) are outside of the range of Xtab. Default is to +; truncate the out of range Yint value(s) to the nearest value +; of Ytab. See the help for the INTERPOLATE function. +; METHOD: +; 3-point Lagrangian interpolation. The average of the two quadratics +; derived from the four nearest points is returned in YTAB. A single +; quadratic is used near the end points. VALUE_LOCATE is used +; to locate center point of the interpolation. +; +; NOTES: +; QUADTERP provides one method of high-order interpolation. The +; RSI interpol.pro function includes the following alternatives: +; +; interpol(/LSQUADRATIC) - least squares quadratic fit to a 4 pt +; neighborhood +; interpol(/QUADRATIC) - quadratic fit to a 3 pt neighborhood +; interpol(/SPLINE) - cubic spline fit to a 4 pt neighborhood +; +; Also, the IDL Astro function HERMITE fits a cubic polynomial and its +; derivative to the two nearest points. +; RESTRICTIONS: +; Unless MISSING keyword is set, points outside the range of Xtab in +; which valid quadratics can be computed are returned at the value +; of the nearest end point of Ytab (i.e. Ytab[0] and Ytab[NPTS-1] ). +; +; EXAMPLE: +; A spectrum has been defined using a wavelength vector WAVE and a +; flux vector FLUX. Interpolate onto a new wavelength grid, e.g. +; +; IDL> wgrid = [1540.,1541.,1542.,1543.,1544.,1545.] +; IDL> quadterp, wave, flux, wgrid, fgrid +; +; FGRID will be a 5 element vector containing the quadratically +; interpolated values of FLUX at the wavelengths given in WGRID. +; +; EXTERNAL ROUTINES: +; ZPARCHECK +; REVISION HISTORY: +; 31 October 1986 by B. Boothman, adapted from the IUE RDAF +; 12 December 1988 J. Murthy, corrected error in Xint +; September 1992, W. Landsman, fixed problem with double precision +; August 1993, W. Landsman, added MISSING keyword +; June, 1995, W. Landsman, use single quadratic near end points +; Converted to IDL V5.0 W. Landsman September 1997 +; Fix occasional problem with integer X table, +; YINT is a scalar if XINT is a scalar W. Landsman Dec 1999 +; Use VALUE_LOCATE instead of TABINV W. Landsman Feb. 2000 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - QUADTERP, xtab, ytab, xint, yint, [ MISSING = ]' + return + endif + + zparcheck,'QUADTERP',xtab,1,[1,2,3,4,5],1,'Independent (X) vector' + zparcheck,'QUADTERP',ytab,2,[1,2,3,4,5],1,'Dependent (Y) vector' + + npts = min( [N_elements(xtab), N_elements(ytab) ] ) + m = n_elements(xint) + + if size(xtab,/TNAME) NE 'DOUBLE' then xt = float(xtab) else xt = xtab + + Xmin = min( [ Xtab[0],Xtab[npts-1] ], max = Xmax) + u = xint > Xmin < Xmax + + if npts LT 3 then $ + message,' ERROR - At least 3 points required for quadratic interpolation' + +; Determine index of data-points from which interpolation is made + + index = value_locate(xtab,xint) > 0L < (npts-2) + +; First quadratic + + i0 = (index-1) > 0 & i1 = i0+1 & i2 = (i1 +1) + x0 = xt[i0] & x1 = xt[i1] & x2 = xt[i2] + p1 = ytab[i0] * (u-x1) * (u-x2) / ((x0-x1) * (x0-x2)) + $ + ytab[i1] * (u-x0) * (u-x2) / ((x1-x0) * (x1-x2)) + $ + ytab[i2] * (u-x0) * (u-x1) / ((x2-x0) * (x2-x1)) + +; Second Quadratic + + i2 = (index+2) < (npts-1) & i1 = i2-1 & i0 = (i1-1) + x0 = xt[i0] & x1 = xt[i1] & x2 = xt[i2] + p2 = ytab[i0] * (u-x1) * (u-x2) / ((x0-x1) * (x0-x2)) + $ + ytab[i1] * (u-x0) * (u-x2) / ((x1-x0) * (x1-x2)) + $ + ytab[i2] * (u-x0) * (u-x1) / ((x2-x0) * (x2-x1)) + + + yint = (p1 + p2) / 2. ;Average of two quadratics + + if N_elements(missing) EQ 1 then begin + bad = where( (Xint LT Xmin) or (Xint GT Xmax ), Nbad) + if Nbad GT 0 then Yint[bad] = missing + endif + + + return + end diff --git a/modules/idl_downloads/astro/pro/query_irsa_cat.pro b/modules/idl_downloads/astro/pro/query_irsa_cat.pro new file mode 100644 index 0000000..5886516 --- /dev/null +++ b/modules/idl_downloads/astro/pro/query_irsa_cat.pro @@ -0,0 +1,258 @@ +FUNCTION query_irsa_cat, targetname_OR_coords, catalog=catalog, radius=radius, radunits=radunits, outfile=outfile, change_null=change_null, DEBUG=debug + +;+ +; NAME: +; QUERY_IRSA_CAT +; +; PURPOSE: +; Query a catalog in the NASA/IPAC Infrared Science Archive (IRSA) +; database by position or resolvable target name. +; +; EXPLANATION: +; Uses the IDL SOCKET command to provide a query of a catalog +; in the IRSA (http://irsa.ipac.caltech.edu/) database over the Web and +; return results in an IDL structure. If outfile is set, it saves +; the query as an IPAC table file. This can be slow for large query +; results, so only write a file if needed. +; +; CALLING SEQUENCE: +; info = query_irsa_cat(targetname_or_coords, [catalog=catalog, +; radius=radius, radunits=radunits, outfile=outfile, +; change_null=change_null, /DEBUG]) +; +; INPUTS: +; +; TARGETNAME_OR_COORDS - Either a string giving a resolvable target +; name (with J2000 coordinates determined by NED or SIMBAD), or a +; 2-element numeric vector giving the J2000 right ascension +; and declination, both in degrees. +; +; OPTIONAL INPUT: +; +; CATALOG - string giving the identifier of the IRSA catalog to be +; searched. The complete list of catalogs and identifier strings is available in +; XML format at: +; http://irsa.ipac.caltech.edu/cgi-bin/Gator/nph-scan?mode=xml +; or as an IPAC Table (ascii) at: +; http://irsa.ipac.caltech.edu/cgi-bin/Gator/nph-scan?mode=ascii +; +; In the table, the identifier string is in the "catname" column. +; +; If this keyword is omitted, the program will query the 2MASS point +; source catalog. +; +; Examples of current IRSA catalogs include: +; 'wise_allsky_4band_p3as_psd' - WISE All-Sky Source Catalog +; 'fp_psc' - 2MASS Point Source Catalog +; 'iraspsc' - IRAS Point Source Catalog v2.1 (PSC) +; 'irasfsc' - IRAS Faint Source Catalog v2.0 +; 'cosmos_ib_phot' - COSMOS Intermediate and Broad Band Photometry Catalog 2008 +; 'akari_irc' - Akari/IRC Point Source Catalogue +; +; RADIUS - scalar input of the radius of the search. By default it +; has a value of 60 arcsec. IRSA +; catalogs have maximum allowable search radii. These are listed on the corresponding +; web interface page for the catalog search, or in the nph-scan return table in the +; "coneradius" column. +; +; RADUNITS - string giving the units of the radius. By default it is 'arcsec'. +; +; OUTFILE - if present, the search results are written to a file with this name. +; +; CHANGE_NULL - a numeric value (input as integer) to put in the structure if the table uses a string for nulls. Default is -9999. +; +; DEBUG - /DEBUG provides some additional output. +; +; OUTPUTS: +; info - Anonymous IDL structure containing information on the catalog. The structure +; tag names are taken from the catalog column names. If no objects were found in +; the catalog, the structure values will be empty or zero. If any input parameter +; (e.g. catalog name) is invalid, the structure will have no +; content fields other than info.CREATED. +; +; If the query fails or is invalid, the function returns a value of -1. +; +; EXAMPLES: +; (1) Plot a histogram of the J magnitudes of all 2MASS +; point sources within 10 arcminutes of the center of the +; globular cluster M13. Save the IPAC table. +; +; IDL> info = query_irsa_cat('m13',radius=10,radunits='arcmin',outfile='save.tbl') +; IDL> help,/struct,info +; IDL> plothist,info.j_m,xran=[10,20] +; +; (2) Find the position of the faintest IRAS 60 micron +; source within 1 degree of central position of the +; COSMOS survey (10h00m28.6s +02d12m21.0s in J2000) +; +; IDL> info = query_irsa_cat([150.11917,2.205833], catalog='irasfsc', radius=1, radunits='deg') +; IDL> help,/struct,info +; IDL> idx = where(info.fnu_60 eq min(info.fnu_60)) +; IDL> print, (info.ra)[idx], (info.dec)[idx] +; +; PROCEDURES USED: +; READ_IPAC_VAR comes with query_irsa_cat.pro +; WEBGET(), VALID_NUM from IDLastro +; +; NOTES: +; The program writes an output IPAC table file only if the +; OUTFILE keyword is set. +; +; MODIFICATION HISTORY: +; Adapted from queryvizier.pro - H. Teplitz, IPAC September 2010 +; Removed requirement of writing/reading IPAC table file - +; T. Brooke, IPAC May 2011 +; Longer timeout for webget, added change_null - TYB June 2013 +;- + +;Copyright © 2013, California Institute of Technology +;All rights reserved. Based on Government Sponsored Research NAS7-03001 and NNN12AA01C. +; +; +;Redistribution and use in source and binary forms, with or without +;modification, are permitted provided that the following conditions +;are met: +; +; * Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; +; * 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. +; +; * Neither the name of the California Institute of Technology +; (Caltech) nor the names of its contributors may be used to +; endorse or promote products derived from this software without +; specific prior written permission. +; +;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +;BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +;OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED +;AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +;LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY +;WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;POSSIBILITY OF SUCH DAMAGE. +; + +on_error,2 +compile_opt idl2 + +if N_params() lt 1 then begin + print,'Syntax - info = query_irsa_cat(targetname_or_coords,' + print,' [catalog=catalog,radius=radius,radunits=radunits,' + print,' outfile=outfile,change_null=change_null,/DEBUG])' +endif + +IF NOT(keyword_set(radius)) THEN radius = 60 +IF NOT(keyword_set(radunits)) THEN radunits = 'arcsec' + +IF (keyword_set(outfile)) THEN BEGIN + writefile=outfile + check = file_search(writefile) + IF check NE '' THEN BEGIN + print, 'OUTFILE exists. Delete it [y/n]? ' + c2 = get_kbrd(1) + IF c2 EQ 'y' OR c2 EQ 'Y' THEN spawn, 'rm '+writefile $ + ELSE return, -1 + ENDIF +ENDIF + +IF ( keyword_set(change_null) ) THEN BEGIN + IF ( NOT(valid_num(change_null,/integer)) ) THEN BEGIN + print, 'ERROR: change null value must be integer.' + return, -1 + ENDIF + null_num = change_null +ENDIF + +;;;;;;;;;;;;;;;;;;; CONSTRUCT THE PARTS OF THE QUERY STRING + +root = 'http://irsa.ipac.caltech.edu/cgi-bin/Gator/nph-query' + +;;;; CATALOG STRING + +IF keyword_set(catalog) THEN catalog_name=catalog ELSE catalog_name='fp_psc' + +catstr='&catalog='+catalog_name + +;;;; OBJECT STRING + +target = targetname_OR_coords + +IF N_elements(target) EQ 2 THEN BEGIN + ra = double(target[0]) + dec = double(target[1]) + objstr = '&objstr='+strn(ra)+'+'+strn(dec) +ENDIF $ +ELSE BEGIN + object = repstr(target,'+','%2B') + object = repstr(strcompress(object),' ','+') + objstr = '&objstr='+object +ENDELSE + +; No empty string +IF strlen(objstr) le 8 THEN BEGIN + print, 'Empty object string not allowed.' + return, -1 +ENDIF + +;;;; SEARCH SHAPE AND SIZE + +spatial_str='Cone' +spatial_param_name=['radius','radunits'] +spatial_param_value_str = [strn(radius), radunits] + +nspat = n_elements(spatial_param_name) + +spatstr = '&spatial='+spatial_str +spatparstr = '' + +FOR i = 0l, nspat-1 DO $ + spatparstr=spatparstr+'&'+spatial_param_name[i]+'='+spatial_param_value_str[i] + +;;;; USE IPAC FORMAT + +out_fmt = '?outfmt=1' + +;;;; combine into query string + +url_q = root+out_fmt+objstr+spatstr+spatparstr+catstr +IF keyword_set(debug) THEN print, url_q + +;;;;; use the IDL WEBGET to do the HTTP GET + +IF keyword_set(debug) THEN print, systime(0) + +url_return = WEBGET(url_q, timeout=120) + +IF keyword_set(debug) THEN print, systime(0) + +;;;;; If requested, write the output to the outputfile + +IF (keyword_set(outfile)) THEN BEGIN + n = N_ELEMENTS(url_return.text) + OPENW, wunit, writefile, /get_lun + FOR i = 0l, n-1 DO PRINTF, wunit, (url_return.text)[i] + FREE_LUN, wunit +ENDIF + +;;;;; read the IPAC query into a structure + +textvar = url_return.text + +IF (keyword_set(change_null)) THEN $ + irsa_struct = read_ipac_var(textvar, change_null = null_num) $ +ELSE $ + irsa_struct = read_ipac_var(textvar) + +IF (n_tags(irsa_struct) eq 0) THEN print,'ERROR: unable to read results into structure.' + +return, irsa_struct + +END diff --git a/modules/idl_downloads/astro/pro/querydss.pro b/modules/idl_downloads/astro/pro/querydss.pro new file mode 100644 index 0000000..6b04de0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/querydss.pro @@ -0,0 +1,182 @@ +PRO QueryDSS, target, Image, Header, IMSIZE=ImSIze, ESO=eso, STSCI=stsci, $ + NED=ned, SURVEY = survey, OUTFILE = outfile, VERBOSE=verbose +;+ +; NAME: +; QueryDSS +; +; PURPOSE: +; Query the digital sky survey (DSS) on-line at the STSCI (or ESO) server +; +; EXPLANATION: +; The script can query the DSS survey and retrieve an image and FITS +; header either from the the Space Telescope Science Institute (STScI) or +; European Space Observatory (ESO) servers. +; See http://archive.eso.org/dss/dss and/or +; http://archive.stsci.edu/dss/index.html for details. +; +; CALLING SEQUENCE: +; QueryDSS, targetname_or_coords, Im, Hdr, [IMSIZE= , /ESO, Outfile= ] +; +; INPUTS: +; TARGETNAME_OR_COORDS - Either a scalar string giving a target name, +; (with J2000 coordinates determined by SIMBAD (default) or NED), or +; a 2-element numeric vector giving the J2000 right ascension in +; *degrees* and the target declination in degrees. +; +; OPTIONAL INPUTS: +; None +; +; OPTIONAL KEYWORD PARAMETERS: +; ImSize - Numeric scalar giving size of the image to be retrieved in +; arcminutes. Default is 10 arcminute. +; +; /ESO - Use the ESO server for image retrieval. Default is to use +; the STScI server +; +; /NED - Query the Nasa Extragalactic Database (NED) for the +; target's coordinates. The default is to use Simbad for +; the target search. +; +; OUTPUT - scalar string specifying name of output FITS file. +; If set, then the output IDL variables are not used. +; +; /STSCI - obsolete keyword, now does nothing, since STSCI is the default +; Server. +; +; SURVEY - Scalar string specifying which survey to retrieve. +; Possible values are +; '1' - First generation (red), this is the default +; '2b' - Second generation blue +; '2r' - Second generation red +; '2i' - Second generation near-infrared +; +; Note that 2nd generation images may not be available for all regions +; of the sky. Also note that the first two letters of the 'REGION' +; keyword in the FITS header gives the bandpass 'XP' - Red IIIaF, +; 'XJ' - Blue IIIaJ, 'XF' - Near-IR IVN +; +; /VERBOSE - If set, then the query sent to the DSS server is displayed +; +; OUTPUTS: +; Im - The image returned by the server. If there is an error, this +; contains a single 0. +; +; Hdr - The FITS header of the image. Empty string in case of errors. +; +; If the OutFile keyword is set then no outputs are returned (only the +; file is written). +; SIDE EFFECTS: +; If Im and Hdr exist in advance, they are overwritten. +; +; RESTRICTIONS: +; Relies on a working network connection. +; +; PROCEDURE: +; Construct a query-url, call WEBGET() and sort out the server's +; answer. +; +; EXAMPLE: +; Retrieve an 10' image surrounding the ultracompact HII region +; G45.45+0.06. Obtain the 2nd generation blue image. +; +; IDL> QueryDSS, 'GAL045.45+00.06', image, header, survey = '2b' +; IDL> tvscl, image +; IDL> hprint, header +; IDL> writefits,'dss_image.fits', image, header +; Note that the coordinates could have been specified directly, rather than +; giving the target name. +; IDL> QueryDSS, [288.587, 11.1510], image, header,survey='2b' +; +; To write a file directly to disk, use the OutFile keyword +; +; IDL> QueryDSS, [288.587, 11.1510], survey='2b', out='gal045_2b.fits' +; +; PROCEDURES CALLED: +; QUERYSIMBAD, WEBGET() +; MODIFICATION HISTORY: +; Written by M. Feldt, Heidelberg, Oct 2001 +; Option to supply target name instead of coords W. Landsman Aug. 2002 +; Added OUTFILE, /NED keywords W. Landsman April 2003 +; Don't abort on Simbad failure W. Landsman/J. Brauher June 2003 +; Added /VERBOSE keyword W. Landsman Jan 2009 +; Make /STScI server the default W. Landsman June 2010 +; Fix OUTPUT option W. Landsman June 2010 +; +;- + On_error,2 + compile_opt idl2 + if N_params() LT 1 then begin + print,'Syntax - QueryDSS, TargetName_or_coords, image, header' + print," [Imsize= ,/ESO, /STScI, Survey = ['1','2b','2r','2i'] " + print,' /NED, OutFile = ]' + return + endif + ;; + if N_elements(target) EQ 2 then begin + ra = float(target[0]) + dec = float(target[1]) + endif else begin + QuerySimbad, target, ra,dec, NED= ned, Found = Found + if found EQ 0 then begin + message,/inf,'Target name ' + target + $ + ' could not be translated by SIMBAD' + return + endif + endelse + IF ~Keyword_Set(ImSize) THEN ImSize = 10 + Equinox = 'J2000' + ;; + ;; + if N_elements(survey) EQ 0 then survey = '1' + dss = strlowcase(strtrim(strmid(survey,0,2),2)) + if keyword_set(ESO) then begin + case dss of + '1': dss = 'DSS1' + '2b': dss = 'DSS2-blue' + '2r': dss = 'DSS2-red' + '2i': dss = 'DSS2-infrared' + else: message,'Unrecognized Survey - should be 1, 2b, 2r or 2i' + endcase + endif + IF keyword_set(eso) THEN $ + QueryURL=strcompress("http://archive.eso.org/dss/dss/image?ra="+$ + string(RA)+$ + "&dec="+$ + string(DEC)+$ + "&x="+$ + string(ImSize)+$ + "&y="+$ + string(ImSize)+$ + "&Sky-Survey="+dss +"&mime-type=download-fits", /remove) $ + ELSE $ + QueryURL=strcompress("http://archive.stsci.edu/cgi-bin/dss_search?ra="+$ + string(RA)+$ + "& dec="+$ + string(DEC)+$ + "& equinox="+$ + Equinox +$ + "& height="+$ + string(ImSize) +$ + "&generation=" + dss +$ + "& width="+$ + string(ImSize)+$ + "& format=FITS", /remove) + ;; + + if keyword_set(verbose) then message,/INF, QueryURL + if keyword_set(OutFile) then begin + if ~keyword_set(ESO) then dss = 'DSS' + dss + message,'Writing ' + dss + ' FITS file ' + outfile,/inf + Result = webget(QueryURL, copyfile= outfile) + return + endif + Result = webget(QueryURL) + Image = Result.Image + Header = Result.ImageHeader + ;; + ;; error ? + ;; + IF N_Elements(Image) NE 1 THEN return + message, 'Problem retrieving your image! The server answered:', /info + print, Result.Text +END diff --git a/modules/idl_downloads/astro/pro/querygsc.pro b/modules/idl_downloads/astro/pro/querygsc.pro new file mode 100644 index 0000000..d59af6b --- /dev/null +++ b/modules/idl_downloads/astro/pro/querygsc.pro @@ -0,0 +1,192 @@ + +function Querygsc, target, dis,magrange = magrange, HOURS = hours, $ + VERBOSE=verbose, BOX = box +;+ +; NAME: +; QUERYGSC +; +; PURPOSE: +; Query the Guide Star Catalog (GSC V2.3.2) at STScI by position +; +; EXPLANATION: +; Uses the IDL SOCKET command to query the GSC 2.3.2 database over the Web. +; The number and names of the structure tags was changed in September 2015 +; +; Alternatively, (and more reliably) one can query the GSC 2.3.2 catalog using +; queryvizier.pro and the VIZIER database, e.g. +; IDL> st = queryvizier('GSC2.3',[23,35],10,/all) +; +; GSC2.3 is an all-sky export of calibrated photographic survey plate +; source parameters from the COMPASS database. The number of unique +; objects is approximately 945,592,683. All sources are +; from the second-generation plate-processing pipeline with the exception +; of Tycho-2 and Skymap sources in the case of very bright objects. The +; Skymap sources are exported when there is no matching GSC or Tycho +; sources. Each GSC 2.3 entry contains only one position and one +; magnitude per bandpass for each unique sky object +; +; CALLING SEQUENCE: +; info = QueryGSC(targetname_or_coords, [ dis, /HOURS] ) +; +; INPUTS: +; TARGETNAME_OR_COORDS - Either a scalar string giving a target name, +; (with J2000 coordinates determined by SIMBAD), or a 2-element +; numeric vector giving the J2000 right ascension in *degrees* (or +; hours if /HOURS is set) and the target declination in degrees. +; +; OPTIONAL INPUT: +; dis - Numeric scalar giving search radius in arcminutes to search around +; specified target Default is 5 arcminutes +; +; OPTIONAL INPUT KEYWORDS: +; +; /BOX - if set, then radius gives a box width in arcminutes +; /HOURS - If set, then the right ascension is both input and output (in +; the info .ra tag) in hours instead of degrees +; /VERBOSE - If set, then the CGI command to the Webserver will be displayed +;; +; OUTPUTS: +; info - IDL structure containing information on the GSC stars within the +; specified distance of the specified center. There are (currently) +; 48 tags in this structure -- for further information see +; http://gsss.stsci.edu/Catalogs/GSC/GSC2/gsc23/gsc23_release_notes.htm +; + +; .GSC2ID - GSC2 name +; .GSC1ID - GSC1 name +; .HSTID - GSC 2.3 name for HST operations +; .RA,.DEC - Position in degrees (double precision). RA is given in +; hours if the /HOURS keyword is set. +; .EPOCH - mean epoch of the observation +; .RAEPSILON, .DECEPSION - uncertainty (in arcseconds) in the RA and +; Dec +; .FPGMAG, .FPGERR, .FPGMAGCODE - mag, error, code in photographic F +; .JPGMAG, .JPGERR, .JPGMAGCODE - mag, error code, photographic J +; .VPGMAG, .VPGERR, .VPGMAGCODE - V mag, error, code +; .NPGMAG, .NPGERR, .NPGMAGCODE - mag, error, code +; .UMAG, .UERR, .UMAGCODE - magnitude, error, code +; .BMAG, .BERR, .BMAGCODE - magnitude, error, code +; .VMAG, .VERR, .VMAGCODE - magnitude, error, code +; .RMAG, .RERR, .RMAGCODE - magnitude, error, code +; .IMAG, .IERR, .IMAGCODE - magnitude, error, code +; .JMAG, .JERR, .JMAGCODE - magnitude, error, code +; .HMAG, .HERR, .HMAGCODE - magnitude, error, code +; .KMAG, .KERR, .KMAGCODE - magnitude, error, code +; .CLASS - classification (0-5): 0-star, 1-galaxy, 2-blend, +; .SEMIMAJORAXIS - semi-major axis in pixels +; .POSITIONANGLE - Position angle of extended objects in degrees +; 3-nonstar, 4-unclassified, 5-defect +; .SOURCESTATUS -10 digit field used to encode more detailed information +; about the properties of the catalog object. For more info, see +;http://www-gsss.stsci.edu/Catalogs/GSC/GSC2/gsc23/gsc23_release_notes.htm#ClassificationCodes +; .VARIABLEFLAG, MULTIPLEFLAG - Variability andd multiplicity flags +; COMPASSGSC2ID - Unique ID in the Compass database +; http://gsss.stsci.edu/zzzOldWebSite/compass/CompassHome.htm +; EXAMPLE: +; Plot a histogram of the photographic J magnitudes of all GSC 2.3.2 +; stars within 10 arcminutes of the center of the globular cluster M13 +; +; IDL> info = querygsc('M13',10) +; IDL> plothist,info.jpgmag,xran=[10,20] +; +; PROCEDURES USED: +; QUERYSIMBAD, RADEC, WEBGET() +; +; MODIFICATION HISTORY: +; Written by W. Landsman SSAI August 2002 +; Fixed parsing of RA and Dec W. Landsman September 2002 +; Major rewrite to use new STScI Web server, remove magrange +; keyword W. Landsman Dec 2007 +; Update server name, added /BOX,/ VERBOSE keywords W.L 19 Dec 2007 +; Web server now also returns infrared data W.L. Feb 2010 +; Fixed case where dec neg. and deg or min 0 Pat Fry Jul 2010 +; Updated for new server format W. Landsman April 2014 +; Updated for new server format W. Landsman September 2015 +; +;- + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - info = QueryGSC(targetname_or_coord, dis,' + print,' [/Hours, /Box, /VERBOSE} )' + print,' RA (degrees), Dec (degrees) -- search coordinates of center)' + print,' dis -- search radius in arcminutes' + if N_elements(info) GT 0 then return,info else return, -1 + endif + if N_elements(dis) EQ 0 then dis = 5 + if N_elements(target) EQ 2 then begin + ra = float(target[0]) + dec = float(target[1]) + endif else begin + QuerySimbad, target, ra,dec, Found = Found + if found EQ 0 then message,'Target name ' + target + $ + ' could not be translated by SIMBAD' + endelse + radius = keyword_set(box)? 'Box' : 'Radius' + + radec,ra,dec,hr,mn,sc,deg,dmn,dsc,hours=keyword_set(hours) + deg = string(deg,'(i3.2)') + dsn = strmid(deg,0,1) + deg = strmid(deg,1,2) + if (dmn lt 0 || dsc lt 0) then begin + dmn = abs(dmn) + dsc = abs(dsc) + dsn = '-' + endif + sc = round(sc) + dsc = round(dsc) + if dsn EQ ' ' then dsn = '%2B' + ;; + QueryURL = "http://gsss.stsci.edu/webservices/vo/CatalogSearch.aspx?" + $ + 'RA=' + strtrim(ra,2) + '&Dec=' + strtrim(dec,2) + $ + '&SR=' + strtrim(dis/60.,2) + $ + '&FORMAT=CSV&CAT=GSC23' + + + if keyword_set(verbose) then print,queryurl + ;; + Result = webget(QueryURL) + ; + t = result.text + + nstar = N_elements(t) -2 + if strmid(t[0],0,5) NE 'Usage' and nstar GT 0 THEN BEGIN + headers = strsplit(t[1],',',/extract) + + info = create_struct(Name='gsc',headers, 0LL,'','','', $ + 0.0d,0.0d, 0.0,0.0,0.0, $ + 0.0, 0.0, 0, $ ;Fpgmag,Err,code + 0.0, 0.0, 0, $ ;Jpgmag,Err,code + 0.0, 0.0, 0, $ ;Vmag,Err,code + 0.0, 0.0, 0, $ ;Nmag,Err,code + 0.0, 0.0, 0, $ ;Umag,Err,code + 0.0, 0.0, 0, $ ;Bmag,Err,code + 0.0, 0.0, 0, $ ;Rmag,Err,code + 0.0, 0.0, 0, $ ;Imag,Err,code + 0.0, 0.0, 0, $ ;Jmag,Err,code + 0.0, 0.0, 0, $ ;Hmag,Err,code + 0.0, 0.0, 0, $ ;Kmag,Err,code + 0, $ ;Classification + 0., $ ;Size + 0., 0., 0LL, $ eccentricity, positionangle, objectflags + 0, 0 , $ ;variable, Multiple flag + 0LL, '' ) + + + + info = replicate(info,nstar) + + for i=0,nstar-1 do begin + temp = strtrim(strsplit(t[i+2],',',/extract),2) + for j=0,N_elements(temp)-1 do begin + info[i].(j) = temp[j] + endfor + endfor + ENDIF ELSE BEGIN + message, 'No objects returned by server. The server answered:', /info + print, Result.Text + if N_elements(info) GT 0 then return, info else return, -1 + ENDELSE + if keyword_set(hours) then info.ra = info.ra/15.0d + return,info +END + diff --git a/modules/idl_downloads/astro/pro/querysimbad.pro b/modules/idl_downloads/astro/pro/querysimbad.pro new file mode 100644 index 0000000..70fd6c3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/querysimbad.pro @@ -0,0 +1,200 @@ +PRO QuerySimbad, name, ra, de, id, Found = found, NED = ned, ERRMSG = errmsg, $ + Verbose = verbose, CADC = cadc, CFA=cfa, Server=server, SILENT=silent, $ + Print = print,Vmag=Vmag,Jmag=Jmag,Hmag=Hmag,Kmag=Kmag,parallax=parallax +;+ +; NAME: +; QUERYSIMBAD +; +; PURPOSE: +; Query the SIMBAD/NED/Vizier astronomical name resolver to obtain coordinates +; +; EXPLANATION: +; Uses the IDL SOCKET command to query either the SIMBAD or NED nameserver +; over the Web to return J2000 coordinates. By default, QuerySimbad +; first queries the Simbad database, then (if no match found) the NED +; database, and then the Vizier database. +; +; For details on the SIMBAD service, see http://simbad.u-strasbg.fr/Simbad +; and for the NED service, see http://ned.ipac.caltech.edu/ +; +; CALLING SEQUENCE: +; QuerySimbad, name, ra, dec, [ id, Found=, /NED, /CADC, ERRMSG=, /VERBOSE] +; /PRINT, Vmag=V, Jmag=J, Hmag=H, Kmag=Kmag, parallax=parallax +; +; INPUTS: +; name - a scalar string containing the target name in SIMBAD (or NED) +; nomenclature. For SIMBAD details see +; http://vizier.u-strasbg.fr/cgi-bin/Dic-Simbad . +; +; OUTPUTS: +; ra - Right ascension of the target in J2000.0 in *degrees*, scalar +; dec - declination of the target in degrees, scalar +; +; OPTIONAL INPUT KEYWORD: +; /CFA - if set, then use the Simbad server at the Center for Astrophysics +; rather than the default server in Strasbourg, France. +; ERRMSG = If defined and passed, then any error messages will be +; returned to the user in this parameter rather than +; depending on the MESSAGE routine in IDL. If no errors are +; encountered, then a null string is returned. +; /NED - if set, then only the nameserver of the NASA Extragalactic database +; is used to resolve the name and return coordinates. Note that +; /NED cannot be used with Galactic objects +; /VERBOSE - If set, then the HTTP-GET command is displayed +; /PRINT - if set, then output coordinates are displayed at the terminal +; By default, the coordinates are displayed if no output parameters +; are supplied to QUERYSIMBAD +; /SILENT - If set, then don't print warnings if multiple SIMBAD objects +; correspond to the supplied name. +; OPTIONAL OUTPUT: +; id - the primary SIMBAD (or NED) ID of the target, scalar string +; As of June 2009, a more reliable ID seems to be found when using +; CFA (/CFA) server. +; +; OPTIONAL KEYWORD OUTPUTS: +; found - set to 1 if the translation was successful, or to 0 if the +; the object name could not be translated by SIMBAD or NED +; Errmsg - if supplied, then any error messages are returned in this +; keyword, rather than being printed at the terminal. May be either +; a scalar or array. +; Server - Character indicating which server was actually used to resolve +; the object, 'S'imbad, 'N'ed or 'V'izier +; Vmag - supply to receive the SIMBAD V magnitude +; Jmag - supply to receive the SIMBAD J magntiude +; Hmag - supply to receive the SIMBAD H magnitude +; Kmag - supply to receive the SIMBAD K magnitude +; Parallax - supply to receive the SIMBAD parallax in milliarcseconds +; +; EXAMPLES: +; (1) Display the J2000 coordinates for the ultracompact HII region +; G45.45+0.06 +; +; IDL> QuerySimbad,'GAL045.45+00.06' +; ===>19 14 20.77 +11 09 3.6 +; PROCEDURES USED: +; REPSTR(), WEBGET() +; NOTES: +; The actual query is made to the Sesame name resolver +; ( see http://cdsweb.u-strasbg.fr/doc/sesame.htx ). The Sesame +; resolver first searches the Simbad name resolver, then NED and then +; Vizier. +; MODIFICATION HISTORY: +; Written by M. Feldt, Heidelberg, Oct 2001 +; Minor updates, W. Landsman August 2002 +; Added option to use NED server, better parsing of SIMBAD names such as +; IRAS F10190+5349 W. Landsman March 2003 +; Turn off extended name search for NED server, fix negative declination +; with /NED W. Landsman April 2003 +; Use Simbad Sesame sever, add /Verbose, /CADC keywords +; B. Stecklum, TLS Tautenburg/ W. Landsman, Feb 2007 +; Update NED query to account for new IPAC format, A. Barth March 2007 +; Update NED query to account for another new IPAC format, A. Barth +; July 2007 +; Update message when NED does not find object W.L. October 2008 +; Remove CADC keyword, add CFA keyword, warning if more than two +; matches W.L. November 2008 +; Make NED queries through the Sesame server, add Server output +; keyword W.L. June 2009 +; Don't get primary name if user didn't ask for it W.L. Aug 2009 +; Added /SILENT keyword W.L. Oct 2009 +; Added /PRINT keyword W.L. Oct 2011 +; Added ability to get V, J, H, and K magnitudes as well as +; a parallax - jswift, Jan 2014 +;- + + compile_opt idl2 + if N_params() LT 1 then begin + print,'Syntax - QuerySimbad, name, ra, dec, [ id, ]' + print,' Found=, /CFA, /NED, ERRMSG=, /VERBOSE]' + print,' Input - object name, scalar string' + print,' Output - Ra, dec of object (degrees)' + return + endif + + Catch, theError + IF theError NE 0 THEN BEGIN + Catch,/CANCEL + void = cgErrorMsg(/Quiet) + RETURN + ENDIF + ;; + printerr = ~arg_present(errmsg) + if ~printerr then errmsg = '' + object = repstr(name,'+','%2B') + object = repstr(strcompress(object),' ','%20') + if keyword_set(Cadc) then message,'CADC keyword is no longer supported' + if keyword_set(cfa) then base = 'vizier.cfa.harvard.edu/viz-bin' else $ + base = 'cdsweb.u-strasbg.fr/cgi-bin' + if keyword_set(NED) then begin + QueryURL = "http://" + base + "/nph-sesame/-o/N?" + $ + strcompress(object,/remove) + endif else begin + QueryURL = "http://" + base + "/nph-sesame/-oI?" + $ + strcompress(object,/remove) + + endelse + ;; + if keyword_set(verbose) then print,queryURL + Result = webget(QueryURL) + found = 0 + ;; + Result=Result.Text + if arg_present(server) then $ + server = strmid(result[1],2,1) +; look for J2000 coords + idx=where(strpos(Result, '%J ') ne -1,cnt) + + if cnt GE 1 then begin + if cnt GT 1 then begin + if ~keyword_set(SILENT) then $ + message,/INF,'Warning - More than one match found for name ' + name + idx = idx[0] + endif + found=1 + ra = 0.0d & de = 0.0d + reads,strmid(Result[idx],2),ra,de + + if N_params() GT 3 then begin + + idx2= where(strpos(Result, '%I.0 ') ne -1,cnt) + if cnt GT 0 then id = strtrim(strmid(Result[idx2],4),2) else $ + if ~keyword_set(SILENT) then $ + message,'Warning - could not determine primary ID',/inf + endif + + ; Get V mag if present + vi = where(strpos(Result, '%M.V ') ne -1,vcnt) + if vcnt GE 1 then reads,strmid(Result[vi],4),vmag + + ; Get J mag if present + ji = where(strpos(Result, '%M.J ') ne -1,jcnt) + if jcnt GE 1 then reads,strmid(Result[ji],4),jmag + + ; Get H mag if present + hi = where(strpos(Result, '%M.H ') ne -1,hcnt) + if hcnt GE 1 then reads,strmid(Result[hi],4),hmag + + ; Get K mag if present + ki = where(strpos(Result, '%M.K ') ne -1,kcnt) + if kcnt GE 1 then reads,strmid(Result[ki],4),kmag + + ; Get parallax if present + plxi = where(strpos(Result, '%X ') ne -1,plxcnt) + if plxcnt GE 1 then reads,strmid(Result[plxi],2),parallax + + + ENDIF ELSE BEGIN + errmsg = ['No objects returned by SIMBAD. The server answered:' , $ + strjoin(result)] + if printerr then begin + message, errmsg[0], /info + message,strjoin(result),/info + endif + ENDELSE + if found GT 0 && ((N_params() LT 2) || keyword_set(print)) then $ + print,adstring(ra,de,1) + + + return +END + diff --git a/modules/idl_downloads/astro/pro/queryvizier.pro b/modules/idl_downloads/astro/pro/queryvizier.pro new file mode 100644 index 0000000..675e65b --- /dev/null +++ b/modules/idl_downloads/astro/pro/queryvizier.pro @@ -0,0 +1,348 @@ +function Queryvizier, catalog, target, dis, VERBOSE=verbose, CANADA = canada, $ + CONSTRAINT = constraint, ALLCOLUMNS=allcolumns, SILENT=silent, $ + CFA = CFA +;+ +; NAME: +; QUERYVIZIER +; +; PURPOSE: +; Query any catalog in the Vizier database by position +; +; EXPLANATION: +; Uses the IDL SOCKET command to provide a positional query of any catalog +; in the the Vizier (http://vizier.u-strasbg.fr/) database over the Web and +; return results in an IDL structure. +; +; +; CALLING SEQUENCE: +; info = QueryVizier(catalog, targetname_or_coords, [ dis +; /ALLCOLUMNS, /CFA, CONSTRAINT= ,/VERBOSE ]) +; +; INPUTS: +; CATALOG - Scalar string giving the name of the VIZIER catalog to be +; searched. The complete list of catalog names is available at +; http://vizier.u-strasbg.fr/vizier/cats/U.htx . +; +; Popular VIZIER catalogs include +; 'II/328'- AllWISE Data Release (Cutri+ 2013) +; 'V/139' - Sloan SDSS photometric catalog Release 9 (2012) +; '2MASS-PSC' - 2MASS point source catalog (2003) +; 'GSC2.3' - Version 2.3.2 of the HST Guide Star Catalog (2006) +; 'USNO-B1' - Verson B1 of the US Naval Observatory catalog (2003) +; 'UCAC4' - 4th U.S. Naval Observatory CCD Astrograph Catalog (2012) +; 'B/DENIS/DENIS' - 2nd Deep Near Infrared Survey of southern Sky (2005) +; 'I/259/TYC2' - Tycho-2 main catalog (2000) +; 'I/311/HIP2' - Hipparcos main catalog, new reduction (2007) +; +; Note that some names will prompt a search of multiple catalogs +; and QUERYVIZIER will only return the result of the first search. +; Thus, setting catalog to "HIP2" will search all catalogs +; associated with the Hipparcos mission, and return results for the +; first catalog found. To specifically search the Hipparcos or +; Tycho main catalogs use the VIZIER catalog names listed above +; +; TARGETNAME_OR_COORDS - Either a scalar string giving a target name, +; (with J2000 coordinates determined by SIMBAD), or a 2-element +; numeric vector giving the J2000 right ascension in *degrees* and +; the target declination in degrees. +; If the targetname is set to 'NONE' then QUERYVIZIER will perform +; an all-sky search using the constraints given in the CONSTRAINT +; keyword. +; OPTIONAL INPUT: +; dis - scalar or 2-element vector. If one value is supplied then this +; is the search radius in arcminutes. If two values are supplied +; then this is the width (i.e., in longitude direction) and height +; of the search box. Default is a radius search with radius of +; 5 arcminutes +; +; OUTPUTS: +; info - Anonymous IDL structure containing information on the catalog +; sources within the specified distance of the specified center. The +; structure tag names are identical with the VIZIER catalog column +; names, with the exception of an occasional underscore +; addition, if necessary to convert the column name to a valid +; structure tag. The VIZIER Web page should consulted for the +; column names and their meaning for each particular catalog.. +; +; If the tagname is numeric and the catalog field is blank then either +; NaN (if floating) or -1 (if integer) is placed in the tag. +; +; If no sources are found within the specified radius, or an +; error occurs in the query then -1 is returned. +; OPTIONAL KEYWORDS: +; /ALLCOLUMNS - if set, then all columns for the catalog are returned +; The default is to return a smaller VIZIER default set. +; +; /CANADA - obsolete, the Canadian Vizier site no longer seems +; supported. +; +; /CFA - By default, the query is sent to the main VIZIER site in +; Strasbourg, France. If /CFA is set then the VIZIER site +; at the Harvard Center for Astrophysics (CFA) is used instead. +; Note that not all Vizier sites have the option to return +; tab-separated values (TSV) which is required by this program. +; +; CONSTRAINT - string giving additional nonpositional numeric +; constraints on the entries to be selected. For example, when +; in the GSC2.3 catalog, to only select sources with Rmag < 16 set +; Constraint = 'Rmag<16'. Multiple constraints can be +; separated by commas. Use '!=' for "not equal", '<=' for smaller +; or equal, ">=" for greater than or equal. See the complete list +; of operators at +; http://vizier.u-strasbg.fr/doc/asu.html#AnnexQual +; For this keyword only, **THE COLUMN NAME IS CASE SENSITIVE** and +; must be written exactly as displayed on the VIZIER Web page. +; Thus for the GSC2.3 catalog one must use 'Rmag' and not 'rmag' or +; 'RMAG'. In addition, *DO NOT INCLUDE ANY BLANK SPACE* unless it +; is a necessary part of the query. +; +; /SILENT - If set, then no message will be displayed if no sources +; are found. Error messages are still displayed. +; /VERBOSE - If set then the query sent to the VIZIER site is +; displayed, along with the returned title(s) of found catalog(s) +; EXAMPLES: +; (1) Plot a histogram of the J magnitudes of all 2MASS point sources +; stars within 10 arcminutes of the center of the globular cluster M13 +; +; IDL> info = queryvizier('2MASS-PSC','m13',10) +; IDL> plothist,info.jmag,xran=[10,20] +; +; (2) Find the brightest J mag GSC2.3 source within 3' of the +; J2000 position ra = 10:12:34, dec = -23:34:35 +; +; IDL> str = queryvizier('GSC2.3',[ten(10,12,34)*15,ten(-23,34,35)],3) +; IDL> print,min(str.jmag,/NAN) +; +; (3) Find sources with V < 19 in the Magellanic Clouds Photometric +; Survey (Zaritsky+, 2002) within 5 arc minutes of the position +; 00:47:34 -73:06:27 +; +; Checking the VIZIER Web page we find that this catalog is +; IDL> catname = 'J/AJ/123/855/table1' +; IDL> ra = ten(0,47,34)*15 & dec = ten(-73,6,27) +; IDL> str = queryvizier(catname, [ra,dec], 5, constra='Vmag<19') +; +; (4) Perform an all-sky search of the Tycho-2 catalog for stars with +; BTmag = 13+/-0.1 +; +; IDL> str = queryvizier('I/259/TYC2','NONE',constrain='BTmag=13+/-0.1') +; +; PROCEDURES USED: +; GETTOK(), REMCHAR, REPSTR(), STRCOMPRESS2(), WEBGET() +; TO DO: +; (1) Allow specification of output sorting +; MODIFICATION HISTORY: +; Written by W. Landsman SSAI October 2003 +; Give structure name returned by VIZIER not that given by user +; W. Landsman February 2004 +; Don't assume same format for all found sources W. L. March 2004 +; Added CONSTRAINT keyword for non-positional constraints WL July 2004 +; Remove use of EXECUTE() statement WL June 2005 +; Make dis optional as advertised WL August 2005 +; Update for change in Vizier output format WL February 2006 +; Fix problem in Feb 2006 update when only 1 object found +; WL/D.Apai March 2006 +; Accept 'E' format for floating point. M. Perrin April 2006 +; Added /ALLCOLUMNS option to return even more data. M. Perrin, May 2006 +; Return anonymous structure W. Landsman May 2006 +; Removed V6.0 notation to restore V5 compatibility W.Landsman July2006 +; Accept target='NONE' for all-sky search, allow '+/-' constraints +; W. Landsman October 2006 +; Use HTTP 1.0 protocol in call to webget.pro +; Use vector form of IDL_VALIDNAME if V6.4 or later W.L. Dec 2007 +; Update Strasbourg Web address for target name W.L. 3 March 2008 +; Also update Web address for coordinate search W.L. 7 March 2008 +; Allow for 'D' specification format R. Gutermuth/W.L. June 2008 +; Allow for possible lower-case returned formats W.L. July 2008 +; Use STRCOMPRESS2()to remove blanks around operators in constraint +; string W.L. August 2008 +; Added /SILENT keyword W.L. Jan 2009 +; Avoid error if output columns but not data returned W.L. Mar 2010 +; Ignore vector tags (e.g. SED spectra) W.L. April 2011 +; Better checking when more than one catalog returned W.L. June 2012 +; Assume since IDL V6.4 W.L. Aug 2013 +; Update HTTP syntax for /CANADA W. L. Feb 2014 +; Add CFA keyword, remove /CANADA keyword W.L. Oct 2014 +;- + On_error,2 + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - info = QueryVizier(catalog, targetname_or_coord, dis,' + print,' [/ALLCOLUMNS, /SILENT, /VERBOSE, /CFA, CONSTRAINT= ]' + print,' ' + print,' Coordinates (if supplied) should be J2000 RA (degrees) and Dec' + print,' dis -- search radius or box in arcminutes' + if N_elements(info) GT 0 then return,info else return, -1 + endif + + if keyword_set(CFA) then root = "http://vizier.hia.nrc.ca/viz-bin/" $ + else root = "http://webviz.u-strasbg.fr/viz-bin/" + silent = keyword_set(silent) + + if N_elements(catalog) EQ 0 then $ + message,'ERROR - A catalog name must be supplied as a keyword' + targname = 0b + if N_elements(dis) EQ 0 then dis = 5 + if min(dis) LE 0 then $ + message,'ERROR - Search distances must be greater than zero' + + nopoint = 0b + if N_elements(dis) EQ 2 then $ + search = "&-c.bm=" + strtrim(dis[0],2) + '/' + strtrim(dis[1],2) else $ + search = "&-c.rm=" + strtrim(dis,2) + if N_elements(target) EQ 2 then begin + ra = float(target[0]) + dec = float(target[1]) + endif else begin + nopoint = strupcase( strtrim(target,2) ) EQ 'NONE' + object = repstr(target,'+','%2B') + object = repstr(strcompress(object),' ','+') + targname = 1b + endelse + +; Add any additional constraints to the search. Convert any URL special +; special characters in the constraint string. + + if N_elements(constraint) EQ 0 then constraint = '' + if strlen(constraint) GT 0 then begin + urlconstrain = strtrim(constraint,2) + urlconstrain = strcompress2(constraint,['<','>','=']) + urlconstrain = repstr(urlconstrain, ',','&') + urlconstrain = repstr(urlconstrain, '<','=%3C') + urlconstrain = repstr(urlconstrain, '>','=%3E') + urlconstrain = repstr(urlconstrain, '+','%2B') + urlconstrain = repstr(urlconstrain, '/','%2F') + urlconstrain = repstr(urlconstrain, '!','=!') + if nopoint then search = urlconstrain else $ + search = search + '&' + urlconstrain + endif + ; + if nopoint then $ + QueryURL = root + "asu-tsv/?-source=" + catalog + '&' + $ + search + '&-out.max=unlimited' else $ + if targname then $ + QueryURL = $ + root + "asu-tsv/?-source=" + catalog + $ + "&-c=" + object + search + '&-out.max=unlimited' else $ + queryURL = $ + root + "asu-tsv/?-source=" + catalog + $ + "&-c.ra=" + strtrim(ra,2) + '&-c.dec=' + strtrim(dec,2) + $ + search + '&-out.max=unlimited' + + if keyword_set(allcolumns) then queryURL = queryURL + '&-out.all=1' + if keyword_set(verbose) then message,queryurl,/inf + + Result = webget(QueryURL,/http10, silent=silent) +; + t = strtrim(result.text,2) + keyword = strtrim(strmid(t,0,7),2) + + linecon = where(keyword EQ '#---Lis', Ncon) + if Ncon GT 0 then remove,linecon, t, keyword + +; Check to see if more than one catalog has been searched +; Use only the first catalog found + + rcol = where(keyword Eq '#RESOUR', Nfound) + if N_elements(rcol) GT 1 then begin + t = t[0:rcol[1]-1 ] + keyword = keyword[0:rcol[1]-1] + endif + lcol = where(keyword EQ "#Column", Nfound) + if Nfound EQ 0 then begin + if max(strpos(strlowcase(t),'errors')) GE 0 then begin + message,'ERROR - Unsuccessful VIZIER query',/CON + print,t + endif else if ~silent then $ + message,'No sources found within specified radius',/INF + return,-1 + endif + + + if keyword_set(verbose) then begin + titcol = where(keyword EQ '#Title:', Ntit) + if Ntit GT 0 then message,/inform, $ + strtrim(strmid(t[titcol[0]],8),2) + endif +;Check if any Warnings or fatal errors in the VIZIER output + badflag = strmid(keyword,0,5) + warn = where(badflag EQ '#++++', Nwarn) + if Nwarn GT 0 then for i=0,Nwarn-1 do $ + message,'Warning: ' + strtrim(t[warn[i]],2),/info + + fatal = where(badflag EQ '#****', Nfatal) + if Nfatal GT 0 then for i=0,Nfatal-1 do $ + message,'Error: ' + strtrim(t[fatal[i]],2),/info + + + trow = t[lcol] + dum = gettok(trow,' ') + colname = gettok(trow,' ') + fmt = gettok(trow,' ') + + remchar,fmt,'(' + remchar,fmt,')' + remchar,colname,')' + colname = IDL_VALIDNAME(colname,/convert_all) + +; Find the vector tags (Format begins with a number) and remove them + + bad = where(stregex(fmt,'^[0-9]') GE 0, Nbad) + if Nbad GT 0 then remove,bad,fmt,colname + + ntag = N_elements(colname) + fmt = strupcase(fmt) + val = fix(strmid(fmt,1,4)) + + for i=0,Ntag-1 do begin + + case strmid(fmt[i],0,1) of + + 'A': cval = ' ' + 'I': cval = (val[i] LE 4) ? 0 : 0L ;16 bit integer if 4 chars or less + 'F': cval = (val[i] LE 7) ? 0. : 0.0d ;floating point if 7 chars or less + 'E': cval = (val[i] LE 7) ? 0. : 0.0d + 'D': cval = (val[i] LE 7) ? 0. : 0.0d + else: message,'ERROR - unrecognized format ' + fmt[i] + + endcase + + if i EQ 0 then info = create_struct(colname[0], cval) else begin + ; If you set the /ALLCOLUMNS flag, in some cases (2MASS) you + ; get a duplicate column name. Check for this and avoid it by appending + ; an extra bit to the duplicate name + if where(tag_names(info) eq strupcase(colname[i])) ge 0 then $ + colname[i] = colname[i] + '_2' + info = create_struct(temporary(info), colname[i],cval) + endelse + endfor + + i0 = max(lcol) + 4 + if i0 GT (N_elements(t)-1) then begin + message,'No sources found within specified radius',/INF + return,-1 + endif + + iend = where( t[i0:*] EQ '', Nend) + if Nend EQ 0 then iend = N_elements(t) else iend = iend[0] + i0 + nstar = iend - i0 + info = replicate(info, nstar) + +; Find positions of tab characters + t = t[i0:iend-1] + + for j=0,Ntag-1 do begin + x = strtrim( gettok(t,string(9b),/exact ),2) + dtype = size(info[0].(j),/type) + if dtype NE 7 then begin + bad = where(strlen(x) EQ 0, Nbad) + if (Nbad GT 0) then $ + if (dtype EQ 4) || (dtype EQ 5) then x[bad] = 'NaN' $ + else x[bad] = -1 + endif + info.(j) = x + endfor + return,info +END + + diff --git a/modules/idl_downloads/astro/pro/radec.pro b/modules/idl_downloads/astro/pro/radec.pro new file mode 100644 index 0000000..ebad235 --- /dev/null +++ b/modules/idl_downloads/astro/pro/radec.pro @@ -0,0 +1,75 @@ +pro radec,ra,dec,ihr,imin,xsec,ideg,imn,xsc, hours = hours +;+ +; NAME: +; RADEC +; PURPOSE: +; To convert RA and Dec from decimal to sexagesimal units. +; EXPLANATION: +; The conversion is to sexagesimal hours for RA, and sexagesimal +; degrees for declination. +; +; CALLING SEQUENCE: +; radec, ra, dec, ihr, imin, xsec, ideg, imn, xsc, [/HOURS} +; +; INPUTS: +; ra - Right ascension, scalar or vector, in DEGREES unless the +; /HOURS keyword is set +; dec - declination in decimal DEGREES, scalar or vector, same number +; of elements as RA +; +; OUTPUTS: +; ihr - right ascension hours (INTEGER*2) +; imin - right ascension minutes (INTEGER*2) +; xsec - right ascension seconds (REAL*4 or REAL*8) +; ideg - declination degrees (INTEGER*2) +; imn - declination minutes (INTEGER*2) +; xsc - declination seconds (REAL*4 or REAL*8) +; +; OPTIONAL KEYWORD INPUT: +; /HOURS - if set, then the input righ ascension should be specified in +; hours instead of degrees. +; RESTRICTIONS: +; RADEC does minimal parameter checking. +; +; REVISON HISTORY: +; Written by B. Pfarr, STX, 4/24/87 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added /HOURS keyword W. Landsman August 2002 +;- + On_error,2 + + if (N_params() LT 2 ) then begin + print,'Syntax - radec, ra, dec, ihr, imin, xsec, ideg, imn, xsc' + return + endif + +; Compute RA + if keyword_set(hours) then begin + ra = ra mod 24. + ra = ra + 24*(ra lt 0) + ihr = fix(ra) + xmin = abs(ra*60. - ihr*60.) + endif else begin + ra = ra mod 360. ;Make sure between 0 and 24 hours + ra = ra + 360*(ra lt 0) + ihr = fix(ra/15.) + xmin =abs(ra*4.0-ihr*60.0) + endelse + imin = fix(xmin) + xsec = (xmin-imin)*60.0 + +; Compute Dec + + ideg = fix(dec) + xmn = abs(dec-ideg)*60.0 + imn = fix(xmn) + xsc = (xmn-imn)*60.0 + +; Now test for the special case of zero degrees + + zero_deg = ( ideg EQ 0 ) and (dec LT 0) + imn = imn - 2*imn*fix( zero_deg*(imn NE 0) ) + xsc = xsc - 2*xsc*zero_deg*(imn EQ 0) + + return + end diff --git a/modules/idl_downloads/astro/pro/randomchi.pro b/modules/idl_downloads/astro/pro/randomchi.pro new file mode 100644 index 0000000..6c79d36 --- /dev/null +++ b/modules/idl_downloads/astro/pro/randomchi.pro @@ -0,0 +1,36 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; RANDOMCHI +; PURPOSE: +; GENERATE CHI-SQUARE DISTRIBUTED RANDOM VARIABLES. +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., SEP 2005 +; +; INPUTS : +; +; SEED - THE SEED FOR THE RANDOM NUMBER GENERATOR, CAN BE UNDEFINED. +; DOF - THE DEGREES OF FREEDOM FOR THE CHI-SQUARED DISTRIBUTION. +; +; OPTIONAL INPUTS : +; +; NRAND - THE NUMBER OF RANDOM NUMBERS TO DRAW +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function randomchi, seed, dof, nrand + +if n_params() lt 2 then begin + print, 'Syntax- result = randomchi( seed, dof[, nrand] )' + return, -1 +endif + +if n_elements(nrand) eq 0 then nrand = 1 + +alpha = dof / 2.0 +beta = 0.5 + +chisqr = randomgam( seed, alpha, beta, nrand ) + +return, chisqr +end diff --git a/modules/idl_downloads/astro/pro/randomdir.pro b/modules/idl_downloads/astro/pro/randomdir.pro new file mode 100644 index 0000000..f1b6e05 --- /dev/null +++ b/modules/idl_downloads/astro/pro/randomdir.pro @@ -0,0 +1,56 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; RANDOMDIR +; PURPOSE: +; GENERATE DIRICHLET-DISTRIBUTED RANDOM VARIABLES. +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., APRIL 2006 +; +; INPUTS : +; +; SEED - THE SEED FOR THE RANDOM NUMBER GENERATOR, CAN BE UNDEFINED. +; ALPHA - THE SHAPE PARAMETERS FOR THE DIRICHLET DISTRIBUTION. THIS +; SHOULD BE A K-ELEMENT VECTOR. +; +; OPTIONAL INPUTS : +; +; NRAND - THE NUMBER OF RANDOM NUMBERS TO DRAW +; +; CALLED ROUTINES : +; +; RANDOMGAM +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function randomdir, seed, alpha, nrand + +if n_params() lt 2 then begin + print, 'Syntax- theta = randomdir( seed, alpha[, nrand] )' + return, 0 +endif + +if n_elements(alpha) lt 2 then begin + print, 'Alpha must have at least 2 elements.' + return, 0 +endif + +K = n_elements(alpha) + +bad = where(alpha le 0, nbad) +if nbad ne 0 then begin + print, 'All elements of ALPHA must be greater than 0.' + return, 0 +endif + +if n_elements(nrand) eq 0 then nrand = 1 + +gamma = dblarr(nrand, K) + +for j = 0, K - 1 do $ + gamma[0,j] = randomgam(seed, alpha[j], 1.0, nrand) + +theta = gamma / transpose(total(gamma,2) ## replicate(1, K)) + +return, theta +end diff --git a/modules/idl_downloads/astro/pro/randomgam.pro b/modules/idl_downloads/astro/pro/randomgam.pro new file mode 100644 index 0000000..5a76873 --- /dev/null +++ b/modules/idl_downloads/astro/pro/randomgam.pro @@ -0,0 +1,88 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; RANDOMGAM +; PURPOSE: +; GENERATE GAMMA-DISTRIBUTED RANDOM VARIABLES. +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., APRIL 2006 +; +; INPUTS : +; +; SEED - THE SEED FOR THE RANDOM NUMBER GENERATOR, CAN BE UNDEFINED. +; ALPHA, BETA - THE SHAPE PARAMETERS FOR THE GAMMA DISTRIBUTION. +; +; OPTIONAL INPUTS : +; +; NRAND - THE NUMBER OF RANDOM NUMBERS TO DRAW +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function randomgam, seed, alpha, beta, nrand + +if n_params() lt 3 then begin + print, 'Syntax- X = randomgam( seed, alpha, beta[, nrand] )' + return, 0 +endif + +if alpha le 0 or beta le 0 then begin + print, 'ALPHA and BETA must both be greater than zero.' + return, 0 +endif + +if n_elements(nrand) eq 0 then nrand = 1 + +if alpha le 1 then begin + + alpha = alpha + 1 + alfshift = 1 + +endif else alfshift = 0 + +d = alpha - 1d / 3 +c = 1 / sqrt(9 * d) + +gamma = dblarr(nrand) + +nempty = nrand +empty = lindgen(nrand) + +repeat begin + + x = randomn(seed, nempty) + v = 1 + c * x + + bad = where(v le 0, nbad) + while nbad gt 0 do begin + + x2 = randomn(seed, nbad) + x[bad] = x2 + v[bad] = 1 + c * x2 + bad2 = where(v[bad] le 0, nbad2) + if nbad2 gt 0 then bad = bad[bad2] + nbad = bad2 + + endwhile + + v = v^3 + + unif = randomu(seed, nempty) + factor = 0.5 * x^2 + d - d * v + d * alog(v) + u = where( alog(unif) lt factor, nu, comp=empty1 ) + + if nu gt 0 then gamma[empty[u]] = d * v[u] + nempty = nempty - nu + + if nempty ne 0 then empty = empty[empty1] + +endrep until nempty eq 0 + +if alfshift then begin + alpha = alpha - 1 + gamma = gamma * (randomu(seed, nrand))^(1d / alpha) +endif + +gamma = gamma / beta + +return, gamma +end diff --git a/modules/idl_downloads/astro/pro/randomp.pro b/modules/idl_downloads/astro/pro/randomp.pro new file mode 100644 index 0000000..1587d09 --- /dev/null +++ b/modules/idl_downloads/astro/pro/randomp.pro @@ -0,0 +1,83 @@ +pro randomp,x,pow,n,range_x=range_x,seed=s +;+ +; NAME: +; RANDOMP +; PURPOSE: +; Generates an array of random numbers distributed as a power law. +; CALLING SEQUENCE: +; RANDOMP, X, Pow, N, [ RANGE_X = [low,high], SEED= ]' +; INPUTS: +; Pow: Exponent of power law. +; The pdf of X is f_X(x) = A*x^pow, low <= x <= high +; ASTRONOMERS PLEASE NOTE: +; pow is little gamma = big gamma - 1 for stellar IMFs. +; N: Number of elements in generated vector. +; +; OPTIONAL INPUT KEYWORD PARAMETER: +; RANGE_X: 2-element vector [low,high] specifying the range of +; output X values; the default is [5, 100]. +; +; OPTIONAL INPUT-OUTPUT KEYWORD PARAMETER: +; SEED: Seed value for RANDOMU function. As described in the +; documentation for RANDOMU, the value of SEED is updated on +; each call to RANDOMP, and taken from the system clock if not +; supplied. This keyword can be used to have RANDOMP give +; identical results on different runs. +; OUTPUTS: +; X: Vector of random numbers, distributed as a power law between +; specified range +; PROCEDURE: +; "Transformation Method" for random variables is described in Bevington +; & Robinson, "Data Reduction & Error Analysis for Physical Sciences", 2nd +; Edition (McGraw-Hill, 1992). p. 83. +; Output of RANDOMU function is transformed to power-law +; random variable. +; +; EXAMPLE: +; Create a stellar initial mass function (IMF) with 10000 stars +; ranging from 0.5 to 100 solar masses and a Salpeter slope. Enter: +; +; RANDOMP,MASS,-2.35,10000,RANGE_X=[0.5,100] +; +; NOTES: +; Versions 5.1.1 and V5.2 of IDL have a bug in RANDOMU such that the SEED +; value is initialized to the same value at the start of each session, +; rather than being initialized by the system clock. RANDOMP will be +; affected in a similar manner. +; MODIFICATION HISTORY: +; Written by R. S. Hill, Hughes STX, July 13, 1995 +; July 14, 1995 SEED keyword added at Landsman's suggestion. +; Documentation converted to standard format. RSH +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - RANDOMP, x, pow, n, [ RANGE_X = [low,high], SEED= ]' + return + endif + + if N_elements(range_x) lt 1 then range_x=[5,100] + if N_elements(range_x) ne 2 then begin + message,'Error - RANGE_X keyword must be a 2 element vector',/CON + return + endif + + pow1 = pow + 1.0 + lo = range_x[0] & hi = range_x[1] + if lo GT hi then begin + temp=lo & lo=hi & hi=tmp + endif + + r = randomu(s, n ) + if pow NE -1.0 then begin + norm = 1.0d0/(hi^pow1 - lo^pow1) + expo = alog10(r/norm + lo^pow1)/pow1 + x = 10.0^expo + endif else begin + norm = 1.0d0/(alog(hi) - alog(lo)) + x = exp(r/norm + alog(lo)) + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/randomwish.pro b/modules/idl_downloads/astro/pro/randomwish.pro new file mode 100644 index 0000000..caf104b --- /dev/null +++ b/modules/idl_downloads/astro/pro/randomwish.pro @@ -0,0 +1,56 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;+ +; NAME: +; RANDOMWISH +; PURUPOSE: +; ROUTINE TO DRAW RANDOM MATRICES FROM A WISHART DISTRIBUTION WITH DOF +; DEGREES OF FREEDOM AND SCALE MATRIX S. +; +; AUTHOR : BRANDON C. KELLY, STEWARD OBS., JULY 2006 +; +; INPUTS : +; +; SEED - THE SEED FOR THE RANDOM NUMBER GENERATOR, CAN BE UNDEFINED. +; DOF - THE DEGREES OF FREEDOM FOR THE WISHART DISTRIBUTION. +; S - THE SCALE MATRIX. THE DIMENSION OF S CANNOT BE GREATER THAN +; DOF. +; +; OPTIONAL INPUTS : +; +; NRAND - THE NUMBER OF RANDOM MATRICES TO DRAW +; +; CALLED ROUTINES : +; +; MRANDOMN +;- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +function randomwish, seed, dof, S, nrand + +if n_params() lt 3 then begin + print, 'Syntax- W = randomwish( seed, dof, S[, nrand] )' + return, 0 +endif + +dim = (size(S, /dim))[0] + +if dim gt dof then begin + + print, 'Dimension of S cannot be larger than DOF.' + return, 0 + +endif + +if n_elements(nrand) eq 0 then nrand = 1 + +wish = dblarr(dim, dim, nrand) + +for i = 0, nrand - 1 do begin + + x = mrandomn(seed, S, dof) + wish[*,*,i] = x ## transpose(x) + +endfor + +return, reform(wish) +end diff --git a/modules/idl_downloads/astro/pro/rdfits_struct.pro b/modules/idl_downloads/astro/pro/rdfits_struct.pro new file mode 100644 index 0000000..7400769 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rdfits_struct.pro @@ -0,0 +1,121 @@ +pro rdfits_struct, filename, struct,SILENT = silent, HEADER_ONLY = header_only,$ + EXTEN = exten +;+ +; NAME: +; RDFITS_STRUCT +; PURPOSE: +; Read an entire FITS file (all extensions) into a single IDL structure. +; EXPLANATION: +; Each header, image or table array is placed in a separate structure +; tag. +; +; CALLING SEQUENCE: +; RDFITS_STRUCT, filename, struct, /SILENT, /HEADER_ONLY, EXTEN= ] +; +; INPUT: +; FILENAME = Scalar string giving the name of the FITS file. +; One can also specify a gzip (.gz) compressed file +; +; OPTIONAL KEYWORD: +; /HEADER_ONLY - If set, then only the FITS headers (and not the data) +; are read into the structure. +; /SILENT - Set this keyword to suppress informational displays at the +; terminal. +; OUTPUT: +; struct = structure into which FITS data is read. The primary header +; and image are placed into tag names HDR0 and IM0. The ith +; extension is placed into the tag names HDRi, and either TABi +; (if it is a binary or ASCII table) or IMi (if it is an image +; extension) +; +; If /HEADER_ONLY is set, then struct will contain tags HDR0, HDR1 +; ....HDRn containing all the headers of a FITS file with n +; extensions +; OPTIONAL INPUT KEYWORD: +; EXTEN - positive integer array specifying which extensions to read. +; Default is to read all extensions. +; PROCEDURES USED: +; FITS_OPEN, FITS_READ, FITS_CLOSE +; +; METHOD: +; The file is opened with FITS_OPEN which return information on the +; number and type of each extension. The CREATE_STRUCT() function +; is used iteratively, with FITS_READ calls to build the final structure. +; +; EXAMPLE: +; Read the FITS file 'm33.fits' into an IDL structure, st +; +; IDL> rdfits_struct, 'm33.fits', st +; IDL> help, /str, st ;Display info about the structure +; +; To just read the second and fourth extensions +; IDL> rdfits_struct, 'm33.fits', st, exten=[2,4] +; RESTRICTIONS: +; Does not handle random groups or variable length binary tables +; MODIFICATION HISTORY: +; Written K. Venkatakrishna, STX April 1992 +; Code cleaned up a bit W. Landsman STX October 92 +; Modified for MacOS I. Freedman HSTX April 1994 +; Work under Windows 95 W. Landsman HSTX January 1996 +; Use anonymous structures, skip extensions without data WBL April 1998 +; Converted to IDL V5.0, W. Landsman, April 1998 +; OS-independent deletion of temporary file W. Landsman Jan 1999 +; Major rewrite to use FITS_OPEN and CREATE_STRUCT() W. Landsman Sep 2002 +; Added /HEADER_ONLY keyword W. Landsman October 2003 +; Do not copy primary header into extension headers W. Landsman Dec 2004 +; Do not modify NAXIS when using /HEADER_ONLY W. Landsman Jan 2005 +; Added EXTEN keyword W. Landsman July 2009 +;- + + compile_opt idl2 + if N_Params() LT 2 then begin + print,'Syntax - RDFITS_STRUCT, file, struct, [ /SILENT, /HEADER_ONLY ]' + return + endif + + fits_open, filename, fcb ; Get the description of the file + if ~keyword_set(silent) then $ + message,/inf,'Now reading file ' + filename + ' with ' + $ + strtrim(fcb.nextend,2) + ' extensions' + + h_only = keyword_set(header_only) + if h_only then begin + fits_read,fcb,0,h,/header_only,exten_no=0 + struct = {hdr0:h} + endif else begin + fits_read,fcb,d,h,exten_no=0 + struct = {hdr0:h,im0:temporary(d)} + endelse + + if fcb.nextend EQ 0 then begin + fits_close,fcb + return + endif + + n = N_elements(exten) + if N_elements(exten) EQ 0 then begin + n = fcb.nextend + exten = indgen(n)+1 + endif else begin + if max(exten) GT fcb.nextend then message, $ + 'ERROR - extension ' + strtrim(max(exten),2) + ' does not exist' + endelse + for i= 0, n-1 do begin + j = exten[i] + jj = strtrim(j,2) + if h_only then begin + fits_read,fcb,0,h,/header_only,/no_pdu,exten=j + struct = create_struct(temporary(struct), 'hdr' + jj, $ + temporary(h)) + endif else begin + fits_read,fcb,d,h,/no_pdu,exten=j + if fcb.xtension[j] EQ 'IMAGE' then tag = 'im' + jj $ + else tag = 'tab' + jj + struct = create_struct(temporary(struct), 'hdr' + jj, $ + temporary(h),tag, temporary(d)) + endelse + endfor + + fits_close,fcb + return + end diff --git a/modules/idl_downloads/astro/pro/rdfloat.pro b/modules/idl_downloads/astro/pro/rdfloat.pro new file mode 100644 index 0000000..f4f2244 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rdfloat.pro @@ -0,0 +1,152 @@ +pro rdfloat,name,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17, $ + v18,v19,SKIPLINE = skipline, NUMLINE = numline,DOUBLE=double, $ + SILENT = silent, COLUMNS = columns +;+ +; NAME: +; RDFLOAT +; PURPOSE: +; Quickly read a numeric ASCII data file into IDL floating/double vectors. +; EXPLANATION: +; Columns of data may be separated by tabs or spaces. This +; program is fast but is restricted to data files where all columns can +; be read as floating point (or all double precision). +; +; Use READCOL if greater flexibility is desired. Use READFMT to read a +; fixed-format ASCII file. Use FORPRINT to print columns of data. +; +; CALLING SEQUENCE: +; RDFLOAT, name, v1, [ v2, v3, v4, v5, ... v19] +; COLUMNS, /DOUBLE, SKIPLINE = , NUMLINE = ] +; +; INPUTS: +; NAME - Name of ASCII data file, scalar string. In VMS, an extension of +; .DAT is assumed, if not supplied. +; +; OPTIONAL INPUT KEYWORDS: +; COLUMNS - Numeric scalar or vector specifying which columns in the file +; to read. For example, if COLUMNS = [3,7,11] then the first +; output variable (v1) would contain column 3, the second would +; contain column 7 and the third would contain column 11. If +; the number of elements in the COLUMNS vector is less than the +; number of output parameters, then consecutive columns are +; implied. For example, if 3 output parameters are supplied +; (v1,v2,v3) and COLUMNS = 3, then columns 3,4, and 5 will be +; read. +; SKIPLINE - Integer scalar specifying number of lines to skip at the top +; of file before reading. Default is to start at the first line. +; NUMLINE - Integer scalar specifying number of lines in the file to read. +; Default is to read the entire file +; /DOUBLE - If this keyword is set, then all variables are read in as +; double precision. +; /SILENT - Set this keyword to suppress any informative messages +; +; OUTPUTS: +; V1,V2,V3,...V19 - IDL vectors to contain columns of data. +; Up to 19 columns may be read. All output vectors are of type +; float, unless the /DOUBLE keyword is set, +; +; EXAMPLES: +; Each row in a file 'position.dat' contains a star number and 6 columns +; of data giving an RA and Dec in sexagesimal format. Read into IDL +; variables. +; +; IDL> rdfloat,'position.dat',ID,hr,min,sec,deg,dmin,dsec +; +; All output vectors will be floating point. To only read the +; declination vectors (Deg,dmin,dsec) +; +; IDL> rdfloat,'position.dat',deg,dmin,dsec,col=4 +; +; RESTRICTIONS: +; (1) All rows in the file must be formatted identically (except for +; those skipped by SKIPLINE). RDFLOAT reads the first line of +; the data (after SKIPLINE) to determine the number of columns of +; data. +; (2) Cannot be used to read strings +; PROCEDURES USED: +; None. +; REVISION HISTORY: +; Written W. Landsman September 1995 +; Call NUMLINES() function February 1996 +; Read up to 19 columns August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Allow to skip more than 32767 lines W. Landsman June 2001 +; Added /SILENT keyword W. Landsman March 2002 +; Added COLUMNS keyword, use STRSPLIT W. Landsman May 2002 +; Use SKIP_LUN if V5.6 or later W. Landsman Nov 2002 +; V5.6 version, use FILE_LINES() W. Landsman Dec 2002 +;- + On_error,2 ;Return to caller + + if N_params() lt 2 then begin + print,'Syntax - RDFLOAT, name, v1, [ v2, v3,...v19 ' + print,' COLUMNS = ,/DOUBLE, SKIPLINE =, NUMLINE = ]' + return + endif + +; Get number of lines in file + + nlines = FILE_LINES( name ) + if nlines LE 0 then begin + message,'ERROR - File ' + name+' contains no data',/CON + return + endif + + + if ~keyword_set( SKIPLINE ) then skipline = 0 + nlines = nlines - skipline + if keyword_set( NUMLINE) then nlines = numline < nlines + +;Read first line, and determine number of columns of data + + openr, lun, name, /GET_LUN + temp = '' + if skipline GT 0 then $ + skip_lun, lun, skipline, /lines + readf,lun,temp + + + colval = strsplit(temp, count=ncol) ;Determine number of columns + +;Create big output array and read entire file into the array + + bigarr = keyword_set(DOUBLE) ? dblarr(ncol, nlines, /NOZERO): $ + fltarr(ncol, nlines, /NOZERO) + + close,lun + openr, lun, name + if skipline GT 0 then skip_lun, lun, skipline, /lines + + readf, lun, bigarr + free_lun, lun + + if ~keyword_set(SILENT) then $ + message, strtrim(nlines,2) + ' lines of data read',/INF + + Nvector = (N_params()-1) < ncol + if N_elements(columns) EQ 0 then c = indgen(nvector) else c = columns - 1 + Nc = N_elements(c) + if Nc LT nvector then c = [c,indgen(nvector-nc) + c[nc-1] +1 ] + v1 = reform( bigarr[c[0],*]) + + if Nvector GT 1 then v2 = reform( bigarr[c[1],*]) else return + if Nvector GT 2 then v3 = reform( bigarr[c[2],*]) else return + if Nvector GT 3 then v4 = reform( bigarr[c[3],*]) else return + if Nvector GT 4 then v5 = reform( bigarr[c[4],*]) else return + if Nvector GT 5 then v6 = reform( bigarr[c[5],*]) else return + if Nvector GT 6 then v7 = reform( bigarr[c[6],*]) else return + if Nvector GT 7 then v8 = reform( bigarr[c[7],*]) else return + if Nvector GT 8 then v9 = reform( bigarr[c[8],*]) else return + if Nvector GT 9 then v10 = reform( bigarr[c[9],*]) else return + if Nvector GT 10 then v11 = reform( bigarr[c[10],*]) else return + if Nvector GT 11 then v12 = reform( bigarr[c[11],*]) else return + if Nvector GT 12 then v13 = reform( bigarr[c[12],*]) else return + if Nvector GT 13 then v14 = reform( bigarr[c[13],*]) else return + if Nvector GT 14 then v15 = reform( bigarr[c[14],*]) else return + if Nvector GT 15 then v16 = reform( bigarr[c[15],*]) else return + if Nvector GT 16 then v17 = reform( bigarr[c[16],*]) else return + if Nvector GT 17 then v18 = reform( bigarr[c[17],*]) else return + if Nvector GT 18 then v19 = reform( bigarr[c[18],*]) + + return + end diff --git a/modules/idl_downloads/astro/pro/rdplot.pro b/modules/idl_downloads/astro/pro/rdplot.pro new file mode 100644 index 0000000..d08bf05 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rdplot.pro @@ -0,0 +1,671 @@ +pro RESET_RDPLOT +; +; If the user crashes out of the RDPLOT program, they can call this procedure +; to reset the graphics device functions to default values. +; +device, /CURSOR_CROSSHAIR, SET_GRAPHICS_FUNCTION=3, BYPASS_TRANSLATION=0 +end + + + +pro RDPLOT, x, y, WaitFlag, DATA=Data, DEVICE=Device, NORMAL=Normal, $ + NOWAIT=NoWait, WAIT=Wait, DOWN=Down, CHANGE=Change, Err=Err, $ + PRINT=Print, XTITLE=XTitle,YTITLE=YTitle, XVALUES=XValues,YVALUES=YValues, $ + FULLCURSOR=FullCursor, NOCLIP=NoClip, LINESTYLE=Linestyle, THICK=Thick, $ + COLOR=Color, BACKGROUND=BackGround, CROSS=Cross, ACCUMULATE=Accumulate, $ + CURSOR_STANDARD=cursor_standard + +;******************************************************************************* +;+ +; NAME: +; RDPLOT +; +; PURPOSE: +; Like CURSOR but with a full-screen cursor and continuous readout option +; +; EXPLANATION: +; This program is designed to essentially mimic the IDL CURSOR command, +; but with the additional options of continuously printing out the data +; values of the cursor's position, and using a full-screen cursor rather +; than a small cross cursor. The full screen cursor uses OPLOT and +; X-windows graphics masking to emulate the cursor. +; One difference is that IF the PRINT keyword is set but the DOWN, +; WAIT, CHANGE, or NOWAIT keywords are not set, then the leftmost mouse +; button will print a "newline" line-feed, but not exit. +; +; Mac users may need to set their X windows preferences to (1) Emulate 3 +; button mouse and (2) Click through inactive windows, to make cursor +; work properly. +; +; CALLING SEQUENCE: +; RDPLOT [, X, Y] [, WaitFlag] [, /DATA | /DEVICE | /NORMAL] +; [, /NOWAIT | /WAIT | /DOWN | /CHANGE] +; [, /FULLCURSOR] [, /NOCLIP] [, /CROSS] [, /ACCUMULATE] +; [, ERR=, PRINT=, XTITLE=, YTITLE=, XVALUES=, YVALUES= +; , LINESTYLE=, THICK=, COLOR=, BACKGROUND=, CURSOR_STANDARD=] +; +; REQUIRED INPUTS: +; None. +; +; OPTIONAL INPUTS: +; WAITFLAG = Uses the same table as the intrinsic CURSOR command, But note +; that unlike the CURSOR command, there is no UP keyword. +; WaitFlag=0 sets the NOWAIT keyword +; WaitFlag=1 sets the WAIT keyword {default} +; WaitFlag=2 sets the CHANGE keyword +; WaitFlag=3 sets the DOWN keyword +; +; OPTIONAL OUTPUTS: +; X - a named variable to receive the final cursor X position, scalar +; or vector (if /ACCUMULATE is set) +; Y - a named variable to receive the final cursor Y position, scalar +; or vector (if /ACCUMULATE is set) +; OPTIONAL KEYWORD INPUT PARAMETERS: +; /DATA - data coordinates are displayed and returned. +; /DEVICE - device coordinates are displayed and returned. +; /NORMAL - normal coordinates are displayed and returned. +; Default is to use DATA coordinates if available (see notes). +; /NOWAIT = if non-zero the routine will immediately return the cursor's +; present position. +; /WAIT - if non-zero will wait for a mouse key click before returning. If +; cursor key is already down, then procedure immediately exits. +; /DOWN - equivalent to WAIT *except* that if the mouse key is already down +; when the procedure is called, the procedure will wait until the mouse +; key is clicked down again. +; /CHANGE - returns when the mouse is moved OR a key is clicked up or down. +; PRINT = if non-zero will continuously print out (at the terminal) the data +; values of the cursor's position. If PRINT>1, program will printout a +; brief header describing the mouse button functions. However, note that +; the button functions are overridden if any of the DOWN, WAIT, or +; CHANGE values are non-zero. +; XTITLE = label used to describe the values of the abscissa if PRINT>0. +; YTITLE = label used to describe the values of the ordinate if PRINT>0. +; XVALUES = a vector corresponding to the values to be printed when the +; PRINT keyword is set. This allows the user the option of printing +; out other values rather than the default X coordinate position of +; the cursor. E.g., if XVALUES is a string vector of dates such as +; ['May 1', 'May 2', ...], then those dates will be printed rather than +; the X value of the cursor's position: if X=1 then 'May 2' would be +; printed, etc. This requires that the values of the X coordinate read +; by the cursor must be positive (can't access negative elements). +; If XVALUES=-1, then NO values for X will be printed. +; YVALUES = analogous to the XVALUES keyword. +; /FULLCURSOR - if non-zero default cursor is blanked out and full-screen +; (or full plot window, depending on the value of NOCLIP) lines are +; drawn; their intersecton is centered on the cursor position. +; /NOCLIP - if non-zero will make a full-screen cursor, otherwise it will +; default to the value in !P.NOCLIP. +; LINESTYLE = style of line that makes the full-screen cursor. +; THICK = thickness of the line that makes the full-screen cursor. +; COLOR = color of the full-screen cursor. +; BACKGROUND = color of the background of the plot device. If this has +; been set to !P.BackGround, then this keyword is unnecessary. +; /CROSS = if non-zero will show the regular cross AND full screen cursors. +; /ACCUMULATE - all of the positions for which the left button was +; clicked are stored in the X and Y variables. Has no effect if X and Y +; are not present. +; CURSOR_STANDARD = this keyword can be used to select the cursor +; appearance if /CROSS is set and will set the cursor to this value +; when the full-screen cursor is turned off if /FULLCURSOR has been +; set. See IDL help for the DEVICE keyword CURSOR_STANDARD to see +; possible cursors for X Windows and MS Windows. The default +; behavior, if this keyword is not set, is to set the cursor to the +; window system's default cursor, which might not be the user's +; preferred cursor. +; +; OPTIONAL KEYWORD OUTPUT PARAMETER: +; ERR = returns the most recent value of the !mouse.button value. +; +; NOTES: +; Note that this procedure does not allow the "UP" keyword/flag...which +; doesn't seem to work too well in the origianl CURSOR version anyway. +; Note: this might have been the case back in the day, but Robishaw +; hasn't experienced any problems with CURSOR, /UP in the last 10 +; years. Even so, it would be somewhat tricky to implement the /UP +; behavior in this routine, which explains why it's still missing. +; +; If a data coordinate system has not been established, then RDPLOT +; will create one identical to the device coordinate system. Note that +; this kluge is required even if the user specified /NORMAL coordinates, +; since RDPLOT makes use of the OPLOT procedure. This new data +; coordinate system is effectively "erased" (!X.CRange and !Y.CRange are +; both set to zero) upon exit of the routine so as to not change the plot +; status from the user's point of view. +; +; Only tested on X-windows systems. If this program is interrupted, the +; graphics function might be left in a non-standard state; in that case, +; run the program RESET_RDPLOT to return the standard graphics functions, +; or type the command: DEVICE, /CURSOR_CROSS, SET_GRAPHICS=3, BYPASS=0 +; +; Robishaw added /ACCUMULATE keyword to pass back all the positions at +; which the mouse was left-clicked. In addition, the value of the exit +; click is returned unless the cursor did not change position between the +; last left-click and the exit click. +; +; +; +; PROCEDURE: +; Basically is a bells-n-whistles version of the CURSOR procedure. All +; the details are covered in the above discussion of the keywords. +; +; EXAMPLES: +; A silly, but informative one: +; Months = ['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', $ +; 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'] +; plot, indgen(12), xrange=[-5, 15] +; rdplot, /FULL, /PRINT, $ +; XTITLE='Month: ', YTITLE='Y-value per month = ', $ +; xvalues=Months +; +; If your plot has a non-black background color, be sure to set either +; !p.background or the BACKGROUND keyword. Here are examples of how to +; use a blue full-screen cursor on a plot with a red background and +; yellow axes and data. First, deal with color decomposition off: +; device, decomposed=0 +; tvlct, [255,255,0], [0,255,0], [0,0,255], 1 +; plot, randomn(seed,1024), XSTYLE=19, PSYM=3, COLOR=2, BACK=1 +; rdplot, /PRINT, /FULL, THICK=5, /NOCLIP, BACK=1, COLOR=3 +; +; For decomposition on (TrueColor or DirectColor only): +; device, decomposed=1 +; plot, randomn(seed,1024), XSTYLE=19, PSYM=3, COLOR=65535l, BACK=255l +; rdplot, /PRINT, /FULL, THICK=5, /NOCLIP, BACK=255l, COLOR=16711680l +; +; MODIFICATION HISTORY: +; Written (originally named CURFULL) by J.Wm.Parker 1993 Nov 22 +; Created data coordinates if not already present, W. Landsman Nov. 93 +; Added continuous printout of data values, COLOR and FULLCURSOR keywords +; (so that default is that it acts just like the cursor command). +; Changed name from CURFULL to RDPLOT. J.Wm.Parker 1994 Apr 20 +; Modified (with some translation table assistance from the IDL support +; group) to correctly plot the crosshair with the desired IDL +; color using the device's translation table to determine the XOR +; function and using the BYPASS function. Added the RESET_RDPLOT +; procedure to cleanup crashes that might occur while running +; RDPLOT. Other minor changes/bug fixes. J.Wm.Parker 1994 May 21 +; Modified DOWN, WAIT, CHANGE functions to behave more similar to the +; generic CURSOR procedure. J.Wm.Parker 1995 April 24 +; Added XVALUES, YVALUES keywords and cleanup. J.Wm.Parker 1995 April 24 +; Convert to IDL V5.0, W. Landsman July 1998 +; Change !D.NCOLORS to !D.TABLE_SIZE for 24 bit displays W. Landsman May 2000 +; Skip translation table for TrueColor visuals W. Landsman March 2001 +; Fixed /FULLCURSOR ghosts. Fixed to properly deal with background colors +; in 24-bit visual classes (TrueColor and DirectColor). Added +; BACKGROUND keyword. Tim Robishaw 2005 Jan 27 +; Added /ACCUMULATE keyword. T. Robishaw 2006 Nov 8 +; Corrected following problems. When /CHANGE and /PRINT were set, +; returned X & Y were different than those printed. When /PRINT and +; /NOWAIT were set, or /PRINT and /WAIT were set and the routine was +; entered with a mouse button clicked, nothing was printed. When +; /PRINT and /DOWN were set, if routine was started with button down, +; advertised behavior was that routine would exit on next down click; +; in practice if cursor was not moved, successive down clicks had no +; effect. Now, if X is passed as an output variable, requires that Y +; is also passed, like CURSOR. Bottom line is that RDPLOT now really +; does behave like CURSOR and when /PRINT is set, the values printed +; correspond to those returned in X & Y. T. Robishaw 2006 Nov 12 +; Fixed misbehavior when color decomposition was set to off for +; TrueColor and DirectColor. Now thoroughly tested on PseudoColor +; displays as well as both decomposition states for TrueColor and +; DirectColor. Also made the default cursor color white when +; decomposition is on (this has been its default value for +; decomposition off). T. Robishaw 2006 Nov 16 +; Fixed misbehavior when /FULLCURSOR not set; was checking for +; non-existent variable VisualName. T. Robishaw 2007 Jul 01 +; Added the CURSOR_STANDARD keyword because I hate how this routine +; changes my default cursor. Also, it was crashing when /FULL not set: +; small fix, now works. T. Robishaw 2007 Jul 03 +; Fixed bug where moving mouse with button pressed or releasing button +; would return values even if DOWN was set. The checks for this were +; only being done if PRINT was set also. T.V. Wenger 2013 May 14 +; Fix problem exiting when X,Y not supplied W. Landsman June 2013 +;- +;******************************************************************************* +On_error,2 + +;;; +; If the device does not support windows, then this program can not be used. +; +if ((!D.Flags and 256) ne 256) then message, $ + 'ERROR - Current graphics device ' + !D.NAME + ' does not support windows' + +;;; +; Like cursor, require that if present, both X and Y be specified... +; +if (N_Params() eq 1) then message, $ + 'Incorrect number of arguments. Both X & Y must be present.' + +;;; +; Keywords, keywords. +; +if (N_Params() eq 3) then begin + case WaitFlag of + 0 : NoWait = 1 + 1 : Wait = 1 + 2 : Change = 1 + 3 : Down = 1 + else : Wait = 1 + endcase +endif + +NoWait = keyword_set(NoWait) +Wait = keyword_set(Wait) +Down = keyword_set(Down); or Wait +Change = keyword_set(Change) +FullCursor = keyword_set(FullCursor) + +;;; +; If plotting coordinates are not already established, and the NORMAL keyword +; is not set, then use device coordinates. +; Note that even if this procedure was called with the DATA keyword set, that +; the DEVICE keyword will always take precedence over the DATA keyword in the +; cursor command. However, if the NORMAL and DEVICE keywords are both set, +; then very strange values are returned. +; +UndefinedPlot = ((!X.CRange[0] eq 0) and (!X.CRange[1] eq 0)) +if UndefinedPlot then plot, [0,!D.X_Size], [0,!D.Y_Size], /NODATA, $ + XSTYLE=5, YSTYLE=5, XMARGIN=[0,0], YMARGIN=[0,0], /NOERASE + +;;; +; Initialize the !mouse.button variable. The value of !mouse.button +; corresponds to the BYTE value of the buttons on the mouse from left to right, +; lowest bit first. So, the left button gives !mouse.button = 1, next button +; gives !mouse.button = 2, then 4. +; Read in the cursor with no wait. If the user does not want to wait, or if +; the DOWN or WAIT keywords are set AND the mouse key is depressed, then we're +; done (I hate GOTO's, but it is appropriate here). +; NOTE: Robishaw gets rid of GOTO statement... if user asks for value to be +; printed, it should be printed! +; +!mouse.button = 0 +cursor, X, Y, /NOWAIT, DATA=Data, DEVICE=Device, NORMAL=Normal +;if (keyword_set(NoWait) or (Wait and (!mouse.button gt 0))) then $ +; goto, LABEL_DONE +;;; +; PRINTOUT SETUP SECTION ================================================== +;;; + +;;; +; Is the PRINT keyword set? Then we have a lot of things to set up. First, +; set up carriage return and line feed variables for the formatted printout, +; and define the titles for the printed values. +; +if keyword_set(Print) then begin + if not(keyword_set(XTitle)) then XTitle = "X = " + if not(keyword_set(YTitle)) then YTitle = "Y = " + Blanks = " " + +;;; +; Now, if the XValues and/or YValues keywords are set, then deal with them. +; Also, we may want to suppress the printing of the X or Y values (e.g., +; XValues=-1 or YValues=-1 sets the ShowX and ShowY variables). +; + ShowX = 1 + UseXV = keyword_set(XValues) + if UseXV then begin + XVSt = string(XValues) + XVtop = n_elements(XValues) - 1 + XVfmt = "(A" + strtrim(max(strlen(XVst))+3,2) + ")" + if ((XVtop eq 0) and (strtrim(XVSt[0],2) eq '-1')) then ShowX = 0 + endif else XVfmt = "(A13)" + if not(ShowX) then XTitle = '' + + ShowY = 1 + UseYV = keyword_set(YValues) + if UseYV then begin + YVSt = string(YValues) + YVtop = n_elements(YValues) - 1 + YVfmt = "(A" + strtrim(max(strlen(YVst)),2) + ")" + if ((YVtop eq 0) and (strtrim(YVSt[0],2) eq '-1')) then ShowY = 0 + endif else YVfmt = "(A13)" + if not(ShowY) then YTitle = '' + +;;; +; If Print>1, then printout the informative header, which will vary depending +; on the values of the DOWN and CHANGE keywords. +; + if (Print gt 1) and not(NoWait) then begin + print + if Change then begin + print, " Hit any mouse button or move the mouse to exit." + endif else begin + if Down or Wait then begin + print, " Hit any mouse button to exit." + endif else begin + print, ' Mouse Button: LEFT MIDDLE RIGHT' + print, ' Result Action: New Line Exit Exit' + endelse + endelse + print + endif + +endif else Print = 0 + + +;;; +; FULL-SCREEN CURSOR SETUP SECTION ======================================= +;;; + +;;;; +; If using the full-screen cursor: +; Determine the data range for the full screen. +; Blank out the regular cross cursor if the CROSS keyword is not set. +; Set up the linestyle, thickness, clipping, and color parameters for the +; oplot commands. +; Set up the graphics to be XOR with the overplotted crosshair, and figure +; out the color to use for plotting the crosshair {details below}. +; +if FullCursor then begin + Yfull = convert_coord([0.0,1.0], [0.0,1.0], /NORMAL, /TO_DATA) + Xfull = Yfull[0,*] + Yfull = Yfull[1,*] + + device, GET_GRAPHICS=OldGraphics, SET_GRAPHICS=6 + if not(keyword_set(Cross)) then device, CURSOR_IMAGE=intarr(16) + + if not(keyword_set(Linestyle)) then Linestyle = 0 + if not(keyword_set(Thick)) then Thick = 1 + NoClip = keyword_set(NoClip) + +;;; +; I think the best way to make the fullscreen cursor work is to use the XOR +; graphics function - overplotting a line will XOR with the data already on +; the screen, then overplotting the same line again will XOR again, effectively +; erasing the line and returning the device to its original state/appearance. +; But first, let me present a quick primer on plotting colors in IDL and the +; related color tables and translation table: +; Normally, when a color N (a number between 0 and 255 which refers to a +; particular color in the currently loaded IDL color table) is used in one of +; the plotting or tv commands, the value that is actually sent to the display is +; the value in the N-th bin of the translation table. E.g., if the background +; color is 0, then the actual (device) color value of the background is the +; value in the zeroth bin of the translation table. Similarly, if the user +; wants to plot the color defined by number 147 in the IDL color table, the +; actual (device) color value of that color is the value in the 147th bin +; of the translation table. +; So in the following example, let's pretend we have the following situation: +; IDL> PRINT, !D.N_Colors +; 222 +; IDL> PRINT, !P.Background +; 0 +; IDL> DEVICE, TRANSLATION=TTab +; IDL> PRINT, TTab[0] +; 34 +; IDL> PRINT, TTab[147] +; 181 +; When we set DEVICE,SET_GRAPHICS=6, and do an overplot, it performs an XOR +; function between the overplot's translated color value and the background's +; translated color value. +; If we want the resulting color to be the IDL color 147, then we have to +; overplot with the color whose translated color value XOR'ed with the +; background's translated color value (34) will equal 181, which is the +; translated color value of the desired IDL color 147. +; +; Symbolically: +; * TTab[Desired Color] = TTab[OPLOT color] XOR TTab[Background] +; * OPLOT Color = where( TTab eq (TTab[Desired Color] XOR TTab[Background]) ) +; +; Numerically {using the above example}: +; * OPLOT Color = where( TTab eq (TTab[147] XOR TTab[0]) ) +; * OPLOT Color = where( TTab eq (181 XOR 34) ) +; * OPLOT Color = where( TTab eq 151 ) +; +; Fine. +; HOWEVER...since the translation table often does NOT contain the full range +; of possible numbers (e.g., 0 to 255), the result of the XOR function between +; the background and the oplot color may be a value that does NOT appear in the +; translation table. This is particularly a problem for colors near the bottom +; of the translation table where the result of the XOR function may be less than +; the lowest value in TTab. +; To fix this problem, I bypass the translation table, and directly send the +; device color (e.g., the value 151 in the above example) to the OPLOT command. +; There is still some bug here - sometimes the color still isn't right. I'll +; have to talk to the IDL support people about this {as soon as our support +; license is renewed!} +; NOTE: Took a while to figure out how to make the full cursor work with +; both a specified cursor color and a non-black background. We stick +; with the XOR graphics function. However, we need to deal with the +; complex case of an indexed color model (Decompositon off) for the +; TrueColor and DirectColor visual classes. For TrueColor, we get +; the RGB triplet stored in the color table at the indices specified +; by Color and BackGround and convert them to 24-bit decomposed color +; indices. Then we turn on color decomposition. Before we exit, we +; turn it back off. For DirectColor, we just need to XOR the 8-bit +; color table indices. -Robishaw +; + + ; CHECK FOR THE VISUAL CLASS AND COLOR DECOMPOSITION STATE... + device, Get_Visual_Name=VisualName, Get_Decomposed=Decomposed + + ; SET COLOR KEYWORDS IF NOT DEFINED... + if ((size(Color))[1] eq 0) then $ ; if undefined + Color = Decomposed ? !D.N_Colors - 1 : !D.Table_Size - 1 + if (N_elements(BACKGROUND) eq 0) then BackGround = !P.BackGround + + ; Are we using a TrueColor or DirectColor visual class... + if (VisualName eq 'TrueColor') OR (VisualName eq 'DirectColor') then begin + if (VisualName eq 'TrueColor') AND not(Decomposed) then begin + ; For TrueColor with color decomposition off, we need to... + ; Turn on Color Decomposition... + device, Decomposed=1 + ; Get the RGB triplets stored in our color table... + tvlct, rct, gct, bct, /GET + ; Find the corresponding 24-bit decomposed color indices... + CTab = long(rct) + ishft(long(gct),8) + ishft(long(bct),16) + DevColor = CTab[Color] + DevBack = CTab[BackGround] + endif else begin + ; If TrueColor or Directcolor with Decomposition On, or + ; DirectColor with Decomposition Off... + DevColor = Color + DevBack = BackGround + endelse + endif else begin + ; If we're not using TrueColor or DirectColor, then we'll + ; access the translation table... + device, TRANSLATION=TTab, BYPASS_TRANSLATION=1 + if (Color ge !D.Table_size) then $ + message, /INFO, $ + 'Trying to draw cursor with color table index GT Table Size' + DevColor = TTab[Color < (!D.Table_size - 1)] + if (BackGround ge !D.Table_size) then $ + message, /INFO, $ + 'Specified background has color table index GT Table Size' + DevBack = TTab[BackGround < (!D.Table_size - 1)] + endelse + OColor = DevColor xor DevBack +endif + + +;;; +; FINALLY...THE PLOT READING SECTION ==================================== +;;; + +;;; +; If the cursor is beyond the boundaries of the window (device coordinates of +; X=-1 and Y=-1), then wait until the cursor is moved into the window. +; +cursor, X, Y, /NOWAIT, /DEVICE +if ((X lt 0) or (Y lt 0)) then cursor, X, Y, /CHANGE + + +;;; +; Begin the loop that will repeat until a button is clicked (or a change if +; that is what the user wanted). Err0 is used to keep track if the procedure +; was entered with a key already down, then it will be non-zero until that +; key has been released, at which point it will be permanantly set to zero. +; NOTE: Robishaw's edits make Err0 obsolete so these lines are commented. +; Wait for a change (movement or key click). Delete the old lines, and +; if we don't exit the loop, repeat and draw new lines. +; +cursor, X, Y, /NOWAIT, DATA=Data, DEVICE=Device, NORMAL=Normal +;Err0 = !mouse.button + +NClicks = 0l +repeat begin ; here we go! + +;;; +; This wait is a kludge to prevent ghosts from being left when /FULLCURSOR +; is set. +; + if FullCursor then wait, 0 ; black magic + +;;; +; If doing a full-screen cursor, overplot two full-screen lines intersecting +; at that position. +; + if FullCursor then begin + XY = convert_coord(X,Y, DATA=Data,DEVICE=Device,NORMAL=Normal, /TO_DATA) + Xdata = XY[0] * [1.0,1.0] + Ydata = XY[1] * [1.0,1.0] + oplot,Xdata,Yfull,LINE=Linestyle,THICK=Thick,NOCLIP=NoClip,COLOR=OColor + oplot,Xfull,Ydata,LINE=Linestyle,THICK=Thick,NOCLIP=NoClip,COLOR=OColor + endif + +;;; +; If printing out data values, do so. +; !mouse.button=1 is the signal for a new line. +; + if (Print gt 0) then begin + + if ShowX then begin + if UseXV then Xst = XVSt[(X+0.5) > 0 < XVtop] else Xst = strtrim(X,2) + XSt = XTitle + string(Xst + Blanks, FORMAT=XVfmt) + endif else Xst = '' + if ShowY then begin + if UseYV then Yst = YVSt[(Y+0.5) > 0 < YVtop] else Yst = strtrim(Y,2) + YSt = YTitle + string(Yst + Blanks, FORMAT=YVfmt) + endif else Yst = '' + + print, Xst, Yst, format='($,2A,%"\R")' + + ; If left button pressed, then print out a new line; accumulate + ; position if /ACCUMULATE set... + if (!mouse.button eq 1) and $ + not(Down or Wait or Change or NoWait) then begin ; new line? + print, format='($,%"\n")' + NClicks++ + if Arg_Present(y) then begin + if keyword_set(ACCUMULATE) && (NClicks gt 1) then begin + xout = [xout,x] + yout = [yout,y] + endif else begin + xout = x + yout = y + endelse + endif + endif + endif + + ; If button is held down, don't continue until button is released... + if ( (!mouse.button eq 1) and not(Wait or Change or NoWait) ) $ + ; if entered with a button down, wait for next down click before + ; returning... + or ( (!mouse.button gt 1) and Down) then begin + while (!mouse.button gt 0) do begin + wait, 0.1 + cursor, XX, YY, /NOWAIT + endwhile + endif + + ;Err0 = Err0 < !mouse.button + +;;; +; Check to see that the cursor's current position is really the last measured +; position (the mouse could have moved during a delay in the last section). If +; so, then go on. If not, then wait for some change in the mouse's status +; before going on. +; In either case, once we are going on, then if doing a full-screen cursor, +; overplot the previous lines {the XOR graphics function will return the plot +; to its original appearance}. Repeat until exit signal. +; + + ; There are a few cases where we just want to exit immediately... + InstantOut = ( NoWait ) OR $ ; if /NoWait is set + ; if /WAIT is set and *any* button is pressed, even if + ; a button is being held down when the routine is called... + ( Wait AND (!mouse.button gt 0) ) OR $ + ; if /CHANGE is set and *any* button is pressed... + ( Change AND (NClicks gt 0) ) + + if ~(InstantOut) then begin + cursor, XX, YY, /NOWAIT, DATA=Data, DEVICE=Device, NORMAL=Normal + if ((XX eq X) and (YY eq Y)) then $ + cursor, XX, YY, /CHANGE, DATA=Data, DEVICE=Device, NORMAL=Normal + ; Load the new XX and YY values into the X and Y variables... + X = XX + Y = YY + endif + + ; Erase the full cursor... + if FullCursor then begin + oplot,Xdata,Yfull,LINE=Linestyle,THICK=Thick,NOCLIP=NoClip,COLOR=OColor + oplot,Xfull,Ydata,LINE=Linestyle,THICK=Thick,NOCLIP=NoClip,COLOR=OColor + endif + + ; Handle case of /CHANGE but cursor was moved rather than a button + ; clicked; we use kludge of incrementing NClicks counter... + ; this will force the new position to be printed... + if Change AND (NClicks eq 0) then begin + XOut = X + YOut = Y + NClicks++ + ExitFlag = 0 + continue + endif + + Err = !mouse.button + + ExitFlag = (Down AND (Err gt 0)) OR (Err gt 1) OR InstantOut + print,down,instantout,err,exitflag +endrep until ExitFlag +;;; +; If exit click was at a position different from last left-click, then add +; this to the list of positions... +; +if (NClicks gt 0) then begin + last_left_click = keyword_set(ACCUMULATE) ? NClicks-1 : 0 + if N_elements(Xout) Gt 0 THEN $ + if ~((X eq XOut[last_left_click]) and $ + (Y eq YOut[last_left_click])) then begin + XOut = [XOut,X] + YOut = [YOut,Y] + endif ELSE BEGIN + Xout = x + YOut = y + endELSE +endif else begin + XOut = X + YOut = Y +endelse + +if (Print gt 0) then print ; clear the last printed line + +;LABEL_DONE: + +;;; +; Done! Go back to the default Graphics and cursor in case they were changed. +; Also erase the plot ranges if they originally were not defined. +; +if FullCursor then begin + if (N_elements(CURSOR_STANDARD) eq 0) $ + then device,/CURSOR_CROSSHAIR,SET_GRAPHICS=OldGraphics,Bypass=0 $ + else device,CURSOR_STANDARD=cursor_standard,SET_GRAPHICS=OldGraphics,$ + Bypass=0 + + ; If the color decomposition was off when we started, shut it off again... + if (VisualName eq 'TrueColor') && ~Decomposed then device, Decomposed=0 +endif + +if UndefinedPlot then begin + !X.CRange = 0 + !Y.CRange = 0 +endif + +;;; +; Assign X & Y to the accumulated values if /ACCUMULATE is set... +if keyword_set(ACCUMULATE) and Arg_Present(Y) then begin + X = temporary(XOut) + Y = temporary(YOut) +endif +end ; RDPLOT diff --git a/modules/idl_downloads/astro/pro/rdpsf.pro b/modules/idl_downloads/astro/pro/rdpsf.pro new file mode 100644 index 0000000..9e72781 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rdpsf.pro @@ -0,0 +1,58 @@ +pro rdpsf,psf,hpsf,psfname +;+ +; NAME: +; RDPSF +; PURPOSE: +; Read the FITS file created by GETPSF in the DAOPHOT sequence +; EXPLANATION: +; Combines the Gaussian with the residuals to create an output PSF array. +; +; CALLING SEQUENCE: +; RDPSF, PSF, HPSF, [ PSFname] +; +; OPTIONAL INPUTS +; PSFname - string giving the name of the FITS file containing the PSF +; residuals +; +; OUTPUTS +; psf - array containing the actual PSF +; hpsf - header associated with psf +; +; PROCEDURES CALLED: +; DAO_VALUE(), MAKE_2D, SXADDPAR, READFITS(), SXPAR() +; REVISION HISTORY: +; Written W. Landsman December, 1988 +; Checked for IDL Version 2, J. Isensee & J. Hill, December, 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - RDPSF, psf, Hpsf, [ PSFname ]' + print,' PSF,HPSF - are the output PSF array and header' + print,' PSFNAME - the name of the file containing the PSF, input' + return + endif + + if N_params() EQ 2 then begin + psfname = '' + read,'Enter name of the FITS file containing the PSF residuals: ',psfname + endif + + resid = readfits(psfname, hpsf) + gauss = sxpar(hpsf,'GAUSS*') ;Get Gaussian parameters (5) + psfrad = sxpar(hpsf,'PSFRAD') ;Get PSF radius + npsf = 2*psfrad+1 ;Width of output array containing PSF + psf = fltarr(npsf,npsf) ;Create output array + dx = indgen(npsf) - psfrad ;Vector gives X distance from center of array + dy = dx ;Ditto for dy + make_2d,dx,dy ;Now have X and Y values for each pixel in +; the output array + + psf = psf + dao_value(dx,dy,gauss,resid) ;Compute DAOPHOT value at each point + + sxaddpar,hpsf,'NAXIS1',npsf ;Update header to contain PSF size + sxaddpar,hpsf,'NAXIS2',npsf ;rather than residual array size + + return + end diff --git a/modules/idl_downloads/astro/pro/read_fmr.pro b/modules/idl_downloads/astro/pro/read_fmr.pro new file mode 100644 index 0000000..b4c7199 --- /dev/null +++ b/modules/idl_downloads/astro/pro/read_fmr.pro @@ -0,0 +1,345 @@ +;+ +; NAME: +; READ_FMR +; +; PURPOSE: +; Read a journal (ApJ, AJ) machine-readable table into IDL +; +; EXPLANATION: +; Given a machine readable table name and optionally column +; numbers, this FUNCTION reads the format information in the +; meta-header and outputs a IDL function containing either the +; complete table or only the requested columns. +; +; CALLING SEQUENCE: +; data = read_fmr(filename) +; +; INPUTS: +; filename [STRING]: the name of the file containing the machine +; readable table. If filename is missing a dialog to select the +; filename will be presented +; +; INPUT KEYWORD PARAMETERS: +; /HELP - if set show the help +; +; COLUMNS - [(array of) integers or strings] of column(s) to be returned. +; If columns is of type integer they represent indices for which +; column numbers to return, if they are strings the columns with the +; corresponding names will be returned in the order as given. +; +; MISSINGVALUE [float]: value with which to replace the missing values in the +; table, default is NaN. +; +; /USE_COLNUM - If specified and non-zero then column names will be generated +; as 'C1, C2, .... Cn' for the number of columns in the table, rather +; than using the table names. +; +; OUTPUTS: +; The ouput data structure will look like: +; TYPE STRING 'mr_structure' +; NAME STRING Array[X] +; UNIT STRING Array[X] +; DESCRIPTION STRING Array[X] +; DATA STRUCT -> Array[1] +; where name contains the names of each columns +; unit contains the given units +; description contains the short descriptions and +; data holds the values of the separate columns. By default the tag names are +; taken from the column names, with modifications necessary to make them a +; valid tag name. For example, the column name 'B-V' will be converted to +; 'B_V' to become a valid tag name. If the /USE_COLNUM keyword is set, then +; the column will be named C0, C1, ... , CX, where X stands for the total +; number of columns read. +; +; RESTRICTIONS: +; (1) The file to be read should be formatted as a machine readable datafile. +; (2) Use of the COLUMN keyword currently requires use of the EXECUTE function, +; and so cannot be used with the IDL Virtual machine. +; EXAMPLE: +; meas = read_fmr('smith.dat',col=[2,5,6], /Use_colnum) +; plot,meas.data.c1,ytitle=meas.name[1]+' ('+meas.unit[1]+')' +; +; and +; data = read_fmr('smith.dat',col=['Name','Date'], /Use_colnum) +; print,meas.data.c0 +; +; MODIFICATION HISTORY: +; Version 1: +; Written by Sacha Hony (ESA) Nov 14 2003 +; Based heavily on mrcolextract by Greg Schwarz (AAS Journals +; staff scientist) on 8/16/00. +; +; Version 1.1: +; Fixed bug where column=[3,4] always returned the first few columns +; +; VErsion 2.0 By default use column names as tag names W. Landsman Feb 2010 +; Version 3.0 Use long integers W. Landsman/T. Ellsworth-Bowers May 2013 +; Version 3.1 Assume since IDL V6.4 W.L. Aug 2013 +;- + +FUNCTION read_fmr,filename, $ + columns=columns, $ + missingvalue=missingvalue, $ + help=help, $ + use_colnum = use_colnum + + compile_opt idl2 + ;; Only print the usage info and return if asked for help + IF keyword_set(help) THEN BEGIN + doc_library,'read_fmr' + return,0 + ENDIF + + ;; If no filename is given then pop-up the dialog_pickfile dialog + IF N_elements(filename) EQ 0 THEN BEGIN + filename =dialog_pickfile(filter=['*.dat;*.asc*;*.txt','*'], $ + /must_exist) + ENDIF + + ;; Check that file exists and is readable otherwise bail-out + IF ~FILE_TEST(filename) THEN BEGIN + message,'The file: '+filename+' does cannot be found or read', $ + /informational + return,0 + ENDIF + + IF N_elements(missingvalue) EQ 0 THEN missingvalue=!VALUES.F_NAN + +;; Variables needed to read single lines of the file + dumI=' ' + tmp='' + irow=0L ;; Make sure it can hold a lot of lines + startpos=' ' + endpos=' ' + +;; Variable in which the total information of the files is collected + names='' + units='' + descriptions='' + startposs=0 + idltypes=0 + + openr,lun,filename,/get_lun + +;; Read the first few lines into a dummy variable +;; because this info is not needed. However, keep +;; track of the number of lines. + WHILE (strpos(dumI,'Bytes Format') EQ -1) DO BEGIN + readf,lun,dumI + irow++ + END + + readf,lun,dumI + irow++ + +;; Read until you reach a '------' line terminator + WHILE (strpos(tmp,'-----------------') EQ -1) DO BEGIN + irow++ + +;; Extract out the 6-8th positions. +;; If there is a number you have a column + readf,lun,f='(1X,A3,1X,A3,1X,A80)',startpos,endpos,tmp + +;; If startpos is --- then you are at the end +;; so set the 9999 flag so it isn't counted + IF (startpos EQ '---') THEN startpos = '9999' + +;; If starpos is blank then this is either a continuation +;; line or a column that is only one digit wide. You can +;; tell by checking if endpos is also blank. If it is a +;; column then set startpos and endpos to the same value + IF (startpos EQ ' ') THEN BEGIN + startpos = endpos + IF (endpos EQ ' ') THEN startpos = '9999' + ENDIF + IF (fix(startpos) GE 1 AND fix(startpos) LE 999) THEN BEGIN + +;; Squeeze out the blanks. + less_blanks = strcompress(tmp) + +;; Separate the non-location info by sorting into an array that is +;; delimited by blank spaces. The first position is the format, +;; the second is the units, the third is the name, and the last +;; positions are the short description of the column + +;;(SH Nov 18 2003) strsplit is not available in older versions of IDL + components=strsplit(less_blanks,' ',/extract) + +;; Determine the column type (A|I|F|E) + vtype = strmid(components[0],0,1) + CASE vtype OF + 'A': idltype = 7 + 'I': idltype = 3 + 'F': idltype = 5 + 'E': idltype = 5 + ENDCASE + + ;; Add the collected data to the lists + names=[names,components[2]] + units=[units,components[1]] + ;; Take the rest of the strings a description + description='' + FOR i=3,n_elements(components)-1 DO description=description+ $ + components[i]+' ' + descriptions=[descriptions,description] + startposs=[startposs,startpos-1] + idltypes=[idltypes,idltype] + ENDIF + ENDWHILE + +;; iskip is the end (maybe see below) of the meta-header + iskip=irow + +;; Continue reading the file to get the number of lines + lastdash=0L + WHILE ~eof(lun) DO BEGIN + readf,lun,dumI + irow++ +;; If you encounter another '--------' (e.g. the end of a +;; notes subsection) mark it because you don't want to +;; read the previous information as data! + IF (strmid(dumI,0,6) EQ '------') THEN BEGIN + lastdash=irow + ENDIF + ENDWHILE + + ;; Make sure we close the file and free the lun + free_lun,lun + +;; If you found a '-------' line then set iskip to the last dash +;; line so not to read any extra headers + IF (lastdash NE 0L) THEN BEGIN + iskip=lastdash + ENDIF + +;; Clean the arrays from the first dummy element + names=names[1:*] + units=units[1:*] + descriptions=descriptions[1:*] + startposs=startposs[1:*] + idltypes=idltypes[1:*] + ncolumns = n_elements(startposs) + if keyword_set(USE_COLNUM) then $ + fieldnames = 'C' + strtrim(indgen(ncolumns),2) else $ + fieldnames = IDL_VALIDNAME(names,/convert_all) + + ;; now fill the template stuff for read_ascii + template = {VERSION:1.00000, $ + DATASTART:iskip, $ + DELIMITER:0B, $ + MISSINGVALUE:missingvalue, $ + COMMENTSYMBOL:'', $ + FIELDCOUNT:ncolumns, $ + FIELDTYPES:idltypes, $ + FIELDNAMES: fieldnames, $ + FIELDLOCATIONS:startposs, $ + FIELDGROUPS:indgen(ncolumns)} + + data = read_ascii(filename,template=template) + + + ;; This is all if the columns keyword is given then + ;; only certain columns are requested. So do the selections here + IF keyword_set(columns) THEN BEGIN + + ncolumns = n_elements(columns) + + ;; are they strings? + IF size(columns,/TNAME) EQ 'STRING' THEN BEGIN + + ;; first convert the columns and the output names to uppercase + ;; to be able to compare them directly without strcmp + names_up = strupcase(names) + columns_up = strupcase(columns) + + ;; create an array to hold the requested column numbers set + ;; these to -1 + idx_columns = make_array(ncolumns,value=-1) + + ;; Now match each string with the names + FOR i=0,ncolumns-1 DO BEGIN + ;; take the first instance where the uppercase name and + ;; uppercase column match + idx_columns[i] = ( where(names_up EQ columns_up[i]) )[0] + ENDFOR + + ;; Are there elements which did not find a match? + idx_missing_columns = where(idx_columns EQ -1,cnt) + + ;; All the elements of idx_columns are -1 + IF (cnt EQ ncolumns) THEN BEGIN + message,'None of the column names could be found in the table', $ + /informational + return,0 + ENDIF + + ;; Some elements are matched but some are missing + IF (cnt NE 0) THEN BEGIN + message,'The following columns are not present in the table:', $ + /informational + message,columns[idx_missing_columns], $ + /informational + ;; Only take the valid columns and still continue + idx_columns =idx_columns[where(idx_columns NE -1)] + ENDIF + + ENDIF ELSE BEGIN + ;; Assume the columns are numbers which indicate the + ;; requested column numbers + + max_column=n_tags(data)-1 + columns = fix(columns) + ;; make sure they are not higher than the available number + ;; of columns and not negative + idx_columns = columns[where( (columns LE max_column) AND $ + (columns GE 0) ,cnt)] + + IF (cnt EQ 0) THEN BEGIN + message,'The requested columns are not present in the file', $ + /informational + return,0 + ENDIF + + ;; Some elements are matched but some are too high + IF cnt NE ncolumns THEN BEGIN + message,'Some column numbers are out of range.'+ $ + ' Valid range=[0,'+ $ + strcompress(string(max_column),/remove_all)+']', $ + /informational + ENDIF + ENDELSE + +;; now take the requested columns + names=names[idx_columns] + units=units[idx_columns] + if ~keyword_set(use_colnum) then fieldnames = fieldnames[idx_columns] $ + else fieldnames = 'C' + strtrim(indgen(ncolumns),2) + descriptions=descriptions[idx_columns] + ncolumns = n_elements(names) + + + ;; We need this to restructure the data structure to hold only + ;; the requested columns + exec_string = 'data={' + fieldnames[0] + $ + ':data.('+string(idx_columns[0])+')' + FOR i=1,ncolumns-1 DO BEGIN + exec_string = exec_string + ',' + fieldnames[i] + $ + ':data.('+string(idx_columns[i])+')' + ENDFOR + exec_string=exec_string+'}' + foo = execute(exec_string) + ENDIF + + + out = {type:'mr_structure', $ + name:names, $ + unit:units, $ + description:descriptions, $ + data:data} + + message,"Read "+strcompress(ncolumns)+" columns from "+ $ + filename,/informational + + return,out + +END diff --git a/modules/idl_downloads/astro/pro/read_ipac_table.pro b/modules/idl_downloads/astro/pro/read_ipac_table.pro new file mode 100644 index 0000000..cf98664 --- /dev/null +++ b/modules/idl_downloads/astro/pro/read_ipac_table.pro @@ -0,0 +1,521 @@ +FUNCTION read_ipac_table, filename, change_null=change_null, debug=debug + +;+ +; NAME: +; READ_IPAC_TABLE +; +; PURPOSE: +; Read an IPAC ascii table from a file into an IDL structure +; +; EXPLANATION: +; Reads an IPAC ascii table from a file into an IDL structure. The +; definition of an IPAC-format table is currently here: +; http://irsa.ipac.caltech.edu/applications/DDGEN/Doc/ipac_tbl.html +; +; CALLING SEQUENCE: +; info = read_ipac_table(filename, [change_null=change_null, /debug]) +; +; INPUTS: +; FILENAME -- string giving the file with the input IPAC ascii table +; +; OPTIONAL INPUT: +; CHANGE_NULL -- an integer value to be used when the IPAC table +; has a non-numeric string for null values in an +; integer column. The default is -9999. For +; floating-point columns, this is 'NaN'. +; +; DEBUG -- enables some debugging statements +; +; OUTPUTS: +; info - Anonymous IDL structure containing information on the catalog. The structure +; tag names are taken from the column names. The structure will put header +; information in tags starting with "HEADER", e.g. +; HEADER_TABLE_HEADER, HEADER_DATA_UNITS, and HEADER_NULL_VALUES. +; Since the table column names may be altered if they are +; not valid IDL variable names, the original column names +; are saved as HEADER_COL_NAMES_ORIG. The original data +; type names are also saved as HEADER_COL_TYPES_ORIG. +; +; If the table is not valid, or contains no data, the function returns a value of -1 +; +; PROCEDURES USED: +; GET_DATE, VALID_NUM +; +; MODIFICATION HISTORY: +; Written by H. Teplitz, IPAC September 2010 +; Allow long integer, convert blanks in numeric fields to null +; value - T. Brooke, IPAC May 2011 +; Allow 64bit long; use valid_num to check - TB June 2013 +;- + +;Copyright © 2013, California Institute of Technology +;All rights reserved. Based on Government Sponsored Research NAS7-03001 and NNN12AA01C. +; +; +;Redistribution and use in source and binary forms, with or without +;modification, are permitted provided that the following conditions +;are met: +; +; * Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; +; * 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. +; +; * Neither the name of the California Institute of Technology +; (Caltech) nor the names of its contributors may be used to +; endorse or promote products derived from this software without +; specific prior written permission. +; +;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +;BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +;OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED +;AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +;LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY +;WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;POSSIBILITY OF SUCH DAMAGE. +; + +on_error,2 +compile_opt idl2 + +IF N_params() lt 1 THEN BEGIN + print,'Syntax - info = read_ipac_table(filename, [change_null=change_null, /debug])' + return, -1 +ENDIF + +file = filename +n_lines = file_lines(file) + +IF keyword_set(change_null) THEN BEGIN + IF ( NOT(valid_num(change_null,/integer)) ) THEN BEGIN + print, 'ERROR: change null value must be integer.' + return,-1 + ENDIF ELSE BEGIN + null_num = change_null + ENDELSE +ENDIF ELSE null_num = -9999 + +line='' +inline='' +inheader='' + +already_read = 0 +lines_read = 0 + +openr, lun, file, /get_lun + +firstchar = '\' +WHILE firstchar NE '|' DO BEGIN + readf, lun, inline + lines_read = lines_read+1 + IF EOF(lun) THEN BEGIN + print, 'ERROR: Invalid IPAC table - no header lines' + return, -1 + ENDIF + firstchar = strmid(inline,0,1) + IF firstchar EQ '\' THEN inheader = [inheader,inline] +ENDWHILE + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; use first line with '|' to find indices between columns +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +line = inline +len = strlen(line) + +;;;; check for trailing spaces after last | + +pos = strpos(line,'|',/reverse_search) +IF (pos lt 2) THEN BEGIN + print,'ERROR: invalid table column header' + return, -1 +ENDIF ELSE BEGIN + len = pos + 1 + line = strmid(line,0,len) +ENDELSE + +name_line_length = len +subline = line + +strput, subline, 'x', 0 +delim_idx = [0] +eol=0 +WHILE NOT(eol) DO BEGIN + char = strpos(subline,'|') + IF char NE -1 THEN begin + strput, subline, 'x', char + delim_idx = [delim_idx, char] + ENDIF + IF char EQ len-1 THEN eol=1 +ENDWHILE + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; check for at least 1 column +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +IF n_elements(delim_idx) le 1 THEN BEGIN + print, 'ERROR: invalid table header' + return, -1 +ENDIF + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; get column names and put into a strarr +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ncol = n_elements(delim_idx)-1 +col_names = strarr(ncol) +col_names_orig = strarr(ncol) +col_width = intarr(ncol) +FOR i = 0, ncol-1 DO BEGIN + col_width[i] = delim_idx[i+1]-delim_idx[i]-1 + col_names[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + col_names_orig[i] = col_names[i] +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; check for duplicate column names, add "_idl_[i]" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +cntr = intarr(ncol)*0 + 1 +FOR ik = 0, ncol-2 DO BEGIN + FOR ij = ik+1, ncol-1 DO BEGIN + IF (strcmp(col_names[ij],col_names[ik],/fold_case)) THEN BEGIN + col_names[ij] = col_names[ij] + '_idl_' + strn(cntr[ik]) + cntr[ik] = cntr[ik] + 1 + print,'WARNING: Duplicate column names, replacing occured' + ENDIF + ENDFOR +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; next line must be data types +;;;; need error check if it isn't.... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +readf, lun, inline +lines_read = lines_read+1 + +;;;; check for no data after types line +IF EOF(lun) THEN BEGIN + print, 'ERROR: invalid table; no data' + return, -1 +ENDIF + +line=inline + +IF strmid(line, 0, 1) NE '|' THEN BEGIN + print, 'ERROR: invalid or missing data types line' + return, -1 +ENDIF + +col_type_string = strarr(ncol) +col_types_orig = strarr(ncol) +col_type_code = intarr(ncol) + +FOR i = 0, ncol-1 DO BEGIN + ;;; strip spaces from data type and convert to all upper case + col_type_string[i] = strupcase(strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2)) + col_types_orig[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in data types line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + +;;; convert data types to + + CASE col_type_string[i] OF + 'INTEGER': BEGIN + col_type_code[i] = 3 + print, 'Data type INTEGER is used. For full compatibility with all IPAC services, please use INT, IN or I' + END + 'INT': col_type_code[i] = 3 + 'IN': col_type_code[i] = 3 + 'I': col_type_code[i] = 3 + 'LONG': col_type_code[i] = 14 + 'LON': col_type_code[i] = 14 + 'LO': col_type_code[i] = 14 + 'L': col_type_code[i] = 14 + 'FLOAT': col_type_code[i] = 4 + 'FLOA': col_type_code[i] = 4 + 'FLO': col_type_code[i] = 4 + 'FL': col_type_code[i] = 4 + 'F': col_type_code[i] = 4 + 'REAL': col_type_code[i] = 4 + 'REA': col_type_code[i] = 4 + 'RE': col_type_code[i] = 4 + 'R': col_type_code[i] = 4 + 'DOUBLE': col_type_code[i] = 5 + 'DOUBL': col_type_code[i] = 5 + 'DOUB': col_type_code[i] = 5 + 'DOU': col_type_code[i] = 5 + 'DO': col_type_code[i] = 5 + 'D': col_type_code[i] = 5 + 'CHAR': col_type_code[i] = 7 + 'CHA': col_type_code[i] = 7 + 'CH': col_type_code[i] = 7 + 'C': col_type_code[i] = 7 + 'DATE': col_type_code[i] = 7 + 'DAT': col_type_code[i] = 7 + 'DA': col_type_code[i] = 7 + ELSE: BEGIN + print, 'ERROR: invalid data type = '+col_type_string[i] + IF keyword_set(debug) then stop + return,-1 + ENDELSE + ENDCASE + +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; create the basic structure +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +get_date, dte, /time +info = create_struct('HEADER_Date_Created', string(dte)) +n_header_lines = 1 + +n_header = n_elements(inheader) +IF n_header GT 1 THEN BEGIN + current = info + info = create_struct(current, 'HEADER_TABLE_HEADER', inheader[1:n_header-1]) + n_header_lines = n_header_lines+1 +ENDIF + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Save the original column names and column types. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +current = info +info = create_struct(current, 'HEADER_Col_Names_Orig', col_names_orig) +n_header_lines = n_header_lines+1 +current = info +info = create_struct(current, 'HEADER_Col_Types_Orig', col_types_orig) +n_header_lines = n_header_lines+1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; Read next line. If it starts with a pipe, it should be the units line. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +readf, lun, inline + +line=inline + +IF strmid(inline,0,1) EQ '|' THEN BEGIN + lines_read = lines_read+1 + data_units_string = strarr(ncol) + FOR i = 0, ncol-1 DO BEGIN + ;;; strip spaces from units + data_units_string[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in units line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + endfor + current = info + info = create_struct(current, 'HEADER_Data_Units', data_units_string) + n_header_lines = n_header_lines+1 +; remember to add lines to structure and to increment lines_read +ENDIF $ +ELSE already_read = 1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; If the line was data units then read next line. +;;;;; If it starts with a pipe, it should be the nulls line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +IF NOT(already_read) THEN BEGIN + readf, lun, inline + line=inline + + IF strmid(inline,0,1) EQ '|' THEN BEGIN + lines_read = lines_read+1 + null_value_string = strarr(ncol) + new_null_value_string = strarr(ncol) + FOR i = 0, ncol-1 DO BEGIN +;;; strip spaces from nulls + null_value_string[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in nulls line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + + IF (col_type_code[i] ne 7) THEN BEGIN + IF ( (col_type_code[i] eq 4) or (col_type_code[i] eq 5) ) THEN BEGIN + check_num = valid_num(null_value_string[i]) + IF (check_num eq 0) THEN BEGIN + new_null_value_string[i] = 'NaN' + ENDIF ELSE BEGIN + new_null_value_string[i] = null_value_string[i] + ENDELSE + ENDIF ELSE BEGIN + check_num = valid_num(null_value_string[i], /integer) + IF (check_num eq 0) THEN BEGIN + new_null_value_string[i] = strn(null_num) + ENDIF ELSE BEGIN + new_null_value_string[i] = null_value_string[i] + ENDELSE + ENDELSE + ENDIF ELSE new_null_value_string[i] = null_value_string[i] + ENDFOR + ENDIF ELSE BEGIN + null_value_string = strarr(ncol)+'no input null strings' + new_null_value_string = null_value_string + iwant = where ( ( (col_type_code eq 4) or (col_type_code eq 5) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = 'NaN' + iwant = where ( ( (col_type_code eq 3) or (col_type_code eq 14) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = strn(null_num) + already_read = 1 + ENDELSE +ENDIF ELSE BEGIN + null_value_string = strarr(ncol)+'no input null strings' + new_null_value_string = null_value_string + iwant = where ( ( (col_type_code eq 4) or (col_type_code eq 5) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = 'NaN' + iwant = where ( ( (col_type_code eq 3) or (col_type_code eq 14) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = strn(null_num) +ENDELSE + +current = info +info = create_struct(current, 'HEADER_Null_Values', new_null_value_string) +n_header_lines = n_header_lines+1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; set up data structure. length of vectors is number of lines in +;;;;; file minus lines read so far +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ndata = n_lines - lines_read + +IF ndata LE 0 THEN BEGIN + print, 'ERROR: no data' + return, -1 +ENDIF + +FOR i = 0, ncol-1 DO BEGIN + current = info + info = create_struct(current, $ + IDL_VALIDNAME(col_names[i],/convert_all),make_array(ndata, type=col_type_code[i])) +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; read data lines to put into structure +;;;;; and pad the line if it isn't long enough for all columns +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +lmax = 2.0d^63 - 1.0d +lmin = -2.0d^63 +lmaxi = 2.0d^31 - 1.0d +lmini = -2.0d^31 + +FOR j = 0, ndata-1 DO BEGIN + + IF NOT(already_read) THEN readf, lun, inline + +;;;; check for non-printable characters + IF ( (stregex(inline,string(9b)) ne -1) or $ + (stregex(inline,string(7b)) ne -1) or $ + (stregex(inline,string(8b)) ne -1) or $ + (stregex(inline,string(10b)) ne -1) or $ + (stregex(inline,string(11b)) ne -1) or $ + (stregex(inline,string(12b)) ne -1) or $ + (stregex(inline,string(13b)) ne -1) or $ + (stregex(inline,string(27b)) ne -1) ) THEN BEGIN + print,'Non-printable character in data row = ',j + return,-1 + ENDIF + + cur_len = strlen(inline) + IF cur_len LT name_line_length THEN BEGIN + padlen = name_line_length - cur_len + pad = strjoin(replicate(' ', padlen)) + line = inline+pad + ENDIF ELSE line=inline + + FOR i = 0, ncol-1 DO BEGIN + data_string = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i],1) + IF check NE ' ' THEN BEGIN + print, 'ERROR: misaligned columns (data under pipe)' + print, 'ERROR: data row, column = ',j,' , ',i + IF keyword_set(debug) THEN stop + return, -1 + ENDIF + IF (col_type_code[i] ne 7) THEN BEGIN + IF ( (col_type_code[i] eq 4) or (col_type_code[i] eq 5) ) THEN BEGIN + check_num = valid_num(data_string) + IF (check_num eq 0) THEN BEGIN + IF (data_string ne null_value_string[i]) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Invalid data entry replaced by null value in row, column = ',j,', ',i + ENDIF ELSE data_string = new_null_value_string[i] + ENDIF +;;;; Check floating point limits + IF (check_num ne 0) THEN BEGIN + check_lim = fix(data_string, type=5) + IF (finite(check_lim)) THEN BEGIN + IF (col_type_code[i] eq 4) THEN BEGIN + check_lim = fix(data_string, type=4) + IF ( NOT(finite(check_lim)) ) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Float overflow replaced by null value in row, column = ',j,', ',i + ENDIF + ENDIF + ENDIF ELSE BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Double overflow replaced by null value in row, column = ',j,', ',i + ENDELSE + ENDIF + ENDIF ELSE BEGIN + check_num = valid_num(data_string,/integer) + IF (check_num eq 0) THEN BEGIN + IF (data_string ne null_value_string[i]) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Invalid data entry replaced by null value in row, column = ',j,', ',i + ENDIF ELSE data_string = new_null_value_string[i] + ENDIF +;;;; Check integer limits + IF (check_num ne 0) THEN BEGIN + check_lim = fix(data_string, type=5) + IF ( (check_lim gt lmin) and (check_lim lt lmax) ) THEN BEGIN + IF (col_type_code[i] eq 3) THEN BEGIN + IF ( (check_lim le lmini) or (check_lim ge lmaxi) ) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Integer overflow replaced by null value in row, column = ',j,', ',i + ENDIF + ENDIF + ENDIF ELSE BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Long overflow replaced by null value in row, column = ',j,', ',i + ENDELSE + ENDIF + ENDELSE + ENDIF + info.(i+n_header_lines)[j] = data_string + ENDFOR + already_read=0 +ENDFOR + +close, lun +free_lun, lun + +return, info + +END + + + diff --git a/modules/idl_downloads/astro/pro/read_ipac_var.pro b/modules/idl_downloads/astro/pro/read_ipac_var.pro new file mode 100644 index 0000000..0d0f49d --- /dev/null +++ b/modules/idl_downloads/astro/pro/read_ipac_var.pro @@ -0,0 +1,528 @@ +FUNCTION read_ipac_var, textvar, change_null=change_null, debug=debug + +;+ +; NAME: +; READ_IPAC_VAR +; +; PURPOSE: +; Read an IPAC ascii table from a variable into an IDL structure. +; Used by query_irsa_cat.pro. +; +; EXPLANATION: +; Reads an IPAC ascii table from a variable into an IDL structure. The +; definition of an IPAC-format table is currently here: +; http://irsa.ipac.caltech.edu/applications/DDGEN/Doc/ipac_tbl.html +; +; CALLING SEQUENCE: +; info = read_ipac_var(textvar, [change_null=change_null, /debug]) +; +; INPUTS: +; TEXTVAR -- a text variable with the table returned from the query +; +; OPTIONAL INPUT: +; CHANGE_NULL -- an integer value to be used when the IPAC table +; has a non-numeric string for null values in an +; integer column. The default is -9999. For +; floating-point columns, this is 'NaN'. +; +; DEBUG -- enables some debugging statements +; +; OUTPUTS: +; info - Anonymous IDL structure containing information on the catalog. The structure +; tag names are taken from the column names. The structure will put header +; information in tags starting with "HEADER", e.g. +; HEADER_TABLE_HEADER, HEADER_DATA_UNITS, and HEADER_NULL_VALUES. +; Since the table column names may be altered if they are +; not valid IDL variable names, the original column names +; are saved as HEADER_COL_NAMES_ORIG. The original data +; type names are also saved as HEADER_COL_TYPES_ORIG. +; +; If the table is not valid, or contains no data, the function returns a value of -1 +; +; PROCEDURES USED: +; GET_DATE, VALID_NUM +; +; NOTES: +; Uses some unnecessary looping, but it's kept this way to stay +; similar to read_ipac_table.pro. +; +; MODIFICATION HISTORY: +; Adapted from read_ipac_table - C. Gonzalez, U. Alicante March 2011 +; Allow long integer, convert blanks in numeric fields to null +; value - T. Brooke, IPAC May 2011 +; Allow 64bit long; use valid_num to check - TB June 2013 +;- + +;Copyright © 2013, California Institute of Technology +;All rights reserved. Based on Government Sponsored Research NAS7-03001 and NNN12AA01C. +; +; +;Redistribution and use in source and binary forms, with or without +;modification, are permitted provided that the following conditions +;are met: +; +; * Redistributions of source code must retain the above copyright +; notice, this list of conditions and the following disclaimer. +; +; * 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. +; +; * Neither the name of the California Institute of Technology +; (Caltech) nor the names of its contributors may be used to +; endorse or promote products derived from this software without +; specific prior written permission. +; +;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +;BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +;OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED +;AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +;LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY +;WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;POSSIBILITY OF SUCH DAMAGE. +; + +on_error,2 +compile_opt idl2 + +n_lines = n_elements(textvar) +IF (n_lines eq 0) THEN BEGIN + print,'ERROR: Empty variable' + return,-1 +ENDIF + +IF keyword_set(change_null) THEN BEGIN + IF ( NOT(valid_num(change_null,/integer)) ) THEN BEGIN + print, 'ERROR: change null value must be integer.' + return,-1 + ENDIF ELSE BEGIN + null_num = change_null + ENDELSE +ENDIF ELSE null_num = -9999 + +line='' +inline='' +inheader='' + +already_read = 0 +lines_read = 0 + +firstchar = '\' +WHILE ( (firstchar ne '|') and (lines_read lt n_lines) ) DO BEGIN + inline = textvar[lines_read] + lines_read = lines_read+1 + firstchar = strmid(inline,0,1) + IF firstchar EQ '\' THEN inheader = [inheader,inline] +ENDWHILE + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; if at end then it means no column header or only 1 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +IF (lines_read eq n_lines) THEN BEGIN + print, 'ERROR: invalid table column header' + return, -1 +ENDIF + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; use first line with '|' to find indices between columns +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +line = inline +len = strlen(line) + +;;;; check for trailing spaces after last | + +pos = strpos(line,'|',/reverse_search) +IF (pos lt 2) THEN BEGIN + print,'ERROR: invalid table column header' + return, -1 +ENDIF ELSE BEGIN + len = pos + 1 + line = strmid(line,0,len) +ENDELSE + +name_line_length = len +subline = line + +strput, subline, 'x', 0 +delim_idx = [0] +eol=0 +WHILE NOT(eol) DO BEGIN + char = strpos(subline,'|') + IF char NE -1 THEN begin + strput, subline, 'x', char + delim_idx = [delim_idx, char] + ENDIF + IF char EQ len-1 THEN eol=1 +ENDWHILE + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; check for at least 1 column +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +IF n_elements(delim_idx) le 1 THEN BEGIN + print, 'ERROR: invalid table header' + return, -1 +ENDIF + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; get column names and put into a strarr +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ncol = n_elements(delim_idx)-1 +col_names = strarr(ncol) +col_names_orig = strarr(ncol) +col_width = intarr(ncol) +FOR i = 0, ncol-1 DO BEGIN + col_width[i] = delim_idx[i+1]-delim_idx[i]-1 + col_names[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + col_names_orig[i] = col_names[i] +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; check for duplicate column names, add "_idl_[i]" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +cntr = intarr(ncol)*0 + 1 +FOR ik = 0, ncol-2 DO BEGIN + FOR ij = ik+1, ncol-1 DO BEGIN + IF (strcmp(col_names[ij],col_names[ik],/fold_case)) THEN BEGIN + col_names[ij] = col_names[ij] + '_idl_' + strn(cntr[ik]) + cntr[ik] = cntr[ik] + 1 + print,'WARNING: Duplicate column names, replacing occured' + ENDIF + ENDFOR +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; next line must be data types +;;;; need error check if it isn't.... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +inline = textvar[lines_read] +lines_read = lines_read+1 + +;;;; check for no data after types line +IF (lines_read eq n_lines) THEN BEGIN + print, 'ERROR: invalid table; no data' + return, -1 +ENDIF + +line=inline + +IF strmid(line, 0, 1) NE '|' THEN BEGIN + print, 'ERROR: invalid or missing data types line' + return, -1 +ENDIF + +col_type_string = strarr(ncol) +col_types_orig = strarr(ncol) +col_type_code = intarr(ncol) + +FOR i = 0, ncol-1 DO BEGIN + ;;; strip spaces from data type and convert to all upper case + col_type_string[i] = strupcase(strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2)) + col_types_orig[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in data types line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + +;;; convert data types to + + CASE col_type_string[i] OF + 'INTEGER': BEGIN + col_type_code[i] = 3 + print, 'Data type INTEGER is used. For full compatibility with all IPAC services, please use INT, IN or I' + END + 'INT': col_type_code[i] = 3 + 'IN': col_type_code[i] = 3 + 'I': col_type_code[i] = 3 + 'LONG': col_type_code[i] = 14 + 'LON': col_type_code[i] = 14 + 'LO': col_type_code[i] = 14 + 'L': col_type_code[i] = 14 + 'FLOAT': col_type_code[i] = 4 + 'FLOA': col_type_code[i] = 4 + 'FLO': col_type_code[i] = 4 + 'FL': col_type_code[i] = 4 + 'F': col_type_code[i] = 4 + 'REAL': col_type_code[i] = 4 + 'REA': col_type_code[i] = 4 + 'RE': col_type_code[i] = 4 + 'R': col_type_code[i] = 4 + 'DOUBLE': col_type_code[i] = 5 + 'DOUBL': col_type_code[i] = 5 + 'DOUB': col_type_code[i] = 5 + 'DOU': col_type_code[i] = 5 + 'DO': col_type_code[i] = 5 + 'D': col_type_code[i] = 5 + 'CHAR': col_type_code[i] = 7 + 'CHA': col_type_code[i] = 7 + 'CH': col_type_code[i] = 7 + 'C': col_type_code[i] = 7 + 'DATE': col_type_code[i] = 7 + 'DAT': col_type_code[i] = 7 + 'DA': col_type_code[i] = 7 + ELSE: BEGIN + print, 'ERROR: invalid data type = '+col_type_string[i] + IF keyword_set(debug) then stop + return,-1 + ENDELSE + ENDCASE + +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; create the basic structure +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +get_date, dte, /time +info = create_struct('HEADER_Date_Created', string(dte)) +n_header_lines = 1 + +n_header = n_elements(inheader) +IF n_header GT 1 THEN BEGIN + current = info + info = create_struct(current, 'HEADER_TABLE_HEADER', inheader[1:n_header-1]) + n_header_lines = n_header_lines+1 +ENDIF + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Save the original column names and column types. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +current = info +info = create_struct(current, 'HEADER_Col_Names_Orig', col_names_orig) +n_header_lines = n_header_lines+1 +current = info +info = create_struct(current, 'HEADER_Col_Types_Orig', col_types_orig) +n_header_lines = n_header_lines+1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; Read next line. If it starts with a pipe, it should be the units line. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +inline = textvar[lines_read] + +line=inline + +IF strmid(inline,0,1) EQ '|' THEN BEGIN + lines_read = lines_read+1 + data_units_string = strarr(ncol) + FOR i = 0, ncol-1 DO BEGIN + ;;; strip spaces from units + data_units_string[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in units line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + endfor + current = info + info = create_struct(current, 'HEADER_Data_Units', data_units_string) + n_header_lines = n_header_lines+1 +; remember to add lines to structure and to increment lines_read +ENDIF $ +ELSE already_read = 1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; If the line was data units then read next line. +;;;;; If it starts with a pipe, it should be the nulls line +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +IF NOT(already_read) THEN BEGIN + inline = textvar[lines_read] + line=inline + + IF strmid(inline,0,1) EQ '|' THEN BEGIN + lines_read = lines_read+1 + null_value_string = strarr(ncol) + new_null_value_string = strarr(ncol) + FOR i = 0, ncol-1 DO BEGIN +;;; strip spaces from nulls + null_value_string[i] = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i+1],1) + IF check NE '|' THEN BEGIN + print, 'ERROR: missing pipe in nulls line' + IF keyword_set(debug) then stop + return, -1 + ENDIF + + IF (col_type_code[i] ne 7) THEN BEGIN + IF ( (col_type_code[i] eq 4) or (col_type_code[i] eq 5) ) THEN BEGIN + check_num = valid_num(null_value_string[i]) + IF (check_num eq 0) THEN BEGIN + new_null_value_string[i] = 'NaN' + ENDIF ELSE BEGIN + new_null_value_string[i] = null_value_string[i] + ENDELSE + ENDIF ELSE BEGIN + check_num = valid_num(null_value_string[i], /integer) + IF (check_num eq 0) THEN BEGIN + new_null_value_string[i] = strn(null_num) + ENDIF ELSE BEGIN + new_null_value_string[i] = null_value_string[i] + ENDELSE + ENDELSE + ENDIF ELSE new_null_value_string[i] = null_value_string[i] + ENDFOR + ENDIF ELSE BEGIN + null_value_string = strarr(ncol)+'no input null strings' + new_null_value_string = null_value_string + iwant = where ( ( (col_type_code eq 4) or (col_type_code eq 5) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = 'NaN' + iwant = where ( ( (col_type_code eq 3) or (col_type_code eq 14) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = strn(null_num) + already_read = 1 + ENDELSE +ENDIF ELSE BEGIN + null_value_string = strarr(ncol)+'no input null strings' + new_null_value_string = null_value_string + iwant = where ( ( (col_type_code eq 4) or (col_type_code eq 5) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = 'NaN' + iwant = where ( ( (col_type_code eq 3) or (col_type_code eq 14) ),nwant) + if (nwant gt 0) then new_null_value_string[iwant] = strn(null_num) +ENDELSE + +current = info +info = create_struct(current, 'HEADER_Null_Values', new_null_value_string) +n_header_lines = n_header_lines+1 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; set up data structure. length of vectors is number of lines in +;;;;; file minus lines read so far +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +ndata = n_lines - lines_read + +IF ndata LE 0 THEN BEGIN + print, 'ERROR: no data' + return, -1 +ENDIF + +FOR i = 0, ncol-1 DO BEGIN + current = info + info = create_struct(current, $ + IDL_VALIDNAME(col_names[i],/convert_all),make_array(ndata, type=col_type_code[i])) +ENDFOR + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; read data lines to put into structure +;;;;; and pad the line if it isn't long enough for all columns +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +lmax = 2.0d^63 - 1.0d +lmin = -2.0d^63 +lmaxi = 2.0d^31 - 1.0d +lmini = -2.0d^31 + +FOR j = 0, ndata-1 DO BEGIN + + IF NOT(already_read) THEN BEGIN + inline = textvar[lines_read] + lines_read = lines_read + 1 + ENDIF + +;;;; check for non-printable characters + IF ( (stregex(inline,string(9b)) ne -1) or $ + (stregex(inline,string(7b)) ne -1) or $ + (stregex(inline,string(8b)) ne -1) or $ + (stregex(inline,string(10b)) ne -1) or $ + (stregex(inline,string(11b)) ne -1) or $ + (stregex(inline,string(12b)) ne -1) or $ + (stregex(inline,string(13b)) ne -1) or $ + (stregex(inline,string(27b)) ne -1) ) THEN BEGIN + print,'Non-printable character in data row = ',j + return,-1 + ENDIF + + cur_len = strlen(inline) + IF cur_len LT name_line_length THEN BEGIN + padlen = name_line_length - cur_len + pad = strjoin(replicate(' ', padlen)) + line = inline+pad + ENDIF ELSE line=inline + + FOR i = 0, ncol-1 DO BEGIN + data_string = strtrim(strmid(line, delim_idx[i]+1, col_width[i]),2) + check = strmid(line,delim_idx[i],1) + IF check NE ' ' THEN BEGIN + print, 'ERROR: misaligned columns (data under pipe)' + print, 'ERROR: data row, column = ',j,' , ',i + IF keyword_set(debug) THEN stop + return, -1 + ENDIF + IF (col_type_code[i] ne 7) THEN BEGIN + IF ( (col_type_code[i] eq 4) or (col_type_code[i] eq 5) ) THEN BEGIN + check_num = valid_num(data_string) + IF (check_num eq 0) THEN BEGIN + IF (data_string ne null_value_string[i]) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Invalid data entry replaced by null value in row, column = ',j,', ',i + ENDIF ELSE data_string = new_null_value_string[i] + ENDIF +;;;; Check floating point limits + IF (check_num ne 0) THEN BEGIN + check_lim = fix(data_string, type=5) + IF (finite(check_lim)) THEN BEGIN + IF (col_type_code[i] eq 4) THEN BEGIN + check_lim = fix(data_string, type=4) + IF ( NOT(finite(check_lim)) ) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Float overflow replaced by null value in row, column = ',j,', ',i + ENDIF + ENDIF + ENDIF ELSE BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Double overflow replaced by null value in row, column = ',j,', ',i + ENDELSE + ENDIF + ENDIF ELSE BEGIN + check_num = valid_num(data_string,/integer) + IF (check_num eq 0) THEN BEGIN + IF (data_string ne null_value_string[i]) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Invalid data entry replaced by null value in row, column = ',j,', ',i + ENDIF ELSE data_string = new_null_value_string[i] + ENDIF +;;;; Check integer limits + IF (check_num ne 0) THEN BEGIN + check_lim = fix(data_string, type=5) + IF ( (check_lim gt lmin) and (check_lim lt lmax) ) THEN BEGIN + IF (col_type_code[i] eq 3) THEN BEGIN + IF ( (check_lim le lmini) or (check_lim ge lmaxi) ) THEN BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Integer overflow replaced by null value in row, column = ',j,', ',i + ENDIF + ENDIF + ENDIF ELSE BEGIN + data_string = new_null_value_string[i] + print,'WARNING: Long overflow replaced by null value in row, column = ',j,', ',i + ENDELSE + ENDIF + ENDELSE + ENDIF + info.(i+n_header_lines)[j] = data_string + ENDFOR + already_read=0 +ENDFOR + +return, info + +END + + + + diff --git a/modules/idl_downloads/astro/pro/read_key.pro b/modules/idl_downloads/astro/pro/read_key.pro new file mode 100644 index 0000000..4e04bac --- /dev/null +++ b/modules/idl_downloads/astro/pro/read_key.pro @@ -0,0 +1,129 @@ +FUNCTION read_key, wait +;+ +; NAME: +; READ_KEY +; PURPOSE: +; To read a keystroke and return its ASCII equivalent +; EXPLANATION: +; If an ESCAPE sequence was produced and the sequence is +; recognized (e.g. up arrow), then a code is returned. +; +; This functionality is mostly made obsolete by the addition of the +; ESCAPE and KEY_NAME keywords to GET_KBRD in IDL V6.2 +; +; CALLING SEQUENCE: +; key = READ_KEY(Wait) +; +; INPUTS: +; Wait - The wait flag. If non-zero, execution is halted until a +; key is struck. If zero, execution returns immediately and +; a zero is returned if there was no keystroke waiting in the +; keyboard buffer. If not specified, zero is assumed. +; +; OUTPUT: +; Returned - The key struck. The ASCII code for non-escape sequences. +; Escape sequence equivalents: +; Up Arrow -- 128 +; Down Arrow -- 130 +; Left Arrow -- 129 +; Right Arrow -- 131 +; Else -- 0 +; +; The return value is a byte value. +; +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 22 June 1990. +; Rewritten for a SUN workstation. MRG, STX, 23 August 1990. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; Check the input parameter. +; +IF (n_params(0) LT 1) THEN wait = 0 +; +; Get the keystroke. +; +key = byte(get_kbrd(wait)) +key = key[0] +; +; If it is an ESCAPE, get the rest of it and +; then decode it. +; +IF (key EQ 27B) THEN BEGIN + st = bytarr(10) +; +; Get the rest of the escape sequence. +; + i = 0 + REPEAT BEGIN + key = byte(get_kbrd(0)) + st[i] = key[0] + i = i + 1 + ENDREP UNTIL (st[i-1] EQ 0B) +; +; Decode the escape sequence. +; + CASE string(st) OF + '[A' : key = 128B + '[B' : key = 130B + '[D' : key = 129B + '[C' : key = 131B + ELSE : BEGIN + IF (i GT 1) THEN key = 0B ELSE key = 27B + END + ENDCASE +ENDIF +; +; If it is a CSI, get the rest of it and +; then decode it. +; +IF (key EQ '9B'XB) THEN BEGIN + st = bytarr(10) +; +; Get the rest of the sequence. +; + i = 0 + REPEAT BEGIN + key = byte(get_kbrd(0)) + st[i] = key[0] + i = i + 1 + ENDREP UNTIL (st[i-1] EQ 0B) +; +; Decode the sequence. +; + CASE string(st) OF + 'A' : key = 128B + 'B' : key = 130B + 'D' : key = 129B + 'C' : key = 131B + ELSE : BEGIN + IF (i GT 1) THEN key = 0B ELSE key = '9B'XB + END + ENDCASE +ENDIF +; +; If it is a SS3, get the rest of it and +; then decode it. +; +IF (key EQ '8F'XB) THEN BEGIN + st = bytarr(10) +; +; Get the rest of the sequence. +; + i = 0 + REPEAT BEGIN + key = byte(get_kbrd(0)) + st[i] = key[0] + i = i + 1 + ENDREP UNTIL (st[i-1] EQ 0B) +; +; Decode the sequence. +; + CASE string(st) OF + ELSE : BEGIN + IF (i GT 1) THEN key = 0B ELSE key = '8F'XB + END + ENDCASE +ENDIF +; +RETURN, key +END diff --git a/modules/idl_downloads/astro/pro/readcol.pro b/modules/idl_downloads/astro/pro/readcol.pro new file mode 100644 index 0000000..dd5ae6c --- /dev/null +++ b/modules/idl_downloads/astro/pro/readcol.pro @@ -0,0 +1,369 @@ +pro readcol,name,v1,V2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15, $ + v16,v17,v18,v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,$ + v31,v32,v33,v34,v35,v36,v37,v38,v39,v40,v41,v42,v43,v44,v45, $ + v46,v47,v48,v49,v50, COMMENT = comment, $ + FORMAT = fmt, DEBUG=debug, SILENT=silent, SKIPLINE = skipline, $ + NUMLINE = numline, DELIMITER = delimiter, NAN = NaN, $ + PRESERVE_NULL = preserve_null, COUNT=ngood, NLINES=nlines, $ + STRINGSKIP = skipstart, QUICK = quick, COMPRESS = compress +;+ +; NAME: +; READCOL +; PURPOSE: +; Read a free-format ASCII file with columns of data into IDL vectors +; EXPLANATION: +; Lines of data not meeting the specified format (e.g. comments) are +; ignored. By default, columns may be separated by commas or spaces. +; +; Use READFMT to read a fixed-format ASCII file. Use RDFLOAT for +; much faster I/O (but less flexibility). Use FORPRINT to write +; columns of data (inverse of READCOL). +; +; If you sure that all lines meet the specified format (excluding +; commented and SKIPed lines) then the speed for reading large files +; can be significantly improved by setting the /QUICK keyword. +; +; CALLING SEQUENCE: +; READCOL, name, v1, [ v2, v3, v4, v5, ... v50 , COMMENT=, /NAN +; DELIMITER= ,FORMAT = , /DEBUG , /SILENT , SKIPLINE = , NUMLINE = +; COUNT =, STRINGSKIP= +; +; INPUTS: +; NAME - Name of ASCII data file, scalar string. +; +; OPTIONAL INPUT KEYWORDS: +; FORMAT - scalar string containing a letter specifying an IDL type +; for each column of data to be read. Allowed letters are +; A - string data, B - byte, D - double precision, F- floating +; point, I - short integer, L - longword, LL - 64 bit integer, +; U - unsigned short integer, UL - unsigned long integer +; Z - longword hexadecimal, and X - skip a column. +; +; Columns without a specified format are assumed to be floating +; point. Examples of valid values of FMT are +; +; 'A,B,I' ;First column to read as a character string, then +; 1 column of byte data, 1 column integer data +; 'L,L,L,L' ;Four columns will be read as longword arrays. +; ' ' ;All columns are floating point +; +; If a FORMAT keyword string is not supplied, then all columns are +; assumed to be floating point. +; +; /SILENT - Normally, READCOL will display each line that it skips over. +; If SILENT is set and non-zero then these messages will be +; suppressed. +; /DEBUG - If this keyword is non-zero, then additional information is +; printed as READCOL attempts to read and interpret the file. +; COMMENT - single character specifying comment character. Any line +; beginning with this character will be skipped. Default is +; no comment lines. +; /COMPRESS - If set, then the file is assumed to be gzip compressed. +; The file is assumed to be compressed if it ends in '.gz' +; DELIMITER - Character(s) specifying delimiter used to separate +; columns. Usually a single character but, e.g. delimiter=':,' +; specifies that either a colon or comma as a delimiter. +; Set DELIM = string(9b) to read tab separated data +; The default delimiter is either a comma or a blank. +; /NAN - if set, then an empty field will be read into a floating or +; double numeric variable as NaN; by default an empty field is +; converted to 0.0. +; /PRESERVE_NULL - If set, then spaces are considered to be valid fields, +; useful if the columns contain missing data. Note that between +; April and December 2006, /PRESERVE_NULL was the default. +; /QUICK - If set, then READCOL does not check that each individual line +; matches the supplied format. This makes READCOL less +; flexible but can provide a significant speed improvement when +; reading large files. +; SKIPLINE - Scalar specifying number of lines to skip at the top of file +; before reading. Default is to start at the first line. +; NUMLINE - Scalar specifying number of lines in the file to read. +; Default is to read the entire file +; STRINGSKIP - will skip all lines that begin with the specified string. +; (Unlike COMMENT this can be more than 1 character.) Useful to +; skip over comment lines. +; +; OUTPUTS: +; V1,V2,V3,...V50 - IDL vectors to contain columns of data. +; Up to 50 columns may be read. The type of the output vectors +; are as specified by FORMAT. +; +; OPTIONAL OUTPUT KEYWORDS: +; COUNT - integer giving the number of valid lines actually read +; NLINES - integer giving the total number of lines in the file +; (as returned by FILE_LINES) +; +; EXAMPLES: +; Each row in a file position.dat contains a star name and 6 columns +; of data giving an RA and Dec in sexagesimal format. Read into IDL +; variables. (NOTE: The star names must not include the delimiter +; as a part of the name, no spaces or commas as default.) +; +; IDL> FMT = 'A,I,I,F,I,I,F' +; IDL> READCOL,'position.dat',F=FMT,name,hr,min,sec,deg,dmin,dsec +; +; The HR,MIN,DEG, and DMIN variables will be integer vectors. +; +; Alternatively, all except the first column could be specified as +; floating point. +; +; IDL> READCOL,'position.dat',F='A',name,hr,min,sec,deg,dmin,dsec +; +; To read just the variables HR,MIN,SEC +; IDL> READCOL,'position.dat',F='X,I,I,F',HR,MIN,SEC +; +; RESTRICTIONS: +; This procedure is designed for generality and not for speed. +; If a large ASCII file is to be read repeatedly, it may be worth +; writing a specialized reader. +; +; Columns to be read as strings must not contain the delimiter character +; (i.e. commas or spaces by default). Either change the default +; delimiter with the DELIMITER keyword, or use READFMT to read such files. +; +; Numeric values are converted to specified format. For example, +; the value 0.13 read with an 'I' format will be converted to 0. +; +; PROCEDURES CALLED +; GETTOK(), STRNUMBER() +; The version of STRNUMBER() must be after August 2006. +; REVISION HISTORY: +; Written W. Landsman November, 1988 +; Modified J. Bloch June, 1991 +; (Fixed problem with over allocation of logical units.) +; Added SKIPLINE and NUMLINE keywords W. Landsman March 92 +; Read a maximum of 25 cols. Joan Isensee, Hughes STX Corp., 15-SEP-93. +; Call NUMLINES() function W. Landsman Feb. 1996 +; Added DELIMITER keyword W. Landsman Nov. 1999 +; Fix indexing typos (i for k) that mysteriously appeared W. L. Mar. 2000 +; Hexadecimal support added. MRG, RITSS, 15 March 2000. +; Default is comma or space delimiters as advertised W.L. July 2001 +; Faster algorithm, use STRSPLIT if V5.3 or later W.L. May 2002 +; Accept null strings separated by delimiter ,e.g. ',,,' +; Use SCOPE_VARFETCH instead of EXECUTE() for >V6.1 W.L. Jun 2005 +; Added compile_opt idl2 W. L. July 2005 +; Added the NaN keyword W. L August 2006 +; Added /PRESERVE_NULL keyword W.L. January 2007 +; Assume since V5.6 (FILE_LINES available ) W.L. Nov 2007 +; Added COUNT output keyword W.L. Aug 2008 +; Added NLINES output keyword W.L. Nov 2008 +; Added SKIPSTART keyword Stephane Beland January 2008 +; Renamed SKIPSTART to STRINGSKIP to keep meaning of SKIP W.L. Feb 2008 +; Assume since V6.1, SCOPE_VARFETCH available W.L. July 2009 +; Read up to 40 columns W.L. Aug 2009 +; Use pointers instead of SCOPE_VARFETCH. Fixes bug with +; IDL Workbench and runs 20% faster Douglas J. Marshall/W.L. Nov 2009 +; Recognize LL, UL, and ULL data types, don't use 'val' output from +; STRNUMBER() W.L. Feb 2010 +; Graceful return even if no valid lines are present D. Sahnow April 2010 +; Ability to read tab separated data WL April 2010 +; Free memory used by pointers WL July 2010 +; Added /QUICK keyword WL Sep 2010 +; Accept normal FORTRAN formats (e.g. F5.1) P. Noterdaeme/W.L Jan 2011 +; Add COMPRESS keyword, IDL 6 notation W. Landsman/J. Bailin Feb 2011 +; Allow filename to be 1 element array W.Landsman/S.Antonille Apr 2011 +; Feb 2010 change caused errors when reading blanks as numbers. +; W.L. July 2012 +; Read up to 50 columns W.L. March 2013 +; Assume a compressed file if it ends in '.gz' W.L. Oct 2015 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() lt 2 then begin + print,'Syntax - READCOL, name, v1, [ v2, v3,...v50, /NAN, DELIMITER=,/QUICK' + print,' FORMAT= ,/SILENT ,SKIPLINE =, NUMLINE = , /DEBUG, COUNT=]' + return + endif + +; Get number of lines in file + + ngood = 0L ;Number of good lines + if N_elements(compress) EQ 0 then $ + compress = strmid(name,2,3,/reverse) EQ '.gz' + nlines = FILE_LINES( name, COMPRESS=compress[0] ) + + + if keyword_set(DEBUG) then $ + message,'File ' + name+' contains ' + strtrim(nlines,2) + ' lines',/INF + + if N_elements( SKIPLINE ) EQ 0 then skipline = 0 + nlines = nlines - skipline + if nlines LE 0 then begin + message,'ERROR - File ' + name+' contains no data',/CON + return + endif + if N_elements( NUMLINE) GT 0 then nlines = numline < nlines + + if N_elements( SKIPSTART ) EQ 0 then begin + skipstart_flg=0 + endif else begin + skipstart_flg=1 + nskipstart = strlen(skipstart) + endelse + + ncol = N_params() - 1 ;Number of columns of data expected + vv = 'v' + strtrim( indgen(ncol)+1, 2) + nskip = 0 + + if N_elements(fmt) GT 0 then begin ;FORMAT string supplied? + + if size(fmt,/tname) NE 'STRING' then $ + message,'ERROR - Supplied FORMAT keyword must be a scalar string' +; Remove blanks from format string + frmt = strupcase(strcompress(fmt,/REMOVE)) + remchar, frmt, '(' ;Remove parenthesis from format + remchar, frmt, ')' + +; Determine number of columns to skip ('X' format) + pos = strpos(frmt, 'X', 0) + + while pos NE -1 do begin + pos = strpos( frmt, 'X', pos+1) + nskip++ + endwhile + + endif else begin ;Read everything as floating point + + frmt = 'F' + if ncol GT 1 then for i = 1,ncol-1 do frmt += ',F' + if ~keyword_set( SILENT ) then message, $ + 'Format keyword not supplied - All columns assumed floating point',/INF + + endelse + + nfmt = ncol + nskip + idltype = intarr(nfmt) + bigarr = ptrarr(ncol) + +; Create output arrays according to specified formats + + k = 0L ;Loop over output columns + hex = bytarr(nfmt) + for i = 0L, nfmt-1 do begin + + fmt1 = gettok( frmt, ',' ) + if fmt1 EQ '' then fmt1 = 'F' ;Default is F format + case strmid(fmt1,0,1) of + 'A': idltype[i] = 7 + 'D': idltype[i] = 5 + 'F': idltype[i] = 4 + 'I': idltype[i] = 2 + 'B': idltype[i] = 1 + 'L': idltype[i] = strmid(fmt1,0,2) EQ 'LL' ? 14 : 3 + 'U': if strmid(fmt1,1,1) NE 'L' then idltype[i] = 12 else $ + idltype[i] = strmid(fmt1,2,1) EQ 'L' ? 15 : 13 + 'Z': begin + idltype[i] = 3 ;Hexadecimal + hex[i] = 1b + end + 'X': idltype[i] = 0 ;IDL type of 0 ==> to skip column + ELSE: message,'Illegal format ' + fmt1 + ' in field ' + strtrim(i,2) + endcase + +; Define output arrays + + if idltype[i] GT 0 then begin + bigarr[k] = ptr_new(make_array(nlines,type=idltype[i])) + k++ + endif + + endfor + goodcol = where(idltype) + idltype = idltype[goodcol] + check_numeric = (idltype NE 7) + check_comment = N_elements(comment) GT 0 + openr, lun, name, /get_lun, compress=compress[0] + + temp = ' ' + skip_lun,lun,skipline, /lines + + if ~keyword_set(delimiter) then delimiter = ' ,' + + for j = 0L, nlines[0]-1 do begin + readf, lun, temp + if skipstart_flg then begin + ; requested to skip lines starting with specifc string + if strmid(temp,0,nskipstart) eq skipstart then begin + ngood-- + goto, BADLINE + endif + endif + + if strlen(temp) LT ncol then begin ;Need at least 1 chr per output line + ngood-- + if ~keyword_set(SILENT) then $ + message,'Skipping Line ' + strtrim(skipline+j+1,2),/INF + goto, BADLINE + endif + + temp = strtrim(temp,1) ;Remove leading spaces + if check_comment then if strmid(temp,0,1) EQ comment then begin + ngood-- + if keyword_set(DEBUG) then $ + message,'Skipping Comment Line ' + strtrim(skipline+j+1,2),/INF + goto, BADLINE + endif + + var = delimiter EQ string(9b) ? $ + strsplit( temp,delimiter,/extract, preserve=preserve_null) $ + :strsplit(strcompress(temp) ,delimiter,/extract, preserve=preserve_null) + if N_elements(var) LT nfmt then begin + if ~keyword_set(SILENT) then $ + message,'Skipping Line ' + strtrim(skipline+j+1,2),/INF + ngood-- + goto, BADLINE ;Enough columns? + endif + var = var[goodcol] + + k = 0 + if keyword_set(quick) then $ ;Don't check for valid numeric values + + for i = 0L,ncol-1 do (*bigarr[i])[ngood] = var[i] $ + + else begin + + + for i = 0L,ncol-1 do begin + + if check_numeric[i] then begin ;Check for valid numeric data + tst = strnumber(var[i],val,hex=hex[i],NAN=nan) ;Valid number? + if ~tst then begin ;If not, skip this line + if ~keyword_set(SILENT) then $ + message,'Skipping Line ' + strtrim(skipline+j+1,2),/INF + ngood-- + goto, BADLINE + endif + endif + if strlen(strtrim(var[i],2)) Eq 0 then begin + if keyword_set(NAN) then (*bigarr[k])[ngood] = !VALUES.F_NAN else $ + (*bigarr[k])[ngood] = 0 + endif else (*bigarr[k])[ngood] = var[i] + k++ + + endfor + +endelse + BADLINE: ngood++ + + endfor + + free_lun,lun + if ngood EQ 0 then begin + message,'ERROR - No valid lines found for specified format',/INFORM + return + endif + + if ~keyword_set(SILENT) then $ + message,strtrim(ngood,2) + ' valid lines read', /INFORM + +; Compress arrays to match actual number of valid lines + if ngood lt Nlines then for i=0,ncol-1 do $ + (*bigarr[i]) = (*bigarr[i])[0:ngood-1] + +; Use SCOPE_VARFETCH to place into output variables.. + for i=0,ncol-1 do $ + (SCOPE_VARFETCH(vv[i],LEVEL=0)) = reform(*bigarr[i]) + ptr_free, bigarr + return +end diff --git a/modules/idl_downloads/astro/pro/readfits.pro b/modules/idl_downloads/astro/pro/readfits.pro new file mode 100644 index 0000000..d4a5b02 --- /dev/null +++ b/modules/idl_downloads/astro/pro/readfits.pro @@ -0,0 +1,598 @@ +;+ +; NAME: +; READFITS +; PURPOSE: +; Read a FITS file into IDL data and header variables. +; EXPLANATION: +; READFITS() can read FITS files compressed with gzip or Unix (.Z) +; compression. FPACK ( http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) +; compressed FITS files can also be read provided that the FPACK software +; is installed. +; See http://idlastro.gsfc.nasa.gov/fitsio.html for other ways of +; reading FITS files with IDL. +; +; CALLING SEQUENCE: +; Result = READFITS( Filename/Fileunit,[ Header, heap, /NOSCALE, EXTEN_NO=, +; NSLICE=, /SILENT , STARTROW =, NUMROW = , HBUFFER=, +; /CHECKSUM, /COMPRESS, /FPACK, /No_Unsigned, NaNVALUE = ] +; +; INPUTS: +; Filename = Scalar string containing the name of the FITS file +; (including extension) to be read. If the filename has +; a *.gz extension, it will be treated as a gzip compressed +; file. If it has a .Z extension, it will be treated as a +; Unix compressed file. If Filename is an empty string then +; the user will be queried for the file name. +; OR +; Fileunit - A scalar integer specifying the unit of an already opened +; FITS file. The unit will remain open after exiting +; READFITS(). There are two possible reasons for choosing +; to specify a unit number rather than a file name: +; (1) For a FITS file with many extensions, one can move to the +; desired extensions with FXPOSIT() and then use READFITS(). This +; is more efficient than repeatedly starting at the beginning of +; the file. +; (2) For reading a FITS file across a Web http: address after opening +; the unit with the SOCKET procedure +; +; OUTPUTS: +; Result = FITS data array constructed from designated record. +; If the specified file was not found, then Result = -1 +; +; OPTIONAL OUTPUT: +; Header = String array containing the header from the FITS file. +; If you don't need the header, then the speed may be improved by +; not supplying this parameter. Note however, that omitting +; the header can imply /NOSCALE, i.e. BSCALE and BZERO values +; may not be applied. +; heap = For extensions, the optional heap area following the main +; data array (e.g. for variable length binary extensions). +; +; OPTIONAL INPUT KEYWORDS: +; /CHECKSUM - If set, then READFITS() will call FITS_TEST_CHECKSUM to +; verify the data integrity if CHECKSUM keywords are present +; in the FITS header. Cannot be used with the NSLICE, NUMROW +; or STARTROW keywords, since verifying the checksum requires +; that all the data be read. See FITS_TEST_CHECKSUM() for more +; information. +; +; /COMPRESS - Signal that the file is gzip compressed. By default, +; READFITS will assume that if the file name extension ends in +; '.gz' then the file is gzip compressed. The /COMPRESS keyword +; is required only if the the gzip compressed file name does not +; end in '.gz' or .ftz +; +; EXTEN_NO - non-negative scalar integer specifying the FITS extension to +; read. For example, specify EXTEN = 1 or /EXTEN to read the +; first FITS extension. +; +; /FPACK - Signal that the file is compressed with the FPACK software. +; http://heasarc.gsfc.nasa.gov/fitsio/fpack/ ) By default, +; (READFITS will assume that if the file name extension ends in +; .fz that it is fpack compressed. The FPACK software must +; be installed on the system +; +; HBUFFER - Number of lines in the header, set this to slightly larger +; than the expected number of lines in the FITS header, to +; improve performance when reading very large FITS headers. +; Should be a multiple of 36 -- otherwise it will be modified +; to the next higher multiple of 36. Default is 180 +; +; /NOSCALE - If present and non-zero, then the ouput data will not be +; scaled using the optional BSCALE and BZERO keywords in the +; FITS header. Default is to scale. +; +; /NO_UNSIGNED - By default, if the header indicates an unsigned integer +; (BITPIX = 16, BZERO=2^15, BSCALE=1) then READFITS() will output +; an IDL unsigned integer data type (UINT). But if /NO_UNSIGNED +; is set, then the data is converted to type LONG. +; +; NSLICE - An integer scalar specifying which N-1 dimensional slice of a +; N-dimensional array to read. For example, if the primary +; image of a file 'wfpc.fits' contains a 800 x 800 x 4 array, +; then +; +; IDL> im = readfits('wfpc.fits',h, nslice=2) +; is equivalent to +; IDL> im = readfits('wfpc.fits',h) +; IDL> im = im[*,*,2] +; but the use of the NSLICE keyword is much more efficient. +; Note that any degenerate dimensions are ignored, so that the +; above code would also work with a 800 x 800 x 4 x 1 array. +; +; NUMROW - Scalar non-negative integer specifying the number of rows +; of the image or table extension to read. Useful when one +; does not want to read the entire image or table. +; +; POINT_LUN - Position (in bytes) in the FITS file at which to start +; reading. Useful if READFITS is called by another procedure +; which needs to directly read a FITS extension. Should +; always be a multiple of 2880, and not be used with EXTEN_NO +; keyword. +; +; /SILENT - Normally, READFITS will display the size the array at the +; terminal. The SILENT keyword will suppress this +; +; STARTROW - Non-negative integer scalar specifying the row +; of the image or extension table at which to begin reading. +; Useful when one does not want to read the entire table. +; +; NaNVALUE - This keyword is included only for backwards compatibility +; with routines that require IEEE "not a number" values to be +; converted to a regular value. +; +; /UNIXPIPE - When a FileUnit is supplied to READFITS(), then /UNIXPIPE +; indicates that the unit is to a Unix pipe, and that +; no automatic byte swapping is performed. +; +; EXAMPLE: +; Read a FITS file test.fits into an IDL image array, IM and FITS +; header array, H. Do not scale the data with BSCALE and BZERO. +; +; IDL> im = READFITS( 'test.fits', h, /NOSCALE) +; +; If the file contains a FITS extension, it could be read with +; +; IDL> tab = READFITS( 'test.fits', htab, /EXTEN ) +; +; The function TBGET() can be used for further processing of a binary +; table, and FTGET() for an ASCII table. +; To read only rows 100-149 of the FITS extension, +; +; IDL> tab = READFITS( 'test.fits', htab, /EXTEN, +; STARTR=100, NUMR = 50 ) +; +; To read in a file that has been compressed: +; +; IDL> tab = READFITS('test.fits.gz',h) +; +; ERROR HANDLING: +; If an error is encountered reading the FITS file, then +; (1) the system variable !ERROR_STATE.CODE is set negative +; (via the MESSAGE facility) +; (2) the error message is displayed (unless /SILENT is set), +; and the message is also stored in !!ERROR_STATE.MSG +; (3) READFITS returns with a value of -1 +; RESTRICTIONS: +; (1) Cannot handle random group FITS +; +; NOTES: +; (1) If data is stored as integer (BITPIX = 16 or 32), and BSCALE +; and/or BZERO keywords are present, then the output array is scaled to +; floating point (unless /NOSCALE is present) using the values of BSCALE +; and BZERO. In the header, the values of BSCALE and BZERO are then +; reset to 1. and 0., while the original values are written into the +; new keywords O_BSCALE and O_BZERO. If the BLANK keyword was +; present (giving the value of undefined elements *prior* to the +; application of BZERO and BSCALE) then the *keyword* value will be +; updated with the values of BZERO and BSCALE. +; +; (2) The use of the NSLICE keyword is incompatible with the NUMROW +; or STARTROW keywords. +; +; (3) On some Unix shells, one may get a "Broken pipe" message if reading +; a Unix compressed (.Z) file, and not reading to the end of the file +; (i.e. the decompression has not gone to completion). This is an +; informative message only, and should not affect the output of READFITS. +; PROCEDURES USED: +; Functions: SXPAR() +; Procedures: MRD_SKIP, SXADDPAR, SXDELPAR +; +; MODIFICATION HISTORY: +; Original Version written in 1988, W.B. Landsman Raytheon STX +; Revision History prior to October 1998 removed +; Major rewrite to eliminate recursive calls when reading extensions +; W.B. Landsman Raytheon STX October 1998 +; Add /binary modifier needed for Windows W. Landsman April 1999 +; Read unsigned datatypes, added /no_unsigned W. Landsman December 1999 +; Output BZERO = 0 for unsigned data types W. Landsman January 2000 +; Update to V5.3 (see notes) W. Landsman February 2000 +; Fixed logic error in use of NSLICE keyword W. Landsman March 2000 +; Fixed byte swapping for Unix compress files on little endian machines +; W. Landsman April 2000 +; Added COMPRESS keyword, catch IO errors W. Landsman September 2000 +; Option to read a unit number rather than file name W.L October 2001 +; Fix undefined variable problem if unit number supplied W.L. August 2002 +; Don't read entire header unless needed W. Landsman Jan. 2003 +; Added HBUFFER keyword W. Landsman Feb. 2003 +; Added CHECKSUM keyword W. Landsman May 2003 +; Restored NaNVALUE keyword for backwards compatibility, +; William Thompson, 16-Aug-2004, GSFC +; Recognize .ftz extension as compressed W. Landsman September 2004 +; Fix unsigned integer problem introduced Sep 2004 W. Landsman Feb 2005 +; Don't modify header for unsigned integers, preserve double precision +; BSCALE value W. Landsman March 2006 +; Use gzip instead of compress for Unix compress files W.Landsman Sep 2006 +; Call MRD_SKIP to skip bytes on different file types W. Landsman Oct 2006 +; Make ndata 64bit for very large files E. Hivon/W. Landsman May 2007 +; Fixed bug introduced March 2006 in applying Bzero C. Magri/W.L. Aug 2007 +; Check possible 32bit overflow when using NSKIP W. Landsman Mar 2008 +; Always reset BSCALE, BZERO even for unsigned integers W. Landsman May 2008 +; Make ndata 64bit for very large extensions J. Schou/W. Landsman Jan 2009 +; Use PRODUCT() to compute # of data points W. Landsman May 2009 +; Read FPACK compressed file via UNIX pipe. W. Landsman May 2009 +; Fix error using NUMROW,STARTROW with non-byte data, allow these +; keywords to be used with primary array W. Landsman July 2009 +; Ignore degenerate trailing dimensions with NSLICE keyword W.L. Oct 2009 +; Add DIALOG_PICKFILE() if filename is an empty string W.L. Apr 2010 +; Set BLANK values *before* applying BSCALE,BZERO, use short-circuit +; operators W.L. May 2010 +; Skip extra SPAWN with FPACK decompress J. Eastman, W.L. July 2010 +; Fix possible problem when startrow=0 supplied J. Eastman/W.L. Aug 2010 +; First header is not necessarily primary if unit supplied WL Jan 2011 +; Fix test for 'SIMPLE' at beginning of header WL November 2012 +; Fix problem passing extensions with > 2GB WL, M. Carlson August 2013 +;- +function READFITS, filename, header, heap, CHECKSUM=checksum, $ + COMPRESS = compress, HBUFFER=hbuf, EXTEN_NO = exten_no, $ + NOSCALE = noscale, NSLICE = nslice, $ + NO_UNSIGNED = no_unsigned, NUMROW = numrow, $ + POINTLUN = pointlun, SILENT = silent, STARTROW = startrow, $ + NaNvalue = NaNvalue, FPACK = fpack, UNIXpipe=unixpipe + + On_error,2 ;Return to user + compile_opt idl2 + On_IOerror, BAD + +; Check for filename input + + if N_params() LT 1 then begin + print,'Syntax - im = READFITS( filename, [ h, heap, /NOSCALE, /SILENT,' + print,' EXTEN_NO =, STARTROW = , NUMROW=, NSLICE = ,' + print,' HBUFFER = ,/NO_UNSIGNED, /CHECKSUM, /COMPRESS]' + return, -1 + endif + + unitsupplied = size(filename,/TNAME) NE 'STRING' + +; Set default keyword values + + silent = keyword_set( SILENT ) + do_checksum = keyword_set( CHECKSUM ) + if N_elements(exten_no) EQ 0 then exten_no = 0 + +; Check if this is a Unix compressed file. (gzip files are handled +; separately using the /compress keyword to OPENR). + + if N_elements(unixpipe) EQ 0 then unixpipe = 0 + if unitsupplied then unit = filename else begin + len = strlen(filename) + if len EQ 0 then begin + filename =dialog_pickfile(filter=['*.fit*;*.fts*;*.img*'], $ + title='Please select a FITS file',/must_exist) + len = strlen(filename) + endif + ext = strlowcase(strmid(filename,len-3,3)) + gzip = (ext EQ '.gz') || (ext EQ 'ftz') + compress = keyword_set(compress) || gzip[0] + unixZ = (strmid(filename, len-2, 2) EQ '.Z') + fcompress = keyword_set(fpack) || ( ext EQ '.fz') + unixpipe = unixZ || fcompress + + +; Go to the start of the file. + + openr, unit, filename, ERROR=error,/get_lun, $ + COMPRESS = compress, /swap_if_little_endian + if error NE 0 then begin + message,/con,' ERROR - Unable to locate file ' + filename + return, -1 + endif + +; Handle Unix or Fpack compressed files which will be opened via a pipe using +; the SPAWN command. + + if unixZ then begin + free_lun, unit + spawn, 'gzip -cd '+filename, unit=unit + gzip = 1b + + endif else if fcompress then begin + free_lun, unit + spawn,'funpack -S ' + filename, unit=unit,/sh + if eof(unit) then begin + message,'Error spawning FPACK decompression',/CON + free_lun,unit + return,-1 + endif + endif + endelse + if N_elements(POINTLUN) GT 0 then mrd_skip, unit, pointlun + + doheader = arg_present(header) || do_checksum + if doheader then begin + if N_elements(hbuf) EQ 0 then hbuf = 180 else begin + remain = hbuf mod 36 + if remain GT 0 then hbuf = hbuf + 36-remain + endelse + endif else hbuf = 36 + + for ext = 0L, exten_no do begin + +; Read the next header, and get the number of bytes taken up by the data. + + block = string(replicate(32b,80,36)) + w = [-1] + if ((ext EQ exten_no) && (doheader)) then header = strarr(hbuf) $ + else header = strarr(36) + headerblock = 0L + i = 0L + + while w[0] EQ -1 do begin + + if EOF(unit) then begin + message,/ CON, $ + 'EOF encountered attempting to read extension ' + strtrim(ext,2) + if ~unitsupplied then free_lun,unit + return,-1 + endif + + readu, unit, block + headerblock++ + w = where(strlen(block) NE 80, Nbad) + if (Nbad GT 0) then begin + message,'Warning-Invalid characters in header',/INF,NoPrint=Silent + block[w] = string(replicate(32b, 80)) + endif + + w = where(strcmp(block,'END ',8), Nend) + if (headerblock EQ 1) || ((ext EQ exten_no) && (doheader)) then begin + if Nend GT 0 then begin + if headerblock EQ 1 then header = block[0:w[0]] $ + else header = [header[0:i-1],block[0:w[0]]] + endif else begin + header[i] = block + i += 36 + if i mod hbuf EQ 0 then $ + header = [header,strarr(hbuf)] + endelse + endif + + if (ext EQ 0 ) && ~((N_elements(pointlun) GT 0) || unitsupplied ) then $ + if strmid( header[0], 0, 8) NE 'SIMPLE ' then begin + message,/CON, $ + 'ERROR - Header does not contain required SIMPLE keyword' + if ~unitsupplied then free_lun, unit + return, -1 + endif + + endwhile +; Get parameters that determine size of data region. + + bitpix = sxpar(header,'BITPIX') + byte_elem = abs(bitpix)/8 ;Bytes per element + naxis = sxpar(header,'NAXIS') + gcount = sxpar(header,'GCOUNT') > 1 + pcount = sxpar(header,'PCOUNT') + + if naxis GT 0 then begin + dims = sxpar( header,'NAXIS*') ;Read dimensions + ndata = product(dims,/integer) + endif else ndata = 0 + + nbytes = byte_elem * gcount * (pcount + ndata) + +; Move to the next extension header in the file. Use MRD_SKIP to skip with +; fastest available method (POINT_LUN or readu) for different file +; types (regular, compressed, Unix pipe, socket) + + if ext LT exten_no then begin + nrec = long64((nbytes + 2879) / 2880) + if nrec GT 0 then mrd_skip, unit, nrec*2880L + endif + endfor + + case BITPIX of + 8: IDL_type = 1 ; Byte + 16: IDL_type = 2 ; 16 bit integer + 32: IDL_type = 3 ; 32 bit integer + 64: IDL_type = 14 ; 64 bit integer + -32: IDL_type = 4 ; Float + -64: IDL_type = 5 ; Double + else: begin + message,/CON, 'ERROR - Illegal value of BITPIX (= ' + $ + strtrim(bitpix,2) + ') in FITS header' + if ~unitsupplied then free_lun,unit + return, -1 + end + endcase + + if nbytes EQ 0 then begin + if ~SILENT then message, $ + "FITS header has NAXIS or NAXISi = 0, no data array read",/CON + if do_checksum then begin + result = FITS_TEST_CHECKSUM(header, data, ERRMSG = errmsg) + if ~SILENT then begin + case result of + 1: message,/INF,'CHECKSUM keyword in header is verified' + -1: message,/CON, errmsg + else: + endcase + endif + endif + if ~unitsupplied then free_lun, unit + return,-1 + endif + +; Check for FITS extensions, GROUPS + + groups = sxpar( header, 'GROUPS' ) + if groups then message,NoPrint=Silent, $ + 'WARNING - FITS file contains random GROUPS', /INF + +; If an extension, did user specify row to start reading, or number of rows +; to read? + + if N_elements(STARTROW) EQ 0 then startrow = 0 ;updated Aug 2010 + if naxis GE 2 then nrow = dims[1] else nrow = ndata + if N_elements(NUMROW) EQ 0 then numrow = nrow + if do_checksum then if ((startrow GT 0) || $ + (numrow LT nrow) || (N_elements(nslice) GT 0)) then begin + message,/CON, $ + 'Warning - CHECKSUM not applied when STARTROW, NUMROW or NSLICE is set' + do_checksum = 0 + endif + + if exten_no GT 0 then begin + xtension = strtrim( sxpar( header, 'XTENSION' , Count = N_ext),2) + if N_ext EQ 0 then message, /INF, NoPRINT = Silent, $ + 'WARNING - Header missing XTENSION keyword' + endif + + if ((startrow NE 0) || (numrow NE nrow)) then begin + if startrow GE dims[1] then begin + message,'ERROR - Specified starting row ' + strtrim(startrow,2) + $ + ' but only ' + strtrim(dims[1],2) + ' rows in extension',/CON + if ~unitsupplied then free_lun,unit + return,-1 + endif + dims[1] = dims[1] - startrow + dims[1] = dims[1] < numrow + sxaddpar, header, 'NAXIS2', dims[1] + if startrow GT 0 then mrd_skip, unit, byte_elem*startrow*dims[0] + + endif else if (N_elements(NSLICE) EQ 1) then begin + + ldim = naxis-1 + lastdim = dims[ldim] + while lastdim EQ 1 do begin + ldim = ldim-1 + lastdim = dims[ldim] + endwhile + if nslice GE lastdim then begin + message,/CON, $ + 'ERROR - Value of NSLICE must be less than ' + strtrim(lastdim,2) + if ~unitsupplied then free_lun, unit + return, -1 + endif + dims = dims[0:ldim-1] + for i = ldim,naxis-1 do sxdelpar,header,'NAXIS' + strtrim(i+1,2) + naxis = ldim + sxaddpar,header,'NAXIS' + strtrim(ldim,2),1 + ndata = ndata/lastdim + nskip = long64(nslice)*ndata*byte_elem + if Ndata GT 0 then mrd_skip, unit, nskip + endif + + + if ~SILENT then begin ;Print size of array being read + + if exten_no GT 0 then message, $ + 'Reading FITS extension of type ' + xtension, /INF + if N_elements(dims) EQ 1 then $ + st = 'Now reading ' + strtrim(dims,2) + ' element vector' else $ + st = 'Now reading ' + strjoin(strtrim(dims,2),' by ') + ' array' + if (exten_no GT 0) && (pcount GT 0) then st = st + ' + heap area' + message,/INF,st + endif + +; Read Data in a single I/O call. Only need byteswapping for data read with +; bidirectional pipe. + + data = make_array( DIM = dims, TYPE = IDL_type, /NOZERO) + readu, unit, data + if unixpipe then swap_endian_inplace,data,/swap_if_little + if (exten_no GT 0) && (pcount GT 0) then begin + theap = sxpar(header,'THEAP') + skip = theap - N_elements(data) + if skip GT 0 then begin + temp = bytarr(skip,/nozero) + readu, unit, skip + endif + heap = bytarr(pcount*gcount*byte_elem) + readu, unit, heap + if do_checksum then $ + result = fits_test_checksum(header,[data,heap],ERRMSG=errmsg) + endif else if do_checksum then $ + result = fits_test_checksum(header, data, ERRMSG = errmsg) + if ~unitsupplied then free_lun, unit + if do_checksum then if ~SILENT then begin + case result of + 1: message,/INF,'CHECKSUM keyword in header is verified' + -1: message,/CON, 'CHECKSUM ERROR! ' + errmsg + else: + endcase + endif + +; Scale data unless it is an extension, or /NOSCALE is set +; Use "TEMPORARY" function to speed processing. + + do_scale = ~keyword_set( NOSCALE ) + if (do_scale && (exten_no GT 0)) then do_scale = xtension EQ 'IMAGE' + if do_scale then begin + + if bitpix GT 0 then $ + blank = sxpar( header, 'BLANK', Count = N_blank) $ + else N_blank = 0 + + Bscale = sxpar( header, 'BSCALE' , Count = N_bscale) + Bzero = sxpar(header, 'BZERO', Count = N_Bzero ) + if (N_blank GT 0) && ((N_bscale GT 0) || (N_Bzero GT 0)) then $ + sxaddpar,header,'O_BLANK',blank,' Original BLANK value' + + + +; Check for unsigned integer (BZERO = 2^15) or unsigned long (BZERO = 2^31) + + if ~keyword_set(No_Unsigned) then begin + no_bscale = (Bscale EQ 1) || (N_bscale EQ 0) + unsgn_int = (bitpix EQ 16) && (Bzero EQ 32768) && no_bscale + unsgn_lng = (bitpix EQ 32) && (Bzero EQ 2147483648) && no_bscale + unsgn = unsgn_int || unsgn_lng + endif else unsgn = 0 + + if unsgn then begin + if unsgn_int then begin + data = uint(data) - 32768US + if N_blank then blank = uint(blank) - 32768US + endif else begin + data = ulong(data) - 2147483648UL + if N_blank then blank = ulong(blank) - 2147483648UL + endelse + if N_blank then sxaddpar,header,'BLANK',blank + sxaddpar, header, 'BZERO', 0 + sxaddpar, header, 'O_BZERO', Bzero,' Original BZERO Value' + + endif else begin + + if N_Bscale GT 0 then $ + if ( Bscale NE 1. ) then begin + if size(Bscale,/TNAME) NE 'DOUBLE' then $ + data *= float(Bscale) else $ + data *= Bscale + if N_blank then blank *= bscale + sxaddpar, header, 'BSCALE', 1. + sxaddpar, header, 'O_BSCALE', Bscale,' Original BSCALE Value' + + endif + + if N_Bzero GT 0 then $ + if (Bzero NE 0) then begin + if size(Bzero,/TNAME) NE 'DOUBLE' then $ + data += float(Bzero) else $ ;Fixed Aug 07 + data += Bzero + if N_blank then blank += bzero + sxaddpar, header, 'BZERO', 0. + sxaddpar, header, 'O_BZERO', Bzero,' Original BZERO Value' + endif + + endelse + if N_blank then sxaddpar,header,'BLANK',blank + endif + + +; Return array. If necessary, first convert NaN values. + + if n_elements(nanvalue) eq 1 then begin + w = where(finite(data,/nan),count) + if count gt 0 then data[w] = nanvalue + endif + return, data + +; Come here if there was an IO_ERROR + + BAD: print,!ERROR_STATE.MSG + if (~unitsupplied) && (N_elements(unit) GT 0) then free_lun, unit + if N_elements(data) GT 0 then return,data else return, -1 + + end diff --git a/modules/idl_downloads/astro/pro/readfmt.pro b/modules/idl_downloads/astro/pro/readfmt.pro new file mode 100644 index 0000000..efdd2d5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/readfmt.pro @@ -0,0 +1,297 @@ +pro readfmt,name,fmt,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15, $ + v16,v17,v18,v19,v20,v21,v22,v23,v24,v25, $ + SILENT = silent, DEBUG = debug, SKIPLINE = skipline, $ + NUMLINE = numline +;+ +; NAME: +; READFMT +; PURPOSE: +; Quickly read a fixed format ASCII data file into IDL variables. +; EXPLANATION: +; Lines of data not meeting the specified format (e.g. comments) are +; ignored. +; +; To read a free format ASCII data file use the procedures +; READCOL or RDFLOAT. To print (formatted or free) columns of data +; use the procedure FORPRINT. +; +; CALLING SEQUENCE: +; READFMT, name, fmt, v1,[ v2, v3, v4, ..., v25 , +; /SILENT, /DEBUG, SKIPLINE= , NUMLINE =] +; +; INPUTS: +; NAME - Name of ASCII data file. An extension of .DAT is assumed, +; if not supplied. +; FMT - scalar string containing a valid FORTRAN read format. +; Must include a field length specification. Cannot include +; internal parenthesis. A format field must be included for +; each output vector. Multiple format fields are allowed, but +; the repetition factor must be less than 100, (.i.e. 19X is +; allowed but 117X is illegal) +; +; Examples of valid FMT values are +; FMT = 'A7,3X,2I4' or FMT = '1H ,5I7,2A7' +; Examples of INVALID FMT values are +; FMT = 'A7,B3' ;'B' is not a valid FORTRAN format +; FMT = 'A7,2(I3,F5.1)' ;Internal parenthesis not allowed +; FMT = 'A7,F,I' ;Field length not included +; +; OUTPUTS: +; V1,V2,V3,V4... - IDL vectors to contain columns of data. +; Up to 25 output vectors may be read. The type of the output +; vectors are specified by FMT. +; +; OPTIONAL KEYWORD INPUTS: +; /SILENT - If this keyword is set and non-zero, then certain terminal +; output is suppressed while reading the file +; /DEBUG - Set this keyword to display additional information while +; reading the file. +; SKIPLINE - Scalar specifying number of lines to skip at the top of +; file before reading. Default is to start at first line +; NUMLINE - Scalar specifying number of lines in the file to read. +; Default is to read the entire file +; +; EXAMPLES: +; Each row in a fixed-format file POSITION.DAT contains a 5 character +; star name and 6 columns of data giving an RA and Dec in sexagesimal +; format. A possible format for such data might be +; +; IDL> FMT = 'A5,2I3,F5.1,2x,3I3' +; and the file could be quickly read with +; +; IDL> READFMT,'POSITION', fmt, name, hr, min, sec, deg, dmin, dsec +; +; NAME will be a string vector,SEC will be a floating point vector, and +; the other vectors will be of integer type. +; +; RESTRICTIONS: +; This procedure is designed for generality and not for speed. +; If a large ASCII file is to be read repeatedly, it may be worth +; writing a specialized reader. +; +; NOTES: +; When reading a field with an integer format I, the output vector is +; byte - if n = 1 +; integer*2 - if 1 < n < 5 +; integer*4 - in all other cases +; Octal ('O') and hexadecimal ('Z') formats are read into longwords +; +; PROCEDURE CALLS: +; GETTOK(), REMCHAR, ZPARCHECK +; +; REVISION HISTORY: +; Written W. Landsman November, 1988 +; Added SKIPLINE and NUMLINE keywords March 92 +; Allow up to 25 columns to be read June 92 +; Call NUMLINES() function Feb 1996 +; Recognize 'O' and 'Z' formats W. Landsman September 1997 +; Recognize 'G' format, use SKIP_LUN W. Landsman May 2010 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax - readfmt, name, fmt, v1,[ v2, v3, v4...v25, ' + print,' /SILENT, /DEBUG, SKIPLINE =, NUMLINE = ]' + return + endif + + zparcheck, 'READFMT', fmt, 2, 7, 0, 'FORMAT string' + +; Get number of lines in file + + nlines = FILE_LINES( name ) + + if ~keyword_set( SKIPLINE ) then skipline = 0 + if keyword_set( NUMLINE) then nlines = numline < nlines else $ + nlines = nlines - skipline + + if nlines LE 0 then begin + message,'ERROR - File ' + name+' contains no valid data',/CON + return + endif + ncol = N_params() - 2 ;Number of columns of data expected + ii = strtrim(indgen(ncol)+1,2) + frmt = strtrim( strupcase(fmt), 2 ) ;Working FORMAT string + +; If format string is of the form "$(...)" then remove dollar sign and +; parenthesis + + remchar, frmt, '$' ;Remove dollar sign + if strmid(frmt,0,1) EQ '(' then $ + frmt = strmid( frmt,1,strlen(frmt)-1 ) + + if strmid(frmt,strlen(frmt)-1,1) EQ ')' then $ + frmt = strmid(frmt,0,strlen(frmt)-1 ) + + fmt1 = '(' + frmt + ')' ;Now make a valid read format + + +; Create output arrays according to specified formats + + k = 0L ;Loop over output columns + REPEAT BEGIN + + fmt_1 = gettok(frmt,',') + vtype = strmid( fmt_1, 0, 1) + ndup = 1 + if (strnumber(vtype,val) EQ 1) then begin ;Test for multiple format + + ndup = val + vtype = strmid(fmt_1,1,1) + + if (strnumber(vtype,val) EQ 1) then begin + + ndup = 10*ndup+ val + vtype = strmid(fmt_1,2,1) + + endif + + if vtype EQ '(' then $ + message,'Parenthesis within format string not allowed' + + endif + + for j = 1L,ndup do begin + CASE vtype OF + + 'A': begin + + tst = strnumber(strmid(fmt_1,1, strlen(fmt_1)-1), nfield) + if (tst EQ 0) or (strlen(fmt_1) LT 2) then $ + message,'String format must include a field length' + + nfield = fix(nfield) + idltype = 7 + end + + 'D': idltype = 5 + + 'E': idltype = 4 + + 'F': idltype = 4 + + 'G': idltype = 4 + + 'I': begin ;Decide whether BYTE, INTEGER or LONG + + pos = strpos(fmt_1,vtype) + len = fix(strmid( fmt_1, pos+1, strlen(fmt_1)-pos-1)) + if len EQ 1 then idltype = 1 $ + else if len LT 5 then idltype = 2 $ + else idltype = 3 + + end + + 'H': goto, NO_VAR + + 'O': idltype = 3 + + 'Z': idltype = 3 + + 'X': goto, NO_VAR ;No variable declaration needed + + ELSE: message,'ERROR - Illegal format '+fmt_1 +' in field ' + strtrim(k,2) + + endcase + +; Define output arrays + + st = 'v'+ ii[k] +'= make_array(nlines, type = idltype)' + tst = execute(st) + st = 'x'+ ii[k] +'= make_array(1,type = idltype)' + tst = execute(st) + k = k+1 + if k EQ ncol then goto, DONE ;Normal exit + endfor +NO_VAR: + + ENDREP until frmt EQ '' + + message,'ERROR - ' + strtrim(ncol,2)+ ' output vectors supplied but only ' + $ + strtrim(k,2) + ' FORMAT fields specified' + +DONE: + + openr, LUN, name, /get_lun + ngood = 0L + skip_lun,lun,skipline,/lines + + On_IOerror, BAD_LINE + + + for j = 0L,nlines-1 do begin + + badline = 1 + + case ncol of ;Can't use ON_IOERROR with EXECUTE statement +; so have to list all the possibilities + 1: readf,LUN,f = fmt1,x1 + 2: readf,LUN,f = fmt1,x1,x2 + 3: readf,LUN,f = fmt1,x1,x2,x3 + 4: readf,LUN,f = fmt1,x1,x2,x3,x4 + 5: readf,LUN,f = fmt1,x1,x2,x3,x4,x5 + 6: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6 + 7: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7 + 8: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8 + 9: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9 + 10: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 + 11: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11 + 12: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12 + 13: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13 + 14: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14 + 15: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15 + 16: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,$ + x16 + 17: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,$ + x16,x17 + 18: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18 + 19: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19 + 20: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20 + 21: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20,x21 + 22: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20,x21,x22 + 23: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20,x21,x22,x23 + 24: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20,x21,x22,x23,x24 + 25: readf,LUN,f = fmt1,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15, $ + x16,x17,x18,x19,x20,x21,x22,x23,x24,x25 + + ENDCASE + + for i = 0L, ncol-1 do begin + + st ='v' + ii[i] + '[ngood] = x'+ii[i] + tst = execute(st) + + endfor + + ngood = ngood + 1 + badline = 0 +BAD_LINE: + if badline then if ~keyword_set(SILENT) then $ + message,'Error reading line ' + strtrim(skipline+ j+1,2),/CON + endfor + free_lun, LUN + + if ngood EQ 0L then message, $ + 'ERROR - No valid lines found with specified format' + if ~keyword_set( SILENT) then $ + message, strtrim(ngood,2) + ' valid lines read',/INF + +; Compress arrays to match actual number of valid lines + + for i = 0L, ncol-1 do begin + + var ='v'+ii[i] + tst = execute(var + '='+ var+ '[0:ngood-1]') + + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/recpol.pro b/modules/idl_downloads/astro/pro/recpol.pro new file mode 100644 index 0000000..50701a1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/recpol.pro @@ -0,0 +1,63 @@ +;------------------------------------------------------------- +;+ +; NAME: +; RECPOL +; PURPOSE: +; Convert 2-d rectangular coordinates to polar coordinates. +; CATEGORY: +; CALLING SEQUENCE: +; recpol, x, y, r, a +; INPUTS: +; x, y = vector in rectangular form. in +; KEYWORD PARAMETERS: +; Keywords: +; /DEGREES means angle is in degrees, else radians. +; OUTPUTS: +; r, a = vector in polar form: radius, angle. out +; COMMON BLOCKS: +; NOTES: +; MODIFICATION HISTORY: +; R. Sterner. 18 Aug, 1986. +; Johns Hopkins University Applied Physics Laboratory. +; RES 13 Feb, 1991 --- added /degrees. +; R. Sterner, 30 Dec, 1991 --- simplified. +; R. Sterner, 25 May, 1993 --- Fixed atan (0,0) problem. +; +; Copyright (C) 1986, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------------- + + + pro recpol, x, y, r, a, help=hlp, degrees=degrees + + if (n_params(0) lt 4) or keyword_set(hlp) then begin + print,' Convert 2-d rectangular coordinates to polar coordinates. + print,' recpol, x, y, r, a + print,' x, y = vector in rectangular form. in' + print,' r, a = vector in polar form: radius, angle. out' + print,' Keywords:' + print,' /DEGREES means angle is in degrees, else radians.' + return + endif + + ;---------------------------------------------------------------- + ; Angle complicated because atan won't take (0,0) and + ; also because want to keep angle in 0 to 360 (2 pi) range. + ;---------------------------------------------------------------- + w = where((x ne 0) or (y ne 0), count) ; Where not both X,Y eq 0. + a = x*0. ; Output angle array. + if count gt 0 then a[w]=atan(y[w],x[w]) ; Find angles. + w = where(a lt 0, count) ; find A < 0 and fix. + if count gt 0 then a[w]= a[w]+2*!dpi ; add 2 pi to angles < 0. + + r = sqrt(x^2 + y^2) ; Find radii. + + if keyword_set(degrees) then a = a*!radeg + + return + end diff --git a/modules/idl_downloads/astro/pro/rem_dup.pro b/modules/idl_downloads/astro/pro/rem_dup.pro new file mode 100644 index 0000000..14ce109 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rem_dup.pro @@ -0,0 +1,104 @@ +function rem_dup, a, flag +;+ +; NAME: +; REM_DUP +; PURPOSE: +; Function to remove duplicate values from a vector. +; +; CALLING SEQUENCE: +; result = rem_dup( a, [ flag ] ) +; +; INPUTS: +; a - vector of values from which duplicates are to be found +; flag - (optional) if supplied then when duplicates occur, +; the one with the largest value of flag is selected. +; If not supplied the the first occurence of the value +; in a is selected. Should be a vector with the same +; number of elements as a. +; +; OUTPUT: +; A vector of subscripts in a is returned. Each subscript +; points to a selected value such that a(rem_dup(a,flag)) +; has no duplicates. +; +; SIDE EFFECTS: +; The returned subscripts will sort the values in a in ascending +; order with duplicates removed. +; +; EXAMPLES: +; +; Remove duplicate values in vector a. +; a = a[ rem_dup(a)] +; +; Remove duplicates in vector WAVE. When duplicate values +; are found, select the one with the largest intensity, INTE. +; +; sub = rem_dup( wave, inte) +; wave = wave[sub] +; inte = inte[sub] +; +; NOTES: +; The UNIQ function in the User's Library uses a faster algorithm, +; but has no equivalent of the "flag" parameter. Also, note that +; REM_DUP() gives the index of the *first* equal value found, while +; UNIQ() gives the index of the *last* equal value found. +; +; MODIFICATION HISTORY: +; D. Lindler Mar. 87 +; 11/16/90 JKF ACC - converted to IDL Version 2. +; August 1997 -- Changed loop index to type LONG +; October 1997 -- Also changed NGOOD index to LONG +; April 2007 - Use faster algorithm when Flag vector not set, W. Landsman +; Feb 2011 - Remove spurious line W.L. +; Jan 2012 - Call BSORT() to ensure original order maintained for equal +; values +;- +;------------------------------------------------------------------------------- +; + compile_opt idl2 + On_error,2 + npar = N_params() ;number of input parameters supplied + if npar EQ 0 then begin + print,'Syntax - b = rem_dup( a, [ flag ] )' + return, -1 + end + + n = N_elements(a) ;number of values in a + if n lt 2 then return, lonarr(1) ;only one value in a + sub = Npar GE 2 ? sort(a) : bsort(a) ;sorted subscripts + aa = a[sub] ;sorted a +; +; loop on aa +; + val = aa[0] ;first value processed + if npar GE 2 then begin + + good = lonarr(n) ;values to keep + ngood = 0L ;number kept. +ff = flag[sub] ;sorted flags + f = ff[0] ;flag for first value + for i = 1L, n-1 do begin + if aa[i] ne val then begin + val = aa[i] + f = ff[i] + ngood++ + good[ngood] = i + end else begin + if ff[i] gt f then begin + f = ff[i] + good[ngood] = i + endif + endelse + endfor + good = good[0:ngood] + + endif else begin + + good = where( shift( aa, 1) NE aa, count) + if count EQ 0 then good = 0 + + endelse + + return, sub[good] ;return subscripts in original a + end + diff --git a/modules/idl_downloads/astro/pro/remchar.pro b/modules/idl_downloads/astro/pro/remchar.pro new file mode 100644 index 0000000..1597735 --- /dev/null +++ b/modules/idl_downloads/astro/pro/remchar.pro @@ -0,0 +1,46 @@ +pro remchar,st,char ;Remove character +;+ +; NAME: +; REMCHAR +; PURPOSE: +; Remove all appearances of character (char) from string (st) +; +; CALLING SEQUENCE: +; REMCHAR, ST, CHAR +; +; INPUT-OUTPUT: +; ST - String from which character will be removed, scalar or vector +; INPUT: +; CHAR- Single character to be removed from string or all elements of a +; string array +; +; EXAMPLE: +; If a = 'a,b,c,d,e,f,g' then +; +; IDL> remchar,a, ',' +; +; will give a = 'abcdefg' +; +; REVISIONS HISTORY +; Written D. Lindler October 1986 +; Test if empty string needs to be returned W. Landsman Feb 1991 +; Work on string arrays W. Landsman August 1997 +; Avoid 32 bit integer overflow K. Tolbert/W. Landsman Feb 2007 +;- + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - REMCHAR, string, character' + return + endif + + bchar = byte(char) & bchar = bchar[0] ;Convert character to byte + + for i = 0L,N_elements(st)-1 do begin + + bst = byte(st[i]) + good = where( bst NE bchar, Ngood) + if Ngood GT 0 then st[i] = string(bst[good]) else st[i] = '' + + endfor + return + end diff --git a/modules/idl_downloads/astro/pro/remove.pro b/modules/idl_downloads/astro/pro/remove.pro new file mode 100644 index 0000000..97f2a75 --- /dev/null +++ b/modules/idl_downloads/astro/pro/remove.pro @@ -0,0 +1,124 @@ +pro remove,index, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14, $ + v15, v16, v17, v18, v19, v20, v21, v22, v23, v24, v25 +;+ +; NAME: +; REMOVE +; PURPOSE: +; Contract a vector or up to 25 vectors by removing specified elements +; CALLING SEQUENCE: +; REMOVE, index, v1,[ v2, v3, v4, v5, v6, ... v25] +; INPUTS: +; INDEX - scalar or vector giving the index number of elements to +; be removed from vectors. Duplicate entries in index are +; ignored. An error will occur if one attempts to remove +; all the elements of a vector. REMOVE will return quietly +; (no error message) if index is !NULL or undefined. +; +; INPUT-OUTPUT: +; v1 - Vector or array. Elements specifed by INDEX will be +; removed from v1. Upon return v1 will contain +; N fewer elements, where N is the number of distinct values in +; INDEX. +; +; OPTIONAL INPUT-OUTPUTS: +; v2,v3,...v25 - additional vectors containing +; the same number of elements as v1. These will be +; contracted in the same manner as v1. +; +; EXAMPLES: +; (1) If INDEX = [2,4,6,4] and V = [1,3,4,3,2,5,7,3] then after the call +; +; IDL> remove,index,v +; +; V will contain the values [1,3,3,5,3] +; +; (2) Suppose one has a wavelength vector W, and three associated flux +; vectors F1, F2, and F3. Remove all points where a quality vector, +; EPS is negative +; +; IDL> bad = where( EPS LT 0, Nbad) +; IDL> if Nbad GT 0 then remove, bad, w, f1, f2, f3 +; +; METHOD: +; If more than one element is to be removed, then HISTOGRAM is used +; to generate a 'keep' subscripting vector. To minimize the length of +; the subscripting vector, it is only computed between the minimum and +; maximum values of the index. Therefore, the slowest case of REMOVE +; is when both the first and last element are removed. +; +; REVISION HISTORY: +; Written W. Landsman ST Systems Co. April 28, 1988 +; Cleaned up code W. Landsman September, 1992 +; Major rewrite for improved speed W. Landsman April 2000 +; Accept up to 25 variables, use SCOPE_VARFETCH internally +; W. Landsman Feb 2010 +; Fix occasional integer overflow problem V. Geers Feb 2011 +; Quietly return if index is !null or undefined W.L. Aug 2011 +; +;- + On_error,2 + compile_opt idl2,strictarrsubs + + npar = N_params() + nvar = npar-1 + if npar LT 2 then begin + print,'Syntax - remove, index, v1, [v2, v3, v4,..., v25]' + return + endif + + if N_elements(index) EQ 0 then return + + vv = 'v' + strtrim( indgen(nvar)+1, 2) + npts = N_elements(v1) + + max_index = max(index, MIN = min_index) + + if ( min_index LT 0 ) || (max_index GT npts-1) then message, $ + 'ERROR - Index vector is out of range' + + if ( max_index Eq min_index ) then begin ;Remove only 1 element? + Ngood = 0 + if npts EQ 1 then message, $ + 'ERROR - Cannot delete all elements from a vector' + endif else begin + + +; Begin case where more than 1 element is to be removed. Use HISTOGRAM +; to determine then indices to keep + + nhist = max_index - min_index +1 + + hist = histogram( index) ;Find unique index values to remove + keep = where( hist EQ 0, Ngood ) + min_index + + if ngood EQ 0 then begin + if ( npts LE nhist ) then message, $ + 'ERROR - Cannot delete all elements from a vector' + endif + endelse + + imin = min_index - 1 + imax = max_index + 1 + i0 = (min_index EQ 0) + 2*(max_index EQ npts-1) + case i0 of + 3: begin + for i=0, nvar-1 do $ + (SCOPE_VARFETCH(vv[i],LEVEL=0)) = $ + (SCOPE_VARFETCH(vv[i],LEVEL=0))[keep] + return + end + + 1: ii = Ngood EQ 0 ? imax + lindgen(npts-imax) : $ + [keep, imax + lindgen(npts-imax) ] + 2: ii = Ngood EQ 0 ? lindgen(imin+1) : $ + [lindgen(imin+1), keep ] + 0: ii = Ngood EQ 0 ? [lindgen(imin+1), imax + lindgen(npts-imax) ] : $ + [lindgen(imin+1), keep, imax + lindgen(npts-imax) ] + endcase + + for i=0,nvar-1 do $ + (SCOPE_VARFETCH(vv[i],LEVEL=0)) = $ + (SCOPE_VARFETCH(vv[i],LEVEL=0))[ii] + + return + end diff --git a/modules/idl_downloads/astro/pro/repchr.pro b/modules/idl_downloads/astro/pro/repchr.pro new file mode 100644 index 0000000..94f1c84 --- /dev/null +++ b/modules/idl_downloads/astro/pro/repchr.pro @@ -0,0 +1,60 @@ +;+ +; NAME: +; REPCHR() +; PURPOSE: +; Replace all occurrences of one character with another in a string. +; +; CALLING SEQUENCE: +; New_String = repchr( In_string, OldChar, [NewChar]) +; INPUTS: +; in_string = original text string, scalar or array +; OldChar = character to replace. If the OldChar contains +; more than 1 character, only the first character is used. +; OPTIONAL INPUT: +; newchar = single character to replace it with. +; The default is a single space +; OUTPUTS: +; new_string = same as in_string, but with all occurrences of old +; replaced by newchar +; EXAMPLE: +; in_string = ['lettuce, tomato, grape'] +; print, repchr( in_string, ',') ;replace comma with space +; 'lettuce tomato grape' +; NOTES: +; Use REPSTR() to replace words rather than a single character +; +; For a more sophisticated routine that allows regular expressions look +; at MG_STRREPLACE() http://docs.idldev.com/idllib/strings/mg_streplace.html +; +; Since IDL 8.4 one can use the .REPLACE() method for string variables +; +; Note that REPCHR() is the fastest (though least versatile) of these routines, +; because the length of the string never changes, allowing direct manipulation of +; byte values. +; MODIFICATION HISTORY: +; Written W. Landsman April 2016 +; Adapted from similar code by R. Sterner JHUAPL Oct, 1986 +;- + + + function repchr, In_String, OldChar, NewChar + + if N_params() LT 2 then begin + print,' Replace all occurrences of one character with another '+$ + 'in a text string.' + print,' new_string = repchr(In_String, OldChar, [NewChar])' + return, -1 + endif + + bString = byte(In_String) ; convert string to a byte array. + b_OldChar = byte(OldChar) ; convert OldChar to byte. + + g = where(bString EQ b_OldChar[0],Ng) ; find occurrences of char 1. + IF Ng EQ 0 then return,In_string ; if none, return input string. + + if N_elements(NewChar) EQ 0 then NewChar = ' ' ;Default new char is a space + b_NewChar = byte(NewChar) ;Convert NewChar to byte + bstring[g] = b_NewChar[0] ; replace oldchar by newchar. + + return, STRING(bString) ; return new string. + END diff --git a/modules/idl_downloads/astro/pro/repstr.pro b/modules/idl_downloads/astro/pro/repstr.pro new file mode 100644 index 0000000..326a671 --- /dev/null +++ b/modules/idl_downloads/astro/pro/repstr.pro @@ -0,0 +1,87 @@ +function repstr,obj,in,out +;+ +; NAME: +; REPSTR +; PURPOSE: +; Replace all occurences of one substring by another. +; EXPLANATION: +; Meant to emulate the string substitution capabilities of text editors +; +; Obsolete since introduction of the REPLACE method for string variables +; introduced in IDL 8.4 +; +; For a more sophisticated routine that allows regular expressions look +; at MG_STRREPLACE() http://docs.idldev.com/idllib/strings/mg_streplace.html +; CALLING SEQUENCE: +; result = repstr( obj, in, out ) +; +; INPUT PARAMETERS: +; obj = object string for editing, scalar or array +; in = substring of 'obj' to be replaced, scalar +; +; OPTIONAL INPUT PARMETER: +; out = what 'in' is replaced with, scalar. If not supplied +; then out = '', i.e. 'in' is not replaced by anything. +; +; OUTPUT PARAMETERS: +; Result returned as function value. Input object string +; not changed unless assignment done in calling program. +; +; PROCEDURE: +; Searches for 'in', splits 'obj' into 3 pieces, reassembles +; with 'out' in place of 'in'. Repeats until all cases done. +; +; EXAMPLE: +; If a = 'I am what I am' then print,repstr(a,'am','was') +; will give 'I was what I was'. +; +; MODIFICATION HISTORY: +; Written by Robert S. Hill, ST Systems Corp., 12 April 1989. +; Accept vector object strings, W. Landsman HSTX, April, 1996 +; Convert loop to LONG, vectorize STRLEN call W. Landsman June 2002 +; Correct bug in optimization, case where STRLEN(OBJ) EQ +; STRLEN(IN), C. Markwardt, Jan 2003 +; Fixed problem when multiple replacements extend the string length +; D. Finkbeiner, W. Landsman April 2003 +; Allow third parameter to be optional again W. Landsman August 2003 +; Remove limitation of 9999 characters, C. Markwardt Dec 2003 +; Test for empty "in" string (causing infinite loop) W. Landsman Jan 2010 +; Streamline code W Landsman Dec 2011 +; Use string .replace method in IDL 8.4 or later W. Landsman Feb 2015 +; Use CALL_METHOD so that it still compiles in IDL 7.1 W.Landsman Aug 2015 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - result = REPSTR( obj, in, out )' + return, obj + endif + + if !VERSION.RELEASE GE '8.4' then return,call_method('replace',obj,in,out) + if N_elements(out) EQ 0 then out = '' + l1 = strlen(in) + if l1 EQ 0 then message,'ERROR - empty input string not allowed' + l2 = strlen(out) + diflen = l2- l1 + Nstring = N_elements(obj) + object = obj + lo = strlen(object) - l1 ;Last character needed to look at + for i= 0L ,Nstring-1 do begin + last_pos = 0 + pos = 0 + while ( pos LE lo[i]) do begin + pos = strpos(object[i],in,last_pos) + if (pos GE 0) then begin + first_part = strmid(object[i],0,pos) + last_part = strmid(object[i],pos+l1) + object[i] = first_part + out + last_part + last_pos = pos + l2 + lo[i] += diflen ;Length of string may have changed + endif else break + endwhile + endfor + + return,object + + end diff --git a/modules/idl_downloads/astro/pro/resistant_mean.pro b/modules/idl_downloads/astro/pro/resistant_mean.pro new file mode 100644 index 0000000..da62363 --- /dev/null +++ b/modules/idl_downloads/astro/pro/resistant_mean.pro @@ -0,0 +1,202 @@ +PRO RESISTANT_Mean,Y,CUT,Mean,Sigma,Num_Rej,goodvec = goodvec, $ + dimension=dimension, double=double,sumdim=sumdim, $ + wused=wused, Silent = silent +;+ +; NAME: +; RESISTANT_Mean +; +; PURPOSE: +; Outlier-resistant determination of the mean and standard deviation. +; +; EXPLANATION: +; RESISTANT_Mean trims away outliers using the median and the median +; absolute deviation. An approximation formula is used to correct for +; the truncation caused by trimming away outliers +; +; CALLING SEQUENCE: +; RESISTANT_Mean, ARRAY, Sigma_CUT, Mean, Sigma_Mean, Num_RejECTED +; [/DOUBLE, DIMENSION= , GOODVEC = ] +; INPUT ARGUMENT: +; ARRAY = Vector or array to average, NaN values will be ignored +; Sigma_CUT = Data more than this number of standard deviations from the +; median is ignored. Suggested values: 2.0 and up. +; +; OUTPUT ARGUMENT: +; Mean = the mean of the input array, numeric scalar, If the +; DIMENSION keyword is set, then MEAN will be an array with one +; less dimension than the input. +; OPTIONAL OUTPUTS: +; Sigma_Mean = the approximate standard deviation of the mean, numeric +; scalar. This is the Sigma of the distribution divided by sqrt(N-1) +; where N is the number of unrejected points. The larger +; SIGMA_CUT, the more accurate. It will tend to underestimate the +; true uncertainty of the mean, and this may become significant for +; cuts of 2.0 or less. +; Num_RejECTED = the number of points trimmed, integer scalar +; OPTIONAL INPUT KEYWORDS: +; /DOUBLE - If set, then all calculations are performed internally +; in double precision. +; DIMENSION - for a multi-dimensional array, the dimension over which to +; take the mean, starting at 1. If not set, then the scalar mean +; over all elements is used. If this argument is present, the result +; is an array with one less dimension than Array. For example, if +; the dimensions of Array are N1, N2, N3, and Dimension is 2, then +; the dimensions of the result are (N1, N3) +; /SILENT - Set to suppress error messages, e.g.if all values in the array +; are NaN +; SUMDIM - Obsolete synonym for DIMENSION +; OPTIONAL OUTPUT KEYWORD: +; Goodvec - Indices of non-trimmed elements of the input vector +; Wused - synonym for Goodvec (for solarsoft compatibility) +; EXAMPLE: +; IDL> a = randomn(seed, 10000) ;Normal distribution with 10000 pts +; IDL> RESISTANT_Mean,a, 3, mean, meansig, num ;3 Sigma clipping +; IDL> print, mean, meansig,num +; +; The mean should be near 0, and meansig should be near 0.01 ( = +; 1/sqrt(10000) ). +; PROCEDURES USED: +; MEAN() - compute simple mean, in Exelis library +; REVISION HISTORY: +; Written, H. Freudenreich, STX, 1989; Second iteration added 5/91. +; Use MEDIAN(/EVEN) W. Landsman April 2002 +; Correct conditional test, higher order truncation correction formula +; R. Arendt/W. Landsman June 2002 +; New truncation formula for sigma H. Freudenriech July 2002 +; Divide Sigma_mean by Num_good rather than Npts W. Landsman/A. Conley +; January 2006 +; Use of double precision S. Bianchi February 2008 +; More double precision B. Carcich December 2009 +; Added DIMENSION keyword (from M. Desnoyer) B. Carcich December 2009 +; Use IDL's MEAN() function instead of AVG() W. Landsman Jan 2012 +; Use of Dimension keyword yielded transpose of correct value +; W. Landsman July 2012 +; Added NaN keyword to MEAN() call N. Crouzet/WL April 2013 +; Allow a row/column to be all NaN values N. Crouzet/WL April 2013 +; Use of DIMENSION keyword yielded wrong answer for non-square arrays +; D. Cottingham December 2014 +;- + + On_Error,2 + compile_opt idl2 + if N_params() LT 3 then begin + print,'Syntax - Resistant_Mean, Vector, Sigma_cut, Mean, [ Sigma_mean, ' + print,' Num_Rejected, GOODVEC=,' + print,' DIMEN=, /DOUBLE]' + return + endif + + sz = size(Y) + indouble = size(Y,/tname) EQ 'DOUBLE' ;Is input double precision? + +; Average over a single dimension? + if N_elements(DIMENSION) then DIM = long(DIMENSION[0]) $ + else if n_elements(SUMDIM) then DIM = long(SUMDIM[0]) + if (sz[0] gt 1L) && (sz[0] lt 5L) && (N_elements(DIM) EQ 1) then begin + if (DIM lt 1L) || (dim gt sz[0]) then begin + message,/continue, 'Invalid dimension number' + print,'Syntax - Resistant_Mean, Vector, Sigma_cut, Mean' + print,' , [ Sigma_mean, Num_Rejected, Dimension={1|2} ]' + return + endif + ;;; + od=[ sz[0:dim-1], sz[dim+1:sz[0]+1] ] ;;; [buffer, i,j,k,m, buffer] + od=[ od[1:sz[0]-1], 1, 1, 1] ;;; [i,j,k,m] + rowlen = sz[dim] + colhgt = sz[sz[0]+2]/rowlen + sd = size([0d0]) + Num_Rej = make_array(od[0],od[1],od[2],od[3],val=0L) + if keyword_set(double) || indouble then v=0d0 else v=0. + Mean = make_array(od[0],od[1],od[2],od[3],val=v) + Sigma = Mean + ;;; + if n_elements(CUT) eq colhgt then iwCUT = lindgen(colhgt) $ + else iwCUT = make_array(colhgt,val=0L) + ;;; + ijkL=0L + + for L=0L,od[3]-1L do begin + for k=0L,od[2]-1L do begin + for j=0L,od[1]-1L do begin + for i=0L,od[0]-1L do begin + thisCut = CUT[iwCUT[ijkL]] + case dim of + 1: RESISTANT_Mean,Y[*,i,j,k,L],thisCUT,M,S,N,double=double,/Silent + 2: RESISTANT_Mean,Y[i,*,j,k,L],thisCUT,M,S,N,double=double,/Silent + 3: RESISTANT_Mean,Y[i,j,*,k,L],thisCUT,M,S,N,double=double,/Silent + 4: RESISTANT_Mean,Y[i,j,k,*,L],thisCUT,M,S,N,double=double,/Silent + 5: RESISTANT_Mean,Y[i,j,k,L,*],thisCUT,M,S,N,double=double,/Silent + endcase + + ;;; + Mean[ijkL] = M + Sigma[ijkL] = S + Num_Rej[ijkL] = N + ijkL++ + endfor + endfor + endfor + endfor + return + endif + + MADscale = 0.6745d0 + MADscale2 = 0.8d0 + MADlim = 1d-24 + Sigcoeff = [ -0.15405d0, +0.90723d0, -0.23584d0, +0.020142d0 ] + One = 1d0 + if ~keyword_set(double) && ~indouble then begin + MADscale = float(MADscale) + MADscale2 = float(MADscale2) + MADlim = float(MADlim) + SIGcoeff = float(SIGcoeff) + One = float(One) + endif + + Npts = N_Elements(Y) + YMed = MEDIAN(Y,/EVEN, DOUBLE=double) + AbsDev = ABS(Y-YMED) + MedAbsDev = MEDIAN(AbsDev,/EVEN, DOUBLE=double)/MADscale + IF MedAbsDev LT MADlim THEN $ + MedAbsDev = MEAN(AbsDev, DOUBLE=double, /NaN)/MADscale2 + + Cutoff = Cut*MedAbsDev + + goodvec = where( AbsDev LE Cutoff, Num_Good) + if Num_Good LE 0 then begin + if ~keyword_set(SILENT) then $ + message,'Unexpected error -- Unable to compute mean',/Con + mean = !Values.F_NaN & sigma = !VALUES.F_NAN & Num_rej = 0 + return + endif + GoodPts = Y[ goodvec] + Mean = mean( GoodPts, DOUBLE=double) + Sigma = SQRT( TOTAL((GoodPts-Mean)^2, DOUBLE=double)/Num_Good ) + Num_Rej = Npts - Num_Good + +; Compensate Sigma for truncation (formula by HF): + SC = Cut > 1.0 + IF SC LE 4.50 THEN SIGMA=SIGMA/poly(SC, SIGcoeff) + + Cutoff = Cut*Sigma + + goodvec = where( AbsDev LE Cutoff, Num_Good) + + Num_Rej = Npts - Num_Good + GoodPts = Y[ goodvec ] + if arg_present(wused) then wused = goodvec + Mean = mean( GoodPts, DOUBLE= double) + if N_params() LT 4 then return ;Skip sigma calculation? + + + Sigma = SQRT( TOTAL((GoodPts-Mean)^2)/Num_Good ) + +; Fixed bug (should check for SC not Sigma) & add higher order correction + SC = Cut > 1.0 + IF SC LE 4.50 THEN SIGMA=SIGMA/poly(SC, SIGcoeff) + +; Now the standard deviation of the mean: + Sigma = Sigma/SQRT(Num_Good-One) + + RETURN + END diff --git a/modules/idl_downloads/astro/pro/rhotheta.pro b/modules/idl_downloads/astro/pro/rhotheta.pro new file mode 100644 index 0000000..5ceec75 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rhotheta.pro @@ -0,0 +1,103 @@ +FUNCTION RHOTHETA,P,T,e,a,i,Omega,omega2,t2 + +;+ +; NAME: +; RHOTHETA +; +; PURPOSE: +; Calculate the separation and position angle of a binary star +; +; EXPLANATION: +; This function will return the separation rho and position angle +; theta of a visual binary star derived from its orbital elements. +; The algorithms described in the following book will be used: +; Meeus J., 1992, Astronomische Algorithmen, Barth. +; Compared to the examples given at p. 400 and no discrepancy found. +; Input parameters will never be changed. +; +; CALLING SEQUENCE: +; +; Result = RHOTHETA ( P, T, e, a, i, Omega, omega2, t2) +; +; INPUT: +; +; P - Period [year] +; T - Time of periastron passage [year] +; e - eccentricity of the orbit +; a - semi-major axis [arc second] +; i - inclination [degree] +; Omega - node [degree] +; omega2 - longitude of periastron [degree] +; t2 - epoch of observation [year] +; +; OUTPUT: +; +; structure containing +; rho - separation [arc second] +; theta - position angle [degree] +; In case of errors rho and theta are -1. +; +; RESTRICTIONS: +; +; All input parameters have to be scalars and floating point numbers. +; +; EXAMPLE: +; Find the position of Eta Coronae Borealis at the epoch 1980.0 +; +; IDL> test=rhotheta(41.623,1934.008,0.2763,0.907,59.025,23.717,219.907,1980.0) +; rho= 0.411014 theta= 318.42307 +; +; PROCEDURES CALLED: +; CIRRANGE - from IDL Astronomy Library +; +; MODIFICATION HISTORY: +; +; Written by: Sebastian Kohl Hamburg Observatory, November, 2012 +;- +; +result={rho:DOUBLE(-1),theta:DOUBLE(-1)} + +IF (N_PARAMS() EQ 8) THEN BEGIN +; see chapter 55 +n=360.0/P +M=n*(t2-T) +M=M/360.0*2.0*!PI; convert M in radians + +; solution of Kepler equation, see chapter 29, 3rd method +F= M GT 0 ? 1 : -1 +M=ABS(M)/2.0/!PI +M=(M-FLOOR(M))*2.0*!PI*F +IF (M LT 0.0) THEN M=M+2.0*!PI +F=1.0 +IF (M GT !PI) THEN F=-1.0 +IF (M GT !PI) THEN M=2.0*!PI-M +E0=!PI/2.0 +D=!PI/4.0 +FOR j=1,33 DO BEGIN +M1=E0-e*sin(E0) +SGN_M = (M-M1) GT 0 ? 1 : -1 +E0=E0+D*SGN_M +D=D/2.0 +ENDFOR +E0=E0*F + +; return to chapter 55 +r=a*(1.0-e*cos(E0)) +nu=2.0*ATAN(SQRT((1.0+e)/(1.0-e))*TAN(E0/2.0)) +my_omega2=omega2/180.0*!PI; convert variables in radians and copy them to a new variable to prevent changes to the input parameter +my_i=i/180.0*!PI +my_Omega=Omega/180.0*!PI +theta=my_Omega+ATAN(SIN(nu+my_omega2)*COS(my_i),COS(nu+my_omega2)) +rho=r*COS(nu+my_omega2)/COS(theta-my_Omega) +theta=theta*180.0/!PI; convert theta in degree + +CIRRANGE,theta; force theta to be in 0..360 range +print,'rho= ',rho,' theta= ',theta +result.rho=rho +result.theta=theta + +ENDIF ELSE print,'Syntax - RHOTHETA, P, T, e, a, i, Omega, omega2, t2' + +RETURN,result + + end diff --git a/modules/idl_downloads/astro/pro/rinter.pro b/modules/idl_downloads/astro/pro/rinter.pro new file mode 100644 index 0000000..702d9e9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rinter.pro @@ -0,0 +1,170 @@ +FUNCTION RINTER, P, X, Y, DFDX, DFDY, INITIALIZE = initialize +;+ +; NAME: +; RINTER +; PURPOSE: +; Cubic interpolation of an image at a set of reference points. +; EXPLANATION: +; This interpolation program is equivalent to using the intrinsic +; INTERPOLATE() function with CUBIC = -0.5. However, +; RINTER() has two advantages: (1) one can optionally obtain the +; X and Y derivatives at the reference points, and (2) if repeated +; interpolation is to be applied to an array, then some values can +; be pre-computed and stored in Common. RINTER() was originally +; for use with the DAOPHOT procedures, but can also be used for +; general cubic interpolation. +; +; CALLING SEQUENCE: +; Z = RINTER( P, X, Y, [ DFDX, DFDY ] ) +; or +; Z = RINTER(P, /INIT) +; +; INPUTS: +; P - Two dimensional data array, +; X - Either an N element vector or an N x M element array, +; containing X subscripts where cubic interpolation is desired. +; Y - Either an N element vector or an N x M element array, +; containing Y subscripts where cubic interpolation is desired. +; +; OUTPUT: +; Z - Result = interpolated vector or array. If X and Y are vectors, +; then so is Z, but if X and Y are arrays then Z will be also. +; If P is DOUBLE precision, then so is Z, otherwise Z is REAL. +; +; OPTIONAL OUTPUT: +; DFDX - Vector or Array, (same size and type as Z), containing the +; derivatives with respect to X +; DFDY - Array containing derivatives with respect to Y +; +; OPTIONAL KEYWORD INPUT: +; /INIT - Perform computations associated only with the input array (i.e. +; not with X and Y) and store in common. This can save time if +; repeated calls to RINTER are made using the same array. +; +; EXAMPLE: +; suppose P is a 256 x 256 element array and X = FINDGEN(50)/2. + 100. +; and Y = X. Then Z will be a 50 element array, containing the +; cubic interpolated points. +; +; SIDE EFFECTS: +; can be time consuming. +; +; RESTRICTION: +; Interpolation is not possible at positions outside the range of +; the array (including all negative subscripts), or within 2 pixel +; units of the edge. No error message is given but values of the +; output array are meaningless at these positions. +; +; PROCEDURE: +; invokes CUBIC interpolation algorithm to evaluate each element +; in Z at virtual coordinates contained in X and Y with the data +; in P. +; +; COMMON BLOCKS: +; If repeated interpolation of the same array is to occur, then +; one can save time by initializing the common block RINTER. +; +; REVISION HISTORY: +; March 1988 written W. Landsman STX Co. +; Checked for IDL Version 2, J. Isensee, September, 1990 +; Corrected call to HISTOGRAM, W. Landsman November 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +; Fix output derivatives for 2-d inputs, added /INIT W. Landsman May 2000 +; +;- + On_error, 2 + common rinter, c1, c2, c3, init + + if (N_params() LT 3) and (NOT keyword_set(INIT)) then begin + print, 'Syntax: Z = RINTER( P, X, Y, [ DFDX, DFDY] ) ' + print, ' or Z = RINTER( P, /INIT) to initialize common block + print,'P - Array to be interpolated' + print,'X - Vector or array of X positions' + print,'Y - Vector or array of Y Positions' + print,'DFDX, DFDY - Optional output derivatives ' + return,0 + endif + + c = size(p) + if c[0] NE 2 then $ + message,'Input array (first parameter) must be 2 dimensional' + + if keyword_set(initialize) then begin + +; Don't use SHIFT function to avoid wraparound at the end points + + nx = c[1] + p_1 = p & p1 = p & p2 = p + p_1[1,0] = p[0:nx-2,*] + p1[0,0] = p[1:*,*] + p2[0,0] = p[2:*,*] + c1 = 0.5*(p1 - p_1) + c2 = 2.*p1 + p_1 - 0.5*(5.*p + p2) + c3 = 0.5*(3.*(p-p1) + p2 - p_1) + init = 1 + if N_params() LT 3 then return,0 + endif + + sx = size(x) + npts = sx[sx[0]+2] + c[3] = c[3] > 4 ;Make sure output array at least REAL + + i = long( x[*] ) + j = long( y[*] ) + xdist = x[*] - i + ydist = y[*] - j + x_1 = c[1]*(j-1) + i + x0 = x_1 + c[1] + x1 = x0 + c[1] + x2 = x1 + c[1] + + if N_elements(init) EQ 0 then init = 0 ;Has COMMON block been initialized? + + if init EQ 0 then begin + + xgood = [ x_1,x0,x1,x2 ] + num = histogram( xgood, MIN=0) + xgood = where( num GE 1 ) + p_1 = p[xgood-1] & p0 = p[xgood] & p1 = p[xgood+1] & p2 = p[xgood+2] + c1 = p*0. & c2 = c1 & c3 = c1 + c1[xgood] = 0.5*( p1 - p_1) + c2[xgood] = 2.*p1 + p_1 - 0.5*(5.*p0 + p2) + c3[xgood] = 0.5*(3.*(p0 - p1) + p2 - p_1) + endif + + y_1 = xdist*( xdist*( xdist*c3[x_1] +c2[x_1]) + c1[x_1]) + p[x_1] + y0 = xdist*( xdist*( xdist*c3[x0] +c2[x0]) + c1[x0]) + p[x0] + y1 = xdist*( xdist*( xdist*c3[x1] +c2[x1]) + c1[x1]) + p[x1] + y2 = xdist*( xdist*( xdist*c3[x2] +c2[x2]) + c1[x2]) + p[x2] + + if N_params() GT 3 then begin + + dy_1 = xdist*(xdist*c3[x_1]*3. + 2.*c2[x_1]) + c1[x_1] + dy0 = xdist*(xdist*c3[x0 ]*3. + 2.*c2[x0]) + c1[x0] + dy1 = xdist*(xdist*c3[x1 ]*3. + 2.*c2[x1]) + c1[x1] + dy2 = xdist*(xdist*c3[x2 ]*3. + 2.*c2[x2]) + c1[x2] + d1 = 0.5*(dy1 - dy_1) + d2 = 2.*dy1 + dy_1 - 0.5*(5.*dy0 +dy2) + d3 = 0.5*( 3.*( dy0-dy1 ) + dy2 - dy_1) + dfdx = ydist*( ydist*( ydist*d3 + d2 ) + d1 ) + dy0 + + endif + + d1 = 0.5*(y1 - y_1) + d2 = 2.*y1 + y_1 - 0.5*(5.*y0 +y2) + d3 = 0.5*(3.*(y0-y1) + y2 - y_1) + z = ydist*(ydist*(ydist*d3 + d2) + d1) + y0 + if N_params() GT 3 then dfdy = ydist*(ydist*d3*3.+2*d2) + d1 + + if ( sx[0] EQ 2 ) then begin ;Convert results to 2-D if desired + + z = reform(z,sx[1],sx[2] ) + if N_params() GT 3 then begin ;Create output derivative arrays? + dfdx = reform(dfdx,sx[1],sx[2]) + dfdy = reform(dfdy,sx[1],sx[2]) + endif + + endif + + return,z + end diff --git a/modules/idl_downloads/astro/pro/rob_checkfit.pro b/modules/idl_downloads/astro/pro/rob_checkfit.pro new file mode 100644 index 0000000..1769606 --- /dev/null +++ b/modules/idl_downloads/astro/pro/rob_checkfit.pro @@ -0,0 +1,66 @@ +FUNCTION ROB_CHECKFIT,Y, YFIT, EPS, DEL, SIG, FRACDEV, NGOOD,W,B,$ + BISQUARE_LIMIT=BLIM +;+ +; NAME: +; ROB_CHECKFIT +; PURPOSE: +; Used by ROBUST_... routines to determine the quality of a fit and to +; return biweights. +; CALLING SEQUENCE: +; status = ROB_CHECKFIT( Y, YFIT, EPS, DEL, SIG, FRACDEV, NGOOD, W, B +; BISQUARE_LIMIT = ) +; INPUT: +; Y = the data +; YFIT = the fit to the data +; EPS = the "too small" limit +; DEL = the "close enough" for the fractional median abs. deviations +; RETURNS: +; Integer status. if =1, the fit is considered to have converged +; +; OUTPUTS: +; SIG = robust standard deviation analog +; FRACDEV = the fractional median absolute deviation of the residuals +; NGOOD = the number of input point given non-zero weight in the +; calculation +; W = the bisquare weights of Y +; B = residuals scaled by sigma +; +; OPTIONAL INPUT KEYWORD: +; BISQUARE_LIMIT = allows changing the bisquare weight limit from +; default 6.0 +; PROCEDURES USED: +; ROBUST_SIGMA() +; REVISION HISTORY: +; Written, H.T. Freudenreich, HSTX, 1/94 +;- + + ISTAT = 0 + + IF KEYWORD_SET(BLIM) THEN BFAC=BLIM ELSE BFAC=6. + + DEV = Y-YFIT + + SIG=ROBUST_SIGMA(DEV,/ZERO) +; If the standard deviation = 0 then we're done: + IF SIG LT EPS THEN GOTO,DONE + + IF DEL GT 0. THEN BEGIN + ; If the fraction std. deviation ~ machine precision, we're done: + Q=WHERE( ABS(YFIT) GT EPS, COUNT ) + IF COUNT LT 3 THEN FRACDEV = 0. ELSE $ + FRACDEV = MEDIAN(ABS( DEV[Q]/YFIT[Q] ),/EVEN ) + IF FRACDEV LT DEL THEN GOTO,DONE + ENDIF + + ISTAT = 1 + +; Calculate the (bi)weights: + B = ABS(DEV)/(BFAC*SIG) + S = WHERE( B GT 1.0,COUNT ) & IF COUNT GT 0 THEN B[S] = 1. + NGOOD = N_ELEMENTS(Y)-COUNT + + W=(1.-B^2) + W=W/TOTAL(W) +DONE: +RETURN, ISTAT +END diff --git a/modules/idl_downloads/astro/pro/robust_linefit.pro b/modules/idl_downloads/astro/pro/robust_linefit.pro new file mode 100644 index 0000000..817a0f0 --- /dev/null +++ b/modules/idl_downloads/astro/pro/robust_linefit.pro @@ -0,0 +1,268 @@ +FUNCTION ROBUST_LINEFIT,XIN,YIN,YFIT,SIG,SS, NUMIT=THIS_MANY, BISECT=TYPE, $ + Bisquare_Limit=Bisquare_Limit, $ + Close_Factor=Close_Factor +;+ +; NAME: +; ROBUST_LINEFIT +; +; PURPOSE: +; An outlier-resistant two-variable linear regression. +; EXPLANATION: +; Either Y on X or, for the case in which there is no true independent +; variable, the bisecting line of Y vs X and X vs Y is calculated. No +; knowledge of the errors of the input points is assumed. +; +; CALLING SEQUENCE: +; COEFF = ROBUST_LINEFIT( X, Y, YFIT, SIG, COEF_SIG, [ /BISECT, +; BiSquare_Limit = , Close_factor = , NumIT = ] ) +; +; INPUTS: +; X = Independent variable vector, floating-point or double-precision +; Y = Dependent variable vector +; +; OUTPUTS: +; Function result = coefficient vector. +; If = 0.0 (scalar), no fit was possible. +; If vector has more than 2 elements (the last=0) then the fit is dubious. +; +; OPTIONAL OUTPUT PARAMETERS: +; YFIT = Vector of calculated y's +; SIG = The "standard deviation" of the fit's residuals. If BISECTOR +; is set, this will be smaller by ~ sqrt(2). +; COEF_SIG = The estimated standard deviations of the coefficients. If +; BISECTOR is set, however, this becomes the vector of fit +; residuals measured orthogonal to the line. +; +; OPTIONAL INPUT KEYWORDS: +; NUMIT = the number of iterations allowed. Default = 25 +; BISECT if set, the bisector of the "Y vs X" and "X vs Y" fits is +; determined. The distance PERPENDICULAR to this line is used +; in calculating weights. This is better when the uncertainties +; in X and Y are comparable, so there is no true independent +; variable. Bisquare_Limit Limit used for calculation of +; bisquare weights. In units of outlier-resistant standard +; deviations. Default: 6. +; Smaller limit ==>more resistant, less efficient +; Close_Factor - Factor used to determine when the calculation has converged. +; Convergence if the computed standard deviation changes by less +; than Close_Factor * ( uncertainty of the std dev of a normal +; distribution ). Default: 0.03. +; SUBROUTINE CALLS: +; ROB_CHECKFIT +; ROBUST_SIGMA, to calculate a robust analog to the std. deviation +; +; PROCEDURE: +; For the initial estimate, the data is sorted by X and broken into 2 +; groups. A line is fitted to the x and y medians of each group. +; Bisquare ("Tukey's Biweight") weights are then calculated, using the +; a limit of 6 outlier-resistant standard deviations. +; This is done iteratively until the standard deviation changes by less +; than CLOSE_ENOUGH = CLOSE_FACTOR * {uncertainty of the standard +; deviation of a normal distribution} +; +; REVISION HISTORY: +; Written, H. Freudenreich, STX, 4/91. +; 4/13/93 to return more realistic SS's HF +; 2/94 --more error-checking, changed convergence criterion HF +; 5/94 --added BISECT option. HF. +; 8/94 --added Close_Factor and Bisquare_Limit options Jack Saba. +; 4/02 --V5.0 version, use MEDIAN(/EVEN) W. Landsman +;- + +ON_ERROR,2 + +IF N_ELEMENTS(THIS_MANY) GT 0 THEN ITMAX = THIS_MANY ELSE ITMAX=25 + +IF N_elements(Close_Factor) EQ 0 THEN Close_Factor = 0.03 + +DEL = 5.0E-07 +EPS = 1.0E-20 + +N = N_ELEMENTS(XIN) + +; First, shift X and Y to their centers of gravity: + X0 = TOTAL(XIN)/N & Y0=TOTAL(YIN)/N + X = XIN-X0 & Y = YIN-Y0 + + CC=FLTARR(2) + SS=FLTARR(2) + SIG=0. + YFIT=YIN + BADFIT=0 + NGOOD=N + +; Make sure the independent variables are not all the same. + XRANGE=MAX(X)-MIN(X) + AVEX= (TOTAL(ABS(X))/N) > EPS + IF (XRANGE LT EPS) OR (XRANGE/AVEX LT DEL) THEN BEGIN + message,'Independent variables the same. No fit possible.',/CON + RETURN,0. +ENDIF + +; First guess: +LSQ=0 +YP=Y +IF N GT 5 THEN BEGIN +; We divide the data into 2 groups and fit a line to their X and Y medians. + S=SORT(X) & U=X[S] & V=Y[S] + NHALF=N/2-1 + X1=MEDIAN(U[0:NHALF],/EVEN) & X2=MEDIAN(U[NHALF+1:N-1],/EVEN) + Y1=MEDIAN(V[0:NHALF],/EVEN) & Y2=MEDIAN(V[NHALF+1:N-1],/EVEN) + IF ABS(X2-X1) LT EPS THEN BEGIN +; The X medians are too close. Select the end-points instead. + X1=U[0] & X2=U[N-1] + Y1=V[0] & Y2=V[N-1] + ENDIF + CC[1]=(Y2-Y1)/(X2-X1) & CC[0]=Y1-CC[1]*X1 + YFIT = CC[0]+CC[1]*X + ISTAT = ROB_CHECKFIT(YP,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S) + IF NGOOD LT 2 THEN LSQ=1 +ENDIF +IF (LSQ EQ 1) OR (N LT 6) THEN BEGIN ; Try a least-squares fit + SX=TOTAL(X) & SY=TOTAL(Y) & SXY=TOTAL(X*Y) & SXX=TOTAL(X*X) + D=SXX-SX*SX + IF ABS(D) LT EPS THEN BEGIN + PRINT,'ROBUST_LINEFIT: No fit possible.' + RETURN,0. + ENDIF + YSLOP=(SXY-SX*SY)/D & YYINT=(SXX*SY-SX*SXY)/D + + IF KEYWORD_SET(TYPE) THEN BEGIN +; Get the X vs Y line. + SYY=TOTAL(Y*Y) + D=SYY-SY*SY + IF ABS(D) LT EPS THEN BEGIN + PRINT,'ROBUST_LINEFIT: No fit possible.' + RETURN,0. + ENDIF + TSLOP=(SXY-SY*SX)/D & TYINT=(SYY*SX-SY*SXY)/D +; Now invert it to get the form Y=a+bX: + IF ABS(TSLOP) LT EPS THEN BEGIN + message,'No fit possible.',/CON + RETURN,0. + ENDIF + XSLOP = 1./TSLOP & XYINT=-TYINT/TSLOP +; Now calculate the equation of the bisector of the 2 lines: + IF YSLOP GT XSLOP THEN BEGIN + A1=YYINT & B1=YSLOP & R1=SQRT(1.+YSLOP^2) + A2=XYINT & B2=XSLOP & R2=SQRT(1.+XSLOP^2) + ENDIF ELSE BEGIN + A2=YYINT & B2=YSLOP & R2=SQRT(1.+YSLOP^2) + A1=XYINT & B1=XSLOP & R1=SQRT(1.+XSLOP^2) + ENDELSE + YINT = (R1*A2+R2*A1)/(R1+R2) + SLOP = (R1*B2+R2*B1)/(R1+R2) +; Now find the orthogonal distance to the line. Convert to normal +; coordinates. + R = SQRT(1.+SLOP^2) & IF YINT GT 0. THEN R=-R + U1 = SLOP/R & U2=-1./R & U3=YINT/R + YP = U1*X+U2*Y+U3 ; = orthog. distance to line + YFIT = FLTARR(N) ; to fool ROB_CHECKFIT + SS=YP + ENDIF ELSE BEGIN + SLOP=YSLOP & YINT=YYINT + YFIT = YINT+SLOP*X + ENDELSE + CC = [YINT,SLOP] + ISTAT = ROB_CHECKFIT(YP,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S) +ENDIF + + IF ISTAT EQ 0 THEN GOTO,AFTERFIT + + IF NGOOD LT 2 THEN BEGIN + message,'Data Dangerously Weird. Fit Questionable.',/CON + BADFIT=1 + GOTO,AFTERFIT +ENDIF + +; Now iterate until the solution converges: + SIG_1= (100.*SIG) < 1.0E20 + CLOSE_ENOUGH = Close_Factor * SQRT(.5/(N-1)) > DEL + DIFF= 1.0E20 + NIT = 0 + WHILE( (DIFF GT CLOSE_ENOUGH) AND (NIT LT ITMAX) ) DO BEGIN + NIT=NIT+1 + SIG_2=SIG_1 + SIG_1=SIG + SX=TOTAL(W*X) & SY=TOTAL(W*Y) & SXY=TOTAL(W*X*Y) & SXX=TOTAL(W*X*X) + D=SXX-SX*SX + IF ABS(D) LT EPS THEN BEGIN + message,'No fit possible.',/CON + RETURN,0. + ENDIF + YSLOP = (SXY-SX*SY)/D & YYINT = (SXX*SY-SX*SXY)/D + SLOP = YSLOP & YINT = YYINT + IF KEYWORD_SET(TYPE) THEN BEGIN +; Get the X vs Y line. + SYY=TOTAL(W*Y*Y) + D=SYY-SY*SY + IF ABS(D) LT EPS THEN BEGIN + PRINT,'ROBUST_LINEFIT: No fit possible.' + RETURN,0. + ENDIF + TSLOP=(SXY-SY*SX)/D & TYINT=(SYY*SX-SY*SXY)/D +; Now invert it to get the form Y=a+bX: + IF ABS(TSLOP) LT EPS THEN BEGIN + PRINT,'ROBUST_LINEFIT: No fit possible.' + RETURN,0. + ENDIF + XSLOP=1./TSLOP & XYINT=-TYINT/TSLOP +; Now calculate the equation of the bisector of the 2 lines: + IF YSLOP GT XSLOP THEN BEGIN + A1=YYINT & B1=YSLOP & R1=SQRT(1.+YSLOP^2) + A2=XYINT & B2=XSLOP & R2=SQRT(1.+XSLOP^2) + ENDIF ELSE BEGIN + A2=YYINT & B2=YSLOP & R2=SQRT(1.+YSLOP^2) + A1=XYINT & B1=XSLOP & R1=SQRT(1.+XSLOP^2) + ENDELSE + YINT=(R1*A2+R2*A1)/(R1+R2) + SLOP=(R1*B2+R2*B1)/(R1+R2) + R=SQRT(1.+SLOP^2) & IF YINT GT 0. THEN R=-R + U1=SLOP/R & U2=-1./R & U3=YINT/R + YP=U1*X+U2*Y+U3 ; = orthog distance to line + YFIT=FLTARR(N) & YFIT[*]=0. + SS=YP + ENDIF ELSE BEGIN + YFIT = YINT+SLOP*X + ENDELSE + CC=[YINT,SLOP] + ISTAT=ROB_CHECKFIT(YP,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S, $ + Bisquare_Limit=Bisquare_Limit ) + + IF ISTAT EQ 0 THEN GOTO,AFTERFIT + IF NGOOD LT 2 THEN BEGIN + PRINT,'ROBUST_LINEFIT: Data Dangerously Weird. Fit Questionable.' + BADFIT=1 + GOTO,AFTERFIT + ENDIF + DIFF = (ABS(SIG_1-SIG)/SIG) < (ABS(SIG_2-SIG)/SIG) +ENDWHILE + +AFTERFIT: +; Untranslate the coefficients + CC[0] = CC[0]+Y0-CC[1]*X0 + +IF N_PARAMS(0) GT 2 THEN YFIT = CC[0] + CC[1]*XIN + IF KEYWORD_SET(BISECT) THEN RETURN,CC + + IF (N_PARAMS(0) GT 3) AND (SIG GT EPS) AND (NGOOD GT 2) THEN BEGIN + ; Here we use an empirical formula to approximate the standard deviations + ; of the coefficients. They are usually accurate to ~ 25%. + SX2 = TOTAL(W*X*X) + UU = S*S + DEV = YIN-YFIT + Y0 = TOTAL( W*DEV ) + Q = WHERE(UU LE 1.0,COUNT) + DEN1 = ABS(TOTAL( (1.-UU[Q])*(1.-5.*UU[Q]) )) + SIG = ROBUST_SIGMA(DEV,/ZERO) + ; Now empirically derived estimates of the uncertainties: + SS[0] = SIG/SQRT(DEN1)/1.105 + SS[1] = SS[0]/SQRT(SX2) + ; Take the X shift into account: + SS[0] = SQRT(SS[0]^2+X0*SS[1]^2) + ENDIF + + IF BADFIT EQ 1 THEN CC=[CC,0.] + + RETURN,CC + END diff --git a/modules/idl_downloads/astro/pro/robust_poly_fit.pro b/modules/idl_downloads/astro/pro/robust_poly_fit.pro new file mode 100644 index 0000000..149a3e7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/robust_poly_fit.pro @@ -0,0 +1,194 @@ +FUNCTION ROBUST_POLY_FIT,X,Y,NDEG,YFIT,SIG, NUMIT=THIS_MANY, DOUBLE=DOUBLE +;+ +; NAME: +; ROBUST_POLY_FIT +; +; PURPOSE: +; An outlier-resistant polynomial fit. +; +; CALLING SEQUENCE: +; COEFF = ROBUST_POLY_FIT(X,Y,NDEGREE, [ YFIT,SIG, /DOUBLE, NUMIT=] ) +; +; INPUTS: +; X = Independent variable vector, floating-point or double-precision +; Y = Dependent variable vector +; NDEGREE - integer giving degree of polynomial to fit, maximum = 6 +; OUTPUTS: +; Function result = coefficient vector, length NDEGREE+1. +; IF COEFF=0.0, NO FIT! If N_ELEMENTS(COEFF) > degree+1, the fit is poor +; (in this case the last element of COEFF=0.) +; Either floating point or double precision. +; +; OPTIONAL OUTPUT PARAMETERS: +; YFIT = Vector of calculated y's +; SIG = the "standard deviation" of the residuals +; +; OPTIONAL INPUT KEYWORD: +; /DOUBLE - If set, then force all computations to double precision. +; NUMIT - Maximum number of iterations to perform, default = 25 +; RESTRICTIONS: +; Large values of NDEGREE should be avoided. This routine works best +; when the number of points >> NDEGREE. +; +; PROCEDURE: +; For the initial estimate, the data is sorted by X and broken into +; NDEGREE+2 sets. The X,Y medians of each set are fitted to a polynomial +; via POLY_FIT. Bisquare ("Tukey's Biweight") weights are then +; calculated, using a limit of 6 outlier-resistant standard deviations. +; The fit is repeated iteratively until the robust standard deviation of +; the residuals changes by less than .03xSQRT(.5/(N-1)). +; +; PROCEDURES CALLED: +; POLY(), POLY_FIT() +; ROB_CHECKFIT() +; REVISION HISTORY +; Written, H. Freudenreich, STX, 8/90. Revised 4/91. +; 2/94 -- changed convergence criterion +; Added /DOUBLE keyword, remove POLYFITW call W. Landsman Jan 2009 +;- + +ON_ERROR,2 +COMPILE_OPT IDL2 + +EPS = 1.0E-20 +DEL = 5.0E-07 +DEGMAX= 6 + +IF N_ELEMENTS(THIS_MANY) GT 0 THEN ITMAX=THIS_MANY ELSE ITMAX=25 + +BADFIT=0 + +NPTS = N_ELEMENTS(X) +MINPTS=NDEG+1 +IF (NPTS/4*4) EQ NPTS THEN NEED2 = 1 ELSE NEED2 = 0 +N3 = 3*NPTS/4 & N1 = NPTS/4 + +; If convenient, move X and Y to their centers of gravity: +IF NDEG LT DEGMAX THEN BEGIN + X0=TOTAL(X)/NPTS & Y0=TOTAL(Y)/NPTS + U=X-X0 & V=Y-Y0 +ENDIF ELSE BEGIN + U=X & V=Y +ENDELSE + +; The initial estimate. + +; Choose an odd number of segments: +NUM_SEG = NDEG+2 +IF (NUM_SEG/2*2) EQ NUM_SEG THEN NUM_SEG =NUM_SEG+1 +MIN_PTS = NUM_SEG*3 +IF NPTS LT 10000 THEN BEGIN ;MIN_PTS THEN BEGIN +; Settle for least-squares: + LSQFIT = 1 + CC = POLY_FIT( U, V, NDEG, YFIT , DOUBLE=DOUBLE) +ENDIF ELSE BEGIN +; Break up the data into segments: + LSQFIT = 0 + Q = SORT(U) + U = U[Q] & V = V[Q] + N_PER_SEG = REPLICATE( NPTS/NUM_SEG, NUM_SEG) + +; Put the leftover points in the middle segment: + N_LEFT = NPTS - N_PER_SEG[0]*NUM_SEG + N_PER_SEG[NUM_SEG/2] = N_PER_SEG[NUM_SEG/2] + N_LEFT + R = DBLARR(NUM_SEG) & S = DBLARR(NUM_SEG) + R[0]=MEDIAN( U[0:N_PER_SEG[0]-1],/EVEN ) + S[0]=MEDIAN( V[0:N_PER_SEG[0]-1],/EVEN ) + I2 = N_PER_SEG[0]-1 + FOR I=1,NUM_SEG-1 DO BEGIN + I1 = I2 + 1 + I2 = I1 + N_PER_SEG[I] - 1 + R[I] = MEDIAN( U[I1:I2], /EVEN) & S[I] = MEDIAN( V[I1:I2],/EVEN ) + ENDFOR +; Now fit: + CC = POLY_FIT( R,S, NDEG, DOUBLE=DOUBLE ) + YFIT = POLY(U,CC) +ENDELSE + +ISTAT = ROB_CHECKFIT(V,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S) + +IF ISTAT EQ 0 THEN GOTO,AFTERFIT + +IF NGOOD LT MINPTS THEN BEGIN + IF LSQFIT EQ 0 THEN BEGIN + ; Try a least-squares: + CC = POLY_FIT( U, V, NDEG, YFIT, DOUBLE=DOUBLE ) + ISTAT = ROB_CHECKFIT(V,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S) + IF ISTAT EQ 0 THEN GOTO,AFTERFIT + NGOOD = NPTS-COUNT + ENDIF + IF NGOOD LT MINPTS THEN BEGIN + PRINT,'ROBUST_POLY_FIT: No Fit Possible!' + RETURN,0. + ENDIF +ENDIF + +; Now iterate until the solution converges: +CLOSE_ENOUGH = .03*SQRT(.5/(NPTS-1)) > DEL +DIFF= 1.0E10 +SIG_1= (100.*SIG) < 1.0E20 +NIT = 0 +WHILE( (DIFF GT CLOSE_ENOUGH) AND (NIT LT ITMAX) ) DO BEGIN + NIT=NIT+1 + SIG_2=SIG_1 + SIG_1=SIG +; We use the "obsolete" POLYFITW routine because it allows us to input weights +; rather than measure errors + g = where(W gt 0, Ng) + if Ng LT N_elements(w) then begin ;Throw out points with zero weight + u = u[g] + v = v[g] + w = w[g] + endif + CC = POLY_FIT( U, V, NDEG, YFIT, MEASURE_ERRORS = 1/W^2, DOUBLE=DOUBLE ) + ISTAT = ROB_CHECKFIT(V,YFIT,EPS,DEL, SIG,FRACDEV,NGOOD,W,S) + IF ISTAT EQ 0 THEN GOTO,AFTERFIT + IF NGOOD LT MINPTS THEN BEGIN + PRINT,'ROBUST_POLY_FIT: Questionable Fit!' + BADFIT=1 + GOTO,AFTERFIT + ENDIF + DIFF = (ABS(SIG_1-SIG)/SIG) < (ABS(SIG_2-SIG)/SIG) +ENDWHILE + +;IF NIT GE ITMAX THEN PRINT,'ROBUST_POLY_FIT: Did not converge in',ITMAX,$ +;' iterations!' + +AFTERFIT: +CC=REFORM(CC) + +IF NDEG LT DEGMAX THEN BEGIN +CASE NDEG OF + 1: CC[0] = CC[0]-CC[1]*X0 + Y0 + 2: BEGIN + CC[0] = CC[0]-CC[1]*X0+CC[2]*X0^2 + Y0 + CC[1] = CC[1]-2.*CC[2]*X0 + END + 3: BEGIN + CC[0] = CC[0]-CC[1]*X0+CC[2]*X0^2-CC[3]*X0^3 + Y0 + CC[1] = CC[1]-2.*CC[2]*X0+3.*CC[3]*X0^2 + CC[2] = CC[2]-3.*CC[3]*X0 + END + 4: BEGIN + CC[0] = CC[0]- CC[1]*X0+CC[2]*X0^2-CC[3]*X0^3+CC[4]*X0^4+ Y0 + CC[1] = CC[1]-2.*CC[2]*X0+3.*CC[3]*X0^2-4.*CC[4]*X0^3 + CC[2] = CC[2]-3.*CC[3]*X0+6.*CC[4]*X0^2 + CC[3] = CC[3]-4.*CC[4]*X0 + END + 5: BEGIN + CC[0] = CC[0]- CC[1]*X0+CC[2]*X0^2-CC[3]*X0^3+CC[4]*X0^4-CC[5]*X0^5+ Y0 + CC[1] = CC[1]-2.*CC[2]*X0+ 3.*CC[3]*X0^2- 4.*CC[4]*X0^3+5.*CC[5]*X0^4 + CC[2] = CC[2]-3.*CC[3]*X0+ 6.*CC[4]*X0^2-10.*CC[5]*X0^3 + CC[3] = CC[3]-4.*CC[4]*X0+10.*CC[5]*X0^2 + CC[4] = CC[4]-5.*CC[5]*X0 + END + ENDCASE +ENDIF + +; Calculate the fit at points X: +IF( N_PARAMS(0) GT 3 )THEN YFIT=POLY(X,CC) + +IF BADFIT EQ 1 THEN CC=[CC,0.] + +RETURN,CC +END diff --git a/modules/idl_downloads/astro/pro/robust_sigma.pro b/modules/idl_downloads/astro/pro/robust_sigma.pro new file mode 100644 index 0000000..e43ef4c --- /dev/null +++ b/modules/idl_downloads/astro/pro/robust_sigma.pro @@ -0,0 +1,73 @@ +FUNCTION ROBUST_SIGMA,Y, ZERO=REF, GOODVEC = Q +; +;+ +; NAME: +; ROBUST_SIGMA +; +; PURPOSE: +; Calculate a resistant estimate of the dispersion of a distribution. +; EXPLANATION: +; For an uncontaminated distribution, this is identical to the standard +; deviation. +; +; CALLING SEQUENCE: +; result = ROBUST_SIGMA( Y, [ /ZERO, GOODVEC = ] ) +; +; INPUT: +; Y = Vector of quantity for which the dispersion is to be calculated +; +; OPTIONAL INPUT KEYWORD: +; /ZERO - if set, the dispersion is calculated w.r.t. 0.0 rather than the +; central value of the vector. If Y is a vector of residuals, this +; should be set. +; +; OPTIONAL OUPTUT KEYWORD: +; GOODVEC = Vector of non-trimmed indices of the input vector +; OUTPUT: +; ROBUST_SIGMA returns the dispersion. In case of failure, returns +; value of -1.0 +; +; PROCEDURE: +; Use the median absolute deviation as the initial estimate, then weight +; points using Tukey's Biweight. See, for example, "Understanding Robust +; and Exploratory Data Analysis," by Hoaglin, Mosteller and Tukey, John +; Wiley & Sons, 1983, or equation 9 in Beers et al. (1990, AJ, 100, 32) +; +; REVSION HISTORY: +; H. Freudenreich, STX, 8/90 +; Replace MED() call with MEDIAN(/EVEN) W. Landsman December 2001 +; Don't count NaN values W.Landsman June 2010 +; +;- + On_error,2 + compile_opt idl2 + + EPS = 1.0E-20 + IF KEYWORD_SET(REF) THEN Y0=0. ELSE Y0 = MEDIAN(Y,/EVEN) + +; First, the median absolute deviation MAD about the median: + + MAD = MEDIAN( ABS(Y-Y0), /EVEN )/0.6745 + +; If the MAD=0, try the MEAN absolute deviation: + IF MAD LT EPS THEN MAD = MEAN( ABS(Y-Y0) )/.80 + IF MAD LT EPS THEN RETURN, 0.0 + +; Now the biweighted value: + U = (Y-Y0)/(6.*MAD) + UU = U*U + Q = WHERE(UU LE 1.0, COUNT) + IF COUNT LT 3 THEN BEGIN + PRINT,'ROBUST_SIGMA: This distribution is TOO WEIRD! Returning -1' + SIGGMA = -1. + RETURN,SIGGMA + ENDIF + + N = TOTAL(FINITE(Y),/INT) ;In case Y has NaN values ; + NUMERATOR = TOTAL( (Y[Q]-Y0)^2 * (1-UU[Q])^4 ) + DEN1 = TOTAL( (1.-UU[Q])*(1.-5.*UU[Q]) ) + SIGGMA = N*NUMERATOR/(DEN1*(DEN1-1.)) + + IF SIGGMA GT 0. THEN RETURN, SQRT(SIGGMA) ELSE RETURN, 0. + + END diff --git a/modules/idl_downloads/astro/pro/safe_correlate.pro b/modules/idl_downloads/astro/pro/safe_correlate.pro new file mode 100644 index 0000000..c44ed3a --- /dev/null +++ b/modules/idl_downloads/astro/pro/safe_correlate.pro @@ -0,0 +1,230 @@ +;function to detect type of error array input +function errtype, err, bad_err_msg +sz = size(err) + case sz[0] of + 0: errtype = 'sigma' + 1: errtype = 'sigmas' + 3: errtype = 'pdfs' + else: message,bad_err_msg + endcase +return,errtype +end + +;function to check for consistent error array input +pro vet_err, err, errtype, n, bad_err_msg + sz = size(err) + + badinput = 0 ;turn this switch on if input is bad + ;check that dimensions are good + ;if errtype eq 'sigma' -- no action needed for scalar + if errtype eq 'sigmas' and sz[1] ne n then badinput = 1 + if errtype eq 'pdfs' and (sz[1] ne n or sz[2] ne 2) then badinput = 1 + + ;print error if bad dimensions + if badinput then message,bad_err_msg +end + +;function to generate simulated data based on values and error array +function generate_data, v, err, type, n, nsim, dbl, seed + r = type eq 'pdfs' ? randomU(seed, n, nsim, double=dbl) : randomN(seed, n, nsim, double=dbl) + case type of + ;v # replicate(1,n) uses matrix multiplication to create an array where the + ;nth column is filled with v[n] + 'sigma': simdata = r*err + (v # replicate(1,nsim)) + 'sigmas': simdata = r*(err # replicate(1,nsim)) + (v # replicate(1,nsim)) + 'pdfs': begin + simdata = dbl ? dblarr(n, nsim) : fltarr(n, nsim) + for i = 0,n-1 do begin + pdfx = err[i,0,*] + pdfy = err[i,1,*] + + ;first compute the cdf from the pdf using trapezoidal integration + trapezoid_areas = 0.5*(pdfy[1:-1] + pdfy[0:-2])*(pdfx[1:-1] - pdfx[0:-2]) + f = TOTAL(trapezoid_areas,/CUMULATIVE) + f = f/f[-1] ;ensure it is normalized + + ;modify x vector have one pt centered at each trapezoidal element + pdfx = (pdfx[1:-1] + pdfx[0:-2])/2. + + ;transform uniform to input distribution via interpolation from the cdf + simdata[i,*] = INTERPOL(pdfx, f, r[i,*]) + endfor + end + endcase + return,simdata +end + +;;;;; THE MAIN FUNCTION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +function safe_correlate, x, y, xerr, yerr, nsim=nsim, seed=seed +;+ +; +; NAME: +; SAFE_CORRELATE +; +; PURPOSE: +; This function computes the probability by which the null hypothesis of +; uncorrelated data may be rejected while accounting for uncertainty in +; the data values. +; +; EXPLANATION: +; This function generates NSIM simulated X,Y datasets based on the +; provided points and their erros. These are then used to compute +; the probability that uncorrelated data could explain the arrangement +; of the points, the probability-to-exceed or PTE, using Spearman's rank +; correlation test. Each simulated dataset is assigned a probability of +; 1/NSIM of occuring. Thus, for a given dataset, the probability that the +; true data (given the uncertainties) are arranged as simulated AND +; that this particular arrangment of data can be explained without an +; underlying correlation is PTE/NSIM. These values are summed to compute +; the overall probability that the data represent an uncorrelated +; arrangement of points (in other words, the p-value or PTE for the null +; hypothesis of uncorrelated data). +; +; A tutorial on SAFE_CORRELATE is available at +; http://parkeloyd.com/output/code/safe_correlate/ +; +; CALLING SEQUENCE: +; Result = SAFE_CORRELATE(X, Y, XERR, YERR, [NSIM=1e4, SEED=SEED]) +; +; INPUTS: +; X,Y: N-element vectors of the data points. These are ignored if +; PDF input is supplied for X or Y (see below). +; +; XERR,YERR: The data point errors. These may be supplied as a scalar, +; N-element vector, 2xM array, or Nx2xM array. +; scalar: The identical Gaussian 1-sigma error for all +; points. +; N vector: The Gaussian 1-sigma error for each respective +; point. +; Nx2xM array: M points sampling the probability distribution +; function (PDF) for each data point. The values +; are contained in [N,0,*] and probability +; densities in [N,1,*]. This is useful for +; non-Gaussian errors, especially upper limits. +; +; KEYWORD PARAMETERS: +; NSIM: The number of X,Y datasets to simulate. Default = 1e4. +; SEED: Random number seed for use with RANDOMN and RANDOMU. Useful for +; ensuring reproducible results. Can either be an input value or +; a variable into which the used value will be stored. +; +; EXAMPLES: +; Data with identical errors: +; xerr = 2.0 +; yerr = 3.0 +; +; ;generate linear data with errors +; N = 10 +; x = findgen(N) + randomn(seed,N)*xerr +; y = findgen(N) + randomn(seed,N)*yerr +; +; ;plot +; ep = errorplot(x,y,replicate(xerr,N),replicate(yerr,N),'o') +; +; ;corrrelate +; print,safe_correlate(x,y,xerr,yerr) +; +; Data with differing errors, 5e3 simulations: +; ;generate nonuniform errors +; N = 10 +; xerr = randomu(seed,N) + 1.0 +; yerr = randomu(seed,N)*1.5 + 1.0 +; +; ;generate linear data with errors +; x = findgen(N) + randomn(seed,N)*xerr +; y = findgen(N) + randomn(seed,N)*yerr +; +; ;plot +; ep = errorplot(x,y,xerr,yerr,'o') +; +; ;correlate +; print,safe_correlate(x,y,xerr,yerr,nsim=5e3) +; +; Data with non-gaussian errors +; ;generate linear data with some scatter +; N = 10 +; x = findgen(N) + 5 + 2*randomn(seed,N) +; y = findgen(N) + 5 + 3*randomn(seed,N) +; +; ;assign uniform pdfs to the x data and gamma distributions to the +; ;y data (just for example, since the data were actaully generated +; ;from a Gaussian PDF) +; ;note that the PDFs do not have to be normalized +; M = 1000 ;number of points sampling pdfs +; xerr = fltarr(N,2,M) +; yerr = fltarr(N,2,M) +; t = 0.7 ;gamma distribution scale parameter +; for i = 0,N-1 do begin &$ +; xvalues = findgen(M)/(M-1) + x[i] - 0.5 &$ ;width = 1.0 +; xprobs = replicate(1.0, M) &$ +; xerr[i,0,*] = xvalues &$ +; xerr[i,1,*] = xprobs &$ +; yvalues = findgen(M)/(M-1)*y[i]*2.0 &$ +; k = y[i]/t + 1 &$ +; yprobs = yvalues^(k-1)*exp(-yvalues/t)/t^k/gamma(k) &$ +; yerr[i,0,*] = yvalues &$ +; yerr[i,1,*] = yprobs &$ +; endfor +; +; ;correlate +; print,safe_correlate(x,y,xerr,yerr) +; +; REFERENCE: +; See Numerical Recipes by Press et al. for information on the +; Spearman Rank correlation test. +; +; MODIFICATION HISTORY: +; Written by: R. O. Parke Loyd, 2014-07 +;- + +;;;;; GROOM AND VET THE INPUT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +bad_err_msg = 'Bad input shape for xerr or yerr, see code header.' + +;determine type of error array supplied (sigma, sigmas, pdfs) +xerrtype = errtype(xerr, bad_err_msg) +yerrtype = errtype(yerr, bad_err_msg) + +;check if x and y are going to be used and, if so, make sure they have the same +;length +if xerrtype eq 'pdfs' then begin + temp = size(xerr) + n = temp[1] +endif else begin + if yerrtype eq 'pdfs' then begin + temp = size(yerr) + n = temp[1] + endif else begin + n = n_elements(x) + if n ne n_elements(y) then begin + message, 'The x and y vectors must have the same number of points.' + endif + endelse +endelse + +;check that error input is good and determine its type +vet_err,xerr,xerrtype,n,bad_err_msg +vet_err,yerr,yerrtype,n,bad_err_msg + +;record whether double precision is used +dbl = isa(x,'double') or isa(y,'double') + +;set default number of simulations +if ~keyword_set(nsim) then nsim = 1e4 + +;;;;; GENERATE SIMULATED DATA ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +xsim = generate_data(x, xerr, xerrtype, n, nsim, dbl, seed) +ysim = generate_data(y, yerr, yerrtype, n, nsim, dbl, seed) + +;;;;; COMPUTE PROBABILITY TO EXCEED FOR NULL HYPOTHESIS ;;;;;;;;;;;;;;;;;;;;;;; + +pte = 0.0d +for i = 0,nsim-1 do begin + result = r_correlate(xsim[*,i], ysim[*,i]) + pte += result[1] +endfor +pte = pte/nsim + +return,pte + +end diff --git a/modules/idl_downloads/astro/pro/select_w.pro b/modules/idl_downloads/astro/pro/select_w.pro new file mode 100644 index 0000000..2497181 --- /dev/null +++ b/modules/idl_downloads/astro/pro/select_w.pro @@ -0,0 +1,138 @@ +PRO select_w_event, event +; +;This procedure is the event handler for the CW_BGROUP widget below +COMMON select_w, val, exclusive + +WIDGET_CONTROL, event.id, GET_VALUE = value + +if exclusive then begin + val = event.value + widget_control, event.top,/DESTROY + return +endif + +done = ((size(value,/tname) EQ 'STRING') && (value EQ 'DONE')) + +if done then begin + good = where( val GE 0, nsel ) + if (nsel GT 0) THEN val = val[good] + widget_control, event.top,/DESTROY + return +endif + +; Get the selections +if (event.select EQ 1) then val = [val,event.value] $ + else val = val[ where( val NE event.value) ] + + + +END + +PRO select_w, items, iselected, comments, command_line, only_one, $ + Count = count, GROUP_LEADER=GROUP, selectin = selectin, columns = columns, $ + y_scroll_size = y_scroll_size +;+ +; NAME: +; SELECT_W +; PURPOSE: +; Create a non-exclusive widget menu of items +; EXPLANATION: +; More than one item may be selected or 'de-selected'. +; +; CALLING SEQUENCE: +; SELECT_W, items ,iselected, [ comments, command_line, only_one, +; SELECTIN = , COLUMNS=, Y_SCROLL_SIZE= ] +; +; INPUTS: +; items - string array giving list of items that can be selected. +; +; OPTIONAL INPUTS: +; comments - string array of comments (same number of elements as items) +; for each item in array selections. Will be displayed as a +; tooltip when passing the cursor over the button for that item. +; Should have the same number of elements as items; otherwise +; will be ignored (and no tooltips will be displayed). +; +; command_line - optional command line to be placed at the bottom +; of the screen. It is usually used to specify what the +; user is selecting. +; only_one - integer flag. If set to 1 then the user can only select +; one item. The routine returns immediately after the first +; selection is made. +; columns - number of columns (default = 8) +; y_scroll_size - size of GUI in device coordinates for scrolling large lists. +; OPTIONAL KEYWORD INPUT +; SELECTIN - vector of items to be pre-selected upon input (not used for +; only_one option) +; +; OUTPUT: +; iselected - list of indices in selections giving the selected +; items, in the order they were selected. +; +; OPTIONAL OUTPUT KEYWORD: +; COUNT - Integer scalar giving the number of items selected +; +; MODIFICATION HISTORY: +; Written, K. Venkatakrishna & W. Landsman, Hughes/STX January, 1992 +; Widgets made MODAL. M. Greason, Hughes STX, 15 July 1992. +; Changed handling of MODAL keyword for V5.0 W.Thompson September 1997 +; Added selectin keyword D. Lindler 01/12/99 +; Added Columns, y_scroll_size keyword inputs, D. Lindler 6/20/2013 +; Use CW_BGROUP instead of obsolete XMENU, implement comments parameter +; as tooltips. W. Landsman Aug 2013 +; Restore SELECTIN capability W. Landsman Aug 2013 +; Kluge for Unix systems when Y_SCROLL_SIZE set Nov 2013 +;- +; + common select_w, val, exclusive + + if N_elements(only_one) EQ 0 then only_one = 0 + if N_params() LT 5 then exclusive = 0 else exclusive = only_one + if N_elements(columns) eq 0 then columns = 8 + + if N_params() LT 4 then command_line = $ +' Select by pressing the left mouse button once; To de-select press twice; finally QUIT' + + scroll = N_elements(y_scroll_size) NE 0 + MODAL = N_ELEMENTS(GROUP) GE 1 + base = WIDGET_BASE( TITLE = command_line, /COLUMN, MODAL=MODAL, $ + GROUP_LEADER=GROUP) +; On windows, IDL knows what X_scroll_size to set to get the specified number +; of columns. On Unix we need a kluge to estimate the required X_SCROLL_SIZE + if (!VERSION.OS_FAMILY EQ 'unix') && keyword_set(y_scroll_size) then $ + x_scroll_size = columns*90 + + if only_one then $ + bgroup = cw_bgroup(base,items, COLUMN=columns, /EXCLUSIVE, $ + y_scroll_size=y_scroll_size, ids = id, UNAME='BGROUP', $ + x_scroll_size=x_scroll_size) $ + else begin + donebut = WIDGET_BUTTON( base, VALUE = 'DONE', UVALUE= -1) + if N_elements(selectin) GT 0 then begin + preselect = bytarr(N_elements(items)) + preselect[selectin] = 1b + val = selectin + endif else val=-1 + bgroup = cw_bgroup(base,items, COLUMN=columns, $ + /NONEXCLUSIVE,y_scroll_size=y_scroll_size, ids= id, $ + X_SCROLL_SIZE=x_scroll_size, UNAME='BGROUP', $ + set_value = preselect) + endelse + +; Realize the widgets: + WIDGET_CONTROL, base, /REALIZE + +;In Unix one gets an error if trying to display a Tooltip of zero length + lencomm = strlen(comments) + if N_elements(comments) EQ N_elements(items) then $ + for i= 0, N_elements(comments)-1 do $ + if lencomm[i] GT 0 then widget_control, id[i], ToolTip = comments[i] + +; Hand off to the XMANAGER, i.e.,event-handler,: + XMANAGER, 'select_w', base, GROUP_LEADER = GROUP + if val[0] NE -1 then iselected = val + count = N_elements( iselected) + + return + end + diff --git a/modules/idl_downloads/astro/pro/sigma_filter.pro b/modules/idl_downloads/astro/pro/sigma_filter.pro new file mode 100644 index 0000000..9cc2b60 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sigma_filter.pro @@ -0,0 +1,88 @@ +function sigma_filter, image, box_width, N_SIGMA=Nsigma, ALL_PIXELS=all, $ + ITERATE=iterate, MONITOR=monitor, $ + KEEP_OUTLIERS=keep, RADIUS=radius, $ + N_CHANGE=nchange, VARIANCE_IMAGE=imvar, DEVIATION_IMAGE=imdev +;+ +; NAME: +; SIGMA_FILTER +; PURPOSE: +; Replace pixels more than a specified pixels deviant from its neighbors +; EXPLANATION: +; Computes the mean and standard deviation of pixels in a box centered at +; each pixel of the image, but excluding the center pixel. If the center +; pixel value exceeds some # of standard deviations from the mean, it is +; replaced by the mean in box. Note option to process pixels on the edges. +; CALLING SEQUENCE: +; Result = sigma_filter( image, box_width, N_sigma=(#), /ALL,/MON ) +; INPUTS: +; image = 2-D image (matrix) +; box_width = width of square filter box, in # pixels (default = 3) +; KEYWORDS: +; N_sigma = # standard deviations to define outliers, floating point, +; recommend > 2, default = 3. For gaussian statistics: +; N_sigma = 1 smooths 35% of pixels, 2 = 5%, 3 = 1%. +; RADIUS = alternative to specify box radius, so box_width = 2*radius+1. +; /ALL_PIXELS causes computation to include edges of image, +; /KEEP causes opposite effect: pixels with values outside of specified +; deviation are not changed, pixels within deviation are smoothed. +; /ITERATE causes sigma_filter to be applied recursively (max = 20 times) +; until no more pixels change (only allowed when N_sigma >= 2). +; /MONITOR prints information about % pixels replaced. +; Optional Outputs: +; N_CHANGE = # of pixels changed (replaced with neighborhood mean). +; VARIANCE = image of pixel neighborhood variances * (N_sigma)^2, +; DEVIATION = image of pixel deviations from neighborhood means, squared. +; CALLS: +; function filter_image( ) +; PROCEDURE: +; Compute mean over moving box-cars using smooth, subtract center values, +; compute variance using smooth on deviations from mean, +; check where pixel deviation from mean is within variance of box, +; replace those pixels in smoothed image (mean) with orignal values, +; return the resulting partial mean image. +; MODIFICATION HISTORY: +; Written, 1991, Frank Varosi and Dan Gezari NASA/GSFC +; F.V.1992, added optional keywords /ITER,/MON,VAR=,DEV=,N_CHANGE=. +; Converted to IDL V5.0 W. Landsman September 1997 +;- + if N_elements( radius ) EQ 1 then box_width = 2*radius+1 else begin + if N_elements( box_width ) NE 1 then box_width=3 + box_width = 2*(fix( box_width )/2) + 1 ;make sure width is odd. + endelse + + if (box_width LT 3) then return,image + bw2 = box_width^2 + + mean=( filter_image( image,SMO=box_width,ALL=all )*bw2 - image )/(bw2-1) + + if N_elements( Nsigma ) NE 1 then Nsigma=3 + if (Nsigma LE 0) then return, mean + + imdev = (image - mean)^2 + fact = float( Nsigma^2 )/(bw2-2) + imvar = fact*( filter_image( imdev,SMO=box_width,ALL=all )*bw2 - imdev ) + + if keyword_set( keep ) then wok = where( imdev GE imvar, nok ) $ + else wok = where( imdev LT imvar, nok ) + + npix = N_elements( image ) + nchange = npix - nok + if keyword_set( monitor ) then $ + print, nchange*100./npix, Nsigma, $ + FORM="(F6.2,' % of pixels replaced, N_sigma=',F3.1)" + + if (nok EQ npix) then return,image + if (nok GT 0) then mean[wok] = image[wok] + + if keyword_set( iterate ) AND (Nsigma GE 2) then begin + iterate = iterate+1 + if (iterate GT 20) then begin + iterate = 1 + return,mean + endif + return, sigma_filter( mean, box_width, N_SIGMA=Nsigma, ALL=all,$ + KEEP=keep, ITER=iterate, MONIT=monitor ) + endif + +return, mean +end diff --git a/modules/idl_downloads/astro/pro/sigrange.pro b/modules/idl_downloads/astro/pro/sigrange.pro new file mode 100644 index 0000000..8d36123 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sigrange.pro @@ -0,0 +1,139 @@ + FUNCTION SIGRANGE,ARRAY,FRACTION=FRACTION,MISSING=MISSING,RANGE=RANGE +;+ +; NAME: +; SIGRANGE() +; PURPOSE: +; Selects the most significant data range in an image. +; EXPLANATION: +; Selects out the most significant range in the data to be used in +; displaying images. The histogram of ARRAY is used to select the most +; significant range. Useful for scaling an image display. +; CALLING SEQUENCE: +; OUTPUT = SIGRANGE( ARRAY ) +; INPUTS: +; ARRAY = Array to take most significant range of. +; OPTIONAL INPUTS: +; None. +; OUTPUTS: +; The function returns an array where values above and below the +; selected range are set equal to the maximum and minimum of the +; range respectively. +; OPTIONAL INPUT KEYWORDS: +; FRACTION = Fraction of data to consider most significant. +; Defaults to 0.99 +; MISSING = Value used to flag missing points. Data points with this +; value are not considered or changed. +; OPTIONAL OUTPUT KEYWORD +; RANGE = 2 element vector, giving the range (minimum and maxmimum) +; used +; +; NOTES: +; If the image array contains more than 10,000 points then SIGRANGE() +; uses random indexing of a subset of the points to determine the range +; (for speed). Thus identical calls to SIGRANGE() might not yield +; identical results (although they should be very close). +; RESTRICTIONS: +; ARRAY must have more than two points. Fraction must be greater than 0 +; and less than 1. +; +; SIGRANGE was originally part of the SERTS image display package. +; Other routines from this package are available at +; +; http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/image/ +; +; Note that this version of SIGRANGE does not include the non-standard +; system variables used in the SERTS package. +; REVISION HISTORY: +; Version 1, William Thompson, GSFC, 12 May 1993. +; Incorporated into CDS library. +; Version 2, William Thompson, GSFC, 25 May 1993. +; Changed call to HISTOGRAM to be compatible with OpenVMS/ALPHA +; Version 3, CDP, RAL, Add RANGE keyword. 16-Apr-96 +; Version 4, William Thompson, GSFC, 17 April 1996 +; Corrected some problems when range is too high. +; Version 5, 13-Jan-1998, William Thompson, GSFC +; Use random numbers to improve statistics when only using a +; fraction of the array. +; Version 6, 06-Mar-1998, William Thompson, GSFC +; Change default to 0.99 +;- +; + IF N_ELEMENTS(FRACTION) NE 1 THEN FRACTION = 0.99 + IF N_ELEMENTS(ARRAY) LE 2 THEN BEGIN + MESSAGE, /CONTINUE, 'Not enough points to form histogram' + RETURN, ARRAY + END ELSE IF (FRACTION LE 0) OR (FRACTION GE 1) THEN BEGIN + MESSAGE, /CONTINUE, 'Fraction must be GT 0 and LT 1' + RETURN, ARRAY + ENDIF +; +; To speed up the process, work on a reduced version of ARRAY. +; + IF N_ELEMENTS(ARRAY) LT 10000 THEN ATEMP0 = ARRAY ELSE BEGIN + NN = 1000 > (N_ELEMENTS(ARRAY) / 25) < 100000 + ATEMP0 = ARRAY[N_ELEMENTS(ARRAY)*RANDOMU(SEED,NN)] + ENDELSE +; +; Get the total range of the data, excluding any missing points. +; + IF N_ELEMENTS(MISSING) EQ 1 THEN BEGIN + W = WHERE(ATEMP0 NE MISSING, COUNT) + IF COUNT GT 0 THEN ATEMP0 = ATEMP0(W) + ENDIF + N_TOTAL = N_ELEMENTS(ATEMP0) + AMAX = 1.*MAX(ATEMP0) + AMIN = 1.*MIN(ATEMP0) + IF AMIN EQ AMAX THEN GOTO, EXIT_POINT +; +; Set up some initial parameters for the reiteration. +; + ATEMP = ATEMP0 + DELTA = 0 +; +; Form the histogram, and calculate an array expressing the fraction of points +; that fall within or below the given bin. +; +FIND_RANGE: + LAST_DELTA = DELTA + X = AMIN + FINDGEN(1001) * (AMAX - AMIN) / 1000. + H = HISTOGRAM(LONG((ATEMP-AMIN)*1000./(AMAX - AMIN))) + FOR I = 1,N_ELEMENTS(H)-1 DO H[I] = H[I] + H[I-1] + H = H / FLOAT(N_TOTAL) +; +; Estimate the endpoints corresponding to the specified range, and calculate +; the values at these endpoints. Limit the array to be within these values. +; + IMIN = (MIN( WHERE( H GT ((1. - FRACTION) / 2.) )) - 1) > 0 + IMAX = MIN( WHERE( H GT ((1. + FRACTION) / 2.) )) + IF IMAX LT 0 THEN IMAX = 1000 + AMIN = X[IMIN] + AMAX = X[IMAX] +; +; If the calculated range is zero, then use 2% of the full range of the data. +; + IF AMAX EQ AMIN THEN BEGIN + BMAX = MAX(ATEMP0, MIN=BMIN) + AMAX = MAX(ATEMP0(WHERE(ATEMP0 LE (AMAX + 0.01*(BMAX-BMIN))))) + AMIN = MIN(ATEMP0(WHERE(ATEMP0 GE (AMIN - 0.01*(BMAX-BMIN))))) + ENDIF +; +; If the range calculated has changed by more than 5% from the last iteration, +; the reiterate. +; + ATEMP = AMIN > ATEMP0 < AMAX + DELTA = AMAX - AMIN + RATIO = (DELTA - LAST_DELTA) / (DELTA + LAST_DELTA) + IF ABS(RATIO) GT 0.05 THEN GOTO, FIND_RANGE +; +; If a missing pixel flag value was passed, then reset those points to the +; flag value. Return the adjusted array. +; +EXIT_POINT: + ATEMP = AMIN > ARRAY < AMAX + IF N_ELEMENTS(MISSING) EQ 1 THEN BEGIN + WW = WHERE(ARRAY EQ MISSING,N_MISSING) + IF N_MISSING GT 0 THEN ATEMP[WW] = MISSING + ENDIF + RANGE = [AMIN,AMAX] + RETURN, ATEMP + END diff --git a/modules/idl_downloads/astro/pro/sip_eval.pro b/modules/idl_downloads/astro/pro/sip_eval.pro new file mode 100644 index 0000000..e7ec74e --- /dev/null +++ b/modules/idl_downloads/astro/pro/sip_eval.pro @@ -0,0 +1,46 @@ +function sip_eval, xy +;+ +; NAME: +; SIP_EVAL +; PURPOSE: +; Compute distorted coordinates given SIP (simple imaging polynomial) +; coefficients. +; EXPLANATION: +; See http://fits.gsfc.nasa.gov/registry/sip.html for the SIP convention +; +; The coefficients are passed via common block. This is because this +; routine is called by the intrinisc BROYDEN() function in AD2XY, and +; common blocks are the only way to pass parameters to the user supplied +; function in BROYDEN(). +; CALLING SEQUENCE: +; res = SIP_EVAL(xy) +; INPUTS: +; xy - 2 elements vector giving the undistorted X,Y position +; OUTPUTS: +; res - 2 element vector giving the distorted position +; COMMON BLOCKS: +; common broyden_coeff,xcoeff,ycoeff +; +; XCOEFF, YCOEFF are both nxn arrays giving the SIP coefficient for an +; n x n polynomial. +; REVISION HISTORY: +; Written W. Landsman Dec 2013 +;- +compile_opt idl2,hidden +common broyden_coeff,xcoeff,ycoeff + +dim = size(xcoeff,/dimen) +n = dim[0] +xp = xy[0] +yp = xy[1] + +for i= 0,n-1 do begin + for j=0,n-1 DO begin + if xcoeff[i,j] NE 0.0 then xp += xcoeff[i,j]*xy[0]^i*xy[1]^j + if ycoeff[i,j] NE 0.0 then yp += ycoeff[i,j]*xy[0]^i*xy[1]^j + endfor +endfor + +return, [xp,yp] + +end diff --git a/modules/idl_downloads/astro/pro/sixlin.pro b/modules/idl_downloads/astro/pro/sixlin.pro new file mode 100644 index 0000000..24fe689 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sixlin.pro @@ -0,0 +1,156 @@ +pro sixlin,xx,yy,a,siga,b,sigb,weight=weight +;+ +; NAME: +; SIXLIN +; PURPOSE: +; Compute linear regression coefficients by six different methods. +; EXPLANATION: +; Adapted from the FORTRAN program (Rev. 1.1) supplied by Isobe, +; Feigelson, Akritas, and Babu Ap. J. Vol. 364, p. 104 (1990). +; Suggested when there is no understanding about the nature of the +; scatter about a linear relation, and NOT when the errors in the +; variable are calculable. +; +; CALLING SEQUENCE: +; SIXLIN, xx, yy, a, siga, b, sigb, [WEIGHT = ] +; +; INPUTS: +; XX - vector of X values +; YY - vector of Y values, same number of elements as XX +; +; OUTPUTS: +; A - Vector of 6 Y intercept coefficients +; SIGA - Vector of standard deviations of 6 Y intercepts +; B - Vector of 6 slope coefficients +; SIGB - Vector of standard deviations of slope coefficients +; +; The output variables are computed using linear regression for each of +; the following 6 cases: +; (0) Ordinary Least Squares (OLS) Y vs. X (c.f. linfit.pro) +; (1) Ordinary Least Squares X vs. Y +; (2) Ordinary Least Squares Bisector +; (3) Orthogonal Reduced Major Axis +; (4) Reduced Major-Axis +; (5) Mean ordinary Least Squares +; +; OPTIONAL INPUT KEYWORD: +; WEIGHT - vector of weights, same number of elements as XX and YY +; For 1 sigma Gausssian errors, the weights are 1/sigma^2 but +; the weight vector can be more general. Default is no +; weighting. +; NOTES: +; Isobe et al. make the following recommendations +; +; (1) If the different linear regression methods yield similar results +; then quoting OLS(Y|X) is probably the most familiar. +; +; (2) If the linear relation is to be used to predict Y vs. X then +; OLS(Y|X) should be used. +; +; (3) If the goal is to determine the functional relationship between +; X and Y then the OLS bisector is recommended. +; +; REVISION HISTORY: +; Written Wayne Landsman February, 1991 +; Corrected sigma calculations February, 1992 +; Added WEIGHT keyword J. Moustakas February 2007 +;- + compile_opt idl2 + On_error, 2 ;Return to Caller + + if N_params() LT 5 then begin + print,'Syntax - SIXLIN, xx, yy, a, siga, b, sigb, {WEIGHT =]' + return + endif + + b = dblarr(6) & siga = b & sigb =b + x = double(xx) ;Keep input X and Y vectors unmodified + y = double(yy) + rn = N_elements(x) + + if rn LT 2 then $ + message,'Input X and Y vectors must contain at least 2 data points' + + if rn NE N_elements(y) then $ + message,'Input X and Y vectors must contain equal number of data points' + + if (n_elements(weight) eq 0L) then weight = replicate(1.0,rn) else begin + if (rn ne n_elements(weight)) then $ + message,'Input X and WEIGHT vectors must contain equal number of data points' + endelse + +; Compute averages and sums + + sumw = total(weight) + + xavg = total( weight * x)/sumw + yavg = total( weight * y)/sumw + x = x - xavg + y = y - yavg + sxx = total( weight * x^2) + syy = total( weight * y^2) + sxy = total( weight * x*y) + if sxy EQ 0. then $ + message,'SXY is zero, SIXLIN is terminated' + if sxy LT 0. then sign = -1.0 else sign = 1.0 + +; Compute the slope coefficients + + b[0] = sxy / sxx + b[1] = syy / sxy + b[2] = (b[0]*b[1] - 1.D + sqrt((1.D + b[0]^2)*(1.D +b[1]^2)))/(b[0] + b[1] ) + b[3] = 0.5 * ( b[1] - 1.D/b[0] + sign*sqrt(4.0D + (b[1]-1.0/b[0])^2)) + b[4] = sign*sqrt( b[0]*b[1] ) + b[5] = 0.5 * ( b[0] + b[1] ) + +; Compute Intercept Coefficients + + a = yavg - b*xavg + +; Prepare for computation of variances + + gam1 = b[2] / ( (b[0] + b[1]) * $ + sqrt( (1.D + b[0]^2)*(1.D + b[1]^2)) ) + gam2 = b[3] / (sqrt( 4.D*b[0]^2 + ( b[0]*b[1] - 1.D)^2)) + sum1 = total( weight * ( x*( y - b[0]*x ) )^2) + sum2 = total( weight * ( y*( y - b[1]*x ) )^2) + sum3 = total( weight * x * y * ( y - b[0]*x) * (y - b[1]*x ) ) + cov = sum3 / ( b[0]*sxx^2 ) + +; Compute variances of the slope coefficients + + sigb[0] = sum1 / sxx^2 + sigb[1] = sum2 / sxy^2 + sigb[2] = (gam1^2) * ( ( (1.D + b[1]^2) ^2 )*sigb[0] + $ + 2.D*(1.D + b[0]^2) * (1.D + b[1]^2)*cov + $ + ( (1.D + b[0]^2)^2)*sigb[1] ) + sigb[3] = (gam2^2)*( sigb[0]/b[0]^2 + 2.D*cov + b[0]^2*sigb[1] ) + sigb[4] = 0.25*(b[1]*sigb[1]/b[1] + $ + 2.D*cov + b[0]*sigb[1]/b[1] ) + sigb[5] = 0.25*(sigb[0] + 2.D*cov + sigb[1] ) + +; Compute variances of the intercept coefficients + + siga[0] = total( weight * ( ( y - b[0]*x) * (1.D - sumw*xavg*x/sxx) )^2 ) + siga[1] = total( weight * ( ( y - b[1]*x) * (1.D - sumw*xavg*y/sxy) )^2 ) + siga[2] = total( weight * ( (x * (y - b[0]*x) * (1.D + b[1]^2) / sxx + $ + y * (y - b[1]*x) * (1.D + b[0]^2) / sxy)* $ + gam1 * xavg * sumw - y + b[2] * x) ^ 2) + siga[3] = total( weight * ( ( x * ( y - b[0]*x) / sxx + $ + y * ( y - b[1]*x) * b[0]^2/ sxy) * gam2 * $ + xavg * sumw / sqrt( b[0]^2) - y + b[3]*x) ^ 2 ) + siga[4] = total( weight * ( ( x * ( y - b[0] * x) * sqrt( b[1] / b[0] ) / sxx + $ + y * ( y - b[1] * x) * sqrt( b[0] / b[1] ) / sxy) * $ + 0.5 * sumw * xavg - y + b[4] * x)^2 ) + + siga[5] = total( weight * ( (x * ( y - b[0] * x) / sxx + $ + y * ( y - b[1] * x) / sxy)* $ + 0.5 * sumw * xavg - y + b[5]*x )^2 ) + +; Convert variances to standard deviation + + sigb = sqrt(sigb) + siga = sqrt(siga)/sumw + + return + end diff --git a/modules/idl_downloads/astro/pro/sixty.pro b/modules/idl_downloads/astro/pro/sixty.pro new file mode 100644 index 0000000..126136c --- /dev/null +++ b/modules/idl_downloads/astro/pro/sixty.pro @@ -0,0 +1,66 @@ + FUNCTION sixty,scalar, Trailsign = trailsign +;+ +; NAME: +; SIXTY() +; PURPOSE: +; Converts a decimal number to sexagesimal. +; EXPLANATION: +; Reverse of the TEN() function. +; +; CALLING SEQUENCE: +; X = SIXTY( SCALAR, [ /TrailSign ] ) +; +; INPUTS: +; SCALAR -- Decimal quantity. +; OUTPUTS: +; Function value returned = real vector of three elements, +; sexagesimal equivalent of input decimal quantity. Double +; precision if the input is double, otherwise floating point. +; By default, a negative number is signified by making the first non-zero +; element of the output vection negative, but this can be modified with +; the /TrailSign keyword. +; +; OPTIONAL INPUT KEYWORD: +; /TrailSign - By default, SIXTY() returns a negative sign in the first +; nonzero element. If /TrailSign is set, then SIXTY() will return +; always return a negative sign in the first element, even if it is +; zero +; PROCEDURE: +; Mostly involves checking arguments and setting the sign. +; +; EXAMPLE: +; If x = -0.345d then sixty(x) = [0.0, -20.0, 42.0] +; and sixty(x,/trail) = [-0.0, 20.0, 42.0] +; MODIFICATION HISTORY: +; Written by R. S. Hill, STX, 19-OCT-87 +; Output changed to single precision. RSH, STX, 1/26/88 +; Accept single element vector W. Landsman Sep. 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added /TrailSign keyword, preserve data type +; B. Stecklum/ W. Landsman March 2006 +;- + + if N_elements(scalar) NE 1 then begin + message,'ERROR - First parameter must contain 1 element',/CON + return,replicate(100.0e0,3) + endif + + ss=abs(3600.0d0*scalar) + mm=abs(60.0d0*scalar) + dd=abs(scalar) + if size(scalar,/tname) EQ 'DOUBLE' then result = dblarr(3) else $ + result=fltarr(3) + result[0]= fix(dd) + result[1]= fix(mm-60.0d0*result[0]) + result[2]= ss - 3600.d0*result[0] - 60.0d0*result[1] + + if scalar[0] lt 0.0d0 then begin + if keyword_set(trailsign) then result[0] = -result[0] else begin + if result[0] ne 0 then result[0] = -result[0] else $ + if result[1] ne 0 then result[1] = -result[1] else $ + result[2] = -result[2] + endelse + endif + + return,result + end diff --git a/modules/idl_downloads/astro/pro/sky.pro b/modules/idl_downloads/astro/pro/sky.pro new file mode 100644 index 0000000..317d758 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sky.pro @@ -0,0 +1,185 @@ +pro sky,image,skymode,skysig, SILENT=silent, CIRCLERAD = circlerad, $ + _EXTRA = _EXTRA, NAN = nan, MEANBACK = meanback +;+ +; NAME: +; SKY +; PURPOSE: +; Determine the sky level in an image +; EXPLANATION: +; Approximately 10000 uniformly spaced pixels are selected for the +; computation. Adapted from the DAOPHOT routine of the same name. +; +; The sky is computed either by using the procedure mmm.pro (default) +; or by sigma clipping (if /MEANBACK is set) +; +; CALLING SEQUENCE: +; SKY, image, [ skymode, skysig ,/SILENT, /MEANBACK, /NAN, CIRCLERAD= ] +; +; Keywords available when MEANBACK is not set (passed to mmm.pro): +; /DEBUG, HIGHBAD=, /INTEGER, MAXITER=. READNOISE= +; Keywords available when /MEANBACK is set: +; CLIPSIG=, /DOUBLE, CONVERGE_NUM=, MAXITER=, /VERBOSE +; INPUTS: +; IMAGE - One or two dimensional array +; +; OPTIONAL OUTPUT ARRAYS: +; SKYMODE - Scalar, giving the mode of the sky pixel values of the +; array IMAGE, as determined by the procedures MMM or MEANCLIP +; SKYSIG - Scalar, giving standard deviation of sky brightness. If it +; was not possible to derive a mode then SKYSIG is set to -1 +; +; INPUT KEYWORD PARAMETERS: +; CIRCLERAD - Use this keyword to have SKY only select pixels within +; specified pixel radius of the center of the image. If +; CIRCLERAD =1, then the radius is set equal to half the image +; width. Can only be used with square images. +; /MEANBACK - if set, then the background is computed using the 3 sigma +; clipped mean (using meanclip.pro) rather than using the mode +; computed with mmm.pro. This keyword is useful for the Poisson +; count regime or where contamination is known to be minimal. +; /NAN - This keyword must be set to ignore NaN values when computing +; the sky. +; /SILENT - If this keyword is supplied and non-zero, then SKY will not +; display the sky value and sigma at the terminal +; +; The _EXTRA facility can is used to pass optional keywords to the programs +; that actually perform the sky computation: either mmm.pro +; (default) or meanclip.pro (if /MEANBACK) is set. The following +; keywords are available with the mmm.pro (default) setting + +; HIGHBAD - scalar value of the (lowest) "bad" pixel level (e.g. cosmic +; rays or saturated pixels) If not supplied, then there is +; assumed to be no high bad pixels. +; READNOISE - Scalar giving the read noise (or minimum noise for any +; pixel). Normally, MMM determines the (robust) median by +; averaging the central 20% of the sky values. In some cases +; where the noise is low, and pixel values are quantized a +; larger fraction may be needed. By supplying the optional +; read noise parameter, MMM is better able to adjust the +; fraction of pixels used to determine the median. +; /INTEGER - Set this keyword if the input SKY image only contains +; discrete integer values. This keyword is only needed if the +; SKY image is of type float or double precision, but contains +; only discrete integer values. +; +; If the /MEANBACK keyword is set then the following keywords are available +; +; CLIPSIG: Number of sigma at which to clip. Default=3 +; MAXITER: Ceiling on number of clipping iterations. Default=5 +; CONVERGE_NUM: If the proportion of rejected pixels is less +; than this fraction, the iterations stop. Default=0.02, i.e., +; iteration stops if fewer than 2% of pixels excluded. +; /DOUBLE - if set then perform all computations in double precision. +; Otherwise double precision is used only if the input +; data is double +; +; PROCEDURE: +; A grid of points, not exceeding 10000 in number, is extracted +; from the srray. The mode of these pixel values is determined +; by the procedure mmm.pro or meanclip.pro. In a 2-d array the grid is +; staggered in each row to avoid emphasizing possible bad columns +; +; PROCEDURE CALLS: +; MEANCLIP, MMM, DIST_CIRCLE +; REVISION HISTORY: +; Written, W. Landsman STX Co. September, 1987 +; Changed INDGEN to LINDGEN January, 1994 +; Fixed display of # of points used March, 1994 +; Stagger beginning pixel in each row, added NSKY, READNOISE, HIGHBAD +; W. Landsman June 2004 +; Adjustments for unbiased sampling W. Landsman June 2004 +; Added /NAN keyword, put back CIRCLERAD keyword W. Landsman July 2004 +; Added MEANBACK keyword, _EXTRA kewyord ,preserve data type in +; calculations W. Landsman November 2005 +; Fix problem for very large images by requiring at least 2 pixels to +; be sampled per row. March 2007 W. Landsman +; Avoid possible out of bounds if /NAN set W. Landsman Jan 2008 +; Use TOTAL(/INTEGER) June 2009 +; Fix occasional out of bounds problem when /NAN set W. Landsman Jul 2013 +;- + On_error,2 ;Return to caller + compile_opt idl2 + + if N_params() eq 0 then begin + print,'Syntax - sky, image, [ skymode, skysig , HIGHBAD= ' + print, ' READNOISE = , /NAN, CIRCLERAD = , /SILENT ]' + return + endif + + checkbad = (N_elements(highbad) GT 0) || keyword_set(circlerad) || $ + keyword_set(nan) + s = size(image) + nrow = s[1] + if s[0] EQ 1 then ncol = 1 else begin + if s[0] NE 2 then message, $ + 'ERROR - Input array (first parameter) must be 1 or 2 dimensional' + ncol = s[2] + endelse + if keyword_set(circlerad) then if ncol ne nrow then message, $ + 'ERROR - The CIRCLERAD keyword only applies to a 2-d square array' + + if checkbad then begin + mask = replicate(1b, nrow, ncol) + if N_elements(highbad) GT 0 then mask = mask and (image LT highbad) + if keyword_set(nan) then mask = mask and finite(image) + if keyword_set(circlerad) then begin + if circlerad EQ 1 then rad = nrow/2 else rad = long(circlerad) + dist_circle,drad, nrow + mask = mask and (temporary(drad) LT rad) + endif + npts = total(mask,/integer) + endif else npts = N_elements(image) + +; Use ~10000 data points or at least 2 points per row + maxsky = 2*npts/(nrow-1) > 10000 ;Maximum # of pixels to be used in sky calculation +; Maintain the same data type as the input image Nov 2005 + istep = npts/maxsky +1 + skyvec = make_array(maxsky+200,type=size(image,/type)) + nstep = (nrow/istep) + + jj = 0 + index0 = istep*lindgen(nstep) + if nstep GT 1 then begin + i0 = (nrow-1 - max(index0) - istep)/2 > 0 ;Adjust margin for symmetry + index0 = index0 + i0 + endif + +; The beginning index in each row is staggered to avoid emphasizing possible +; bad columns + + for i=0, Ncol-1 do begin + index = index0 + (i mod istep) + row = image[*,i] + if checkbad then begin + g = where(mask[*,i],ng) + case ng of + 0: goto, Done + Nrow: + else: row = row[g] + endcase + endif else ng = nrow + imax = value_locate( index, ng-1) > 0 + ix = index[0:imax] < (ng-1) + skyvec[jj] = row[ix] + jj = jj + imax + 1 + DONE: + + endfor + skyvec = skyvec[0:jj-1] + + + if keyword_set(meanback) then begin + meanclip, skyvec, skymode, skysig,sub=sub, _EXTRA = _extra + nsky = N_elements(sub) + endif else $ + MMM, skyvec, skymode, skysig, _EXTRA = _extra, nsky = nsky + + skymode = float(skymode) & skysig = float(skysig) + if ~keyword_set(SILENT) then begin + print,'Number of points used to find sky = ',nsky + print,'Approximate sky value for this frame = ',skymode + print,'Standard deviation of sky brightness = ',skysig + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/skyadj_cube.pro b/modules/idl_downloads/astro/pro/skyadj_cube.pro new file mode 100644 index 0000000..2a15f37 --- /dev/null +++ b/modules/idl_downloads/astro/pro/skyadj_cube.pro @@ -0,0 +1,343 @@ +;+ +; NAME: +; SKYADJ_CUBE +; +; PURPOSE: +; Sky adjust the planes of a datacube. +; +; EXPLANATION: +; When removing cosmic rays from a set of images, it is desirable that +; all images have the same sky level. This procedure (called by +; CR_REJECT) removes the sky from each image in a data cube. +; +; CALLING SEQUENCE: +; SKYADJ_CUBE,Datacube,Skyvals,Totsky +; +; MODIFIED ARGUMENT: +; Datacube: 3-D array with one image of same field in each plane. +; Returned with sky in each plane adjusted to zero. +; +; OUTPUT ARGUMENTS: +; Skyvals: Array of sky values used on each plane of datacube. +; For a scalar sky, this parameter is a vector +; containing the sky value for each image plane. For a +; vector sky, this parameter is a 2-D array where each +; line corresponds to one image plane. +; +; INPUT KEYWORD PARAMETERS: +; +; REGION - [X0,X1,Y0,Y1] to restrict area used for computation +; of sky. Default is 0.1*Xdim, 0.9*Xdim, 0.1*Ydim, +; 0.9*Ydim. If INPUT_MASK is specified, the two +; specs are combined, i.e., the intersection of the +; areas is used. +; VERBOSE - Flag. If set, print information on skyvals. +; NOEDIT - Flag. If set, return sky values without changing +; datacube. +; XMEDSKY - Flag. If set, return vector sky as a function of X. +; SELECT - Array of subscripts of planes of the cube to process. +; (Default=all) +; EXTRAPR - Applies only in XMEDSKY mode. +; Subregion to use for polynomial extrapolation of sky +; vector into portions excluded by REGION parameter. +; (Default=first and last 10% of pixels; set to zero +; to defeat extrapolation) +; EDEGREE - Applies only in XMEDSKY mode. +; Degree of polynomial for extrapolation (Default=1) +; INPUT_MASK - Cube of flags corresponding to data cube. If used, +; the sky computation is restricted to the smallest +; contiguous rectangle containing all the pixels flagged +; valid (with 1 rather than 0). +; +; PROCEDURE: +; Uses astronomy library "sky" routine for scalar sky and +; column-by-column median for vector sky. +; +; MODIFICATION HISTORY: +; 10 Jul. 1997 - Written. R. S. Hill, Hughes STX +; 20 Oct. 1997 - 1-D sky option. RSH +; 7 Aug. 1998 - SELECT keyword. RSH +; 6 Oct. 1998 - Extrapolation. RSH +; 7 Oct. 1998 - INPUT_MASK added. RSH +; 21 Oct. 1998 - Fallback to 3-sigma clipped mean if mode fails. RSH +; 22 Mar. 2000 - Combine mask with region rather having mask +; override region. Improve comments. RSH +; 16 June 2000 - On_error and message used. Square brackets for array +; subscripts. EXTRAP included in this file. +; WBL & RSH, 16 June 2000 +;- +pro EXTRAP, Deg, X, Y, Y2, LIMS=lims +;+ +; NAME: +; EXTRAP +; +; PURPOSE: +; This procedure fills in the ends of a one-dimensional array from +; interior portions using polynomial extrapolation. +; +; CATEGORY: +; Image processing +; +; CALLING SEQUENCE: +; EXTRAP, Deg, X, Y, Y2 +; +; INPUT POSITIONAL PARAMETERS: +; Deg: Degree of polynomial +; X: Independent variable +; Y: Dependent variable +; +; KEYWORD PARAMETERS: +; LIMS: 3-element array giving range of X to be used to fit +; polynomial and starting point where extrapolation is +; to be substituted; if not given, you click on a plot; +; order of elements is [xmin, xmax, xstart]; if LIMS is +; specified, then program is silent +; +; OUTPUT POSITIONAL PARAMETERS: +; Y2: Dependent variable with extrapolated portion filled in +; +; SIDE EFFECTS: +; May pop a window for selecting range. +; +; MODIFICATION HISTORY: +; Written by RSH, RITSS, 14 Aug 98 +; Spiffed up for library. RSH, 6 Oct 98 +;- +IF n_params(0) LT 1 THEN BEGIN + print, 'CALLING SEQUENCE: extrap, deg, x, y, y2' + print, 'KEYWORD PARAMETER: lims' + RETALL +ENDIF +IF ~keyword_set(lims) THEN BEGIN + verbose = 1b + savedev = strtrim(strupcase(!D.name),2) + set_plot, 'X' + window, /free + plot,x,y + print, 'Click on fit limit 1' + cursor, xx1, yy1, /down, /data + print, 'Click on fit limit 2' + cursor, xx2, yy2, /down, /data + print, 'Click starting point of extrapolation' + cursor, xx3, yy3, /down, /data + wdelete, !D.window + IF savedev NE 'X' THEN set_plot, savedev +ENDIF ELSE BEGIN + verbose = 0b + xx1 = lims[0] + xx2 = lims[1] + xx3 = lims[2] +ENDELSE +IF verbose THEN print,'Extrapolating from region ',xx1, ' to ', xx2 +wmin = min(where(x ge min([xx1,xx2]))) +wmax = max(where(x le max([xx1,xx2]))) +coeff = poly_fit(x[wmin:wmax],y[wmin:wmax], deg, yfit, /double) +xhalf = 0.5*(min(x)+max(x)) +up = 1b +if xx3 lt xhalf then up = 0b +ypoly = poly(x, coeff) +y2 = y +IF up THEN BEGIN + if verbose then print, 'Extrapolating above x = ',xx3 + y2[wstart] = ypoly[wstart:*] +ENDIF ELSE BEGIN + if verbose then print, 'Extrapolating below x = ',xx3 + y2[0] = ypoly[0:wstart] +ENDELSE +RETURN +END + +PRO SKYADJ_CUBE,Datacube,Skyvals,Totsky, XMEDSKY=xmedsky, $ + REGION=region,VERBOSE=verbose,NOEDIT=noedit, $ + SELECT=select,EXTRAPR=extrapr,EDEGREE=edegree, $ + INPUT_MASK=input_mask + + +xmed = keyword_set(xmedsky) +verbose=keyword_set(verbose) +ipm = keyword_set(input_mask) +szc = size(datacube) +xdim = szc[1] +ydim = szc[2] +zdim = szc[3] + +; +; Default region is between 10% and 90% of range in each +; coordinate +IF n_elements(region) LT 1 THEN BEGIN + xmarg = xdim/10 + ymarg = ydim/10 + region = [xmarg,xdim-xmarg,ymarg,ydim-ymarg] +ENDIF + +; +; Arrays to hold min and max good pixels according to input +; mask +xmin = intarr(zdim) +xmax = xmin +ymax = xmin +ymin = xmin + +; +; Process input mask if any +IF ipm THEN BEGIN + ; + ; Check size + szm = size(input_mask) + w_dim_ne = where(szc[0:3] NE szm[0:3], cw_dim_ne) + IF cw_dim_ne GT 0 THEN BEGIN + print, 'SKYADJ_CUBE: INPUT_MASK has different dims from ' $ + + 'DATACUBE' + print, 'Executing RETALL.' + retall + ENDIF + ; + ; Go through planes of mask one by one + FOR i=0,zdim-1 DO BEGIN + ; + ; Integrate over Y + xtot = total(input_mask[*,*,i],2) + ; + ; Integrate over X + ytot = total(input_mask[*,*,i],1) + ; + ; Non-zero in each dimension + wxt = where(xtot GT 0,cwxt) + wyt = where(ytot GT 0,cwyt) + ; + ; If whole image masked out something wrong + IF cwxt LE 0 OR cwyt LE 0 THEN BEGIN + print, 'SKYADJ_CUBE: INPUT_MASK invalid' + print, 'Executing RETALL' + retall + ENDIF + ; + ; Find smallest rectangle containing all the good pixels + xmin1 = min(wxt,max=xmax1) + ymin1 = min(wyt,max=ymax1) + xmin[i] = xmin1 + ymin[i] = ymin1 + xmax[i] = xmax1 + ymax[i] = ymax1 + ENDFOR +ENDIF ELSE BEGIN + ; + ; No input mask: set limits to whole image + xmin[*] = 0 + ymin[*] = 0 + xmax[*] = xdim-1 + ymax[*] = ydim-1 +ENDELSE + +IF n_elements(edegree) LT 1 THEN edegree=1 +IF n_elements(extrapr) LT 1 THEN extrapr=0.1 +do_extrap=keyword_set(extrapr) + +IF n_elements(select) LT 1 THEN select=indgen(zdim) +nsel = n_elements(select) + +; +; Initialize sky arrays +IF xmed THEN BEGIN + skyvals = fltarr(xdim,zdim) - 32768. +ENDIF ELSE BEGIN + skyvals = fltarr(zdim) - 32768. +ENDELSE +skyplane = fltarr(xdim,ydim) + +; +; Go through all the planes that are in the selected set +; (probably usually all of them) +FOR i=0,nsel-1 DO BEGIN + sel = select[i] + plane = datacube[*,*,sel] + ; + ; Final clip region + clip_par = [xmin[sel]>region[0],xmax[sel]region[2],ymax[sel] a = spec_dir('test','dat') +; +; is equivalent to the commands +; IDL> cd, current=cdir +; IDL> a = cdir + delim + 'test.dat' +; +; where delim is the OS-dependent separator +; METHOD: +; SPEC_DIR() decomposes the file name using FDECOMP, and appends the +; default directory (obtained from the FILE_EXPAND_PATH) if necessary. +; +; SPEC_DIR() does not check whether the constructed file name actually +; exists. +; PROCEDURES CALLED: +; FDECOMP, EXPAND_TILDE() +; REVISION HISTORY: +; Written W. Landsman STX July, 1987 +; Expand Unix tilde if necessary W. Landsman September 1997 +; Assume since V5.5, use FILE_EXPAND_PATH, remove VMS support +; W. Landsman September 2006 +;- + On_error,2 ;Return to user + compile_opt idl2 + fdecomp,filename,disk,dir,name,ext + if N_elements(extension) GT 0 then $ + if (ext EQ '') then ext = extension + + dir = disk+ dir + if !VERSION.OS_FAMILY EQ 'unix' then $ + if strpos(dir,'~') GE 0 then dir = expand_tilde(dir) + + dir = file_expand_path(disk+dir) + return, dir + path_sep() + name + '.' + ext + end diff --git a/modules/idl_downloads/astro/pro/sphdist.pro b/modules/idl_downloads/astro/pro/sphdist.pro new file mode 100644 index 0000000..2e7cdfa --- /dev/null +++ b/modules/idl_downloads/astro/pro/sphdist.pro @@ -0,0 +1,88 @@ +;------------------------------------------------------------- +;+ +; NAME: +; SPHDIST +; PURPOSE: +; Angular distance between points on a sphere. +; CALLING SEQUENCE: +; d = sphdist(long1, lat1, long2, lat2) +; INPUTS: +; long1 = longitude of point 1, scalar or vector +; lat1 = latitude of point 1, scalar or vector +; long2 = longitude of point 2, scalar or vector +; lat2 = latitude of point 2, scalar or vector +; +; OPTIONAL KEYWORD INPUT PARAMETERS: +; /DEGREES - means angles are in degrees, else radians. +; OUTPUTS: +; d = angular distance between points (in radians unless /DEGREES +; is set.) +; PROCEDURES CALLED: +; RECPOL, POLREC +; NOTES: +; (1) The procedure GCIRC is similar to SPHDIST(), but may be more +; suitable for astronomical applications. +; +; (2) If long1,lat1 are scalars, and long2,lat2 are vectors, then +; SPHDIST returns a vector giving the distance of each element of +; long2,lat2 to long1,lat1. Similarly, if long1,lat1 are vectors, +; and long2, lat2 are scalars, then SPHDIST returns a vector giving +; giving the distance of each element of long1,lat1 to to long2,lat2. +; If both long1,lat1 and long2,lat2 are vectors then SPHDIST returns +; vector giving the distance of each element of long1,lat1 to the +; corresponding element of long2, lat2. If the input vectors are +; not of equal length, then excess elements of the longer ones will +; be ignored. +; MODIFICATION HISTORY: +; R. Sterner, 5 Feb, 1991 +; R. Sterner, 26 Feb, 1991 --- Renamed from sphere_dist.pro +; +; Copyright (C) 1991, Johns Hopkins University/Applied Physics Laboratory +; This software may be used, copied, or redistributed as long as it is not +; sold and this copyright notice is reproduced on each copy made. This +; routine is provided as is without any express or implied warranties +; whatsoever. Other limitations apply as described in the file disclaimer.txt. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------------- + + function sphdist, long1, lat1, long2, lat2, $ + help=hlp, degrees=degrees + + if (n_params(0) lt 4) or keyword_set(hlp) then begin + print,' Angular distance between points on a sphere.' + print,' d = sphdist(long1, lat1, long2, lat2)' + print,' long1 = longitude of point 1. in' + print,' lat1 = latitude of point 1. in' + print,' long2 = longitude of point 2. in' + print,' lat2 = latitude of point 2. in' + print,' d = angular distance between points. out' + print,' Keywords:' + print,' /DEGREES means angles are in degrees, else radians.' + print,' Notes: points 1 and 2 may be arrays.' + return, -1 + endif + + cf = 1.0 + if keyword_set(degrees) then cf = !radeg + + ;--- Convert both points to rectangular coordinates. --- + polrec, 1.0, lat1/cf, rxy, z1 + polrec, rxy, long1/cf, x1, y1 + polrec, 1.0, lat2/cf, rxy, z2 + polrec, rxy, long2/cf, x2, y2 + + ;--- Compute vector dot product for both points. --- + cs = x1*x2 + y1*y2 + z1*z2 + + ;--- Compute the vector cross product for both points. --- + xc = y1*z2 - z1*y2 + yc = z1*x2 - x1*z2 + zc = x1*y2 - y1*x2 + sn = sqrt(xc*xc + yc*yc + zc*zc) + + ;--- Convert to polar. ------ + recpol, cs, sn, r, a + return, cf*a + + end diff --git a/modules/idl_downloads/astro/pro/srcor.pro b/modules/idl_downloads/astro/pro/srcor.pro new file mode 100644 index 0000000..cb3d362 --- /dev/null +++ b/modules/idl_downloads/astro/pro/srcor.pro @@ -0,0 +1,257 @@ +PRO srcor,x1in,y1in,x2in,y2in,dcr,ind1,ind2,option=option,magnitude=magnitude,$ + spherical=spherical,silent=silent,count = count +;+ +; NAME: +; SRCOR +; PURPOSE: +; Correlate the source positions found on two lists. +; +; EXPLANATION: +; Source matching is done by finding sources within a specified radius. +; If you have position errors available and wish to match by significance +; level, then try match_xy.pro in the TARA library +; (http://www.astro.psu.edu/xray/docs/TARA/) +; +; CALLING SEQUENCE: +; srcor,x1in,ylin,x2in,y2in,dcr,ind1,ind2, +; [MAGNITUDE=,SPHERICAL=,COUNT=,/SILENT] +; INPUTS: +; x1in,y1in - First set of x and y coordinates. The program +; marches through this list element by element, +; looking in list 2 for the closest match. So, the program +; will run faster if this is the shorter of the two lists. +; Unless you use the option or magnitude keyword, there is +; nothing to guarantee unique matches. +; x2in,y2in - Second set of x and y coordinates. This list is +; searched in its entirety every time one element of list 1 +; is processed. +; dcr - Critical radius outside which correlations are rejected; +; but see 'option' below. +; OPTIONAL KEYWORD INPUT: +; option - Changes behavior of program and description of output +; lists slightly, as follows: +; OPTION=0 or left out +; Same as older versions of SRCOR. The closest match from list2 +; is found for each element of list 1, but if the distance is +; greater than DCR, the match is thrown out. Thus the index +; of that element within list 1 will not appear in the IND1 output +; array. +; OPTION=1 +; Forces the output mapping to be one-to-one. OPTION=0 results, +; in general, in a many-to-one mapping from list 1 to list 2. +; Under OPTION=1, a further processing step is performed to +; keep only the minimum-distance match, whenever an entry from +; list 1 appears more than once in the initial mapping. +; OPTION=2 +; Same as OPTION=1, except the critical distance parameter DCR +; is ignored. I.e., the closest object is retrieved from list 2 +; for each object in list 1 WITHOUT a critical-radius criterion, +; then the clean-up of duplicates is done as under OPTION=1. +; magnitude +; An array of stellar magnitudes corresponding to x1in and y1in. +; If this is supplied, then the brightest star from list 1 +; within the selected distance of the star in list 2 is taken. +; The option keyword is ignored in this case. +; spherical +; If SPHERICAL=1, it is assumed that the input arrays are in +; celestial coordinates (RA and Dec), with x1in and x2in in +; decimal hours and y1in and y2in in decimal degrees. If +; SPHERICAL=2 then it is assumed that the input arrays are in +; longitude and latitude with x1in,x2in,y1in,y2in in decimal +; degrees. In both cases, the critial radius dcr is in +; *arcseconds*. Calculations of spherical distances are made +; with the gcirc program. +; OUTPUTS: +; ind1 - index of matched stars in first list, set to -1 if no matches +; found +; ind2 - index of matched stars in second list +; OPTIONAL OUTPUT KEYWORD: +; Count - integer giving number of matches returned +; PROCEDURES USED: +; GCIRC, REMOVE +; REVISON HISTORY: +; Adapted from UIT procedure J.Wm.Parker, SwRI 29 July 1997 +; Improve speed for spherical searches, added /SILENT keyword +; W. Landsman Mar 2009 +; Avoid error when no matches found with /SPHERICAL O. Trottier June 2009 +; Added output Count keyword W.L June 2009 +; Adjust right ascension for cosine angle W.L. December 2009 +; Return as soon as no matches found W.L. December 2009 +; Use some V6.0 notation W.L. February 2011 +; Fix problem when /Spherical and Option =2 set, and sources separated +; by more han 180 degrees. W.L. March 2011 +; +;- +; + ON_Error,2 ; Return if error (incl. non-info message) + compile_opt idl2 +;;; +; If not enough parameters, then print out the syntax. +; +IF N_params() lt 7 THEN BEGIN + print,'SRCOR calling sequence: ' + print,'srcor,x1in,y1in,x2in,y2in,dcr,ind1,ind2 [,option={0, 1, or 2}] $' + print,' [,magnitude=mag_list_1, COUNT=count, spherical={1 or 2}, /SILENT]' + RETURN +ENDIF + count = 0 + +;;; +; Keywords. +; +IF ~keyword_set(option) THEN option=0 +IF (option lt 0) or (option gt 2) THEN MESSAGE,'Invalid option code.' + +SphereFlag = keyword_set(Spherical) + +;;; +; Store the input variables into internal arrays that we can manipulate and +; modify. +; +x1 = x1in +y1 = y1in +x2 = x2in +y2 = y2in + +;;; +; If the Spherical keyword is set, then convert the input values (degrees +; and maybe hours) into radians, so GCIRC doesn't have to make this calculation +; each time it is called in the FOR loop. Also convert the critical radius +; (which is in arcsec, so convert by 3600.) to radians +; +if SphereFlag then begin + dcr2 = dcr + XScale = Spherical EQ 1 ? 15.0 : 1.0 + d2r = !DPI/180.0d0 + x1 = x1 * (XScale * d2r) + y1 = y1 * d2r + x2 = x2 * (XScale * d2r) + y2 = y2 * d2r + cosy2 = sin(y2) + dcr2 = dcr2 * (d2r / 3600.) + radcr2 = dcr2/cos(y2) ;Adjust RA for declination +endif else dcr2=dcr^2 + + +;;; +; Set up some other variables. +; + n1 = N_elements(x1) + n2 = N_elements(x2) + if ~keyword_set(silent) then begin + message,/info,'Option code = '+strtrim(option,2) + message,/info,strtrim(n1,2)+' sources in list 1' + message,/info,strtrim(n2,2)+' sources in list 2' + endif + +;;; +; The main loop. Step through each index of list 1, look for matches in 2. +; + nmch = 0L + ind1 = lonarr(n1)-1 & ind2 = ind1 + + if SphereFlag then begin + if option EQ 2 then begin ;Closest source, no critical distance +;For speed we find the maximum value of cos(d) where d is the arc distance +;This avoids having to calculate the arc cosine. Test modified Mar 2011 + cosy2 = cos(y2) + siny2 = sin(y2) + FOR i=0L,n1-1 DO BEGIN + d2 = siny2*sin(y1[i]) + cosy2*cos(y1[i])*cos(x1[i]-x2) + dmch = max(d2,m) ;Uncommented 29-May-2009 + ind1[nmch] = i + ind2[nmch] = m + nmch++ + ENDFOR + + endif else begin ;Closest source within critical distance + +;For speed we first find sources within a square of the size of the critical +;distance. Exact distances are then computed for sources within the square. + FOR i=0L,n1-1 DO BEGIN + xx = x1[i] & yy = y1[i] + + g = where(( x2 GE (xx-radcr2)) and (x2 LE (xx+radcr2)) and $ + (y2 GE (yy-dcr2)) and (y2 LE (yy + dcr2)), Ng) + + if Ng GT 0 then begin + gcirc,0,x2[g],y2[g],xx,yy,d2 + dmch = min(d2,mg) + if dmch LE dcr2 then begin + ind1[nmch] = i + ind2[nmch] = g[mg] + nmch++ + endif + endif + ENDFOR + endelse + endif else begin + FOR i=0L,n1-1 DO BEGIN + + d2=(x1[i]-x2)^2+(y1[i]-y2)^2 + dmch=min(d2,m) + IF (option eq 2) || (dmch le dcr2) THEN BEGIN + ind1[nmch] = i + ind2[nmch] = m + nmch++ + ENDIF + ENDFOR + endelse + +if ~keyword_set(silent) then message,/info,strtrim(nmch,2)+' matches found.' + +count = nmch +if nmch GT 0 then begin + ind1 = ind1[0:nmch-1] + ind2 = ind2[0:nmch-1] +endif else begin + ind1 = -1 & ind2 = -1 + return +endelse +;;; +; Modify the matches depending on input options. +; +use_mag = (n_elements(magnitude) ge 1) +IF (option eq 0) && (~use_mag) THEN RETURN +if ~keyword_set(silent) then begin +IF use_mag THEN BEGIN + message,/info,'Cleaning up output list using magnitudes.' +ENDIF ELSE BEGIN + + IF option eq 1 then message,/info,'Cleaning up output list (option = 1).' + IF option eq 2 then message,/info,'Cleaning up output list (option = 2).' +ENDELSE +endif + +FOR i=0L,max(ind2) DO BEGIN + csave = n_elements(ind2) + ww = where(ind2 eq i,count) ; All but one of the list in WW must + ; eventually be removed. + IF count gt 1 THEN BEGIN + IF use_mag THEN BEGIN + dummy = min(magnitude[ind1[ww]],m) + ENDIF ELSE BEGIN + xx=x2[i] & yy=y2[i] + if SphereFlag then gcirc,0,xx,yy,x1[ind1[ww]],y1[ind1[ww]],d2 else $ + d2=(xx-x1[ind1[ww]])^2+(yy-y1[ind1[ww]])^2 + IF n_elements(d2) ne count THEN MESSAGE,'Logic error 1' + dummy = min(d2,m) + ENDELSE + remove,m,ww ; Delete the minimum element + ; from the deletion list itself. + + remove,ww,ind1,ind2 ; Now delete the deletion list from + ; the original index arrays. + IF n_elements(ind2) ne (csave-count+1) THEN MESSAGE,'Logic error 2' + IF n_elements(ind1) ne (csave-count+1) THEN MESSAGE,'Logic error 3' + IF n_elements(ind2) ne n_elements(ind1) THEN MESSAGE,'Logic error 4' + ENDIF +ENDFOR + + count = N_elements(ind1) + if ~keyword_set(silent) then $ + message,/info,strtrim(n_elements(ind1),2)+' final matches found' + +; +RETURN +end diff --git a/modules/idl_downloads/astro/pro/st_diskread.pro b/modules/idl_downloads/astro/pro/st_diskread.pro new file mode 100644 index 0000000..61d1171 --- /dev/null +++ b/modules/idl_downloads/astro/pro/st_diskread.pro @@ -0,0 +1,781 @@ +pro st_diskread, infiles, DUMP = dump +;+ +; NAME: +; ST_DISKREAD +; +; PURPOSE: +; Read HST FITS formatted disk files and reconstruct GEIS (STSDAS) files. +; +; CALLING SEQUENCE: +; ST_DISKREAD, infiles +; +; INPUT PARAMETER: +; infiles - (scalar string) input disk files to be converted into GEIS +; files. Wildcards are allowed. +; FILES CREATED: +; +; GEIS files: +; The GEIS file is reconstructed from each input Fits file. The +; output filename is composed from the rootname of the observation +; and the appropriate GEIS file extension (i.e. d0h/d, c0h/d, etc.). +; Tables: +; If input file is a fits table, the output is an SDAS table. +; +; EXAMPLES: +; a) Reconstruct the GEIS file for disk FITS file z29i020ct*.fits. +; st_diskread,'z29i020ct*.fits' +; +; PROCEDURES CALLED: +; ST_DISK_DATA, ST_DISK_TABLE, ST_DISK_GEIS +; FTSIZE,SXPAR(),TAB_CREATE, TAB_WRITE +; HISTORY: +; 10/17/94 JKF/ACC - taken from ST_TAPEREAD. +; 11/02/94 JKF/ACC - added /block on open statement to +; handle files with 512 bytes/record. +; 12/6/95 JKF/ACC - include new jitter files...replaces +; st_read_jitter.pro. +; 03/5/96 W. Landsman, change FORRD to READU, remove Version 1 +; type codes, add message facility +; 05/20/00 W. Landsman, remove obsolete !ERR calls, new calling +; sequence to FTINFO +; 09/2006 W. Landsman, remove obsolete keywords to OPEN +; +;**************************************************************************** +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + On_error,2 + + if n_params() lt 1 then begin + print,'Syntax - ST_DISKREAD, infiles' + return + endif + !ERROR = 0 + if not keyword_set(DUMP) then dump = 0 +; +; Search for names of input disk FITS files. +; + file_list = file_search(infiles,count=count) + if count le 0 then $ + message,' No files found: '+ infiles $ + else message,/INF, $ + 'Number of files to process: ' + strtrim(count,2) +; +; Loop on files +; + for file = 0,count-1 do begin + openr,unit,file_list[file],/get_lun +; +; read data header and data +; + st_disk_data,unit,h,data,fname,gcount,dimen,opsize,nbytes,itype + if !ERROR NE 0 then return +; +; read optional table extension +; + st_disk_table,unit,htab,tab,table_available + if !ERROR NE 0 then return +; +; Finished reading the input dataset at this point. Now process the information +; and create the output datasets. +; +; GEIS file or trailer text file +; + + if sxpar(h,'naxis') gt 0 then begin + st_disk_geis,h,data,htab,tab,table_available, $ + fname,gcount,dimen,opsize,nbytes,itype ;GEIS file + if !ERROR NE 0 then return + if dump gt 0 then $ + print,format='(t5,i4,t15,a)',file+1,strlowcase(fname) + end else begin ;either a text trailer or jitter table + + outname = strtrim(sxpar(htab,'extname'),2) + if outname eq strtrim(0,2) then $ + outname= strtrim(sxpar(h,'filename')) + + if table_available then begin + + outname = strtrim(sxpar(htab,'extname')) + s=size(tab) & nl=s[2] + name=strtrim(sxpar(htab,'extname')) ;file name + ; + ; What type of table? + ; - trailer file - ascii table + ; - jitter data - sdas table + ; + if strpos(strlowcase(name),'jit') eq -1 then begin; text trailer + ; + ; Special case NAME: PODPS/IRAF uses j7 as special + ; character, so that a file with z0j7<...> will be + ; created as z0.<...> ( . is substituted for j7 ). + ; To avoid: Check file name for ., if found replace + ; with j7. + ; + invalid_char = strpos(name,'.') + if invalid_char lt 5 then begin + message,' Warning: Invalid filename found: '+name ,/cont + name = strmid(name,0,invalid_char) + 'j7' + $ + strmid(name,invalid_char+1,strlen(name)) + message,' Filename will be changed to: '+ name,/cont + end + + openw,ounit,name,/get_lun + for i = 0,nl-1 do printf,ounit,strtrim(string(tab[*,i])) + free_lun,ounit + if dump gt 0 then $ + print,format='(t5,i4,t15,a)',file+1,strlowcase(name) + end else begin ; jitter table + ; + ; Convert from FITS to SDAS table + ; + ftsize,htab,tab,ncols,nrows,tfields + tab_create,tcb,otab,tfields,nrows,ncols/2 + ftinfo,htab,ft_str + fname = ft_str.ttype + for j= 0, tfields-1 do begin + val=ftget(ft_str,tab,j+1) ; extract column + tab_put,strtrim(fname[i]),val,tcb,otab + end + tab_write,outname,tcb,otab,htab + if dump gt 0 then $ + print,format='(t5,i4,t15,a,a)',file+1, $ + strlowcase(outname)," jitter table " + end + end else $ + if dump gt 0 then $ + print,format='(t5,i4,t15,a,a)',file+1, $ + strlowcase(outname)," (No data found) + end + free_lun,unit + endfor +return +end +; +pro st_disk_data,unit,h,data,name,gcount,dimen,opsize,nbytes,itype +;************************************************************************** +;+ +; NAME: +; ST_DISK_DATA +; +; PURPOSE: +; Routine to read next header and data array from an HST FITS disk file. +; This is a subroutine of ST_DISKREAD and not intended for stand alone +; use. +; +;CALLING SEQUENCE: +; st_disk_data,unit,h,data,name,gcount,dimen,opsize,nbytes,itype +; +;INPUTS: +; unit - logical unit number. +; +;OUTPUTS: +; h - FITS header +; data - data array +; name - file name +; gcount - number of groups +; dimen - data dimensions +; opsize - parameter blocks size +; nbytes - bytes per data group +; itype - idl data type +; +; Notes: +; This is not a standalone program. Use ST_DISKREAD. +; +; PROCEDURES CALLED: +; GETTOK(), SXPAR() +; HISTORY: +; 10/17/94 JKF/ACC - taken from ST_TAPE_DATA. +; +;*************************************************************************** +;- + On_error,2 +; +; read fits header +; + h = strarr(500) + nhead = 0 + while 1 do begin + buf=bytarr(2880) + readu,unit,buf + + for i=0,35 do begin + st = string(buf[i*80:i*80+79]) + h[nhead]=st + if strtrim(strmid(st,0,8)) eq 'END' then goto,fini + nhead=nhead+1 + endfor + endwhile +fini: +; +; get keywords from header needed to read data +; + bitpix = sxpar(h,'bitpix', Count = N_bitpix) + + if N_bitpix EQ 0 then begin + message,/CON,'ERROR - BITPIX missing from FITS header' + return + endif + + naxis = sxpar(h,'naxis', Count = N_naxis) + if N_naxis EQ 0 then begin + message,/CON,'ERROR- NAXIS missing from FITS header' + return + endif + if naxis eq 0 then return ;NO data to read +; +; get scale factors +; + bscale = sxpar(h,'bscale', Count = N_bscale) + if N_bscale EQ 0 then bscale=1. + bzero = sxpar(h,'bzero', Count = N_bzero) + if N_bzero EQ 0 then bzero=0. + iraf_bp = sxpar(h,'IRAF-B/P') ;Geis file bitpix + if iraf_bp ne 64 then begin + bscale = float(bscale) + bzero = float(bzero) + end else begin + bscale = double(bscale) + bzero = double(bzero) + end +; +; determine output bitpix +; + obitpix = abs(bitpix) + if (bscale ne 1.0) or (bzero ne 0.0) then obitpix = 32 + if iraf_bp eq 64 then obitpix = 64 +; +; get dimensions +; + dimen = lonarr(naxis) + npoints = 1L + for i=0,naxis-1 do begin + dimen[i]=sxpar(h,'naxis'+strtrim(i+1,2)) + if dimen[i] le 0 then begin + message,/CON,'ERROR- Invalid data dimension' + return + endif + npoints = npoints*dimen[i] + endfor +; +; determine group count +; + gcount = sxpar(h,'sdasmgnu')>1 + if gcount gt 1 then begin + naxis = naxis-1 + dimen = dimen[0:naxis-1] + if n_elements(dimen) eq 1 then dimen = lonarr(1)+dimen + npoints = npoints/gcount + endif +; +; determine orignal psize in bytes +; + opsize = sxpar(h,'opsize', Count = N_opsize) + if N_opsize EQ 0 then opsize = 0 + opsize = opsize/8 +; +; set up data array +; + case bitpix of + 8: data = make_array(dimen=dimen,/byte) + 16: data = make_array(dimen=dimen,/int) + 32: data = make_array(dimen=dimen,/long) + 64: data = make_array(dimen=dimen,/double) + -32: data = make_array(dimen=dimen,/float) + -64: data = make_array(dimen=dimen,/double) + + else: begin + message,/CON,'ERROR - Invalid BITPIX value' + return + end + endcase +; +; determine file name +; + ; + ; Keyword IRAFNAME has been changed to FILENAME in new style + ; PODPS keywords (JHB 11-2-91) + ; + name = sxpar(h,'FILENAME', Count = N_filename) + if N_filename EQ 0 then begin + name = sxpar(h,'IRAFNAME', Count = N_irafname) + if N_irafname EQ 0 then $ + message,' Keyword(IRAFNAME) missing from data header'+ $ + '...ABORTING ' + endif + + ; + ; Special case NAME: PODPS/IRAF uses j7 as special + ; character, so that a file with z0j7<...> will be + ; created as z0.<...> ( . is substituted for j7 ). + ; To avoid: Check file name for ., if found replace + ; with j7. + ; Special case code added by JKF/ACC 12/30/91 + ; + invalid_char = strpos(name,'.') + if invalid_char lt 5 then begin + message,' Warning: Invalid filename found: '+name ,/cont + name = strmid(name,0,invalid_char) + 'j7' + $ + strmid(name,invalid_char+1,strlen(name)) + message,' Filename will be changed to: '+ name,/cont + end + + name = strtrim(gettok(name,'.') +'.'+ gettok(name,'.'),2) + pos = strpos(name,'_cvt') ;take out _cvt + if pos gt 4 then name = strmid(name,0,pos) + $ + strmid(name,pos+4,strlen(name)-pos-4) + dname = name + strput,dname,'d',strlen(name)-1 ;change last character to a d +; +; determine number of blocks in the file +; + bytes_per_point = obitpix/8 + in_bytes_per_point = abs(bitpix)/8 + nbytes = bytes_per_point * npoints + nblocks = ((nbytes + opsize)*gcount + 511)/512 +; +; open output data file +; + close,1 + openw,1,dname +; +; create output assoc variable +; + if (bzero eq 0) and (bscale eq 1) and (bitpix gt 0) then begin + s = size(data) & itype = s[s[0]+1] ; idl data type + tmp_data = make_array( dimen=dimen, type= itype ) + + end else begin + + if obitpix eq 32 then begin + tmp_data = make_array(dimen=dimen,/float) + itype = 4 + end else begin + tmp_data = make_array(dimen=dimen,/double) + itype = 5 + end + end +; +; read data +; + + pointer = 2880 ;byte pointer in current 2880 byte disk record + + for group=0,gcount-1 do begin ;loop on groups + pos = 0 ;current pointer in data array + while pos lt npoints do begin + if pointer ge 2880 then begin + readu,unit,buf + case bitpix of + 16: byteorder,buf,/NtoHS + 32: byteorder,buf,/NtoHL + -32: byteorder,buf,/XDRTOF + -64: byteorder,buf,/XDRTOD + ELSE: + endcase + pointer = 0 + endif + words_needed = (npoints-pos) + bytes_needed = words_needed*in_bytes_per_point + bytes_to_take = (2880-pointer) < bytes_needed + words_to_take = bytes_to_take/in_bytes_per_point + + case bitpix of + 8: data[pos]=buf[pointer:bytes_to_take-1] + 16: data[pos]=fix(buf,pointer,words_to_take) + 32: data[pos]=long(buf,pointer,words_to_take) + 64: data[pos]=double(buf,pointer,words_to_take) + -32: data[pos]=float(buf,pointer,words_to_take) ;IEEE + -64: data[pos]=double(buf,pointer,words_to_take) ;IEEE + endcase + pos = pos + words_to_take + pointer = pointer + bytes_to_take + endwhile +; +; write data +; + if (bscale ne 1.0) or (bzero ne 0.0) then begin + + out_rec = assoc(1,tmp_data,(nbytes+opsize)*group) + out_rec[0] = data * bscale + bzero + end else begin + out_rec = assoc(1,tmp_data,(nbytes+opsize)*group) + out_rec[0] = data + end + endfor +return +end +; +pro st_disk_table,unit,h,data,table_available +;+ +;NAME: +; ST_DISK_TABLE +; +; PURPOSE: +; Routine to read FITS table from an ST fits on disk. +; This is a subroutine of st_diskread and not intended for stand alone +; use. +; +; CALLING SEQUENCE: +; st_disk_table,unit,h,data +; +; INPUTS PARAMETER: +; unit - disk unit number +; +; +; OUTPUTS: +; h - FITS header +; data - table array +; +; NOTES: +; This is not a standalone program. Use ST_DISKREAD. +; +; HISTORY: +; 10/17/94 JKF/ACC - taken from ST_TAPE_TABLE. +; 12/7/95 JKF/ACC - handle tables for jitter data. +; +;**************************************************************************** +;- +; +; read fits header +; + h = strarr(500) + nhead = 0 + while 1 do begin + + buf = bytarr(2880) + +on_ioerror, no_table_found + readu,unit,buf + + for i=0,35 do begin + st = string(buf[i*80:i*80+79]) + h[nhead]=st + if strtrim(strmid(st,0,8)) eq 'END' then goto,fini + nhead=nhead+1 + endfor + endwhile +fini: + +; +; get keywords from header needed to read data +; + bitpix = sxpar(h,'bitpix', Count = N_bitpix) + if N_bitpix EQ 0 then begin + message,/CON,'ERROR- BITPIX missing from FITS header' + return + endif + if bitpix ne 8 then begin + message,/CON,'Invalid BITPIX for FITS table' + return + endif + naxis = sxpar(h,'naxis', Count = N_naxis) + if N_naxis EQ 0 then begin + message,/CON,'ERROR- NAXIS missing from FITS table header' + return + endif + if naxis ne 2 then begin + message,/CON,'Invalid NAXIS for FITS table ' + return + endif + + dimen = lonarr(2) + npoints = 1L + for i=0,1 do begin + dimen[i]=sxpar(h,'naxis'+strtrim(i+1,2)) + if dimen[i] le 0 then begin + if dump gt 1 then message,/cont,"No data found in table" + goto, no_table_found + endif + npoints = npoints*dimen[i] + endfor + data = make_array(dimen=dimen,/byte) +; +; read data array +; + nrecs = (npoints + 2879)/2880 + nleft = npoints + + for i=0L,nrecs-1 do begin + readu,unit,buf + case bitpix of + 16: byteorder,buf,/NtoHS + 32: byteorder,buf,/NtoHL + -32: byteorder,buf,/XDRTOF + -64: byteorder,buf,/XDRTOD + ELSE: + endcase + + if nleft lt 2880 then max_nleft = nleft-1 $ + else max_nleft= 2880L-1 + data[i*2880L] = buf[0 : max_nleft ] + nleft = (npoints-1) - ((i+1)*2880L) + endfor + +table_available=1 +return + +no_table_found: +table_available=0 + +return +end + +pro st_disk_geis,h,data,htab,tab,table_available,name,gcount,dimen,opsize, $ + nbytes_g,itype +;+ +; NAME: +; ST_DISK_GEIS +; +; PURPOSE: +; Routine to construct GEIS files from ST FITS disk files. +; +; CALLING SEQUENCE: +; ST_DISK_GEIS, h, data, htab, tab, table_available, name, gcount, +; dimen,opsize, nbytes_g,itype +; +; INPUT PARAMETERS: +; h - header for data +; data - data array +; htab - header for the table +; tab - fits table +; table_available - logical variable (1 if table was found) +; name - data set name +; gcount - number of groups +; dimen - data dimensions +; opsize - original parameter block size +; nbytes_g - number of bytes per group +; itype - idl integer data type value for the output data groups +; +; SIDE EFFECTS: +; +; GEIS file updated with group parameters in unit 1 (already open) +; and header file created +; +; NOTES: +; This is not a standalone program. Use st_diskread. +; +; During the creation of the header, this routine performs the +; following steps: +; 1) create a basic fits header (7 keywords) +; 2) adjust basic fits header for the number of axis present (i.e. >1) +; 3) adjust basic fits header for parameter keywords (i.e. ptype,etc) +; 4) from this point, sequentially copies keywords until it hits one of +; the following keywords 'INSTRUME','INSTRUID', or 'CONFG'. +; 5) append 'END' statement +; +; PROCEDURES CALLED: +; FTSIZE, SXADDPAR, SXHWRITE +; HISTORY: +; 10/17/94 JKF/ACC - taken from ST_DISK_GEIS +; +;**************************************************************************** +;- +; +; convert table to parameter block +; + hpar = strarr(200) ;parameter header + hpar[0]='END' + sxaddpar,hpar,'PCOUNT',0 + sxaddpar,hpar,'PSIZE',opsize*8 + npar = 0 + if table_available then begin + ftsize,htab,tab,ncols,ngroups,npar + if ngroups ne gcount then begin + print,'ST_DISK_GEIS - number of rows in table does '+ $ + 'not match GCOUNT' + retall + endif + sxaddpar,hpar,'PCOUNT',npar +; +; get parameter descriptions +; + + ptype = sxpar(htab,'ttype*') ;parameter name + tform = sxpar(htab,'tform*') ;formats in table + tbcol = sxpar(htab,'tbcol*')-1 ;starting byte in table + twidth = intarr(npar) ;width of table columns + pdtype = strarr(16,npar) ;data type + nbytes = intarr(npar) ;size in bytes of the par. + sbyte = intarr(npar) ;starting byte in par. block + idltypes = intarr(npar) ;idl data type + for i=0,npar-1 do begin + type=strmid(tform[i],0,1) + case strupcase(type) of + 'A' : idltype = 1 + 'I' : idltype = 16 + 'E' : idltype = 8 + 'F' : idltype = 8 + 'D' : idltype = 32 + endcase + idltypes[i]=idltype +; +; get field width in characters +; + twidth[i]=fix(strtrim(gettok( $ + strmid(tform[i],1,strlen(tform[i])-1),'.'),2)) + + case idltype of + 1: begin ;string + if ((twidth[i] mod 4) gt 0) then $ + twidth[i]= (fix(twidth[i]/4)*4 + 4) + nbytes[i] = twidth[i] + pdtype[i] = 'CHARACTER*'+strtrim(twidth[i],2) + end + 8: begin + nbytes[i] = 4 + pdtype[i] = 'REAL*4' + end + 16: begin + nbytes[i] = 4 + pdtype[i] = 'INTEGER*4' + end + 32: begin + nbytes[i] = 8 + pdtype[i] = 'REAL*8' + end + endcase + + if i gt 0 then sbyte[i] = nbytes[i-1]+sbyte[i-1] + + endfor +; +; complete parameter block portion of the header +; + if total(nbytes) ne opsize then begin + print,'ST_DISK_GEIS - mismatch of computed and ' + $ + 'original group par. block sizes' + retall + endif + blank = string(replicate(32b,80)) + strput,blank,'=',8 + nhpar = 2 + for i=0,npar-1 do begin + st=strtrim(i+1,2) + + line=blank ;PTYPEn + strput,line,'PTYPE'+st + strput,line,"'"+ptype[i]+"'",10 +; +; Add comments to group parameters (PTYPEn field)...JKF/ACC 1/22/92 +; + strput,line,'/',31 + strput,line, strtrim(sxpar(htab,ptype[i]),2), 33 + hpar[nhpar]=line + + line=blank ;PDTYPEn + strput,line,'PDTYPE'+st + strput,line,"'"+pdtype[i]+"'",10 + strput,line,'/',31 + hpar[nhpar+1]=line + + line=blank ;PSIZEn + strput,line,'PSIZE'+st + strput,line,string(nbytes[i]*8,'(I5)'),25 + strput,line,'/',31 + hpar[nhpar+2]=line + nhpar=nhpar+3 + endfor + hpar[nhpar]='END' +; +; read table columns and insert into 2-d parameter block +; + pblock=bytarr(total(nbytes),ngroups) + for i=0,npar-1 do begin + width = twidth[i] + width1 = width-1 + column = tab[tbcol[i]:tbcol[i]+width1,*] + if idltypes[i] ne 1 then begin + case idltypes[i] of + 8: val = fltarr(ngroups) + 16: val = lonarr(ngroups) + 32: val = dblarr(ngroups) + endcase + for j=0L,ngroups-1 do begin + start = width*j + ; + ; If the field is blank, force atleast + ; a character 0. (DJL 10/92) + ; + tmp = string(column[start:start+width1]) + if strtrim(tmp) eq '' then tmp ='0' + val[j]=tmp + endfor + column = byte(val,0,nbytes[i],ngroups) + endif + pblock[sbyte[i],0]=column + endfor + endif +; +; Create output header --------------------------------------------- +; +; determine type and size of data +; + case itype of + 1: begin & datatype='BYTE' & bitpix=8 & end + 2: begin & datatype='INTEGER*2' & bitpix=16 & end + 3: begin & datatype='INTEGER*4' & bitpix=32 & end + 4: begin & datatype='REAL*4' & bitpix=32 & end + 5: begin & datatype='REAL*8' & bitpix=64 & end + endcase +; +; create output header for GEIS file +; + + hout = strarr(500) & hout[0]='END' ;standard keywords + sxaddpar,hout,'SIMPLE','F' ;not standard fits + sxaddpar,hout,'BITPIX',bitpix + sxaddpar,hout,'DATATYPE',datatype + sxaddpar,hout,'NAXIS',n_elements(dimen) + ndim = n_elements(dimen) + for i=1,ndim do sxaddpar,hout,'NAXIS'+strtrim(i,2),dimen[i-1] + sxaddpar,hout,'GROUPS','T' ;group format data + sxaddpar,hout,'GCOUNT',gcount +; +; combine information from hpar, hs and h headers to form output header +; + nout = 7 + while strtrim(strmid(hout[nout],0,8)) ne 'END' do nout=nout+1 +; +; add parameter block information +; + pos = 0 + while strtrim(strmid(hpar[pos],0,8)) ne 'END' do begin + hout[nout]=hpar[pos] + nout=nout+1 + pos=pos+1 + endwhile +; +; skip junk at first part of h header +; + pos = 0 + while (strmid(h[pos],0,8) ne 'INSTRUME') and $ + (strmid(h[pos],0,8) ne 'INSTRUID') and $ + (strtrim(strmid(h[pos],0,8),2) ne 'CONFIG') do begin + pos = pos + 1 + if strtrim(strmid(h[pos],0,8)) eq 'END' then begin + print,'ST_DISK_GEIS- INSTRUME keyword missing from header' + retall + endif + endwhile +; +; copy rest of header to hout +; + while strtrim(strmid(h[pos],0,8)) ne 'END' do begin + hout[nout] = h[pos] + nout=nout+1 + pos=pos+1 + endwhile + hout[nout]='END' +; +; Create output GEIS file -------------------------------------------------- +; + sxhwrite,name,hout ;output header file + if npar gt 0 then begin + out_rec = assoc(1,bytarr(1)) ;put in group parameters + for i=0,gcount-1 do $ + out_rec[i*(nbytes_g+opsize)+nbytes_g] = pblock[*,i] + end +close,1 +return +end diff --git a/modules/idl_downloads/astro/pro/starast.pro b/modules/idl_downloads/astro/pro/starast.pro new file mode 100644 index 0000000..a120d24 --- /dev/null +++ b/modules/idl_downloads/astro/pro/starast.pro @@ -0,0 +1,140 @@ +pro starast,ra,dec,x,y,cd, righthanded=right,hdr=hdr, projection=projection +;+ +; NAME: +; STARAST +; PURPOSE: +; Compute astrometric solution using positions of 2 or 3 reference stars +; EXPLANATION: +; Computes an exact astrometric solution using the positions and +; coordinates from 2 or 3 reference stars and assuming a tangent +; (gnomonic) projection. If 2 stars are used, then +; the X and Y plate scales are assumed to be identical, and the +; axis are assumed to be orthogonal. Use of three stars will +; allow a unique determination of each element of the CD matrix. +; +; CALLING SEQUENCE: +; starast, ra, dec, x, y, cd, [/Righthanded, HDR = h, PROJECTION=] +; +; INPUTS: +; RA - 2 or 3 element vector containing the Right Ascension in DEGREES +; DEC- 2 or 3 element vector containing the Declination in DEGREES +; X - 2 or 3 element vector giving the X position of reference stars +; Y - 2 or 3 element vector giving the Y position of reference stars +; OUTPUTS: +; CD - CD (Coordinate Description) matrix (DEGREES/PIXEL) determined +; from stellar positions and coordinates. +; OPTIONAL INPUT KEYWORD: +; /RightHanded - If only 2 stars are supplied, then there is an ambiguity +; in the orientation of the coordinate system. By default, +; STARAST assumes the astronomical standard left-handed system +; (R.A. increase to the left). If /Right is set then a +; righthanded coordinate is assumed. This keyword has no effect +; if 3 star positions are supplied. +; PROJECTION - Either a 3 letter scalar string giving the projection +; type (e.g. 'TAN' or 'SIN') or an integer 1 - 25 specifying the +; projection as given in the WCSSPH2XY procedure. If not +; specified then a tangent projection is computed. +; OPTIONAL INPUT-OUTPUT KEYWORD: +; HDR - If a FITS header string array is supplied, then an astrometry +; solution is added to the header using the CD matrix and star 0 +; as the reference pixel (see example). Equinox 2000 is assumed. +; EXAMPLE: +; To use STARAST to add astrometry to a FITS header H; +; +; IDL> starast,ra,dec,x,y,cd ;Determine CD matrix +; IDL> crval = [ra[0],dec[0]] ;Use Star 0 as reference star +; IDL> crpix = [x[0],y[0]] +1 ;FITS is offset 1 pixel from IDL +; IDL> putast,H,cd,crpix,crval ;Add parameters to header +; +; This is equivalent to the following command: +; IDL> STARAST,ra,dec,x,y,hdr=h +; +; METHOD: +; The CD parameters are determined by solving the linear set of equations +; relating position to local coordinates (l,m) +; +; For highest accuracy the first star position should be the one closest +; to the reference pixel. +; REVISION HISTORY: +; Written, W. Landsman January 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added /RightHanded and HDR keywords W. Landsman September 2000 +; Write CTYPE values into header W. Landsman/A. Surkov December 2002 +; CD matrix was mistakenly transpose in 3 star solution +; Added projection keyword W. Landsman September 2003 +; Test for singular matrix W. Landsman August 2011 +;- + On_ERROR,2 + compile_opt idl2 + + if N_params() LT 4 then begin + print,'Syntax - STARAST, ra, dec, x, y, cd, [/Right, HDR =h,Projection=]' + return + endif + + cdr = !DPI/180.0D + map_types=['DEF','AZP','TAN','SIN','STG','ARC','ZPN','ZEA','AIR','CYP',$ + 'CAR','MER','CEA','COP','COD','COE','COO','BON','PCO','SFL',$ + 'PAR','AIT','MOL','CSC','QSC','TSC'] + + iterate = (N_elements(crpix) EQ 2) && (N_elements(crval) EQ 0) + if N_elements(projection) EQ 0 then projection = 2 ;Default is tangent proj. + if size(projection,/TNAME) EQ 'STRING' then begin + map_type =where(map_types EQ strupcase(strtrim(projection,2)), Ng) + if Ng EQ 0 then message, $ + 'ERROR - supplied projection of ' + projection[0] + ' not recognized' + map_type = map_type[0] + endif else map_type = projection + + nstar = min( [N_elements(ra), N_elements(dec), N_elements(x), N_elements(y)]) + if (nstar NE 2) && (nstar NE 3) then $ + message,'ERROR - Either 2 or 3 star positions required' + crval1 = [ ra[0], dec[0] ] + crpix1 = [ x[0], y[0] ] + +; Convert RA, Dec to Eta, Xi + + wcssph2xy, crval = crval1, ra[1:*], dec[1:*], eta, xi, map_type, $ + latpole = 0.0 + delx1 = x[1] - crpix1[0] + dely1 = y[1] - crpix1[1] + +if nstar EQ 3 then begin + + delx2 = x[2] - crpix1[0] & dely2 = y[2] - crpix1[1] + b = double([eta[0],xi[0],eta[1],xi[1]]) + a = double( [ [delx1, 0, delx2, 0 ], $ + [dely1, 0, dely2, 0 ], $ + [0. , delx1, 0, delx2 ], $ + [0 , dely1 , 0. ,dely2] ] ) +endif else begin + + b = double( [eta[0],xi[0]] ) + if keyword_set(right) then $ + a = double( [ [delx1,dely1], [-dely1,delx1] ] ) else $ + a = double( [ [delx1,-dely1], [dely1,delx1] ] ) + +endelse + + cd = invert(a,status)#b ;Solve linear equations + if status EQ 1 then $ + message,'ERROR - Singular matrix (collinear points)' + if nstar EQ 2 then begin + if keyword_set(right) then $ + cd = [ [cd[0],cd[1]],[-cd[1],cd[0]] ] else $ + cd = [ [cd[0],cd[1]],[cd[1],-cd[0]] ] + endif else $ + cd = transpose(reform(cd,2,2)) + + +;Add parameters to header + if N_elements(hdr) GT 0 then begin + proj = map_types[map_type] + make_astr, astr,CD = cd, crval = crval1, crpix = crpix1+1, $ + ctype = ['RA---','DEC--'] + proj + putast, hdr, astr, equi=2000.0,cd_type=2 + + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/store_array.pro b/modules/idl_downloads/astro/pro/store_array.pro new file mode 100644 index 0000000..8e4f988 --- /dev/null +++ b/modules/idl_downloads/astro/pro/store_array.pro @@ -0,0 +1,149 @@ + PRO STORE_ARRAY, DESTINATION, INSERT, INDEX +;+ +; NAME: +; STORE_ARRAY +; PURPOSE: +; Insert array INSERT into the array DESTINATION +; EXPLANATION: +; The dimensions of the DESTINATION array are adjusted to accommodate +; the inserted array. +; CATEGOBY: +; Utility +; CALLING SEQUENCE: +; STORE_ARRAY, DESTINATION, INSERT, INDEX +; INPUT: +; DESTINATION = Array to be expanded. +; INSERT = Array to insert into DESTINATION. +; INDEX = Index of the final dimension of DESTINATION to insert +; INSERT into. +; OUTPUTS: +; DESTINATION = Expanded output array. If both input arrays have the +; same number of dimensions, then the DESTINATION will +; be replaced with INSERT. +; RESTRICTIONS: +; DESTINATION and INSERT have to be either both of type string or both of +; numerical types. +; +; INSERT must not have more dimensions than DESTINATION. +; +; MODIFICATION HISTOBY: +; William Thompson, Feb. 1992, from BOOST_ARRAY by D. Zarro and P. Hick. +; Converted to IDL V5.0 W. Landsman September 1997 +;- +; + ON_ERROR, 2 ;On error, return to caller +; +; Check the number of parameters. +; + IF N_PARAMS() NE 3 THEN MESSAGE, $ + 'Syntax: STORE_ARRAY, DESTINATION, INSERT, INDEX' +; +; Make sure everything is defined. +; + IF N_ELEMENTS(INSERT) EQ 0 THEN MESSAGE,'INSERT not defined' + IF N_ELEMENTS(INDEX) EQ 0 THEN MESSAGE,'INDEX not defined' +; +; If DESTINATION is not defined, then set it equal to INSERT. +; + IF N_ELEMENTS(DESTINATION) EQ 0 THEN BEGIN + DESTINATION = INSERT + RETURN + ENDIF +; +; Get the array types and dimensions of DESTINATION and INSERT. +; + SD = SIZE(DESTINATION) + SA = SIZE(INSERT) + D_NDIM = SD[0] + A_NDIM = SA[0] + IF D_NDIM EQ 0 THEN D_DIM = 1 ELSE D_DIM = SD[1:D_NDIM] + IF A_NDIM EQ 0 THEN A_DIM = 1 ELSE A_DIM = SA[1:A_NDIM] + D_TYPE = SD[N_ELEMENTS(SD)-2] + A_TYPE = SA[N_ELEMENTS(SA)-2] +; +; Treat scalars as one-dimensional arrays. +; + D_NDIM = D_NDIM > 1 + A_NDIM = A_NDIM > 1 +; +; Check to see if both arrays are of type string or numeric. +; + IF D_TYPE EQ 7 THEN D_STRING = 1 ELSE D_STRING = 0 + IF A_TYPE EQ 7 THEN A_STRING = 1 ELSE A_STRING = 0 + IF D_STRING NE A_STRING THEN MESSAGE, $ + 'Data arrays should be either both string or both non-string' +; +; If both arrays have the same number of elements, then replace DESTINATION +; with INSERT. +; + IF D_NDIM EQ A_NDIM THEN BEGIN + DESTINATION = INSERT + RETURN +; +; Otherwise, make sure that INSERT has fewer dimensions than DESTINATION. +; + END ELSE IF D_NDIM LT A_NDIM THEN MESSAGE, $ + 'INSERT has more dimensions than DESTINATION' +; +; Check INDEX +; + LAST = D_DIM[D_NDIM-1] - 1 + IF (INDEX LT 0) OR (INDEX GT LAST) THEN MESSAGE, $ + 'INDEX must be between 0 and ' + STRTRIM(LAST,2) +; +; Merge the dimensions of DESTINATION and INSERT. +; + R_DIM = D_DIM + FOR I = 0,A_NDIM-1 DO R_DIM[I] = D_DIM[I] > A_DIM[I] +; +; Create the output array with the correct number of elements, and the greater +; of the types of DESTINATION and INSERT. +; + OUTPUT = MAKE_ARRAY(DIMENSION=R_DIM, TYPE=(D_TYPE > A_TYPE)) + R_NDIM = N_ELEMENTS(R_DIM) +; +; If INDEX is not zero, then store the first part of DESTINATION in the output +; array. +; + IF INDEX NE 0 THEN BEGIN + K = INDEX - 1 + CASE R_NDIM OF + 2: OUTPUT[0,0] = DESTINATION[*,0:K] + 3: OUTPUT[0,0,0] = DESTINATION[*,*,0:K] + 4: OUTPUT[0,0,0,0] = DESTINATION[*,*,*,0:K] + 5: OUTPUT[0,0,0,0,0] = DESTINATION[*,*,*,*,0:K] + 6: OUTPUT[0,0,0,0,0,0] = DESTINATION[*,*,*,*,*,0:K] + 7: OUTPUT[0,0,0,0,0,0,0] = DESTINATION[*,*,*,*,*,*,0:K] + ENDCASE + ENDIF +; +; Add INSERT. +; + CASE R_NDIM OF + 2: OUTPUT[0,INDEX] = INSERT + 3: OUTPUT[0,0,INDEX] = INSERT + 4: OUTPUT[0,0,0,INDEX] = INSERT + 5: OUTPUT[0,0,0,0,INDEX] = INSERT + 6: OUTPUT[0,0,0,0,0,INDEX] = INSERT + 7: OUTPUT[0,0,0,0,0,0,INDEX] = INSERT + ENDCASE +; +; Store the remainder of DESTINATION, if any, in the output array. +; + IF INDEX NE LAST THEN BEGIN + K = INDEX + 1 + CASE R_NDIM OF + 2: OUTPUT[0,K] = DESTINATION[*,K:*] + 3: OUTPUT[0,0,K] = DESTINATION[*,*,K:*] + 4: OUTPUT[0,0,0,K] = DESTINATION[*,*,*,K:*] + 5: OUTPUT[0,0,0,0,K] = DESTINATION[*,*,*,*,K:*] + 6: OUTPUT[0,0,0,0,0,K] = DESTINATION[*,*,*,*,*,K:*] + 7: OUTPUT[0,0,0,0,0,0,K] = DESTINATION[*,*,*,*,*,*,K:*] + ENDCASE + ENDIF +; +; Replace DESTINATION with OUTPUT, and return. +; + DESTINATION = OUTPUT + RETURN + END diff --git a/modules/idl_downloads/astro/pro/str_index.pro b/modules/idl_downloads/astro/pro/str_index.pro new file mode 100644 index 0000000..d3c9b13 --- /dev/null +++ b/modules/idl_downloads/astro/pro/str_index.pro @@ -0,0 +1,68 @@ +FUNCTION STR_INDEX, str, substr, offset +;+ +; NAME: +; STR_INDEX() +; +; PURPOSE: +; Get indices of a substring (SUBSTR) in string. +; +; EXPLANATION: +; The IDL intrinsic function STRPOS returns only the index of the first +; occurrence of a substring. This routine calls itself recursively to get +; indices of the remaining occurrences. +; +; CALLING SEQUENCE: +; result= STR_INDEX(str, substr [, offset]) +; +; INPUTS: +; STR -- The string in which the substring is searched for +; SUBSTR -- The substring to be searched for within STR +; +; OPTIONAL INPUTS: +; OFFSET -- The character position at which the search is begun. If +; omitted or being negative, the search begins at the first +; character (character position 0). +; +; OUTPUTS: +; RESULT -- Integer scalar or vector containing the indices of SUBSTR +; within STR. If no substring is found, it is -1. +; +; CALLS: +; DELVARX +; +; COMMON BLOCKS: +; STR_INDEX -- internal common block. The variable save in the block is +; deleted upon final exit of this routine. +; +; CATEGORY: +; Utility, string +; +; MODIFICATION HISTORY: +; Written January 3, 1995, Liyun Wang, GSFC/ARC +; Converted to IDL V5.0 W. Landsman September 1997 +; Use size(/TNAME) instead of DATATYPE() W. Landsman October 2001 +; +;- +; + ON_ERROR, 2 + COMMON str_index, idx + + IF N_PARAMS() LT 2 THEN MESSAGE,'Syntax: str_index, str, substr [,offset]' + + IF size(str,/TNAME) NE 'STRING' OR size(substr,/TNAME) NE 'STRING' THEN $ + MESSAGE, 'The first two input parameters must be of string type.' + + IF N_ELEMENTS(offset) EQ 0 THEN pos = 0 ELSE pos = offset + aa = STRPOS(str,substr,pos) + IF aa NE -1 THEN BEGIN + IF N_ELEMENTS(idx) EQ 0 THEN idx = aa ELSE idx = [idx,aa] + bb = str_index(str,substr,aa+1) + RETURN, bb + ENDIF ELSE BEGIN + IF N_ELEMENTS(idx) NE 0 THEN BEGIN + result = idx + delvarx, idx + ENDIF ELSE result = -1 + RETURN, result + ENDELSE +END diff --git a/modules/idl_downloads/astro/pro/strcompress2.pro b/modules/idl_downloads/astro/pro/strcompress2.pro new file mode 100644 index 0000000..3c34055 --- /dev/null +++ b/modules/idl_downloads/astro/pro/strcompress2.pro @@ -0,0 +1,51 @@ +function strcompress2, str, chars +;+ +; NAME: +; STRCOMPRESS2 +; PURPOSE: +; Remove blanks around specified characters in a string +; CALLING SEQUENCE +; newstring = strcompress2( st, chars) +; INPUTS: +; st - any scalar string +; chars - scalar or vector string specifing which characters around which +; blanks should be removed. For example, if chars=['=','-','+'] +; then spaces around the three characters "=', '-', and '+' will +; be removed. +; OUTPUTS: +; newstring - input string with spaces removed around the specified +; characters. +; EXAMPLE: +; The Vizier constraint string (see queryvizier.pro) does not allow +; blanks around the operators '=','<', or '>'. But we do not want +; to remove blanks around names (e.g. 'NGC 5342'): +; +; IDL> st = 'name = NGC 5342, v< 23' +; IDL> print,strcompress2(st, ['=','<','>']) +; name=NGC 5342, v<23 +; MODIFICATION HISTORY: +; Written by W.Landsman July 2008 +;- + + On_error,2 + compile_opt idl2 + st = strcompress(str) ;Ok to compress to a single space + if N_elements(chars) GT 1 then op = '(' + strjoin(chars,'|') + ')' $ + else op = chars + + op1 = ' ' + op ;first look for Leading space + n = stregex(st, op1) + while n GT 0 do begin + st = strmid(st,0,n) + strmid(st,n+1) ;piece string together + n = stregex(st,op1) ; Look for another occurrence since stregex just + endwhile ; gives the first + + op2 = op + ' ' ;Now look for Following space + n = stregex(st, op2) + while n GT 0 do begin + st = strmid(st,0,n+1) + strmid(st,n+2) + n = stregex(st,op2) + endwhile + + return,st + end diff --git a/modules/idl_downloads/astro/pro/strn.pro b/modules/idl_downloads/astro/pro/strn.pro new file mode 100644 index 0000000..45b92bc --- /dev/null +++ b/modules/idl_downloads/astro/pro/strn.pro @@ -0,0 +1,100 @@ +function strn, number, LENGTH = length, PADTYPE = padtype, PADCHAR = padchar, $ + FORMAT = Format +;+ +; NAME: +; STRN +; PURPOSE: +; Convert a number to a string and remove padded blanks. +; EXPLANATION: +; The main and original purpose of this procedure is to convert a number +; to an unpadded string (i.e. with no blanks around it.) However, it +; has been expanded to be a multi-purpose formatting tool. You may +; specify a length for the output string; the returned string is either +; set to that length or padded to be that length. You may specify +; characters to be used in padding and which side to be padded. Finally, +; you may also specify a format for the number. NOTE that the input +; "number" need not be a number; it may be a string, or anything. It is +; converted to string. +; +; CALLING SEQEUNCE: +; tmp = STRN( number, [ LENGTH=, PADTYPE=, PADCHAR=, FORMAT = ] ) +; +; INPUT: +; NUMBER This is the input variable to be operated on. Traditionally, +; it was a number, but it may be any scalar type. +; +; OPTIONAL INPUT: +; LENGTH This KEYWORD specifies the length of the returned string. +; If the output would have been longer, it is truncated. If +; the output would have been shorter, it is padded to the right +; length. +; PADTYPE This KEYWORD specifies the type of padding to be used, if any. +; 0=Padded at End, 1=Padded at front, 2=Centered (pad front/end) +; IF not specified, PADTYPE=1 +; PADCHAR This KEYWORD specifies the character to be used when padding. +; The default is a space (' '). +; FORMAT This keyword allows the FORTRAN type formatting of the input +; number (e.g. '(f6.2)') +; +; OUTPUT: +; tmp The formatted string +; +; USEFUL EXAMPLES: +; print,'Used ',strn(stars),' stars.' ==> 'Used 22 stars.' +; print,'Attempted ',strn(ret,leng=6,padt=1,padch='0'),' retries.' +; ==> 'Attempted 000043 retries.' +; print,strn('M81 Star List',length=80,padtype=2) +; ==> an 80 character line with 'M81 Star List' centered. +; print,'Error: ',strn(err,format='(f15.2)') +; ==> 'Error: 3.24' or ==> 'Error: 323535.22' +; +; HISTORY: +; 03-JUL-90 Version 1 written by Eric W. Deutsch +; 10-JUL-90 Trimming and padding options added (E. Deutsch) +; 29-JUL-91 Changed to keywords and header spiffed up (E. Deutsch) +; Ma7 92 Work correctly for byte values (W. Landsman) +; 19-NOV-92 Added Patch to work around IDL 2.4.0 bug which caused an +; error when STRN('(123)') was encountered. (E. Deutsch) +;; Handles array input, M. Sullivan March 2014 +; Use V6.0 notation W. Landsman April 2014 +; Fix problem with vector strings of different length WL Aug 2014 +;- + On_error,2 + if ( N_params() LT 1 ) then begin + print,'Call: IDL> tmp=STRN(number,[length=,padtype=,padchar=,format=])' + print,"e.g.: IDL> print,'Executed ',strn(ret,leng=6,padt=1,padch='0'),' retries.'" + return,'' + endif + if (N_elements(padtype) eq 0) then padtype=1 + if (N_elements(padchar) eq 0) then padchar=' ' + if (N_elements(Format) eq 0) then Format='' + + padc = byte(padchar) + pad = string(replicate(padc[0],200)) + + tmp=STRARR(N_ELEMENTS(number)) + FOR i=0L,N_ELEMENTS(number)-1 DO BEGIN + ss=size(number[i]) & PRN=1 & if (ss[1] eq 7) then PRN=0 + if ( Format EQ '') then tmp[i] = strtrim( string(number[i], PRINT=PRN),2) $ + else tmp[i] = strtrim( string( number[i], FORMAT=Format, PRINT=PRN),2) + + if (N_elements(length) eq 0) then len=strlen(tmp[i]) else len = length + + if (strlen(tmp[i]) gt len) then tmp[i]=strmid(tmp[i],0,len) + + if (strlen(tmp[i]) lt len) && (padtype eq 0) then begin + tmp[i] += strmid(pad,0,len-strlen(tmp[i])) + endif + + if (strlen(tmp[i]) lt len) && (padtype eq 1) then begin + tmp[i] = strmid(pad,0,len-strlen(tmp[i]))+tmp[i] + endif + + if (strlen(tmp[i]) lt len) && (padtype eq 2) then begin + padln=len-strlen(tmp[i]) & padfr=padln/2 & padend=padln-padfr + tmp[i]=strmid(pad,0,padfr)+tmp[i]+strmid(pad,0,padend) + endif + endfor +;;Return an array if passed an array, or not if not + IF ( SIZE(number,/DIMENSION) EQ 0 ) THEN RETURN,tmp[0] ELSE RETURN,tmp +end diff --git a/modules/idl_downloads/astro/pro/strnumber.pro b/modules/idl_downloads/astro/pro/strnumber.pro new file mode 100644 index 0000000..4586301 --- /dev/null +++ b/modules/idl_downloads/astro/pro/strnumber.pro @@ -0,0 +1,84 @@ +function strnumber, st, val, hex = hexflg, NaN = nan, L64 = l64 +;+ +; NAME: +; STRNUMBER() +; PURPOSE: +; Function to determine if a string is a valid numeric value. +; +; EXPLANATION: +; A string is considered a valid numeric value if IDL can convert it +; to a numeric variable without error. +; CALLING SEQUENCE: +; result = strnumber( st, [val, /HEX] ) +; +; INPUTS: +; st - any IDL scalar string +; +; OUTPUTS: +; 1 is returned as the function value if the string st has a +; valid numeric value, otherwise, 0 is returned. +; +; OPTIONAL OUTPUT: +; val - (optional) value of the string. double precision unless /L64 is set +; +; OPTIONAL INPUT KEYWORD: +; /HEX - If present and nonzero, the string is treated as a hexadecimal +; longword integer. +; /L64 - If present and nonzero, the val output variable is returned +; as a 64 bit integer. This to ensure that precision is not +; lost when returning a large 64 bit integer as double precision. +; This keyword has no effect on the function result. +; /NAN - if set, then the value of an empty string is returned as NaN, +; by default the returned value is 0.0d. In either case, +; an empty string is considered a valid numeric value. +; +; EXAMPLES: +; IDL> res = strnumber('0.2d', val) +; returns res=1 (a valid number), and val = 0.2000d +; +; NOTES: +; (1) STRNUMBER was modified in August 2006 so that an empty string is +; considered a valid number. Earlier versions of strnumber.pro did not +; do this because in very early (pre-V4.0) versions of IDL +; this could corrupt the IDL session. +; +; (2) STRNUMBER will return a string such as '23.45uyrg' as a valid +; number (=23.45) since this is how IDL performs the type conversion. If +; you want a stricter definition of valid number then use the VALID_NUM() +; function. +; HISTORY: +; version 1 By D. Lindler Aug. 1987 +; test for empty string, W. Landsman February, 1993 +; Hex keyword added. MRG, RITSS, 15 March 2000. +; An empty string is a valid number W. Landsman August 2006 +; Added /NAN keyword W. Landsman August 2006 +; Added /L64 keyword W. Landsman Feb 2010 +;- + compile_opt idl2 + if N_params() EQ 0 then begin + print,'Syntax - result = strnumber( st, [val, /HEX, /NAN] )' + return, 0 + endif + + newstr = strtrim( st ) + if keyword_set(NAN) then if newstr EQ '' then begin + val = !VALUES.D_NAN + return, 1 + endif + + On_IOerror, L1 ;Go to L1 if conversion error occurs + + If ~keyword_set(hexflg) Then Begin + val = double( newstr ) + EndIf Else Begin + val = 0L + reads, newstr, val, Format="(Z)" + EndElse + + if keyword_set(L64) then val = long64( newstr) + return, 1 ;No conversion error + + L1: return, 0 ;Conversion error occured + + end + diff --git a/modules/idl_downloads/astro/pro/substar.pro b/modules/idl_downloads/astro/pro/substar.pro new file mode 100644 index 0000000..9ece34e --- /dev/null +++ b/modules/idl_downloads/astro/pro/substar.pro @@ -0,0 +1,124 @@ +pro substar,image,x,y,mag,id,psfname,VERBOSE = verbose ;Subtract scaled PSF stars +;+ +; NAME: +; SUBSTAR +; PURPOSE: +; Subtract a scaled point spread function at specified star position(s). +; EXPLANATION: +; Part of the IDL-DAOPHOT photometry sequence +; +; CALLING SEQUENCE: +; SUBSTAR, image, x, y, mag, [ id, psfname, /VERBOSE] +; +; INPUT-OUTPUT: +; IMAGE - On input, IMAGE is the original image array. A scaled +; PSF will be subtracted from IMAGE at specified star positions. +; Make a copy of IMAGE before calling SUBSTAR, if you want to +; keep a copy of the unsubtracted image array +; +; INPUTS: +; X - REAL Vector of X positions found by NSTAR (or FIND) +; Y - REAL Vector of Y positions found by NSTAR (or FIND) +; MAG - REAL Vector of stellar magnitudes found by NSTAR (or APER) +; Used to scale the PSF to match intensity at star position. +; Stars with magnitude values of 0.0 are assumed missing and +; ignored in the subtraction. +; +; OPTIONAL INPUTS: +; ID - Index vector indicating which stars are to be subtracted. If +; omitted, (or set equal to -1), then stars will be subtracted +; at all positions specified by the X and Y vectors. +; +; PSFNAME - Name of the FITS file containing the PSF residuals, as +; generated by GETPSF. SUBSTAR will prompt for this parameter +; if not supplied. +; +; OPTIONAL INPUT KEYWORD: +; VERBOSE - If this keyword is set and nonzero, then SUBSTAR will +; display the star that it is currently processing +; +; COMMON BLOCKS: +; The RINTER common block is used (see RINTER.PRO) to save time in the +; PSF calculations +; +; PROCEDURES CALLED: +; DAO_VALUE(), READFITS(), REMOVE, SXOPEN, SXPAR(), SXREAD() +; REVISION HISTORY: +; Written, W. Landsman August, 1988 +; Added VERBOSE keyword January, 1992 +; Fix star subtraction near edges, W. Landsman May, 1996 +; Assume the PSF file is in FITS format W. Landsman July, 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + common rinter,c1,c2,c3,init ;Save time in RINTER + if N_params() LT 4 then begin + print,'Syntax - SUBSTAR, image, x, y, mag,[ id, psfname, /VERBOSE]' + return + endif + + s = size(image) + if s[0] NE 2 then $ + message, 'ERROR - Input array (first parameter) must be 2 dimensions' + npts = N_elements(image) + + if N_elements(psfname) NE 1 then begin + psfname = '' + read, 'Enter name of the FITS file containing PSF residuals: ', psfname + endif + + if N_params() LT 5 then id = indgen( N_elements(x) ) else begin + if min(id) LT 0 then id = indgen( N_elements(x) ) ;Subtract all stars? + endelse + + psf = readfits(psfname, hpsf) + nstar = N_elements(id) ;Number of stars to subtract + gauss = sxpar( hpsf, 'GAUSS*' ) + psfmag = sxpar( hpsf, 'PSFMAG' ) + psfrad = sxpar( hpsf, 'PSFRAD' ) + fitrad = sxpar( hpsf, 'FITRAD' ) + npsf = sxpar( hpsf, 'NAXIS1' ) + + nbox = ( 2*fix( psfrad + 0.5 ) + 1) > ((npsf-7)/2) + nhalf = (nbox-1)/2 + psfrsq = psfrad^2 + lx = fix( x[id] + 0.5 ) - nhalf + ly = fix( y[id] + 0.5 ) - nhalf + smag = mag[id] + scale = 10^(-0.4*(smag- psfmag)) + xx = x[id] - lx + yy = y[id] - ly + bad = where( (smag EQ 0.0), Nbad) ;Any stars with missing magnitudes? + if Nbad GT 0 then begin + nstar = nstar - Nbad + remove,bad,lx,ly,xx,yy,scale + endif + rsq = fltarr( nbox, nbox) + boxgen = indgen(nbox) + +; Compute RINTER common block arrays + + p_1 = shift(psf,1,0) & p1 = shift(psf,-1,0) & p2 = shift(psf,-2,0) + c1 = 0.5*(p1-p_1) + c2 = 2.*p1 + p_1 - 0.5*(5.*psf + p2) + c3 = 0.5 *(3.*(psf-p1) + p2 - p_1) + init = 1 + + verbose = keyword_set(VERBOSE) + cr = string("15b) + for i = 0L,nstar-1 do begin + dx = boxgen - xx[i] + dy = boxgen - yy[i] + dx2 = dx^2 & dy2 = dy^2 + for j = 0,nbox-1 do rsq[0,j] = dx2 + dy2[j] + good = where( rsq LT psfrsq) + xgood = good mod nbox & ygood = good/nbox + dx = dx[xgood] & dy = dy[ygood] + goodbig = ( xgood + lx[i] ) + ( ygood + ly[i] )*s[1] + bad = where( (goodbig LT 0) or (goodbig GE npts), Nbad) + if nbad GT 0 then remove,bad,goodbig,dx,dy + image[goodbig] = image[goodbig] - scale[i] * dao_value( dx,dy,gauss,psf ) + if VERBOSE then $ + print,f="($,'SUBSTAR: Processing Star',I5,A)",id[i],cr +endfor +return +end diff --git a/modules/idl_downloads/astro/pro/sunpos.pro b/modules/idl_downloads/astro/pro/sunpos.pro new file mode 100644 index 0000000..8b25c82 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sunpos.pro @@ -0,0 +1,167 @@ +PRO sunpos, jd, ra, dec, longmed, oblt, RADIAN = radian +;+ +; NAME: +; SUNPOS +; PURPOSE: +; To compute the RA and Dec of the Sun at a given date. +; +; CALLING SEQUENCE: +; SUNPOS, jd, ra, dec, [elong, obliquity, /RADIAN ] +; INPUTS: +; jd - The Julian date of the day (and time), scalar or vector +; usually double precision +; OUTPUTS: +; ra - The right ascension of the sun at that date in DEGREES +; double precision, same number of elements as jd +; dec - The declination of the sun at that date in DEGREES +; +; OPTIONAL OUTPUTS: +; elong - Ecliptic longitude of the sun at that date in DEGREES. +; obliquity - the obliquity of the ecliptic, in DEGREES +; +; OPTIONAL INPUT KEYWORD: +; /RADIAN - If this keyword is set and non-zero, then all output variables +; are given in Radians rather than Degrees +; +; NOTES: +; Patrick Wallace (Rutherford Appleton Laboratory, UK) has tested the +; accuracy of a C adaptation of the sunpos.pro code and found the +; following results. From 1900-2100 SUNPOS gave 7.3 arcsec maximum +; error, 2.6 arcsec RMS. Over the shorter interval 1950-2050 the figures +; were 6.4 arcsec max, 2.2 arcsec RMS. +; +; The returned RA and Dec are in the given date's equinox. +; +; Procedure was extensively revised in May 1996, and the new calling +; sequence is incompatible with the old one. +; METHOD: +; Uses a truncated version of Newcomb's Sun. Adapted from the IDL +; routine SUN_POS by CD Pike, which was adapted from a FORTRAN routine +; by B. Emerson (RGO). +; EXAMPLE: +; (1) Find the apparent RA and Dec of the Sun on May 1, 1982 +; +; IDL> jdcnv, 1982, 5, 1,0 ,jd ;Find Julian date jd = 2445090.5 +; IDL> sunpos, jd, ra, dec +; IDL> print,adstring(ra,dec,2) +; 02 31 32.61 +14 54 34.9 +; +; The Astronomical Almanac gives 02 31 32.58 +14 54 34.9 so the error +; in SUNPOS for this case is < 0.5". +; +; (2) Find the apparent RA and Dec of the Sun for every day in 1997 +; +; IDL> jdcnv, 1997,1,1,0, jd ;Julian date on Jan 1, 1997 +; IDL> sunpos, jd+ dindgen(365), ra, dec ;RA and Dec for each day +; +; MODIFICATION HISTORY: +; Written by Michael R. Greason, STX, 28 October 1988. +; Accept vector arguments, W. Landsman April,1989 +; Eliminated negative right ascensions. MRG, Hughes STX, 6 May 1992. +; Rewritten using the 1993 Almanac. Keywords added. MRG, HSTX, +; 10 February 1994. +; Major rewrite, improved accuracy, always return values in degrees +; W. Landsman May, 1996 +; Added /RADIAN keyword, W. Landsman August, 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + compile_opt idl2 +; Check arguments. + if N_params() LT 3 then begin + print, 'Syntax - SUNPOS, jd, ra, dec, [elong, obliquity, /RADIAN] ' + print, 'Inputs - jd (Julian date)' + print, 'Outputs - Apparent RA and Dec, longitude, & obliquity' + print, 'All angles in DEGREES unless /RADIAN is set' + return + endif + + dtor = !DPI/180.0d ;(degrees to radian, double precision) + +; form time in Julian centuries from 1900.0 + + t = (jd - 2415020.0d)/36525.0d0 + +; form sun's mean longitude + + l = (279.696678d0+((36000.768925d0*t) mod 360.0d0))*3600.0d0 + +; allow for ellipticity of the orbit (equation of centre) +; using the Earth's mean anomaly ME + + me = 358.475844d0 + ((35999.049750D0*t) mod 360.0d0) + ellcor = (6910.1d0 - 17.2D0*t)*sin(me*dtor) + 72.3D0*sin(2.0D0*me*dtor) + l = l + ellcor + +; allow for the Venus perturbations using the mean anomaly of Venus MV + + mv = 212.603219d0 + ((58517.803875d0*t) mod 360.0d0) + vencorr = 4.8D0 * cos((299.1017d0 + mv - me)*dtor) + $ + 5.5D0 * cos((148.3133d0 + 2.0D0 * mv - 2.0D0 * me )*dtor) + $ + 2.5D0 * cos((315.9433d0 + 2.0D0 * mv - 3.0D0 * me )*dtor) + $ + 1.6D0 * cos((345.2533d0 + 3.0D0 * mv - 4.0D0 * me )*dtor) + $ + 1.0D0 * cos((318.15d0 + 3.0D0 * mv - 5.0D0 * me )*dtor) +l = l + vencorr + +; Allow for the Mars perturbations using the mean anomaly of Mars MM + + mm = 319.529425d0 + (( 19139.858500d0 * t) mod 360.0d0 ) + marscorr = 2.0d0 * cos((343.8883d0 - 2.0d0 * mm + 2.0d0 * me)*dtor ) + $ + 1.8D0 * cos((200.4017d0 - 2.0d0 * mm + me) * dtor) + l = l + marscorr + +; Allow for the Jupiter perturbations using the mean anomaly of +; Jupiter MJ + + mj = 225.328328d0 + (( 3034.6920239d0 * t) mod 360.0d0 ) + jupcorr = 7.2d0 * cos(( 179.5317d0 - mj + me )*dtor) + $ + 2.6d0 * cos((263.2167d0 - MJ ) *dtor) + $ + 2.7d0 * cos(( 87.1450d0 - 2.0d0 * mj + 2.0D0 * me ) *dtor) + $ + 1.6d0 * cos((109.4933d0 - 2.0d0 * mj + me ) *dtor) + l = l + jupcorr + +; Allow for the Moons perturbations using the mean elongation of +; the Moon from the Sun D + + d = 350.7376814d0 + (( 445267.11422d0 * t) mod 360.0d0 ) + mooncorr = 6.5d0 * sin(d*dtor) + l = l + mooncorr + +; Allow for long period terms + + longterm = + 6.4d0 * sin(( 231.19d0 + 20.20d0 * t )*dtor) + l = l + longterm + l = ( l + 2592000.0d0) mod 1296000.0d0 + longmed = l/3600.0d0 + +; Allow for Aberration + + l = l - 20.5d0 + +; Allow for Nutation using the longitude of the Moons mean node OMEGA + + omega = 259.183275d0 - (( 1934.142008d0 * t ) mod 360.0d0 ) + l = l - 17.2d0 * sin(omega*dtor) + +; Form the True Obliquity + + oblt = 23.452294d0 - 0.0130125d0*t + (9.2d0*cos(omega*dtor))/3600.0d0 + +; Form Right Ascension and Declination + + l = l/3600.0d0 + ra = atan( sin(l*dtor) * cos(oblt*dtor) , cos(l*dtor) ) + + neg = where(ra LT 0.0d0, Nneg) + if Nneg GT 0 then ra[neg] = ra[neg] + 2.0d*!DPI + + dec = asin(sin(l*dtor) * sin(oblt*dtor)) + + if keyword_set(RADIAN) then begin + oblt = oblt*dtor + longmed = longmed*dtor + endif else begin + ra = ra/dtor + dec = dec/dtor + endelse + end diff --git a/modules/idl_downloads/astro/pro/sunsymbol.pro b/modules/idl_downloads/astro/pro/sunsymbol.pro new file mode 100644 index 0000000..5bd2558 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sunsymbol.pro @@ -0,0 +1,77 @@ +function sunsymbol, FONT=font +;+ +; NAME: +; SUNSYMBOL +; PURPOSE: +; Return the Sun symbol as a subscripted postscript character string +; EXPLANATION: +; Returns the Sun symbol (circle with a dot in the middle) as a +; (subscripted) postscript character string. Needed because although +; the Sun symbol is available using the vector fonts as the string +; '!9n', it is not in the standard postscript set. +; +; CALLING SEQUENCE: +; result = SUNSYMBOL([FONT= ]) +; +; INPUTS: +; None +; +; OPTIONAL INPUT KEYWORDS: +; font = scalar font graphics keyword (-1,0 or 1) for text. Note that +; this keyword is useful for printing text with XYOUTS but *not* +; e.g. the XTIT keyword to PLOT where the font call to PLOT takes +; precedence. +; +; OUTPUTS: +; result - a scalar string representing the Sun symbol. A different +; string is output depending (1) the device is postscript and +; hardware fonts are used (!P.FONT=0), (2) vector fonts are used, +; or (3) hardware fonts are used on a non-postscript device. +; For case (3), SUNSYMBOL simply outputs the 3 character string +; 'Sun' +; +; EXAMPLE: +; To make the X-axis of a plot read M/M_Sun +; IDL> cgplot,indgen(10),xtit = 'M / M' + sunsymbol() +; +; RESTRICTIONS: +; (1) The postscript output does not have the dot perfectly centered in +; the circle. For a better symbol, consider postprocessing with +; psfrag (see http://www.astrobetter.com/idl-psfrag/ ). +; (2) SUNSYMBOL() includes subscript output positioning commands in the +; output string. +; (3) For true-type fonts(Font=1) and IDL Versions prior to V8.2, +; you must first use the SET_FONT keyword to Device to use a font +; that includes the Sun Symbol, e.g. "arial Unicode MS" or +; the Apple Symbols font. +; http://www.idlcoyote.com/misc_tips/sun_symbol.html +; In V8.2 and later, SUNSYMBOL() will automatically convert to the +; DejaVuSans font to create a Sun symbol (and then return to the +; input font). +; (4) Also look at CGSYMBOL http://www.idlcoyote.com/programs/cgsymbol.pro +; which includes 'sun' as one if the symbols. +; REVISION HISTORY: +; Written, W. Landsman, HSTX April, 1997 +; Allow font keyword to be passed. T. Robishaw Apr. 2006 +; Since IDL8.2 a Sun symbol is available for true-type fonts Feb 2013 +;- + On_error,2 + compile_opt idl2 + + if N_elements(font) eq 0 then font = !p.font + if (font EQ -1) then return,'!D!9n!N!X' else $ + if (!D.NAME NE 'PS') then return,'!DSun!N' else begin + +;Since 8.2 we can use !10 to select DejaVuSans font and then use the +;unicode Sun symbol + if FONT EQ 1 then $ + if (!VERSION.RELEASE GE '8.2') then return,'!10!D!Z(2609)!X!N' else $ + return,'!D!Z(2609)!X!N' +;Want to use /AVANTGARDE,/BOOK which is the default font 17, but to make sure +;that ISOLATIN encoding is turned off, we'll define our own font. + + device,/AVANTGARDE,/BOOK,ISOLATIN=0,FONT_INDEX = 20 + + return, '!20!S!DO!R!I ' + string(183b) + '!X!N' + endelse + end diff --git a/modules/idl_downloads/astro/pro/sxaddhist.pro b/modules/idl_downloads/astro/pro/sxaddhist.pro new file mode 100644 index 0000000..7597d15 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxaddhist.pro @@ -0,0 +1,137 @@ +pro sxaddhist,history,header,blank = blank,comment= comment, location=key, $ + pdu=pdu +;+ +; NAME: +; SXADDHIST +; PURPOSE: +; Procedure to add HISTORY (or COMMENT) line(s) to a FITS header +; +; EXPLANATION: +; The advantage of using SXADDHIST instead of SXADDPAR is that with +; SXADDHIST many HISTORY or COMMENT records can be added in a single call. +; +; CALLING SEQUENCE +; sxaddhist, history, header, [ /PDU, /COMMENT ] +; +; INPUTS: +; history - string or string array containing history or comment line(s) +; to add to the FITS header +; INPUT/OUTPUT +; header - FITS header (string array). Upon output, it will contain the +; specified HISTORY records added to the end +; +; OPTIONAL KEYWORD INPUTS: +; /BLANK - If specified then blank (' ') keywords will be written +; rather than 'HISTORY ' keywords. +; /COMMENT - If specified, then 'COMMENT ' keyword will be written rather +; than 'HISTORY ' keywords. +; Note that according to the FITS definition, any number of +; 'COMMENT' and 'HISTORY' or blank keywords may appear in a header, +; whereas all other keywords may appear only once. +; LOCATION=key - If present, the history will be added before this +; keyword. Otherwise put it at the end. +; /PDU - if specified, the history will be added to the primary +; data unit header, (before the line beginning BEGIN EXTENSION...) +; Otherwise, it will be added to the end of the header. +; This has meaning only for extension headers using the STScI +; inheritance convention. +; OUTPUTS: +; header - updated FITS header +; +; EXAMPLES: +; sxaddhist, 'I DID THIS', header ;Add one history record +; +; hist = strarr(3) +; hist[0] = 'history line number 1' +; hist[1[ = 'the next history line' +; hist[2] = 'the last history line' +; sxaddhist, hist, header ;Add three history records +; +; SIDE EFFECTS: +; Header array is truncated to the final END statement +; LOCATION overrides PDU. +; HISTORY: +; D. Lindler Feb. 87 +; April 90 Converted to new idl D. Lindler +; Put only a single space after HISTORY W. Landsman November 1992 +; Aug. 95 Added PDU keyword parameters +; LOCATION added. M. Greason, 28 September 2004. +; Missing minus sign (1 -> -1) in testing for WHERE output when +; looking for location to insert a comment M. Haffner Oct 2012 +;- +;-------------------------------------------------------------------- + On_error,2 + + if N_params() LT 2 then begin + print, ' Syntax - SXADDHIST, hist, header, ' + print, ' /PDU, /BLANK, /COMMENT, LOCATION= ] ' + return + endif + +; Check input parameters + + if (n_elements(key) LE 0) then keynam = '' $ + else keynam = strupcase(strtrim(key, 2)) + + s = size(history) & ndim = s[0] & type = s[ndim+1] + if type NE 7 then message, $ + 'Invalid history lines specified; must be a string or string array' + + if keyword_set(COMMENT) then keyword = 'COMMENT ' else $ + if keyword_set(BLANK) then keyword = ' ' else $ + keyword = 'HISTORY ' + nadd = N_elements(history) ;Number of lines to add + + s = size(header) & ndim2 = s[0] & type = s[ndim2+1] + if (ndim2 NE 1) || (type NE 7) then message, $ + 'Invalid FITS header supplied; header must be a string array' + + nlines = N_elements(header) ;Number of lines in header + +; Find END statement of FITS header + + endline = where( strtrim(strmid(header,0,8),2) EQ 'END' ) + n = endline[0] + if n LT 0 then message, $ + 'Invalid FITS header array, END keyword not found' + + blank = string( replicate(32b,80) ) + n1 = n ;position to insert +; +; if LOCATION was specified and found, make room before it. +; + locfnd = 0 + if (strlen(keynam) gt 0) then begin + extline = where( strupcase(strtrim(strmid(header,0,8),2)) EQ keynam ) + n_ext = extline[0] + if (n_ext gt -1) then begin + n1 = n_ext + locfnd = 1 + endif + endif +; +; if /PDU find beginning of the extension header and make room for the +; history +; + if (keyword_set(PDU) && (locfnd EQ 0)) then begin + extline = where( strupcase(strtrim(strmid(header,0,8),2)) EQ 'BEGIN EX' ) + n_ext = extline[0] + if n_ext gt 1 then n1 = n_ext + end +; +; make room in the header +; + if n1 eq 0 then header = [replicate(blank,nadd),header[n1:n]] else $ + header = [header[0:n1-1],replicate(blank,nadd),header[n1:n]] + +; Add history records to header starting at position N1 + + for i = 0, nadd-1 do begin + + newline = blank + strput, newline, keyword + history[i] + header[n1+i] = newline + + endfor + return + end diff --git a/modules/idl_downloads/astro/pro/sxaddpar.pro b/modules/idl_downloads/astro/pro/sxaddpar.pro new file mode 100644 index 0000000..bf984b4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxaddpar.pro @@ -0,0 +1,390 @@ +Pro sxaddpar, Header, Name, Value, Comment, Location, before=before, $ + savecomment = savecom, after=after , format=format, pdu = pdu, $ + missing = missing, null = null +;+ +; NAME: +; SXADDPAR +; PURPOSE: +; Add or modify a parameter in a FITS header array. +; +; CALLING SEQUENCE: +; SXADDPAR, Header, Name, Value, [ Comment, Location, /SaveComment, +; BEFORE =, AFTER = , FORMAT= , /PDU +; /SAVECOMMENT, Missing=, /Null +; INPUTS: +; Header = String array containing FITS or STSDAS header. The +; length of each element must be 80 characters. If not +; defined, then SXADDPAR will create an empty FITS header array. +; +; Name = Name of parameter. If Name is already in the header the value +; and possibly comment fields are modified. Otherwise a new +; record is added to the header. If name is equal to 'COMMENT' +; or 'HISTORY' or a blank string then the value will be added to +; the record without replacement. For these cases, the comment +; parameter is ignored. +; +; Value = Value for parameter. The value expression must be of the +; correct type, e.g. integer, floating or string. String values +; of 'T' or 'F' are considered logical values. +; +; OPTIONAL INPUT PARAMETERS: +; Comment = String field. The '/' is added by this routine. Added +; starting in position 31. If not supplied, or set equal to +; '', or /SAVECOMMENT is set, then the previous comment field is +; retained (when found) +; +; Location = Keyword string name. The parameter will be placed before the +; location of this keyword. This parameter is identical to +; the BEFORE keyword and is kept only for consistency with +; earlier versions of SXADDPAR. +; +; OPTIONAL INPUT KEYWORD PARAMETERS: +; BEFORE = Keyword string name. The parameter will be placed before the +; location of this keyword. For example, if BEFORE='HISTORY' +; then the parameter will be placed before the first history +; location. This applies only when adding a new keyword; +; keywords already in the header are kept in the same position. +; +; AFTER = Same as BEFORE, but the parameter will be placed after the +; location of this keyword. This keyword takes precedence over +; BEFORE. +; +; FORMAT = Specifies FORTRAN-like format for parameter, e.g. "F7.3". A +; scalar string should be used. For complex numbers the format +; should be defined so that it can be applied separately to the +; real and imaginary parts. If not supplied then the default is +; 'G19.12' for double precision, and 'G14.7' for floating point. +; /NULL = If set, then keywords with values which are undefined, or +; which have non-finite values (such as NaN, Not-a-Number) are +; stored in the header without a value, such as +; +; MYKEYWD = /My comment +; +; MISSING = A value which signals that data with this value should be +; considered missing. For example, the statement +; +; FXADDPAR, HEADER, 'MYKEYWD', -999, MISSING=-999 +; +; would result in the valueless line described above for the +; /NULL keyword. Setting MISSING to a value implies /NULL. +; Cannot be used with string or complex values. +; /PDU = specifies keyword is to be added to the primary data unit +; header. If it already exists, it's current value is updated in +; the current position and it is not moved. +; /SAVECOMMENT = if set, then any existing comment is retained, i.e. the +; COMMENT parameter only has effect if the keyword did not +; previously exist in the header. +; OUTPUTS: +; Header = updated FITS header array. +; +; EXAMPLE: +; Add a keyword 'TELESCOP' with the value 'KPNO-4m' and comment 'Name +; of Telescope' to an existing FITS header h. +; +; IDL> sxaddpar, h, 'TELESCOPE','KPNO-4m','Name of Telescope' +; NOTES: +; The functions SXADDPAR() and FXADDPAR() are nearly identical, with the +; major difference being that FXADDPAR forces required FITS keywords +; BITPIX, NAXISi, EXTEND, PCOUNT, GCOUNT to appear in the required order +; in the header, and FXADDPAR supports the OGIP LongString convention. +; There is no particular reason for having two nearly identical +; procedures, but both are too widely used to drop either one. +; +; All HISTORY records are inserted in order at the end of the header. +; +; All COMMENT records are also inserted in order at the end of the header +; header, but before the HISTORY records. The BEFORE and AFTER keywords +; can override this. +; +; All records with no keyword (blank) are inserted in order at the end of +; the header, but before the COMMENT and HISTORY records. The BEFORE and +; AFTER keywords can override this. + +; RESTRICTIONS: +; Warning -- Parameters and names are not checked +; against valid FITS parameter names, values and types. +; +; MODIFICATION HISTORY: +; DMS, RSI, July, 1983. +; D. Lindler Oct. 86 Added longer string value capability +; Converted to NEWIDL D. Lindler April 90 +; Added Format keyword, J. Isensee, July, 1990 +; Added keywords BEFORE and AFTER. K. Venkatakrishna, May '92 +; Pad string values to at least 8 characters W. Landsman April 94 +; Aug 95: added /PDU option and changed routine to update last occurrence +; of an existing keyword (the one SXPAR reads) instead of the +; first occurrence. +; Comment for string data can start after column 32 W. Landsman June 97 +; Make sure closing quote supplied with string value W. Landsman June 98 +; Increase precision of default formatting of double precision floating +; point values. C. Gehman, JPL September 1998 +; Mar 2000, D. Lindler, Modified to use capital E instead of lower case +; e for exponential formats. +; Apr 2000, Make user-supplied format upper-case W. Landsman +; Oct 2001, Treat COMMENT or blank string like HISTORY keyword W. Landsman +; Jan 2002, Allow BEFORE, AFTER to apply to COMMENT keywords W. Landsman +; June 2003, Added SAVECOMMENT keyword W. Landsman +; Jan 2004, If END is missing, then add it at the end W. Landsman +; May 2005 Fix SAVECOMMENT error with non-string values W. Landsman +; Oct 2005 Jan 2004 change made SXADDPAR fail for empty strings W.L. +; May 2011 Fix problem with slashes in string values W.L. +; Aug 2013 Only use keyword_set for binary keywords W. L. +; Sep 2015 Added NULL and MISSING keywords W.L> +; +;- + compile_opt idl2 + if N_params() LT 3 then begin ;Need at least 3 parameters + print,'Syntax - Sxaddpar, Header, Name, Value, [Comment, Postion' + print,' BEFORE = ,AFTER = , FORMAT =, /SAVECOMMENT' + print,' MISSING =, /NULL' + return + endif + +; Define a blank line and the END line + + ENDLINE = 'END' +string(replicate(32b,77)) ;END line + BLANK = string(replicate(32b,80)) ;BLANK line +; +; If Location parameter not defined, set it equal to 'END ' +; + if ( N_params() GT 4 ) then loc = strupcase(location) else $ + if N_elements( BEFORE) GT 0 then loc = strupcase(before) else $ + if N_elements( AFTER) GT 0 then loc = strupcase(after) else $ + if N_elements( PDU) GT 0 then loc = 'BEGIN EX' else $ + loc = 'END' + + while strlen(loc) lt 8 do loc += ' ' + + if N_params() lt 4 then comment = '' ;Is comment field specified? + + n = N_elements(header) ;# of lines in FITS header + if (n EQ 0) then begin ;header defined? + header=strarr(10) ;no, make it. + header[0]=ENDLINE + n=10 + endif else begin + s = size(header) ;check for string type + if (s[0] ne 1) || (s[2] ne 7) then $ + message,'FITS Header (first parameter) must be a string array' + endelse + +; Make sure Name is 8 characters long + + nn = string(replicate(32b,8)) ;8 char name + strput,nn,strupcase(name) ;insert name +; +; Check to see if the parameter should be saved as a null value. +; + stype = size(value,/type) + save_as_null = 0 + if stype EQ 0 then begin + if (n_elements(missing) eq 1) || keyword_set(null) then $ + save_as_null = 1 else $ + message,'Keyword value (third parameter) is not defined' + endif else if (stype NE 6) && (stype NE 7) && (stype NE 9) then begin + if N_elements(missing) eq 1 then $ + if value eq missing then save_as_null = 1 + if ~save_as_null then if ~finite(value) then begin + if ((n_elements(missing) eq 1) || keyword_set(null)) then $ + save_as_null = 1 else $ + message,'Keyword value (third parameter) is not finite' + endif + endif +; +; Extract first 8 characters of each line of header, and locate END line + + keywrd = strmid(header,0,8) ;Header keywords + iend = where(keywrd eq 'END ',nfound) +; +; If no END, then add it. Either put it after the last non-null string, or +; append it to the end. +; + if nfound EQ 0 then begin + ii = where(strtrim(header) ne '',nfound) + ii = max(ii) + 1 + if ii eq n_elements(header) then begin + header = [header,endline] + n++ + endif else header[ii] = endline + keywrd = strmid(header,0,8) + iend = where(keywrd eq 'END ',nfound) + endif +; + iend = iend[0] > 0 ;make scalar + +; History, comment and "blank" records are treated differently from the +; others. They are simply added to the header array whether there are any +; already there or not. + + if (nn EQ 'HISTORY ') || (nn EQ 'COMMENT ') || $ + (nn EQ ' ') then begin ;add history record? +; +; If the header array needs to grow, then expand it in increments of 5 lines. +; + + if iend GE (n-1) then begin + header = [header,replicate(blank,5)] ;yes, add 5. + n = N_elements(header) + endif + +; Format the record + + newline = blank + strput,newline,nn+string(value),0 + +; +; If a history record, then append to the record just before the end. +; + if nn EQ 'HISTORY ' then begin + header[iend] = newline ;add history rec. + header[iend+1] = endline +; +; The comment record is placed immediately after the last previous comment +; record, or immediately before the first history record, unless overridden by +; either the BEFORE or AFTER keywords. +; + endif else if nn EQ 'COMMENT ' then begin + if loc EQ 'END ' then loc = 'COMMENT ' + iloc = where(keywrd EQ loc, nloc) + if nloc EQ 0 then iloc = where(keywrd EQ 'HISTORY ', nloc) + if nloc gt 0 then begin + i = iloc[nloc-1] + if keyword_set(after) or (loc EQ 'COMMENT ') then i = i+1 < iend + if i gt 0 then header=[header[0:i-1],newline,header[i:n-1]] $ + else header=[newline,header[0:n-1]] + endif else begin + header[iend] = newline + header[iend+1] = endline + endelse + +; +; The "blank" record is placed immediately after the last previous "blank" +; record, or immediately before the first comment or history record, unless +; overridden by either the BEFORE or AFTER keywords. +; + ENDIF ELSE BEGIN + if loc EQ 'END ' then loc = ' ' + iloc = where(keywrd[0:iend] EQ loc, nloc) + if nloc gt 0 then begin + i = iloc[0] + if keyword_set(after) and loc ne 'HISTORY ' then i = i+1 < iend + if i gt 0 then header=[header[0:i-1],newline,header[i:n-1]] $ + else header=[newline,header[0:n-1]] + endif else begin + iloc = where(keywrd EQ 'COMMENT ', nloc) + if nloc Eq 0 then iloc = where(keywrd EQ 'HISTORY ', nloc) + if nloc GT 0 then begin + i = iloc[0] + if i gt 0 then header=[header[0:i-1],newline,header[i:n-1]] $ + else header=[newline,header[0:n-1]] + endif else begin + header[iend] = newline + header[iend+1] = endline + endelse + endelse + endelse + RETURN + endif + +; Find location to insert keyword. Save the existing comment if user did +; not supply a new one. Comment starts after column 32 for numeric data, +; after the slash (but at least after final quote) for string data. + + ncomment = comment + ipos = where(keywrd eq nn,nfound) + if nfound gt 0 then begin + i = ipos[nfound-1] + if comment eq '' or keyword_set(savecom) then begin ;save comment? + if strmid(header[i],10,1) NE "'" then $ + ncomment=strmid(header[i],32,48) else begin + quote = strpos(header[i],"'",11) + + if quote EQ -1 then slash = -1 else $ + slash = strpos(header[i],'/',quote) + if slash NE -1 then $ + ncomment = strmid(header[i], slash+1, 80) else $ + ncomment = string(replicate(32B,80)) + endelse + endif + goto, REPLACE + endif + + if loc ne '' then begin + iloc = where(keywrd eq loc,nloc) + if nloc gt 0 then begin + i = iloc[0] + if keyword_set(after) && (loc ne 'HISTORY ') then i = i+1 < iend + if i gt 0 then header=[header[0:i-1],blank,header[i:n-1]] $ + else header=[blank,header[0:n-1]] + goto, REPLACE + endif + endif + +; At this point keyword and location parameters were not found, so a new +; line is added at the end of the FITS header + + if iend lt (n-1) then begin ;Not found, add more? + header[iend+1] = ENDLINE ;no, already long enough. + i = iend ;position to add. + endif else begin ;must lengthen. + header = [header,replicate(blank,5)] ;add an element on the end + header[n]=ENDLINE ;save "END" + i =n-1 ;add to end + end + +; Now put value into keyword at line i + +REPLACE: + h=blank ;80 blanks + strput,h,nn+'= ' ;insert name and =. + apost = "'" ;quote a quote + type = size(value) ;get type of value parameter + if type[0] ne 0 then $ + message,'Keyword Value (third parameter) must be scalar' + + case type[1] of ;which type? + +7: begin + upval = strupcase(value) ;force upper case. + if (upval eq 'T') || (upval eq 'F') then begin + strput,h,upval,29 ;insert logical value. + end else begin ;other string? + if strlen(value) gt 18 then begin ;long string + strput, h, apost + strmid(value,0,68) + apost + $ + ' /' + ncomment,10 + header[i] = h + return + endif + strput, h, apost + value,10 ;insert string val + strput, h, apost, 11 + (strlen(value)>8) ;pad string vals + endelse ;to at least 8 chars + endcase + +5: BEGIN + IF (N_ELEMENTS(format) EQ 1) THEN $ ; use format keyword + v = string(value, FORMAT='('+strupcase(format)+')') $ + ELSE v = STRING(value, FORMAT='(G19.12)') + s = strlen(v) ; right justify + strput, h, v, (30-s)>10 + END + + else: begin + if ~save_as_null then begin + if (N_elements(format) eq 1) then $ ;use format keyword + v = string(value, FORMAT='('+strupcase(format)+')' ) else $ + v = strtrim(strupcase(value),2) + ;convert to string, default format + s = strlen(v) ;right justify + strput,h,v,(30-s)>10 ;insert + endif + end + endcase + + if (~save_as_null) || (strlen(strtrim(comment)) GT 0) then begin + strput,h,' /',30 ;add ' /' + strput, h, ncomment, 32 ;add comment + endif + header[i] = h ;save line + + return + end diff --git a/modules/idl_downloads/astro/pro/sxdelpar.pro b/modules/idl_downloads/astro/pro/sxdelpar.pro new file mode 100644 index 0000000..2cd73a5 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxdelpar.pro @@ -0,0 +1,69 @@ +pro sxdelpar, h, parname +;+ +; NAME: +; SXDELPAR +; PURPOSE: +; Procedure to delete a keyword parameter(s) from a FITS header +; +; CALLING SEQUENCE: +; sxdelpar, h, parname +; +; INPUTS: +; h - FITS or STSDAS header, string array +; parname - string or string array of keyword name(s) to delete +; +; OUTPUTS: +; h - updated FITS header, If all lines are deleted from +; the header, then h is returned with a value of 0 +; +; EXAMPLE: +; Delete the astrometry keywords CDn_n from a FITS header, h +; +; IDL> sxdelpar, h, ['CD1_1','CD1_2','CD2_1','CD2_2'] +; +; NOTES: +; (1) No message is returned if the keyword to be deleted is not found +; (2) All appearances of a keyword in the header will be deleted +; HISTORY: +; version 1 D. Lindler Feb. 1987 +; Test for case where all keywords are deleted W. Landsman Aug 1995 +; Allow for headers with more than 32767 lines W. Landsman Jan. 2003 +; Use ARRAY_EQUAL, cleaner syntax W. L. July 2009 +;------------------------------------------------------------------ + On_error,2 + compile_opt idl2 + + if N_Params() LT 2 then begin + print,'Syntax - SXDELPAR, h, parname' + return + endif + +; convert parameters to string array of upper case names of length 8 char + + + if size(parname,/type) NE 7 then $ + message,'Keyword name(s) must be a string or string array' + par = strtrim( strupcase(parname),2 ) + + sz = size(h,/structure) + if (sz.N_dimensions NE 1) || (sz.type NE 7) then $ + message,'FITS header (1st parameter) must be a string array' + + nlines = sz.N_elements ;number of lines in header array + pos = 0L ;position in compressed header with keywords removed + +; loop on header lines + + keyword = strtrim( strmid(h,0,8), 2 ) + for i = 0L, nlines-1 do begin + if array_equal(keyword[i] NE par, 1b) then begin + h[pos] = h[i] ;keep it + pos++ ;increment number of lines kept + if keyword[i] eq 'END' then break ;end of header + endif + endfor + + if pos GT 0 then h = h[0:pos-1] else h = 0 ;truncate + + return + end diff --git a/modules/idl_downloads/astro/pro/sxginfo.pro b/modules/idl_downloads/astro/pro/sxginfo.pro new file mode 100644 index 0000000..e12ae35 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxginfo.pro @@ -0,0 +1,126 @@ +pro sxginfo,h,par,type,sbyte,nbytes +;+ +; NAME: +; SXGINFO +; +; PURPOSE: +; Return information on all group parameters in an STSDAS header. +; EXPLANATION: +; Return datatype, starting byte, and number bytes for all group +; parameters in an STSDAS file. Obtaining these values +; greatly speed up execution time in subsequent calls to SXGPAR. +; +; CALLING SEQUENCE: +; sxginfo, h, par, type, sbyte, nbytes +; +; INPUTS: +; h - header returned by SXOPEN +; par - parameter block returned by SXREAD or multiple +; parameter blocks stored in array of dimension +; greater than one. +; +; OUTPUT: +; type - data type (if not supplied or null string, the +; header is searched for type,sbyte, and nbytes) +; sbyte - starting byte in parameter block for data +; nbytes - number of bytes in parameter block for data +; +; The number of elements in type,sbyte and nbytes equals the total +; number of group parameters. +; +; METHOD: +; The parameter type for each parameter is obtained +; from PDTYPEn keyword. If not found then DATATYPE keyword +; value is used. If that is not found then BITPIX is +; used. BITPIX=8, byte; BITPIX=16 integer*2; BITPIX=32 +; integer*4. +; +; NOTES: +; For an example of the use of SXGINFO, see CONV_STSDAS +; +; HISTORY: +; version 1 W. Landsman Apr. 93 +; +; Converted to IDL V5.0 W. Landsman September 1997 +;------------------------------------------------------------ + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - sxginfo,h,par,type,sbyte,nbytes' + return + endif + +; determine size of output result + + s = size(par) + ndim = s[0] + dtype = s[ndim+1] + case 1 of + (ndim eq 0) or (dtype ne 1) : message, $ + 'Invalid parameter block specified' + + ndim eq 1 : begin + scalar = 1 ; output will be scalar + dimen = intarr(1)+1 + end + else: begin + scalar = 0 ; output will be vector + dimen = s[2:ndim] + end + endcase + plen = s[1] ;length of parameter blocks +; +; check remaining input parameters +; + s=size(h) + !err=-1 + if (s[0] ne 1) or (s[2] ne 7) then message, $ + 'Header array must be string array' + + if strlen(h[0]) ne 80 then message, $ + 'Header must contain 80 character strings' +; +; get number of group parameters and size +; +; + pcount = sxpar(h,'PCOUNT') ;get number of group parameters + if pcount eq 0 then begin + message,'No group parameters present',/INFO + return + endif + + sbyte = intarr(pcount) + nbytes = intarr(pcount) + type = strarr(pcount) + +; Determine BITPIX and DATATYPE in case PSIZE or PDTYPE is undefined + + nbits=0 ;number of bits to skip + dtype = strtrim(sxpar(h, 'DATATYPE') ) + bitpix = sxpar(h,'BITPIX') + if !err lt 0 then begin + case bitpix of + 8: dtype = 'BYTE' + 16: dtype = 'INTEGER*2' + 32: dtype = 'INTEGER*4' + -32: dtype = 'REAL*4' + -64: dtype = 'REAL*8' + endcase + endif + + for i = 1,pcount do begin + nbit = sxpar(h,'PSIZE'+strtrim(i,2)) + if !err lt 0 then nbit = bitpix + nbits=nbits+nbit + if i NE pcount then sbyte[i]=nbits/8 ;number of bytes to skip + pdtype = strtrim(sxpar(h,'PDTYPE' + strtrim(i,2))) + if !ERR LT 0 then pdtype = dtype + type[i-1] = pdtype + aster = strpos(pdtype,'*') + if aster gt 0 then $ + nbytes[i-1]=fix(strmid(pdtype,aster+1,strlen(pdtype)-aster-1)) $ + else nbytes[i-1]=4 + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/sxgpar.pro b/modules/idl_downloads/astro/pro/sxgpar.pro new file mode 100644 index 0000000..0c2f10d --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxgpar.pro @@ -0,0 +1,228 @@ +function sxgpar,h,par,name,type,sbyte,nbytes +; +;+ +; NAME: +; SXGPAR +; +; PURPOSE: +; Obtain group parameter value in SDAS/FITS file +; +; CALLING SEQUENCE: +; result = sxgpar( h, par, name, [ type, sbyte, nbytes] ) +; +; INPUTS: +; h - header returned by SXOPEN +; par - parameter block returned by SXREAD or multiple +; parameter blocks stored in array of dimension +; greater than one. +; name - parameter name (keyword PTYPEn) or integer +; parameter number. +; +; OPTIONAL INPUT/OUTPUT +; type - data type (if not supplied or null string, the +; header is searched for type,sbyte, and nbytes) +; sbyte - starting byte in parameter block for data +; nbytes - number of bytes in parameter block for data +; +; OUTPUT: +; parameter value or value(s) returned as function value +; +; SIDE EFFECTS: +; If an error occured then !err is set to -1 +; +; OPERATIONAL NOTES: +; Supplying type, sbyte and nbytes greatly decreases execution +; time. The best way to get the types is on the first call +; pass undefined variables for the three parameters or set +; type = ''. The routine will then return their values for +; use in subsequent calls. +; +; METHOD: +; The parameter type for parameter n is obtained +; from PDTYPEn keyword. If not found then DATATYPE keyword +; value is used. If that is not found then BITPIX is +; used. BITPIX=8, byte; BITPIX=16 integer*2; BITPIX=32 +; integer*4. +; +; HISTORY: +; version 1 D. Lindler Oct. 86 +; version 2 D. Lindler Jan. 90 added ability to process +; multiple parameter blocks in single call +; version 3 D. Lindler (converted to New vaxidl) +; Apr 14 1991 JKF/ACC - fixed make_array datatypes(float/double) +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;------------------------------------------------------------ + On_error,2 + + if N_params() lt 3 then $ + message,'Syntax - result = sxgpar( h, par, name, [ type, sbyte, nbytes ])' +; +; determine size of output result +; + s = size(par) + ndim = s[0] + dtype = s[ndim+1] + case 1 of + (ndim eq 0) or (dtype ne 1) : begin + print,'SXGPAR - invalid parameter block specified' + return,0 + end + ndim eq 1 : begin + scalar = 1 ; output will be scalar + dimen = intarr(1)+1 + end + else: begin + scalar = 0 ; output will be vector + dimen = s[2:ndim] + end + endcase + plen = s[1] ;length of parameter blocks +; +; check if type, sbyte and nbytes supplied +; + if n_elements(type) ne 0 then if strtrim(type) ne '' then goto,bypass +; +; check remaining input parameters +; + s=size(h) + !err=-1 + if (s[0] ne 1) or (s[2] ne 7) then begin + print,'SXGPAR -- Header array must be string array' + return,0 + end + if strlen(h[0]) ne 80 then begin + print,'SXGPAR -- header must contain 80 character strings' + return,0 + end +; + if n_elements(name) eq 0 then begin + print,'SXGPAR -- parameter name must be a scalar' + return,0 + endif +; +; get number of group parameters and size +; +; + pcount=sxpar(h,'PCOUNT') ;get number of group parameters + if pcount eq 0 then begin + print,'sxgpar -- No group parameters present' + return,0 + endif + psize=sxpar(h,'PSIZE') ;number of bits in parameter block + if psize eq 0 then psize=sxpar(h,'BITPIX')*pcount +; +; determine if name supplied or parameter number +; + s=size(name) + if s[1] eq 7 then begin ;is it a string? + nam=strtrim(strupcase(name)) ;convert to upper case and trim +; +; search for parameter name +; + for i=1,pcount do begin + if strtrim(sxpar(h,'PTYPE'+strtrim(i,2))) eq nam then $ + goto,found + endfor + !err=-1 + print,'SXGPAR -- group parameter ',name,' not found' + return,0 +found: + ipar=i + end else begin ;integer + ipar=fix(name) + if ipar gt pcount then begin + !err=-1 + print,'SXGPAR -- parameter number',name,' is too large' + print,' -- only ',pcount,' group parameters' + return,0 + endif + endelse +; +; find starting position of parameter in parameter block +; + nbits=0 ;number of bits to skip + if ipar gt 1 then begin + for i=1,ipar-1 do begin + nbit=sxpar(h,'PSIZE'+strtrim(i,2)) + if !err lt 0 then nbit=sxpar(h,'bitpix') + nbits=nbits+nbit + endfor + endif + sbyte=nbits/8 ;number of bytes to skip +; +; determine type of output data +; + charn=strtrim(ipar,2) ;convert ipar to string + type=strtrim(sxpar(h,'pdtype'+charn)) + if !err lt 0 then type=strtrim(sxpar(h,'datatype')) + if !err lt 0 then begin + case sxpar(h,'bitpix') of + 8: type = 'BYTE' + 16: type = 'INTEGER*2' + 32: type = 'INTEGER*4' + -32: type = 'REAL*4' + endcase + endif +; +; get number of bytes from type +; + aster=strpos(type,'*') + if aster gt 0 then $ + nbytes=fix(strmid(type,aster+1,strlen(type)-aster-1)) $ + else nbytes=4 + +BYPASS: +;------------------------------------------------------------- +; +; get first character of type +; + c=strupcase(strmid(type,0,1)) +; +; create output vector +; + if c eq 'L' then c = 'I' ;change LOGICAL to INTEGER + case c of + 'R' : if nbytes eq 8 then $ + val = make_array(dimension=dimen,/double) $ + else val = make_array(dimension=dimen,/float) + 'I' : case nbytes of + 1: val=make_array(dimension=dimen,/byte) + 2: val=make_array(dimension=dimen,/int) + 4: val=make_array(dimension=dimen,/long) + endcase + 'B' : val = make_array(dimension=dimen,/byte) + 'C' : val = make_array(dimension=dimen,/string) + else: begin + print,'sxgpar -- unsupported group parameter data type' + !err=-1 + return,0 + end + endcase + nval = n_elements(val) +; +; extract data +; + for i=0,nval-1 do begin + ssbyte = sbyte + plen*i + case c of + 'R' : begin + if nbytes eq 4 then val[i]=float(par,ssbyte) + if nbytes eq 8 then val[i]=double(par,ssbyte) + end + 'I' : begin + if nbytes eq 1 then val[i]=byte(par,ssbyte) + if nbytes eq 2 then val[i]=fix(par,ssbyte) + if nbytes eq 4 then val[i]=long(par,ssbyte) + end + 'B' :val=byte(par,ssbyte,1) + 'C' : begin + val[i]=string(byte(par,ssbyte,nbytes)) + end + endcase + endfor +; + if scalar then val=val[0] + !err=0 + return,val +end diff --git a/modules/idl_downloads/astro/pro/sxgread.pro b/modules/idl_downloads/astro/pro/sxgread.pro new file mode 100644 index 0000000..48de936 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxgread.pro @@ -0,0 +1,55 @@ +function sxgread,unit,group +;+ +; NAME: +; SXGREAD +; PURPOSE: +; Read group parameters from a Space Telescope STSDAS image file +; +; CALLING SEQUENCE: +; grouppar = sxgread( unit, group ) +; +; INPUTS: +; UNIT = Supply same unit as used in SXOPEN. +; GROUP = group number to read. if omitted, read first group. +; The first group is number 0. +; +; OUTPUTS: +; GROUPPAR = parameter values from fits group parameter block. +; It is a byte array which may contain multiple data types. +; The function SXGPAR can be used to retrieve values from it. +; +; COMMON BLOCKS: +; Uses IDL Common STCOMMN to access parameters. +; SIDE EFFECTS: +; IO is performed. +; MODIFICATION HISTORY: +; WRITTEN, Don Lindler, July, 1 1987 +; MODIFIED, Don Neill, Jan 11, 1991 - derived from sxread.pro +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 +; +; common block containing description of file (see SXOPEN) +; + common stcommn,result,filename +; +; check if unit open +; + if (unit lt 1) or (unit gt 9) then $ + message,'Invalid unit number, must be between 1 and 9' + if N_elements(result) eq 0 then result = 0 + if (N_elements(result) ne 200) or (result[0,unit] ne 121147) then $ + message,'Specified unit is not open' + desc = result[*,unit] ;description for unit +; +; default group number is 0 (first group) +; + if N_params() eq 1 then group = 0 +; +; read group parameters +; + parrec = assoc(UNIT,bytarr(desc[7]),(group+1)*desc[9]-desc[7]) + par = parrec[0] +; + return,par + end diff --git a/modules/idl_downloads/astro/pro/sxhcopy.pro b/modules/idl_downloads/astro/pro/sxhcopy.pro new file mode 100644 index 0000000..e0736c3 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxhcopy.pro @@ -0,0 +1,85 @@ +pro sxhcopy, h, keyword1, keyword2, hout +;+ +; NAME: +; SXHCOPY +; PURPOSE: +; Copies selected portions of one header to another +; +; CALLING SEQUENCE: +; sxhcopy, h, keyword1, keyword2, hout +; +; INPUTS: +; h - input header +; keyword1 - first keyword to copy +; keyword2 - last keyword to copy +; +; INPUT/OUTPUT: +; hout - header to copy the information to. +; +; METHOD: +; the headers lines from keyword1 to keyword2 are copied to +; the end of the output header. No check is made to verify +; that a keyword value already exists in the output header. +; +; HISTORY: +; version 1 D. Lindler Sept. 1989 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;-------------------------------------------------------------------------- +; +; make keywords 8 characters long (upper case) +; + key1 = strmid(strupcase(keyword1+' '),0,8) + key2 = strmid(strupcase(keyword2+' '),0,8) +; +; get header lengths +; + n = n_elements(h) + nout = n_elements(hout) +; +; find position of first keyword in h +; + i1 = 0 + + while i1 lt n do begin + key = strmid(h[i1],0,8) + if key1 eq key then goto,found1 + if key eq 'END ' then begin + print,'SXHCOPY -- keyword '+key1+' not found in header.' + print,' Nothing copied to output header.' + return + endif + i1 = i1+1 + endwhile +found1: +; +; find position of second keyword +; + i2 = i1 + while i2 lt n do begin + key = strmid(h[i2],0,8) + if key eq 'END ' then begin + i2 = i2-1 ;do not copy 'END ' + goto,found2 + endif + if key2 eq key then goto,found2 + i2 = i2+1 + endwhile +found2: +; +; find end of output header +; + i = 0 + while i lt nout do begin + if strmid(hout[i],0,8) eq 'END ' then goto,found + i = i+1 + endwhile + message,'No END keyword found in output header' +found: +; +; create new output header +; + if i gt 0 then hout=[hout[0:i-1],h[i1:i2],hout[i]] $ + else hout=[h[i1:i2],hout[i]] +return +end diff --git a/modules/idl_downloads/astro/pro/sxhmake.pro b/modules/idl_downloads/astro/pro/sxhmake.pro new file mode 100644 index 0000000..e45675f --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxhmake.pro @@ -0,0 +1,76 @@ +Pro sxhmake,data,groups,header +;+ +; NAME: +; SXHMAKE +; PURPOSE: +; Create a basic STSDAS header file from an IDL data array +; +; CALLING SEQUENCE: +; sxhmake, Data, Groups, Header +; +; INPUTS: +; Data = IDL data array of the same type, dimensions and +; size as are to be written to file. +; Groups = # of groups to be written. +; +; OUTPUTS: +; Header = String array containing ST header file. +; +; PROCEDURE: +; Call sxhmake to create a header file. Then call sxopen to +; open output image, followed by sxwrite to write the data. +; If you do not plan to change the header created by sxhmake +; before calling sxopen, you might consider using sxmake which +; does both steps. +; +; MODIFICATION HISTORY: +; Don Lindler Feb 1990 modified from SXMAKE by DMS, July, 1983. +; D. Lindler April 90 Converted to new VMS IDL +; M. Greason May 1990 Header creation bugs eliminated. +; W. Landsman Aug 1997 Use SYSTIME() instead of !STIME for V5.0 +; Converted to IDL V5.0 W. Landsman September 1997 +; Recognize unsigned datatype January 2000 W. Landsman +;- +;----------------------------------------------------------------------------- + On_error,2 + if N_Params() LT 3 then begin + print,'Syntax - sxhmake, Data, Groups, Header' + return + endif + + s = size(data) ;obtain size of array. + stype = s[s[0]+1] ;type of data. + if (groups eq 0) and (stype LT 6) then $ + sxaddpar,header,'simple','T','Written by IDL: '+ systime() $ + else $ + sxaddpar,header,'simple','F','Written by IDL: '+ systime() + + case stype of +0: message,'Data parameter is not defined' +7: message,"Can't write strings to ST files' +1: begin& bitpix= 8 & d='INTEGER*1' & endcase +2: begin& bitpix= 16 & d = 'INTEGER*2' & endcase +4: begin& bitpix= 32 & d='REAL*4' & endcase +3: begin& bitpix= 32 & d='INTEGER*4' & endcase +5: begin& bitpix= 64 & d='REAL*8' & endcase +6: begin& bitpix= 64 & d='COMPLEX*8' & endcase +12: begin & bitpix=16 & d='UNSIGNED*2' & endcase +13: begin & bitpix=32 & d='UNSIGNED*4' & endcase +else: message,'ERROR -- Unrecoginized input data type' + endcase + sxaddpar,header,'BITPIX',bitpix + sxaddpar,header,'NAXIS',S[0] ;# of dimensions + for i=1,s[0] do sxaddpar,header,'NAXIS'+strtrim(i,2),s[i] + sxaddpar,header,'DATATYPE',d,'Type of data' + Get_date,dte ;Get current date as CCYY-MM-DD + sxaddpar,header,'DATE',dte + if groups eq 0 then $ ;true if not group fmt. + sxaddpar,header,'GROUPS','F','No groups' $ + else begin ;make group params. + sxaddpar,header,'GROUPS','T' + sxaddpar,header,'PCOUNT',0 + sxaddpar,header,'GCOUNT',groups + sxaddpar,header,'PSIZE',0,'# of bits in parm blk' + endelse + return +end diff --git a/modules/idl_downloads/astro/pro/sxhread.pro b/modules/idl_downloads/astro/pro/sxhread.pro new file mode 100644 index 0000000..43e1869 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxhread.pro @@ -0,0 +1,120 @@ +pro sxhread, name, header +;+ +; NAME: +; SXHREAD +; PURPOSE: +; Procedure to read a STSDAS header from disk. +; EXPLANATION: +; This version of SXHREAD can read two types of disk files +; (1) Unix stream files with a CR after every 80 bytes +; (2) Variable length record files +; (3) Fixed length (80 byte) record files +; +; CALLING SEQUENCE: +; sxhread, name, header +; +; INPUT: +; name - file name, scalar string. An extension of .hhh is appended +; if not already supplied. (Note STSDAS headers are required +; to have a 3 letter extension ending in 'h'.) gzip extensions +; .gz will be recognized as compressed. +; OUTPUT: +; header - STSDAS header, string array +; NOTES: +; SXHREAD does not do any checking to see if the file is a valid +; STSDAS header. It simply reads the file into a string array with +; 80 byte elements +; +; HISTORY: +; Version 1 D. Lindler July, 1987 +; Version 2 M. Greason, August 1990 +; Use READU for certain ST VAX GEIS files W. Landsman January, 1992 +; Read variable length Unix files E. Deutsch/W. Landsman November, 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated by E. Artigau to handle gzipped fits August 2004 +; Remove VMS support, W. Lnadsman September 2006 +;- +;-------------------------------------------------------------------- + compile_opt idl2 + On_error,2 ;Return to caller + + if N_params() LT 2 then begin + print,'Syntax - SXHREAD, name, header' + return + endif + +; Add extension name if needed + + hname = strtrim(name,2) + if strpos(hname,'.',strpos(hname,']') ) EQ -1 then hname = hname + '.hhh' + compress = (strmid(name,strlen(name)-2,2) eq 'gz') + openr, unit, hname, /GET_LUN, ERROR = err,COMPRESS = compress + + if err LT 0 then goto, BADFILE + + len = 80 & ai = 99 ;Usual header length is 80 bytes + ;but Unix files may have an + ;embedded carriage returns to make + atmp = assoc(unit,bytarr(85)) ;header length 81 bytes + a=atmp[0] & ai=0 + while (a[ai] ne 10) and (a[ai] ne 13) and (ai lt 84) do ai=ai+1 + if (ai EQ 80) then len=81 + Point_lun, unit, 0 ;Back to the beginning of the file + + + +; Get the number of lines in the header + + status = fstat(unit) + nlines = status.size/len ;Number of lines in file + if (ai lt 80) then goto,VAR_LENGTH + +; Read header + + header = bytarr(len,nlines ,/NOZERO) + On_ioerror, VAR_LENGTH ;READU cannot be used on variable length records + readu, unit, header + header = string(header) + On_ioerror,NULL + + free_lun,unit ;Close and free file unit + +; Trim to the END line, and delete carriage returns if necessary + + endline = where( strmid(header,0,8) EQ 'END ',nfound) + if nfound gt 0 then header = header[0:endline[0]] else $ + message,'WARNING: No END statement found in header',/inform + if len EQ 81 then header = strmid(header,0,80) + return + +VAR_LENGTH: ;Now try to read as variable length records + + Point_lun, unit, 0 ;Back to the beginning of file + h = '' & header = strarr( nlines) + i = 0 + + On_ioerror,NOEND ;Can't use EOF function on certain GEIS files + while ( strtrim( strmid(h,0,8), 2) NE 'END') do begin + readf, unit, h + if (strlen(h) LT 80) then h=h+string(replicate(32b,80-strlen(h))) + header[i] = h ;Swapped with line above 95-Aug + i = i + 1 + if i EQ nlines then begin + header = [header,strarr(100)] + nlines = nlines + 100 + endif + endwhile + header = header[0:i-1] + free_lun,unit + return + +NOEND: + message,'WARNING - No END statement found in header', /INFORM + free_lun,unit + return + +BADFILE: + message,'Error opening file ' + ' ' + hname + return + +end diff --git a/modules/idl_downloads/astro/pro/sxhwrite.pro b/modules/idl_downloads/astro/pro/sxhwrite.pro new file mode 100644 index 0000000..0ad4848 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxhwrite.pro @@ -0,0 +1,95 @@ +pro sxhwrite,name,h +;+ +; NAME: +; SXHWRITE +; PURPOSE: +; Procedure to write an STSDAS or FITS header to disk as a *.hhh file. +; +; CALLING SEQUENCE: +; SXHWRITE,name,h +; +; INPUTS: +; name - file name. If an extension is supplied it must be 3 characters +; ending in "h". +; h - FITS header, string array +; +; SIDE EFFECTS: +; File with specified name is written. If qualifier not specified +; then .hhh is used +; +; SXHWRITE will modify the header in the following ways, if necessary +; (1) If not already present, an END statement is added as the +; last line. Lines after an existing END statment are +; deleted. +; (2) Spaces are appended to force each line to be 80 characters. +; (3) On Unix machines, a carriage return is appended at the end +; of each line. This is consistent with STSDAS and allows +; the file to be directly displayed on a stream device +; +; PROCEDURES USED: +; zparcheck, fdecomp +; HISTORY: +; version 1 D. Lindler June 1987 +; conversion cleaned up. M. Greason, June 1990 +; Add carriage return at the end of Unix files W. Landsman Oct 1991 +; Use SYSTIME() instead of !STIME for V5.0 compatibility Aug 1997 +; Assume since V55, remove VMS support +;- +;---------------------------------------------------------------- + compile_opt idl2 + On_error,2 + if N_params() LT 2 then begin + print,'Syntax - SXHWRITE, name, hdr' + return + endif + +; Create output file name + + ZPARCHECK, 'SXHWRITE', name, 1, 7, 0, 'Disk file name' ;Check for valid param + FDECOMP,name, disk, dir, file, qual + if ( qual EQ '' ) then qual = 'hhh' ;default qualifier + +; Check for valid qualifier + + if ( strlen(qual) NE 3 ) || ( strupcase(strmid(qual,2,1)) NE 'H' ) then $ + message,'Qualifier on file name must be 3 characters, ending in h' + + hname = disk + dir + file + '.' + qual ;header file name + +; Check that valid FITS header was supplied + + ZPARCHECK, 'SXHWRITE', h, 2, 7, 1, 'FITS header' + + sxdelpar,'XTENSION',h ;For SDAS header SIMPLE must be the first line + SXADDPAR, h, 'SIMPLE', 'F', ' Written by IDL: ' + systime() + +; Determine if an END line occurs, and add one if necessary + + endline = where( strtrim( strmid(h,0,8), 2) EQ 'END', Nend) + if Nend EQ 0 then begin + + message, /INF, $ + 'WARNING - An END statement has been appended to the FITS header' + h = [ h, 'END' + string( replicate(32b,77) ) ] + endline = N_elements(h) - 1 + + endif + nmax = endline[0] + 1 + +; Convert to byte and force into 80 character lines + + temp = replicate( 32b, 80, nmax) + for n = 0, endline[0] do temp[0,n] = byte( h[n] ) + +; Under Unix append a carriage return ( = string(10b) ) + + temp = [ temp, rotate( replicate(10b,nmax), 1 ) ] + +; Open the output file and write as byte array. + + openw, unit, hname, 80, /GET_LUN + writeu, unit, temp + free_lun,unit + + return + end diff --git a/modules/idl_downloads/astro/pro/sxmake.pro b/modules/idl_downloads/astro/pro/sxmake.pro new file mode 100644 index 0000000..54fc315 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxmake.pro @@ -0,0 +1,128 @@ +Pro sxmake, unit, File, Data, Par, Groups, Header, PSIZE = psize +;+ +; NAME: +; SXMAKE +; PURPOSE: +; Create a basic ST header file from an IDL array prior to writing data. +; +; CALLING SEQUENCE: +; sxmake, Unit, File, Data, Par, Groups, Header, [ PSIZE = ] +; +; INPUTS: +; Unit = Logical unit number from 1 to 9. +; File = file name of data and header files to create. If no file name +; extension is supplied then the default is to use .hhh for the +; header file extension and .hhd for the data file extension +; If an extension is supplied, it should be of the form .xxh +; where xx are any alphanumeric characters. +; Data = IDL data array of the same type, dimensions and +; size as are to be written to file. +; Par = # of elements in each parameter block for each data record. If +; set equal to 0, then parameter blocks will not be written. The +; data type of the parameter blocks must be the same as the data +; array. To get around this restriction, use the PSIZE keyword. +; Groups = # of groups to write. If 0 then write in basic +; format without groups. +; +; OPTIONAL INPUT PARAMETERS: +; Header = String array containing ST header file. If this +; parameter is omitted, a basic header is constructed. +; If included, the basic parameters are added to the +; header using sxaddpar. The END keyword must terminate +; the parameters in Header. +; +; OPTIONAL KEYWORD INPUT PARAMETER: +; PSIZE - Integer scalar giving the number of bits in the parameter +; block. If the PSIZE keyword is given, then the Par input +; parameter is ignored. +; +; OPTIONAL OUTPUT PARAMETERS: +; Header = ST header array, an 80 by N character array. +; +; COMMON BLOCKS: +; Stcommn - as used in sxwrite, sxopen, etc. +; +; SIDE EFFECTS: +; The header file is created and written and then the +; data file is opened on the designated unit. +; +; RESTRICTIONS: +; Header files must be named .xxh and data files must be +; named .xxd, where xx are any alphanumeric characters. +; +; PROCEDURE: +; Call sxmake to create a header file. Then call sxwrite +; to output each group. +; +; PROCEDURES USED: +; GET_DATE, SXADDPAR, SXOPEN +; MODIFICATION HISTORY: +; DMS, July, 1983. +; converted to new VMS IDL April 90 +; Use SYSTIME() instead of !STIME W. Landsman Aug 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added optional PSIZE keyword August 1999 W. Landsman +; Recognize unsigned datatype January 2000 W. Landsman +;- + common stcommn, result, filename +; + if N_params() LT 2 then begin + print,'Syntax - SXMAKE,unit,file,data,par,groups,header, [PSIZE = ]' + return + endif +; + if N_elements(result) ne 200 then begin + result = lonarr(20,10) ;define common blks + filename = strarr(10) + endif +; + if (unit lt 1) or (unit gt 9) then $ ;unit ok? + message,'Unit number must be from 1 to 9.' +; + close,unit + result[unit,*]=0 +; + if N_elements(par) EQ 0 then par = 0 + if N_elements(groups) EQ 0 then groups = 0 +; + s = size(data) ;obtain size of array. + stype = s[s[0]+1] ;type of data. + if (par eq 0) and (groups eq 0) and (stype LT 6) then $ + sxaddpar,header,'simple','T','Written by IDL: '+ systime() $ + else $ + sxaddpar,header,'simple','F','Written by IDL: '+ systime() + case stype of +0: message,'Data parameter is not defined' +7: message,"Can't write strings to ST files" +1: begin& bitpix= 8 & d = 'INTEGER*1' & endcase +2: begin& bitpix= 16 & d = 'INTEGER*2' & endcase +4: begin& bitpix= 32 & d = 'REAL*4' & endcase +3: begin& bitpix= 32 & d = 'INTEGER*4' & endcase +5: begin& bitpix= 64 & d = 'REAL*8' & endcase +6: begin& bitpix= 64 & d = 'COMPLEX*8' & endcase +12: begin & bitpix=16 & d='UNSIGNED*2' & endcase +13: begin & bitpix=32 & d='UNSIGNED*4' & endcase +else: message,'ERROR -- Unrecognized input data type' + + endcase +; + sxaddpar,header,'BITPIX',bitpix + sxaddpar,header,'NAXIS',S[0] ;# of dimensions + for i=1,s[0] do sxaddpar,header,'NAXIS'+strtrim(i,2),s[i] + sxaddpar,header,'DATATYPE',d,'Type of data' + Get_date,dte + sxaddpar,header,'DATE',dte +; + if groups eq 0 then $ ;true if not group fmt. + sxaddpar,header,'GROUPS','F','No groups' $ + else begin ;make group params. + sxaddpar,header,'GROUPS','T' + sxaddpar,header,'PCOUNT',par + sxaddpar,header,'GCOUNT',groups + if N_elements(psize) EQ 0 then psize = bitpix*par + sxaddpar,header,'PSIZE',psize,'# of bits in parm blk' + endelse +; + sxopen,unit,file,header,hist,'W' ;make header file, etc. + return +end diff --git a/modules/idl_downloads/astro/pro/sxopen.pro b/modules/idl_downloads/astro/pro/sxopen.pro new file mode 100644 index 0000000..f47908f --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxopen.pro @@ -0,0 +1,213 @@ +pro SXOPEN,unit,fname,header,history,access +;+ +; NAME: +; SXOPEN +; PURPOSE: +; Open a Space Telescope formatted (STSDAS) header file. +; EXPLANATION: +; Saves the parameters required subsequent SX routines in +; the common block Stcommn. Optionally save the header in +; the string array Header, and the history in the string array +; History. Open the data file associated with this +; header on the same unit. +; +; CALLING SEQUENCE: +; SXOPEN, Unit, Fname [, Header [,History] [,Access]] +; +; INPUTS: +; Unit = IDL unit used for IO. Must be from 1 to 9. +; Fname = File name of header file. Default extension +; is .hhh for header files and .hhd for data +; files. If an extension is supplied it must have the +; form .xxh where xx are any alphanumeric characters. The +; data file must have extension .xxd +; No version number is allowed. Most recent versions +; of the files are used. +; +; OPTIONAL INPUT PARAMETER: +; Access = 'R' to open for read, 'W' to open for write. +; +; OUTPUTS: +; Stcommn = Common block containing ST parameter blocks. +; (Long arrays.) +; +; OPTIONAL OUTPUT PARAMETERS: +; Header = 80 char by N string array containing the +; names, values and comments from the FITS header. +; Use the function SXPAR to obtain individual +; parameter values. +; History = String array containing the value of the +; history parameter. +; +; COMMON BLOCKS: +; STCOMMN - Contains RESULT(20,10) where RESULT(i,LUN) = +; 0 - 121147 for consistency check, 1 - Unit for consistency, +; 2 - bitpix, 3 - naxis, 4 - groups (0 or 1), 5 - pcount, +; 6 - gcount, 7 - psize, 8 - data type as idl type code, +; 9 - bytes / record, 10 to 10+N-1 - dimension N, +; 17 = record length of file in bytes. +; 18 - # of groups written, 19 = gcount. +; +; SIDE EFFECTS: +; The data and header files are accessed. +; +; RESTRICTIONS: +; Works only for disc files. The data file must have +; must have the extension ".xxd" and the header file must +; have the extension ".xxh" where x is any alphanumeric character +; +; PROCEDURE: +; The header file is opened and each line is read. +; Important parameters are stored in the output +; parameter. If the last two parameters are specified +; the parameter names and values are stored. The common +; block STCOMMN is filled with the type of data, dimensions, +; etc. for use by SXREAD. +; +; If access is for write, each element of the header +; array, which must be supplied, is written to the +; header file. The common block is filled with +; relevant parameters for SXWRITE. A keyword of "END" +; ends the header. +; +; MODIFICATION HISTORY: +; Written, DMS, May, 1983. +; D. Lindler Feb. 1990 +; Modified to allow var. record length header files. +; D. Lindler April 1990 Conversion to new VMS IDL +; Added /BLOCK when opening new .hhd file +; Converted to IDL V5.0 W. Landsman September 1997 +; Recognize unsigned datatype for V5.1 or greater W. Landsman Jan 2000 +; Assume since V5.5 W. Landsman Sep 2006 +;- +;------------------------------------------------------------------------------ + On_error,2 + common stcommn,result,filename +; + if N_params() LT 2 then begin + print, 'Syntax: SXOPEN, unit, fname, [ header, history, access]' + return + endif +; + if N_elements(result) NE 200 then begin ;defined? + result = lonarr(20,10) + filename = strarr(10) + endif +; + if (unit lt 1) OR (unit gt 9) then $ + message,'Unit number must be from 1 to 9.' +; + close,unit ;close unit first +; + n = N_params(0) ;# of parameters we have + if n LT 5 then access = 'R' ;read access if unspecified +; +; Add default extension (.hhh) if not specified +; + xname=strtrim(fname,2) + if strmid(xname,strlen(xname)-4,1) NE '.' then xname = xname + '.hhh' + t=xname ;Open keywords. + CASE strupcase(access) OF +'R': sxhread,fname,header ;Read FITS header +'W': sxhwrite,fname,header ;Write FITS header +ELSE: message,'Illegal access value, must be R or W' + ENDCASE +; + result[*,unit]=0 ;Zero our block + filename[unit]=fname ;Save file name + result[0,unit]=121147L ;Code for descr block + result[1,unit] = unit ;Save unit number + result[6,unit]=1 ;Default value of GCOUNT is 1 +; +; Get keyword names and values from header array +; + name = strtrim(strmid(header,0,8),2) ;param name + value = strtrim(strmid(header,10,20),2) ;param value +; + L_bitpix = where(name EQ 'BITPIX',nfound) + if nfound GT 0 then result[2,unit] = value[L_bitpix[0]] else $ + message,'Required Keyword BITPIX not found',/CON +; + l_naxis = where(strmid(name,0,5) EQ 'NAXIS',nfound) + IF nfound GT 0 then BEGIN + axis = fix(strtrim(strmid(name[l_naxis],5,3),2)) + for i=0,nfound-1 do begin + if axis[i] EQ 0 then $ + result[3,unit]=value[l_naxis[i]] else $ ;# of dimensions + result[9+axis[i],unit]=value[l_naxis[i]] ;each dimension + endfor + endif else message,'Required Keyword NAXIS not found' +; + if n GE 4 then BEGIN ;Create history parameter? + L_hist = where(name EQ 'HISTORY',nfound) + IF nfound then history = strtrim(strmid(header[l_hist],8,72),2) else $ + history = '' +ENDIF +; + L_groups = where(name EQ 'GROUPS',nfound) + if nfound GT 0 then result[4,unit] = value[L_groups[0]] eq 'T' +; + L_pcount = where(name EQ 'PCOUNT',nfound) + if nfound GT 0 then result[5,unit] = value[L_pcount[0]] +; + L_gcount = where(name EQ 'GCOUNT',nfound) +if nfound GT 0 then result[6,unit] = value[L_gcount[0]] +; + L_psize = where(name EQ 'PSIZE',nfound) + if nfound GT 0 then result[7,unit] = value[L_psize[0]]/8 $ + else result[7,unit] = result[5,unit]*result[2,unit] +; + L_datatype = where(name EQ 'DATATYPE',nfound) + if nfound GT 0 then begin + v = value[L_datatype[0]] ;Process data type. + v = strmid(v,1,strlen(v)-2) ;Remove apostrophes + v = strtrim(v,2) ;trim blanks + CASE v OF ;Cvt datatype to IDL type code + 'BYTE': result[8,unit]=1 + 'LOGICAL*1': result[8,unit]=1 ;Byte + 'INTEGER*1': result[8,unit]=1 + 'REAL*4': result[8,unit]=4 + 'INTEGER*2': result[8,unit]=2 + 'UNSIGNED*2': result[8,unit]=12 + 'INTEGER*4': result[8,unit]=3 + 'UNSIGNED*4': result[8,unit]=13 + 'REAL*8': result[8,unit]=5 + 'COMPLEX*8': result[8,unit]=6 + ELSE: message,'Undefined Datatype value' + ENDCASE ;V OF + endif ;DATATYPE +; +; +; If DATATYPE not specified assume integer of size specified by BITPIX +; + if result[8,unit] EQ 0 then begin + CASE result[2,unit] OF + 8: result[8,unit]=1 ;byte + 16: result[8,unit]=2 ;integer*2 + 32: result[8,unit]=3 ;integer*4 + -32: result[8,unit]=4 + -64: result[8,unit]=5 + else: message,'Unable to determine data type' + ENDCASE + endif +; + bytes = abs(result[2,unit])/8l ;bytes/datum + for j=1,result[3,unit] do $ ;accum bytes/record + bytes=bytes*result[9+j,unit] + bytes = bytes + result[7,unit] ;+ header. + result[9,unit]=bytes ;Save bytes/record. +; + xname=strmid(xname,0,strlen(xname)-1)+'d' ;Change to data filename +; + If result[3,unit] GT 0 then begin ;NAXIS non-zero? + close,unit + if strupcase(access) eq 'R' then $ + openr,unit,xname $ + else begin + nrecs = (result[6,unit]*result[9,unit]+511)/512 + openw, unit, xname + endelse + result[17,unit] = 512 ;Save record length + endif else result[17,unit]=0 ;NAXIS = 0 + return +end diff --git a/modules/idl_downloads/astro/pro/sxpar.pro b/modules/idl_downloads/astro/pro/sxpar.pro new file mode 100644 index 0000000..d137cf4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxpar.pro @@ -0,0 +1,404 @@ +function SXPAR, hdr, name, abort, COUNT=matches, COMMENT = comments, $ + IFound = number, NoContinue = NoContinue, SILENT = silent, $ + NULL = K_Null, NAN = NaN, MISSING = Missing +;+ +; NAME: +; SXPAR +; PURPOSE: +; Obtain the value of a parameter in a FITS header +; +; CALLING SEQUENCE: +; result = SXPAR( Hdr, Name, [ Abort, COUNT=, COMMENT =, /NoCONTINUE, +; /SILENT ]) +; +; INPUTS: +; Hdr = FITS header array, (e.g. as returned by READFITS) +; string array, each element should have a length of 80 characters +; +; Name = String name of the parameter to return. If Name is of the +; form 'keyword*' then an array is returned containing values of +; keywordN where N is a positive (non-zero) integer. The value of +; keywordN will be placed in RESULT[N-1]. The data type of RESULT +; will be the type of the first valid match of keywordN found. +; +; OPTIONAL INPUTS: +; ABORT - string specifying that SXPAR should do a RETALL +; if a parameter is not found. ABORT should contain +; a string to be printed if the keyword parameter is not found. +; If not supplied, SXPAR will return quietly with COUNT = 0 +; (and !ERR = -1) if a keyword is not found. +; +; OPTIONAL INPUT KEYWORDS: +; /NOCONTINUE = If set, then continuation lines will not be read, even +; if present in the header +; /SILENT - Set this keyword to suppress warning messages about duplicate +; keywords in the FITS header. +; MISSING = By default, this routine returns 0 when keyword values are +; not found. This can be overridden by using the MISSING +; keyword, e.g. MISSING=-1. +; /NAN = If set, then return Not-a-Number (!values.f_nan) for missing +; values. Ignored if keyword MISSING is present. +; /NULL = If set, then return !NULL (undefined) for missing values. +; Ignored if MISSING of /NAN is present, or if earlier than IDL +; version 8.0. If multiple values would be returned, then +; MISSING= or /NAN should be used instead of /NULL, making sure +; that the datatype is consistent with the non-missing values, +; e.g. MISSING='' for strings, MISSING=-1 for integers, or +; MISSING=-1.0 or /NAN for floating point. /NAN should not be +; used if the datatype would otherwise be integer. +; +; OPTIONAL OUTPUT KEYWORDS: +; COUNT - Optional keyword to return a value equal to the number of +; parameters found by SXPAR, integer scalar +; +; COMMENT - Array of comments associated with the returned values +; IFOUND - Array of found keyword indicies when Name is of the form keyword* +; For example, one searches for 'TUNIT*' and the FITS header contains +; TUNIT1, TUNIT2, TUNIT4, and TUNIT6 then IFOUND woud be returned as +; [1,2,4,6]. Set to zero if Name is not of the form keyword*. + +; +; OUTPUTS: +; Function value = value of parameter in header. +; If parameter is double precision, floating, long or string, +; the result is of that type. Apostrophes are stripped +; from strings. If the parameter is logical, 1b is +; returned for T, and 0b is returned for F. +; If Name was of form 'keyword*' then a vector of values +; are returned. +; +; SIDE EFFECTS: +; !ERR is set to -1 if parameter not found, 0 for a scalar +; value returned. If a vector is returned it is set to the +; number of keyword matches found. The use of !ERR is deprecated, and +; instead the COUNT keyword is preferred +; +; If a keyword (except HISTORY or COMMENT) occurs more than once in a +; header, a warning is given, and the *last* occurrence is used. +; +; EXAMPLES: +; Given a FITS header, h, return the values of all the NAXISi values +; into a vector. Then place the history records into a string vector. +; +; IDL> naxisi = sxpar( h ,'NAXIS*') ; Extract NAXISi value +; IDL> history = sxpar( h, 'HISTORY' ) ; Extract HISTORY records +; +; PROCEDURE: +; The first 8 chacters of each element of Hdr are searched for a +; match to Name. The value from the last 20 characters is returned. +; An error occurs if there is no parameter with the given name. +; +; If a numeric value has no decimal point it is returned as type +; LONG. If it contains more than 8 numerals, or contains the +; characters 'D' or 'E', then it is returned as type DOUBLE. Otherwise +; it is returned as type FLOAT. Very large integer values, outside +; the range of valid LONG, are returned as DOUBLE. +; +; If the value is too long for one line, it may be continued on to the +; the next input card, using the OGIP CONTINUE convention. For more info, +; see http://fits.gsfc.nasa.gov/registry/continue_keyword.html +; +; Complex numbers are recognized as two numbers separated by one or more +; space characters. +; +; If a numeric value has no decimal point (or E or D) it is returned as +; type LONG. If it contains more than 8 numerals, or contains the +; character 'D', then it is returned as type DOUBLE. Otherwise it is +; returned as type FLOAT. If an integer is too large to be stored as +; type LONG, then it is returned as DOUBLE. +; +; NOTES: +; The functions SXPAR() and FXPAR() are nearly identical, although +; FXPAR() has slightly more sophisticated parsing, and additional keywords +; to specify positions in the header to search (for speed), and to force +; the output to a specified data type.. There is no +; particular reason for having two nearly identical procedures, but +; both are too widely used to drop either one. +; +; PROCEDURES CALLED: +; cgErrorMsg(), GETTOK(), VALID_NUM() +; MODIFICATION HISTORY: +; DMS, May, 1983, STPAR Written. +; D. Lindler Jan 90 added ABORT input parameter +; J. Isensee Jul,90 added COUNT keyword +; W. Thompson, Feb. 1992, added support for FITS complex values. +; W. Thompson, May 1992, corrected problem with HISTORY/COMMENT/blank +; keywords, and complex value error correction. +; W. Landsman, November 1994, fix case where NAME is an empty string +; W. Landsman, March 1995, Added COMMENT keyword, ability to read +; values longer than 20 character +; W. Landsman, July 1995, Removed /NOZERO from MAKE_ARRAY call +; T. Beck May 1998, Return logical as type BYTE +; W. Landsman May 1998, Make sure integer values are within range of LONG +; W. Landsman Feb 1998, Recognize CONTINUE convention +; W. Landsman Oct 1999, Recognize numbers such as 1E-10 as floating point +; W. Landsman Jan 2000, Only accept integer N values when name = keywordN +; W. Landsman Dec 2001, Optional /SILENT keyword to suppress warnings +; W. Landsman/D. Finkbeiner Mar 2002 Make sure extracted vectors +; of mixed data type are returned with the highest type. +; W.Landsman Aug 2008 Use vector form of VALID_NUM() +; W. Landsman Jul 2009 Eliminate internal recursive call +; W. Landsman Apr 2012 Require vector numbers be greater than 0 +; W. Landsman Apr 2014 Don't convert Long64 numbers to double +; W. Landsman Nov 2014 Use cgErrorMsg rather than On_error,2 +; W. Landsman Dec 2014 Return Logical as IDL Boolean in IDL 8.4 or later +; W. Landsman May 2015 Added IFound output keyword +; J. Slavin Aug 2015 Allow for 72 character par values (fixed from 71) +; W. Landsman Sep 2015 Added Missing, /NULL and /NaN keywords +;- +;---------------------------------------------------------------------- + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - result = sxpar( hdr, name, [abort])' + print,' Input Keywords: /NOCONTINUE, /SILENT, MISSING=, /NAN, /NULL' + print,' Output Keywords: COUNT=, COMMENT= ' + return, -1 + endif + + ; +; Determine the default value for missing data. +; + CASE 1 OF + N_ELEMENTS(MISSING) EQ 1: MISSING_VALUE = MISSING + KEYWORD_SET(NAN): MISSING_VALUE = !VALUES.F_NAN + KEYWORD_SET(K_NULL) AND !VERSION.RELEASE GE '8.': $ + DUMMY = EXECUTE('MISSING_VALUE = !NULL') + ELSE: MISSING_VALUE = 0 + ENDCASE + VALUE = MISSING_VALUE +; + + VALUE = 0 + if N_params() LE 2 then begin + abort_return = 0 + abort = 'FITS Header' + end else abort_return = 1 + if abort_return then On_error,1 else begin + Catch, theError + if theError NE 0 then begin + Catch,/Cancel + void = cgErrorMsg(/quiet) + return,-1 + endif + endelse +; Check for valid header + +;Check header for proper attributes. + if ( size(hdr,/N_dimen) NE 1 ) || ( size(hdr,/type) NE 7 ) then $ + message,'FITS Header (first parameter) must be a string array' + + nam = strtrim( strupcase(name) ) ;Copy name, make upper case + + +; Determine if NAME is of form 'keyword*'. If so, then strip off the '*', and +; set the VECTOR flag. One must consider the possibility that NAM is an empty +; string. + + namelength1 = (strlen(nam) - 1 ) > 1 + if strpos( nam, '*' ) EQ namelength1 then begin + nam = strmid( nam, 0, namelength1) + vector = 1 ;Flag for vector output + name_length = strlen(nam) ;Length of name + num_length = 8 - name_length ;Max length of number portion + if num_length LE 0 then $ + message, 'Keyword length must be 8 characters or less' + +; Otherwise, extend NAME with blanks to eight characters. + + endif else begin + while strlen(nam) LT 8 do nam += ' ' ;Make 8 chars long + vector = 0 + endelse + + +; If of the form 'keyword*', then find all instances of 'keyword' followed by +; a number. Store the positions of the located keywords in NFOUND, and the +; value of the number field in NUMBER. + + histnam = (nam eq 'HISTORY ') || (nam eq 'COMMENT ') || (nam eq '') + keyword = strmid( hdr, 0, 8) + number = 0 + + if vector then begin + nfound = where(strpos(keyword,nam) GE 0, matches) + if matches GT 0 then begin + numst= strmid( hdr[nfound], name_length, num_length) + igood = where(VALID_NUM(numst,/INTEGER), matches) + if matches GT 0 then begin + nfound = nfound[igood] + number = long(numst[igood]) + g = where(number GT 0, matches) + if matches GT 0 then number = number[g] + + endif + endif + +; Otherwise, find all the instances of the requested keyword. If more than +; one is found, and NAME is not one of the special cases, then print an error +; message. + + endif else begin + nfound = where(keyword EQ nam, matches) + if (matches GT 1) && ~histnam then $ + if ~keyword_set(silent) then $ + message,/informational, 'Warning - keyword ' + $ + nam + ' located more than once in ' + abort + endelse + + +; Process string parameter + + if matches GT 0 then begin + line = hdr[nfound] + svalue = strtrim( strmid(line,9,71),2) + if histnam then $ + value = strtrim(strmid(line,8,72),2) else for i = 0,matches-1 do begin + if ( strmid(svalue[i],0,1) EQ "'" ) then begin ;Is it a string? + test = strmid( svalue[i],1,strlen( svalue[i] )-1) + next_char = 0 + off = 0 + value = '' + NEXT_APOST: + endap = strpos(test, "'", next_char) ;Ending apostrophe + if endap LT 0 then $ + MESSAGE,'Value of '+name+' invalid in '+abort + value += strmid( test, next_char, endap-next_char ) + +; Test to see if the next character is also an apostrophe. If so, then the +; string isn't completed yet. Apostrophes in the text string are signalled as +; two apostrophes in a row. + + if strmid( test, endap+1, 1) EQ "'" then begin + value += "'" + next_char = endap+2 + goto, NEXT_APOST + endif + +; Extract the comment, if any + + slash = strpos( test, "/", endap ) + if slash LT 0 then comment = '' else $ + comment = strmid( test, slash+1, strlen(test)-slash-1 ) + +; This is a string that could be continued on the next line. Check this +; possibility with the following four criteria: *1) Ends with '&' +; (2) Next line is CONTINUE (3) LONGSTRN keyword is present (recursive call to +; SXPAR) 4. /NOCONTINE is not set + + if ~keyword_set(nocontinue) then begin + off++ + val = strtrim(value,2) + + if (strlen(val) gt 0) && $ + (strmid(val, strlen(val)-1, 1) EQ '&') && $ + (strmid(hdr[nfound[i]+off],0,8) EQ 'CONTINUE') then $ + if ~array_equal(keyword EQ 'LONGSTRN',0b) then begin + value = strmid(val, 0, strlen(val)-1) + test = hdr[nfound[i]+off] + test = strmid(test, 8, strlen(test)-8) + test = strtrim(test, 2) + if strmid(test, 0, 1) NE "'" then message, $ + 'ERROR: Invalidly CONTINUEd string in '+ abort + next_char = 1 + GOTO, NEXT_APOST + ENDIF + ENDIF + + +; Process non-string value + + endif else begin + value = missing_value + test = svalue[i] + if test EQ '' then begin + comment = '' + GOTO, got_value + endif + slash = strpos( test, "/" ) + if slash GE 0 then begin + comment = strmid( test, slash+1, strlen(test)-slash-1 ) + if slash GT 0 then test = strmid(test, 0, slash) else $ + GOTO, got_value + endif else comment = '' + +; Find the first word in TEST. Is it a logical value ('T' or 'F') ? + + test2 = test + value = gettok(test2,' ') + true = 1b + false = 0b + if !VERSION.RELEASE GE 8.4 then begin + true = boolean(true) + false = boolean(false) + endif + + if ( value EQ 'T' ) then value = true else $ + if ( value EQ 'F' ) then value = false else begin + +; Test to see if a complex number. It's a complex number if the value and +; the next word, if any, are both valid values. + + if strlen(test2) EQ 0 then goto, NOT_COMPLEX + value2 = gettok( test2, ' ') + if value2 EQ '' then goto, NOT_COMPLEX + On_ioerror, NOT_COMPLEX + value2 = float(value2) + value = complex(value,value2) + goto, GOT_VALUE + +; Not a complex number. Decide if it is a floating point, double precision, +; or integer number. + +NOT_COMPLEX: + On_IOerror, GOT_VALUE + if (strpos(value,'.') GE 0) || (strpos(value,'E') GT 0) $ + || (strpos(value,'D') GE 0) then begin ;Floating or double? + if ( strpos(value,'D') GT 0 ) || $ ;Double? + ( strlen(value) GE 8 ) then value = double(value) $ + else value = float(value) + endif else begin ;Long integer + lmax = 2.0d^31 - 1.0d + lmin = -2.0d^31 ;Typo fixed Feb 2010 + value = long64(value) + if (value GE lmin) && (value LE lmax) then $ + value = long(value) + endelse + +GOT_VALUE: + On_IOerror, NULL + endelse + endelse; if c eq apost + +; Add to vector if required + + if vector then begin + if ( i EQ 0 ) then begin + maxnum = max(number) + dtype = size(value,/type) + result = make_array( maxnum, TYPE = dtype ) + comments = strarr( maxnum ) + endif + if size(value,/type) GT dtype then begin ;Do we need to recast? + result = result + 0*value + dtype = size(value,/type) + endif + result[ number[i]-1 ] = value + comments[ number[i]-1 ] = comment + endif else $ + comments = comment + endfor + + if vector then begin + !ERR = matches + return, result + endif else !ERR = 0 + +endif else begin + if abort_return then message,'Keyword '+nam+' not found in '+abort + !ERR = -1 +endelse + +return, value + +END diff --git a/modules/idl_downloads/astro/pro/sxread.pro b/modules/idl_downloads/astro/pro/sxread.pro new file mode 100644 index 0000000..4a255ef --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxread.pro @@ -0,0 +1,81 @@ +function sxread,unit,group,par +;+ +; NAME: +; SXREAD +; PURPOSE: +; Read a Space Telescope STSDAS image file +; +; CALLING SEQUENCE: +; result = sxread( Unit, group , [par] ) +; +; INPUTS: +; UNIT = Unit number of file, must be from 1 to 9. +; Unit must have been opened with SXOPEN. +; GROUP = group number to read. if omitted, read first record. +; The first record is number 0. +; OUTPUTS: +; Result of function = array constructed from designated record. +; +; OPTIONAL OUTPUT: +; PAR = Variable name into which parameter values from STSDAS +; group parameter block are read. It is a byte array +; which may contain multiple data types. The function +; SXGPAR can be used to retrieve values from it. +; +; COMMON BLOCKS: +; Uses IDL Common STCOMMN to access parameters. +; +; NOTES: +; Use the function SXGREAD to read the group parameter blocks without +; having to read the group array. +; +; If the STSDAS file does not contain groups, then the optional output +; parameter PAR is returned undefined, but no error message is given. +; +; SIDE EFFECTS: +; IO is performed. +; MODIFICATION HISTORY: +; WRITTEN, Don Lindler, July, 1 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + +; common block containing description of file (see SXOPEN) + + common stcommn,result,filename + +; check if unit open + + if ( unit LT 1 ) or ( unit GT 9 ) then $ + message,'Invalid unit number, must be between 1 and 9' + + if N_elements(result) EQ 0 then result = 0 + + if ( N_elements(result) NE 200 ) or ( result[0,unit] NE 121147 ) then $ + message,'Specified unit is not open' + + desc = result[*,unit] ;description for unit + +; default group number is 0 (first group) + + if N_params() eq 1 then group = 0 + +; read group parameters if requested + + if (N_params() GT 2) and ( desc[7] GT 0 ) then begin + parrec = assoc(UNIT, bytarr(desc[7]),(group+1)*desc[9]-desc[7]) + par = parrec[0] + end + +; read data with dimensions specified in desc. + + ndimen = desc[3] + dtype = desc[8] + dimen = desc[10:9+ndimen] + sbyte = long(group)*desc[9] + + rec = assoc(unit,make_array(size=[ndimen,dimen>1,dtype,0],/nozero),sbyte) + + return,rec[0] + + end diff --git a/modules/idl_downloads/astro/pro/sxwrite.pro b/modules/idl_downloads/astro/pro/sxwrite.pro new file mode 100644 index 0000000..a106095 --- /dev/null +++ b/modules/idl_downloads/astro/pro/sxwrite.pro @@ -0,0 +1,92 @@ +pro SXWRITE, Unit, Data, Par +;+ +; NAME: +; SXWRITE +; PURPOSE: +; Write a group of data and parameters in ST format +; to a STSDAS data file. +; +; CALLING SEQUENCE: +; SXWRITE, Unit, Data,[ Par] +; +; INPUTS: +; Unit = unit number of file. The file must have been +; previously opened by SXOPEN. +; Data = Array of data to be written. The dimensions +; must agree with those supplied to SXOPEN and written +; into the FITS header. The type is converted if +; necessary. +; +; OPTIONAL INPUT PARAMETERS: +; Par = parameter block. The size of this array must +; agree with the Psize parameter in the FITS header. +; +; OUTPUTS: +; None. +; COMMON BLOCKS: +; STCOMMN - Contains RESULT(20,10) where RESULT(i,LUN) = +; 0 - 121147 for consistency check, 1 - Unit for consistency, +; 2 - bitpix, 3 - naxis, 4 - groups (0 or 1), 5 - pcount, +; 6 - gcount, 7 - psize, 8 - data type as idl type code, +; 9 - bytes / record, 10 to 10+N-1 - dimension N, +; 18 - # of groups written, 19 = gcount. +; +; SIDE EFFECTS: +; The data are written into the next group. +; +; RESTRICTIONS: +; SXOPEN must have been called to initialize the +; header and the common block. +; +; MODIFICATION HISTORY: +; DMS, July, 1983. +; D.Lindler July, 1986 - changed block size of file to 512 +; moved group parameters after the groups data. +; D.Lindler July, 1987 - modified to allow any size parameter block +; (in bytes). +; D. Lindler April, 1990 - converted to new VMS IDL +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;---------------------------------------------------------------------------- +; + common stcommn, result, filename + if N_params() LT 2 then begin + print,'Syntax - SXWRITE, Unit, Data,[ Par] + return + endif +; + if N_elements(result) ne 200 then begin + print,'SXWRITE - Sxopen not called' + return + endif + if result[1,unit] ne unit then begin + print,'SXWRITE - unit not opened with SXOPEN' + return + endif +; + on_error,2 ;return to caller on error + s = size(data) ;get data dims +; +; determine position in file to write +; + start=result[18,unit]*result[9,unit] +; +; create assoc variable for data +; + rec = assoc(unit,data,start) +; +; write data +; + rec[0]=data +; +; write pblk +; + if result[7,unit] gt 0 then begin + if n_params(0) lt 3 then par=bytarr(result[7,unit]) + p=byte(par,0,result[7,unit]) + rec=assoc(unit,p,start+result[9,unit]-result[7,unit]) + rec[0]=p + end + result[18,unit] = result[18,unit]+1 ;did one more group + return +end diff --git a/modules/idl_downloads/astro/pro/t_aper.pro b/modules/idl_downloads/astro/pro/t_aper.pro new file mode 100644 index 0000000..8a9b24c --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_aper.pro @@ -0,0 +1,160 @@ +pro t_aper,image,fitsfile,apr,skyrad,badpix,PRINT=print,SILENT=silent, $ + NEWTABLE = newtable, SETSKYVAL = setskyval,EXACT = Exact +;+ +; NAME: +; T_APER +; PURPOSE: +; Driver procedure (for APER) to compute concentric aperture photometry. +; EXPLANATION: +; Data is read from and written to disk FITS ASCII tables. +; Part of the IDL-DAOPHOT photometry sequence +; +; CALLING SEQUENCE: +; T_APER, image, fitsfile, [ apr, skyrad, badpix, PRINT=, NEWTABLE=, +; /EXACT, /SILENT, SETSKYVAL = ] +; +; INPUTS: +; IMAGE - input data array +; FITSFILE - disk FITS ASCII table name (from T_FIND). Must contain +; the keywords 'X' and 'Y' giving the centroid of the source +; positions in FORTRAN (first pixel is 1) convention. An +; extension of .fit is assumed if not supplied. +; +; OPTIONAL INPUTS: +; User will be prompted for the following parameters if not supplied. +; +; APR - Vector of up to 12 REAL photometry aperture radii. +; SKYRAD - Two element vector giving the inner and outer radii +; to be used for the sky annulus +; BADPIX - Two element vector giving the minimum and maximum +; value of a good pixel (Default [-32765,32767]) +; +; OPTIONAL KEYWORDS INPUTS: +; /EXACT - If this keyword is set, then intersection of the circular +; aperture is computed exactly (and slowly) rather than using +; an approximation. See APER for more info. +; /PRINT - if set and non-zero then NSTAR will also write its results to +; a file aper.prt. One can specify a different output file +; name by setting PRINT = 'filename'. +; /SILENT - If this keyword is set and non-zero, then APER will not +; display photometry results at the screen, and the results +; will be automatically incorporated in the FITS table without +; prompting the user +; NEWTABLE - Name of output disk FITS ASCII table, scalar string. +; If not supplied, then the input FITSFILE will be updated with +; the aperture photometry results. +; SETSKYVAL - Use this keyword to force the sky to a specified value +; rather than have APER compute a sky value. SETSKYVAL +; can either be a scalar specifying the sky value to use for +; all sources, or a 3 element vector specifying the sky value, +; the sigma of the sky value, and the number of elements used +; to compute a sky value. The 3 element form of SETSKYVAL +; is needed for accurate error budgeting. +; +; PROMPTS: +; T_APER requires the number of photons per analog digital unit +; (PHPADU), so that it can compute Poisson noise statistics to assign +; photometry errors. It first tries to find the PHPADU keyword in the +; original image header, and if not found will look for the GAIN, +; CCDGAIN and finally ATODGAIN keywords. If still not found, T_APER +; will prompt the user for this value. +; +; PROCEDURES: +; APER, FTADDCOL, FTGET(), FTINFO, FTPUT, READFITS(), SXADDPAR, +; SXPAR(), WRITEFITS +; REVISON HISTORY: +; Written W. Landsman ST Systems Co. May 1988 +; Store results as flux or magnitude August 1988 +; Added SILENT keyword W. Landsman Sep. 1991 +; Changed ERR SKY to ERR_SKY W. Landsman March 1996 +; Replace TEXTOUT keyword with PRINT keyword W. Landsman May 1996 +; Check CCDGAIN or ATODGAIN keywords to find phpadu W. Landsman May 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated for new FTINFO calling sequence W. Landsman May 2000 +; Added /EXACT keyword W. Landsman June 2000 +; +;- + On_error,2 ;Return to caller + + if N_params() LT 2 then begin + print,'Syntax - T_APER, image, fitsfile, [ apr, skyrad, badpix' + print,' /EXACT, SETSKY = ,PRINT = , NEWTABLE = ,/SILENT ]' + return + endif + + newfile = keyword_set(NEWTABLE) + if not keyword_set(NEWTABLE) then newtable = fitsfile + + dummy = readfits( fitsfile, hprimary, /SILENT ) + tab = readfits( fitsfile, h, /exten) + + ftinfo,h,ft_str + ttype = strtrim(ft_str.ttype,2) + xc = ftget( ft_str, tab, 'X' ) - 1. ;Subtract to conv from FORTRAN to IDL + yc = ftget( ft_str, tab, 'Y' ) - 1. + + phpadu = sxpar( hprimary, 'PHPADU', Count = n ) ;Try to get photons per ADU + if n EQ 0 then begin + phpadu = sxpar( hprimary, 'GAIN', Count = n) + if n EQ 0 then phpadu = sxpar( hprimary, 'CCDGAIN', Count = n) + if n EQ 0 then phpadu = sxpar( hprimary, 'ATODGAIN', Count = n) + if n EQ 0 then begin + read,'Enter photons per ADU (CCD Gain): ',phpadu + message,'Storing photon/ADU value of ' + strtrim(phpadu,2) + $ + ' in header',/INF + sxaddpar,hprimary,'PHPADU',phpadu,'Photons Per ADU',before = 'HISTORY' + endif + endif + + message,'Using photon/ADU value of ' + strtrim(phpadu,2),/INF + + aper, image, xc, yc, mags, errap, sky, skyerr, phpadu, apr, skyrad,$ + badpix, PRINT = print, SILENT=silent, SETSKYVAL = setskyval, EXACT = exact + + ans='' + if NOT keyword_set(SILENT) and (NOT newfile) then read, $ + 'T_APER: Update table with current results [Y]? ',ans + + if strupcase(ans) NE 'N' then begin + sxaddpar,h,'EXTNAME','IDL DAOPHOT: APER',' Last DAOPHOT step' + sxaddpar,h,'SKYIN',skyrad[0],' Inner Sky Radius','TTYPE1' + sxaddpar,h,'SKYOUT',skyrad[1],' Outer Sky Radius','TTYPE1' + sxaddpar,h,'BADPIX1',badpix[0],' Bad Pixel Value: LOW','TTYPE1' + sxaddpar,h,'BADPIX2',badpix[1],' Bad Pixel Value: HIGH','TTYPE1' + + gsky = where(ttype EQ 'SKY', N_sky) + if N_sky EQ 0 then ftaddcol,h,tab,'SKY',8,'F8.3' + ftput,h,tab,'SKY',0,sky + + gskyerr = where(ttype EQ 'ERR_SKY', N_skyerr) + if N_skyerr EQ 0 then ftaddcol,h,tab,'ERR_SKY',8,'F8.3' + ftput,h,tab,'ERR_SKY',0,skyerr + nstars = N_elements(xc) + name = 'MAG' & e_name = 'ERR_AP' + units = ' MAG' + f_format = 'F7.3' & e_format ='F6.3' + + for i = 1,N_elements(apr) do begin + ii = strtrim(i,2) + apsize = 'APR' + ii + sxaddpar,h,apsize,apr[i-1],' Aperture ' + ii + ' Size','TTYPE1' + field = 'AP' + ii + '_' + name + efield = e_name + ii + gap = where(ttype EQ field, Nap) + + if Nap EQ 0 then begin ;Create new columns? + ftaddcol,h,tab,field,8,f_format,units + ftaddcol,h,tab,efield,8,e_format,units + endif + ftput,h,tab,field,0,fltarr(nstars) + mags[i-1,*] + ftput,h,tab,efield,0,fltarr(nstars) + errap[i-1,*] + endfor + + sxaddhist,'T_APER: '+ systime(),h + endif + + writefits, newtable, 0, hprimary + writefits, newtable, tab,h,/append + + return + end diff --git a/modules/idl_downloads/astro/pro/t_find.pro b/modules/idl_downloads/astro/pro/t_find.pro new file mode 100644 index 0000000..e94ef07 --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_find.pro @@ -0,0 +1,127 @@ +pro t_find,image, im_hdr, fitsfile, hmin, fwhm, sharplim, roundlim,$ + PRINT = print, SILENT = silent +;+ +; NAME: +; T_FIND +; PURPOSE: +; Driver procedure (for FIND) to locate stars in an image. +; EXPLANATION: +; Finds positive brightness perturbations (i.e stars) in a +; 2 dimensional image. Output is to a FITS ASCII table. +; +; CALLING SEQUENCE: +; T_FIND, image, im_hdr, [ fitsfile, hmin, fwhm, sharplim, roundlim, +; PRINT = , /SILENT ] +; INPUTS: +; image - 2 dimensional image array (integer or real) for which one +; wishes to identify the stars present +; im_hdr - FITS header associated with image array +; +; OPTIONAL INPUTS: +; T_FIND will prompt for these parameters if not supplied +; +; fitsfile - scalar string specifying the name of the output FITS ASCII +; table file +; fwhm - FWHM to be used in the convolving filter +; hmin - Threshold intensity for a point source - should generally +; be 3 or 4 sigma above background level +; sharplim - 2 element vector giving low and high Limit for +; sharpness statistic (Default: [0.2,1.0] ) +; roundlim - 2 element vector giving low and high Limit for +; roundness statistic (Default: [-1.0,1.0] ) +; +; OPTIONAL INPUT KEYWORDS: +; /PRINT - if set and non-zero then NSTAR will also write its results to +; a file find.prt. One can specify the output file name by +; setting PRINT = 'filename'. +; /SILENT - If this keyword is set and non-zero, then FIND will work +; silently, and not display each star found +; +; OUTPUTS: +; None +; +; PROCEDURES CALLED: +; CHECK_FITS, FDECOMP, FIND, FTADDCOL, FTCREATE, SXADDHIST, SXADDPAR, +; SXDELPAR, SXPAR(), WRITEFITS +; +; REVISION HISTORY: +; Written W. Landsman, STX May, 1988 +; Added phpadu, J. Hill, STX, October, 1990 +; New calling syntax output to disk FITS table, W. Landsman May 1996 +; Work with more than 32767 stars W. Landsman August 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Remove obsolete !ERR system variable W. Landsman May 2000 +;- + On_error,2 ;Return to caller + + if N_params() LT 2 then begin + print,'Syntax - ' + $ + 'T_FIND, image, hdr, [fitsfile, hmin, fwhm, sharplim, roundlim ' + print,' PRINT = ,/SILENT ]' + return + endif + + if not keyword_set( SILENT ) then silent = 0 + + check_FITS, image, im_hdr, /NOTYPE, ERRMSG = errmsg + if ERRMSG NE '' then begin + message,'ERROR - ' + errmsg, /CON + return + endif + + if N_elements(fitsfile) EQ 0 then begin + fitsfile = '' + read,'Enter name of output FITS ASCII table file: ', fitsfile + endif + + find, image, x, y, flux, sharp, round, hmin, fwhm, roundlim, sharplim, $ + PRINT = print, SILENT = silent + + nstar = N_elements(x) + if nstar EQ 0 then message,'No FITS table created' + + ftcreate, 80, nstar, h, tab + + name = sxpar( im_hdr, 'IMAGE', Count = N_name ) + if N_name GT 0 then sxaddpar, h, 'IMAGE',name + + sxaddpar, h, 'EXTNAME', 'IDL DAOPHOT: FIND',' Last DAOPHOT stage' + sxaddpar, h, 'HMIN', hmin, 'Threshold Above Background' + sxaddpar, h, 'FWHM', fwhm, 'FIND FWHM' + sxaddpar, h, 'ROUNDLO', roundlim[0], ' Roundness Limit: Low ' + sxaddpar, h, 'ROUNDHI', roundlim[1], ' Roundness Limit: High' + sxaddpar, h, 'SHARPLO', sharplim[0], ' Sharpness Limit: Low ' + sxaddpar, h, 'SHARPHI', sharplim[1], ' Sharpness Limit: High' + + bscale = sxpar( im_hdr, 'BSCALE', Count = N_bscale ) + if N_bscale EQ 0 then sxaddpar, h, 'BSCALE', bscale, 'Calibration Const' + phpadu = sxpar( im_hdr, 'PHPADU', Count = N_phpadu ) + if N_phpadu EQ 0 then sxaddpar, h, 'PHPADU', phpadu, 'Photons Per ADU' + + ftaddcol, h, tab, 'STAR_ID', 4, 'I5' + ftput, h, tab, 1, 0, lindgen(nstar)+1 + ftaddcol, h, tab, 'X', 8, 'F7.2', 'PIX' + ftput, h, tab, 2, 0, x+1. ;Position written in FORTRAN convention + ftaddcol, h, tab, 'Y', 8, 'F7.2', 'PIX' + ftput, h, tab, 3, 0, y+1. + ftaddcol, h, tab, 'FLUX', 8, 'F8.1', 'ADU' + ftput, h, tab, 4, 0, flux + ftaddcol, h, tab, 'SHARP', 8, 'F6.3' + ftput, h, tab, 5, 0, sharp + ftaddcol, h, tab, 'ROUND', 8, 'F6.3' + ftput, h, tab, 6, 0, round + sxaddhist, 'T_FIND: ' + systime(),h + + hprimary = im_hdr ;Primary FITS header + sxdelpar,hprimary,['NAXIS1','NAXIS2'] + sxaddpar,hprimary,'NAXIS',0 + sxaddpar,hprimary,'SIMPLE','T' + sxaddpar,hprimary,'EXTEND','T',after='NAXIS' + + sxaddpar, h, 'NAXIS1', 80 + message,'Creating FITS ASCII table ' + fitsfile, /INF + writefits, fitsfile, 0, hprimary + writefits, fitsfile, tab,h,/append + + return + end diff --git a/modules/idl_downloads/astro/pro/t_getpsf.pro b/modules/idl_downloads/astro/pro/t_getpsf.pro new file mode 100644 index 0000000..f08cb8a --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_getpsf.pro @@ -0,0 +1,120 @@ +pro t_getpsf,image,fitsfile,idpsf,psfrad,fitrad,psfname, $ + NEWTABLE = newtable, DEBUG = debug +;+ +; NAME: +; T_GETPSF +; PURPOSE: +; Driver procedure (for GETPSF) to generate a PSF from isolate stars. +; EXPLANATION: +; Generates a point-spread function from one or more isolated stars. +; List of stars is read from the FITS ASCII table output of T_APER. +; PSF is represented as a sum of a Gaussian plus residuals. +; Ouput residuals are written to a FITS image file. +; +; CALLING SEQUENCE: +; T_GETPSF, image, fitsfile, [ idpsf, psfrad, fitrad, psfname, +; /DEBUG, NEWTABLE =] +; +; INPUTS: +; IMAGE - image array +; FITSFILE - scalar string giving name of disk FITS ASCII table. Must +; contain the keywords 'X','Y' (from T_FIND) and 'AP1_MAG','SKY' +; (from T_APER). +; +; OPTIONAL INPUTS: +; IDPSF - vector of stellar ID indices indicating which stars are to be +; used to create the PSF. Not that the PSF star should be +; specified *not* by its STAR_ID value, but rather by the its +; row number (starting with 0) in the FITS table +; PSFRAD - the radius for which the PSF will be defined +; FITRAD - fitting radius, always smaller than PSFRAD +; PSFNAME - name of FITS image file to contain PSF residuals, +; scalar string +; GETPSF will prompt for all the above values if not supplied. +; +; OPTIONAL KEYWORD INPUT +; NEWTABLE - scalar string specifying the name of the output FITS ASCII +; table. If not supplied, then the input table is updated with +; the keyword PSF_CODE, specifying which stars were used for the +; PSF. +; DEBUG - if this keyword is set and non-zero, then the result of each +; fitting iteration will be displayed. +; +; PROMPTS: +; T_GETPSF will prompt for the readout noise (in data numbers), and +; the gain (in photons or electrons per data number) so that pixels can +; be weighted during the PSF fit. To avoid the prompt, add the +; keywords RONOIS and PHPADU to the FITS ASCII table header. +; +; PROCEDURES USED: +; FTADDCOL, FTGET(), FTPUT, GETPSF, READFITS(), SXADDHIST, SXADDPAR, +; SXPAR(), WRITEFITS, ZPARCHECK +; REVISION HISTORY: +; Written W. Landsman STX May, 1988 +; Update PSF_CODE to indicate PSF stars in order used, W. Landsman Mar 96 +; I/O to FITS ASCII disk files W. Landsman May 96 +; Converted to IDL V5.0 W. Landsman September 1997 +; Update for new FTINFO call W. Landsman May 2000 +;- + On_error,2 + + if N_params() LT 2 then begin + print,'Syntax - T_GETPSF, image, fitsfile, [ idpsf, psfrad, fitrad,'+ $ + '/DEBUG, NEWTABLE = ]' + return + endif + + zparcheck,'T_GETPSF',image,1,[1,2,3,4,5],2,'image array' + zparcheck,'T_GETPSF',fitsfile,2,7,0,'name of disk FITS ASCII table' + if not keyword_set(newtable) then newtable = fitsfile + + dummy = readfits(fitsfile, hprimary,/SILENT) + tab = readfits(fitsfile,h,/ext) + + ftinfo,h,ft_str + ttype = strtrim(ft_str.ttype,2) + x = ftget(ft_str,tab,'X') - 1. + y = ftget(ft_str,tab,'Y') - 1. + apmag = ftget(ft_str,tab,'AP1_MAG') + sky = ftget(ft_str,tab,'SKY') + +;Try to get read-out noise from header; otherwise prompt for it + + ronois = sxpar(hprimary,'RONOIS', Count = N_Ronois) + if N_Ronois EQ 0 then begin + read,'Enter the read-out noise in ADU per pixel: ',ronois + print,'Storing readout noise of ',strtrim(ronois,2),' in header' + sxaddpar,hprimary,'RONOIS',ronois,'Read out noise (ADU/pixel)', $ + before = 'HISTORY' + endif + +;Try to get photons per ADU; otherwise prompt for it + + phpadu = sxpar(hprimary,'PHPADU', Count = N_phpadu) + if N_phpadu GT 0 then begin + message,'Using photon/ADU value of ' + strtrim(phpadu,2),/INF + endif else begin + read,'Enter photons per ADU: ',phpadu + print,'Storing photon/ADU of ',strtrim(phpadu,2),' in header' + sxaddpar,hprimary,'PHPADU',phpadu,'Photons Per ADU',before='HISTORY' + endelse + + getpsf,image,x,y,apmag,sky,ronois,phpadu,gauss,psf,idpsf,psfrad,fitrad,psfname + + if psfname NE '' then begin + code = bytarr(N_elements(apmag)) + code[idpsf] = indgen(N_elements(idpsf)) + 1 + + g = where(ttype EQ 'PSF_CODE', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'PSF_CODE',2,'I1' + ftput,h,tab,'PSF_CODE',0,code + + sxaddpar,h,'EXTNAME','IDL DAOPHOT: GETPSF','DAOPHOT stage' + sxaddpar,h,'PSF_NAME',psfname,'Name of PSF Image','TTYPE1' + sxaddhist,'T_GETPSF: ' + systime(),h + writefits, newtable, 0, hprimary + writefits, newtable, tab,h,/append + endif else print,'No PSF file created; Table not updated' + + return + end diff --git a/modules/idl_downloads/astro/pro/t_group.pro b/modules/idl_downloads/astro/pro/t_group.pro new file mode 100644 index 0000000..011516f --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_group.pro @@ -0,0 +1,73 @@ +pro t_group,fitsfile,rmax,xpar=xpar,ypar=ypar, NEWTABLE = newtable +;+ +; NAME: +; T_GROUP +; PURPOSE: +; Driver procedure (for GROUP) to place stars in non-overlapping groups. +; EXPLANATION: +; This procedure is part of the DAOPHOT sequence that places star +; positions with non-overlapping PSFs into distinct groups +; Input and output are to FITS ASCII tables +; +; CALLING SEQUENCE: +; T_GROUP, fitsfile, [ rmax, XPAR = , YPAR = , NEWTABLE = ] +; +; INPUTS: +; FITSFILE - Name of disk FITS ASCII table containing the X,Y positions +; in FITS (FORTRAN) convention (first pixel is 1,1) +; +; OPTIONAL INPUTS: +; rmax - maximum allowable distance between stars in a single group +; +; OPTIONAL INPUT KEYWORDS: +; XPAR, YPAR - scalar strings giving the field name in the output table +; containing the X and Y coordinates. If not supplied, +; then the fields 'X' and 'Y' are read. +; NEWTABLE - scalar giving name of output disk FITS ASCII table. If not +; supplied, +; +; PROCEDURES: +; FTADDCOL, FTGET(), FTINFO, FTPUT, GROUP, READFITS(), SXADDHIST, +; SXADDHIST, WRITEFITS +; REVISION HISTORY: +; Written, W. Landsman STX Co. May, 1996 +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated for new FTINFO call W. Landsman May 2000 +;- + On_error,2 + + if N_params() LT 1 then begin + print,'Syntax - T_GROUP, fitsfile, [rmax, XPAR = , YPAR =, NEWTABLE = ]' + return + endif + + if not keyword_set(XPAR) then xpar = 'X' + if not keyword_set(YPAR) then ypar = 'Y' + if not keyword_set(NEWTABLE) then newtable = fitsfile + + dummy = readfits( fitsfile, hprimary, /SILENT ) + tab = readfits(fitsfile, h, /ext) + + ftinfo,h,ft_str + ttype = strtrim(ft_str.ttype,2) + x = ftget( ft_str, tab, xpar) - 1. + y = ftget( ft_str, tab, ypar) - 1. + + if N_elements(rmax) EQ 0 then $ + read,'Enter maximum distance between stars in a group: ',rmax + + group, x, y, rmax, ngroup + + sxaddpar, h, 'RMAX', rmax, 'Maximum Distance in Group', 'TTYPE1' + sxaddpar, h, 'EXTNAME', 'IDL DAOPHOT: Group', 'DAOPHOT Stage' + + gid = where(ttype EQ 'GROUP_ID', Nid) + if Nid EQ 0 then ftaddcol, h, tab, 'GROUP_ID', 4, 'I4' + ftput, h, tab, 'GROUP_ID', 0, ngroup + sxaddhist, 'T_GROUP: ' + systime(),h + + writefits, newtable, 0, hprimary + writefits, newtable, tab,h,/append + return + + end diff --git a/modules/idl_downloads/astro/pro/t_nstar.pro b/modules/idl_downloads/astro/pro/t_nstar.pro new file mode 100644 index 0000000..453c980 --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_nstar.pro @@ -0,0 +1,159 @@ +pro t_nstar,image,fitsfile,psfname,groupsel,SILENT=silent,PRINT=print, $ + NEWTABLE = newtable, VARSKY = varsky, DEBUG = debug +;+ +; NAME: +; T_NSTAR +; PURPOSE: +; Driver procedure (for NSTAR) for simultaneous PSF fitting. +; EXPLANATION: +; Input and output are to disk FITS ASCII tables. +; +; CALLING SEQUENCE: +; T_NSTAR, image, fitsfile, [psfname, groupsel, /SILENT, /PRINT +; NEWTABLE = , /VARSKY ] +; INPUTS: +; IMAGE - 2-d image array +; FITSFILE - scalar string giving name of disk FITS ASCII table. Must +; contain the keywords 'X','Y' (from T_FIND) 'AP1_MAG','SKY' +; (from T_APER) and 'GROUP_ID' (from T_GROUP). This table +; will be updated with the results of T_NSTAR, unless the +; keyword NEWTABLE is supplied. +; +; OPTIONAL INPUTS: +; PSFNAME - Name of the FITS file created by T_GETPSF containing +; PSF residuals, scalar string +; GROUPSEL - Scalar or vector listing the groups to process. For +; example, to process stars in groups 2 and 5 set +; GROUPSEL = [2,5]. If omitted, or set equal to -1, +; then NSTAR will process all groups. +; +; OPTIONAL KEYWORD INPUTS: +; VARSKY - If this keyword is set and non-zero, then the mean sky level +; in each group of stars, will be fit along with the brightness +; and positions. +; /SILENT - if set and non-zero, then NSTAR will not display its results +; at the terminal +; /PRINT - if set and non-zero then NSTAR will also write its results to +; a file NSTAR.PRT. One can specify the output file name by +; setting PRINT = 'filename'. +; NEWTABLE - Name of output disk FITS ASCII table to contain the results +; of NSTAR. If not supplied, then the input FITSFILE will be +; updated. +; DEBUG - if this keyword is set and non-zero, then the result of each +; fitting iteration will be displayed. +; +; PROCEDURES CALLED: +; FTADDCAL, FTINFO, FTGET(), FTPUT, NSTAR, SXADDHIST, +; SXADDPAR, SXPAR(), READFITS(), WRITEFITS +; REVISION HISTORY: +; Written W. Landsman STX Co. May, 1988 +; Check for CCDGAIN, ATODGAIN keywords to get PHPADU W. Landsman May 1997 +; Fixed typo preventing compilation, groupsel parameter W.L. July 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Update for new FTINFO call W. Landsman May 2000 +;- + On_error,2 + + if N_params() LT 2 then begin + print, 'Syntax - T_NSTAR, image, fitsfile, [ psfname, groupsel, ' + print,' /VARSKY, NEWTABLE = ,/SILENT, PRINT=]' + return + endif + + if not keyword_set(NEWTABLE) then newtable = fitsfile + + dummy = readfits(fitsfile, hprimary, /SILENT) + tab = readfits(fitsfile, h, /ext) + + ftinfo, h, ft_str + ttype = strtrim(ft_str.ttype,2) + + idg = where(ttype EQ 'GROUP_ID', Nid) + if Nid EQ 0 then begin + message,'T_NSTAR: ERROR - Field GROUP_ID not found in header',/CON + message,'Procedure T_GROUP must be run before T_NSTAR',/CON + return + endif else group = ftget(ft_str,tab,idg[0] + 1) + + if N_params() EQ 4 then begin + nsel = N_elements(groupsel) + if groupsel[0] LT 0 then select = indgen(N_elements(group)) $ + else begin + select = where(group EQ groupsel[0]) + if nsel GT 1 then $ + for i=1,nsel-1 do select = [select,where(group eq groupsel[i])] + endelse + endif else select = indgen(N_elements(group)) + group = group[select] + + id = ftget( ft_str, tab, 'STAR_ID', select ) + x = ftget( ft_str, tab, 'X', select )-1. + y = ftget( ft_str, tab, 'Y', select )-1. + mags = ftget( ft_str, tab, 'AP1_MAG', select ) + sky = ftget( ft_str, tab, 'SKY', select ) + +;Try to get read-out noise from header + ronois = sxpar(hprimary,'RONOIS', Count = Nronois) + if Nronois EQ 0 then begin + read,'Enter the read-out noise in ADU per pixel: ',ronois + print,'Storing readout noise of ',ronois,' in header' + sxaddpar,hprimary,'RONOIS',ronois,' Read out noise (ADU/pixel)', $ + before='HISTORY' + endif + + phpadu = sxpar( hprimary, 'PHPADU', COUNT = n ) ;Try to get photons per ADU + if n EQ 0 then begin + phpadu = sxpar( hprimary, 'GAIN', Count = n) + if n EQ 0 then phpadu = sxpar( hprimary, 'CCDGAIN', Count = n) + if n EQ 0 then phpadu = sxpar( hprimary, 'ATODGAIN', Count = n) + if n EQ 0 then begin + read,'Enter photons per ADU (CCD Gain): ',phpadu + sxaddpar,hprimary,'PHPADU',phpadu,' Photons Per ADU',before = 'HISTORY' + endif + endif + + message,'Using photon/ADU (CCD Gain) value of ' + strtrim(phpadu,2),/INF + + nstar, image, id, x, y, mags, sky, group, phpadu, ronois, psfname, errmag,$ + iter, chisq,peak,PRINT = print, SILENT = silent, VARSKY = varsky, $ + DEBUG = debug + + id = id-1 + + sxaddpar,h,'EXTNAME','IDL DAOPHOT: NSTAR','DAOPHOT stage' + + g = where(ttype EQ 'X_PSF', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'X_PSF',8,'F7.2','PIX' + ftput,h,tab,'X_PSF',id,x+1. + + g = where(ttype EQ 'Y_PSF', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'Y_PSF',8,'F7.2','PIX' + ftput,h,tab,'Y_PSF',id,y+1. + + g = where(ttype EQ 'PSF_MAG', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'PSF_MAG',8,'F7.3','MAG' + ftput,h,tab,'PSF_MAG',id,mags + + g = where(ttype EQ 'ERR_PSF', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'ERR_PSF',8,'F5.3','MAG' + ftput,h,tab,'ERR_PSF',id,errmag + + g = where(ttype EQ 'ITER', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'ITER',4,'I2' + ftput,h,tab,'ITER',id,iter + + g = where(ttype EQ 'CHI', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'CHI',8,'F5.2' + ftput,h,tab,'CHI',id,chisq + + g = where(ttype EQ 'PEAK', Ng) + if Ng EQ 0 then ftaddcol,h,tab,'PEAK',8,'F7.3' + ftput,h,tab,'PEAK',id,peak + + sxaddhist,'T_NSTAR: ' + systime(), h + + writefits, newtable, 0, hprimary + writefits, newtable, tab,h,/append + + return + end diff --git a/modules/idl_downloads/astro/pro/t_substar.pro b/modules/idl_downloads/astro/pro/t_substar.pro new file mode 100644 index 0000000..b09bce2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/t_substar.pro @@ -0,0 +1,78 @@ +pro t_substar,image,fitsfile,id,psfname, VERBOSE = verbose, NOPSF = nopsf +;+ +; NAME: +; T_SUBSTAR +; PURPOSE: +; Driver procedure (for SUBSTAR) to subtract scaled PSF values +; EXPLANATION: +; Computes residuals of the PSF fitting program +; +; CALLING SEQUENCE: +; T_SUBSTAR, image, fitsfile, id,[ psfname, /VERBOSE, /NOPSF ] +; +; INPUT-OUTPUT: +; IMAGE - On input, IMAGE is the original image array. A scaled +; PSF will be subtracted from IMAGE at specified star positions. +; Make a copy of IMAGE before calling SUBSTAR, if you want to +; keep a copy of the unsubtracted image array +; INPUTS: +; FITSFILE - scalar string giving the name of the disk FITS ASCII +; produced as an output from T_NSTAR. +; +; OPTIONAL INPUTS: +; ID - Index vector indicating which stars are to be subtracted. If +; omitted, (or set equal to -1), then stars will be subtracted +; at all positions specified by the X and Y vectors. +; (IDL convention - zero-based subscripts) +; PSFNAME - Name of the FITS file containing the PSF residuals, as +; generated by GETPSF. SUBSTAR will prompt for this parameter +; if not supplied. +; OPTIONAL INPUT KEYWORD: +; /VERBOSE - If this keyword is set and non-zero, then the value of each +; star number will be displayed as it is processed. +; /NOPSF - if this keyword is set and non-zero, then all stars will be +; be subtracted *except* those used to determine the PSF. +; An improved PSF can then be derived from the subtracted image. +; If NOPSF is supplied, then the ID parameter is ignored +; NOTES: +; T_SUBSTAR does not modify the input FITS table. +; +; PROCEDURES USED: +; FTGET(), FTINFO, READFITS(), REMOVE, SUBSTAR +; REVISION HISTORY: +; Written, R. Hill, ST Sys. Corp., 22 August 1991 +; Added NOPSF keyword W. Landsman March, 1996 +; Use FITS format for PSF resduals July, 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Call FTINFO first to improve efficiency W. Landsman May 2000 +;- + On_Error,2 + + if N_params() LT 2 then begin + print,'Syntax - T_SUBSTAR, im, fitsfile,[id, psfname, /VERBOSE, /NOPSF ]' + print,' im - Image Array' + print,' fitsfile - name of disk FITS ASCII table (from T_NSTAR)' + print," id - vector of Star ID's to subtract (optional)" + print,' psfname - Name of FITS file containing the PSF' + return + endif + + tab = readfits(fitsfile, htab,/exten) + ftinfo, htab, ft_str + x = ftget(ft_str,tab,'X_PSF') - 1.0 + y = ftget(ft_str,tab,'Y_PSF') - 1.0 + mag = ftget(ft_str,tab,'PSF_MAG') + IF (N_elements(id) EQ 0) THEN id = -1 + if keyword_set(NOPSF) then begin + g = where(ft_str.ttype EQ 'PSF_CODE', Ng) + if Ng EQ 0 then message,'ERROR -- FITS table missing PSF_CODE column' + idpsf = ftget(ft_str,tab,'PSF_CODE') + ipsf = where(idpsf) + id = indgen(N_elements(x) ) + remove, ipsf, id + endif + if not keyword_set( VERBOSE ) then verbose = 0 + substar,image,x,y,mag,id,psfname, VERBOSE = verbose ;Subtract scaled PSF stars + + RETURN + END diff --git a/modules/idl_downloads/astro/pro/tabinv.pro b/modules/idl_downloads/astro/pro/tabinv.pro new file mode 100644 index 0000000..1feafd8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tabinv.pro @@ -0,0 +1,95 @@ +PRO TABINV, XARR, X, IEFF, FAST = fast +;+ +; NAME: +; TABINV +; PURPOSE: +; To find the effective index of a function value in an ordered vector. +; +; CALLING SEQUENCE: +; TABINV, XARR, X, IEFF, [/FAST] +; INPUTS: +; XARR - the vector array to be searched, must be monotonic +; increasing or decreasing +; X - the function value(s) whose effective +; index is sought (scalar or vector) +; +; OUTPUT: +; IEFF - the effective index or indices of X in XARR +; always floating point, same # of elements as X +; +; OPTIONAL KEYWORD INPUT: +; /FAST - If this keyword is set, then the input vector is not checked +; for monotonicity, in order to improve the program speed. +; RESTRICTIONS: +; TABINV will abort if XARR is not monotonic. (Equality of +; neighboring values in XARR is allowed but results may not be +; unique.) This requirement may mean that input vectors with padded +; zeroes could cause routine to abort. +; +; PROCEDURE: +; VALUE_LOCATE() is used to find the values XARR[I] +; and XARR[I+1] where XARR[I] < X < XARR[I+1]. +; IEFF is then computed using linear interpolation +; between I and I+1. +; IEFF = I + (X-XARR[I]) / (XARR[I+1]-XARR[I]) +; Let N = number of elements in XARR +; if x < XARR[0] then IEFF is set to 0 +; if x > XARR[N-1] then IEFF is set to N-1 +; +; EXAMPLE: +; Set all flux values of a spectrum (WAVE vs FLUX) to zero +; for wavelengths less than 1150 Angstroms. +; +; IDL> tabinv, wave, 1150.0, I +; IDL> flux[ 0:fix(I) ] = 0. +; +; FUNCTIONS CALLED: +; None +; REVISION HISTORY: +; Adapted from the IUE RDAF January, 1988 +; More elegant code W. Landsman August, 1989 +; Mod to work on 2 element decreasing vector August, 1992 +; Updated for V5.3 to use VALUE_LOCATE() W. Landsman January 2000 +; Work when both X and Xarr are integers W. Landsman August 2001 +; Use ARRAY_EQUAL, always internal double precision W.L. July 2009 +; Allow Double precision output, faster test for monotonicity. +; WL, January 2012 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print,'Syntax- TABINV, XARR, X, I, [/FAST]' + return + endif + + Npoints = N_elements(xarr) & npt= npoints - 1 + if ( Npoints LE 1 ) then message, /TRACE, $ + 'Search vector (first parameter) must contain at least 2 elements' + + do_double= (size(xarr,/tname) EQ 'DOUBLE') || (size(x,/TNAME) EQ 'DOUBLE') + + if ~keyword_set(fast) then begin + + ; Test for monotonicity (everywhere increasing or decreasing vector) + + i = xarr[1:*] GE xarr + test = array_equal( i, 1b) || array_equal(i, 0b) + if ~test then message, $ + 'ERROR - First parameter must be a monotonic vector' + endif + + if do_double then ieff = double( VALUE_LOCATE(xarr,x)) else $ + ieff = float( VALUE_LOCATE(xarr,x)) + g = where( (ieff LT npt) and (ieff GE 0), Ngood) + if Ngood GT 0 then begin + neff = ieff[g] + x0 = double(xarr[neff]) + diff = x[g] - x0 + ieff[g] = neff + diff / (xarr[neff+1] - x0 ) + endif + + ieff = ieff > 0.0 + + return + end diff --git a/modules/idl_downloads/astro/pro/tag_exist.pro b/modules/idl_downloads/astro/pro/tag_exist.pro new file mode 100644 index 0000000..8006edc --- /dev/null +++ b/modules/idl_downloads/astro/pro/tag_exist.pro @@ -0,0 +1,99 @@ +;+ +; NAME: +; TAG_EXIST() +; PURPOSE: +; To test whether a tag name exists in a structure. +; EXPLANATION: +; Routine obtains a list of tagnames and tests whether the requested one +; exists or not. The search is recursive so if any tag names in the +; structure are themselves structures the search drops down to that level. +; (However, see the keyword TOP_LEVEL). +; +; CALLING SEQUENCE: +; status = TAG_EXIST(str, tag, [ INDEX =, /TOP_LEVEL, /QUIET ] ) +; +; INPUT PARAMETERS: +; str - structure variable to search +; tag - tag name to search for, scalar string +; +; OUTPUTS: +; Function returns 1b if tag name exists or 0b if it does not. +; +; OPTIONAL INPUT KEYWORD: +; /TOP_LEVEL = If set, then only the top level of the structure is +; searched. +; /QUIET - if set, then do not print messages if invalid parameters given +; /RECURSE - does nothing but kept for compatibility with the +; Solarsoft version for which recursion is not the default +; http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/struct/tag_exist.pro +; OPTIONAL OUTPUT KEYWORD: +; INDEX = index of matching tag, scalar longward, -1 if tag name does +; not exist +; +; EXAMPLE: +; Determine if the tag 'THICK' is in the !P system variable +; +; IDL> print,tag_exist(!P,'THICK') +; +; PROCEDURE CALLS: +; None. +; +; MODIFICATION HISTORY: : +; Written, C D Pike, RAL, 18-May-94 +; Passed out index of matching tag, D Zarro, ARC/GSFC, 27-Jan-95 +; William Thompson, GSFC, 6 March 1996 Added keyword TOP_LEVEL +; Zarro, GSFC, 1 August 1996 Added call to help +; Use SIZE(/TNAME) rather than DATATYPE() W. Landsman October 2001 +; Added /RECURSE and /QUIET for compatibility with Solarsoft version +; W. Landsman March 2009 +; Slightly faster algorithm W. Landsman July 2009 +; July 2009 update was not setting Index keyword W. L Sep 2009. +; Use V6.0 notation W.L. Jan 2012 +; Not setting index again, sigh W.L./ K. Allers Jan 2012 +;- + +function tag_exist, str, tag,index=index, top_level=top_level,recurse=recurse, $ + quiet=quiet + +; +; check quantity of input +; +compile_opt idl2 +if N_params() lt 2 then begin + print,'Use: status = tag_exist(structure, tag_name)' + return,0b +endif + +; +; check quality of input +; + +if size(str,/TNAME) ne 'STRUCT' or size(tag,/TNAME) ne 'STRING' then begin + if ~keyword_set(quiet) then begin + if size(str,/TNAME) ne 'STRUCT' then help,str + if size(tag,/TNAME) ne 'STRING' then help,tag + print,'Use: status = tag_exist(str, tag)' + print,'str = structure variable' + print,'tag = string variable' + endif + return,0b +endif + + tn = tag_names(str) + + index = where(tn eq strupcase(tag), nmatch) + + if ~nmatch && ~keyword_set(top_level) then begin + status= 0b + for i=0,n_elements(tn)-1 do begin + if size(str.(i),/TNAME) eq 'STRUCT' then $ + status=tag_exist(str.(i),tag,index=index) + if status then return,1b + endfor + return,0b + +endif else begin + index = index[0] + return,logical_true(nmatch) + endelse +end diff --git a/modules/idl_downloads/astro/pro/tbdelcol.pro b/modules/idl_downloads/astro/pro/tbdelcol.pro new file mode 100644 index 0000000..f9f7479 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbdelcol.pro @@ -0,0 +1,111 @@ +pro tbdelcol,h,tab,name +;+ +; NAME: +; TBDELCOL +; PURPOSE: +; Delete a column of data from a FITS binary table +; +; CALLING SEQUENCE: +; TBDELCOL, h, tab, name +; +; INPUTS-OUPUTS +; h,tab - FITS binary table header and data array. H and TAB will +; be updated with the specified column deleted +; +; INPUTS: +; name - Either (1) a string giving the name of the column to delete +; or (2) a scalar giving the column number to delete +; +; EXAMPLE: +; Delete the column "FLUX" from FITS binary table test.fits +; +; IDL> tab = readfits('test.fits',h,/ext) ;Read table +; IDL> tbdelcol, h, tab, 'FLUX' ;Delete Flux column +; IDL> modfits,'test.fits',tab,h,/ext ;Write back table +; +; PROCEDURES USED: +; SXADDPAR, TBINFO, TBSIZE +; REVISION HISTORY: +; Written W. Landsman STX Co. August, 1988 +; Use new structure returned by TBINFO, August, 1997 +; Use SIZE(/TNAME) instead of DATATYPE() October 2001 +; Use /NOSCALE in call to TBINFO, update TDISP W. Landsman March 2007 +;- + compile_opt idl2 + On_error, 2 + + if N_params() LT 3 then begin + print,'Syntax - tbdelcol, h, tab, name' + return + endif + + s = size(name) + + tbsize, h, tab, ncol, nrows, tfields, allcols, allrows + +; Make sure column exists + + tbinfo,h,tb_str,/NOSCALE + + case size(name,/TNAME) of + 'STRING': begin + field = where(tb_str.ttype eq strupcase(name),nfound) + if nfound eq 0 then $ + message,'Field '+strupcase(name) + ' not found in header' + end + 'UNDEFINED':message,'Third parameter must be field name or number' + ELSE: begin + field = name-1 + if (field LT 0 ) or (field GT tfields) then $ + message,'Field number must be between 1 and ' +strtrim(tfields,2) + end + endcase + + fname = strtrim(strupcase(name),2) + field = field[0] + +; Eliminate relevant columns from TAB + + tcol = tb_str.tbcol[field] & w = tb_str.width[field]*tb_str.numval[field] + + case 1 of + tcol eq 0: tab = tab[w:*,*] ;First column + tcol eq ncol-w: tab = tab[0:tcol-1,*] ;Last column + else: tab = [tab[0:tcol-1,*],tab[tcol+w:*,*]] ;All other columns + endcase + +; Parse the header. Remove specified keyword from header. Lower +; the index of subsequent keywords. Update the TBCOL*** index of +; subsequent keywords + + nlines = N_elements(h) + field = field + 1 + hnew = strarr(nlines) + j = 0 + for i = 0,nlines-1 DO BEGIN ;Loop over each element in header + + key = strupcase(strmid(h[i],0,5)) + if (key eq 'TTYPE') OR (key eq 'TFORM') or (key eq 'TUNIT') or $ + (key eq 'TNULL') or (key EQ 'TDISP') then begin + row = h[i] + ifield = fix(strtrim(strmid(row,5,3))) + if ifield gt field then begin ;Subsequent field? + if ifield le 10 then fmt = "(I1,' ')" else fmt ='(I2)' + strput,row,string(ifield-1,format=fmt),5 + endif + if ifield ne field then hnew[j] = row else j=j-1 + endif else hnew[j] = h[i] + + j = j+1 + + endfor + + sxaddpar,hnew,'TFIELDS',tfields-1 ;Reduce number of fields by 1 + sxaddpar,hnew,'NAXIS1',ncol-w ;Reduce num. of columns by WIDTH + + h = hnew[0:j-1] + + message,'Field '+fname+' has been deleted from the FITS table',/INF + + return + end diff --git a/modules/idl_downloads/astro/pro/tbdelrow.pro b/modules/idl_downloads/astro/pro/tbdelrow.pro new file mode 100644 index 0000000..7926cd2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbdelrow.pro @@ -0,0 +1,76 @@ +pro tbdelrow,h,tab,rows +;+ +; NAME: +; TBDELROW +; PURPOSE: +; Delete specified row or rows of data from a FITS binary table +; +; CALLING SEQUENCE: +; TBDELROW, h, tab, rows +; +; INPUTS-OUPUTS +; h,tab - FITS binary table header and data array. H and TAB will +; be updated on output with the specified row(s) deleted. +; +; rows - scalar or vector, specifying the row numbers to delete +; First row has index 0. If a vector it will be sorted and +; duplicates removed by TBDELROW +; +; EXAMPLE: +; Compress a table to include only non-negative flux values +; +; flux = TBGET(h,tab,'FLUX') ;Obtain original flux vector +; bad = where(flux lt 0) ;Find negative fluxes +; TBDELROW,h,tab,bad ;Delete rows with negative fluxes +; +; PROCEDURE: +; Specified rows are deleted from the data array, TAB. The NAXIS2 +; keyword in the header is updated. +; +; REVISION HISTORY: +; Written W. Landsman STX Co. August, 1988 +; Checked for IDL Version 2, J. Isensee, July, 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 + + if N_params() LT 3 then begin + print,'Syntax - tbdelrow, h, tab, rows ' + return + endif + + nrows = sxpar(h,'NAXIS2') ;Original number of rows + if (max(rows) GE nrows) or (min(rows) LT 0) then $ + message,'Specified rows must be between 0 and ' + strtrim(nrows-1,2) + + ndel = N_elements(rows) + if ndel GT 1 then begin + rows = rows[rem_dup(rows)] + ndel = N_elements(rows) + endif + + j = 0L + i = rows[0] + + for k = long(rows[0]),nrows-1 do begin + + if k eq rows[j] then begin + j = j+1 + if j EQ ndel then goto,done + endif else begin + tab[0,i] = tab[*,k] + i = i+1 + endelse + + endfor + + k = k-1 + +DONE: + + if k NE nrows-1 then tab[0,i] = tab[*,i+j:nrows-1] + tab = tab[*,0:nrows-ndel-1] + sxaddpar,h,'NAXIS2',nrows-ndel ;Reduce number of rows + + return + end diff --git a/modules/idl_downloads/astro/pro/tbget.pro b/modules/idl_downloads/astro/pro/tbget.pro new file mode 100644 index 0000000..f6a6720 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbget.pro @@ -0,0 +1,255 @@ +function tbget, hdr_or_tbstr, tab, field, rows, nulls, NOSCALE = noscale, $ + CONTINUE = continue +;+ +; NAME: +; TBGET +; PURPOSE: +; Return value(s) from specified column in a FITS binary table +; +; CALLING SEQUENCE +; values = TBGET( h, tab, field, [ rows, nulls, /NOSCALE] ) +; or +; values = TBGET( tb_str, tab, field, [ rows, nulls, /NOSCALE] ) +; +; INPUTS: +; h - FITS binary table header, e.g. as returned by FITS_READ +; or +; tb_str - IDL structure extracted from FITS header by TBINFO. +; Use of the IDL structure will improve processing speed +; tab - FITS binary table array, e.g. as returned by FITS_READ +; field - field name or number, scalar +; +; OPTIONAL INPUTS: +; rows - scalar or vector giving row number(s) +; Row numbers start at 0. If not supplied or set to +; -1 then values for all rows are returned +; +; OPTIONAL KEYWORD INPUT: +; /NOSCALE - If this keyword is set and nonzero, then the TSCALn and +; TZEROn keywords will *not* be used to scale to physical values +; Default is to perform scaling +; CONTINUE - This keyword does nothing, it is kept for consistency with +; with earlier versions of TBGET(). +; OUTPUTS: +; the values for the row are returned as the function value. +; Null values are set to 0 or blanks for strings. +; +; OPTIONAL OUTPUT: +; nulls - null value flag of same length as the returned data. +; Only used for integer data types, B, I, and J +; It is set to 1 at null value positions and 0 elsewhere. +; If supplied then the optional input, rows, must also +; be supplied. +; +; EXAMPLE: +; Read the columns labeled 'WAVELENGTH' and 'FLUX' from the second +; extension of a FITS file 'spectra.fits' into IDL vectors w and f +; +; IDL> fits_read,'spectra.fits',tab,htab,exten=2 ;Read 2nd extension +; IDL> w = tbget(htab,tab,'wavelength') +; IDL> f = tbget(htab,tab,'flux') +; +; NOTES: +; (1) If the column is variable length ('P') format, then TBGET() will +; return the longword array of pointers into the heap area. TBGET() +; currently lacks the ability to actually extract the data from the +; heap area. +; (2) Use the higher-level procedure FTAB_EXT (which calls TBGET()) to +; extract vectors directly from the FITS file. +; (3) Use the procedure FITS_HELP to determine which extensions are +; binary tables, and FTAB_HELP or TBHELP to determine the columns of the +; table +; PROCEDURE CALLS: +; TBINFO, TBSIZE +; HISTORY: +; Written W. Landsman February, 1991 +; Work for string and complex W. Landsman April, 1993 +; Default scaling by TSCALn, TZEROn, Added /NOSCALE keyword, +; Fixed nulls output, return longword pointers for variable length +; binary tables, W. Landsman December 1996 +; Added a check for zero width column W. Landsman April, 1997 +; Add TEMPORARY() and REFORM() for speed W. Landsman May, 1997 +; Use new structure returned by TBINFO W. Landsman August 1997 +; Add IS_IEEE_BIG(), No subscripting when all rows requested +; W. Landsman March 2000 +; Use SIZE(/TNAME) instead of DATATYPE() W. Landsman October 2001 +; Bypass IEEE_TO_HOST call for improved speed W. Landsman November 2002 +; Cosmetic changes to SIZE() calls W. Landsman December 2002 +; Added unofficial support for 64bit integers W. Landsman February 2003 +; Support unsigned integers, new pointer types of TSCAL and TZERO +; returned by TBINFO W. Landsman April 2003 +; Add an i = i[0] for V6.0 compatibility W. Landsman August 2003 +; Use faster BYTEORDER byteswapping W. Landsman April 2006 +; Free pointers if FITS header supplied W. Landsman March 2007 +; Use V6.0 notation W. Landsman April 2014 +;- +;------------------------------------------------------------------ + On_error,2 + compile_opt idl2 + + if N_params() LT 3 then begin + print, $ + 'Syntax - values = TBGET(h, tab, field, [ rows, nulls, /NOSCALE ])' + return, -1 + endif + +; get size of table + + ndimen = size(tab,/n_dimen) + if Ndimen EQ 1 then nrows =1 else $ + nrows = (size(tab,/dimen))[1] + +; get characteristics of specified field + + case size(hdr_or_tbstr,/type) of + 7: tbinfo,hdr_or_tbstr,tb_str,NOSCALE=noscale + 8: tb_str = hdr_or_tbstr + else: message,'ERROR - Invalid FITS header or structure supplied' + endcase + + tfields = N_elements(tb_str.ttype) + + case size(field,/TNAME) of + + 'STRING': begin + i = where( strupcase(tb_str.ttype) EQ strupcase(field), Nfound) + if Nfound EQ 0 then $ + message,'Field ' + field + ' not found in header' + i=i[0] + end + + 'UNDEFINED':message,'First parameter must be field name or number' + + ELSE: begin + i = field[0]-1 + if (i LT 0 ) || (i GT tfields) then $ + message,'Field number must be between 1 and ' +strtrim(tfields,2) + end + + endcase + +; Now that the right column has been found, extract necessary info about this +; column + + ttype = tb_str.ttype[i] + numval = tb_str.numval[i] + tform = tb_str.tform[i] + tbcol = tb_str.tbcol[i] + width = tb_str.width[i] + idltype = tb_str.idltype[i] + tnull = tb_str.tnull[i] + + if numval EQ 0 then begin + message,/INF, 'Column ' + ttype + ' has zero width' + return, -1 + endif + + if tform EQ 'P' then message, /INF, $ + 'Variable Length column - returning array of pointers' + +; if rows not supplied then return all rows + + if N_params() LT 4 then rows = -1 + +; determine if scalar supplied + + row = rows + ndim = size(row,/N_dimen) + if row[0] LT 0 then nrow = nrows else begin + nrow = N_elements(row) + ; check for valid row numbers + if (min(row) LT 0) || (max(row) GT (nrows-1)) then $ + message,'ERROR - Invalid row number: FITS table contains '+ $ + strtrim(nrows,2) + ' rows' + endelse +; get column + + if row[0] LT 0 then $ ;All rows? + d = tab[tbcol:tbcol + numval*width-1,*] $ + else if ndim EQ 0 then $ ;scalar? + d = tab[tbcol:tbcol + numval*width-1,row[0]] $ + else $ ;vector of rows + d = tab[tbcol:tbcol + numval*width-1,row] + Nnull = 0 +; convert data to the correct type + + case idltype of + + 1: begin + temp = byte( d, 0, numval, nrow) + if tform EQ 'L' then begin + d = strarr( numval, nrow ) + for j = 0, numval*nrow-1 do d[j] = string( temp[j] ) + endif else if tnull NE 0 then nullval = where(d EQ tnull, Nnull) + end + + 2: begin + byteorder,d,/NTOHS, /SWAP_IF_LITTLE + d = fix(d,0, numval, nrow) + if tnull NE 0 then nullval = where(d EQ tnull, Nnull) + end + + 3: begin + byteorder,d,/NTOHL, /SWAP_IF_LITTLE + d = long( d, 0, numval, nrow) + if tnull NE 0 then nullval = where(d EQ tnull, Nnull) + end + + 4: begin + d = float( d, 0, numval, nrow) + byteorder,d,/LSWAP, /SWAP_IF_LITTLE + end + + 5: begin + d = double( d, 0, numval, nrow) + byteorder,d,/L64SWAP, /SWAP_IF_LITTLE + end + + 6: begin + d = complex( d, 0, numval, nrow) + byteorder,d,/LSWAP, /SWAP_IF_LITTLE + end + + 7: d = string(d) + + + 14: begin + d = long64(d, 0, numval, nrow) + byteorder, d, /L64swap, /SWAP_IF_LITTLE + end + + endcase + + + if ~keyword_set(NOSCALE) then begin + if tag_exist(tb_str,'TSCAL') then begin + tscale = *tb_str.tscal[i] + tzero = *tb_str.tzero[i] + unsgn_int = (tzero EQ 32768) && (tscale EQ 1) + unsgn_lng = (tzero EQ 2147483648) && (tscale EQ 1) + if unsgn_int then d = uint(d) - uint(32768) $ + else if unsgn_lng then d = ulong(d) - ulong(2147483648) else $ + if ( (tscale NE 1.0) or (tzero NE 0.0) ) then $ + d = temporary(d)*tscale + tzero + endif + endif + + if N_params() EQ 5 then begin + nulls = bytarr(N_elements(d)) + if Nnull GT 0 then begin + nulls[nullval] = 1b + d[nullval] = 0 + endif + endif + +; Extract correct rows if vector supplied + + if size(hdr_or_tbstr,/TYPE) NE 8 && (~keyword_set(NOSCALE)) then begin + ptr_free, tb_str.tscal + ptr_free, tb_str.tzero + endif + + if N_elements(d) EQ 1 then return, d[0] else return, reform(d,/overwrite) + + + end diff --git a/modules/idl_downloads/astro/pro/tbhelp.pro b/modules/idl_downloads/astro/pro/tbhelp.pro new file mode 100644 index 0000000..64db8c8 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbhelp.pro @@ -0,0 +1,132 @@ +pro tbhelp,h, TEXTOUT = textout +;+ +; NAME: +; TBHELP +; PURPOSE: +; Routine to print a description of a FITS binary table header +; +; CALLING SEQUENCE: +; TBHELP, h, [TEXTOUT = ] +; +; INPUTS: +; h - FITS header for a binary table, string array +; +; OPTIONAL INPUT KEYWORD: +; TEXTOUT - scalar number (0-7) or string (file name) controling +; output device (see TEXTOPEN). Default is TEXTOUT=1, output +; to the user's terminal +; +; METHOD: +; FITS Binary Table keywords NAXIS*,EXTNAME,TFIELDS,TTYPE*,TFORM*,TUNIT*, +; are read from the header and displayed at the terminal +; +; A FITS header is recognized as bein for a binary table if the keyword +; XTENSION has the value 'BINTABLE' or 'A3DTABLE' +; +; NOTES: +; Certain fields may be truncated in the display +; SYSTEM VARIABLES: +; Uses the non-standard system variables !TEXTOUT and !TEXTUNIT. These +; are automatically defined by TBHELP if they have not been defined +; previously. +; PROCEDURES USED: +; REMCHAR, SXPAR(), TEXTCLOSE, TEXTOPEN, ZPARCHECK +; HISTORY: +; W. Landsman February, 1991 +; Parsing of a FITS binary header made more robust May, 1992 +; Added TEXTOUT keyword August 1997 +; Define !TEXTOUT if not already present W. Landsman November 2002 +; Slightly more compact display W. Landsman August 2005 +; Fix Aug 2005 error omitting TFORM display W. Landsman Sep 2005 +;- + compile_opt idl2 + On_error,2 + + if N_params() LT 1 then begin + print,'Syntax - tbhelp, hdr, [TEXTOUT= ]' + return + endif +; Define !TEXTOUT and !TEXTUNIT if not already present + defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it. + defsysv,'!TEXTUNIT',exists=ex ; Check if !TEXTUNIT exists. + if ex eq 0 then defsysv,'!TEXTUNIT',0 ; If not define it. + + zparcheck, 'TBHELP', h, 1, 7, 1, 'Table Header' + + naxis = sxpar( h, 'NAXIS*') + if N_elements(naxis) LT 2 then $ + message,'ERROR - FITS Binary table must have NAXIS = 2' + + ext_type = strmid( strtrim( sxpar( h, 'XTENSION'), 2 ), 0, 8) + if (ext_type NE 'A3DTABLE') && (ext_type NE 'BINTABLE') then message, $ + 'WARNING - Header type of ' + ext_type + ' is not for a FITS Binary Table',/CON + + n = sxpar( h, 'TFIELDS', Count = N_tfields) + if N_tfields EQ 0 then message, $ + 'ERROR - Required TFIELDS keyword is missing from binary table header' + + tform = sxpar(h,'TFORM*', Count = N_tform) ;Get required TFORM* values + n = n > N_tform + + if ~keyword_set(TEXTOUT) then textout = !TEXTOUT + textopen,'tbhelp',TEXTOUT=textout + + printf,!TEXTUNIT,'FITS Binary Table: ' + $ + 'Size ',strtrim(naxis[0],2),' by ',strtrim(naxis[1],2) + extname = sxpar(h,'EXTNAME', Count=N_ext) + if N_ext GT 0 then printf,!TEXTUNIT, 'Extension Name: ',sxpar(h,'EXTNAME') + + tnull = strarr(n) + tunit = tnull & ttype =tnull & tcomm = tnull + key = strmid( h, 0, 5) + for i = 1, N_elements(h)-1 do begin + + case key[i] of + 'TTYPE': begin + j = fix(strtrim(strmid(h[i],5,3),2)) + apos = strpos( h[i], "'") + ttype[j-1] = strmid( h[i], apos+1, 20) + slash = strpos(h[i],'/') + if slash GT 0 then $ + tcomm[j-1] = strcompress( strmid(h[i], slash+1, 55)) + end + + 'TUNIT': begin + apos = strpos( h[i], "'") + tunit[fix(strtrim(strmid(h[i],5,3),2))-1] = strmid(h[i],apos+1,20) + end + 'TNULL': begin + tnull[fix(strtrim(strmid(h[i],5,3),2))-1] = $ + strtrim( strmid( h[i], 10, 20 ),2) + end + 'END ': goto, DONE + ELSE : + endcase + endfor + +DONE: + remchar,ttype,"'" & ttype = strtrim(ttype,2) + remchar,tunit,"'" & tunit = strtrim(tunit,2) + tform = strtrim(tform,2) + remchar,tnull,"'" & tnull = strtrim(tnull,2) + len_ttype = strtrim( max(strlen(ttype)) > 4,2) + len_tunit = strtrim( max(strlen(tunit)) > 4,2) + len_tform = strtrim( max(strlen(tform)) > 4,2) + len_tnull = strtrim( max(strlen(tnull)) > 4,2) + + + fmt = '(A5,1x,A' + len_ttype +',1x,A' + len_tunit + ',1x,A' + len_tform + $ + ',1x,A' + len_tnull +',1x,A)' + + printf,!TEXTUNIT,'Field','Name','Unit','Frmt','Null','Comment',f=fmt + + field = strtrim(sindgen(n)+1,2) + for i=0,n-1 do begin + printf,!TEXTUNIT,field[i],ttype[i],tunit[i],tform[i],tnull[i],tcomm[i], $ + format=fmt + endfor + + textclose, TEXTOUT = textout + return + end diff --git a/modules/idl_downloads/astro/pro/tbinfo.pro b/modules/idl_downloads/astro/pro/tbinfo.pro new file mode 100644 index 0000000..0d2c8c2 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbinfo.pro @@ -0,0 +1,192 @@ +pro tbinfo,h,tb_str, errmsg = errmsg, NOSCALE= noscale +;+ +; NAME: +; TBINFO +; PURPOSE: +; Return an informational IDL structure from a FITS binary table header. +; +; CALLING SEQUENCE: +; tbinfo, h, tb_str, [ERRMSG = ] +; INPUTS: +; h - FITS binary table header, e.g. as returned by READFITS() +; +; OUTPUTS: +; tb_str - IDL structure with extracted info from the FITS binary table +; header. Tags include +; .tbcol - starting column position in bytes, integer vector +; .width - width of the field in bytes, integer vector +; .idltype - idltype of field, byte vector +; 7 - string, 4- real*4, 3-integer*4, 5-real*8 +; .numval - repeat count, 64 bit longword vector +; .tunit - string unit numbers, string vector +; .tnull - integer null value for the field, stored as a string vector +; so that an empty string indicates that TNULL is not present +; .tform - format for the field, string vector +; .ttype - field name, string vector +; .maxval- maximum number of elements in a variable length array, long +; vector +; .tscal - pointer array giving the scale factor for converting to +; physical values, default 1.0 +; .tzero - pointer array giving the additive offset for converting to +; physical values, default 0.0 +; .tdisp - recommended output display format +; +; All of the output vectors will have same number of elements, equal +; to the number of columns in the binary table. +; +; The .tscal and .tzero values are stored as pointers so as to preserve +; the individual data types (e.g. float or double) which may differ +; in different columns. For example, to obtain the value of TSCAL for +; the third column use *tab_str.tscal[2] +; OPTIONAL INPUT KEYWORD: +; /NOSCALE - if set, then the TSCAL* and TZERO* keywords are not extracted +; from the FITS header, and the .tscal and .tzero pointers do not +; appear in the output structure. +; OPTIONAL OUTPUT KEYWORD: +; ERRMSG = if present, then error messages are returned in this keyword +; rather than displayed using the MESSAGE facility +; PROCEDURES USED: +; SXPAR() +; NOTES: +; For variable length ('P' format) column, TBINFO returns values for +; reading the 2 element longward array of pointers (numval=2, +; idltype = 3, width=4) +; HISTORY: +; Major rewrite to return a structure W. Landsman August 1997 +; Added "unofficial" 64 bit integer "K" format W. Landsamn Feb. 2003 +; Store .tscal and .tzero tags as pointers, so as to preserve +; type information W. Landsman April 2003 +; Treat repeat count for string as specifying string length, not number +; of elements, added ERRMSG W. Landsman July 2006 +; Treat logical as character string 'T' or 'F' W. Landsman October 2006 +; Added NOSCALE keyword W. Landsman March 2007 +; Make .numval 64 bit for very large tables W. Landsman April 2014 +;- +;---------------------------------------------------------------------------- + On_error,2 + compile_opt idl2 + if N_params() LT 2 then begin + print,'Syntax - TBINFO, h, tb_str, [ERRMSG=, /NOSCALE]' + return + endif + save_err = arg_present(errmsg) + +; get number of fields + + tfields = sxpar( h, 'TFIELDS', COUNT = N_TFields) + if N_TFields EQ 0 then begin ;Legal Binary Table Header? + errmsg = 'Invalid FITS binary table header. keyword TFIELDS is missing' + if ~save_err then message,errmsg else return + endif + + if tfields EQ 0 then begin ;Any fields in table? + errmsg = 'No Columns in FITS binary table, keyword TFIELDS = 0' + if ~save_err then message,errmsg else return + endif + +; Create output arrays with default values + + idltype = intarr(tfields) & tnull = idltype + numval = lon64arr(tfields) & tbcol = numval & width = numval & maxval = numval + tunit = replicate('',tfields) & ttype = tunit & tdisp = tunit & tnull = tunit + + type = sxpar(h,'TTYPE*', COUNT = N_ttype) + if N_ttype GT 0 then ttype[0] = strtrim(type,2) + + tform = strtrim( sxpar(h,'tform*', COUNT = N_tform), 2) ; column format + if N_tform EQ 0 then $ + message,'Invalid FITS table header -- keyword TFORM not present + tform = strupcase(strtrim(tform,2)) + + unit = strtrim(sxpar(h, 'TUNIT*', COUNT = N_tunit),2) ;physical units + if N_tunit GT 0 then tunit[0] = unit + + null = sxpar(h, 'TNULL*', COUNT = N_tnull) ;null data value + if N_tnull GT 0 then tnull[0] = null + + if ~keyword_set(noscale) then begin + tscal = ptrarr(tfields,/all) + tzero = ptrarr(tfields,/all) + index = strtrim(indgen(tfields)+1,2) + for i=0,tfields-1 do begin + scale = sxpar(h,'TSCAL' + index[i], COUNT = N_tscal) ;Scale factor + if N_tscal GT 0 then *tscal[i] = scale else *tscal[i] = 1.0 + zero = sxpar(h,'TZERO' + index[i], Count = N_tzero) + if N_tzero GT 0 then *tzero[i] = zero else *tzero[i] = 0 + endfor + endif + + disp = sxpar(h,'TDISP*', COUNT = N_tdisp) ;Display format string + if N_tdisp GT 0 then tdisp[0] = disp + +; determine idl data type from format + + len = strlen(tform) + + for i = 0, N_elements(tform)-1 do begin + +; Step through each character in the format, until a non-numerical character +; is encountered + + ichar = 0 +NEXT_CHAR: + if ichar GE len[i] then message, $ + 'Invalid format specification for keyword TFORM ' + strtrim(i+1) + char = strupcase( strmid(tform[i],ichar,1) ) + if ( (char GE '0') && ( char LE '9')) then begin + ichar++ + goto, NEXT_CHAR + endif + + if ichar EQ 0 then numval[i] = 1 else $ + numval[i] = strmid( tform[i], 0, ichar ) + + if char EQ "P" then begin ;Variable length array? + char = strupcase( strmid(tform[i],ichar+1,1) ) + maxval[i] = long( strmid(tform[i],ichar+3, len[i]-ichar-4) ) + width[i] = 4 & numval[i] = 2 & idltype[i] = 3 + endif else begin + + tform[i] = char + + case strupcase( tform[i] ) of + + 'A' : begin + idltype[i] = 7 & width[i] = numval[i] & numval[i]=1 + end + 'I' : begin & idltype[i] = 2 & width[i] = 2 & end + 'J' : begin & idltype[i] = 3 & width[i] = 4 & end + 'E' : begin & idltype[i] = 4 & width[i] = 4 & end + 'D' : begin & idltype[i] = 5 & width[i] = 8 & end + 'L' : begin & idltype[i] = 7 & width[i] = 1 & end + 'B' : begin & idltype[i] = 1 & width[i] = 1 & end + 'C' : begin & idltype[i] = 6 & width[i] = 8 & end + 'M' : begin & idltype[i] = 9 & width[i] =16 & end + 'K' : begin & idltype[i] = 14 & width[i] = 8 & end +; Treat bit arrays as byte arrays with 1/8 the number of elements. + + 'X' : begin + idltype[i] = 1 + numval[i] = long((numval[i]+7)/8) + width[i] = 1 + end + + else : message,'Invalid format specification for keyword ' + $ + 'TFORM'+ strtrim(i+1,2) + endcase + endelse + + if i ge 1 then tbcol[i] = tbcol[i-1] + width[i-1]*numval[i-1] + + endfor + if keyword_set(noscale) then $ + + tb_str = {TBCOL:tbcol,WIDTH:width,IDLTYPE:idltype,NUMVAL:numval,TUNIT:tunit,$ + TNULL:tnull,TFORM:tform,TTYPE:ttype,MAXVAL:maxval, TDISP:tdisp} $ + else $ + + tb_str = {TBCOL:tbcol,WIDTH:width,IDLTYPE:idltype,NUMVAL:numval,TUNIT:tunit,$ + TNULL:tnull,TFORM:tform,TTYPE:ttype,MAXVAL:maxval, TSCAL:tscal, $ + TZERO:tzero, TDISP:tdisp} + return + end diff --git a/modules/idl_downloads/astro/pro/tbprint.pro b/modules/idl_downloads/astro/pro/tbprint.pro new file mode 100644 index 0000000..dcebebf --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbprint.pro @@ -0,0 +1,307 @@ +pro tbprint,hdr_or_tbstr,tab,columns,rows,textout=textout,fmt=fmt, $ + num_header_lines=num_header_lines,nval_per_line=nval_per_line +;+ +; NAME: +; TBPRINT +; PURPOSE: +; Procedure to print specified columns & rows of a FITS binary table +; +; CALLING SEQUENCE: +; TBPRINT, h, tab, columns, [ rows, TEXTOUT =, FMT=, NUM_HEADER= ] +; or +; TBPRINT,tb_str, tab, columns, [ rows, TEXTOUT =, FMT=, NUM_HEADER = ] +; +; INPUTS: +; h - FITS header for table, string array +; or +; tb_str - IDL structure extracted from FITS header by TBINFO, useful +; when TBPRINT is called many times with the same header +; tab - table array +; columns - string giving column names, or vector giving +; column numbers (beginning with 1). If string +; supplied then column names should be separated by comma's. +; If set to '*' then all columns are printed in table format +; (1 row per line, binary tables only). +; rows - (optional) vector of row numbers to print. If +; not supplied or set to scalar, -1, then all rows +; are printed. +; +; OUTPUTS: +; None +; OPTIONAL INPUT KEYWORDS: +; FMT = Format string for print display. If not supplied, then any +; formats in the TDISP keyword fields of the table will be +; used, otherwise IDL default formats. +; NUM_HEADER_LINES - Number of lines to display the column headers +; default = 1). By setting NUM_HEADER_LINES to an integer larger +; than 1, one can avoid truncation of the column header labels. +; In addition, setting NUM_HEADER_LINES will display commented +; lines indicating a FORMAT for reading the data, and a +; suggested call to readfmt.pro. +; NVAL_PER_LINE - The maximum number of values displayed from a multivalued +; column when printing in table format. Default = 6 +; TEXTOUT - scalar number (0-7) or string (file name) determining +; output device (see TEXTOPEN). Default is TEXTOUT=1, output +; to the user's terminal +; SYSTEM VARIABLES: +; Uses nonstandard system variables !TEXTOUT and !TEXTOPEN +; Set !TEXTOUT = 3 to direct output to a disk file. The system +; variable is overriden by the value of the keyword TEXTOUT +; +; EXAMPLES: +; tab = readfits('test.fits',htab,/ext) ;Read first extension into vars +; tbprint,h,tab,'STAR ID,RA,DEC' ;print id,ra,dec for all stars +; tbprint,h,tab,[2,3,4],indgen(100) ;print columns 2-4 for +; first 100 stars +; tbprint,h,tab,text="stars.dat" ;Convert entire FITS table to +; ;an ASCII file named 'stars.dat' +; +; PROCEDURES USED: +; GETTOK(), STRNUMBER(), TEXTOPEN, TEXTCLOSE, TBINFO +; +; RESTRICTIONS: +; (1) Program does not check whether output length exceeds output +; device capacity (e.g. 80 or 132). +; (2) Column heading may be truncated to fit in space defined by +; the FORMAT specified for the column. Use NUM_HEADER_LINES +; to avoid truncation. +; (3) Program does not check for null values +; (4) Does not work with variable length columns +; (5) Will only the display the first value of fields with multiple values +; (unless there is one row each with the same number of mulitple values) +; If printing in table format (column='*') then up to 6 values +; can be printed per line. +; +; HISTORY: +; version 1 D. Lindler Feb. 1987 +; Accept undefined values of rows,columns W. Landsman August 1997 +; Use new structure returned by TBINFO W. Landsman August 1997 +; Made formatting more robust W. Landsman March 2000 +; Use STRSPLIT to parse string column listing W. Landsman July 2002 +; Wasn't always printing last row W. Landsman Feb. 2003 +; Better formatting (space between columns) W. Landsman Oct. 2005 +; Use case-insensitive match with TTYPE, use STRJOIN W.L. June 2006 +; Fixed check for multiple values W.L. August 2006 +; Fixed bad index value in August 2006 fix W.L Aug 15 2006 +; Free-up pointers after calling TBINFO W.L. Mar 2007 +; Add table format capability W.L. Mar 2010 +; Add NUM_HEADER_LINE keyword P. Broos Apr 2010 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - TBPRINT, h, tab, [ columns, rows, device, ' + print,' TEXTOUT= ,FMT=, NUM_HEADER_LINES= ' + return + endif + +; set default parameters + + if N_elements(columns) EQ 0 then columns = -1 + if N_elements(rows) EQ 0 then rows= -1 + if ~keyword_set(textout) then textout = 1 + if N_elements(nval_per_line) EQ 0 then $ + nval_per_line = 6 ;Number of values that can be displayed in 'table' format + + nbytes = [1,2,4,4,8,8,1,0,16] + fmt_def = ['','I4','I8','I12','G13.6','G16.8','','A','','','',''] + +; make sure rows is a vector + + sz = size(tab) + nrows = sz[2] + r = long(rows) + if r[0] eq -1 then r = lindgen(nrows) ;default + n = N_elements(r) + dotable = n EQ 1 ;Print in table format? + +; Did user supply a FITS header, or a structure (output of tbinfo)? + + case size(hdr_or_tbstr,/type) of + 7: tbinfo,hdr_or_tbstr,tb_str + 8: tb_str = hdr_or_tbstr + else: message,'ERROR - Invalid FITS header or structure supplied' + endcase + + tfields = N_elements(tb_str.ttype) + +; if columns is a string, change it to string array + + if size(columns,/tname) eq 'STRING' then begin + if columns[0] EQ '*' then begin + colnum = indgen(tfields) + 1 + numcol = tfields + dotable = 1 + endif else begin + colnames = strsplit(columns,',',/extract) + numcol = N_elements(colnames) + colnum = intarr(numcol) + field = strupcase(colnames) + for i = 0,numcol-1 do begin + colnum[i] = where(strupcase(tb_str.ttype) EQ field[i],nfound) + 1 + if nfound EQ 0 then $ + message,'Field '+ field[i] + ' not found in header' + endfor + endelse + endif else begin ;user supplied vector + colnum = fix(columns) ;make sure it is integer + if colnum[0] eq -1 then colnum = indgen(tfields) + 1 + numcol = N_elements(colnum) ;number of elements + endelse + + if ~keyword_set(fmt) then form = tb_str.tdisp[colnum-1] else begin + if N_elements(fmt) EQ 1 && (numcol GT 1) then begin + temp = strupcase(strtrim(fmt,2)) + if strmid(temp,0,1) EQ '(' then $ + temp = strmid(temp,1,strlen(temp)-2) + form = strarr(numcol) + ifmt = 0 + while strtrim(temp,2) NE '' do begin + tstform = gettok(temp,',') + ndup = 1 + vtype = strmid(tstform,0,1) + if strnumber(vtype,val) then begin + ndup = val + tstform = strmid(tstform,1,100) + endif + if strpos(tstform,'X') LT 0 then begin + form[ifmt:ifmt+ndup-1]=tstform + ifmt += ndup + endif + endwhile + endif else form = fmt + endelse + + default = where(form EQ '',Ndef) + if Ndef GT 0 then form[default] = fmt_def[ tb_str.idltype[colnum[default]-1] ] + form = strtrim(form,2) + row_format = strjoin(form,',1x,') + + num = where(tb_str.idltype[colnum-1] NE 7, Nnumeric) + if Nnumeric GT 0 then minnumval = min(tb_str.numval[colnum[num]-1]) $ + else minnumval = 1 + + if (minnumval GT 1) then begin + if rows[0] NE -1 then nrow1 = N_elements(rows)-1 else begin + rows = lindgen(minnumval) + nrow1 = minnumval-1 + endelse + + endif + + textopen,'TBPRINT', TEXTOUT = textout + + field = tb_str.ttype[colnum-1] + fieldlen = strlen(field) + +;Print in table format? + dotable = dotable || (n EQ 1) && (minnumval LE nval_per_line) + if dotable then begin + maxlen = max(fieldlen) + + for j = 0, n-1 do begin + printf,!TEXTUNIT,'ROW: ',r[j] + for i = 0, numcol-1 do begin + val = tbget(tb_str,tab,colnum[i],r[j]) + nval = N_elements(val) + if nval GT 1 then begin ;Print up to 5 values + val = strcompress(strjoin(val[0:(nval-1)< (nval_per_line-1)],' ')) + if nval GT nval_per_line then val = val + '...' + endif + printf,!TEXTUNIT, colnum[i],') ', field[i],strtrim(string(val,/pr),2),$ + f='(i3,A,A-' + strtrim(maxlen+2,2) + ',A)' + endfor + printf,!TEXTUNIT, ' ' + endfor + + endif else begin + + + varname = 'v' + strtrim(sindgen(numcol)+1,2) + len = lonarr(numcol) + varstr = varname + '[0]' + xform = '(' + form + ')' + for i = 0,numcol-1 do begin + result = execute(varname[i] + '= tbget(tb_str,tab,colnum[i],r)' ) + result = execute('len[i] = strlen(string(' + varstr[i] + ',f=xform[i]))') + endfor + + + if keyword_set(num_header_lines) then begin + ;; Build a multi-line header showing the column names left-justified. + header = strarr(num_header_lines+1) + +; The printed data columns are separated by a space, so the column widths are actually (len+1). + column_width = len + 1 + for ii=0,numcol-1 do begin + header_ind = ii MOD num_header_lines + + ; Pad the start of the header lines as needed. + if ((ii GT 0) && (ii LT num_header_lines)) then header[header_ind] += string(replicate(32B, total(column_width[0:ii-1], /INT))) + + if ((ii+num_header_lines) LT numcol) then begin + ; The space we have to print this label is the width of the next num_header_lines columns, minus one space for the '|' separator.. + ; Put the label at the LEFT end of this space. + label_length = total(column_width[ii : ii+num_header_lines-1], /INT) - 1 + label_format_code = string(label_length, F='(%"|%%-%ds")') + endif else begin + ; We're at the end of the header line, so print this last label without truncation. + label_format_code = '|%s' + endelse + header[header_ind] += string(field[ii], F='(%"'+label_format_code+'")') + endfor ; ii + + printf,!TEXTUNIT, "# FORMAT='" + row_format + "'" + printf,!TEXTUNIT, 3+num_header_lines+1, strjoin(field,','), F='(%"# readfmt, ''table.txt'', SKIPLINE=%d, FORMAT, %s")' + printf,!TEXTUNIT, "#" + + header[num_header_lines] = string(replicate(byte('-'), max(strlen(header)))) + strput, header, '#', 0 + forprint, TEXTOUT=5, header, /NoComment + + endif else begin + ;; Build a single-line header showing the column names centered on the columns. + field = strtrim(tb_str.ttype[colnum-1],2) + fieldlen = strlen(field) + for i=0,numcol-1 do begin + if fieldlen[i] LT len[i] then begin + space = len[i] - fieldlen[i] + if space EQ 1 then field[i] = field[i]+ ' ' else begin + pad = string(replicate(32b,space/2)) + field[i] = pad + field[i] + pad + if space mod 2 EQ 1 then field[i] = field[i] + ' ' + endelse + endif else field[i] = strmid(field[i],0,len[i]) + endfor + printf,!TEXTUNIT,field + endelse + + + if size(hdr_or_tbstr,/TYPE) NE 8 then begin + ptr_free, tb_str.tscal + ptr_free, tb_str.tzero + endif + + + +; If there are multiple values then only print the first value.... + + if minnumval EQ 1 then begin + index = replicate('[i]',numcol) + g = where( tb_str.numval[colnum-1] GT 1,Ng) + if Ng GT 0 then index[g] = '[0,i]' + vstring = strjoin(varname + index,',') + endif else vstring = strjoin(varname + '[i]',',') + + row_format = '(' + row_format + ')' + + if minnumval EQ 1 then $ + result = execute('for i=0,n-1 do printf,!TEXTUNIT,' + $ + vstring + ',f=row_format') else $ + result = execute('for i=rows[0],rows[nrow1] do printf,!TEXTUNIT,' + $ + vstring + ',f=fmt') + endelse + textclose, TEXTOUT = textout + return + end diff --git a/modules/idl_downloads/astro/pro/tbsize.pro b/modules/idl_downloads/astro/pro/tbsize.pro new file mode 100644 index 0000000..36dc68d --- /dev/null +++ b/modules/idl_downloads/astro/pro/tbsize.pro @@ -0,0 +1,63 @@ +pro tbsize, h, tab, ncols, nrows, tfields, ncols_all, nrows_all +;+ +; NAME: +; TBSIZE +; +; PURPOSE: +; Procedure to return the size of a FITS binary table. +; +; CALLING SEQUENCE: +; tbsize, h, tab, ncols, nrows, tfields, ncols_all, nrows_all +; +; INPUTS: +; h - FITS table header +; tab - FITS table array +; +; OUTPUTS: +; ncols - number of characters per row in table +; nrows - number of rows in table +; tfields - number of fields per row +; ncols_all - number of characters/row allocated (size of tab) +; nrows_all - number of rows allocated +; PROCEDURES USED: +; SXPAR() +; HISTORY +; D. Lindler July, 1987 +; Converted to IDL V5.0 W. Landsman September 1997 +; Remove obsolete !ERR call W. Landsman May 2000 +;- +;------------------------------------------------------------------------ + On_error,2 + +; check for valid header type + + s=size(h) & ndim=s[0] & type=s[ndim+1] + if (ndim NE 1) or (type ne 7) then $ + message,'Invalid FITS header, it must be a string array' + +; check for valid table array + + s = size(tab) & ndim = s[0] & type = s[ndim+1] + if (ndim gt 2) or (type ne 1) or (ndim lt 1) then $ + message,'Invalid table array, it must be a 2-D byte array' + + ncols_all = s[1] ;allocated characters per row + nrows_all = s[2] ;allocated rows + +; +; get number of fields +; + tfields = sxpar( h, 'TFIELDS', Count = N_tfields ) + if N_tfields EQ 0 then $ + message,'Invalid FITS table header, TFIELDS keyword missing' + +; +; get number of columns and rows +; + ncols = sxpar(h, 'NAXIS1' ) + nrows = sxpar(h, 'NAXIS2' ) + if ( ncols GT ncols_all ) or ( nrows GT nrows_all ) then message, $ + 'WARNING - Size information in header does not match that in array',/CON + + return + end diff --git a/modules/idl_downloads/astro/pro/tdb2tdt.pro b/modules/idl_downloads/astro/pro/tdb2tdt.pro new file mode 100644 index 0000000..86e1e1c --- /dev/null +++ b/modules/idl_downloads/astro/pro/tdb2tdt.pro @@ -0,0 +1,1071 @@ +;+ +; NAME: +; TDB2TDT +; +; AUTHOR: +; Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770 +; craigm@lheamail.gsfc.nasa.gov +; UPDATED VERSIONs can be found on my WEB PAGE: +; http://cow.physics.wisc.edu/~craigm/idl/idl.html +; +; PURPOSE: +; Relativistic clock corrections due to Earth motion in solar system +; +; MAJOR TOPICS: +; Planetary Orbits +; +; CALLING SEQUENCE: +; corr = TDB2TDT(JD, TBASE=, DERIV=deriv) +; +; DESCRIPTION: +; +; The function TDB2TDT computes relativistic corrections that must +; be applied when performing high precision absolute timing in the +; solar system. +; +; According to general relativity, moving clocks, and clocks at +; different gravitational potentials, will run at different rates +; with respect to each other. A clock placed on the earth will run +; at a time-variable rate because of the non-constant influence of +; the sun and other planets. Thus, for the most demanding +; astrophysical timing applications -- high precision pulsar timing +; -- times in the accelerating earth observer's frame must be +; corrected to an inertial frame, such as the solar system +; barycenter (SSB). This correction is also convenient because the +; coordinate time at the SSB is the ephemeris time of the JPL +; Planetary Ephemeris. +; +; In general, the difference in the rate of Ti, the time kept by an +; arbitrary clock, and the rate of T, the ephemeris time, is given +; by the expression (Standish 1998): +; +; dTi/dT = 1 - (Ui + vi^2/2) / c^2 +; +; where Ui is the potential of clock i, and vi is the velocity of +; clock i. However, when integrated, this expression depends on the +; position of an individual clock. A more convenient approximate +; expression is: +; +; T = Ti + (robs(Ti) . vearth(T))/c^2 + dtgeo(Ti) + TDB2TDT(Ti) +; +; where robs is the vector from the geocenter to the observer; +; vearth is the vector velocity of the earth; and dtgeo is a +; correction to convert from the observer's clock to geocentric TT +; time. TDB2TDT is the value computed by this function, the +; correction to convert from the geocenter to the solar system +; barycenter. +; +; As the above equation shows, while this function provides an +; important component of the correction, the user must also be +; responsible for (a) correcting their times to the geocenter (ie, +; by maintaining atomic clock corrections); (b) estimating the +; observatory position vector; and and (c) estimating earth's +; velocity vector (using JPLEPHINTERP). +; +; Users may note a circularity to the above equation, since +; vearth(T) is expressed in terms of the SSB coordinate time. This +; appears to be a chicken and egg problem since in order to get the +; earth's velocity, the ephemeris time is needed to begin with. +; However, to the precision of the above equation, < 25 ns, it is +; acceptable to replace vearth(T) with vearth(TT). +; +; The method of computation of TDB2TDT in this function is based on +; the analytical formulation by Fairhead, Bretagnon & Lestrade, 1988 +; (so-called FBL model) and Fairhead & Bretagnon 1990, in terms of +; sinusoids of various amplitudes. TDB2TDT has a dominant periodic +; component of period 1 year and amplitude 1.7 ms. The set of 791 +; coefficients used here were drawn from the Princeton pulsar timing +; program TEMPO version 11.005 (Taylor & Weisberg 1989). +; +; Because the TDB2TDT quantity is rather expensive to compute but +; slowly varying, users may wish to also retrieve the time +; derivative using the DERIV keyword, if they have many times to +; convert over a short baseline. +; +; Verification +; +; This implementation has been compared against a set of FBL test +; data found in the 1996 IERS Conventions, Chapter 11, provided by +; T. Fukushima. It has been verified that this routine reproduces +; the Fukushima numbers to the accuracy of the table, within +; 10^{-14} seconds. +; +; Fukushima (1995) has found that the 791-term Fairhead & Bretagnon +; analytical approximation use here has a maximum error of 23 +; nanoseconds in the time range 1980-2000, compared to a numerical +; integration. In comparison the truncated 127-term approximation +; has an error of ~130 nanoseconds. +; +; +; PARAMETERS: +; +; JD - Geocentric time TT, scalar or vector, expressed in Julian +; days. The actual time used is (JD + TBASE). For maximum +; precision, TBASE should be used to express a fixed epoch in +; whole day numbers, and JD should express fractional offset +; days from that epoch. +; +; +; KEYWORD PARAMETERS: +; +; TBASE - scalar Julian day of a fixed epoch, which provides the +; origin for times passed in JD. +; Default: 0 +; +; DERIV - upon return, contains the derivative of TDB2TDT in units +; of seconds per day. As many derivatives are returned as +; values passed in JD. +; +; +; RETURNS: +; The correction offset(s) in units of seconds, to be applied as +; noted above. +; +; +; EXAMPLE: +; +; Find the correction at ephemeris time 2451544.5 (JD): +; IDL> print, tdb2tdt(2451544.5d) +; -0.00011376314 +; or 0.11 ms. +; +; +; REFERENCES: +; +; Princeton TEMPO Program +; http://tempo.sourceforge.net/tempo_idx.html +; +; FBL Test Data Set +; ftp://maia.usno.navy.mil/conventions/chapter11/fbl.results +; +; Fairhead, L. & Bretagnon, P. 1990, A&A, 229, 240 +; (basis of this routine) +; +; Fairhead, L. Bretagnon, P. & Lestrade, J.-F. 1988, in *The Earth's +; Rotation and Reference Frames for Geodesy and Geodynamics*, +; ed. A. K. Babcock and G. A. Wilkins, (Dordrecht: Kluwer), p. 419 +; (original "FBL" paper) +; +; Fukushima, T. 1995, A&A, 294, 895 (error analysis) +; +; Irwin, A. W. & Fukushima, T. 1999, A&A, 348, 642 (error analysis) +; +; Standish, E. M. 1998, A&A, 336, 381 (description of time scales) +; +; Taylor, J. H. & Weisberg, J. M. 1989, ApJ, 345, 434 (pulsar timing) +; +; +; SEE ALSO +; JPLEPHREAD, JPLEPHINTERP, JPLEPHTEST +; +; MODIFICATION HISTORY: +; Original logic from Fairhead & Bretagnon, 1990 +; Drawn from TEMPO v. 11.005, copied 20 Jun 2001 +; Documented and vectorized, 30 Jun 2001 +; +; +; $Id: tdb2tdt.pro,v 1.4 2001/07/01 07:37:40 craigm Exp $ +; +;- +; Copyright (C) 2001, Craig Markwardt +; This software is provided as is without any warranty whatsoever. +; Permission to use, copy and distribute unmodified copies for +; non-commercial purposes, and to modify and use for personal or +; internal use, is granted. All other rights are reserved. +;- + + +function tdb2tdt_calc, jd, deriv=deriv, tbase=tbase + + common tdb2tdt_common, const0, freq0, phase0, texp + if n_elements(const0) EQ 0 then begin +fbldata = [ $ +1656.674564d, 6283.075849991d, 6.240054195d, $ + 22.417471d, 5753.384884897d, 4.296977442d, $ + 13.839792d, 12566.151699983d, 6.196904410d, $ + 4.770086d, 529.690965095d, 0.444401603d, $ + 4.676740d, 6069.776754553d, 4.021195093d, $ + 2.256707d, 213.299095438d, 5.543113262d, $ + 1.694205d, -3.523118349d, 5.025132748d, $ + 1.554905d, 77713.771467920d, 5.198467090d, $ + 1.276839d, 7860.419392439d, 5.988822341d, $ + 1.193379d, 5223.693919802d, 3.649823730d, $ + 1.115322d, 3930.209696220d, 1.422745069d, $ + 0.794185d, 11506.769769794d, 2.322313077d, $ + 0.447061d, 26.298319800d, 3.615796498d, $ + 0.435206d, -398.149003408d, 4.349338347d, $ + 0.600309d, 1577.343542448d, 2.678271909d, $ + 0.496817d, 6208.294251424d, 5.696701824d, $ + 0.486306d, 5884.926846583d, 0.520007179d, $ + 0.432392d, 74.781598567d, 2.435898309d, $ + 0.468597d, 6244.942814354d, 5.866398759d, $ + 0.375510d, 5507.553238667d, 4.103476804d, $ + 0.243085d, -775.522611324d, 3.651837925d, $ + 0.173435d, 18849.227549974d, 6.153743485d, $ + 0.230685d, 5856.477659115d, 4.773852582d, $ + 0.203747d, 12036.460734888d, 4.333987818d, $ + 0.143935d, -796.298006816d, 5.957517795d ] +fbldata = [ fbldata, $ + 0.159080d, 10977.078804699d, 1.890075226d, $ + 0.119979d, 38.133035638d, 4.551585768d, $ + 0.118971d, 5486.777843175d, 1.914547226d, $ + 0.116120d, 1059.381930189d, 0.873504123d, $ + 0.137927d, 11790.629088659d, 1.135934669d, $ + 0.098358d, 2544.314419883d, 0.092793886d, $ + 0.101868d, -5573.142801634d, 5.984503847d, $ + 0.080164d, 206.185548437d, 2.095377709d, $ + 0.079645d, 4694.002954708d, 2.949233637d, $ + 0.062617d, 20.775395492d, 2.654394814d, $ + 0.075019d, 2942.463423292d, 4.980931759d, $ + 0.064397d, 5746.271337896d, 1.280308748d, $ + 0.063814d, 5760.498431898d, 4.167901731d, $ + 0.048042d, 2146.165416475d, 1.495846011d, $ + 0.048373d, 155.420399434d, 2.251573730d, $ + 0.058844d, 426.598190876d, 4.839650148d, $ + 0.046551d, -0.980321068d, 0.921573539d, $ + 0.054139d, 17260.154654690d, 3.411091093d, $ + 0.042411d, 6275.962302991d, 2.869567043d, $ + 0.040184d, -7.113547001d, 3.565975565d, $ + 0.036564d, 5088.628839767d, 3.324679049d, $ + 0.040759d, 12352.852604545d, 3.981496998d, $ + 0.036507d, 801.820931124d, 6.248866009d, $ + 0.036955d, 3154.687084896d, 5.071801441d, $ + 0.042732d, 632.783739313d, 5.720622217d ] +fbldata = [ fbldata, $ + 0.042560d, 161000.685737473d, 1.270837679d, $ + 0.040480d, 15720.838784878d, 2.546610123d, $ + 0.028244d, -6286.598968340d, 5.069663519d, $ + 0.033477d, 6062.663207553d, 4.144987272d, $ + 0.034867d, 522.577418094d, 5.210064075d, $ + 0.032438d, 6076.890301554d, 0.749317412d, $ + 0.030215d, 7084.896781115d, 3.389610345d, $ + 0.029247d, -71430.695617928d, 4.183178762d, $ + 0.033529d, 9437.762934887d, 2.404714239d, $ + 0.032423d, 8827.390269875d, 5.541473556d, $ + 0.027567d, 6279.552731642d, 5.040846034d, $ + 0.029862d, 12139.553509107d, 1.770181024d, $ + 0.022509d, 10447.387839604d, 1.460726241d, $ + 0.020937d, 8429.241266467d, 0.652303414d, $ + 0.020322d, 419.484643875d, 3.735430632d, $ + 0.024816d, -1194.447010225d, 1.087136918d, $ + 0.025196d, 1748.016413067d, 2.901883301d, $ + 0.021691d, 14143.495242431d, 5.952658009d, $ + 0.017673d, 6812.766815086d, 3.186129845d, $ + 0.022567d, 6133.512652857d, 3.307984806d, $ + 0.016155d, 10213.285546211d, 1.331103168d, $ + 0.014751d, 1349.867409659d, 4.308933301d, $ + 0.015949d, -220.412642439d, 4.005298270d, $ + 0.015974d, -2352.866153772d, 6.145309371d, $ + 0.014223d, 17789.845619785d, 2.104551349d ] +fbldata = [ fbldata, $ + 0.017806d, 73.297125859d, 3.475975097d, $ + 0.013671d, -536.804512095d, 5.971672571d, $ + 0.011942d, 8031.092263058d, 2.053414715d, $ + 0.014318d, 16730.463689596d, 3.016058075d, $ + 0.012462d, 103.092774219d, 1.737438797d, $ + 0.010962d, 3.590428652d, 2.196567739d, $ + 0.015078d, 19651.048481098d, 3.969480770d, $ + 0.010396d, 951.718406251d, 5.717799605d, $ + 0.011707d, -4705.732307544d, 2.654125618d, $ + 0.010453d, 5863.591206116d, 1.913704550d, $ + 0.012420d, 4690.479836359d, 4.734090399d, $ + 0.011847d, 5643.178563677d, 5.489005403d, $ + 0.008610d, 3340.612426700d, 3.661698944d, $ + 0.011622d, 5120.601145584d, 4.863931876d, $ + 0.010825d, 553.569402842d, 0.842715011d, $ + 0.008666d, -135.065080035d, 3.293406547d, $ + 0.009963d, 149.563197135d, 4.870690598d, $ + 0.009858d, 6309.374169791d, 1.061816410d, $ + 0.007959d, 316.391869657d, 2.465042647d, $ + 0.010099d, 283.859318865d, 1.942176992d, $ + 0.007147d, -242.728603974d, 3.661486981d, $ + 0.007505d, 5230.807466803d, 4.920937029d, $ + 0.008323d, 11769.853693166d, 1.229392026d, $ + 0.007490d, -6256.777530192d, 3.658444681d, $ + 0.009370d, 149854.400134205d, 0.673880395d ] +fbldata = [ fbldata, $ + 0.007117d, 38.027672636d, 5.294249518d, $ + 0.007857d, 12168.002696575d, 0.525733528d, $ + 0.007019d, 6206.809778716d, 0.837688810d, $ + 0.006056d, 955.599741609d, 4.194535082d, $ + 0.008107d, 13367.972631107d, 3.793235253d, $ + 0.006731d, 5650.292110678d, 5.639906583d, $ + 0.007332d, 36.648562930d, 0.114858677d, $ + 0.006366d, 4164.311989613d, 2.262081818d, $ + 0.006858d, 5216.580372801d, 0.642063318d, $ + 0.006919d, 6681.224853400d, 6.018501522d, $ + 0.006826d, 7632.943259650d, 3.458654112d, $ + 0.005308d, -1592.596013633d, 2.500382359d, $ + 0.005096d, 11371.704689758d, 2.547107806d, $ + 0.004841d, 5333.900241022d, 0.437078094d, $ + 0.005582d, 5966.683980335d, 2.246174308d, $ + 0.006304d, 11926.254413669d, 2.512929171d, $ + 0.006603d, 23581.258177318d, 5.393136889d, $ + 0.005123d, -1.484472708d, 2.999641028d, $ + 0.004648d, 1589.072895284d, 1.275847090d, $ + 0.005119d, 6438.496249426d, 1.486539246d, $ + 0.004521d, 4292.330832950d, 6.140635794d, $ + 0.005680d, 23013.539539587d, 4.557814849d, $ + 0.005488d, -3.455808046d, 0.090675389d, $ + 0.004193d, 7234.794256242d, 4.869091389d, $ + 0.003742d, 7238.675591600d, 4.691976180d ] +fbldata = [ fbldata, $ + 0.004148d, -110.206321219d, 3.016173439d, $ + 0.004553d, 11499.656222793d, 5.554998314d, $ + 0.004892d, 5436.993015240d, 1.475415597d, $ + 0.004044d, 4732.030627343d, 1.398784824d, $ + 0.004164d, 12491.370101415d, 5.650931916d, $ + 0.004349d, 11513.883316794d, 2.181745369d, $ + 0.003919d, 12528.018664345d, 5.823319737d, $ + 0.003129d, 6836.645252834d, 0.003844094d, $ + 0.004080d, -7058.598461315d, 3.690360123d, $ + 0.003270d, 76.266071276d, 1.517189902d, $ + 0.002954d, 6283.143160294d, 4.447203799d, $ + 0.002872d, 28.449187468d, 1.158692983d, $ + 0.002881d, 735.876513532d, 0.349250250d, $ + 0.003279d, 5849.364112115d, 4.893384368d, $ + 0.003625d, 6209.778724132d, 1.473760578d, $ + 0.003074d, 949.175608970d, 5.185878737d, $ + 0.002775d, 9917.696874510d, 1.030026325d, $ + 0.002646d, 10973.555686350d, 3.918259169d, $ + 0.002575d, 25132.303399966d, 6.109659023d, $ + 0.003500d, 263.083923373d, 1.892100742d, $ + 0.002740d, 18319.536584880d, 4.320519510d, $ + 0.002464d, 202.253395174d, 4.698203059d, $ + 0.002409d, 2.542797281d, 5.325009315d, $ + 0.003354d, -90955.551694697d, 1.942656623d, $ + 0.002296d, 6496.374945429d, 5.061810696d ] +fbldata = [ fbldata, $ + 0.003002d, 6172.869528772d, 2.797822767d, $ + 0.003202d, 27511.467873537d, 0.531673101d, $ + 0.002954d, -6283.008539689d, 4.533471191d, $ + 0.002353d, 639.897286314d, 3.734548088d, $ + 0.002401d, 16200.772724501d, 2.605547070d, $ + 0.003053d, 233141.314403759d, 3.029030662d, $ + 0.003024d, 83286.914269554d, 2.355556099d, $ + 0.002863d, 17298.182327326d, 5.240963796d, $ + 0.002103d, -7079.373856808d, 5.756641637d, $ + 0.002303d, 83996.847317911d, 2.013686814d, $ + 0.002303d, 18073.704938650d, 1.089100410d, $ + 0.002381d, 63.735898303d, 0.759188178d, $ + 0.002493d, 6386.168624210d, 0.645026535d, $ + 0.002366d, 3.932153263d, 6.215885448d, $ + 0.002169d, 11015.106477335d, 4.845297676d, $ + 0.002397d, 6243.458341645d, 3.809290043d, $ + 0.002183d, 1162.474704408d, 6.179611691d, $ + 0.002353d, 6246.427287062d, 4.781719760d, $ + 0.002199d, -245.831646229d, 5.956152284d, $ + 0.001729d, 3894.181829542d, 1.264976635d, $ + 0.001896d, -3128.388765096d, 4.914231596d, $ + 0.002085d, 35.164090221d, 1.405158503d, $ + 0.002024d, 14712.317116458d, 2.752035928d, $ + 0.001737d, 6290.189396992d, 5.280820144d, $ + 0.002229d, 491.557929457d, 1.571007057d ] +fbldata = [ fbldata, $ + 0.001602d, 14314.168113050d, 4.203664806d, $ + 0.002186d, 454.909366527d, 1.402101526d, $ + 0.001897d, 22483.848574493d, 4.167932508d, $ + 0.001825d, -3738.761430108d, 0.545828785d, $ + 0.001894d, 1052.268383188d, 5.817167450d, $ + 0.001421d, 20.355319399d, 2.419886601d, $ + 0.001408d, 10984.192351700d, 2.732084787d, $ + 0.001847d, 10873.986030480d, 2.903477885d, $ + 0.001391d, -8635.942003763d, 0.593891500d, $ + 0.001388d, -7.046236698d, 1.166145902d, $ + 0.001810d, -88860.057071188d, 0.487355242d, $ + 0.001288d, -1990.745017041d, 3.913022880d, $ + 0.001297d, 23543.230504682d, 3.063805171d, $ + 0.001335d, -266.607041722d, 3.995764039d, $ + 0.001376d, 10969.965257698d, 5.152914309d, $ + 0.001745d, 244287.600007027d, 3.626395673d, $ + 0.001649d, 31441.677569757d, 1.952049260d, $ + 0.001416d, 9225.539273283d, 4.996408389d, $ + 0.001238d, 4804.209275927d, 5.503379738d, $ + 0.001472d, 4590.910180489d, 4.164913291d, $ + 0.001169d, 6040.347246017d, 5.841719038d, $ + 0.001039d, 5540.085789459d, 2.769753519d, $ + 0.001004d, -170.672870619d, 0.755008103d, $ + 0.001284d, 10575.406682942d, 5.306538209d, $ + 0.001278d, 71.812653151d, 4.713486491d ] +fbldata = [ fbldata, $ + 0.001321d, 18209.330263660d, 2.624866359d, $ + 0.001297d, 21228.392023546d, 0.382603541d, $ + 0.000954d, 6282.095528923d, 0.882213514d, $ + 0.001145d, 6058.731054289d, 1.169483931d, $ + 0.000979d, 5547.199336460d, 5.448375984d, $ + 0.000987d, -6262.300454499d, 2.656486959d, $ + 0.001070d,-154717.609887482d, 1.827624012d, $ + 0.000991d, 4701.116501708d, 4.387001801d, $ + 0.001155d, -14.227094002d, 3.042700750d, $ + 0.001176d, 277.034993741d, 3.335519004d, $ + 0.000890d, 13916.019109642d, 5.601498297d, $ + 0.000884d, -1551.045222648d, 1.088831705d, $ + 0.000876d, 5017.508371365d, 3.969902609d, $ + 0.000806d, 15110.466119866d, 5.142876744d, $ + 0.000773d, -4136.910433516d, 0.022067765d, $ + 0.001077d, 175.166059800d, 1.844913056d, $ + 0.000954d, -6284.056171060d, 0.968480906d, $ + 0.000737d, 5326.786694021d, 4.923831588d, $ + 0.000845d, -433.711737877d, 4.749245231d, $ + 0.000819d, 8662.240323563d, 5.991247817d, $ + 0.000852d, 199.072001436d, 2.189604979d, $ + 0.000723d, 17256.631536341d, 6.068719637d, $ + 0.000940d, 6037.244203762d, 6.197428148d, $ + 0.000885d, 11712.955318231d, 3.280414875d, $ + 0.000706d, 12559.038152982d, 2.824848947d ] +fbldata = [ fbldata, $ + 0.000732d, 2379.164473572d, 2.501813417d, $ + 0.000764d, -6127.655450557d, 2.236346329d, $ + 0.000908d, 131.541961686d, 2.521257490d, $ + 0.000907d, 35371.887265976d, 3.370195967d, $ + 0.000673d, 1066.495477190d, 3.876512374d, $ + 0.000814d, 17654.780539750d, 4.627122566d, $ + 0.000630d, 36.027866677d, 0.156368499d, $ + 0.000798d, 515.463871093d, 5.151962502d, $ + 0.000798d, 148.078724426d, 5.909225055d, $ + 0.000806d, 309.278322656d, 6.054064447d, $ + 0.000607d, -39.617508346d, 2.839021623d, $ + 0.000601d, 412.371096874d, 3.984225404d, $ + 0.000646d, 11403.676995575d, 3.852959484d, $ + 0.000704d, 13521.751441591d, 2.300991267d, $ + 0.000603d, -65147.619767937d, 4.140083146d, $ + 0.000609d, 10177.257679534d, 0.437122327d, $ + 0.000631d, 5767.611978898d, 4.026532329d, $ + 0.000576d, 11087.285125918d, 4.760293101d, $ + 0.000674d, 14945.316173554d, 6.270510511d, $ + 0.000726d, 5429.879468239d, 6.039606892d, $ + 0.000710d, 28766.924424484d, 5.672617711d, $ + 0.000647d, 11856.218651625d, 3.397132627d, $ + 0.000678d, -5481.254918868d, 6.249666675d, $ + 0.000618d, 22003.914634870d, 2.466427018d, $ + 0.000738d, 6134.997125565d, 2.242668890d ] +fbldata = [ fbldata, $ + 0.000660d, 625.670192312d, 5.864091907d, $ + 0.000694d, 3496.032826134d, 2.668309141d, $ + 0.000531d, 6489.261398429d, 1.681888780d, $ + 0.000611d,-143571.324284214d, 2.424978312d, $ + 0.000575d, 12043.574281889d, 4.216492400d, $ + 0.000553d, 12416.588502848d, 4.772158039d, $ + 0.000689d, 4686.889407707d, 6.224271088d, $ + 0.000495d, 7342.457780181d, 3.817285811d, $ + 0.000567d, 3634.621024518d, 1.649264690d, $ + 0.000515d, 18635.928454536d, 3.945345892d, $ + 0.000486d, -323.505416657d, 4.061673868d, $ + 0.000662d, 25158.601719765d, 1.794058369d, $ + 0.000509d, 846.082834751d, 3.053874588d, $ + 0.000472d, -12569.674818332d, 5.112133338d, $ + 0.000461d, 6179.983075773d, 0.513669325d, $ + 0.000641d, 83467.156352816d, 3.210727723d, $ + 0.000520d, 10344.295065386d, 2.445597761d, $ + 0.000493d, 18422.629359098d, 1.676939306d, $ + 0.000478d, 1265.567478626d, 5.487314569d, $ + 0.000472d, -18.159247265d, 1.999707589d, $ + 0.000559d, 11190.377900137d, 5.783236356d, $ + 0.000494d, 9623.688276691d, 3.022645053d, $ + 0.000463d, 5739.157790895d, 1.411223013d, $ + 0.000432d, 16858.482532933d, 1.179256434d, $ + 0.000574d, 72140.628666286d, 1.758191830d ] +fbldata = [ fbldata, $ + 0.000484d, 17267.268201691d, 3.290589143d, $ + 0.000550d, 4907.302050146d, 0.864024298d, $ + 0.000399d, 14.977853527d, 2.094441910d, $ + 0.000491d, 224.344795702d, 0.878372791d, $ + 0.000432d, 20426.571092422d, 6.003829241d, $ + 0.000481d, 5749.452731634d, 4.309591964d, $ + 0.000480d, 5757.317038160d, 1.142348571d, $ + 0.000485d, 6702.560493867d, 0.210580917d, $ + 0.000426d, 6055.549660552d, 4.274476529d, $ + 0.000480d, 5959.570433334d, 5.031351030d, $ + 0.000466d, 12562.628581634d, 4.959581597d, $ + 0.000520d, 39302.096962196d, 4.788002889d, $ + 0.000458d, 12132.439962106d, 1.880103788d, $ + 0.000470d, 12029.347187887d, 1.405611197d, $ + 0.000416d, -7477.522860216d, 1.082356330d, $ + 0.000449d, 11609.862544012d, 4.179989585d, $ + 0.000465d, 17253.041107690d, 0.353496295d, $ + 0.000362d, -4535.059436924d, 1.583849576d, $ + 0.000383d, 21954.157609398d, 3.747376371d, $ + 0.000389d, 17.252277143d, 1.395753179d, $ + 0.000331d, 18052.929543158d, 0.566790582d, $ + 0.000430d, 13517.870106233d, 0.685827538d, $ + 0.000368d, -5756.908003246d, 0.731374317d, $ + 0.000330d, 10557.594160824d, 3.710043680d, $ + 0.000332d, 20199.094959633d, 1.652901407d ] +fbldata = [ fbldata, $ + 0.000384d, 11933.367960670d, 5.827781531d, $ + 0.000387d, 10454.501386605d, 2.541182564d, $ + 0.000325d, 15671.081759407d, 2.178850542d, $ + 0.000318d, 138.517496871d, 2.253253037d, $ + 0.000305d, 9388.005909415d, 0.578340206d, $ + 0.000352d, 5749.861766548d, 3.000297967d, $ + 0.000311d, 6915.859589305d, 1.693574249d, $ + 0.000297d, 24072.921469776d, 1.997249392d, $ + 0.000363d, -640.877607382d, 5.071820966d, $ + 0.000323d, 12592.450019783d, 1.072262823d, $ + 0.000341d, 12146.667056108d, 4.700657997d, $ + 0.000290d, 9779.108676125d, 1.812320441d, $ + 0.000342d, 6132.028180148d, 4.322238614d, $ + 0.000329d, 6268.848755990d, 3.033827743d, $ + 0.000374d, 17996.031168222d, 3.388716544d, $ + 0.000285d, -533.214083444d, 4.687313233d, $ + 0.000338d, 6065.844601290d, 0.877776108d, $ + 0.000276d, 24.298513841d, 0.770299429d, $ + 0.000336d, -2388.894020449d, 5.353796034d, $ + 0.000290d, 3097.883822726d, 4.075291557d, $ + 0.000318d, 709.933048357d, 5.941207518d, $ + 0.000271d, 13095.842665077d, 3.208912203d, $ + 0.000331d, 6073.708907816d, 4.007881169d, $ + 0.000292d, 742.990060533d, 2.714333592d, $ + 0.000362d, 29088.811415985d, 3.215977013d ] +fbldata = [ fbldata, $ + 0.000280d, 12359.966151546d, 0.710872502d, $ + 0.000267d, 10440.274292604d, 4.730108488d, $ + 0.000262d, 838.969287750d, 1.327720272d, $ + 0.000250d, 16496.361396202d, 0.898769761d, $ + 0.000325d, 20597.243963041d, 0.180044365d, $ + 0.000268d, 6148.010769956d, 5.152666276d, $ + 0.000284d, 5636.065016677d, 5.655385808d, $ + 0.000301d, 6080.822454817d, 2.135396205d, $ + 0.000294d, -377.373607916d, 3.708784168d, $ + 0.000236d, 2118.763860378d, 1.733578756d, $ + 0.000234d, 5867.523359379d, 5.575209112d, $ + 0.000268d,-226858.238553767d, 0.069432392d, $ + 0.000265d, 167283.761587465d, 4.369302826d, $ + 0.000280d, 28237.233459389d, 5.304829118d, $ + 0.000292d, 12345.739057544d, 4.096094132d, $ + 0.000223d, 19800.945956225d, 3.069327406d, $ + 0.000301d, 43232.306658416d, 6.205311188d, $ + 0.000264d, 18875.525869774d, 1.417263408d, $ + 0.000304d, -1823.175188677d, 3.409035232d, $ + 0.000301d, 109.945688789d, 0.510922054d, $ + 0.000260d, 813.550283960d, 2.389438934d, $ + 0.000299d, 316428.228673312d, 5.384595078d, $ + 0.000211d, 5756.566278634d, 3.789392838d, $ + 0.000209d, 5750.203491159d, 1.661943545d, $ + 0.000240d, 12489.885628707d, 5.684549045d ] +fbldata = [ fbldata, $ + 0.000216d, 6303.851245484d, 3.862942261d, $ + 0.000203d, 1581.959348283d, 5.549853589d, $ + 0.000200d, 5642.198242609d, 1.016115785d, $ + 0.000197d, -70.849445304d, 4.690702525d, $ + 0.000227d, 6287.008003254d, 2.911891613d, $ + 0.000197d, 533.623118358d, 1.048982898d, $ + 0.000205d, -6279.485421340d, 1.829362730d, $ + 0.000209d, -10988.808157535d, 2.636140084d, $ + 0.000208d, -227.526189440d, 4.127883842d, $ + 0.000191d, 415.552490612d, 4.401165650d, $ + 0.000190d, 29296.615389579d, 4.175658539d, $ + 0.000264d, 66567.485864652d, 4.601102551d, $ + 0.000256d, -3646.350377354d, 0.506364778d, $ + 0.000188d, 13119.721102825d, 2.032195842d, $ + 0.000185d, -209.366942175d, 4.694756586d, $ + 0.000198d, 25934.124331089d, 3.832703118d, $ + 0.000195d, 4061.219215394d, 3.308463427d, $ + 0.000234d, 5113.487598583d, 1.716090661d, $ + 0.000188d, 1478.866574064d, 5.686865780d, $ + 0.000222d, 11823.161639450d, 1.942386641d, $ + 0.000181d, 10770.893256262d, 1.999482059d, $ + 0.000171d, 6546.159773364d, 1.182807992d, $ + 0.000206d, 70.328180442d, 5.934076062d, $ + 0.000169d, 20995.392966449d, 2.169080622d, $ + 0.000191d, 10660.686935042d, 5.405515999d ] +fbldata = [ fbldata, $ + 0.000228d, 33019.021112205d, 4.656985514d, $ + 0.000184d, -4933.208440333d, 3.327476868d, $ + 0.000220d, -135.625325010d, 1.765430262d, $ + 0.000166d, 23141.558382925d, 3.454132746d, $ + 0.000191d, 6144.558353121d, 5.020393445d, $ + 0.000180d, 6084.003848555d, 0.602182191d, $ + 0.000163d, 17782.732072784d, 4.960593133d, $ + 0.000225d, 16460.333529525d, 2.596451817d, $ + 0.000222d, 5905.702242076d, 3.731990323d, $ + 0.000204d, 227.476132789d, 5.636192701d, $ + 0.000159d, 16737.577236597d, 3.600691544d, $ + 0.000200d, 6805.653268085d, 0.868220961d, $ + 0.000187d, 11919.140866668d, 2.629456641d, $ + 0.000161d, 127.471796607d, 2.862574720d, $ + 0.000205d, 6286.666278643d, 1.742882331d, $ + 0.000189d, 153.778810485d, 4.812372643d, $ + 0.000168d, 16723.350142595d, 0.027860588d, $ + 0.000149d, 11720.068865232d, 0.659721876d, $ + 0.000189d, 5237.921013804d, 5.245313000d, $ + 0.000143d, 6709.674040867d, 4.317625647d, $ + 0.000146d, 4487.817406270d, 4.815297007d, $ + 0.000144d, -664.756045130d, 5.381366880d, $ + 0.000175d, 5127.714692584d, 4.728443327d, $ + 0.000162d, 6254.626662524d, 1.435132069d, $ + 0.000187d, 47162.516354635d, 1.354371923d ] +fbldata = [ fbldata, $ + 0.000146d, 11080.171578918d, 3.369695406d, $ + 0.000180d, -348.924420448d, 2.490902145d, $ + 0.000148d, 151.047669843d, 3.799109588d, $ + 0.000157d, 6197.248551160d, 1.284375887d, $ + 0.000167d, 146.594251718d, 0.759969109d, $ + 0.000133d, -5331.357443741d, 5.409701889d, $ + 0.000154d, 95.979227218d, 3.366890614d, $ + 0.000148d, -6418.140930027d, 3.384104996d, $ + 0.000128d, -6525.804453965d, 3.803419985d, $ + 0.000130d, 11293.470674356d, 0.939039445d, $ + 0.000152d, -5729.506447149d, 0.734117523d, $ + 0.000138d, 210.117701700d, 2.564216078d, $ + 0.000123d, 6066.595360816d, 4.517099537d, $ + 0.000140d, 18451.078546566d, 0.642049130d, $ + 0.000126d, 11300.584221356d, 3.485280663d, $ + 0.000119d, 10027.903195729d, 3.217431161d, $ + 0.000151d, 4274.518310832d, 4.404359108d, $ + 0.000117d, 6072.958148291d, 0.366324650d, $ + 0.000165d, -7668.637425143d, 4.298212528d, $ + 0.000117d, -6245.048177356d, 5.379518958d, $ + 0.000130d, -5888.449964932d, 4.527681115d, $ + 0.000121d, -543.918059096d, 6.109429504d, $ + 0.000162d, 9683.594581116d, 5.720092446d, $ + 0.000141d, 6219.339951688d, 0.679068671d, $ + 0.000118d, 22743.409379516d, 4.881123092d ] +fbldata = [ fbldata, $ + 0.000129d, 1692.165669502d, 0.351407289d, $ + 0.000126d, 5657.405657679d, 5.146592349d, $ + 0.000114d, 728.762966531d, 0.520791814d, $ + 0.000120d, 52.596639600d, 0.948516300d, $ + 0.000115d, 65.220371012d, 3.504914846d, $ + 0.000126d, 5881.403728234d, 5.577502482d, $ + 0.000158d, 163096.180360983d, 2.957128968d, $ + 0.000134d, 12341.806904281d, 2.598576764d, $ + 0.000151d, 16627.370915377d, 3.985702050d, $ + 0.000109d, 1368.660252845d, 0.014730471d, $ + 0.000131d, 6211.263196841d, 0.085077024d, $ + 0.000146d, 5792.741760812d, 0.708426604d, $ + 0.000146d, -77.750543984d, 3.121576600d, $ + 0.000107d, 5341.013788022d, 0.288231904d, $ + 0.000138d, 6281.591377283d, 2.797450317d, $ + 0.000113d, -6277.552925684d, 2.788904128d, $ + 0.000115d, -525.758811831d, 5.895222200d, $ + 0.000138d, 6016.468808270d, 6.096188999d, $ + 0.000139d, 23539.707386333d, 2.028195445d, $ + 0.000146d, -4176.041342449d, 4.660008502d, $ + 0.000107d, 16062.184526117d, 4.066520001d, $ + 0.000142d, 83783.548222473d, 2.936315115d, $ + 0.000128d, 9380.959672717d, 3.223844306d, $ + 0.000135d, 6205.325306007d, 1.638054048d, $ + 0.000101d, 2699.734819318d, 5.481603249d ] +fbldata = [ fbldata, $ + 0.000104d, -568.821874027d, 2.205734493d, $ + 0.000103d, 6321.103522627d, 2.440421099d, $ + 0.000119d, 6321.208885629d, 2.547496264d, $ + 0.000138d, 1975.492545856d, 2.314608466d, $ + 0.000121d, 137.033024162d, 4.539108237d, $ + 0.000123d, 19402.796952817d, 4.538074405d, $ + 0.000119d, 22805.735565994d, 2.869040566d, $ + 0.000133d, 64471.991241142d, 6.056405489d, $ + 0.000129d, -85.827298831d, 2.540635083d, $ + 0.000131d, 13613.804277336d, 4.005732868d, $ + 0.000104d, 9814.604100291d, 1.959967212d, $ + 0.000112d, 16097.679950283d, 3.589026260d, $ + 0.000123d, 2107.034507542d, 1.728627253d, $ + 0.000121d, 36949.230808424d, 6.072332087d, $ + 0.000108d, -12539.853380183d, 3.716133846d, $ + 0.000113d, -7875.671863624d, 2.725771122d, $ + 0.000109d, 4171.425536614d, 4.033338079d, $ + 0.000101d, 6247.911759770d, 3.441347021d, $ + 0.000113d, 7330.728427345d, 0.656372122d, $ + 0.000113d, 51092.726050855d, 2.791483066d, $ + 0.000106d, 5621.842923210d, 1.815323326d, $ + 0.000101d, 111.430161497d, 5.711033677d, $ + 0.000103d, 909.818733055d, 2.812745443d, $ + 0.000101d, 1790.642637886d, 1.965746028d ] +fbldata = [ fbldata, $ ;; From end of TDB1NS.F + 0.00065d, 6069.776754d, 4.021194d, $ + 0.00033d, 213.299095d, 5.543132d, $ + -0.00196d, 6208.294251d, 5.696701d, $ + -0.00173d, 74.781599d, 2.435900d ] + +i1terms = n_elements(fbldata)/3 +; T**1 +fbldata = [ fbldata, $ + 102.156724d, 6283.075849991d, 4.249032005d, $ + 1.706807d, 12566.151699983d, 4.205904248d, $ + 0.269668d, 213.299095438d, 3.400290479d, $ + 0.265919d, 529.690965095d, 5.836047367d, $ + 0.210568d, -3.523118349d, 6.262738348d, $ + 0.077996d, 5223.693919802d, 4.670344204d, $ + 0.054764d, 1577.343542448d, 4.534800170d, $ + 0.059146d, 26.298319800d, 1.083044735d, $ + 0.034420d, -398.149003408d, 5.980077351d, $ + 0.032088d, 18849.227549974d, 4.162913471d, $ + 0.033595d, 5507.553238667d, 5.980162321d, $ + 0.029198d, 5856.477659115d, 0.623811863d, $ + 0.027764d, 155.420399434d, 3.745318113d, $ + 0.025190d, 5746.271337896d, 2.980330535d, $ + 0.022997d, -796.298006816d, 1.174411803d, $ + 0.024976d, 5760.498431898d, 2.467913690d, $ + 0.021774d, 206.185548437d, 3.854787540d, $ + 0.017925d, -775.522611324d, 1.092065955d, $ + 0.013794d, 426.598190876d, 2.699831988d, $ + 0.013276d, 6062.663207553d, 5.845801920d, $ + 0.011774d, 12036.460734888d, 2.292832062d, $ + 0.012869d, 6076.890301554d, 5.333425680d, $ + 0.012152d, 1059.381930189d, 6.222874454d, $ + 0.011081d, -7.113547001d, 5.154724984d, $ + 0.010143d, 4694.002954708d, 4.044013795d ] +fbldata = [ fbldata, $ + 0.009357d, 5486.777843175d, 3.416081409d, $ + 0.010084d, 522.577418094d, 0.749320262d, $ + 0.008587d, 10977.078804699d, 2.777152598d, $ + 0.008628d, 6275.962302991d, 4.562060226d, $ + 0.008158d, -220.412642439d, 5.806891533d, $ + 0.007746d, 2544.314419883d, 1.603197066d, $ + 0.007670d, 2146.165416475d, 3.000200440d, $ + 0.007098d, 74.781598567d, 0.443725817d, $ + 0.006180d, -536.804512095d, 1.302642751d, $ + 0.005818d, 5088.628839767d, 4.827723531d, $ + 0.004945d, -6286.598968340d, 0.268305170d, $ + 0.004774d, 1349.867409659d, 5.808636673d, $ + 0.004687d, -242.728603974d, 5.154890570d, $ + 0.006089d, 1748.016413067d, 4.403765209d, $ + 0.005975d, -1194.447010225d, 2.583472591d, $ + 0.004229d, 951.718406251d, 0.931172179d, $ + 0.005264d, 553.569402842d, 2.336107252d, $ + 0.003049d, 5643.178563677d, 1.362634430d, $ + 0.002974d, 6812.766815086d, 1.583012668d, $ + 0.003403d, -2352.866153772d, 2.552189886d, $ + 0.003030d, 419.484643875d, 5.286473844d, $ + 0.003210d, -7.046236698d, 1.863796539d, $ + 0.003058d, 9437.762934887d, 4.226420633d, $ + 0.002589d, 12352.852604545d, 1.991935820d, $ + 0.002927d, 5216.580372801d, 2.319951253d ] +fbldata = [ fbldata, $ + 0.002425d, 5230.807466803d, 3.084752833d, $ + 0.002656d, 3154.687084896d, 2.487447866d, $ + 0.002445d, 10447.387839604d, 2.347139160d, $ + 0.002990d, 4690.479836359d, 6.235872050d, $ + 0.002890d, 5863.591206116d, 0.095197563d, $ + 0.002498d, 6438.496249426d, 2.994779800d, $ + 0.001889d, 8031.092263058d, 3.569003717d, $ + 0.002567d, 801.820931124d, 3.425611498d, $ + 0.001803d, -71430.695617928d, 2.192295512d, $ + 0.001782d, 3.932153263d, 5.180433689d, $ + 0.001694d, -4705.732307544d, 4.641779174d, $ + 0.001704d, -1592.596013633d, 3.997097652d, $ + 0.001735d, 5849.364112115d, 0.417558428d, $ + 0.001643d, 8429.241266467d, 2.180619584d, $ + 0.001680d, 38.133035638d, 4.164529426d, $ + 0.002045d, 7084.896781115d, 0.526323854d, $ + 0.001458d, 4292.330832950d, 1.356098141d, $ + 0.001437d, 20.355319399d, 3.895439360d, $ + 0.001738d, 6279.552731642d, 0.087484036d, $ + 0.001367d, 14143.495242431d, 3.987576591d, $ + 0.001344d, 7234.794256242d, 0.090454338d, $ + 0.001438d, 11499.656222793d, 0.974387904d, $ + 0.001257d, 6836.645252834d, 1.509069366d, $ + 0.001358d, 11513.883316794d, 0.495572260d, $ + 0.001628d, 7632.943259650d, 4.968445721d ] +fbldata = [ fbldata, $ + 0.001169d, 103.092774219d, 2.838496795d, $ + 0.001162d, 4164.311989613d, 3.408387778d, $ + 0.001092d, 6069.776754553d, 3.617942651d, $ + 0.001008d, 17789.845619785d, 0.286350174d, $ + 0.001008d, 639.897286314d, 1.610762073d, $ + 0.000918d, 10213.285546211d, 5.532798067d, $ + 0.001011d, -6256.777530192d, 0.661826484d, $ + 0.000753d, 16730.463689596d, 3.905030235d, $ + 0.000737d, 11926.254413669d, 4.641956361d, $ + 0.000694d, 3340.612426700d, 2.111120332d, $ + 0.000701d, 3894.181829542d, 2.760823491d, $ + 0.000689d, -135.065080035d, 4.768800780d, $ + 0.000700d, 13367.972631107d, 5.760439898d, $ + 0.000664d, 6040.347246017d, 1.051215840d, $ + 0.000654d, 5650.292110678d, 4.911332503d, $ + 0.000788d, 6681.224853400d, 4.699648011d, $ + 0.000628d, 5333.900241022d, 5.024608847d, $ + 0.000755d, -110.206321219d, 4.370971253d, $ + 0.000628d, 6290.189396992d, 3.660478857d, $ + 0.000635d, 25132.303399966d, 4.121051532d, $ + 0.000534d, 5966.683980335d, 1.173284524d, $ + 0.000543d, -433.711737877d, 0.345585464d, $ + 0.000517d, -1990.745017041d, 5.414571768d, $ + 0.000504d, 5767.611978898d, 2.328281115d, $ + 0.000485d, 5753.384884897d, 1.685874771d ] +fbldata = [ fbldata, $ + 0.000463d, 7860.419392439d, 5.297703006d, $ + 0.000604d, 515.463871093d, 0.591998446d, $ + 0.000443d, 12168.002696575d, 4.830881244d, $ + 0.000570d, 199.072001436d, 3.899190272d, $ + 0.000465d, 10969.965257698d, 0.476681802d, $ + 0.000424d, -7079.373856808d, 1.112242763d, $ + 0.000427d, 735.876513532d, 1.994214480d, $ + 0.000478d, -6127.655450557d, 3.778025483d, $ + 0.000414d, 10973.555686350d, 5.441088327d, $ + 0.000512d, 1589.072895284d, 0.107123853d, $ + 0.000378d, 10984.192351700d, 0.915087231d, $ + 0.000402d, 11371.704689758d, 4.107281715d, $ + 0.000453d, 9917.696874510d, 1.917490952d, $ + 0.000395d, 149.563197135d, 2.763124165d, $ + 0.000371d, 5739.157790895d, 3.112111866d, $ + 0.000350d, 11790.629088659d, 0.440639857d, $ + 0.000356d, 6133.512652857d, 5.444568842d, $ + 0.000344d, 412.371096874d, 5.676832684d, $ + 0.000383d, 955.599741609d, 5.559734846d, $ + 0.000333d, 6496.374945429d, 0.261537984d, $ + 0.000340d, 6055.549660552d, 5.975534987d, $ + 0.000334d, 1066.495477190d, 2.335063907d, $ + 0.000399d, 11506.769769794d, 5.321230910d, $ + 0.000314d, 18319.536584880d, 2.313312404d, $ + 0.000424d, 1052.268383188d, 1.211961766d ] +fbldata = [ fbldata, $ + 0.000307d, 63.735898303d, 3.169551388d, $ + 0.000329d, 29.821438149d, 6.106912080d, $ + 0.000357d, 6309.374169791d, 4.223760346d, $ + 0.000312d, -3738.761430108d, 2.180556645d, $ + 0.000301d, 309.278322656d, 1.499984572d, $ + 0.000268d, 12043.574281889d, 2.447520648d, $ + 0.000257d, 12491.370101415d, 3.662331761d, $ + 0.000290d, 625.670192312d, 1.272834584d, $ + 0.000256d, 5429.879468239d, 1.913426912d, $ + 0.000339d, 3496.032826134d, 4.165930011d, $ + 0.000283d, 3930.209696220d, 4.325565754d, $ + 0.000241d, 12528.018664345d, 3.832324536d, $ + 0.000304d, 4686.889407707d, 1.612348468d, $ + 0.000259d, 16200.772724501d, 3.470173146d, $ + 0.000238d, 12139.553509107d, 1.147977842d, $ + 0.000236d, 6172.869528772d, 3.776271728d, $ + 0.000296d, -7058.598461315d, 0.460368852d, $ + 0.000306d, 10575.406682942d, 0.554749016d, $ + 0.000251d, 17298.182327326d, 0.834332510d, $ + 0.000290d, 4732.030627343d, 4.759564091d, $ + 0.000261d, 5884.926846583d, 0.298259862d, $ + 0.000249d, 5547.199336460d, 3.749366406d, $ + 0.000213d, 11712.955318231d, 5.415666119d, $ + 0.000223d, 4701.116501708d, 2.703203558d, $ + 0.000268d, -640.877607382d, 0.283670793d ] +fbldata = [ fbldata, $ + 0.000209d, 5636.065016677d, 1.238477199d, $ + 0.000193d, 10177.257679534d, 1.943251340d, $ + 0.000182d, 6283.143160294d, 2.456157599d, $ + 0.000184d, -227.526189440d, 5.888038582d, $ + 0.000182d, -6283.008539689d, 0.241332086d, $ + 0.000228d, -6284.056171060d, 2.657323816d, $ + 0.000166d, 7238.675591600d, 5.930629110d, $ + 0.000167d, 3097.883822726d, 5.570955333d, $ + 0.000159d, -323.505416657d, 5.786670700d, $ + 0.000154d, -4136.910433516d, 1.517805532d, $ + 0.000176d, 12029.347187887d, 3.139266834d, $ + 0.000167d, 12132.439962106d, 3.556352289d, $ + 0.000153d, 202.253395174d, 1.463313961d, $ + 0.000157d, 17267.268201691d, 1.586837396d, $ + 0.000142d, 83996.847317911d, 0.022670115d, $ + 0.000152d, 17260.154654690d, 0.708528947d, $ + 0.000144d, 6084.003848555d, 5.187075177d, $ + 0.000135d, 5756.566278634d, 1.993229262d, $ + 0.000134d, 5750.203491159d, 3.457197134d, $ + 0.000144d, 5326.786694021d, 6.066193291d, $ + 0.000160d, 11015.106477335d, 1.710431974d, $ + 0.000133d, 3634.621024518d, 2.836451652d, $ + 0.000134d, 18073.704938650d, 5.453106665d, $ + 0.000134d, 1162.474704408d, 5.326898811d, $ + 0.000128d, 5642.198242609d, 2.511652591d ] +fbldata = [ fbldata, $ + 0.000160d, 632.783739313d, 5.628785365d, $ + 0.000132d, 13916.019109642d, 0.819294053d, $ + 0.000122d, 14314.168113050d, 5.677408071d, $ + 0.000125d, 12359.966151546d, 5.251984735d, $ + 0.000121d, 5749.452731634d, 2.210924603d, $ + 0.000136d, -245.831646229d, 1.646502367d, $ + 0.000120d, 5757.317038160d, 3.240883049d, $ + 0.000134d, 12146.667056108d, 3.059480037d, $ + 0.000137d, 6206.809778716d, 1.867105418d, $ + 0.000141d, 17253.041107690d, 2.069217456d, $ + 0.000129d, -7477.522860216d, 2.781469314d, $ + 0.000116d, 5540.085789459d, 4.281176991d, $ + 0.000116d, 9779.108676125d, 3.320925381d, $ + 0.000129d, 5237.921013804d, 3.497704076d, $ + 0.000113d, 5959.570433334d, 0.983210840d, $ + 0.000122d, 6282.095528923d, 2.674938860d, $ + 0.000140d, -11.045700264d, 4.957936982d, $ + 0.000108d, 23543.230504682d, 1.390113589d, $ + 0.000106d, -12569.674818332d, 0.429631317d, $ + 0.000110d, -266.607041722d, 5.501340197d, $ + 0.000115d, 12559.038152982d, 4.691456618d, $ + 0.000134d, -2388.894020449d, 0.577313584d, $ + 0.000109d, 10440.274292604d, 6.218148717d, $ + 0.000102d, -543.918059096d, 1.477842615d, $ + 0.000108d, 21228.392023546d, 2.237753948d ] +fbldata = [ fbldata, $ + 0.000101d, -4535.059436924d, 3.100492232d, $ + 0.000103d, 76.266071276d, 5.594294322d, $ + 0.000104d, 949.175608970d, 5.674287810d, $ + 0.000101d, 13517.870106233d, 2.196632348d, $ + 0.000100d, 11933.367960670d, 4.056084160d ] + +i2terms = n_elements(fbldata)/3 +; T**2 +fbldata = [ fbldata, $ + 4.322990d, 6283.075849991d, 2.642893748d, $ + 0.406495d, 0.000000000d, 4.712388980d, $ + 0.122605d, 12566.151699983d, 2.438140634d, $ + 0.019476d, 213.299095438d, 1.642186981d, $ + 0.016916d, 529.690965095d, 4.510959344d, $ + 0.013374d, -3.523118349d, 1.502210314d, $ + 0.008042d, 26.298319800d, 0.478549024d, $ + 0.007824d, 155.420399434d, 5.254710405d, $ + 0.004894d, 5746.271337896d, 4.683210850d, $ + 0.004875d, 5760.498431898d, 0.759507698d, $ + 0.004416d, 5223.693919802d, 6.028853166d, $ + 0.004088d, -7.113547001d, 0.060926389d, $ + 0.004433d, 77713.771467920d, 3.627734103d, $ + 0.003277d, 18849.227549974d, 2.327912542d, $ + 0.002703d, 6062.663207553d, 1.271941729d, $ + 0.003435d, -775.522611324d, 0.747446224d, $ + 0.002618d, 6076.890301554d, 3.633715689d, $ + 0.003146d, 206.185548437d, 5.647874613d, $ + 0.002544d, 1577.343542448d, 6.232904270d, $ + 0.002218d, -220.412642439d, 1.309509946d, $ + 0.002197d, 5856.477659115d, 2.407212349d, $ + 0.002897d, 5753.384884897d, 5.863842246d, $ + 0.001766d, 426.598190876d, 0.754113147d, $ + 0.001738d, -796.298006816d, 2.714942671d, $ + 0.001695d, 522.577418094d, 2.629369842d ] +fbldata = [ fbldata, $ + 0.001584d, 5507.553238667d, 1.341138229d, $ + 0.001503d, -242.728603974d, 0.377699736d, $ + 0.001552d, -536.804512095d, 2.904684667d, $ + 0.001370d, -398.149003408d, 1.265599125d, $ + 0.001889d, -5573.142801634d, 4.413514859d, $ + 0.001722d, 6069.776754553d, 2.445966339d, $ + 0.001124d, 1059.381930189d, 5.041799657d, $ + 0.001258d, 553.569402842d, 3.849557278d, $ + 0.000831d, 951.718406251d, 2.471094709d, $ + 0.000767d, 4694.002954708d, 5.363125422d, $ + 0.000756d, 1349.867409659d, 1.046195744d, $ + 0.000775d, -11.045700264d, 0.245548001d, $ + 0.000597d, 2146.165416475d, 4.543268798d, $ + 0.000568d, 5216.580372801d, 4.178853144d, $ + 0.000711d, 1748.016413067d, 5.934271972d, $ + 0.000499d, 12036.460734888d, 0.624434410d, $ + 0.000671d, -1194.447010225d, 4.136047594d, $ + 0.000488d, 5849.364112115d, 2.209679987d, $ + 0.000621d, 6438.496249426d, 4.518860804d, $ + 0.000495d, -6286.598968340d, 1.868201275d, $ + 0.000456d, 5230.807466803d, 1.271231591d, $ + 0.000451d, 5088.628839767d, 0.084060889d, $ + 0.000435d, 5643.178563677d, 3.324456609d, $ + 0.000387d, 10977.078804699d, 4.052488477d, $ + 0.000547d, 161000.685737473d, 2.841633844d ] +fbldata = [ fbldata, $ + 0.000522d, 3154.687084896d, 2.171979966d, $ + 0.000375d, 5486.777843175d, 4.983027306d, $ + 0.000421d, 5863.591206116d, 4.546432249d, $ + 0.000439d, 7084.896781115d, 0.522967921d, $ + 0.000309d, 2544.314419883d, 3.172606705d, $ + 0.000347d, 4690.479836359d, 1.479586566d, $ + 0.000317d, 801.820931124d, 3.553088096d, $ + 0.000262d, 419.484643875d, 0.606635550d, $ + 0.000248d, 6836.645252834d, 3.014082064d, $ + 0.000245d, -1592.596013633d, 5.519526220d, $ + 0.000225d, 4292.330832950d, 2.877956536d, $ + 0.000214d, 7234.794256242d, 1.605227587d, $ + 0.000205d, 5767.611978898d, 0.625804796d, $ + 0.000180d, 10447.387839604d, 3.499954526d, $ + 0.000229d, 199.072001436d, 5.632304604d, $ + 0.000214d, 639.897286314d, 5.960227667d, $ + 0.000175d, -433.711737877d, 2.162417992d, $ + 0.000209d, 515.463871093d, 2.322150893d, $ + 0.000173d, 6040.347246017d, 2.556183691d, $ + 0.000184d, 6309.374169791d, 4.732296790d, $ + 0.000227d, 149854.400134205d, 5.385812217d, $ + 0.000154d, 8031.092263058d, 5.120720920d, $ + 0.000151d, 5739.157790895d, 4.815000443d, $ + 0.000197d, 7632.943259650d, 0.222827271d, $ + 0.000197d, 74.781598567d, 3.910456770d ] +fbldata = [ fbldata, $ + 0.000138d, 6055.549660552d, 1.397484253d, $ + 0.000149d, -6127.655450557d, 5.333727496d, $ + 0.000137d, 3894.181829542d, 4.281749907d, $ + 0.000135d, 9437.762934887d, 5.979971885d, $ + 0.000139d, -2352.866153772d, 4.715630782d, $ + 0.000142d, 6812.766815086d, 0.513330157d, $ + 0.000120d, -4705.732307544d, 0.194160689d, $ + 0.000131d, -71430.695617928d, 0.000379226d, $ + 0.000124d, 6279.552731642d, 2.122264908d, $ + 0.000108d, -6256.777530192d, 0.883445696d ] + +i3terms = n_elements(fbldata)/3 +; T**3 +fbldata = [ fbldata, $ + 0.143388d, 6283.075849991d, 1.131453581d, $ + 0.006671d, 12566.151699983d, 0.775148887d, $ + 0.001480d, 155.420399434d, 0.480016880d, $ + 0.000934d, 213.299095438d, 6.144453084d, $ + 0.000795d, 529.690965095d, 2.941595619d, $ + 0.000673d, 5746.271337896d, 0.120415406d, $ + 0.000672d, 5760.498431898d, 5.317009738d, $ + 0.000389d, -220.412642439d, 3.090323467d, $ + 0.000373d, 6062.663207553d, 3.003551964d, $ + 0.000360d, 6076.890301554d, 1.918913041d, $ + 0.000316d, -21.340641002d, 5.545798121d, $ + 0.000315d, -242.728603974d, 1.884932563d, $ + 0.000278d, 206.185548437d, 1.266254859d, $ + 0.000238d, -536.804512095d, 4.532664830d, $ + 0.000185d, 522.577418094d, 4.578313856d, $ + 0.000245d, 18849.227549974d, 0.587467082d, $ + 0.000180d, 426.598190876d, 5.151178553d, $ + 0.000200d, 553.569402842d, 5.355983739d, $ + 0.000141d, 5223.693919802d, 1.336556009d, $ + 0.000104d, 5856.477659115d, 4.239842759d ] + +i4terms = n_elements(fbldata)/3 +; T**4 +fbldata = [ fbldata, $ + 0.003826d, 6283.075849991d, 5.705257275d, $ + 0.000303d, 12566.151699983d, 5.407132842d, $ + 0.000209d, 155.420399434d, 1.989815753d ] + + nterms = n_elements(fbldata)/3 + fbldata = reform(fbldata, 3, nterms, /overwrite) + const0 = reform(fbldata[0,*], nterms) + freq0 = reform(fbldata[1,*], nterms) + phase0 = reform(fbldata[2,*], nterms) + + texp = dblarr(nterms) + 0 + texp[i1terms:i2terms-1] = 1 + texp[i2terms:i3terms-1] = 2 + texp[i3terms:i4terms-1] = 3 + texp[i4terms:* ] = 4 + + endif + + if n_elements(tbase) EQ 0 then tbase = 0D + t = ((tbase[0]-2451545D) + jd[0])/365250.0D + if t EQ 0 then t = 1d-100 + + ph = freq0 * t + phase0 + sint = sin( ph ) + sinf = const0 * t^texp + + dt = total(sinf*sint)*1d-6 + if arg_present(deriv) then $ + deriv = total(sinf*(texp*sint/t + freq0*cos(ph)))*(1d-6/365250.0D) + + return, dt +end + +function tdb2tdt, jd, deriv=deriv, tbase=tbase + + sz = size(jd) + if sz[0] EQ 0 then $ + return, tdb2tdt_calc(jd, deriv=deriv, tbase=tbase) + + result = reform(double(jd), sz[1:sz[0]]) + if arg_present(deriv) then begin + deriv = reform(double(jd), sz[1:sz[0]]) + for i = 0L, sz[sz[0]+2]-1 do begin + result[i] = tdb2tdt_calc(jd[i], deriv=dd, tbase=tbase) + deriv[i] = dd + endfor + endif else begin + for i = 0L, sz[sz[0]+2]-1 do begin + result[i] = tdb2tdt_calc(jd[i], tbase=tbase) + endfor + endelse + + return, result +end + diff --git a/modules/idl_downloads/astro/pro/ten.pro b/modules/idl_downloads/astro/pro/ten.pro new file mode 100644 index 0000000..e3b894c --- /dev/null +++ b/modules/idl_downloads/astro/pro/ten.pro @@ -0,0 +1,93 @@ + FUNCTION ten,dd,mm,ss +;+ +; NAME: +; TEN() +; PURPOSE: +; Converts a sexagesimal number or string to decimal. +; EXPLANATION: +; Inverse of the SIXTY() function. +; +; CALLING SEQUENCES: +; X = TEN( [ HOUR_OR_DEG, MIN, SEC ] ) +; X = TEN( HOUR_OR_DEG, MIN, SEC ) +; X = TEN( [ HOUR_OR_DEG, MIN ] ) +; X = TEN( HOUR_OR_DEG, MIN ) +; X = TEN( [ HOUR_OR_DEG ] ) <-- Trivial cases +; X = TEN( HOUR_OR_DEG ) <-- +; +; or +; X = TEN(HRMNSC_STRING) +; +; INPUTS: +; HOUR_OR_DEG,MIN,SEC -- Scalars giving sexagesimal quantity in +; in order from largest to smallest. +; or +; HRMNSC_STRING - String giving sexagesmal quantity separated by +; spaces or colons e.g. "10 23 34" or "-3:23:45.2" +; Any negative values should begin with a minus sign. +; OUTPUTS: +; Function value returned = double real scalar, decimal equivalent of +; input sexigesimal quantity. For numeric input, a minus sign on any +; nonzero element of the input vector causes all the elements to be taken +; as < 0. +; +; EXAMPLES: +; IDL> print,ten(0,-23,34) +; --> -0.39277778 +; IDL> print,ten("-0:23:34") +; --> -0.39277778 +; PROCEDURE: +; Mostly involves checking arguments and setting the sign. +; +; The procedure TENV can be used when dealing with a vector of +; sexigesimal quantities. +; +; MODIFICATION HISTORY: +; Written by R. S. Hill, STX, 21 April 87 +; Modified to allow non-vector arguments. RSH, STX, 19-OCT-87 +; Recognize -0.0 W. Landsman/B. Stecklum Dec 2005 +; Work with string input W. Landsman Dec 2008 +;- + compile_opt idl2 + np = N_params() + + if (np eq 1) then begin + if size(dd,/TNAME) EQ 'STRING' then begin + temp = strtrim(dd,2) + neg = strmid(dd,0,1) EQ '-' + temp = repchr(temp,':',' ') + value = abs(double(gettok(temp,' '))) + mm = double(gettok(temp,' ')) + decimal = value + mm/60. + double(temp)/3600.0d + if neg then decimal = -decimal + return,decimal + endif else vector=dd + endif else begin + if (np lt 1) or (np gt 3) then goto,bad_args + vector=dblarr(3) + vector[0]=dd + vector[1]=mm + if np gt 2 then vector[2]=ss + endelse + sz = size(vector) + ndim = sz[0] + if (ndim eq 0) then return,double(vector) + facs=[1.0d0,60.0d0,3600.0d0] + nel = sz[1] + sign = +1.0d0 + dummy=where(strpos(string(vector),'-') ge 0,cnt) + if cnt gt 0 then sign = -1.0d0 + vector = abs(vector) + decim = double(vector[0]) + i = 1 + while (i le nel-1) do begin + decim = decim + double(vector[i])/facs[i] + i = i + 1 + endwhile + return,decim*sign +bad_args: + print,'Argument(s) should be hours/degrees, minutes (optional),' + print,'seconds (optional) in vector or as separate arguments.' + print,'If any one number negative, all taken as negative.' + return,0.0d0 + end diff --git a/modules/idl_downloads/astro/pro/tenv.pro b/modules/idl_downloads/astro/pro/tenv.pro new file mode 100644 index 0000000..c029235 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tenv.pro @@ -0,0 +1,106 @@ + FUNCTION tenv,dd,mm,ss +;+ +; NAME: +; TENV() +; PURPOSE: +; Converts sexagesimal number or string vector to decimal. +; EXPLANATION: +; Like TEN() but allows vector input. +; +; CALLING SEQUENCES: +; Result = TENV( dd, mm ) ; result = dd + mm/60. +; Result = TENV( dd, mm, ss) ; result = dd + mm/60. + ss/3600. +; or +; Result = TENV(ddmmss_string) +; INPUTS: +; dd - sexagesimal element(s) corresponding to hours or degrees +; mm - sexagesimal element(s) corresponding to minutes +; ss - sexagesimal element(s) corresponding to seconds (optional) +; The input parameters can be scalars or vectors. However, the +; number of elements in each parameter must be the same. +; +; HRMNSC_STRING - String scalar or vector giving sexagesmal quantity +; separated by spaces or colons e.g. "10 23 34" or "-3:23:45.2" +; Any negative values should begin with a minus sign. +; OUTPUTS: +; Result - double, decimal equivalent of input sexagesimal +; quantities. Same number of elements as the input parameters. +; If the nth element in any of the input parameters is negative +; then the nth element in Result will also be negative. +; +; EXAMPLE: +; If dd = [60,60,0], and mm = [30,-30,-30], then +; +; IDL> Result = TENV(dd,mm) ====> Result = [60.5,-60.5,-0.5] +; +; Alternatively, the input could be written as the string vector +; IDL> str = ['60:30','-60:30','-0:30'] +; IDL> print,tenv(str) ====> Result = [60.5,-60.5,-0.5] +; +; WARNING: +; TENV() will recognize floating point values of -0.0 as negative numbers. +; However, there is no distinction in the binary representation of -0 +; and 0 (integer values), and so TENV will treat both values as positive. +; PROCEDURES USED: +; GETTOK(), REPCHR() for string processing. +; PROCEDURE: +; Mostly involves checking arguments and setting the sign. +; +; MODIFICATION HISTORY: +; Written by W.B. Landsman April, 1991 +; Recognize -0.0 W. Landsman/B. Stecklum Dec 2005 +; Work with string input W. Landsman Feb 2009 +; +;- + compile_opt idl2 + On_error,2 ;Return to caller + + npar = N_params() + npts = N_elements(dd) + if npts EQ 0 then begin + print,'Syntax - RESULT = TENV( dd, mm, ss)' + return, 0.0d + endif + + if ( npar EQ 1 ) then begin + if size(dd,/TNAME) EQ 'STRING' then begin + temp = strtrim(dd,2) + temp = repchr(temp,':',' ') + neg = where( strmid(temp,0,1) EQ '-', Nneg) + value = abs(double(gettok(temp,' '))) + mm = double(gettok(temp,' ')) + decimal = value + mm/60. + double(temp)/3600.0d + if Nneg GT 0 then decimal[neg] = -decimal[neg] + return,decimal + + endif else return,double( dd ) ;No need to check for neg values. + endif + + value = double( abs(dd) ) + + if ( npar GT 1 ) then begin ;Add minutes/60., check for <0 + + if N_elements(mm) NE npts then $ + message,'ERROR - Number of elements in each parameter must be equal' + nd=(strpos(string(dd),'-') ge 0) + nm=(strpos(string(mm),'-') ge 0) + neg = nd OR nm + value = value + abs(mm)/60.0d + + endif + + if ( npar GT 2 ) then begin ;Add sec/3600., check for <0 + + if N_elements(ss) NE npts then $ + message,'ERROR - Number of elements in each parameter must be equal' + ns=(strpos(string(ss),'-') ge 0) + neg = neg OR ns + value = value + abs(ss)/3600.0d + + endif + + neg = where( neg, Nfound ) ;Account for negative values + if ( Nfound GT 0 ) then value[neg] = -value[neg] + + return,value + end diff --git a/modules/idl_downloads/astro/pro/textclose.pro b/modules/idl_downloads/astro/pro/textclose.pro new file mode 100644 index 0000000..e05be10 --- /dev/null +++ b/modules/idl_downloads/astro/pro/textclose.pro @@ -0,0 +1,46 @@ +pro textclose,textout=textout +;+ +; NAME: +; TEXTCLOSE +; +; PURPOSE: +; Close a text outpu file previously opened with TEXTOPEN +; EXPLANATION: +; procedure to close file for text output as specifed +; by the (non-standard) system variable !TEXTOUT. +; +; CALLING SEQUENCE: +; textclose, [ TEXTOUT = ] +; +; KEYWORDS: +; textout - Indicates output device that was used by +; TEXTOPEN +; +; SIDE EFFECTS: +; if !textout is not equal to 5 and the textunit is +; opened. Then unit !textunit is closed and released +; +; HISTORY: +; D. Lindler Dec. 1986 (Replaces PRTOPEN) +; Test if TEXTOUT is a scalar string W. Landsman August 1993 +; Can't close unit -1 (Standard Output) I. Freedman April 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +;- +;----------------------------------------------------------- +; CLOSE PROPER UNIT +; + + if N_elements( textout ) EQ 0 then textout = !textout ;use default + + ptype = size( textout ) ;Test if TEXTOUT is a scalar string + if ptype[1] EQ 7 then text_out = 6 else text_out = textout + + if ( text_out NE 5 ) then begin + if !textunit ne 0 AND !textunit ne -1 then begin + free_lun, !TEXTUNIT + !textunit = 0 + end + end + + return + end diff --git a/modules/idl_downloads/astro/pro/textopen.pro b/modules/idl_downloads/astro/pro/textopen.pro new file mode 100644 index 0000000..6432539 --- /dev/null +++ b/modules/idl_downloads/astro/pro/textopen.pro @@ -0,0 +1,217 @@ +PRO TEXTOPEN,PROGRAM,TEXTOUT=TEXTOUT, STDOUT = STDOUT, MORE_SET = more_set, $ + SILENT = silent, WIDTH = width +;+ +; NAME: +; TEXTOPEN +; PURPOSE: +; Open a device specified by TEXTOUT with unit !TEXTUNIT +; EXPLANATION: +; Procedure to open file for text output. The type of output +; device (disk file or terminal screen) is specified by the +; TEXTOUT keyword or the (nonstandard) system variable !TEXTOUT. +; +; CALLING SEQUENCE: +; textopen, program, [ TEXTOUT =, /STDOUT, /SILENT, MORE_SET=, WIDTH= ] +; +; INPUTS: +; program - scalar string giving name of program calling textopen +; +; OPTIONAL INPUT KEYWORDS: +; TEXTOUT - Integer scalar (0-7) specifying output file/device to be +; opened (see below) or scalar string giving name of output file. +; If TEXTOUT is not supplied, then the (non-standard) system +; variable !TEXTOUT is used. +; /SILENT - By default, TEXTOPEN prints an informational message when +; opening a file for hardcopy output. Set /SILENT (or !QUIET) +; to suppress this message. +; /STDOUT - if this keyword is set and non-zero, then the standard output +; (unit = -1) is used for TEXTOUT=1 or TEXTOUT=2. The use +; of STDOUT has 2 possible advantages: +; (1) the output will appear in a journal file +; (2) Many Unix machines print spurious control characters when +; printing to /dev/tty. These characters are eliminated by +; setting /STDOUT +; +; The disadvantage of /STDOUT is that the /MORE option is not +; available. +; +; WIDTH - Specify line width for hardcopy output line wrapping (passed onto OPENW). +; +; OPTIONAL OUTPUT KEYWORD: +; MORE_SET - Returns 1 if the output unit was opened with /MORE. This +; occurs if (1) TEXTOUT = 1 and (2) the device is a tty, and +; (3) /STDOUT is not set. User can use the returned value +; of MORE_SET to determine whether to end output when user +; presses 'Q'. +; SIDE EFFECTS: +; The following dev/file is opened for output. Different effects +; occur depending whether the standard output is a GUI (Macintosh, +; Windows, Unix/IDLTool) or a TTY +; +; textout=0 Nowhere +; textout=1 if a TTY then TERMINAL using /more option +; otherwise standard (Unit=-1) output +; textout=2 if a TTY then TERMINAL without /more option +; otherwise standard (Unit=-1) output +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 same as 3 but text is appended to .prt +; file if it already exists. +; textout = filename (default extension of .prt) +; +; The unit to be opened is obtained with the procedure GET_LUN +; unless !TEXTOUT=5. The unit number is placed in system variable +; !TEXTUNIT. For !TEXTOUT=5 the user must set !TEXTUNIT to the +; appropriate unit number. +; +; NOTES: +; When printing to a TTY terminal, the output will *not* appear in an +; IDL JOURNAL session, unlike text printed with the PRINT command. +; +; NON-STANDARD SYSTEM VARIABLES: +; TEXTOPEN will automatically define the following system variables if +; they are not previously defined: +; +; DEFSYSV,'!TEXTOUT',1 +; DEFSYSV,'!TEXTUNIT',0 +; HISTORY: +; D. Lindler Dec. 1986 +; Keyword textout added, J. Isensee, July, 1990 +; Made transportable, D. Neill, April, 1991 +; Trim input PROGRAM string W. Landsman Feb 1993 +; Don't modify TEXTOUT value W. Landsman Aug 1993 +; Modified for MacOS I. Freedman April 1994 +; Modified for output terminals without a TTY W. Landsman August 1995 +; Added /STDOUT keyword W. Landsman April 1996 +; added textout=7 option, D. Lindler, July, 1996 +; Exit with RETURN instead of RETALL W. Landsman June 1999 +; In IDL V5.4 filepath(/TERMINAL) not allowed in the IDLDE WL August 2001 +; Added MORE_SET output keyword W.Landsman January 2002 +; Added /SILENT keyword W. Landsman June 2002 +; Define !TEXTOUT and !TEXTUNIT if needed. R. Sterner, 2002 Aug 27 +; Return Calling Sequence if no parameters supplied W.Landsman Nov 2002 +; Remove VMS specific code W. Landsman Sep 2006 +; Make sure MORE_SET is always defined W. Landsman Jan 2007 +; Added WIDTH keyword J. Bailin Nov 2010 +; Use V6.0 notation W. Landsman April 2011 +;- +;----------------------------------------------------------- + On_Error,2 + compile_opt idl2 + + if N_params() LT 1 then begin + print,'Syntax - TEXTOPEN, program, [ TEXTOUT =, /STDOUT, /SILENT,' + print,' MORE_SET=, WIDTH= ]' + return + endif + + defsysv,'!TEXTOUT',exists=ex ; Check if !TEXTOUT exists. + if ex eq 0 then defsysv,'!TEXTOUT',1 ; If not define it. + defsysv,'!TEXTUNIT',exists=ex ; Check if !TEXTUNIT exists. + if ex eq 0 then defsysv,'!TEXTUNIT',0 ; If not define it. + more_set = 0 + ; + ; Open proper unit. + ; + if N_elements( textout ) NE 1 then textout = !textout ;use default output dev. + + ; keywords for openw + if n_elements(width) gt 0 then openw_keywords = {width: width} + + if size(textout,/tname) EQ 'STRING' then begin ;test if filename entered + filename = textout + j = strpos(filename,'.') ;test if file extension given + if j lt 0 then filename = filename + ".prt" + text_out = 6 + endif else text_out = textout + + if TEXT_OUT eq 5 then begin + if !TEXTUNIT eq 0 then begin + print,' ' + print,' You must set !TEXTUNIT to the desired unit number...' + print,' ...see following example' + print,' ' + print,' OPENW, LUN, filename, /GET_LUN + print,' !TEXTUNIT = LUN + print,' DBPRINT... + print,' + print,' Action: returning' + print,' ' + return + end + return + end + stndout = fstat(-1) + isatty = (stndout.isatty) && (~stndout.isagui) && $ + (~keyword_set(STDOUT)) + + if isatty || (text_out GT 2) then begin + + if !TEXTUNIT GT 0 then free_lun,!TEXTUNIT + get_lun,unit + !TEXTUNIT = unit + + endif else !TEXTUNIT = -1 ;standard output + + more_set = (text_out EQ 1) && isatty + + case text_out of + 1: if isatty then openw, !TEXTUNIT, filepath(/TERMINAL), /MORE, _extra=openw_keywords + + 2: if isatty then openw, !TEXTUNIT, filepath(/TERMINAL) , _extra=openw_keywords + + 3: begin + oname = strlowcase( strtrim( PROGRAM,2) +'.prt') + openw, !TEXTUNIT, oname, _extra=openw_keywords + if ~keyword_set(SILENT) then $ + message,'Output is being directed to a file ' + oname,/INFORM + end + + 4: openw, !TEXTUNIT, 'laser.tmp', _extra=openw_keywords + + 6: begin + openw,!TEXTUNIT,filename, _extra=openw_keywords + if ~keyword_set(SILENT) then $ + message,'Output is being directed to a file ' + filename,/INFORM + end + + 7: begin + oname = strlowcase(strtrim( PROGRAM,2) +'.prt') + openw, !TEXTUNIT, oname, /append, _extra=openw_keywords + if ~keyword_set(SILENT) then $ + message,'Output is being appended to file ' + oname,/INFORM + for i=0,3 do printf,!textunit,' ' ;added a couple of blank lines + end + + 0: openw,!TEXTUNIT, strtrim(PROGRAM,2) + '.tmp',/DELETE, _extra=openw_keywords + + else: begin + !textunit = 0 + print,' ' + print,' Invalid value for TEXTOUT =',TEXTOUT + print,' ' + print,' ...the possibilities are: + print,' ' + print,' textout=0 nowhere + if isatty then begin + print,' textout=1 terminal with /more + print,' textout=2 terminal without /more + endif else begin + print,' textout=1 terminal + print,' textout=2 terminal + endelse + print,' textout=3 file .prt + print,' textout=4 file laser.tmp + print,' textout=5 User supplied file + print,' textout = filename (default extension of .prt) + print,' textout=7 Same as 3 but append the file + print,' ' + print,' Action: returning + print,' ' + return + end + endcase + + return + end ; textout diff --git a/modules/idl_downloads/astro/pro/tic_one.pro b/modules/idl_downloads/astro/pro/tic_one.pro new file mode 100644 index 0000000..3521471 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tic_one.pro @@ -0,0 +1,63 @@ +pro tic_one, min, pixx, incr, min2, tic1, RA=ra +;+ +; NAME: +; TIC_ONE +; PURPOSE: +; Determine the position of the first tic mark for astronomical images. +; EXPLANATION: +; For use in labelling images with right ascension +; and declination axes. This routine determines the +; position in pixels of the first tic. +; +; CALLING SEQUENCE: +; tic_one, zmin, pixx, incr, min2, tic1, [RA = ] +; +; INPUTS: +; zmin - astronomical coordinate value at axis zero point (degrees +; or hours) +; pixx - distance in pixels between tic marks (usually obtained from TICS) +; incr - increment in minutes for labels (usually an even number obtained +; from the procedure TICS) +; +; OUTPUTS: +; min2 - astronomical coordinate value at first tic mark +; tic1 - position in pixels of first tic mark +; +; EXAMPLE: +; Suppose a declination axis has a value of 30.2345 degrees at its +; zero point. A tic mark is desired every 10 arc minutes, which +; corresponds to 12.74 pixels. Then +; +; IDL> TIC_ONE, 30.2345, 1, 12.74, min2, tic1 +; +; yields values of min2 = 30.333 and tic1 = 5.74, i.e. the first tic +; mark should be labeled 30 deg 20 minutes and be placed at pixel value +; 5.74 +; +; REVISION HISTORY: +; by B. Pfarr, 4/15/87 +; Converted to IDL V5.0 W. Landsman September 1997 +;- + On_error,2 +; convert min to minutes + if keyword_set(RA) then mul = 4.0000 else mul = 60.00000 + min1 = min*mul ;Convert from degrees to minutes +; + incra = abs(incr) + rem = min1 mod incra ;get remainder + sign = min1*incr + + if ( sign GT 0 ) then begin + + tic1 = pixx - abs(rem)*(pixx/incra) + min2 = (min1+incr-rem)/mul + + endif else begin + + tic1 = abs(rem)*(pixx/incra) + min2 = (min1 - rem)/mul + + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/ticlabels.pro b/modules/idl_downloads/astro/pro/ticlabels.pro new file mode 100644 index 0000000..91d07e9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/ticlabels.pro @@ -0,0 +1,233 @@ +pro ticlabels, minval, numtics, incr, ticlabs, RA=ra, DELTA=delta, FONT=font +;+ +; NAME: +; TICLABELS +; PURPOSE: +; Create tic labels for labeling astronomical images. +; EXPLANATION: +; Used to display images with right ascension or declination +; axes. This routine creates labels for already determined tic +; marks (every other tic mark by default) +; +; CALLING SEQUENCE: +; TICLABELS, minval, numtics, incr, ticlabs, [ RA = ,DELTA = ] +; +; INPUTS: +; minval - minimum value for labels (degrees) +; numtics - number of tic marks +; incr - increment in minutes for labels +; +; OUTPUTS: +; ticlabs - array of charater string labels +; +; OPTIONAL INPUT KEYWORDS: +; /RA - if this keyword is set then the grid axis is assumed to be +; a Right Ascension. Otherwise a declination axis is assumed +; DELTA - Scalar specifying spacing of labels. The default is +; DELTA = 2 which means that a label is made for every other tic +; mark. Set DELTA=1 to create a label for every tic mark. +; FONT - scalar font graphics keyword (-1,0 or 1) for text +; +; PROCEDURES USED: +; RADEC +; +; RESTRICTIONS: +; Invalid for wide field (> 2 degree) images since it assumes that a +; fixed interval in Y (or X) corresponds to a fixed interval in Dec +; (or RA) +; +; REVISON HISTORY: +; written by B. Pfarr, 4/15/87 +; Added DELTA keywrd for compatibility with IMCONTOUR W. Landsman Nov 1991 +; Added nicer hms and dms symbols when using native PS fonts Deutsch 11/92 +; Added Patch for bug in IDL <2.4.0 as explained in NOTES E. Deutsch 11/92 +; Fix when crossing 0 dec or 24h RA +; Fix DELTA keyword so that it behaves according to the documentation +; W. Landsman Hughes STX, Nov 95 +; Allow sub arcsecond formatting W. Landsman May 2000 +; Better formatting for non-unity DELTA values W. Landsman July 2004 +; Allow FONT keyword to be passed. T. Robishaw Apr. 2006 +; Write 0h rather than 24h W. L. August 2008 +; Fix problem when tic values is exactly 0 degrees Mar 2012 +; Only modulo 24 when /RA is set WL. October 2012 +;- + On_error,2 + compile_opt idl2 +; convert min to hours, minutes, secs + if N_params() LT 4 then begin + + print,'Syntax - ticlabels, minval, numtics, incr, ticlabs, ' + $ + '[ /RA ,DELTA = ]' + return + + endif + + if N_elements(FONT) eq 0 then font = !p.font + + ticlabs = replicate(' ',numtics ) + + if minval LT 0 then begin + neg = -1 & sgn = '-' + endif else begin + neg = 1 & sgn = '' + endelse + firstval = minval + if ~keyword_set( DELTA ) then delta = 2 + + + if keyword_set( RA ) then begin ;Define RA tic symbols + + radec, firstval, 0, minh, minm, mins, dum1, dum2, dum3 + sd = '!Ah!N' & sm = '!Am!N' & ss = '!As!N' + + if (!d.name eq 'PS') and (font eq 0) then begin ;Postscript fonts? + sd ='!Uh!N' & sm='!Um!N' & ss='!Us!N' + endif + + endif else begin + + radec, 0, firstval, dum1, dum2, dum3, minh, minm, mins + minm = abs(minm) + mins = abs(mins) + sd = "!Ao!N" & sm = "'" & ss = "''" + + if (!d.name eq 'PS') and (font eq 0) then begin + + RtEF = '!X' + sd = '!9' + string(176b) + RtEF + sm = '!9' + string(162b) + RtEF + ss = '!9' + string(178b) + RtEF + endif + + endelse + + inc1 = incr*60.0d + inc = incr*60.0d*delta ;increment in arc seconds + if abs(inc1) GE 1.0 then begin + mins = round(mins) + sfmt = '(i2.2)' + endif else $ + if abs(inc1) GT 0.1 then sfmt = '(f4.1)' else sfmt = '(f5.2)' + if abs(inc) GE 1.0 then inc = round(inc) + + + while (mins GE 60) do begin + mins = mins - 60 + minm++ + endwhile + + if (minm ge 60) then begin + minm = minm - 60 + minh = minh + neg + endif + + + if (abs(mins) GT 1) || (abs(incr) LT 1.0/DELTA) then begin ;Seconds + + ticlabs[0] = sgn + string( abs(minh), '(i2.2)') + sd + ' ' + $ + string(minm,'(i2.2)') + sm + ' ' + string( mins, sfmt) + ss + + for i = delta,numtics-1, delta do begin + + mins = mins + neg*inc + if ( ( mins GE 60) || (mins LE 0) ) then begin + + while ( mins GE 60 ) do begin + mins = mins - 60 + minm++ + endwhile + + while ( mins LT 0 ) do begin + mins = mins + 60 + minm-- + endwhile + + if (minm ge 60) then begin + minm = minm - 60 + minh = minh + neg + ticlabs[i]= sgn + string(abs(minh),'(i2.2)') + sd + ' ' + $ + string(minm,'(i2.2)') + sm + + endif else if (minm LE 0) then begin + + if minh EQ 0 then begin ;Cross zero Dec or RA? + if keyword_set(RA) then begin + minh = 23 + minm = minm + 60 + endif else begin + minm = -minm + neg = -neg + if neg EQ 1 then sgn = '' else sgn = '-' + endelse + endif else begin + minm = minm + 60 + minh = minh - neg + endelse + + ticlabs[i]= sgn + string(abs(minh),'(i2.2)') + sd + ' ' + $ + string((minm),'(i2)') + sm + ' ' +string(mins,sfmt) + ss + + + endif else ticlabs[i] = string( minm, '(i2.2)' ) + sm + ' '+ $ + string( mins, sfmt) + ss + + endif else ticlabs[i] = string( mins, sfmt ) + ss + + endfor + + endif else $ + if (abs(minm) gt 1) || (abs(incr) LT 60.0/DELTA) then begin ;MINUTES + + inc = fix(incr*DELTA) + ticlabs[0] = sgn + string(abs(minh),'(i2.2)')+ sd+ ' ' + $ + string(minm,'(i2.2)') + sm + for i = delta,numtics-1, delta do begin + minm = minm + neg*inc + + if (minm ge 60) then begin + minm = minm - 60 + minh = minh + neg + if keyword_set(RA) then begin + while minh LT 0 do minh = minh + 24 + while minh GE 24 do minh = minh - 24 + endif + ticlabs[i]= sgn + string(abs(minh),'(i2.2)') + sd + ' ' + $ + string(minm,'(i2.2)') +sm + + endif else if (minm LT 0) then begin + + if minh EQ 0 then begin ;Cross zero Dec or RA? + if keyword_set(RA) then begin + minh = 23 + minm = minm + 60 + endif else begin + minm = -minm + neg = -neg + if neg EQ 1 then sgn = '' else sgn = '-' + endelse + endif else begin + minm = minm + 60 + minh = minh - neg + endelse + ticlabs[i]= sgn + string(abs(minh),'(i2.2)') + sd + ' ' + $ + string((minm),'(i2.2)') + sm + endif else ticlabs[i] = string(minm,'(i2.2)') + endfor + endif else begin ;Hours/Degrees + + inc = fix(DELTA*incr/60.0) + ticlabs[0] = strtrim(minh,2) + sd + for i = delta,numtics-1, delta do begin + minh = minh + inc + if keyword_set(RA) then begin + + while minh LT 0 do minh = minh + 24 + while minh GE 24 do minh = minh - 24 + endif + ticlabs[i] = strtrim( minh,2) + sd + endfor + + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/ticpos.pro b/modules/idl_downloads/astro/pro/ticpos.pro new file mode 100644 index 0000000..92e621a --- /dev/null +++ b/modules/idl_downloads/astro/pro/ticpos.pro @@ -0,0 +1,88 @@ +pro ticpos,deglen,pixlen,ticsize,incr,units ;Compute tic positions +;+ +; NAME: +; TICPOS +; PURPOSE: +; Specify distance between tic marks for astronomical coordinate overlays +; EXPLANATION: +; User inputs number an approximate distance +; between tic marks, and the axis length in degrees. TICPOS will return +; a distance between tic marks such that the separation is a round +; multiple in arc seconds, arc minutes, or degrees +; +; CALLING SEQUENCE: +; TICPOS, deglen, pixlen, ticsize, incr, units +; +; INPUTS: +; deglen - length of axis in DEGREES +; pixlen - length of axis in plotting units (pixels) +; ticsize - distance between tic marks (pixels). This value will be +; adjusted by TICPOS such that the distance corresponds to +; a round multiple in the astronomical coordinate. +; +; OUTPUTS: +; ticsize - distance between tic marks (pixels), positive scalar +; incr - incremental value for tic marks in round units given +; by the UNITS parameter +; units - string giving units of ticsize, either 'ARC SECONDS', +; 'ARC MINUTES', or 'DEGREES' +; +; EXAMPLE: +; Suppose a 512 x 512 image array corresponds to 0.2 x 0.2 degrees on +; the sky. A tic mark is desired in round angular units, approximately +; every 75 pixels. +; +; IDL> ticsize = 75 +; IDL> TICPOS,0.2,512,ticsize,incr,units +; +; ==> ticsize = 85.333, incr = 2. units = 'Arc Minutes' +; +; i.e. a good tic mark spacing is every 2 arc minutes, corresponding +; to 85.333 pixels. +; +; REVISON HISTORY: +; written by W. Landsman November, 1988 +; Converted to IDL V5.0 W. Landsman September 1997 +; Don't use all capital letters W. Landsman May 2003 +; Fix case where incr crosses degree/minute or minute/degree boundary +; A. Mortier/W.Landsman April 2005 +;- + On_error,2 + + minpix = deglen*60./pixlen ;Arc minute per pixel + incr = minpix*ticsize ;Arc minutes between tics + + if (incr LT 0 ) then sgn = -1 else sgn = 1 + incr = abs(incr) + if ( incr GE 30 ) then units = 'Degrees' else $ + if ( incr LE 0.5 ) then units = 'Arc Seconds' $ + else units = 'Arc Minutes' +; determine increment + case 1 of + + incr GE 120.0 : incr = 4. ;degrees + incr GE 60.0 : incr = 2. ;degrees + incr GE 30.0 : incr = 1. ;degrees + incr GT 15.0 : incr = 30. ;minutes + incr GE 10.0 : incr = 15. ;minutes + incr GE 5.0 : incr = 10. ;minutes + incr GE 2.0 : incr = 5. ;minutes + incr GE 1.0 : incr = 2. ;minutes + incr GT 0.5 : incr = 1. ;minutes + incr GE 0.25 : incr = 30. ;seconds + incr GE 0.16 : incr = 15. ;seconds + incr GE 0.08 : incr = 10. ;seconds + incr GE 0.04 : incr = 5. ;seconds + incr GE 0.02 : incr = 2. ;seconds + incr LT 0.02 : incr = 1. ;seconds + + endcase + + if ( units EQ 'Arc Seconds' ) then minpix = minpix*60. else $ + if ( units EQ 'Degrees' ) then minpix = minpix/60. + + ticsize= incr/abs(minpix) ;determine ticsize + incr = incr*sgn + + return + end diff --git a/modules/idl_downloads/astro/pro/tics.pro b/modules/idl_downloads/astro/pro/tics.pro new file mode 100644 index 0000000..ab28918 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tics.pro @@ -0,0 +1,76 @@ +pro tics,radec_min,radec_max,numx,ticsize,incr,RA=ra +;+ +; NAME: +; TICS +; PURPOSE: +; Compute a nice increment between tic marks for astronomical images. +; EXPLANATION: +; For use in labelling a displayed image with right ascension +; or declination axes. An approximate distance between tic +; marks is input, and a new value is computed such that the +; distance between tic marks is in simple increments of the +; tic label values. +; +; CALLING SEQUENCE: +; tics, radec_min, radec_max, numx, ticsize, incr, [ /RA ] +; +; INPUTS: +; radec_min - minimum axis value (degrees) +; radec_max - maximum axis value (degrees) +; numx - number of pixels in x direction +; +; INPUT/OUTPUT +; ticsize - distance between tic marks (pixels) +; +; OUTPUTS: +; incr - incremental value for tic labels (in minutes of +; time for R.A., minutes of arc for dec.) +; +; REVISON HISTORY: +; written by B. Pfarr, 4/14/87 +; Added some more tick precision (i.e. 1 & 2 seconds in case:) EWD May92 +; Added sub arcsecond tick precision W. Landsman May 2000 +; Plate scale off by 1 pixel W. Landsman July 2004 +;- + On_error,2 + + numtics = numx/ticsize ;initial number of tics + +; Convert total distance to arc minutes for dec. or to +; minutes of time for r.a. + + if keyword_set(RA) then mul = 4.0 else mul = 60. + mins = abs(radec_min-radec_max)*mul ;total distance in minutes + rapix = (numx-1)/mins ;pixels per minute + incr = mins/numtics ;minutes per tic + +; determine increment + case 1 of + incr GE 120.0 : incr = 480.0 ; 4 hours + incr GE 60.0 : incr = 120.0 ; 2 hours + incr GE 30.0 : incr = 60.0 ; 1 hour + incr GE 15.0 : incr = 30.0 ; 30 minutes + incr GE 10.0 : incr = 15.0 ; 15 minutes + incr GE 5.0 : incr = 10.0 ; 10 minutes + incr GE 2.0 : incr = 5.0 ; 5 minutes + incr GE 1.0 : incr = 2.0 ; 2 minutes + incr GE 0.5 : incr = 1.0 ; 1 minute + incr GE 0.25 : incr = 0.5 ; 30 seconds + incr GE 10/60.0d : incr = 0.25 ; 15 seconds + incr GE 5/60.0d : incr = 10/60.0d ; 10 seconds + incr GE 2/60.0d : incr = 5/60.0d ; 5 seconds + incr GE 1/60.0d : incr = 2/60.0d ; 2 seconds + incr GE 0.5/60.0d : incr = 1./60.0d ; 1 seconds + incr GE 0.2/60.0d : incr = 0.5/60.0d ; 0.5 seconds + incr GE 0.1/60.0d : incr = 0.2/60.0d ; 0.2 seconds + incr GE 0.05/60.0d : incr = 0.1/60.0d ; 0.1 seconds + incr GE 0.02/60.0d : incr = 0.05/60.0d ; 0.05 seconds + incr GE 0.01/60.0d : incr = 0.02/60.0d ; 0.02 seconds + incr GE 0 : incr = 0.01/60.0d ; 0.01 seconds + endcase + + ticsize = rapix*incr ;determine ticsize + if ( radec_min GT radec_max ) then incr = -incr + + return + end diff --git a/modules/idl_downloads/astro/pro/tnx_eval.pro b/modules/idl_downloads/astro/pro/tnx_eval.pro new file mode 100644 index 0000000..67d9f51 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tnx_eval.pro @@ -0,0 +1,132 @@ +function TNX_eval, xy + +;+ +; NAME: +; TNX_EVAL +; PURPOSE: +; Compute distorted coordinates given TNX (Tangent + Iraf tnx +; distortion polynomial) coefficients. +; EXPLANATION: +; See http://fits.gsfc.nasa.gov/registry/tnx.html for the TNX convention +; +; This distortion convention is used by IRAF. +; +; The coefficients and information are passed via common block. This is because this +; routine is called by the intrinisc BROYDEN() function in AD2XY, and +; common blocks are the only way to pass parameters to the user supplied +; function in BROYDEN(). +; CALLING SEQUENCE: +; res = TNX_EVAL(xy) +; INPUTS: +; xy - 2 elements vector giving the undistorted X,Y position +; OUTPUTS: +; res - 2 element vector giving the distorted position +; COMMON BLOCKS: +; common broyden_coeff,pv1,pv2 +; +; pv1, pv2 are both structures giving the TNX coefficients. The +; pv1/pv2 naming convention is a hangover from tpv_eval.pro on +; which this approach is heavily based. +; pv1.functype gives the TNX function type. Only type 3 +; (polynominal) is supported. +; pv1.xterms gives the type of cross-terms (1: full, 2: half, 0: none) +; pv1.etaorder gives the order in eta +; pv1.xiorder gives the order in xi +; pv1.coeff gives the actual coefficients. +; REVISION HISTORY: +; Written M. Sullivan Mar 2014 +;- + +compile_opt idl2,hidden +common broyden_coeff,pv1,pv2 + +lngcor=pv1 +latcor=pv2 + +if N_elements(xy) EQ 2 then begin + x = xy[0] + y = xy[1] +endif else begin + x = reform(xy[*,0]) + y = reform(xy[*,1]) +endelse + +IF(lngcor.functype NE 3 || latcor.functype NE 3)THEN BEGIN + PRINT,'ERROR in tnx_eval: only functype=3 (polynominal) is supported)' + RETURN,0 +ENDIF + + +IF(lngcor.functype EQ 1 || lngcor.functype EQ 2)THEN xin = (2. * x - (lngcor.ximax + lngcor.ximin)) / (lngcor.ximax - lngcor.ximin) ELSE xin=x +IF(latcor.functype EQ 1 || latcor.functype EQ 2)THEN etain = (2. * y - (latcor.etamax + latcor.etamin)) / (latcor.etamax - latcor.etamin) ELSE yin=y + +xp=0.d0 +icount=0L +IF(lngcor.xterms EQ 1)THEN BEGIN + ;; full cross-terms + FOR n=0,lngcor.etaorder-1 DO BEGIN + FOR m=0,lngcor.xiorder-1 DO BEGIN + xp=xp + xin^m * yin^n * lngcor.coeff[icount] + icount++ + ENDFOR + ENDFOR +ENDIF ELSE IF(lngcor.xterms EQ 0)THEN BEGIN + ;; no cross-terms + FOR m=0,lngcor.xiorder-1 DO BEGIN + xp=xp + xin^m * lngcor.coeff[icount] + icount++ + ENDFOR + FOR n=0,lngcor.etaorder-1 DO BEGIN + xp=xp + yin^n * lngcor.coeff[icount] + icount++ + ENDFOR +ENDIF ELSE IF(lngcor.xterms EQ 2)THEN BEGIN + ;; half cross terms + maxxt=MAX([lngcor.xiorder,lngcor.etaorder])-1 + FOR n=0,lngcor.etaorder-1 DO BEGIN + FOR m=0,lngcor.xiorder-1 DO BEGIN + IF(m+n GT maxxt)THEN CONTINUE + xp=xp + xin^m * yin^n * lngcor.coeff[icount] + icount++ + ENDFOR + ENDFOR +ENDIF + +yp=0.d0 +icount=0L +IF(latcor.xterms EQ 1)THEN BEGIN + ;; full cross-terms + FOR n=0,latcor.etaorder-1 DO BEGIN + FOR m=0,latcor.xiorder-1 DO BEGIN + yp=yp + xin^m * yin^n * latcor.coeff[icount] + icount++ + ENDFOR + ENDFOR +ENDIF ELSE IF(latcor.xterms EQ 0)THEN BEGIN + ;; no cross-terms + FOR m=0,latcor.xiorder-1 DO BEGIN + yp=yp + xin^m * latcor.coeff[icount] + icount++ + ENDFOR + FOR n=0,latcor.etaorder-1 DO BEGIN + yp=yp + yin^n * latcor.coeff[icount] + icount++ + ENDFOR +ENDIF ELSE IF(latcor.xterms EQ 2)THEN BEGIN + ;; half cross terms + maxxt=MAX([latcor.xiorder,latcor.etaorder])-1 + FOR n=0,latcor.etaorder-1 DO BEGIN + FOR m=0,latcor.xiorder-1 DO BEGIN + IF(m+n GT maxxt)THEN CONTINUE + yp=yp + xin^m * yin^n * latcor.coeff[icount] + icount++ + ENDFOR + ENDFOR +ENDIF + +xp=x+xp +yp=y+yp + +return, [[xp],[yp]] + +end diff --git a/modules/idl_downloads/astro/pro/to_hex.pro b/modules/idl_downloads/astro/pro/to_hex.pro new file mode 100644 index 0000000..4203397 --- /dev/null +++ b/modules/idl_downloads/astro/pro/to_hex.pro @@ -0,0 +1,44 @@ +FUNCTION TO_HEX, D, NCHAR +;+ +; NAME: +; TO_HEX +; PURPOSE: +; Translate a non-negative decimal integer to a hexadecimal string +; CALLING SEQUENCE: +; HEX = TO_HEX( D, [ NCHAR ] ) +; INPUTS: +; D - non-negative decimal integer, scalar or vector. If input as a +; string, (e.g. '32') then all leading blanks are removed. +; +; OPTIONAL INPUT: +; NCHAR - number of characters in the output hexadecimal string. +; If not supplied, then the hex string will contain no +; leading zeros. +; +; OUTPUT: +; HEX - hexadecimal translation of input integer, string +; +; EXAMPLES: +; IDL> A = TO_HEX([11,16]) ==> A = ['B','10'] +; IDL> A = TO_HEX(100,3) ==> A = '064' +; +; METHOD: +; The hexadecimal format code '(Z)' is used to convert. No parameter +; checking is done. +; PROCEDURES CALLED: +; None. +; REVISION HISTORY: +; Written W. Landsman November, 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +; Use FSTRING() for more than 1024 values March 2000 +; Assume since V5.4, omit FSTRING() call April 2006 +;- + + if N_elements(nchar) EQ 0 then format = '(Z)' else begin + ch = strtrim( nchar, 2 ) + format = '(Z' + ch + '.' + ch + ')' + endelse + + return, strtrim( string(d, FORM = format), 2) + + end diff --git a/modules/idl_downloads/astro/pro/tpv_eval.pro b/modules/idl_downloads/astro/pro/tpv_eval.pro new file mode 100644 index 0000000..d502472 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tpv_eval.pro @@ -0,0 +1,157 @@ +function TPV_eval, xy +;+ +; NAME: +; TPV_EVAL +; PURPOSE: +; Compute distorted coordinates given TPV (Tangent + PV_ polynomial) +; coefficients. +; EXPLANATION: +; See http://fits.gsfc.nasa.gov/registry/tpvwcs.html for the TPV convention +; +; This distortion convention is used by the SCAMP software +; ( http://www.astromatic.net/software/scamp ) though SCAMP does not +; include the '-TPV' in the CTYPE keyword. +; +; The coefficients are passed via common block. This is because this +; routine is called by the intrinisc BROYDEN() function in AD2XY, and +; common blocks are the only way to pass parameters to the user supplied +; function in BROYDEN(). +; CALLING SEQUENCE: +; res = TPV_EVAL(xy) +; INPUTS: +; xy - 2 elements vector giving the undistorted X,Y position +; OUTPUTS: +; res - 2 element vector giving the distorted position +; COMMON BLOCKS: +; common broyden_coeff,pv1,ycoeff +; +; pv1, YCOEFF are both vectors giving the TPV coefficients +; REVISION HISTORY: +; Written W. Landsman Dec 2013 +; Correct several typos for 4th power terms M. Sullivan Mar 2014 +; Corrected 4th order terms once again and +; added 5th,6th and 7th order terms Arjun Dey Sep 3, 2015 +;- +compile_opt idl2,hidden +common broyden_coeff,pv1,pv2 + +Npv1 = N_elements(pv1) +NPv2 = N_elements(pv2) + +if N_elements(xy) EQ 2 then begin + x = xy[0] + y = xy[1] +endif else begin + x = reform(xy[*,0]) + y = reform(xy[*,1]) +endelse +x2 = x*x +y2 = y*y + +xp = pv1[0] + pv1[1]*x + pv1[2]*y +if Npv1 GT 3 && (pv1[3] NE 0.0) then xp += pv1[3]*sqrt(x2 + y2) +if Npv1 GT 4 && (pv1[4] NE 0.0) then xp += pv1[4]*x2 +if Npv1 GT 5 && (pv1[5] NE 0.0) then xp += pv1[5]*x*y +if Npv1 GT 6 && (pv1[6] NE 0.0) then xp += pv1[6]*y2 +if Npv1 GT 7 then begin + if pv1[7] NE 0.0 then xp += pv1[7]*x^3 + if Npv1 GT 8 && (pv1[8] NE 0.0) then xp += pv1[8]*x2*y + if Npv1 GT 9 && (pv1[9] NE 0.0) then xp += pv1[9]*x*y2 + if Npv1 GT 10 && (pv1[10] NE 0.0) then xp += pv1[10]*y2*y + if Npv1 GT 11 && (pv1[11] NE 0.0) then xp += pv1[11]*sqrt(x2+y2)^3 + if Npv1 GT 12 then begin + if (pv1[12] NE 0.0) then xp += pv1[12]*x2*x2 + if Npv1 GT 13 && (pv1[13] NE 0.0) then xp += pv1[13]*x2*x*y + if Npv1 GT 14 && (pv1[14] NE 0.0) then xp += pv1[14]*x2*y2 + if Npv1 GT 15 && (pv1[15] NE 0.0) then xp += pv1[15]*x*y2*y + if Npv1 GT 16 && (pv1[16] NE 0.0) then xp += pv1[16]*y2*y2 + if Npv1 GT 17 then begin + x4 = x2*x2 + y4 = y2*y2 + if (pv1[17] NE 0.0) then xp += pv1[17]*x4*x + if Npv1 GT 18 && (pv1[18] NE 0.0) then xp += pv1[18]*x4*y + if Npv1 GT 19 && (pv1[19] NE 0.0) then xp += pv1[19]*x2*x*y2 + if Npv1 GT 20 && (pv1[20] NE 0.0) then xp += pv1[20]*x2*y2*y + if Npv1 GT 21 && (pv1[21] NE 0.0) then xp += pv1[21]*x*y4 + if Npv1 GT 22 && (pv1[22] NE 0.0) then xp += pv1[22]*y4*y + if Npv1 GT 23 && (pv1[23] NE 0.0) then xp += pv1[23]*sqrt(x2+y2)^5 + if Npv1 GT 24 then begin + if (pv1[24] NE 0.0) then xp += pv2[24]*x4*x2 + if Npv1 GT 25 && (pv1[25] NE 0.0) then xp += pv1[25]*x4*x*y + if Npv1 GT 26 && (pv1[26] NE 0.0) then xp += pv1[26]*x4*y2 + if Npv1 GT 27 && (pv1[27] NE 0.0) then xp += pv1[27]*x2*x*y2*y + if Npv1 GT 28 && (pv1[28] NE 0.0) then xp += pv1[28]*x2*y4 + if Npv1 GT 29 && (pv1[29] NE 0.0) then xp += pv1[29]*x*y4*y + if Npv1 GT 30 && (pv1[30] NE 0.0) then xp += pv1[30]*y4*y2 + if Npv1 GT 31 then begin + if (pv1[31] NE 0.0) then xp += pv1[31]*x4*x2*x + if Npv1 GT 32 && (pv1[32] NE 0.0) then xp += pv1[32]*x4*x2*y + if Npv1 GT 33 && (pv1[33] NE 0.0) then xp += pv1[33]*x4*x*y2 + if Npv1 GT 34 && (pv1[34] NE 0.0) then xp += pv1[34]*x4*y2*y + if Npv1 GT 35 && (pv1[35] NE 0.0) then xp += pv1[35]*x2*x*y4 + if Npv1 GT 36 && (pv1[36] NE 0.0) then xp += pv1[36]*x2*y*y4 + if Npv1 GT 37 && (pv1[37] NE 0.0) then xp += pv1[37]*x*y2*y4 + if Npv1 GT 38 && (pv1[38] NE 0.0) then xp += pv1[38]*y4*y2*y + if Npv1 GT 39 && (pv1[39] NE 0.0) then xp += pv1[39]*sqrt(x2+y2)^7 + if Npv1 GT 40 then print,'PV1 TERMS > 40 (ORDER > 7) NOT EVALUATED' + endif + endif + endif + endif + endif + +yp = pv2[0] + pv2[1]*y + pv2[2]*x +if Npv2 GT 3 && (pv2[3] NE 0.0) then yp += pv2[3]*sqrt(x2 + y2) +if NPv2 GT 4 && (pv2[4] NE 0.0) then yp += pv2[4]*y2 +if NPv2 GT 5 && (pv2[5] NE 0.0) then yp += pv2[5]*x*y +if NPv2 GT 6 && (pv2[6] NE 0.0) then yp += pv2[6]*x2 +if NPv2 GT 7 then begin + if pv2[7] NE 0.0 then yp += pv2[7]*y^3 + if NPv2 GT 8 && (pv2[8] NE 0.0) then yp += pv2[8]*y2*x + if NPv2 GT 9 && (pv2[9] NE 0.0) then yp += pv2[9]*y*x2 + if NPv2 GT 10 && (pv2[10] NE 0.0) then yp += pv2[10]*x2*x + if NPv2 GT 11 && (pv2[11] NE 0.0) then yp += pv2[11]*sqrt(x2+y2)^3 + if NPv2 GT 12 then begin + if (pv2[12] NE 0.0) then yp += pv2[12]*y2*y2 + if NPv2 GT 13 && (pv2[13] NE 0.0) then yp += pv2[13]*y2*y*x + if NPv2 GT 14 && (pv2[14] NE 0.0) then yp += pv2[14]*y2*x2 + if NPv2 GT 15 && (pv2[15] NE 0.0) then yp += pv2[15]*y*x2*x + if NPv2 GT 16 && (pv2[16] NE 0.0) then yp += pv2[16]*x2*x2 + if Npv2 GT 17 then begin + x4 = x2*x2 + y4 = y2*y2 + if (pv2[17] NE 0.0) then yp += pv2[17]*y4*y + if Npv2 GT 18 && (pv2[18] NE 0.0) then yp += pv2[18]*y4*x + if Npv2 GT 19 && (pv2[19] NE 0.0) then yp += pv2[19]*y2*y*x2 + if Npv2 GT 20 && (pv2[20] NE 0.0) then yp += pv2[20]*y2*x2*x + if Npv2 GT 21 && (pv2[21] NE 0.0) then yp += pv2[21]*y*x4 + if Npv2 GT 22 && (pv2[22] NE 0.0) then yp += pv2[22]*x4*x + if Npv2 GT 23 && (pv2[23] NE 0.0) then yp += pv2[23]*sqrt(x2+y2)^5 + if Npv2 GT 24 then begin + if (pv2[24] NE 0.0) then yp += pv2[24]*y4*y2 + if Npv2 GT 25 && (pv2[25] NE 0.0) then yp += pv2[25]*y4*y*x + if Npv2 GT 26 && (pv2[26] NE 0.0) then yp += pv2[26]*y4*x2 + if Npv2 GT 27 && (pv2[27] NE 0.0) then yp += pv2[27]*y2*y*x2*x + if Npv2 GT 28 && (pv2[28] NE 0.0) then yp += pv2[28]*y2*x4 + if Npv2 GT 29 && (pv2[29] NE 0.0) then yp += pv2[29]*y*x4*x + if Npv2 GT 30 && (pv2[30] NE 0.0) then yp += pv2[30]*x4*x2 + if Npv2 GT 31 then begin + if (pv2[31] NE 0.0) then yp += pv2[31]*y4*y2*y + if Npv2 GT 32 && (pv2[32] NE 0.0) then yp += pv2[32]*y4*y2*x + if Npv2 GT 33 && (pv2[33] NE 0.0) then yp += pv2[33]*y4*y*x2 + if Npv2 GT 34 && (pv2[34] NE 0.0) then yp += pv2[34]*y4*x2*x + if Npv2 GT 35 && (pv2[35] NE 0.0) then yp += pv2[35]*y2*y*x4 + if Npv2 GT 36 && (pv2[36] NE 0.0) then yp += pv2[36]*y2*x*x4 + if Npv2 GT 37 && (pv2[37] NE 0.0) then yp += pv2[37]*y*x2*x4 + if Npv2 GT 38 && (pv2[38] NE 0.0) then yp += pv2[38]*x4*x2*x + if Npv2 GT 39 && (pv2[39] NE 0.0) then yp += pv2[39]*sqrt(x2+y2)^7 + if Npv2 GT 40 then print,'PV2 TERMS > 40 (ORDER > 7) NOT EVALUATED' + endif + endif + endif + endif + endif + +return, [[xp],[yp]] + +end diff --git a/modules/idl_downloads/astro/pro/transform_coeff.pro b/modules/idl_downloads/astro/pro/transform_coeff.pro new file mode 100644 index 0000000..b8094f1 --- /dev/null +++ b/modules/idl_downloads/astro/pro/transform_coeff.pro @@ -0,0 +1,62 @@ + +function transform_coeff, coeff, alpha, beta +;+ +; NAME: +; TRANSFORM_COEFF() +; PURPOSE: +; Compute new polynomial coefficients under a linear transformation +; EXPLANATION: +; Suppose one has a (nonlinear) polynomial (similar to the POLY() function) +; y = C[0] + C[1]*x + C[2]*x^2 + C[3]*x^3 + ... +; +; and one has a linear transformation in X +; +; x = alpha*x' + beta +; This function computes the new polynomial coefficients under the linear +; transformation. +; +; CALLING SEQUENCE: +; newcoeff = TRANSFORM_COEFF( coeff, alpha, beta) +; INPUTS: +; Coeff - vector of polynomial coefficients (as with POLY()). The +; degree of the polynomial is N_elements(coeff) - 1 +; Alpha, Beta - numeric scalars defining the linear transformation in X +; OUTPUTS: +; NewCoeff - Vector (same size as Coeff) giving the new polynomial +; coefficients +; EXAMPLE: +; Suppose one has polynomial mapping a nonlinear distortion in the X +; direction of a spectrum +; +; y = 0.2 + 1.1*x + 0.1*x^2 +; +; if one rebins the spectrum to half the size then the linear transformation +; is x = 2.*x' +; so alpha = 2 and beta = 0 +; The new coefficients are +; IDL> print, transform_coeff([0.2,1.1,0.1],2.,0) +; ==> [0.2, 2.2, 0.4] +; METHOD: +; Performs a binomial expansion of the polynomial and collect like terms +; groups.google.com/group/comp.lang.idl-pvwave/msg/11132d96d9c0f93d?hl=en& +; REVISION HISTORY: +; Written W. Landsman December 2007 +;- +compile_opt idl2 +if N_Params() LT 3 then begin + print,'Syntax - newcoeff = TRANSFORM_COEFF( coeff, alpha, beta) ' + if N_elements(coeff) GT 0 then return,coeff else return,-1 +endif +degree=n_elements(coeff)-1 + +newarray=coeff*0 + +FOR i=0,degree DO BEGIN + FOR j=0,i DO BEGIN + newarray[j] = newarray[j] + $ + coeff[i]*factorial(i)*alpha^j*beta^(i-j)/factorial(j)/factorial(i-j) + ENDFOR +ENDFOR + +return, newarray +end diff --git a/modules/idl_downloads/astro/pro/trapzd.pro b/modules/idl_downloads/astro/pro/trapzd.pro new file mode 100644 index 0000000..11e0cda --- /dev/null +++ b/modules/idl_downloads/astro/pro/trapzd.pro @@ -0,0 +1,82 @@ +pro trapzd, func, a, b, s, step, _EXTRA = _EXTRA +;+ +; NAME: +; TRAPZD +; PURPOSE: +; Compute the nth stage of refinement of an extended trapezoidal rule. +; EXPLANATION: +; This procedure is called by QSIMP and QTRAP. Algorithm from Numerical +; Recipes, Section 4.2. TRAPZD is meant to be called iteratively from +; a higher level procedure. +; +; CALLING SEQUENCE: +; TRAPZD, func, A, B, S, step, [ _EXTRA = ] +; +; INPUTS: +; func - scalar string giving name of function to be integrated. This +; must be a function of one variable. +; A,B - scalars giving the limits of the integration +; +; INPUT-OUTPUT: +; S - scalar giving the total sum from the previous iterations on +; input and the refined sum after the current iteration on output. +; +; step - LONG scalar giving the number of points at which to compute the +; function for the current iteration. If step is not defined on +; input, then S is intialized using the average of the endpoints +; of limits of integration. +; +; OPTIONAL INPUT KEYWORDS: +; Any supplied keywords will be passed to the user function via the +; _EXTRA facility. +; +; NOTES: +; (1) TRAPZD will check for math errors (except for underflow) when +; computing the function at the endpoints, but not on subsequent +; iterations. +; +; (2) TRAPZD always uses double precision to sum the function values +; but the call to the user-supplied function is double precision only if +; one of the limits A or B is double precision. +; REVISION HISTORY: +; Written W. Landsman August, 1991 +; Always use double precision for TOTAL March, 1996 +; Pass keyword to function via _EXTRA facility W. Landsman July 1999 +; Don't check for floating underflow W.Landsman April 2008 +;- + On_error,2 + compile_opt idl2 + + kpresent = keyword_set(_EXTRA) + if N_elements(step) EQ 0 then begin ;Initialize? + +;If a math error occurs, it is likely to occur at the endpoints + junk = check_math() ; + if kpresent then s1 = CALL_FUNCTION(func,A, _EXTRA= _EXTRA) $ + else s1 = CALL_FUNCTION(func,A) + if check_math(mask=211) NE 0 then $ + message,'ERROR - Illegal lower bound of '+strtrim(A,2)+ $ + ' to function ' + strupcase(func) + if kpresent then s2 = CALL_FUNCTION(func,B, _EXTRA = _EXTRA) $ + else s2 = CALL_FUNCTION(func,B) + if check_math(mask=211) NE 0 then $ + message,'ERROR - Illegal upper bound of '+strtrim(B,2) + $ + ' to function ' + strupcase(func) + junk= check_math() + s = 0.5d * ( double(B)-A ) * ( s1+s2 ) ;First approx is average of endpoints + step = 1l + + endif else begin + + tnm = float( step ) + del = ( B - A ) / tnm ;Spacing of the points to add + x = A + 0.5*del + findgen( step ) * del ;Grid of points @ compute function + if kpresent then sum = CALL_FUNCTION( func, x, _EXTRA = _EXTRA) $ + else sum = CALL_FUNCTION( func, x) + S = 0.5d * ( S + (double(B)-A) * total( sum, /DOUBLE )/tnm ) + step = 2*step + + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/tsc.pro b/modules/idl_downloads/astro/pro/tsc.pro new file mode 100644 index 0000000..0ddecd7 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tsc.pro @@ -0,0 +1,595 @@ +FUNCTION tsc,value,posx,nx,posy,ny,posz,nz, $ + AVERAGE=average,WRAPAROUND=wraparound,NO_MESSAGE=no_message, $ + ISOLATED=isolated +;+ +; NAME: +; TSC +; +; PURPOSE: +; Interpolate an irregularly sampled field using a Triangular Shaped Cloud +; +; EXPLANATION: +; This function interpolates an irregularly sampled field to a +; regular grid using Triangular Shaped Cloud (nearest grid point +; gets weight 0.75-dx^2, points before and after nearest grid +; points get weight 0.5*(1.5-dx)^2, where dx is the distance +; from the sample to the grid point in units of the cell size). +; +; CATEGORY: +; Mathematical functions, Interpolation +; +; CALLING SEQUENCE: +; Result = TSC, VALUE, POSX, NX[, POSY, NY, POSZ, NZ, +; AVERAGE = average, WRAPAROUND = wraparound, +; ISOLATED = isolated, NO_MESSAGE = no_message] +; +; INPUTS: +; VALUE: Array of sample weights (field values). For e.g. a +; temperature field this would be the temperature and the +; keyword AVERAGE should be set. For e.g. a density field +; this could be either the particle mass (AVERAGE should +; not be set) or the density (AVERAGE should be set). +; POSX: Array of X coordinates of field samples, unit indices: [0,NX>. +; NX: Desired number of grid points in X-direction. +; +; OPTIONAL INPUTS: +; POSY: Array of Y coordinates of field samples, unit indices: [0,NY>. +; NY: Desired number of grid points in Y-direction. +; POSZ: Array of Z coordinates of field samples, unit indices: [0,NZ>. +; NZ: Desired number of grid points in Z-direction. +; +; KEYWORD PARAMETERS: +; AVERAGE: Set this keyword if the nodes contain field samples +; (e.g. a temperature field). The value at each grid +; point will then be the weighted average of all the +; samples allocated to it. If this keyword is not +; set, the value at each grid point will be the +; weighted sum of all the nodes allocated to it +; (e.g. for a density field from a distribution of +; particles). (D=0). +; WRAPAROUND: Set this keyword if you want the first grid point +; to contain samples of both sides of the volume +; (see below). +; ISOLATED: Set this keyword if the data is isolated, i.e. not +; periodic. In that case total `mass' is not conserved. +; This keyword cannot be used in combination with the +; keyword WRAPAROUND. +; NO_MESSAGE: Suppress informational messages. +; +; Example of default allocation of nearest grid points: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---| Range allocated to gridpoints ([0.0,1.0> --> 0, etc.) +; 0 1 2 3 4 posx +; +; Example of ngp allocation for WRAPAROUND: n0=4, *=gridpoint. +; +; 0 1 2 3 Index of gridpoints +; * * * * Grid points +; |---|---|---|---|-- Range allocated to gridpoints ([0.5,1.5> --> 1, etc.) +; 0 1 2 3 4=0 posx +; +; +; OUTPUTS: +; Prints that a TSC interpolation is being performed of x +; samples to y grid points, unless NO_MESSAGE is set. +; +; RESTRICTIONS: +; Field data is assumed to be periodic with the sampled volume +; the basic cell, unless ISOLATED is set. +; All input arrays must have the same dimensions. +; Position coordinates should be in `index units' of the +; desired grid: POSX=[0,NX>, etc. +; Keywords ISOLATED and WRAPAROUND cannot both be set. +; +; PROCEDURE: +; Nearest grid point is determined for each sample. +; TSC weights are computed for each sample. +; Samples are interpolated to the grid. +; Grid point values are computed (sum or average of samples). +; +; EXAMPLE: +; nx=20 +; ny=10 +; posx=randomu(s,1000) +; posy=randomu(s,1000) +; value=posx^2+posy^2 +; field=tsc(value,posx*nx,nx,posy*ny,ny,/average) +; surface,field,/lego +; +; NOTES: +; Use csc.pro or ngp.pro for lower order interpolation schemes. A +; standard reference for these interpolation methods is: R.W. Hockney +; and J.W. Eastwood, Computer Simulations Using Particles (New York: +; McGraw-Hill, 1981). +; +; MODIFICATION HISTORY: +; Written by Joop Schaye, Feb 1999. +; Check for overflow for large dimensions P. Riley/W. Landsman Dec. 1999 +;- + +nrsamples=n_elements(value) +nparams=n_params() +dim=(nparams-1)/2 + +IF dim LE 2 THEN BEGIN + nz=1 + IF dim EQ 1 THEN ny=1 +ENDIF +nxny=long(nx)*long(ny) + + +;--------------------- +; Some error handling. +;--------------------- + +on_error,2 ; Return to caller if an error occurs. + +IF NOT (nparams EQ 3 OR nparams EQ 5 OR nparams EQ 7) THEN BEGIN + message,'Incorrect number of arguments!',/continue + message,'Syntax: TSC, VALUE, POSX, NX[, POSY, NY, POSZ, NZ,' + $ + ' AVERAGE = average, WRAPAROUND = wraparound]' +ENDIF + +IF (nrsamples NE n_elements(posx)) OR $ + (dim GE 2 AND nrsamples NE n_elements(posy)) OR $ + (dim EQ 3 AND nrsamples NE n_elements(posz)) THEN $ + message,'Input arrays must have the same dimensions!' + +IF keyword_set(isolated) AND keyword_set(wraparound) THEN $ + message,'Keywords ISOLATED and WRAPAROUND cannot both be set!' + +IF NOT keyword_set(no_message) THEN $ + print,'Interpolating ' + strtrim(string(nrsamples,format='(i10)'),1) $ + + ' samples to ' + strtrim(string(nxny*nz,format='(i10)'),1) + $ + ' grid points using TSC...' + + +;----------------------- +; Calculate TSC weights. +;----------------------- + +; Compute weights per axis, in order to reduce memory (everything +; needs to be in memory if we compute all nearest grid points first). + +;************* +; X-direction. +;************* + +; Coordinates of nearest grid point (ngp). +IF keyword_set(wraparound) THEN ngx=fix(posx+0.5) $ +ELSE ngx=fix(posx)+0.5 + +; Distance from sample to ngp. +dngx=ngx-posx + +; Index of ngp. +IF keyword_set(wraparound) THEN kx2=temporary(ngx) $ +ELSE kx2=temporary(ngx)-0.5 +; Weight of ngp. +wx2=0.75-dngx*dngx + +; Point before ngp. +kx1=kx2-1 ; Index. +dx=1.0-dngx ; Distance to sample. +wx1=0.5*(1.5-temporary(dx))^2 ; TSC-weight. + +; Point after ngp. +kx3=kx2+1 ; Index. +dx=1.0+temporary(dngx) ; Distance to sample. +wx3=0.5*(1.5-temporary(dx))^2 ; TSC-weight. + +; Periodic boundary conditions. +bad=where(kx2 EQ 0,count) +IF count NE 0 THEN BEGIN ; Otherwise kx1=-1. + kx1[bad]=nx-1 + IF keyword_set(isolated) THEN wx1[bad]=0. +ENDIF +bad=where(kx2 EQ nx-1,count) +IF count NE 0 THEN BEGIN ; Otherwise kx3=nx. + kx3[bad]=0 + IF keyword_set(isolated) THEN wx3[bad]=0. +ENDIF +IF keyword_set(wraparound) THEN BEGIN + bad=where(kx2 EQ nx,count) + IF count NE 0 THEN BEGIN + kx2[bad]=0 + kx3[bad]=1 + ENDIF +ENDIF +bad=0 ; Free memory. + + +;************* +; Y-direction. +;************* + +IF dim GE 2 THEN BEGIN + ; Coordinates of nearest grid point (ngp). + IF keyword_set(wraparound) THEN ngy=fix(posy+0.5) $ + ELSE ngy=fix(posy)+0.5 + + ; Distance from sample to ngp. + dngy=ngy-posy + + ; Index of ngp. + IF keyword_set(wraparound) THEN ky2=temporary(ngy) $ + ELSE ky2=temporary(ngy)-0.5 + ; Weight of ngp. + wy2=0.75-dngy*dngy + + ; Point before ngp. + ky1=ky2-1 ; Index. + dy=1.0-dngy ; Distance to sample. + wy1=0.5*(1.5-temporary(dy))^2 ; TSC-weight. + + ; Point after ngp. + ky3=ky2+1 ; Index. + dy=1.0+temporary(dngy) ; Distance to sample. + wy3=0.5*(1.5-temporary(dy))^2 ; TSC-weight. + + ; Periodic boundary conditions. + bad=where(ky2 EQ 0,count) + IF count NE 0 THEN BEGIN ; Otherwise ky1=-1. + ky1[bad]=ny-1 + IF keyword_set(isolated) THEN wy1[bad]=0. + ENDIF + bad=where(ky2 EQ ny-1,count) + IF count NE 0 THEN BEGIN ; Otherwise ky3=ny. + ky3[bad]=0 + IF keyword_set(isolated) THEN wy3[bad]=0. + ENDIF + IF keyword_set(wraparound) THEN BEGIN + bad=where(ky2 EQ ny,count) + IF count NE 0 THEN BEGIN + ky2[bad]=0 + ky3[bad]=1 + ENDIF + ENDIF + bad=0 ; Free memory. +ENDIF ELSE BEGIN + ky1=0 + ky2=0 + wy1=1 + wy2=1 +ENDELSE + + +;************* +; Z-direction. +;************* + +IF dim EQ 3 THEN BEGIN + ; Coordinates of nearest grid point (ngp). + IF keyword_set(wraparound) THEN ngz=fix(posz+0.5) $ + ELSE ngz=fix(posz)+0.5 + + ; Distance from sample to ngp. + dngz=ngz-posz + + ; Index of ngp. + IF keyword_set(wraparound) THEN kz2=temporary(ngz) $ + ELSE kz2=temporary(ngz)-0.5 + ; Weight of ngp. + wz2=0.75-dngz*dngz + + ; Point before ngp. + kz1=kz2-1 ; Index. + dz=1.0-dngz ; Distance to sample. + wz1=0.5*(1.5-temporary(dz))^2 ; TSC-weight. + + ; Point after ngp. + kz3=kz2+1 ; Index. + dz=1.0+temporary(dngz) ; Distance to sample. + wz3=0.5*(1.5-temporary(dz))^2 ; TSC-weight. + + ; Periodic boundary conditions. + bad=where(kz2 EQ 0,count) + IF count NE 0 THEN BEGIN ; Otherwise kz1=-1. + kz1[bad]=nz-1 + IF keyword_set(isolated) THEN wz1[bad]=0. + ENDIF + bad=where(kz2 EQ nz-1,count) + IF count NE 0 THEN BEGIN ; Otherwise kz3=nz. + kz3[bad]=0 + IF keyword_set(isolated) THEN wz3[bad]=0. + ENDIF + IF keyword_set(wraparound) THEN BEGIN + bad=where(kz2 EQ nz,count) + IF count NE 0 THEN BEGIN + kz2[bad]=0 + kz3[bad]=1 + ENDIF + ENDIF + bad=0 ; Free memory. +ENDIF ELSE BEGIN + kz1=0 + kz2=0 + wz1=1 + wz2=1 +ENDELSE + + +;----------------------------- +; Interpolate samples to grid. +;----------------------------- + +field=fltarr(nx,ny,nz) +IF keyword_set(average) THEN tottscweight=fltarr(nx,ny,nz) + +; tscweight adds up all tsc weights allocated to a grid point, we need +; to keep track of this in order to compute the temperature. +; Note that total(tscweight) is equal to nrsamples and that +; total(ifield)=n0^3 if sph.plot NE 'sph,temp' (not 1 because we use +; xpos=posx*n0 --> cube length different from EDFW paper). + +index=kx1+ky1*nx+kz1*nxny +tscweight=wx1*wy1*wz1 +IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR +ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] +index=kx2+ky1*nx+kz1*nxny +tscweight=wx2*wy1*wz1 +IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR +ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] +index=kx3+ky1*nx+kz1*nxny +tscweight=wx3*wy1*wz1 +IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR +ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + +IF dim GE 2 THEN BEGIN + index=kx1+ky2*nx+kz1*nxny + tscweight=wx1*wy2*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky2*nx+kz1*nxny + tscweight=wx2*wy2*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky2*nx+kz1*nxny + tscweight=wx3*wy2*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky3*nx+kz1*nxny + tscweight=wx1*wy3*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky3*nx+kz1*nxny + tscweight=wx2*wy3*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky3*nx+kz1*nxny + tscweight=wx3*wy3*wz1 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + + IF dim EQ 3 THEN BEGIN + index=kx1+ky1*nx+kz2*nxny + tscweight=wx1*wy1*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky1*nx+kz2*nxny + tscweight=wx2*wy1*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky1*nx+kz2*nxny + tscweight=wx3*wy1*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky2*nx+kz2*nxny + tscweight=wx1*wy2*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky2*nx+kz2*nxny + tscweight=wx2*wy2*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky2*nx+kz2*nxny + tscweight=wx3*wy2*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky3*nx+kz2*nxny + tscweight=wx1*wy3*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky3*nx+kz2*nxny + tscweight=wx2*wy3*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky3*nx+kz2*nxny + tscweight=wx3*wy3*wz2 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky1*nx+kz3*nxny + tscweight=wx1*wy1*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky1*nx+kz3*nxny + tscweight=wx2*wy1*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky1*nx+kz3*nxny + tscweight=wx3*wy1*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky2*nx+kz3*nxny + tscweight=wx1*wy2*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky2*nx+kz3*nxny + tscweight=wx2*wy2*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky2*nx+kz3*nxny + tscweight=wx3*wy2*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx1+ky3*nx+kz3*nxny + tscweight=wx1*wy3*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx2+ky3*nx+kz3*nxny + tscweight=wx2*wy3*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + index=kx3+ky3*nx+kz3*nxny + tscweight=wx3*wy3*wz3 + IF keyword_set(average) THEN BEGIN + FOR j=0l,nrsamples-1l DO BEGIN + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + tottscweight[index[j]]=tottscweight[index[j]]+tscweight[j] + ENDFOR + ENDIF ELSE FOR j=0l,nrsamples-1l DO $ + field[index[j]]=field[index[j]]+tscweight[j]*value[j] + ENDIF + +ENDIF + +; Free memory (no need to free any more local arrays, will not lower +; maximum memory usage). +index=0 +weight=0 + + +;-------------------------- +; Compute weighted average. +;-------------------------- + +IF keyword_set(average) THEN BEGIN + good=where(tottscweight NE 0,nrgood) + field[good]=temporary(field[good])/temporary(tottscweight[good]) +ENDIF + +return,field + +END ; End of procedure tsc. diff --git a/modules/idl_downloads/astro/pro/tsum.pro b/modules/idl_downloads/astro/pro/tsum.pro new file mode 100644 index 0000000..00a8745 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tsum.pro @@ -0,0 +1,100 @@ +FUNCTION TSUM,X,Y,IMIN,IMAX, NAN=NAN ;Trapezoidal summation +;+ +; NAME: +; TSUM +; PURPOSE: +; Trapezoidal summation of the area under a curve. +; EXPLANATION: +; Adapted from the procedure INTEG in the IUE procedure library. +; +; CALLING SEQUENCE: +; Result = TSUM(y) +; or +; Result = TSUM( x, y, [ imin, imax, /nan ] ) +; INPUTS: +; x = array containing monotonic independent variable. If omitted, then +; x is assumed to contain the index of the y variable. +; x = lindgen( N_elements(y) ). +; y = array containing dependent variable y = f(x) +; +; OPTIONAL INPUTS: +; imin = scalar index of x array at which to begin the integration +; If omitted, then summation starts at x[0]. +; imax = scalar index of x value at which to end the integration +; If omitted then the integration ends at x[npts-1]. +; nan: If set cause the routine to check for occurrences of the IEEE +; floating-point values NaN or Infinity in the input data. +; Elements with the value NaN or Infinity are treated as missing data +; +; OUTPUTS: +; result = area under the curve y=f(x) between x[imin] and x[imax]. +; +; EXAMPLE: +; IDL> x = [0.0,0.1,0.14,0.3] +; IDL> y = sin(x) +; IDL> print,tsum(x,y) ===> 0.0445843 +; +; In this example, the exact curve can be computed analytically as +; 1.0 - cos(0.3) = 0.0446635 +; PROCEDURE: +; The area is determined of individual trapezoids defined by x[i], +; x[i+1], y[i] and y[i+1]. +; +; If the data is known to be at all smooth, then a more accurate +; integration can be found by interpolation prior to the trapezoidal +; sums, for example, by the standard IDL User Library int_tabulated.pro. +; MODIFICATION HISTORY: +; Written, W.B. Landsman, STI Corp. May 1986 +; Modified so X is not altered in a one parameter call Jan 1990 +; Converted to IDL V5.0 W. Landsman September 1997 +; Allow non-integer values of imin and imax W. Landsman April 2001 +; Fix problem if only 1 parameter supplied W. Landsman June 2002 +; Added /nan keyword. Julio Castro/WL May 2014 +;- +; Set default parameters + On_error,2 + npar = N_params() + + if npar EQ 1 then begin + npts = N_elements(x) + yy = x + xx = lindgen(npts) + ilo = 0 & imin = ilo + ihi = npts-1 & imax = ihi + endif else begin + + if ( npar LT 3 ) then imin = 0 + npts = min( [N_elements(x), N_elements(y)] ) + if ( npar LT 4 ) then imax = npts-1 + ilo = long(imin) + ihi = long(imax) + xx = x[ilo:ihi] + yy = y[ilo:ihi] + npts = ihi - ilo + 1 + endelse +; +; Remove NaN values +; + if keyword_set(NaN) then begin + g = where(finite(yy),npts) + yy = yy[g] + xx = xx[g] + endif +; +; Compute areas of trapezoids and sum result +; + xdif = xx[1:*] - xx + yavg = ( yy[0:npts-2] + yy[1:npts-1] ) / 2. + sum = total( xdif*yavg ) + +; Now account for edge effects if IMIN or IMAX parameter are not integers + + hi = imax - ihi + lo = imin - ilo + if (ihi LT imax) then sum += (x[ihi+1]-x[ihi])*hi* $ + (y[ihi] + (hi/2.) *(y[ihi+1] - y[ihi]) ) + if (ilo LT imin) then sum -= (x[ilo+1]-x[ilo])*lo* $ + (y[ilo] + (lo/2.) *(y[ilo+1] - y[ilo]) ) + return, sum + + end diff --git a/modules/idl_downloads/astro/pro/tvbox.pro b/modules/idl_downloads/astro/pro/tvbox.pro new file mode 100644 index 0000000..58f13a4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tvbox.pro @@ -0,0 +1,191 @@ +pro tvbox,width,x,y,color,DATA = data,Color=TheColor, ANGLE = angle, $ + DEVICE=device, SQUARE=SQUARE, _EXTRA = _EXTRA +;+ +; NAME: +; TVBOX +; PURPOSE: +; Draw a box(es) or rectangle(s) of specified width +; EXPLANATION: +; Positions can be specified either by the cursor position or by +; supplying a vector of X,Y positions. By default, TVBOX now +; (since Jan 2012) assumes data coordinates if !X.crange is set. +; +; CALLING SEQUENCE: +; TVBOX, width, [ x, y, color, /DATA, ANGLE= ,COLOR =, _EXTRA = ] +; +; INPUTS: +; WIDTH - either a scalar giving the width of a box, or a 2 element +; vector giving the length and width of a rectangle. +; +; OPTIONAL INPUTS: +; X - x position for box center, scalar or vector +; Y - y position for box center, scalar or vector. If vector, then Y +; must have the same number of elements as X +; Positions are specified in device coordinates unless /DATA is set +; If X and Y are not specified, and device has a cursor, then +; TVBOX will draw a box at current cursor position +; COLOR - String or integer specifying the color to draw the box(es) +; If COLORS is a scalar then all boxes are drawn with the same +; color value. Otherwise, the Nth box is drawn with the +; Nth value of color. Color can also be specified as +; string (e.g.'red'). See cgCOLOR for a list of available +; color names. Default = "opposite". +; OUTPUTS: +; None +; +; OPTIONAL KEYWORD INPUTS: +; ANGLE - numeric scalar specifying the clockwise rotation of +; the boxes or rectangles. +; COLOR - Scalar or vector, overrides the COLOR input parameter +; Color can be specified as a string (e.g. 'red') or intensity +; value. See cgCOLOR() for a list of color names. +; Default = 'opposite' (i.e. color opposite the background). +; /DATA - if this keyword is set and non-zero, then the box width and +; X,Y position center are interpreted as being in DATA +; coordinates. Note that data coordinates must be previously +; defined (with a PLOT or CONTOUR call). The default +; is to assume data coordinates if !X.CRANGE is set. Force +; device coordinates by setting DATA = 0 or /DEVICE +; /DEVICE Set this keyword to force use of device coordinates +; /FILL - If set, fill the box using cgCOLORFILL +; /SQUARE - If set, then a square is drawn, even if in data coordinates +; with unequal X and Y axes. The X width is used for the +; square width, and the Y width is ignored. +; +; Any keyword recognized by cgPLOTS (or cgCOLORFILL if /FILL is set) +; is also recognized by TVBOX. +; In particular, the linestyle, thickness and clipping of the boxes +; is controlled by the LINESTYLE, THICK and NOCLIP keywords. +; (Clipping is turned off by default, set NOCLIP=0 to activate it.) +; If /FILL is set then available keywords include LINE_FILL and +; FILL_PATTERN. +; +; SIDE EFFECTS: +; A square or rectangle will be drawn on the device +; For best results WIDTH should be odd when using the default DEVICE +; coordinates. (If WIDTH is even, the actual size of the box will be +; WIDTH + 1, so that box remains centered.) +; +; EXAMPLES: +; (1) Draw a double thick box of width 13, centered at 221,256 in the +; currently active window +; +; IDL> tvbox, 13, 221, 256, thick=2 +; +; (2) Overlay a "slit" with dimension 52" x 2" on a previously displayed +; image at a position angle (East of North) of 32 degrees. The +; slit is to be centered at XC, YC and the plate scale +; arcsec_per_pixel is known. +; +; IDL> w = [2.,52.]/arcsec_per_pixel ;Convert slit size to pixel units +; IDL> tvbox,w,XC,YC,ang=-32 ;Draw slit +; RESTRICTIONS: +; Allows use of only device (default) or data (if /DATA is set) +; coordinates. Normalized coordinates are not allowed +; PROCEDURES USED: +; cgpolygon, zparcheck +; REVISON HISTORY: +; Written, W. Landsman STX Co. 10-6-87 +; Modified to take vector arguments. Greg Hennessy Mar 1991 +; Fixed centering of odd width W. Landsman Sep. 1991 +; Let the user specify COLOR=0, accept vector color, W. Landsman Nov. 1995 +; Fixed typo in _EXTRA keyword W. Landsman August 1997 +; Added ANGLE keyword W.Landsman February 2000 +; Make sure ANGLE is a scalar W. Landsman September 2001 +; Don't round coordinates if /DATA is set. M. Perrin August 2005 +; Use STRICT_EXTRA to flag valid keywords W. Landsman Sep 2005 +; Check that width has only 1 or 2 elements W. Landsman August 2010 +; Use Coyote Graphcis W. Landsman February 2011 +; Added /FILL keyword W. Landsman July 2011 +; Default to data coordinates if !X.crange present WL Jan 2012 +; Added Square keyword WL. April 2012 +; +;- + compile_opt idl2 + On_error,2 + + npar = N_params() ;Get number of parameters + + if ( npar LT 1 ) then begin + print,'Syntax - TVBOX, width,[ x, y, color, THICK= ,/DATA, ANGLE=, COLOR=]' + return + endif + + zparcheck, 'TVBOX', width, 1, [1,2,3,4,5], [0,1], 'Box Width' + + if N_elements(width) GT 2 then message, $ + 'ERROR - First parameter (box width) must have 1 or 2 values' + if ( N_elements(width) EQ 2 ) then w = width/2. else w = [width,width]/2. + +; Use data coordinates if !X.crange is set (previous plot) and /DEVICE not set + +; Default to data coordinates if !X.crange is set (previous plot) + if keyword_set(device) then datacoord = 0 else begin + if N_elements(data) eq 0 then datacoord = !x.crange[0] NE !x.crange[1] $ + else datacoord = logical_true(data) + endelse + + +; Can't figure out in IDL how to figure out if the device has a cursor so +; we'll just check for a postscript device + + if ( npar LT 3 ) then if (!D.NAME NE 'PS') then begin + cursor,x,y,/DEVICE,/NOWAIT ;Read X,Y from the window + if (x LT 0) or (y LT 0) then begin + message,'Position cursor in window ' + strtrim(!D.WINDOW,2) + $ + ' -- then hit mouse button',/INF + cursor,x,y,/DEVICE,/WAIT + message, 'Box is centered at (' + strtrim(x,2) + ',' + $ + strtrim(y,2) + ')',/INF + endif + endif else message, $ + 'ERROR - X,Y position must be specified for Postscript device' + + if N_elements(TheColor) EQ 0 then begin + if N_elements(color) EQ 0 then color = cgcolor('opposite') + endif else color = TheColor + nbox = N_elements(x) ;Number of boxes to draw + if ( nbox NE N_elements(Y) ) then $ + message,'ERROR - X and Y positions must have same number of elements' + + xs = x & ys = y + + Ncol = N_elements(color) + xbox = [1,1,-1,-1,1]*w[0] + ybox = [-1,1,1,-1,-1]*w[1] + if keyword_set(angle) then begin ;Non-zero rotation angle? + ang = angle[0]/!RADEG + xprime = xbox*cos(ang) + ybox*sin(ang) + yprime = -xbox*sin(ang) + ybox*cos(ang) + xbox = xprime + ybox = yprime + endif + + if keyword_set(square) && datacoord then begin + ; Get ratio of unit vectors in X and Y direction + t = convert_coord([0,w[0],0],[0,0,w[0]],/data,/to_device) + ratio = (t[0,1]-t[0,0])/(t[1,2]-t[1,0]) + ybox = ybox*ratio + endif + + for i = 0l, nbox-1 do begin + + j = i < (Ncol-1) + xt = xs[i] + xbox ;X edges of rectangle + yt = ys[i] + ybox ;Y edges of rectangle + +; Plot the box in data or device coordinates. Default for Coyote graphcis +; is data coordinates. + + if datacoord then $ + cgpolygon, xt, yt, color= color[j], _STRICT_EXTRA = _EXTRA $ + else begin + ; only round coordinates to integers if using device coords; + ; data coords can potentially be fractional. + xt = round(xt) & yt = round(yt) + cgpolygon,xt,yt,/DEVICE,color=color[j],_STRICT_EXTRA=_EXTRA + endelse + endfor + + return + end diff --git a/modules/idl_downloads/astro/pro/tvcircle.pro b/modules/idl_downloads/astro/pro/tvcircle.pro new file mode 100644 index 0000000..4693e07 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tvcircle.pro @@ -0,0 +1,228 @@ +Pro Tvcircle, radius, xc, yc, color, COLOR = TheColor, Device=device, $ + DATA= data, FILL=fill,_Extra = _extra +;+ +; NAME: +; TVCIRCLE +; PURPOSE: +; Draw circle(s) of specified radius at specified position(s) +; EXPLANATION: +; If a position is not specified, and device has a cursor, then a circle +; is drawn at the current cursor position. By default, TVCIRCLE now +; (since Jan 2012) assumes data coordinates if !X.crange is set. +; +; CALLING SEQUENCE: +; TVCIRCLE, rad, x, y, color, [ /DATA, /FILL, _EXTRA = ] +; +; INPUTS: +; RAD - radius of circle(s) to be drawn, positive numeric scalar +; +; OPTIONAL INPUT: +; X - x position for circle center, vector or scalar +; Y - y position for circle center, vector or scalar +; If X and Y are not specified, and the device has a cursor, +; then program will draw a circle at the current cursor position +; COLOR - color name or intensity value(s) (0 - !D.N_COLORS) used to draw +; the circle(s). If COLOR is a scalar then all circles are drawn +; with the same color value. Otherwise, the Nth circle is drawn +; with the Nth value of color. See cgCOLOR() for a list of color +; names. Default = 'opposite' (i.e. color opposite the +; background). +; +; OPTIONAL KEYWORD INPUTS: +; /DATA - if this keyword is set and non-zero, then the circle width and +; X,Y position center are interpreted as being in DATA +; coordinates. Note that data coordinates must be previously +; defined (with a PLOT or CONTOUR call). TVCIRCLE will +; internally convert to device coordinates before drawing the +; circle, in order to maintain optimal smoothness. The default +; is to assume data coordinates if !X.CRANGE is set. Force +; device coordinates by setting DATA = 0 or /DEVICE +; /DEVICE - If set, then force use of device coordinates.. +; /FILL - If set, fill the circle using cgCOLORFILL +; +; Any keyword recognized by cgPLOTS (or cgCOLORFILL if /FILL is +; set) is also recognized by TVCIRCLE. In particular, the color, +; linestyle, thickness and clipping of the circles are controlled +; by the COLOR, LINESTYLE, THICK and NOCLIP keywords. (Clipping +; is turned off by default, set NOCLIP=0 to activate it.) +; If /FILL is set then available keywords are LINE_FILL and +; FILL_PATTERN. +; OUTPUTS: +; None +; +; RESTRICTIONS: +; (1) Some round-off error may occur when non-integral values are +; supplied for both the radius and the center coordinates +; (2) TVCIRCLE does not accept /NORMAL coordinates. +; (3) TVCIRCLE always draws a circle --- even when in data coordinates +; and the X and Y data scales are unequal. (The X data scale is +; used to define the circle radius.) If this is not the behaviour +; you want, then use TVELLIPSE instead. +; EXAMPLE: +; (1) Draw circles of radius 9 pixels at the positions specified by +; X,Y vectors, using double thickness lines +; +; IDL> tvcircle, 9, x, y, THICK = 2 +; +; Now fill in the circles using the LINE_FILL method +; +; IDL> tvcircle, 9, x, y, /FILL, /LINE_FILL +; METHOD: +; The method used is that of Michener's, modified to take into account +; the fact that IDL plots arrays faster than single points. See +; "Fundamental of Interactive Computer Graphics" by Foley and Van Dam" +; p. 445 for the algorithm. +; +; REVISON HISTORY: +; Original version written by B. Pfarr STX 10-88 +; Major rewrite adapted from CIRCLE by Allyn Saroyan LNLL +; Wayne Landsman STX Sep. 91 +; Added DATA keyword Wayne Landsman HSTX June 1993 +; Added FILL keyword. R. S. Hill, HSTX, 4-Nov-1993 +; Always convert to device coords, add _EXTRA keyword, allow vector +; colors. Wayne Landsman, HSTX, May 1995 +; Allow one to set COLOR = 0, W. Landsman, HSTX, November 1995 +; Check if data axes reversed. P. Mangifico, W. Landsman May 1996 +; Use strict_extra to check input keywords W. Landsman July 2005 +; Update documentation to note NOCLIP=0 option W.L. Oct. 2006 +; Make all integers default to LONG W. Landsman Dec 2006 +; Use Coyote Graphics procedures W. Landsman Feb 2011 +; Default to data coordinates if !X.crange present WL Jan 2012 +; Add /DEVICE coords, fix Jan 2012 update. Mar 2012 +;- + + On_Error, 2 ; Return to caller + compile_opt idl2 + + if ( N_params() LT 1) then begin + print, 'Syntax - TVCIRCLE, rad, [ xc, yc, color, /DATA, /FILL, _EXTRA= ]' + return + endif + +; Default to data coordinates if !X.crange is set (previous plot) + if keyword_set(device) then datacoord = 0 else begin + if N_elements(data) eq 0 then datacoord = !x.crange[0] NE !x.crange[1] $ + else datacoord = logical_true(data) + endelse + + if N_elements(radius) NE 1 then message, $ + 'ERROR - Circle radius (first parameter) must be a scalar' + + if N_elements(TheColor) EQ 0 then begin + IF N_Elements( Color ) EQ 0 THEN Color = cgcolor('opposite') + endif else color = TheColor + + + if N_params() LT 3 then begin + if (!D.WINDOW EQ -1) then message, $ + 'ERROR - Cursor not available for device ' + !D.NAME + cursor, xc, yc, /DEVICE, /NOWAIT + if (xc LT 0) || (yc LT 0) then begin + message,'Position cursor in window ' + strtrim(!D.WINDOW,2) + $ + ' -- then hit mouse button',/INF + cursor, xc, yc, /DEVICE, /WAIT + message,'Circle is centered at (' + strtrim(xc,2) + ',' + $ + strtrim(yc,2) + ')',/INF + endif + + endif + + N_circle = min( [ N_elements(xc), N_elements(yc) ] ) + + + if datacoord then begin + coord = abs(convert_coord(radius,0,/data,/to_dev) - $ + convert_coord(0,0,/data,/to_dev)) + irad = round( coord[0] ) + endif else $ + irad = round(radius) + + x = 0 + y = irad + d = 3 - 2 * irad + + + ; Find the x and y coordinates for one eighth of a circle. + ; The maximum number of these coordinates is the radius of the circle. + + xHalfQuad = Make_Array( irad + 1, /Long, /NoZero ) + yHalfQuad = xHalfQuad + + path = 0 + + WHILE x lt y $ + DO BEGIN + + xHalfQuad[path] = x + yHalfQuad[path] = y + + path++ + + IF d lt 0 $ + THEN d += 4*x + 6 $ + ELSE BEGIN + + d += 4*(x-y) + 10 + y-- + + END + + x++ + + END + + IF x eq y $ + THEN BEGIN ; Fill in last point + + xHalfQuad[path] = x + yHalfQuad[path] = y + + path++ + + END ; Filling in last point + + ; Shrink the arrays to their correct size + + xHalfQuad = xHalfQuad[ 0:path-1 ] + yHalfQuad = yHalfQuad[ 0:path-1 ] + + ; Convert the eighth circle into a quadrant + + xQuad = [ xHalfQuad, Rotate(yHalfQuad, 5) ] + yQuad = [ yHalfQuad, Rotate(xHalfQuad, 5) ] + + ; Prepare for converting the quadrants into a full circle + + xQuadRev = Rotate( xQuad[0:2*path-2], 5 ) + yQuadRev = Rotate( yQuad[0:2*path-2], 5 ) + + ; Create full-circle coordinates + + x = [ xQuad, xQuadRev, -xQuad[1:*], -xQuadRev ] + y = [ yQuad, -yQuadRev, -yQuad[1:*], yQuadRev ] + + ; Plot the coordinates about the given center + + if datacoord then begin ;Convert to device coordinates + coord = convert_coord( xc, yc, /DATA, /TO_DEVICE) + xcen = round(coord[0,*]) & ycen = round(coord[1,*]) + endif else begin + xcen = round(xc) & ycen = round(yc) + endelse + + + Ncolor1 = N_elements(color) -1 + for i = 0l, N_circle-1 do begin + j = i < Ncolor1 + if keyword_set(fill) then begin + cgcolorfill, x+xcen[i], y + ycen[i], COLOR=color[j], /DEV, $ + _STRICT_Extra = _extra + endif else begin + cgPlotS, x + xcen[i], y+ ycen[i], COLOR = Color[j], /DEV, $ + _STRICT_Extra = _extra + endelse + + endfor + + Return + End; TVcircle diff --git a/modules/idl_downloads/astro/pro/tvellipse.pro b/modules/idl_downloads/astro/pro/tvellipse.pro new file mode 100644 index 0000000..6f98274 --- /dev/null +++ b/modules/idl_downloads/astro/pro/tvellipse.pro @@ -0,0 +1,184 @@ +pro tvellipse, rmax, rmin, xc, yc, pos_ang, color, DATA = data, $ + NPOINTS = npoints, COLOR=thecolor, MAJOR=major, MINOR=minor, $ + DEVICE= device, FILL = fill, _Extra = _extra +;+ +; NAME: +; TVELLIPSE +; +; PURPOSE: +; Draw an ellipse on the current graphics device. +; +; CALLING SEQUENCE: +; TVELLIPSE, rmax, rmin, xc, yc, [ pos_ang, color, COLOR= ,/DATA, NPOINTS= +; LINESTYLE=, THICK=, /MAJOR, /MINOR ] +; INPUTS: +; RMAX,RMIN - Scalars giving the semi-major and semi-minor axes of +; the ellipse +; OPTIONAL INPUTS: +; XC,YC - Scalars giving the position on the TV of the ellipse center +; If not supplied (or if XC, YC are negative and /DATA is not +; set), and an interactive graphics device (e.g. not postscript) +; is set, then the user will be prompted for X,Y +; POS_ANG - Position angle of the major axis, measured counter-clockwise +; from the X axis. Default is 0. +; COLOR - Scalar integer or string specifying color to draw ellipse. +; See cgcolor.pro for a list of possible color names + +; OPTIONAL KEYWORD INPUT: +; COLOR - Intensity value or color name used to draw the circle, +; overrides parameter value. Default = 'opposite' +; See cgCOLOR() for a list of color names.; +; /DATA - if this keyword is set and non-zero, then the ellipse radii and +; X,Y position center are interpreted as being in DATA +; coordinates. Note that the data coordinates must have been +; previously defined (with a PLOT or CONTOUR call). The default +; is to assume data coordinates if !X.CRANGE has been set by a +; previous plot. Force device coordinates by setting DATA = 0. +; /DEVICE - Set to force use of device coordinates. +; /FILL - If set, then fill the ellipse using cgCOLORFILL +; NPOINTS - Number of points to connect to draw ellipse, default = 120 +; Increase this value to improve smoothness +; /MAJOR - Plot a line along the ellipse's major axis +; /MINOR - Plot a line along the ellipse's minor axis +; +; Any keyword recognized by cgPLOTS is also recognized by TVELLIPSE. +; In particular, the color, linestyle, thickness and clipping of +; the ellipses are controlled by the COLOR, LINESTYLE, THICK and +; NOCLIP keywords. (Clipping is turned off by default, set +; NOCLIP=0 to activate it.) If /FILL is set then available +; keywords include LINE_FILL and FILL_PATTERN. +; +; RESTRICTIONS: +; TVELLIPSE does not check whether the ellipse is within the boundaries +; of the window. +; +; The ellipse is evaluated at NPOINTS (default = 120) points and +; connected by straight lines, rather than using the more sophisticated +; algorithm used by TVCIRCLE +; +; TVELLIPSE does not accept normalized coordinates. +; +; TVELLIPSE is not vectorized; it only draws one ellipse at a time +; +; EXAMPLE: +; Draw an ellipse of semi-major axis 50 pixels, minor axis 30 +; pixels, centered on (250,100), with the major axis inclined 25 +; degrees counter-clockwise from the X axis. Use a double thickness +; line and device coordinates +; +; IDL> tvellipse,50,30,250,100,25,thick=2,/device +; +; NOTES: +; Note that the position angle for TVELLIPSE (counter-clockwise from +; the X axis) differs from the astronomical position angle +; (counter-clockwise from the Y axis). +; +; REVISION HISTORY: +; Written W. Landsman STX July, 1989 +; Converted to use with a workstation. M. Greason, STX, June 1990 +; LINESTYLE keyword, evaluate at 120 points, W. Landsman HSTX Nov 1995 +; Added NPOINTS keyword, fixed /DATA keyword W. Landsman HSTX Jan 1996 +; Check for reversed /DATA coordinates P. Mangiafico, W.Landsman May 1996 +; Work correctly when X & Y data scales are unequal December 1998 +; Removed cursor input when -ve coords are entered with /data +; keyword set P. Maxted, Keele, 2002 +; Use _EXTRA keywords including NOCLIP W. Landsman October 2006 +; Add plotting of major and minor axes and /MAJOR, /MINOR keywords; +; fixed description of RMAX,RMIN (semi-axes). J. Guerber Feb. 2007 +; Update to use Coyote graphics W. Landsman Feb 2011 +; Default to data coordinates if a previous plot has been made +; (X.crange is non-zero) W. Landsman Jan 2012 +; Added /DEVICE keyword W. Landsman Mar 2012 +; Added /FILL keyword W. Landsman Mar 2012 +;- + On_error,2 ;Return to caller + + if N_params() lt 2 then begin + print,'Syntax - TVELLIPSE, rmax, rmin, xc, yc, [pos_ang, color, COLOR=,' + print,' /FILL, NPOINTS=, LINESTYLE=, THICK=, /DATA, /MAJOR, /MINOR]' + print,' /DEVICE...any other keyword accepted by cgPLOTS' + return + endif + + ; Default to data coordinates if !X.crange is set (previous plot) + + if keyword_set(device) then datacoord = 0 else begin + if N_elements(data) Eq 0 then datacoord = !x.crange[0] NE !x.crange[1] $ + else datacoord = logical_true(data) + endelse + + if N_params() lt 4 then $ + cursor, xc, yc, /DEVICE, /NOWAIT ;Get unroamed,unzoomed coordinates + + if ( (xc LT 0) || (yc LT 0)) && ~keyword_set(data) then begin + message,'Position cursor in window ' + strtrim(!D.WINDOW,2) + $ + ' -- then hit mouse button',/INF + cursor, xc, yc, /DEVICE, /WAIT + message,'Ellipse is centered at (' + strtrim(xc,2) + ',' + $ + strtrim(yc,2) + ')',/INF + endif + + if N_params() LT 5 then pos_ang = 0. ;Default position angle + if N_Elements(TheColor) EQ 0 then begin + IF N_Elements( Color ) eq 0 THEN Color = cgcolor('opposite') + endif else color = TheColor + + if ~keyword_set(NPOINTS) then npoints = 120 ;Number of points to connect + + phi = 2*!pi*(findgen(npoints)/(npoints-1)) ;Divide circle into Npoints + ang = pos_ang/!RADEG ;Position angle in radians + cosang = cos(ang) + sinang = sin(ang) + + x = rmax*cos(phi) ;Parameterized equation of ellipse + y = rmin*sin(phi) + + xprime = xc + x*cosang - y*sinang ;Rotate to desired position angle + yprime = yc + x*sinang + y*cosang + + if keyword_set(fill) then begin + if datacoord then $ + cgcolorfill, xprime, yprime, /DATA, COLOR=color, _STRICT_Extra = _extra else $ + cgcolorfill, round(xprime), round(yprime), COLOR=color, /DEVICE, $ + _STRICT_Extra = _extra + endif else begin + if datacoord then $ + cgplots, xprime, yprime, /DATA, COLOR=color, _STRICT_Extra = _extra else $ + cgplots, round(xprime), round(yprime), COLOR=color, /DEVICE, $ + _STRICT_Extra = _extra + endelse + + if keyword_set(major) then begin + xmaj = xc + [rmax,-rmax]*cosang ; rot & transl points (rmax,0),(-rmax,0) + ymaj = yc + [rmax,-rmax]*sinang + if keyword_set(fill) then begin + if datacoord then $ + cgcolorfill, xmaj, ymaj, /DATA, COLOR=color, _STRICT_Extra=_extra $ + else cgcolorfill, round(xmaj), round(ymaj), $ + /DEVICE, COLOR=color, _STRICT_Extra=_extra + endif else begin + if datacoord then $ + cgplots, xmaj, ymaj, /DATA, COLOR=color, _STRICT_Extra=_extra $ + else cgplots, round(xmaj), round(ymaj), $ + /DEVICE, COLOR=color, _STRICT_Extra=_extra + endelse + endif + + if keyword_set(minor) then begin + xmin = xc - [rmin,-rmin]*sinang ; rot & transl points (0,rmin),(0,-rmin) + ymin = yc + [rmin,-rmin]*cosang + if keyword_set(fill) then begin + if datacoord then $ + cgcolorfill, xmin, ymin, /DATA, COLOR=color, _STRICT_Extra=_extra $ + else cgplots, round(xmin), round(ymin), $ + /DEVICE, COLOR=color, _STRICT_Extra=_extra + endif else begin + if datacoord then $ + cgplots, xmin, ymin, /DATA, COLOR=color, _STRICT_Extra=_extra $ + else cgplots, round(xmin), round(ymin), $ + /DEVICE, COLOR=color, _STRICT_Extra=_extra + endelse + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/tvlaser.pro b/modules/idl_downloads/astro/pro/tvlaser.pro new file mode 100644 index 0000000..c4c3b2f --- /dev/null +++ b/modules/idl_downloads/astro/pro/tvlaser.pro @@ -0,0 +1,707 @@ +PRO TVLASER, hdr, Image, BARPOS=BarPos, CARROWS=CArrows, CLABELS=CLabels, $ + COLORPS=ColorPS, COMMENTS=Comments, CSIZE=CSize, CTITLE=CTitle, $ + DX=dX, DY=dY, ENCAP=encap, FILENAME=filename, HEADER=Header, HELP=Help,$ + IMAGEOut=ImageOut, INTERP=Interp, MAGNIFY=Magnify, NoClose=noclose, $ + NODELETE=NoDelete, NO_PERS_INFO=No_Pers_Info, NOEIGHT=NoEight, $ + NOPRINT=NoPrint, NORETAIN = NoRetain, PORTRAIT=Portrait, $ + PRINTER = Printer, REVERSE=Reverse, SCALE=Scale, TITLE=Title, $ + XSTART=XStart, YSTART=YStart, XDIM=XDim, YDIM=YDim, $ + TrueColor=TrueColor, BOTTOMDW=bottomdw, NCOLORSDW=ncolorsdw +;+ +; NAME: +; TVLASER +; PURPOSE: +; Prints screen or image array onto a Postscript file or printer. +; Information from FITS header is optionally used for labeling. +; +; CALLING SEQUENCE: +; TVLASER, [header, Image, BARPOS = ,CARROWS =, CLABELS = ,/COLORPS, +; COMMENTS = ,CSIZE = ,CTITLE = , DX = , DY =, /ENCAP, FILENAME = +; HEADER = ,/HELP, IMAGEOUT = ,/INTERP, /MAGNIFY, /NoCLOSE, +; /NoDELETE, /NO_PERS_INFO, /NoEIGHT, /NoPRINT, /NoRETAIN, +; /PORTRAIT, PRINTER = , /REVERSE, /SCALE, TITLE = , /TrueColor, +; XDIM=, XSTART=, YDIM=, YSTART=, BOTTOMDW=, NCOLORSDW= ] +; +; Note that the calling sequence was changed in May 1997 +; OPTIONAL INPUTS: +; HEADER - FITS header string array. Object and astrometric info from +; the FITS header will be used for labeling, if available +; IMAGE - if an array is passed through this parameter, then this image +; will be used rather than reading off the current window. This +; allows easy use of large images. It is usually preferable +; to optimally byte scale IMAGE before supplying it to TVLASER +; +; OPTIONAL KEYWORD INPUT PARAMETERS: +; BARPOS - A four- or five-element vector giving the position and +; orientation of the color bar. The first four elements +; [X0,Y0,XSize,YSize] indicate the position and size of the color +; bar in INCHES, relative to origin of the displayed image. +; (X0,Y0) are the position of the lower left corner and +; (XSize,YSize) are the width and height. The fifth element is +; optional, and if present, the color bar will be printed +; horizontally rather than vertically. If BARPOS is set to +; anything but a four- or five-element vector, the bar is NOT +; printed. The default value is BARPOS = [-0.25, 0.0, 0.2, 2.0] +; BOTTOMDW - The lowest value to use in building the density +; wedge. Used with NCOLORSDW. Compatible with BOTTOM and +; NCOLORS keywords of XLOADCT. +; CARROWS - The color to print the North-East arrows. Default is dark. +; Three types of values can be passed: +; SCALAR: that value's color in the current color table +; 3-ELEMENT VECTOR: the color will be [R,G,B] +; STRING: A letter indicating the color. Valid names are: +; 'W' (white), 'D' (dark/black), 'R' (red), 'G' (green), +; 'B' (blue), 'T' (turquoise), 'V' (violet), 'Y' (yellow), +; If the keyword is set to a value of -1, the arrows are +; NOT printed. +; COLORPS - If present and non-zero, the idl.ps file is written using +; color postscript. +; COMMENTS - A string that will be included in the comment line below the +; image. For multi-line comments you can either use "!C" in the +; string as a carriage return {although the vertical spacing +; might be a little off} or, preferably, make the COMMENTS a +; string array with each line as a separate element. +; CLABELS - Color to print the labels, same format as for CARROWS. +; CSIZE - Color to print the size-scale bar and label, same format as for +; CARROWS. +; CTITLE - Color to print the title, same format as for CARROWS. +; DX,DY - offsets in INCHES added to the position of the figure on the +; paper. As is the case for the device keywords XOFFSET and +; YOFFSET, when in landscape mode DX and DY are the same +; *relative to the paper*, not relative to the plot (e.g., DX is +; the horizontal offset in portrait mode, but the *vertical* +; offset in landscape mode). +; ENCAP - If present and non-zero, the IDL.PS file is written in +; encapsulated postscript for import into LaTeX documents +; FILENAME - scalar string giving name of output postscript file. +; Default is idl.ps. Automatically sets /NODELETE +; HEADER = FITS header. This is an alternative to supplying the FITS +; header in the first parameter. +; HELP - print out the sytax for this procedure. +; INTERP - If present and non-zero, current color table will be +; interpolated to fill the full range of the PostScript color +; table (256 colors). Otherwise, the current color table will be +; directly copied. You probably will want to use this if you +; are using IMAGE keyword and a shared color table. +; MAGNIFY - The net magnification of the entire figure. At this point, +; the figure is not automatically centered on the paper if the +; value of MAGNIFY is not equal to 1, but the DX and DY keywords +; can be used to shift location. For example, to fit a full plot +; on the printable area (8.5x8.5 inches) of the Tek PhaserIISD +; color printer use: MAGNIFY=0.8, DX=0.5, DY=0.5.; +; NCOLORSDW - The number of values to include in the density +; wedge. Used with BOTTOMDW. Compatible with +; BOTTOM/NCOLORS keywords of XLOADCT. +; NoCLOSE - If present and non-zero, then the postscript file is not +; closed (or printed), the device is set to 'PS', and the data +; coordinate system is set to match the image size. This allows the +; user to add additional plotting commands before printing. For +; example, to include a 15 pixel circle around a source at +; coordinates (150,160), around an image, im, with FITS header +; array, h +; +; IDL> tvlaser,h,im,/NoClose ;Write image & annotation +; IDL> tvcircle,15,150,160,/data ;Draw circle +; IDL> device,/close ;Close postscript file & print +; +; NoDELETE - If present and non-zero, the postscript file is kept AND is +; also sent to the printer +; NoEIGHT - if set then only four bits sent to printer (saves space) +; NO_PERS_INFO - if present and non-zero, output notation will NOT +; include date/user block of information. +; NoPRINT - If present and non-zero, the output is sent to a file (default +; name 'idl.ps'), which is NOT deleted and is NOT sent to the +; printer. +; NoRETAIN - In order to avoid possible problems when using TVRD with +; an obscured window, TVLASER will first copy the current window +; to a temporary RETAIN=2 window. Set /NORETAIN to skip this +; step and improve performance +; PORTRAIT - if present and non-zero, the printer results will be in +; portrait format; otherwise, they will be in landscape format. +; If labels are requested, image will be in portrait mode, +; regardless +; PRINTER - scalar string giving the OS command to send a the postscript +; file to the printer. Under Unix, the default value of PRINTER +; is 'lpr ' while for other OS it is 'print ' +; REVERSE - if present and non-zero, color table will be fliped, so black +; and white are reversed. +; SCALE - if present and non-zero, image will be bytscaled before being +; sent to postscript file. +; TITLE - if present and non-zero, the string entered here will be the +; title of the picture. Default is the OBJECT field in the +; header (if present). +; TRUECOLOR - if present and non-zero, the postscript file is created +; using the truecolor switch (i.e. true=3). The colorbar is +; not displayed in this mode. +; XDIM,YDIM - Number of pixels. Default is from !d.x_size and !d.y_size, +; or size of image if passed with IMAGE keyword. +; XSTART,YSTART - lower left corner (default of (0,0)) +; +; OPTIONAL KEYWORD OUTPUT PARAMETER +; IMAGEOUT = the image byte array actually sent to the postscript file. +; +; SIDE EFFECTS: +; A postscript file is created in the current directory. User must have +; write privileges in the current directory. The file is named idl.ps +; unless the FILENAME keyword is given. The file is directed to the +; printer unless the /ENCAP, /NoCLOSE, or /NOPRINT keywords are given. +; After printing, the file is deleted unless the /NODELETE or FILENAME +; keywords are given. +; PROCEDURE: +; Read display or take IMAGE and then redisplay into a postscript file. +; If a header exists, printout header information. If header has +; astrometry, then print out orientation and scale information. +; PROCEDURES USED: +; ARROWS, EXTAST, FDECOMP, GETROT, PIXCOLOR, SXPAR(), XYAD, ZPARCHECK +; +;*EXAMPLE: +; 1) Send a true color image (xsize,ysize,3) to a printer (i.e. print23l), +; tvlaser,huv,cpic,/colorps,/truecolor,printer="print23l" +; % TVLASER: Now printing image: $print23l idl.ps +; +; MODIFICATION HISTORY: +; Major rewrite from UIT version W. Landsman Dec 94 +; Massive rewrite. Added North-East arrows, pixel scale bar, color bar, +; and keywords DX, DY, MAGNIFY, INTERP, HELP, and COMMENTS. +; Created ablility to define colors for annotation and +; text. Repositioned text labels. J.Wm.Parker, HITC, 5/95 +; Make Header and Image parameters instead of keywords. Add PRINTER +; keyword. Include alternate FITS keywords. W. Landsman May 97 +; Copy to a RETAIN=2 window, work without FITS header W. Landsman June 97 +; Cleaner output when no astrometry in header W. Landsman June 97 +; Added /INFO to final MESSAGE W. Landsman July 1997 +; 12/4/97 jkf/acc - added TrueColor optional keyword. +; Added /NoClose keyword, trim Equinox format W. Landsman 9-Jul-1998 +; Don't display coordinate labels if no astrometry, more flexible +; formatting of exposure time W. Landsman 30-Aug-1998 +; BottomDW and NColorsDW added. R. S. Hill, 1-Mar-1999 +; Apply func tab to color bar if not colorps. RSH, 21 Mar 2000 +; Fix problem with /NOCLOSE and unequal X,Y sizes W. Landsman Feb 2001 +; Use TVRD(True=3) if /TRUECOLOR set W. Landsman November 2001 +; More synonyms, check for header supplied W. Landsman November 2007 +;- + compile_opt idl2 + on_error,2 + + if keyword_set(Help) then begin + print, 'Syntax: TVLASER, [ Header, Image ]' + print, 'Keywords: BARPOS= ,CARROWS= , CLABELS= ,/COLOPS, COMMENTS= ,' + print, ' CSIZE= , CTITLE= , DX= , DY= , /ENCAP, FILENAME= ,' + print, ' HEADER= ,/HELP, IMAGEOUT= , /INTERP, /MAGNIFY,/NoCLOSE ,' + print, ' /NoDELETE, NO_PERS_INFO, /NoEIGHT, /NoPRINT, /NORETAIN,' + print, ' /PORTRAIT,PRINTER=,/REVERSE, /SCALE, TITLE= , /TRUECOLOR,' + print, ' XDIM= ,XSTART=, YDIM= , YSTART= ] ' + print, ' ' + return + endif + +;----------------------------; +; SECTION: INITIALIZATION ; +;----------------------------; + +;;; +; Save some info and set some variables. LogoDir may need to be changed +; depending on where the GIF logos are. +; + sv_device = !D.NAME + sv_color = !P.Color + if !D.NAME EQ 'PS' then set_plot,'X' ;Return to X terminal + tvlct,sv_rr,sv_gg,sv_bb,/get + + if keyword_set(NoEight) THEN NBits = 4 ELSE NBits = 8 + if keyword_set(Portrait) THEN Lands = 0 ELSE Lands = 1 + ColorPS = keyword_set(ColorPS) + Encap = keyword_set(Encap) + NoPrint = keyword_set(NoPrint) + NoDelete = keyword_set(NoDelete) + TrueColor= keyword_set(TrueColor) + if TrueColor then TrueValue =3 else TrueValue =0 + + if N_elements(hdr) EQ 0 then $ + if N_elements(header) NE 0 then hdr = header + if (N_params() GE 1) and (N_elements(hdr) EQ 0) then message,/INF, $ + 'Warning - No valid FITS header supplied' + if N_elements(hdr) NE 0 then zparcheck,'TVLASER',hdr,1,7,1,'FITS image header' +;;; +; If no image was passed in the IMAGE keyword, then we will be reading the +; image from the screen. Default values are to start at 0,0 and read the +; entire window. +; + FromTV = N_elements(Image) eq 0 + if FromTV then begin + if !D.WINDOW EQ -1 then begin + tvlaser,/help + return + endif + message,'Reading image from window ' + strtrim(!D.WINDOW,2) + $ + ' ... Please be patient', /INF + if not keyword_set(XStart) then XStart = 0 + if not keyword_set(YStart) then YStart = 0 + if not keyword_set(XDim) then XDim = !d.x_size + if not keyword_set(YDim) then YDim = !d.y_size + if not keyword_set(noretain) then begin + chan = !D.WINDOW + xsize = !D.X_SIZE & ysize = !D.Y_SIZE + window,/free,xsize=xsize,ysize=ysize + wset,!D.WINDOW + device,copy=[0,0,xsize,ysize,0,0,chan] + endif + ImageOut = tvrd(XStart,YStart,XDim,YDim,true = truevalue) + if not keyword_set(noretain) then begin + wdelete,!D.WINDOW + wset,chan + endif + endif else begin + XStart = 0 + YStart = 0 + XDim = (size(Image))[1] + YDim = (size(Image))[2] + ImageOut = Image + endelse +;;; +; YSpace is used to scale the vertical spacing of text and the title. +; + YSpace = (float(Xdim) / Ydim) > 1. ;Modified December 1994 WBL + XSpace = (float(Ydim) / Xdim) > 1. + +;;; +; If using B/W PostScript, use NTSC color -> B/W formula, J Brinkmann +; Scale and/or reverse if desired. +; + if not(ColorPS) then ImageOut = $ + 0.299 * sv_rr[ImageOut] + 0.587 * sv_gg[ImageOut] + 0.114 * sv_bb[ImageOut] + if keyword_set(Scale) then ImageOut = bytscl(ImageOut) + if keyword_set(Reverse) then ImageOut = 255b - temporary(ImageOut) + +;;; +; If a header is given, put in portrait mode regardless. +; + if N_elements(hdr) NE 0 then Lands = 0 + +;;; +; Set up colors for density wedge. +; + if N_elements(BottomDW) LE 0 then BottomDW = 0 + nc = !D.table_size - BottomDW + if n_elements(NColors) GT 0 then nc = nc < ncolors + if nc LE 0 then begin + message, /INFO, 'Bad color spec; using default' + BottomDW = 0 + nc = !D.table_size + endif + + +;------------------------------; +; SECTION: POSTSCRIPT SETUP ; +;------------------------------; + +;;; +; Redirect output to Postscript printer file, which may be printed. +; Size of image is restricted to 7.5 inches in the paper's narrow direction +; for MAGNIFY=1. If we will be printing out header info, then restrict the +; Y size to be no more than 7.5 also. +; +if (Lands eq 1) then begin + inx = 10.0 + iny = float(YDim)/float(XDim)*float(inx) + if (iny gt 7.5) then begin + iny = 7.5 + inx = (float(XDim)/float(YDim))*float(iny) + endif + endif + + if (Lands eq 0) then begin + if N_elements(hdr) NE 0 then iny = 7.5 else iny = 10.0 + inx = float(XDim)/float(YDim)*float(iny) + if (inx gt 7.5) then begin + inx = 7.5 + iny = (float(YDim)/float(XDim))*float(inx) + endif + endif + +;;; +; Some info for the user, and setting the filename. +; + pstype = ' ' + if Encap then pstype = pstype + 'encapsulated ' + if ColorPS then pstype = pstype + 'color ' + if not keyword_set(filename) then fname = 'idl.ps' else begin + fdecomp,filename,disk,dir,name,ext + if ext EQ '' then ext = 'ps' + fname = disk + dir + name + '.' + ext + NoDelete = 1 + endelse + if keyword_set(NoDelete) or keyword_set(EnCap) or keyword_set(NoPrint) then $ + message,'Writing image to' + pstype + 'postscript file ' + fname, /INF + +;;; +; Set plot to the PostScript printer. Set all the device keywords. +; +set_plot, 'ps', INTERPOLATE=keyword_set(Interp) +sv_font = !P.FONT +!p.font = 0 + + if not keyword_set(dX) then dX = 0 + if not keyword_set(dY) then dY = 0 + + XOff = 0.75 + dX + YOff = 10.25 + dY + if Lands then begin + device, /landscape + YOff = inx + ((11 - inx) / 2.0) + dY ; centered + endif else begin + device, /portrait + YOff = Yoff - iny + endelse + + device, xsize=inx, ysize=iny, xoffset=XOff, yoffset=YOff, /inches, $ + bits=NBits, filename=fname, /helvetica, encapsulated=Encap, color=ColorPS + + if keyword_set(Magnify) then device, scale=Magnify else device, scale=1 + + +;-----------------------; +; SECTION: TV OUTPUT ; +;-----------------------; + + tv, ImageOut,true=TrueValue + +; If the BarPos keyword has four or five elements, then show the color bar. + + if (not(TrueValue)) then begin + if (N_elements(BarPos) eq 0) then BarPos = [-0.25, 0.0, 0.2, 2.0] + NumEls = N_elements(BarPos) + if ( (NumEls eq 4) or (NumEls eq 5) ) then begin + ColorBar = byte(round(congrid(findgen(nc)+BottomDW, 256))) $ + # make_array(20,val=1b) + if not(ColorPS) then $ + ColorBar = 0.299 * sv_rr[ColorBar] + 0.587 * sv_gg[ColorBar] $ + + 0.114 * sv_bb[ColorBar] + ColorBar[0:*,[0,19]] = 0 + ColorBar[[0,255],0:*] = 0 + if (NumEls eq 4) then ColorBar = transpose(ColorBar) + tv, ColorBar, BarPos[0],BarPos[1], xsize=BarPos[2],ysize=BarPos[3], /INCHES + endif + endif + +;;; +; Now that the image has been displayed with the desired color table, we will +; play with the color table a bit to get the appropriate colors for the text, +; arrows, and scale bar. The three RGB values for each one will be loaded into +; vectors called things like 'CArrowsRGBN', 'CSizeRGBN', etc. The last value +; in this vector will be the location of that color in the color table. +; "Colors" is a string array of the keyword names, then via the EXECUTE +; function, we determine what the content of each variable is: a string to be +; used inthe pixcolor procedure, a single number indicating the location in the +; current color table, or a 3-element vector with RGB values. One reason for +; doing it this way, is that if more objects to be colored are added to the +; keywords, only the variable COLORS need be changed here by adding those +; keyword names. +; "Val" is where we will be temporarily putting the new colors (usually in +; the bottom bin). +; + Colors = ['CArrows','CSize','CTitle','CLabels'] + r_new = bytarr(n_elements(Colors)) + g_new = r_new + b_new = r_new + + for N=0,(n_elements(Colors) -1) do begin + tvlct, sv_rr, sv_gg, sv_bb + Val = 0 + + dummy = execute( 'NumEls = n_elements(' + Colors[N] + ')' ) + if (NumEls eq 0) then begin + dummy = execute( Colors[N] + ' = "D"' ) + NumEls = 1 + endif + dummy = execute( 'C = ' + Colors[N] ) + if (NumEls eq 1) then begin ; string or color value + if ((size(C))[1] eq 7) then pixcolor, Val, C else Val = C + endif else begin + if (NumEls eq 3) then tvlct,transpose(C) else pixcolor, Val, 'D' + endelse + + tvlct, r, g, b, /get + if (Val[0] ne -1) then begin + r_new[N] = r[Val] + g_new[N] = g[Val] + b_new[N] = b[Val] + dummy = execute(Colors[N]+'RGBN = [r[Val],g[Val],b[Val],N]') + endif +endfor + + tvlct, r_new, g_new, b_new + + +;-------------------------------; +; SECTION: HEADER and LABELS ; +;-------------------------------; + +;;; +; If a FITS header was given then include whatever of the following FITS +; keywords that are present as annotation: OBJECT (becomes the title if none +; given), TELESCOP, IMAGE, EXPTIME, EQUINOX, CRVAL1 (Right Ascension), CRVAL2 +; (Declination), NAXIS1, NAXIS2, CD (Rotation angle and pixel size), PDSDATIM +; (Date of Microdensitometry). Also will include the name of the user and the +; current date. Some blocks can be suppressed...see description of keywords +; above. Also prints directional arrows and scale. +; +if (N_elements(Hdr) NE 0) then begin + + +;;; +; Does the header have astrometry? +; + extast, hdr, astr, NoAstrom + if NoAstrom GT 0 then begin + ast_type = strmid( strupcase( strtrim(astr.ctype[0],2) ), 0 ,4) + if ((ast_type NE 'RA--') and (ast_type NE 'GLON') and $ ;Valid projection? + (ast_type NE 'ELAT') ) then NoAstrom = -1 + endif + + if (NoAstrom LT 0) then begin + rga = 'N/A' + decl = 'N/A' + equi = '' + ROTATE = 'N/A' + CDELT = [0.0,0.0] + CDELTAS = 'N/A' + endif else begin + xcen = (XDim-XStart-1)/2. + ycen = (YDim-YStart-1)/2. + if FromTV then zoom_xy,xcen,ycen ;In case TV image has non-zero zoom or roam + xyad,hdr, xcen, ycen, ra_cen, dec_cen + str = adstring(ra_cen,dec_cen,1) + rga = strmid( str, 1, 11) + decl = strmid( str, 14, 11) + equi = sxpar( hdr, 'EQUINOX', Count = N_equi) + if N_equi EQ 0 then equi = '' else $ + equi = '(' + strmid(strtrim(equi,2),0,7) + ')' + getrot, hdr ,ROTATE, CDELT + ROTATE = strtrim(string(ROTATE, format='(f7.2)'),2) + ' degrees' + CDELT = abs(CDELT*60.*60.) + if CDELT[0] LT 0.1 then fmt = '(f7.3)' else fmt = '(f7.2)' + CDELTAS = strtrim(string(CDELT[0],format=fmt ),2) + if (abs(CDELT[0] - CDELT[1]) GT 0.05*CDELT[0]) THEN $ + CDELTAS = CDELTAS + ' by ' + strtrim(string(CDELT[1],format=fmt),2) + CDELTAS = CDELTAS + ' arcsec/pixel' + endelse + +;;; +; Printout the image information? YSpace is used to scale the spacing of the +; linformation lines in NORMAL units. dY is one line height. LabXs and LabYs +; are arrays that define the placement of Label/Value pairs in the NORMAL +; coordinates. So to increment to the next line, simply use: +; LabYs = LabYs + dY +; +if (strtrim(CLabels[0],2) ne '-1') then begin + dY = -0.025 * YSpace + LabYs = [-0.05, -0.05] * YSpace + LabX1s = [ 0.01, 0.21] * XSpace + LabX2s = [ 0.64, 0.74] * XSpace + +;;; +; Set the label color and print out each label/value. +; + !P.Color = CLabelsRGBN[3] + +;OBJECT + OBJ = strtrim( sxpar(hdr,'OBJECT', Count = N_Obj),2 ) + if N_Obj EQ 0 then begin + OBJ = strtrim( sxpar( hdr,'TARGNAME', Count = N_Obj),2) + if N_Obj EQ 0 then OBJ = 'N/A' + endif + XYOUTS, LabX1s, LabYs, ['OBJECT:',OBJ],/ NORMAL + LabYs = LabYs + dY + +;TITLE (set here, but print out later in case no header was given) + if NOT keyword_set(TITLE) then begin + if (N_Obj NE 0) then TITLE=OBJ else TITLE = '' + endif + +;IMAGE ID + imname = 'N/A' + imname = sxpar(hdr,'IMAGE', Count = N_image) + if N_image EQ 0 then imname = sxpar(hdr,'EXPNAME', Count = N_image) + if N_image EQ 0 then imname = sxpar(hdr,'OBS_ID', Count = N_image) + if N_image EQ 0 then imname = sxpar(hdr,'ROOTNAME', Count = N_image) + imname = strtrim(imname,2) + + + XYOUTS,LabX1s,LabYs,['IMAGE:',IMNAME],/NORMAL + LabYs = LabYs + dY + + LabYs = LabYs + dY + +;TELESCOPE + scop = sxpar( hdr,'INSTRUME', Count = N_Scop) + if N_Scop EQ 0 then scop = sxpar( hdr,'TELESCOP', Count = N_Scop) + if N_Scop EQ 0 then scop = sxpar( hdr,'OBSERVAT', Count = N_Scop) + if N_Scop EQ 0 then scop = '' else scop = strtrim(scop,2) + detector = sxpar( hdr,'DETECTOR', Count = N_det) + if N_det EQ 0 then detector = '' else detector = strtrim(detector,2) + if scop EQ '' then scop = detector else $ + if detector NE '' then scop = scop + '/' + detector + XYOUTS,LabX1s,LabYs,['INSTRUMENT:',scop],/NORMAL + +;SIZE + SIZ = strtrim(XDim,2) +' by ' + strtrim(YDim,2) + ' pixels' + XYOUTS,LabX2s,LabYs,['SIZE:',SIZ],/NORMAL + LabYs = LabYs + dY + +;FILTER + filter = sxpar(hdr, 'FILTER', Count= N_filter) + if N_filter EQ 0 then filter = sxpar(hdr, 'FILTNAM1', Count= N_filter) + if N_filter EQ 0 then filter = sxpar(hdr, 'FILTER1', Count= N_filter) + if N_filter EQ 0 then FILTER = 'N/A' else filter = strtrim(filter,2) + XYOUTS,LabX1s,LabYs,['CAMERA/FILTER:',FILTER],/NORMAL + +;SCALE + if NoAstrom GE 0 then XYOUTS,LabX2s,LabYs,['SCALE:',CDELTAS],/NORMAL + LabYs = LabYs + dY + +;EXPOSURE TIME First try 'EXPTIME' then 'EXPOSURE' then 'INTEG' + exptime = sxpar(hdr, 'EXPTIME', Count = N_time) + if N_time EQ 0 then exptime = sxpar(hdr, 'EXPOSURE', Count = N_time) + if N_time EQ 0 then exptime = sxpar(hdr, 'INTEG', Count = N_time) + if N_time EQ 0 then exptime = 'N/A' else $ + exptime = strmid( strtrim(exptime,2),0,6) + ' seconds' + XYOUTS,LabX1s,LabYs,['EXPOSURE TIME:',EXPTIME],/NORMAL + LabYs = LabYs + dY + + LabYs = LabYs + dY + + if noastrom GE 0 then begin +;CENTER COORDINATES + XYOUTS, LabX1s, LabYs,['CENTER '+ equi + ':', $ + 'RA = ' + RGA + ' DEC = ' + DECL], /NORMAL + LabYs = LabYs + dY + +;ROTATION + XYOUTS,LabX1s,LabYs,['ROTATION:',strtrim(ROTATE,2)],/NORMAL + LabYs = LabYs + dY + endif + + + +;COMMENTS + if keyword_set(Comments) then begin + XYOUTS,LabX1s[0],LabYs[0],'COMMENTS:',/NORMAL + for N=0,(n_elements(Comments)-1) do $ + XYOUTS,LabX1s[1],(LabYs[1] + (dY * N)),Comments[N],/NORMAL + endif + LabYs = LabYs + dY + +;USER and DATE/TIME + if not keyword_set(No_pers_info) then begin + XYOUTS, LabX2s[0],LabYs[0], GetEnv('USER') + ' (' + $ + STRMID(systime(),4,20) + ')' ,SIZE=0.9, /NORMAL + endif + + endif + + +;ARROWS +; The calculations AX and XY allow the smallest use of space for the arrows +; for all possible rotation angles. To test the extent of the circle, add +; code like the following in before the "R = float(..." line: +; hextract,ImageOut,h,i1,h1,0,5,0,5 & for N=0,18 do begin +; hrot,i1,h1,i2,h2,N*20,-1,-1,0 & getrot, h2 ,Rotate +; + if ((strtrim(CArrows[0],2) ne '-1') and (NoAstrom ne -1)) then begin + R = float(rotate) * !pi / 180 + AX = ( 0.50 + (0.05 * (cos(R) + sin(R)))) * XSpace + AY = (-0.10 - (0.05 * (cos(R) - sin(R)))) * YSpace + + !P.Font = -1 + !P.Color = CArrowsRGBN[3] + arrows, hdr, AX, AY, /NORMAL, FONT=13, COLOR=!P.Color, arrowlen=3, charsize=2 + !P.Font = 0 + endif + + +;SIZE SCALE BAR +; This is probably more complicated than necessary, but the idea is to find +; the best size scale bar for any image, where the scale may be a few arcsec +; or a few degrees. +; "BarLength" is the length of a 1 arcsecond bar in normal coordinates +; "BarScale" is the list of standard sizes for the bar in arcsec or arcmin. +; "BarLength" is the length in normal coordiates of the "best" scale bar. +; + if ((strtrim(CSize[0],2) ne '-1') and (NoAstrom ne -1)) then begin + BarLength = 1.0 / (CDelt[0] * XDim) + BarScale = [1,2,3,5,10,15,20,25,30,40] + MinBar = 0.1 * XSpace + + BS = where((BarLength * BarScale) gt MinBar) ; bar scale in arcsec? + if (BS[0] ne -1) then begin + BarLength = BarLength * BarScale[BS[0]] + BarLabel = strtrim(BarScale[BS[0]], 2) + '"' + endif else begin + BS = where((BarLength * BarScale * 60) gt MinBar) ; bar scale in arcmin? + if (BS[0] ne -1) then begin + BarLength = BarLength * BarScale[BS[0]] * 60 + BarLabel = strtrim(BarScale[BS[0]], 2) + "'" + endif else begin + BarLength = BarLength * 3600 + BarLabel = '1 degree' + endelse + endelse + +; Barlength = BarLength * XSpace + BarX = 0.7 * XSpace ; left end of bar + BarY = -0.03 * YSpace ; Y position of bar + BarDY = 0.01 * [-1,1] * YSpace ; height of bar's endpoints + LabY = BarY - (0.025 * YSpace) ; position of label + + !P.Color = CSizeRGBN[3] + plots, BarX+[0,BarLength], [BarY,BarY], /NORMAL + plots, [BarX,BarX], BarY+BarDY, /NORMAL + plots, BarLength+[BarX,BarX], BarY+BarDY,/NORMAL + xyouts, ((BarX + (BarX + BarLength)) / 2.0), LabY, /NORMAL, ALIGN=0.5, $ + '!6'+BarLabel+'!X', FONT=-1 + + endif + +endif + +;;; +; TITLE (handle here in case no header was given but TITLE keyword was used.) +; + if (keyword_set(TITLE) and (strtrim(CTitle[0],2) ne '-1')) then begin + !P.Color = CTitleRGBN[3] + XYOUTS, 0.50*XSpace, 1+(0.01*YSpace), TITLE,SIZE=2.0, /NORMAL, ALIGN=0.5 + endif + + if keyword_set(NoClose) then begin + plot,[0,xdim-1],[0,ydim-1],/noerase,xsty=5,ysty=5,/nodata, $ + pos = [0,0,1,1] + return + endif + + Device,/close + +;-------------------------------; +; SECTION: PRINTING THE FILE ; +;-------------------------------; + + if not(NoPrint or Encap) then begin ;Should the file be printed out? + if not keyword_set(PRINTER) then begin + case !VERSION.OS_FAMILY of + 'unix': printer = 'lpr' + else: printer = 'print' + endcase + endif + spawn,printer + ' ' + fname + message,/INFO,'Now printing image: $' + printer + ' ' + fname + endif + +; Reset output direction to X-windows, and restore some variables. + + tvlct,sv_rr,sv_gg,sv_bb + set_plot, sv_device + !P.font = sv_font + !P.Color = sv_color + + return + end diff --git a/modules/idl_downloads/astro/pro/tvlist.pro b/modules/idl_downloads/astro/pro/tvlist.pro new file mode 100644 index 0000000..3acc4da --- /dev/null +++ b/modules/idl_downloads/astro/pro/tvlist.pro @@ -0,0 +1,164 @@ +pro tvlist, image, dx, dy, TEXTOUT = textout, OFFSET = offset, ZOOM = ZOOM +;+ +; NAME: +; TVLIST +; PURPOSE: +; Cursor controlled listing of image pixel values in a window. +; +; CALLING SEQUENCE: +; TVLIST, [image, dx, dy, TEXTOUT=, OFFSET= , ZOOM= ] +; +; OPTIONAL INPUTS: +; IMAGE - Array containing the image currently displayed on the screen. +; If omitted, the byte pixel intensities are read from the TV +; If the array does not start at position (0,0) on the window then +; the OFFSET keyword should be supplied. +; +; DX -Integer scalar giving the number of pixels in the X direction +; to be displayed. If omitted then DX = 18 for byte images, and +; DX = 14 for integer images. TVLIST will display REAL data +; with more significant figures if more room is availble to +; print. +; +; DY - Same as DX, but in Y direction. If omitted, then DY = DX +; +; OPTIONAL INPUT KEYWORDS: +; OFFSET - 2 element vector giving the location of the image pixel (0,0) +; on the window display. OFFSET can be positive (e.g if the +; image is centered in a larger window) or negative (e.g. if the +; only the central region of an image much larger than the window +; is being displayed. +; Default value is [0,0], or no offset. +; ZOOM - Scalar specifying the magnification of the window with respect +; to the image variable. Use, for example, if image has been +; REBINed before display. +; TEXTOUT - Optional keyword that determines output device. +; The following dev/file is opened for output. +; +; textout=1 TERMINAL using /more option (default) +; textout=2 TERMINAL without /more option +; textout=3 .prt +; textout=4 laser.tmp +; textout=5 user must open file +; textout=7 Append to an existing .prt file if it +; exists +; textout = filename (default extension of .prt) +; +; If TEXTOUT > 3 or set to a filename, then TVLIST will prompt for a +; brief description to be included in the output file +; OUTPUTS: +; None. +; PROCEDURE: +; Program prompts user to place cursor on region of interest in +; image display. Corresponding region of image is then displayed at +; the terminal. A compression factor between the image array and the +; displayed image is determined using the ratio of image sizes. If +; necessary, TVLIST will divide all pixel values in a REAL*4 image by a +; (displayed) factor of 10^n (n=1,2,3...) to make a pretty format. +; +; SYSTEM VARIABLE: +; The nonstandard system variable !TEXTOUT is used as an alternative to +; the keyword TEXTOUT. The procedure ASTROLIB can be used to define +; !TEXTOUT (and !TEXTUNIT) if necessary. +; +; RESTRICTIONS: +; TVLIST may not be able to correctly format all pixel values if the +; dynamic range near the cursor position is very large. +; +; For the cursor to work under Mac OSX the "Click-through Inactive +; Windows" setting the in X11:Preferences:Window needs to be enabled. +; PROCEDURES CALLED: +; IMLIST, UNZOOM_XY +; REVISION HISTORY: +; Written by rhc, SASC Tech, 3/14/86. +; Added textout keyword option, J. Isensee, July, 1990 +; Check for readable pixels W. Landsman May 1992 +; Use integer format statement from F_FORMAT W. Landsman Feb 1994 +; Added OFFSET, ZOOM keywords W. Landsman Mar 1996 +; More intelligent formatting of longword, call TEXTOPEN with /STDOUT +; W. Landsman April, 1996 +; Added check for valid dx value W. Landsman Mar 1997 +; Converted to IDL V5.0 W. Landsman September 1997 +; Major rewrite to call IMLIST, recognize new integer data types +; W. Landsman Jan 2000 +; Remove all calls to !TEXTUNIT W. Landsman Sep 2000 +; Always call UNZOOM_XY for MOUSSE compatibility W. Landsman Sep. 2004 +;- + On_error,2 + Compile_opt idl2 + + npar = N_params() + + if npar GE 2 then $ + if N_elements( dx) NE 1 then $ + message, 'ERROR - Second parameter (format width) must be a scalar' + + if npar EQ 0 then begin ;Read pixel values from TV + + if (!D.FLAGS and 128) NE 128 then message, $ + 'ERROR -- Unable to read pixels from current device ' + !D.NAME + message,'No image array supplied, pixel values read from TV',/INF + type = 1 ;Byte format + + endif else begin + + sz = size(image) + if (sz[0] LT 2) or (sz[sz[0]+2] NE sz[1]*sz[2]) then $ + message,'Image array (first parameter) not 2-dimensional' + type = sz[sz[0]+1] ;Byte or Integer image? + + endelse + + if (!D.FLAGS AND 256) EQ 256 THEN wshow,!D.WINDOW + + if ( npar GT 0 ) then begin ;get X and Y dimensions of the image + xdim = sz[1] - 1 + ydim = sz[2] - 1 + endif else begin ;dimensions of TV display + xdim = !d.x_vsize + ydim = !d.y_vsize + endelse + + if N_elements(dx) EQ 0 then $ ;Use default print size? + if type EQ 1 then dx = 18 else dx = 15 else $ + if (dx GT 38) then begin + message, 'ERROR - X Pixel Width (second parameter) value of ' + $ + strtrim(dx,2) + ' is too large',/CON + return + endif + + tvcrs, 1 ;Make sure cursor is on + print, 'Put the cursor on the area you want to list; press any mousse button' + if Npar GT 0 then begin + cursor, xtv, ytv, /WAIT, /DEVICE + unzoom_xy, xtv, ytv, xim, yim, OFFSET=offset, ZOOM=zoom + xim = fix(xim+0.5) + yim = fix(yim+0.5) + endif else cursor, xim, yim, /WAIT, /DEVICE + + if npar LT 3 then dy = dx +; Don't try to print outside the image + xmax = (xim + dx/2) < xdim + xmin = (xim - dx/2) > 0 + ymax = (yim + dy/2) < ydim + ymin = (yim - dy/2) > 0 + + dx = xmax - xmin + 1 & dy = ymax - ymin + 1 + + if xmin GE xmax then $ + message,'ERROR - The cursor is off the image in the x-direction' + if ymin GE ymax then $ + message,'ERROR - The cursor is off the image in the y-direction' + + + if npar EQ 0 then begin + image = tvrd( xmin,ymin,dx,dy) + xim = dx/2 + yim = dy/2 + zoffset = [xmin,ymin] + endif + + imlist,image,xim,yim,dx=dx,dy=dy,textout=textout,offset=zoffset + + return + end diff --git a/modules/idl_downloads/astro/pro/unzoom_xy.pro b/modules/idl_downloads/astro/pro/unzoom_xy.pro new file mode 100644 index 0000000..ed49b9e --- /dev/null +++ b/modules/idl_downloads/astro/pro/unzoom_xy.pro @@ -0,0 +1,82 @@ +pro unzoom_xy,xtv,ytv,xim,yim,OFFSET=offset, ZOOM = zoom +;+ +; NAME: +; UNZOOM_XY +; PURPOSE: +; Converts X, Y position on the image display to the the X,Y position +; on the corresponding data array. (These positions are identical +; only for an unroamed, unzoomed image with with pixel [0,0] of the +; image placed at position [0,0] on the image display.) +; +; CALLING SEQUENCE: +; UNZoom_XY, Xtv,Ytv,Xim,Yim, [ OFFSET =, ZOOM = ] +; +; INPUTS: +; XTV - Scalar or vector giving X position(s) as read on the image +; display (e.g. with Cursor, Xtv, Ytv,/DEVICE) +; YTV - Scalar or vector giving Y position(s) on the image display. +; +; If only 2 parameters are supplied then XTV and YTV will be modified +; on output to contain the image array coordinates. +; +; OPTIONAL KEYWORD INPUT: +; OFFSET - 2 element vector giving the location of the image pixel [0,0] +; on the window display. OFFSET can be positive (e.g if the +; image is centered in a larger window) or negative (e.g. if the +; only the central region of an image much larger than the window +; is being displayed. +; Default value is [0,0], or no offset. +; ZOOM - scalar giving the ratio of the size on the image display to the +; original data size. There is no capability for separate X +; and Y zoom. Default = 1. +; OUTPUTS: +; XIM,YIM - X and Y coordinates of the image corresponding to the +; cursor position on the image display. +; COMMON BLOCKS: +; If present, ZOOM_XY will use the TV and IMAGE common blocks which are +; defined in the MOUSSE software system (see +; http://archive.stsci.edu/uit/analysis.html) If the user is not using +; the MOUSSE software (which keeps track of the offset and zoom in each +; window) then the common blocks are ignored. +; NOTES: +; The integer value of a pixel is assumed to refer to the *center* +; of a pixel. +; REVISON HISTORY: +; Adapted from MOUSSE procedure W. Landsman March 1996 +; Proper handling of offset option S. Ott/W. Landsman May 2000 +; Put back common blocks for MOUSSE compatibility September 2004 +; Fix algorithm for non-unity ZOOM values Aug. 2013 +;- + + On_error,2 + Compile_opt idl2 + common tv,chan,czoom,xroam,yroam + common images,x00,y00,xsize,ysize + + if N_params() LT 2 then begin + print,'Syntax - UNZOOM_XY, xtv, ytv, xim, yim, [OFFSET= ,ZOOM = ]' + return + endif + + + if N_elements(offset) NE 2 then begin +;Determine if Images common block defined + if N_elements(x00) eq 0 then offset = [0,0] $ + else offset = [x00[chan],y00[chan]] + endif + if N_elements(zoom) NE 1 then begin + if N_elements(czoom) GT 0 then zoom = czoom[chan] else $ + zoom = 1 + endif + + + cen = (zoom-1)/2. + xim = float((xtv-cen)/zoom) - offset[0] + yim = float((ytv-cen)/zoom) - offset[1] + if N_Params() LT 3 then begin + xtv = xim & ytv = yim + endif + +return +end + diff --git a/modules/idl_downloads/astro/pro/update_distort.pro b/modules/idl_downloads/astro/pro/update_distort.pro new file mode 100644 index 0000000..1c84b1a --- /dev/null +++ b/modules/idl_downloads/astro/pro/update_distort.pro @@ -0,0 +1,78 @@ +pro update_distort, distort, xcoeff, ycoeff +;+ +; NAME: +; UPDATE_DISTORT +; PURPOSE: +; Update SIP nonlinear distortion coefficients for a linear transformation +; EXPLANATION: +; The SIP coefficients can account for nonlinearities in the astrometry +; of an astronomical image. When the image is compressed or expanded +; these coefficients must be adjusted in a nonlinear way. +; CALLING SEQUENCE: +; UPDATE_DISTORT, distort, xcoeff, ycoeff +; INPUT/OUTPUT: +; distort - structure giving SIP coefficients. See extast.pro for +; description of the SIP distortion structure +; xcoeff - 2 element numeric vector describing the linear transformation +; xp = xcoeff[0]*x + xcoeff[1] +; xcoeff - 2 element numeric vector describing the linear transformation +; yp = ycoeff[0]*x + ycoeff[1] +; +; METHOD: +; The procedure TRANSFORM_COEFF is used to determine how the +; coefficients change under the linear transformation. +; +; See example of usage in hrebin.pro +; REVISION HISTORY: +; Written, December 2007 W. Landsman +;- + compile_opt idl2 + On_error,2 + if N_params() LT 3 then begin + print,'Syntax - UPDATE_DISTORT, distort, xcoeff, ycoeff' + return + endif + + a = distort.a + b = distort.b + a_sz = size(a,/dimen) + + for i=0,a_sz[0] - 1 do begin + a[0,i] = transform_coeff(a[*,i], xcoeff[0], xcoeff[1] ) + b[0,i] = transform_coeff(b[*,i], xcoeff[0], xcoeff[1] ) + endfor + + a = transpose(a) + b = transpose(b) + for i=0,a_sz[1] - 1 do begin + a[0,i] = transform_coeff(a[*,i], ycoeff[0], ycoeff[1] ) + b[0,i] = transform_coeff(b[*,i], ycoeff[0], ycoeff[1] ) + endfor + distort.a = transpose(a)/xcoeff[0] + distort.b = transpose(b)/ycoeff[0] + + if N_elements(distort.ap) GT 1 then begin + + ap = distort.ap + bp = distort.bp + ap_sz = size(ap,/dimen) + + for i=0,ap_sz[0] - 1 do begin + ap[0,i] = transform_coeff(ap[*,i], xcoeff[0], xcoeff[1] ) + bp[0,i] = transform_coeff(bp[*,i], xcoeff[0], xcoeff[1] ) + endfor + + ap = transpose(ap) + bp = transpose(bp) + for i=0,ap_sz[1] - 1 do begin + ap[0,i] = transform_coeff(ap[*,i], ycoeff[0], ycoeff[1] ) + bp[0,i] = transform_coeff(bp[*,i], ycoeff[0], ycoeff[1] ) + endfor + distort.ap = transpose(ap)/xcoeff[0] + distort.bp = transpose(bp)/ycoeff[0] + + endif + + return + end + diff --git a/modules/idl_downloads/astro/pro/uvbybeta.pro b/modules/idl_downloads/astro/pro/uvbybeta.pro new file mode 100644 index 0000000..45c9379 --- /dev/null +++ b/modules/idl_downloads/astro/pro/uvbybeta.pro @@ -0,0 +1,488 @@ +pro uvbybeta,xby,xm1,xc1,xHbeta,xn,Te,MV,eby,delm0,radius,TEXTOUT=textout, $ + eby_in = eby_in, name = name, prompt=prompt,print=print +;+ +; NAME: +; UVBYBETA +; PURPOSE: +; Derive dereddened colors, metallicity, and Teff from Stromgren colors. +; EXPLANATION: +; Adapted from FORTRAN routine of same name published by T.T. Moon, +; Communications of University of London Observatory, No. 78. Parameters +; can either be input interactively (with /PROMPT keyword) or supplied +; directly. +; +; CALLING SEQUENCE: +; uvbybeta, /PROMPT ;Prompt for all parameters +; uvbybeta,by,m1,c1,Hbeta,n ;Supply inputs, print outputs +; uvbybeta, by, m1, c1, Hbeta, n, Te, Mv, Eby, delm0, radius, +; [ TEXTOUT=, Eby_in =, Name = ] +; +; INPUTS: +; by - Stromgren b-y color, scalar or vector +; m1 - Stromgren line-blanketing parameter, scalar or vector +; c1 - Stromgren Balmer discontinuity parameter, scalar or vector +; Hbeta - H-beta line strength index. Set Hbeta to 0 if it is not +; known, and UVBYBETA will estimate a value based on by, m1,and c1. +; Hbeta is not used for stars in group 8. +; n - Integer (1-8), scalar or vector, giving approximate stellar +; classification +; +; (1) B0 - A0, classes III - V, 2.59 < Hbeta < 2.88,-0.20 < c0 < 1.00 +; (2) B0 - A0, class Ia , 2.52 < Hbeta < 2.59,-0.15 < c0 < 0.40 +; (3) B0 - A0, class Ib , 2.56 < Hbeta < 2.61,-0.10 < c0 < 0.50 +; (4) B0 - A0, class II , 2.58 < Hbeta < 2.63,-0.10 < c0 < 0.10 +; (5) A0 - A3, classes III - V, 2.87 < Hbeta < 2.93,-0.01 < (b-y)o< 0.06 +; (6) A3 - F0, classes III - V, 2.72 < Hbeta < 2.88, 0.05 < (b-y)o< 0.22 +; (7) F1 - G2, classes III - V, 2.60 < Hbeta < 2.72, 0.22 < (b-y)o< 0.39 +; (8) G2 - M2, classes IV _ V, 0.20 < m0 < 0.76, 0.39 < (b-y)o< 1.00 +; +; +; OPTIONAL INPUT KEYWORD: +; Eby_in - numeric scalar specifying E(b-y) color to use. If not +; supplied, then E(b-y) will be estimated from the Stromgren colors +; NAME - scalar or vector string giving name(s) of star(s). Used only +; when writing to disk for identification purposes. +; /PROMPT - if set, then uvbybeta.pro will prompt for Stromgren indicies +; interactively +; TEXTOUT - Used to determine output device. If not present, the +; value of the !TEXTOUT system variable is used (see TEXTOPEN) +; textout=1 Terminal with /MORE (if a tty) +; textout=2 Terminal without /MORE +; textout=3 uvbybeta.prt (output file) +; textout=4 Laser Printer +; textout=5 User must open file +; textout=7 Append to existing uvbybeta.prt file +; textout = filename (default extension of .prt) +; /PRINT - if set, then force display output information to the device +; specified by !TEXTOUT. By default, UVBYBETA does not display +; information if output variables are supplied (and TEXTOUT is +; not set). +; +; OPTIONAL OUTPUTS: +; Te - approximate effective temperature +; MV - absolute visible magnitude +; Eby - Color excess E(b-y) +; delm0 - metallicity index, delta m0, (may not be calculable for early +; B stars). +; radius - Stellar radius (R/R(solar)) +; EXAMPLE: +; Suppose 5 stars have the following Stromgren parameters +; +; by = [-0.001 ,0.403, 0.244, 0.216, 0.394 ] +; m1 = [0.105, -0.074, -0.053, 0.167, 0.186 ] +; c1 = [0.647, 0.215, 0.051, 0.785, 0.362] +; hbeta = [2.75, 2.552, 2.568, 2.743, 0 ] +; nn = [1,2,3,7,8] ;Processing group number +; +; Determine stellar parameters and write to a file uvbybeta.prt +; IDL> uvbybeta, by,m1,c1,hbeta, nn, t=3 +; ==> E(b-y) = 0.050 0.414 0.283 0.023 -0.025 +; Teff = 13060 14030 18420 7250 5760 +; M_V = -0.27 -6.91 -5.94 2.23 3.94 +; radius= 2.71 73.51 39.84 2.02 1.53 +; SYSTEM VARIABLES: +; The non-standard system variables !TEXTOUT and !TEXTUNIT will be +; automatically defined if they are not already present. +; +; DEFSYSV,'!TEXTOUT',1 +; DEFSYSV,'!TEXTUNIT',0 +; +; NOTES: +; (1) **This procedure underwent a major revision in January 2002 +; and the new calling sequence may not be compatible with the old** (NAME +; is now a keyword rather than a parameter.) +; +; (2) Napiwotzki et al. (1993, A&A, 268, 653) have written a FORTRAN +; program that updates some of the Moon (1985) calibrations. These +; updates are *not* included in this IDL procedure. +; PROCEDURES USED: +; DEREDD, TEXTOPEN, TEXTCLOSE +; REVISION HISTORY: +; W. Landsman IDL coding February, 1988 +; Keyword textout added, J. Isensee, July, 1990 +; Made some constants floating point. W. Landsman April, 1994 +; Converted to IDL V5.0 W. Landsman September 1997 +; Added Eby_in, /PROMPT keywords, make NAME a keyword and not a parameter +; W. Landsman January 2002 +;- + npar = N_params() + if (npar EQ 0) and ( not keyword_set(PROMPT)) then begin + print,'Syntax - UVBYBETA, by, m1, c1, beta, n, ;Input parameters' + print,' Te,MV,eby,delm0,radius ;Output parameters' + print,'Input Keywords: Eby_in=, /PROMPT, NAME=, TEXTOUT =' + return + endif + + defsysv,'!textout',exists = i + if i EQ 0 then astrolib + + if N_elements( TEXTOUT ) EQ 0 then textout = !TEXTOUT ;default output dev. + do_print = (npar LT 6) || (TEXTOUT GT 2) || keyword_set(PRINT) + + Rm1 = -0.33 & Rc1 = 0.19 & Rub = 1.53 ;Parameter values + init = 0 + + READ_PAR: if keyword_set(PROMPT) then begin + ans = '' + print,'Enter (b-y), m1, c1, and Hbeta in that order ([RETURN] to exit)' + read,ans + if ans eq '' then begin ;Normal Exit + if ( init EQ 1 ) then textclose, TEXTOUT = textout + return + endif else ans = getopt(ans) + if ( N_elements(ans) NE 4 ) then begin + message, 'INPUT ERROR - Expecting 4 scalar values', /CON + print, 'Enter 0.0 for Hbeta if it is not known: ' + goto, READ_PAR + endif else begin + xby = ans[0] & xm1 = ans[1] & xc1 = ans[2] & xhbeta = ans[3] + endelse + endif + + nstar = N_elements(xby) + xub = xc1 + 2*(xm1+xby) + xflag1 = (xHbeta EQ 0.) + + + READ_GROUP: if ( npar LT 5 )then begin + + print,' The following group of stars are available' + print, $ + '(1) B0 - A0, classes III - V, 2.59 < Hbeta < 2.88,-0.20 < c0 < 1.00' + print, $ + '(2) B0 - A0, class Ia , 2.52 < Hbeta < 2.59,-0.15 < c0 < 0.40' + print, $ + '(3) B0 - A0, class Ib , 2.56 < Hbeta < 2.61,-0.10 < c0 < 0.50' + print, $ + '(4) B0 - A0, class II , 2.58 < Hbeta < 2.63,-0.10 < c0 < 0.10' + print, $ + '(5) A0 - A3, classes III - V, 2.87 < Hbeta < 2.93,-0.01 < (b-y)o< 0.06' + print, $ + '(6) A3 - F0, classes III - V, 2.72 < Hbeta < 2.88, 0.05 < (b-y)o< 0.22' + print,$ + '(7) F1 - G2, classes III - V, 2.60 < Hbeta < 2.72, 0.22 < (b-y)o< 0.39' + print, $ + '(8) G2 - M2, classes IV _ V, 0.20 < m0 < 0.76, 0.39 < (b-y)o< 1.00' + xn = 0 + read,'Enter group number to which star belongs: ',xn + + if N_elements(name) Eq 0 then begin + if (TEXTOUT ne 1) and (npar lt 6) then begin ;Prompt for star name? + name = '' + read,'Enter name of star: ',name + endif + endif + endif + + do_eby = N_elements(eby_in) EQ 0 + te = fltarr(nstar) & MV = te & delm0 = te & radius = te + if N_elements(name) EQ 0 then name = strtrim( indgen(nstar)+1,2) + if not do_eby then eby = replicate(eby_in,nstar) else eby = te + + for i=0,Nstar -1 do begin + by = xby[i] & m1 = xm1[i] & c1 = xc1[i] & hbeta = xhbeta[i] & n = fix(xn[i]) + ub = xub[i] & flag1 = xflag1[i] + flag2 = 0 + warn = '' + + case n of + + 1: BEGIN + +; For group 1, beta is a luminosity indicator and c0 is a temperature +; indicator. (u-b) is also a suitable temperature indicator. + +; For dereddening a linear relation between the intrinsic (b-y) +; and (u-b) colors is used (Crawford 1978, AJ 83, 48) + + if do_eby then Eby[i] = ( 13.608*by-ub+1.467 ) / (13.608-Rub) + DEREDD, Eby[i], by, m1, c1, ub, by0, m0, c0, ub0 + +; If beta is not given it is estimated using a cubic fit to the +; c0-beta relation for luminosity class V given in Crawford (1978). + IF flag1 EQ 1 then Hbeta = $ + poly(c0, [2.61033, 0.132557, 0.161463, -0.027352] ) +; Calculation of the absolute magnitude by applying the calibration +; of Balona & Shobbrock (1974, MNRAS 211, 375) + g = ALOG10(Hbeta - 2.515) - 1.6*ALOG10(c0 +0.322) + MV[i] = 3.4994 + 7.2026*ALOG10(Hbeta - 2.515) -2.3192*g + 2.9375*g^3 + Te[i] = 5040/(0.2917*c0 + 0.2) + +; The ZAMS value of m0 is calculated from a fit to the data of +; Crawford (1978), modified by Hilditch, Hill & Barnes (1983, +; MNRAS 204, 241) + m0zams = poly(c0, [0.07473, 0.109804, -0.139003, 0.0957758] ) + delm0[i] = m0zams - m0 + flag2 = 1 + END + + 2: BEGIN + if do_eby then begin +; For dereddening the linear relations between c0 and (u-b) +; determined from Zhang (1983, AJ 88, 825) is used. + Eub = ( 1.5*c1 - ub + 0.035) / (1.5/(Rub/Rc1)-1) + Eby[i] = Eub/Rub + endif + DEREDD, Eby[i], by, m1, c1, ub, by0, m0, c0, ub0 + if ( flag1 EQ 1 ) then Hbeta = 0.037*c0 + 2.542 + END + + 3: BEGIN +; For dereddening the linear relations between c0 and (u-b) +; determined from Zhang (1983, AJ 88, 825) is used. + if do_Eby then begin + Eub = (1.36*c1-ub+0.004) / (1.36/(Rub/Rc1)-1) + Eby[i] = Eub/Rub + endif + DEREDD, Eby[i], by, m1, c1, ub, by0, m0, c0, ub0 +; If beta is not given it is derived from a fit of the c0-beta +; relation of Zhang (1983). + if flag1 then Hbeta = 0.047*c0 +2.578 + END + + 4: BEGIN +; For dereddening the linear relations between c0 and (u-b) +; determined from Zhang (1983, AJ 88, 825) is used. + if do_Eby then begin + Eub = ( 1.32*c1 - ub - 0.056) / ( 1.32 / (Rub/Rc1)-1 ) + Eby[i] = Eub/Rub + endif + DEREDD, Eby[i], by, m1, c1, ub, by0, m0, c0, ub0 +; If beta is not given it is derived from a fit of the c0-beta +; relation of Zhang (1983). + if ( flag1 EQ 1 ) then Hbeta = 0.066*c0+2.59 + END + + 5: BEGIN +; For group 5, the hydrogen Balmer lines are at maximum; hence two +; new parameters, a0 = f{(b-y),(u-b)} and r = f{beta,[c1]} are defined +; in order to calculate absolute magnitude and metallicity. + + if do_eby then begin + m = m1 - Rm1*by + by0 = 4.2608*m^2 - 0.53921*m - 0.0235 + REPEAT BEGIN + bycorr = by0 + m0 = m1 - Rm1*(by-bycorr) + by0 = 14.0881*m0^2 - 3.36225*m0 + 0.175709 + ENDREP UNTIL ( abs(bycorr - by0) LT 0.001) + Eby[i] = by - by0 + endif + DEREDD, Eby[i], by, m1, c1, ub, by0, m0, c0, ub0 + if flag1 eq 1 then Hbeta = 2.7905 - 0.6105*by + 0.5*m0 + 0.0355*c0 + r = 0.35*(c1-Rc1*by) - (Hbeta-2.565) + a0 = by0+ 0.18*(ub0-1.36) +; MV is calculated according to Stroemgren (1966, ARA&A 4, 433) +; with corrections by Moon & Dworetsky (1984, Observatory 104, 273) + MV[i] = 1.5 + 6.0*a0 - 17.0*r + Te[i] = 5040. /(0.7536 *a0 +0.5282) + m0zams = -3.95105*by0^2 + 0.86888*by0 + 0.1598 + delm0[i] = m0zams - m0 + end + + 6: begin + if flag1 then begin + warn = ' Estimate of Hbeta only valid if star is unreddened' + Hbeta = 3.06 - 1.221*by - 0.104*c1 + endif + m1zams = -2.158*Hbeta^2 +12.26*Hbeta-17.209 + if ( Hbeta LE 2.74 ) then begin + + c1zams = 3.0*Hbeta - 7.56 + MVzams = 22.14 - 7*Hbeta + + endif else if ( ( Hbeta GT 2.74 ) and ( Hbeta LE 2.82 ) ) then begin + + c1zams = 2.0*Hbeta - 4.82 + MVzams = 11.16-3*Hbeta + + endif else begin + c1zams = 2.0*Hbeta-4.83 + MVzams =-88.4*Hbeta^2+497.2*Hbeta-696.41 + + endelse + if do_eby then begin + delm1 = m1zams - m1 + delc1 = c1-c1zams + if delm1 lt 0. then $ + by0 = 2.946 - Hbeta - 0.1*delc1 - 0.25*delm1 else $ + by0 = 2.946 - Hbeta - 0.1*delc1 + Eby[i] = by - by0 + endif + Deredd, eby[i], by, m1, c1, ub, by0, m0, c0, ub0 + delm0[i] = m1zams - m0 + delc0 = c0 - c1zams + MV[i] = MVzams -9.0*delc0 + Te[i] = 5040 / (0.771453*by0 + 0.546544) + end + + 7: begin + +; For group 7 c1 is the luminosity indicator for a particular beta, +; while beta {or (b-y)0} indicates temperature. +; Where beta is not available iteration is necessary to evaluate +; a corrected (b-y) from which beta is then estimated. + + if flag1 then begin + byinit = by + m1init = m1 + for ii = 1,1000 do begin + m1by = 2.5*byinit^2 - 1.32*byinit + 0.345 + bycorr = byinit + (m1by-m1init) / 2.0 + if ( abs(bycorr-byinit) LE 0.0001 ) then goto,T71 + byinit = bycorr + m1init = m1by + endfor + T71: Hbeta = 1.01425*bycorr^2 - 1.32861*bycorr + 2.96618 + endif + +; m1(ZAMS) and MV(ZAMS) are calculated according to Crawford (1975) +; with corrections suggested by Hilditch, Hill & Barnes (1983, +; MNRAS 204, 241) and Olson (1984, A&AS 57, 443). + + m1zams = poly(Hbeta, [ 46.4167, -34.4538, 6.41701] ) + MVzams = poly(Hbeta, [324.482, -188.748, 11.0494, 5.48012]) + +;c1(ZAMS) calculated according to Crawford (1975) + if Hbeta le 2.65 then $ + c1zams = 2*Hbeta - 4.91 else $ + c1zams = 11.1555*Hbeta^2-56.9164*Hbeta+72.879 + + if do_eby then begin + delm1 = m1zams - m1 + delc1 = c1 - c1zams + dbeta = 2.72 - Hbeta + by0 = 0.222+1.11*dbeta +2.7*dbeta^2-0.05*delc1-(0.1+3.6*dbeta)*delm1 + Eby[i] = by - by0 + endif + Deredd,Eby[i],by,m1,c1,ub,by0,m0,c0,ub0 + delm0[i] = m1zams - m0 + delc0 = c0 - c1zams + f = 9.0 + 20.0*dbeta + MV[i] = MVzams - f*delc0 + Te[i] = 5040/(0.771453*by0 + 0.546544) + end + + 8: begin + if ( flag1 EQ 1 ) then flag1 = 2 +; Dereddening is done using color-color relations derived from +; Olson 1984, A&AS 57, 443) + if ( by LE 0.65 ) then $ + Eby[i] = (5.8651*by - ub -0.8975) / (5.8651 - Rub) $ + + else if ( ( by GT 0.65 ) and ( by LT 0.79 ) ) then begin + + Eby[i] = (-0.7875*by - c1 +0.6585)/(-0.7875 - Rc1) + by0 = by - Eby[i] + if ( by0 LT 0.65 ) then $ + Eby[i] = (5.8651*by - ub -0.8975) / (5.8651-Rub) + + endif else begin + + Eby[i] = ( 0.5126*by - c1 - 0.3645 ) / (0.5126-Rc1) + by0 = by - Eby[i] + if ( by0 LT 0.79 ) then $ + Eby[i] = (-0.7875*by - c1 + 0.6585) / (-0.7875-Rc1) + by0 = by - Eby[i] + if ( by0 LT 0.65 ) then $ + Eby[i] = ( 5.8651*by - ub - 0.8975) / (5.8651-Rub) + + endelse + + + DEREDD,Eby[i],by,m1,c1,ub,by0,m0,c0,ub0 +; m1(ZAMS), c1(ZAMS), and MV(ZAMS) are calculated according to Olson (1984) + m1zams = poly( by0, [7.18436, -49.43695, 122.1875, -122.466, 42.93678]) + IF by0 lt 0.65 THEN BEGIN + c1zams = poly(by0, [3.78514, -21.278, 42.7486, -28.7056 ] ) + MVzams = $ + poly(by0, [-59.2095, 432.156, -1101.257, 1272.503, -552.48]) + ENDIF ELSE IF (by0 GE 0.65) and (by0 lt 0.79) THEN BEGIN + c1zams = -0.631821*by0^2+0.116031*by0+0.33657 + MVzams = 1.37632*by0^2 + 4.97911*by0+3.4305 + ENDIF ELSE BEGIN + c1zams = -0.010028*by0^2 + 0.530426*by0 - 0.37237 + MVzams = 1.18298*by0^2 + 3.92776*by0 + 4.37507 + ENDELSE + delm0[i] = m1zams - m0 + delc0 =c0 - c1zams +; Teff and MV calibration of Olson (1984) + IF (by0 LE 0.505) THEN BEGIN + f = 10. - 80.*(by0-0.38) + Te[i] = 10^(-0.416*by0+3.924) + ENDIF ELSE BEGIN + f = 0.0 + Te[i] = 10^(-0.341*by0+3.869) + ENDELSE + MV[i] = MVzams - f*delc0 + 3.2*delm0[i] - 0.07 + END + ELSE: BEGIN + print,'A stellar group of',n,' is not available' + npar = npar<4 + goto, READ_GROUP + end + + endcase + if (n GE 2) and ( n LE 4 ) then begin +; c0-beta relation for ZAMS stars according to Crawford (1978, +; AJ 83, 48), modified by Hilditch, Hill & Barnes (1983, MNRAS 204, 241). + betaza = poly(c0, [2.62745, 0.228638, -0.099623, 0.277363, -0.160402 ] ) + B = betaza - 2.5 +; MV(ZAMS) calculated according to Balona & Shobbrock (1984, MNRAS 211, 375) + MVzams =203.704*B^3 - 206.98*B^2 + 77.18*b - 9.563 +; MV is calculated from the d(beta)-d(MV) relation of Zhang (1983) + dbeta = betaza - Hbeta + dMV = -121.6*dbeta^2 +61.0*dbeta + 0.08 + MV[i] = MVzams - dMV +; Estimate of Teff by coupling the relations of Boehm-Vitense +; (1981, ARA&A 19, 295) and Zhang (1983) + Te[i] = 5040 / (0.35866*ub0 + 0.27346) + flag2 = 2 +endif + +; Transformation according to the FV-(b-y)0 relation of Moon +; (1984, MNRAS 211, 21P) + if ( by0 LE 0.335 ) then $ + FV = -6.759*by0^3 + 3.731*by0^2 - 1.092*by0 + 3.981 $ + else FV = -0.534*by0 + 3.959 + radius[i] = 10^(2.*(4.236-0.1*MV[i] - FV)) + if do_print then begin + if ( flag2 EQ 2 )then metal = 'no delta(m0)' else metal = 'delta(m0) = ' + Hbeta = round(Hbeta*1000)/1000. + Teff = long(round(Te[i]/10.)*10.) + if !TEXTUNIT eq 0 then textopen,'uvbybeta',textout=textout + init = 1 ;First star has been done + printf,!TEXTUNIT,' Star is: ',strtrim(name[i],2), $ + ' Processed in group ' + strtrim(n,2) + fmt = '(2x,A, f6.3,7x, A, f6.3, 10x,A, F6.3,A,F5.3)' + if strlen(warn) GT 0 then printf, !TEXTUNIT, warn + nohbeta = ' Hbeta is not used' + + case flag1 of + 2: printf, !TEXTUNIT, 'b-y = ',by, 'm1 = ', m1,'c1 = ',c1, f=fmt, $ + nohbeta + 1: printf, !TEXTUNIT, f = fmt, $ + 'b-y = ',by, 'm1 = ', m1,'c1 = ',c1,' estimated Hbeta = ', Hbeta + 0: printf,!TEXTUNIT, f = fmt, $ + 'b-y = ',by, 'm1 = ', m1,'c1 = ',c1,' Hbeta = ', Hbeta + endcase + + fmt = '(1x,A, F6.3,7X, A,F6.3,10X,A,F6.3, 8x, A, F6.3,/)' + printf,!TEXTUNIT,f=fmt, '(b-y)0 = ', by0, 'm0 = ',m0,'c0 = ', c0, $ + 'E(b-y) = ',Eby[i] + + printf,!TEXTUNIT,form="(1X,'Absolute Magnitude (Mv) = ',F6.2,5x," + $ + "'Radius (R/R[solar]) = ',F7.2)",MV[i],radius[i] + + fmt1 = "(1X,A12,25X,'Effective Temperature (Teff) = ',I5,1X,'K'//)" + fmt2 = "(1X,A12,F6.3,20X,'Effective Temperature (Teff) = ',I5,1X,'K'//)" + + if ( flag2 EQ 2 ) then printf,!TEXTUNIT,form=fmt1,metal,Teff else $ + printf,!TEXTUNIT,form=fmt2,metal,delm0[i],Teff + + endif + endfor + if keyword_set(PROMPT) then goto, READ_PAR + if do_print then textclose, textout = textout + return + end diff --git a/modules/idl_downloads/astro/pro/vactoair.pro b/modules/idl_downloads/astro/pro/vactoair.pro new file mode 100644 index 0000000..d0dc2a9 --- /dev/null +++ b/modules/idl_downloads/astro/pro/vactoair.pro @@ -0,0 +1,68 @@ +pro vactoair,wave_vac, wave_air +;+ +; NAME: +; VACTOAIR +; PURPOSE: +; Convert vacuum wavelengths to air wavelengths +; EXPLANATION: +; Corrects for the index of refraction of air under standard conditions. +; Wavelength values below 2000 A will not be altered. Accurate to +; about 10 m/s. +; +; CALLING SEQUENCE: +; VACTOAIR, WAVE_VAC, [WAVE_AIR] +; +; INPUT/OUTPUT: +; WAVE_VAC - Vacuum Wavelength in Angstroms, scalar or vector +; If the second parameter is not supplied, then this will be +; updated on output to contain double precision air wavelengths. +; +; OPTIONAL OUTPUT: +; WAVE_AIR - Air wavelength in Angstroms, same number of elements as +; WAVE_VAC, double precision +; +; EXAMPLE: +; If the vacuum wavelength is W = 2000, then +; +; IDL> VACTOAIR, W +; +; yields an air wavelength of W = 1999.353 Angstroms +; +; METHOD: +; Formula from Ciddor 1996 Applied Optics , 35, 1566 +; +; REVISION HISTORY +; Written, D. Lindler 1982 +; Documentation W. Landsman Feb. 1989 +; Use Ciddor (1996) formula for better accuracy in the infrared +; Added optional output vector, W Landsman Mar 2011 +;- + On_error,2 + compile_opt idl2 + + if N_params() EQ 0 then begin + print,'Syntax - VACTOAIR, Wave_Vac, [Wave_Air]' + return + endif + + wave_air = double(wave_vac) + g = where(wave_vac GE 2000, Ng) ;Only modify above 2000 A + + if Ng GT 0 then begin + + sigma2 = (1d4/double(wave_vac[g]) )^2. ;Convert to wavenumber squared + +; Compute conversion factor + + fact = 1.D + 5.792105D-2/(238.0185D0 - sigma2) + $ + 1.67917D-3/( 57.362D0 - sigma2) + + +; Convert wavelengths + + wave_air[g] = wave_vac[g]/fact + if N_Params() eq 1 then wave_vac = wave_air + endif + + return + end diff --git a/modules/idl_downloads/astro/pro/valid_num.pro b/modules/idl_downloads/astro/pro/valid_num.pro new file mode 100644 index 0000000..05b2a20 --- /dev/null +++ b/modules/idl_downloads/astro/pro/valid_num.pro @@ -0,0 +1,80 @@ +;+ +; NAME: +; VALID_NUM() +; PURPOSE: +; Check if a string is a valid number representation. +; EXPLANATION: +; The input string is parsed for characters that may possibly +; form a valid number. It is more robust than simply checking +; for an IDL conversion error because that allows strings such +; as '22.3qwert' to be returned as the valid number 22.3 +; +; This function had a major rewrite in August 2008 to use STREGEX +; and allow vector input. It should be backwards compatible. +; CALLING SEQUENCE: +; IDL> status = valid_num(string [,value] [,/integer]) +; +; INPUTS: +; string - the string to be tested, scalar or array +; +; RETURNS +; status - byte scalar or array, same size as the input string +; set to 1 where the string is a valid number, 0 for invalid +; OPTIONAL OUTPUT: +; value - The value the string decodes to, same size as input string. +; This will be returned as a double precision number unless +; /INTEGER is present, in which case a long integer is returned. +; +; OPTIONAL INPUT KEYWORD: +; /INTEGER - if present code checks specifically for an integer. +; EXAMPLES: +; (1) IDL> print,valid_num(3.2,/integer) +; --> 0 ;Since 3.2 is not an integer +; (2) IDL> str =['-0.03','2.3g', '3.2e12'] +; IDL> test = valid_num(str,val) +; test = [1,0,1] & val = [-0.030000000 ,NaN ,3.2000000e+12] +; REVISION HISTORY: +; Version 1, C D Pike, RAL, 24-May-93 +; Version 2, William Thompson, GSFC, 14 October 1994 +; Added optional output parameter VALUE to allow +; VALID_NUM to replace STRNUMBER in FITS routines. +; Version 3 Wayne Landsman rewrite to use STREGEX, vectorize +; Version 4 W.L. (fix from C. Markwardt) Better Stregex expression, +; was missing numbers like '134.' before Jan 1 2010 +;- + +FUNCTION valid_num, string, value, INTEGER=integer + On_error,2 + compile_opt idl2 + +; A derivation of the regular expressions below can be found on +; http://wiki.tcl.tk/989 + + if keyword_set(INTEGER) then $ + st = '^[-+]?[0-9][0-9]*$' else $ ;Integer + st = '^[-+]?([0-9]+\.?[0-9]*|\.[0-9]+)([eEdD][-+]?[0-9]+)?$' ;F.P. + +;Simple return if we just need a boolean test. + if N_params() EQ 1 then return, stregex(strtrim(string,2),st,/boolean) + + + vv = stregex(strtrim(string,2),st,/boolean) + if size(string,/N_dimen) EQ 0 then begin ;Scalar + if vv then $ + value= keyword_set(integer) ? long(string) : double(string) + endif else begin ;Array + + g = where(vv,Ng) + if Ng GT 0 then begin ;Need to create output vector + if keyword_set(integer) then begin + value = vv*0L + value[g] = long(string[g]) + endif else begin + value = replicate(!VALUES.D_NAN,N_elements(vv)) + value[g] = double(string[g]) + endelse + endif + endelse + + return,vv + end diff --git a/modules/idl_downloads/astro/pro/vect.pro b/modules/idl_downloads/astro/pro/vect.pro new file mode 100644 index 0000000..1990abc --- /dev/null +++ b/modules/idl_downloads/astro/pro/vect.pro @@ -0,0 +1,61 @@ +function VECT,vctr,form,Format=Format,delim=delim +;+ +; NAME: +; VECT +; PURPOSE: +; Print a set of numbers as a string with delimiters included +; EXPLANATION: +; This function returns the given vector in parenthesized coordinates +; as in the form (X,Y). No limit on the number of dimensions. Also +; note that the vector does not need to be numbers. It may also be a +; string vector. e.g. ['X','Y'] +; +; CALLING SEQEUNCE: +; tmp = VECT( vctr, [ form, FORMAT = , DELIM = ] ) +; INPUT: +; VCTR The vector to be displayed e.g. [56,44] +; +; OPTIONAL KEYWORD INPUT: +; FORMAT This KEYWORD allows the specification of a format for the +; elements. e.g.: VECT([2,3],format='(f7.1)') gives '(2.0,3.0)' +; DELIM This KEYWORD specifies the delimeter. The default is ',' but +; other useful examples might be ', ' or ':' +; +; OPTIONAL INPUT +; FORM This parameter may be used instead of the keyword FORMAT +; +; OUTPUT: +; tmp A returned string of the parenthesized vector +; +; Other Procedures/Functions Called: +; STRN +; +; HISTORY: +; 03-JUL-90 Version 1 written by Eric W. Deutsch +; 24-AUG-91 Format='' keyword added (E. Deutsch) +; 29-AUG-91 FORM parameter added (E. Deutsch) +; Converted to IDL V5.0 W. Landsman September 1997 +;- + + if (n_params(0) lt 1) then begin + print,'Call: IDL> stringvar=VECT(vector,[FORMAT],[FORMAT=])' + print,"e.g.: IDL> tmp=VECT([512,512]) & print,'Center: ',tmp" + return,'' + endif + if (n_params(0) lt 2) then FORM='' + if (n_elements(vctr) lt 1) then return,'' + if (n_elements(Format) eq 0) then Format='' + if (n_elements(delim) eq 0) then delim=',' + if (FORM ne '') then Format=FORM + + tmp='(' + for i=0,n_elements(vctr)-1 do begin + sep=delim + if (i eq 0) then sep='' + if (Format eq '') then tmp=tmp+sep+strn(vctr[i]) $ + else tmp=tmp+sep+strn(vctr[i],Format=Format) + endfor + tmp=tmp+')' + + return,tmp +end diff --git a/modules/idl_downloads/astro/pro/vsym.pro b/modules/idl_downloads/astro/pro/vsym.pro new file mode 100644 index 0000000..9f78c03 --- /dev/null +++ b/modules/idl_downloads/astro/pro/vsym.pro @@ -0,0 +1,98 @@ +PRO VSYM, Nvert, STAR=star, SKELETON=skeleton, POLYGON=polygon, $ + FILL=fill, ROT=rot, THICK=thick + +;+ +; NAME: +; VSYM +; +; PURPOSE: +; Create "Mongo"-like polygonal plot symbols +; EXPLANATION: +; This procedure generates a subset of Mongo-like plot symbols. +; The symbols are the rotationally symmetric ones that have +; a specified number of vertices and are either open or filled. +; (The half-filled symbols are not included.) After defining the +; plot symbol with VSYM, make the call to PLOT (or PLOTS or OPLOT) with +; PSYM=8. +; +; CATEGORY: +; Graphics +; +; CALLING SEQUENCE: +; VSYM, Nvert +; +; INPUT POSITIONAL PARAMETERS: +; Nvert: Number of vertices in plot symbol. Maximum value +; used is 24. +; +; INPUT KEYWORD PARAMETERS: +; STAR: Set this flag to get a star. E.g., +; vsym, 5,/star gets you a pentagram. +; SKELETON: Set this flag to get an asterisk-like symbol, where +; the center is connected to each vertex. E.g., +; vsym, 4, /skel gets you an X. +; POLYGON: Set this flag to get a regular polygon. This is +; the default symbol type. +; FILL: Set this flag to get filled symbol. Default=open +; ROT: Rotation of symbol about center, in degrees. +; E.g., vsym, 4, rot=45 gets you a diamond, whereas +; vsym, 4 gets you a square. +; THICK: Line thickness of symbol. Default=!P.thick +; +; MODIFICATION HISTORY: +; Written by: R. S. Hill, RITSS, 2 Oct 98 +;- + +On_error, 0 + +IF n_elements(nvert) LT 1 THEN nvert=4 + +IF nvert GT 24 THEN $ + message,/info,'More than 24 vertices requested; 24 used' + +nv = nvert < 24 +vangle = (nv-2.)/nv*180. + +st = keyword_set(star) +sk = keyword_set(skeleton) +po = keyword_set(polygon) +fi = keyword_set(fill) +rt = keyword_set(rot) + +IF n_elements(thick) LT 1 THEN thick=!P.thick + +rot_zero = -0.5*vangle +if rt then rot_zero = rot_zero + 180./nvert + +IF st + sk + po GT 1 THEN message, 'More than one symbol type specified' +IF st + sk + po EQ 0 THEN po=1 + +angles = indgen(nv+1)/float(nv) * 2 * !pi + rot_zero/180.0*!pi +x = cos(angles) & y = sin(angles) + +inv2 = indgen(nv+1)*2 +inv2_1 = indgen(nv)*2 + 1 + +IF po THEN BEGIN + usersym, x, y, fill=fi, thick=thick +ENDIF ELSE IF sk THEN BEGIN + xx = fltarr(2*nv+1) & yy = xx + xx[inv2] = x + yy[inv2] = y + usersym, xx, yy, thick=thick +ENDIF ELSE IF st THEN BEGIN + rot2 = rot_zero + 180./nv + inner_angles = $ + indgen(nv)/float(nv) * 2 * !pi + rot2/180.0*!pi + inner_x = cos(inner_angles)*0.32 + inner_y = sin(inner_angles)*0.32 + xx = fltarr(2*nv+1) & yy = xx + xx[inv2] = x + xx[inv2_1] = inner_x + yy[inv2] = y + yy[inv2_1] = inner_y + usersym, xx, yy, fill=fi, thick=thick +ENDIF + +RETURN +END diff --git a/modules/idl_downloads/astro/pro/wcs_check_ctype.pro b/modules/idl_downloads/astro/pro/wcs_check_ctype.pro new file mode 100644 index 0000000..b613c9d --- /dev/null +++ b/modules/idl_downloads/astro/pro/wcs_check_ctype.pro @@ -0,0 +1,153 @@ +PRO wcs_check_ctype, ctype, projection_type, coord_type +;+ +; NAME: +; WCS_CHECK_CTYPE +; PURPOSE: +; Checks that a pair of CTYPE parameters conform to WCS format and return +; the projection type and coordinate type extracted from them. +; +; EXPLANATION: +; +; Stops with an error message if CTYPE does not conform to standard, +; unless one or both CTYPE strings is missing. +; +; If only CTYPE[0] is present, and is valid, this counts as a +; "pass". +; +; If ctype is unset, returns silently, with coord_type = 'X' and +; projection_type = 'DEF'. +; +; Low-level procedure extracted from WCSXY2SPH & WCSSPH2XY to reduce code +; duplication. +; +; CATEGORY: +; Mapping and Auxiliary FITS Routine +; +; CALLING SEQUENCE: +; wcs_check_ctype, ctype, projection_type, [coord_type] +; +; INPUT PARAMETERS: +; ctype - astrometry-related CTYPE strings extracted from the header. +; +; OUTPUT PARAMETERS: +; projection_type - three-character code specifying map projection. +; If ctype is not specified returns 'DEF' for default. +; coord_type - one- or two-character code specifying the coordinate +; type, 'X' (unknown) if not specified. 'C' for RA & Dec. +; +; NOTES: +; The conventions followed here check consistency with +; "Representations of Celestial Coordinates in FITS" by Calabretta +; and Greisen (2002, A&A, 395, 1077; also see +; http://fits.gsfc.nasa.gov/fits_wcs.html). +; +; PROCEDURE: +; Astrometry CTYPEs should come in longitude and latitude pairs in one +; of three formats: 'RA---xxx' & 'DEC--xxx', 'yLON-xxx' & 'yLAT-xxx', or +; 'zzLN-xxx' & 'zzLT-xxx' where xxx is the projection code and y or zz +; specify the type of the latitude & longitude axes, e.g. Galactic, +; Ecliptic etc. If the CTYPE pair is in this format, xxx is returned as +; the projection type. +; +; COMMON BLOCKS: +; none +; +; PROCEDURES CALLED: +; none +; +; AUTHOR: +; +; J. P. Leahy +; +; MODIFICATIONS/REVISION LEVEL: +; +; 1.0 Jul 2013 Extracted from WCSXY2SPH & WCSSPH2XY +; 1.1 Aug 2013 Now does actually stop if error detected. +; 1.2 Jan 2014 Recognize when RA, DEC reversed, W. Landsman +;- +COMPILE_OPT IDL2, hidden +ON_ERROR, 1 + +projection_type = 'DEF' +coord_type = 'X' +coord_form1 = 0 +IF N_elements( ctype ) GE 1 THEN BEGIN + ctype1 = strtrim(ctype[0],2) + if strlen(ctype1) LT 8 then $ + message,'ERROR - ' + strupcase(ctype1) + $ + ' is not a valid spherical projection type.' + projection_type = STRUPCASE(STRMID(ctype1,5,3)) + coord = STRUPCASE(STRMID(ctype1,0,4)) + coord_tail = STRMID(coord,2,2) + bad_coord = 0B + CASE coord_tail OF + '--': BEGIN + coord_form1 = 1 + bad_coord = coord NE 'RA--' + coord_type = 'C' + END + 'ON': BEGIN + coord_form1 = 2 + bad_coord = STRMID(coord,1,3) NE 'LON' + coord_type = STRMID(coord,0,1) + END + 'LN': BEGIN + coord_form1 = 3 + coord_type = STRMID(coord,0,2) + END + 'C-': BEGIN + coord_form1 = 1 + bad_coord = coord NE 'DEC-' + coord_type = 'C' + END + ELSE: bad_coord = 1B + ENDCASE + + IF bad_coord THEN BEGIN + MESSAGE, 'Unrecognised first coordinate type:' + coord, /continue + MESSAGE, 'Should be ''RA--'' or ''xLON'' or ''xxLN''' + ENDIF + + IF N_elements( ctype ) GE 2 THEN BEGIN + ctype2 = ctype[1] + if (projection_type ne STRUPCASE(STRMID(ctype2,5,3))) then begin + message,'The same map projection type must be in characters',/continue + message,' 5-8 of both CTYPE1 and CTYPE2.' + endif + coord = STRUPCASE(STRMID(ctype2,0,4)) + coord_tail = STRMID(coord,2,2) + CASE coord_tail OF + 'C-': BEGIN + bad_coord = coord NE 'DEC-' + coord_form2 = 1 + coord_head2='C' + END + '--': BEGIN + coord_form2 = 1 + bad_coord = coord NE 'RA--' + coord_head2 = 'C' + END + + 'AT': BEGIN + bad_coord = STRMID(coord,1,3) NE 'LAT' + coord_head2 = STRMID(coord,0,1) + coord_form2 = 2 + END + 'LT': BEGIN + coord_head2 = STRMID(coord,0,2) + coord_form2 = 3 + END + ELSE: bad_coord = 1B + ENDCASE + IF bad_coord THEN BEGIN + MESSAGE, 'Unrecognised second coordinate type:' + coord, /CONTINUE + MESSAGE, 'Should be ''DEC-'' or ''xLAT'' or ''xxLT''' + ENDIF + if (coord_form1 NE coord_form2 || coord_type NE coord_head2) then begin + message,'The same standard system must be in the first 4', /continue + message,'characters of both CTYPE1 and CTYPE2.' + endif + ENDIF +ENDIF +END + diff --git a/modules/idl_downloads/astro/pro/wcs_demo.pro b/modules/idl_downloads/astro/pro/wcs_demo.pro new file mode 100644 index 0000000..d745176 --- /dev/null +++ b/modules/idl_downloads/astro/pro/wcs_demo.pro @@ -0,0 +1,1198 @@ +;+ +; NAME: +; WCS_DEMO +; +; PURPOSE: +; Demonstrate the basic capabilities of procedures WCSSPH2XY & WCSXY2SPH +; +; CATEGORY: +; Mapping and Auxilary FITS Demo Routine +; +; CALLING SEQUENCE: +; +; .run wcs_demo: compiles wcs_demo and the supporting demo routines +; wcs_demo: run the demo +; +; INPUT PARAMETERS: +; +; none +; +; OUTPUT PARAMETERS: +; none +; +; PROCEDURE: +; +; This is a demo program which is meant to call the routines +; wcssph2xy.pro and wcsxy2sph.pro. Since the purpose of this +; routine is both to show what the routines can do and what the +; user has to do, a file is created with all of the commands +; needed to complete the desired operation. Wcs_demo actually +; executes this command file, so the user can exactly duplicate +; the results by simply re-executing this file. Also, this +; allows a user to edit an already existing file which calls +; wcssph2xy.pro and wcsxy2sph.pro properly and extend the file's +; usefulness. This demo program allows several possible tests. +; The first option is to simply draw a grid of evenly spaced +; latitude and longitude lines in a particular map transformation. +; Another possibility is to do a full loop, creating a Cartesian +; grid of latitude and longitude lines and calling wcssph2xy.pro +; to convert them to a particular map. Then, wcsxy2sph.pro is +; called to invert the process and the difference between the +; original and final latitudes and longitudes can be plotted. +; This allows one to assess the level of the numerical errors +; introduced by the mapping routines. A third possible option is to +; look at some of the map transformations and include rotations of +; the reference points so that a different perspective is given. +; +; COMMON BLOCKS: +; none +; +; PROCEDURES CALLED: +; SPHDIST(), WCSXY2SPH, WCSSPH2XY +; COPYRIGHT NOTICE: +; +; Copyright 1991, The Regents of the University of California. This +; software was produced under U.S. Government contract (W-7405-ENG-36) +; by Los Alamos National Laboratory, which is operated by the +; University of California for the U.S. Department of Energy. +; The U.S. Government is licensed to use, reproduce, and distribute +; this software. Neither the Government nor the University makes +; any warranty, express or implied, or assumes any liability or +; responsibility for the use of this software. +; +; AUTHOR: +; +; Rick Balsano +; +; MODIFICATIONS/REVISION LEVEL: +; +; 1.1 8/31/93 +; 1.2 3/19/96 - J. Bloch - LANL +; - Made compatible with wcslib-2.2 by Calabretta. +; Converted to IDL V5.0 W. Landsman September 1997 +; Updated for conical projections W. Landsman July 2003 +;- + +; PROCEDURE FOR OPTION 1 +pro wcssph2xy_plot,file_unit,map,param1,param2 +printf,file_unit,";PLOTTING" +printf,file_unit,"; Plot the resulting map." +if ((map ge 0) and (map le 22)) then begin + ; For all but the spherical cube projections, simply plot the results from + ; wcssph2xy.pro as is. + printf,file_unit,"xdelta = (max(xx) - min(xx))/20" + printf,file_unit,"ydelta = (max(y) - min(y))/20" + printf,file_unit,$ + "plot,xx,y,psym = 3,xrange = [min(xx) - xdelta,max(xx) + xdelta],$" + printf,file_unit,$ + "yrange = [min(y) - ydelta,max(y) + ydelta],xstyle = 4,ystyle = 4" + + ; ZENITHAL PROJECTIONS. + if ((map ge 1) and (map le 8)) then begin + + printf,file_unit,"" + printf,file_unit,$ + "; Only connect latitude lines in a full circle if the longitude" + printf,file_unit,"; values cover the full circle." + printf,file_unit,$ + "if (360 - abs(longitude(0,0) - longitude(n_elements(xx[*,0])-1)) $" + printf,file_unit," le lon_spacing) $" + printf,file_unit,$ + "then for i = 0,num_lat - 1 do oplot,[xx[*,i],xx(0,i)],[y[*,i],y(0,i)] $" + printf,file_unit,"else for i = 0,num_lat - 1 do oplot,xx[*,i],y[*,i]" + + printf,file_unit,"" + printf,file_unit,$ + "; Connect the longitude lines from the poles outward." + printf,file_unit,"for i = 0,num_lon - 1 do oplot,xx[i,*],y[i,*]" + + printf,file_unit,"" + printf,file_unit,";LABELS" + printf,file_unit,$ + "; Label the latitude and longitude lines and correctly orient the labels." + printf,file_unit,"j = 0" + printf,file_unit,"repeat begin" + printf,file_unit," i = lon_index(j)" + printf,file_unit," xyouts,xx(i,0)-xdelta*sin(longitude(i,0)/!radeg),$" + printf,file_unit," y(i,0)-ydelta*cos(longitude(i,0)/!radeg),$" + printf,file_unit,$ + " strcompress(string(long(longitude(i,0)))),alignment=0.5,$" + printf,file_unit," orientation=360-longitude(i,0)" + printf,file_unit," j = j + 1" + printf,file_unit,"endrep until (j eq n_elements(lon_index))" + printf,file_unit,"if (lat_index[0] ne -1) then $" + printf,file_unit," xyouts,xx(0,lat_index),y(0,lat_index),$" + printf,file_unit," strcompress(string(long(latitude(0,lat_index))))" + + ; CYLINDRICAL PROJECTIONS + endif else if (((map ge 9) and (map le 12)) or (map eq 0)) then begin + printf,file_unit,"" + printf,file_unit,"; Draw lines connecting equal longitudes" + printf,file_unit,"for i = 0,num_lon - 1 do oplot,xx[i,*],y[i,*]" + printf,file_unit,"; Draw lines connecting equal latitudes" + printf,file_unit,$ + "if ((min(longitude[*,0]) ge 180) or (max(longitude[*,0]) lt 180)) then $" + printf,file_unit," for i = 0,num_lat - 1 do oplot,xx[*,i],y[*,i] $" + printf,file_unit,"else begin" + printf,file_unit," index = where(longitude[*,0] ge 180)" + printf,file_unit,$ + " if ((360 - max(longitude[*,0]) + min(longitude[*,0])) le lon_spacing) $" + printf,file_unit," then begin" + printf,file_unit,$ + " for i = 0, num_lat - 1 do oplot,[xx(index,i),xx(0:index[0]-1,i)],$" + printf,file_unit,$ + " [y(index,i),y(0:index[0]-1,i)]" + printf,file_unit," endif else begin" + printf,file_unit," for i = 0,num_lat - 1 do begin" + printf,file_unit," oplot,xx(0:index[0] - 1,i),y(0:index[0] - 1,i)" + printf,file_unit," oplot,xx(index,i),y(index,i)" + printf,file_unit," endfor" + printf,file_unit," endelse" + printf,file_unit,"endelse" + + printf,file_unit,"" + printf,file_unit,";LABELS" + printf,file_unit,$ + "; Label the latitude and longitude lines and correctly orient the labels." + printf,file_unit,$ + "xyouts,xx(lon_index,0),y(lon_index,0) - ydelta,orientation=90,$" + printf,file_unit,$ + " strcompress(string(long(longitude(lon_index,0)))),alignment=0.5" + printf,file_unit,"y_index = where(longitude[0,*] eq max(longitude[0,*]))" + printf,file_unit,"if (lat_index[0] ne -1) then $" + printf,file_unit,$ + "xyouts,max(xx) + xdelta,y(y_index[0],lat_index),alignment=0.5,$" + printf,file_unit," strcompress(string(long(latitude(0,lat_index))))" + + ; CONICAL PROJECTIONS + endif else if ((map ge 13) and (map le 16)) then begin + printf,file_unit,"" + printf,file_unit,"; Draw lines of longitude out from the poles." + printf,file_unit,"for i = 0,num_lon - 1 do oplot,xx[i,*],y[i,*]" + + printf,file_unit,$ + "; Draw lines of latitude, making sure to break the line at 180 degrees." + printf,file_unit,"index = where(longitude[*,0] ge 180)" + printf,file_unit,"if (index[0] ne -1) then $" + printf,file_unit,$ + " for i = 0,num_lat - 1 do oplot,[xx(index,i),xx(0:index[0]-1,i)],$" + printf,file_unit," [y(index,i),y(0:index[0]-1,i)] $" + printf,file_unit,"else begin" + printf,file_unit," index = where(longitude[*,0] eq max(longitude[*,0]))" + printf,file_unit,$ + " for i = 0,num_lat - 1 do oplot,xx(0:index[0],i),y(0:index[0],i)" + printf,file_unit,"endelse" + + printf,file_unit,"" + printf,file_unit,";LABELS" + printf,file_unit,$ + "; Label latitude and longitude and correctly orient the labels." + printf,file_unit,"j = 0" + printf,file_unit,"if (min(longitude) lt 180) then begin" + printf,file_unit,$ + " lon_ind_1 = lon_index(where(longitude(lon_index,0) lt 180))" + printf,file_unit,$ + " lon_ind_1 = lon_ind_1(reverse(sort(longitude(lon_ind_1,0))))" + printf,file_unit,"endif" + printf,file_unit,"if (max(longitude) ge 180) then begin" + printf,file_unit,$ + " lon_ind_2 = lon_index(where(longitude(lon_index,0) ge 180))" + printf,file_unit,$ + " lon_ind_2 = lon_ind_2(reverse(sort(longitude(lon_ind_2,0))))" + printf,file_unit,"endif" + printf,file_unit,$ + "if ((n_elements(lon_ind_1) ne 0) and (n_elements(lon_ind_2) ne 0)) then $" + printf,file_unit," lon_index = [lon_ind_1,lon_ind_2] $" + printf,file_unit,"else if (n_elements(lon_ind_1) ne 0) then $" + printf,file_unit," lon_index = lon_ind_1 $" + printf,file_unit,"else if (n_elements(lon_ind_2) ne 0) then $" + printf,file_unit," lon_index = lon_ind_2" + if (param2 gt -param1) then begin + printf,file_unit,"repeat begin" + printf,file_unit," i = lon_index(j)" + printf,file_unit," i1 = lon_index(j + 1)" + printf,file_unit," angle = atan(y(i1,0) - y(i,0),xx(i1,0) - xx(i,0))" + printf,file_unit,$ + " xyouts,xx(i,0) + xdelta*sin(angle),y(i,0) - ydelta*cos(angle),$" + printf,file_unit,$ + " strcompress(string(long(longitude(i,0)))),alignment = 0.5,$" + printf,file_unit," orientation = !radeg*angle" + printf,file_unit," j = j + 1" + printf,file_unit,"endrep until (j eq (n_elements(lon_index) - 1))" + endif else begin + printf,file_unit,"end_index = n_elements(xx[i,*]) - 1" + printf,file_unit,"repeat begin" + printf,file_unit," i = lon_index(j)" + printf,file_unit," i1 = lon_index(j + 1)" + printf,file_unit," angle = atan(y(i1,end_index) - y(i,end_index),$" + printf,file_unit," xx(i1,end_index) - xx(i,end_index))" + printf,file_unit,$ + " xyouts,xx(i,end_index) - xdelta*sin(angle),y(i,end_index) + $" + printf,file_unit,$ + " ydelta*cos(angle),strcompress(string(long(longitude($" + printf,file_unit,"i,end_index)))),alignment=0.5,orientation=!radeg*angle" + printf,file_unit," j = j + 1" + printf,file_unit,"endrep until (j eq n_elements(lon_index) - 1)" + endelse + printf,file_unit,$ + "if (lat_index[0] ne -1) then xyouts,xx(0,lat_index),y(0,lat_index),$" + printf,file_unit,$ + " strcompress(string(long(latitude(0,lat_index))))" + + ; CONVENTIONAL PROJECTIONS + endif else if ((map ge 17) and (map le 22)) then begin + printf,file_unit,"" + printf,file_unit,"; Draw lines of longitude" + printf,file_unit,"for i = 0,num_lon - 1 do oplot,xx[i,*],y[i,*]" + + printf,file_unit,$ + "; Draw lines of latitude, breaking the line at 180 degrees." + printf,file_unit,$ + "if ((min(longitude[*,0]) ge 180) or (max(longitude[*,0]) lt 180)) then $" + printf,file_unit," for i = 0,num_lat - 1 do oplot,xx[*,i],y[*,i] $" + printf,file_unit,"else begin" + printf,file_unit," index = where(longitude[*,0] ge 180)" + printf,file_unit,$ + " if ((360 - max(longitude[*,0]) + min(longitude[*,0])) le lon_spacing) $" + printf,file_unit," then begin" + printf,file_unit,$ + " for i = 0, num_lat - 1 do oplot,[xx(index,i),xx(0:index[0]-1,i)],$" + printf,file_unit,$ + " [y(index,i),y(0:index[0]-1,i)]" + printf,file_unit," endif else begin" + printf,file_unit," for i = 0,num_lat - 1 do begin" + printf,file_unit," oplot,xx(0:index[0] - 1,i),y(0:index[0] - 1,i)" + printf,file_unit," oplot,xx(index,i),y(index,i)" + printf,file_unit," endfor" + printf,file_unit," endelse" + printf,file_unit,"endelse" + + printf,file_unit,"" + printf,file_unit,";LABELS" + printf,file_unit,$ + "; Label latitude and longitude lines and orient the labels correctly." + printf,file_unit,"if (lat_index[0] ne -1) then $" + printf,file_unit,"xyouts,xx(0,lat_index),y(0,lat_index),$" + printf,file_unit," strcompress(string(long(latitude(0,lat_index))))" + printf,file_unit,$ + "index = where(abs(latitude[0,*]) eq min(abs(latitude[0,*])))" + printf,file_unit,$ + "xyouts,xx(lon_index,index[0]),y(lon_index,index[0]),orientation=90,$" + printf,file_unit,$ +" strcompress(string(long(longitude(lon_index,index[0])))),alignment=0.5" + endif + +; SPHERICAL CUBE PROJECTIONS +endif else begin + printf,file_unit,"xx = -x" + printf,file_unit,"yy = y" + + printf,file_unit,"" + printf,file_unit,"; Make arrays with the locations of all points." + printf,file_unit,"face_0 = where(face eq 0)" + printf,file_unit,"face_1 = where(face eq 1)" + printf,file_unit,"face_2 = where(face eq 2)" + printf,file_unit,"face_3 = where(face eq 3)" + printf,file_unit,"face_4 = where(face eq 4)" + printf,file_unit,"face_5 = where(face eq 5)" + + printf,file_unit,"" + printf,file_unit,"; Define the size of the box around each face." + printf,file_unit,"x_len = 2*45.0" + printf,file_unit,"y_len = 2*45.0" + + printf,file_unit,"" + printf,file_unit,$ + "; Correctly adjust the x and y values for display purposes (they all start " + printf,file_unit,$ + "; out on the same face)." + printf,file_unit,"if (face_0[0] ne -1) then begin" + printf,file_unit," x0 = -x(face_0) + 2.d0*x_len" + printf,file_unit," y0 = y(face_0) + y_len" + printf,file_unit," xx(face_0) = x0" + printf,file_unit," yy(face_0) = y0" + printf,file_unit,"endif" + printf,file_unit,"if (face_1[0] ne -1) then begin" + printf,file_unit," x1 = -x(face_1) + 2.d0*x_len" + printf,file_unit," y1 = y(face_1)" + printf,file_unit," xx(face_1) = x1" + printf,file_unit," yy(face_1) = y1" + printf,file_unit,"endif" + printf,file_unit,"if (face_2[0] ne -1) then begin" + printf,file_unit," x2 = -x(face_2) + x_len" + printf,file_unit," y2 = y(face_2)" + printf,file_unit," xx(face_2) = x2" + printf,file_unit," yy(face_2) = y2" + printf,file_unit,"endif" + printf,file_unit,"if (face_3[0] ne -1) then begin" + printf,file_unit," x3 = -x(face_3)" + printf,file_unit," y3 = y(face_3)" + printf,file_unit," xx(face_3) = x3" + printf,file_unit," yy(face_3) = y3" + printf,file_unit,"endif" + printf,file_unit,"if (face_4[0] ne -1) then begin" + printf,file_unit," x4 = -x(face_4) - x_len" + printf,file_unit," y4 = y(face_4)" + printf,file_unit," xx(face_4) = x4" + printf,file_unit," yy(face_4) = y4" + printf,file_unit,"endif" + printf,file_unit,"if (face_5[0] ne -1) then begin" + printf,file_unit," x5 = -x(face_5) + 2.d0*x_len" + printf,file_unit," y5 = y(face_5) - y_len" + printf,file_unit," xx(face_5) = x5" + printf,file_unit," yy(face_5) = y5" + printf,file_unit,"endif" + + printf,file_unit,"" + printf,file_unit,$ + "; Define plot ranges by finding which faces are actually used." + printf,file_unit,"if (face_4[0] ne -1) then x_low = -3*x_len/2 $" + printf,file_unit,"else if (face_3[0] ne -1) then x_low = -x_len/2 $" + printf,file_unit,"else if (face_2[0] ne -1) then x_low = x_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_0[0] ne -1) or (face_5[0] ne -1)) $" + printf,file_unit,"then x_low = 3*x_len/2" + printf,file_unit,$ + "if ((face_1[0] ne -1) or (face_5[0] ne -1) or (face_0[0] ne -1)) $" + printf,file_unit," then x_high = 5*x_len/2 $" + printf,file_unit,"else if (face_2[0] ne -1) then x_high = 3*x_len/2 $" + printf,file_unit,"else if (face_3[0] ne -1) then x_high = x_len/2 $" + printf,file_unit,"else if (face_4[0] ne -1) then x_high = -x_len/2" + printf,file_unit,"if (face_5[0] ne -1) then y_low = -3*y_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_3[0] ne -1) or (face_2[0] ne -1) or $" + printf,file_unit," (face_4[0] ne -1)) then y_low = -y_len/2 $" + printf,file_unit,"else if (face_0[0] ne -1) then y_low = y_len/2" + printf,file_unit,"if (face_0[0] ne -1) then y_high = 3*y_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_3[0] ne -1) or (face_2[0] ne -1) or $" + printf,file_unit," (face_4[0] ne -1)) then y_high = y_len/2 $" + printf,file_unit,"else if (face_5[0] ne -1) then y_high = -y_len/2" + + printf,file_unit,"" + printf,file_unit,"; Plot the points calculated by wcssph2xy." + printf,file_unit,$ + "plot,xx,yy,psym=3,xrange=[x_low,x_high],yrange=[y_low,y_high],xstyle=4,$" + printf,file_unit," ystyle=4" + + printf,file_unit,"" + printf,file_unit,$ + "; Set-up an array with the correct ordering of indices to connect the" + printf,file_unit,"; latitude lines correctly on faces 1-4." + printf,file_unit,"face_ind = intarr(1)" + printf,file_unit,"if (face_4[0] ne -1) then face_ind = [face_ind,face_4]" + printf,file_unit,"if (face_3[0] ne -1) then face_ind = [face_ind,face_3]" + printf,file_unit,"if (face_2[0] ne -1) then face_ind = [face_ind,face_2]" + printf,file_unit,"if (face_1[0] ne -1) then face_ind = [face_ind,face_1]" + printf,file_unit,"; Draw the latitude lines on faces 1-4" + printf,file_unit,"if (n_elements(face_ind) gt 1) then begin" + printf,file_unit," face_ind = face_ind(1:*)" + printf,file_unit," xxx = xx(face_ind)" + printf,file_unit," yyy = yy(face_ind)" + printf,file_unit," for i = 0,num_lat - 1 do begin" + printf,file_unit," index = where(latitude(face_ind) eq latitude(0,i))" + printf,file_unit," if (index[0] ne -1) then begin" + printf,file_unit," tempx = xxx(index)" + printf,file_unit," tempy = yyy(index)" + printf,file_unit," index = sort(tempx)" + printf,file_unit,$ + " if (((360 - abs(longitude(0,0) - longitude(num_lon - 1,0))) le $" + printf,file_unit,$ + " lon_spacing) or (max(longitude(index)) le 135) or $" + printf,file_unit,$ +" (min(longitude(index)) gt 135)) then oplot,tempx(index),tempy(index) $" + printf,file_unit," else begin" + printf,file_unit," lon_ind = 0" + printf,file_unit,$ + " repeat lon_ind=lon_ind+1 until (longitude(index(lon_ind)) gt 135)" + printf,file_unit," index_1 = index(0:lon_ind - 1)" + printf,file_unit," index_2 = index(lon_ind:*) + printf,file_unit," oplot,tempx(index_1),tempy(index_1)" + printf,file_unit," oplot,tempx(index_2),tempy(index_2)" + printf,file_unit," endelse" + printf,file_unit," endif" + printf,file_unit," endfor" + printf,file_unit," endif" + printf,file_unit,"" + printf,file_unit,"; Draw latitude lines on faces 0 and 5" + printf,file_unit," for i = 0,num_lat - 1 do begin" + printf,file_unit," if (face_0[0] ne -1) then begin" + printf,file_unit," index = where(latitude(face_0) eq latitude(0,i))" + printf,file_unit," if (index[0] ne -1) then begin" + printf,file_unit,$ + " if ((360 - abs(longitude(0,0) - longitude(n_elements(x) - 1))) $" + printf,file_unit," le lon_spacing) then $" + printf,file_unit,$ + " oplot,[x0(index),x0(index[0])],[y0(index),y0(index[0])] $" + printf,file_unit," else oplot,x0(index),y0(index)" + printf,file_unit," endif" + printf,file_unit," endif" + printf,file_unit," if (face_5[0] ne -1) then begin" + printf,file_unit," index = where(latitude(face_5) eq latitude(0,i))" + printf,file_unit," if (index[0] ne -1) then begin" + printf,file_unit,$ + " if ((360 - abs(longitude(0,0) - longitude(n_elements(x) - 1))) $" + printf,file_unit," le lon_spacing) then $" + printf,file_unit,$ + " oplot,[x5(index),x5(index[0])],[y5(index),y5(index[0])] $" + printf,file_unit," else oplot,x5(index),y5(index)" + printf,file_unit," endif" + printf,file_unit," endif" + printf,file_unit," endfor" + printf,file_unit,"" + printf,file_unit,"; Draw boxes around each face and draw longitude lines" + printf,file_unit," for i = 0,num_lon - 1 do begin" + printf,file_unit," if (face_4[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_4) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x4(index),y4(index)" + printf,file_unit," plots,[-3*x_len/2,-x_len/2],[-y_len/2,-y_len/2]" + printf,file_unit," plots,[-3*x_len/2,-x_len/2],[y_len/2,y_len/2]" + printf,file_unit," plots,[-x_len/2,-x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," plots,[-3*x_len/2,-3*x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," endif" + printf,file_unit," if (face_2[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_2) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x2(index),y2(index)" + printf,file_unit," plots,[x_len/2,3*x_len/2],[-y_len/2,-y_len/2]" + printf,file_unit," plots,[x_len/2,3*x_len/2],[y_len/2,y_len/2]" + printf,file_unit," plots,[x_len/2,x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," plots,[3*x_len/2,3*x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," endif" + printf,file_unit," if (face_3[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_3) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x3(index),y3(index)" + printf,file_unit," plots,[-x_len/2,x_len/2],[-y_len/2,-y_len/2]" + printf,file_unit," plots,[-x_len/2,x_len/2],[y_len/2,y_len/2]" + printf,file_unit," plots,[-x_len/2,-x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," plots,[x_len/2,x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," endif" + printf,file_unit," if (face_1[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_1) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x1(index),y1(index)" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[-y_len/2,-y_len/2]" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[y_len/2,y_len/2]" + printf,file_unit," plots,[3*x_len/2,3*x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," plots,[5*x_len/2,5*x_len/2],[-y_len/2,y_len/2]" + printf,file_unit," endif" + printf,file_unit," if (face_0[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_0) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x0(index),y0(index)" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[y_len/2,y_len/2]" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[3*y_len/2,3*y_len/2]" + printf,file_unit," plots,[3*x_len/2,3*x_len/2],[y_len/2,3*y_len/2]" + printf,file_unit," plots,[5*x_len/2,5*x_len/2],[y_len/2,3*y_len/2]" + printf,file_unit," endif" + printf,file_unit," if (face_5[0] ne -1) then begin" + printf,file_unit," index = where(longitude(face_5) eq longitude(i,0))" + printf,file_unit," if (index[0] ne -1) then oplot,x5(index),y5(index)" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[-3*y_len/2,-3*y_len/2]" + printf,file_unit," plots,[3*x_len/2,5*x_len/2],[-y_len/2,-y_len/2]" + printf,file_unit," plots,[3*x_len/2,3*x_len/2],[-3*y_len/2,-y_len/2]" + printf,file_unit," plots,[5*x_len/2,5*x_len/2],[-3*y_len/2,-y_len/2]" + printf,file_unit," endif" + printf,file_unit," endfor" + printf,file_unit,"" + printf,file_unit,";LABELS" + printf,file_unit," if (lat_index[0] ne -1) then $" + printf,file_unit," xyouts,xx(0,lat_index),yy(0,lat_index),$" + printf,file_unit," strcompress(string(long(latitude(0,lat_index))))" + printf,file_unit,$ + " index = where(abs(latitude[0,*]) eq min(abs(latitude[0,*])))" + printf,file_unit,$ + " xyouts,xx(lon_index,index[0]),yy(lon_index,index[0]),orientation=90,$" + printf,file_unit,$ +" strcompress(string(long(longitude(lon_index,index[0])))),alignment=0.5" +endelse +end + +; PROCEDURE FOR OPTION 2 +pro inversion_error,file_unit,map,param1,param2 +printf,file_unit,";CONVERSION" +printf,file_unit,$ +"; Convert the x-y coordinates into spherical coordinates by using wcsxy2sph." +if (map lt 23) then begin + if (n_elements(param1) eq 0) then begin + printf,file_unit,"wcsxy2sph,x,y,longitude_inv,latitude_inv,map" + endif else if (n_elements(param2) eq 0) then begin + printf,file_unit,"wcsxy2sph,x,y,longitude_inv,latitude_inv,map,pv2=param1" + endif else begin + printf,file_unit,$ + "wcsxy2sph,x,y,longitude_inv,latitude_inv,map,pv2= [param1, param2] " + endelse +endif else begin + printf,file_unit,$ + "; The variable face must be declared with the same structure as latitude and" + printf,file_unit,"; longitude before calling wcsxy2sph." + printf,file_unit,"wcsxy2sph,x,y,longitude_inv,latitude_inv,map,face=face" +endelse + +printf,file_unit,"" +printf,file_unit,";PLOTTING" +printf,file_unit,"; Plot the resulting map." +printf,file_unit,"lon_delta = (max(longitude_inv) - min(longitude_inv))/20" +printf,file_unit,"lat_delta = (max(latitude_inv) - min(latitude_inv))/20" +printf,file_unit,$ + "plot,longitude_inv,latitude_inv,psym = 3,xrange = [min(longitude_inv) - $" +printf,file_unit,$ +" lon_delta,max(longitude_inv) + lon_delta],yrange = [min(latitude_inv) - $" +printf,file_unit,$ +" lat_delta,max(latitude_inv) + lat_delta],xstyle = 4,ystyle = 4" +printf,file_unit,"; Draw lines connecting equal longitudes" +printf,file_unit,$ + "for i = 0,num_lon - 1 do oplot,longitude_inv[i,*],latitude_inv[i,*]" +printf,file_unit,"; Draw lines connecting equal latitudes" +printf,file_unit,$ +"if ((min(longitude[*,0]) ge 180) or (max(longitude[*,0]) lt 180)) then $" +printf,file_unit,$ + " for i = 0,num_lat - 1 do oplot,longitude_inv[*,i],latitude_inv[*,i] $" +printf,file_unit,"else begin" +printf,file_unit," index = where(longitude[*,0] ge 180)" +printf,file_unit,$ +" if ((360 - max(longitude[*,0]) + min(longitude[*,0])) le lon_spacing) $" +printf,file_unit," then begin" +printf,file_unit,$ + " for i = 0, num_lat - 1 do oplot,[longitude_inv(index,i),$" +printf,file_unit,$ + " longitude_inv(0:index[0]-1,i)],[latitude_inv(index,i),$" +printf,file_unit," latitude_inv(0:index[0]-1,i)]" +printf,file_unit," endif else begin" +printf,file_unit," for i = 0,num_lat - 1 do begin" +printf,file_unit,$ + " oplot,longitude_inv(0:index[0] - 1,i),latitude_inv(0:index[0] - 1,i)" +printf,file_unit," oplot,longitude_inv(index,i),latitude_inv(index,i)" +printf,file_unit," endfor" +printf,file_unit," endelse" +printf,file_unit,"endelse" + +printf,file_unit,"" +printf,file_unit,";LABELS" +printf,file_unit,$ +"; Label the latitude and longitude lines and correctly orient the labels." +printf,file_unit,$ + "xyouts,longitude_inv(lon_index,0),latitude_inv(lon_index,0) - lat_delta,$" +printf,file_unit,$ + " orientation=90,strcompress(string(long(longitude(lon_index,0)))),$" +printf,file_unit," alignment=0.5" +printf,file_unit,"lat1_index = where(longitude[0,*] eq max(longitude[0,*]))" +printf,file_unit,"if (lat_index[0] ne -1) then $" +printf,file_unit,$ +"xyouts,max(longitude_inv) + lon_delta,latitude_inv(lat1_index[0],lat_index),$" +printf,file_unit,$ +" alignment=0.5,strcompress(string(long(latitude(0,lat_index))))" + +printf,file_unit,"read,'Press return to continue',key" +print," In order to make the scripts wcssph2xy.pro and wcsxy2sph.pro" +print,"invertible and minimize the error in the process, it was necessary to" +print,"offset the latitude of all points at the poles by a small amount." +print,"When viewing the difference between the original longitude and" +print,"latitude and the longitude and latitude after points are run through" +print,"wcssph2xy.pro and wcsxy2sph.pro, the offset at the poles will show up" +print,"as vertical lines. This overshadows any numerical error elsewhere" +print,"by orders of magnitude. The default is to ignore these errors, but" +print,"to include them, enter n at the prompt" +print,"" +key = "" +repeat $ + read,"Ignore offset at poles when plotting vector field (y or n):",key $ +until ((key eq "y") or (key eq "n")) + +if (key eq "y") then begin + printf,file_unit,"poles = where(abs(abs(latitude_inv) - 9.d1) le 573.d-4)" + printf,file_unit,"if (poles[0] ne -1) then $" + printf,file_unit,$ + " latitude_inv(poles) = latitude_inv(poles)/abs(latitude_inv(poles))*9.d1" +endif + +printf,file_unit, $ + "dist = sphdist(longitude,latitude,longitude_inv,latitude_inv,/degrees)" +printf,file_unit,"erase" +printf,file_unit,$ +"print,'The largest arrow on the plot will represent a difference of '" +printf,file_unit,"print,max(dist),' degrees.'" +printf,file_unit,"read,'Press return to continue',key" +printf,file_unit,$ + "norm = sqrt((longitude-longitude_inv)^2 + (latitude-latitude_inv)^2)" +printf,file_unit,"lon_diff=dist*(longitude-longitude_inv)" +printf,file_unit,"good = where(norm ne 0.d0)" +printf,file_unit,"lon_diff(good) = lon_diff(good)/norm(good)" +printf,file_unit,"lat_diff = dist*(latitude-latitude_inv)" +printf,file_unit,"lat_diff(good) = lat_diff(good)/norm(good)" +printf,file_unit,"velovect,lon_diff,lat_diff,longitude[*,0],latitude[0,*]" +end + +; PROCEDURE FOR OPTION 3 +pro wcs_rot,file_unit,map,param1,param2 +printf,file_unit,";PLOTTING" +printf,file_unit,"; Plot the resulting map." +if ((map ge 0) and (map le 22)) then begin + ; For all but the spherical cube projections, simply plot the results from + ; wcssph2xy.pro as is. + printf,file_unit,"xdelta = (max(xx) - min(xx))/20" + printf,file_unit,"ydelta = (max(y) - min(y))/20" + printf,file_unit,$ + "plot,xx,y,psym = 3,xrange = [min(xx) - xdelta,max(xx) + xdelta],$" + printf,file_unit,$ + "yrange = [min(y) - ydelta,max(y) + ydelta],xstyle = 4,ystyle = 4" + printf,file_unit,"zero_ind = where(latitude[0,*] eq min(abs(latitude[0,*])))" + printf,file_unit,$ + "xyouts,xx(lon_index,zero_ind[0]),y(lon_index,zero_ind[0]),$" + printf,file_unit,$ + " strcompress(string(long(longitude(lon_index,zero_ind[0])))),$" + printf,file_unit," alignment = 0.5" + printf,file_unit,$ + "zero_ind2 = where(longitude[*,0] eq min(abs(longitude[*,0])))" + printf,file_unit,$ + "xyouts,xx(zero_ind2[0],lat_index),y(zero_ind2[0],lat_index),$" + printf,file_unit,$ + " strcompress(string(long(latitude(zero_ind2[0],lat_index)))),$" + printf,file_unit," alignment = 0.5" + printf,file_unit,$ + "non_zero_ind = where(longitude[*,0] ne min(abs(longitude[*,0]))) + printf,file_unit,$ + "for i = 0,zero_ind[0] - 1 do $" + printf,file_unit,$ + " oplot,xx(non_zero_ind,i),y(non_zero_ind,i),psym=4" + printf,file_unit,$ + "for i = zero_ind[0] + 1,n_elements(longitude[0,*]) - 1 do $" + printf,file_unit," oplot,xx(non_zero_ind,i),y(non_zero_ind,i),psym=4" +endif else begin + printf,file_unit,"xx = -x" + printf,file_unit,"yy = y" + + printf,file_unit,"" + printf,file_unit,"; Make arrays with the locations of all points." + printf,file_unit,"face_0 = where(face eq 0)" + printf,file_unit,"face_1 = where(face eq 1)" + printf,file_unit,"face_2 = where(face eq 2)" + printf,file_unit,"face_3 = where(face eq 3)" + printf,file_unit,"face_4 = where(face eq 4)" + printf,file_unit,"face_5 = where(face eq 5)" + + printf,file_unit,"" + printf,file_unit,"; Define the size of the box around each face." + if (map eq 23) then begin + printf,file_unit,"x_len = 90" + printf,file_unit,"y_len = 90" + endif else begin + printf,file_unit,"x_len = 2*!radeg" + printf,file_unit,"y_len = 2*!radeg" + endelse + + printf,file_unit,"" + printf,file_unit,$ + "; Correctly adjust the x and y values for display purposes (they all start " + printf,file_unit,$ + "; out on the same face)." + printf,file_unit,"if (face_0[0] ne -1) then begin" + printf,file_unit," x0 = -x(face_0)" + printf,file_unit," y0 = y(face_0) - y_len" + printf,file_unit," xx(face_0) = x0" + printf,file_unit," yy(face_0) = y0" + printf,file_unit,"endif" + printf,file_unit,"if (face_1[0] ne -1) then begin" + printf,file_unit," x1 = -x(face_1) + 2.d0*x_len" + printf,file_unit," y1 = y(face_1)" + printf,file_unit," xx(face_1) = x1" + printf,file_unit," yy(face_1) = y1" + printf,file_unit,"endif" + printf,file_unit,"if (face_2[0] ne -1) then begin" + printf,file_unit," x2 = -x(face_2) + x_len" + printf,file_unit," y2 = y(face_2)" + printf,file_unit," xx(face_2) = x2" + printf,file_unit," yy(face_2) = y2" + printf,file_unit,"endif" + printf,file_unit,"if (face_3[0] ne -1) then begin" + printf,file_unit," x3 = -x(face_3)" + printf,file_unit," y3 = y(face_3)" + printf,file_unit," xx(face_3) = x3" + printf,file_unit," yy(face_3) = y3" + printf,file_unit,"endif" + printf,file_unit,"if (face_4[0] ne -1) then begin" + printf,file_unit," x4 = -x(face_4) - x_len" + printf,file_unit," y4 = y(face_4)" + printf,file_unit," xx(face_4) = x4" + printf,file_unit," yy(face_4) = y4" + printf,file_unit,"endif" + printf,file_unit,"if (face_5[0] ne -1) then begin" + printf,file_unit," x5 = -x(face_5)" + printf,file_unit," y5 = y(face_5) - y_len" + printf,file_unit," xx(face_5) = x5" + printf,file_unit," yy(face_5) = y5" + printf,file_unit,"endif" + + printf,file_unit,"" + printf,file_unit,$ + "; Define plot ranges by finding which faces are actually used." + printf,file_unit,"if (face_4[0] ne -1) then x_low = -3*x_len/2 $" + printf,file_unit,"else if (face_3[0] ne -1) then x_low = -x_len/2 $" + printf,file_unit,"else if (face_2[0] ne -1) then x_low = x_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_5[0] ne -1) or (face_0[0] ne -1)) $" + printf,file_unit," then x_low = 3*x_len/2" + printf,file_unit,"if (face_4[0] ne -1) then x_high = -x_len/2 $" + printf,file_unit,"else if (face_2[0] ne -1) then x_high = 3*x_len/2 $" + printf,file_unit,"else if (face_3[0] ne -1) then x_high = x_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_5[0] ne -1) or (face_0[0] ne -1)) $" + printf,file_unit," then x_high = 5*x_len/2" + printf,file_unit,"if (face_5[0] ne -1) then y_low = -3*y_len/2 $" + printf,file_unit,$ + "else if ((face_4[0] ne -1) or (face_3[0] ne -1) or (face_2[0] ne -1) or $" + printf,file_unit," (face_1[0] ne -1)) then y_low = -y_len/2 $" + printf,file_unit,"else if (face_0[0] ne -1) then y_low = y_len/2" + printf,file_unit,"if (face_0[0] ne -1) then y_high = 3*y_len/2 $" + printf,file_unit,$ + "else if ((face_1[0] ne -1) or (face_3[0] ne -1) or (face_2[0] ne -1) or $" + printf,file_unit," (face_4[0] ne -1)) then y_high = y_len/2 $" + printf,file_unit,"else if (face_5[0] ne -1) then y_high = -y_len/2" + + printf,file_unit,"" + printf,file_unit,"; Plot the points calculated by wcssph2xy." + printf,file_unit,$ + "plot,xx,yy,psym=3,xrange=[x_low,x_high],yrange=[y_low,y_high],xstyle=4,$" + printf,file_unit," ystyle=4" + printf,file_unit,"zero_ind = where(latitude[0,*] eq min(abs(latitude[0,*])))" + printf,file_unit,$ + "xyouts,xx(lon_index,zero_ind[0]),yy(lon_index,zero_ind[0]),$" + printf,file_unit,$ + " strcompress(string(long(longitude(lon_index,zero_ind[0])))),$" + printf,file_unit," alignment = 0.5" + printf,file_unit,$ + "zero_ind2 = where(longitude[*,0] eq min(abs(longitude[*,0])))" + printf,file_unit,$ + "xyouts,xx(zero_ind2[0],lat_index),yy(zero_ind2[0],lat_index),$" + printf,file_unit,$ + " strcompress(string(long(latitude(zero_ind2[0],lat_index)))),$" + printf,file_unit," alignment = 0.5" + printf,file_unit,$ + "non_zero_ind = where(longitude[*,0] ne min(abs(longitude[*,0]))) + printf,file_unit,$ + "for i = 0,zero_ind[0] - 1 do $" + printf,file_unit,$ + " oplot,xx(non_zero_ind,i),yy(non_zero_ind,i),psym=4" + printf,file_unit,$ + "for i = zero_ind[0] + 1,n_elements(longitude[0,*]) - 1 do $" + printf,file_unit," oplot,xx(non_zero_ind,i),yy(non_zero_ind,i),psym=4" +endelse +end + +; MAIN DEMO PROGRAM +pro wcs_demo +print,"" +print,"This demo program demonstrates the basic usage of the IDL procedures" +print,"wcssph2xy.pro and wcsxy2sph.pro. You will be prompted for information" +print,"about the type of map projection you would like to try out and what" +print,"portion of the sky you would like to view. All of the commands" +print,"actually issued to carry out these operations will be recorded in a" +print,"journal file so that the user may later reproduce the results from this" +print,"demo by issuing the commands him/herself. Enjoy!" +key='' +print,"" +repeat read,"Enter 'c' to continue or 'x' to exit:",key $ +until ((key eq 'c') or (key eq 'x')) +if (key eq 'x') then stop +print,"" + +; Major loop of whole program. +repeat begin + +print,"" +print,"Your options are:" +print,"(1) Convert spherical (sky) coordinates to x and y coordinates" +print," (in other words, perform a map projection) and plot the results." +print,"(2) Do (1) without plotting, then perform the inverse operation." +print," Plot the results, then plot the difference between the original" +print," sky coordinates and the coordinates that have been produced by" +print," wcssph2xy and wcsxy2sph." +print,"(3) Do (1) with an added twist, rotating the coordinate system." +print,"(4) Exit" +print,"" +repeat read,"Enter a number between 1 and 4:",option $ +until ((option ge 1) and (option le 4)) +print,"" + +if (option eq 4) then stop + +file_name = "" +repeat begin + read,"Please enter a name for the journal file:",file_name + print,"" + suffix = strmid(file_name,strlen(file_name)-4,4) + if (suffix ne ".pro") then file_name = string(file_name,".pro") + file_test = file_search(file_name) + if (file_test[0] ne "") then begin + print,"The file ",file_name," already exists." + print,"You can overwrite this file, but if you used this journal name" + print,"previously in this IDL session, you will not get the desired" + print,"results. To avoid any conflicts, either quit and start a new" + print,"session of IDL using this name (and ignore this message) or give a" + print,"new name to the journal file. NOTE: This is due to IDL's" + print,"inability to re-compile a procedure except from the interactive" + print,"mode." + print,"" + read,"Type 'y' to overwrite the file:",key + if (key ne 'y') then file_name = "" + endif +endrep until (file_name ne "") +openw,file_unit,file_name,/get_lun + +printf,file_unit,$ +"; This is an IDL procedure created by running the IDL program wcs_demo.pro" +printf,file_unit,$ +"; and can be executed from the IDL prompt by typing .run ",file_name,"." +printf,file_unit,$ +"; This procedure may be far more complicated than what you need. In order" +printf,file_unit,$ +"; to make it more user-friendly, I have broken up the tasks performed into" +printf,file_unit,"; the following categories:" +printf,file_unit,"; (1) SET-UP -- sections declaring constants" +printf,file_unit,$ +"; (2) CONVERSION -- section in which spherical to xy conversion is done" +printf,file_unit,$ +"; (3) LABELS -- sections setting up and printing labels on the maps" +printf,file_unit,$ +"; (4) PLOTTING -- sections in which data or lines are plotted" +printf,file_unit,$ +";To find the appropriate section, simply search for one of these four" +printf,file_unit,";capitalized words." + +printf,file_unit,"" +printf,file_unit,string("pro ",strmid(file_name,0,strlen(file_name) - 4)) + +map = 0 +print,"" +print,"Which map projection would you like to try? Your options are:" +print,"Number Description Number Description" +print,"------ ------------------------- ------ -------------------------" +print," 0 Default = Cartesian 1 Zenithal perspective" +print," 2 Gnomic 3 Orthographic" +print," 4 Stereographic 5 Zenithal Equidistant" +print," 6 Zenithal polynomial (not implemented)" +print," 7 Zenithal equal area 8 Airy" +print," 9 Cylindrical perspective 10 Cartesian" +print," 11 Mercator 12 Cylindrical equal area" +print," 13 Conical perspective 14 Conical equidistant" +print," 15 Conical equal area 16 Conical orthomorphic" +print," 17 Bonne's equal area 18 Polyconic" +print," 19 Sanson-Flmsteed 20 Parabolic" +print," 21 Hammer-Aitoff 22 Mollweide" +print," 23 Cobe Quadrilateralized Spherical Cube" +print," 24 Quadrilateralized Spherical Cube" +print," 25 Tangential Spherical Cube" +print,"" +print,$ +"NOTE: This demo program does not support the map types: 1-4,8-9,11,13, or 16 " +print,$ +"with coordinate system rotation (option 3 above). These are allowed by" +print,$ +"wcssph2xy.pro and wcsxy2sph.pro, but due to problems with the general case of" +print,$ +"latitude and longitude restrictions, these map types were skipped here." +print,"" +repeat read,"Please enter a number from 0 to 25:",map $ +until ((map ge 0) and (map le 25)) + +if (option eq 3) then begin + if ((map le 4) or (map eq 8) or (map eq 9) or (map eq 11) or (map eq 13) $ + or (map eq 16)) then begin + close,file_unit + file_delete, file_name + message,"The map type selected is not supported with coordinate rotations." + endif else begin + print,$ + "The idea behind the rotation of the coordinate systems is to relocate the" + print,$ + "'special' point of the projection. For instance, the azimuthal projections" + print,$ + "project from the north pole. So, the lines of longitude appear as rays" + print,$ + "coming from the center of the projection and lines of latitude appear as" + print,$ + "concentric rings around the center. By rotating the coordinate system," + print,$ + "a different point can play the role of the north pole in this example." + print,$ + "To perform the rotation, the latitude and longitude of the new 'special'" + print,$ + "point must be given. In addition, to specify a full rotation, a third" + print,$ + "angle must be given. This angle specifies the longitude of the north" + print,$ + "pole in the transformed system and has a default of 180 degrees." + print,"" + read,"Please enter the longitude of the 'special' point:",alpha + read,"Please enter the latitude of the 'special' point:",delta + read,"Please enter the third angle (enter 180 for the default):",longpole + endelse +endif + +printf,file_unit,";SET-UP" +printf,file_unit,"; Set-up constants used later in this procedure" +printf,file_unit,"map = ",map +print,"" + +; Get parameters for map types that require them. +case map of + 1:begin + read,$ + "AZP: Enter distance of source to projection (range = [0,10^14]):",param1 + end + 6:begin + close,file_unit + file_delete,file_name,/allow + message,"ZPN: This map projection has not been implemented." + end + 8:begin + print,"AIR: Enter the angular distance from the tangent point in which the" + read,"error is to be minimized (range = [0,90]):",param1 + end + 9:begin + read,"CYP: Enter the radius of the cylinder (range = [0,10^14]):",param2 + print,"CYP: Enter the distance from the projection point to the center of" + read,"the sphere (range = [-10^14,10^14], but not -radius):",param1 + end + 12:begin + print,"CEA: Enter the square of the cosine of the latitude at which the" + read,"map is conformal (range = [0,1]):",param1 + end + 13:begin + read,$ + "COP: Lower angle at which cone intersects sphere (range = [-90,upper]):",$ + theta1 + read,$ + "COP: Upper angle at which cone intersects sphere (range = [lower,90]):",$ + theta2 + param1 = (theta2+theta1)/2. + param2 = abs(theta2 - theta1)/2 + end + 14:begin + read,$ + "COD: Lower angle at which cone intersects sphere (range = [-90,upper]):",$ + param1 + read,$ + "COD: Upper angle at which cone intersects sphere (range = [lower,90]):",$ + param2 + end + 15:begin + read,$ + "COE: Lower angle at which cone intersects sphere (range = [-90,upper]):",$ + param1 + read,$ + "COE: Upper angle at which cone intersects sphere (range = [lower,90]):",$ + param2 + end + 16:begin + read,$ + "COO: Lower angle at which cone intersects sphere (range = [-90,upper]):",$ + param1 + read,$ + "COO: Upper angle at which cone intersects sphere (range = [lower,90]):",$ + param2 + end + 17:begin + read,"BON: Characteristic angle (range = [-90,90]):",param1 + end + else: +endcase + +if (n_elements(param1) ne 0) then printf,file_unit,"param1 = ",param1 +if (n_elements(param2) ne 0) then printf,file_unit,"param2 = ",param2 +if (n_elements(alpha) ne 0) then printf,file_unit,"alpha = ",alpha +if (n_elements(delta) ne 0) then printf,file_unit,"delta = ",delta +if (n_elements(longpole) ne 0) then printf,file_unit,"longpole = ",longpole + +print,"Would you like to:" +print,"(1) Do a whole-sky map." +print,"(2) Select a (rectangular) region on the sky to map." +print,"" +repeat read,"Enter '1' or '2':",choice until ((choice eq 1) or (choice eq 2)) +print,"" + +; Set-up to do a full-sky map. +if (choice eq 1) then begin + ; set-up the longitude range + printf,file_unit,"min_lon = 0" + printf,file_unit,"max_lon = 345" + printf,file_unit,"lon_spacing = 15" + + ; set-up the latitude range (this differs from map to map because some maps + ; diverge at particular latitudes) + if ((map eq 1) or (map eq 3)) then begin + printf,file_unit,"min_lat = 0" + printf,file_unit,"max_lat = 90" + endif else if (map eq 2) then begin + printf,file_unit,"min_lat = 15" + printf,file_unit,"max_lat = 90" + endif else if (map eq 4) then begin + printf,file_unit,"min_lat = -75" + printf,file_unit,"max_lat = 90" + endif else if (map eq 8) then begin + ; For the Airy map projection, the minimum usable latitude depends on the + ; input parameters, so it must be calculated now. + xi = (findgen(90) + 1)/!radeg + xi_b = (!pi/2.0 - param1/!radeg)/2.0 + radius=-!radeg*(alog(cos(xi))/tan(xi)+alog(cos(xi_b))/tan(xi_b)*tan(xi)) + i = 0 + repeat i = i + 1 $ + until ((radius[i + 1] lt radius[i]) or (i eq (n_elements(radius) - 2))) + i = i - 1 + min_lat = 90 - 2*!radeg*xi[i] + printf,file_unit,"min_lat = ",min_lat[0] + printf,file_unit,"max_lat = 90" + endif else if (map eq 9) then begin + ; The CYP map projection diverges at the poles when param1 (mu) is equal to 0. + if (param1 eq 0) then begin + printf,file_unit,"min_lat = -75" + printf,file_unit,"max_lat = 75" + endif else begin + printf,file_unit,"min_lat = -90" + printf,file_unit,"max_lat = 90" + endelse + endif else if (map eq 11) then begin + printf,file_unit,"min_lat = -75" + printf,file_unit,"max_lat = 75" + endif else if (map eq 13) then begin + printf,file_unit,"min_lat = -90 > (param1 - 90 + 15)" + printf,file_unit,"max_lat = 90 < (param1 + 90 - 15)" + endif else if (map eq 16) then begin + printf,file_unit,"min_lat = -75" + printf,file_unit,"max_lat = 90" + endif else begin + printf,file_unit,"min_lat = -90" + printf,file_unit,"max_lat = 90" + endelse + printf,file_unit,"lat_spacing = 15" +endif else if (choice eq 2) then begin + print,"Please enter the following quantities in degrees.' + read," minimum longitude:",min_lon + printf,file_unit,"min_lon = ",min_lon + read," maximum longitude:",max_lon + printf,file_unit,"max_lon = ",max_lon + read," longitude spacing:",lon_spacing + printf,file_unit,"lon_spacing = ",lon_spacing + read," minimum latitude:",min_lat + printf,file_unit,"min_lat = ",min_lat + read," maximum latitude:",max_lat + printf,file_unit,"max_lat = ",max_lat + read," latitude spacing:",lat_spacing + printf,file_unit,"lat_spacing = ",lat_spacing +endif + +printf,file_unit,"" +printf,file_unit,$ +"; Based on the ranges for latitude and longitude, as well as their spacing," +printf,file_unit,$ +"; generate the latitude and longitude arrays." +printf,file_unit,"num_lon = long((max_lon - min_lon)/lon_spacing) + 1" +printf,file_unit,"lon = dindgen(num_lon)*lon_spacing + min_lon" +printf,file_unit,"num_lat = long((max_lat - min_lat)/lat_spacing) + 1" +printf,file_unit,"lat = dindgen(num_lat)*lat_spacing + min_lat" +printf,file_unit,"longitude = dblarr(num_lon,num_lat)" +printf,file_unit,"for i = 0,num_lat - 1 do longitude[*,i] = lon" +printf,file_unit,"latitude = dblarr(num_lon,num_lat)" +printf,file_unit,"for i = 0,num_lon - 1 do latitude[i,*] = lat" + +printf,file_unit,"" +printf,file_unit,";CONVERSION" + +printf,file_unit,$ +"; Convert the spherical coordinates into x-y coordinates by using wcssph2xy." +if (map lt 23) then begin + if (n_elements(param1) eq 0) then begin + if (n_elements(alpha) ne 0) then begin + printf,file_unit,$ + "wcssph2xy,longitude,latitude,x,y,map,crval=[alpha,delta],$" + printf,file_unit," longpole=longpole" + endif else begin + printf,file_unit,"wcssph2xy,longitude,latitude,x,y,map" + endelse + endif else if (n_elements(param2) eq 0) then begin + if (n_elements(alpha) ne 0) then begin + printf,file_unit,$ + "wcssph2xy,longitude,latitude,x,y,map,pv2=param1, $" + printf,file_unit," crval=[alpha,delta],longpole=longpole" + endif else begin + printf,file_unit,"wcssph2xy,longitude,latitude,x,y,map,pv2=param1" + endelse + endif else begin + if (n_elements(alpha) ne 0) then begin + printf,file_unit,$ + "wcssph2xy,longitude,latitude,x,y,map,pv2=[param1,param2],$ + printf,file_unit," crval=[alpha,delta],longpole=longpole" + endif else begin + printf,file_unit,$ + "wcssph2xy,longitude,latitude,x,y,map,pv2=[param1,param2]" + endelse + endelse +endif else begin + printf,file_unit,$ + "; The variable face must be declared with the same structure as latitude and" + printf,file_unit,"; longitude before calling wcssph2xy." + printf,file_unit,"face = longitude - longitude" + if (n_elements(alpha) ne 0) then begin + printf,file_unit,$ + "wcssph2xy,longitude,latitude,x,y,map,face=face,crval=[alpha,delta], $ + printf,file_unit," longpole=longpole" + endif else begin + printf,file_unit,"wcssph2xy,longitude,latitude,x,y,map,face=face" + endelse +endelse +printf,file_unit,"" + +printf,file_unit,";PLOTTING" +printf,file_unit,$ +"; all maps have x increasing to the left, so switch this" +printf,file_unit,"xx = -x" +printf,file_unit,"" + +printf,file_unit,";LABELS" +printf,file_unit,$ +"; The arrays lon_index and lat_index contain the indices for the latitude" +printf,file_unit,$ +"; and longitude labels. Labels occur every 30 degrees unless 30 doesn't" +printf,file_unit,$ +"; divide into any of the latitude and longitude values evenly. In this case," +printf,file_unit,$ +"; all latitude and longitude lines are labeled." +printf,file_unit,$ + "lon_index = where(long(longitude[*,0])/30 eq longitude[*,0]/30.)" +printf,file_unit,$ + "lat_index = where(long(latitude[0,*])/30 eq latitude[0,*]/30.)" +printf,file_unit,$ + "if (lat_index[0] eq -1) then lat_index = indgen(n_elements(latitude[0,*]))" +printf,file_unit,$ + "if (lon_index[0] eq -1) then lon_index = indgen(n_elements(longitude[*,0]))" + +printf,file_unit,"" + +if (option lt 3) then begin + if (n_elements(param2) eq 1) then wcssph2xy_plot,file_unit,map,param1,param2 $ + else if (n_elements(param1) eq 1) then wcssph2xy_plot,file_unit,map,param1 $ + else wcssph2xy_plot,file_unit,map + + if (option eq 2) then begin + printf,file_unit,"key = ''" + printf,file_unit,"read,'Press return to continue',key" + + if (n_elements(param2) eq 1) then $ + inversion_error,file_unit,map,param1,param2 $ + else if (n_elements(param1) eq 1) then $ + inversion_error,file_unit,map,param1 $ + else inversion_error,file_unit,map + endif +endif else begin + if (n_elements(param2) eq 1) then wcs_rot,file_unit,map,param1,param2 $ + else if (n_elements(param1) eq 1) then wcs_rot,file_unit,map,param1 $ + else wcs_rot,file_unit,map +endelse + +printf,file_unit,"end" +close,file_unit +print,$ +"The commands needed to execute what you are about to see can be executed" +print,"interactively, by typing ",strmid(file_name,0,strlen(file_name)-3) +print,"" +command = strmid(file_name,0,strlen(file_name) - 4) +r = execute(command) +endrep until (option eq 4) +end diff --git a/modules/idl_downloads/astro/pro/wcs_getpole.pro b/modules/idl_downloads/astro/pro/wcs_getpole.pro new file mode 100644 index 0000000..e317cee --- /dev/null +++ b/modules/idl_downloads/astro/pro/wcs_getpole.pro @@ -0,0 +1,141 @@ +;+ +; NAME: +; WCS_GETPOLE +; +; PURPOSE: +; Compute the coordinates of the native pole +; +; EXPLANATION: +; WCS_GETPOLE is used to determine the celestial position of the +; native pole. See section 2.4 of the paper +; "Representation of Celestial Coordinates in FITS" by Calabretta +; Greisen (2002, A&A, 395, 1077, also available at +; http://fits.gsfc.nasa.gov/fits_wcs.html Called by WCS_ROTATE +; +; CALLING SEQUENCE: +; WCS_GETPOLE, crval, lonpole, theta0, alpha_p, delta_p, [LATPOLE= AT_POLE=] +; +; INPUT PARAMETERS: +; crval - 2 element vector containing standard system coordinates (the +; longitude and latitude) of the reference point in degrees +; lonpole - native longitude of the celestial North Pole (degrees) +; *unless* the fiducial point is at non-zero native longitude +; (phi_0 =/ 0), in which case phi_0 should have been subtracted, +; i.e. lonpole = phi_p - phi_0. +; theta0 - native latitude of the fiducial point (degrees) +; +; OUTPUT PARAMETERS: +; alpha_p, delta_p - celestial longitude and latitude of the native pole +; (Radians) +; OPTIONAL KEYWORD INPUT PARAMETERS: +; LATPOLE - native latitude of the celestial North Pole (degrees) +; NB only used to resolve ambiguity. Final value is the one +; nearest to input value of LATPOLE. Can be set outside range +; [-90,90] +; +; OPTIONAL KEYWORD OUTPUT PARAMETERS +; AT_POLE (byte) true if delta_p = pi/2 (avoiding some round-off errors) +; +; REVISION HISTORY: +; Written W. Landsman June, 2003 +; Fix calculation when theta0 is not 0 or 90 February 2004 +; E. Hivon: alpha_p, delta_p consistenly in Radians May 2010 +; J. P. Leahy introduced AT_POLE, more traps for special cases to +; avoid rounding errors July 2013 +; +;- + +pro WCS_GETPOLE, crval, lonpole, theta0, alpha_p, delta_p, $ + LATPOLE = latpole, AT_POLE = at_pole + + compile_opt idl2, hidden + +; check to see that enough parameters (at least 4) were sent + if (N_params() lt 5) then begin + print,'Syntax - WCS_GETPOLE, crval, lonpole, theta0 = ,alpha_p, delta_p, ' + print,' [LATPOLE= ]' + return + endif + + ; DEFINE ANGLE CONSTANTS + pi = !DPI + pi2 = acos(0d0) ; do it this way to mitigate risks of round-off errors when + ; checking equality to pi/2 + + radeg = 1.8d2/pi + alpha_0 = double(crval[0])/radeg + delta_0 = double(crval[1])/radeg + + if theta0 EQ 90 then begin + alpha_p = alpha_0 + delta_p = delta_0 + at_pole = crval[1] EQ 90d0 + return + endif + +; Longpole is the longitude in the native system of the North Pole in the +; standard system (default = 180 degrees). + + phi_p = double(lonpole)/radeg + theta_p = double(latpole)/radeg + sp = sin(phi_p) + cp = cos(phi_p) + sd = sin(delta_0) + cd = cos(delta_0) + tand = tan(delta_0) + + + if (theta0 EQ 0d0) then begin + if (delta_0 EQ 0d0) && (abs(lonpole) EQ 90.0d) then begin + delta_p = theta_p + at_pole = latpole EQ 90d0 + endif else begin + delta_p = acos( sd/cp) ;Updated May 98 + IF latpole LE -90 then delta_p *= -1d0 else if $ + (latpole LT 90 && abs(theta_p + delta_p) LT abs(theta_p - delta_p)) $ + then delta_p = -delta_p + at_pole = theta_p ge 0d0 && crval[1] EQ 0d0 + endelse + alpha_p = alpha_0 + if (lonpole NE 1.8d2) && (cd NE 0d0) THEN CASE delta_p OF + pi2: alpha_p += phi_p - !dpi + -pi2: alpha_p -= phi_p + ELSE: alpha_p -= atan(sp/cd, -tan(delta_p)*tand ) + ENDCASE + endif else IF theta0 EQ crval[1] && lonpole EQ 0 THEN BEGIN + delta_p = pi2 + alpha_p = alpha_0 + phi_p - !dpi + at_pole = 1B + ENDIF ELSE begin ;General case for arbitary theta0 + ctheta = cos(theta0/RADEG) + stheta = sin(theta0/RADEG) + term1 = atan(stheta, ctheta*cp ) + term2 = acos( sd/( sqrt(1.0d - ctheta^2*sp^2) )) + if term2 EQ 0d0 then delta_p = term1 else begin + delta_p1 = abs( (term1 + term2)*radeg) + delta_p2 = abs( (term1 - term2)*radeg) + case 1 of + (delta_p1 GT 90) and (delta_p2 GT 90):message,'No valid solution' + (delta_p1 LE 90) and (delta_p2 GT 90): delta_p = term1 + term2 + (delta_p1 GT 90) and (delta_p2 LE 90): delta_p = term1 - term2 + else: begin ;Two valid solutions + delta_p1 = (term1 + term2)*radeg + delta_p2 = (term1 - term2)*radeg + print, delta_p1, delta_p2, latpole + if abs(latpole-delta_p1) LT abs(latpole - delta_p2) then $ + delta_p = term1+term2 else delta_p = term1 - term2 + end + endcase + if (cd EQ 0d0) then alpha_p = alpha_0 else begin + sdelt = sin(delta_p) + if (sdelt EQ 1) then alpha_p = alpha_0 - phi_p - !DPI else $ + if (sdelt EQ -1) then alpha_p = alpha_0 -phi_p else $ + alpha_p = alpha_0 - $ + atan( (stheta-sin(delta_p)*sd)/(cos(delta_p)*cd), sp*ctheta/cd ) + endelse + endelse + at_pole = delta_p EQ pi2 + endelse + + return + end diff --git a/modules/idl_downloads/astro/pro/wcs_rotate.pro b/modules/idl_downloads/astro/pro/wcs_rotate.pro new file mode 100644 index 0000000..e9b64b4 --- /dev/null +++ b/modules/idl_downloads/astro/pro/wcs_rotate.pro @@ -0,0 +1,205 @@ +;+ +; NAME: +; WCS_ROTATE +; +; PURPOSE: +; Rotate between standard (e.g. celestial) and native coordinates +; EXPLANATION: +; Computes a spherical coordinate rotation between native coordinates +; and standard celestial coordinate system (celestial, Galactic, or +; ecliptic). Applies the equations in Appendix B of the paper +; "Representation of Celestial Coordinates in FITS" by Calabretta +; Greisen (2002, A&A, 395, 1077). Also see +; http://fits.gsfc.nasa.gov/fits_wcs.html +; +; CATEGORY: +; Mapping and Auxiliary FITS Routine +; +; CALLING SEQUENCE: +; WCS_ROTATE, longitude, latitude, phi, theta, crval, theta0 = +; [LONGPOLE = , LATPOLE = , PV1 = , /REVERSE, /ORIGIN ] +; +; INPUT PARAMETERS: +; crval - 2 element vector containing standard system coordinates (the +; longitude and latitude) of the reference point +; +; INPUT OR OUTPUT PARAMETERS +; longitude - longitude of data, scalar or vector, in degrees, in the +; standard celestial coordinate system +; latitude - latitude of data, same number of elements as longitude, +; in degrees +; theta - latitude of data in the native system, in degrees, scalar or +; vector +; +; If the keyword(REVERSE) is set then phi and theta are input parameters +; and longitude and latitude are computed. Otherwise, longitude and +; latitude are input parameters and phi and theta are computed. +; +; OPTIONAL KEYWORD INPUT PARAMETERS: +; +; THETA0 - Native latitude of the reference point (required unless PV1 set) +; PV1 - Vector giving parameters of user-defined fiducial point +; LONGPOLE - native longitude of standard system's North Pole +; LATPOLE - native latitude of the standard system's North Pole +; /REVERSE - if set then phi and theta are input parameters and longitude +; and latitude are computed. By default, longitude and +; latitude are input parameters and phi and theta are computed. +; +; /ORIGIN This keyword is obsolete and is no longer used. Replaced by +; explicitly specifying theta0 and/or PV1 +; +; REVISION HISTORY: +; Written W. Landsman December, 1994 +; Fixed error in finding North Pole if /ORIGIN and LONGPOLE NE 180 +; Xiaoyi Wu and W. Landsman, March, 1996 +; Fixed implementation of March 96 error, J. Thieler, April 1996 +; Updated to IDL V5.0 W. Landsman December 1997 +; Fixed determination of alpha_p if /ORIGIN and LONGPOLE EQ 180 +; W. Landsman May 1998 +; Ensure argument of ASIN() is -1