From 7f8ebf7bcf2b73fe247d6a1c4450caeded0b4e6c Mon Sep 17 00:00:00 2001 From: fvitello Date: Wed, 20 Jun 2018 17:02:45 +0200 Subject: [PATCH] updated release --- Code/script_idl_mv/.DS_Store | Bin 10244 -> 0 bytes Code/script_idl_mv/astrolib/.idlwave_catalog | 583 ---- Code/script_idl_mv/astrolib/ad2xy.pro | 326 -- Code/script_idl_mv/astrolib/add_distort.pro | 161 - Code/script_idl_mv/astrolib/adstring.pro | 208 -- Code/script_idl_mv/astrolib/adxy.pro | 139 - Code/script_idl_mv/astrolib/airtovac.pro | 67 - Code/script_idl_mv/astrolib/aitoff.pro | 56 - Code/script_idl_mv/astrolib/aitoff_grid.pro | 144 - Code/script_idl_mv/astrolib/al_legend.pro | 572 ---- Code/script_idl_mv/astrolib/al_legendtest.pro | 85 - Code/script_idl_mv/astrolib/altaz2hadec.pro | 69 - Code/script_idl_mv/astrolib/aper.pro | 476 --- Code/script_idl_mv/astrolib/arcbar.pro | 155 - Code/script_idl_mv/astrolib/arrows.pro | 138 - Code/script_idl_mv/astrolib/asinh.pro | 40 - Code/script_idl_mv/astrolib/astdisp.pro | 98 - Code/script_idl_mv/astrolib/astro.pro | 175 - Code/script_idl_mv/astrolib/astrolib.pro | 51 - Code/script_idl_mv/astrolib/autohist.pro | 106 - Code/script_idl_mv/astrolib/avg.pro | 111 - Code/script_idl_mv/astrolib/baryvel.pro | 340 -- Code/script_idl_mv/astrolib/biweight_mean.pro | 88 - Code/script_idl_mv/astrolib/blink.pro | 114 - Code/script_idl_mv/astrolib/blkshift.pro | 231 -- Code/script_idl_mv/astrolib/boost_array.pro | 130 - Code/script_idl_mv/astrolib/boxave.pro | 128 - Code/script_idl_mv/astrolib/bprecess.pro | 219 -- Code/script_idl_mv/astrolib/break_path.pro | 140 - Code/script_idl_mv/astrolib/bsort.pro | 103 - Code/script_idl_mv/astrolib/calz_unred.pro | 79 - Code/script_idl_mv/astrolib/ccm_unred.pro | 147 - Code/script_idl_mv/astrolib/check_fits.pro | 227 -- Code/script_idl_mv/astrolib/checksum32.pro | 125 - Code/script_idl_mv/astrolib/cic.pro | 417 --- Code/script_idl_mv/astrolib/cirrange.pro | 49 - Code/script_idl_mv/astrolib/cleanplot.pro | 150 - Code/script_idl_mv/astrolib/cntrd.pro | 245 -- Code/script_idl_mv/astrolib/co_aberration.pro | 92 - Code/script_idl_mv/astrolib/co_nutate.pro | 115 - Code/script_idl_mv/astrolib/co_refract.pro | 186 -- .../script_idl_mv/astrolib/compare_struct.pro | 239 -- Code/script_idl_mv/astrolib/concat_dir.pro | 110 - Code/script_idl_mv/astrolib/cons_dec.pro | 116 - Code/script_idl_mv/astrolib/cons_ra.pro | 119 - Code/script_idl_mv/astrolib/convolve.pro | 178 -- Code/script_idl_mv/astrolib/copy_struct.pro | 250 -- .../astrolib/copy_struct_inx.pro | 287 -- Code/script_idl_mv/astrolib/correl_images.pro | 210 -- .../astrolib/correl_optimize.pro | 125 - .../astrolib/corrmat_analyze.pro | 174 - Code/script_idl_mv/astrolib/cosmo_param.pro | 106 - Code/script_idl_mv/astrolib/cr_reject.pro | 886 ------ Code/script_idl_mv/astrolib/create_struct.pro | 309 -- Code/script_idl_mv/astrolib/cspline.pro | 79 - Code/script_idl_mv/astrolib/ct2lst.pro | 109 - Code/script_idl_mv/astrolib/curs.pro | 135 - Code/script_idl_mv/astrolib/curval.pro | 304 -- Code/script_idl_mv/astrolib/dao_value.pro | 87 - Code/script_idl_mv/astrolib/daoerf.pro | 58 - Code/script_idl_mv/astrolib/date.pro | 75 - Code/script_idl_mv/astrolib/date_conv.pro | 449 --- Code/script_idl_mv/astrolib/daycnv.pro | 73 - Code/script_idl_mv/astrolib/db_ent2ext.pro | 121 - Code/script_idl_mv/astrolib/db_ent2host.pro | 134 - Code/script_idl_mv/astrolib/db_info.pro | 218 -- Code/script_idl_mv/astrolib/db_item.pro | 347 -- Code/script_idl_mv/astrolib/db_item_info.pro | 122 - Code/script_idl_mv/astrolib/db_or.pro | 52 - Code/script_idl_mv/astrolib/db_titles.pro | 54 - Code/script_idl_mv/astrolib/dbbuild.pro | 168 - Code/script_idl_mv/astrolib/dbcircle.pro | 208 -- Code/script_idl_mv/astrolib/dbclose.pro | 56 - Code/script_idl_mv/astrolib/dbcompare.pro | 131 - Code/script_idl_mv/astrolib/dbcreate.pro | 522 --- Code/script_idl_mv/astrolib/dbdelete.pro | 142 - Code/script_idl_mv/astrolib/dbedit.pro | 395 --- Code/script_idl_mv/astrolib/dbedit_basic.pro | 157 - Code/script_idl_mv/astrolib/dbext.pro | 85 - Code/script_idl_mv/astrolib/dbext_dbf.pro | 152 - Code/script_idl_mv/astrolib/dbext_ind.pro | 143 - Code/script_idl_mv/astrolib/dbfind.pro | 382 --- Code/script_idl_mv/astrolib/dbfind_entry.pro | 117 - Code/script_idl_mv/astrolib/dbfind_sort.pro | 275 -- Code/script_idl_mv/astrolib/dbfparse.pro | 240 -- Code/script_idl_mv/astrolib/dbget.pro | 106 - Code/script_idl_mv/astrolib/dbhelp.pro | 275 -- Code/script_idl_mv/astrolib/dbindex.pro | 218 -- Code/script_idl_mv/astrolib/dbindex_blk.pro | 49 - Code/script_idl_mv/astrolib/dbmatch.pro | 173 - Code/script_idl_mv/astrolib/dbopen.pro | 411 --- Code/script_idl_mv/astrolib/dbprint.pro | 318 -- Code/script_idl_mv/astrolib/dbput.pro | 78 - Code/script_idl_mv/astrolib/dbrd.pro | 115 - Code/script_idl_mv/astrolib/dbsearch.pro | 139 - Code/script_idl_mv/astrolib/dbsort.pro | 122 - Code/script_idl_mv/astrolib/dbtarget.pro | 93 - Code/script_idl_mv/astrolib/dbtitle.pro | 38 - Code/script_idl_mv/astrolib/dbupdate.pro | 163 - Code/script_idl_mv/astrolib/dbval.pro | 50 - Code/script_idl_mv/astrolib/dbwrt.pro | 195 -- Code/script_idl_mv/astrolib/dbxput.pro | 56 - Code/script_idl_mv/astrolib/dbxval.pro | 71 - Code/script_idl_mv/astrolib/delvarx.pro | 52 - Code/script_idl_mv/astrolib/deredd.pro | 55 - Code/script_idl_mv/astrolib/detabify.pro | 62 - Code/script_idl_mv/astrolib/dist_circle.pro | 97 - Code/script_idl_mv/astrolib/dist_ellipse.pro | 121 - Code/script_idl_mv/astrolib/eci2geo.pro | 81 - Code/script_idl_mv/astrolib/eq2hor.pro | 300 -- Code/script_idl_mv/astrolib/eqpole.pro | 57 - Code/script_idl_mv/astrolib/eqpole_grid.pro | 147 - Code/script_idl_mv/astrolib/euler.pro | 169 - Code/script_idl_mv/astrolib/expand_tilde.pro | 67 - Code/script_idl_mv/astrolib/extast.pro | 714 ----- Code/script_idl_mv/astrolib/extgrp.pro | 88 - Code/script_idl_mv/astrolib/f_format.pro | 112 - Code/script_idl_mv/astrolib/factor.pro | 277 -- Code/script_idl_mv/astrolib/fdecomp.pro | 130 - Code/script_idl_mv/astrolib/file_launch.pro | 108 - Code/script_idl_mv/astrolib/filter_image.pro | 196 -- Code/script_idl_mv/astrolib/find.pro | 464 --- Code/script_idl_mv/astrolib/find_all_dir.pro | 202 -- Code/script_idl_mv/astrolib/find_with_def.pro | 153 - Code/script_idl_mv/astrolib/findpro.pro | 173 - Code/script_idl_mv/astrolib/fitexy.pro | 205 -- .../astrolib/fits_add_checksum.pro | 104 - .../astrolib/fits_ascii_encode.pro | 68 - Code/script_idl_mv/astrolib/fits_cd_fix.pro | 80 - Code/script_idl_mv/astrolib/fits_close.pro | 66 - Code/script_idl_mv/astrolib/fits_help.pro | 119 - Code/script_idl_mv/astrolib/fits_info.pro | 348 -- Code/script_idl_mv/astrolib/fits_open.pro | 459 --- Code/script_idl_mv/astrolib/fits_read.pro | 573 ---- .../astrolib/fits_test_checksum.pro | 109 - Code/script_idl_mv/astrolib/fits_write.pro | 379 --- Code/script_idl_mv/astrolib/fitsdir.pro | 332 -- .../astrolib/fitsrgb_to_tiff.pro | 143 - Code/script_idl_mv/astrolib/flegendre.pro | 74 - Code/script_idl_mv/astrolib/flux2mag.pro | 51 - Code/script_idl_mv/astrolib/fm_unred.pro | 174 - Code/script_idl_mv/astrolib/forprint.pro | 240 -- Code/script_idl_mv/astrolib/frebin.pro | 217 -- Code/script_idl_mv/astrolib/ftab_delrow.pro | 106 - Code/script_idl_mv/astrolib/ftab_ext.pro | 124 - Code/script_idl_mv/astrolib/ftab_help.pro | 103 - Code/script_idl_mv/astrolib/ftab_print.pro | 107 - Code/script_idl_mv/astrolib/ftaddcol.pro | 150 - Code/script_idl_mv/astrolib/ftcreate.pro | 55 - Code/script_idl_mv/astrolib/ftdelcol.pro | 114 - Code/script_idl_mv/astrolib/ftdelrow.pro | 74 - Code/script_idl_mv/astrolib/ftget.pro | 146 - Code/script_idl_mv/astrolib/fthelp.pro | 96 - Code/script_idl_mv/astrolib/fthmod.pro | 63 - Code/script_idl_mv/astrolib/ftinfo.pro | 116 - Code/script_idl_mv/astrolib/ftkeeprow.pro | 41 - Code/script_idl_mv/astrolib/ftprint.pro | 170 - Code/script_idl_mv/astrolib/ftput.pro | 174 - Code/script_idl_mv/astrolib/ftsize.pro | 73 - Code/script_idl_mv/astrolib/ftsort.pro | 97 - Code/script_idl_mv/astrolib/fxaddpar.pro | 718 ----- Code/script_idl_mv/astrolib/fxbaddcol.pro | 382 --- Code/script_idl_mv/astrolib/fxbclose.pro | 101 - Code/script_idl_mv/astrolib/fxbcolnum.pro | 124 - Code/script_idl_mv/astrolib/fxbcreate.pro | 190 -- Code/script_idl_mv/astrolib/fxbdimen.pro | 127 - Code/script_idl_mv/astrolib/fxbfind.pro | 158 - Code/script_idl_mv/astrolib/fxbfindlun.pro | 120 - Code/script_idl_mv/astrolib/fxbfinish.pro | 129 - Code/script_idl_mv/astrolib/fxbgrow.pro | 245 -- Code/script_idl_mv/astrolib/fxbheader.pro | 81 - Code/script_idl_mv/astrolib/fxbhelp.pro | 128 - Code/script_idl_mv/astrolib/fxbhmake.pro | 150 - Code/script_idl_mv/astrolib/fxbintable.pro | 71 - Code/script_idl_mv/astrolib/fxbisopen.pro | 77 - Code/script_idl_mv/astrolib/fxbopen.pro | 350 -- Code/script_idl_mv/astrolib/fxbparse.pro | 162 - Code/script_idl_mv/astrolib/fxbread.pro | 388 --- Code/script_idl_mv/astrolib/fxbreadm.pro | 905 ------ Code/script_idl_mv/astrolib/fxbstate.pro | 74 - Code/script_idl_mv/astrolib/fxbtdim.pro | 90 - Code/script_idl_mv/astrolib/fxbtform.pro | 212 -- Code/script_idl_mv/astrolib/fxbwrite.pro | 282 -- Code/script_idl_mv/astrolib/fxbwritm.pro | 713 ----- Code/script_idl_mv/astrolib/fxfindend.pro | 93 - Code/script_idl_mv/astrolib/fxhclean.pro | 110 - Code/script_idl_mv/astrolib/fxhmake.pro | 252 -- Code/script_idl_mv/astrolib/fxhmodify.pro | 277 -- Code/script_idl_mv/astrolib/fxhread.pro | 119 - Code/script_idl_mv/astrolib/fxmove.pro | 137 - Code/script_idl_mv/astrolib/fxpar.pro | 462 --- Code/script_idl_mv/astrolib/fxparpos.pro | 85 - Code/script_idl_mv/astrolib/fxposit.pro | 267 -- Code/script_idl_mv/astrolib/fxread.pro | 588 ---- Code/script_idl_mv/astrolib/fxwrite.pro | 312 -- Code/script_idl_mv/astrolib/gal_flat.pro | 94 - Code/script_idl_mv/astrolib/gal_uvw.pro | 130 - Code/script_idl_mv/astrolib/galage.pro | 130 - Code/script_idl_mv/astrolib/gaussian.pro | 107 - Code/script_idl_mv/astrolib/gcirc.pro | 123 - Code/script_idl_mv/astrolib/gcntrd.pro | 326 -- Code/script_idl_mv/astrolib/geo2eci.pro | 79 - Code/script_idl_mv/astrolib/geo2geodetic.pro | 153 - Code/script_idl_mv/astrolib/geo2mag.pro | 103 - Code/script_idl_mv/astrolib/geodetic2geo.pro | 125 - Code/script_idl_mv/astrolib/get_coords.pro | 165 - Code/script_idl_mv/astrolib/get_date.pro | 109 - Code/script_idl_mv/astrolib/get_equinox.pro | 101 - Code/script_idl_mv/astrolib/get_juldate.pro | 44 - .../astrolib/get_pipe_filesize.pro | 57 - Code/script_idl_mv/astrolib/getopt.pro | 95 - Code/script_idl_mv/astrolib/getpro.pro | 126 - Code/script_idl_mv/astrolib/getpsf.pro | 405 --- Code/script_idl_mv/astrolib/getrot.pro | 168 - Code/script_idl_mv/astrolib/gettok.pro | 84 - Code/script_idl_mv/astrolib/getwrd.pro | 154 - Code/script_idl_mv/astrolib/glactc.pro | 140 - Code/script_idl_mv/astrolib/glactc_pm.pro | 193 -- Code/script_idl_mv/astrolib/group.pro | 107 - Code/script_idl_mv/astrolib/gsss_stdast.pro | 105 - Code/script_idl_mv/astrolib/gsssadxy.pro | 174 - Code/script_idl_mv/astrolib/gsssextast.pro | 99 - Code/script_idl_mv/astrolib/gsssxyad.pro | 116 - Code/script_idl_mv/astrolib/hadec2altaz.pro | 74 - Code/script_idl_mv/astrolib/hastrom.pro | 317 -- Code/script_idl_mv/astrolib/hboxave.pro | 162 - Code/script_idl_mv/astrolib/hcongrid.pro | 302 -- Code/script_idl_mv/astrolib/headfits.pro | 118 - Code/script_idl_mv/astrolib/helio.pro | 189 -- Code/script_idl_mv/astrolib/helio_jd.pro | 102 - Code/script_idl_mv/astrolib/helio_rv.pro | 145 - Code/script_idl_mv/astrolib/hermite.pro | 129 - Code/script_idl_mv/astrolib/heuler.pro | 169 - Code/script_idl_mv/astrolib/hextract.pro | 205 -- Code/script_idl_mv/astrolib/hgrep.pro | 65 - Code/script_idl_mv/astrolib/histogauss.pro | 196 -- Code/script_idl_mv/astrolib/hor2eq.pro | 256 -- Code/script_idl_mv/astrolib/host_to_ieee.pro | 98 - Code/script_idl_mv/astrolib/hprecess.pro | 134 - Code/script_idl_mv/astrolib/hprint.pro | 100 - Code/script_idl_mv/astrolib/hrebin.pro | 277 -- Code/script_idl_mv/astrolib/hreverse.pro | 165 - Code/script_idl_mv/astrolib/hrot.pro | 251 -- Code/script_idl_mv/astrolib/hrotate.pro | 214 -- Code/script_idl_mv/astrolib/ieee_to_host.pro | 104 - Code/script_idl_mv/astrolib/imcontour.pro | 335 -- Code/script_idl_mv/astrolib/imdbase.pro | 205 -- Code/script_idl_mv/astrolib/imf.pro | 129 - Code/script_idl_mv/astrolib/imlist.pro | 231 -- Code/script_idl_mv/astrolib/irafdir.pro | 185 -- Code/script_idl_mv/astrolib/irafrd.pro | 300 -- Code/script_idl_mv/astrolib/irafwrt.pro | 249 -- Code/script_idl_mv/astrolib/is_ieee_big.pro | 32 - Code/script_idl_mv/astrolib/isarray.pro | 20 - Code/script_idl_mv/astrolib/ismeuv.pro | 176 -- Code/script_idl_mv/astrolib/jdcnv.pro | 67 - Code/script_idl_mv/astrolib/jplephinterp.pro | 745 ----- Code/script_idl_mv/astrolib/jplephread.pro | 404 --- Code/script_idl_mv/astrolib/jplephtest.pro | 194 -- Code/script_idl_mv/astrolib/jprecess.pro | 226 -- Code/script_idl_mv/astrolib/juldate.pro | 121 - Code/script_idl_mv/astrolib/ksone.pro | 125 - Code/script_idl_mv/astrolib/kstwo.pro | 100 - Code/script_idl_mv/astrolib/kuiperone.pro | 126 - Code/script_idl_mv/astrolib/kuipertwo.pro | 132 - Code/script_idl_mv/astrolib/lineid_plot.pro | 261 -- Code/script_idl_mv/astrolib/linmix_err.pro | 1308 -------- Code/script_idl_mv/astrolib/linterp.pro | 119 - .../script_idl_mv/astrolib/list_with_path.pro | 70 - Code/script_idl_mv/astrolib/lsf_rotate.pro | 80 - Code/script_idl_mv/astrolib/lumdist.pro | 123 - Code/script_idl_mv/astrolib/mag2flux.pro | 51 - Code/script_idl_mv/astrolib/mag2geo.pro | 97 - Code/script_idl_mv/astrolib/make_2d.pro | 57 - Code/script_idl_mv/astrolib/make_astr.pro | 258 -- Code/script_idl_mv/astrolib/match.pro | 170 - Code/script_idl_mv/astrolib/match2.pro | 169 - Code/script_idl_mv/astrolib/max_entropy.pro | 79 - .../script_idl_mv/astrolib/max_likelihood.pro | 93 - Code/script_idl_mv/astrolib/meanclip.pro | 86 - Code/script_idl_mv/astrolib/medarr.pro | 132 - Code/script_idl_mv/astrolib/medsmooth.pro | 71 - Code/script_idl_mv/astrolib/minf_bracket.pro | 130 - .../script_idl_mv/astrolib/minf_conj_grad.pro | 127 - .../script_idl_mv/astrolib/minf_parabol_d.pro | 173 - .../script_idl_mv/astrolib/minf_parabolic.pro | 147 - Code/script_idl_mv/astrolib/minmax.pro | 71 - Code/script_idl_mv/astrolib/mkhdr.pro | 169 - Code/script_idl_mv/astrolib/mlinmix_err.pro | 878 ------ Code/script_idl_mv/astrolib/mmm.pro | 310 -- Code/script_idl_mv/astrolib/modfits.pro | 321 -- Code/script_idl_mv/astrolib/month_cnv.pro | 68 - Code/script_idl_mv/astrolib/moonpos.pro | 250 -- Code/script_idl_mv/astrolib/mphase.pro | 56 - Code/script_idl_mv/astrolib/mrandomn.pro | 80 - Code/script_idl_mv/astrolib/mrd_hread.pro | 135 - Code/script_idl_mv/astrolib/mrd_skip.pro | 72 - Code/script_idl_mv/astrolib/mrd_struct.pro | 219 -- Code/script_idl_mv/astrolib/mrdfits.pro | 2801 ----------------- Code/script_idl_mv/astrolib/multinom.pro | 81 - Code/script_idl_mv/astrolib/multiplot.pro | 555 ---- Code/script_idl_mv/astrolib/mwrfits.pro | 1731 ---------- Code/script_idl_mv/astrolib/n_bytes.pro | 52 - Code/script_idl_mv/astrolib/ngp.pro | 201 -- Code/script_idl_mv/astrolib/nint.pro | 55 - Code/script_idl_mv/astrolib/nstar.pro | 485 --- Code/script_idl_mv/astrolib/nulltrim.pro | 26 - Code/script_idl_mv/astrolib/nutate.pro | 145 - Code/script_idl_mv/astrolib/observatory.pro | 440 --- Code/script_idl_mv/astrolib/one_arrow.pro | 115 - Code/script_idl_mv/astrolib/one_ray.pro | 62 - Code/script_idl_mv/astrolib/oploterror.pro | 308 -- Code/script_idl_mv/astrolib/ordinal.pro | 37 - Code/script_idl_mv/astrolib/partvelvec.pro | 250 -- Code/script_idl_mv/astrolib/pca.pro | 264 -- Code/script_idl_mv/astrolib/pent.pro | 145 - Code/script_idl_mv/astrolib/permute.pro | 122 - Code/script_idl_mv/astrolib/pixcolor.pro | 100 - Code/script_idl_mv/astrolib/pixwt.pro | 257 -- Code/script_idl_mv/astrolib/pkfit.pro | 247 -- Code/script_idl_mv/astrolib/planck.pro | 71 - Code/script_idl_mv/astrolib/planet_coords.pro | 169 - Code/script_idl_mv/astrolib/ploterror.pro | 334 -- Code/script_idl_mv/astrolib/plothist.pro | 369 --- Code/script_idl_mv/astrolib/plotsym.pro | 135 - Code/script_idl_mv/astrolib/poidev.pro | 134 - Code/script_idl_mv/astrolib/polint.pro | 85 - Code/script_idl_mv/astrolib/polrec.pro | 52 - Code/script_idl_mv/astrolib/poly_smooth.pro | 191 -- Code/script_idl_mv/astrolib/polyleg.pro | 76 - Code/script_idl_mv/astrolib/posang.pro | 121 - Code/script_idl_mv/astrolib/positivity.pro | 50 - Code/script_idl_mv/astrolib/precess.pro | 163 - Code/script_idl_mv/astrolib/precess_cd.pro | 105 - Code/script_idl_mv/astrolib/precess_xyz.pro | 63 - Code/script_idl_mv/astrolib/premat.pro | 92 - Code/script_idl_mv/astrolib/prime.pro | 81 - Code/script_idl_mv/astrolib/print_struct.pro | 245 -- Code/script_idl_mv/astrolib/prob_ks.pro | 70 - Code/script_idl_mv/astrolib/prob_kuiper.pro | 76 - Code/script_idl_mv/astrolib/psf_gaussian.pro | 190 -- Code/script_idl_mv/astrolib/putast.pro | 484 --- Code/script_idl_mv/astrolib/qdcb_grid.pro | 162 - Code/script_idl_mv/astrolib/qget_string.pro | 89 - Code/script_idl_mv/astrolib/qsimp.pro | 99 - Code/script_idl_mv/astrolib/qtrap.pro | 84 - Code/script_idl_mv/astrolib/quadterp.pro | 128 - .../script_idl_mv/astrolib/query_irsa_cat.pro | 258 -- Code/script_idl_mv/astrolib/querydss.pro | 182 -- Code/script_idl_mv/astrolib/querygsc.pro | 192 -- Code/script_idl_mv/astrolib/querysimbad.pro | 200 -- Code/script_idl_mv/astrolib/queryvizier.pro | 348 -- Code/script_idl_mv/astrolib/radec.pro | 75 - Code/script_idl_mv/astrolib/randomchi.pro | 36 - Code/script_idl_mv/astrolib/randomdir.pro | 56 - Code/script_idl_mv/astrolib/randomgam.pro | 88 - Code/script_idl_mv/astrolib/randomp.pro | 83 - Code/script_idl_mv/astrolib/randomwish.pro | 56 - Code/script_idl_mv/astrolib/rdfits_struct.pro | 121 - Code/script_idl_mv/astrolib/rdfloat.pro | 152 - Code/script_idl_mv/astrolib/rdplot.pro | 671 ---- Code/script_idl_mv/astrolib/rdpsf.pro | 58 - Code/script_idl_mv/astrolib/read_fmr.pro | 345 -- .../astrolib/read_ipac_table.pro | 521 --- Code/script_idl_mv/astrolib/read_ipac_var.pro | 528 ---- Code/script_idl_mv/astrolib/read_key.pro | 129 - Code/script_idl_mv/astrolib/readcol.pro | 369 --- Code/script_idl_mv/astrolib/readfits.pro | 598 ---- Code/script_idl_mv/astrolib/readfmt.pro | 297 -- Code/script_idl_mv/astrolib/recpol.pro | 63 - Code/script_idl_mv/astrolib/rem_dup.pro | 104 - Code/script_idl_mv/astrolib/remchar.pro | 46 - Code/script_idl_mv/astrolib/remove.pro | 124 - Code/script_idl_mv/astrolib/repchr.pro | 60 - Code/script_idl_mv/astrolib/repstr.pro | 87 - .../script_idl_mv/astrolib/resistant_mean.pro | 202 -- Code/script_idl_mv/astrolib/rhotheta.pro | 103 - Code/script_idl_mv/astrolib/rinter.pro | 170 - Code/script_idl_mv/astrolib/rob_checkfit.pro | 66 - .../script_idl_mv/astrolib/robust_linefit.pro | 268 -- .../astrolib/robust_poly_fit.pro | 194 -- Code/script_idl_mv/astrolib/robust_sigma.pro | 73 - .../script_idl_mv/astrolib/safe_correlate.pro | 230 -- Code/script_idl_mv/astrolib/select_w.pro | 138 - Code/script_idl_mv/astrolib/sigma_filter.pro | 88 - Code/script_idl_mv/astrolib/sigrange.pro | 139 - Code/script_idl_mv/astrolib/sip_eval.pro | 46 - Code/script_idl_mv/astrolib/sixlin.pro | 156 - Code/script_idl_mv/astrolib/sixty.pro | 66 - Code/script_idl_mv/astrolib/sky.pro | 185 -- Code/script_idl_mv/astrolib/skyadj_cube.pro | 343 -- Code/script_idl_mv/astrolib/solve_astro.pro | 501 --- Code/script_idl_mv/astrolib/spec_dir.pro | 60 - Code/script_idl_mv/astrolib/sphdist.pro | 88 - Code/script_idl_mv/astrolib/srcor.pro | 257 -- Code/script_idl_mv/astrolib/st_diskread.pro | 781 ----- Code/script_idl_mv/astrolib/starast.pro | 140 - Code/script_idl_mv/astrolib/store_array.pro | 149 - Code/script_idl_mv/astrolib/str_index.pro | 68 - Code/script_idl_mv/astrolib/strcompress2.pro | 51 - Code/script_idl_mv/astrolib/strn.pro | 100 - Code/script_idl_mv/astrolib/strnumber.pro | 84 - Code/script_idl_mv/astrolib/substar.pro | 124 - Code/script_idl_mv/astrolib/sunpos.pro | 167 - Code/script_idl_mv/astrolib/sunsymbol.pro | 77 - Code/script_idl_mv/astrolib/sxaddhist.pro | 137 - Code/script_idl_mv/astrolib/sxaddpar.pro | 390 --- Code/script_idl_mv/astrolib/sxdelpar.pro | 69 - Code/script_idl_mv/astrolib/sxginfo.pro | 126 - Code/script_idl_mv/astrolib/sxgpar.pro | 228 -- Code/script_idl_mv/astrolib/sxgread.pro | 55 - Code/script_idl_mv/astrolib/sxhcopy.pro | 85 - Code/script_idl_mv/astrolib/sxhmake.pro | 76 - Code/script_idl_mv/astrolib/sxhread.pro | 120 - Code/script_idl_mv/astrolib/sxhwrite.pro | 95 - Code/script_idl_mv/astrolib/sxmake.pro | 128 - Code/script_idl_mv/astrolib/sxopen.pro | 213 -- Code/script_idl_mv/astrolib/sxpar.pro | 404 --- Code/script_idl_mv/astrolib/sxread.pro | 81 - Code/script_idl_mv/astrolib/sxwrite.pro | 92 - Code/script_idl_mv/astrolib/t_aper.pro | 160 - Code/script_idl_mv/astrolib/t_find.pro | 127 - Code/script_idl_mv/astrolib/t_getpsf.pro | 120 - Code/script_idl_mv/astrolib/t_group.pro | 73 - Code/script_idl_mv/astrolib/t_nstar.pro | 159 - Code/script_idl_mv/astrolib/t_substar.pro | 78 - Code/script_idl_mv/astrolib/tabinv.pro | 95 - Code/script_idl_mv/astrolib/tag_exist.pro | 99 - Code/script_idl_mv/astrolib/tbdelcol.pro | 111 - Code/script_idl_mv/astrolib/tbdelrow.pro | 76 - Code/script_idl_mv/astrolib/tbget.pro | 255 -- Code/script_idl_mv/astrolib/tbhelp.pro | 132 - Code/script_idl_mv/astrolib/tbinfo.pro | 192 -- Code/script_idl_mv/astrolib/tbprint.pro | 307 -- Code/script_idl_mv/astrolib/tbsize.pro | 63 - Code/script_idl_mv/astrolib/tdb2tdt.pro | 1071 ------- Code/script_idl_mv/astrolib/ten.pro | 93 - Code/script_idl_mv/astrolib/tenv.pro | 106 - Code/script_idl_mv/astrolib/textclose.pro | 46 - Code/script_idl_mv/astrolib/textopen.pro | 217 -- Code/script_idl_mv/astrolib/tic_one.pro | 63 - Code/script_idl_mv/astrolib/ticlabels.pro | 233 -- Code/script_idl_mv/astrolib/ticpos.pro | 88 - Code/script_idl_mv/astrolib/tics.pro | 76 - Code/script_idl_mv/astrolib/tnx_eval.pro | 134 - Code/script_idl_mv/astrolib/to_hex.pro | 44 - Code/script_idl_mv/astrolib/tpv_eval.pro | 92 - .../astrolib/transform_coeff.pro | 62 - Code/script_idl_mv/astrolib/trapzd.pro | 82 - Code/script_idl_mv/astrolib/tsc.pro | 595 ---- Code/script_idl_mv/astrolib/tsum.pro | 100 - Code/script_idl_mv/astrolib/tvbox.pro | 191 -- Code/script_idl_mv/astrolib/tvcircle.pro | 228 -- Code/script_idl_mv/astrolib/tvellipse.pro | 184 -- Code/script_idl_mv/astrolib/tvlaser.pro | 707 ----- Code/script_idl_mv/astrolib/tvlist.pro | 164 - Code/script_idl_mv/astrolib/unzoom_xy.pro | 82 - .../script_idl_mv/astrolib/update_distort.pro | 78 - Code/script_idl_mv/astrolib/uvbybeta.pro | 488 --- Code/script_idl_mv/astrolib/vactoair.pro | 68 - Code/script_idl_mv/astrolib/valid_num.pro | 80 - Code/script_idl_mv/astrolib/vect.pro | 61 - Code/script_idl_mv/astrolib/vsym.pro | 98 - .../astrolib/wcs_check_ctype.pro | 153 - Code/script_idl_mv/astrolib/wcs_demo.pro | 1198 ------- Code/script_idl_mv/astrolib/wcs_getpole.pro | 141 - Code/script_idl_mv/astrolib/wcs_rotate.pro | 205 -- Code/script_idl_mv/astrolib/wcssph2xy.pro | 1138 ------- Code/script_idl_mv/astrolib/wcsxy2sph.pro | 1447 --------- Code/script_idl_mv/astrolib/webget.pro | 280 -- Code/script_idl_mv/astrolib/wfpc2_metric.pro | 199 -- Code/script_idl_mv/astrolib/wfpc2_read.pro | 292 -- Code/script_idl_mv/astrolib/where_tag.pro | 170 - Code/script_idl_mv/astrolib/wherenan.pro | 113 - .../astrolib/write_ipac_table.pro | 290 -- Code/script_idl_mv/astrolib/writefits.pro | 291 -- Code/script_idl_mv/astrolib/xdispstr.pro | 170 - Code/script_idl_mv/astrolib/xmedsky.pro | 77 - Code/script_idl_mv/astrolib/xy2ad.pro | 199 -- Code/script_idl_mv/astrolib/xyad.pro | 205 -- Code/script_idl_mv/astrolib/xyxy.pro | 110 - Code/script_idl_mv/astrolib/xyz.pro | 189 -- Code/script_idl_mv/astrolib/ydn2md.pro | 62 - Code/script_idl_mv/astrolib/ymd2dn.pro | 56 - Code/script_idl_mv/astrolib/zang.pro | 78 - Code/script_idl_mv/astrolib/zbrent.pro | 157 - Code/script_idl_mv/astrolib/zenpos.pro | 73 - Code/script_idl_mv/astrolib/zoom_xy.pro | 79 - Code/script_idl_mv/astrolib/zparcheck.pro | 132 - Code/script_idl_mv/higalfit/lbol.pro | 41 - Code/script_idl_mv/higalfit/newtest.pro | 26 - Code/script_idl_mv/higalfit/planck.pro | 71 - .../higalfit/sedbank_thick_large.pro | 58 - .../higalfit/sedbank_thin_large.pro | 56 - .../sedfitgrid_engine_thick_vialactea.pro | 234 -- .../sedfitgrid_engine_thin_vialactea.pro | 212 -- Code/script_idl_mv/modelsed_fit.pro | 101 - Code/script_idl_mv/modelsed_fit_v2.pro | 111 - Code/script_idl_mv/pad0_num.pro | 8 - Code/script_idl_mv/remove_char.pro | 12 - Code/script_idl_mv/rename_tags.pro | 100 - .../sedfitgrid_engine_thick_vialactea.pro | 233 -- .../sedfitgrid_engine_thin_vialactea.pro | 212 -- Code/script_idl_mv/tostring.pro | 3 - Code/script_idl_mv/vialactea_tap_sedfit.pro | 120 - .../script_idl_mv/vialactea_tap_sedfit_v2.pro | 132 - .../script_idl_mv/vialactea_tap_sedfit_v3.pro | 146 - .../script_idl_mv/vialactea_tap_sedfit_v6.pro | 262 -- .../script_idl_mv/vialactea_tap_sedfit_v7.pro | 330 -- Code/script_idl_mv/wheretomulti.pro | 62 - Code/sed_fit/certs.zip | Bin 1511 -> 0 bytes Code/sed_fit/execute.bin | 4 - Code/sed_fit/inputs.zip | Bin 12515 -> 0 bytes Code/sed_fit/portmapping.txt | 2 - Code/sed_fit/scripts.zip | Bin 11986 -> 0 bytes Code/sed_fit/workflow.xml | 65 - Code/sed_fit/workflow.xml.orig | 65 - 517 files changed, 98029 deletions(-) delete mode 100644 Code/script_idl_mv/.DS_Store delete mode 100644 Code/script_idl_mv/astrolib/.idlwave_catalog delete mode 100644 Code/script_idl_mv/astrolib/ad2xy.pro delete mode 100644 Code/script_idl_mv/astrolib/add_distort.pro delete mode 100644 Code/script_idl_mv/astrolib/adstring.pro delete mode 100644 Code/script_idl_mv/astrolib/adxy.pro delete mode 100644 Code/script_idl_mv/astrolib/airtovac.pro delete mode 100644 Code/script_idl_mv/astrolib/aitoff.pro delete mode 100644 Code/script_idl_mv/astrolib/aitoff_grid.pro delete mode 100644 Code/script_idl_mv/astrolib/al_legend.pro delete mode 100644 Code/script_idl_mv/astrolib/al_legendtest.pro delete mode 100644 Code/script_idl_mv/astrolib/altaz2hadec.pro delete mode 100644 Code/script_idl_mv/astrolib/aper.pro delete mode 100644 Code/script_idl_mv/astrolib/arcbar.pro delete mode 100644 Code/script_idl_mv/astrolib/arrows.pro delete mode 100644 Code/script_idl_mv/astrolib/asinh.pro delete mode 100644 Code/script_idl_mv/astrolib/astdisp.pro delete mode 100644 Code/script_idl_mv/astrolib/astro.pro delete mode 100644 Code/script_idl_mv/astrolib/astrolib.pro delete mode 100644 Code/script_idl_mv/astrolib/autohist.pro delete mode 100644 Code/script_idl_mv/astrolib/avg.pro delete mode 100644 Code/script_idl_mv/astrolib/baryvel.pro delete mode 100644 Code/script_idl_mv/astrolib/biweight_mean.pro delete mode 100644 Code/script_idl_mv/astrolib/blink.pro delete mode 100644 Code/script_idl_mv/astrolib/blkshift.pro delete mode 100644 Code/script_idl_mv/astrolib/boost_array.pro delete mode 100644 Code/script_idl_mv/astrolib/boxave.pro delete mode 100644 Code/script_idl_mv/astrolib/bprecess.pro delete mode 100644 Code/script_idl_mv/astrolib/break_path.pro delete mode 100644 Code/script_idl_mv/astrolib/bsort.pro delete mode 100644 Code/script_idl_mv/astrolib/calz_unred.pro delete mode 100644 Code/script_idl_mv/astrolib/ccm_unred.pro delete mode 100644 Code/script_idl_mv/astrolib/check_fits.pro delete mode 100644 Code/script_idl_mv/astrolib/checksum32.pro delete mode 100644 Code/script_idl_mv/astrolib/cic.pro delete mode 100644 Code/script_idl_mv/astrolib/cirrange.pro delete mode 100644 Code/script_idl_mv/astrolib/cleanplot.pro delete mode 100644 Code/script_idl_mv/astrolib/cntrd.pro delete mode 100644 Code/script_idl_mv/astrolib/co_aberration.pro delete mode 100644 Code/script_idl_mv/astrolib/co_nutate.pro delete mode 100644 Code/script_idl_mv/astrolib/co_refract.pro delete mode 100644 Code/script_idl_mv/astrolib/compare_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/concat_dir.pro delete mode 100644 Code/script_idl_mv/astrolib/cons_dec.pro delete mode 100644 Code/script_idl_mv/astrolib/cons_ra.pro delete mode 100644 Code/script_idl_mv/astrolib/convolve.pro delete mode 100644 Code/script_idl_mv/astrolib/copy_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/copy_struct_inx.pro delete mode 100644 Code/script_idl_mv/astrolib/correl_images.pro delete mode 100644 Code/script_idl_mv/astrolib/correl_optimize.pro delete mode 100644 Code/script_idl_mv/astrolib/corrmat_analyze.pro delete mode 100644 Code/script_idl_mv/astrolib/cosmo_param.pro delete mode 100644 Code/script_idl_mv/astrolib/cr_reject.pro delete mode 100644 Code/script_idl_mv/astrolib/create_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/cspline.pro delete mode 100644 Code/script_idl_mv/astrolib/ct2lst.pro delete mode 100644 Code/script_idl_mv/astrolib/curs.pro delete mode 100644 Code/script_idl_mv/astrolib/curval.pro delete mode 100644 Code/script_idl_mv/astrolib/dao_value.pro delete mode 100644 Code/script_idl_mv/astrolib/daoerf.pro delete mode 100644 Code/script_idl_mv/astrolib/date.pro delete mode 100644 Code/script_idl_mv/astrolib/date_conv.pro delete mode 100644 Code/script_idl_mv/astrolib/daycnv.pro delete mode 100644 Code/script_idl_mv/astrolib/db_ent2ext.pro delete mode 100644 Code/script_idl_mv/astrolib/db_ent2host.pro delete mode 100644 Code/script_idl_mv/astrolib/db_info.pro delete mode 100644 Code/script_idl_mv/astrolib/db_item.pro delete mode 100644 Code/script_idl_mv/astrolib/db_item_info.pro delete mode 100644 Code/script_idl_mv/astrolib/db_or.pro delete mode 100644 Code/script_idl_mv/astrolib/db_titles.pro delete mode 100644 Code/script_idl_mv/astrolib/dbbuild.pro delete mode 100644 Code/script_idl_mv/astrolib/dbcircle.pro delete mode 100644 Code/script_idl_mv/astrolib/dbclose.pro delete mode 100644 Code/script_idl_mv/astrolib/dbcompare.pro delete mode 100644 Code/script_idl_mv/astrolib/dbcreate.pro delete mode 100644 Code/script_idl_mv/astrolib/dbdelete.pro delete mode 100644 Code/script_idl_mv/astrolib/dbedit.pro delete mode 100644 Code/script_idl_mv/astrolib/dbedit_basic.pro delete mode 100644 Code/script_idl_mv/astrolib/dbext.pro delete mode 100644 Code/script_idl_mv/astrolib/dbext_dbf.pro delete mode 100644 Code/script_idl_mv/astrolib/dbext_ind.pro delete mode 100644 Code/script_idl_mv/astrolib/dbfind.pro delete mode 100644 Code/script_idl_mv/astrolib/dbfind_entry.pro delete mode 100644 Code/script_idl_mv/astrolib/dbfind_sort.pro delete mode 100644 Code/script_idl_mv/astrolib/dbfparse.pro delete mode 100644 Code/script_idl_mv/astrolib/dbget.pro delete mode 100644 Code/script_idl_mv/astrolib/dbhelp.pro delete mode 100644 Code/script_idl_mv/astrolib/dbindex.pro delete mode 100644 Code/script_idl_mv/astrolib/dbindex_blk.pro delete mode 100644 Code/script_idl_mv/astrolib/dbmatch.pro delete mode 100644 Code/script_idl_mv/astrolib/dbopen.pro delete mode 100644 Code/script_idl_mv/astrolib/dbprint.pro delete mode 100644 Code/script_idl_mv/astrolib/dbput.pro delete mode 100644 Code/script_idl_mv/astrolib/dbrd.pro delete mode 100644 Code/script_idl_mv/astrolib/dbsearch.pro delete mode 100644 Code/script_idl_mv/astrolib/dbsort.pro delete mode 100644 Code/script_idl_mv/astrolib/dbtarget.pro delete mode 100644 Code/script_idl_mv/astrolib/dbtitle.pro delete mode 100644 Code/script_idl_mv/astrolib/dbupdate.pro delete mode 100644 Code/script_idl_mv/astrolib/dbval.pro delete mode 100644 Code/script_idl_mv/astrolib/dbwrt.pro delete mode 100644 Code/script_idl_mv/astrolib/dbxput.pro delete mode 100644 Code/script_idl_mv/astrolib/dbxval.pro delete mode 100644 Code/script_idl_mv/astrolib/delvarx.pro delete mode 100644 Code/script_idl_mv/astrolib/deredd.pro delete mode 100644 Code/script_idl_mv/astrolib/detabify.pro delete mode 100644 Code/script_idl_mv/astrolib/dist_circle.pro delete mode 100644 Code/script_idl_mv/astrolib/dist_ellipse.pro delete mode 100644 Code/script_idl_mv/astrolib/eci2geo.pro delete mode 100644 Code/script_idl_mv/astrolib/eq2hor.pro delete mode 100644 Code/script_idl_mv/astrolib/eqpole.pro delete mode 100644 Code/script_idl_mv/astrolib/eqpole_grid.pro delete mode 100644 Code/script_idl_mv/astrolib/euler.pro delete mode 100644 Code/script_idl_mv/astrolib/expand_tilde.pro delete mode 100644 Code/script_idl_mv/astrolib/extast.pro delete mode 100644 Code/script_idl_mv/astrolib/extgrp.pro delete mode 100644 Code/script_idl_mv/astrolib/f_format.pro delete mode 100644 Code/script_idl_mv/astrolib/factor.pro delete mode 100644 Code/script_idl_mv/astrolib/fdecomp.pro delete mode 100644 Code/script_idl_mv/astrolib/file_launch.pro delete mode 100644 Code/script_idl_mv/astrolib/filter_image.pro delete mode 100644 Code/script_idl_mv/astrolib/find.pro delete mode 100644 Code/script_idl_mv/astrolib/find_all_dir.pro delete mode 100644 Code/script_idl_mv/astrolib/find_with_def.pro delete mode 100644 Code/script_idl_mv/astrolib/findpro.pro delete mode 100644 Code/script_idl_mv/astrolib/fitexy.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_add_checksum.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_ascii_encode.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_cd_fix.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_close.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_help.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_info.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_open.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_read.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_test_checksum.pro delete mode 100644 Code/script_idl_mv/astrolib/fits_write.pro delete mode 100644 Code/script_idl_mv/astrolib/fitsdir.pro delete mode 100644 Code/script_idl_mv/astrolib/fitsrgb_to_tiff.pro delete mode 100644 Code/script_idl_mv/astrolib/flegendre.pro delete mode 100644 Code/script_idl_mv/astrolib/flux2mag.pro delete mode 100644 Code/script_idl_mv/astrolib/fm_unred.pro delete mode 100644 Code/script_idl_mv/astrolib/forprint.pro delete mode 100644 Code/script_idl_mv/astrolib/frebin.pro delete mode 100644 Code/script_idl_mv/astrolib/ftab_delrow.pro delete mode 100644 Code/script_idl_mv/astrolib/ftab_ext.pro delete mode 100644 Code/script_idl_mv/astrolib/ftab_help.pro delete mode 100644 Code/script_idl_mv/astrolib/ftab_print.pro delete mode 100644 Code/script_idl_mv/astrolib/ftaddcol.pro delete mode 100644 Code/script_idl_mv/astrolib/ftcreate.pro delete mode 100644 Code/script_idl_mv/astrolib/ftdelcol.pro delete mode 100644 Code/script_idl_mv/astrolib/ftdelrow.pro delete mode 100644 Code/script_idl_mv/astrolib/ftget.pro delete mode 100644 Code/script_idl_mv/astrolib/fthelp.pro delete mode 100644 Code/script_idl_mv/astrolib/fthmod.pro delete mode 100644 Code/script_idl_mv/astrolib/ftinfo.pro delete mode 100644 Code/script_idl_mv/astrolib/ftkeeprow.pro delete mode 100644 Code/script_idl_mv/astrolib/ftprint.pro delete mode 100644 Code/script_idl_mv/astrolib/ftput.pro delete mode 100644 Code/script_idl_mv/astrolib/ftsize.pro delete mode 100644 Code/script_idl_mv/astrolib/ftsort.pro delete mode 100644 Code/script_idl_mv/astrolib/fxaddpar.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbaddcol.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbclose.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbcolnum.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbcreate.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbdimen.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbfind.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbfindlun.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbfinish.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbgrow.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbheader.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbhelp.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbhmake.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbintable.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbisopen.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbopen.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbparse.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbread.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbreadm.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbstate.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbtdim.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbtform.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbwrite.pro delete mode 100644 Code/script_idl_mv/astrolib/fxbwritm.pro delete mode 100644 Code/script_idl_mv/astrolib/fxfindend.pro delete mode 100644 Code/script_idl_mv/astrolib/fxhclean.pro delete mode 100644 Code/script_idl_mv/astrolib/fxhmake.pro delete mode 100644 Code/script_idl_mv/astrolib/fxhmodify.pro delete mode 100644 Code/script_idl_mv/astrolib/fxhread.pro delete mode 100644 Code/script_idl_mv/astrolib/fxmove.pro delete mode 100644 Code/script_idl_mv/astrolib/fxpar.pro delete mode 100644 Code/script_idl_mv/astrolib/fxparpos.pro delete mode 100644 Code/script_idl_mv/astrolib/fxposit.pro delete mode 100644 Code/script_idl_mv/astrolib/fxread.pro delete mode 100644 Code/script_idl_mv/astrolib/fxwrite.pro delete mode 100644 Code/script_idl_mv/astrolib/gal_flat.pro delete mode 100644 Code/script_idl_mv/astrolib/gal_uvw.pro delete mode 100644 Code/script_idl_mv/astrolib/galage.pro delete mode 100644 Code/script_idl_mv/astrolib/gaussian.pro delete mode 100644 Code/script_idl_mv/astrolib/gcirc.pro delete mode 100644 Code/script_idl_mv/astrolib/gcntrd.pro delete mode 100644 Code/script_idl_mv/astrolib/geo2eci.pro delete mode 100644 Code/script_idl_mv/astrolib/geo2geodetic.pro delete mode 100644 Code/script_idl_mv/astrolib/geo2mag.pro delete mode 100644 Code/script_idl_mv/astrolib/geodetic2geo.pro delete mode 100644 Code/script_idl_mv/astrolib/get_coords.pro delete mode 100644 Code/script_idl_mv/astrolib/get_date.pro delete mode 100644 Code/script_idl_mv/astrolib/get_equinox.pro delete mode 100644 Code/script_idl_mv/astrolib/get_juldate.pro delete mode 100644 Code/script_idl_mv/astrolib/get_pipe_filesize.pro delete mode 100644 Code/script_idl_mv/astrolib/getopt.pro delete mode 100644 Code/script_idl_mv/astrolib/getpro.pro delete mode 100644 Code/script_idl_mv/astrolib/getpsf.pro delete mode 100644 Code/script_idl_mv/astrolib/getrot.pro delete mode 100644 Code/script_idl_mv/astrolib/gettok.pro delete mode 100644 Code/script_idl_mv/astrolib/getwrd.pro delete mode 100644 Code/script_idl_mv/astrolib/glactc.pro delete mode 100644 Code/script_idl_mv/astrolib/glactc_pm.pro delete mode 100644 Code/script_idl_mv/astrolib/group.pro delete mode 100644 Code/script_idl_mv/astrolib/gsss_stdast.pro delete mode 100644 Code/script_idl_mv/astrolib/gsssadxy.pro delete mode 100644 Code/script_idl_mv/astrolib/gsssextast.pro delete mode 100644 Code/script_idl_mv/astrolib/gsssxyad.pro delete mode 100644 Code/script_idl_mv/astrolib/hadec2altaz.pro delete mode 100644 Code/script_idl_mv/astrolib/hastrom.pro delete mode 100644 Code/script_idl_mv/astrolib/hboxave.pro delete mode 100644 Code/script_idl_mv/astrolib/hcongrid.pro delete mode 100644 Code/script_idl_mv/astrolib/headfits.pro delete mode 100644 Code/script_idl_mv/astrolib/helio.pro delete mode 100644 Code/script_idl_mv/astrolib/helio_jd.pro delete mode 100644 Code/script_idl_mv/astrolib/helio_rv.pro delete mode 100644 Code/script_idl_mv/astrolib/hermite.pro delete mode 100644 Code/script_idl_mv/astrolib/heuler.pro delete mode 100644 Code/script_idl_mv/astrolib/hextract.pro delete mode 100644 Code/script_idl_mv/astrolib/hgrep.pro delete mode 100644 Code/script_idl_mv/astrolib/histogauss.pro delete mode 100644 Code/script_idl_mv/astrolib/hor2eq.pro delete mode 100644 Code/script_idl_mv/astrolib/host_to_ieee.pro delete mode 100644 Code/script_idl_mv/astrolib/hprecess.pro delete mode 100644 Code/script_idl_mv/astrolib/hprint.pro delete mode 100644 Code/script_idl_mv/astrolib/hrebin.pro delete mode 100644 Code/script_idl_mv/astrolib/hreverse.pro delete mode 100644 Code/script_idl_mv/astrolib/hrot.pro delete mode 100644 Code/script_idl_mv/astrolib/hrotate.pro delete mode 100644 Code/script_idl_mv/astrolib/ieee_to_host.pro delete mode 100644 Code/script_idl_mv/astrolib/imcontour.pro delete mode 100644 Code/script_idl_mv/astrolib/imdbase.pro delete mode 100644 Code/script_idl_mv/astrolib/imf.pro delete mode 100644 Code/script_idl_mv/astrolib/imlist.pro delete mode 100644 Code/script_idl_mv/astrolib/irafdir.pro delete mode 100644 Code/script_idl_mv/astrolib/irafrd.pro delete mode 100644 Code/script_idl_mv/astrolib/irafwrt.pro delete mode 100644 Code/script_idl_mv/astrolib/is_ieee_big.pro delete mode 100644 Code/script_idl_mv/astrolib/isarray.pro delete mode 100644 Code/script_idl_mv/astrolib/ismeuv.pro delete mode 100644 Code/script_idl_mv/astrolib/jdcnv.pro delete mode 100644 Code/script_idl_mv/astrolib/jplephinterp.pro delete mode 100644 Code/script_idl_mv/astrolib/jplephread.pro delete mode 100644 Code/script_idl_mv/astrolib/jplephtest.pro delete mode 100644 Code/script_idl_mv/astrolib/jprecess.pro delete mode 100644 Code/script_idl_mv/astrolib/juldate.pro delete mode 100644 Code/script_idl_mv/astrolib/ksone.pro delete mode 100644 Code/script_idl_mv/astrolib/kstwo.pro delete mode 100644 Code/script_idl_mv/astrolib/kuiperone.pro delete mode 100644 Code/script_idl_mv/astrolib/kuipertwo.pro delete mode 100644 Code/script_idl_mv/astrolib/lineid_plot.pro delete mode 100644 Code/script_idl_mv/astrolib/linmix_err.pro delete mode 100644 Code/script_idl_mv/astrolib/linterp.pro delete mode 100644 Code/script_idl_mv/astrolib/list_with_path.pro delete mode 100644 Code/script_idl_mv/astrolib/lsf_rotate.pro delete mode 100644 Code/script_idl_mv/astrolib/lumdist.pro delete mode 100644 Code/script_idl_mv/astrolib/mag2flux.pro delete mode 100644 Code/script_idl_mv/astrolib/mag2geo.pro delete mode 100644 Code/script_idl_mv/astrolib/make_2d.pro delete mode 100644 Code/script_idl_mv/astrolib/make_astr.pro delete mode 100644 Code/script_idl_mv/astrolib/match.pro delete mode 100644 Code/script_idl_mv/astrolib/match2.pro delete mode 100644 Code/script_idl_mv/astrolib/max_entropy.pro delete mode 100644 Code/script_idl_mv/astrolib/max_likelihood.pro delete mode 100644 Code/script_idl_mv/astrolib/meanclip.pro delete mode 100644 Code/script_idl_mv/astrolib/medarr.pro delete mode 100644 Code/script_idl_mv/astrolib/medsmooth.pro delete mode 100644 Code/script_idl_mv/astrolib/minf_bracket.pro delete mode 100644 Code/script_idl_mv/astrolib/minf_conj_grad.pro delete mode 100644 Code/script_idl_mv/astrolib/minf_parabol_d.pro delete mode 100644 Code/script_idl_mv/astrolib/minf_parabolic.pro delete mode 100644 Code/script_idl_mv/astrolib/minmax.pro delete mode 100644 Code/script_idl_mv/astrolib/mkhdr.pro delete mode 100644 Code/script_idl_mv/astrolib/mlinmix_err.pro delete mode 100644 Code/script_idl_mv/astrolib/mmm.pro delete mode 100644 Code/script_idl_mv/astrolib/modfits.pro delete mode 100644 Code/script_idl_mv/astrolib/month_cnv.pro delete mode 100644 Code/script_idl_mv/astrolib/moonpos.pro delete mode 100644 Code/script_idl_mv/astrolib/mphase.pro delete mode 100644 Code/script_idl_mv/astrolib/mrandomn.pro delete mode 100644 Code/script_idl_mv/astrolib/mrd_hread.pro delete mode 100644 Code/script_idl_mv/astrolib/mrd_skip.pro delete mode 100644 Code/script_idl_mv/astrolib/mrd_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/mrdfits.pro delete mode 100644 Code/script_idl_mv/astrolib/multinom.pro delete mode 100644 Code/script_idl_mv/astrolib/multiplot.pro delete mode 100644 Code/script_idl_mv/astrolib/mwrfits.pro delete mode 100644 Code/script_idl_mv/astrolib/n_bytes.pro delete mode 100644 Code/script_idl_mv/astrolib/ngp.pro delete mode 100644 Code/script_idl_mv/astrolib/nint.pro delete mode 100644 Code/script_idl_mv/astrolib/nstar.pro delete mode 100644 Code/script_idl_mv/astrolib/nulltrim.pro delete mode 100644 Code/script_idl_mv/astrolib/nutate.pro delete mode 100644 Code/script_idl_mv/astrolib/observatory.pro delete mode 100644 Code/script_idl_mv/astrolib/one_arrow.pro delete mode 100644 Code/script_idl_mv/astrolib/one_ray.pro delete mode 100644 Code/script_idl_mv/astrolib/oploterror.pro delete mode 100644 Code/script_idl_mv/astrolib/ordinal.pro delete mode 100644 Code/script_idl_mv/astrolib/partvelvec.pro delete mode 100644 Code/script_idl_mv/astrolib/pca.pro delete mode 100644 Code/script_idl_mv/astrolib/pent.pro delete mode 100644 Code/script_idl_mv/astrolib/permute.pro delete mode 100644 Code/script_idl_mv/astrolib/pixcolor.pro delete mode 100644 Code/script_idl_mv/astrolib/pixwt.pro delete mode 100644 Code/script_idl_mv/astrolib/pkfit.pro delete mode 100644 Code/script_idl_mv/astrolib/planck.pro delete mode 100644 Code/script_idl_mv/astrolib/planet_coords.pro delete mode 100644 Code/script_idl_mv/astrolib/ploterror.pro delete mode 100644 Code/script_idl_mv/astrolib/plothist.pro delete mode 100644 Code/script_idl_mv/astrolib/plotsym.pro delete mode 100644 Code/script_idl_mv/astrolib/poidev.pro delete mode 100644 Code/script_idl_mv/astrolib/polint.pro delete mode 100644 Code/script_idl_mv/astrolib/polrec.pro delete mode 100644 Code/script_idl_mv/astrolib/poly_smooth.pro delete mode 100644 Code/script_idl_mv/astrolib/polyleg.pro delete mode 100644 Code/script_idl_mv/astrolib/posang.pro delete mode 100644 Code/script_idl_mv/astrolib/positivity.pro delete mode 100644 Code/script_idl_mv/astrolib/precess.pro delete mode 100644 Code/script_idl_mv/astrolib/precess_cd.pro delete mode 100644 Code/script_idl_mv/astrolib/precess_xyz.pro delete mode 100644 Code/script_idl_mv/astrolib/premat.pro delete mode 100644 Code/script_idl_mv/astrolib/prime.pro delete mode 100644 Code/script_idl_mv/astrolib/print_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/prob_ks.pro delete mode 100644 Code/script_idl_mv/astrolib/prob_kuiper.pro delete mode 100644 Code/script_idl_mv/astrolib/psf_gaussian.pro delete mode 100644 Code/script_idl_mv/astrolib/putast.pro delete mode 100644 Code/script_idl_mv/astrolib/qdcb_grid.pro delete mode 100644 Code/script_idl_mv/astrolib/qget_string.pro delete mode 100644 Code/script_idl_mv/astrolib/qsimp.pro delete mode 100644 Code/script_idl_mv/astrolib/qtrap.pro delete mode 100644 Code/script_idl_mv/astrolib/quadterp.pro delete mode 100644 Code/script_idl_mv/astrolib/query_irsa_cat.pro delete mode 100644 Code/script_idl_mv/astrolib/querydss.pro delete mode 100644 Code/script_idl_mv/astrolib/querygsc.pro delete mode 100644 Code/script_idl_mv/astrolib/querysimbad.pro delete mode 100644 Code/script_idl_mv/astrolib/queryvizier.pro delete mode 100644 Code/script_idl_mv/astrolib/radec.pro delete mode 100644 Code/script_idl_mv/astrolib/randomchi.pro delete mode 100644 Code/script_idl_mv/astrolib/randomdir.pro delete mode 100644 Code/script_idl_mv/astrolib/randomgam.pro delete mode 100644 Code/script_idl_mv/astrolib/randomp.pro delete mode 100644 Code/script_idl_mv/astrolib/randomwish.pro delete mode 100644 Code/script_idl_mv/astrolib/rdfits_struct.pro delete mode 100644 Code/script_idl_mv/astrolib/rdfloat.pro delete mode 100644 Code/script_idl_mv/astrolib/rdplot.pro delete mode 100644 Code/script_idl_mv/astrolib/rdpsf.pro delete mode 100644 Code/script_idl_mv/astrolib/read_fmr.pro delete mode 100644 Code/script_idl_mv/astrolib/read_ipac_table.pro delete mode 100644 Code/script_idl_mv/astrolib/read_ipac_var.pro delete mode 100644 Code/script_idl_mv/astrolib/read_key.pro delete mode 100644 Code/script_idl_mv/astrolib/readcol.pro delete mode 100644 Code/script_idl_mv/astrolib/readfits.pro delete mode 100644 Code/script_idl_mv/astrolib/readfmt.pro delete mode 100644 Code/script_idl_mv/astrolib/recpol.pro delete mode 100644 Code/script_idl_mv/astrolib/rem_dup.pro delete mode 100644 Code/script_idl_mv/astrolib/remchar.pro delete mode 100644 Code/script_idl_mv/astrolib/remove.pro delete mode 100644 Code/script_idl_mv/astrolib/repchr.pro delete mode 100644 Code/script_idl_mv/astrolib/repstr.pro delete mode 100644 Code/script_idl_mv/astrolib/resistant_mean.pro delete mode 100644 Code/script_idl_mv/astrolib/rhotheta.pro delete mode 100644 Code/script_idl_mv/astrolib/rinter.pro delete mode 100644 Code/script_idl_mv/astrolib/rob_checkfit.pro delete mode 100644 Code/script_idl_mv/astrolib/robust_linefit.pro delete mode 100644 Code/script_idl_mv/astrolib/robust_poly_fit.pro delete mode 100644 Code/script_idl_mv/astrolib/robust_sigma.pro delete mode 100644 Code/script_idl_mv/astrolib/safe_correlate.pro delete mode 100644 Code/script_idl_mv/astrolib/select_w.pro delete mode 100644 Code/script_idl_mv/astrolib/sigma_filter.pro delete mode 100644 Code/script_idl_mv/astrolib/sigrange.pro delete mode 100644 Code/script_idl_mv/astrolib/sip_eval.pro delete mode 100644 Code/script_idl_mv/astrolib/sixlin.pro delete mode 100644 Code/script_idl_mv/astrolib/sixty.pro delete mode 100644 Code/script_idl_mv/astrolib/sky.pro delete mode 100644 Code/script_idl_mv/astrolib/skyadj_cube.pro delete mode 100644 Code/script_idl_mv/astrolib/solve_astro.pro delete mode 100644 Code/script_idl_mv/astrolib/spec_dir.pro delete mode 100644 Code/script_idl_mv/astrolib/sphdist.pro delete mode 100644 Code/script_idl_mv/astrolib/srcor.pro delete mode 100644 Code/script_idl_mv/astrolib/st_diskread.pro delete mode 100644 Code/script_idl_mv/astrolib/starast.pro delete mode 100644 Code/script_idl_mv/astrolib/store_array.pro delete mode 100644 Code/script_idl_mv/astrolib/str_index.pro delete mode 100644 Code/script_idl_mv/astrolib/strcompress2.pro delete mode 100644 Code/script_idl_mv/astrolib/strn.pro delete mode 100644 Code/script_idl_mv/astrolib/strnumber.pro delete mode 100644 Code/script_idl_mv/astrolib/substar.pro delete mode 100644 Code/script_idl_mv/astrolib/sunpos.pro delete mode 100644 Code/script_idl_mv/astrolib/sunsymbol.pro delete mode 100644 Code/script_idl_mv/astrolib/sxaddhist.pro delete mode 100644 Code/script_idl_mv/astrolib/sxaddpar.pro delete mode 100644 Code/script_idl_mv/astrolib/sxdelpar.pro delete mode 100644 Code/script_idl_mv/astrolib/sxginfo.pro delete mode 100644 Code/script_idl_mv/astrolib/sxgpar.pro delete mode 100644 Code/script_idl_mv/astrolib/sxgread.pro delete mode 100644 Code/script_idl_mv/astrolib/sxhcopy.pro delete mode 100644 Code/script_idl_mv/astrolib/sxhmake.pro delete mode 100644 Code/script_idl_mv/astrolib/sxhread.pro delete mode 100644 Code/script_idl_mv/astrolib/sxhwrite.pro delete mode 100644 Code/script_idl_mv/astrolib/sxmake.pro delete mode 100644 Code/script_idl_mv/astrolib/sxopen.pro delete mode 100644 Code/script_idl_mv/astrolib/sxpar.pro delete mode 100644 Code/script_idl_mv/astrolib/sxread.pro delete mode 100644 Code/script_idl_mv/astrolib/sxwrite.pro delete mode 100644 Code/script_idl_mv/astrolib/t_aper.pro delete mode 100644 Code/script_idl_mv/astrolib/t_find.pro delete mode 100644 Code/script_idl_mv/astrolib/t_getpsf.pro delete mode 100644 Code/script_idl_mv/astrolib/t_group.pro delete mode 100644 Code/script_idl_mv/astrolib/t_nstar.pro delete mode 100644 Code/script_idl_mv/astrolib/t_substar.pro delete mode 100644 Code/script_idl_mv/astrolib/tabinv.pro delete mode 100644 Code/script_idl_mv/astrolib/tag_exist.pro delete mode 100644 Code/script_idl_mv/astrolib/tbdelcol.pro delete mode 100644 Code/script_idl_mv/astrolib/tbdelrow.pro delete mode 100644 Code/script_idl_mv/astrolib/tbget.pro delete mode 100644 Code/script_idl_mv/astrolib/tbhelp.pro delete mode 100644 Code/script_idl_mv/astrolib/tbinfo.pro delete mode 100644 Code/script_idl_mv/astrolib/tbprint.pro delete mode 100644 Code/script_idl_mv/astrolib/tbsize.pro delete mode 100644 Code/script_idl_mv/astrolib/tdb2tdt.pro delete mode 100644 Code/script_idl_mv/astrolib/ten.pro delete mode 100644 Code/script_idl_mv/astrolib/tenv.pro delete mode 100644 Code/script_idl_mv/astrolib/textclose.pro delete mode 100644 Code/script_idl_mv/astrolib/textopen.pro delete mode 100644 Code/script_idl_mv/astrolib/tic_one.pro delete mode 100644 Code/script_idl_mv/astrolib/ticlabels.pro delete mode 100644 Code/script_idl_mv/astrolib/ticpos.pro delete mode 100644 Code/script_idl_mv/astrolib/tics.pro delete mode 100644 Code/script_idl_mv/astrolib/tnx_eval.pro delete mode 100644 Code/script_idl_mv/astrolib/to_hex.pro delete mode 100644 Code/script_idl_mv/astrolib/tpv_eval.pro delete mode 100644 Code/script_idl_mv/astrolib/transform_coeff.pro delete mode 100644 Code/script_idl_mv/astrolib/trapzd.pro delete mode 100644 Code/script_idl_mv/astrolib/tsc.pro delete mode 100644 Code/script_idl_mv/astrolib/tsum.pro delete mode 100644 Code/script_idl_mv/astrolib/tvbox.pro delete mode 100644 Code/script_idl_mv/astrolib/tvcircle.pro delete mode 100644 Code/script_idl_mv/astrolib/tvellipse.pro delete mode 100644 Code/script_idl_mv/astrolib/tvlaser.pro delete mode 100644 Code/script_idl_mv/astrolib/tvlist.pro delete mode 100644 Code/script_idl_mv/astrolib/unzoom_xy.pro delete mode 100644 Code/script_idl_mv/astrolib/update_distort.pro delete mode 100644 Code/script_idl_mv/astrolib/uvbybeta.pro delete mode 100644 Code/script_idl_mv/astrolib/vactoair.pro delete mode 100644 Code/script_idl_mv/astrolib/valid_num.pro delete mode 100644 Code/script_idl_mv/astrolib/vect.pro delete mode 100644 Code/script_idl_mv/astrolib/vsym.pro delete mode 100644 Code/script_idl_mv/astrolib/wcs_check_ctype.pro delete mode 100644 Code/script_idl_mv/astrolib/wcs_demo.pro delete mode 100644 Code/script_idl_mv/astrolib/wcs_getpole.pro delete mode 100644 Code/script_idl_mv/astrolib/wcs_rotate.pro delete mode 100644 Code/script_idl_mv/astrolib/wcssph2xy.pro delete mode 100644 Code/script_idl_mv/astrolib/wcsxy2sph.pro delete mode 100644 Code/script_idl_mv/astrolib/webget.pro delete mode 100644 Code/script_idl_mv/astrolib/wfpc2_metric.pro delete mode 100644 Code/script_idl_mv/astrolib/wfpc2_read.pro delete mode 100644 Code/script_idl_mv/astrolib/where_tag.pro delete mode 100644 Code/script_idl_mv/astrolib/wherenan.pro delete mode 100644 Code/script_idl_mv/astrolib/write_ipac_table.pro delete mode 100644 Code/script_idl_mv/astrolib/writefits.pro delete mode 100644 Code/script_idl_mv/astrolib/xdispstr.pro delete mode 100644 Code/script_idl_mv/astrolib/xmedsky.pro delete mode 100644 Code/script_idl_mv/astrolib/xy2ad.pro delete mode 100644 Code/script_idl_mv/astrolib/xyad.pro delete mode 100644 Code/script_idl_mv/astrolib/xyxy.pro delete mode 100644 Code/script_idl_mv/astrolib/xyz.pro delete mode 100644 Code/script_idl_mv/astrolib/ydn2md.pro delete mode 100644 Code/script_idl_mv/astrolib/ymd2dn.pro delete mode 100644 Code/script_idl_mv/astrolib/zang.pro delete mode 100644 Code/script_idl_mv/astrolib/zbrent.pro delete mode 100644 Code/script_idl_mv/astrolib/zenpos.pro delete mode 100644 Code/script_idl_mv/astrolib/zoom_xy.pro delete mode 100644 Code/script_idl_mv/astrolib/zparcheck.pro delete mode 100755 Code/script_idl_mv/higalfit/lbol.pro delete mode 100644 Code/script_idl_mv/higalfit/newtest.pro delete mode 100644 Code/script_idl_mv/higalfit/planck.pro delete mode 100644 Code/script_idl_mv/higalfit/sedbank_thick_large.pro delete mode 100644 Code/script_idl_mv/higalfit/sedbank_thin_large.pro delete mode 100644 Code/script_idl_mv/higalfit/sedfitgrid_engine_thick_vialactea.pro delete mode 100644 Code/script_idl_mv/higalfit/sedfitgrid_engine_thin_vialactea.pro delete mode 100644 Code/script_idl_mv/modelsed_fit.pro delete mode 100644 Code/script_idl_mv/modelsed_fit_v2.pro delete mode 100755 Code/script_idl_mv/pad0_num.pro delete mode 100755 Code/script_idl_mv/remove_char.pro delete mode 100644 Code/script_idl_mv/rename_tags.pro delete mode 100644 Code/script_idl_mv/sedfitgrid_engine_thick_vialactea.pro delete mode 100644 Code/script_idl_mv/sedfitgrid_engine_thin_vialactea.pro delete mode 100644 Code/script_idl_mv/tostring.pro delete mode 100644 Code/script_idl_mv/vialactea_tap_sedfit.pro delete mode 100644 Code/script_idl_mv/vialactea_tap_sedfit_v2.pro delete mode 100644 Code/script_idl_mv/vialactea_tap_sedfit_v3.pro delete mode 100644 Code/script_idl_mv/vialactea_tap_sedfit_v6.pro delete mode 100644 Code/script_idl_mv/vialactea_tap_sedfit_v7.pro delete mode 100644 Code/script_idl_mv/wheretomulti.pro delete mode 100644 Code/sed_fit/certs.zip delete mode 100644 Code/sed_fit/execute.bin delete mode 100644 Code/sed_fit/inputs.zip delete mode 100644 Code/sed_fit/portmapping.txt delete mode 100755 Code/sed_fit/scripts.zip delete mode 100755 Code/sed_fit/workflow.xml delete mode 100755 Code/sed_fit/workflow.xml.orig diff --git a/Code/script_idl_mv/.DS_Store b/Code/script_idl_mv/.DS_Store deleted file mode 100644 index 1097fa5c6b6ea8ca8b3cc1039c6baa4eff2ce550..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10244 zcmeHMTWl0n823c3vlySfnvXBE3qZ1p)S^(I z_5mU$5y@mEOHztZ8dL5bFbc(Ji-9tn>2ZIziafG>)+uRWoPJ*7P}Zs_DmSt8YyW z`=hDQ42waBS=c9z9Lvr`{T?$MF86zV-@Vv3GkuOdnr8DmeJ?Z}&n`>|-QVwcmOt9z z7d_6UXcn4aC|1Wv|ro$!dRYxGOAx}!&%TUr|vt?R}b6GxlZ zG*f?lOY_(mJFRJpSG2b89L$g1|Lk+mzwqKqCqMdFVu8{71m;y>b9O3VtRU-V=vKJz zB-Gqsq(`C_d#sGwSC>#TjQCZZU7HtnZ%H#&4D8*uYlhB<-DQS$kY+Ujfw?W~d(l0n zS#8#Ivqf^U+g&&1+-V2>S>G+@JmH-!_^#XI2Ttht-rzuJ9}c+>ALugEz}~4b=Nnw-ni);tDQT~SYRydAK^&5_MTBb34>;k zwLQ!6hW66bc%gI1u?u=_>|4FpGjq0#S`=TRvoqR$i>`gAZ*d<>SmKM~2~FF_^_>Nq zTB$bb@4cPaAVXIft2Jindt5VPyHeF+tku|dy?;dBfK;{_ z8?;(%)CaPDE=N}wNcG0}%^LeeJHXGq!wkY*dE2{mRUMi($Sv)bWn1;h54uZyitCdN zTu?^}u4$58#uu!m&;%XO2L~VzN8kZC1}ET6I0J9N+wdWL24BKBT!8Q42lx?wf?p6Z zhE+Hd=i*{qf=h7)w%{6U#dUZScHw5+f?IJX_F+E`;$A$64&H_?=CFu&;oW#I-iHt3 z<9H08z~gulU&lA_G`^2#@e4eUU(4%?mHE82e92Pc1(H)yHXl*;_%xK=y6qOW{R*b+ zcnv4&`~_Dptc#f2b#dkeB`2~?5KJ;iFssa*3RYZB+-nvsUJ}37NKE%2>>-NUhXv=@ z>~q}Ps5h32XM%w^jyJ?tYV<&`m^817ujX`TGo)3}*wWcdX(a-4>a!|o-DnVTx9e<{ zJZz75avn2HIyc0(=o-VnLfJnd?59N6^Y9IPM|AxeenSK6a2Zi_HEzI7n8Z$^XgBV{ z9!y~`ku*&N&0rR7^w7sUuz(?s5m8Hck09zp_%J?#kK&W~6h4h7@EJUXFXJotD!zvA z;Jf%MG<{*1G)KWS(cKl%)#UF--z5%>GBkA@?yiXAXI4capb$_9 zC~@bo&(rC{r~^dg)6;6Kq2ryKme<{Qe7Q%BjwydVK{7O=aaEcS*BxN@LAOACeGDvFwUy-m<`~NE; KgZ;1V|Nj6^h9%hm diff --git a/Code/script_idl_mv/astrolib/.idlwave_catalog b/Code/script_idl_mv/astrolib/.idlwave_catalog deleted file mode 100644 index 55907894..00000000 --- a/Code/script_idl_mv/astrolib/.idlwave_catalog +++ /dev/null @@ -1,583 +0,0 @@ -;; -;; 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 deleted file mode 100644 index ef148b0c..00000000 --- a/Code/script_idl_mv/astrolib/ad2xy.pro +++ /dev/null @@ -1,326 +0,0 @@ -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 deleted file mode 100644 index ca871fdd..00000000 --- a/Code/script_idl_mv/astrolib/add_distort.pro +++ /dev/null @@ -1,161 +0,0 @@ - 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 deleted file mode 100644 index 3e0ba133..00000000 --- a/Code/script_idl_mv/astrolib/adstring.pro +++ /dev/null @@ -1,208 +0,0 @@ -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 deleted file mode 100644 index 736a772d..00000000 --- a/Code/script_idl_mv/astrolib/adxy.pro +++ /dev/null @@ -1,139 +0,0 @@ -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 deleted file mode 100644 index 1cbdd01d..00000000 --- a/Code/script_idl_mv/astrolib/airtovac.pro +++ /dev/null @@ -1,67 +0,0 @@ -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 deleted file mode 100644 index 6e7fbee4..00000000 --- a/Code/script_idl_mv/astrolib/aitoff.pro +++ /dev/null @@ -1,56 +0,0 @@ -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 deleted file mode 100644 index 62e45f91..00000000 --- a/Code/script_idl_mv/astrolib/aitoff_grid.pro +++ /dev/null @@ -1,144 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 74c02f60..00000000 --- a/Code/script_idl_mv/astrolib/al_legend.pro +++ /dev/null @@ -1,572 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 55e33be9..00000000 --- a/Code/script_idl_mv/astrolib/al_legendtest.pro +++ /dev/null @@ -1,85 +0,0 @@ - -;+ -; 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 deleted file mode 100644 index 96d543b3..00000000 --- a/Code/script_idl_mv/astrolib/altaz2hadec.pro +++ /dev/null @@ -1,69 +0,0 @@ -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 deleted file mode 100644 index 940bb0cf..00000000 --- a/Code/script_idl_mv/astrolib/aper.pro +++ /dev/null @@ -1,476 +0,0 @@ -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 deleted file mode 100644 index b331d29c..00000000 --- a/Code/script_idl_mv/astrolib/arcbar.pro +++ /dev/null @@ -1,155 +0,0 @@ -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 deleted file mode 100644 index f1c78542..00000000 --- a/Code/script_idl_mv/astrolib/arrows.pro +++ /dev/null @@ -1,138 +0,0 @@ -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 deleted file mode 100644 index 0083d464..00000000 --- a/Code/script_idl_mv/astrolib/asinh.pro +++ /dev/null @@ -1,40 +0,0 @@ -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 deleted file mode 100644 index 1521c058..00000000 --- a/Code/script_idl_mv/astrolib/astdisp.pro +++ /dev/null @@ -1,98 +0,0 @@ -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 deleted file mode 100644 index 994a68d1..00000000 --- a/Code/script_idl_mv/astrolib/astro.pro +++ /dev/null @@ -1,175 +0,0 @@ -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 deleted file mode 100644 index 99d61f92..00000000 --- a/Code/script_idl_mv/astrolib/astrolib.pro +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index 66bff440..00000000 --- a/Code/script_idl_mv/astrolib/autohist.pro +++ /dev/null @@ -1,106 +0,0 @@ -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 deleted file mode 100644 index 8f1a242d..00000000 --- a/Code/script_idl_mv/astrolib/avg.pro +++ /dev/null @@ -1,111 +0,0 @@ -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 deleted file mode 100644 index 132532e0..00000000 --- a/Code/script_idl_mv/astrolib/baryvel.pro +++ /dev/null @@ -1,340 +0,0 @@ -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 deleted file mode 100644 index 2ecd438b..00000000 --- a/Code/script_idl_mv/astrolib/biweight_mean.pro +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index 0fd34c24..00000000 --- a/Code/script_idl_mv/astrolib/blink.pro +++ /dev/null @@ -1,114 +0,0 @@ -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 deleted file mode 100644 index faa8234c..00000000 --- a/Code/script_idl_mv/astrolib/blkshift.pro +++ /dev/null @@ -1,231 +0,0 @@ -;+ -; 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 deleted file mode 100644 index d1229033..00000000 --- a/Code/script_idl_mv/astrolib/boost_array.pro +++ /dev/null @@ -1,130 +0,0 @@ - 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 deleted file mode 100644 index 899de45a..00000000 --- a/Code/script_idl_mv/astrolib/boxave.pro +++ /dev/null @@ -1,128 +0,0 @@ -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 deleted file mode 100644 index cf812a62..00000000 --- a/Code/script_idl_mv/astrolib/bprecess.pro +++ /dev/null @@ -1,219 +0,0 @@ -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 deleted file mode 100644 index 703c381a..00000000 --- a/Code/script_idl_mv/astrolib/break_path.pro +++ /dev/null @@ -1,140 +0,0 @@ - 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 deleted file mode 100644 index b420f0a1..00000000 --- a/Code/script_idl_mv/astrolib/bsort.pro +++ /dev/null @@ -1,103 +0,0 @@ -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 deleted file mode 100644 index de407895..00000000 --- a/Code/script_idl_mv/astrolib/calz_unred.pro +++ /dev/null @@ -1,79 +0,0 @@ -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 deleted file mode 100644 index 7aacc109..00000000 --- a/Code/script_idl_mv/astrolib/ccm_unred.pro +++ /dev/null @@ -1,147 +0,0 @@ -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 deleted file mode 100644 index 000bffa2..00000000 --- a/Code/script_idl_mv/astrolib/check_fits.pro +++ /dev/null @@ -1,227 +0,0 @@ -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 deleted file mode 100644 index 2e23c540..00000000 --- a/Code/script_idl_mv/astrolib/checksum32.pro +++ /dev/null @@ -1,125 +0,0 @@ -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 deleted file mode 100644 index b1ff45bf..00000000 --- a/Code/script_idl_mv/astrolib/cic.pro +++ /dev/null @@ -1,417 +0,0 @@ -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 deleted file mode 100644 index e2044059..00000000 --- a/Code/script_idl_mv/astrolib/cirrange.pro +++ /dev/null @@ -1,49 +0,0 @@ -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 deleted file mode 100644 index abcd1b11..00000000 --- a/Code/script_idl_mv/astrolib/cleanplot.pro +++ /dev/null @@ -1,150 +0,0 @@ -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 deleted file mode 100644 index 04ceb814..00000000 --- a/Code/script_idl_mv/astrolib/cntrd.pro +++ /dev/null @@ -1,245 +0,0 @@ -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 deleted file mode 100644 index e1ea5e39..00000000 --- a/Code/script_idl_mv/astrolib/co_aberration.pro +++ /dev/null @@ -1,92 +0,0 @@ -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 deleted file mode 100644 index 4371a7a6..00000000 --- a/Code/script_idl_mv/astrolib/co_nutate.pro +++ /dev/null @@ -1,115 +0,0 @@ -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 deleted file mode 100644 index ec95de65..00000000 --- a/Code/script_idl_mv/astrolib/co_refract.pro +++ /dev/null @@ -1,186 +0,0 @@ -;+ -; 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 deleted file mode 100644 index aa497e36..00000000 --- a/Code/script_idl_mv/astrolib/compare_struct.pro +++ /dev/null @@ -1,239 +0,0 @@ -;+ -; 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 deleted file mode 100644 index a89656a9..00000000 --- a/Code/script_idl_mv/astrolib/concat_dir.pro +++ /dev/null @@ -1,110 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 414a9e18..00000000 --- a/Code/script_idl_mv/astrolib/cons_dec.pro +++ /dev/null @@ -1,116 +0,0 @@ -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 deleted file mode 100644 index c90fcb09..00000000 --- a/Code/script_idl_mv/astrolib/cons_ra.pro +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index f56e016a..00000000 --- a/Code/script_idl_mv/astrolib/convolve.pro +++ /dev/null @@ -1,178 +0,0 @@ -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 deleted file mode 100644 index 147fc0da..00000000 --- a/Code/script_idl_mv/astrolib/copy_struct.pro +++ /dev/null @@ -1,250 +0,0 @@ -;+ -; 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 deleted file mode 100644 index c162bb41..00000000 --- a/Code/script_idl_mv/astrolib/copy_struct_inx.pro +++ /dev/null @@ -1,287 +0,0 @@ -;+ -; 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 deleted file mode 100644 index de9aaa20..00000000 --- a/Code/script_idl_mv/astrolib/correl_images.pro +++ /dev/null @@ -1,210 +0,0 @@ -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 deleted file mode 100644 index 71c93951..00000000 --- a/Code/script_idl_mv/astrolib/correl_optimize.pro +++ /dev/null @@ -1,125 +0,0 @@ -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 deleted file mode 100644 index 26af51ca..00000000 --- a/Code/script_idl_mv/astrolib/corrmat_analyze.pro +++ /dev/null @@ -1,174 +0,0 @@ -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 deleted file mode 100644 index 4472c9de..00000000 --- a/Code/script_idl_mv/astrolib/cosmo_param.pro +++ /dev/null @@ -1,106 +0,0 @@ -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 deleted file mode 100644 index ec0e3159..00000000 --- a/Code/script_idl_mv/astrolib/cr_reject.pro +++ /dev/null @@ -1,886 +0,0 @@ -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 deleted file mode 100644 index 602dacb6..00000000 --- a/Code/script_idl_mv/astrolib/create_struct.pro +++ /dev/null @@ -1,309 +0,0 @@ -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 deleted file mode 100644 index 7dede40e..00000000 --- a/Code/script_idl_mv/astrolib/cspline.pro +++ /dev/null @@ -1,79 +0,0 @@ -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 deleted file mode 100644 index 2244ce8b..00000000 --- a/Code/script_idl_mv/astrolib/ct2lst.pro +++ /dev/null @@ -1,109 +0,0 @@ -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 deleted file mode 100644 index c6282e55..00000000 --- a/Code/script_idl_mv/astrolib/curs.pro +++ /dev/null @@ -1,135 +0,0 @@ -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 deleted file mode 100644 index 7dd13ba7..00000000 --- a/Code/script_idl_mv/astrolib/curval.pro +++ /dev/null @@ -1,304 +0,0 @@ -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 deleted file mode 100644 index 2aaa4aa4..00000000 --- a/Code/script_idl_mv/astrolib/dao_value.pro +++ /dev/null @@ -1,87 +0,0 @@ -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 deleted file mode 100644 index f1451e69..00000000 --- a/Code/script_idl_mv/astrolib/daoerf.pro +++ /dev/null @@ -1,58 +0,0 @@ -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 deleted file mode 100644 index 2abd07f6..00000000 --- a/Code/script_idl_mv/astrolib/date.pro +++ /dev/null @@ -1,75 +0,0 @@ -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 deleted file mode 100644 index e34a46d7..00000000 --- a/Code/script_idl_mv/astrolib/date_conv.pro +++ /dev/null @@ -1,449 +0,0 @@ -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 deleted file mode 100644 index d0f79583..00000000 --- a/Code/script_idl_mv/astrolib/daycnv.pro +++ /dev/null @@ -1,73 +0,0 @@ -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 deleted file mode 100644 index 987424df..00000000 --- a/Code/script_idl_mv/astrolib/db_ent2ext.pro +++ /dev/null @@ -1,121 +0,0 @@ - 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 deleted file mode 100644 index 52249502..00000000 --- a/Code/script_idl_mv/astrolib/db_ent2host.pro +++ /dev/null @@ -1,134 +0,0 @@ - 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 deleted file mode 100644 index 77d0dd88..00000000 --- a/Code/script_idl_mv/astrolib/db_info.pro +++ /dev/null @@ -1,218 +0,0 @@ -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 deleted file mode 100644 index 626dc071..00000000 --- a/Code/script_idl_mv/astrolib/db_item.pro +++ /dev/null @@ -1,347 +0,0 @@ -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 deleted file mode 100644 index 1dfa2b7e..00000000 --- a/Code/script_idl_mv/astrolib/db_item_info.pro +++ /dev/null @@ -1,122 +0,0 @@ -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 deleted file mode 100644 index cb6cd105..00000000 --- a/Code/script_idl_mv/astrolib/db_or.pro +++ /dev/null @@ -1,52 +0,0 @@ -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 deleted file mode 100644 index 3cb8389a..00000000 --- a/Code/script_idl_mv/astrolib/db_titles.pro +++ /dev/null @@ -1,54 +0,0 @@ -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 deleted file mode 100644 index 58b78d11..00000000 --- a/Code/script_idl_mv/astrolib/dbbuild.pro +++ /dev/null @@ -1,168 +0,0 @@ -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 deleted file mode 100644 index 8c5a44b0..00000000 --- a/Code/script_idl_mv/astrolib/dbcircle.pro +++ /dev/null @@ -1,208 +0,0 @@ -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 deleted file mode 100644 index f145b0b1..00000000 --- a/Code/script_idl_mv/astrolib/dbdelete.pro +++ /dev/null @@ -1,142 +0,0 @@ -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 deleted file mode 100644 index 1f439fd2..00000000 --- a/Code/script_idl_mv/astrolib/dbedit.pro +++ /dev/null @@ -1,395 +0,0 @@ -;+ -; 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 deleted file mode 100644 index d934c87f..00000000 --- a/Code/script_idl_mv/astrolib/dbedit_basic.pro +++ /dev/null @@ -1,157 +0,0 @@ -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 deleted file mode 100644 index 28250cf5..00000000 --- a/Code/script_idl_mv/astrolib/dbext.pro +++ /dev/null @@ -1,85 +0,0 @@ -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 deleted file mode 100644 index d56cadea..00000000 --- a/Code/script_idl_mv/astrolib/dbext_dbf.pro +++ /dev/null @@ -1,152 +0,0 @@ -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 deleted file mode 100644 index a9466e70..00000000 --- a/Code/script_idl_mv/astrolib/dbext_ind.pro +++ /dev/null @@ -1,143 +0,0 @@ -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 deleted file mode 100644 index f2bc1446..00000000 --- a/Code/script_idl_mv/astrolib/dbfind.pro +++ /dev/null @@ -1,382 +0,0 @@ -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 deleted file mode 100644 index f15fdbd0..00000000 --- a/Code/script_idl_mv/astrolib/dbfind_entry.pro +++ /dev/null @@ -1,117 +0,0 @@ -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 deleted file mode 100644 index 0218c20d..00000000 --- a/Code/script_idl_mv/astrolib/dbfparse.pro +++ /dev/null @@ -1,240 +0,0 @@ -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 deleted file mode 100644 index e2bb8b5a..00000000 --- a/Code/script_idl_mv/astrolib/dbhelp.pro +++ /dev/null @@ -1,275 +0,0 @@ -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 deleted file mode 100644 index 8359e9bb..00000000 --- a/Code/script_idl_mv/astrolib/dbindex.pro +++ /dev/null @@ -1,218 +0,0 @@ -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 deleted file mode 100644 index 70485702..00000000 --- a/Code/script_idl_mv/astrolib/dbindex_blk.pro +++ /dev/null @@ -1,49 +0,0 @@ -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 deleted file mode 100644 index e733a5e5..00000000 --- a/Code/script_idl_mv/astrolib/dbmatch.pro +++ /dev/null @@ -1,173 +0,0 @@ -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 deleted file mode 100644 index 2b10da69..00000000 --- a/Code/script_idl_mv/astrolib/dbopen.pro +++ /dev/null @@ -1,411 +0,0 @@ -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 deleted file mode 100644 index 6229081b..00000000 --- a/Code/script_idl_mv/astrolib/dbprint.pro +++ /dev/null @@ -1,318 +0,0 @@ -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 deleted file mode 100644 index 9dfe5d21..00000000 --- a/Code/script_idl_mv/astrolib/dbput.pro +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index 0697ddd5..00000000 --- a/Code/script_idl_mv/astrolib/dbrd.pro +++ /dev/null @@ -1,115 +0,0 @@ -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 deleted file mode 100644 index 4c955e85..00000000 --- a/Code/script_idl_mv/astrolib/dbsearch.pro +++ /dev/null @@ -1,139 +0,0 @@ -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 deleted file mode 100644 index 8c7f8f8e..00000000 --- a/Code/script_idl_mv/astrolib/dbtarget.pro +++ /dev/null @@ -1,93 +0,0 @@ -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 deleted file mode 100644 index 18232b9f..00000000 --- a/Code/script_idl_mv/astrolib/dbtitle.pro +++ /dev/null @@ -1,38 +0,0 @@ -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 deleted file mode 100644 index 73d252e7..00000000 --- a/Code/script_idl_mv/astrolib/dbupdate.pro +++ /dev/null @@ -1,163 +0,0 @@ -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 deleted file mode 100644 index 747f2142..00000000 --- a/Code/script_idl_mv/astrolib/dbval.pro +++ /dev/null @@ -1,50 +0,0 @@ -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 deleted file mode 100644 index 34f39f4d..00000000 --- a/Code/script_idl_mv/astrolib/dbwrt.pro +++ /dev/null @@ -1,195 +0,0 @@ -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 deleted file mode 100644 index 5de3f6c1..00000000 --- a/Code/script_idl_mv/astrolib/dbxput.pro +++ /dev/null @@ -1,56 +0,0 @@ -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 deleted file mode 100644 index 4b0693df..00000000 --- a/Code/script_idl_mv/astrolib/dbxval.pro +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index c7565058..00000000 --- a/Code/script_idl_mv/astrolib/delvarx.pro +++ /dev/null @@ -1,52 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 880f0d42..00000000 --- a/Code/script_idl_mv/astrolib/deredd.pro +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index c57f7c69..00000000 --- a/Code/script_idl_mv/astrolib/detabify.pro +++ /dev/null @@ -1,62 +0,0 @@ - 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 deleted file mode 100644 index a5457bfd..00000000 --- a/Code/script_idl_mv/astrolib/dist_circle.pro +++ /dev/null @@ -1,97 +0,0 @@ -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 deleted file mode 100644 index 0e23c31f..00000000 --- a/Code/script_idl_mv/astrolib/dist_ellipse.pro +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index c39625ec..00000000 --- a/Code/script_idl_mv/astrolib/eci2geo.pro +++ /dev/null @@ -1,81 +0,0 @@ -;+ -; 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 deleted file mode 100644 index fdb8bf39..00000000 --- a/Code/script_idl_mv/astrolib/eq2hor.pro +++ /dev/null @@ -1,300 +0,0 @@ -;+ -; 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 deleted file mode 100644 index e81654c6..00000000 --- a/Code/script_idl_mv/astrolib/eqpole.pro +++ /dev/null @@ -1,57 +0,0 @@ -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 deleted file mode 100644 index f400d174..00000000 --- a/Code/script_idl_mv/astrolib/eqpole_grid.pro +++ /dev/null @@ -1,147 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 9ab363d0..00000000 --- a/Code/script_idl_mv/astrolib/euler.pro +++ /dev/null @@ -1,169 +0,0 @@ -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 deleted file mode 100644 index 728bee66..00000000 --- a/Code/script_idl_mv/astrolib/expand_tilde.pro +++ /dev/null @@ -1,67 +0,0 @@ -;+ -; 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 deleted file mode 100644 index b6ba118f..00000000 --- a/Code/script_idl_mv/astrolib/extast.pro +++ /dev/null @@ -1,714 +0,0 @@ -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 deleted file mode 100644 index 0764cefe..00000000 --- a/Code/script_idl_mv/astrolib/extgrp.pro +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index ba7814d8..00000000 --- a/Code/script_idl_mv/astrolib/f_format.pro +++ /dev/null @@ -1,112 +0,0 @@ -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 deleted file mode 100644 index 683932bd..00000000 --- a/Code/script_idl_mv/astrolib/factor.pro +++ /dev/null @@ -1,277 +0,0 @@ -;------------------------------------------------------------- -;+ -; 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 deleted file mode 100644 index 3cf2677c..00000000 --- a/Code/script_idl_mv/astrolib/file_launch.pro +++ /dev/null @@ -1,108 +0,0 @@ -; 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 deleted file mode 100644 index 22e9c56b..00000000 --- a/Code/script_idl_mv/astrolib/filter_image.pro +++ /dev/null @@ -1,196 +0,0 @@ -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 deleted file mode 100644 index f1ed8d14..00000000 --- a/Code/script_idl_mv/astrolib/find.pro +++ /dev/null @@ -1,464 +0,0 @@ -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 deleted file mode 100644 index 61ce9587..00000000 --- a/Code/script_idl_mv/astrolib/find_all_dir.pro +++ /dev/null @@ -1,202 +0,0 @@ - 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 deleted file mode 100644 index 1fa4ade0..00000000 --- a/Code/script_idl_mv/astrolib/find_with_def.pro +++ /dev/null @@ -1,153 +0,0 @@ - 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 deleted file mode 100644 index 7f00a896..00000000 --- a/Code/script_idl_mv/astrolib/findpro.pro +++ /dev/null @@ -1,173 +0,0 @@ -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 deleted file mode 100644 index 5acf3127..00000000 --- a/Code/script_idl_mv/astrolib/fitexy.pro +++ /dev/null @@ -1,205 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 71492c77..00000000 --- a/Code/script_idl_mv/astrolib/fits_add_checksum.pro +++ /dev/null @@ -1,104 +0,0 @@ -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 deleted file mode 100644 index 1fbb628c..00000000 --- a/Code/script_idl_mv/astrolib/fits_ascii_encode.pro +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index 40a5219a..00000000 --- a/Code/script_idl_mv/astrolib/fits_cd_fix.pro +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 index 627f4a12..00000000 --- a/Code/script_idl_mv/astrolib/fits_close.pro +++ /dev/null @@ -1,66 +0,0 @@ -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 deleted file mode 100644 index 8bd19335..00000000 --- a/Code/script_idl_mv/astrolib/fits_help.pro +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index c0746d44..00000000 --- a/Code/script_idl_mv/astrolib/fits_info.pro +++ /dev/null @@ -1,348 +0,0 @@ -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 deleted file mode 100644 index 87bb87b0..00000000 --- a/Code/script_idl_mv/astrolib/fits_open.pro +++ /dev/null @@ -1,459 +0,0 @@ -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 deleted file mode 100644 index 3298d6ae..00000000 --- a/Code/script_idl_mv/astrolib/fits_read.pro +++ /dev/null @@ -1,573 +0,0 @@ -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 deleted file mode 100644 index 0ca0e512..00000000 --- a/Code/script_idl_mv/astrolib/fits_test_checksum.pro +++ /dev/null @@ -1,109 +0,0 @@ - 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 deleted file mode 100644 index 5ce3af2b..00000000 --- a/Code/script_idl_mv/astrolib/fits_write.pro +++ /dev/null @@ -1,379 +0,0 @@ -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 deleted file mode 100644 index d674003a..00000000 --- a/Code/script_idl_mv/astrolib/fitsdir.pro +++ /dev/null @@ -1,332 +0,0 @@ -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 deleted file mode 100644 index e3b711ad..00000000 --- a/Code/script_idl_mv/astrolib/fitsrgb_to_tiff.pro +++ /dev/null @@ -1,143 +0,0 @@ - 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 deleted file mode 100644 index 00fb5baf..00000000 --- a/Code/script_idl_mv/astrolib/flegendre.pro +++ /dev/null @@ -1,74 +0,0 @@ -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 deleted file mode 100644 index d21d9cf0..00000000 --- a/Code/script_idl_mv/astrolib/flux2mag.pro +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index 2bb8de24..00000000 --- a/Code/script_idl_mv/astrolib/fm_unred.pro +++ /dev/null @@ -1,174 +0,0 @@ -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 deleted file mode 100644 index b529e12f..00000000 --- a/Code/script_idl_mv/astrolib/forprint.pro +++ /dev/null @@ -1,240 +0,0 @@ -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 deleted file mode 100644 index 1f2e10ec..00000000 --- a/Code/script_idl_mv/astrolib/frebin.pro +++ /dev/null @@ -1,217 +0,0 @@ -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 deleted file mode 100644 index a2b3d1fe..00000000 --- a/Code/script_idl_mv/astrolib/ftab_help.pro +++ /dev/null @@ -1,103 +0,0 @@ -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 deleted file mode 100644 index 63bb8f97..00000000 --- a/Code/script_idl_mv/astrolib/ftab_print.pro +++ /dev/null @@ -1,107 +0,0 @@ -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 deleted file mode 100644 index a53d23a5..00000000 --- a/Code/script_idl_mv/astrolib/ftaddcol.pro +++ /dev/null @@ -1,150 +0,0 @@ -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 deleted file mode 100644 index 5602ed39..00000000 --- a/Code/script_idl_mv/astrolib/ftcreate.pro +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index 8c9fa914..00000000 --- a/Code/script_idl_mv/astrolib/ftdelcol.pro +++ /dev/null @@ -1,114 +0,0 @@ -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 deleted file mode 100644 index 5e64b7e4..00000000 --- a/Code/script_idl_mv/astrolib/ftdelrow.pro +++ /dev/null @@ -1,74 +0,0 @@ -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 deleted file mode 100644 index a5f6885f..00000000 --- a/Code/script_idl_mv/astrolib/ftget.pro +++ /dev/null @@ -1,146 +0,0 @@ -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 deleted file mode 100644 index 63eb46f3..00000000 --- a/Code/script_idl_mv/astrolib/fthelp.pro +++ /dev/null @@ -1,96 +0,0 @@ -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 deleted file mode 100644 index 2e1e8d38..00000000 --- a/Code/script_idl_mv/astrolib/fthmod.pro +++ /dev/null @@ -1,63 +0,0 @@ -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 deleted file mode 100644 index c5230fd8..00000000 --- a/Code/script_idl_mv/astrolib/ftinfo.pro +++ /dev/null @@ -1,116 +0,0 @@ -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 deleted file mode 100644 index f02c4b16..00000000 --- a/Code/script_idl_mv/astrolib/ftkeeprow.pro +++ /dev/null @@ -1,41 +0,0 @@ -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 deleted file mode 100644 index 71278e0b..00000000 --- a/Code/script_idl_mv/astrolib/ftprint.pro +++ /dev/null @@ -1,170 +0,0 @@ -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 deleted file mode 100644 index cee3f6c5..00000000 --- a/Code/script_idl_mv/astrolib/ftput.pro +++ /dev/null @@ -1,174 +0,0 @@ -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 deleted file mode 100644 index 81c633c1..00000000 --- a/Code/script_idl_mv/astrolib/ftsize.pro +++ /dev/null @@ -1,73 +0,0 @@ -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 deleted file mode 100644 index 0e3c86b5..00000000 --- a/Code/script_idl_mv/astrolib/ftsort.pro +++ /dev/null @@ -1,97 +0,0 @@ -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 deleted file mode 100644 index 3f40df49..00000000 --- a/Code/script_idl_mv/astrolib/fxaddpar.pro +++ /dev/null @@ -1,718 +0,0 @@ -;+ -; 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 deleted file mode 100644 index fc09694d..00000000 --- a/Code/script_idl_mv/astrolib/fxbaddcol.pro +++ /dev/null @@ -1,382 +0,0 @@ - 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 deleted file mode 100644 index 2c6987c0..00000000 --- a/Code/script_idl_mv/astrolib/fxbclose.pro +++ /dev/null @@ -1,101 +0,0 @@ - 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 deleted file mode 100644 index c456cb56..00000000 --- a/Code/script_idl_mv/astrolib/fxbcolnum.pro +++ /dev/null @@ -1,124 +0,0 @@ - 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 deleted file mode 100644 index 45a2fa9d..00000000 --- a/Code/script_idl_mv/astrolib/fxbcreate.pro +++ /dev/null @@ -1,190 +0,0 @@ - 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 deleted file mode 100644 index 16bc619a..00000000 --- a/Code/script_idl_mv/astrolib/fxbdimen.pro +++ /dev/null @@ -1,127 +0,0 @@ - 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 deleted file mode 100644 index 530835de..00000000 --- a/Code/script_idl_mv/astrolib/fxbfind.pro +++ /dev/null @@ -1,158 +0,0 @@ - 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 deleted file mode 100644 index 78b3bb8b..00000000 --- a/Code/script_idl_mv/astrolib/fxbfindlun.pro +++ /dev/null @@ -1,120 +0,0 @@ - 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 deleted file mode 100644 index e5c9b39f..00000000 --- a/Code/script_idl_mv/astrolib/fxbfinish.pro +++ /dev/null @@ -1,129 +0,0 @@ - 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 deleted file mode 100644 index 6285bce4..00000000 --- a/Code/script_idl_mv/astrolib/fxbgrow.pro +++ /dev/null @@ -1,245 +0,0 @@ - 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 deleted file mode 100644 index 6e37e19a..00000000 --- a/Code/script_idl_mv/astrolib/fxbheader.pro +++ /dev/null @@ -1,81 +0,0 @@ - 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 deleted file mode 100644 index 2a7c1997..00000000 --- a/Code/script_idl_mv/astrolib/fxbhelp.pro +++ /dev/null @@ -1,128 +0,0 @@ - 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 deleted file mode 100644 index 7d9ff316..00000000 --- a/Code/script_idl_mv/astrolib/fxbhmake.pro +++ /dev/null @@ -1,150 +0,0 @@ - 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 deleted file mode 100644 index f4791a2d..00000000 --- a/Code/script_idl_mv/astrolib/fxbintable.pro +++ /dev/null @@ -1,71 +0,0 @@ -;+ -; 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 deleted file mode 100644 index ae5fca17..00000000 --- a/Code/script_idl_mv/astrolib/fxbisopen.pro +++ /dev/null @@ -1,77 +0,0 @@ - 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 deleted file mode 100644 index f3273776..00000000 --- a/Code/script_idl_mv/astrolib/fxbopen.pro +++ /dev/null @@ -1,350 +0,0 @@ - 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 deleted file mode 100644 index 92601d50..00000000 --- a/Code/script_idl_mv/astrolib/fxbparse.pro +++ /dev/null @@ -1,162 +0,0 @@ - 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 deleted file mode 100644 index a482f0e7..00000000 --- a/Code/script_idl_mv/astrolib/fxbread.pro +++ /dev/null @@ -1,388 +0,0 @@ - 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 deleted file mode 100644 index cf70a8da..00000000 --- a/Code/script_idl_mv/astrolib/fxbreadm.pro +++ /dev/null @@ -1,905 +0,0 @@ -;+ -; 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 deleted file mode 100644 index b2de4693..00000000 --- a/Code/script_idl_mv/astrolib/fxbstate.pro +++ /dev/null @@ -1,74 +0,0 @@ - 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 deleted file mode 100644 index 3c116e75..00000000 --- a/Code/script_idl_mv/astrolib/fxbtdim.pro +++ /dev/null @@ -1,90 +0,0 @@ - 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 deleted file mode 100644 index c0e05d53..00000000 --- a/Code/script_idl_mv/astrolib/fxbtform.pro +++ /dev/null @@ -1,212 +0,0 @@ - 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 deleted file mode 100644 index 0c0f4539..00000000 --- a/Code/script_idl_mv/astrolib/fxbwrite.pro +++ /dev/null @@ -1,282 +0,0 @@ - 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 deleted file mode 100644 index a07f508a..00000000 --- a/Code/script_idl_mv/astrolib/fxbwritm.pro +++ /dev/null @@ -1,713 +0,0 @@ - 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 deleted file mode 100644 index b33c1aaa..00000000 --- a/Code/script_idl_mv/astrolib/fxfindend.pro +++ /dev/null @@ -1,93 +0,0 @@ - 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 deleted file mode 100644 index 2b162ed1..00000000 --- a/Code/script_idl_mv/astrolib/fxhclean.pro +++ /dev/null @@ -1,110 +0,0 @@ - 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 deleted file mode 100644 index 598a455b..00000000 --- a/Code/script_idl_mv/astrolib/fxhmake.pro +++ /dev/null @@ -1,252 +0,0 @@ - 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 deleted file mode 100644 index 8ac0ad27..00000000 --- a/Code/script_idl_mv/astrolib/fxhmodify.pro +++ /dev/null @@ -1,277 +0,0 @@ -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 deleted file mode 100644 index 3a4da731..00000000 --- a/Code/script_idl_mv/astrolib/fxhread.pro +++ /dev/null @@ -1,119 +0,0 @@ - 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 deleted file mode 100644 index 02b93bf2..00000000 --- a/Code/script_idl_mv/astrolib/fxmove.pro +++ /dev/null @@ -1,137 +0,0 @@ -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 deleted file mode 100644 index a456b5a1..00000000 --- a/Code/script_idl_mv/astrolib/fxpar.pro +++ /dev/null @@ -1,462 +0,0 @@ - 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 deleted file mode 100644 index eb3b0ec5..00000000 --- a/Code/script_idl_mv/astrolib/fxparpos.pro +++ /dev/null @@ -1,85 +0,0 @@ - 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 deleted file mode 100644 index ba2263da..00000000 --- a/Code/script_idl_mv/astrolib/fxposit.pro +++ /dev/null @@ -1,267 +0,0 @@ - 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 deleted file mode 100644 index d609ff24..00000000 --- a/Code/script_idl_mv/astrolib/fxread.pro +++ /dev/null @@ -1,588 +0,0 @@ - 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 deleted file mode 100644 index 30e2c7c1..00000000 --- a/Code/script_idl_mv/astrolib/fxwrite.pro +++ /dev/null @@ -1,312 +0,0 @@ - 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 deleted file mode 100644 index d6407e28..00000000 --- a/Code/script_idl_mv/astrolib/gal_flat.pro +++ /dev/null @@ -1,94 +0,0 @@ -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 deleted file mode 100644 index 69e63b97..00000000 --- a/Code/script_idl_mv/astrolib/gal_uvw.pro +++ /dev/null @@ -1,130 +0,0 @@ -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 deleted file mode 100644 index c42c4946..00000000 --- a/Code/script_idl_mv/astrolib/galage.pro +++ /dev/null @@ -1,130 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 1f640a1a..00000000 --- a/Code/script_idl_mv/astrolib/gaussian.pro +++ /dev/null @@ -1,107 +0,0 @@ -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 deleted file mode 100644 index 06e0d717..00000000 --- a/Code/script_idl_mv/astrolib/gcirc.pro +++ /dev/null @@ -1,123 +0,0 @@ -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 deleted file mode 100644 index 344d6ca7..00000000 --- a/Code/script_idl_mv/astrolib/gcntrd.pro +++ /dev/null @@ -1,326 +0,0 @@ -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 deleted file mode 100644 index d11208c6..00000000 --- a/Code/script_idl_mv/astrolib/geo2eci.pro +++ /dev/null @@ -1,79 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 225384ab..00000000 --- a/Code/script_idl_mv/astrolib/geo2geodetic.pro +++ /dev/null @@ -1,153 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 21f87867..00000000 --- a/Code/script_idl_mv/astrolib/geo2mag.pro +++ /dev/null @@ -1,103 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 0615516b..00000000 --- a/Code/script_idl_mv/astrolib/geodetic2geo.pro +++ /dev/null @@ -1,125 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 0e3427c9..00000000 --- a/Code/script_idl_mv/astrolib/get_coords.pro +++ /dev/null @@ -1,165 +0,0 @@ -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 deleted file mode 100644 index d18e8549..00000000 --- a/Code/script_idl_mv/astrolib/get_date.pro +++ /dev/null @@ -1,109 +0,0 @@ -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 deleted file mode 100644 index d1a24853..00000000 --- a/Code/script_idl_mv/astrolib/get_equinox.pro +++ /dev/null @@ -1,101 +0,0 @@ -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 deleted file mode 100644 index 585cc7d8..00000000 --- a/Code/script_idl_mv/astrolib/get_juldate.pro +++ /dev/null @@ -1,44 +0,0 @@ -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 deleted file mode 100644 index 743b6af9..00000000 --- a/Code/script_idl_mv/astrolib/get_pipe_filesize.pro +++ /dev/null @@ -1,57 +0,0 @@ -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 deleted file mode 100644 index 9ad56a95..00000000 --- a/Code/script_idl_mv/astrolib/getopt.pro +++ /dev/null @@ -1,95 +0,0 @@ -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 deleted file mode 100644 index 04608077..00000000 --- a/Code/script_idl_mv/astrolib/getpro.pro +++ /dev/null @@ -1,126 +0,0 @@ -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 deleted file mode 100644 index d2c36f36..00000000 --- a/Code/script_idl_mv/astrolib/getpsf.pro +++ /dev/null @@ -1,405 +0,0 @@ -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 deleted file mode 100644 index edac6da6..00000000 --- a/Code/script_idl_mv/astrolib/glactc.pro +++ /dev/null @@ -1,140 +0,0 @@ -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 deleted file mode 100644 index 75c0206c..00000000 --- a/Code/script_idl_mv/astrolib/glactc_pm.pro +++ /dev/null @@ -1,193 +0,0 @@ -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 deleted file mode 100644 index 2df2d6f4..00000000 --- a/Code/script_idl_mv/astrolib/group.pro +++ /dev/null @@ -1,107 +0,0 @@ -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 deleted file mode 100644 index 12793f12..00000000 --- a/Code/script_idl_mv/astrolib/gsss_stdast.pro +++ /dev/null @@ -1,105 +0,0 @@ -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 deleted file mode 100644 index 561c644c..00000000 --- a/Code/script_idl_mv/astrolib/gsssadxy.pro +++ /dev/null @@ -1,174 +0,0 @@ -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 deleted file mode 100644 index 65340a69..00000000 --- a/Code/script_idl_mv/astrolib/gsssextast.pro +++ /dev/null @@ -1,99 +0,0 @@ -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 deleted file mode 100644 index 70d7c18e..00000000 --- a/Code/script_idl_mv/astrolib/gsssxyad.pro +++ /dev/null @@ -1,116 +0,0 @@ -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 deleted file mode 100644 index 6876ca23..00000000 --- a/Code/script_idl_mv/astrolib/hadec2altaz.pro +++ /dev/null @@ -1,74 +0,0 @@ -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 deleted file mode 100644 index ff3c4a61..00000000 --- a/Code/script_idl_mv/astrolib/hastrom.pro +++ /dev/null @@ -1,317 +0,0 @@ -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 deleted file mode 100644 index d5cfc59f..00000000 --- a/Code/script_idl_mv/astrolib/hboxave.pro +++ /dev/null @@ -1,162 +0,0 @@ -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 deleted file mode 100644 index 68e6b556..00000000 --- a/Code/script_idl_mv/astrolib/hcongrid.pro +++ /dev/null @@ -1,302 +0,0 @@ -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 deleted file mode 100644 index c6495e40..00000000 --- a/Code/script_idl_mv/astrolib/headfits.pro +++ /dev/null @@ -1,118 +0,0 @@ -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 deleted file mode 100644 index 70ba4a8c..00000000 --- a/Code/script_idl_mv/astrolib/helio.pro +++ /dev/null @@ -1,189 +0,0 @@ -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 deleted file mode 100644 index af82fbc1..00000000 --- a/Code/script_idl_mv/astrolib/helio_jd.pro +++ /dev/null @@ -1,102 +0,0 @@ -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 deleted file mode 100644 index cd6fe2c2..00000000 --- a/Code/script_idl_mv/astrolib/helio_rv.pro +++ /dev/null @@ -1,145 +0,0 @@ -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 deleted file mode 100644 index 9023f920..00000000 --- a/Code/script_idl_mv/astrolib/hermite.pro +++ /dev/null @@ -1,129 +0,0 @@ -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 deleted file mode 100644 index 2c7dd973..00000000 --- a/Code/script_idl_mv/astrolib/heuler.pro +++ /dev/null @@ -1,169 +0,0 @@ -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 deleted file mode 100644 index 111147a1..00000000 --- a/Code/script_idl_mv/astrolib/hextract.pro +++ /dev/null @@ -1,205 +0,0 @@ -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 deleted file mode 100644 index b998f5d7..00000000 --- a/Code/script_idl_mv/astrolib/hgrep.pro +++ /dev/null @@ -1,65 +0,0 @@ -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 deleted file mode 100644 index 1c7401b4..00000000 --- a/Code/script_idl_mv/astrolib/histogauss.pro +++ /dev/null @@ -1,196 +0,0 @@ -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 deleted file mode 100644 index e7b086ad..00000000 --- a/Code/script_idl_mv/astrolib/hor2eq.pro +++ /dev/null @@ -1,256 +0,0 @@ -;+ -; 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 deleted file mode 100644 index ff17e006..00000000 --- a/Code/script_idl_mv/astrolib/host_to_ieee.pro +++ /dev/null @@ -1,98 +0,0 @@ -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 deleted file mode 100644 index 6dc544c0..00000000 --- a/Code/script_idl_mv/astrolib/hprecess.pro +++ /dev/null @@ -1,134 +0,0 @@ -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 deleted file mode 100644 index 6b587e47..00000000 --- a/Code/script_idl_mv/astrolib/hprint.pro +++ /dev/null @@ -1,100 +0,0 @@ -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 deleted file mode 100644 index 86b3ec25..00000000 --- a/Code/script_idl_mv/astrolib/hrebin.pro +++ /dev/null @@ -1,277 +0,0 @@ - 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 deleted file mode 100644 index 446008e5..00000000 --- a/Code/script_idl_mv/astrolib/hreverse.pro +++ /dev/null @@ -1,165 +0,0 @@ -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 deleted file mode 100644 index f905ffee..00000000 --- a/Code/script_idl_mv/astrolib/hrot.pro +++ /dev/null @@ -1,251 +0,0 @@ -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 deleted file mode 100644 index ac20f84e..00000000 --- a/Code/script_idl_mv/astrolib/hrotate.pro +++ /dev/null @@ -1,214 +0,0 @@ -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 deleted file mode 100644 index cb1b1f38..00000000 --- a/Code/script_idl_mv/astrolib/ieee_to_host.pro +++ /dev/null @@ -1,104 +0,0 @@ -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 deleted file mode 100644 index 2665ca84..00000000 --- a/Code/script_idl_mv/astrolib/imcontour.pro +++ /dev/null @@ -1,335 +0,0 @@ -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 deleted file mode 100644 index d2970eab..00000000 --- a/Code/script_idl_mv/astrolib/imdbase.pro +++ /dev/null @@ -1,205 +0,0 @@ -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 deleted file mode 100644 index 4c0f7e8d..00000000 --- a/Code/script_idl_mv/astrolib/imf.pro +++ /dev/null @@ -1,129 +0,0 @@ -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 deleted file mode 100644 index 58e9bd63..00000000 --- a/Code/script_idl_mv/astrolib/imlist.pro +++ /dev/null @@ -1,231 +0,0 @@ -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 deleted file mode 100644 index 8b064eb2..00000000 --- a/Code/script_idl_mv/astrolib/irafdir.pro +++ /dev/null @@ -1,185 +0,0 @@ -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 deleted file mode 100644 index c4d18bab..00000000 --- a/Code/script_idl_mv/astrolib/irafrd.pro +++ /dev/null @@ -1,300 +0,0 @@ -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 deleted file mode 100644 index c4609f3c..00000000 --- a/Code/script_idl_mv/astrolib/irafwrt.pro +++ /dev/null @@ -1,249 +0,0 @@ -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 deleted file mode 100644 index 9127dd72..00000000 --- a/Code/script_idl_mv/astrolib/is_ieee_big.pro +++ /dev/null @@ -1,32 +0,0 @@ -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 deleted file mode 100644 index 0e7e051b..00000000 --- a/Code/script_idl_mv/astrolib/isarray.pro +++ /dev/null @@ -1,20 +0,0 @@ -;+ -; 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 deleted file mode 100644 index c23a501a..00000000 --- a/Code/script_idl_mv/astrolib/ismeuv.pro +++ /dev/null @@ -1,176 +0,0 @@ -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 deleted file mode 100644 index 652dd301..00000000 --- a/Code/script_idl_mv/astrolib/jdcnv.pro +++ /dev/null @@ -1,67 +0,0 @@ -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 deleted file mode 100644 index 61d10dfe..00000000 --- a/Code/script_idl_mv/astrolib/jplephinterp.pro +++ /dev/null @@ -1,745 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 841679fa..00000000 --- a/Code/script_idl_mv/astrolib/jplephread.pro +++ /dev/null @@ -1,404 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 5f441d38..00000000 --- a/Code/script_idl_mv/astrolib/jplephtest.pro +++ /dev/null @@ -1,194 +0,0 @@ -;+ -; 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 deleted file mode 100644 index bf843af8..00000000 --- a/Code/script_idl_mv/astrolib/jprecess.pro +++ /dev/null @@ -1,226 +0,0 @@ -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 deleted file mode 100644 index c6d0281e..00000000 --- a/Code/script_idl_mv/astrolib/juldate.pro +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index c8b2ab06..00000000 --- a/Code/script_idl_mv/astrolib/ksone.pro +++ /dev/null @@ -1,125 +0,0 @@ - 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 deleted file mode 100644 index 28619ce9..00000000 --- a/Code/script_idl_mv/astrolib/kstwo.pro +++ /dev/null @@ -1,100 +0,0 @@ - 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 deleted file mode 100644 index 665960b5..00000000 --- a/Code/script_idl_mv/astrolib/kuiperone.pro +++ /dev/null @@ -1,126 +0,0 @@ - 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 deleted file mode 100644 index 8f9827ca..00000000 --- a/Code/script_idl_mv/astrolib/kuipertwo.pro +++ /dev/null @@ -1,132 +0,0 @@ - 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 deleted file mode 100644 index 8665e280..00000000 --- a/Code/script_idl_mv/astrolib/lineid_plot.pro +++ /dev/null @@ -1,261 +0,0 @@ -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 deleted file mode 100644 index d1b24f1d..00000000 --- a/Code/script_idl_mv/astrolib/linmix_err.pro +++ /dev/null @@ -1,1308 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index 95ead98b..00000000 --- a/Code/script_idl_mv/astrolib/linterp.pro +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index 0814d539..00000000 --- a/Code/script_idl_mv/astrolib/list_with_path.pro +++ /dev/null @@ -1,70 +0,0 @@ - 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 deleted file mode 100644 index 9914869d..00000000 --- a/Code/script_idl_mv/astrolib/lsf_rotate.pro +++ /dev/null @@ -1,80 +0,0 @@ - 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 deleted file mode 100644 index 17113123..00000000 --- a/Code/script_idl_mv/astrolib/lumdist.pro +++ /dev/null @@ -1,123 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 030e405f..00000000 --- a/Code/script_idl_mv/astrolib/mag2flux.pro +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index 7cada630..00000000 --- a/Code/script_idl_mv/astrolib/mag2geo.pro +++ /dev/null @@ -1,97 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 0b75a198..00000000 --- a/Code/script_idl_mv/astrolib/make_2d.pro +++ /dev/null @@ -1,57 +0,0 @@ -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 deleted file mode 100644 index 20177f4e..00000000 --- a/Code/script_idl_mv/astrolib/make_astr.pro +++ /dev/null @@ -1,258 +0,0 @@ -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 deleted file mode 100644 index af66c90b..00000000 --- a/Code/script_idl_mv/astrolib/match.pro +++ /dev/null @@ -1,170 +0,0 @@ -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 deleted file mode 100644 index 16b33cea..00000000 --- a/Code/script_idl_mv/astrolib/match2.pro +++ /dev/null @@ -1,169 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 4c99ea30..00000000 --- a/Code/script_idl_mv/astrolib/max_entropy.pro +++ /dev/null @@ -1,79 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 11e82804..00000000 --- a/Code/script_idl_mv/astrolib/max_likelihood.pro +++ /dev/null @@ -1,93 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 995011c0..00000000 --- a/Code/script_idl_mv/astrolib/meanclip.pro +++ /dev/null @@ -1,86 +0,0 @@ -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 deleted file mode 100644 index a3f0b7be..00000000 --- a/Code/script_idl_mv/astrolib/medarr.pro +++ /dev/null @@ -1,132 +0,0 @@ -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 deleted file mode 100644 index 15d95931..00000000 --- a/Code/script_idl_mv/astrolib/medsmooth.pro +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index a0de52c5..00000000 --- a/Code/script_idl_mv/astrolib/minf_bracket.pro +++ /dev/null @@ -1,130 +0,0 @@ -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 deleted file mode 100644 index 81a32bcc..00000000 --- a/Code/script_idl_mv/astrolib/minf_conj_grad.pro +++ /dev/null @@ -1,127 +0,0 @@ -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 deleted file mode 100644 index 313a043a..00000000 --- a/Code/script_idl_mv/astrolib/minf_parabol_d.pro +++ /dev/null @@ -1,173 +0,0 @@ -; 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 deleted file mode 100644 index eff8345c..00000000 --- a/Code/script_idl_mv/astrolib/minf_parabolic.pro +++ /dev/null @@ -1,147 +0,0 @@ -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 deleted file mode 100644 index 71b8e37f..00000000 --- a/Code/script_idl_mv/astrolib/minmax.pro +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index bf130b1c..00000000 --- a/Code/script_idl_mv/astrolib/mkhdr.pro +++ /dev/null @@ -1,169 +0,0 @@ -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 deleted file mode 100644 index b74da78d..00000000 --- a/Code/script_idl_mv/astrolib/mlinmix_err.pro +++ /dev/null @@ -1,878 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index cd0dd15d..00000000 --- a/Code/script_idl_mv/astrolib/mmm.pro +++ /dev/null @@ -1,310 +0,0 @@ -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 deleted file mode 100644 index a922f9be..00000000 --- a/Code/script_idl_mv/astrolib/modfits.pro +++ /dev/null @@ -1,321 +0,0 @@ -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 deleted file mode 100644 index 39a771b4..00000000 --- a/Code/script_idl_mv/astrolib/month_cnv.pro +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index 3b026f8f..00000000 --- a/Code/script_idl_mv/astrolib/moonpos.pro +++ /dev/null @@ -1,250 +0,0 @@ - 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 deleted file mode 100644 index 40840796..00000000 --- a/Code/script_idl_mv/astrolib/mphase.pro +++ /dev/null @@ -1,56 +0,0 @@ -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 deleted file mode 100644 index 1d976ca7..00000000 --- a/Code/script_idl_mv/astrolib/mrandomn.pro +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 index f464e98c..00000000 --- a/Code/script_idl_mv/astrolib/mrd_hread.pro +++ /dev/null @@ -1,135 +0,0 @@ -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 deleted file mode 100644 index 40744eef..00000000 --- a/Code/script_idl_mv/astrolib/mrd_skip.pro +++ /dev/null @@ -1,72 +0,0 @@ -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 deleted file mode 100644 index d11fd0db..00000000 --- a/Code/script_idl_mv/astrolib/multinom.pro +++ /dev/null @@ -1,81 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index 0dea9200..00000000 --- a/Code/script_idl_mv/astrolib/multiplot.pro +++ /dev/null @@ -1,555 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 28f71020..00000000 --- a/Code/script_idl_mv/astrolib/mwrfits.pro +++ /dev/null @@ -1,1731 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 4e73c561..00000000 --- a/Code/script_idl_mv/astrolib/n_bytes.pro +++ /dev/null @@ -1,52 +0,0 @@ -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 deleted file mode 100644 index 301ec63f..00000000 --- a/Code/script_idl_mv/astrolib/ngp.pro +++ /dev/null @@ -1,201 +0,0 @@ -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 deleted file mode 100644 index 3b54e2f4..00000000 --- a/Code/script_idl_mv/astrolib/nint.pro +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index 9552aaf1..00000000 --- a/Code/script_idl_mv/astrolib/nstar.pro +++ /dev/null @@ -1,485 +0,0 @@ -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 deleted file mode 100644 index 47dadbdf..00000000 --- a/Code/script_idl_mv/astrolib/nulltrim.pro +++ /dev/null @@ -1,26 +0,0 @@ -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 deleted file mode 100644 index 9502438b..00000000 --- a/Code/script_idl_mv/astrolib/nutate.pro +++ /dev/null @@ -1,145 +0,0 @@ -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 deleted file mode 100644 index 9e16ccf9..00000000 --- a/Code/script_idl_mv/astrolib/observatory.pro +++ /dev/null @@ -1,440 +0,0 @@ -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 deleted file mode 100644 index 98d64f43..00000000 --- a/Code/script_idl_mv/astrolib/one_arrow.pro +++ /dev/null @@ -1,115 +0,0 @@ -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 deleted file mode 100644 index 6714878b..00000000 --- a/Code/script_idl_mv/astrolib/one_ray.pro +++ /dev/null @@ -1,62 +0,0 @@ -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 deleted file mode 100644 index 742f2143..00000000 --- a/Code/script_idl_mv/astrolib/oploterror.pro +++ /dev/null @@ -1,308 +0,0 @@ -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 deleted file mode 100644 index c0f4f1ea..00000000 --- a/Code/script_idl_mv/astrolib/ordinal.pro +++ /dev/null @@ -1,37 +0,0 @@ -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 deleted file mode 100644 index 69a64ee5..00000000 --- a/Code/script_idl_mv/astrolib/partvelvec.pro +++ /dev/null @@ -1,250 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 6004f48d..00000000 --- a/Code/script_idl_mv/astrolib/pca.pro +++ /dev/null @@ -1,264 +0,0 @@ -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 deleted file mode 100644 index 7461f684..00000000 --- a/Code/script_idl_mv/astrolib/pent.pro +++ /dev/null @@ -1,145 +0,0 @@ - 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 deleted file mode 100644 index 7baea747..00000000 --- a/Code/script_idl_mv/astrolib/permute.pro +++ /dev/null @@ -1,122 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 76408637..00000000 --- a/Code/script_idl_mv/astrolib/pixcolor.pro +++ /dev/null @@ -1,100 +0,0 @@ -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 deleted file mode 100644 index 3dc8233f..00000000 --- a/Code/script_idl_mv/astrolib/pixwt.pro +++ /dev/null @@ -1,257 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 5815e362..00000000 --- a/Code/script_idl_mv/astrolib/pkfit.pro +++ /dev/null @@ -1,247 +0,0 @@ -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 deleted file mode 100644 index ffbf5908..00000000 --- a/Code/script_idl_mv/astrolib/planck.pro +++ /dev/null @@ -1,71 +0,0 @@ -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 deleted file mode 100644 index 3f62cddb..00000000 --- a/Code/script_idl_mv/astrolib/planet_coords.pro +++ /dev/null @@ -1,169 +0,0 @@ -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 deleted file mode 100644 index dbb3515a..00000000 --- a/Code/script_idl_mv/astrolib/ploterror.pro +++ /dev/null @@ -1,334 +0,0 @@ -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 deleted file mode 100644 index b311a1ef..00000000 --- a/Code/script_idl_mv/astrolib/plothist.pro +++ /dev/null @@ -1,369 +0,0 @@ -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 deleted file mode 100644 index 70bbcaf8..00000000 --- a/Code/script_idl_mv/astrolib/poidev.pro +++ /dev/null @@ -1,134 +0,0 @@ -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 deleted file mode 100644 index 9c36b4b8..00000000 --- a/Code/script_idl_mv/astrolib/polint.pro +++ /dev/null @@ -1,85 +0,0 @@ -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 deleted file mode 100644 index 1b246b11..00000000 --- a/Code/script_idl_mv/astrolib/polrec.pro +++ /dev/null @@ -1,52 +0,0 @@ -;------------------------------------------------------------- -;+ -; 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 deleted file mode 100644 index 0289e4f4..00000000 --- a/Code/script_idl_mv/astrolib/poly_smooth.pro +++ /dev/null @@ -1,191 +0,0 @@ -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 deleted file mode 100644 index e32dd858..00000000 --- a/Code/script_idl_mv/astrolib/posang.pro +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index 6e0abc57..00000000 --- a/Code/script_idl_mv/astrolib/positivity.pro +++ /dev/null @@ -1,50 +0,0 @@ -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 deleted file mode 100644 index e304799b..00000000 --- a/Code/script_idl_mv/astrolib/precess.pro +++ /dev/null @@ -1,163 +0,0 @@ -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 deleted file mode 100644 index fbf071c2..00000000 --- a/Code/script_idl_mv/astrolib/precess_cd.pro +++ /dev/null @@ -1,105 +0,0 @@ -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 deleted file mode 100644 index 01801304..00000000 --- a/Code/script_idl_mv/astrolib/precess_xyz.pro +++ /dev/null @@ -1,63 +0,0 @@ -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 deleted file mode 100644 index 63b055b3..00000000 --- a/Code/script_idl_mv/astrolib/premat.pro +++ /dev/null @@ -1,92 +0,0 @@ -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 deleted file mode 100644 index 490916eb..00000000 --- a/Code/script_idl_mv/astrolib/prime.pro +++ /dev/null @@ -1,81 +0,0 @@ -;------------------------------------------------------------- -;+ -; 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 deleted file mode 100644 index 9271a6e1..00000000 --- a/Code/script_idl_mv/astrolib/print_struct.pro +++ /dev/null @@ -1,245 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 43df32d7..00000000 --- a/Code/script_idl_mv/astrolib/prob_ks.pro +++ /dev/null @@ -1,70 +0,0 @@ -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 deleted file mode 100644 index 25c13f9f..00000000 --- a/Code/script_idl_mv/astrolib/prob_kuiper.pro +++ /dev/null @@ -1,76 +0,0 @@ -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 deleted file mode 100644 index 1c0b94df..00000000 --- a/Code/script_idl_mv/astrolib/psf_gaussian.pro +++ /dev/null @@ -1,190 +0,0 @@ -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 deleted file mode 100644 index c7231c27..00000000 --- a/Code/script_idl_mv/astrolib/putast.pro +++ /dev/null @@ -1,484 +0,0 @@ -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 deleted file mode 100644 index 432d7677..00000000 --- a/Code/script_idl_mv/astrolib/qdcb_grid.pro +++ /dev/null @@ -1,162 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 0b615920..00000000 --- a/Code/script_idl_mv/astrolib/qget_string.pro +++ /dev/null @@ -1,89 +0,0 @@ -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 deleted file mode 100644 index 3e571459..00000000 --- a/Code/script_idl_mv/astrolib/qsimp.pro +++ /dev/null @@ -1,99 +0,0 @@ -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 deleted file mode 100644 index 22532d18..00000000 --- a/Code/script_idl_mv/astrolib/qtrap.pro +++ /dev/null @@ -1,84 +0,0 @@ -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 deleted file mode 100644 index 6f18f3bd..00000000 --- a/Code/script_idl_mv/astrolib/quadterp.pro +++ /dev/null @@ -1,128 +0,0 @@ -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 deleted file mode 100644 index 5886516a..00000000 --- a/Code/script_idl_mv/astrolib/query_irsa_cat.pro +++ /dev/null @@ -1,258 +0,0 @@ -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 deleted file mode 100644 index 6b04de01..00000000 --- a/Code/script_idl_mv/astrolib/querydss.pro +++ /dev/null @@ -1,182 +0,0 @@ -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 deleted file mode 100644 index d59af6bc..00000000 --- a/Code/script_idl_mv/astrolib/querygsc.pro +++ /dev/null @@ -1,192 +0,0 @@ - -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 deleted file mode 100644 index 70fd6c39..00000000 --- a/Code/script_idl_mv/astrolib/querysimbad.pro +++ /dev/null @@ -1,200 +0,0 @@ -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 deleted file mode 100644 index 675e65b0..00000000 --- a/Code/script_idl_mv/astrolib/queryvizier.pro +++ /dev/null @@ -1,348 +0,0 @@ -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 deleted file mode 100644 index ebad2358..00000000 --- a/Code/script_idl_mv/astrolib/radec.pro +++ /dev/null @@ -1,75 +0,0 @@ -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 deleted file mode 100644 index 6c79d362..00000000 --- a/Code/script_idl_mv/astrolib/randomchi.pro +++ /dev/null @@ -1,36 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index f1b6e054..00000000 --- a/Code/script_idl_mv/astrolib/randomdir.pro +++ /dev/null @@ -1,56 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index 5a76873f..00000000 --- a/Code/script_idl_mv/astrolib/randomgam.pro +++ /dev/null @@ -1,88 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index 1587d090..00000000 --- a/Code/script_idl_mv/astrolib/randomp.pro +++ /dev/null @@ -1,83 +0,0 @@ -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 deleted file mode 100644 index caf104b8..00000000 --- a/Code/script_idl_mv/astrolib/randomwish.pro +++ /dev/null @@ -1,56 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;+ -; 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 deleted file mode 100644 index 74007690..00000000 --- a/Code/script_idl_mv/astrolib/rdfits_struct.pro +++ /dev/null @@ -1,121 +0,0 @@ -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 deleted file mode 100644 index f4f22442..00000000 --- a/Code/script_idl_mv/astrolib/rdfloat.pro +++ /dev/null @@ -1,152 +0,0 @@ -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 deleted file mode 100644 index d08bf05f..00000000 --- a/Code/script_idl_mv/astrolib/rdplot.pro +++ /dev/null @@ -1,671 +0,0 @@ -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 deleted file mode 100644 index 9e72781c..00000000 --- a/Code/script_idl_mv/astrolib/rdpsf.pro +++ /dev/null @@ -1,58 +0,0 @@ -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 deleted file mode 100644 index b4c7199f..00000000 --- a/Code/script_idl_mv/astrolib/read_fmr.pro +++ /dev/null @@ -1,345 +0,0 @@ -;+ -; 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 deleted file mode 100644 index cf98664f..00000000 --- a/Code/script_idl_mv/astrolib/read_ipac_table.pro +++ /dev/null @@ -1,521 +0,0 @@ -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 deleted file mode 100644 index 0d0f49db..00000000 --- a/Code/script_idl_mv/astrolib/read_ipac_var.pro +++ /dev/null @@ -1,528 +0,0 @@ -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 deleted file mode 100644 index 4e04bac1..00000000 --- a/Code/script_idl_mv/astrolib/read_key.pro +++ /dev/null @@ -1,129 +0,0 @@ -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 deleted file mode 100644 index e88900b7..00000000 --- a/Code/script_idl_mv/astrolib/readcol.pro +++ /dev/null @@ -1,369 +0,0 @@ -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 deleted file mode 100644 index 20c62c65..00000000 --- a/Code/script_idl_mv/astrolib/readfits.pro +++ /dev/null @@ -1,598 +0,0 @@ -;+ -; 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 deleted file mode 100644 index efdd2d5f..00000000 --- a/Code/script_idl_mv/astrolib/readfmt.pro +++ /dev/null @@ -1,297 +0,0 @@ -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 deleted file mode 100644 index 50701a19..00000000 --- a/Code/script_idl_mv/astrolib/recpol.pro +++ /dev/null @@ -1,63 +0,0 @@ -;------------------------------------------------------------- -;+ -; 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 deleted file mode 100644 index 14ce1097..00000000 --- a/Code/script_idl_mv/astrolib/rem_dup.pro +++ /dev/null @@ -1,104 +0,0 @@ -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 deleted file mode 100644 index 15977356..00000000 --- a/Code/script_idl_mv/astrolib/remchar.pro +++ /dev/null @@ -1,46 +0,0 @@ -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 deleted file mode 100644 index 97f2a758..00000000 --- a/Code/script_idl_mv/astrolib/remove.pro +++ /dev/null @@ -1,124 +0,0 @@ -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 deleted file mode 100644 index 94f1c84b..00000000 --- a/Code/script_idl_mv/astrolib/repchr.pro +++ /dev/null @@ -1,60 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 326a6716..00000000 --- a/Code/script_idl_mv/astrolib/repstr.pro +++ /dev/null @@ -1,87 +0,0 @@ -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 deleted file mode 100644 index da623638..00000000 --- a/Code/script_idl_mv/astrolib/resistant_mean.pro +++ /dev/null @@ -1,202 +0,0 @@ -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 deleted file mode 100644 index 5ceec75e..00000000 --- a/Code/script_idl_mv/astrolib/rhotheta.pro +++ /dev/null @@ -1,103 +0,0 @@ -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 deleted file mode 100644 index 702d9e9f..00000000 --- a/Code/script_idl_mv/astrolib/rinter.pro +++ /dev/null @@ -1,170 +0,0 @@ -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 deleted file mode 100644 index 17696066..00000000 --- a/Code/script_idl_mv/astrolib/rob_checkfit.pro +++ /dev/null @@ -1,66 +0,0 @@ -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 deleted file mode 100644 index 817a0f07..00000000 --- a/Code/script_idl_mv/astrolib/robust_linefit.pro +++ /dev/null @@ -1,268 +0,0 @@ -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 deleted file mode 100644 index 149a3e79..00000000 --- a/Code/script_idl_mv/astrolib/robust_poly_fit.pro +++ /dev/null @@ -1,194 +0,0 @@ -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 deleted file mode 100644 index e43ef4c8..00000000 --- a/Code/script_idl_mv/astrolib/robust_sigma.pro +++ /dev/null @@ -1,73 +0,0 @@ -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 deleted file mode 100644 index c44ed3ab..00000000 --- a/Code/script_idl_mv/astrolib/safe_correlate.pro +++ /dev/null @@ -1,230 +0,0 @@ -;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 deleted file mode 100644 index 24971819..00000000 --- a/Code/script_idl_mv/astrolib/select_w.pro +++ /dev/null @@ -1,138 +0,0 @@ -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 deleted file mode 100644 index 9cc2b601..00000000 --- a/Code/script_idl_mv/astrolib/sigma_filter.pro +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index 8d36123d..00000000 --- a/Code/script_idl_mv/astrolib/sigrange.pro +++ /dev/null @@ -1,139 +0,0 @@ - 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 deleted file mode 100644 index e7ec74e0..00000000 --- a/Code/script_idl_mv/astrolib/sip_eval.pro +++ /dev/null @@ -1,46 +0,0 @@ -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 deleted file mode 100644 index 24fe6891..00000000 --- a/Code/script_idl_mv/astrolib/sixlin.pro +++ /dev/null @@ -1,156 +0,0 @@ -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 deleted file mode 100644 index 126136c2..00000000 --- a/Code/script_idl_mv/astrolib/sixty.pro +++ /dev/null @@ -1,66 +0,0 @@ - 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 deleted file mode 100644 index 317d758a..00000000 --- a/Code/script_idl_mv/astrolib/sky.pro +++ /dev/null @@ -1,185 +0,0 @@ -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 deleted file mode 100644 index 2a15f370..00000000 --- a/Code/script_idl_mv/astrolib/skyadj_cube.pro +++ /dev/null @@ -1,343 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 2e7cdfab..00000000 --- a/Code/script_idl_mv/astrolib/sphdist.pro +++ /dev/null @@ -1,88 +0,0 @@ -;------------------------------------------------------------- -;+ -; 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 deleted file mode 100644 index cb3d3622..00000000 --- a/Code/script_idl_mv/astrolib/srcor.pro +++ /dev/null @@ -1,257 +0,0 @@ -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 deleted file mode 100644 index 61d11711..00000000 --- a/Code/script_idl_mv/astrolib/st_diskread.pro +++ /dev/null @@ -1,781 +0,0 @@ -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 deleted file mode 100644 index a120d24b..00000000 --- a/Code/script_idl_mv/astrolib/starast.pro +++ /dev/null @@ -1,140 +0,0 @@ -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 deleted file mode 100644 index 8e4f9888..00000000 --- a/Code/script_idl_mv/astrolib/store_array.pro +++ /dev/null @@ -1,149 +0,0 @@ - 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 deleted file mode 100644 index d3c9b132..00000000 --- a/Code/script_idl_mv/astrolib/str_index.pro +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index 3c34055d..00000000 --- a/Code/script_idl_mv/astrolib/strcompress2.pro +++ /dev/null @@ -1,51 +0,0 @@ -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 deleted file mode 100644 index 45b92bcf..00000000 --- a/Code/script_idl_mv/astrolib/strn.pro +++ /dev/null @@ -1,100 +0,0 @@ -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 deleted file mode 100644 index 45863018..00000000 --- a/Code/script_idl_mv/astrolib/strnumber.pro +++ /dev/null @@ -1,84 +0,0 @@ -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 deleted file mode 100644 index 9ece34e4..00000000 --- a/Code/script_idl_mv/astrolib/substar.pro +++ /dev/null @@ -1,124 +0,0 @@ -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 deleted file mode 100644 index 8b25c82e..00000000 --- a/Code/script_idl_mv/astrolib/sunpos.pro +++ /dev/null @@ -1,167 +0,0 @@ -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 deleted file mode 100644 index 5bd25587..00000000 --- a/Code/script_idl_mv/astrolib/sunsymbol.pro +++ /dev/null @@ -1,77 +0,0 @@ -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 deleted file mode 100644 index 7597d158..00000000 --- a/Code/script_idl_mv/astrolib/sxaddhist.pro +++ /dev/null @@ -1,137 +0,0 @@ -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 deleted file mode 100644 index fa95b949..00000000 --- a/Code/script_idl_mv/astrolib/sxaddpar.pro +++ /dev/null @@ -1,390 +0,0 @@ -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 deleted file mode 100644 index 2cd73a5e..00000000 --- a/Code/script_idl_mv/astrolib/sxdelpar.pro +++ /dev/null @@ -1,69 +0,0 @@ -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 deleted file mode 100644 index e12ae359..00000000 --- a/Code/script_idl_mv/astrolib/sxginfo.pro +++ /dev/null @@ -1,126 +0,0 @@ -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 deleted file mode 100644 index 0c2f10d1..00000000 --- a/Code/script_idl_mv/astrolib/sxgpar.pro +++ /dev/null @@ -1,228 +0,0 @@ -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 deleted file mode 100644 index 48de9364..00000000 --- a/Code/script_idl_mv/astrolib/sxgread.pro +++ /dev/null @@ -1,55 +0,0 @@ -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 deleted file mode 100644 index e0736c3a..00000000 --- a/Code/script_idl_mv/astrolib/sxhcopy.pro +++ /dev/null @@ -1,85 +0,0 @@ -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 deleted file mode 100644 index e45675fe..00000000 --- a/Code/script_idl_mv/astrolib/sxhmake.pro +++ /dev/null @@ -1,76 +0,0 @@ -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 deleted file mode 100644 index 43e18695..00000000 --- a/Code/script_idl_mv/astrolib/sxhread.pro +++ /dev/null @@ -1,120 +0,0 @@ -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 deleted file mode 100644 index 0ad48482..00000000 --- a/Code/script_idl_mv/astrolib/sxhwrite.pro +++ /dev/null @@ -1,95 +0,0 @@ -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 deleted file mode 100644 index 54fc315f..00000000 --- a/Code/script_idl_mv/astrolib/sxmake.pro +++ /dev/null @@ -1,128 +0,0 @@ -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 deleted file mode 100644 index f47908ff..00000000 --- a/Code/script_idl_mv/astrolib/sxopen.pro +++ /dev/null @@ -1,213 +0,0 @@ -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 deleted file mode 100644 index d137cf4d..00000000 --- a/Code/script_idl_mv/astrolib/sxpar.pro +++ /dev/null @@ -1,404 +0,0 @@ -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 deleted file mode 100644 index 4a255ef1..00000000 --- a/Code/script_idl_mv/astrolib/sxread.pro +++ /dev/null @@ -1,81 +0,0 @@ -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 deleted file mode 100644 index a1060950..00000000 --- a/Code/script_idl_mv/astrolib/sxwrite.pro +++ /dev/null @@ -1,92 +0,0 @@ -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 deleted file mode 100644 index 8a9b24c0..00000000 --- a/Code/script_idl_mv/astrolib/t_aper.pro +++ /dev/null @@ -1,160 +0,0 @@ -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 deleted file mode 100644 index e94ef07e..00000000 --- a/Code/script_idl_mv/astrolib/t_find.pro +++ /dev/null @@ -1,127 +0,0 @@ -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 deleted file mode 100644 index f08cb8a7..00000000 --- a/Code/script_idl_mv/astrolib/t_getpsf.pro +++ /dev/null @@ -1,120 +0,0 @@ -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 deleted file mode 100644 index 011516f4..00000000 --- a/Code/script_idl_mv/astrolib/t_group.pro +++ /dev/null @@ -1,73 +0,0 @@ -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 deleted file mode 100644 index 453c9806..00000000 --- a/Code/script_idl_mv/astrolib/t_nstar.pro +++ /dev/null @@ -1,159 +0,0 @@ -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 deleted file mode 100644 index b09bce2b..00000000 --- a/Code/script_idl_mv/astrolib/t_substar.pro +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index 1feafd8a..00000000 --- a/Code/script_idl_mv/astrolib/tabinv.pro +++ /dev/null @@ -1,95 +0,0 @@ -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 deleted file mode 100644 index 8006edcc..00000000 --- a/Code/script_idl_mv/astrolib/tag_exist.pro +++ /dev/null @@ -1,99 +0,0 @@ -;+ -; 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 deleted file mode 100644 index f9f74799..00000000 --- a/Code/script_idl_mv/astrolib/tbdelcol.pro +++ /dev/null @@ -1,111 +0,0 @@ -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 deleted file mode 100644 index 7926cd22..00000000 --- a/Code/script_idl_mv/astrolib/tbdelrow.pro +++ /dev/null @@ -1,76 +0,0 @@ -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 deleted file mode 100644 index f6a67203..00000000 --- a/Code/script_idl_mv/astrolib/tbget.pro +++ /dev/null @@ -1,255 +0,0 @@ -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 deleted file mode 100644 index 64db8c8c..00000000 --- a/Code/script_idl_mv/astrolib/tbhelp.pro +++ /dev/null @@ -1,132 +0,0 @@ -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 deleted file mode 100644 index 0d2c8c20..00000000 --- a/Code/script_idl_mv/astrolib/tbinfo.pro +++ /dev/null @@ -1,192 +0,0 @@ -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 deleted file mode 100644 index dcebebf7..00000000 --- a/Code/script_idl_mv/astrolib/tbprint.pro +++ /dev/null @@ -1,307 +0,0 @@ -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 deleted file mode 100644 index 36dc68d4..00000000 --- a/Code/script_idl_mv/astrolib/tbsize.pro +++ /dev/null @@ -1,63 +0,0 @@ -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 deleted file mode 100644 index 86e1e1c5..00000000 --- a/Code/script_idl_mv/astrolib/tdb2tdt.pro +++ /dev/null @@ -1,1071 +0,0 @@ -;+ -; 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 deleted file mode 100644 index e3b894c8..00000000 --- a/Code/script_idl_mv/astrolib/ten.pro +++ /dev/null @@ -1,93 +0,0 @@ - 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 deleted file mode 100644 index c0292356..00000000 --- a/Code/script_idl_mv/astrolib/tenv.pro +++ /dev/null @@ -1,106 +0,0 @@ - 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 deleted file mode 100644 index e05be109..00000000 --- a/Code/script_idl_mv/astrolib/textclose.pro +++ /dev/null @@ -1,46 +0,0 @@ -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 deleted file mode 100644 index 64325393..00000000 --- a/Code/script_idl_mv/astrolib/textopen.pro +++ /dev/null @@ -1,217 +0,0 @@ -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 deleted file mode 100644 index 35214717..00000000 --- a/Code/script_idl_mv/astrolib/tic_one.pro +++ /dev/null @@ -1,63 +0,0 @@ -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 deleted file mode 100644 index 91d07e95..00000000 --- a/Code/script_idl_mv/astrolib/ticlabels.pro +++ /dev/null @@ -1,233 +0,0 @@ -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 deleted file mode 100644 index 92e621ac..00000000 --- a/Code/script_idl_mv/astrolib/ticpos.pro +++ /dev/null @@ -1,88 +0,0 @@ -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 deleted file mode 100644 index ab28918d..00000000 --- a/Code/script_idl_mv/astrolib/tics.pro +++ /dev/null @@ -1,76 +0,0 @@ -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 deleted file mode 100644 index d5dcbba8..00000000 --- a/Code/script_idl_mv/astrolib/tnx_eval.pro +++ /dev/null @@ -1,134 +0,0 @@ -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 deleted file mode 100644 index 42033975..00000000 --- a/Code/script_idl_mv/astrolib/to_hex.pro +++ /dev/null @@ -1,44 +0,0 @@ -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 deleted file mode 100644 index 3f7c8d40..00000000 --- a/Code/script_idl_mv/astrolib/tpv_eval.pro +++ /dev/null @@ -1,92 +0,0 @@ -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 deleted file mode 100644 index b8094f1b..00000000 --- a/Code/script_idl_mv/astrolib/transform_coeff.pro +++ /dev/null @@ -1,62 +0,0 @@ - -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 deleted file mode 100644 index 11e0cda7..00000000 --- a/Code/script_idl_mv/astrolib/trapzd.pro +++ /dev/null @@ -1,82 +0,0 @@ -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 deleted file mode 100644 index 0ddecd7d..00000000 --- a/Code/script_idl_mv/astrolib/tsc.pro +++ /dev/null @@ -1,595 +0,0 @@ -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 deleted file mode 100644 index 00a87450..00000000 --- a/Code/script_idl_mv/astrolib/tsum.pro +++ /dev/null @@ -1,100 +0,0 @@ -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 deleted file mode 100644 index 58f13a46..00000000 --- a/Code/script_idl_mv/astrolib/tvbox.pro +++ /dev/null @@ -1,191 +0,0 @@ -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 deleted file mode 100644 index 4693e074..00000000 --- a/Code/script_idl_mv/astrolib/tvcircle.pro +++ /dev/null @@ -1,228 +0,0 @@ -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 deleted file mode 100644 index 6f98274f..00000000 --- a/Code/script_idl_mv/astrolib/tvellipse.pro +++ /dev/null @@ -1,184 +0,0 @@ -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 deleted file mode 100644 index c4c3b2f4..00000000 --- a/Code/script_idl_mv/astrolib/tvlaser.pro +++ /dev/null @@ -1,707 +0,0 @@ -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 deleted file mode 100644 index 3acc4da5..00000000 --- a/Code/script_idl_mv/astrolib/tvlist.pro +++ /dev/null @@ -1,164 +0,0 @@ -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 deleted file mode 100644 index ed49b9e6..00000000 --- a/Code/script_idl_mv/astrolib/unzoom_xy.pro +++ /dev/null @@ -1,82 +0,0 @@ -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 deleted file mode 100644 index 1c84b1a0..00000000 --- a/Code/script_idl_mv/astrolib/update_distort.pro +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index 45c93797..00000000 --- a/Code/script_idl_mv/astrolib/uvbybeta.pro +++ /dev/null @@ -1,488 +0,0 @@ -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 deleted file mode 100644 index d0dc2a99..00000000 --- a/Code/script_idl_mv/astrolib/vactoair.pro +++ /dev/null @@ -1,68 +0,0 @@ -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 deleted file mode 100644 index 05b2a205..00000000 --- a/Code/script_idl_mv/astrolib/valid_num.pro +++ /dev/null @@ -1,80 +0,0 @@ -;+ -; 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 deleted file mode 100644 index 1990abc2..00000000 --- a/Code/script_idl_mv/astrolib/vect.pro +++ /dev/null @@ -1,61 +0,0 @@ -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 deleted file mode 100644 index 9f78c032..00000000 --- a/Code/script_idl_mv/astrolib/vsym.pro +++ /dev/null @@ -1,98 +0,0 @@ -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 deleted file mode 100644 index b613c9d9..00000000 --- a/Code/script_idl_mv/astrolib/wcs_check_ctype.pro +++ /dev/null @@ -1,153 +0,0 @@ -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 deleted file mode 100644 index d7451762..00000000 --- a/Code/script_idl_mv/astrolib/wcs_demo.pro +++ /dev/null @@ -1,1198 +0,0 @@ -;+ -; 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 deleted file mode 100644 index e317cee6..00000000 --- a/Code/script_idl_mv/astrolib/wcs_getpole.pro +++ /dev/null @@ -1,141 +0,0 @@ -;+ -; 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 deleted file mode 100644 index e9b64b47..00000000 --- a/Code/script_idl_mv/astrolib/wcs_rotate.pro +++ /dev/null @@ -1,205 +0,0 @@ -;+ -; 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