diff --git a/Code/.DS_Store b/Code/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..8f7b3328c74ea79382b39f6d9b3a74f32c351f55 Binary files /dev/null and b/Code/.DS_Store differ diff --git a/Code/VisIVODesktop-vtk6_qt5.pro b/Code/VisIVODesktop-vtk6_qt5.pro new file mode 100644 index 0000000000000000000000000000000000000000..777be4a5e60508aed208d308eab108e3623acb14 --- /dev/null +++ b/Code/VisIVODesktop-vtk6_qt5.pro @@ -0,0 +1,251 @@ +#------------------------------------------------- +# +# Project created by QtCreator 2015-05-18T11:03:07 +# +#------------------------------------------------- + +QT += core gui network printsupport xml widgets concurrent webkitwidgets +#CONFIG += static +QMAKE_MAC_SDK = macosx10.13 +CONFIG-=app_bundle + +greaterThan(QT_MAJOR_VERSION, 4): QT += widgets + +TARGET = VisIVODesktop-vtk6_qt5 +TEMPLATE = app + + +ICON = logo.icns +#win32:RC_ICONS += your_icon.ico + + +INCLUDEPATH += /opt/vtk6.20/include/vtk-6.2/ +INCLUDEPATH += /opt/cfitsio3_1_0/include/ \ + /opt/local/include \ + /opt/boost_1_63_0/include/ + +INCLUDEPATH += /Users/fxbio6600/OACT/VisIVOServer_svn_locale/branches/2.3/ +INCLUDEPATH +=/opt/hdf5-1.10.0-patch1/include +LIBS += /opt/cfitsio3_1_0/lib/libcfitsio.a + + +LIBS += -L/opt/vtk6.20/lib/ +LIBS += -lvtkChartsCore-6.2 -lvtkCommonColor-6.2 -lvtkCommonComputationalGeometry-6.2 -lvtkCommonCore-6.2 -lvtkCommonDataModel-6.2 -lvtkCommonExecutionModel-6.2 -lvtkCommonMath-6.2 -lvtkCommonMisc-6.2 -lvtkCommonSystem-6.2 -lvtkCommonTransforms-6.2 -lvtkDICOMParser-6.2 -lvtkDomainsChemistry-6.2 -lvtkFiltersAMR-6.2 -lvtkFiltersCore-6.2 -lvtkFiltersExtraction-6.2 -lvtkFiltersFlowPaths-6.2 -lvtkFiltersGeneral-6.2 -lvtkFiltersGeneric-6.2 -lvtkFiltersGeometry-6.2 -lvtkFiltersHybrid-6.2 -lvtkFiltersHyperTree-6.2 -lvtkFiltersImaging-6.2 -lvtkFiltersModeling-6.2 -lvtkFiltersParallel-6.2 -lvtkFiltersParallelImaging-6.2 -lvtkFiltersProgrammable-6.2 -lvtkFiltersSMP-6.2 -lvtkFiltersSelection-6.2 -lvtkFiltersSources-6.2 -lvtkFiltersStatistics-6.2 -lvtkFiltersTexture-6.2 -lvtkFiltersVerdict-6.2 -lvtkGUISupportQt-6.2 -lvtkGUISupportQtOpenGL-6.2 -lvtkGUISupportQtSQL-6.2 -lvtkGUISupportQtWebkit-6.2 -lvtkGeovisCore-6.2 -lvtkIOAMR-6.2 -lvtkIOCore-6.2 -lvtkIOEnSight-6.2 -lvtkIOExodus-6.2 -lvtkIOExport-6.2 -lvtkIOGeometry-6.2 -lvtkIOImage-6.2 -lvtkIOImport-6.2 -lvtkIOInfovis-6.2 -lvtkIOLSDyna-6.2 -lvtkIOLegacy-6.2 -lvtkIOMINC-6.2 -lvtkIOMovie-6.2 -lvtkIONetCDF-6.2 -lvtkIOPLY-6.2 -lvtkIOParallel-6.2 -lvtkIOParallelXML-6.2 -lvtkIOSQL-6.2 -lvtkIOVideo-6.2 -lvtkIOXML-6.2 -lvtkIOXMLParser-6.2 -lvtkImagingColor-6.2 -lvtkImagingCore-6.2 -lvtkImagingFourier-6.2 -lvtkImagingGeneral-6.2 -lvtkImagingHybrid-6.2 -lvtkImagingMath-6.2 -lvtkImagingMorphological-6.2 -lvtkImagingSources-6.2 -lvtkImagingStatistics-6.2 -lvtkImagingStencil-6.2 -lvtkInfovisCore-6.2 -lvtkInfovisLayout-6.2 -lvtkInteractionImage-6.2 -lvtkInteractionStyle-6.2 -lvtkInteractionWidgets-6.2 -lvtkNetCDF-6.2 -lvtkNetCDF_cxx-6.2 -lvtkParallelCore-6.2 -lvtkRenderingAnnotation-6.2 -lvtkRenderingContext2D-6.2 -lvtkRenderingContextOpenGL-6.2 -lvtkRenderingCore-6.2 -lvtkRenderingFreeType-6.2 -lvtkRenderingFreeTypeOpenGL-6.2 -lvtkRenderingGL2PS-6.2 -lvtkRenderingImage-6.2 -lvtkRenderingLIC-6.2 -lvtkRenderingLOD-6.2 -lvtkRenderingLabel-6.2 -lvtkRenderingOpenGL-6.2 -lvtkRenderingQt-6.2 -lvtkRenderingVolume-6.2 -lvtkRenderingVolumeOpenGL-6.2 -lvtkViewsContext2D-6.2 -lvtkViewsCore-6.2 -lvtkViewsInfovis-6.2 -lvtkViewsQt-6.2 -lvtkalglib-6.2 -lvtkexoIIc-6.2 -lvtkexpat-6.2 -lvtkfreetype-6.2 -lvtkftgl-6.2 -lvtkgl2ps-6.2 -lvtkhdf5-6.2 -lvtkhdf5_hl-6.2 -lvtkjpeg-6.2 -lvtkjsoncpp-6.2 -lvtklibxml2-6.2 -lvtkmetaio-6.2 -lvtkoggtheora-6.2 -lvtkpng-6.2 -lvtkproj4-6.2 -lvtksqlite-6.2 -lvtksys-6.2 -lvtktiff-6.2 -lvtkverdict-6.2 -lvtkzlib-6.2 +#LIBS += -lvtkChartsCore-6.2 -lvtkCommonColor-6.2 -lvtkCommonComputationalGeometry-6.2 -lvtkCommonCore-6.2 -lvtkCommonDataModel-6.2 -lvtkCommonExecutionModel-6.2 -lvtkCommonMath-6.2 -lvtkCommonMisc-6.2 -lvtkCommonSystem-6.2 -lvtkCommonTransforms-6.2 -lvtkDICOMParser-6.2 -lvtkDomainsChemistry-6.2 -lvtkFiltersAMR-6.2 -lvtkFiltersCore-6.2 -lvtkFiltersExtraction-6.2 -lvtkFiltersFlowPaths-6.2 -lvtkFiltersGeneral-6.2 -lvtkFiltersGeneric-6.2 -lvtkFiltersGeometry-6.2 -lvtkFiltersHybrid-6.2 -lvtkFiltersHyperTree-6.2 -lvtkFiltersImaging-6.2 -lvtkFiltersModeling-6.2 -lvtkFiltersParallel-6.2 -lvtkFiltersParallelImaging-6.2 -lvtkFiltersProgrammable-6.2 -lvtkFiltersSMP-6.2 -lvtkFiltersSelection-6.2 -lvtkFiltersSources-6.2 -lvtkFiltersStatistics-6.2 -lvtkFiltersTexture-6.2 -lvtkFiltersVerdict-6.2 -lvtkGUISupportQt-6.2 -lvtkGUISupportQtOpenGL-6.2 -lvtkGUISupportQtSQL-6.2 -lvtkGUISupportQtWebkit-6.2 -lvtkGeovisCore-6.2 -lvtkIOAMR-6.2 -lvtkIOCore-6.2 -lvtkIOEnSight-6.2 -lvtkIOExodus-6.2 -lvtkIOExport-6.2 -lvtkIOGeometry-6.2 -lvtkIOImage-6.2 -lvtkIOImport-6.2 -lvtkIOInfovis-6.2 -lvtkIOLSDyna-6.2 -lvtkIOLegacy-6.2 -lvtkIOMINC-6.2 -lvtkIOMovie-6.2 -lvtkIONetCDF-6.2 -lvtkIOPLY-6.2 -lvtkIOParallel-6.2 -lvtkIOParallelXML-6.2 -lvtkIOSQL-6.2 -lvtkIOVideo-6.2 -lvtkIOXML-6.2 -lvtkIOXMLParser-6.2 -lvtkImagingColor-6.2 -lvtkImagingCore-6.2 -lvtkImagingFourier-6.2 -lvtkImagingGeneral-6.2 -lvtkImagingHybrid-6.2 -lvtkImagingMath-6.2 -lvtkImagingMorphological-6.2 -lvtkImagingSources-6.2 -lvtkImagingStatistics-6.2 -lvtkImagingStencil-6.2 -lvtkInfovisCore-6.2 -lvtkInfovisLayout-6.2 -lvtkInteractionImage-6.2 -lvtkInteractionStyle-6.2 -lvtkInteractionWidgets-6.2 -lvtkNetCDF-6.2 -lvtkNetCDF_cxx-6.2 -lvtkParallelCore-6.2 -lvtkRenderingAnnotation-6.2 -lvtkRenderingContext2D-6.2 -lvtkRenderingContextOpenGL-6.2 -lvtkRenderingCore-6.2 -lvtkRenderingFreeType-6.2 -lvtkRenderingFreeTypeFontConfig-6.2 -lvtkRenderingFreeTypeOpenGL-6.2 -lvtkRenderingGL2PS-6.2 -lvtkRenderingImage-6.2 -lvtkRenderingLIC-6.2 -lvtkRenderingLOD-6.2 -lvtkRenderingLabel-6.2 -lvtkRenderingOpenGL-6.2 -lvtkRenderingQt-6.2 -lvtkRenderingVolume-6.2 -lvtkRenderingVolumeOpenGL-6.2 -lvtkViewsContext2D-6.2 -lvtkViewsCore-6.2 -lvtkViewsInfovis-6.2 -lvtkViewsQt-6.2 -lvtkalglib-6.2 -lvtkexoIIc-6.2 -lvtkexpat-6.2 -lvtkfreetype-6.2 -lvtkftgl-6.2 -lvtkgl2ps-6.2 -lvtkhdf5-6.2 -lvtkhdf5_hl-6.2 -lvtkjpeg-6.2 -lvtkjsoncpp-6.2 -lvtklibxml2-6.2 -lvtkmetaio-6.2 -lvtkoggtheora-6.2 -lvtkpng-6.2 -lvtkproj4-6.2 -lvtksqlite-6.2 -lvtksys-6.2 -lvtktiff-6.2 -lvtkverdict-6.2 -lvtkzlib-6.2 +#LIBS += -L/Users/fxbio6600/OACT/develop/VisIVODesktop6/trunk/lib/ -lsamp -lVOApps -lVO -lVOTable -lVOClient +LIBS += -lm -lc -lpthread -lcurl +LIBS += /Users/fxbio6600/OACT/VisIVOServer_svn_locale/branches/2.3/API_LIGHT/libVisIVOApi.a +LIBS += -L/opt/hdf5-1.10.0-patch1/lib/ -lhdf5 +LIBS += /usr/lib/libc++.dylib + +macx:LIBS += -framework \ + Foundation \ + -framework \ + Cocoa \ + -framework \ + GLUT \ + -framework \ + QTKit \ + -framework \ + OpenGL \ + -framework \ + AGL \ + -framework \ + IOKit \ + -framework \ + QtPrintSupport + + + +SOURCES += src/main.cpp\ + src/mainwindow.cpp \ + src/treemodel.cpp \ + src/treeitem.cpp \ + src/vtkfitsreader.cpp \ + src/vispoint.cpp \ + src/observedobject.cpp \ + src/operationqueue.cpp \ + src/sednode.cpp \ + src/sed.cpp \ + src/pointspipe.cpp \ + src/pipe.cpp \ + src/vtkellipse.cpp \ + src/base64.cpp \ + src/astroutils.cpp \ + src/libwcs/fitsfile.c \ + src/libwcs/hget.c \ + src/libwcs/fileutil.c \ + src/libwcs/fitswcs.c \ + src/libwcs/distort.c \ + src/libwcs/hput.c \ + src/libwcs/iget.c \ + src/libwcs/imio.c \ + src/libwcs/imhfile.c \ + src/libwcs/dateutil.c \ + src/libwcs/wcsinit.c \ + src/libwcs/dsspos.c \ + src/libwcs/wcs.c \ + src/libwcs/wcstrig.c \ + src/libwcs/wcscon.c \ + src/libwcs/lin.c \ + src/libwcs/platepos.c \ + src/libwcs/tnxpos.c \ + src/libwcs/wcslib.c \ + src/libwcs/cel.c \ + src/libwcs/proj.c \ + src/libwcs/sph.c \ + src/libwcs/worldpos.c \ + src/vialacteasource.cpp \ + src/vlkbquery.cpp \ + src/loadingwidget.cpp \ + src/sedvisualizerplot.cpp \ + src/qcustomplot.cpp \ + src/sedplotpointcustom.cpp \ + src/sedfitgrid_thin.cpp \ + src/sedfitgrid_thick.cpp \ + src/luteditor.cpp \ + src/vtktoolswidget.cpp \ + src/color.cpp \ + src/vtkfitstoolswidget.cpp \ + src/higalselectedsources.cpp \ + src/plotwindow.cpp \ + src/vlkbquerycomposer.cpp \ + src/vlkbtable.cpp \ + src/fitsimagestatisiticinfo.cpp \ + src/vlkbsimplequerycomposer.cpp \ + src/dbquery.cpp \ + src/xmlparser.cpp \ + src/vialactea_fileload.cpp \ + src/selectedsourcefieldsselect.cpp \ + src/downloadmanager.cpp \ + src/viewselectedsourcedataset.cpp \ + src/vialactea.cpp \ + src/contour.cpp \ + src/histogram.cpp \ + src/lutselector.cpp \ + src/vtkwindow_new.cpp \ + src/vtkfitstoolwidget_new.cpp \ + src/vtkfitstoolwidgetobject.cpp \ + src/vialacteainitialquery.cpp \ + src/settingform.cpp \ + src/aboutform.cpp \ + src/selectedsourcesform.cpp \ + src/vtklegendscaleactor.cpp \ + src/lutcustomize.cpp \ + src/vtkextracthistogram.cpp \ + src/extendedglyph3d.cpp \ + # src/vosamp.cpp \ + src/visivoimporterdesktop.cpp \ + src/vstabledesktop.cpp \ + src/visivoutilsdesktop.cpp \ + src/vsobjectdesktop.cpp \ + src/visivofilterdesktop.cpp \ + src/filtercustomize.cpp \ + src/vialacteastringdictwidget.cpp + + +HEADERS += src/mainwindow.h \ + src/singleton.h \ + src/treemodel.h \ + src/treeitem.h \ + src/vtkfitsreader.h \ + src/vispoint.h \ + src/observedobject.h \ + src/operationqueue.h \ + src/sednode.h \ + src/sed.h \ + src/pointspipe.h \ + src/pipe.h \ + src/vtkellipse.h \ + src/base64.h \ + src/astroutils.h \ + src/libwcs/fitsfile.h \ + src/libwcs/wcs.h \ + src/vialacteasource.h \ + src/vlkbquery.h \ + src/loadingwidget.h \ + src/sedvisualizerplot.h \ + src/qcustomplot.h \ + src/sedplotpointcustom.h \ + src/sedfitgrid_thin.h \ + src/sedfitgrid_thick.h \ + src/luteditor.h \ + src/vtktoolswidget.h \ + src/color.h \ + src/vtkfitstoolswidget.h \ + src/higalselectedsources.h \ + src/plotwindow.h \ + src/vlkbquerycomposer.h \ + src/vlkbtable.h \ + src/fitsimagestatisiticinfo.h \ + src/vlkbsimplequerycomposer.h \ + src/dbquery.h \ + src/xmlparser.h \ + src/extendedglyph3d.h \ + src/vialactea_fileload.h \ + src/selectedsourcefieldsselect.h \ + src/downloadmanager.h \ + src/viewselectedsourcedataset.h \ + src/vialactea.h \ + src/contour.h \ + src/histogram.h \ + src/lutselector.h \ + src/vtkwindow_new.h \ + src/vtkfitstoolwidget_new.h \ + src/vtkfitstoolwidgetobject.h \ + src/vialacteainitialquery.h \ + src/settingform.h \ + src/aboutform.h \ + src/selectedsourcesform.h \ + src/vtklegendscaleactor.h \ + src/lutcustomize.h \ + src/vtkextracthistogram.h \ + src/osxhelper.h \ + # src/vosamp.h \ + src/visivoimporterdesktop.h \ + src/vstabledesktop.h \ + src/visivoutilsdesktop.h \ + src/vsobjectdesktop.h \ + src/visivofilterdesktop.h \ + src/filtercustomize.h \ + src/vialacteastringdictwidget.h + + +FORMS += ui/mainwindow.ui \ + ui/operationqueue.ui \ + ui/vtkwindow.ui \ + ui/vlkbquery.ui \ + ui/loadingwidget.ui \ + ui/sedvisualizerplot.ui \ + ui/sedfitgrid_thin.ui \ + ui/sedfitgrid_thick.ui \ + ui/vtktoolswidget.ui \ + ui/vtkfitstoolswidget.ui \ + ui/higalselectedsources.ui \ + ui/plotwindow.ui \ + ui/vlkbquerycomposer.ui \ + ui/fitsimagestatisiticinfo.ui \ + ui/vlkbsimplequerycomposer.ui \ + ui/dbquery.ui \ + ui/vialactea_fileload.ui \ + ui/selectedsourcefieldsselect.ui \ + ui/viewselectedsourcedataset.ui \ + ui/vialactea.ui \ + ui/contour.ui \ + ui/vtkwindow_new.ui \ + ui/vtkfitstoolwidget_new.ui \ + ui/vialacteainitialquery.ui \ + ui/settingform.ui \ + ui/aboutform.ui \ + ui/selectedsourcesform.ui \ + ui/lutcustomize.ui \ + ui/filtercustomize.ui \ + src/vialacteastringdictwidget.ui + +RESOURCES += \ + visivo.qrc + +DISTFILES += + +OBJECTIVE_SOURCES += \ + src/osxhelper.mm diff --git a/Code/VisIVODesktop-vtk6_qt5.pro.user b/Code/VisIVODesktop-vtk6_qt5.pro.user new file mode 100644 index 0000000000000000000000000000000000000000..f62c868f3582485f2a962a0a503d0234d65dccc1 --- /dev/null +++ b/Code/VisIVODesktop-vtk6_qt5.pro.user @@ -0,0 +1,339 @@ + + + + + + EnvironmentId + {d7bdcdd1-3e2c-4559-a568-85e4bf761de3} + + + ProjectExplorer.Project.ActiveTarget + 0 + + + ProjectExplorer.Project.EditorSettings + + true + false + true + + Cpp + + CppGlobal + + + + QmlJS + + QmlJSGlobal + + + 2 + UTF-8 + false + 4 + false + 80 + true + true + 1 + true + false + 0 + true + true + 0 + 8 + true + 1 + true + true + true + false + + + + ProjectExplorer.Project.PluginSettings + + + + ProjectExplorer.Project.Target.0 + + Desktop + Desktop + {fefc9313-5518-4942-9856-e8ccfb4406bc} + 1 + 0 + 0 + + /Users/fxbio6600/OACT/develop/VisIVODesktop6/build-VisIVODesktop-vtk6_qt5-Desktop-Debug + + + true + qmake + + QtProjectManager.QMakeBuildStep + true + + false + false + false + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + false + + + + 2 + Build + + ProjectExplorer.BuildSteps.Build + + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + true + clean + + + 1 + Clean + + ProjectExplorer.BuildSteps.Clean + + 2 + false + + LC_NUMERIC=en_US.UTF-8 + + Debug + + Qt4ProjectManager.Qt4BuildConfiguration + 2 + true + + + /Users/fxbio6600/OACT/develop/VisIVODesktop6/build-VisIVODesktop-vtk6_qt5-Desktop-Release + + + true + qmake + + QtProjectManager.QMakeBuildStep + false + + false + false + false + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + false + + + + 2 + Build + + ProjectExplorer.BuildSteps.Build + + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + true + clean + + + 1 + Clean + + ProjectExplorer.BuildSteps.Clean + + 2 + false + + Release + + Qt4ProjectManager.Qt4BuildConfiguration + 0 + true + + + /Users/fxbio6600/OACT/develop/VisIVODesktop6/build-VisIVODesktop-vtk6_qt5-Desktop-Profile + + + true + qmake + + QtProjectManager.QMakeBuildStep + true + + false + true + false + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + false + + + + 2 + Build + + ProjectExplorer.BuildSteps.Build + + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + true + clean + + + 1 + Clean + + ProjectExplorer.BuildSteps.Clean + + 2 + false + + Profile + + Qt4ProjectManager.Qt4BuildConfiguration + 0 + true + + 3 + + + 0 + Deploy + + ProjectExplorer.BuildSteps.Deploy + + 1 + Deploy locally + + ProjectExplorer.DefaultDeployConfiguration + + 1 + + + false + false + 1000 + + true + + false + false + false + false + true + 0.01 + 10 + true + 1 + 25 + + 1 + true + false + true + valgrind + + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + + 2 + + VisIVODesktop-vtk6_qt5 + + Qt4ProjectManager.Qt4RunConfiguration:/Users/fxbio6600/OACT/develop/VisIVODesktop6/trunk/VisIVODesktop-vtk6_qt5.pro + true + + VisIVODesktop-vtk6_qt5.pro + false + false + + /Users/fxbio6600/OACT/develop/VisIVODesktop6/build-VisIVODesktop-vtk6_qt5-Desktop-Release + 3768 + false + true + false + false + true + + 1 + + + + ProjectExplorer.Project.TargetCount + 1 + + + ProjectExplorer.Project.Updater.FileVersion + 18 + + + Version + 18 + + diff --git a/Code/VisIVODesktop-vtk6_qt5.pro.user.a9018b3 b/Code/VisIVODesktop-vtk6_qt5.pro.user.a9018b3 new file mode 100644 index 0000000000000000000000000000000000000000..6dc29e650dc877e4c7699d8e4766be0f92869ced --- /dev/null +++ b/Code/VisIVODesktop-vtk6_qt5.pro.user.a9018b3 @@ -0,0 +1,271 @@ + + + + + + EnvironmentId + {a9018b3b-7afd-4732-92b3-1651299ec816} + + + ProjectExplorer.Project.ActiveTarget + 0 + + + ProjectExplorer.Project.EditorSettings + + true + false + true + + Cpp + + CppGlobal + + + + QmlJS + + QmlJSGlobal + + + 2 + UTF-8 + false + 4 + false + 80 + true + true + 1 + true + false + 0 + true + 0 + 8 + true + 1 + true + true + true + false + + + + ProjectExplorer.Project.PluginSettings + + + + ProjectExplorer.Project.Target.0 + + Desktop Qt 5.4.1 clang 64bit + Desktop Qt 5.4.1 clang 64bit + qt.54.clang_64_kit + 1 + 0 + 0 + + /Users/fxbio6600/OACT/develop/VisIVODesktop6/build-VisIVODesktop-vtk6_qt5-Desktop_Qt_5_4_1_clang_64bit-Debug + + + true + qmake + + QtProjectManager.QMakeBuildStep + false + true + + false + false + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + false + + + + 2 + Build + + ProjectExplorer.BuildSteps.Build + + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + true + clean + + + 1 + Clean + + ProjectExplorer.BuildSteps.Clean + + 2 + false + + Debug + + Qt4ProjectManager.Qt4BuildConfiguration + 2 + true + + + /Users/fxbio6600/OACT/develop//build-VisIVODesktop-vtk6_qt5-Desktop_Qt_5_4_1_clang_64bit-Release + + + true + qmake + + QtProjectManager.QMakeBuildStep + false + true + + false + false + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + false + + + + 2 + Build + + ProjectExplorer.BuildSteps.Build + + + + true + Make + + Qt4ProjectManager.MakeStep + + -w + -r + + true + clean + + + 1 + Clean + + ProjectExplorer.BuildSteps.Clean + + 2 + false + + LC_NUMERIC=en_US.UTF-8 + + Release + + Qt4ProjectManager.Qt4BuildConfiguration + 0 + true + + 2 + + + 0 + Deploy + + ProjectExplorer.BuildSteps.Deploy + + 1 + Deploy locally + + ProjectExplorer.DefaultDeployConfiguration + + 1 + + + + false + false + false + false + true + 0.01 + 10 + true + 1 + 25 + + 1 + true + false + true + /opt/valgrind/bin/valgrind + + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + + 2 + + VisIVODesktop-vtk6_qt5 + + Qt4ProjectManager.Qt4RunConfiguration:/Users/fxbio6600/OACT/develop/VisIVODesktop6/trunk/VisIVODesktop-vtk6_qt5.pro + + VisIVODesktop-vtk6_qt5.pro + false + false + + 3768 + false + true + false + false + true + + 1 + + + + ProjectExplorer.Project.TargetCount + 1 + + + ProjectExplorer.Project.Updater.FileVersion + 18 + + + Version + 18 + + diff --git a/Code/customprocess.cpp b/Code/customprocess.cpp new file mode 100644 index 0000000000000000000000000000000000000000..049202855696f1f8193ba58cd33977bfa928a77b --- /dev/null +++ b/Code/customprocess.cpp @@ -0,0 +1,24 @@ +#include "customprocess.h" +#include +#include +#include + +CustomProcess::CustomProcess() +{ + + + QProcess *process = new QProcess(); + connect(process, SIGNAL(finished(int, QProcess::ExitStatus)), this, SLOT(onFinished())); + process->start("ls", QStringList()); + if (!process->waitForStarted()) + qDebug() << "error"; + + + +} + +CustomProcess::~CustomProcess() +{ + +} + diff --git a/Code/customprocess.h b/Code/customprocess.h new file mode 100644 index 0000000000000000000000000000000000000000..d9cdea0b8bfd56cee46ddad2fcc5158a6e076c74 --- /dev/null +++ b/Code/customprocess.h @@ -0,0 +1,13 @@ +#ifndef CUSTOMPROCESS_H +#define CUSTOMPROCESS_H + +#include + +class CustomProcess : public QObject +{ +public: + CustomProcess(); + ~CustomProcess(); +}; + +#endif // CUSTOMPROCESS_H diff --git a/Code/icons/.DS_Store b/Code/icons/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..24154484bd613f6e2b458b27a646d1a320b9b64b Binary files /dev/null and b/Code/icons/.DS_Store differ diff --git a/Code/icons/CHECK_OFF.bmp b/Code/icons/CHECK_OFF.bmp new file mode 100644 index 0000000000000000000000000000000000000000..29a0e4bccd08104e2c7a8d4ad6fa64a9a01b4137 Binary files /dev/null and b/Code/icons/CHECK_OFF.bmp differ diff --git a/Code/icons/CHECK_ON.bmp b/Code/icons/CHECK_ON.bmp new file mode 100644 index 0000000000000000000000000000000000000000..f51be532e7d0959975bcd3478cf073aa38f7ccef Binary files /dev/null and b/Code/icons/CHECK_ON.bmp differ diff --git a/Code/icons/CLOSE_SASH.bmp b/Code/icons/CLOSE_SASH.bmp new file mode 100644 index 0000000000000000000000000000000000000000..b4ea916b0b3ba8b5b60f3a97a4c2caa9cd25b87c Binary files /dev/null and b/Code/icons/CLOSE_SASH.bmp differ diff --git a/Code/icons/DISABLED.bmp b/Code/icons/DISABLED.bmp new file mode 100644 index 0000000000000000000000000000000000000000..babe589514b1c1605d54a4f19216078de74d0b32 Binary files /dev/null and b/Code/icons/DISABLED.bmp differ diff --git a/Code/icons/FILE_NEW.bmp b/Code/icons/FILE_NEW.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2f0377fdcfc37898437a817a765dcd539342e710 Binary files /dev/null and b/Code/icons/FILE_NEW.bmp differ diff --git a/Code/icons/FILE_OPEN.bmp b/Code/icons/FILE_OPEN.bmp new file mode 100644 index 0000000000000000000000000000000000000000..25baa29bf17df47237ecd8c79edf7b5dbe9a72d9 Binary files /dev/null and b/Code/icons/FILE_OPEN.bmp differ diff --git a/Code/icons/FILE_SAVE.bmp b/Code/icons/FILE_SAVE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..ddd83208b753f7857165057900284e815e0ef221 Binary files /dev/null and b/Code/icons/FILE_SAVE.bmp differ diff --git a/Code/icons/FLYTO.bmp b/Code/icons/FLYTO.bmp new file mode 100644 index 0000000000000000000000000000000000000000..1c2f9bdf8afb2b1b2b15a44bab17f5dc9938be4d Binary files /dev/null and b/Code/icons/FLYTO.bmp differ diff --git a/Code/icons/INFO.bmp b/Code/icons/INFO.bmp new file mode 100644 index 0000000000000000000000000000000000000000..85956128e33a0f6bf7bc0330503ef8ee598f3457 Binary files /dev/null and b/Code/icons/INFO.bmp differ diff --git a/Code/icons/MOVIE_RECORD.bmp b/Code/icons/MOVIE_RECORD.bmp new file mode 100644 index 0000000000000000000000000000000000000000..3aa0a925c0eaf753d4030f43b30206373d1e0549 Binary files /dev/null and b/Code/icons/MOVIE_RECORD.bmp differ diff --git a/Code/icons/NODE_BLUE.bmp b/Code/icons/NODE_BLUE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..44498e105bf608af9c319c34e83400d564c37b02 Binary files /dev/null and b/Code/icons/NODE_BLUE.bmp differ diff --git a/Code/icons/NODE_GRAY.bmp b/Code/icons/NODE_GRAY.bmp new file mode 100644 index 0000000000000000000000000000000000000000..6cafe9b79e7addb008a554fe0904d64b9a09ed16 Binary files /dev/null and b/Code/icons/NODE_GRAY.bmp differ diff --git a/Code/icons/NODE_RED.bmp b/Code/icons/NODE_RED.bmp new file mode 100644 index 0000000000000000000000000000000000000000..070a08503f54cdb2f435e7bef7956993eccba913 Binary files /dev/null and b/Code/icons/NODE_RED.bmp differ diff --git a/Code/icons/NODE_YELLOW.bmp b/Code/icons/NODE_YELLOW.bmp new file mode 100644 index 0000000000000000000000000000000000000000..7ffb562c31c41f0941252101d36719405bad304e Binary files /dev/null and b/Code/icons/NODE_YELLOW.bmp differ diff --git a/Code/icons/OPAddVector.png b/Code/icons/OPAddVector.png new file mode 100644 index 0000000000000000000000000000000000000000..fc59ef0948a12ab106afd0775b2ab2e5e88a0e92 Binary files /dev/null and b/Code/icons/OPAddVector.png differ diff --git a/Code/icons/OPEN_LOCAL.png b/Code/icons/OPEN_LOCAL.png new file mode 100644 index 0000000000000000000000000000000000000000..7d531f9cca7c4aa311cb7cd6d8c09d17e8fe4187 Binary files /dev/null and b/Code/icons/OPEN_LOCAL.png differ diff --git a/Code/icons/OPEN_REMOTE.png b/Code/icons/OPEN_REMOTE.png new file mode 100644 index 0000000000000000000000000000000000000000..097a3937b69219d743f47a05dfae77684f9a36c7 Binary files /dev/null and b/Code/icons/OPEN_REMOTE.png differ diff --git a/Code/icons/OP_COPY.bmp b/Code/icons/OP_COPY.bmp new file mode 100644 index 0000000000000000000000000000000000000000..8ca09f05a1605609dfaa158cbe8bf76491b8a2d1 Binary files /dev/null and b/Code/icons/OP_COPY.bmp differ diff --git a/Code/icons/OP_CUT.bmp b/Code/icons/OP_CUT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..04ab372862f0652d938fbfc13c4245fdd030d999 Binary files /dev/null and b/Code/icons/OP_CUT.bmp differ diff --git a/Code/icons/OP_MakePlot.png b/Code/icons/OP_MakePlot.png new file mode 100644 index 0000000000000000000000000000000000000000..65079fc09bd6cb76cd810d92d7bbcd1f2262b566 Binary files /dev/null and b/Code/icons/OP_MakePlot.png differ diff --git a/Code/icons/OP_Merger.png b/Code/icons/OP_Merger.png new file mode 100644 index 0000000000000000000000000000000000000000..ebcaa730b528c318ba3c770ce77d9afa1ce5ce94 Binary files /dev/null and b/Code/icons/OP_Merger.png differ diff --git a/Code/icons/OP_PASTE.bmp b/Code/icons/OP_PASTE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..10f5cae64e108c265f6444de33d80b3e554289ec Binary files /dev/null and b/Code/icons/OP_PASTE.bmp differ diff --git a/Code/icons/OP_Parser.png b/Code/icons/OP_Parser.png new file mode 100644 index 0000000000000000000000000000000000000000..f13b5a6086b8746f109afc71580aae26d19aa691 Binary files /dev/null and b/Code/icons/OP_Parser.png differ diff --git a/Code/icons/OP_REDO.bmp b/Code/icons/OP_REDO.bmp new file mode 100644 index 0000000000000000000000000000000000000000..f2e84505e9782b7f8d826f75fda2c8b778bc9699 Binary files /dev/null and b/Code/icons/OP_REDO.bmp differ diff --git a/Code/icons/OP_UNDO.bmp b/Code/icons/OP_UNDO.bmp new file mode 100644 index 0000000000000000000000000000000000000000..9431efd81b06e05e6f46acd6e3f93afdc22b7e80 Binary files /dev/null and b/Code/icons/OP_UNDO.bmp differ diff --git a/Code/icons/PIC_BACK.bmp b/Code/icons/PIC_BACK.bmp new file mode 100644 index 0000000000000000000000000000000000000000..732dfa8f6a5667628e5acf763fb3edbea5d0abb2 Binary files /dev/null and b/Code/icons/PIC_BACK.bmp differ diff --git a/Code/icons/PIC_BOTTOM.bmp b/Code/icons/PIC_BOTTOM.bmp new file mode 100644 index 0000000000000000000000000000000000000000..d9b1d47b736f0bdaeabc2365abb53bc7b409431b Binary files /dev/null and b/Code/icons/PIC_BOTTOM.bmp differ diff --git a/Code/icons/PIC_FRONT.bmp b/Code/icons/PIC_FRONT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..f13d3c622fb79f1d558a671aed1be0e1ce7bc2c9 Binary files /dev/null and b/Code/icons/PIC_FRONT.bmp differ diff --git a/Code/icons/PIC_LEFT.bmp b/Code/icons/PIC_LEFT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..3b41281b55b0a47a1b9a0e265f5b76ce6b1fb942 Binary files /dev/null and b/Code/icons/PIC_LEFT.bmp differ diff --git a/Code/icons/PIC_RIGHT.bmp b/Code/icons/PIC_RIGHT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..9fcbca74f68439733c42f5e6558c81eac212446a Binary files /dev/null and b/Code/icons/PIC_RIGHT.bmp differ diff --git a/Code/icons/PIC_TOP.bmp b/Code/icons/PIC_TOP.bmp new file mode 100644 index 0000000000000000000000000000000000000000..5f590c690ca3d9e773dd8f76de8c9c25ce270667 Binary files /dev/null and b/Code/icons/PIC_TOP.bmp differ diff --git a/Code/icons/PRINT.bmp b/Code/icons/PRINT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..19cf42a415405c197075196745d9455621d6d6d1 Binary files /dev/null and b/Code/icons/PRINT.bmp differ diff --git a/Code/icons/PRINT_PREVIEW.bmp b/Code/icons/PRINT_PREVIEW.bmp new file mode 100644 index 0000000000000000000000000000000000000000..d21f96e87bf79ee7189fbef11689ec050e1fd935 Binary files /dev/null and b/Code/icons/PRINT_PREVIEW.bmp differ diff --git a/Code/icons/RADIO_OFF.bmp b/Code/icons/RADIO_OFF.bmp new file mode 100644 index 0000000000000000000000000000000000000000..4abe8cf57e50486528ed16abcb76b203c5a282ce Binary files /dev/null and b/Code/icons/RADIO_OFF.bmp differ diff --git a/Code/icons/RADIO_ON.bmp b/Code/icons/RADIO_ON.bmp new file mode 100644 index 0000000000000000000000000000000000000000..c4890794a40f18c4c37045978862326873e775d3 Binary files /dev/null and b/Code/icons/RADIO_ON.bmp differ diff --git a/Code/icons/ROLLOUT_CLOSE.bmp b/Code/icons/ROLLOUT_CLOSE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0ab35c79f6524fa7736d69bf8a1a15d2b9d120a5 Binary files /dev/null and b/Code/icons/ROLLOUT_CLOSE.bmp differ diff --git a/Code/icons/ROLLOUT_OPEN.bmp b/Code/icons/ROLLOUT_OPEN.bmp new file mode 100644 index 0000000000000000000000000000000000000000..843f233e2ac4be30f752e65102195ecb63ba4a17 Binary files /dev/null and b/Code/icons/ROLLOUT_OPEN.bmp differ diff --git a/Code/icons/TIME_BEGIN.bmp b/Code/icons/TIME_BEGIN.bmp new file mode 100644 index 0000000000000000000000000000000000000000..6c7270344ec273fc6b93c31ece367941c35f311c Binary files /dev/null and b/Code/icons/TIME_BEGIN.bmp differ diff --git a/Code/icons/TIME_END.bmp b/Code/icons/TIME_END.bmp new file mode 100644 index 0000000000000000000000000000000000000000..55d8382202b09ca7fdd9c42310dbc9c1d53da0d2 Binary files /dev/null and b/Code/icons/TIME_END.bmp differ diff --git a/Code/icons/TIME_NEXT.bmp b/Code/icons/TIME_NEXT.bmp new file mode 100644 index 0000000000000000000000000000000000000000..54ad4c41d93b5baac5ff648a3c38e02a3c6e1291 Binary files /dev/null and b/Code/icons/TIME_NEXT.bmp differ diff --git a/Code/icons/TIME_PLAY.bmp b/Code/icons/TIME_PLAY.bmp new file mode 100644 index 0000000000000000000000000000000000000000..67d0f2c9613908ce8402e172427f25d86a69ea3f Binary files /dev/null and b/Code/icons/TIME_PLAY.bmp differ diff --git a/Code/icons/TIME_PREV.bmp b/Code/icons/TIME_PREV.bmp new file mode 100644 index 0000000000000000000000000000000000000000..422d27c7017d43862c8aec58427395b88a21414f Binary files /dev/null and b/Code/icons/TIME_PREV.bmp differ diff --git a/Code/icons/TIME_STOP.bmp b/Code/icons/TIME_STOP.bmp new file mode 100644 index 0000000000000000000000000000000000000000..7d504edf208f1329f0f07109a8a797a1fdab862c Binary files /dev/null and b/Code/icons/TIME_STOP.bmp differ diff --git a/Code/icons/VBT_CLOUD.bmp b/Code/icons/VBT_CLOUD.bmp new file mode 100644 index 0000000000000000000000000000000000000000..9c812170e4de38752c430716cde81125d42420f2 Binary files /dev/null and b/Code/icons/VBT_CLOUD.bmp differ diff --git a/Code/icons/VBT_Table.bmp b/Code/icons/VBT_Table.bmp new file mode 100644 index 0000000000000000000000000000000000000000..6bee44e26be46b0c4c403f442ba42226a4357736 Binary files /dev/null and b/Code/icons/VBT_Table.bmp differ diff --git a/Code/icons/VBT_Volume.bmp b/Code/icons/VBT_Volume.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0d832a990cc3c194743558c0c42374f978397fd2 Binary files /dev/null and b/Code/icons/VBT_Volume.bmp differ diff --git a/Code/icons/VME_FEM.bmp b/Code/icons/VME_FEM.bmp new file mode 100644 index 0000000000000000000000000000000000000000..8366b5bf00801c351c3d605f89c400c738c70a77 Binary files /dev/null and b/Code/icons/VME_FEM.bmp differ diff --git a/Code/icons/VME_IMAGE.bmp b/Code/icons/VME_IMAGE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..11e61bc79a414c851c459cd2732ec0dc195da6dd Binary files /dev/null and b/Code/icons/VME_IMAGE.bmp differ diff --git a/Code/icons/VME_LANDMARK.bmp b/Code/icons/VME_LANDMARK.bmp new file mode 100644 index 0000000000000000000000000000000000000000..8553c4d29bff7c7e82032736d17b3865bbd6f8eb Binary files /dev/null and b/Code/icons/VME_LANDMARK.bmp differ diff --git a/Code/icons/VME_SURFACE.bmp b/Code/icons/VME_SURFACE.bmp new file mode 100644 index 0000000000000000000000000000000000000000..c6b63caa295d203b73771dc97081b6d6512711e2 Binary files /dev/null and b/Code/icons/VME_SURFACE.bmp differ diff --git a/Code/icons/VME_VOLUME.bmp b/Code/icons/VME_VOLUME.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2b595cb4705add9bf06c5ecb7c77f27d4607fb68 Binary files /dev/null and b/Code/icons/VME_VOLUME.bmp differ diff --git a/Code/icons/VisIVODesktop.icns b/Code/icons/VisIVODesktop.icns new file mode 100644 index 0000000000000000000000000000000000000000..f97b15c68669a362f48fc92ca99739aa56d04c52 Binary files /dev/null and b/Code/icons/VisIVODesktop.icns differ diff --git a/Code/icons/ZOOM.bmp b/Code/icons/ZOOM.bmp new file mode 100644 index 0000000000000000000000000000000000000000..f3fe21cf4bcea102bb5f065a3b6f38392c214e1a Binary files /dev/null and b/Code/icons/ZOOM.bmp differ diff --git a/Code/icons/ZOOM_ALL.bmp b/Code/icons/ZOOM_ALL.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2f05fca348522a517c58583583df398aaafe1cfb Binary files /dev/null and b/Code/icons/ZOOM_ALL.bmp differ diff --git a/Code/icons/ZOOM_SEL.bmp b/Code/icons/ZOOM_SEL.bmp new file mode 100644 index 0000000000000000000000000000000000000000..bcc0a92734adc468ffcf45ded75d00e42b074954 Binary files /dev/null and b/Code/icons/ZOOM_SEL.bmp differ diff --git a/Code/icons/colorize.png b/Code/icons/colorize.png new file mode 100644 index 0000000000000000000000000000000000000000..72f18df87e212a0b2da34a6b2b25fa89acc42b4d Binary files /dev/null and b/Code/icons/colorize.png differ diff --git a/Code/icons/ellipse-select.png b/Code/icons/ellipse-select.png new file mode 100644 index 0000000000000000000000000000000000000000..2575584c95e6539736043a35471055ccff544944 Binary files /dev/null and b/Code/icons/ellipse-select.png differ diff --git a/Code/icons/filter.png b/Code/icons/filter.png new file mode 100644 index 0000000000000000000000000000000000000000..f724b68b22376f1dfbeccabea6e3349192511da3 Binary files /dev/null and b/Code/icons/filter.png differ diff --git a/Code/icons/logo3b_vl.jpg b/Code/icons/logo3b_vl.jpg new file mode 100644 index 0000000000000000000000000000000000000000..da054efd443905b76edb9a71e8cfb5798d19d78b Binary files /dev/null and b/Code/icons/logo3b_vl.jpg differ diff --git a/Code/icons/mafVMEVector.bmp b/Code/icons/mafVMEVector.bmp new file mode 100644 index 0000000000000000000000000000000000000000..68bccefc578289229f947de15fd9f9bef2e8e790 Binary files /dev/null and b/Code/icons/mafVMEVector.bmp differ diff --git a/Code/icons/rect-select.png b/Code/icons/rect-select.png new file mode 100644 index 0000000000000000000000000000000000000000..866b602a89b6afd40aff72016d9a34e21ba66b0e Binary files /dev/null and b/Code/icons/rect-select.png differ diff --git a/Code/icons/visivo.png b/Code/icons/visivo.png new file mode 100644 index 0000000000000000000000000000000000000000..552d7e3e17c132b4985acd2c4d5a71fab51d7159 Binary files /dev/null and b/Code/icons/visivo.png differ diff --git a/Code/images/splash.png b/Code/images/splash.png new file mode 100644 index 0000000000000000000000000000000000000000..75b3e982866f6b06a834c4e506d99641a4449d60 Binary files /dev/null and b/Code/images/splash.png differ diff --git a/Code/lib/.DS_Store b/Code/lib/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..5008ddfcf53c02e82d7eee2e57c38e5672ef89f6 Binary files /dev/null and b/Code/lib/.DS_Store differ diff --git a/Code/lib/libVO.a b/Code/lib/libVO.a new file mode 100644 index 0000000000000000000000000000000000000000..019a31294fe9b229a223e6804d01b183482bef58 Binary files /dev/null and b/Code/lib/libVO.a differ diff --git a/Code/lib/libVOApps.a b/Code/lib/libVOApps.a new file mode 100644 index 0000000000000000000000000000000000000000..44a7e6d66d27537229ca3930941446445404cd01 Binary files /dev/null and b/Code/lib/libVOApps.a differ diff --git a/Code/lib/libVOClient.a b/Code/lib/libVOClient.a new file mode 100644 index 0000000000000000000000000000000000000000..a2cd11104a3e02359861ddccd1cc3a5730a3e601 Binary files /dev/null and b/Code/lib/libVOClient.a differ diff --git a/Code/lib/libVOTable.a b/Code/lib/libVOTable.a new file mode 100644 index 0000000000000000000000000000000000000000..7d84812d0bc1a3194f21c6798deee4f3ebfefbdd Binary files /dev/null and b/Code/lib/libVOTable.a differ diff --git a/Code/lib/libcfitsio.a b/Code/lib/libcfitsio.a new file mode 100644 index 0000000000000000000000000000000000000000..23bd7579ac54a1712a39a765d69a5ea77b004d6c Binary files /dev/null and b/Code/lib/libcfitsio.a differ diff --git a/Code/lib/libcurl.a b/Code/lib/libcurl.a new file mode 100644 index 0000000000000000000000000000000000000000..9a6daffbeb768f402568f79f9c2e031c0830a76a Binary files /dev/null and b/Code/lib/libcurl.a differ diff --git a/Code/lib/libexpat.a b/Code/lib/libexpat.a new file mode 100644 index 0000000000000000000000000000000000000000..61bfad4b2d843e48109f49b7187d91276b99a891 Binary files /dev/null and b/Code/lib/libexpat.a differ diff --git a/Code/lib/libsamp.a b/Code/lib/libsamp.a new file mode 100644 index 0000000000000000000000000000000000000000..274d66caa7f4dfa6151de73afeb7d4d0d63d9f3c Binary files /dev/null and b/Code/lib/libsamp.a differ diff --git a/Code/logo.icns b/Code/logo.icns new file mode 100644 index 0000000000000000000000000000000000000000..6d26a11c023271a009d36cd82e4dddf99c9ff778 Binary files /dev/null and b/Code/logo.icns differ diff --git a/Code/script_idl_mv/.DS_Store b/Code/script_idl_mv/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..1097fa5c6b6ea8ca8b3cc1039c6baa4eff2ce550 Binary files /dev/null and b/Code/script_idl_mv/.DS_Store differ diff --git a/Code/script_idl_mv/astrolib/.idlwave_catalog b/Code/script_idl_mv/astrolib/.idlwave_catalog new file mode 100644 index 0000000000000000000000000000000000000000..55907894aace370a30440f0e90f41a58851fb422 --- /dev/null +++ b/Code/script_idl_mv/astrolib/.idlwave_catalog @@ -0,0 +1,583 @@ +;; +;; IDLWAVE catalog for library Astrolib +;; Automatically Generated -- do not edit. +;; Created by idlwave_catalog on Wed May 25 13:21:39 2016 +;; +(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") ("MISSING") ("NOCONTINUE") ("NOLOGICAL") ("NULL"))) + ("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") ("MISSING") ("NAN") ("NOCONTINUE") ("NULL") ("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") ("TOTAL"))) + ("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)) + ("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(In_String, OldChar, NewChar)" (nil)) + ("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") ("missing") ("null") ("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") ("IFound") ("MISSING") ("NAN") ("NoContinue") ("NULL") ("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)) + ("file_launch" pro nil (lib "file_launch.pro" nil "Astrolib") "%s, file" (nil ("bUseJava") ("Nowait") ("ojDesktop") ("quiet"))) + ("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/Code/script_idl_mv/astrolib/ad2xy.pro b/Code/script_idl_mv/astrolib/ad2xy.pro new file mode 100644 index 0000000000000000000000000000000000000000..ef148b0c390e238c3c4843d4c09bce4c957a32bb --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/add_distort.pro b/Code/script_idl_mv/astrolib/add_distort.pro new file mode 100644 index 0000000000000000000000000000000000000000..ca871fddb88e5a93bb3eecf4e80611d7fae716bc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/adstring.pro b/Code/script_idl_mv/astrolib/adstring.pro new file mode 100644 index 0000000000000000000000000000000000000000..3e0ba1332ea861078cea8b845d7714053ef302db --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/adxy.pro b/Code/script_idl_mv/astrolib/adxy.pro new file mode 100644 index 0000000000000000000000000000000000000000..736a772d934ce31e155988ff57b4ce22c93b922b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/airtovac.pro b/Code/script_idl_mv/astrolib/airtovac.pro new file mode 100644 index 0000000000000000000000000000000000000000..1cbdd01d0f443f0970928ce0b08d6d0cf98ac40e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/aitoff.pro b/Code/script_idl_mv/astrolib/aitoff.pro new file mode 100644 index 0000000000000000000000000000000000000000..6e7fbee43321e80eab083cc72b7915d3670001d5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/aitoff_grid.pro b/Code/script_idl_mv/astrolib/aitoff_grid.pro new file mode 100644 index 0000000000000000000000000000000000000000..62e45f91499c2de56cf260567d2d2ae0b71f8e5e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/al_legend.pro b/Code/script_idl_mv/astrolib/al_legend.pro new file mode 100644 index 0000000000000000000000000000000000000000..74c02f60e5f167b61d8163a5cadfcff9b5b549ae --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/al_legendtest.pro b/Code/script_idl_mv/astrolib/al_legendtest.pro new file mode 100644 index 0000000000000000000000000000000000000000..55e33be9fedd4d5f03659a82533e858c81914095 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/altaz2hadec.pro b/Code/script_idl_mv/astrolib/altaz2hadec.pro new file mode 100644 index 0000000000000000000000000000000000000000..96d543b33baedc546e9f2ea80f05d6f3503984fa --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/aper.pro b/Code/script_idl_mv/astrolib/aper.pro new file mode 100644 index 0000000000000000000000000000000000000000..940bb0cf0a97d91d5ad986949a0f3a509433cb8b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/arcbar.pro b/Code/script_idl_mv/astrolib/arcbar.pro new file mode 100644 index 0000000000000000000000000000000000000000..b331d29c44f576baeb412474ccf922230956169f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/arrows.pro b/Code/script_idl_mv/astrolib/arrows.pro new file mode 100644 index 0000000000000000000000000000000000000000..f1c785420831bfaaac74552794cb0cef3b44a130 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/asinh.pro b/Code/script_idl_mv/astrolib/asinh.pro new file mode 100644 index 0000000000000000000000000000000000000000..0083d4645276de605bfea43f59ad3ed181ccade6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/astdisp.pro b/Code/script_idl_mv/astrolib/astdisp.pro new file mode 100644 index 0000000000000000000000000000000000000000..1521c0585e739e3b8f2aca963bf3220bb4313315 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/astro.pro b/Code/script_idl_mv/astrolib/astro.pro new file mode 100644 index 0000000000000000000000000000000000000000..994a68d1079e99119a7be017b383492109c075bc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/astrolib.pro b/Code/script_idl_mv/astrolib/astrolib.pro new file mode 100644 index 0000000000000000000000000000000000000000..99d61f92e72880d13af85c8f6b922d8a40a3f63e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/autohist.pro b/Code/script_idl_mv/astrolib/autohist.pro new file mode 100644 index 0000000000000000000000000000000000000000..66bff440abc69fd2804aec7b8f404aaf80fa1ece --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/avg.pro b/Code/script_idl_mv/astrolib/avg.pro new file mode 100644 index 0000000000000000000000000000000000000000..8f1a242d64891ea858b7861f925248ca7d29a6e7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/baryvel.pro b/Code/script_idl_mv/astrolib/baryvel.pro new file mode 100644 index 0000000000000000000000000000000000000000..132532e044b02788cb93dc77cb453a69bca01fcc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/biweight_mean.pro b/Code/script_idl_mv/astrolib/biweight_mean.pro new file mode 100644 index 0000000000000000000000000000000000000000..2ecd438b16a90b12ae9b28890e3f08b4298b7724 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/blink.pro b/Code/script_idl_mv/astrolib/blink.pro new file mode 100644 index 0000000000000000000000000000000000000000..0fd34c24b7b893db5937b449878c1a59168a049e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/blkshift.pro b/Code/script_idl_mv/astrolib/blkshift.pro new file mode 100644 index 0000000000000000000000000000000000000000..faa8234c0d47e508478bf73868ffc83ed496ad49 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/boost_array.pro b/Code/script_idl_mv/astrolib/boost_array.pro new file mode 100644 index 0000000000000000000000000000000000000000..d12290335d43bf20ef58de28d32267b6c64e117d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/boxave.pro b/Code/script_idl_mv/astrolib/boxave.pro new file mode 100644 index 0000000000000000000000000000000000000000..899de45a515a0d98aba165b1735abe2d17d584b6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/bprecess.pro b/Code/script_idl_mv/astrolib/bprecess.pro new file mode 100644 index 0000000000000000000000000000000000000000..cf812a62a2db89ad8d18ddae67a347d7748d28ca --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/break_path.pro b/Code/script_idl_mv/astrolib/break_path.pro new file mode 100644 index 0000000000000000000000000000000000000000..703c381a6ec31ae5d2263836870fa5f490f52d3a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/bsort.pro b/Code/script_idl_mv/astrolib/bsort.pro new file mode 100644 index 0000000000000000000000000000000000000000..b420f0a1c2f43f8dd642e6538df979e36421ab3e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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://idldatapoint.com/2012/04/19/an-lsd-radix-sort-algorithm-in-idl/ +; 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/Code/script_idl_mv/astrolib/calz_unred.pro b/Code/script_idl_mv/astrolib/calz_unred.pro new file mode 100644 index 0000000000000000000000000000000000000000..de407895da29eb563ebab20e2b49d0a3e9e37615 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ccm_unred.pro b/Code/script_idl_mv/astrolib/ccm_unred.pro new file mode 100644 index 0000000000000000000000000000000000000000..7aacc109c24ff300fe275f52be9ad62c74d64e1b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/check_fits.pro b/Code/script_idl_mv/astrolib/check_fits.pro new file mode 100644 index 0000000000000000000000000000000000000000..000bffa2545abc7ea33875483918444766bbee46 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 INTEGER*2, 3 for INTEGER*4, 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/Code/script_idl_mv/astrolib/checksum32.pro b/Code/script_idl_mv/astrolib/checksum32.pro new file mode 100644 index 0000000000000000000000000000000000000000..2e23c540a26fc3080ebe540547ae4a4df0063cb8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/checksum32.pro @@ -0,0 +1,125 @@ +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 +; +; Could probably be done in a cleverer way (similar to the C +; implementation) but then the array-oriented TOTAL() function could not +; be used. +; 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/Code/script_idl_mv/astrolib/cic.pro b/Code/script_idl_mv/astrolib/cic.pro new file mode 100644 index 0000000000000000000000000000000000000000..b1ff45bf3ad6dd0c11bb45c3d963c95d21bb7e08 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cirrange.pro b/Code/script_idl_mv/astrolib/cirrange.pro new file mode 100644 index 0000000000000000000000000000000000000000..e2044059969e50d36fe534a8b362b87d30db108b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cleanplot.pro b/Code/script_idl_mv/astrolib/cleanplot.pro new file mode 100644 index 0000000000000000000000000000000000000000..abcd1b11b7b929ea3f39ff32d4e331396d6e039a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cntrd.pro b/Code/script_idl_mv/astrolib/cntrd.pro new file mode 100644 index 0000000000000000000000000000000000000000..04ceb814673d3010cb26871c0ff61c278fd0ab75 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/co_aberration.pro b/Code/script_idl_mv/astrolib/co_aberration.pro new file mode 100644 index 0000000000000000000000000000000000000000..e1ea5e39070e9f23985e3b482312c6ad7ef16638 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/co_nutate.pro b/Code/script_idl_mv/astrolib/co_nutate.pro new file mode 100644 index 0000000000000000000000000000000000000000..4371a7a65351604a832dece6d38defd943f75a84 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/co_refract.pro b/Code/script_idl_mv/astrolib/co_refract.pro new file mode 100644 index 0000000000000000000000000000000000000000..ec95de65e1f579b02ebc1f53ad5a9f0a3fdd456b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/compare_struct.pro b/Code/script_idl_mv/astrolib/compare_struct.pro new file mode 100644 index 0000000000000000000000000000000000000000..aa497e3601d9dd5791e9ef70b30da88da34659fd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/concat_dir.pro b/Code/script_idl_mv/astrolib/concat_dir.pro new file mode 100644 index 0000000000000000000000000000000000000000..a89656a9edce565ad24616fb2f55e775c7cad1b8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cons_dec.pro b/Code/script_idl_mv/astrolib/cons_dec.pro new file mode 100644 index 0000000000000000000000000000000000000000..414a9e18f5de78b8679bc42e5a5090a225f5ab96 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cons_ra.pro b/Code/script_idl_mv/astrolib/cons_ra.pro new file mode 100644 index 0000000000000000000000000000000000000000..c90fcb097d9808c8a6fdd7538b251b17f1438547 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/convolve.pro b/Code/script_idl_mv/astrolib/convolve.pro new file mode 100644 index 0000000000000000000000000000000000000000..f56e016a738b30892db4d4ee9b177903675baacc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/copy_struct.pro b/Code/script_idl_mv/astrolib/copy_struct.pro new file mode 100644 index 0000000000000000000000000000000000000000..147fc0da185a4665e9964b1a413c86963d884ad0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/copy_struct_inx.pro b/Code/script_idl_mv/astrolib/copy_struct_inx.pro new file mode 100644 index 0000000000000000000000000000000000000000..c162bb41f8ba41cdac069faf7c54588099063d14 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/correl_images.pro b/Code/script_idl_mv/astrolib/correl_images.pro new file mode 100644 index 0000000000000000000000000000000000000000..de9aaa2009d4c112ca94e9224f29405c2e7e1691 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/correl_optimize.pro b/Code/script_idl_mv/astrolib/correl_optimize.pro new file mode 100644 index 0000000000000000000000000000000000000000..71c93951cf5bbbd60908288aac6b470f667d2e09 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/corrmat_analyze.pro b/Code/script_idl_mv/astrolib/corrmat_analyze.pro new file mode 100644 index 0000000000000000000000000000000000000000..26af51caa7fc9b7fab8420c9dffea8001ecb1a69 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cosmo_param.pro b/Code/script_idl_mv/astrolib/cosmo_param.pro new file mode 100644 index 0000000000000000000000000000000000000000..4472c9de9dcaf235c632056c3c74658caac90a47 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cr_reject.pro b/Code/script_idl_mv/astrolib/cr_reject.pro new file mode 100644 index 0000000000000000000000000000000000000000..ec0e3159dd97133812383deba8760ff21d1e1f4c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/create_struct.pro b/Code/script_idl_mv/astrolib/create_struct.pro new file mode 100644 index 0000000000000000000000000000000000000000..602dacb6a2758695a3848a5fc9e4f5ce9b582fe7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/cspline.pro b/Code/script_idl_mv/astrolib/cspline.pro new file mode 100644 index 0000000000000000000000000000000000000000..7dede40e206aa4ca965e58288db1971576f28591 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ct2lst.pro b/Code/script_idl_mv/astrolib/ct2lst.pro new file mode 100644 index 0000000000000000000000000000000000000000..2244ce8b929d01a529406061b17c0d73be55343e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/curs.pro b/Code/script_idl_mv/astrolib/curs.pro new file mode 100644 index 0000000000000000000000000000000000000000..c6282e556311479431b95948912f42eccd4e7389 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/curval.pro b/Code/script_idl_mv/astrolib/curval.pro new file mode 100644 index 0000000000000000000000000000000000000000..7dd13ba7abce9da084ef58083b5747b40c7571f2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dao_value.pro b/Code/script_idl_mv/astrolib/dao_value.pro new file mode 100644 index 0000000000000000000000000000000000000000..2aaa4aa4d528ebc794c070326eae11c3e65c9078 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/daoerf.pro b/Code/script_idl_mv/astrolib/daoerf.pro new file mode 100644 index 0000000000000000000000000000000000000000..f1451e6948d58734717e4eaa84b46fe7153179e5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/date.pro b/Code/script_idl_mv/astrolib/date.pro new file mode 100644 index 0000000000000000000000000000000000000000..2abd07f68f248324e96c5a53e7cd88883941ef49 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/date_conv.pro b/Code/script_idl_mv/astrolib/date_conv.pro new file mode 100644 index 0000000000000000000000000000000000000000..e34a46d70031c7c59fb167f697bd5d2fb546bbc1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/daycnv.pro b/Code/script_idl_mv/astrolib/daycnv.pro new file mode 100644 index 0000000000000000000000000000000000000000..d0f79583ace4f5a20c7c11728e23fa14f711c004 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_ent2ext.pro b/Code/script_idl_mv/astrolib/db_ent2ext.pro new file mode 100644 index 0000000000000000000000000000000000000000..987424df45a24fb687a0d1294e0d39dac0c26559 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_ent2host.pro b/Code/script_idl_mv/astrolib/db_ent2host.pro new file mode 100644 index 0000000000000000000000000000000000000000..522495028b2a18239b62381550bd3becce0bb566 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_info.pro b/Code/script_idl_mv/astrolib/db_info.pro new file mode 100644 index 0000000000000000000000000000000000000000..77d0dd88991a5b26c3b4c65e065391486ccd7785 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_item.pro b/Code/script_idl_mv/astrolib/db_item.pro new file mode 100644 index 0000000000000000000000000000000000000000..626dc071568f4b3687f94edd5bae10999433dc21 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_item_info.pro b/Code/script_idl_mv/astrolib/db_item_info.pro new file mode 100644 index 0000000000000000000000000000000000000000..1dfa2b7edf007ca9863cb353c3c83efce474cf6c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_or.pro b/Code/script_idl_mv/astrolib/db_or.pro new file mode 100644 index 0000000000000000000000000000000000000000..cb6cd105c21b06b7260f2ad5938d5affba242c2d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/db_titles.pro b/Code/script_idl_mv/astrolib/db_titles.pro new file mode 100644 index 0000000000000000000000000000000000000000..3cb8389ab1dcde63b84e8fc70b65f5fc93308b8d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbbuild.pro b/Code/script_idl_mv/astrolib/dbbuild.pro new file mode 100644 index 0000000000000000000000000000000000000000..58b78d11965365175840d7c2557d465aafd04cbe --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbcircle.pro b/Code/script_idl_mv/astrolib/dbcircle.pro new file mode 100644 index 0000000000000000000000000000000000000000..8c5a44b031c77f653f5bb49235e065bfd72fd72d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbdelete.pro b/Code/script_idl_mv/astrolib/dbdelete.pro new file mode 100644 index 0000000000000000000000000000000000000000..f145b0b18243208278a00b48470c48bc4eef8516 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbedit.pro b/Code/script_idl_mv/astrolib/dbedit.pro new file mode 100644 index 0000000000000000000000000000000000000000..1f439fd2354f0c9ba0710de349bf6ad03c32cccd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbedit_basic.pro b/Code/script_idl_mv/astrolib/dbedit_basic.pro new file mode 100644 index 0000000000000000000000000000000000000000..d934c87f8736fcdd5307ac12addb2112ba82e93f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbext.pro b/Code/script_idl_mv/astrolib/dbext.pro new file mode 100644 index 0000000000000000000000000000000000000000..28250cf561a29bc4cbad2bf3cb3e8b343ec09756 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbext_dbf.pro b/Code/script_idl_mv/astrolib/dbext_dbf.pro new file mode 100644 index 0000000000000000000000000000000000000000..d56cadeac51ed8d58c993a0026b4ef786e0dfcb8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbext_ind.pro b/Code/script_idl_mv/astrolib/dbext_ind.pro new file mode 100644 index 0000000000000000000000000000000000000000..a9466e70af9ca788046b9b5e0b4efaff881915a8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbfind.pro b/Code/script_idl_mv/astrolib/dbfind.pro new file mode 100644 index 0000000000000000000000000000000000000000..f2bc14469e06fa96d54f1d86595f7f1f69b1f0ec --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbfind_entry.pro b/Code/script_idl_mv/astrolib/dbfind_entry.pro new file mode 100644 index 0000000000000000000000000000000000000000..f15fdbd00f19e5afd74958b50347fc4506039e7a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbfparse.pro b/Code/script_idl_mv/astrolib/dbfparse.pro new file mode 100644 index 0000000000000000000000000000000000000000..0218c20d93b7430bfaec16d7ded5ea6fe5e52ba4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbhelp.pro b/Code/script_idl_mv/astrolib/dbhelp.pro new file mode 100644 index 0000000000000000000000000000000000000000..e2bb8b5ab4bccef95f6f7674b253d62645c175fd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbindex.pro b/Code/script_idl_mv/astrolib/dbindex.pro new file mode 100644 index 0000000000000000000000000000000000000000..8359e9bba586b2519e9b31fc59ab804cdb12863b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbindex_blk.pro b/Code/script_idl_mv/astrolib/dbindex_blk.pro new file mode 100644 index 0000000000000000000000000000000000000000..7048570264a1cbc554a522983f5fe1403ecc25b7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbmatch.pro b/Code/script_idl_mv/astrolib/dbmatch.pro new file mode 100644 index 0000000000000000000000000000000000000000..e733a5e518714c2719df05dfaadcac291582daa8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbopen.pro b/Code/script_idl_mv/astrolib/dbopen.pro new file mode 100644 index 0000000000000000000000000000000000000000..2b10da69a1beb2f6de40550eab8caf670e482bfc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbprint.pro b/Code/script_idl_mv/astrolib/dbprint.pro new file mode 100644 index 0000000000000000000000000000000000000000..6229081b4819d44168800284f9fa31fbacf5f150 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbput.pro b/Code/script_idl_mv/astrolib/dbput.pro new file mode 100644 index 0000000000000000000000000000000000000000..9dfe5d21c767d4e026275490a1b8985a15c5b667 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbrd.pro b/Code/script_idl_mv/astrolib/dbrd.pro new file mode 100644 index 0000000000000000000000000000000000000000..0697ddd5bda20d40011e0889cdaf5ef5d8866320 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbsearch.pro b/Code/script_idl_mv/astrolib/dbsearch.pro new file mode 100644 index 0000000000000000000000000000000000000000..4c955e85ae59959234a204c0d7bd6a8baeb46c3f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbtarget.pro b/Code/script_idl_mv/astrolib/dbtarget.pro new file mode 100644 index 0000000000000000000000000000000000000000..8c7f8f8e6ad52a0fea225c22943bd8cdbcb28685 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbtitle.pro b/Code/script_idl_mv/astrolib/dbtitle.pro new file mode 100644 index 0000000000000000000000000000000000000000..18232b9ffb23cda701d8b04930d3feae65d55b4c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbupdate.pro b/Code/script_idl_mv/astrolib/dbupdate.pro new file mode 100644 index 0000000000000000000000000000000000000000..73d252e7f31b3d480d80fcdeb9e971ef48e7cc66 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbval.pro b/Code/script_idl_mv/astrolib/dbval.pro new file mode 100644 index 0000000000000000000000000000000000000000..747f2142dd25f9315bb3f94a9c3acbeeb0db1aca --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbwrt.pro b/Code/script_idl_mv/astrolib/dbwrt.pro new file mode 100644 index 0000000000000000000000000000000000000000..34f39f4d0aa2cf316e9bd3dce8d953ad119a9263 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbxput.pro b/Code/script_idl_mv/astrolib/dbxput.pro new file mode 100644 index 0000000000000000000000000000000000000000..5de3f6c19edad9a6a6a19cc8cdc0a2d161e320e7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dbxval.pro b/Code/script_idl_mv/astrolib/dbxval.pro new file mode 100644 index 0000000000000000000000000000000000000000..4b0693dfc4dadefc2d4cf67faf69623a91c10c4f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/delvarx.pro b/Code/script_idl_mv/astrolib/delvarx.pro new file mode 100644 index 0000000000000000000000000000000000000000..c7565058111c2700755db4c8dc86075219f7aa96 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/deredd.pro b/Code/script_idl_mv/astrolib/deredd.pro new file mode 100644 index 0000000000000000000000000000000000000000..880f0d4256f631b775bf7e718e7d60954049635c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/detabify.pro b/Code/script_idl_mv/astrolib/detabify.pro new file mode 100644 index 0000000000000000000000000000000000000000..c57f7c698568535a25b2699ab6c9e0c48db83a3b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dist_circle.pro b/Code/script_idl_mv/astrolib/dist_circle.pro new file mode 100644 index 0000000000000000000000000000000000000000..a5457bfdaa32f87dda0d94a0f7ca5e3e4090a38e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/dist_ellipse.pro b/Code/script_idl_mv/astrolib/dist_ellipse.pro new file mode 100644 index 0000000000000000000000000000000000000000..0e23c31fb22906a6d59890f6e635de55a38766be --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/eci2geo.pro b/Code/script_idl_mv/astrolib/eci2geo.pro new file mode 100644 index 0000000000000000000000000000000000000000..c39625ec71094c4e56ea98062b66e61994afb4d8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/eq2hor.pro b/Code/script_idl_mv/astrolib/eq2hor.pro new file mode 100644 index 0000000000000000000000000000000000000000..fdb8bf3950c3ea10926ec86c93803967cbc4a2f5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/eqpole.pro b/Code/script_idl_mv/astrolib/eqpole.pro new file mode 100644 index 0000000000000000000000000000000000000000..e81654c69d9b57d69c9b1a289b1050a702c50238 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/eqpole_grid.pro b/Code/script_idl_mv/astrolib/eqpole_grid.pro new file mode 100644 index 0000000000000000000000000000000000000000..f400d174ff3f2f986edb76e9dc4c2c8d2ce141b5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/euler.pro b/Code/script_idl_mv/astrolib/euler.pro new file mode 100644 index 0000000000000000000000000000000000000000..9ab363d05f68a10db833ab1bf7f0a4db46340a1c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/expand_tilde.pro b/Code/script_idl_mv/astrolib/expand_tilde.pro new file mode 100644 index 0000000000000000000000000000000000000000..728bee66f14969344ec25ddfb93e0e5a8bf1eed7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/extast.pro b/Code/script_idl_mv/astrolib/extast.pro new file mode 100644 index 0000000000000000000000000000000000000000..b6ba118f9c58fc27087d6195dd7513fa6f0faf44 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/extgrp.pro b/Code/script_idl_mv/astrolib/extgrp.pro new file mode 100644 index 0000000000000000000000000000000000000000..0764cefefc43ddf5f2e6345c046cdfdc59c60081 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/f_format.pro b/Code/script_idl_mv/astrolib/f_format.pro new file mode 100644 index 0000000000000000000000000000000000000000..ba7814d8d0976cfd35941d9da311a12b14ccff5d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/factor.pro b/Code/script_idl_mv/astrolib/factor.pro new file mode 100644 index 0000000000000000000000000000000000000000..683932bdc56c46c2b3b56e7d506874a4a85f0841 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/file_launch.pro b/Code/script_idl_mv/astrolib/file_launch.pro new file mode 100644 index 0000000000000000000000000000000000000000..3cf2677c235db649d5f44ab8aa626caa498fb312 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/filter_image.pro b/Code/script_idl_mv/astrolib/filter_image.pro new file mode 100644 index 0000000000000000000000000000000000000000..22e9c56b6e1a99e9125ee5411a7f9739aa532641 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/find.pro b/Code/script_idl_mv/astrolib/find.pro new file mode 100644 index 0000000000000000000000000000000000000000..f1ed8d14e278d7e01b6214dbe5f05c6370024787 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/find_all_dir.pro b/Code/script_idl_mv/astrolib/find_all_dir.pro new file mode 100644 index 0000000000000000000000000000000000000000..61ce95878f140670f3cf8f124bf4eeb0ae0a6c08 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/find_with_def.pro b/Code/script_idl_mv/astrolib/find_with_def.pro new file mode 100644 index 0000000000000000000000000000000000000000..1fa4ade0328f90792f2146c821d4a973e072f825 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/findpro.pro b/Code/script_idl_mv/astrolib/findpro.pro new file mode 100644 index 0000000000000000000000000000000000000000..7f00a89647086f9064d0e511a3ac2825170e3a67 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fitexy.pro b/Code/script_idl_mv/astrolib/fitexy.pro new file mode 100644 index 0000000000000000000000000000000000000000..5acf3127654b17b258ed6af112690bd1f5a33115 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_add_checksum.pro b/Code/script_idl_mv/astrolib/fits_add_checksum.pro new file mode 100644 index 0000000000000000000000000000000000000000..71492c776ee6669228e87613da9f2d751cf339ba --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_ascii_encode.pro b/Code/script_idl_mv/astrolib/fits_ascii_encode.pro new file mode 100644 index 0000000000000000000000000000000000000000..1fbb628c91264b4a04565226faf7c2850bbf7489 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_cd_fix.pro b/Code/script_idl_mv/astrolib/fits_cd_fix.pro new file mode 100644 index 0000000000000000000000000000000000000000..40a5219a71555cdaba3045e86165fea85c64ac39 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_close.pro b/Code/script_idl_mv/astrolib/fits_close.pro new file mode 100644 index 0000000000000000000000000000000000000000..627f4a12a25482773626d50d220bb7bbafea3376 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_help.pro b/Code/script_idl_mv/astrolib/fits_help.pro new file mode 100644 index 0000000000000000000000000000000000000000..8bd193357747895bf8599f0ac7066621c623690f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_info.pro b/Code/script_idl_mv/astrolib/fits_info.pro new file mode 100644 index 0000000000000000000000000000000000000000..c0746d4472b14697848ce728cb825903eae0145d --- /dev/null +++ b/Code/script_idl_mv/astrolib/fits_info.pro @@ -0,0 +1,348 @@ +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 +; Replaced 2880 with 2880LL to work on very large files EH Mar 2015 +;- + 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 += 2880LL + 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 ; Integer*2 + 32: IDL_type = 3 ; Integer*4 + -32: IDL_type = 4 ; Real*4 + -64: IDL_type = 5 ; Real*8 + 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 + 2880LL + 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*2880LL + if compress[nf] then mrd_skip,lun1,nrec*2880LL 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/Code/script_idl_mv/astrolib/fits_open.pro b/Code/script_idl_mv/astrolib/fits_open.pro new file mode 100644 index 0000000000000000000000000000000000000000..87bb87b00fe03ca94614d78f28c8b0563bc5cea1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_read.pro b/Code/script_idl_mv/astrolib/fits_read.pro new file mode 100644 index 0000000000000000000000000000000000000000..3298d6aec482e7486167dc32daf7b09466081d3c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 ; Integer*2 + 32: IDL_type = 3 ; Integer*4 + -32: IDL_type = 4 ; Real*4 + -64: IDL_type = 5 ; Real*8 + 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/Code/script_idl_mv/astrolib/fits_test_checksum.pro b/Code/script_idl_mv/astrolib/fits_test_checksum.pro new file mode 100644 index 0000000000000000000000000000000000000000..0ca0e512e338f40f4e039a51bb0b77aad950bf2b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fits_write.pro b/Code/script_idl_mv/astrolib/fits_write.pro new file mode 100644 index 0000000000000000000000000000000000000000..5ce3af2bdee32b89ed61f1b53000714cbfdd485b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fitsdir.pro b/Code/script_idl_mv/astrolib/fitsdir.pro new file mode 100644 index 0000000000000000000000000000000000000000..d674003a78df03b83cbfbdf5aafcbd190b555f05 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fitsrgb_to_tiff.pro b/Code/script_idl_mv/astrolib/fitsrgb_to_tiff.pro new file mode 100644 index 0000000000000000000000000000000000000000..e3b711ad49444d4c9d2f3a503a6db84ea2cc2cf8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/flegendre.pro b/Code/script_idl_mv/astrolib/flegendre.pro new file mode 100644 index 0000000000000000000000000000000000000000..00fb5baf5ec526084820b317d3f8bbcad430c051 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/flux2mag.pro b/Code/script_idl_mv/astrolib/flux2mag.pro new file mode 100644 index 0000000000000000000000000000000000000000..d21d9cf0aab8d61fc64d28851e75d790bb0299a3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fm_unred.pro b/Code/script_idl_mv/astrolib/fm_unred.pro new file mode 100644 index 0000000000000000000000000000000000000000..2bb8de241f6c800f7089f3c62491dc427afcc521 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/forprint.pro b/Code/script_idl_mv/astrolib/forprint.pro new file mode 100644 index 0000000000000000000000000000000000000000..b529e12fa512ebab725b72918c72c651431d0b7a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 FORPRINT 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/Code/script_idl_mv/astrolib/frebin.pro b/Code/script_idl_mv/astrolib/frebin.pro new file mode 100644 index 0000000000000000000000000000000000000000..1f2e10eca98ebdc31e0bae5eaf7620c7bf390028 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftab_help.pro b/Code/script_idl_mv/astrolib/ftab_help.pro new file mode 100644 index 0000000000000000000000000000000000000000..a2b3d1fecf1eb5337115fd50e422ded0e8b721d3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftab_print.pro b/Code/script_idl_mv/astrolib/ftab_print.pro new file mode 100644 index 0000000000000000000000000000000000000000..63bb8f97a6224e81a00b77d162a492ea4889afc3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftaddcol.pro b/Code/script_idl_mv/astrolib/ftaddcol.pro new file mode 100644 index 0000000000000000000000000000000000000000..a53d23a5eca036707924e046361c0be8951f71e7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftcreate.pro b/Code/script_idl_mv/astrolib/ftcreate.pro new file mode 100644 index 0000000000000000000000000000000000000000..5602ed399074680b21dd26d802a959296cb94503 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftdelcol.pro b/Code/script_idl_mv/astrolib/ftdelcol.pro new file mode 100644 index 0000000000000000000000000000000000000000..8c9fa9148c01a784f4f5eaf550d39f813d4c7273 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftdelrow.pro b/Code/script_idl_mv/astrolib/ftdelrow.pro new file mode 100644 index 0000000000000000000000000000000000000000..5e64b7e475b0ea608f1dae09620a50ae65138e11 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftget.pro b/Code/script_idl_mv/astrolib/ftget.pro new file mode 100644 index 0000000000000000000000000000000000000000..a5f6885fb1f49fbc9aa643ff035855b41186184e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fthelp.pro b/Code/script_idl_mv/astrolib/fthelp.pro new file mode 100644 index 0000000000000000000000000000000000000000..63eb46f35d82a76ff14a995d45dfdd537245b608 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fthmod.pro b/Code/script_idl_mv/astrolib/fthmod.pro new file mode 100644 index 0000000000000000000000000000000000000000..2e1e8d38a86f83f87397c698dcbf3a62d7dd5d7f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftinfo.pro b/Code/script_idl_mv/astrolib/ftinfo.pro new file mode 100644 index 0000000000000000000000000000000000000000..c5230fd8583d4cd89e4fbd8f3f54a8657802683f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftkeeprow.pro b/Code/script_idl_mv/astrolib/ftkeeprow.pro new file mode 100644 index 0000000000000000000000000000000000000000..f02c4b16bb55430429e72e573bda70da69214b6b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftprint.pro b/Code/script_idl_mv/astrolib/ftprint.pro new file mode 100644 index 0000000000000000000000000000000000000000..71278e0b099da479c08ab8854a5f8b7ebd576728 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftput.pro b/Code/script_idl_mv/astrolib/ftput.pro new file mode 100644 index 0000000000000000000000000000000000000000..cee3f6c5e4a724051e18415ca6b396be322908a2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftsize.pro b/Code/script_idl_mv/astrolib/ftsize.pro new file mode 100644 index 0000000000000000000000000000000000000000..81c633c1adedcee40a1e8d829091be8f8a9e6b8c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ftsort.pro b/Code/script_idl_mv/astrolib/ftsort.pro new file mode 100644 index 0000000000000000000000000000000000000000..0e3c86b528ecb732cadc75413c27d3698f00f56a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxaddpar.pro b/Code/script_idl_mv/astrolib/fxaddpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..3f40df496b9d3341dfe69ade420eb4973d244954 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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://heasarc.gsfc.nasa.gov/docs/heasarc/ofwg/docs/ofwg_recomm/r13.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/Code/script_idl_mv/astrolib/fxbaddcol.pro b/Code/script_idl_mv/astrolib/fxbaddcol.pro new file mode 100644 index 0000000000000000000000000000000000000000..fc09694dd7d9025bc0584acc6959e4d8940bfa99 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbclose.pro b/Code/script_idl_mv/astrolib/fxbclose.pro new file mode 100644 index 0000000000000000000000000000000000000000..2c6987c084234265d3521f985ed5e2086e709fe0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbcolnum.pro b/Code/script_idl_mv/astrolib/fxbcolnum.pro new file mode 100644 index 0000000000000000000000000000000000000000..c456cb563bd419c11d4598c98b4c40b3fa175cb9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbcreate.pro b/Code/script_idl_mv/astrolib/fxbcreate.pro new file mode 100644 index 0000000000000000000000000000000000000000..45a2fa9dbb8ba5e817f26707a41cbfa880dac4a4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbdimen.pro b/Code/script_idl_mv/astrolib/fxbdimen.pro new file mode 100644 index 0000000000000000000000000000000000000000..16bc619a69aca3710c9bbee55e46713a05fd7307 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbfind.pro b/Code/script_idl_mv/astrolib/fxbfind.pro new file mode 100644 index 0000000000000000000000000000000000000000..530835de7f71580bd41ebdec9e43d4847079be1d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbfindlun.pro b/Code/script_idl_mv/astrolib/fxbfindlun.pro new file mode 100644 index 0000000000000000000000000000000000000000..78b3bb8b8d33ba14f3904b3be3f70cb7a55144f9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/fxbfindlun.pro @@ -0,0 +1,120 @@ + 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 +; Make NAXIS1, NAXIS2, HEAP, DHEAP, BYTOFF 64-bit integers to deal with large files, +; E. Hivon Mar 2008 +; Also make NHEADER a 64 bit integer W. Landsman May 2016 +; +;- +; +@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 = 0LL + 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/Code/script_idl_mv/astrolib/fxbfinish.pro b/Code/script_idl_mv/astrolib/fxbfinish.pro new file mode 100644 index 0000000000000000000000000000000000000000..e5c9b39ff102b54ec5659e6ec65730ca80b58a16 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbgrow.pro b/Code/script_idl_mv/astrolib/fxbgrow.pro new file mode 100644 index 0000000000000000000000000000000000000000..6285bce4061ea256dd190e4adc5393021eea41e9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbheader.pro b/Code/script_idl_mv/astrolib/fxbheader.pro new file mode 100644 index 0000000000000000000000000000000000000000..6e37e19abfd31c10e43b0c26a7267e7113dbf557 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbhelp.pro b/Code/script_idl_mv/astrolib/fxbhelp.pro new file mode 100644 index 0000000000000000000000000000000000000000..2a7c19977ab1e592ca3c284deebe5579dcca7d88 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbhmake.pro b/Code/script_idl_mv/astrolib/fxbhmake.pro new file mode 100644 index 0000000000000000000000000000000000000000..7d9ff316702841923e037fde7c95714e4df11bfa --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbintable.pro b/Code/script_idl_mv/astrolib/fxbintable.pro new file mode 100644 index 0000000000000000000000000000000000000000..f4791a2d5da790b1c483cd08651790e6f0582e13 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbisopen.pro b/Code/script_idl_mv/astrolib/fxbisopen.pro new file mode 100644 index 0000000000000000000000000000000000000000..ae5fca17b2eed8a05d4e6d0bfdbbbf4d9a613266 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbopen.pro b/Code/script_idl_mv/astrolib/fxbopen.pro new file mode 100644 index 0000000000000000000000000000000000000000..f3273776d82cafe9239614e5594c8dda4599816d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbparse.pro b/Code/script_idl_mv/astrolib/fxbparse.pro new file mode 100644 index 0000000000000000000000000000000000000000..92601d50869682818292953193234b52641163df --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbread.pro b/Code/script_idl_mv/astrolib/fxbread.pro new file mode 100644 index 0000000000000000000000000000000000000000..a482f0e7a4953133d1836db7224a22eb9bc129fa --- /dev/null +++ b/Code/script_idl_mv/astrolib/fxbread.pro @@ -0,0 +1,388 @@ + 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 16, William Thompson, 18-May-2016, change POINTER to ULONG +; Version : +; Version 16, 18-May-2016 +;- +; +@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 = ULONARR(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/Code/script_idl_mv/astrolib/fxbreadm.pro b/Code/script_idl_mv/astrolib/fxbreadm.pro new file mode 100644 index 0000000000000000000000000000000000000000..cf70a8dacf1c94a43c8acf686cee9059b01cb111 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbstate.pro b/Code/script_idl_mv/astrolib/fxbstate.pro new file mode 100644 index 0000000000000000000000000000000000000000..b2de4693f0d8e483e2a8cf1dd99dd70d15963efd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbtdim.pro b/Code/script_idl_mv/astrolib/fxbtdim.pro new file mode 100644 index 0000000000000000000000000000000000000000..3c116e75ce2dab9ea38258fa67ccfde8e63d8b07 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbtform.pro b/Code/script_idl_mv/astrolib/fxbtform.pro new file mode 100644 index 0000000000000000000000000000000000000000..c0e05d537c79ed136b6823c50786f8fedb2ca315 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxbwrite.pro b/Code/script_idl_mv/astrolib/fxbwrite.pro new file mode 100644 index 0000000000000000000000000000000000000000..0c0f4539703345765db9c0930d2b9bd82344e66e --- /dev/null +++ b/Code/script_idl_mv/astrolib/fxbwrite.pro @@ -0,0 +1,282 @@ + 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 6, Converted to IDL V5.0 W. Landsman September 1997 +; Version 7, William Thompson, 18-May-2016, change POINTER to ULONG +; Version : +; Version 7, 18-May-2016 +;- +; +@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 = ULONARR(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/Code/script_idl_mv/astrolib/fxbwritm.pro b/Code/script_idl_mv/astrolib/fxbwritm.pro new file mode 100644 index 0000000000000000000000000000000000000000..a07f508a14237eee7e3a9a2d00d69cf962f44389 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxfindend.pro b/Code/script_idl_mv/astrolib/fxfindend.pro new file mode 100644 index 0000000000000000000000000000000000000000..b33c1aaa1ed595afbca207f4d48fa7db719c2dc1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxhclean.pro b/Code/script_idl_mv/astrolib/fxhclean.pro new file mode 100644 index 0000000000000000000000000000000000000000..2b162ed1f026a294b74b43f464e357b056d03ad2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxhmake.pro b/Code/script_idl_mv/astrolib/fxhmake.pro new file mode 100644 index 0000000000000000000000000000000000000000..598a455ba0b3fa10676383009fdebccf9624d19a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxhmodify.pro b/Code/script_idl_mv/astrolib/fxhmodify.pro new file mode 100644 index 0000000000000000000000000000000000000000..8ac0ad27c982cbc70799536e369f0b67ca36b172 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxhread.pro b/Code/script_idl_mv/astrolib/fxhread.pro new file mode 100644 index 0000000000000000000000000000000000000000..3a4da731b4d18777a7262ac705175a87a88f8398 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxmove.pro b/Code/script_idl_mv/astrolib/fxmove.pro new file mode 100644 index 0000000000000000000000000000000000000000..02b93bf2dec7f1472c28924f431cd3da8f82d627 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxpar.pro b/Code/script_idl_mv/astrolib/fxpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..a456b5a107e5e57f08d3857db132648e1920b799 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxparpos.pro b/Code/script_idl_mv/astrolib/fxparpos.pro new file mode 100644 index 0000000000000000000000000000000000000000..eb3b0ec573c1bb260a875caeb681d16a0f82f669 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxposit.pro b/Code/script_idl_mv/astrolib/fxposit.pro new file mode 100644 index 0000000000000000000000000000000000000000..ba2263dab7c59e352c1d190ca14f778f896e6f07 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxread.pro b/Code/script_idl_mv/astrolib/fxread.pro new file mode 100644 index 0000000000000000000000000000000000000000..d609ff24cb8402ff990be5da179b929e9d82c50f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/fxwrite.pro b/Code/script_idl_mv/astrolib/fxwrite.pro new file mode 100644 index 0000000000000000000000000000000000000000..30e2c7c189436cf8db45077eaf970a3a323992f1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gal_flat.pro b/Code/script_idl_mv/astrolib/gal_flat.pro new file mode 100644 index 0000000000000000000000000000000000000000..d6407e283088b44e7721aa17c7c4a8be0520b136 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gal_uvw.pro b/Code/script_idl_mv/astrolib/gal_uvw.pro new file mode 100644 index 0000000000000000000000000000000000000000..69e63b970300f868258414f0a6aec3d3e9adb5e9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/galage.pro b/Code/script_idl_mv/astrolib/galage.pro new file mode 100644 index 0000000000000000000000000000000000000000..c42c49461c2e47c8d3ea9a4f1a35d8cbe22c355a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gaussian.pro b/Code/script_idl_mv/astrolib/gaussian.pro new file mode 100644 index 0000000000000000000000000000000000000000..1f640a1a10cd43548d67c9fac36be9d48fad921f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gcirc.pro b/Code/script_idl_mv/astrolib/gcirc.pro new file mode 100644 index 0000000000000000000000000000000000000000..06e0d717ef4b85b23102dc2c0a3fc7457d814eef --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gcntrd.pro b/Code/script_idl_mv/astrolib/gcntrd.pro new file mode 100644 index 0000000000000000000000000000000000000000..344d6ca7787bb2e2753242a8ce4bdce0de538696 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/geo2eci.pro b/Code/script_idl_mv/astrolib/geo2eci.pro new file mode 100644 index 0000000000000000000000000000000000000000..d11208c674e569b362e5eb7ec76ef80c4de626ed --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/geo2geodetic.pro b/Code/script_idl_mv/astrolib/geo2geodetic.pro new file mode 100644 index 0000000000000000000000000000000000000000..225384ab7b0a10b2d5d09810ce0e8a3c97079642 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/geo2mag.pro b/Code/script_idl_mv/astrolib/geo2mag.pro new file mode 100644 index 0000000000000000000000000000000000000000..21f878675bbb4902a5c3fadd1ba63c16af50a842 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/geodetic2geo.pro b/Code/script_idl_mv/astrolib/geodetic2geo.pro new file mode 100644 index 0000000000000000000000000000000000000000..0615516b34a6c711dcf80bd3efa7cd30524d6283 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/get_coords.pro b/Code/script_idl_mv/astrolib/get_coords.pro new file mode 100644 index 0000000000000000000000000000000000000000..0e3427c97b020bc56b0538adc289ab659bf5a901 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/get_date.pro b/Code/script_idl_mv/astrolib/get_date.pro new file mode 100644 index 0000000000000000000000000000000000000000..d18e854924735b9f76f31d084c0eb995edae5ab1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/get_equinox.pro b/Code/script_idl_mv/astrolib/get_equinox.pro new file mode 100644 index 0000000000000000000000000000000000000000..d1a24853cbde2432921b2e917058736c2925dedf --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/get_juldate.pro b/Code/script_idl_mv/astrolib/get_juldate.pro new file mode 100644 index 0000000000000000000000000000000000000000..585cc7d8f550ec440ee72bab6b878548cf7f8e80 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/get_pipe_filesize.pro b/Code/script_idl_mv/astrolib/get_pipe_filesize.pro new file mode 100644 index 0000000000000000000000000000000000000000..743b6af9b848f9a79c4d02bf88c43509198f99b2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/getopt.pro b/Code/script_idl_mv/astrolib/getopt.pro new file mode 100644 index 0000000000000000000000000000000000000000..9ad56a95c2f13e3f5cad48d3856568e3026cc822 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/getpro.pro b/Code/script_idl_mv/astrolib/getpro.pro new file mode 100644 index 0000000000000000000000000000000000000000..046080778fb62a45cad1afc99e54984d8610bd50 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/getpsf.pro b/Code/script_idl_mv/astrolib/getpsf.pro new file mode 100644 index 0000000000000000000000000000000000000000..d2c36f36f00cd5482d67d425f32952c16c77d865 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/glactc.pro b/Code/script_idl_mv/astrolib/glactc.pro new file mode 100644 index 0000000000000000000000000000000000000000..edac6da6079a2cfc5372deb74bd353b2d821f5c9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/glactc_pm.pro b/Code/script_idl_mv/astrolib/glactc_pm.pro new file mode 100644 index 0000000000000000000000000000000000000000..75c0206c9dc0602166e37fab2f733facb623f0dc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/group.pro b/Code/script_idl_mv/astrolib/group.pro new file mode 100644 index 0000000000000000000000000000000000000000..2df2d6f4bf256371188a57128efb0804abc2a8f0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gsss_stdast.pro b/Code/script_idl_mv/astrolib/gsss_stdast.pro new file mode 100644 index 0000000000000000000000000000000000000000..12793f127f7dd8a617bf5db0af939ee40a541f18 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gsssadxy.pro b/Code/script_idl_mv/astrolib/gsssadxy.pro new file mode 100644 index 0000000000000000000000000000000000000000..561c644c2af8a69d13b255a68a7c52808f336ff2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gsssextast.pro b/Code/script_idl_mv/astrolib/gsssextast.pro new file mode 100644 index 0000000000000000000000000000000000000000..65340a6970b9ab4c5a3c929a2850bdc9d4bed8f4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/gsssxyad.pro b/Code/script_idl_mv/astrolib/gsssxyad.pro new file mode 100644 index 0000000000000000000000000000000000000000..70d7c18e41b94b6da2788a4ab8a8e36960d110c7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hadec2altaz.pro b/Code/script_idl_mv/astrolib/hadec2altaz.pro new file mode 100644 index 0000000000000000000000000000000000000000..6876ca23ce30f32c915547ffaad92377c1a431fd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hastrom.pro b/Code/script_idl_mv/astrolib/hastrom.pro new file mode 100644 index 0000000000000000000000000000000000000000..ff3c4a615635c8629c1b009a6d9892c35d9f3e39 --- /dev/null +++ b/Code/script_idl_mv/astrolib/hastrom.pro @@ -0,0 +1,317 @@ +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. Currently, HASTROM +; will force a value of degree of less than 4 (see notes) +; 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. +; (4) We found (in May 2016) numerical instability in POLYWARP when +; Degree is set to a value of 5 or larger. Therefore DEGREE will +; be forced to a value of 4 or less (along with a warning). Note +; that in POLYWARP a DEGREE of 5 actually includes 10th order terms +; like x^5*y^5 +; 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 +; Test for Degree > 4 usage in Polywarp W. Landsman May 2016 +; +;- + 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 degree GT 4 then message,/INF, $ + 'Warning - POLYWARP Polynomial degree set to 4' + + if interp EQ 0 $ ;Get coefficients + then polywarp, x+.5, y+.5, xref, yref, degree<4, kx, ky, status = status $ + else polywarp, x, y, xref, yref, degree<4, kx, ky ,status=status + case status of + 0: + 1: message,NoPrint=Silent,/INF,'Warning: Singular matrix in version in PolyWarp' + 2: message,NoPrint=Silent,/INF,'Warning: Small Pivot element in Polywarp' + 3: message,'Invalid Status value returned from Polywarp' + endcase + + + 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<4,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/Code/script_idl_mv/astrolib/hboxave.pro b/Code/script_idl_mv/astrolib/hboxave.pro new file mode 100644 index 0000000000000000000000000000000000000000..d5cfc59ff8054079b5d7e51fa6c7671254a99e6e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hcongrid.pro b/Code/script_idl_mv/astrolib/hcongrid.pro new file mode 100644 index 0000000000000000000000000000000000000000..68e6b5566048af2420a7c6d3bdbb29430960e7e1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/headfits.pro b/Code/script_idl_mv/astrolib/headfits.pro new file mode 100644 index 0000000000000000000000000000000000000000..c6495e40f0b00e3af24fe2eb613e29b0135b1535 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/helio.pro b/Code/script_idl_mv/astrolib/helio.pro new file mode 100644 index 0000000000000000000000000000000000000000..70ba4a8c81e61560d3734a080964e9120e9ac627 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/helio_jd.pro b/Code/script_idl_mv/astrolib/helio_jd.pro new file mode 100644 index 0000000000000000000000000000000000000000..af82fbc1998658526dcb6272291895ccb30b0f19 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/helio_rv.pro b/Code/script_idl_mv/astrolib/helio_rv.pro new file mode 100644 index 0000000000000000000000000000000000000000..cd6fe2c2e4b898e2110dd621a9170680853cd3f8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hermite.pro b/Code/script_idl_mv/astrolib/hermite.pro new file mode 100644 index 0000000000000000000000000000000000000000..9023f9205784d69363afc4d0abdd6cb08781ea23 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/heuler.pro b/Code/script_idl_mv/astrolib/heuler.pro new file mode 100644 index 0000000000000000000000000000000000000000..2c7dd97342c82b04b2366308447150208ffa7b55 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hextract.pro b/Code/script_idl_mv/astrolib/hextract.pro new file mode 100644 index 0000000000000000000000000000000000000000..111147a15bae4f46e49dfa8874bf39fbd5a2f1bb --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hgrep.pro b/Code/script_idl_mv/astrolib/hgrep.pro new file mode 100644 index 0000000000000000000000000000000000000000..b998f5d75fc17269df7565ae50f34a8b2aecbc02 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/histogauss.pro b/Code/script_idl_mv/astrolib/histogauss.pro new file mode 100644 index 0000000000000000000000000000000000000000..1c7401b43f06bd66c8d8152bac4862b297cdd061 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hor2eq.pro b/Code/script_idl_mv/astrolib/hor2eq.pro new file mode 100644 index 0000000000000000000000000000000000000000..e7b086ad15b73f174d7b37a4ae63530b72f1c1ef --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/host_to_ieee.pro b/Code/script_idl_mv/astrolib/host_to_ieee.pro new file mode 100644 index 0000000000000000000000000000000000000000..ff17e0063c5069b29ba79033217573ee0a7c6658 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hprecess.pro b/Code/script_idl_mv/astrolib/hprecess.pro new file mode 100644 index 0000000000000000000000000000000000000000..6dc544c0a29ee63a8c3e1df9adaf224d4bfcce58 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hprint.pro b/Code/script_idl_mv/astrolib/hprint.pro new file mode 100644 index 0000000000000000000000000000000000000000..6b587e47d847780fceb2ab2b914996d0847d2daf --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hrebin.pro b/Code/script_idl_mv/astrolib/hrebin.pro new file mode 100644 index 0000000000000000000000000000000000000000..86b3ec25de2726d8fc12d453bf615d3ce28a4a15 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hreverse.pro b/Code/script_idl_mv/astrolib/hreverse.pro new file mode 100644 index 0000000000000000000000000000000000000000..446008e569a363e40ec45e2ee374184fac7ba661 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hrot.pro b/Code/script_idl_mv/astrolib/hrot.pro new file mode 100644 index 0000000000000000000000000000000000000000..f905ffeeb0442812019cfccfebc63c7468aca7ce --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/hrotate.pro b/Code/script_idl_mv/astrolib/hrotate.pro new file mode 100644 index 0000000000000000000000000000000000000000..ac20f84ec7f8329702c16505540f346831fd7a84 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ieee_to_host.pro b/Code/script_idl_mv/astrolib/ieee_to_host.pro new file mode 100644 index 0000000000000000000000000000000000000000..cb1b1f38cd5d69366c21664923b92314b6a87730 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/imcontour.pro b/Code/script_idl_mv/astrolib/imcontour.pro new file mode 100644 index 0000000000000000000000000000000000000000..2665ca849d633bbf67f0bf99a894d57b1cf9a8af --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/imdbase.pro b/Code/script_idl_mv/astrolib/imdbase.pro new file mode 100644 index 0000000000000000000000000000000000000000..d2970eab34cff8b85164717c8f5f28218750e7b1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/imf.pro b/Code/script_idl_mv/astrolib/imf.pro new file mode 100644 index 0000000000000000000000000000000000000000..4c0f7e8d764c8eac6bd9c99929a6f60d1b20e577 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/imlist.pro b/Code/script_idl_mv/astrolib/imlist.pro new file mode 100644 index 0000000000000000000000000000000000000000..58e9bd63a9f20455f9036c2532e0d1f567e2dc81 --- /dev/null +++ b/Code/script_idl_mv/astrolib/imlist.pro @@ -0,0 +1,231 @@ +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 +; Converted to IDL V5.0 W. Landsman September 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 +;- + 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,'!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( 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 + + defsysv,'!TEXTUNIT',exist=i + if i EQ 0 then astrolib + 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/Code/script_idl_mv/astrolib/irafdir.pro b/Code/script_idl_mv/astrolib/irafdir.pro new file mode 100644 index 0000000000000000000000000000000000000000..8b064eb2e289953f1a6222ac93c5079bd6168f0c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/irafrd.pro b/Code/script_idl_mv/astrolib/irafrd.pro new file mode 100644 index 0000000000000000000000000000000000000000..c4d18bab7887a8e40116afb014d6a074ecdb7956 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/irafwrt.pro b/Code/script_idl_mv/astrolib/irafwrt.pro new file mode 100644 index 0000000000000000000000000000000000000000..c4609f3c36372b4e8609a07df124505e77eda9e8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/is_ieee_big.pro b/Code/script_idl_mv/astrolib/is_ieee_big.pro new file mode 100644 index 0000000000000000000000000000000000000000..9127dd72ea3bb1c835af6e6724e530017eb3abc5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/isarray.pro b/Code/script_idl_mv/astrolib/isarray.pro new file mode 100644 index 0000000000000000000000000000000000000000..0e7e051b19c17e8f10b2684bd0f8afbd28bb61ee --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ismeuv.pro b/Code/script_idl_mv/astrolib/ismeuv.pro new file mode 100644 index 0000000000000000000000000000000000000000..c23a501a68de747dfbc04ec139a501837e7e4f18 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/jdcnv.pro b/Code/script_idl_mv/astrolib/jdcnv.pro new file mode 100644 index 0000000000000000000000000000000000000000..652dd3014c0180dc0306ae7092e599ca19fb0f69 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/jplephinterp.pro b/Code/script_idl_mv/astrolib/jplephinterp.pro new file mode 100644 index 0000000000000000000000000000000000000000..61d10dfecffeb0b156028b78f63070658f68331c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/jplephread.pro b/Code/script_idl_mv/astrolib/jplephread.pro new file mode 100644 index 0000000000000000000000000000000000000000..841679fa5213c747edf24490bc960ce610690f41 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/jplephtest.pro b/Code/script_idl_mv/astrolib/jplephtest.pro new file mode 100644 index 0000000000000000000000000000000000000000..5f441d38cbe5d5c9d6c76668f3fd787700729c93 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/jprecess.pro b/Code/script_idl_mv/astrolib/jprecess.pro new file mode 100644 index 0000000000000000000000000000000000000000..bf843af8955e2b93b90b9918919304df7b763258 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/juldate.pro b/Code/script_idl_mv/astrolib/juldate.pro new file mode 100644 index 0000000000000000000000000000000000000000..c6d0281ea42ba436d5aa4154061226f1595f9e29 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ksone.pro b/Code/script_idl_mv/astrolib/ksone.pro new file mode 100644 index 0000000000000000000000000000000000000000..c8b2ab06fbc0191d588bb6a2d8dce291666427dd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/kstwo.pro b/Code/script_idl_mv/astrolib/kstwo.pro new file mode 100644 index 0000000000000000000000000000000000000000..28619ce9b659cb6a8899428b33088573b48535d9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/kuiperone.pro b/Code/script_idl_mv/astrolib/kuiperone.pro new file mode 100644 index 0000000000000000000000000000000000000000..665960b5766b9383fd8baf098e1197aaa3058725 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/kuipertwo.pro b/Code/script_idl_mv/astrolib/kuipertwo.pro new file mode 100644 index 0000000000000000000000000000000000000000..8f9827ca66b25435a5850468507b65b4333c30fa --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/lineid_plot.pro b/Code/script_idl_mv/astrolib/lineid_plot.pro new file mode 100644 index 0000000000000000000000000000000000000000..8665e28064504ab39a0dff8e4b3a491602160b8b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/linmix_err.pro b/Code/script_idl_mv/astrolib/linmix_err.pro new file mode 100644 index 0000000000000000000000000000000000000000..d1b24f1d0df1c4a62ffdb4cdf38b11f9ffa5128e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/linterp.pro b/Code/script_idl_mv/astrolib/linterp.pro new file mode 100644 index 0000000000000000000000000000000000000000..95ead98b30839b05beb60e6fb67a61a0d3368c14 --- /dev/null +++ b/Code/script_idl_mv/astrolib/linterp.pro @@ -0,0 +1,119 @@ +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) Prior to V8.2.3 LINTERP converted the new grid vector to floating point +; (because INTERPOLATE does this) whereas INTERPOL() and post-V8.2.3 +; LINTERP 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 float +; +; 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 +; Call INTERPOLATE with /DOUBLE if V8.2.3 W. Landsman Feb 2015 +;- + 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 $ + if !VERSION.RELEASE GE '8.2.3' then $ + Yint = interpolate( Ytab, r, DOUBLE = (ytype EQ 5) ) 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/Code/script_idl_mv/astrolib/list_with_path.pro b/Code/script_idl_mv/astrolib/list_with_path.pro new file mode 100644 index 0000000000000000000000000000000000000000..0814d5390f9d4ce508b70b45bf064ff4795ed47c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/lsf_rotate.pro b/Code/script_idl_mv/astrolib/lsf_rotate.pro new file mode 100644 index 0000000000000000000000000000000000000000..9914869d9192a5565025c0de15fae54d0ac9fd88 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/lumdist.pro b/Code/script_idl_mv/astrolib/lumdist.pro new file mode 100644 index 0000000000000000000000000000000000000000..17113123ae8cbe9cd0fc68ef91aa85737673432d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mag2flux.pro b/Code/script_idl_mv/astrolib/mag2flux.pro new file mode 100644 index 0000000000000000000000000000000000000000..030e405ff0e709b2e22267b5852905adcbd28253 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mag2geo.pro b/Code/script_idl_mv/astrolib/mag2geo.pro new file mode 100644 index 0000000000000000000000000000000000000000..7cada6305846eb0988fb2b67970deae91bc5bbd4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/make_2d.pro b/Code/script_idl_mv/astrolib/make_2d.pro new file mode 100644 index 0000000000000000000000000000000000000000..0b75a1985ab42b18f49d0cdb2e496ca8d4ec8472 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/make_astr.pro b/Code/script_idl_mv/astrolib/make_astr.pro new file mode 100644 index 0000000000000000000000000000000000000000..20177f4ea11180707df7fb2606b03730c664f35a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/match.pro b/Code/script_idl_mv/astrolib/match.pro new file mode 100644 index 0000000000000000000000000000000000000000..af66c90bc8da63d6077d86d956d017b1590b007c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/match2.pro b/Code/script_idl_mv/astrolib/match2.pro new file mode 100644 index 0000000000000000000000000000000000000000..16b33cea8f4f349fa1ae14eda65312797d3f9c1a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/max_entropy.pro b/Code/script_idl_mv/astrolib/max_entropy.pro new file mode 100644 index 0000000000000000000000000000000000000000..4c99ea30db7f19fda285d90e467d81b24fe11566 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/max_likelihood.pro b/Code/script_idl_mv/astrolib/max_likelihood.pro new file mode 100644 index 0000000000000000000000000000000000000000..11e82804bd804eafa5abb6076908471449e68f2a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/meanclip.pro b/Code/script_idl_mv/astrolib/meanclip.pro new file mode 100644 index 0000000000000000000000000000000000000000..995011c08c277caa37f6e5327ccaf1b51935c25a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/medarr.pro b/Code/script_idl_mv/astrolib/medarr.pro new file mode 100644 index 0000000000000000000000000000000000000000..a3f0b7be35989a1b5cbe032e10084802f6a5a885 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/medsmooth.pro b/Code/script_idl_mv/astrolib/medsmooth.pro new file mode 100644 index 0000000000000000000000000000000000000000..15d95931259d69444f1a5fd280b557fe1865aa32 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/minf_bracket.pro b/Code/script_idl_mv/astrolib/minf_bracket.pro new file mode 100644 index 0000000000000000000000000000000000000000..a0de52c5866aa996ee8002fec02d96d941dc69da --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/minf_conj_grad.pro b/Code/script_idl_mv/astrolib/minf_conj_grad.pro new file mode 100644 index 0000000000000000000000000000000000000000..81a32bccf059ec5348914d29929dd07b60486596 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/minf_parabol_d.pro b/Code/script_idl_mv/astrolib/minf_parabol_d.pro new file mode 100644 index 0000000000000000000000000000000000000000..313a043a9b4ce680308e56c50131df2b73c695d1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/minf_parabolic.pro b/Code/script_idl_mv/astrolib/minf_parabolic.pro new file mode 100644 index 0000000000000000000000000000000000000000..eff8345c31ab593c090599ca929fed3f075f1333 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/minmax.pro b/Code/script_idl_mv/astrolib/minmax.pro new file mode 100644 index 0000000000000000000000000000000000000000..71b8e37ffe86e3cd39dfa693c17ff875ae110d22 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mkhdr.pro b/Code/script_idl_mv/astrolib/mkhdr.pro new file mode 100644 index 0000000000000000000000000000000000000000..bf130b1c76b49fa10ed0fc0d3d3a119578308ae1 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mlinmix_err.pro b/Code/script_idl_mv/astrolib/mlinmix_err.pro new file mode 100644 index 0000000000000000000000000000000000000000..b74da78d3ae732b44423101e6dd333f50ee47db9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mmm.pro b/Code/script_idl_mv/astrolib/mmm.pro new file mode 100644 index 0000000000000000000000000000000000000000..cd0dd15d2f1298646fe880a15c90c823fe46fbc9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/modfits.pro b/Code/script_idl_mv/astrolib/modfits.pro new file mode 100644 index 0000000000000000000000000000000000000000..a922f9beb1e538a56a5cb19afed90f9b04f0c366 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/month_cnv.pro b/Code/script_idl_mv/astrolib/month_cnv.pro new file mode 100644 index 0000000000000000000000000000000000000000..39a771b4cc8dd57797fcaeb3fce8e31bcc17cf60 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/moonpos.pro b/Code/script_idl_mv/astrolib/moonpos.pro new file mode 100644 index 0000000000000000000000000000000000000000..3b026f8f8ac7a8b777474e975ee76bb038200a19 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mphase.pro b/Code/script_idl_mv/astrolib/mphase.pro new file mode 100644 index 0000000000000000000000000000000000000000..40840796a9f66705a54ca6f6bdcae679e89a3754 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mrandomn.pro b/Code/script_idl_mv/astrolib/mrandomn.pro new file mode 100644 index 0000000000000000000000000000000000000000..1d976ca748b364e25c4247dd605bcbbf59b57103 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mrd_hread.pro b/Code/script_idl_mv/astrolib/mrd_hread.pro new file mode 100644 index 0000000000000000000000000000000000000000..f464e98cd2c4960e8fc24da5953895807036b493 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mrd_skip.pro b/Code/script_idl_mv/astrolib/mrd_skip.pro new file mode 100644 index 0000000000000000000000000000000000000000..40744eef5a385c46bf3aa396e6e42e98d1d23974 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/multinom.pro b/Code/script_idl_mv/astrolib/multinom.pro new file mode 100644 index 0000000000000000000000000000000000000000..d11fd0dbee2000c74de71a320cae7e62ef4f6539 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/multiplot.pro b/Code/script_idl_mv/astrolib/multiplot.pro new file mode 100644 index 0000000000000000000000000000000000000000..0dea9200d861145628df8cc921e98ca4d36feb09 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/mwrfits.pro b/Code/script_idl_mv/astrolib/mwrfits.pro new file mode 100644 index 0000000000000000000000000000000000000000..28f71020860b306710ddbfa17dfff420e7ecd9ba --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/n_bytes.pro b/Code/script_idl_mv/astrolib/n_bytes.pro new file mode 100644 index 0000000000000000000000000000000000000000..4e73c561a1f0e95b3cae2122ca94edd63178b404 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 ;Integer*2 + 3: nb = 4 ;Integer*4 + 4: nb = 4 ;Real*4 + 5: nb = 8 ;Real*8 + 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 Integer*2 + 13: nb = 4 ;Unsigned Integer*4 + 14: nb = 8 ;64 bit integer + 15: nb = 8 ;Unsigned 64 bit integer + else: message,'ERROR - Object or Pointer data types not valid' + endcase + + return,long64(nel)*nb + end diff --git a/Code/script_idl_mv/astrolib/ngp.pro b/Code/script_idl_mv/astrolib/ngp.pro new file mode 100644 index 0000000000000000000000000000000000000000..301ec63f35197310df1fb7c2015ffb878bd0f237 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/nint.pro b/Code/script_idl_mv/astrolib/nint.pro new file mode 100644 index 0000000000000000000000000000000000000000..3b54e2f49c7fbdb006768c6bf5a80c2bc13fee36 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/nstar.pro b/Code/script_idl_mv/astrolib/nstar.pro new file mode 100644 index 0000000000000000000000000000000000000000..9552aaf1187b43c09ca867146daaaaed80c1b0eb --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/nulltrim.pro b/Code/script_idl_mv/astrolib/nulltrim.pro new file mode 100644 index 0000000000000000000000000000000000000000..47dadbdf8b7ef754e04e112e1d00aa100bd733a8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/nutate.pro b/Code/script_idl_mv/astrolib/nutate.pro new file mode 100644 index 0000000000000000000000000000000000000000..9502438b686d54019cfd8314470a5715a698c995 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/observatory.pro b/Code/script_idl_mv/astrolib/observatory.pro new file mode 100644 index 0000000000000000000000000000000000000000..9e16ccf9addb641008751b9cb53550de8eb0bc94 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/one_arrow.pro b/Code/script_idl_mv/astrolib/one_arrow.pro new file mode 100644 index 0000000000000000000000000000000000000000..98d64f43e12bfe9ec9305900acb05af9cfb1e87e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/one_ray.pro b/Code/script_idl_mv/astrolib/one_ray.pro new file mode 100644 index 0000000000000000000000000000000000000000..6714878b8aec27403a7885af59d2c32107176062 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/oploterror.pro b/Code/script_idl_mv/astrolib/oploterror.pro new file mode 100644 index 0000000000000000000000000000000000000000..742f2143ca9a47c93b7f725503a625b5dd2ec793 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ordinal.pro b/Code/script_idl_mv/astrolib/ordinal.pro new file mode 100644 index 0000000000000000000000000000000000000000..c0f4f1ea9d7bd9e158da68eecf52f892dbe75f9f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/partvelvec.pro b/Code/script_idl_mv/astrolib/partvelvec.pro new file mode 100644 index 0000000000000000000000000000000000000000..69a64ee56dd1146e8a0e0f3f3549d776c57a6e81 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/pca.pro b/Code/script_idl_mv/astrolib/pca.pro new file mode 100644 index 0000000000000000000000000000000000000000..6004f48d8ae54c0ac48cff604a882474b1933598 --- /dev/null +++ b/Code/script_idl_mv/astrolib/pca.pro @@ -0,0 +1,264 @@ +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. +; +; 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 can be added to one's session using the procedure ASTROLIB. +; +; 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/Code/script_idl_mv/astrolib/pent.pro b/Code/script_idl_mv/astrolib/pent.pro new file mode 100644 index 0000000000000000000000000000000000000000..7461f684ad90967a3260b1871b32690684d8fc83 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/permute.pro b/Code/script_idl_mv/astrolib/permute.pro new file mode 100644 index 0000000000000000000000000000000000000000..7baea7474e4dbce7479c27a6eb80f07eaf989979 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/pixcolor.pro b/Code/script_idl_mv/astrolib/pixcolor.pro new file mode 100644 index 0000000000000000000000000000000000000000..764086370e17f34a1428cb7d21d29f0d8f1aa265 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/pixwt.pro b/Code/script_idl_mv/astrolib/pixwt.pro new file mode 100644 index 0000000000000000000000000000000000000000..3dc8233fb523d83dbae2c425297db2befb92f6e7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/pkfit.pro b/Code/script_idl_mv/astrolib/pkfit.pro new file mode 100644 index 0000000000000000000000000000000000000000..5815e362c6550949613231d96a3d274e910367e0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/planck.pro b/Code/script_idl_mv/astrolib/planck.pro new file mode 100644 index 0000000000000000000000000000000000000000..ffbf59089abb356c01f494dc9f99782d766572e9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/planet_coords.pro b/Code/script_idl_mv/astrolib/planet_coords.pro new file mode 100644 index 0000000000000000000000000000000000000000..3f62cddb6b58796aeeec1dec0db117e82d76cfa5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ploterror.pro b/Code/script_idl_mv/astrolib/ploterror.pro new file mode 100644 index 0000000000000000000000000000000000000000..dbb3515a2502f0874f6159d98e945ec34574f90a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/plothist.pro b/Code/script_idl_mv/astrolib/plothist.pro new file mode 100644 index 0000000000000000000000000000000000000000..b311a1ef760429377636b3d71597560030999e72 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/poidev.pro b/Code/script_idl_mv/astrolib/poidev.pro new file mode 100644 index 0000000000000000000000000000000000000000..70bbcaf83e324ce3c17fb25fd24cb070dac4a43f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/polint.pro b/Code/script_idl_mv/astrolib/polint.pro new file mode 100644 index 0000000000000000000000000000000000000000..9c36b4b894f05604b8fb53fadf0b4705f5ca1082 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/polrec.pro b/Code/script_idl_mv/astrolib/polrec.pro new file mode 100644 index 0000000000000000000000000000000000000000..1b246b1156181abbff0ca70f62e7e8e9c903bb0e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/poly_smooth.pro b/Code/script_idl_mv/astrolib/poly_smooth.pro new file mode 100644 index 0000000000000000000000000000000000000000..0289e4f473909f9d639757665b6fb9121fae6fc4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/posang.pro b/Code/script_idl_mv/astrolib/posang.pro new file mode 100644 index 0000000000000000000000000000000000000000..e32dd8585f1439b8a3ec878700d9c80488f34af9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/positivity.pro b/Code/script_idl_mv/astrolib/positivity.pro new file mode 100644 index 0000000000000000000000000000000000000000..6e0abc5756d5d27bf17bc3c7de648b47eaf3ea93 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/precess.pro b/Code/script_idl_mv/astrolib/precess.pro new file mode 100644 index 0000000000000000000000000000000000000000..e304799bb405cf5e1b8fbbe82bf6ca717ba50aa7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/precess_cd.pro b/Code/script_idl_mv/astrolib/precess_cd.pro new file mode 100644 index 0000000000000000000000000000000000000000..fbf071c2fcbf7258590ee833d43ee8081617f992 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/precess_xyz.pro b/Code/script_idl_mv/astrolib/precess_xyz.pro new file mode 100644 index 0000000000000000000000000000000000000000..01801304a1c4d67d6612328f2943c20b06d7fdd2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/premat.pro b/Code/script_idl_mv/astrolib/premat.pro new file mode 100644 index 0000000000000000000000000000000000000000..63b055b3793dd4df7b921fcad7513f1f2ae89155 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/prime.pro b/Code/script_idl_mv/astrolib/prime.pro new file mode 100644 index 0000000000000000000000000000000000000000..490916eb970d4e7137ec7b17c7a35d119369e3c3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/print_struct.pro b/Code/script_idl_mv/astrolib/print_struct.pro new file mode 100644 index 0000000000000000000000000000000000000000..9271a6e1464e33b4ccb0d2a4d9ac3db061b4c73d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/prob_ks.pro b/Code/script_idl_mv/astrolib/prob_ks.pro new file mode 100644 index 0000000000000000000000000000000000000000..43df32d77962a5f35fd294619084c50d79c2c197 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/prob_kuiper.pro b/Code/script_idl_mv/astrolib/prob_kuiper.pro new file mode 100644 index 0000000000000000000000000000000000000000..25c13f9f8241fb6c60536b6cf2a86ed8ffe4a171 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/psf_gaussian.pro b/Code/script_idl_mv/astrolib/psf_gaussian.pro new file mode 100644 index 0000000000000000000000000000000000000000..1c0b94df95969776c2c5f95f3aeccb3d08569733 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/putast.pro b/Code/script_idl_mv/astrolib/putast.pro new file mode 100644 index 0000000000000000000000000000000000000000..c7231c27be1b684b35defbde4afb0e7c35f38af5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/putast.pro @@ -0,0 +1,484 @@ +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 +;- + + 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 + +; + if N_elements(longpole) EQ 1 then begin + 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 + 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, 'RADESYS'+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/Code/script_idl_mv/astrolib/qdcb_grid.pro b/Code/script_idl_mv/astrolib/qdcb_grid.pro new file mode 100644 index 0000000000000000000000000000000000000000..432d76776d9b6b6b2f6aff033cb33e62d6887e86 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/qget_string.pro b/Code/script_idl_mv/astrolib/qget_string.pro new file mode 100644 index 0000000000000000000000000000000000000000..0b6159201e720c526fda2d9212d28fdc6d68c5fc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/qsimp.pro b/Code/script_idl_mv/astrolib/qsimp.pro new file mode 100644 index 0000000000000000000000000000000000000000..3e57145993dd94350d4e5d31706396a2ca10d362 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/qtrap.pro b/Code/script_idl_mv/astrolib/qtrap.pro new file mode 100644 index 0000000000000000000000000000000000000000..22532d181326c716e73a16dae40c28c484ada0ca --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/quadterp.pro b/Code/script_idl_mv/astrolib/quadterp.pro new file mode 100644 index 0000000000000000000000000000000000000000..6f18f3bd44f5d85819d22c701a1c5ed70dd7275c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/query_irsa_cat.pro b/Code/script_idl_mv/astrolib/query_irsa_cat.pro new file mode 100644 index 0000000000000000000000000000000000000000..5886516a606a6ee27e4d906dbc539a301792a8a4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/querydss.pro b/Code/script_idl_mv/astrolib/querydss.pro new file mode 100644 index 0000000000000000000000000000000000000000..6b04de0157580240fa456405ec84c8b45cef9835 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/querygsc.pro b/Code/script_idl_mv/astrolib/querygsc.pro new file mode 100644 index 0000000000000000000000000000000000000000..d59af6bcae9bffda3f09fcd4f879e3f3a31392a4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/querysimbad.pro b/Code/script_idl_mv/astrolib/querysimbad.pro new file mode 100644 index 0000000000000000000000000000000000000000..70fd6c3946f432e2b9b7ed67c6c189f1f28eb3e9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/queryvizier.pro b/Code/script_idl_mv/astrolib/queryvizier.pro new file mode 100644 index 0000000000000000000000000000000000000000..675e65b02ef8dc4844614a63bbf51da53680d329 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/radec.pro b/Code/script_idl_mv/astrolib/radec.pro new file mode 100644 index 0000000000000000000000000000000000000000..ebad23581d89257269646ddb246a7671e7031b68 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/randomchi.pro b/Code/script_idl_mv/astrolib/randomchi.pro new file mode 100644 index 0000000000000000000000000000000000000000..6c79d362e0599b8fa0438771a98d60a593ba1b52 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/randomdir.pro b/Code/script_idl_mv/astrolib/randomdir.pro new file mode 100644 index 0000000000000000000000000000000000000000..f1b6e054fe678d0b6dca3f0cf1ded9278e036ab2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/randomgam.pro b/Code/script_idl_mv/astrolib/randomgam.pro new file mode 100644 index 0000000000000000000000000000000000000000..5a76873f4531c3c1f38bad5ff08aee9da775e7d0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/randomp.pro b/Code/script_idl_mv/astrolib/randomp.pro new file mode 100644 index 0000000000000000000000000000000000000000..1587d090467b4e71985177f93e8634ee1f196fc5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/randomwish.pro b/Code/script_idl_mv/astrolib/randomwish.pro new file mode 100644 index 0000000000000000000000000000000000000000..caf104b89e6be0e2423da9c89fde47c269d35c47 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rdfits_struct.pro b/Code/script_idl_mv/astrolib/rdfits_struct.pro new file mode 100644 index 0000000000000000000000000000000000000000..7400769041a1cb10e7cdaa058eb9e94ad45f26a0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rdfloat.pro b/Code/script_idl_mv/astrolib/rdfloat.pro new file mode 100644 index 0000000000000000000000000000000000000000..f4f22442c6a92f16d95bbaecb68c19f386d4ac28 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rdplot.pro b/Code/script_idl_mv/astrolib/rdplot.pro new file mode 100644 index 0000000000000000000000000000000000000000..d08bf05f780674ed2fa083f5b1c26d2d161f671a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rdpsf.pro b/Code/script_idl_mv/astrolib/rdpsf.pro new file mode 100644 index 0000000000000000000000000000000000000000..9e72781c9cd1fc26d5c70bb5997ce502eb4dd8c0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/read_fmr.pro b/Code/script_idl_mv/astrolib/read_fmr.pro new file mode 100644 index 0000000000000000000000000000000000000000..b4c7199f34b8d6a404ec239d0cf83f3911dda041 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/read_ipac_table.pro b/Code/script_idl_mv/astrolib/read_ipac_table.pro new file mode 100644 index 0000000000000000000000000000000000000000..cf98664f5aa1a395653d33ee8271018b4290d574 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/read_ipac_var.pro b/Code/script_idl_mv/astrolib/read_ipac_var.pro new file mode 100644 index 0000000000000000000000000000000000000000..0d0f49db883c005bbbe893e38cfcd3e066f4bec7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/read_key.pro b/Code/script_idl_mv/astrolib/read_key.pro new file mode 100644 index 0000000000000000000000000000000000000000..4e04bac1cc2e71dd05800740e30266fb434f7b47 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/readcol.pro b/Code/script_idl_mv/astrolib/readcol.pro new file mode 100644 index 0000000000000000000000000000000000000000..e88900b74a0083bdf950bc50a688106115cd5180 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 ) + + + 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 + + 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/Code/script_idl_mv/astrolib/readfits.pro b/Code/script_idl_mv/astrolib/readfits.pro new file mode 100644 index 0000000000000000000000000000000000000000..20c62c65ecca1aff501a0a56f7df3621895674f9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 ; Integer*2 + 32: IDL_type = 3 ; Integer*4 + 64: IDL_type = 14 ; Integer*8 + -32: IDL_type = 4 ; Real*4 + -64: IDL_type = 5 ; Real*8 + 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/Code/script_idl_mv/astrolib/readfmt.pro b/Code/script_idl_mv/astrolib/readfmt.pro new file mode 100644 index 0000000000000000000000000000000000000000..efdd2d5f5ce42e65bd95aa25663418e2e61574c9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/recpol.pro b/Code/script_idl_mv/astrolib/recpol.pro new file mode 100644 index 0000000000000000000000000000000000000000..50701a19b580038b7670db9dd6be673162b9739d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rem_dup.pro b/Code/script_idl_mv/astrolib/rem_dup.pro new file mode 100644 index 0000000000000000000000000000000000000000..14ce10972b8b35e3fecbf5d58f062c21bdd11d0b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/remchar.pro b/Code/script_idl_mv/astrolib/remchar.pro new file mode 100644 index 0000000000000000000000000000000000000000..15977356e7b1fa8b2faccf971f7d7767b63c61dc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/remove.pro b/Code/script_idl_mv/astrolib/remove.pro new file mode 100644 index 0000000000000000000000000000000000000000..97f2a758ee9fab414a776ecbf50c1542f5323459 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/repchr.pro b/Code/script_idl_mv/astrolib/repchr.pro new file mode 100644 index 0000000000000000000000000000000000000000..94f1c84b2e4a41566cad6f9d69e287a31bc81fd8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/repstr.pro b/Code/script_idl_mv/astrolib/repstr.pro new file mode 100644 index 0000000000000000000000000000000000000000..326a671622320241c04b9718cdd6b646cc8f371d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/resistant_mean.pro b/Code/script_idl_mv/astrolib/resistant_mean.pro new file mode 100644 index 0000000000000000000000000000000000000000..da623638d007963090c1688eee6a2a2df9a0056d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rhotheta.pro b/Code/script_idl_mv/astrolib/rhotheta.pro new file mode 100644 index 0000000000000000000000000000000000000000..5ceec75e252c29d99c608e24cd4693477aaf5aed --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rinter.pro b/Code/script_idl_mv/astrolib/rinter.pro new file mode 100644 index 0000000000000000000000000000000000000000..702d9e9fe6d0dfd4bc0341bbee8292d25731bec6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/rob_checkfit.pro b/Code/script_idl_mv/astrolib/rob_checkfit.pro new file mode 100644 index 0000000000000000000000000000000000000000..17696066f9c5f32f470eb2eb052f626e3b18d85d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/robust_linefit.pro b/Code/script_idl_mv/astrolib/robust_linefit.pro new file mode 100644 index 0000000000000000000000000000000000000000..817a0f07a5be2813bdedd63a306ced18fa34ec07 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/robust_poly_fit.pro b/Code/script_idl_mv/astrolib/robust_poly_fit.pro new file mode 100644 index 0000000000000000000000000000000000000000..149a3e7974719c41369abd1021dc7938af2c145b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/robust_sigma.pro b/Code/script_idl_mv/astrolib/robust_sigma.pro new file mode 100644 index 0000000000000000000000000000000000000000..e43ef4c83096b45c189df92ea8ced2c39bb8d379 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/safe_correlate.pro b/Code/script_idl_mv/astrolib/safe_correlate.pro new file mode 100644 index 0000000000000000000000000000000000000000..c44ed3ab4189c5a4d6a56e9141e251b9cd592cb4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/select_w.pro b/Code/script_idl_mv/astrolib/select_w.pro new file mode 100644 index 0000000000000000000000000000000000000000..24971819cf4e0d122ee44525bc15f44bf4a274ea --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sigma_filter.pro b/Code/script_idl_mv/astrolib/sigma_filter.pro new file mode 100644 index 0000000000000000000000000000000000000000..9cc2b6014c78dc58ede3634a0f83a50a2a47e00c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sigrange.pro b/Code/script_idl_mv/astrolib/sigrange.pro new file mode 100644 index 0000000000000000000000000000000000000000..8d36123da8644d8fe20499aa4fdd395e302cb2eb --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sip_eval.pro b/Code/script_idl_mv/astrolib/sip_eval.pro new file mode 100644 index 0000000000000000000000000000000000000000..e7ec74e047cf6eae351eef3a9963446216d27d24 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sixlin.pro b/Code/script_idl_mv/astrolib/sixlin.pro new file mode 100644 index 0000000000000000000000000000000000000000..24fe6891e184bdd18cb5f29bb45036d868627bd2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sixty.pro b/Code/script_idl_mv/astrolib/sixty.pro new file mode 100644 index 0000000000000000000000000000000000000000..126136c2b0b94726ae1ffbe7ab5d422f59c3d3e8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sky.pro b/Code/script_idl_mv/astrolib/sky.pro new file mode 100644 index 0000000000000000000000000000000000000000..317d758a20fe6838818a4fa27e53972b548e0dd7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/skyadj_cube.pro b/Code/script_idl_mv/astrolib/skyadj_cube.pro new file mode 100644 index 0000000000000000000000000000000000000000..2a15f3706c89a0484a5966dd6c16331c762dd05f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sphdist.pro b/Code/script_idl_mv/astrolib/sphdist.pro new file mode 100644 index 0000000000000000000000000000000000000000..2e7cdfab4879ee1373eff0acbe5573953783af5d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/srcor.pro b/Code/script_idl_mv/astrolib/srcor.pro new file mode 100644 index 0000000000000000000000000000000000000000..cb3d36223b9512427cdab5137011281aeed8fb88 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/st_diskread.pro b/Code/script_idl_mv/astrolib/st_diskread.pro new file mode 100644 index 0000000000000000000000000000000000000000..61d11711b92895b447366e290e0d4f490629ccfa --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/starast.pro b/Code/script_idl_mv/astrolib/starast.pro new file mode 100644 index 0000000000000000000000000000000000000000..a120d24b2825dbc41e0c63afd1a3d237fd2a5386 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/store_array.pro b/Code/script_idl_mv/astrolib/store_array.pro new file mode 100644 index 0000000000000000000000000000000000000000..8e4f9888d75ca039d541046b0fec1005ad68b64e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/str_index.pro b/Code/script_idl_mv/astrolib/str_index.pro new file mode 100644 index 0000000000000000000000000000000000000000..d3c9b132f28c903d99631e9b59eef533f25d5066 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/strcompress2.pro b/Code/script_idl_mv/astrolib/strcompress2.pro new file mode 100644 index 0000000000000000000000000000000000000000..3c34055d8d432b48a32ce6f391873fc444bcced6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/strn.pro b/Code/script_idl_mv/astrolib/strn.pro new file mode 100644 index 0000000000000000000000000000000000000000..45b92bcf62a9a6bb1accb3de8971bafc6348f6c4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/strnumber.pro b/Code/script_idl_mv/astrolib/strnumber.pro new file mode 100644 index 0000000000000000000000000000000000000000..458630186a846a6ae5f39cab543c3f47eb4ec756 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/substar.pro b/Code/script_idl_mv/astrolib/substar.pro new file mode 100644 index 0000000000000000000000000000000000000000..9ece34e4ae217cb7e26f5452be17953117e02411 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sunpos.pro b/Code/script_idl_mv/astrolib/sunpos.pro new file mode 100644 index 0000000000000000000000000000000000000000..8b25c82e8735bbdb1feb25aa3e246feebe19c95e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sunsymbol.pro b/Code/script_idl_mv/astrolib/sunsymbol.pro new file mode 100644 index 0000000000000000000000000000000000000000..5bd2558708caaac9d7568e5560f5236e2e8b5faa --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxaddhist.pro b/Code/script_idl_mv/astrolib/sxaddhist.pro new file mode 100644 index 0000000000000000000000000000000000000000..7597d1583962f2521bff9a57d432c3828dd84dc6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxaddpar.pro b/Code/script_idl_mv/astrolib/sxaddpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..fa95b949bde988547d272534ff612a819574c2c8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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 $ + if (n_elements(missing) eq 1) || keyword_set(null) then $ + save_as_null = 1 else $ + message = 'keyword value (third parameter) is not defined' + 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/Code/script_idl_mv/astrolib/sxdelpar.pro b/Code/script_idl_mv/astrolib/sxdelpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..2cd73a5ec1f0a7201b5b8bb6ff6b1f9afadb28f2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxginfo.pro b/Code/script_idl_mv/astrolib/sxginfo.pro new file mode 100644 index 0000000000000000000000000000000000000000..e12ae35983a19bc19470dc280254cc4b73cd937d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxgpar.pro b/Code/script_idl_mv/astrolib/sxgpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..0c2f10d1aa21bcee97112ade22c045fc5719d8c5 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxgread.pro b/Code/script_idl_mv/astrolib/sxgread.pro new file mode 100644 index 0000000000000000000000000000000000000000..48de9364fff300c292c1e3c99cf67690f2b1bb4a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxhcopy.pro b/Code/script_idl_mv/astrolib/sxhcopy.pro new file mode 100644 index 0000000000000000000000000000000000000000..e0736c3add4ef03070b917efd8fce7b142f64fc7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxhmake.pro b/Code/script_idl_mv/astrolib/sxhmake.pro new file mode 100644 index 0000000000000000000000000000000000000000..e45675fe326ab425c3f5da689ebc0a0ad4736ff8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxhread.pro b/Code/script_idl_mv/astrolib/sxhread.pro new file mode 100644 index 0000000000000000000000000000000000000000..43e186952d57e7c308fb6d4e967fe6c759b5d605 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxhwrite.pro b/Code/script_idl_mv/astrolib/sxhwrite.pro new file mode 100644 index 0000000000000000000000000000000000000000..0ad4848274866bec3672d17653a1baa5c5382ce9 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxmake.pro b/Code/script_idl_mv/astrolib/sxmake.pro new file mode 100644 index 0000000000000000000000000000000000000000..54fc315fb3d16960a46c146258000ba3378a5f61 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxopen.pro b/Code/script_idl_mv/astrolib/sxopen.pro new file mode 100644 index 0000000000000000000000000000000000000000..f47908ff230374a393726d2e665a27ee7074bd55 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxpar.pro b/Code/script_idl_mv/astrolib/sxpar.pro new file mode 100644 index 0000000000000000000000000000000000000000..d137cf4d49c584647624ab9fb85db0024998a13d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxread.pro b/Code/script_idl_mv/astrolib/sxread.pro new file mode 100644 index 0000000000000000000000000000000000000000..4a255ef1c2c1c66f0dcd5535b30981c2f4a47f35 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/sxwrite.pro b/Code/script_idl_mv/astrolib/sxwrite.pro new file mode 100644 index 0000000000000000000000000000000000000000..a106095077d3fa66314be80e297c4902348c7476 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_aper.pro b/Code/script_idl_mv/astrolib/t_aper.pro new file mode 100644 index 0000000000000000000000000000000000000000..8a9b24c056cbe820c189e1cfa83486e3b2aad71b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_find.pro b/Code/script_idl_mv/astrolib/t_find.pro new file mode 100644 index 0000000000000000000000000000000000000000..e94ef07e86b6452e3cfecc2b46ecde44900f78a3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_getpsf.pro b/Code/script_idl_mv/astrolib/t_getpsf.pro new file mode 100644 index 0000000000000000000000000000000000000000..f08cb8a7a96d2c141742dfc3f294f1e5d258d2a2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_group.pro b/Code/script_idl_mv/astrolib/t_group.pro new file mode 100644 index 0000000000000000000000000000000000000000..011516f400e99477e02d081b06c36bf3cab8adf2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_nstar.pro b/Code/script_idl_mv/astrolib/t_nstar.pro new file mode 100644 index 0000000000000000000000000000000000000000..453c9806e15ae0581d03702278a327f10d06506e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/t_substar.pro b/Code/script_idl_mv/astrolib/t_substar.pro new file mode 100644 index 0000000000000000000000000000000000000000..b09bce2b0487ba0e36dd9074d9ff9b8b3bf6689a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tabinv.pro b/Code/script_idl_mv/astrolib/tabinv.pro new file mode 100644 index 0000000000000000000000000000000000000000..1feafd8abb39b3fa7c7559c24560699bfc040df3 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tag_exist.pro b/Code/script_idl_mv/astrolib/tag_exist.pro new file mode 100644 index 0000000000000000000000000000000000000000..8006edcc6b6e6e9239f97037ff8b83c46ae3b86c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbdelcol.pro b/Code/script_idl_mv/astrolib/tbdelcol.pro new file mode 100644 index 0000000000000000000000000000000000000000..f9f7479918505147a21fc208ac2eebfdee944196 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbdelrow.pro b/Code/script_idl_mv/astrolib/tbdelrow.pro new file mode 100644 index 0000000000000000000000000000000000000000..7926cd222eb30e9e69702bd1bec4dc5d019aa07b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbget.pro b/Code/script_idl_mv/astrolib/tbget.pro new file mode 100644 index 0000000000000000000000000000000000000000..f6a6720314be6e023e72566a62d07533753b0ea2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbhelp.pro b/Code/script_idl_mv/astrolib/tbhelp.pro new file mode 100644 index 0000000000000000000000000000000000000000..64db8c8c6dc22dc9c451cb319dbc99d8ec7d64cc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbinfo.pro b/Code/script_idl_mv/astrolib/tbinfo.pro new file mode 100644 index 0000000000000000000000000000000000000000..0d2c8c205703abbafc71dcd1abd4cdd132c3c5e0 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbprint.pro b/Code/script_idl_mv/astrolib/tbprint.pro new file mode 100644 index 0000000000000000000000000000000000000000..dcebebf74f9afec10654d5a4a97870d640629c40 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tbsize.pro b/Code/script_idl_mv/astrolib/tbsize.pro new file mode 100644 index 0000000000000000000000000000000000000000..36dc68d47a4c3de718edce3cef3d28de26b30e56 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tdb2tdt.pro b/Code/script_idl_mv/astrolib/tdb2tdt.pro new file mode 100644 index 0000000000000000000000000000000000000000..86e1e1c5b06613855786110a04969b9e56e67b7e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ten.pro b/Code/script_idl_mv/astrolib/ten.pro new file mode 100644 index 0000000000000000000000000000000000000000..e3b894c8276ad3f066505513d49b1d2e8bc67a0a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tenv.pro b/Code/script_idl_mv/astrolib/tenv.pro new file mode 100644 index 0000000000000000000000000000000000000000..c0292356d1ffd520c24926a0730dbc7f51a7b655 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/textclose.pro b/Code/script_idl_mv/astrolib/textclose.pro new file mode 100644 index 0000000000000000000000000000000000000000..e05be1092e08476ae0289bb41eafa1c10851dc98 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/textopen.pro b/Code/script_idl_mv/astrolib/textopen.pro new file mode 100644 index 0000000000000000000000000000000000000000..64325393562e1d76464be329154b5ccbaae76649 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tic_one.pro b/Code/script_idl_mv/astrolib/tic_one.pro new file mode 100644 index 0000000000000000000000000000000000000000..35214717d1defc26aa3af4dd0b044dff504c2f09 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ticlabels.pro b/Code/script_idl_mv/astrolib/ticlabels.pro new file mode 100644 index 0000000000000000000000000000000000000000..91d07e952a3340ab4a7315a36c801177b6337325 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/ticpos.pro b/Code/script_idl_mv/astrolib/ticpos.pro new file mode 100644 index 0000000000000000000000000000000000000000..92e621ac670eac47caa3e07bbe85b8743262b14a --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tics.pro b/Code/script_idl_mv/astrolib/tics.pro new file mode 100644 index 0000000000000000000000000000000000000000..ab28918d7678bdef704689f6af778e790925c630 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tnx_eval.pro b/Code/script_idl_mv/astrolib/tnx_eval.pro new file mode 100644 index 0000000000000000000000000000000000000000..d5dcbba8a86588c9627d90c8222452dacd5e21a7 --- /dev/null +++ b/Code/script_idl_mv/astrolib/tnx_eval.pro @@ -0,0 +1,134 @@ +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 current procedures only +; supports simple polynomials and not Legendre or Chebyshev polynomials +; +; 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 +; (polynomial) 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 +; Use post-V6.0 notation W. Landsman Feb 2015 +;- + +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 += 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 += xin^m * lngcor.coeff[icount] + icount++ + ENDFOR + FOR n=0,lngcor.etaorder-1 DO BEGIN + 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 += 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 += 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 += xin^m * latcor.coeff[icount] + icount++ + ENDFOR + FOR n=0,latcor.etaorder-1 DO BEGIN + 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 += xin^m * yin^n * latcor.coeff[icount] + icount++ + ENDFOR + ENDFOR +ENDIF + +xp = x+xp +yp = y+yp + +return, [[xp],[yp]] + +end diff --git a/Code/script_idl_mv/astrolib/to_hex.pro b/Code/script_idl_mv/astrolib/to_hex.pro new file mode 100644 index 0000000000000000000000000000000000000000..42033975adef58e7815f8ccbc1f7fcf7d79d7d1b --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tpv_eval.pro b/Code/script_idl_mv/astrolib/tpv_eval.pro new file mode 100644 index 0000000000000000000000000000000000000000..3f7c8d40e5b36f180da2b308be62643027cb208a --- /dev/null +++ b/Code/script_idl_mv/astrolib/tpv_eval.pro @@ -0,0 +1,92 @@ +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 +;- +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]*y2*y2 + 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 + 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 + endif + + endif + +return, [[xp],[yp]] + +end diff --git a/Code/script_idl_mv/astrolib/transform_coeff.pro b/Code/script_idl_mv/astrolib/transform_coeff.pro new file mode 100644 index 0000000000000000000000000000000000000000..b8094f1b9db30b85f0020c66628bdc971d0fb5ee --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/trapzd.pro b/Code/script_idl_mv/astrolib/trapzd.pro new file mode 100644 index 0000000000000000000000000000000000000000..11e0cda795109365868489ec20265ae443c1831f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tsc.pro b/Code/script_idl_mv/astrolib/tsc.pro new file mode 100644 index 0000000000000000000000000000000000000000..0ddecd7dddc86597f291463dea355e982a84ff4c --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tsum.pro b/Code/script_idl_mv/astrolib/tsum.pro new file mode 100644 index 0000000000000000000000000000000000000000..00a87450dd479d8518d94965a38bb12c0204edfc --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tvbox.pro b/Code/script_idl_mv/astrolib/tvbox.pro new file mode 100644 index 0000000000000000000000000000000000000000..58f13a46a5fe46e7e1193ddc455b6167561b3db8 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tvcircle.pro b/Code/script_idl_mv/astrolib/tvcircle.pro new file mode 100644 index 0000000000000000000000000000000000000000..4693e0742f5e8470d24017710e4e2d2a71a331ae --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tvellipse.pro b/Code/script_idl_mv/astrolib/tvellipse.pro new file mode 100644 index 0000000000000000000000000000000000000000..6f98274f3979f9e47d43ad12eafde2951a87b7e2 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tvlaser.pro b/Code/script_idl_mv/astrolib/tvlaser.pro new file mode 100644 index 0000000000000000000000000000000000000000..c4c3b2f4aa7055f181fcf746707747405ef08f21 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/tvlist.pro b/Code/script_idl_mv/astrolib/tvlist.pro new file mode 100644 index 0000000000000000000000000000000000000000..3acc4da5068b7a9a3f6c5dcccd6894a5bee51afd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/unzoom_xy.pro b/Code/script_idl_mv/astrolib/unzoom_xy.pro new file mode 100644 index 0000000000000000000000000000000000000000..ed49b9e67587bc8b0ceb54410e0de379a600331f --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/update_distort.pro b/Code/script_idl_mv/astrolib/update_distort.pro new file mode 100644 index 0000000000000000000000000000000000000000..1c84b1a0f2c56d7af3496daeca96ffaafcade888 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/uvbybeta.pro b/Code/script_idl_mv/astrolib/uvbybeta.pro new file mode 100644 index 0000000000000000000000000000000000000000..45c93797af5dcc7b9db70338c316dc419aef022d --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/vactoair.pro b/Code/script_idl_mv/astrolib/vactoair.pro new file mode 100644 index 0000000000000000000000000000000000000000..d0dc2a997f5d354f9023243d57e49bbfac1977dd --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/valid_num.pro b/Code/script_idl_mv/astrolib/valid_num.pro new file mode 100644 index 0000000000000000000000000000000000000000..05b2a205bc0bfd60f96c83525a50a68682e1c1be --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/vect.pro b/Code/script_idl_mv/astrolib/vect.pro new file mode 100644 index 0000000000000000000000000000000000000000..1990abc291ee78d96f55ca4f22d7129ce84797c6 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/vsym.pro b/Code/script_idl_mv/astrolib/vsym.pro new file mode 100644 index 0000000000000000000000000000000000000000..9f78c032106fad27dd5050e7633c04d5294bfa85 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/wcs_check_ctype.pro b/Code/script_idl_mv/astrolib/wcs_check_ctype.pro new file mode 100644 index 0000000000000000000000000000000000000000..b613c9d91437a543e72354a0833dfb0448614c47 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/wcs_demo.pro b/Code/script_idl_mv/astrolib/wcs_demo.pro new file mode 100644 index 0000000000000000000000000000000000000000..d74517627e26b31e825992af4f03c5c898d3631e --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/wcs_getpole.pro b/Code/script_idl_mv/astrolib/wcs_getpole.pro new file mode 100644 index 0000000000000000000000000000000000000000..e317cee60ba6ffafddf32dba7e32cc28e8ff8208 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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/Code/script_idl_mv/astrolib/wcs_rotate.pro b/Code/script_idl_mv/astrolib/wcs_rotate.pro new file mode 100644 index 0000000000000000000000000000000000000000..e9b64b47c6891aca571a850564457681cc7afae4 --- /dev/null +++ b/Code/script_idl_mv/astrolib/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