From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- math/README | 20 + math/Revisions | 406 ++ math/_math.hd | 5 + math/bevington/README | 13 + math/bevington/agauss.f | 40 + math/bevington/area.f | 79 + math/bevington/chifit.f | 169 + math/bevington/curfit.f | 128 + math/bevington/determ.f | 54 + math/bevington/factor.f | 39 + math/bevington/fchisq.f | 54 + math/bevington/fderiv.f | 39 + math/bevington/gamma.f | 49 + math/bevington/gradls.f | 113 + math/bevington/gridls.f | 102 + math/bevington/integ.f | 58 + math/bevington/interp.f | 85 + math/bevington/legfit.f | 173 + math/bevington/linfit.f | 79 + math/bevington/man/agauss.3m | 24 + math/bevington/man/area.3m | 25 + math/bevington/man/chifit.3m | 44 + math/bevington/man/curfit.3m | 49 + math/bevington/man/determ.3m | 25 + math/bevington/man/factor.3m | 20 + math/bevington/man/fchisq.3m | 29 + math/bevington/man/fderiv.3m | 27 + math/bevington/man/gamma.3m | 21 + math/bevington/man/gradls.3m | 40 + math/bevington/man/gridls.3m | 41 + math/bevington/man/integ.3m | 28 + math/bevington/man/interp.3m | 29 + math/bevington/man/legfit.3m | 49 + math/bevington/man/linfit.3m | 33 + math/bevington/man/matinv.3m | 25 + math/bevington/man/pbinom.3m | 23 + math/bevington/man/pchisq.3m | 26 + math/bevington/man/pcorre.3m | 22 + math/bevington/man/pgauss.3m | 22 + math/bevington/man/ploren.3m | 22 + math/bevington/man/polfit.3m | 36 + math/bevington/man/ppoiss.3m | 22 + math/bevington/man/regres.3m | 49 + math/bevington/man/smooth.3m | 21 + math/bevington/man/xfit.3m | 29 + math/bevington/matinv.f | 96 + math/bevington/mkpkg | 35 + math/bevington/pbinom.f | 26 + math/bevington/pchisq.f | 62 + math/bevington/pcorre.f | 69 + math/bevington/pgauss.f | 25 + math/bevington/ploren.f | 23 + math/bevington/polfit.f | 100 + math/bevington/ppoiss.f | 23 + math/bevington/regres.f | 173 + math/bevington/smooth.f | 29 + math/bevington/xfit.f | 59 + math/curfit/README | 6 + math/curfit/Revisions | 118 + math/curfit/curfit.sem | 708 ++ math/curfit/curfitdef.h | 55 + math/curfit/cv_b1eval.gx | 110 + math/curfit/cv_b1evald.x | 110 + math/curfit/cv_b1evalr.x | 110 + math/curfit/cv_beval.gx | 147 + math/curfit/cv_bevald.x | 147 + math/curfit/cv_bevalr.x | 147 + math/curfit/cv_feval.gx | 242 + math/curfit/cv_fevald.x | 242 + math/curfit/cv_fevalr.x | 242 + math/curfit/cv_userfnc.gx | 84 + math/curfit/cv_userfncd.x | 76 + math/curfit/cv_userfncr.x | 76 + math/curfit/cvaccum.gx | 108 + math/curfit/cvaccumd.x | 100 + math/curfit/cvaccumr.x | 100 + math/curfit/cvacpts.gx | 186 + math/curfit/cvacptsd.x | 178 + math/curfit/cvacptsr.x | 178 + math/curfit/cvchomat.gx | 117 + math/curfit/cvchomatd.x | 109 + math/curfit/cvchomatr.x | 109 + math/curfit/cvcoeff.gx | 26 + math/curfit/cvcoeffd.x | 18 + math/curfit/cvcoeffr.x | 18 + math/curfit/cverrors.gx | 91 + math/curfit/cverrorsd.x | 83 + math/curfit/cverrorsr.x | 83 + math/curfit/cveval.gx | 59 + math/curfit/cvevald.x | 51 + math/curfit/cvevalr.x | 51 + math/curfit/cvfit.gx | 66 + math/curfit/cvfitd.x | 45 + math/curfit/cvfitr.x | 45 + math/curfit/cvfree.gx | 45 + math/curfit/cvfreed.x | 37 + math/curfit/cvfreer.x | 37 + math/curfit/cvinit.gx | 95 + math/curfit/cvinitd.x | 87 + math/curfit/cvinitr.x | 87 + math/curfit/cvpower.gx | 526 ++ math/curfit/cvpowerd.x | 492 ++ math/curfit/cvpowerr.x | 492 ++ math/curfit/cvrefit.gx | 111 + math/curfit/cvrefitd.x | 103 + math/curfit/cvrefitr.x | 103 + math/curfit/cvreject.gx | 82 + math/curfit/cvrejectd.x | 74 + math/curfit/cvrejectr.x | 74 + math/curfit/cvrestore.gx | 100 + math/curfit/cvrestored.x | 88 + math/curfit/cvrestorer.x | 88 + math/curfit/cvsave.gx | 56 + math/curfit/cvsaved.x | 44 + math/curfit/cvsaver.x | 44 + math/curfit/cvset.gx | 98 + math/curfit/cvsetd.x | 85 + math/curfit/cvsetr.x | 85 + math/curfit/cvsolve.gx | 51 + math/curfit/cvsolved.x | 43 + math/curfit/cvsolver.x | 43 + math/curfit/cvstat.gx | 61 + math/curfit/cvstatd.x | 49 + math/curfit/cvstatr.x | 49 + math/curfit/cvvector.gx | 42 + math/curfit/cvvectord.x | 34 + math/curfit/cvvectorr.x | 34 + math/curfit/cvzero.gx | 47 + math/curfit/cvzerod.x | 34 + math/curfit/cvzeror.x | 34 + math/curfit/dcurfitdef.h | 54 + math/curfit/doc/curfit.hd | 24 + math/curfit/doc/curfit.hlp | 163 + math/curfit/doc/curfit.men | 20 + math/curfit/doc/curfit.spc | 479 ++ math/curfit/doc/cvaccum.hlp | 51 + math/curfit/doc/cvacpts.hlp | 54 + math/curfit/doc/cvcoeff.hlp | 36 + math/curfit/doc/cvepower.hlp | 55 + math/curfit/doc/cverrors.hlp | 53 + math/curfit/doc/cveval.hlp | 33 + math/curfit/doc/cvfit.hlp | 62 + math/curfit/doc/cvfree.hlp | 26 + math/curfit/doc/cvinit.hlp | 55 + math/curfit/doc/cvpower.hlp | 40 + math/curfit/doc/cvrefit.hlp | 52 + math/curfit/doc/cvreject.hlp | 41 + math/curfit/doc/cvrestore.hlp | 32 + math/curfit/doc/cvsave.hlp | 35 + math/curfit/doc/cvset.hlp | 56 + math/curfit/doc/cvsolve.hlp | 39 + math/curfit/doc/cvstati.hlp | 47 + math/curfit/doc/cvstatr.hlp | 44 + math/curfit/doc/cvvector.hlp | 41 + math/curfit/doc/cvzero.hlp | 26 + math/curfit/mkpkg | 87 + math/deboor/Notes | 36 + math/deboor/README | 20 + math/deboor/Revisions | 7 + math/deboor/banfac.f | 110 + math/deboor/banslv.f | 53 + math/deboor/bchfac.f | 87 + math/deboor/bchslv.f | 50 + math/deboor/bsplbv.f | 91 + math/deboor/bspln.h | 14 + math/deboor/bsplpp.f | 105 + math/deboor/bsplvd.f | 111 + math/deboor/bspp2d.f | 122 + math/deboor/bvalue.f | 138 + math/deboor/chol1d.f | 58 + math/deboor/colloc_io.f | 139 + math/deboor/colpnt_io.f | 65 + math/deboor/cubspl.f | 119 + math/deboor/cwidth.f | 220 + math/deboor/difequ_io.f | 100 + math/deboor/dtblok.f | 36 + math/deboor/eqblok_io.f | 91 + math/deboor/factrb.f | 87 + math/deboor/fcblok.f | 56 + math/deboor/fsplin.x | 63 + math/deboor/interv.f | 95 + math/deboor/knots.f | 38 + math/deboor/l2appr.f | 109 + math/deboor/l2err_io.f | 69 + math/deboor/l2knts.f | 33 + math/deboor/mkpkg | 49 + math/deboor/newnot_fake.f | 30 + math/deboor/newnot_io.f | 108 + math/deboor/ppvalu.f | 48 + math/deboor/progs/prog1.f | 45 + math/deboor/progs/prog10.f | 76 + math/deboor/progs/prog11.f | 69 + math/deboor/progs/prog12.f | 70 + math/deboor/progs/prog13.f | 77 + math/deboor/progs/prog14.f | 37 + math/deboor/progs/prog15.f | 48 + math/deboor/progs/prog16.f | 115 + math/deboor/progs/prog17.f | 10 + math/deboor/progs/prog18.f | 35 + math/deboor/progs/prog19.f | 58 + math/deboor/progs/prog2.f | 48 + math/deboor/progs/prog20.f | 62 + math/deboor/progs/prog21.f | 74 + math/deboor/progs/prog3.f | 44 + math/deboor/progs/prog4.f | 35 + math/deboor/progs/prog5.f | 27 + math/deboor/progs/prog6.f | 23 + math/deboor/progs/prog7.f | 17 + math/deboor/progs/prog8.f | 63 + math/deboor/progs/prog9.f | 38 + math/deboor/putit_io.f | 82 + math/deboor/round.f | 10 + math/deboor/sbblok.f | 48 + math/deboor/setdat.f | 41 + math/deboor/setdat2.f | 29 + math/deboor/setdat3.f | 27 + math/deboor/setupq.f | 40 + math/deboor/seval.x | 159 + math/deboor/shiftb.f | 50 + math/deboor/slvblk.f | 127 + math/deboor/smooth.f | 112 + math/deboor/spli2d_io.f | 130 + math/deboor/spline.x | 93 + math/deboor/splint.f | 113 + math/deboor/spllsq.x | 160 + math/deboor/splopt_io.f | 196 + math/deboor/splsqv.x | 149 + math/deboor/subbak.f | 33 + math/deboor/subfor.f | 45 + math/deboor/tautsp.f | 313 + math/deboor/titand.f | 18 + math/gsurfit/README | 6 + math/gsurfit/dgsurfitdef.h | 61 + math/gsurfit/doc/gsaccum.hlp | 51 + math/gsurfit/doc/gsacpts.hlp | 56 + math/gsurfit/doc/gsadd.hlp | 35 + math/gsurfit/doc/gscoeff.hlp | 39 + math/gsurfit/doc/gscopy.hlp | 32 + math/gsurfit/doc/gsder.hlp | 48 + math/gsurfit/doc/gserrors.hlp | 61 + math/gsurfit/doc/gseval.hlp | 34 + math/gsurfit/doc/gsfit.hlp | 64 + math/gsurfit/doc/gsfree.hlp | 26 + math/gsurfit/doc/gsgcoeff.hlp | 31 + math/gsurfit/doc/gsinit.hlp | 64 + math/gsurfit/doc/gsrefit.hlp | 55 + math/gsurfit/doc/gsreject.hlp | 44 + math/gsurfit/doc/gsrestore.hlp | 36 + math/gsurfit/doc/gssave.hlp | 39 + math/gsurfit/doc/gsscoeff.hlp | 35 + math/gsurfit/doc/gssolve.hlp | 40 + math/gsurfit/doc/gsstati.hlp | 35 + math/gsurfit/doc/gsstatr.hlp | 34 + math/gsurfit/doc/gssub.hlp | 35 + math/gsurfit/doc/gsurfit.hd | 25 + math/gsurfit/doc/gsurfit.hlp | 169 + math/gsurfit/doc/gsurfit.men | 21 + math/gsurfit/doc/gsvector.hlp | 41 + math/gsurfit/doc/gszero.hlp | 27 + math/gsurfit/gs_b1eval.gx | 85 + math/gsurfit/gs_b1evald.x | 85 + math/gsurfit/gs_b1evalr.x | 85 + math/gsurfit/gs_beval.gx | 120 + math/gsurfit/gs_bevald.x | 98 + math/gsurfit/gs_bevalr.x | 98 + math/gsurfit/gs_chomat.gx | 110 + math/gsurfit/gs_chomatd.x | 106 + math/gsurfit/gs_chomatr.x | 106 + math/gsurfit/gs_deval.gx | 241 + math/gsurfit/gs_devald.x | 241 + math/gsurfit/gs_devalr.x | 241 + math/gsurfit/gs_f1deval.gx | 189 + math/gsurfit/gs_f1devald.x | 159 + math/gsurfit/gs_f1devalr.x | 159 + math/gsurfit/gs_fder.gx | 288 + math/gsurfit/gs_fderd.x | 231 + math/gsurfit/gs_fderr.x | 228 + math/gsurfit/gs_feval.gx | 332 + math/gsurfit/gs_fevald.x | 274 + math/gsurfit/gs_fevalr.x | 271 + math/gsurfit/gsaccum.gx | 193 + math/gsurfit/gsaccumd.x | 165 + math/gsurfit/gsaccumr.x | 165 + math/gsurfit/gsacpts.gx | 257 + math/gsurfit/gsacptsd.x | 216 + math/gsurfit/gsacptsr.x | 216 + math/gsurfit/gsadd.gx | 181 + math/gsurfit/gsaddd.x | 161 + math/gsurfit/gsaddr.x | 161 + math/gsurfit/gscoeff.gx | 31 + math/gsurfit/gscoeffd.x | 23 + math/gsurfit/gscoeffr.x | 23 + math/gsurfit/gscopy.gx | 69 + math/gsurfit/gscopyd.x | 57 + math/gsurfit/gscopyr.x | 57 + math/gsurfit/gsder.gx | 264 + math/gsurfit/gsderd.x | 244 + math/gsurfit/gsderr.x | 244 + math/gsurfit/gserrors.gx | 90 + math/gsurfit/gserrorsd.x | 78 + math/gsurfit/gserrorsr.x | 78 + math/gsurfit/gseval.gx | 104 + math/gsurfit/gsevald.x | 91 + math/gsurfit/gsevalr.x | 91 + math/gsurfit/gsfit.gx | 49 + math/gsurfit/gsfit1.gx | 117 + math/gsurfit/gsfit1d.x | 99 + math/gsurfit/gsfit1r.x | 99 + math/gsurfit/gsfitd.x | 35 + math/gsurfit/gsfitr.x | 35 + math/gsurfit/gsfree.gx | 58 + math/gsurfit/gsfreed.x | 33 + math/gsurfit/gsfreer.x | 33 + math/gsurfit/gsgcoeff.gx | 53 + math/gsurfit/gsgcoeffd.x | 45 + math/gsurfit/gsgcoeffr.x | 45 + math/gsurfit/gsinit.gx | 124 + math/gsurfit/gsinitd.x | 108 + math/gsurfit/gsinitr.x | 108 + math/gsurfit/gsrefit.gx | 174 + math/gsurfit/gsrefitd.x | 137 + math/gsurfit/gsrefitr.x | 137 + math/gsurfit/gsreject.gx | 188 + math/gsurfit/gsrejectd.x | 153 + math/gsurfit/gsrejectr.x | 153 + math/gsurfit/gsrestore.gx | 102 + math/gsurfit/gsrestored.x | 90 + math/gsurfit/gsrestorer.x | 90 + math/gsurfit/gssave.gx | 50 + math/gsurfit/gssaved.x | 42 + math/gsurfit/gssaver.x | 42 + math/gsurfit/gsscoeff.gx | 54 + math/gsurfit/gsscoeffd.x | 46 + math/gsurfit/gsscoeffr.x | 46 + math/gsurfit/gssolve.gx | 101 + math/gsurfit/gssolved.x | 84 + math/gsurfit/gssolver.x | 84 + math/gsurfit/gsstat.gx | 99 + math/gsurfit/gsstatd.x | 83 + math/gsurfit/gsstatr.x | 83 + math/gsurfit/gssub.gx | 198 + math/gsurfit/gssubd.x | 170 + math/gsurfit/gssubr.x | 170 + math/gsurfit/gsurfit.h | 48 + math/gsurfit/gsurfitdef.h | 61 + math/gsurfit/gsvector.gx | 65 + math/gsurfit/gsvectord.x | 57 + math/gsurfit/gsvectorr.x | 57 + math/gsurfit/gszero.gx | 60 + math/gsurfit/gszerod.x | 40 + math/gsurfit/gszeror.x | 40 + math/gsurfit/mkpkg | 111 + math/gsurfit/zzdebug.x | 348 + math/ieee/README | 8 + math/ieee/chap1/README | 14 + math/ieee/chap1/const.f | 114 + math/ieee/chap1/fast.f | 73 + math/ieee/chap1/ffa.f | 84 + math/ieee/chap1/ffs.f | 80 + math/ieee/chap1/fft842.f | 116 + math/ieee/chap1/fftaoh.f | 82 + math/ieee/chap1/fftasm.f | 67 + math/ieee/chap1/fftohm.f | 101 + math/ieee/chap1/fftsoh.f | 81 + math/ieee/chap1/fftsym.f | 84 + math/ieee/chap1/ford1.f | 24 + math/ieee/chap1/ford2.f | 46 + math/ieee/chap1/fourea.f | 98 + math/ieee/chap1/fr2tr.f | 15 + math/ieee/chap1/fr4syn.f | 109 + math/ieee/chap1/fr4tr.f | 118 + math/ieee/chap1/fsst.f | 71 + math/ieee/chap1/iftaoh.f | 87 + math/ieee/chap1/iftasm.f | 77 + math/ieee/chap1/iftohm.f | 83 + math/ieee/chap1/iftsoh.f | 94 + math/ieee/chap1/iftsym.f | 90 + math/ieee/chap1/inishl.f | 179 + math/ieee/chap1/ord1.f | 24 + math/ieee/chap1/ord2.f | 46 + math/ieee/chap1/r2tr.f | 16 + math/ieee/chap1/r2tx.f | 18 + math/ieee/chap1/r4syn.f | 20 + math/ieee/chap1/r4tr.f | 18 + math/ieee/chap1/r4tx.f | 29 + math/ieee/chap1/r8syn.f | 186 + math/ieee/chap1/r8tr.f | 201 + math/ieee/chap1/r8tx.f | 107 + math/ieee/chap1/rad4sb.f | 38 + math/ieee/chap1/radix4.f | 488 ++ math/ieee/chap1/test/test12.f | 90 + math/ieee/chap1/test/test13.f | 260 + math/ieee/chap1/test/test17.f | 147 + math/ieee/chap1/test/test18.f | 71 + math/ieee/chap1/time/time12.f | 53 + math/ieee/chap1/time/time17.f | 53 + math/ieee/chap1/time/time18.f | 48 + math/ieee/chap1/weave1.f | 371 ++ math/ieee/chap1/weave2.f | 412 ++ math/ieee/chap1/wfta.f | 150 + math/ieee/d1mach.f | 256 + math/ieee/i1mach.f | 382 ++ math/ieee/r1mach.f | 177 + math/ieee/uni.c | 8 + math/iminterp/Revisions | 7 + math/iminterp/arbpix.x | 339 + math/iminterp/arider.x | 108 + math/iminterp/arieval.x | 147 + math/iminterp/asider.x | 154 + math/iminterp/asieval.x | 67 + math/iminterp/asifit.x | 146 + math/iminterp/asifree.x | 17 + math/iminterp/asigeti.x | 25 + math/iminterp/asigetr.x | 20 + math/iminterp/asigrl.x | 194 + math/iminterp/asiinit.x | 57 + math/iminterp/asirestore.x | 50 + math/iminterp/asisave.x | 42 + math/iminterp/asisinit.x | 64 + math/iminterp/asitype.x | 90 + math/iminterp/asivector.x | 56 + math/iminterp/doc/arbpix.hlp | 57 + math/iminterp/doc/arider.hlp | 59 + math/iminterp/doc/arieval.hlp | 48 + math/iminterp/doc/asider.hlp | 52 + math/iminterp/doc/asieval.hlp | 44 + math/iminterp/doc/asifit.hlp | 40 + math/iminterp/doc/asifree.hlp | 25 + math/iminterp/doc/asigeti.hlp | 36 + math/iminterp/doc/asigetr.hlp | 36 + math/iminterp/doc/asigrl.hlp | 40 + math/iminterp/doc/asiinit.hlp | 39 + math/iminterp/doc/asirestore.hlp | 36 + math/iminterp/doc/asisave.hlp | 39 + math/iminterp/doc/asisinit.hlp | 60 + math/iminterp/doc/asitype.hlp | 95 + math/iminterp/doc/asivector.hlp | 52 + math/iminterp/doc/im1dinterp.spc | 525 ++ math/iminterp/doc/im2dinterp.spc | 432 ++ math/iminterp/doc/iminterp.hd | 37 + math/iminterp/doc/iminterp.hlp | 234 + math/iminterp/doc/iminterp.men | 32 + math/iminterp/doc/iminterp.spc | 525 ++ math/iminterp/doc/mrider.hlp | 79 + math/iminterp/doc/mrieval.hlp | 57 + math/iminterp/doc/msider.hlp | 52 + math/iminterp/doc/msieval.hlp | 46 + math/iminterp/doc/msifit.hlp | 45 + math/iminterp/doc/msifree.hlp | 26 + math/iminterp/doc/msigeti.hlp | 35 + math/iminterp/doc/msigetr.hlp | 37 + math/iminterp/doc/msigrid.hlp | 51 + math/iminterp/doc/msigrl.hlp | 43 + math/iminterp/doc/msiinit.hlp | 41 + math/iminterp/doc/msirestore.hlp | 36 + math/iminterp/doc/msisave.hlp | 38 + math/iminterp/doc/msisinit.hlp | 61 + math/iminterp/doc/msisqgrl.hlp | 38 + math/iminterp/doc/msitype.hlp | 95 + math/iminterp/doc/msivector.hlp | 54 + math/iminterp/ii_1dinteg.x | 372 ++ math/iminterp/ii_bieval.x | 1080 +++ math/iminterp/ii_cubspl.f | 119 + math/iminterp/ii_eval.x | 430 ++ math/iminterp/ii_greval.x | 859 +++ math/iminterp/ii_pc1deval.x | 291 + math/iminterp/ii_pc2deval.x | 444 ++ math/iminterp/ii_polterp.x | 39 + math/iminterp/ii_sinctable.x | 123 + math/iminterp/ii_spline.x | 56 + math/iminterp/ii_spline2d.x | 63 + math/iminterp/im1interpdef.h | 55 + math/iminterp/im2interpdef.h | 63 + math/iminterp/mkpkg | 53 + math/iminterp/mrider.x | 420 ++ math/iminterp/mrieval.x | 303 + math/iminterp/msider.x | 294 + math/iminterp/msieval.x | 74 + math/iminterp/msifit.x | 275 + math/iminterp/msifree.x | 21 + math/iminterp/msigeti.x | 24 + math/iminterp/msigetr.x | 20 + math/iminterp/msigrid.x | 65 + math/iminterp/msigrl.x | 238 + math/iminterp/msiinit.x | 69 + math/iminterp/msirestore.x | 50 + math/iminterp/msisave.x | 43 + math/iminterp/msisinit.x | 91 + math/iminterp/msisqgrl.x | 96 + math/iminterp/msitype.x | 97 + math/iminterp/msivector.x | 65 + math/interp/Iinterp.hlp | 293 + math/interp/README | 7 + math/interp/arbpix.x | 203 + math/interp/arider.x | 214 + math/interp/arival.x | 124 + math/interp/asidef.h | 16 + math/interp/asider.x | 121 + math/interp/asieva.x | 38 + math/interp/asifit.x | 75 + math/interp/asigrl.x | 201 + math/interp/asiset.x | 20 + math/interp/asival.x | 49 + math/interp/bench.x | 55 + math/interp/cubspl.f | 119 + math/interp/iieval.x | 137 + math/interp/iif_spline.x | 67 + math/interp/iimail | 213 + math/interp/iipol_terp.x | 41 + math/interp/interp.h | 19 + math/interp/interpdef.h | 19 + math/interp/mkpkg | 21 + math/interp/noteari | 64 + math/interp/noteasi | 101 + math/interp/notes3 | 216 + math/interp/overview | 43 + math/interp/usernote | 118 + math/llsq/README | 33 + math/llsq/bndacc.f | 74 + math/llsq/bndsol.f | 71 + math/llsq/diff.f | 6 + math/llsq/g1.f | 33 + math/llsq/g2.f | 9 + math/llsq/gen.f | 31 + math/llsq/h12.f | 80 + math/llsq/hfti.f | 136 + math/llsq/ldp.f | 79 + math/llsq/mfeout.f | 64 + math/llsq/mkpkg | 23 + math/llsq/nnls.f | 276 + math/llsq/original_f/bndacc.f | 74 + math/llsq/original_f/bndsol.f | 70 + math/llsq/original_f/diff.f | 6 + math/llsq/original_f/g1.f | 33 + math/llsq/original_f/g2.f | 9 + math/llsq/original_f/gen.f | 28 + math/llsq/original_f/h12.f | 80 + math/llsq/original_f/hfti.f | 136 + math/llsq/original_f/ldp.f | 79 + math/llsq/original_f/nnls.f | 278 + math/llsq/original_f/qrbd.f | 208 + math/llsq/original_f/sfeout.f | 64 + math/llsq/original_f/sva.f | 193 + math/llsq/original_f/svdrs.f | 205 + math/llsq/progs/README | 5 + math/llsq/progs/band.x | 70 + math/llsq/progs/data4 | 15 + math/llsq/progs/lsq.x | 70 + math/llsq/progs/prog1.f | 124 + math/llsq/progs/prog2.f | 125 + math/llsq/progs/prog3.f | 138 + math/llsq/progs/prog4.f | 22 + math/llsq/progs/prog5.f | 146 + math/llsq/progs/prog6.f | 116 + math/llsq/qrbd.f | 208 + math/llsq/sva.f | 198 + math/llsq/svdrs.f | 205 + math/math.hd | 58 + math/math.men | 11 + math/minpack/chkder.f | 140 + math/minpack/dogleg.f | 177 + math/minpack/dpmpar.f | 171 + math/minpack/enorm.f | 108 + math/minpack/fdjac1.f | 150 + math/minpack/fdjac2.f | 107 + math/minpack/hybrd.f | 459 ++ math/minpack/hybrd1.f | 123 + math/minpack/hybrj.f | 440 ++ math/minpack/hybrj1.f | 127 + math/minpack/lmder.f | 452 ++ math/minpack/lmder1.f | 156 + math/minpack/lmdif.f | 454 ++ math/minpack/lmdif1.f | 135 + math/minpack/lmpar.f | 264 + math/minpack/lmstr.f | 466 ++ math/minpack/lmstr1.f | 156 + math/minpack/qform.f | 95 + math/minpack/qrfac.f | 164 + math/minpack/qrsolv.f | 193 + math/minpack/r1mpyq.f | 92 + math/minpack/r1updt.f | 207 + math/minpack/rwupdt.f | 113 + math/mkpkg | 138 + math/nlfit/README | 81 + math/nlfit/doc/nlerrors.hlp | 67 + math/nlfit/doc/nleval.hlp | 35 + math/nlfit/doc/nlfit.hd | 12 + math/nlfit/doc/nlfit.hlp | 81 + math/nlfit/doc/nlfit.men | 8 + math/nlfit/doc/nlfree.hlp | 26 + math/nlfit/doc/nlinit.hlp | 86 + math/nlfit/doc/nllmfit.hlp | 172 + math/nlfit/doc/nlpget.hlp | 38 + math/nlfit/doc/nlstat.hlp | 57 + math/nlfit/doc/nlvector.hlp | 43 + math/nlfit/mkpkg | 63 + math/nlfit/nlacpts.gx | 111 + math/nlfit/nlacptsd.x | 107 + math/nlfit/nlacptsr.x | 107 + math/nlfit/nlchomat.gx | 130 + math/nlfit/nlchomatd.x | 126 + math/nlfit/nlchomatr.x | 126 + math/nlfit/nldump.gx | 164 + math/nlfit/nldumpd.x | 160 + math/nlfit/nldumpr.x | 160 + math/nlfit/nlerrmsg.x | 24 + math/nlfit/nlerrors.gx | 111 + math/nlfit/nlerrorsd.x | 107 + math/nlfit/nlerrorsr.x | 107 + math/nlfit/nleval.gx | 25 + math/nlfit/nlevald.x | 21 + math/nlfit/nlevalr.x | 21 + math/nlfit/nlfit.gx | 171 + math/nlfit/nlfitd.x | 167 + math/nlfit/nlfitdef.gh | 51 + math/nlfit/nlfitdefd.h | 52 + math/nlfit/nlfitdefr.h | 52 + math/nlfit/nlfitr.x | 167 + math/nlfit/nlfree.gx | 41 + math/nlfit/nlfreed.x | 37 + math/nlfit/nlfreer.x | 37 + math/nlfit/nlinit.gx | 66 + math/nlfit/nlinitd.x | 62 + math/nlfit/nlinitr.x | 62 + math/nlfit/nliter.gx | 59 + math/nlfit/nliterd.x | 55 + math/nlfit/nliterr.x | 55 + math/nlfit/nllist.x | 30 + math/nlfit/nlpget.gx | 18 + math/nlfit/nlpgetd.x | 14 + math/nlfit/nlpgetr.x | 14 + math/nlfit/nlsolve.gx | 41 + math/nlfit/nlsolved.x | 37 + math/nlfit/nlsolver.x | 37 + math/nlfit/nlstat.gx | 30 + math/nlfit/nlstatd.x | 26 + math/nlfit/nlstati.x | 26 + math/nlfit/nlstatr.x | 26 + math/nlfit/nlvector.gx | 27 + math/nlfit/nlvectord.x | 23 + math/nlfit/nlvectorr.x | 23 + math/nlfit/nlzero.gx | 38 + math/nlfit/nlzerod.x | 34 + math/nlfit/nlzeror.x | 34 + math/slalib/Makefile.am | 76 + math/slalib/Notes | 23 + math/slalib/README | 233 + math/slalib/SED1 | 214 + math/slalib/SED2 | 132 + math/slalib/SLA_CONDITIONS | 280 + math/slalib/addet.f | 85 + math/slalib/afin.f | 120 + math/slalib/airmas.f | 76 + math/slalib/altaz.f | 163 + math/slalib/amp.f | 89 + math/slalib/ampqk.f | 140 + math/slalib/aop.f | 192 + math/slalib/aoppa.f | 194 + math/slalib/aoppat.f | 63 + math/slalib/aopqk.f | 260 + math/slalib/atmdsp.f | 141 + math/slalib/atms.f | 58 + math/slalib/atmt.f | 72 + math/slalib/av2m.f | 85 + math/slalib/bear.f | 60 + math/slalib/caf2r.f | 75 + math/slalib/caldj.f | 75 + math/slalib/calyd.f | 83 + math/slalib/cc2s.f | 70 + math/slalib/cc62s.f | 100 + math/slalib/cd2tf.f | 73 + math/slalib/cldj.f | 95 + math/slalib/clyd.f | 119 + math/slalib/combn.f | 160 + math/slalib/configure.ac | 134 + math/slalib/cr2af.f | 76 + math/slalib/cr2tf.f | 76 + math/slalib/cs2c.f | 58 + math/slalib/cs2c6.f | 73 + math/slalib/ctf2d.f | 74 + math/slalib/ctf2r.f | 72 + math/slalib/daf2r.f | 73 + math/slalib/dafin.f | 181 + math/slalib/dat.f | 232 + math/slalib/dav2m.f | 84 + math/slalib/dbear.f | 60 + math/slalib/dbjin.f | 131 + math/slalib/dc62s.f | 100 + math/slalib/dcc2s.f | 70 + math/slalib/dcmpf.f | 160 + math/slalib/dcs2c.f | 57 + math/slalib/dd2tf.f | 107 + math/slalib/de2h.f | 107 + math/slalib/deuler.f | 181 + math/slalib/dfltin.f | 298 + math/slalib/dh2e.f | 101 + math/slalib/dimxv.f | 69 + math/slalib/djcal.f | 93 + math/slalib/djcl.f | 84 + math/slalib/dm2av.f | 75 + math/slalib/dmat.f | 158 + math/slalib/dmoon.f | 659 ++ math/slalib/dmxm.f | 73 + math/slalib/dmxv.f | 69 + math/slalib/doc/addet.hlp | 42 + math/slalib/doc/afin.hlp | 91 + math/slalib/doc/airmas.hlp | 51 + math/slalib/doc/altaz.hlp | 79 + math/slalib/doc/amp.hlp | 61 + math/slalib/doc/ampqk.hlp | 65 + math/slalib/doc/aop.hlp | 166 + math/slalib/doc/aoppa.hlp | 114 + math/slalib/doc/aoppat.hlp | 39 + math/slalib/doc/aopqk.hlp | 131 + math/slalib/doc/atmdsp.hlp | 75 + math/slalib/doc/av2m.hlp | 37 + math/slalib/doc/bear.hlp | 30 + math/slalib/doc/caf2r.hlp | 38 + math/slalib/doc/caldj.hlp | 38 + math/slalib/doc/calyd.hlp | 49 + math/slalib/doc/cc2s.hlp | 33 + math/slalib/doc/cc62s.hlp | 30 + math/slalib/doc/cd2tf.hlp | 47 + math/slalib/doc/cldj.hlp | 34 + math/slalib/doc/clyd.hlp | 50 + math/slalib/doc/cr2af.hlp | 46 + math/slalib/doc/cr2tf.hlp | 46 + math/slalib/doc/cs2c.hlp | 31 + math/slalib/doc/cs2c6.hlp | 30 + math/slalib/doc/ctf2d.hlp | 37 + math/slalib/doc/ctf2r.hlp | 40 + math/slalib/doc/daf2r.hlp | 36 + math/slalib/doc/dafin.hlp | 90 + math/slalib/doc/dat.hlp | 55 + math/slalib/doc/dav2m.hlp | 36 + math/slalib/doc/dbear.hlp | 30 + math/slalib/doc/dbjin.hlp | 52 + math/slalib/doc/dc62s.hlp | 30 + math/slalib/doc/dcc2s.hlp | 33 + math/slalib/doc/dcmpf.hlp | 70 + math/slalib/doc/dcs2c.hlp | 31 + math/slalib/doc/dd2tf.hlp | 44 + math/slalib/doc/de2h.hlp | 59 + math/slalib/doc/deuler.hlp | 50 + math/slalib/doc/dfltin.hlp | 118 + math/slalib/doc/dh2e.hlp | 58 + math/slalib/doc/dimxv.hlp | 32 + math/slalib/doc/djcal.hlp | 38 + math/slalib/doc/djcl.hlp | 34 + math/slalib/doc/dm2av.hlp | 38 + math/slalib/doc/dmat.hlp | 58 + math/slalib/doc/dmoon.hlp | 58 + math/slalib/doc/dmxm.hlp | 34 + math/slalib/doc/dmxv.hlp | 29 + math/slalib/doc/dpav.hlp | 38 + math/slalib/doc/dr2af.hlp | 46 + math/slalib/doc/dr2tf.hlp | 46 + math/slalib/doc/drange.hlp | 23 + math/slalib/doc/dranrm.hlp | 24 + math/slalib/doc/ds2c6.hlp | 32 + math/slalib/doc/ds2tp.hlp | 30 + math/slalib/doc/dsep.hlp | 29 + math/slalib/doc/dt.hlp | 55 + math/slalib/doc/dtf2d.hlp | 36 + math/slalib/doc/dtf2r.hlp | 39 + math/slalib/doc/dtp2s.hlp | 28 + math/slalib/doc/dtp2v.hlp | 40 + math/slalib/doc/dtps2c.hlp | 58 + math/slalib/doc/dtpv2c.hlp | 51 + math/slalib/doc/dtt.hlp | 41 + math/slalib/doc/dv2tp.hlp | 42 + math/slalib/doc/dvdv.hlp | 24 + math/slalib/doc/dvn.hlp | 27 + math/slalib/doc/dvxv.hlp | 25 + math/slalib/doc/e2h.hlp | 59 + math/slalib/doc/earth.hlp | 44 + math/slalib/doc/ecleq.hlp | 31 + math/slalib/doc/ecmat.hlp | 34 + math/slalib/doc/ecor.hlp | 54 + math/slalib/doc/eg50.hlp | 38 + math/slalib/doc/el2ue.hlp | 133 + math/slalib/doc/epb.hlp | 27 + math/slalib/doc/epb2d.hlp | 27 + math/slalib/doc/epco.hlp | 40 + math/slalib/doc/epj.hlp | 26 + math/slalib/doc/epj2d.hlp | 26 + math/slalib/doc/eqecl.hlp | 31 + math/slalib/doc/eqeqx.hlp | 33 + math/slalib/doc/eqgal.hlp | 38 + math/slalib/doc/etrms.hlp | 35 + math/slalib/doc/euler.hlp | 52 + math/slalib/doc/evp.hlp | 66 + math/slalib/doc/fitxy.hlp | 76 + math/slalib/doc/fk425.hlp | 81 + math/slalib/doc/fk45z.hlp | 83 + math/slalib/doc/fk524.hlp | 81 + math/slalib/doc/fk52h.hlp | 56 + math/slalib/doc/fk54z.hlp | 56 + math/slalib/doc/fk5hz.hlp | 54 + math/slalib/doc/flotin.hlp | 118 + math/slalib/doc/galeq.hlp | 38 + math/slalib/doc/galsup.hlp | 43 + math/slalib/doc/ge50.hlp | 38 + math/slalib/doc/geoc.hlp | 33 + math/slalib/doc/gmst.hlp | 41 + math/slalib/doc/gmsta.hlp | 55 + math/slalib/doc/h2e.hlp | 58 + math/slalib/doc/h2fk5.hlp | 57 + math/slalib/doc/hfk5z.hlp | 60 + math/slalib/doc/imxv.hlp | 32 + math/slalib/doc/intin.hlp | 90 + math/slalib/doc/invf.hlp | 66 + math/slalib/doc/kbj.hlp | 28 + math/slalib/doc/m2av.hlp | 38 + math/slalib/doc/map.hlp | 65 + math/slalib/doc/mappa.hlp | 69 + math/slalib/doc/mapqk.hlp | 76 + math/slalib/doc/mapqkz.hlp | 68 + math/slalib/doc/moon.hlp | 59 + math/slalib/doc/mxm.hlp | 33 + math/slalib/doc/mxv.hlp | 29 + math/slalib/doc/nut.hlp | 34 + math/slalib/doc/nutc.hlp | 33 + math/slalib/doc/oap.hlp | 163 + math/slalib/doc/oapqk.hlp | 114 + math/slalib/doc/obs.hlp | 83 + math/slalib/doc/pa.hlp | 36 + math/slalib/doc/pav.hlp | 40 + math/slalib/doc/pcd.hlp | 51 + math/slalib/doc/pda2h.hlp | 33 + math/slalib/doc/pdq2h.hlp | 33 + math/slalib/doc/pertel.hlp | 121 + math/slalib/doc/pertue.hlp | 152 + math/slalib/doc/planel.hlp | 96 + math/slalib/doc/planet.hlp | 130 + math/slalib/doc/plante.hlp | 97 + math/slalib/doc/pm.hlp | 45 + math/slalib/doc/polmo.hlp | 87 + math/slalib/doc/prebn.hlp | 36 + math/slalib/doc/prec.hlp | 53 + math/slalib/doc/preces.hlp | 47 + math/slalib/doc/precl.hlp | 47 + math/slalib/doc/precss.hlp | 44 + math/slalib/doc/prenut.hlp | 35 + math/slalib/doc/pv2el.hlp | 145 + math/slalib/doc/pv2ue.hlp | 70 + math/slalib/doc/pvobs.hlp | 31 + math/slalib/doc/pxy.hlp | 56 + math/slalib/doc/range.hlp | 24 + math/slalib/doc/ranorm.hlp | 24 + math/slalib/doc/rcc.hlp | 83 + math/slalib/doc/rdplan.hlp | 73 + math/slalib/doc/read.me | 437 ++ math/slalib/doc/refco.hlp | 54 + math/slalib/doc/refcoq.hlp | 167 + math/slalib/doc/refro.hlp | 123 + math/slalib/doc/refv.hlp | 79 + math/slalib/doc/refz.hlp | 78 + math/slalib/doc/rverot.hlp | 40 + math/slalib/doc/rvgalc.hlp | 42 + math/slalib/doc/rvlg.hlp | 36 + math/slalib/doc/rvlsrd.hlp | 51 + math/slalib/doc/rvlsrk.hlp | 50 + math/slalib/doc/s2tp.hlp | 31 + math/slalib/doc/sedscript | 35 + math/slalib/doc/sep.hlp | 29 + math/slalib/doc/sla.news | 36 + math/slalib/doc/slalib.hd | 183 + math/slalib/doc/slalib.hlp | 591 ++ math/slalib/doc/slalib.hlp.sav | 591 ++ math/slalib/doc/slalib.men | 179 + math/slalib/doc/smat.hlp | 60 + math/slalib/doc/subet.hlp | 41 + math/slalib/doc/sun67.tex | 12311 ++++++++++++++++++++++++++++++++++ math/slalib/doc/supgal.hlp | 43 + math/slalib/doc/svd.hlp | 73 + math/slalib/doc/svdcov.hlp | 35 + math/slalib/doc/svdsol.hlp | 82 + math/slalib/doc/tp2s.hlp | 28 + math/slalib/doc/tp2v.hlp | 40 + math/slalib/doc/tps2c.hlp | 58 + math/slalib/doc/tpv2c.hlp | 51 + math/slalib/doc/ue2el.hlp | 167 + math/slalib/doc/ue2pv.hlp | 87 + math/slalib/doc/unpcd.hlp | 57 + math/slalib/doc/v2tp.hlp | 42 + math/slalib/doc/vdv.hlp | 24 + math/slalib/doc/vn.hlp | 27 + math/slalib/doc/vxv.hlp | 25 + math/slalib/doc/xy2xy.hlp | 45 + math/slalib/doc/zd.hlp | 48 + math/slalib/dpav.f | 82 + math/slalib/dr2af.f | 76 + math/slalib/dr2tf.f | 76 + math/slalib/drange.f | 50 + math/slalib/dranrm.f | 48 + math/slalib/ds2c6.f | 75 + math/slalib/ds2tp.f | 85 + math/slalib/dsep.f | 61 + math/slalib/dsepv.f | 77 + math/slalib/dt.f | 97 + math/slalib/dtf2d.f | 73 + math/slalib/dtf2r.f | 71 + math/slalib/dtp2s.f | 60 + math/slalib/dtp2v.f | 74 + math/slalib/dtps2c.f | 109 + math/slalib/dtpv2c.f | 101 + math/slalib/dtt.f | 64 + math/slalib/dv2tp.f | 96 + math/slalib/dvdv.f | 45 + math/slalib/dvn.f | 70 + math/slalib/dvxv.f | 57 + math/slalib/e2h.f | 107 + math/slalib/earth.f | 130 + math/slalib/ecleq.f | 73 + math/slalib/ecmat.f | 70 + math/slalib/ecor.f | 96 + math/slalib/eg50.f | 108 + math/slalib/el2ue.f | 329 + math/slalib/epb.f | 48 + math/slalib/epb2d.f | 48 + math/slalib/epco.f | 69 + math/slalib/epj.f | 47 + math/slalib/epj2d.f | 47 + math/slalib/epv.f | 2509 +++++++ math/slalib/eqecl.f | 73 + math/slalib/eqeqx.f | 75 + math/slalib/eqgal.f | 97 + math/slalib/etrms.f | 80 + math/slalib/euler.f | 86 + math/slalib/evp.f | 457 ++ math/slalib/f77.h.in | 956 +++ math/slalib/fitxy.f | 329 + math/slalib/fk425.f | 267 + math/slalib/fk45z.f | 183 + math/slalib/fk524.f | 275 + math/slalib/fk52h.f | 123 + math/slalib/fk54z.f | 87 + math/slalib/fk5hz.f | 125 + math/slalib/flotin.f | 146 + math/slalib/galeq.f | 97 + math/slalib/galsup.f | 97 + math/slalib/ge50.f | 108 + math/slalib/geoc.f | 78 + math/slalib/gmst.f | 78 + math/slalib/gmsta.f | 100 + math/slalib/gresid.F__vms | 89 + math/slalib/gresid.F__win | 90 + math/slalib/gresid.Fdefault | 113 + math/slalib/h2e.f | 101 + math/slalib/h2fk5.f | 127 + math/slalib/hfk5z.f | 140 + math/slalib/idchf.f | 112 + math/slalib/idchi.f | 109 + math/slalib/imxv.f | 69 + math/slalib/intin.f | 194 + math/slalib/invf.f | 106 + math/slalib/kbj.f | 74 + math/slalib/m2av.f | 75 + math/slalib/map.f | 99 + math/slalib/mappa.f | 129 + math/slalib/mapqk.f | 160 + math/slalib/mapqkz.f | 131 + math/slalib/mkpkg | 193 + math/slalib/moon.f | 380 ++ math/slalib/mxm.f | 72 + math/slalib/mxv.f | 69 + math/slalib/newnames | 205 + math/slalib/nut.f | 76 + math/slalib/nutc.f | 831 +++ math/slalib/nutc80.f | 476 ++ math/slalib/oap.f | 193 + math/slalib/oapqk.f | 251 + math/slalib/obs.f | 943 +++ math/slalib/pa.f | 64 + math/slalib/pav.f | 71 + math/slalib/pcd.f | 77 + math/slalib/pda2h.f | 118 + math/slalib/pdq2h.f | 116 + math/slalib/permut.f | 160 + math/slalib/pertel.f | 182 + math/slalib/pertue.f | 644 ++ math/slalib/planel.f | 184 + math/slalib/planet.f | 725 ++ math/slalib/plante.f | 251 + math/slalib/plantu.f | 156 + math/slalib/pm.f | 98 + math/slalib/polmo.f | 159 + math/slalib/prebn.f | 80 + math/slalib/prec.f | 97 + math/slalib/preces.f | 102 + math/slalib/precl.f | 143 + math/slalib/precss.f | 76 + math/slalib/precss.f.sav | 76 + math/slalib/prenut.f | 67 + math/slalib/pv2el.f | 380 ++ math/slalib/pv2ue.f | 168 + math/slalib/pvobs.f | 77 + math/slalib/pxy.f | 110 + math/slalib/random.F__vms | 69 + math/slalib/random.F__win | 59 + math/slalib/random.Fdefault | 87 + math/slalib/range.f | 51 + math/slalib/ranorm.f | 49 + math/slalib/rcc.f | 1110 ++++ math/slalib/rdplan.f | 201 + math/slalib/read.me | 443 ++ math/slalib/refco.f | 88 + math/slalib/refcoq.f | 227 + math/slalib/refro.f | 402 ++ math/slalib/refv.f | 129 + math/slalib/refz.f | 170 + math/slalib/rtl_random.c | 33 + math/slalib/rverot.f | 66 + math/slalib/rvgalc.f | 87 + math/slalib/rvlg.f | 82 + math/slalib/rvlsrd.f | 96 + math/slalib/rvlsrk.f | 95 + math/slalib/s2tp.f | 85 + math/slalib/sedscript | 17 + math/slalib/sep.f | 56 + math/slalib/sepv.f | 71 + math/slalib/sla.c | 2338 +++++++ math/slalib/sla.news | 88 + math/slalib/slaTest.c | 112 + math/slalib/sla_link | 1 + math/slalib/sla_link_adam | 1 + math/slalib/sla_test.f | 6655 +++++++++++++++++++ math/slalib/slalib.h | 509 ++ math/slalib/smat.f | 159 + math/slalib/subet.f | 84 + math/slalib/sun67.tex | 13140 +++++++++++++++++++++++++++++++++++++ math/slalib/supgal.f | 97 + math/slalib/svd.f | 401 ++ math/slalib/svdcov.f | 78 + math/slalib/svdsol.f | 127 + math/slalib/tp2s.f | 60 + math/slalib/tp2v.f | 74 + math/slalib/tps2c.f | 109 + math/slalib/tpv2c.f | 101 + math/slalib/ue2el.f | 212 + math/slalib/ue2pv.f | 253 + math/slalib/unpcd.f | 145 + math/slalib/v2tp.f | 96 + math/slalib/vdv.f | 45 + math/slalib/veri.f.in | 52 + math/slalib/vers.f.in | 58 + math/slalib/vn.f | 64 + math/slalib/vxv.f | 57 + math/slalib/wait.f__vms | 60 + math/slalib/wait.f__win | 83 + math/slalib/wait.fdefault | 49 + math/slalib/xy2xy.f | 67 + math/slalib/zd.f | 80 + math/surfit/doc/iscoeff.hlp | 63 + math/surfit/doc/iseval.hlp | 34 + math/surfit/doc/isfree.hlp | 27 + math/surfit/doc/isinit.hlp | 61 + math/surfit/doc/islaccum.hlp | 60 + math/surfit/doc/islfit.hlp | 67 + math/surfit/doc/islrefit.hlp | 51 + math/surfit/doc/islsolve.hlp | 45 + math/surfit/doc/islzero.hlp | 32 + math/surfit/doc/isreplace.hlp | 33 + math/surfit/doc/isresolve.hlp | 45 + math/surfit/doc/issave.hlp | 55 + math/surfit/doc/issolve.hlp | 49 + math/surfit/doc/isvector.hlp | 41 + math/surfit/doc/iszero.hlp | 26 + math/surfit/doc/surfit.hd | 19 + math/surfit/doc/surfit.hlp | 157 + math/surfit/doc/surfit.men | 15 + math/surfit/doc/surfit.spc | 500 ++ math/surfit/iscoeff.x | 37 + math/surfit/iseval.x | 92 + math/surfit/isfree.x | 45 + math/surfit/isinit.x | 167 + math/surfit/islaccum.x | 117 + math/surfit/islfit.x | 150 + math/surfit/islrefit.x | 74 + math/surfit/islsolve.x | 48 + math/surfit/islzero.x | 25 + math/surfit/isreplace.x | 114 + math/surfit/isresolve.x | 127 + math/surfit/issave.x | 44 + math/surfit/issolve.x | 169 + math/surfit/isvector.x | 76 + math/surfit/iszero.x | 26 + math/surfit/mkpkg | 29 + math/surfit/sf_b1eval.x | 108 + math/surfit/sf_beval.x | 143 + math/surfit/sf_f1deval.x | 233 + math/surfit/sf_feval.x | 280 + math/surfit/sfchomat.x | 105 + math/surfit/surfitdef.h | 74 + 1095 files changed, 147396 insertions(+) create mode 100644 math/README create mode 100644 math/Revisions create mode 100644 math/_math.hd create mode 100644 math/bevington/README create mode 100644 math/bevington/agauss.f create mode 100644 math/bevington/area.f create mode 100644 math/bevington/chifit.f create mode 100644 math/bevington/curfit.f create mode 100644 math/bevington/determ.f create mode 100644 math/bevington/factor.f create mode 100644 math/bevington/fchisq.f create mode 100644 math/bevington/fderiv.f create mode 100644 math/bevington/gamma.f create mode 100644 math/bevington/gradls.f create mode 100644 math/bevington/gridls.f create mode 100644 math/bevington/integ.f create mode 100644 math/bevington/interp.f create mode 100644 math/bevington/legfit.f create mode 100644 math/bevington/linfit.f create mode 100644 math/bevington/man/agauss.3m create mode 100644 math/bevington/man/area.3m create mode 100644 math/bevington/man/chifit.3m create mode 100644 math/bevington/man/curfit.3m create mode 100644 math/bevington/man/determ.3m create mode 100644 math/bevington/man/factor.3m create mode 100644 math/bevington/man/fchisq.3m create mode 100644 math/bevington/man/fderiv.3m create mode 100644 math/bevington/man/gamma.3m create mode 100644 math/bevington/man/gradls.3m create mode 100644 math/bevington/man/gridls.3m create mode 100644 math/bevington/man/integ.3m create mode 100644 math/bevington/man/interp.3m create mode 100644 math/bevington/man/legfit.3m create mode 100644 math/bevington/man/linfit.3m create mode 100644 math/bevington/man/matinv.3m create mode 100644 math/bevington/man/pbinom.3m create mode 100644 math/bevington/man/pchisq.3m create mode 100644 math/bevington/man/pcorre.3m create mode 100644 math/bevington/man/pgauss.3m create mode 100644 math/bevington/man/ploren.3m create mode 100644 math/bevington/man/polfit.3m create mode 100644 math/bevington/man/ppoiss.3m create mode 100644 math/bevington/man/regres.3m create mode 100644 math/bevington/man/smooth.3m create mode 100644 math/bevington/man/xfit.3m create mode 100644 math/bevington/matinv.f create mode 100644 math/bevington/mkpkg create mode 100644 math/bevington/pbinom.f create mode 100644 math/bevington/pchisq.f create mode 100644 math/bevington/pcorre.f create mode 100644 math/bevington/pgauss.f create mode 100644 math/bevington/ploren.f create mode 100644 math/bevington/polfit.f create mode 100644 math/bevington/ppoiss.f create mode 100644 math/bevington/regres.f create mode 100644 math/bevington/smooth.f create mode 100644 math/bevington/xfit.f create mode 100644 math/curfit/README create mode 100644 math/curfit/Revisions create mode 100644 math/curfit/curfit.sem create mode 100644 math/curfit/curfitdef.h create mode 100644 math/curfit/cv_b1eval.gx create mode 100644 math/curfit/cv_b1evald.x create mode 100644 math/curfit/cv_b1evalr.x create mode 100644 math/curfit/cv_beval.gx create mode 100644 math/curfit/cv_bevald.x create mode 100644 math/curfit/cv_bevalr.x create mode 100644 math/curfit/cv_feval.gx create mode 100644 math/curfit/cv_fevald.x create mode 100644 math/curfit/cv_fevalr.x create mode 100644 math/curfit/cv_userfnc.gx create mode 100644 math/curfit/cv_userfncd.x create mode 100644 math/curfit/cv_userfncr.x create mode 100644 math/curfit/cvaccum.gx create mode 100644 math/curfit/cvaccumd.x create mode 100644 math/curfit/cvaccumr.x create mode 100644 math/curfit/cvacpts.gx create mode 100644 math/curfit/cvacptsd.x create mode 100644 math/curfit/cvacptsr.x create mode 100644 math/curfit/cvchomat.gx create mode 100644 math/curfit/cvchomatd.x create mode 100644 math/curfit/cvchomatr.x create mode 100644 math/curfit/cvcoeff.gx create mode 100644 math/curfit/cvcoeffd.x create mode 100644 math/curfit/cvcoeffr.x create mode 100644 math/curfit/cverrors.gx create mode 100644 math/curfit/cverrorsd.x create mode 100644 math/curfit/cverrorsr.x create mode 100644 math/curfit/cveval.gx create mode 100644 math/curfit/cvevald.x create mode 100644 math/curfit/cvevalr.x create mode 100644 math/curfit/cvfit.gx create mode 100644 math/curfit/cvfitd.x create mode 100644 math/curfit/cvfitr.x create mode 100644 math/curfit/cvfree.gx create mode 100644 math/curfit/cvfreed.x create mode 100644 math/curfit/cvfreer.x create mode 100644 math/curfit/cvinit.gx create mode 100644 math/curfit/cvinitd.x create mode 100644 math/curfit/cvinitr.x create mode 100644 math/curfit/cvpower.gx create mode 100644 math/curfit/cvpowerd.x create mode 100644 math/curfit/cvpowerr.x create mode 100644 math/curfit/cvrefit.gx create mode 100644 math/curfit/cvrefitd.x create mode 100644 math/curfit/cvrefitr.x create mode 100644 math/curfit/cvreject.gx create mode 100644 math/curfit/cvrejectd.x create mode 100644 math/curfit/cvrejectr.x create mode 100644 math/curfit/cvrestore.gx create mode 100644 math/curfit/cvrestored.x create mode 100644 math/curfit/cvrestorer.x create mode 100644 math/curfit/cvsave.gx create mode 100644 math/curfit/cvsaved.x create mode 100644 math/curfit/cvsaver.x create mode 100644 math/curfit/cvset.gx create mode 100644 math/curfit/cvsetd.x create mode 100644 math/curfit/cvsetr.x create mode 100644 math/curfit/cvsolve.gx create mode 100644 math/curfit/cvsolved.x create mode 100644 math/curfit/cvsolver.x create mode 100644 math/curfit/cvstat.gx create mode 100644 math/curfit/cvstatd.x create mode 100644 math/curfit/cvstatr.x create mode 100644 math/curfit/cvvector.gx create mode 100644 math/curfit/cvvectord.x create mode 100644 math/curfit/cvvectorr.x create mode 100644 math/curfit/cvzero.gx create mode 100644 math/curfit/cvzerod.x create mode 100644 math/curfit/cvzeror.x create mode 100644 math/curfit/dcurfitdef.h create mode 100644 math/curfit/doc/curfit.hd create mode 100644 math/curfit/doc/curfit.hlp create mode 100644 math/curfit/doc/curfit.men create mode 100644 math/curfit/doc/curfit.spc create mode 100644 math/curfit/doc/cvaccum.hlp create mode 100644 math/curfit/doc/cvacpts.hlp create mode 100644 math/curfit/doc/cvcoeff.hlp create mode 100644 math/curfit/doc/cvepower.hlp create mode 100644 math/curfit/doc/cverrors.hlp create mode 100644 math/curfit/doc/cveval.hlp create mode 100644 math/curfit/doc/cvfit.hlp create mode 100644 math/curfit/doc/cvfree.hlp create mode 100644 math/curfit/doc/cvinit.hlp create mode 100644 math/curfit/doc/cvpower.hlp create mode 100644 math/curfit/doc/cvrefit.hlp create mode 100644 math/curfit/doc/cvreject.hlp create mode 100644 math/curfit/doc/cvrestore.hlp create mode 100644 math/curfit/doc/cvsave.hlp create mode 100644 math/curfit/doc/cvset.hlp create mode 100644 math/curfit/doc/cvsolve.hlp create mode 100644 math/curfit/doc/cvstati.hlp create mode 100644 math/curfit/doc/cvstatr.hlp create mode 100644 math/curfit/doc/cvvector.hlp create mode 100644 math/curfit/doc/cvzero.hlp create mode 100644 math/curfit/mkpkg create mode 100644 math/deboor/Notes create mode 100644 math/deboor/README create mode 100644 math/deboor/Revisions create mode 100644 math/deboor/banfac.f create mode 100644 math/deboor/banslv.f create mode 100644 math/deboor/bchfac.f create mode 100644 math/deboor/bchslv.f create mode 100644 math/deboor/bsplbv.f create mode 100644 math/deboor/bspln.h create mode 100644 math/deboor/bsplpp.f create mode 100644 math/deboor/bsplvd.f create mode 100644 math/deboor/bspp2d.f create mode 100644 math/deboor/bvalue.f create mode 100644 math/deboor/chol1d.f create mode 100644 math/deboor/colloc_io.f create mode 100644 math/deboor/colpnt_io.f create mode 100644 math/deboor/cubspl.f create mode 100644 math/deboor/cwidth.f create mode 100644 math/deboor/difequ_io.f create mode 100644 math/deboor/dtblok.f create mode 100644 math/deboor/eqblok_io.f create mode 100644 math/deboor/factrb.f create mode 100644 math/deboor/fcblok.f create mode 100644 math/deboor/fsplin.x create mode 100644 math/deboor/interv.f create mode 100644 math/deboor/knots.f create mode 100644 math/deboor/l2appr.f create mode 100644 math/deboor/l2err_io.f create mode 100644 math/deboor/l2knts.f create mode 100644 math/deboor/mkpkg create mode 100644 math/deboor/newnot_fake.f create mode 100644 math/deboor/newnot_io.f create mode 100644 math/deboor/ppvalu.f create mode 100644 math/deboor/progs/prog1.f create mode 100644 math/deboor/progs/prog10.f create mode 100644 math/deboor/progs/prog11.f create mode 100644 math/deboor/progs/prog12.f create mode 100644 math/deboor/progs/prog13.f create mode 100644 math/deboor/progs/prog14.f create mode 100644 math/deboor/progs/prog15.f create mode 100644 math/deboor/progs/prog16.f create mode 100644 math/deboor/progs/prog17.f create mode 100644 math/deboor/progs/prog18.f create mode 100644 math/deboor/progs/prog19.f create mode 100644 math/deboor/progs/prog2.f create mode 100644 math/deboor/progs/prog20.f create mode 100644 math/deboor/progs/prog21.f create mode 100644 math/deboor/progs/prog3.f create mode 100644 math/deboor/progs/prog4.f create mode 100644 math/deboor/progs/prog5.f create mode 100644 math/deboor/progs/prog6.f create mode 100644 math/deboor/progs/prog7.f create mode 100644 math/deboor/progs/prog8.f create mode 100644 math/deboor/progs/prog9.f create mode 100644 math/deboor/putit_io.f create mode 100644 math/deboor/round.f create mode 100644 math/deboor/sbblok.f create mode 100644 math/deboor/setdat.f create mode 100644 math/deboor/setdat2.f create mode 100644 math/deboor/setdat3.f create mode 100644 math/deboor/setupq.f create mode 100644 math/deboor/seval.x create mode 100644 math/deboor/shiftb.f create mode 100644 math/deboor/slvblk.f create mode 100644 math/deboor/smooth.f create mode 100644 math/deboor/spli2d_io.f create mode 100644 math/deboor/spline.x create mode 100644 math/deboor/splint.f create mode 100644 math/deboor/spllsq.x create mode 100644 math/deboor/splopt_io.f create mode 100644 math/deboor/splsqv.x create mode 100644 math/deboor/subbak.f create mode 100644 math/deboor/subfor.f create mode 100644 math/deboor/tautsp.f create mode 100644 math/deboor/titand.f create mode 100644 math/gsurfit/README create mode 100644 math/gsurfit/dgsurfitdef.h create mode 100644 math/gsurfit/doc/gsaccum.hlp create mode 100644 math/gsurfit/doc/gsacpts.hlp create mode 100644 math/gsurfit/doc/gsadd.hlp create mode 100644 math/gsurfit/doc/gscoeff.hlp create mode 100644 math/gsurfit/doc/gscopy.hlp create mode 100644 math/gsurfit/doc/gsder.hlp create mode 100644 math/gsurfit/doc/gserrors.hlp create mode 100644 math/gsurfit/doc/gseval.hlp create mode 100644 math/gsurfit/doc/gsfit.hlp create mode 100644 math/gsurfit/doc/gsfree.hlp create mode 100644 math/gsurfit/doc/gsgcoeff.hlp create mode 100644 math/gsurfit/doc/gsinit.hlp create mode 100644 math/gsurfit/doc/gsrefit.hlp create mode 100644 math/gsurfit/doc/gsreject.hlp create mode 100644 math/gsurfit/doc/gsrestore.hlp create mode 100644 math/gsurfit/doc/gssave.hlp create mode 100644 math/gsurfit/doc/gsscoeff.hlp create mode 100644 math/gsurfit/doc/gssolve.hlp create mode 100644 math/gsurfit/doc/gsstati.hlp create mode 100644 math/gsurfit/doc/gsstatr.hlp create mode 100644 math/gsurfit/doc/gssub.hlp create mode 100644 math/gsurfit/doc/gsurfit.hd create mode 100644 math/gsurfit/doc/gsurfit.hlp create mode 100644 math/gsurfit/doc/gsurfit.men create mode 100644 math/gsurfit/doc/gsvector.hlp create mode 100644 math/gsurfit/doc/gszero.hlp create mode 100644 math/gsurfit/gs_b1eval.gx create mode 100644 math/gsurfit/gs_b1evald.x create mode 100644 math/gsurfit/gs_b1evalr.x create mode 100644 math/gsurfit/gs_beval.gx create mode 100644 math/gsurfit/gs_bevald.x create mode 100644 math/gsurfit/gs_bevalr.x create mode 100644 math/gsurfit/gs_chomat.gx create mode 100644 math/gsurfit/gs_chomatd.x create mode 100644 math/gsurfit/gs_chomatr.x create mode 100644 math/gsurfit/gs_deval.gx create mode 100644 math/gsurfit/gs_devald.x create mode 100644 math/gsurfit/gs_devalr.x create mode 100644 math/gsurfit/gs_f1deval.gx create mode 100644 math/gsurfit/gs_f1devald.x create mode 100644 math/gsurfit/gs_f1devalr.x create mode 100644 math/gsurfit/gs_fder.gx create mode 100644 math/gsurfit/gs_fderd.x create mode 100644 math/gsurfit/gs_fderr.x create mode 100644 math/gsurfit/gs_feval.gx create mode 100644 math/gsurfit/gs_fevald.x create mode 100644 math/gsurfit/gs_fevalr.x create mode 100644 math/gsurfit/gsaccum.gx create mode 100644 math/gsurfit/gsaccumd.x create mode 100644 math/gsurfit/gsaccumr.x create mode 100644 math/gsurfit/gsacpts.gx create mode 100644 math/gsurfit/gsacptsd.x create mode 100644 math/gsurfit/gsacptsr.x create mode 100644 math/gsurfit/gsadd.gx create mode 100644 math/gsurfit/gsaddd.x create mode 100644 math/gsurfit/gsaddr.x create mode 100644 math/gsurfit/gscoeff.gx create mode 100644 math/gsurfit/gscoeffd.x create mode 100644 math/gsurfit/gscoeffr.x create mode 100644 math/gsurfit/gscopy.gx create mode 100644 math/gsurfit/gscopyd.x create mode 100644 math/gsurfit/gscopyr.x create mode 100644 math/gsurfit/gsder.gx create mode 100644 math/gsurfit/gsderd.x create mode 100644 math/gsurfit/gsderr.x create mode 100644 math/gsurfit/gserrors.gx create mode 100644 math/gsurfit/gserrorsd.x create mode 100644 math/gsurfit/gserrorsr.x create mode 100644 math/gsurfit/gseval.gx create mode 100644 math/gsurfit/gsevald.x create mode 100644 math/gsurfit/gsevalr.x create mode 100644 math/gsurfit/gsfit.gx create mode 100644 math/gsurfit/gsfit1.gx create mode 100644 math/gsurfit/gsfit1d.x create mode 100644 math/gsurfit/gsfit1r.x create mode 100644 math/gsurfit/gsfitd.x create mode 100644 math/gsurfit/gsfitr.x create mode 100644 math/gsurfit/gsfree.gx create mode 100644 math/gsurfit/gsfreed.x create mode 100644 math/gsurfit/gsfreer.x create mode 100644 math/gsurfit/gsgcoeff.gx create mode 100644 math/gsurfit/gsgcoeffd.x create mode 100644 math/gsurfit/gsgcoeffr.x create mode 100644 math/gsurfit/gsinit.gx create mode 100644 math/gsurfit/gsinitd.x create mode 100644 math/gsurfit/gsinitr.x create mode 100644 math/gsurfit/gsrefit.gx create mode 100644 math/gsurfit/gsrefitd.x create mode 100644 math/gsurfit/gsrefitr.x create mode 100644 math/gsurfit/gsreject.gx create mode 100644 math/gsurfit/gsrejectd.x create mode 100644 math/gsurfit/gsrejectr.x create mode 100644 math/gsurfit/gsrestore.gx create mode 100644 math/gsurfit/gsrestored.x create mode 100644 math/gsurfit/gsrestorer.x create mode 100644 math/gsurfit/gssave.gx create mode 100644 math/gsurfit/gssaved.x create mode 100644 math/gsurfit/gssaver.x create mode 100644 math/gsurfit/gsscoeff.gx create mode 100644 math/gsurfit/gsscoeffd.x create mode 100644 math/gsurfit/gsscoeffr.x create mode 100644 math/gsurfit/gssolve.gx create mode 100644 math/gsurfit/gssolved.x create mode 100644 math/gsurfit/gssolver.x create mode 100644 math/gsurfit/gsstat.gx create mode 100644 math/gsurfit/gsstatd.x create mode 100644 math/gsurfit/gsstatr.x create mode 100644 math/gsurfit/gssub.gx create mode 100644 math/gsurfit/gssubd.x create mode 100644 math/gsurfit/gssubr.x create mode 100644 math/gsurfit/gsurfit.h create mode 100644 math/gsurfit/gsurfitdef.h create mode 100644 math/gsurfit/gsvector.gx create mode 100644 math/gsurfit/gsvectord.x create mode 100644 math/gsurfit/gsvectorr.x create mode 100644 math/gsurfit/gszero.gx create mode 100644 math/gsurfit/gszerod.x create mode 100644 math/gsurfit/gszeror.x create mode 100644 math/gsurfit/mkpkg create mode 100644 math/gsurfit/zzdebug.x create mode 100644 math/ieee/README create mode 100644 math/ieee/chap1/README create mode 100644 math/ieee/chap1/const.f create mode 100644 math/ieee/chap1/fast.f create mode 100644 math/ieee/chap1/ffa.f create mode 100644 math/ieee/chap1/ffs.f create mode 100644 math/ieee/chap1/fft842.f create mode 100644 math/ieee/chap1/fftaoh.f create mode 100644 math/ieee/chap1/fftasm.f create mode 100644 math/ieee/chap1/fftohm.f create mode 100644 math/ieee/chap1/fftsoh.f create mode 100644 math/ieee/chap1/fftsym.f create mode 100644 math/ieee/chap1/ford1.f create mode 100644 math/ieee/chap1/ford2.f create mode 100644 math/ieee/chap1/fourea.f create mode 100644 math/ieee/chap1/fr2tr.f create mode 100644 math/ieee/chap1/fr4syn.f create mode 100644 math/ieee/chap1/fr4tr.f create mode 100644 math/ieee/chap1/fsst.f create mode 100644 math/ieee/chap1/iftaoh.f create mode 100644 math/ieee/chap1/iftasm.f create mode 100644 math/ieee/chap1/iftohm.f create mode 100644 math/ieee/chap1/iftsoh.f create mode 100644 math/ieee/chap1/iftsym.f create mode 100644 math/ieee/chap1/inishl.f create mode 100644 math/ieee/chap1/ord1.f create mode 100644 math/ieee/chap1/ord2.f create mode 100644 math/ieee/chap1/r2tr.f create mode 100644 math/ieee/chap1/r2tx.f create mode 100644 math/ieee/chap1/r4syn.f create mode 100644 math/ieee/chap1/r4tr.f create mode 100644 math/ieee/chap1/r4tx.f create mode 100644 math/ieee/chap1/r8syn.f create mode 100644 math/ieee/chap1/r8tr.f create mode 100644 math/ieee/chap1/r8tx.f create mode 100644 math/ieee/chap1/rad4sb.f create mode 100644 math/ieee/chap1/radix4.f create mode 100644 math/ieee/chap1/test/test12.f create mode 100644 math/ieee/chap1/test/test13.f create mode 100644 math/ieee/chap1/test/test17.f create mode 100644 math/ieee/chap1/test/test18.f create mode 100644 math/ieee/chap1/time/time12.f create mode 100644 math/ieee/chap1/time/time17.f create mode 100644 math/ieee/chap1/time/time18.f create mode 100644 math/ieee/chap1/weave1.f create mode 100644 math/ieee/chap1/weave2.f create mode 100644 math/ieee/chap1/wfta.f create mode 100644 math/ieee/d1mach.f create mode 100644 math/ieee/i1mach.f create mode 100644 math/ieee/r1mach.f create mode 100644 math/ieee/uni.c create mode 100644 math/iminterp/Revisions create mode 100644 math/iminterp/arbpix.x create mode 100644 math/iminterp/arider.x create mode 100644 math/iminterp/arieval.x create mode 100644 math/iminterp/asider.x create mode 100644 math/iminterp/asieval.x create mode 100644 math/iminterp/asifit.x create mode 100644 math/iminterp/asifree.x create mode 100644 math/iminterp/asigeti.x create mode 100644 math/iminterp/asigetr.x create mode 100644 math/iminterp/asigrl.x create mode 100644 math/iminterp/asiinit.x create mode 100644 math/iminterp/asirestore.x create mode 100644 math/iminterp/asisave.x create mode 100644 math/iminterp/asisinit.x create mode 100644 math/iminterp/asitype.x create mode 100644 math/iminterp/asivector.x create mode 100644 math/iminterp/doc/arbpix.hlp create mode 100644 math/iminterp/doc/arider.hlp create mode 100644 math/iminterp/doc/arieval.hlp create mode 100644 math/iminterp/doc/asider.hlp create mode 100644 math/iminterp/doc/asieval.hlp create mode 100644 math/iminterp/doc/asifit.hlp create mode 100644 math/iminterp/doc/asifree.hlp create mode 100644 math/iminterp/doc/asigeti.hlp create mode 100644 math/iminterp/doc/asigetr.hlp create mode 100644 math/iminterp/doc/asigrl.hlp create mode 100644 math/iminterp/doc/asiinit.hlp create mode 100644 math/iminterp/doc/asirestore.hlp create mode 100644 math/iminterp/doc/asisave.hlp create mode 100644 math/iminterp/doc/asisinit.hlp create mode 100644 math/iminterp/doc/asitype.hlp create mode 100644 math/iminterp/doc/asivector.hlp create mode 100644 math/iminterp/doc/im1dinterp.spc create mode 100644 math/iminterp/doc/im2dinterp.spc create mode 100644 math/iminterp/doc/iminterp.hd create mode 100644 math/iminterp/doc/iminterp.hlp create mode 100644 math/iminterp/doc/iminterp.men create mode 100644 math/iminterp/doc/iminterp.spc create mode 100644 math/iminterp/doc/mrider.hlp create mode 100644 math/iminterp/doc/mrieval.hlp create mode 100644 math/iminterp/doc/msider.hlp create mode 100644 math/iminterp/doc/msieval.hlp create mode 100644 math/iminterp/doc/msifit.hlp create mode 100644 math/iminterp/doc/msifree.hlp create mode 100644 math/iminterp/doc/msigeti.hlp create mode 100644 math/iminterp/doc/msigetr.hlp create mode 100644 math/iminterp/doc/msigrid.hlp create mode 100644 math/iminterp/doc/msigrl.hlp create mode 100644 math/iminterp/doc/msiinit.hlp create mode 100644 math/iminterp/doc/msirestore.hlp create mode 100644 math/iminterp/doc/msisave.hlp create mode 100644 math/iminterp/doc/msisinit.hlp create mode 100644 math/iminterp/doc/msisqgrl.hlp create mode 100644 math/iminterp/doc/msitype.hlp create mode 100644 math/iminterp/doc/msivector.hlp create mode 100644 math/iminterp/ii_1dinteg.x create mode 100644 math/iminterp/ii_bieval.x create mode 100644 math/iminterp/ii_cubspl.f create mode 100644 math/iminterp/ii_eval.x create mode 100644 math/iminterp/ii_greval.x create mode 100644 math/iminterp/ii_pc1deval.x create mode 100644 math/iminterp/ii_pc2deval.x create mode 100644 math/iminterp/ii_polterp.x create mode 100644 math/iminterp/ii_sinctable.x create mode 100644 math/iminterp/ii_spline.x create mode 100644 math/iminterp/ii_spline2d.x create mode 100644 math/iminterp/im1interpdef.h create mode 100644 math/iminterp/im2interpdef.h create mode 100644 math/iminterp/mkpkg create mode 100644 math/iminterp/mrider.x create mode 100644 math/iminterp/mrieval.x create mode 100644 math/iminterp/msider.x create mode 100644 math/iminterp/msieval.x create mode 100644 math/iminterp/msifit.x create mode 100644 math/iminterp/msifree.x create mode 100644 math/iminterp/msigeti.x create mode 100644 math/iminterp/msigetr.x create mode 100644 math/iminterp/msigrid.x create mode 100644 math/iminterp/msigrl.x create mode 100644 math/iminterp/msiinit.x create mode 100644 math/iminterp/msirestore.x create mode 100644 math/iminterp/msisave.x create mode 100644 math/iminterp/msisinit.x create mode 100644 math/iminterp/msisqgrl.x create mode 100644 math/iminterp/msitype.x create mode 100644 math/iminterp/msivector.x create mode 100644 math/interp/Iinterp.hlp create mode 100644 math/interp/README create mode 100644 math/interp/arbpix.x create mode 100644 math/interp/arider.x create mode 100644 math/interp/arival.x create mode 100644 math/interp/asidef.h create mode 100644 math/interp/asider.x create mode 100644 math/interp/asieva.x create mode 100644 math/interp/asifit.x create mode 100644 math/interp/asigrl.x create mode 100644 math/interp/asiset.x create mode 100644 math/interp/asival.x create mode 100644 math/interp/bench.x create mode 100644 math/interp/cubspl.f create mode 100644 math/interp/iieval.x create mode 100644 math/interp/iif_spline.x create mode 100644 math/interp/iimail create mode 100644 math/interp/iipol_terp.x create mode 100644 math/interp/interp.h create mode 100644 math/interp/interpdef.h create mode 100644 math/interp/mkpkg create mode 100644 math/interp/noteari create mode 100644 math/interp/noteasi create mode 100644 math/interp/notes3 create mode 100644 math/interp/overview create mode 100644 math/interp/usernote create mode 100644 math/llsq/README create mode 100644 math/llsq/bndacc.f create mode 100644 math/llsq/bndsol.f create mode 100644 math/llsq/diff.f create mode 100644 math/llsq/g1.f create mode 100644 math/llsq/g2.f create mode 100644 math/llsq/gen.f create mode 100644 math/llsq/h12.f create mode 100644 math/llsq/hfti.f create mode 100644 math/llsq/ldp.f create mode 100644 math/llsq/mfeout.f create mode 100644 math/llsq/mkpkg create mode 100644 math/llsq/nnls.f create mode 100644 math/llsq/original_f/bndacc.f create mode 100644 math/llsq/original_f/bndsol.f create mode 100644 math/llsq/original_f/diff.f create mode 100644 math/llsq/original_f/g1.f create mode 100644 math/llsq/original_f/g2.f create mode 100644 math/llsq/original_f/gen.f create mode 100644 math/llsq/original_f/h12.f create mode 100644 math/llsq/original_f/hfti.f create mode 100644 math/llsq/original_f/ldp.f create mode 100644 math/llsq/original_f/nnls.f create mode 100644 math/llsq/original_f/qrbd.f create mode 100644 math/llsq/original_f/sfeout.f create mode 100644 math/llsq/original_f/sva.f create mode 100644 math/llsq/original_f/svdrs.f create mode 100644 math/llsq/progs/README create mode 100644 math/llsq/progs/band.x create mode 100644 math/llsq/progs/data4 create mode 100644 math/llsq/progs/lsq.x create mode 100644 math/llsq/progs/prog1.f create mode 100644 math/llsq/progs/prog2.f create mode 100644 math/llsq/progs/prog3.f create mode 100644 math/llsq/progs/prog4.f create mode 100644 math/llsq/progs/prog5.f create mode 100644 math/llsq/progs/prog6.f create mode 100644 math/llsq/qrbd.f create mode 100644 math/llsq/sva.f create mode 100644 math/llsq/svdrs.f create mode 100644 math/math.hd create mode 100644 math/math.men create mode 100644 math/minpack/chkder.f create mode 100644 math/minpack/dogleg.f create mode 100644 math/minpack/dpmpar.f create mode 100644 math/minpack/enorm.f create mode 100644 math/minpack/fdjac1.f create mode 100644 math/minpack/fdjac2.f create mode 100644 math/minpack/hybrd.f create mode 100644 math/minpack/hybrd1.f create mode 100644 math/minpack/hybrj.f create mode 100644 math/minpack/hybrj1.f create mode 100644 math/minpack/lmder.f create mode 100644 math/minpack/lmder1.f create mode 100644 math/minpack/lmdif.f create mode 100644 math/minpack/lmdif1.f create mode 100644 math/minpack/lmpar.f create mode 100644 math/minpack/lmstr.f create mode 100644 math/minpack/lmstr1.f create mode 100644 math/minpack/qform.f create mode 100644 math/minpack/qrfac.f create mode 100644 math/minpack/qrsolv.f create mode 100644 math/minpack/r1mpyq.f create mode 100644 math/minpack/r1updt.f create mode 100644 math/minpack/rwupdt.f create mode 100644 math/mkpkg create mode 100644 math/nlfit/README create mode 100644 math/nlfit/doc/nlerrors.hlp create mode 100644 math/nlfit/doc/nleval.hlp create mode 100644 math/nlfit/doc/nlfit.hd create mode 100644 math/nlfit/doc/nlfit.hlp create mode 100644 math/nlfit/doc/nlfit.men create mode 100644 math/nlfit/doc/nlfree.hlp create mode 100644 math/nlfit/doc/nlinit.hlp create mode 100644 math/nlfit/doc/nllmfit.hlp create mode 100644 math/nlfit/doc/nlpget.hlp create mode 100644 math/nlfit/doc/nlstat.hlp create mode 100644 math/nlfit/doc/nlvector.hlp create mode 100644 math/nlfit/mkpkg create mode 100644 math/nlfit/nlacpts.gx create mode 100644 math/nlfit/nlacptsd.x create mode 100644 math/nlfit/nlacptsr.x create mode 100644 math/nlfit/nlchomat.gx create mode 100644 math/nlfit/nlchomatd.x create mode 100644 math/nlfit/nlchomatr.x create mode 100644 math/nlfit/nldump.gx create mode 100644 math/nlfit/nldumpd.x create mode 100644 math/nlfit/nldumpr.x create mode 100644 math/nlfit/nlerrmsg.x create mode 100644 math/nlfit/nlerrors.gx create mode 100644 math/nlfit/nlerrorsd.x create mode 100644 math/nlfit/nlerrorsr.x create mode 100644 math/nlfit/nleval.gx create mode 100644 math/nlfit/nlevald.x create mode 100644 math/nlfit/nlevalr.x create mode 100644 math/nlfit/nlfit.gx create mode 100644 math/nlfit/nlfitd.x create mode 100644 math/nlfit/nlfitdef.gh create mode 100644 math/nlfit/nlfitdefd.h create mode 100644 math/nlfit/nlfitdefr.h create mode 100644 math/nlfit/nlfitr.x create mode 100644 math/nlfit/nlfree.gx create mode 100644 math/nlfit/nlfreed.x create mode 100644 math/nlfit/nlfreer.x create mode 100644 math/nlfit/nlinit.gx create mode 100644 math/nlfit/nlinitd.x create mode 100644 math/nlfit/nlinitr.x create mode 100644 math/nlfit/nliter.gx create mode 100644 math/nlfit/nliterd.x create mode 100644 math/nlfit/nliterr.x create mode 100644 math/nlfit/nllist.x create mode 100644 math/nlfit/nlpget.gx create mode 100644 math/nlfit/nlpgetd.x create mode 100644 math/nlfit/nlpgetr.x create mode 100644 math/nlfit/nlsolve.gx create mode 100644 math/nlfit/nlsolved.x create mode 100644 math/nlfit/nlsolver.x create mode 100644 math/nlfit/nlstat.gx create mode 100644 math/nlfit/nlstatd.x create mode 100644 math/nlfit/nlstati.x create mode 100644 math/nlfit/nlstatr.x create mode 100644 math/nlfit/nlvector.gx create mode 100644 math/nlfit/nlvectord.x create mode 100644 math/nlfit/nlvectorr.x create mode 100644 math/nlfit/nlzero.gx create mode 100644 math/nlfit/nlzerod.x create mode 100644 math/nlfit/nlzeror.x create mode 100644 math/slalib/Makefile.am create mode 100644 math/slalib/Notes create mode 100644 math/slalib/README create mode 100644 math/slalib/SED1 create mode 100644 math/slalib/SED2 create mode 100644 math/slalib/SLA_CONDITIONS create mode 100644 math/slalib/addet.f create mode 100644 math/slalib/afin.f create mode 100644 math/slalib/airmas.f create mode 100644 math/slalib/altaz.f create mode 100644 math/slalib/amp.f create mode 100644 math/slalib/ampqk.f create mode 100644 math/slalib/aop.f create mode 100644 math/slalib/aoppa.f create mode 100644 math/slalib/aoppat.f create mode 100644 math/slalib/aopqk.f create mode 100644 math/slalib/atmdsp.f create mode 100644 math/slalib/atms.f create mode 100644 math/slalib/atmt.f create mode 100644 math/slalib/av2m.f create mode 100644 math/slalib/bear.f create mode 100644 math/slalib/caf2r.f create mode 100644 math/slalib/caldj.f create mode 100644 math/slalib/calyd.f create mode 100644 math/slalib/cc2s.f create mode 100644 math/slalib/cc62s.f create mode 100644 math/slalib/cd2tf.f create mode 100644 math/slalib/cldj.f create mode 100644 math/slalib/clyd.f create mode 100644 math/slalib/combn.f create mode 100644 math/slalib/configure.ac create mode 100644 math/slalib/cr2af.f create mode 100644 math/slalib/cr2tf.f create mode 100644 math/slalib/cs2c.f create mode 100644 math/slalib/cs2c6.f create mode 100644 math/slalib/ctf2d.f create mode 100644 math/slalib/ctf2r.f create mode 100644 math/slalib/daf2r.f create mode 100644 math/slalib/dafin.f create mode 100644 math/slalib/dat.f create mode 100644 math/slalib/dav2m.f create mode 100644 math/slalib/dbear.f create mode 100644 math/slalib/dbjin.f create mode 100644 math/slalib/dc62s.f create mode 100644 math/slalib/dcc2s.f create mode 100644 math/slalib/dcmpf.f create mode 100644 math/slalib/dcs2c.f create mode 100644 math/slalib/dd2tf.f create mode 100644 math/slalib/de2h.f create mode 100644 math/slalib/deuler.f create mode 100644 math/slalib/dfltin.f create mode 100644 math/slalib/dh2e.f create mode 100644 math/slalib/dimxv.f create mode 100644 math/slalib/djcal.f create mode 100644 math/slalib/djcl.f create mode 100644 math/slalib/dm2av.f create mode 100644 math/slalib/dmat.f create mode 100644 math/slalib/dmoon.f create mode 100644 math/slalib/dmxm.f create mode 100644 math/slalib/dmxv.f create mode 100644 math/slalib/doc/addet.hlp create mode 100644 math/slalib/doc/afin.hlp create mode 100644 math/slalib/doc/airmas.hlp create mode 100644 math/slalib/doc/altaz.hlp create mode 100644 math/slalib/doc/amp.hlp create mode 100644 math/slalib/doc/ampqk.hlp create mode 100644 math/slalib/doc/aop.hlp create mode 100644 math/slalib/doc/aoppa.hlp create mode 100644 math/slalib/doc/aoppat.hlp create mode 100644 math/slalib/doc/aopqk.hlp create mode 100644 math/slalib/doc/atmdsp.hlp create mode 100644 math/slalib/doc/av2m.hlp create mode 100644 math/slalib/doc/bear.hlp create mode 100644 math/slalib/doc/caf2r.hlp create mode 100644 math/slalib/doc/caldj.hlp create mode 100644 math/slalib/doc/calyd.hlp create mode 100644 math/slalib/doc/cc2s.hlp create mode 100644 math/slalib/doc/cc62s.hlp create mode 100644 math/slalib/doc/cd2tf.hlp create mode 100644 math/slalib/doc/cldj.hlp create mode 100644 math/slalib/doc/clyd.hlp create mode 100644 math/slalib/doc/cr2af.hlp create mode 100644 math/slalib/doc/cr2tf.hlp create mode 100644 math/slalib/doc/cs2c.hlp create mode 100644 math/slalib/doc/cs2c6.hlp create mode 100644 math/slalib/doc/ctf2d.hlp create mode 100644 math/slalib/doc/ctf2r.hlp create mode 100644 math/slalib/doc/daf2r.hlp create mode 100644 math/slalib/doc/dafin.hlp create mode 100644 math/slalib/doc/dat.hlp create mode 100644 math/slalib/doc/dav2m.hlp create mode 100644 math/slalib/doc/dbear.hlp create mode 100644 math/slalib/doc/dbjin.hlp create mode 100644 math/slalib/doc/dc62s.hlp create mode 100644 math/slalib/doc/dcc2s.hlp create mode 100644 math/slalib/doc/dcmpf.hlp create mode 100644 math/slalib/doc/dcs2c.hlp create mode 100644 math/slalib/doc/dd2tf.hlp create mode 100644 math/slalib/doc/de2h.hlp create mode 100644 math/slalib/doc/deuler.hlp create mode 100644 math/slalib/doc/dfltin.hlp create mode 100644 math/slalib/doc/dh2e.hlp create mode 100644 math/slalib/doc/dimxv.hlp create mode 100644 math/slalib/doc/djcal.hlp create mode 100644 math/slalib/doc/djcl.hlp create mode 100644 math/slalib/doc/dm2av.hlp create mode 100644 math/slalib/doc/dmat.hlp create mode 100644 math/slalib/doc/dmoon.hlp create mode 100644 math/slalib/doc/dmxm.hlp create mode 100644 math/slalib/doc/dmxv.hlp create mode 100644 math/slalib/doc/dpav.hlp create mode 100644 math/slalib/doc/dr2af.hlp create mode 100644 math/slalib/doc/dr2tf.hlp create mode 100644 math/slalib/doc/drange.hlp create mode 100644 math/slalib/doc/dranrm.hlp create mode 100644 math/slalib/doc/ds2c6.hlp create mode 100644 math/slalib/doc/ds2tp.hlp create mode 100644 math/slalib/doc/dsep.hlp create mode 100644 math/slalib/doc/dt.hlp create mode 100644 math/slalib/doc/dtf2d.hlp create mode 100644 math/slalib/doc/dtf2r.hlp create mode 100644 math/slalib/doc/dtp2s.hlp create mode 100644 math/slalib/doc/dtp2v.hlp create mode 100644 math/slalib/doc/dtps2c.hlp create mode 100644 math/slalib/doc/dtpv2c.hlp create mode 100644 math/slalib/doc/dtt.hlp create mode 100644 math/slalib/doc/dv2tp.hlp create mode 100644 math/slalib/doc/dvdv.hlp create mode 100644 math/slalib/doc/dvn.hlp create mode 100644 math/slalib/doc/dvxv.hlp create mode 100644 math/slalib/doc/e2h.hlp create mode 100644 math/slalib/doc/earth.hlp create mode 100644 math/slalib/doc/ecleq.hlp create mode 100644 math/slalib/doc/ecmat.hlp create mode 100644 math/slalib/doc/ecor.hlp create mode 100644 math/slalib/doc/eg50.hlp create mode 100644 math/slalib/doc/el2ue.hlp create mode 100644 math/slalib/doc/epb.hlp create mode 100644 math/slalib/doc/epb2d.hlp create mode 100644 math/slalib/doc/epco.hlp create mode 100644 math/slalib/doc/epj.hlp create mode 100644 math/slalib/doc/epj2d.hlp create mode 100644 math/slalib/doc/eqecl.hlp create mode 100644 math/slalib/doc/eqeqx.hlp create mode 100644 math/slalib/doc/eqgal.hlp create mode 100644 math/slalib/doc/etrms.hlp create mode 100644 math/slalib/doc/euler.hlp create mode 100644 math/slalib/doc/evp.hlp create mode 100644 math/slalib/doc/fitxy.hlp create mode 100644 math/slalib/doc/fk425.hlp create mode 100644 math/slalib/doc/fk45z.hlp create mode 100644 math/slalib/doc/fk524.hlp create mode 100644 math/slalib/doc/fk52h.hlp create mode 100644 math/slalib/doc/fk54z.hlp create mode 100644 math/slalib/doc/fk5hz.hlp create mode 100644 math/slalib/doc/flotin.hlp create mode 100644 math/slalib/doc/galeq.hlp create mode 100644 math/slalib/doc/galsup.hlp create mode 100644 math/slalib/doc/ge50.hlp create mode 100644 math/slalib/doc/geoc.hlp create mode 100644 math/slalib/doc/gmst.hlp create mode 100644 math/slalib/doc/gmsta.hlp create mode 100644 math/slalib/doc/h2e.hlp create mode 100644 math/slalib/doc/h2fk5.hlp create mode 100644 math/slalib/doc/hfk5z.hlp create mode 100644 math/slalib/doc/imxv.hlp create mode 100644 math/slalib/doc/intin.hlp create mode 100644 math/slalib/doc/invf.hlp create mode 100644 math/slalib/doc/kbj.hlp create mode 100644 math/slalib/doc/m2av.hlp create mode 100644 math/slalib/doc/map.hlp create mode 100644 math/slalib/doc/mappa.hlp create mode 100644 math/slalib/doc/mapqk.hlp create mode 100644 math/slalib/doc/mapqkz.hlp create mode 100644 math/slalib/doc/moon.hlp create mode 100644 math/slalib/doc/mxm.hlp create mode 100644 math/slalib/doc/mxv.hlp create mode 100644 math/slalib/doc/nut.hlp create mode 100644 math/slalib/doc/nutc.hlp create mode 100644 math/slalib/doc/oap.hlp create mode 100644 math/slalib/doc/oapqk.hlp create mode 100644 math/slalib/doc/obs.hlp create mode 100644 math/slalib/doc/pa.hlp create mode 100644 math/slalib/doc/pav.hlp create mode 100644 math/slalib/doc/pcd.hlp create mode 100644 math/slalib/doc/pda2h.hlp create mode 100644 math/slalib/doc/pdq2h.hlp create mode 100644 math/slalib/doc/pertel.hlp create mode 100644 math/slalib/doc/pertue.hlp create mode 100644 math/slalib/doc/planel.hlp create mode 100644 math/slalib/doc/planet.hlp create mode 100644 math/slalib/doc/plante.hlp create mode 100644 math/slalib/doc/pm.hlp create mode 100644 math/slalib/doc/polmo.hlp create mode 100644 math/slalib/doc/prebn.hlp create mode 100644 math/slalib/doc/prec.hlp create mode 100644 math/slalib/doc/preces.hlp create mode 100644 math/slalib/doc/precl.hlp create mode 100644 math/slalib/doc/precss.hlp create mode 100644 math/slalib/doc/prenut.hlp create mode 100644 math/slalib/doc/pv2el.hlp create mode 100644 math/slalib/doc/pv2ue.hlp create mode 100644 math/slalib/doc/pvobs.hlp create mode 100644 math/slalib/doc/pxy.hlp create mode 100644 math/slalib/doc/range.hlp create mode 100644 math/slalib/doc/ranorm.hlp create mode 100644 math/slalib/doc/rcc.hlp create mode 100644 math/slalib/doc/rdplan.hlp create mode 100644 math/slalib/doc/read.me create mode 100644 math/slalib/doc/refco.hlp create mode 100644 math/slalib/doc/refcoq.hlp create mode 100644 math/slalib/doc/refro.hlp create mode 100644 math/slalib/doc/refv.hlp create mode 100644 math/slalib/doc/refz.hlp create mode 100644 math/slalib/doc/rverot.hlp create mode 100644 math/slalib/doc/rvgalc.hlp create mode 100644 math/slalib/doc/rvlg.hlp create mode 100644 math/slalib/doc/rvlsrd.hlp create mode 100644 math/slalib/doc/rvlsrk.hlp create mode 100644 math/slalib/doc/s2tp.hlp create mode 100755 math/slalib/doc/sedscript create mode 100644 math/slalib/doc/sep.hlp create mode 100644 math/slalib/doc/sla.news create mode 100644 math/slalib/doc/slalib.hd create mode 100644 math/slalib/doc/slalib.hlp create mode 100644 math/slalib/doc/slalib.hlp.sav create mode 100644 math/slalib/doc/slalib.men create mode 100644 math/slalib/doc/smat.hlp create mode 100644 math/slalib/doc/subet.hlp create mode 100644 math/slalib/doc/sun67.tex create mode 100644 math/slalib/doc/supgal.hlp create mode 100644 math/slalib/doc/svd.hlp create mode 100644 math/slalib/doc/svdcov.hlp create mode 100644 math/slalib/doc/svdsol.hlp create mode 100644 math/slalib/doc/tp2s.hlp create mode 100644 math/slalib/doc/tp2v.hlp create mode 100644 math/slalib/doc/tps2c.hlp create mode 100644 math/slalib/doc/tpv2c.hlp create mode 100644 math/slalib/doc/ue2el.hlp create mode 100644 math/slalib/doc/ue2pv.hlp create mode 100644 math/slalib/doc/unpcd.hlp create mode 100644 math/slalib/doc/v2tp.hlp create mode 100644 math/slalib/doc/vdv.hlp create mode 100644 math/slalib/doc/vn.hlp create mode 100644 math/slalib/doc/vxv.hlp create mode 100644 math/slalib/doc/xy2xy.hlp create mode 100644 math/slalib/doc/zd.hlp create mode 100644 math/slalib/dpav.f create mode 100644 math/slalib/dr2af.f create mode 100644 math/slalib/dr2tf.f create mode 100644 math/slalib/drange.f create mode 100644 math/slalib/dranrm.f create mode 100644 math/slalib/ds2c6.f create mode 100644 math/slalib/ds2tp.f create mode 100644 math/slalib/dsep.f create mode 100644 math/slalib/dsepv.f create mode 100644 math/slalib/dt.f create mode 100644 math/slalib/dtf2d.f create mode 100644 math/slalib/dtf2r.f create mode 100644 math/slalib/dtp2s.f create mode 100644 math/slalib/dtp2v.f create mode 100644 math/slalib/dtps2c.f create mode 100644 math/slalib/dtpv2c.f create mode 100644 math/slalib/dtt.f create mode 100644 math/slalib/dv2tp.f create mode 100644 math/slalib/dvdv.f create mode 100644 math/slalib/dvn.f create mode 100644 math/slalib/dvxv.f create mode 100644 math/slalib/e2h.f create mode 100644 math/slalib/earth.f create mode 100644 math/slalib/ecleq.f create mode 100644 math/slalib/ecmat.f create mode 100644 math/slalib/ecor.f create mode 100644 math/slalib/eg50.f create mode 100644 math/slalib/el2ue.f create mode 100644 math/slalib/epb.f create mode 100644 math/slalib/epb2d.f create mode 100644 math/slalib/epco.f create mode 100644 math/slalib/epj.f create mode 100644 math/slalib/epj2d.f create mode 100644 math/slalib/epv.f create mode 100644 math/slalib/eqecl.f create mode 100644 math/slalib/eqeqx.f create mode 100644 math/slalib/eqgal.f create mode 100644 math/slalib/etrms.f create mode 100644 math/slalib/euler.f create mode 100644 math/slalib/evp.f create mode 100644 math/slalib/f77.h.in create mode 100644 math/slalib/fitxy.f create mode 100644 math/slalib/fk425.f create mode 100644 math/slalib/fk45z.f create mode 100644 math/slalib/fk524.f create mode 100644 math/slalib/fk52h.f create mode 100644 math/slalib/fk54z.f create mode 100644 math/slalib/fk5hz.f create mode 100644 math/slalib/flotin.f create mode 100644 math/slalib/galeq.f create mode 100644 math/slalib/galsup.f create mode 100644 math/slalib/ge50.f create mode 100644 math/slalib/geoc.f create mode 100644 math/slalib/gmst.f create mode 100644 math/slalib/gmsta.f create mode 100644 math/slalib/gresid.F__vms create mode 100644 math/slalib/gresid.F__win create mode 100644 math/slalib/gresid.Fdefault create mode 100644 math/slalib/h2e.f create mode 100644 math/slalib/h2fk5.f create mode 100644 math/slalib/hfk5z.f create mode 100644 math/slalib/idchf.f create mode 100644 math/slalib/idchi.f create mode 100644 math/slalib/imxv.f create mode 100644 math/slalib/intin.f create mode 100644 math/slalib/invf.f create mode 100644 math/slalib/kbj.f create mode 100644 math/slalib/m2av.f create mode 100644 math/slalib/map.f create mode 100644 math/slalib/mappa.f create mode 100644 math/slalib/mapqk.f create mode 100644 math/slalib/mapqkz.f create mode 100644 math/slalib/mkpkg create mode 100644 math/slalib/moon.f create mode 100644 math/slalib/mxm.f create mode 100644 math/slalib/mxv.f create mode 100644 math/slalib/newnames create mode 100644 math/slalib/nut.f create mode 100644 math/slalib/nutc.f create mode 100644 math/slalib/nutc80.f create mode 100644 math/slalib/oap.f create mode 100644 math/slalib/oapqk.f create mode 100644 math/slalib/obs.f create mode 100644 math/slalib/pa.f create mode 100644 math/slalib/pav.f create mode 100644 math/slalib/pcd.f create mode 100644 math/slalib/pda2h.f create mode 100644 math/slalib/pdq2h.f create mode 100644 math/slalib/permut.f create mode 100644 math/slalib/pertel.f create mode 100644 math/slalib/pertue.f create mode 100644 math/slalib/planel.f create mode 100644 math/slalib/planet.f create mode 100644 math/slalib/plante.f create mode 100644 math/slalib/plantu.f create mode 100644 math/slalib/pm.f create mode 100644 math/slalib/polmo.f create mode 100644 math/slalib/prebn.f create mode 100644 math/slalib/prec.f create mode 100644 math/slalib/preces.f create mode 100644 math/slalib/precl.f create mode 100644 math/slalib/precss.f create mode 100644 math/slalib/precss.f.sav create mode 100644 math/slalib/prenut.f create mode 100644 math/slalib/pv2el.f create mode 100644 math/slalib/pv2ue.f create mode 100644 math/slalib/pvobs.f create mode 100644 math/slalib/pxy.f create mode 100644 math/slalib/random.F__vms create mode 100644 math/slalib/random.F__win create mode 100644 math/slalib/random.Fdefault create mode 100644 math/slalib/range.f create mode 100644 math/slalib/ranorm.f create mode 100644 math/slalib/rcc.f create mode 100644 math/slalib/rdplan.f create mode 100644 math/slalib/read.me create mode 100644 math/slalib/refco.f create mode 100644 math/slalib/refcoq.f create mode 100644 math/slalib/refro.f create mode 100644 math/slalib/refv.f create mode 100644 math/slalib/refz.f create mode 100644 math/slalib/rtl_random.c create mode 100644 math/slalib/rverot.f create mode 100644 math/slalib/rvgalc.f create mode 100644 math/slalib/rvlg.f create mode 100644 math/slalib/rvlsrd.f create mode 100644 math/slalib/rvlsrk.f create mode 100644 math/slalib/s2tp.f create mode 100755 math/slalib/sedscript create mode 100644 math/slalib/sep.f create mode 100644 math/slalib/sepv.f create mode 100644 math/slalib/sla.c create mode 100644 math/slalib/sla.news create mode 100644 math/slalib/slaTest.c create mode 100755 math/slalib/sla_link create mode 100755 math/slalib/sla_link_adam create mode 100644 math/slalib/sla_test.f create mode 100644 math/slalib/slalib.h create mode 100644 math/slalib/smat.f create mode 100644 math/slalib/subet.f create mode 100644 math/slalib/sun67.tex create mode 100644 math/slalib/supgal.f create mode 100644 math/slalib/svd.f create mode 100644 math/slalib/svdcov.f create mode 100644 math/slalib/svdsol.f create mode 100644 math/slalib/tp2s.f create mode 100644 math/slalib/tp2v.f create mode 100644 math/slalib/tps2c.f create mode 100644 math/slalib/tpv2c.f create mode 100644 math/slalib/ue2el.f create mode 100644 math/slalib/ue2pv.f create mode 100644 math/slalib/unpcd.f create mode 100644 math/slalib/v2tp.f create mode 100644 math/slalib/vdv.f create mode 100644 math/slalib/veri.f.in create mode 100644 math/slalib/vers.f.in create mode 100644 math/slalib/vn.f create mode 100644 math/slalib/vxv.f create mode 100644 math/slalib/wait.f__vms create mode 100644 math/slalib/wait.f__win create mode 100644 math/slalib/wait.fdefault create mode 100644 math/slalib/xy2xy.f create mode 100644 math/slalib/zd.f create mode 100644 math/surfit/doc/iscoeff.hlp create mode 100644 math/surfit/doc/iseval.hlp create mode 100644 math/surfit/doc/isfree.hlp create mode 100644 math/surfit/doc/isinit.hlp create mode 100644 math/surfit/doc/islaccum.hlp create mode 100644 math/surfit/doc/islfit.hlp create mode 100644 math/surfit/doc/islrefit.hlp create mode 100644 math/surfit/doc/islsolve.hlp create mode 100644 math/surfit/doc/islzero.hlp create mode 100644 math/surfit/doc/isreplace.hlp create mode 100644 math/surfit/doc/isresolve.hlp create mode 100644 math/surfit/doc/issave.hlp create mode 100644 math/surfit/doc/issolve.hlp create mode 100644 math/surfit/doc/isvector.hlp create mode 100644 math/surfit/doc/iszero.hlp create mode 100644 math/surfit/doc/surfit.hd create mode 100644 math/surfit/doc/surfit.hlp create mode 100644 math/surfit/doc/surfit.men create mode 100644 math/surfit/doc/surfit.spc create mode 100644 math/surfit/iscoeff.x create mode 100644 math/surfit/iseval.x create mode 100644 math/surfit/isfree.x create mode 100644 math/surfit/isinit.x create mode 100644 math/surfit/islaccum.x create mode 100644 math/surfit/islfit.x create mode 100644 math/surfit/islrefit.x create mode 100644 math/surfit/islsolve.x create mode 100644 math/surfit/islzero.x create mode 100644 math/surfit/isreplace.x create mode 100644 math/surfit/isresolve.x create mode 100644 math/surfit/issave.x create mode 100644 math/surfit/issolve.x create mode 100644 math/surfit/isvector.x create mode 100644 math/surfit/iszero.x create mode 100644 math/surfit/mkpkg create mode 100644 math/surfit/sf_b1eval.x create mode 100644 math/surfit/sf_beval.x create mode 100644 math/surfit/sf_f1deval.x create mode 100644 math/surfit/sf_feval.x create mode 100644 math/surfit/sfchomat.x create mode 100644 math/surfit/surfitdef.h (limited to 'math') diff --git a/math/README b/math/README new file mode 100644 index 00000000..57e8f2af --- /dev/null +++ b/math/README @@ -0,0 +1,20 @@ + +The IRAF math library provides a collection of general purpose numerical +routines for use in scientific applications programs. This library is +continually growing as we collect numerical packages from around the country. + +At present the library is just a collection of untested routines from various +sources. As time goes on, these routines will be edited to conform to a +standard which has not yet been developed. The standard is expected to provide +for different classes of routines, according to how well the routines have +been integrated into the system and tested. The standard for the math library +will affect programming style, naming conventions, documentation, and the +subset of Fortran which portable library routines are expected to comply with. + +A fundamental part of the standard is that math library routines should not do +i/o. Some of the otherwise numerical routines in these directories print +error messages when an error occurs, using Fortran i/o. This is bad because +Fortran i/o is not used elsewhere in the IRAF system, and because it is +preferable for a numerical routine to return an error code in the event of an +error. Before these codes are used in IRAF applications programs, this will +have to be fixed. diff --git a/math/Revisions b/math/Revisions new file mode 100644 index 00000000..44110034 --- /dev/null +++ b/math/Revisions @@ -0,0 +1,406 @@ +.help revisions Jun88 math +.nf + +gsurfit/gs_deval.gx +iminterp/mrider.x +iminterp/mrieval.x + Fixed some procedure calls being closed with a ']' insted of + a ')' (2/17/08, MJF) + +gsurfit/gs_chomat.gx + The test for singularity would fail with certain kinds of problems + because the test used EPSILON (should have been EPSILOND for the + double precision) but this is for distinguishing numbers small + numbers from 1 and not from each other. The test is now done + with a comparison against the smallest real or double difference. + The place where this was found to be a problem was with CCSETWCS. + (8/31/04, Valdes) + +======== +V2.12.2a +======== + +curfit/cvinit.gx + If one of the error checks caused an error return the cv pointer + would have been allocated (cv != NULL) but some of the pointer + fields could have garbage values since a malloc was used instead + of a calloc. A later call to cvfree could result in a segmentation + error. This was changed so that 1) a null cv pointer is returned + in the initial error checks cause an error return and 2) the + cv pointer is initially allocated with calloc so that no pointer + fields will be non-NULL until explicitly set. + (11/18/02, Valdes) + +======= +V2.12.1 +======= + +gsurfit/gsder.gx +gsurfit/gsderr.x +gsurfit/gsderd.x +gsurfit/gs_fder.gx +gsurfit/gs_fderr.x +gsurfit/gs_fderd.x +gsurfit/gs_deval.gx +gsurfit/gs_devalr.x +gsurfit/gs_devald.x + Rewrote the routines which compute the derivatives of the polynomial + surfaces. There were some renormalization problems in this code + for non-linear chebyshev and legendre polynomial surfaces. The new + code uses recursion relations for computation the derivatives which + could cause small errors if they are used to do flux conservation. + (27/10/99 LED) + +curfit/mkpkg +deboor/mkpkg +iminterp/mkpkg + Added some missing file dependencies to the above mkpkg files. + (20/9/99 LED) + +slalib + Upgraded slalib from Version 1.6.3 to Version 2.3.0. Seventeen + new routines were added including 4 dealing with FK5 to ICRS + coordinate conversions (17/6/99 LED). + +arbpix.x +arider.x +arieval.x +asider.x +asieval.x +asifit.x +asifree.x +asigeti.x +asigetr.x +asigrl.x +asiinit.x +asirestore.x +asisave.x +asisinit.x +asitype.x +asivector.x +ii_1dinteg.x +ii_bieval.x +ii_cubspl.f +ii_eval.x +ii_greval.x +ii_pc1deval.x +ii_pc2deval.x +ii_polterp.x +ii_sinctable.x +ii_spline.x +ii_spline2d.x +im1interpdef.h +im2interpdef.h +mkpkg +mrider.x +mrieval.x +msider.x +msieval.x +msifit.x +msifree.x +msigeti.x +msigetr.x +msigrid.x +msigrl.x +msiinit.x +msirestore.x +msisave.x +msisinit.x +msisqgrl.x +msitype.x +msivector.x + The 1D interpolation routines were replaced with new versions which + support look-up table since and drizzle interpolation. Minor + modifications were also made to the existing 1D sinc routines. The 2D + image interpolation routines were replaced with new versions modified + which support sinc, look-up table sinc and drizzle interpolation. + (12/28/98 Davis) + +iminterp.hd +iminterp.men +iminterp.spc +arbpix.hlp +arider.hlp +arieval.hlp +asider.hlp +asieval.hlp +asifit.hlp +asifree.hlp +asigeti.hlp +asigetr.hlp +asigrl.hlp +asiinit.hlp +asirestore.hlp +asisave.hlp +asisinit.hlp +asitype.hlp +asivector.hlp +iminterp.hlp +mrider.hlp +mrieval.hlp +msider.hlp +msieval.hlp +msifit.hlp +msifree.hlp +msigeti.hlp +msigetr.hlp +msigrid.hlp +msigrl.hlp +msiinit.hlp +msirestore.hlp +msisave.hlp +msisinit.hlp +msisqgrl.hlp +msitype.hlp +msivector.hlp + The 1D and 2D image interpolation routines help pages were updated + to reflect the changes in both packages. (12/28/98 Davis) + +math$nlfit/nlchomat.gx +math$nlfit/nlchomatr.x +math$nlfit/nlchomatd.x + Modified the singular matrix test to make a comparison against + EPSILON instead of 0.0 to avoid floating point problems. + + (8/1/98 Davis) + +math$gsurfit/ + Installed a completely new version of gsurfit which support "half" + or "diagonal" cross terms. All the .gx and .x files were replaced. + + (4/30/97 Davis) + +math$gsurfit/gsrestore.gx +math$gsurfit/gsrestorer.x +math$gsurfit/gsrestored.x + Changed the type declaration of the xmin, xmax, ymin, ymax variables + from real to PIXEL to avoid machine precision problems. + + (3/21/96 Davis) + +math$nlfit/nlfit.gx +math$nlfit/nlfitr.x +math$nlfit/nlfitd.x + Fixed a divide by zero error in the nlscatter routine which occurs + if the fit has no degrees of freedom and the weighting type is + WTS_SCATTER. + + (6/13/94 Davis) + +math/gsurfit/gssub.gx +math/gsurfit/gssubd.x + The gsurfit double precision routine gssubd was incorrectly calling + the real precision routine gsgeti instead of the double precision + routine dgsgeti due to an error in the gssub.gx file. This bug + results in the wrong value of the parameter GSNSAVE being returned to + the calling routine gssubd in the double precision case. + + (1/17/94 Davis) + +math/iminterp/arbpix.x +math/interp/arbpix.x + Changed all if (x == INDEF) constructs to IS_INDEF(x) constructs. + + (1/15/93 Davis) + +math/surfit/iseval.x + Two indices were not being initialized before being used in a pointer + offset computation in the spline1 and spline3 single input point code + producing incorrect results. + + (12/17/92 Davis) + +math/nlfit/nlfit.gx +math/nlfit/nlfitr.x +math/nlfit/nlfitd.x +math/nlfit/nliter.gx +math/nlfit/nliterr.x +math/nlfit/nliterd.x + Added a test for lambda<=0.0 in the nlfit loop and in the iteration + loop. Precision problems could cause the code to go into an infinite + loop in some circumstances. The code returns a NOT_DONE status + message if the convergence criteria have not been met in this + circumstance. Made some other minor changes to the convergence + criteria. + + (7/20/92 Davis) + +math/nlfit/nlacpts.gx +math/nlfit/nlerrors.gx + Fixed a bug in the routine nlacpts where the variable sum was + not being initialized properly for each iteration. This could + cause a slow drift in repeated fits. Also fixed a related problem + in the error computation. Note this was not a problem + with the version of nlfit in apphot in versions 2.9 or in + testphot. + + (1/9/92 Davis) + +math/nlfit/nlfit.gx +math/nlfit/nlfitr.x +math/nlfit/nlfitd.x + Added some code to force the nlfit package to do at least MINITER + iterations whether or not the solution actually converged; MINITER + + 1 if the weighting type is WTS_SCATTER. + (1/3/91 Davis) + +math/nlfit/nliter.gx +math/nlfit/nliterr.x +math/nlfit/nliterd.x + Simplied the test for determining whether the lambda factor needs + to be increased or decreased. + (1/3/91 Davis) + +math/nlfit/nlzero.gx +math/nlfit/nlfitdefr.h +math/nlfit/nlfitdefd.h + Removed an extra argument from two aclr$t routines. Also these routines + were being called with the pointer instead of the array as the + argument. (10/3/91 Davis) + +lib/math/iminterp.h +math/iminterp/arbpix.x +math/iminterp/arider.x +math/iminterp/arieval.x +math/iminterp/asider.x +math/iminterp/asieval.x +math/iminterp/asifit.x +math/iminterp/asiffree.x +math/iminterp/asigrl.x +math/iminterp/asiinit.x +math/iminterp/asirestore.x +math/iminterp/asisave.x +math/iminterp/asivector.x +math/iminterp/ii_1dinteg.x +math/iminterp/ii_eval.x +math/iminterp/ii_pc1deval.x +math/iminterp/im1interpdef.h +math/iminterp/doc/arbpix.hlp +math/iminterp/doc/arider.hlp +math/iminterp/doc/arieval.hlp +math/iminterp/doc/asider.hlp +math/iminterp/doc/asieval.hlp +math/iminterp/doc/asifit.hlp +math/iminterp/doc/asigrl.hlp +math/iminterp/doc/asiinit.hlp +math/iminterp/doc/asivector.hlp + The 1D image interpolation routines were replaced with new versions + modified by Frank Valdes to support sinc interpolation. (7/26/91 Davis) + +lib/math/curfit.h +lib/math/gsurfit.h +lib/math/iminterp.h +lib/math/interp.h +lib/math/surfit.h + Added dictionary string definitions for the interpolator types and + weights. Use of these strings insures that strdic/clgwrd will + return the correct type code. Currently one has to assume the code + definitions will not change or put a lookup table with a data + statement containing the macro definitions. The code would also + have to be modified to add new types. The dates were restored to + their original values to avoid recompilation. (5/9, Valdes) + +math$curfit/cverrors.gx: Davis, May 6, 1991 +math$curfit/cvpower.gx +math$curfit/cvrefit.gx +math$curfit/cvrestore.gx + Finished cleanup of curfit package .gx files. + +math$gsurfit/gs_f1deval.gx: Davis, May 6, 1991 + Changed the line "call amulk$t (,,,2.,,,)" to "call amulk$t (,,,2$f,,,) + to remove a type dependence problem found by ftoc on the Mac. + +math$curfit/cvpower.gx: Davis, May 6, 1991 + Changed the constant from INDEFR to INDEF in the amov$t call in cvpower.gx. + This was causing a problem for the Mac compiler. + +math$curfit/cv_b1eval.gx: Davis, April 23, 1991 +math$curfit/cv_beval.gx +math$curfit/cv_feval.gx +math$curfit/cvaccum.gx +math$curfit/cvacpts.gx +math$curfit/cvchomat.gx +math$curfit/cvfree.gx +math$curfit/cvinit.gx + Did some cleaning up in the following .gx files to make the code easier + to read. + +math$nlfit/: Davis, Jan 31, 1991 + Added the nlfit package to the math package. + +math$surfit/isreplace.x: Davis, September 18, 1990 + 1. Changed the int calls in isreplace.x to nint calls. This is a totally + safe way to do the conversion from floating point to integer + quantities in the surfit package and removes any potential precision + problems for task which must read the surfit structure back from a + text database file. + +math$gsurfit/gsrestore.gx,gsrestorer.x,gsrestored.x: Davis, September 18, 1990 + 1. Changed the int calls in gsrestore.gx to nint calls. This is a totally + safe way to do the conversion from floating point to integer + quantities in the gsurfit package and removes any potential precision + problems for task which must read the gsurfit structure back from a + text database file. + +math$curfit/cvrestore.gx,cvrestorer.x,cvrestored.x: Davis, September 18, 1990 + 1. Changed the int calls in cvrestore.gx to nint calls. This is a totally + safe way to do the conversion from floating point to integer + quantities in the curfit package and removes any potential precision + problems for task which must read the curfit structure back from a + text database file. + +math$gsurfit/gsder.gx,gsderd.x: Davis, August 1, 1990 + 1. Fixed a typo in the routine which computes the double precision + derivatives of a surface. Due to this type the salloc routine was being + passed a pointer instead of size. When the value of this pointer + got very large this could cause an out of memory allocation error. + +math$iminterp/msigrl.x: Davis, Feb 8, 1989 + 1. There was a bug in the shift and wrap routines in the 2D routine + which integrates in polygonal apertures. If the vertices of the + polygon were listed in certain orders the routine would produce + wrong results. The routine has been totally rewritten to use + the polygon clipping code in polyphot. + +math$interp/asigrl.x: Davis, Jan 27, 1988 + 1. The routine ii_getpcoeff was duplicated in the files asigrl.x and + ii_1dinteg.x. I removed the copy in asigrl.x and rebuilt the library. + +math$interp/arider.x: Davis, February 10, 1988 + 1. The routines iidr_poly3, iidr_poly5 and iidr_spine3 were declared + as functions but called everywhere as subroutines. I removed the + function declarations. + +math$gsurfit/gsder.gx: Davis, October 16, 1987 + 1. changed a real type conversion call to double in the gsder routine. + This error was causing the derivative evaluations to fail on the sun. + +math$gsurfit/gsder.gx: Davis, August 11, 1987 + 1. A call in gsder to gscoeff was not being set to double precision. + +math$gsurfit: Davis, January 22, 1986 + 1. A new version of the gsurfit package was installed. A double precision + gsurfit has been added. The double precision calls are the same as + the single precision calls but prefixed by a d. Some of the evaluation + routines were vectorized and run significantly faster than the old version. + A power series polynomial function was added to the package for convenience + in evaluating the simple rotation transformation functions. + +math$iminterp/arider.x: Davis, September 7, 1986 + 1. The routines ii_pcpoly3, ii_pcpoly5 and ii_pcspline3 were declared + as functions but called everywhere as subroutines. Removed the function + declaration. I also moved these routines into a file of their own + ii_pc1deval.x and changed the prefix to ia_ from ii_ to avoid conflict + with the 2D equivalents. + +math$interp/arider.x: Davis, September 7, 1986 + 1. The routines ii_pcpoly3, ii_pcpoly5 and ii_pcspline3 were declared + as functions but called everywhere as subroutines. Removed the function + declaration. + +From Davis Jan 8, 1986 + +1. Added documentation for surfit package. + +---------------------------------------------------------------------------- +.endhelp diff --git a/math/_math.hd b/math/_math.hd new file mode 100644 index 00000000..1d4c8877 --- /dev/null +++ b/math/_math.hd @@ -0,0 +1,5 @@ +# Root help directory for the MATH branch of the help database. + +math sys = math$README, + hlp = math$math.men, + pkg = math$math.hd diff --git a/math/bevington/README b/math/bevington/README new file mode 100644 index 00000000..d0b3f778 --- /dev/null +++ b/math/bevington/README @@ -0,0 +1,13 @@ +This directory cotnains the original Fortran source for the Bevington +routines, as copied from his book. + +Jun85 Removed the nonstandard & in col 1 UNIX style continuation and + replaced it with standard Fortran (col 6) continuation. + +Oct85 Added an extran continuation statement to chifit.f to avoid ambiguous + transfer of control to statement 70 + +Nov85 It was possible to get a floating point divide by zero in regres.f + when rmul=1 in the calculation in statement 135 of ftest. The value + of rmul (the correlation) is now tested before the division and a + value of ftest = -99999. is returned when rmul=1. diff --git a/math/bevington/agauss.f b/math/bevington/agauss.f new file mode 100644 index 00000000..6aefc503 --- /dev/null +++ b/math/bevington/agauss.f @@ -0,0 +1,40 @@ +c function agauss.f +c +c source +c Bevington, page 48. +c +c purpose +c evaluate integral of gaussian probability function +c +c usage +c result = agauss (x, averag, sigma) +c +c description of parameters +c x - limit for integral +c averag - mean of distribution +c sigma - standard deviation of distribution +c integration range is averag +/- z*sigma +c where z = abs(x-averag)/sigma +c +c subroutines and function subprograms required +c none +c + function agauss (x,averag,sigma) + double precision z,y2,term,sum,denom +11 z=abs(x-averag)/sigma + agauss=0. + if (z) 42,42,21 +21 term=0.7071067812*z +22 sum=term + y2=(z**2)/2. + denom=1. +c +c accumulate sums of terms +c +31 denom=denom+2. +32 term=term*(y2*2./denom) +33 sum=sum+term + if (term/sum-1.e-10) 41,41,31 +41 agauss=1.128379167*sum*dexp(-y2) +42 return + end diff --git a/math/bevington/area.f b/math/bevington/area.f new file mode 100644 index 00000000..ae89d35a --- /dev/null +++ b/math/bevington/area.f @@ -0,0 +1,79 @@ +c function area.f +c +c source +c Bevington, pages 272-273. +c +c purpose +c integrate the area beneath a set of data points +c +c usage +c result = area (x, y, npts, nterms) +c +c description of parameters +c x - array of data points for independent variable +c y - array of data points for dependent variable +c npts - number of pairs of data points +c nterms - number of terms in fitting polynomial +c +c subroutines and function subprograms required +c integ (x, y, nterms, i1, x1, x2 sum) +c fits a polynomial with nterms starting at i1 +c and integrates area from x1 to x2 +c + function area (x,y,npts,nterms) + double precision sum + dimension x(1),y(1) +11 sum=0. + if (npts-nterms) 21,21,13 +13 neven=2*(nterms/2) + idelta=nterms/2-1 + if (nterms-neven) 31,31,51 +c +c fit all points with one curve +c +21 x1=x(1) + x2=x(npts) +23 call integ (x,y,npts,1,x1,x2,sum) + goto 71 +c +c even number of terms +c +31 x1=x(1) + j=nterms-idelta + x2=x(j) + call integ (x,y,nterms,1,x1,x2,sum) + i1=npts-nterms+1 + j=i1+idelta + x1=x(j) + x2=x(npts) +39 call integ (x,y,nterms,i1,x1,x2,sum) + if (i1-2) 71,71,41 +41 imax=i1-1 + do 46 i=2,imax + j=i+idelta + x1=x(j) + x2=x(j+1) +46 call integ (x,y,nterms,i,x1,x2,sum) + goto 71 +c +c odd number of terms +c +51 x1=x(1) + j=nterms-idelta + x2=(x(j)+x(j-1))/2. + call integ (x,y,nterms,1,x1,x2,sum) + i1=npts-nterms+1 + j=i1+idelta + x1=(x(j)+x(j+1))/2. + x2=x(npts) +59 call integ (x,y,nterms,i1,x1,x2,sum) + if (i1-2) 71,71,61 +61 imax=i1-1 + do 66 i=2,imax + j=i+idelta + x1=(x(j+1)+x(j))/2. + x2=(x(j+2)+x(j+1))/2. +66 call integ (x,y,nterms,i,x1,x2,sum) +71 area=sum + return + end diff --git a/math/bevington/chifit.f b/math/bevington/chifit.f new file mode 100644 index 00000000..ff4b0669 --- /dev/null +++ b/math/bevington/chifit.f @@ -0,0 +1,169 @@ +C SUBROUTINE CHIFIT.F +C +C SOURCE +C BEVINGTON, PAGES 228-231. +C +C PURPOSE +C MAKE A LEAST-SQUARES FIT TO A NON-LINEAR FUNCTION +C WITH A PARABOLIC EXPANSION OF CHI SQUARE +C +C USAGE +C CALL CHIFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA, +C SIGMAA, YFIT, CHISQR) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF PARAMETERS +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C A - ARRAY OF PARAMETERS +C DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A +C SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A +C YFIT - ARRAY OF CALCULATED VALUES OF Y +C CHISQR - REDUCED CHI SQUARE FOR FIT +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C FUNCTN (X, I, A) +C EVALUATES THE FITTING FUNCTION FOR THE ITH TERM +C FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT) +C EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA +C MATINV (ARRAY, NTERMS, DET) +C INVERTS A SYMMETRIC TWO-DIMENSIONAL MATRIX OF DEGREE NTERMS +C AND CALCULATES ITS DETERMINANT +C +C COMMENTS +C DIMENSION STATEMENT VALID FOR NTERMS UP TO 10 +C + SUBROUTINE CHIFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA, + *SIGMAA,YFIT,CHISQR) + DOUBLE PRECISION ALPHA + DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1), + *YFIT(1) + DIMENSION ALPHA(10,10),BETA(10),DA(10) + REAL FUNCTN + EXTERNAL FUNCTN +C +11 NFREE=NPTS-NTERMS + FREE=NFREE + IF (NFREE) 14,14,16 +14 CHISQR=0. + GOTO 120 +16 DO 17 I=1,NPTS +17 YFIT(I)=FUNCTN (X,I,A) + CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +C +C EVALUATE ALPHA AND BETA MATRICES +C +20 DO 60 J=1,NTERMS +C +C A(J) + DELTAA(J) +C +21 AJ=A(J) + A(J)=AJ+DELTAA(J) + DO 24 I=1,NPTS +24 YFIT(I)=FUNCTN (X,I,A) + CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + ALPHA(J,J)=CHISQ2-2.*CHISQ1 + BETA(J)=-CHISQ2 +31 DO 50 K=1,NTERMS + IF (K-J) 33,50,36 +33 ALPHA(K,J)=(ALPHA(K,J)-CHISQ2)/2. + ALPHA(J,K)=ALPHA(K,J) + GOTO 50 +36 ALPHA(J,K)=CHISQ1-CHISQ2 +C +C A(J) + DELTAA(J) AND A(K) + DELTAA(K) +C +41 AK=A(K) + A(K)=AK+DELTAA(K) + DO 44 I=1,NPTS +44 YFIT(I)=FUNCTN (X,I,A) + CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + ALPHA(J,K)=ALPHA(J,K)+CHISQ3 + A(K)=AK +50 CONTINUE +C +C A(J) - DELTAA(J) +C +51 A(J)=AJ-DELTAA(J) + DO 53 I=1,NPTS +53 YFIT(I)=FUNCTN (X,I,A) + CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + A(J)=AJ + ALPHA(J,J)=(ALPHA(J,J)+CHISQ3)/2. + BETA(J)=(BETA(J)+CHISQ3)/4. +60 CONTINUE +C +C ELIMINATE NEGATIVE CURVATURE +C +61 DO 70 J=1,NTERMS + IF (ALPHA(J,J)) 63,65,70 +63 ALPHA(J,J)=-ALPHA(J,J) + GOTO 66 +65 ALPHA(J,J)=0.01 +C Changed from DO 70 +66 DO 700 K=1,NTERMS +C Changed from 68, 70, 68 + IF (K-J) 68,700,68 +68 ALPHA(J,K)=0. + ALPHA(K,J)=0. +C New continuation statement +700 CONTINUE +70 CONTINUE +C +C INVERT MATRIX AND EVALUATE PARAMETER INCREMENTS +C +71 CALL MATINV (ALPHA,NTERMS,DET) + DO 76 J=1,NTERMS + DA(J)=0. +74 DO 75 K=1,NTERMS +75 DA(J)=DA(J)+BETA(K)*ALPHA(J,K) +76 DA(J)=0.2*DA(J)*DELTAA(J) +C +C MAKE SURE CHI SQUARE DECREASES +C +81 DO 82 J=1,NTERMS +82 A(J)=A(J)+DA(J) +83 DO 84 I=1,NPTS +84 YFIT(I)=FUNCTN (X,I,A) + CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + IF (CHISQ1-CHISQ2) 87,91,91 +87 DO 89 J=1,NTERMS + DA(J)=DA(J)/2. +89 A(J)=A(J)-DA(J) + GOTO 83 +C +C INCREMENT PARAMETERS UNTIL CHI SQUARE STARTS TO INCREASE +C +91 DO 92 J=1,NTERMS +92 A(J)=A(J)+DA(J) + DO 94 I=1,NPTS +94 YFIT(I)=FUNCTN (X,I,A) + CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + IF (CHISQ3-CHISQ2) 97,101,101 +97 CHISQ1=CHISQ2 + CHISQ2=CHISQ3 +99 GOTO 91 +C +C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS +C +101 DELTA=1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5 + DO 104 J=1,NTERMS + A(J)=A(J)-DELTA*DA(J) +104 SIGMAA(J)=DELTAA(J)*SQRT(FREE*ALPHA(J,J)) + DO 106 I=1,NPTS +106 YFIT(I)=FUNCTN (X,I,A) + CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +111 IF (CHISQ2-CHISQR) 112,120,120 +112 DO 113 J=1,NTERMS +113 A(J)=A(J)+(DELTA-1.)*DA(J) + DO 115 I=1,NPTS +115 YFIT(I)=FUNCTN (X,I,A) + CHISQR=CHISQ2 +120 RETURN + END diff --git a/math/bevington/curfit.f b/math/bevington/curfit.f new file mode 100644 index 00000000..523a4c17 --- /dev/null +++ b/math/bevington/curfit.f @@ -0,0 +1,128 @@ +C SUBROUTINE CURFIT.F +C +C SOURCE +C BEVINGTON, PAGES 237-239. +C +C PURPOSE +C MAKE A LEAST-SQUARES FIT TO A NON-LINEAR FUNCTION +C WITH A LINEARIZATION OF THE FITTING FUNCTION +C +C USAGE +C CALL CURFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA, +C SIGMAA, FLAMDA, YFIT, CHISQR) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF PARAMETERS +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C A - ARRAY OF PARAMETERS +C DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A +C SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A +C FLAMDA - PROPORTION OF GRADIENT SEARCH INCLUDED +C YFIT - ARRAY OF CALCULATED VALUES OF Y +C CHISQR - REDUCED CHI SQUARE FOR FIT +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C FUNCTN (X, I, A) +C EVALUATES THE FITTING FUNCTION FOR THE ITH TERM +C FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT) +C EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA +C FDERIV (X, I, A, DELTAA, NTERMS, DERIV) +C EVALUATES THE DERIVATIVES OF THE FITTING FUNCTION +C FOR THE ITH TERM WITH RESPECT TO EACH PARAMETER +C MATINV (ARRAY, NTERMS, DET) +C INVERTS A SYMMETRIC TWO-DIMENSIONAL MATRIX OF DEGREE NTERMS +C AND CALCULATES ITS DETERMINANT +C +C COMMENTS +C DIMENSION STATEMENT VALID FOR NTERMS UP TO 10 +C SET FLAMDA = 0.001 AT BEGINNING OF SEARCH +C + SUBROUTINE CURFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA, + *SIGMAA,FLAMDA,YFIT,CHISQR) + DOUBLE PRECISION ARRAY + DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1), + *YFIT(1) + DIMENSION WEIGHT(100),ALPHA(10,10),BETA(10),DERIV(10), + *ARRAY(10,10),B(10) + REAL FUNCTN + EXTERNAL FUNCTN + +C +11 NFREE=NPTS-NTERMS + IF (NFREE) 13,13,20 +13 CHISQR=0. + GOTO 110 +C +C EVALUATE WEIGHTS +C +20 DO 30 I=1,NPTS +21 IF (MODE) 22,27,29 +22 IF (Y(I)) 25,27,23 +23 WEIGHT(I)=1./Y(I) + GOTO 30 +25 WEIGHT(I)=1./(-Y(I)) + GOTO 30 +27 WEIGHT(I)=1. + GOTO 30 +29 WEIGHT(I)=1./SIGMAY(I)**2 +30 CONTINUE +C +C EVALUATE ALPHA AND BETA MATRICES +C +31 DO 34 J=1,NTERMS + BETA(J)=0. + DO 34 K=1,J +34 ALPHA(J,K)=0. +41 DO 50 I=1,NPTS + CALL FDERIV (X,I,A,DELTAA,NTERMS,DERIV) + DO 46 J=1,NTERMS + BETA(J)=BETA(J)+WEIGHT(I)*(Y(I)-FUNCTN(X,I,A))*DERIV(J) + DO 46 K=1,J +46 ALPHA(J,K)=ALPHA(J,K)+WEIGHT(I)*DERIV(J)*DERIV(K) +50 CONTINUE +51 DO 53 J=1,NTERMS + DO 53 K=1,J +53 ALPHA(K,J)=ALPHA(J,K) +C +C EVALUATE CHI SQUARE AT STARTING POINT +C +61 DO 62 I=1,NPTS +62 YFIT(I)=FUNCTN (X,I,A) +63 CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +C +C INVERT MODIFIED CURVATURE MATRIX TO FIND NEW PARAMETERS +C +71 DO 74 J=1,NTERMS + DO 73 K=1,NTERMS +73 ARRAY(J,K)=ALPHA(J,K)/SQRT(ALPHA(J,J)*ALPHA(K,K)) +74 ARRAY(J,J)=1.+FLAMDA +80 CALL MATINV (ARRAY,NTERMS,DET) +81 DO 84 J=1,NTERMS + B(J)=A(J) + DO 84 K=1,NTERMS +84 B(J)=B(J)+BETA(K)*ARRAY(J,K)/SQRT(ALPHA(J,J)*ALPHA(K,K)) +C +C IF CHI SQUARE INCREASED, INCREASE FLAMDA AND TRY AGAIN +C +91 DO 92 I=1,NPTS +92 YFIT(I)=FUNCTN (X,I,B) +93 CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + IF (CHISQ1-CHISQR) 95,101,101 +95 FLAMDA=10.*FLAMDA + GOTO 71 +C +C EVALUATE PARAMETERS AND UNCERTAINTIES +C +101 DO 103 J=1,NTERMS + A(J)=B(J) +103 SIGMAA(J)=SQRT(ARRAY(J,J)/ALPHA(J,J)) + FLAMDA=FLAMDA/10. +110 RETURN + END diff --git a/math/bevington/determ.f b/math/bevington/determ.f new file mode 100644 index 00000000..4bdc2778 --- /dev/null +++ b/math/bevington/determ.f @@ -0,0 +1,54 @@ +C FUNCTION DETERM.F +C +C SOURCE +C BEVINGTON, PAGE 294. +C +C PURPOSE +C CALCULATE THE DETERMINANT OF A SQUARE MATRIX +C +C USAGE +C DET = DETERM (ARRAY, NORDER) +C +C DESCRIPTION OF PARAMETERS +C ARRAY - MATRIX +C NORDER - ORDER OF DETERMINANT (DEGREE OF MATRIX) +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C +C COMMENTS +C THIS SUBPROGRAM DESTROYS THE INPUT MATRIX ARRAY +C DIMENSION STATEMENT VALID FOR NORDER UP TO 10 +C + FUNCTION DETERM (ARRAY,NORDER) + DOUBLE PRECISION ARRAY,SAVE + DIMENSION ARRAY(10,10) +C +10 DETERM=1. +11 DO 50 K=1,NORDER +C +C INTERCHANGE COLUMNS IF DIAGONAL ELEMENT IS ZERO +C + IF (ARRAY(K,K)) 41,21,41 +21 DO 23 J=K,NORDER + IF (ARRAY(K,J)) 31,23,31 +23 CONTINUE + DETERM=0. + GOTO 60 +31 DO 34 I=K,NORDER + SAVE=ARRAY(I,J) + ARRAY(I,J)=ARRAY(I,K) +34 ARRAY(I,K)=SAVE + DETERM=-DETERM +C +C SUBTRACT ROW K FROM LOWER ROWS TO GET DIAGONAL MATRIX +C +41 DETERM=DETERM*ARRAY(K,K) + IF (K-NORDER) 43,50,50 +43 K1=K+1 + DO 46 I=K1,NORDER + DO 46 J=K1,NORDER +46 ARRAY(I,J)=ARRAY(I,J)-ARRAY(I,K)*ARRAY(K,J)/ARRAY(K,K) +50 CONTINUE +60 RETURN + END diff --git a/math/bevington/factor.f b/math/bevington/factor.f new file mode 100644 index 00000000..23b23307 --- /dev/null +++ b/math/bevington/factor.f @@ -0,0 +1,39 @@ +c function factor.f +c +c source +c Bevington, page 32. +c +c purpose +c calculates factorial function for integers +c +c usage +c result = factor (n) +c +c description of parameters +c n - integer argument +c +c subroutines and function subprograms required +c none +c + function factor (n) + double precision fi,sum +11 factor=1. + if (n-1) 40,40,13 +13 if (n-10) 21,21,31 +c +c n less than 11 +c +21 do 23 i=2,n + fi=i +23 factor=factor*fi + goto 40 +c +c n greater than 10 +c +31 sum=0. + do 34 i=11,n + fi=i +34 sum=sum+dlog(fi) +35 factor=3628800.*dexp(sum) +40 return + end diff --git a/math/bevington/fchisq.f b/math/bevington/fchisq.f new file mode 100644 index 00000000..1f9a8dc2 --- /dev/null +++ b/math/bevington/fchisq.f @@ -0,0 +1,54 @@ +C FUNCTION FCHISQ.F +C +C SOURCE +C BEVINGTON, PAGE 194. +C +C PURPOSE +C EVALUATE REDUCED CHI SQUARE FOR FIT OF DATA +C FCHISQ = SUM ((Y-YFIT)**2 / SIGMA**2) / NFREE +C +C USAGE +C RESULT = FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT) +C +C DESCRIPTION OF PARAMETERS +C Y - ARRAY OF DATA POINTS +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR DATA POINTS +C NPTS - NUMBER OF DATA POINTS +C NFREE - NUMBER OF DEGREES OF FREEDOM +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C YFIT - ARRAY OF CALCULATED VALUES OF Y +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C + FUNCTION FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + DOUBLE PRECISION CHISQ,WEIGHT + DIMENSION Y(1),SIGMAY(1),YFIT(1) +11 CHISQ=0. +12 IF (NFREE) 13,13,20 +13 FCHISQ=0. + GOTO 40 +C +C ACCUMULATE CHI SQUARE +C +20 DO 30 I=1,NPTS +21 IF (MODE) 22,27,29 +22 IF (Y(I)) 25,27,23 +23 WEIGHT=1./Y(I) + GOTO 30 +25 WEIGHT=1./(-Y(I)) + GOTO 30 +27 WEIGHT=1. + GOTO 30 +29 WEIGHT=1./SIGMAY(I)**2 +30 CHISQ=CHISQ+WEIGHT*(Y(I)-YFIT(I))**2 +C +C DIVIDE BY NUMBER OF DEGREES OF FREEDOM +C +31 FREE=NFREE +32 FCHISQ=CHISQ/FREE +40 RETURN + END diff --git a/math/bevington/fderiv.f b/math/bevington/fderiv.f new file mode 100644 index 00000000..720953cb --- /dev/null +++ b/math/bevington/fderiv.f @@ -0,0 +1,39 @@ +c subroutine fderiv.f (non-analytical) +c +c source +c Bevington, page 242. +c +c purpose +c evaluate derivatives of function for least-squares search +c for arbitrary function given by functn +c +c usage +c call fderiv (x, i, a, deltaa, nterms, deriv) +c +c description of parameters +c x - array of data points for independent variable +c i - index of data points +c a - array of parameters +c deltaa - array of parameter increments +c nterms - number of parameters +c deriv - derivatives of function +c +c subroutines and function subprograms required +c functn (x, i, a) +c evaluates the fitting function for the ith term +c + subroutine fderiv (x,i,a,deltaa,nterms,deriv) + dimension x(1),a(1),deltaa(1),deriv(1) + real FUNCTN + external FUNCTN + +11 do 18 j=1,nterms + aj=a(j) + delta=deltaa(j) + a(j)=aj+delta + yfit=functn(x,i,a) + a(j)=aj-delta + deriv(j)=(yfit-functn(x,i,a))/(2.*delta) +18 a(j)=aj + return + end diff --git a/math/bevington/gamma.f b/math/bevington/gamma.f new file mode 100644 index 00000000..9c393649 --- /dev/null +++ b/math/bevington/gamma.f @@ -0,0 +1,49 @@ +c function gamma.f +c +c source +c Bevington, page 126. +c +c purpose +c calculate the gamma function for integers and half-integers +c +c usage +c result = gamma (x) +c +c description of parameters +c x - integer or half-integer +c +c subroutines or function subprograms required +c factor (n) +c calculates n factorial for integers +c + function gamma (x) + double precision prod,sum,fi +c +c integerize argument +c +11 n=x-0.25 + xn=n +13 if (x-xn-0.75) 31,31,21 +c +c argument is integer +c +21 gamma=factor(n) + goto 60 +c +c argument is half-integer +c +31 prod=1.77245385 + if (n) 44,44,33 +33 if (n-10) 41,41,51 +41 do 43 i=1,n + fi=i +43 prod=prod*(fi-0.5) +44 gamma=prod + goto 60 +51 sum=0. + do 54 i=11,n + fi=i +54 sum=sum+dlog(fi-0.5) +55 gamma=prod*639383.8623*dexp(sum) +60 return + end diff --git a/math/bevington/gradls.f b/math/bevington/gradls.f new file mode 100644 index 00000000..f6b88d68 --- /dev/null +++ b/math/bevington/gradls.f @@ -0,0 +1,113 @@ +C SUBROUTINE GRADLS.F +C +C SOURCE +C BEVINGTON, PAGES 220-222. +C +C PURPOSE +C MAKE A GRADIENT-SEARCH LEAST-SQUARES FIT TO DATA WITH A +C SPECIFIED FUNCTION WHICH IS NOT LINEAR IN COEFFICIENTS +C +C USAGE +C CALL GRADLS (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA, +C YFIT, CHISQR) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF PARAMETERS +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C A - ARRAY OF PARAMETERS +C DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A +C YFIT - ARRAY OF CALCULATED VALUES OF Y +C CHISQR - REDUCED CHI SQUARE FOR FIT +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C FUNCTN (X, I, A) +C EVALUATES THE FITTING FUNCTION FOR THE ITH TERM +C FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT) +C EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA +C +C COMMENTS +C DIMENSION STATEMENT VALID FOR NTERMS UP TO 10 +C + SUBROUTINE GRADLS (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA, + *YFIT,CHISQR) + DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),YFIT(1) + DIMENSION GRAD(10) + REAL FUNCTN + EXTERNAL FUNCTN + +C +C EVALUATE CHI SQUARE AT BEGINNING +C +11 NFREE=NPTS-NTERMS + IF (NFREE) 13,13,21 +13 CHISQR=0. + GOTO 110 +21 DO 22 I=1,NPTS +22 YFIT(I)=FUNCTN (X,I,A) + CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +C +C EVALUATE GRADIENT OF CHI SQUARE +C +31 SUM=0. +32 DO 39 J=1,NTERMS + DELTA=0.1*DELTAA(J) + A(J)=A(J)+DELTA + DO 36 I=1,NPTS +36 YFIT(I)=FUNCTN (X,I,A) + A(J)=A(J)-DELTA + GRAD(J)=CHISQ1-FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +39 SUM=SUM+GRAD(J)**2 +41 DO 42 J=1,NTERMS +42 GRAD(J)=DELTAA(J)*GRAD(J)/SQRT(SUM) +C +C EVALUATE CHI SQUARE AT NEW POINT +C +51 DO 52 J=1,NTERMS +52 A(J)=A(J)+GRAD(J) +53 DO 54 I=1,NPTS +54 YFIT(I)=FUNCTN (X,I,A) + CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +C +C MAKE SURE CHI SQUARE DECREASES +C +61 IF (CHISQ1-CHISQ2) 62,62,71 +62 DO 64 J=1,NTERMS + A(J)=A(J)-GRAD(J) +64 GRAD(J)=GRAD(J)/2. + GOTO 51 +C +C INCREMENT PARAMETERS UNTIL CHI SQUARE STARTS TO INCREASE +C +71 DO 72 J=1,NTERMS +72 A(J)=A(J)+GRAD(J) + DO 74 I=1,NPTS +74 YFIT(I)=FUNCTN (X,I,A) +75 CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +76 IF (CHISQ3-CHISQ2) 81,91,91 +81 CHISQ1=CHISQ2 +82 CHISQ2=CHISQ3 + GOTO 71 +C +C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS +C +91 DELTA=1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5 + DO 93 J=1,NTERMS +93 A(J)=A(J)-DELTA*GRAD(J) + DO 95 I=1,NPTS +95 YFIT(I)=FUNCTN (X,I,A) + CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +101 IF (CHISQ2-CHISQR) 102,110,110 +102 DO 103 J=1,NTERMS +103 A(J)=A(J)+(DELTA-1.)*GRAD(J) +104 DO 105 I=1,NPTS +105 YFIT(I)=FUNCTN (X,I,A) +106 CHISQR=CHISQ2 +110 RETURN + END diff --git a/math/bevington/gridls.f b/math/bevington/gridls.f new file mode 100644 index 00000000..e62d3219 --- /dev/null +++ b/math/bevington/gridls.f @@ -0,0 +1,102 @@ +C SUBROUTINE GRIDLS.F +C +C SOURCE +C BEVINGTON, PAGES 212-213. +C +C PURPOSE +C MAKE A GRID-SEARCH LEAST-SQUARES FIT TO DATA WITH A SPECIFIED +C FUNCTION WHICH IS NOT LINEAR IN COEFFICIENTS +C +C USAGE +C CALL GRIDLS (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA, +C SIGMAA, YFIT, CHISQR) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF PARAMETERS +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C A - ARRAY OF PARAMETERS +C DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A +C SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A +C YFIT - ARRAY OF CALCULATED VALUES OF Y +C CHISQR - REDUCED CHI SQUARE FOR FIT +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C FUNCTN (X, I, A) +C EVALUATES THE FITTING FUNCTION FOR THE ITH TERM +C FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT) +C EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA +C +C COMMENTS +C DELTAA VALUES ARE MODIFIED BY THE PROGRAM +C + SUBROUTINE GRIDLS (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA, + *SIGMAA,YFIT,CHISQR) + DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1), + *YFIT(1) + REAL FUNCTN + EXTERNAL FUNCTN + +C +11 NFREE=NPTS-NTERMS + FREE=NFREE + CHISQR=0. + IF (NFREE) 100,100,20 +20 DO 90 J=1,NTERMS +C +C EVALUATE CHI SQUARE AT FIRST TWO SEARCH POINTS +C +21 DO 22 I=1,NPTS +22 YFIT(I)=FUNCTN (X,I,A) +23 CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) + FN=0. + DELTA=DELTAA(J) +41 A(J)=A(J)+DELTA + DO 43 I=1,NPTS +43 YFIT(I)=FUNCTN (X,I,A) +44 CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +45 IF (CHISQ1-CHISQ2) 51,41,61 +C +C REVERSE DIRECTION OF SEARCH IF CHI SQUARE IS INCREASING +C +51 DELTA=-DELTA + A(J)=A(J)+DELTA + DO 54 I=1,NPTS +54 YFIT(I)=FUNCTN (X,I,A) + SAVE=CHISQ1 + CHISQ1=CHISQ2 +57 CHISQ2=SAVE +C +C INCREMENT A(J) UNTIL CHI SQUARE INCREASES +C +61 FN=FN+1. + A(J)=A(J)+DELTA + DO 64 I=1,NPTS +64 YFIT(I)=FUNCTN (X,I,A) + CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +66 IF (CHISQ3-CHISQ2) 71,81,81 +71 CHISQ1=CHISQ2 + CHISQ2=CHISQ3 + GOTO 61 +C +C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS +C +81 DELTA=DELTA*(1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5) +82 A(J)=A(J)-DELTA +83 SIGMAA(J)=DELTAA(J)*SQRT(2./(FREE*(CHISQ3-2.*CHISQ2+CHISQ1))) +84 DELTAA(J)=DELTAA(J)*FN/3. +90 CONTINUE +C +C EVALUATE FIT AND CHI SQUARE FOR FINAL PARAMETERS +C +91 DO 92 I=1,NPTS +92 YFIT(I)=FUNCTN (X,I,A) +93 CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT) +100 RETURN + END diff --git a/math/bevington/integ.f b/math/bevington/integ.f new file mode 100644 index 00000000..153bafe1 --- /dev/null +++ b/math/bevington/integ.f @@ -0,0 +1,58 @@ +c subroutine integ.f +c +c source +c Bevington, page 274. +c +c purpose +c integrate the area beneath two data points +c +c usage +c call integ (x, y, nterms, i1, x1, x2, sum) +c +c description of parameters +c x - array of data points for independent variable +c y - array of data points for dependent variable +c nterms - number of terms in fitting polymonial +c i1 - first data point for fitting polynomial +c x1 - first value of x for integration +c x2 - final value of x for integration +c +c subroutines and function subprograms required +c none +c +c comments +c dimension statement valid for nterms up to 10 +c + subroutine integ (x,y,nterms,i1,x1,x2,sum) + double precision xjk,array,a,denom,deltax,sum + dimension x(1),y(1) + dimension array(10,10) +c +c construct square matrix and invert +c +11 do 17 j=1,nterms + i=j+i1-1 + deltax=x(i)-x(i1) + xjk=1. + do 17 k=1,nterms + array(j,k)=xjk +17 xjk=xjk*deltax +21 call matinv (array,nterms,det) + if (det) 31,23,31 +23 imid=i1+nterms/2 + sum=sum+y(imid)*(x2-x1) + goto 40 +c +c evaluate coefficients and integrate +c +31 dx1=x1-x(i1) + dx2=x2-x(i1) +33 do 39 j=1,nterms + i=j+i1-1 + a=0. + do 37 k=1,nterms +37 a=a+y(i)*array(j,k) + denom=j +39 sum=sum+(a/denom)*(dx2**j-dx1**j) +40 return + end diff --git a/math/bevington/interp.f b/math/bevington/interp.f new file mode 100644 index 00000000..75ca1b23 --- /dev/null +++ b/math/bevington/interp.f @@ -0,0 +1,85 @@ +C SUBROUTINE INTERP.F +C +C SOURCE +C BEVINGTON, PAGES 266-267. +C +C PURPOSE +C INTERPOLATE BETWEEN DATA POINTS TO EVALUATE A FUNCTION +C +C USAGE +C CALL INTERP (X, Y, NPTS, NTERMS, XIN, YOUT) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF TERMS IN FITTING POLYNOMIAL +C XIN - INPUT VALUE OF X +C YOUT - INTERPOLATED VALUE OF Y +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C +C COMMENTS +C DIMENSION STATEMENT VALID FOR NTERMS UP TO 10 +C VALUE OF NTERMS MAY BE MODIFIED BY THE PROGRAM +C + SUBROUTINE INTERP (X,Y,NPTS,NTERMS,XIN,YOUT) + DOUBLE PRECISION DELTAX,DELTA,A,PROD,SUM + DIMENSION X(1),Y(1) + DIMENSION DELTA(10),A(10) +C +C SEARCH FOR APPROPRIATE VALUE OF X(1) +C +11 DO 19 I=1,NPTS + IF (XIN-X(I)) 13,17,19 +13 I1=I-NTERMS/2 + IF (I1) 15,15,21 +15 I1=1 + GOTO 21 +17 YOUT=Y(I) +18 GOTO 61 +19 CONTINUE + I1=NPTS-NTERMS+1 +21 I2=I1+NTERMS-1 + IF (NPTS-I2) 23,31,31 +23 I2=NPTS + I1=I2-NTERMS+1 +25 IF (I1) 26,26,31 +26 I1=1 +27 NTERMS=I2-I1+1 +C +C EVALUATE DEVIATIONS DELTA +C +31 DENOM=X(I1+1)-X(I1) + DELTAX=(XIN-X(I1))/DENOM + DO 35 I=1,NTERMS + IX=I1+I-1 +35 DELTA(I)=(X(IX)-X(I1))/DENOM +C +C ACCUMULATE COEFFICIENTS A +C +40 A(1)=Y(I1) +41 DO 50 K=2,NTERMS + PROD=1. + SUM=0. + IMAX=K-1 + IXMAX=I1+IMAX + DO 49 I=1,IMAX + J=K-I + PROD=PROD*(DELTA(K)-DELTA(J)) +49 SUM=SUM-A(J)/PROD +50 A(K)=SUM+Y(IXMAX)/PROD +C +C ACCUMULATE SUM OF EXPANSION +C +51 SUM=A(1) + DO 57 J=2,NTERMS + PROD=1. + IMAX=J-1 + DO 56 I=1,IMAX +56 PROD=PROD*(DELTAX-DELTA(I)) +57 SUM=SUM+A(J)*PROD +60 YOUT=SUM +61 RETURN + END diff --git a/math/bevington/legfit.f b/math/bevington/legfit.f new file mode 100644 index 00000000..eb00b824 --- /dev/null +++ b/math/bevington/legfit.f @@ -0,0 +1,173 @@ +c subroutine legfit.f +c +c source +c Bevington, pages 155-157. +c +c purpose +c make a least-squares fit to data with a legendre polynomial +c y = a(1) + a(2)*x + a(3)*(3x**2-1)/2 + ... +c = a(1) * (1. + b(2)*x + b(3)*(3x**2-1)/2 + ... ) +c where x = cos(theta) +c +c usage +c call legfit (theta, y, sigmay, npts, norder, neven, mode, ftest, +c yfit, a, sigmaa, b, sigmab, chisqr) +c +c description of parameters +c theta - array of angles (in degrees) of the data points +c y - array of data points for dependent variable +c sigmay - array of standard deivations for y data points +c npts - number of pairs of data points +c norder - highest order of polynomial (number of terms - 1) +c neven - determines odd or even character of polynomial +c +1 fits only to even terms +c 0 fits to all terms +c -1 fits only to odd terms (plus constant term) +c mode - determines mode of weighting least-squares fit +c +1 (instrumental) weight(i) = 1./sigmay(i)**2 +c 0 (no weighting) weight(i) = 1. +c -1 (statistical) weight(i) = 1./y(i) +c ftest - array of values of f(l) for an f test +c yfit - array of calculated values of y +c a - array of coefficients of polynomial +c sigmaa - array of standard deviations for coefficients +c b - array of normalized relative coefficients +c sigmab - array of standard deviations for relative coefficients +c chisqr - reduced chi square for fit +c +c subroutines and function subprograms required +c matinv (array, nterms, det) +c inverts a symmetric two-dimensional matrix of degree nterms +c and calculates its determinant +c +c comments +c dimension statement valid for npts up to 100 and order up to 9 +c dcos changed to cos in statement 31 +c + subroutine legfit (theta,y,sigmay,npts,norder,neven,mode, + *ftest,yfit,a,sigmaa,b,sigmab,chisqr) + double precision cosine,p,beta,alpha,chisq + dimension theta(1),y(1),sigmay(1),ftest(1),yfit(1), + *a(1),sigmaa(1),b(1),sigmab(1) + dimension weight(100),p(100,10),beta(10),alpha(10,10) +c +c accumulate weights and legendre polynomials +c +11 nterms=1 + ncoeff=1 + jmax=norder+1 +20 do 40 i=1,npts +21 if (mode) 22,27,29 +22 if (y(i)) 25,27,23 +23 weight(i)=1./y(i) + goto 31 +25 weight(i)=1./(-y(i)) + goto 31 +27 weight(i)=1. + goto 31 +29 weight(i)=1./sigmay(i)**2 +31 cosine=cos(0.01745329252*theta(i)) + p(i,1)=1. + p(i,2)=cosine + do 36 l=2,norder + fl=l +36 p(i,l+1)=((2.*fl-1.)*cosine*p(i,l)-(fl-1.)*p(i,l-1))/fl +40 continue +c +c accumulate matrices alpha and beta +c +51 do 54 j=1,nterms + beta(j)=0. + do 54 k=1,nterms +54 alpha(j,k)=0. +61 do 66 i=1,npts + do 66 j=1,nterms + beta(j)=beta(j)+p(i,j)*y(i)*weight(i) + do 66 k=j,nterms + alpha(j,k)=alpha(j,k)+p(i,j)*p(i,k)*weight(i) +66 alpha(k,j)=alpha(j,k) +c +c delete fixed coefficients +c +70 if (neven) 71,91,81 +71 do 76 j=3,nterms,2 + beta(j)=0. + do 75 k=1,nterms + alpha(j,k)=0. +75 alpha(k,j)=0. +76 alpha(j,j)=1. + goto 91 +81 do 86 j=2,nterms,2 + beta(j)=0. + do 85 k=1,nterms + alpha(j,k)=0. +85 alpha(k,j)=0. +86 alpha(j,j)=1. +c +c invert curvature matrix alpha +c +91 do 95 j=1,jmax + a(j)=0. + sigmaa(j)=0. + b(j)=0. +95 sigmab(j)=0. + do 97 i=1,npts +97 yfit(i)=0. +101 call matinv (alpha,nterms,det) + if (det) 111,103,111 +103 chisqr=0. + goto 170 +c +c calculate coefficients, fit, and chi square +c +111 do 115 j=1,nterms + do 113 k=1,nterms +113 a(j)=a(j)+beta(k)*alpha(j,k) + do 115 i=1,npts +115 yfit(i)=yfit(i)+a(j)*p(i,j) +121 chisq=0. + do 123 i=1,npts +123 chisq=chisq+(y(i)-yfit(i))**2*weight(i) + free=npts-ncoeff + chisqr=chisq/free +c +c test for end of fit +c +131 if (nterms-jmax) 132,151,151 +132 if (ncoeff-2) 133,134,141 +133 if (neven) 137,137,135 +134 if (neven) 135,137,135 +135 nterms=nterms+2 + goto 138 +137 nterms=nterms+1 +138 ncoeff=ncoeff+1 + chisq1=chisq + goto 51 +141 fvalue=(chisq1-chisq)/chisqr + if (ftest(nterms)-fvalue) 134,143,143 +143 if (neven) 144,146,144 +144 nterms=nterms-2 + goto 147 +146 nterms=nterms-1 +147 ncoeff=ncoeff-1 + jmax=nterms +149 goto 51 +c +c calculate remainder of output +c +151 if (mode) 152,154,152 +152 varnce=1. + goto 155 +154 varnce=chisqr +155 do 156 j=1,nterms +156 sigmaa(j)=dsqrt(varnce*alpha(j,j)) +161 if (a(1)) 162,170,162 +162 do 166 j=2,nterms + if (a(j)) 164,166,164 +164 b(j)=a(j)/a(1) +165 sigmab(j)=b(j)*dsqrt((sigmaa(j)/a(j))**2+(sigmaa(1)/a(1))**2 + *-2.*varnce*alpha(j,1)/(a(j)*a(1))) +166 continue + b(1)=1. +170 return + end diff --git a/math/bevington/linfit.f b/math/bevington/linfit.f new file mode 100644 index 00000000..132c62b0 --- /dev/null +++ b/math/bevington/linfit.f @@ -0,0 +1,79 @@ +c subroutine linfit.f +c +c source +c Bevington, pages 104-105. +c +c purpose +c make a least-squares fit to a data set with a straight line +c +c usage +c call linfit (x, y, sigmay, npts, mode, a, sigmaa, b, sigmab, r) +c +c description of parameters +c x - array of data points for independent variable +c y - array of data points for dependent variable +c sigmay - array of standard deviations for y data points +c npts - number of pairs of data points +c mode - determines method of weighting least-squares fit +c +1 (instrumental) weight(i) = 1./sigmay(i)**2 +c 0 (no weighting) weight(i) = 1. +c -1 (statistical) weight(i) = 1./y(i) +c a - y intercept of fitted straight line +c sigmaa - standard deviation of a +c b - slope of fitted straight line +c sigmab - standard deviation of b +c r - linear correlation coefficient +c +c subroutines and function subprograms required +c none +c + subroutine linfit (x,y,sigmay,npts,mode,a,sigmaa,b,sigmab,r) + double precision sum,sumx,sumy,sumx2,sumxy,sumy2 + double precision xi,yi,weight,delta,varnce + dimension x(1),y(1),sigmay(1) +c +c accumulate weighted sums +c +11 sum=0. + sumx=0. + sumy=0. + sumx2=0. + sumxy=0. + sumy2=0. +21 do 50 i=1,npts + xi=x(i) + yi=y(i) + if (mode) 31,36,38 +31 if (yi) 34,36,32 +32 weight=1./yi + goto 41 +34 weight=1./(-yi) + goto 41 +36 weight=1. + goto 41 +38 weight=1./sigmay(i)**2 +41 sum=sum+weight + sumx=sumx+weight*xi + sumy=sumy+weight*yi + sumx2=sumx2+weight*xi*xi + sumxy=sumxy+weight*xi*yi + sumy2=sumy2+weight*yi*yi +50 continue +c +c calculate coefficients and standard deviations +c +51 delta=sum*sumx2-sumx*sumx + a=(sumx2*sumy-sumx*sumxy)/delta +53 b=(sumxy*sum-sumx*sumy)/delta +61 if (mode) 62,64,62 +62 varnce=1. + goto 67 +64 c=npts-2 + varnce=(sumy2+a*a*sum+b*b*sumx2 + *-2.*(a*sumy+b*sumxy-a*b*sumx))/c +67 sigmaa=dsqrt(varnce*sumx2/delta) +68 sigmab=dsqrt(varnce*sum/delta) +71 r=(sum*sumxy-sumx*sumy)/ + *dsqrt(delta*(sum*sumy2-sumy*sumy)) + return + end diff --git a/math/bevington/man/agauss.3m b/math/bevington/man/agauss.3m new file mode 100644 index 00000000..4f66e826 --- /dev/null +++ b/math/bevington/man/agauss.3m @@ -0,0 +1,24 @@ +.TH AGAUSS 3M +.SH NAME +agauss +.SH DESCRIPTION +function agauss.f + +source + Bevington, page 48. + +purpose + evaluate integral of Gaussian probability function + +usage + result = agauss (x, averag, sigma) + +description of parameters + x - limit for integral + averag - mean of distribution + sigma - standard deviation of distribution + integration range is averag +/- z*sigma + where z = abs(x-averag)/sigma + +subroutines and function subprograms required + none diff --git a/math/bevington/man/area.3m b/math/bevington/man/area.3m new file mode 100644 index 00000000..1505ef4d --- /dev/null +++ b/math/bevington/man/area.3m @@ -0,0 +1,25 @@ +.TH AREA 3M +.SH NAME +area +.SH DESCRIPTION +function area.f + +source + Bevington, pages 272-273. + +purpose + integrate the area beneath a set of data points + +usage + result = area (x, y, npts, nterms) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + npts - number of pairs of data points + nterms - number of terms in fitting polynomial + +subroutines and function subprograms required + integ (x, y, nterms, i1, x1, x2 sum) + fits a polynomial with nterms starting at i1 + and integrates area from x1 to x2 diff --git a/math/bevington/man/chifit.3m b/math/bevington/man/chifit.3m new file mode 100644 index 00000000..ec8f7f2c --- /dev/null +++ b/math/bevington/man/chifit.3m @@ -0,0 +1,44 @@ +.TH CHIFIT 3M +.SH NAME +chifit +.SH DESCRIPTION +subroutine chifit.f + +source + Bevington, pages 228-231. + +purpose + make least-squares fit to a non-linear function + with a parabolic expansion of chi square + +usage + call chifit (x, y, sigmay, npts, nterms, mode, a, deltaa, + sigmaa, yfit, chisqr) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of parameters + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - array of parameters + deltaa - array of increments for parameters a + sigmaa - array of standard deviations for parameters a + yfit - array of calculated values of y + chisqr - reduced chi square for fit + +subroutines and function subprograms required + functn (x, i, a) + evaluates the fitting function for the ith term + fchisq (y, sigmay, npts, nfree, mode, yfit) + evaluates reduced chi squared for fit to data + matinv (array, nterms, det) + inverts symmetric two-dimension matrix of degree nterms + and calculates its determinant + +comments + valid for nterms up to 10 diff --git a/math/bevington/man/curfit.3m b/math/bevington/man/curfit.3m new file mode 100644 index 00000000..799f0545 --- /dev/null +++ b/math/bevington/man/curfit.3m @@ -0,0 +1,49 @@ +.TH CURFIT 3M +.SH NAME +curfit +.SH DESCRIPTION +subroutine curfit.f + +source + Bevington, pages 237-239. + +purpose + make least-squares fit to a non-linear function + with a linearization of the fitting function + +usage + call curfit (x, y, sigmay, npts, nterms, mode, a, deltaa, + sigmaa, flamda, yfit, chisqr) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of parameters + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - array of parameters + deltaa - array of increments for parameters a + sigmaa - array of standard deviations for parameters a + flamda - proportion of gradient search included + yfit - array of calculated values of y + chisqr - reduced chi square for fit + +subroutines and function subprograms required + functn (x, i, a) + evaluates the fitting function for the ith term + fchisq (y, sigmay, npts, nfree, mode, yfit) + evaluates reduced chi squared for fit to data + fderiv (x, i, a, deltaa, nterms, deriv) + evaluates the derivatives of the fitting function + for the ith term with respect to each parameter + matinv (array, nterms, det) + inverts symmetric two-dimension matrix of degree nterms + and calculates its determinant + +comments + valid for nterms up to 10 + set flamda = 0.001 at beginning of search diff --git a/math/bevington/man/determ.3m b/math/bevington/man/determ.3m new file mode 100644 index 00000000..5ec86d06 --- /dev/null +++ b/math/bevington/man/determ.3m @@ -0,0 +1,25 @@ +.TH DETERM 3M +.SH NAME +determ +.SH DESCRIPTION +function determ.f + +source + Bevington, page 294. + +purpose + calculate the determinant of a square matrix + +usage + result = determ (array, norder) + +description of parameters + array - matrix + norder - order of determinant (degree of matrix) + +subroutines and function subprograms required + none + +comments + this subprogram destroys the input matrix array + valid for norder up to 10 diff --git a/math/bevington/man/factor.3m b/math/bevington/man/factor.3m new file mode 100644 index 00000000..1127c5d0 --- /dev/null +++ b/math/bevington/man/factor.3m @@ -0,0 +1,20 @@ +.TH FACTOR 3M +.SH NAME +factor +.SH DESCRIPTION +function factor.f + +source + Bevington, page 32. + +purpose + calculates factorial function for integers + +usage + result = factor (n) + +description of parameters + n - integer argument + +subroutines and function subprograms required + none diff --git a/math/bevington/man/fchisq.3m b/math/bevington/man/fchisq.3m new file mode 100644 index 00000000..0511409b --- /dev/null +++ b/math/bevington/man/fchisq.3m @@ -0,0 +1,29 @@ +.TH FCHISQ 3M +.SH NAME +fchisq +.SH DESCRIPTION +function fchisq.f + +source + Bevington, page 194. + +purpose + evaluate reduced chi square for fit of data + fchisq = sum ((y-yfit)**2 / sigma**2) / nfree + +usage + result = fchisq (y, sigmay, npts, nfree, mode, yfit) + +description of parameters + y - array of data points + sigmay - array of standard deviations for data points + npts - number of data points + nfree - number of degrees of freedom + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + yfit - array of calculated values of y + +subroutines and function subprograms required + none diff --git a/math/bevington/man/fderiv.3m b/math/bevington/man/fderiv.3m new file mode 100644 index 00000000..d9c88aeb --- /dev/null +++ b/math/bevington/man/fderiv.3m @@ -0,0 +1,27 @@ +.TH FDERIV 3M +.SH NAME +fderiv +.SH DESCRIPTION +subroutine fderiv.f (non-analytical) + +source + Bevington, page 242. + +purpose + evaluate derivatives of function for least-squares search + for arbitrary function given by functn + +usage + call fderiv (x, i, a, deltaa, nterms, deriv) + +description of parameters + x - array of data points for independent variable + i - index of data points + a - array of parameters + deltaa - array of parameter increments + nterms - number of parameters + deriv - derivatives of function + +subroutines and function subprograms required + functn (x, i, a) + evaluates the fitting function for the ith term diff --git a/math/bevington/man/gamma.3m b/math/bevington/man/gamma.3m new file mode 100644 index 00000000..31939ef3 --- /dev/null +++ b/math/bevington/man/gamma.3m @@ -0,0 +1,21 @@ +.TH GAMMA 3M +.SH NAME +gamma +.SH DESCRIPTION +function gamma.f + +source + Bevington, page 126. + +purpose + calculate gamma function for integers and 1/2-integers + +usage + result = gamma (x) + +description of parameters + x - integer or half-integer + +subroutines or function subprograms required + factor (n) + calculates n factorial for integers diff --git a/math/bevington/man/gradls.3m b/math/bevington/man/gradls.3m new file mode 100644 index 00000000..681c93f4 --- /dev/null +++ b/math/bevington/man/gradls.3m @@ -0,0 +1,40 @@ +.TH GRADLS 3M +.SH NAME +gradls +.SH DESCRIPTION +subroutine gradls.f + +source + Bevington, pages 220-222. + +purpose + make gradient-search least-squares fit to data with a + specified function which is not linear in coefficients + +usage + call gradls (x, y, sigmay, npts, nterms, mode, a, deltaa, + yfit, chisqr) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of parameters + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - array of parameters + deltaa - array of increments for parameters a + yfit - array of calculated values of y + chisqr - reduced chi square for fit + +subroutines and function subprograms required + functn (x, i, a) + evaluates the fitting function for the ith term + fchisq (y, sigmay, npts, nfree, mode, yfit) + evaluates reduced chi squared for fit to data + +comments + valid for nterms up to 10 diff --git a/math/bevington/man/gridls.3m b/math/bevington/man/gridls.3m new file mode 100644 index 00000000..331a566c --- /dev/null +++ b/math/bevington/man/gridls.3m @@ -0,0 +1,41 @@ +.TH GRIDLS 3M +.SH NAME +gridls +.SH DESCRIPTION +subroutine gridls.f + +source + Bevington, pages 212-213. + +purpose + make grid-search least-squares fit to data with specified + function which is not linear in coefficients + +usage + call gridls (x, y, sigmay, npts, nterms, mode, a, deltaa, + sigmaa, yfit, chisqr) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of parameters + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - array of parameters + deltaa - array of increments for parameters a + sigmaa - array of standard deviations for parameters a + yfit - array of calculated values of y + chisqr - reduced chi square for fit + +subroutines and function subprograms required + functn (x, i, a) + evaluates the fitting function for the ith term + fchisq (y, sigmay, npts, nfree, mode, yfit) + evaluates reduced chi squared for fit to data + +comments + deltaa values are modified by the program diff --git a/math/bevington/man/integ.3m b/math/bevington/man/integ.3m new file mode 100644 index 00000000..e6200645 --- /dev/null +++ b/math/bevington/man/integ.3m @@ -0,0 +1,28 @@ +.TH INTEG 3M +.SH NAME +integ +.SH DESCRIPTION +subroutine integ.f + +source + Bevington, page 274. + +purpose + integrate the area beneath two data points + +usage + call integ (x, y, nterms, i1, x1, x2, sum) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + nterms - number of terms in fitting polymonial + i1 - first data point for fitting polynomial + x1 - first value of x for integration + x2 - final value of x for integration + +subroutines and function subprograms required + none + +comments + valid for nterms up to 10 diff --git a/math/bevington/man/interp.3m b/math/bevington/man/interp.3m new file mode 100644 index 00000000..0a25b2b0 --- /dev/null +++ b/math/bevington/man/interp.3m @@ -0,0 +1,29 @@ +.TH INTERP 3M +.SH NAME +interp +.SH DESCRIPTION +subroutine interp.f + +source + Bevington, pages 266-267. + +purpose + interpolate between data points to evaluate a function + +usage + call interp (x, y, npts, nterms, xin, yout) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + npts - number of pairs of data points + nterms - number of terms in fitting polynomial + xin - input value of x + yout - interpolated value of y + +subroutines and function subprograms required + none + +comments + valid for nterms up to 10 + value of nterms may be modified by the program diff --git a/math/bevington/man/legfit.3m b/math/bevington/man/legfit.3m new file mode 100644 index 00000000..efe61c07 --- /dev/null +++ b/math/bevington/man/legfit.3m @@ -0,0 +1,49 @@ +.TH LEGFIT 3M +.SH NAME +legfit +.SH DESCRIPTION +subroutine legfit.f + +source + Bevington, pages 155-157. + +purpose + make least-squares fit to data with a Legendre polynomial + y = a(1) + a(2)*x + a(3)*(3x**2-1)/2 + ... + = a(1) * (1. + b(2)*x + b(3)*(3x**2-1)/2 + ... ) + where x = cos(theta) + +usage + call legfit (theta, y, sigmay, npts, norder, neven, mode, + ftest, yfit, a, sigmaa, b, sigmab, chisqr) + +description of parameters + theta - array of angles (in degrees) of the data points + y - array of data points for dependent variable + sigmay - array of standard deivations for y data points + npts - number of pairs of data points + norder - highest order of polynomial (number of terms - 1) + neven - determines odd or even character of polynomial + +1 fits only to even terms + 0 fits to all terms + -1 fits only to odd terms (plus constant term) + mode - determines mode of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + ftest - array of values of f(l) for an f test + yfit - array of calculated values of y + a - array of coefficients of polynomial + sigmaa - array of standard deviations for coefficients + b - array of normalized relative coefficients + sigmab - array of std. deviations of relative coefficients + chisqr - reduced chi square for fit + +subroutines and function subprograms required + matinv (array, nterms, det) + inverts symmetric two-dimension matrix of degree nterms + and calculates its determinant + +comments + valid for npts up to 100 and order up to 9 + one source line modified - cos substituted for dcos diff --git a/math/bevington/man/linfit.3m b/math/bevington/man/linfit.3m new file mode 100644 index 00000000..e6e63f75 --- /dev/null +++ b/math/bevington/man/linfit.3m @@ -0,0 +1,33 @@ +.TH LINFIT 3M +.SH NAME +linfit +.SH DESCRIPTION +subroutine linfit.f + +source + Bevington, pages 104-105. + +purpose + make least-squares fit to a data set with a straight line + +usage + call linfit (x, y, sigmay, npts, mode, a, sigmaa, + b, sigmab, r) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - y intercept of fitted straight line + sigmaa - standard deviation of a + b - slope of fitted straight line + sigmab - standard deviation of b + r - linear correlation coefficient + +subroutines and function subprograms required + none diff --git a/math/bevington/man/matinv.3m b/math/bevington/man/matinv.3m new file mode 100644 index 00000000..6b2d1c44 --- /dev/null +++ b/math/bevington/man/matinv.3m @@ -0,0 +1,25 @@ +.TH MATINV 3M +.SH NAME +matinv +.SH DESCRIPTION +subroutine matinv.f + +source + Bevington, pages 302-303. + +purpose + invert a symmetric matrix and calculate its determinant + +usage + call matinv (array, norder, det) + +description of parameters + array - input matrix which is replaced by its inverse + norder - degree of matrix (order of determinant) + det - determinant of input matrix + +subroutines and function subprograms required + none + +comments + valid for norder up to 10 diff --git a/math/bevington/man/pbinom.3m b/math/bevington/man/pbinom.3m new file mode 100644 index 00000000..344a62b3 --- /dev/null +++ b/math/bevington/man/pbinom.3m @@ -0,0 +1,23 @@ +.TH PBINOM 3M +.SH NAME +pbinom +.SH DESCRIPTION +function pbinom.f + +source + Bevington, page 31. + +purpose + evaluate binomial probability coefficient + +usage + result = pbinom (nobs, ntotal, prob) + +description of parameters + nobs - number of items observed + ntotal - total number of items + prob - probability of observing each item + +subroutines and function subprograms required + factor (n) + calculates n factorial for integers diff --git a/math/bevington/man/pchisq.3m b/math/bevington/man/pchisq.3m new file mode 100644 index 00000000..1f4c6742 --- /dev/null +++ b/math/bevington/man/pchisq.3m @@ -0,0 +1,26 @@ +.TH PCHISQ 3M +.SH NAME +pchisq +.SH DESCRIPTION +function pchisq.f + +source + Bevington, pages 192-193. + +purpose + evaluate probability for exceeding chi square + +usage + result = pchisq (chisqr, nfree) + +description of parameters + chisqr - comparison value of reduced chi square + nfree - number of degrees of freedom + +subroutines and function subprograms required + gamma (x) + calculates gamma function for integers and 1/2-integers + +comments + calculation is approximate for nfree odd and + chi square greater than 50 diff --git a/math/bevington/man/pcorre.3m b/math/bevington/man/pcorre.3m new file mode 100644 index 00000000..832c6640 --- /dev/null +++ b/math/bevington/man/pcorre.3m @@ -0,0 +1,22 @@ +.TH PCORRE 3M +.SH NAME +pcorre +.SH DESCRIPTION +function pcorre.f + +source + Bevington, pages 124-125. + +purpose + evaluate probability of no correlation between 2 variables + +usage + result = pcorre (r, npts) + +description of parameters + r - linear correlation coefficient + npts - number of data points + +subroutines and function subprograms required + gamma (x) + calculates gamma function for integers and 1/2-integers diff --git a/math/bevington/man/pgauss.3m b/math/bevington/man/pgauss.3m new file mode 100644 index 00000000..4f0c7c7d --- /dev/null +++ b/math/bevington/man/pgauss.3m @@ -0,0 +1,22 @@ +.TH PGAUSS 3M +.SH NAME +pgauss +.SH DESCRIPTION +function pgauss.f + +source + Bevington, page 45. + +purpose + evaluate Gaussian probability function + +usage + result = pgauss (x, averag, sigma) + +description of parameters + x - value for which probability is to be evaluated + averag - mean of distribution + sigma - standard deviation of distribution + +subroutines and function subprograms required + none diff --git a/math/bevington/man/ploren.3m b/math/bevington/man/ploren.3m new file mode 100644 index 00000000..dfd485f5 --- /dev/null +++ b/math/bevington/man/ploren.3m @@ -0,0 +1,22 @@ +.TH PLOREN 3M +.SH NAME +ploren +.SH DESCRIPTION +function ploren.f + +source + Bevington, page 51. + +purpose + evaluate Lorentzian probability function + +usage + result = ploren (x, averag, width) + +description of parameters + x - value for which probability is to be evaluated + averag - mean of distribution + width - full width at half maximum of distribution + +subroutines and function subprograms required + none diff --git a/math/bevington/man/polfit.3m b/math/bevington/man/polfit.3m new file mode 100644 index 00000000..9553e619 --- /dev/null +++ b/math/bevington/man/polfit.3m @@ -0,0 +1,36 @@ +.TH POLFIT 3M +.SH NAME +polfit +.SH DESCRIPTION +subroutine polfit.f + +source + Bevington, pages 140-142. + +purpose + make least-squares fit to data with a polynomial curve + y = a(1) + a(2)*x + a(3)*x**2 + a(3)*x**3 + . . . + +usage + call polfit (x, y, sigmay, npts, nterms, mode, a, chisqr) + +description of parameters + x - array of data points for independent variable + y - array of data points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of coefficients (degree of polynomial + 1) + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + a - array of coefficients of polynomial + chisqr - reduced chi square for fit + +subroutines and function subprograms required + determ (array, norder) + evaluates the determinant of a symetrical + two-dimension matrix of order norder + +comments + valid for nterms up to 10 diff --git a/math/bevington/man/ppoiss.3m b/math/bevington/man/ppoiss.3m new file mode 100644 index 00000000..0197768f --- /dev/null +++ b/math/bevington/man/ppoiss.3m @@ -0,0 +1,22 @@ +.TH PPOISS 3M +.SH NAME +ppoiss +.SH DESCRIPTION +function ppoiss.f + +source + Bevington, page 39. + +purpose + evaluate Poisson probability function + +usage + result = ppoiss (nobs, averag) + +description of parameters + nobs - number of items observed + averag - mean of distribution + +subroutines and function subprograms required + factor (n) + calculates n factorial for integers diff --git a/math/bevington/man/regres.3m b/math/bevington/man/regres.3m new file mode 100644 index 00000000..e8cf076d --- /dev/null +++ b/math/bevington/man/regres.3m @@ -0,0 +1,49 @@ +.TH REGRES 3M +.SH NAME +regres +.SH DESCRIPTION +subroutine regres.f + +source + Bevington, pages 172-175. + +purpose + make mulitple linear regression fit to data with specified + function which is linear in coefficients + +usage + call regres (x, y, sigmay, npts, nterms, m, mode, yfit, + a0, a, sigma0, sigmaa, r, rmul, chisqr, ftest) + +description of parameters + x - array of points for independent variable + y - array of points for dependent variable + sigmay - array of standard deviations for y data points + npts - number of pairs of data points + nterms - number of coefficients + m - array of inclusion/rejection criteria for fctn + mode - determines method of weighting least-squares fit + +1 (instrumental) weight(i) = 1./sigmay(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1./y(i) + yfit - array of calculated values of y + a0 - constant term + a - array of coefficients + sigma0 - standard deviation of a0 + sigmaa - array of standard deviations for coefficients + r - array of linear correlation coefficients + rmul - multiple linear correlation coefficient + chisqr - reduced chi square for fit + ftest - value of f for test of fit + +subroutines and function subprograms required + fctn (x, i, j, m) + evaluates function for the jth term and the ith data + point using array m to specify terms in function + matinv (array, nterms, det) + inverts symmetric two-dimension matrix of degree nterms + and calculates its determinant + +comments + valid for npts up to 100 and nterms up to 10 + one source line modified - sigmaa substituted for sigmaag diff --git a/math/bevington/man/smooth.3m b/math/bevington/man/smooth.3m new file mode 100644 index 00000000..6db69d22 --- /dev/null +++ b/math/bevington/man/smooth.3m @@ -0,0 +1,21 @@ +.TH SMOOTH 3M +.SH NAME +smooth +.SH DESCRIPTION +subroutine smooth.f + +source + Bevington, page 260. + +purpose + smooth a set of data points by averaging adjacent channels + +usage + call smooth (y, npts) + +description of parameters + y - array of data points + npts - number of data points + +subroutines and function subprograms required + none diff --git a/math/bevington/man/xfit.3m b/math/bevington/man/xfit.3m new file mode 100644 index 00000000..53ed8ae8 --- /dev/null +++ b/math/bevington/man/xfit.3m @@ -0,0 +1,29 @@ +.TH XFIT 3M +.SH NAME +xfit +.SH DESCRIPTION +subroutine xfit.f + +source + Bevington, page 76. + +purpose + calculate mean and estimated errors for set of data points + +usage + call xfit (x, sigmax, npts, mode, xmean, sigmam, sigma) + +description of parameters + x - array of data points + sigmax - array of standard deviations for data points + npts - number of data points + mode - determines method of weighting + +1 (instrumental) weight(i) = 1./sigmax(i)**2 + 0 (no weighting) weight(i) = 1. + -1 (statistical) weight(i) = 1. + xmean - weighted mean + sigmam - standard deviation of mean + sigma - standard deviation of data + +subroutines and function subprograms required + none diff --git a/math/bevington/matinv.f b/math/bevington/matinv.f new file mode 100644 index 00000000..5b1815c2 --- /dev/null +++ b/math/bevington/matinv.f @@ -0,0 +1,96 @@ +C SUBROUTINE MATINV.F +C +C SOURCE +C BEVINGTON, PAGES 302-303. +C +C PURPOSE +C INVERT A SYMMETRIC MATRIX AND CALCULATE ITS DETERMINANT +C +C USAGE +C CALL MATINV (ARRAY, NORDER, DET) +C +C DESCRIPTION OF PARAMETERS +C ARRAY - INPUT MATRIX WHICH IS REPLACED BY ITS INVERSE +C NORDER - DEGREE OF MATRIX (ORDER OF DETERMINANT) +C DET - DETERMINANT OF INPUT MATRIX +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C +C COMMENT +C DIMENSION STATEMENT VALID FOR NORDER UP TO 10 +C + SUBROUTINE MATINV (ARRAY,NORDER,DET) + DOUBLE PRECISION ARRAY,AMAX,SAVE + DIMENSION ARRAY(10,10),IK(10),JK(10) +C +10 DET=1. +11 DO 100 K=1,NORDER +C +C FIND LARGEST ELEMENT ARRAY(I,J) IN REST OF MATRIX +C + AMAX=0. +21 DO 30 I=K,NORDER + DO 30 J=K,NORDER +23 IF (DABS(AMAX)-DABS(ARRAY(I,J))) 24,24,30 +24 AMAX=ARRAY(I,J) + IK(K)=I + JK(K)=J +30 CONTINUE +C +C INTERCHANGE ROWS AND COLUMNS TO PUT AMAX IN ARRAY(K,K) +C +31 IF (AMAX) 41,32,41 +32 DET=0. + GOTO 140 +41 I=IK(K) + IF (I-K) 21,51,43 +43 DO 50 J=1,NORDER + SAVE=ARRAY(K,J) + ARRAY(K,J)=ARRAY(I,J) +50 ARRAY(I,J)=-SAVE +51 J=JK(K) + IF (J-K) 21,61,53 +53 DO 60 I=1,NORDER + SAVE=ARRAY(I,K) + ARRAY(I,K)=ARRAY(I,J) +60 ARRAY(I,J)=-SAVE +C +C ACCUMULATE ELEMENTS OF INVERSE MATRIX +C +61 DO 70 I=1,NORDER + IF (I-K) 63,70,63 +63 ARRAY(I,K)=-ARRAY(I,K)/AMAX +70 CONTINUE +71 DO 80 I=1,NORDER + DO 80 J=1,NORDER + IF (I-K) 74,80,74 +74 IF (J-K) 75,80,75 +75 ARRAY(I,J)=ARRAY(I,J)+ARRAY(I,K)*ARRAY(K,J) +80 CONTINUE +81 DO 90 J=1,NORDER + IF (J-K) 83,90,83 +83 ARRAY(K,J)=ARRAY(K,J)/AMAX +90 CONTINUE + ARRAY(K,K)=1./AMAX +100 DET=DET*AMAX +C +C RESTORE ORDERING OF MATRIX +C +101 DO 130 L=1,NORDER + K=NORDER-L+1 + J=IK(K) + IF (J-K) 111,111,105 +105 DO 110 I=1,NORDER + SAVE=ARRAY(I,K) + ARRAY(I,K)=-ARRAY(I,J) +110 ARRAY(I,J)=SAVE +111 I=JK(K) + IF (I-K) 130,130,113 +113 DO 120 J=1,NORDER + SAVE=ARRAY(K,J) + ARRAY(K,J)=-ARRAY(I,J) +120 ARRAY(I,J)=SAVE +130 CONTINUE +140 RETURN + END diff --git a/math/bevington/mkpkg b/math/bevington/mkpkg new file mode 100644 index 00000000..5d9bef3f --- /dev/null +++ b/math/bevington/mkpkg @@ -0,0 +1,35 @@ +# Make the Bevington library. + +$checkout libbev.a lib$ +$update libbev.a +$checkin libbev.a lib$ +$exit + +libbev.a: + agauss.f + area.f + chifit.f + curfit.f + determ.f + factor.f + fchisq.f + fderiv.f + gamma.f + gradls.f + gridls.f + integ.f + interp.f + legfit.f + linfit.f + matinv.f + pbinom.f + pchisq.f + pcorre.f + pgauss.f + ploren.f + polfit.f + ppoiss.f + regres.f + smooth.f + xfit.f + ; diff --git a/math/bevington/pbinom.f b/math/bevington/pbinom.f new file mode 100644 index 00000000..325f6f70 --- /dev/null +++ b/math/bevington/pbinom.f @@ -0,0 +1,26 @@ +c function pbinom.f +c +c source +c Bevington, page 31. +c +c purpose +c evaluate binomial probability coefficient +c +c usage +c result = pbinom (nobs, ntotal, prob) +c +c description of parameters +c nobs - number of items observed +c ntotal - total number of items +c prob - probability of observing each item +c +c subroutines and function subprograms required +c factor (n) +c calculates n factorial for integers +c + function pbinom (nobs,ntotal,prob) +1 notobs=ntotal-nobs +2 pbinom=factor(ntotal)/(factor(nobs)*factor(notobs))* + * (prob**nobs)*(1.-prob)**notobs + return + end diff --git a/math/bevington/pchisq.f b/math/bevington/pchisq.f new file mode 100644 index 00000000..0dbe6d9b --- /dev/null +++ b/math/bevington/pchisq.f @@ -0,0 +1,62 @@ +c function pchisq.f +c +c source +c Bevington, pages 192-193. +c +c purpose +c evaluate probability for exceeding chi square +c +c usage +c result = pchisq (chisqr, nfree) +c +c description of parameters +c chisqr - comparison value of reduced chi square +c nfree - number of degrees of freedom +c +c subroutines and function subprograms required +c gamma (x) +c calculates gamma function for integers and half-integers +c +c comments +c calculation is approximate for nfree odd and +c chi square greater than 50 +c + function pchisq (chisqr,nfree) + double precision z,term,sum +11 if (nfree) 12,12,14 +12 pchisq=0. + goto 60 +14 free=nfree + z=chisqr*free/2. + neven=2*(nfree/2) + if (nfree-neven) 21,21,41 +c +c number of degrees of freedom is even +c +21 imax=nfree/2 + term=1. + sum=0. +31 do 34 i=1,imax + fi=i + sum=sum+term +34 term=term*z/fi +35 pchisq=sum*dexp(z) + goto 60 +c +c number of degrees of freedom is odd +c +41 if (z-25) 44,44,42 +42 z=chisqr*(free-1.)/2. + goto 21 +44 pwr=free/2. + term=1. + sum=term/pwr +51 do 56 i=1,1000 + fi=i + term=-term*z/fi + sum=sum+term/(pwr+fi) +55 if (dabs(term/sum)-0.00001) 57,57,56 +56 continue +57 pchisq=1.-(z**pwr)*sum/gamma(pwr) +60 return + end diff --git a/math/bevington/pcorre.f b/math/bevington/pcorre.f new file mode 100644 index 00000000..9c0b0ae3 --- /dev/null +++ b/math/bevington/pcorre.f @@ -0,0 +1,69 @@ +c function pcorre.f +c +c source +c Bevington, pages 124-125. +c +c purpose +c evaluate probability for no correlation between two variables +c +c usage +c result = pcorre (r, npts) +c +c description of parameters +c r - linear correlation coefficient +c npts - number of data points +c +c subroutines and function subprograms required +c gamma (x) +c calculates gamma function for integers and half-integers +c + function pcorre (r,npts) + double precision r2,term,sum,fi,fnum,denom +c +c evaluate number of degrees of freedom +c +11 nfree=npts-2 + if (nfree) 13,13,15 +13 pcorre=0. + goto 60 +15 r2=r**2 + if (1.-r2) 13,13,17 +17 neven=2*(nfree/2) + if (nfree-neven) 21,21,41 +c +c number of degrees of freedom is even +c +21 imax=(nfree-2)/2 + free=nfree +23 term=abs(r) + sum=term + if (imax) 60,26,31 +26 pcorre=1.-term + goto 60 +31 do 36 i=1,imax + fi=i + fnum=imax-i+1 + denom=2*i+1 + term=-term*r2*fnum/fi +36 sum=sum+term/denom + pcorre=1.128379167*(gamma((free+1.)/2.)/gamma(free/2.)) + pcorre=1.-pcorre*sum + goto 60 +c +c number of degrees of freedom is odd +c +41 imax=(nfree-3)/2 +42 term=abs(r)*dsqrt(1.-r2) +43 sum=datan(r2/term) + if (imax) 57,45,51 +45 sum=sum+term + goto 57 +51 sum=sum+term +52 do 56 i=1,imax + fnum=2*i + denom=2*i+1 + term=term*(1.-r2)*fnum/denom +56 sum=sum+term +57 pcorre=1.-0.6366197724*sum +60 return + end diff --git a/math/bevington/pgauss.f b/math/bevington/pgauss.f new file mode 100644 index 00000000..56cf5d4e --- /dev/null +++ b/math/bevington/pgauss.f @@ -0,0 +1,25 @@ +c function pgauss.f +c +c source +c Bevington, page 45. +c +c purpose +c evaluate gaussian probability function +c +c usage +c result = pgauss (x, averag, sigma) +c +c description of parameters +c x - value for which probability is to be evaluated +c averag - mean of distribution +c sigma - standard deviation of distribution +c +c subroutines and function subprograms required +c none +c + function pgauss (x,averag,sigma) + double precision z +1 z=(x-averag)/sigma +2 pgauss=0.3989422804/sigma*dexp(-(z**2)/2.) + return + end diff --git a/math/bevington/ploren.f b/math/bevington/ploren.f new file mode 100644 index 00000000..20fcb7c3 --- /dev/null +++ b/math/bevington/ploren.f @@ -0,0 +1,23 @@ +c function ploren.f +c +c source +c Bevington, page 51. +c +c purpose +c evaluate lorentzian probability function +c +c usage +c result = ploren (x, averag, width) +c +c description of parameters +c x - value for which probability is to be evaluated +c averag - mean of distribution +c width - full width at half maximum of distribution +c +c subroutines and function subprograms required +c none +c + function ploren (x,averag,width) +1 ploren=0.1591549431*width/((x-averag)**2+(width/2.)**2) + return + end diff --git a/math/bevington/polfit.f b/math/bevington/polfit.f new file mode 100644 index 00000000..cfbdb178 --- /dev/null +++ b/math/bevington/polfit.f @@ -0,0 +1,100 @@ +C SUBROUTINE POLFIT.F +C +C SOURCE +C BEVINGTON, PAGES 140-142. +C +C PURPOSE +C MAKE A LEAST-SQUARES FIT TO DATA WITH A POLYNOMIAL CURVE +C Y = A(1) + A(2)*X + A(3)*X**2 + A(3)*X**3 + . . . +C +C USAGE +C CALL POLFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, CHISQR) +C +C DESCRIPTION OF PARAMETERS +C X - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE +C Y - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE +C SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS +C NPTS - NUMBER OF PAIRS OF DATA POINTS +C NTERMS - NUMBER OF COEFFICIENTS (DEGREE OF POLYNOMIAL + 1) +C MODE - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT +C +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2 +C 0 (NO WEIGHTING) WEIGHT(I) = 1. +C -1 (STATISTICAL) WEIGHT(I) = 1./Y(I) +C A - ARRAY OF COEFFICIENTS OF POLYNOMIAL +C CHISQR - REDUCED CHI SQUARE FOR FIT +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C DETERM (ARRAY, NORDER) +C EVALUATES THE DETERMINANT OF A SYMETRICAL +C TWO-DIMENSIONAL MATRIX OF ORDER NORDER +C +C COMMENTS +C DIMENSION STATEMENT VALID FOR NTERMS UP TO 10 +C + SUBROUTINE POLFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,CHISQR) + DOUBLE PRECISION SUMX,SUMY,XTERM,YTERM,ARRAY,CHISQ + DIMENSION X(1),Y(1),SIGMAY(1),A(1) + DIMENSION SUMX(19),SUMY(10),ARRAY(10,10) +C +C ACCUMULATE WEIGHTED SUMS +C +11 NMAX=2*NTERMS-1 + DO 13 N=1,NMAX +13 SUMX(N)=0. + DO 15 J=1,NTERMS +15 SUMY(J)=0. + CHISQ=0. +21 DO 50 I=1,NPTS + XI=X(I) + YI=Y(I) +31 IF (MODE) 32,37,39 +32 IF (YI) 35,37,33 +33 WEIGHT=1./YI + GOTO 41 +35 WEIGHT=1./(-YI) + GOTO 41 +37 WEIGHT=1. + GOTO 41 +39 WEIGHT=1./SIGMAY(I)**2 +41 XTERM=WEIGHT + DO 44 N=1,NMAX + SUMX(N)=SUMX(N)+XTERM +44 XTERM=XTERM*XI +45 YTERM=WEIGHT*YI + DO 48 N=1,NTERMS + SUMY(N)=SUMY(N)+YTERM +48 YTERM=YTERM*XI +49 CHISQ=CHISQ+WEIGHT*YI**2 +50 CONTINUE +C +C CONSTRUCT MATRICES AND CALCULATE COEFFICIENTS +C +51 DO 54 J=1,NTERMS + DO 54 K=1,NTERMS + N=J+K-1 +54 ARRAY(J,K)=SUMX(N) + DELTA=DETERM (ARRAY,NTERMS) + IF (DELTA) 61,57,61 +57 CHISQR=0. + DO 59 J=1,NTERMS +59 A(J)=0. + GOTO 80 +61 DO 70 L=1,NTERMS +62 DO 66 J=1,NTERMS + DO 65 K=1,NTERMS + N=J+K-1 +65 ARRAY(J,K)=SUMX(N) +66 ARRAY(J,L)=SUMY(J) +70 A(L)=DETERM (ARRAY,NTERMS) /DELTA +C +C CALCULATE CHI SQUARE +C +71 DO 75 J=1,NTERMS + CHISQ=CHISQ-2.*A(J)*SUMY(J) + DO 75 K=1,NTERMS + N=J+K-1 +75 CHISQ=CHISQ+A(J)*A(K)*SUMX(N) +76 FREE=NPTS-NTERMS +77 CHISQR=CHISQ/FREE +80 RETURN + END diff --git a/math/bevington/ppoiss.f b/math/bevington/ppoiss.f new file mode 100644 index 00000000..4782fde8 --- /dev/null +++ b/math/bevington/ppoiss.f @@ -0,0 +1,23 @@ +c function ppoiss.f +c +c source +c Bevington, page 39. +c +c purpose +c evaluate poisson probability function +c +c usage +c result = ppoiss (nobs, averag) +c +c description of parameters +c nobs - number of items observed +c averag - mean of distribution +c +c subroutines and function subprograms required +c factor (n) +c calculates n factorial for integers +c + function ppoiss (nobs,averag) +1 ppoiss=((averag**nobs)/factor(nobs))*exp(-averag) + return + end diff --git a/math/bevington/regres.f b/math/bevington/regres.f new file mode 100644 index 00000000..ef23a574 --- /dev/null +++ b/math/bevington/regres.f @@ -0,0 +1,173 @@ +c subroutine regres.f +c +c source +c Bevington, pages 172-175. +c +c purpose +c make a mulitple linear regression fit to data with a specified +c function which is linear in coefficients +c +c usage +c call regres (x, y, sigmay, npts, nterms, m, mode, yfit, +c a0, a, sigma0, sigmaa, r, rmul, chisqr, ftest) +c +c description of parameters +c x - array of points for independent variable +c y - array of points for dependent variable +c sigmay - array of standard deviations for y data points +c npts - number of pairs of data points +c nterms - number of coefficients +c m - array of inclusion/rejection criteria for fctn +c mode - determines method of weighting least-squares fit +c +1 (instrumental) weight(i) = 1./sigmay(i)**2 +c 0 (no weighting) weight(i) = 1. +c -1 (statistical) weight(i) = 1./y(i) +c yfit - array of calculated values of y +c a0 - constant term +c a - array of coefficients +c sigma0 - standard deviation of a0 +c sigmaa - array of standard deviations for coefficients +c r - array of linear correlation coefficients +c rmul - multiple linear correlation coefficient +c chisqr - reduced chi square for fit +c ftest - value of f for test of fit +c +c subroutines and function subprograms required +c fctn (x, i, j, m) +c evaluates the function for the jth term and the ith data point +c using the array m to specify terms in the function +c matinv (array, nterms, det) +c inverts a symmetric two-dimensional matrix of degree nterms +c and calculates its determinant +c +c comments +c (dim npts changed 100->1000 21-may-84 dct) +c dimension statement valid for npts up to 100 and nterms up to 10 +c sigmaag changed to sigmaa in statement following statement 132 +c + subroutine regres (x,y,sigmay,npts,nterms,m,mode,yfit, + *a0,a,sigma0,sigmaa,r,rmul,chisqr,ftest) + double precision array,sum,ymean,sigma,chisq,xmean,sigmax + dimension x(1),y(1),sigmay(1),m(1),yfit(1),a(1),sigmaa(1), + *r(1) + dimension weight(1000),xmean(10),sigmax(10),array(10,10) + REAL FCTN + EXTERNAL FCTN + +c +c initialize sums and arrays +c +11 sum=0. + ymean=0. + sigma=0. + chisq=0. + rmul=0. + do 17 i=1,npts +17 yfit(i)=0. +21 do 28 j=1,nterms + xmean(j)=0. + sigmax(j)=0. + r(j)=0. + a(j)=0. + sigmaa(j)=0. + do 28 k=1,nterms +28 array(j,k)=0. +c +c accumulate weighted sums +c +30 do 50 i=1,npts +31 if (mode) 32,37,39 +32 if (y(i)) 35,37,33 +33 weight(i)=1./y(i) + goto 41 +35 weight(i)=1./(-y(i)) + goto 41 +37 weight(i)=1. + goto 41 +39 weight(i)=1./sigmay(i)**2 +41 sum=sum+weight(i) + ymean=ymean+weight(i)*y(i) + do 44 j=1,nterms +44 xmean(j)=xmean(j)+weight(i)*fctn(x,i,j,m) +50 continue +51 ymean=ymean/sum + do 53 j=1,nterms +53 xmean(j)=xmean(j)/sum + fnpts=npts + wmean=sum/fnpts + do 57 i=1,npts +57 weight(i)=weight(i)/wmean +c +c accumulate matrices r and array +c +61 do 67 i=1,npts + sigma=sigma+weight(i)*(y(i)-ymean)**2 + do 67 j=1,nterms + sigmax(j)=sigmax(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))**2 + r(j)=r(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))*(y(i)-ymean) + do 67 k=1,j +67 array(j,k)=array(j,k)+weight(i)*(fctn(x,i,j,m)-xmean(j))* + *(fctn(x,i,k,m)-xmean(k)) +71 free1=npts-1 +72 sigma=dsqrt(sigma/free1) + do 78 j=1,nterms +74 sigmax(j)=dsqrt(sigmax(j)/free1) + r(j)=r(j)/(free1*sigmax(j)*sigma) + do 78 k=1,j + array(j,k)=array(j,k)/(free1*sigmax(j)*sigmax(k)) +78 array(k,j)=array(j,k) +c +c invert symmetric matrix +c +81 call matinv (array,nterms,det) + if (det) 101,91,101 +91 a0=0. + sigma0=0. + rmul=0. + chisqr=0. + ftest=0. + goto 150 +c +c calculate coefficients, fit, and chi square +c +101 a0=ymean +102 do 108 j=1,nterms + do 104 k=1,nterms +104 a(j)=a(j)+r(k)*array(j,k) +105 a(j)=a(j)*sigma/sigmax(j) +106 a0=a0-a(j)*xmean(j) +107 do 108 i=1,npts +108 yfit(i)=yfit(i)+a(j)*fctn(x,i,j,m) +111 do 113 i=1,npts + yfit(i)=yfit(i)+a0 +113 chisq=chisq+weight(i)*(y(i)-yfit(i))**2 + freen=npts-nterms-1 +115 chisqr=chisq*wmean/freen +c +c calculate uncertainties +c +121 if (mode) 122,124,122 +122 varnce=1./wmean + goto 131 +124 varnce=chisqr +131 do 133 j=1,nterms +132 sigmaa(j)=array(j,j)*varnce/(free1*sigmax(j)**2) + sigmaa(j)=sqrt(sigmaa(j)) +133 rmul=rmul+a(j)*r(j)*sigmax(j)/sigma + freej=nterms +c +noao: When rmul = 1, the following division (stmt 135) would blow up. +c It has been changed so ftest is set to -99999. in this case. + if (1. - rmul) 135, 935, 135 +135 ftest=(rmul/freej)/((1.-rmul)/freen) + goto 136 +935 ftest = -99999. +c -noao +136 rmul=sqrt(rmul) +141 sigma0=varnce/fnpts + do 145 j=1,nterms + do 145 k=1,nterms +145 sigma0=sigma0+varnce*xmean(j)*xmean(k)*array(j,k)/ + *(free1*sigmax(j)*sigmax(k)) +146 sigma0=sqrt(sigma0) +150 return + end diff --git a/math/bevington/smooth.f b/math/bevington/smooth.f new file mode 100644 index 00000000..19c2c457 --- /dev/null +++ b/math/bevington/smooth.f @@ -0,0 +1,29 @@ +c subroutine smooth.f +c +c source +c Bevington, page 260. +c +c purpose +c smooth a set of data points by averaging adjacent channels +c +c usage +c call smooth (y, npts) +c +c description of parameters +c y - array of data points +c npts - number of data points +c +c subroutines and function subprograms required +c none +c + subroutine smooth (y,npts) + dimension y(1) +11 imax=npts-1 + yi=y(1) +21 do 24 i=1,imax + ynew=(yi+2.*y(i)+y(i+1))/4. + yi=y(i) +24 y(i)=ynew +25 y(npts)=(yi+3.*y(npts))/4. + return + end diff --git a/math/bevington/xfit.f b/math/bevington/xfit.f new file mode 100644 index 00000000..a097d4af --- /dev/null +++ b/math/bevington/xfit.f @@ -0,0 +1,59 @@ +c subroutine xfit.f +c +c source +c Bevington, page 76. +c +c purpose +c calculate the mean and estimated errors for a set of data points +c +c usage +c call xfit (x, sigmax, npts, mode, xmean, sigmam, sigma) +c +c description of parameters +c x - array of data points +c sigmax - array of standard deviations for data points +c npts - number of data points +c mode - determines method of weighting +c +1 (instrumental) weight(i) = 1./sigmax(i)**2 +c 0 (no weighting) weight(i) = 1. +c -1 (statistical) weight(i) = 1. +c xmean - weighted mean +c sigmam - standard deviation of mean +c sigma - standard deviation of data +c +c subroutines and function subprograms required +c none +c + subroutine xfit (x,sigmax,npts,mode,xmean,sigmam,sigma) + double precision sum,sumx,weight,free + dimension x(1),sigmax(1) +c +c accumulate weighted sums +c +11 sum=0. + sumx=0. + sigma=0. + sigmam=0. +20 do 32 i=1,npts +21 if (mode) 22,22,24 +22 weight=1. + goto 31 +24 weight=1./sigmax(i)**2 +31 sum=sum+weight +32 sumx=sumx+weight*x(i) +c +c evaluate mean and standard deviations +c +41 xmean=sumx/sum +51 do 52 i=1,npts +52 sigma=sigma+(x(i)-xmean)**2 + free=npts-1 +54 sigma=dsqrt(sigma/free) +61 if (mode) 62,64,66 +62 sigmam=dsqrt(xmean/sum) + goto 70 +64 sigmam=sigma/dsqrt(sum) + goto 70 +66 sigmam=dsqrt(1./sum) +70 return + end diff --git a/math/curfit/README b/math/curfit/README new file mode 100644 index 00000000..b622c824 --- /dev/null +++ b/math/curfit/README @@ -0,0 +1,6 @@ +Linear Least squares curve fitting package. +Contains routines to fit Legendre and Chebyshev polynomials and linear +cubic splines in the least squares sense to 1-dimensional data. +The normal equations are accumulated and solved using Cholesky factorization. +The package contains separate entry points for accumulating points, +solving the matrix equations, rejecting points and evaluating the curve. diff --git a/math/curfit/Revisions b/math/curfit/Revisions new file mode 100644 index 00000000..ea59404b --- /dev/null +++ b/math/curfit/Revisions @@ -0,0 +1,118 @@ +.help revisions Jun89 math.curfit +.nf +From Davis, September 20, 1999 + +Added some missing file dependices to the mkpkg file. +pkg/math/curfit/mkpkg + +From Davis, March 20, 1997 + +The weights computed by the WTS_CHISQ option in the routines cvacpts[rd] +were not being forced to be positive as intended. +math/curfit/cvacpts.gx +math/curfit/cvacptsr.x +math/curfit/cvacptsd.x + +There was an inconsistency in the way the ncoeff argument to the cvpower[rd] +routines was being used. Ncoeff was intended to be an output argument. +pkg/math/curfit/doc/cvpower.hlp +pkg/math/curfit/cvpower.gx +pkg/math/curfit/cvpowerr.x +pkg/math/curfit/cvpowerd.x + +From Davis, June 13, 1995 + +Added a new routine cvepower to the curfit math package. Cvepower computes +errors of the equivalent power series coefficients for the fitted Legendre +and Chebyshev polynomials and has the same calling sequence as the +cverrors routine. +math/curfit/cvpower.gx +math/curfit/cvpowerr.x +math/curfit/cvpowerd.x +math/curfit/doc/curfit.hd +math/curfit/doc/curfit.men +math/curfit/doc/cvepower.hlp + +From Davis, May, 6, 1990 + +Finished cleaning up the .gx files in curfit. +math/curfit/cverrors.gx +math/curfit/cvpower.gx +math/curfit/cvrefit.gx +math/curfit/cvpower.gx + +From Davis, May 6, 1990 + +Changed the constant from INDEFR to INDEF in the amov$t call in cvpower.gx. +This was causing a problem for the Mac compiler. + +From Davis, April 23, 1991 + +Did some cleaning up in the following .gx files to make the code easier to read. +math/curfit/cv_b1eval.gx +math/curfit/cv_beval.gx +math/curfit/cv_feval.gx +math/curfit/cvaccum.gx +math/curfit/cvacpts.gx +math/curfit/cvchomat.gx +math/curfit/cvfree.gx +math/curfit/cvinit.gx + +From Davis, September 18, 1990 + +Changed the int calls in cvrestore.gx to nint calls. This is a totally +safe way to do the conversion from double precision to integer +quantities in the curfit package and removes any potential precision +problems for task which must read the curfit structure back from a +text database file. + +From Davis, July 14, 1988: + +The calling sequence for the cverrors routine as been changed to include +an npts argument. This edition removesd the possibility for error when +points have been rejected by setting w[i] = 0. + +----------------------------------------------------------------------------- + +From Davis, April 30, 1986: + +1. Several bugs involving double precision constants in the double precision +version of curfit detected on the SUN have been fixed. + +----------------------------------------------------------------------------- + +From Davis, March 13, 1986: + +1. A double precision version of CURFIT has been installed in IRAF. The entry +points for the double precision version are identical to those of the real +version with the addition of a preceeding d (e.g. cveval and dcveval). All +internal arithmetic is done in double and the data is entered in double. + +2. A user function facility has been added to CURFIT. The user may enter +any linear function in the following manner. + + extern func + + ... + + call cvinit (cv, USERFNC, nterms, xmin, xmax) + call cvuser (cv, func) + call cvfit (cv, x, y, w, npts, WTS_USER, ier) + call cvvector (cv, x, yfit, npts) + call cvfree (cv) + + ... + +The user function must have the following form. + + procedure func (x, nterms, k1, k2, basis) + +where + + real x x value + int nterms number of basis functions + real k1, k2 optional normalization parameters + real basis[ARB] computed basis functions + +------------------------------------------------------------------------------- +.endhelp diff --git a/math/curfit/curfit.sem b/math/curfit/curfit.sem new file mode 100644 index 00000000..28058626 --- /dev/null +++ b/math/curfit/curfit.sem @@ -0,0 +1,708 @@ +# Semi-code for curfit.h + +# define the permitted types of curves + +define CHEBYSHEV 1 +define LEGENDRE 2 +define L2SPLINE4 3 + +# define the weighting flags + +define NORMAL 1 # user enters weights +define UNIFORM 2 # equal weights, weight 1.0 +define SPACING 3 # weigth proportional to spacing of data points + +define SPLINE_ORDER 4 + +# set up the curve fitting structure + +define LEN_CVSTRUCT + +struct curfit { + +define CV_TYPE Memi[] # Type of curve to be fitted +define CV_ORDER Memi[] # Order of the fit +define CV_NPIECES Memi[] # Number of polynomial pieces, spline +define CV_NCOEFF Memi[] # Number of coefficients +define CV_XMAX Memr[] # Maximum x value +define CV_XMIN Memr[] # Minimum x value +define CV_RANGE Memr[] # Xmax minus xmin +define CV_MAXMIN Memr[] # Xmax plus xmin +define CV_SPACING Memr[] # Knot spacing for splines +define CV_YNORM Memr[] # Norm of the Y vector +define CV_NPTS Memi[] # Number of data points + +define CV_MATRIX Memi[] # Pointer to original matrix +define CV_CHOFAC Memi[] # Pointer to Cholesky factorization +define CV_BASIS Memi[] # Pointer to basis functions +define CV_VECTOR Memi[] # Pointer to vector +define CV_COEFF Memi[] # Pointer to coefficient vector +define CV_LEFT Memi[] # + +} + +# matrix and vector element definitions + +define MATRIX Memr[$1+($2-1)*NCOEFF(cv)] # Matrix element +define CHOFAC Memr[$1+($2-1)*NCOEFF(cv)] # Triangular matrix +define VECTOR Memr[$1+$2] # Right side +define COEFF Memr[$1+$2] # Coefficient vector +define LEFT Memi[$1+$2] + +# matrix and vector definitions + +define MAT Memr[$1] +define CHO Memr[$1] +define VECT Memr[$1] +define COF Memr[$1] + +# semi-code for the initialization procedure + +include "curfit.h" + +# CVINIT -- Procedure to set up the curve descriptor. + +procedure cvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # pointer to curve descriptor structure +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +real xmin # minimum value of x +real xmax # maximum value of x + +begin + # allocate space for the curve descriptor + call smark (sp) + call salloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(CV) = order + CV_RANGE(cv) = xmax - xmin + CV_MAXMIN(cv) = xmax + xmin + case L2SPLINE4: + CV_ORDER(cv) = SPLINE_ORDER + CV_NCOEFF(cv) = order + SPLINE_ORDER - 1 + CV_NPIECES(cv) = order + CV_SPACING(cv) = (xmax - xmin) / order + default: + call error (0, "CVINIT: Unknown curve type.") + } + + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + + CV_NPTS(cv) = 0 + CV_YNORM(cv) = 0. +end + +# semi-code for cvaccum + +include "curfit.h" + +# CVACCUM -- Procedure to add a single point to the data set. + +procedure cvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +real x # x value +real y # y value +real w # weight of the data point +int wtflag # type of weighting desired + +begin + # calculate the weights + switch (wtflag) { + case UNIFORM: + w = 1.0 + case NORMAL, SPACING: # problem spacing + default: + w = 1.0 + } + + # caculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # accumulate into the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) + bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) + basis[j] * bw + ii = ii + 1 + } + } + + CV_NPTS(cv) = CV_NPTS(cv) + 1 + CV_YNORM(cv) = CV_YNORM(cv) + w * y * y +end + +# semi-code for cvreject + +include "curfit.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set +# to be fitted. + +procedure cvreject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +real x # x value +real y # y value +real w # weight of the data point + +begin + # caculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # subtract the data point from the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) - bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) - basis[j] * bw + ii = ii + 1 + } + } + + CV_NPTS(cv) = CV_NPTS(cv) - 1 + CV_NORM(cv) = CV_NORM(cv) - w * y * y +end + +# semi-code for cvsolve + +include "curfit.h" + +# CVSOLVE -- Procedure to solve a matrix equation of the form Ax = B. +# The Cholesky factorization of matrix A is calculated in the first +# step, followed by forward and back substitution to solve for the vector +# x. + +procedure cvsolve (cv, ier) + +pointer cv # pointer to the image descriptor structure +int ier # ier = 0, everything OK + # ier = 1, matrix is singular + +begin + # solve matrix by adapting Deboor's bchfac.f and bchslv.f routines + # so that the original matrix and vector are not destroyed + + call chofac (MAT(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHO(CV_CHOFAC(cv)), ier) + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECT(CV_VECTOR(cv)), COF(CV_COEFF(cv))) +end + +# semi-code for cvfit + +include "curfit.h" + +# CVFIT -- Procedure to fit a curve to an array of data points x and y with +# weights w. + +procedure cvfit (x, y, w, npts, wtflag, ier) + +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int wtflag # type of weighting +int ier + +begin + # calculate weights + switch (wtflag) { + case UNIFORM: + call amovkr (1., w, npts) + case SPACING: + w[1] = x[2] - x[1] # check for npts > 1 + do i = 2, npts - 1 + w[i] = x[i+1] - x[i-1] + w[npts] = x[npts] - x[npts-1] + case NORMAL: + default: + call amovkr (1., w, npts) + } + + # accumulate data points + do i = 1, npts { + + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the norm of the Y vector + CV_YNORM(cv) = CV_YNORM(cv) + w[i] * y[i] * y[i] + + # calculate non zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # accumulate the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) + bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) + basis[j] * bw + ii = ii + 1 + } + } + } + + # solve the matrix + ier = 0 + call chofac (MAT(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHO(CV_CHOFAC(cv)), ier) + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECT(CV_VECTOR(cv)), COF(CV_COEFF(cv))) +end + +# semi-code for cvrefit + +include "curfit.com" + +# CV_REFIT -- Procedure to refit the data assuming that the x and w values do +# not change. + +procedure cvrefit (cv, x, y, w, ier) + +pointer cv +real x[ARB] +real y[ARB] +real w[ARB] +int ier + +begin + # if first call to refit then calculate and store the basis + # functions + + vcptr = CV_VECTOR(cv) - 1 + do i = 1, NCOEFF(cv) + VECTOR(vcptr+i) = 0. + + CV_YNORM(cv) = 0. + lptr = CV_LEFT(cv) - 1 + bcptr = CV_BASIS(cv) - CV_NPTS(cv) + + if (CV_BASIS(cv) == NULL) { + + call calloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_REAL) + call calloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + + do l = 1, CV_NPTS(cv) { + bptr = bcptr + l * CV_NPTS(cv) + switch (CV_TYPE(cv)) { + case LEGENDRE: + LEFT(lptr+l) = 1 + call legendre (cv, x, BASIS(bptr)) + case CHEBYSHEV: + LEFT(lptr+l) = 1 + call chebyshev (cv, x, BASIS(bptr)) + case L2SPLINE4: + call l2spline4 (cv, x, LEFT(lptr+l), BASIS(bptr)) + } + } + } + + # reset vector to zero + + # accumulate right side of the matrix equation + do l = 1, CV_NPTS(cv) { + + CV_YNORM(cv) = CV_YNORM(cv) + w[l] * y[l] * y[l] + leftm1 = LEFT(lptr+l) - 1 + bptr = bcptr + l * CV_NPTS(cv) + + do i = 1, CV_ORDER(cv) { + vptr = vcptr + leftm1 + i + VECTOR(vptr) = VECTOR(vptr) + BASIS(bptr) * w[l] * y[l] + } + } + + # solve the matrix + call choslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(CV), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end + +# semi-code for cvcoeff + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure cvcoeff (cv, coeff, ncoeff) + +pointer cv # pointer to the curve fitting descriptor +real coeff[ncoeff] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + cptr = CV_COEFF(cv) - 1 + do i = 1, ncoeff + coeff[i] = COEFF(cptr, i) +end + +# semi-code for cvvector + +include "curfit.h" + +# CVVECTOR -- Procedure to evaluate the fitted curve + +procedure cvvector (cv, x, npts, yfit) + +pointer cv # pointer to the curve descriptor structure +real x[npts] # data x values +int npts # number of data points +real yfit[npts] # the fitted y values + +begin + do l = 1, npts { + + # calculate the non-zero basis functions + switch (CV_TYPE(cv) { + case LEGENDRE: + left = 1 + call legendre (cv, x[l], XBASIS(CV_XBASIS(cv))) + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x[l], XBASIS(CV_XBASIS(cv))) + case L2SPLINE4: + call l2spline4 (cv, x[l], left, XBASIS(CV_XBASIS(cv))) + } + + sum = 0.0 + leftm1 = left - 1 + cptr = CV_COEFF(cv) - 1 + xptr = CV_XBASIS(cv) - 1 + + do i = 1, CV_NCOEFF(cv) { + jj = leftm1 + i + sum = sum + XBASIS(xptr + i) * COEFF(cptr + jj) + } + } +end + +# semi-code for cveval + +include "curfit.h" + +# CVEVAL -- Procedure to evaluate curve at a given x + +real procedure cveval (cv, x) + +pointer cv # pointer to image descriptor structure +real x # x value + +int left, leftm1, i +pointer cptr, xptr +real sum + +begin + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 1 + call legendre (cv, x, XBASIS(CV_XBASIS(cv))) + case L2SPLINE4: + call l2spline4 (cv, x, left, XBASIS(CV_XBASIS(cv))) + } + + sum = 0. + leftm1 = left - 1 + cptr = CV_COEFF(cv) - 1 + xptr = CV_XBASIS(cv) - 1 + do i = 1, CV_NCOEFF(cv) { + jj = leftm1 + i + sum = sum + XBASIS(xptr + i) * COEFF(cptr + jj) + } + + return (sum) +end + +# semi-code for cverrors + +include "curfit.h" + +# CVERRORS -- Procedure to calculate the standard deviation of the fit and the +# standard deviations of the coefficients + +procedure cverrors (cv, rms, errors) + +pointer cv # curve descriptor +real rms # standard deviation of data with respect to fit +real errors[ARB] # errors in coefficients + +begin + # calculate the variance + rms = CV_YNORM(cv) + cptr = CV_COEFF(cv) - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_NCOEFF(cv) + rms = rms - COEFF(cptr, i) * VECTOR(vptr, i) + rms = rms / (CV_NPTS(cv) - CV_NCOEFF(cv)) + + # calculate the standard deviations + do i = 1, CV_NCOEFF(cv) { + do j = 1, CV_NCOEFF(cv) + cov[j] = 0. + cov[i] = 1. + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), cov, cov) + errors[i] = sqrt (cov[i] * rms) + } + + rms = sqrt (rms) +end + +# semi-code for CVFREE + +# CVFREE -- Procedure to free the curve descriptor + +procedure cvfree (cv) + +pointer cv + +begin + call sfree (cv) +end + +include "curfit.h" + +# LEGENDRE -- Procedure to calculate the Legendre functions. + +procedure legendre (cv, x, basis) + +pointer cv +real x +real basis[ARB] + +begin + # normalize to the range x = -1. to 1. + xnorm = (2. * x - CV_MAXMIN(cv)) / CV_RANGE(cv) + + b[1] = 1.0 + if (CV_ORDER(cv) == 1) + return + + b[2] = xnorm + if (CV_ORDER(cv) == 2) + return + + do i = 3, CV_ORDER(cv) { + ri = i + b[i] = ((2.*ri-3.)*xnorm*b[i-1] - (ri-2.)*b[i-2]) / (ri-1.) + } +end + +# CHEBYSHEV -- Procedure to calculate Chebyshev polynomials. + +procedure chebyshev (cv, x, basis) + +real x +int order +real basis[ARB] + +begin + # normalize to the range -1. to 1. + xnorm = (2. * x - CV_MAXMIN(cv)) / CV_RANGE(cv) + + b[1] = 1. + if (CV_ORDER(cv) == 1) + return + + b[2] = xnorm + if (CV_ORDER(cv) == 2) + return + + do i = 3, CV_ORDER(cv) { + ri = i + b[i] = 2.*xnorm*b[i-1] - b[i-2] + } +end + +define NPTS_SPLINE 401 # Number of points in the spline lookup table +define INTERVALS 100 # Number of intervals per spline knot + +# L2SPLINE4 -- Procedure to calculate the cubic spline functions + +procedure (cv, x, left, basis) + +pointer cv +real x +int left +real basis[ARB] + +real table[NPTS_SPLINE] + +# data table containing the spline +include "table.dat" + +begin + xnorm = (x - CV_XMIN(cv)) / CV_SPACING(cv) + temp = min (int (xnorm), npieces - 1) + left = temp + 1 + xnorm = xnorm - temp + + near = int ((1. - xnorm + 0.5) * INTERVALS) + 1 + basis[1] = table[near] + near = table[near] + INTERVALS + basis[2] = table[near] + near = table[near] + INTERVALS + basis[3] = table[near] + near = table[near] + INTERVALS + basis[4] = table[near] +end + +# CHOFAC -- Routine to calculate the Cholesky factorization of a banded +# matrix. + +procedure chofac (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] +int nbands +int nrows +real matfac[nbands, nrows] +int ier + +begin + ier = 0 + + if (nrows == 1) { + if (matrix[1,1] .gt. 0.) + matfac[1,1] = 1./matrix[1,1] + return + } + + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (matfac[1,n] + matrix[1,n] <= matrix[1,n]) { + do j = 1, nbands + w[j,n] = 0. + ier = 1 + next + } + + matfac[1,n] = 1./matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + +# CHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CHOFAC. + +procedure choslv (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] +int nbands +int nrows +real vector[nrows] +real coeff[nrows] + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax < 1) + next + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * b[n] + } + + # back substitution + for (n = nrows; n > 0; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - 1) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } + +end diff --git a/math/curfit/curfitdef.h b/math/curfit/curfitdef.h new file mode 100644 index 00000000..b72349ac --- /dev/null +++ b/math/curfit/curfitdef.h @@ -0,0 +1,55 @@ +# Header file for the curve fitting package + +# set up the curve descriptor structure + +define LEN_CVSTRUCT 20 + +define CV_TYPE Memi[$1] # Type of curve to be fitted +define CV_ORDER Memi[$1+1] # Order of the fit +define CV_NPIECES Memi[$1+2] # Number of polynomial pieces - 1 +define CV_NCOEFF Memi[$1+3] # Number of coefficients +define CV_XMAX Memr[P2R($1+4)] # Maximum x value +define CV_XMIN Memr[P2R($1+5)] # Minimum x value +define CV_RANGE Memr[P2R($1+6)] # 2. / (xmax - xmin), polynomials +define CV_MAXMIN Memr[P2R($1+7)] # - (xmax + xmin) / 2., polynomials +define CV_SPACING Memr[P2R($1+8)] # order / (xmax - xmin), splines +define CV_NPTS Memi[$1+9] # Number of data points + +define CV_XBASIS Memi[$1+10] # Pointer to non zero basis for single x +define CV_MATRIX Memi[$1+11] # Pointer to original matrix +define CV_CHOFAC Memi[$1+12] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+13] # Pointer to vector +define CV_COEFF Memi[$1+14] # Pointer to coefficient vector +define CV_BASIS Memi[$1+15] # Pointer to basis functions (all x) +define CV_LEFT Memi[$1+16] # Pointer to first non-zero basis +define CV_WY Memi[$1+17] # Pointer to y * w (cvrefit) +define CV_USERFNC Memi[$1+18] # Pointer to external user subroutine +define CV_USERFNCR Memr[P2R($1+18)]# Real version of above for cvrestore. + # one free slot left + +# matrix and vector element definitions + +define XBASIS Memr[P2P($1)] # Non zero basis for single x +define MATRIX Memr[P2P($1)] # Element of MATRIX +define CHOFAC Memr[P2P($1)] # Element of CHOFAC +define VECTOR Memr[P2P($1)] # Element of VECTOR +define COEFF Memr[P2P($1)] # Element of COEFF +define BASIS Memr[P2P($1)] # Element of BASIS +define LEFT Memi[P2P($1)] # Element of LEFT + +# structure definitions for restore + +define CV_SAVETYPE $1[1] +define CV_SAVEORDER $1[2] +define CV_SAVEXMIN $1[3] +define CV_SAVEXMAX $1[4] +define CV_SAVEFNC $1[5] + +define CV_SAVECOEFF 5 + + +# miscellaneous + +define SPLINE3_ORDER 4 +define SPLINE1_ORDER 2 +define DELTA EPSILON diff --git a/math/curfit/cv_b1eval.gx b/math/curfit/cv_b1eval.gx new file mode 100644 index 00000000..bd77f0ed --- /dev/null +++ b/math/curfit/cv_b1eval.gx @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure $tcv_b1leg (x, order, k1, k2, basis) + +PIXEL x # array of data points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int i +PIXEL ri, xnorm + +begin + basis[1] = PIXEL(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((PIXEL(2.0) * ri - PIXEL(3.0)) * xnorm * basis[i-1] - + (ri - PIXEL(2.0)) * basis[i-2]) / (ri - PIXEL(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure $tcv_b1cheb (x, order, k1, k2, basis) + +PIXEL x # number of data points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int i +PIXEL xnorm + +begin + basis[1] = PIXEL(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = PIXEL(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure $tcv_b1spline1 (x, npieces, k1, k2, basis, left) + +PIXEL x # set of data points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions +int left # index of the appropriate spline functions + +PIXEL xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (PIXEL(0.0), min (PIXEL(1.0), xnorm - left)) + basis[1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure $tcv_b1spline3 (x, npieces, k1, k2, basis, left) + +PIXEL x # array of data points +int npieces # number of polynomial pieces +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +PIXEL sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (PIXEL(0.0), min (PIXEL(1.0), sx - left)) + tx = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = PIXEL(1.0) + tx * (PIXEL(3.0) + tx * (PIXEL(3.0) - + PIXEL(3.0) * tx)) + basis[3] = PIXEL(1.0) + sx * (PIXEL(3.0) + sx * (PIXEL(3.0) - + PIXEL(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_b1evald.x b/math/curfit/cv_b1evald.x new file mode 100644 index 00000000..d5254ed8 --- /dev/null +++ b/math/curfit/cv_b1evald.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure dcv_b1leg (x, order, k1, k2, basis) + +double x # array of data points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int i +double ri, xnorm + +begin + basis[1] = double(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((double(2.0) * ri - double(3.0)) * xnorm * basis[i-1] - + (ri - double(2.0)) * basis[i-2]) / (ri - double(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure dcv_b1cheb (x, order, k1, k2, basis) + +double x # number of data points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int i +double xnorm + +begin + basis[1] = double(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = double(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure dcv_b1spline1 (x, npieces, k1, k2, basis, left) + +double x # set of data points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # basis functions +int left # index of the appropriate spline functions + +double xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (double(0.0), min (double(1.0), xnorm - left)) + basis[1] = max (double(0.0), min (double(1.0), double(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure dcv_b1spline3 (x, npieces, k1, k2, basis, left) + +double x # array of data points +int npieces # number of polynomial pieces +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +double sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (double(0.0), min (double(1.0), sx - left)) + tx = max (double(0.0), min (double(1.0), double(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = double(1.0) + tx * (double(3.0) + tx * (double(3.0) - + double(3.0) * tx)) + basis[3] = double(1.0) + sx * (double(3.0) + sx * (double(3.0) - + double(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_b1evalr.x b/math/curfit/cv_b1evalr.x new file mode 100644 index 00000000..fd6fb8e7 --- /dev/null +++ b/math/curfit/cv_b1evalr.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure rcv_b1leg (x, order, k1, k2, basis) + +real x # array of data points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i +real ri, xnorm + +begin + basis[1] = real(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((real(2.0) * ri - real(3.0)) * xnorm * basis[i-1] - + (ri - real(2.0)) * basis[i-2]) / (ri - real(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure rcv_b1cheb (x, order, k1, k2, basis) + +real x # number of data points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i +real xnorm + +begin + basis[1] = real(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = real(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure rcv_b1spline1 (x, npieces, k1, k2, basis, left) + +real x # set of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left # index of the appropriate spline functions + +real xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (real(0.0), min (real(1.0), xnorm - left)) + basis[1] = max (real(0.0), min (real(1.0), real(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure rcv_b1spline3 (x, npieces, k1, k2, basis, left) + +real x # array of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +real sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (real(0.0), min (real(1.0), sx - left)) + tx = max (real(0.0), min (real(1.0), real(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = real(1.0) + tx * (real(3.0) + tx * (real(3.0) - + real(3.0) * tx)) + basis[3] = real(1.0) + sx * (real(3.0) + sx * (real(3.0) - + real(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_beval.gx b/math/curfit/cv_beval.gx new file mode 100644 index 00000000..3bb2b2e1 --- /dev/null +++ b/math/curfit/cv_beval.gx @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure $tcv_bcheb (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovk$t (PIXEL(1.0), basis, npts) + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulk$t (basis[bptr], PIXEL(2.0), basis[bptr], npts) + call asub$t (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure $tcv_bleg (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int k, bptr +PIXEL ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovk$t (PIXEL(1.0), basis, npts) + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsu$t (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + bptr = bptr + npts + } +end + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure $tcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +PIXEL x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call alta$t (x, basis[1+npts], npts, k1, k2) + call acht$ti (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (PIXEL(0.0), min (PIXEL(1.0), + basis[npts+k] - left[k])) + basis[k] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure $tcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +PIXEL x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +PIXEL dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + + # calculate the index of the first non-zero coeff + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Mem$t[sx+i-1] = max (PIXEL(0.0), min (PIXEL(1.0), + Mem$t[sx+i-1] - left[i])) + Mem$t[tx+i-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Mem$t[sx+i-1] + dtx = Mem$t[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = PIXEL(1.0) + dtx * (PIXEL(3.0) + dtx * + (PIXEL(3.0) - PIXEL(3.0) * dtx)) + basis[2*npts+i] = PIXEL(1.0) + dsx * (PIXEL(3.0) + dsx * + (PIXEL(3.0) - PIXEL(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_bevald.x b/math/curfit/cv_bevald.x new file mode 100644 index 00000000..7d7f6e44 --- /dev/null +++ b/math/curfit/cv_bevald.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure dcv_bcheb (x, npts, order, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkd (double(1.0), basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkd (basis[bptr], double(2.0), basis[bptr], npts) + call asubd (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure dcv_bleg (x, npts, order, k1, k2, basis) + +double x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int k, bptr +double ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkd (double(1.0), basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsud (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + bptr = bptr + npts + } +end + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure dcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +double x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call altad (x, basis[1+npts], npts, k1, k2) + call achtdi (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (double(0.0), min (double(1.0), + basis[npts+k] - left[k])) + basis[k] = max (double(0.0), min (double(1.0), double(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure dcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +double x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +double dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + + # calculate the index of the first non-zero coeff + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Memd[sx+i-1] = max (double(0.0), min (double(1.0), + Memd[sx+i-1] - left[i])) + Memd[tx+i-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Memd[sx+i-1] + dtx = Memd[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = double(1.0) + dtx * (double(3.0) + dtx * + (double(3.0) - double(3.0) * dtx)) + basis[2*npts+i] = double(1.0) + dsx * (double(3.0) + dsx * + (double(3.0) - double(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_bevalr.x b/math/curfit/cv_bevalr.x new file mode 100644 index 00000000..b36aebad --- /dev/null +++ b/math/curfit/cv_bevalr.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure rcv_bcheb (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkr (real(1.0), basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkr (basis[bptr], real(2.0), basis[bptr], npts) + call asubr (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure rcv_bleg (x, npts, order, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int k, bptr +real ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkr (real(1.0), basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsur (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + bptr = bptr + npts + } +end + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure rcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call altar (x, basis[1+npts], npts, k1, k2) + call achtri (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (real(0.0), min (real(1.0), + basis[npts+k] - left[k])) + basis[k] = max (real(0.0), min (real(1.0), real(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure rcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +real dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + + # calculate the index of the first non-zero coeff + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Memr[sx+i-1] = max (real(0.0), min (real(1.0), + Memr[sx+i-1] - left[i])) + Memr[tx+i-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Memr[sx+i-1] + dtx = Memr[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = real(1.0) + dtx * (real(3.0) + dtx * + (real(3.0) - real(3.0) * dtx)) + basis[2*npts+i] = real(1.0) + dsx * (real(3.0) + dsx * + (real(3.0) - real(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_feval.gx b/math/curfit/cv_feval.gx new file mode 100644 index 00000000..759bb193 --- /dev/null +++ b/math/curfit/cv_feval.gx @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL c1, c2 + +begin + # fit a constant + if (order == 1) { + call amovk$t (coeff[1], yfit, npts) + return + } + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altm$t (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (pn, npts, TY_PIXEL) + call salloc (pnm1, npts, TY_PIXEL) + call salloc (pnm2, npts, TY_PIXEL) + + # a higher order polynomial + call amovk$t (PIXEL(1.0), Mem$t[pnm2], npts) + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + call amulk$t (Mem$t[sx], PIXEL(2.0), Mem$t[sx], npts) + do i = 3, order { + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call asub$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure $tcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL ri, ri1, ri2 + +begin + + # fit a constant + if (order == 1) { + call amovk$t (coeff[1], yfit, npts) + return + } + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altm$t (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (pn, npts, TY_PIXEL) + call salloc (pnm1, npts, TY_PIXEL) + call salloc (pnm2, npts, TY_PIXEL) + + # a higher order polynomial + call amovk$t (PIXEL(1.0), Mem$t[pnm2], npts) + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call awsu$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts, ri1, ri2) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure $tcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +PIXEL coeff[ARB] # array of coefficients +PIXEL x[npts] # array of x values +PIXEL yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +PIXEL k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Mem$t[aindex] = max (PIXEL(0.0), min (PIXEL(1.0), Mem$t[aindex] - + Memi[index+j-1])) + Mem$t[tx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Mem$t[tx+j-1] * coeff[1+Memi[index+j-1]] + + Mem$t[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure $tcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +PIXEL coeff[ARB] # array of coeffcients +PIXEL x[npts] # array of x values +PIXEL yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +PIXEL k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + call salloc (temp, npts, TY_PIXEL) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Mem$t[sx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), Mem$t[sx+j-1] - + Memi[index+j-1])) + Mem$t[tx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclr$t (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowk$t (Mem$t[tx], 3, Mem$t[temp], npts) + case 2: + do j = 1, npts { + Mem$t[temp+j-1] = PIXEL(1.0) + Mem$t[tx+j-1] * + (PIXEL(3.0) + Mem$t[tx+j-1] * (PIXEL(3.0) - + PIXEL(3.0) * Mem$t[tx+j-1])) + } + case 3: + do j = 1, npts { + Mem$t[temp+j-1] = PIXEL(1.0) + Mem$t[sx+j-1] * + (PIXEL(3.0) + Mem$t[sx+j-1] * (PIXEL(3.0) - + PIXEL(3.0) * Mem$t[sx+j-1])) + } + case 4: + call apowk$t (Mem$t[sx], 3, Mem$t[temp], npts) + } + + do j = 1, npts + Mem$t[temp+j-1] = Mem$t[temp+j-1] * coeff[i+Memi[index+j-1]] + call aadd$t (yfit, Mem$t[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_fevald.x b/math/curfit/cv_fevald.x new file mode 100644 index 00000000..9293a821 --- /dev/null +++ b/math/curfit/cv_fevald.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double c1, c2 + +begin + # fit a constant + if (order == 1) { + call amovkd (coeff[1], yfit, npts) + return + } + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmd (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (double(1.0), Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + call amulkd (Memd[sx], double(2.0), Memd[sx], npts) + do i = 3, order { + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call asubd (Memd[pn], Memd[pnm2], Memd[pn], npts) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure dcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double ri, ri1, ri2 + +begin + + # fit a constant + if (order == 1) { + call amovkd (coeff[1], yfit, npts) + return + } + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmd (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (double(1.0), Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call awsud (Memd[pn], Memd[pnm2], Memd[pn], npts, ri1, ri2) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure dcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +double coeff[ARB] # array of coefficients +double x[npts] # array of x values +double yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +double k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Memd[aindex] = max (double(0.0), min (double(1.0), Memd[aindex] - + Memi[index+j-1])) + Memd[tx+j-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Memd[tx+j-1] * coeff[1+Memi[index+j-1]] + + Memd[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure dcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +double coeff[ARB] # array of coeffcients +double x[npts] # array of x values +double yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +double k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + call salloc (temp, npts, TY_DOUBLE) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memd[sx+j-1] = max (double(0.0), min (double(1.0), Memd[sx+j-1] - + Memi[index+j-1])) + Memd[tx+j-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclrd (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowkd (Memd[tx], 3, Memd[temp], npts) + case 2: + do j = 1, npts { + Memd[temp+j-1] = double(1.0) + Memd[tx+j-1] * + (double(3.0) + Memd[tx+j-1] * (double(3.0) - + double(3.0) * Memd[tx+j-1])) + } + case 3: + do j = 1, npts { + Memd[temp+j-1] = double(1.0) + Memd[sx+j-1] * + (double(3.0) + Memd[sx+j-1] * (double(3.0) - + double(3.0) * Memd[sx+j-1])) + } + case 4: + call apowkd (Memd[sx], 3, Memd[temp], npts) + } + + do j = 1, npts + Memd[temp+j-1] = Memd[temp+j-1] * coeff[i+Memi[index+j-1]] + call aaddd (yfit, Memd[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_fevalr.x b/math/curfit/cv_fevalr.x new file mode 100644 index 00000000..ac019042 --- /dev/null +++ b/math/curfit/cv_fevalr.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real c1, c2 + +begin + # fit a constant + if (order == 1) { + call amovkr (coeff[1], yfit, npts) + return + } + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmr (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (real(1.0), Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + call amulkr (Memr[sx], real(2.0), Memr[sx], npts) + do i = 3, order { + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call asubr (Memr[pn], Memr[pnm2], Memr[pn], npts) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure rcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real ri, ri1, ri2 + +begin + + # fit a constant + if (order == 1) { + call amovkr (coeff[1], yfit, npts) + return + } + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmr (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (real(1.0), Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call awsur (Memr[pn], Memr[pnm2], Memr[pn], npts, ri1, ri2) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure rcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coefficients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +real k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Memr[aindex] = max (real(0.0), min (real(1.0), Memr[aindex] - + Memi[index+j-1])) + Memr[tx+j-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Memr[tx+j-1] * coeff[1+Memi[index+j-1]] + + Memr[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure rcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coeffcients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (temp, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memr[sx+j-1] = max (real(0.0), min (real(1.0), Memr[sx+j-1] - + Memi[index+j-1])) + Memr[tx+j-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclrr (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowkr (Memr[tx], 3, Memr[temp], npts) + case 2: + do j = 1, npts { + Memr[temp+j-1] = real(1.0) + Memr[tx+j-1] * + (real(3.0) + Memr[tx+j-1] * (real(3.0) - + real(3.0) * Memr[tx+j-1])) + } + case 3: + do j = 1, npts { + Memr[temp+j-1] = real(1.0) + Memr[sx+j-1] * + (real(3.0) + Memr[sx+j-1] * (real(3.0) - + real(3.0) * Memr[sx+j-1])) + } + case 4: + call apowkr (Memr[sx], 3, Memr[temp], npts) + } + + do j = 1, npts + Memr[temp+j-1] = Memr[temp+j-1] * coeff[i+Memi[index+j-1]] + call aaddr (yfit, Memr[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_userfnc.gx b/math/curfit/cv_userfnc.gx new file mode 100644 index 00000000..7a4e80e8 --- /dev/null +++ b/math/curfit/cv_userfnc.gx @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure $tcv_b1user (cv, x) + +pointer cv +PIXEL x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure $tcv_buser (cv, x, npts) + +pointer cv +PIXEL x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call $tcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure $tcv_evuser (cv, x, yfit, npts) + +pointer cv +PIXEL x[ARB], yfit[ARB] +int npts + +int i +PIXEL adot$t + +begin + do i = 1, npts { + call $tcv_b1user (cv, x[i]) + yfit[i] = adot$t ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +$if (datatype == r) +procedure cvuserfnc (cv, fnc) +$else +procedure dcvuserfnc (cv, fnc) +$endif + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cv_userfncd.x b/math/curfit/cv_userfncd.x new file mode 100644 index 00000000..ae05d372 --- /dev/null +++ b/math/curfit/cv_userfncd.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure dcv_b1user (cv, x) + +pointer cv +double x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure dcv_buser (cv, x, npts) + +pointer cv +double x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call dcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure dcv_evuser (cv, x, yfit, npts) + +pointer cv +double x[ARB], yfit[ARB] +int npts + +int i +double adotd + +begin + do i = 1, npts { + call dcv_b1user (cv, x[i]) + yfit[i] = adotd ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +procedure dcvuserfnc (cv, fnc) + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cv_userfncr.x b/math/curfit/cv_userfncr.x new file mode 100644 index 00000000..b9f502c3 --- /dev/null +++ b/math/curfit/cv_userfncr.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure rcv_b1user (cv, x) + +pointer cv +real x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure rcv_buser (cv, x, npts) + +pointer cv +real x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call rcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure rcv_evuser (cv, x, yfit, npts) + +pointer cv +real x[ARB], yfit[ARB] +int npts + +int i +real adotr + +begin + do i = 1, npts { + call rcv_b1user (cv, x[i]) + yfit[i] = adotr ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +procedure cvuserfnc (cv, fnc) + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cvaccum.gx b/math/curfit/cvaccum.gx new file mode 100644 index 00000000..fb5a957b --- /dev/null +++ b/math/curfit/cvaccum.gx @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +$if (datatype == r) +procedure cvaccum (cv, x, y, w, wtflag) +$else +procedure dcvaccum (cv, x, y, w, wtflag) +$endif + +pointer cv # curve descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +PIXEL bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvaccumd.x b/math/curfit/cvaccumd.x new file mode 100644 index 00000000..2a30b584 --- /dev/null +++ b/math/curfit/cvaccumd.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +procedure dcvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +double x # x value +double y # y value +double w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +double bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvaccumr.x b/math/curfit/cvaccumr.x new file mode 100644 index 00000000..a2184840 --- /dev/null +++ b/math/curfit/cvaccumr.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +procedure cvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +real x # x value +real y # y value +real w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +real bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvacpts.gx b/math/curfit/cvacpts.gx new file mode 100644 index 00000000..56a36cb2 --- /dev/null +++ b/math/curfit/cvacpts.gx @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +$if (datatype == r) +procedure cvacpts (cv, x, y, w, npts, wtflag) +$else +procedure dcvacpts (cv, x, y, w, npts, wtflag) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # array of abcissa +PIXEL y[npts] # array of ordinates +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_PIXEL) + call mfree (CV_WY(cv), TY_PIXEL) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovk$t (PIXEL(1.0), w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1. + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1. + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > PIXEL(0.0)) + w[i] = PIXEL(1.0) / y[i] + else if (y[i] < PIXEL(0.0)) + w[i] = -PIXEL(1.0) / y[i] + else + w[i] = PIXEL(0.0) + } + default: + call amovk$t (PIXEL(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_PIXEL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call $tcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call $tcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call $tcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call $tcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_PIXEL) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amul$t (w, BASIS(bptr), Mem$t[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Mem$t[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amul$t (w, BASIS(bptr), Mem$t[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Mem$t[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvacptsd.x b/math/curfit/cvacptsd.x new file mode 100644 index 00000000..aa4665d8 --- /dev/null +++ b/math/curfit/cvacptsd.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +procedure dcvacpts (cv, x, y, w, npts, wtflag) + +pointer cv # curve descriptor +double x[npts] # array of abcissa +double y[npts] # array of ordinates +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkd (double(1.0), w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1. + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1. + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > double(0.0)) + w[i] = double(1.0) / y[i] + else if (y[i] < double(0.0)) + w[i] = -double(1.0) / y[i] + else + w[i] = double(0.0) + } + default: + call amovkd (double(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_DOUBLE) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call dcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call dcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call dcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call dcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_DOUBLE) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amuld (w, BASIS(bptr), Memd[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Memd[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amuld (w, BASIS(bptr), Memd[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Memd[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvacptsr.x b/math/curfit/cvacptsr.x new file mode 100644 index 00000000..fde31363 --- /dev/null +++ b/math/curfit/cvacptsr.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +procedure cvacpts (cv, x, y, w, npts, wtflag) + +pointer cv # curve descriptor +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkr (real(1.0), w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1. + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1. + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > real(0.0)) + w[i] = real(1.0) / y[i] + else if (y[i] < real(0.0)) + w[i] = -real(1.0) / y[i] + else + w[i] = real(0.0) + } + default: + call amovkr (real(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_REAL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call rcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call rcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call rcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call rcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_REAL) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amulr (w, BASIS(bptr), Memr[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Memr[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amulr (w, BASIS(bptr), Memr[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Memr[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvchomat.gx b/math/curfit/cvchomat.gx new file mode 100644 index 00000000..c9324a32 --- /dev/null +++ b/math/curfit/cvchomat.gx @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure $tcvchofac (matrix, nbands, nrows, matfac, ier) + +PIXEL matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +PIXEL matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +PIXEL ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + $if (datatype == r) + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILONR) { + $else + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILOND) { + $endif + do j = 1, nbands + matfac[j,n] = PIXEL (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure $tcvchoslv (matfac, nbands, nrows, vector, coeff) + +PIXEL matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +PIXEL vector[nrows] # right side of matrix equation +PIXEL coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/curfit/cvchomatd.x b/math/curfit/cvchomatd.x new file mode 100644 index 00000000..1afef515 --- /dev/null +++ b/math/curfit/cvchomatd.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "dcurfitdef.h" + +# CVCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure dcvchofac (matrix, nbands, nrows, matfac, ier) + +double matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +double matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +double ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILOND) { + do j = 1, nbands + matfac[j,n] = double (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure dcvchoslv (matfac, nbands, nrows, vector, coeff) + +double matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +double vector[nrows] # right side of matrix equation +double coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/curfit/cvchomatr.x b/math/curfit/cvchomatr.x new file mode 100644 index 00000000..cce25ecf --- /dev/null +++ b/math/curfit/cvchomatr.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "curfitdef.h" + +# CVCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure rcvchofac (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +real matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +real ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILONR) { + do j = 1, nbands + matfac[j,n] = real (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure rcvchoslv (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +real vector[nrows] # right side of matrix equation +real coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/curfit/cvcoeff.gx b/math/curfit/cvcoeff.gx new file mode 100644 index 00000000..46c58c0f --- /dev/null +++ b/math/curfit/cvcoeff.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +$if (datatype == r) +procedure cvcoeff (cv, coeff, ncoeff) +$else +procedure dcvcoeff (cv, coeff, ncoeff) +$endif + +pointer cv # curve descriptor +PIXEL coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amov$t (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cvcoeffd.x b/math/curfit/cvcoeffd.x new file mode 100644 index 00000000..1d63b9cf --- /dev/null +++ b/math/curfit/cvcoeffd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure dcvcoeff (cv, coeff, ncoeff) + +pointer cv # curve descriptor +double coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amovd (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cvcoeffr.x b/math/curfit/cvcoeffr.x new file mode 100644 index 00000000..69e73848 --- /dev/null +++ b/math/curfit/cvcoeffr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure cvcoeff (cv, coeff, ncoeff) + +pointer cv # curve descriptor +real coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amovr (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cverrors.gx b/math/curfit/cverrors.gx new file mode 100644 index 00000000..07288c7f --- /dev/null +++ b/math/curfit/cverrors.gx @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +define COV Mem$t[P2P($1)] # element of COV + +# CVERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +$if (datatype == r) +procedure cverrors (cv, y, w, yfit, npts, chisqr, errors) +$else +procedure dcverrors (cv, y, w, yfit, npts, chisqr, errors) +$endif + +pointer cv # curve descriptor +PIXEL y[ARB] # data points +PIXEL yfit[ARB] # fitted data points +PIXEL w[ARB] # array of weights +int npts # number of points +PIXEL chisqr # reduced chi-squared of fit +PIXEL errors[ARB] # errors in coefficients + +int i, n, nfree +PIXEL variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_PIXEL) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + do i = 1, CV_NCOEFF(cv) { + call aclr$t (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + + call sfree (sp) +end diff --git a/math/curfit/cverrorsd.x b/math/curfit/cverrorsd.x new file mode 100644 index 00000000..ed0cf9dc --- /dev/null +++ b/math/curfit/cverrorsd.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +define COV Memd[P2P($1)] # element of COV + +# CVERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure dcverrors (cv, y, w, yfit, npts, chisqr, errors) + +pointer cv # curve descriptor +double y[ARB] # data points +double yfit[ARB] # fitted data points +double w[ARB] # array of weights +int npts # number of points +double chisqr # reduced chi-squared of fit +double errors[ARB] # errors in coefficients + +int i, n, nfree +double variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_DOUBLE) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + do i = 1, CV_NCOEFF(cv) { + call aclrd (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + + call sfree (sp) +end diff --git a/math/curfit/cverrorsr.x b/math/curfit/cverrorsr.x new file mode 100644 index 00000000..89533b7b --- /dev/null +++ b/math/curfit/cverrorsr.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +define COV Memr[P2P($1)] # element of COV + +# CVERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure cverrors (cv, y, w, yfit, npts, chisqr, errors) + +pointer cv # curve descriptor +real y[ARB] # data points +real yfit[ARB] # fitted data points +real w[ARB] # array of weights +int npts # number of points +real chisqr # reduced chi-squared of fit +real errors[ARB] # errors in coefficients + +int i, n, nfree +real variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_REAL) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + do i = 1, CV_NCOEFF(cv) { + call aclrr (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + + call sfree (sp) +end diff --git a/math/curfit/cveval.gx b/math/curfit/cveval.gx new file mode 100644 index 00000000..995b4f74 --- /dev/null +++ b/math/curfit/cveval.gx @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +$if (datatype == r) +PIXEL procedure cveval (cv, x) +$else +PIXEL procedure dcveval (cv, x) +$endif + +pointer cv # curve descriptor +PIXEL x # x value + +int left +pointer cptr, xptr +PIXEL yfit + +PIXEL adot$t() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adot$t (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvevald.x b/math/curfit/cvevald.x new file mode 100644 index 00000000..c1c1f052 --- /dev/null +++ b/math/curfit/cvevald.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +double procedure dcveval (cv, x) + +pointer cv # curve descriptor +double x # x value + +int left +pointer cptr, xptr +double yfit + +double adotd() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adotd (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvevalr.x b/math/curfit/cvevalr.x new file mode 100644 index 00000000..56c4c772 --- /dev/null +++ b/math/curfit/cvevalr.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +real procedure cveval (cv, x) + +pointer cv # curve descriptor +real x # x value + +int left +pointer cptr, xptr +real yfit + +real adotr() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adotr (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvfit.gx b/math/curfit/cvfit.gx new file mode 100644 index 00000000..65c3bfb5 --- /dev/null +++ b/math/curfit/cvfit.gx @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +$if (datatype == r) +procedure cvfit (cv, x, y, w, npts, wtflag, ier) +$else +procedure dcvfit (cv, x, y, w, npts, wtflag, ier) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # array of abcissa +PIXEL y[npts] # array of ordinates +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + $if (datatype == r) + + # zero the appropriate arrays + call cvzero (cv) + + # enter data points + call cvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call cvsolve (cv, ier) + + $else + + # zero the appropriate arrays + call dcvzero (cv) + + # enter data points + call dcvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call dcvsolve (cv, ier) + + $endif +end diff --git a/math/curfit/cvfitd.x b/math/curfit/cvfitd.x new file mode 100644 index 00000000..bd4f9e83 --- /dev/null +++ b/math/curfit/cvfitd.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +procedure dcvfit (cv, x, y, w, npts, wtflag, ier) + +pointer cv # curve descriptor +double x[npts] # array of abcissa +double y[npts] # array of ordinates +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + + # zero the appropriate arrays + call dcvzero (cv) + + # enter data points + call dcvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call dcvsolve (cv, ier) + +end diff --git a/math/curfit/cvfitr.x b/math/curfit/cvfitr.x new file mode 100644 index 00000000..53374278 --- /dev/null +++ b/math/curfit/cvfitr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +procedure cvfit (cv, x, y, w, npts, wtflag, ier) + +pointer cv # curve descriptor +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + + # zero the appropriate arrays + call cvzero (cv) + + # enter data points + call cvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call cvsolve (cv, ier) + +end diff --git a/math/curfit/cvfree.gx b/math/curfit/cvfree.gx new file mode 100644 index 00000000..1c18d637 --- /dev/null +++ b/math/curfit/cvfree.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVFREE -- Procedure to free the curve descriptor + +$if (datatype == r) +procedure cvfree (cv) +$else +procedure dcvfree (cv) +$endif + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_PIXEL) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_PIXEL) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_PIXEL) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_PIXEL) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_PIXEL) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_PIXEL) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_PIXEL) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvfreed.x b/math/curfit/cvfreed.x new file mode 100644 index 00000000..42971c86 --- /dev/null +++ b/math/curfit/cvfreed.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVFREE -- Procedure to free the curve descriptor + +procedure dcvfree (cv) + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_DOUBLE) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_DOUBLE) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_DOUBLE) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_DOUBLE) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_DOUBLE) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_DOUBLE) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_DOUBLE) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvfreer.x b/math/curfit/cvfreer.x new file mode 100644 index 00000000..95adffca --- /dev/null +++ b/math/curfit/cvfreer.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVFREE -- Procedure to free the curve descriptor + +procedure cvfree (cv) + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_REAL) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_REAL) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_REAL) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_REAL) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_REAL) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_REAL) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_REAL) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvinit.gx b/math/curfit/cvinit.gx new file mode 100644 index 00000000..f3518dab --- /dev/null +++ b/math/curfit/cvinit.gx @@ -0,0 +1,95 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVINIT -- Procedure to initialize the curve descriptor. + +$if (datatype == r) +procedure cvinit (cv, curve_type, order, xmin, xmax) +$else +procedure dcvinit (cv, curve_type, order, xmin, xmax) +$endif + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +PIXEL xmin # minimum value of x +PIXEL xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_PIXEL) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_PIXEL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvinitd.x b/math/curfit/cvinitd.x new file mode 100644 index 00000000..6613d88a --- /dev/null +++ b/math/curfit/cvinitd.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "dcurfitdef.h" + +# CVINIT -- Procedure to initialize the curve descriptor. + +procedure dcvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +double xmin # minimum value of x +double xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvinitr.x b/math/curfit/cvinitr.x new file mode 100644 index 00000000..0af12853 --- /dev/null +++ b/math/curfit/cvinitr.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "curfitdef.h" + +# CVINIT -- Procedure to initialize the curve descriptor. + +procedure cvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +real xmin # minimum value of x +real xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvpower.gx b/math/curfit/cvpower.gx new file mode 100644 index 00000000..0e3cb62a --- /dev/null +++ b/math/curfit/cvpower.gx @@ -0,0 +1,526 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +$if (datatype == r) +procedure cvpower (cv, ps_coeff, ncoeff) +$else +procedure dcvpower (cv, ps_coeff, ncoeff) +$endif + +pointer cv # Pointer to curfit structure +PIXEL ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +$if (datatype == r) +int cvstati() +$else +int dcvstati() +$endif + +begin + $if (datatype == r) + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + $else + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + $endif + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovk$t (INDEF, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_PIXEL) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + $if (datatype == r) + call cvcoeff (cv, Memr[cf_coeff], ncoeff) + $else + call dcvcoeff (cv, Memd[cf_coeff], ncoeff) + $endif + + switch (function){ + case (LEGENDRE): + call $tcv_mlegen (Memd[elm], ncoeff) + call $tcv_legen (Memd[elm], Mem$t[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call $tcv_mcheby (Memd[elm], ncoeff) + call $tcv_cheby (Memd[elm], Mem$t[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call $tcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series coefficients. First the +# variance and the reduced chi-squared of the fit are estimated. If these +# two quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +$if (datatype == r) +procedure cvepower (cv, y, w, yfit, npts, chisqr, perrors) +$else +procedure dcvepower (cv, y, w, yfit, npts, chisqr, perrors) +$endif + +pointer cv # curve descriptor +PIXEL y[ARB] # data points +PIXEL yfit[ARB] # fitted data points +PIXEL w[ARB] # array of weights +int npts # number of points +PIXEL chisqr # reduced chi-squared of fit +PIXEL perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +PIXEL variance, chisq, hold +pointer sp, covar, elm +$if (datatype == r) +int cvstati() +$else +int dcvstati() +$endif + +begin + # Determine the function type. + $if (datatype == r) + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + $else + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + $endif + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovk$t (INDEF, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # If the variance equals the reduced chi_squared as in the case of + # uniform weights then scale the errors in the coefficients by the + # variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) { + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + } else + variance = 1. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclr$t (perrors, ncoeff) + perrors[j] = PIXEL(1.0) + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulk$t (perrors, PIXEL(variance), perrors, ncoeff) + call acht$td (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call $tcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call $tcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call $tcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call $tcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure $tcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double $tcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = $tcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure $tcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +PIXEL perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure $tcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +PIXEL cf_coeff[ncoeff] +PIXEL ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure $tcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double $tcv_factorial() + +begin + sum1 = ((-1) ** k) * $tcv_factorial (2 * n - 2 * k) + divisor = (2**n) * $tcv_factorial (k) * $tcv_factorial (n-k) * + $tcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure $tcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double $tcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + $tcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure $tcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +PIXEL cf_coeff[ncoeff] # Input curfit coefficients +PIXEL ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure $tcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double $tcv_factorial() + +begin + sum1 = ((-1) ** m) * $tcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = $tcv_factorial (n - (2*m)) * $tcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure $tcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +PIXEL ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double $tcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = $tcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure $tcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double $tcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = $tcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure $tcv_bcoeff (n, i) + +int n +int i + +double $tcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return ($tcv_factorial (n) / ($tcv_factorial (n - i) * + $tcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure $tcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmul$t (a, b, c, ndim) + +PIXEL a[ndim,ndim] #I left input matrix +PIXEL b[ndim,ndim] #I right input matrix +PIXEL c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +PIXEL v + +begin + do j = 1, ndim + do i = 1, ndim { + v = PIXEL(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvpowerd.x b/math/curfit/cvpowerd.x new file mode 100644 index 00000000..626aa723 --- /dev/null +++ b/math/curfit/cvpowerd.x @@ -0,0 +1,492 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "dcurfitdef.h" + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +procedure dcvpower (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +double ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +int dcvstati() + +begin + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovkd (INDEFD, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_DOUBLE) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + call dcvcoeff (cv, Memd[cf_coeff], ncoeff) + + switch (function){ + case (LEGENDRE): + call dcv_mlegen (Memd[elm], ncoeff) + call dcv_legen (Memd[elm], Memd[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call dcv_mcheby (Memd[elm], ncoeff) + call dcv_cheby (Memd[elm], Memd[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call dcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series coefficients. First the +# variance and the reduced chi-squared of the fit are estimated. If these +# two quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure dcvepower (cv, y, w, yfit, npts, chisqr, perrors) + +pointer cv # curve descriptor +double y[ARB] # data points +double yfit[ARB] # fitted data points +double w[ARB] # array of weights +int npts # number of points +double chisqr # reduced chi-squared of fit +double perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +double variance, chisq, hold +pointer sp, covar, elm +int dcvstati() + +begin + # Determine the function type. + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovkd (INDEFD, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # If the variance equals the reduced chi_squared as in the case of + # uniform weights then scale the errors in the coefficients by the + # variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) { + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + } else + variance = 1. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclrd (perrors, ncoeff) + perrors[j] = double(1.0) + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulkd (perrors, double(variance), perrors, ncoeff) + call achtdd (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call dcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call dcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call dcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call dcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure dcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double dcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = dcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure dcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +double perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure dcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +double cf_coeff[ncoeff] +double ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure dcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double dcv_factorial() + +begin + sum1 = ((-1) ** k) * dcv_factorial (2 * n - 2 * k) + divisor = (2**n) * dcv_factorial (k) * dcv_factorial (n-k) * + dcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure dcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double dcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + dcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure dcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +double cf_coeff[ncoeff] # Input curfit coefficients +double ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure dcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double dcv_factorial() + +begin + sum1 = ((-1) ** m) * dcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = dcv_factorial (n - (2*m)) * dcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure dcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +double ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double dcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = dcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure dcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double dcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = dcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure dcv_bcoeff (n, i) + +int n +int i + +double dcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return (dcv_factorial (n) / (dcv_factorial (n - i) * + dcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure dcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmuld (a, b, c, ndim) + +double a[ndim,ndim] #I left input matrix +double b[ndim,ndim] #I right input matrix +double c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +double v + +begin + do j = 1, ndim + do i = 1, ndim { + v = double(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvpowerr.x b/math/curfit/cvpowerr.x new file mode 100644 index 00000000..a100d057 --- /dev/null +++ b/math/curfit/cvpowerr.x @@ -0,0 +1,492 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +include "curfitdef.h" + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +procedure cvpower (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +real ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +int cvstati() + +begin + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovkr (INDEFR, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_REAL) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + call cvcoeff (cv, Memr[cf_coeff], ncoeff) + + switch (function){ + case (LEGENDRE): + call rcv_mlegen (Memd[elm], ncoeff) + call rcv_legen (Memd[elm], Memr[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call rcv_mcheby (Memd[elm], ncoeff) + call rcv_cheby (Memd[elm], Memr[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call rcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series coefficients. First the +# variance and the reduced chi-squared of the fit are estimated. If these +# two quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure cvepower (cv, y, w, yfit, npts, chisqr, perrors) + +pointer cv # curve descriptor +real y[ARB] # data points +real yfit[ARB] # fitted data points +real w[ARB] # array of weights +int npts # number of points +real chisqr # reduced chi-squared of fit +real perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +real variance, chisq, hold +pointer sp, covar, elm +int cvstati() + +begin + # Determine the function type. + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovkr (INDEFR, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # If the variance equals the reduced chi_squared as in the case of + # uniform weights then scale the errors in the coefficients by the + # variance not the reduced chi-squared + if (abs (chisq - variance) <= DELTA) { + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + } else + variance = 1. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclrr (perrors, ncoeff) + perrors[j] = real(1.0) + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulkr (perrors, real(variance), perrors, ncoeff) + call achtrd (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call rcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call rcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call rcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call rcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure rcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double rcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = rcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure rcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +real perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure rcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +real cf_coeff[ncoeff] +real ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure rcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double rcv_factorial() + +begin + sum1 = ((-1) ** k) * rcv_factorial (2 * n - 2 * k) + divisor = (2**n) * rcv_factorial (k) * rcv_factorial (n-k) * + rcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure rcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double rcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + rcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure rcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +real cf_coeff[ncoeff] # Input curfit coefficients +real ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure rcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double rcv_factorial() + +begin + sum1 = ((-1) ** m) * rcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = rcv_factorial (n - (2*m)) * rcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure rcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +real ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double rcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = rcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure rcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double rcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = rcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure rcv_bcoeff (n, i) + +int n +int i + +double rcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return (rcv_factorial (n) / (rcv_factorial (n - i) * + rcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure rcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmulr (a, b, c, ndim) + +real a[ndim,ndim] #I left input matrix +real b[ndim,ndim] #I right input matrix +real c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +real v + +begin + do j = 1, ndim + do i = 1, ndim { + v = real(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvrefit.gx b/math/curfit/cvrefit.gx new file mode 100644 index 00000000..448ac684 --- /dev/null +++ b/math/curfit/cvrefit.gx @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +$if (datatype == r) +procedure cvrefit (cv, x, y, w, ier) +$else +procedure dcvrefit (cv, x, y, w, ier) +$endif + +pointer cv # curve descriptor +PIXEL x[ARB] # x array +PIXEL y[ARB] # y array +PIXEL w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclr$t (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_PIXEL) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_PIXEL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call $tcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call $tcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call $tcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call $tcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amul$t (w, y, Mem$t[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Mem$t[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Mem$t[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvrefitd.x b/math/curfit/cvrefitd.x new file mode 100644 index 00000000..2714beb6 --- /dev/null +++ b/math/curfit/cvrefitd.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +procedure dcvrefit (cv, x, y, w, ier) + +pointer cv # curve descriptor +double x[ARB] # x array +double y[ARB] # y array +double w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclrd (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_DOUBLE) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call dcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call dcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call dcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call dcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amuld (w, y, Memd[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Memd[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Memd[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvrefitr.x b/math/curfit/cvrefitr.x new file mode 100644 index 00000000..5de9abe2 --- /dev/null +++ b/math/curfit/cvrefitr.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +procedure cvrefit (cv, x, y, w, ier) + +pointer cv # curve descriptor +real x[ARB] # x array +real y[ARB] # y array +real w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclrr (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_REAL) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_REAL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call rcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call rcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call rcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call rcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amulr (w, y, Memr[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Memr[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Memr[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvreject.gx b/math/curfit/cvreject.gx new file mode 100644 index 00000000..bbaffef4 --- /dev/null +++ b/math/curfit/cvreject.gx @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +$if (datatype == r) +procedure cvrject (cv, x, y, w) +$else +procedure dcvrject (cv, x, y, w) +$endif + +pointer cv # curve fitting image descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +PIXEL bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrejectd.x b/math/curfit/cvrejectd.x new file mode 100644 index 00000000..903ef594 --- /dev/null +++ b/math/curfit/cvrejectd.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +procedure dcvrject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +double x # x value +double y # y value +double w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +double bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrejectr.x b/math/curfit/cvrejectr.x new file mode 100644 index 00000000..3f275cce --- /dev/null +++ b/math/curfit/cvrejectr.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +procedure cvrject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +real x # x value +real y # y value +real w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +real bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrestore.gx b/math/curfit/cvrestore.gx new file mode 100644 index 00000000..cfec56d7 --- /dev/null +++ b/math/curfit/cvrestore.gx @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +$if (datatype == r) +procedure cvrestore (cv, fit) +$else +procedure dcvrestore (cv, fit) +$endif + +pointer cv # curve descriptor +PIXEL fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + $if (datatype == r) + CV_USERFNCR(cv) = CV_SAVEFNC(fit) # avoids type conversion + $else + CV_USERFNCD(cv) = CV_SAVEFNC(fit) # avoids type conversion + $endif + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_PIXEL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_PIXEL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amov$t (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amov$t (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvrestored.x b/math/curfit/cvrestored.x new file mode 100644 index 00000000..e528c1f0 --- /dev/null +++ b/math/curfit/cvrestored.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +procedure dcvrestore (cv, fit) + +pointer cv # curve descriptor +double fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNCD(cv) = CV_SAVEFNC(fit) # avoids type conversion + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amovd (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amovd (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvrestorer.x b/math/curfit/cvrestorer.x new file mode 100644 index 00000000..859d434f --- /dev/null +++ b/math/curfit/cvrestorer.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +procedure cvrestore (cv, fit) + +pointer cv # curve descriptor +real fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNCR(cv) = CV_SAVEFNC(fit) # avoids type conversion + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amovr (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amovr (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsave.gx b/math/curfit/cvsave.gx new file mode 100644 index 00000000..95fedd2b --- /dev/null +++ b/math/curfit/cvsave.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +$if (datatype == r) +procedure cvsave (cv, fit) +$else +procedure dcvsave (cv, fit) +$endif + +pointer cv # curve descriptor +PIXEL fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + $if (datatype == r) + CV_SAVEFNC(fit) = CV_USERFNCR(cv) # no type conversion + $else + CV_SAVEFNC(fit) = CV_USERFNCD(cv) + $endif + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amov$t (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amov$t (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsaved.x b/math/curfit/cvsaved.x new file mode 100644 index 00000000..04cb7c8b --- /dev/null +++ b/math/curfit/cvsaved.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +procedure dcvsave (cv, fit) + +pointer cv # curve descriptor +double fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + CV_SAVEFNC(fit) = CV_USERFNCD(cv) + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amovd (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amovd (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsaver.x b/math/curfit/cvsaver.x new file mode 100644 index 00000000..513083a5 --- /dev/null +++ b/math/curfit/cvsaver.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +procedure cvsave (cv, fit) + +pointer cv # curve descriptor +real fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + CV_SAVEFNC(fit) = CV_USERFNCR(cv) # no type conversion + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amovr (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amovr (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvset.gx b/math/curfit/cvset.gx new file mode 100644 index 00000000..fed1cf46 --- /dev/null +++ b/math/curfit/cvset.gx @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +$if (datatype == r) +procedure cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) +$else +procedure dcvset (cv, curve_type, xmin, xmax, coeff, ncoeff) +$endif + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +PIXEL xmin # the minimum x value +PIXEL xmax # the maximum x value +PIXEL coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + $if (datatype == r) + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + $else + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + $endif + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amov$t (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsetd.x b/math/curfit/cvsetd.x new file mode 100644 index 00000000..c0f41f09 --- /dev/null +++ b/math/curfit/cvsetd.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +procedure dcvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +double xmin # the minimum x value +double xmax # the maximum x value +double coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amovd (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsetr.x b/math/curfit/cvsetr.x new file mode 100644 index 00000000..9a3ec193 --- /dev/null +++ b/math/curfit/cvsetr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +procedure cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +real xmin # the minimum x value +real xmax # the maximum x value +real coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amovr (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsolve.gx b/math/curfit/cvsolve.gx new file mode 100644 index 00000000..08e0bf92 --- /dev/null +++ b/math/curfit/cvsolve.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. + +$if (datatype == r) +procedure cvsolve (cv, ier) +$else +procedure dcvsolve (cv, ier) +$endif + + +pointer cv # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix +int nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call $tcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvsolved.x b/math/curfit/cvsolved.x new file mode 100644 index 00000000..ba61be19 --- /dev/null +++ b/math/curfit/cvsolved.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. + +procedure dcvsolve (cv, ier) + + +pointer cv # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix +int nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call dcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvsolver.x b/math/curfit/cvsolver.x new file mode 100644 index 00000000..b52f012e --- /dev/null +++ b/math/curfit/cvsolver.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. + +procedure cvsolve (cv, ier) + + +pointer cv # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix +int nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call rcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvstat.gx b/math/curfit/cvstat.gx new file mode 100644 index 00000000..e98367b9 --- /dev/null +++ b/math/curfit/cvstat.gx @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSTATI -- Return integer paramters from the curfit package + +$if (datatype == r) +int procedure cvstati (cv, param) +$else +int procedure dcvstati (cv, param) +$endif + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +$if (datatype == r) +PIXEL procedure cvstatr (cv, param) +$else +PIXEL procedure dcvstatd (cv, param) +$endif + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvstatd.x b/math/curfit/cvstatd.x new file mode 100644 index 00000000..fae7c87e --- /dev/null +++ b/math/curfit/cvstatd.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVSTATI -- Return integer paramters from the curfit package + +int procedure dcvstati (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +double procedure dcvstatd (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvstatr.x b/math/curfit/cvstatr.x new file mode 100644 index 00000000..ee5ef05b --- /dev/null +++ b/math/curfit/cvstatr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVSTATI -- Return integer paramters from the curfit package + +int procedure cvstati (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +real procedure cvstatr (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvvector.gx b/math/curfit/cvvector.gx new file mode 100644 index 00000000..eb005a1a --- /dev/null +++ b/math/curfit/cvvector.gx @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +$if (datatype == r) +procedure cvvector (cv, x, yfit, npts) +$else +procedure dcvvector (cv, x, yfit, npts) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # data x values +PIXEL yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call $tcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call $tcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call $tcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call $tcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvvectord.x b/math/curfit/cvvectord.x new file mode 100644 index 00000000..f23e988e --- /dev/null +++ b/math/curfit/cvvectord.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "dcurfitdef.h" + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +procedure dcvvector (cv, x, yfit, npts) + +pointer cv # curve descriptor +double x[npts] # data x values +double yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call dcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call dcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call dcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call dcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvvectorr.x b/math/curfit/cvvectorr.x new file mode 100644 index 00000000..b344ab84 --- /dev/null +++ b/math/curfit/cvvectorr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +include "curfitdef.h" + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +procedure cvvector (cv, x, yfit, npts) + +pointer cv # curve descriptor +real x[npts] # data x values +real yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call rcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call rcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call rcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call rcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvzero.gx b/math/curfit/cvzero.gx new file mode 100644 index 00000000..c6774758 --- /dev/null +++ b/math/curfit/cvzero.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +$if (datatype == r) +procedure cvzero (cv) +$else +procedure dcvzero (cv) +$endif + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclr$t (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclr$t (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + $if (datatype == r) + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + $else + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + $endif + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/cvzerod.x b/math/curfit/cvzerod.x new file mode 100644 index 00000000..f9395fc1 --- /dev/null +++ b/math/curfit/cvzerod.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +procedure dcvzero (cv) + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclrd (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclrd (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/cvzeror.x b/math/curfit/cvzeror.x new file mode 100644 index 00000000..bd84029f --- /dev/null +++ b/math/curfit/cvzeror.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +procedure cvzero (cv) + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclrr (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclrr (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/dcurfitdef.h b/math/curfit/dcurfitdef.h new file mode 100644 index 00000000..ab611450 --- /dev/null +++ b/math/curfit/dcurfitdef.h @@ -0,0 +1,54 @@ +# Header file for the curve fitting package + +# set up the curve descriptor structure + +define LEN_CVSTRUCT 30 + +define CV_XMAX Memd[P2D($1)] # Maximum x value +define CV_XMIN Memd[P2D($1+2)] # Minimum x value +define CV_RANGE Memd[P2D($1+4)] # 2. / (xmax - xmin), polynomials +define CV_MAXMIN Memd[P2D($1+6)] # - (xmax + xmin) / 2., polynomials +define CV_SPACING Memd[P2D($1+8)] # order / (xmax - xmin), splines +define CV_USERFNCD Memd[P2D($1+10)]# Real version of above for cvrestore. +define CV_TYPE Memi[$1+12] # Type of curve to be fitted +define CV_ORDER Memi[$1+13] # Order of the fit +define CV_NPIECES Memi[$1+14] # Number of polynomial pieces - 1 +define CV_NCOEFF Memi[$1+15] # Number of coefficients +define CV_NPTS Memi[$1+16] # Number of data points + +define CV_XBASIS Memi[$1+17] # Pointer to non zero basis for single x +define CV_MATRIX Memi[$1+18] # Pointer to original matrix +define CV_CHOFAC Memi[$1+19] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+20] # Pointer to vector +define CV_COEFF Memi[$1+21] # Pointer to coefficient vector +define CV_BASIS Memi[$1+22] # Pointer to basis functions (all x) +define CV_LEFT Memi[$1+23] # Pointer to first non-zero basis +define CV_WY Memi[$1+24] # Pointer to y * w (cvrefit) +define CV_USERFNC Memi[$1+25] # Pointer to external user subroutine + # one free slot left + +# matrix and vector element definitions + +define XBASIS Memd[$1] # Non zero basis for single x +define MATRIX Memd[$1] # Element of MATRIX +define CHOFAC Memd[$1] # Element of CHOFAC +define VECTOR Memd[$1] # Element of VECTOR +define COEFF Memd[$1] # Element of COEFF +define BASIS Memd[$1] # Element of BASIS +define LEFT Memi[$1] # Element of LEFT + +# structure definitions for restore + +define CV_SAVETYPE $1[1] +define CV_SAVEORDER $1[2] +define CV_SAVEXMIN $1[3] +define CV_SAVEXMAX $1[4] +define CV_SAVEFNC $1[5] + +define CV_SAVECOEFF 5 + +# miscellaneous + +define SPLINE3_ORDER 4 +define SPLINE1_ORDER 2 +define DELTA EPSILON diff --git a/math/curfit/doc/curfit.hd b/math/curfit/doc/curfit.hd new file mode 100644 index 00000000..b8a00640 --- /dev/null +++ b/math/curfit/doc/curfit.hd @@ -0,0 +1,24 @@ +# Help directory for the CURFIT (curve fitting) package. + +$curfit = "math$curfit/" + +cvaccum hlp = cvaccum.hlp, src = curfit$cvaccum.gx +cvacpts hlp = cvacpts.hlp, src = curfit$cvacpts.gx +cvcoeff hlp = cvcoeff.hlp, src = curfit$cvcoeff.gx +cvepower hlp = cvepower.hlp, src = curfit$cvepower.gx +cverrors hlp = cverrors.hlp, src = curfit$cverrors.gx +cveval hlp = cveval.hlp, src = curfit$cveval.gx +cvinit hlp = cvinit.hlp, src = curfit$cvinit.gx +cvfit hlp = cvfit.hlp, src = curfit$cvfit.gx +cvfree hlp = cvfree.hlp, src = curfit$cvfree.gx +cvpower hlp = cvpower.hlp, src = curfit$cvpower.gx +cvrefit hlp = cvrefit.hlp, src = curfit$cvrefit.gx +cvreject hlp = cvreject.hlp, src = curfit$cvreject.gx +cvrestore hlp = cvrestore.hlp, src = curfit$cvrestore.gx +cvsave hlp = cvsave.hlp, src = curfit$cvsave.gx +cvsolve hlp = cvsolve.hlp, src = curfit$cvsolve.gx +cvstati hlp = cvstati.hlp, src = curfit$cvstat.gx +cvstatr hlp = cvstatr.hlp, src = curfit$cvstat.gx +cvvector hlp = cvvector.hlp, src = curfit$cvvector.gx +cvzero hlp = cvzero.hlp, src = curfit$cvzero.gx +cvset hlp = cvset.hlp, src = curfit$cvset.gx diff --git a/math/curfit/doc/curfit.hlp b/math/curfit/doc/curfit.hlp new file mode 100644 index 00000000..35950c08 --- /dev/null +++ b/math/curfit/doc/curfit.hlp @@ -0,0 +1,163 @@ +.help curfit Jul84 "Math Package" +.ih +NAME +curfit -- curve fitting package +.ih +SYNOPSIS + +.nf + cvinit (cv, curve_type, order, xmin, xmax) + cvzero (cv) + cvaccum (cv, x, y, weight, wtflag) + cvreject (cv, x, y, weight) + cvsolve (cv, ier) + cvfit (cv, x, y, weight, npts, wtflag, ier) + cvrefit (cv, x, y, weight, ier) + y = cveval (cv, x) + cvvector (cv, x, yfit, npts) + cvcoeff (cv, coeff, ncoeff) + cverrors (cv, y, weight, yfit, rms, errors) + cvsave (cv, fit) + cvstati (cv, parameter, ival) + cvstatr (cv, parameter, ival) + cvrestore (cv, fit) + cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + cvfree (cv) +.fi +.ih +DESCRIPTION +The curfit package provides a set of routines for fitting data to functions +linear in their coefficients using least squares techniques. The numerical +technique employed is the solution of the normal equations by the +Cholesky method. +.ih +NOTES +The fitting function curve_type is chosen at run time from the following +list. + +.nf + LEGENDRE # Legendre polynomials + CHEBYSHEV # Chebyshev polynomials + SPLINE3 # cubic spline with uniformly spaced break points + SPLINE1 # linear spline with uniformly spaced break points +.fi + + +The CURFIT package performs a weighted fit. +The weighting options are WTS_USR, WTS_UNIFORM and WTS_SPACING. +The user must supply a weight array. In WTS_UNIFORM mode the curfit +routines set the weights to 1. In WTS_USER mode the user must supply an +array of weight values. +In WTS_SPACING mode +the weights are set to the difference between adjacent data points. +The data must be sorted in x in order to use the WTS_SPACING mode. +In WTS_UNIFORM mode the reduced chi-squared returned by CVERRORS +is the variance of the fit and the errors in the coefficients are scaled +by the square root of this variance. Otherwise the weights are +interpreted as one over the variance of the data and the true reduced +chi-squared is returned. + +The routines assume that all the x values of interest lie in the region +xmin <= x <= xmax. Checking for out of bounds x values is the responsibility +of the calling program. The package routines assume that INDEF values +have been removed from the data set prior to entering the package +routines. + +In order to make the package definitions available to the calling program +an include statement must be included in the user program. +CVINIT must be called before each fit. CVFREE frees space used by the +CURFIT package. +.ih +EXAMPLES +.nf +Example 1: Fit curve to data, unifrom weighting + + include + + ... + + call cvinit (cv, CHEBYSHEV, 4, 1., 512.) + + call cvfit (cv, x, y, weight, 512, WTS_UNIFORM, ier) + if (ier != OK) + call error (...) + + do i = 1, 512 { + x = i + call printf ("%g %g\n") + call pargr (x) + call pargr (cveval (cv, x)) + } + + call cvfree (cv) + + +Example 2: Fit curve using accumulate mode, weight based on spacing + + include + + ... + + old_x = x + do i = 1, 512 { + x = real (i) + if (y[i] != INDEF) { + call cvaccum (cv, x, y, weight, x - old_x, WTS_USER) + old_x = x + } + } + + call cvsolve (cv, ier) + if (ier != OK) + call error (...) + + ... + + call cvfree (cv) + + +Example 3: Fit and subtract smooth curve from image lines + + include + + ... + + call cvinit (cv, CHEBYSHEV, order, 1., 512.) + + do line = 1, nlines { + inpix = imgl2r (im, line) + outpix = impl2r (im, line) + if (line == 1) + call cvfit (cv, x, Memr[inpix], weight, 512, WTS_UNIFORM, ier) + else + call cvrefit (cv, x, Memr[inpix], weight, ier) + if (ier != OK) + ... + call cvvector (cv, x, y, 512) + call asubr (Memr[inpix], y, Memr[outpix], 512) + } + + call cvfree (cv) + + +Example 4: Fit curve, save fit for later use by CVEVAL. LEN_FIT must be a least + order + 7 elements long. + + include + + real fit[LEN_FIT] + + ... + call cvinit (cv, CHEBYSHEV, order, xmin, xmax) + call cvfit (cv, x, y, w, npts, WTS_UNIFORM, ier) + if (ier != OK) + ... + call cvsave (cv, fit) + call cvfree (cv) + ... + call cvrestore (cv, fit) + do i = 1, npts + yfit[i] = cveval (cv, x[i]) + call cvfree (cv) + ... +.fi diff --git a/math/curfit/doc/curfit.men b/math/curfit/doc/curfit.men new file mode 100644 index 00000000..b061badc --- /dev/null +++ b/math/curfit/doc/curfit.men @@ -0,0 +1,20 @@ + cvaccum - Accumulate point into data set + cvacpts - Accumulate points into a data set + cvcoeff - Get coefficients + cvepower - Convert errors to power series equivalents + cverrors - Calculate chi-squared and errors in coefficients + cveval - Evaluate curve at x + cvfit - Fit curve + cvfree - Free space allocated by cvinit + cvinit - Make ready to fit a curve; set up parameters of fit + cvpower - Convert coefficients to power series coefficients + cvrefit - Refit curve, same x and weight, different y + cvreject - Reject point from data set + cvrestore - Restore curve parameters and coefficients + cvsave - Save curve parameters and coefficients + cvset - Input coefficients derived external to the CURFIT package + cvsolve - Solve matrix for coefficients + cvstati - Get integer parameter + cvstatr - Get real parameter + cvvector - Evaluate curve at an array of x + cvzero - Zero arrays for new fit diff --git a/math/curfit/doc/curfit.spc b/math/curfit/doc/curfit.spc new file mode 100644 index 00000000..f5e555a3 --- /dev/null +++ b/math/curfit/doc/curfit.spc @@ -0,0 +1,479 @@ +.help curfit May84 "Math Package" +.ce +Specifications for the Curfit Package +.ce +Lindsey Davis +.ce +July 1984 + +.sh +1. Introduction + +The CURFIT package provides a set of routines for fitting data to +functions linear in their coefficients using least +squares techniques. The basic numerical technique employed +is the solution of the normal equations by the Cholesky method. +This document presents the formal requirements for the package +and describes the algorithms used. + +.sh +2. Requirements + +.ls 4 +.ls (1) +The package shall take as input a set of x and y values and their +corresponding weights. The package routines asssume that data values +equal to INDEF have been rejected from the data set or replaced with +appropriate interpolated values prior to entering the package +routines. The input data may be arbitrarily spaced in x. No assumptions +are made about the ordering of the x values, but see (3) below. +.le +.ls (2) +The package shall perform the following operations: +.ls o +Determine the coefficients of the fitting function by solving the normal +equations. The fitting function is selected at run time from the following +list: (1) LEGENDRE, Legendre polynomials, (2) CHEBYSHEV, +Chebyshev polynomials, (3) SPLINE3, Cubic spline +with uniformly spaced break points, SPLINE1, Linear spline with evenly +spaced break points. The calling sequence must be +invariant to the form of the fitting function. +.le +.ls o +Set an error code if the numerical routines are unable to fit the +specified function. +.le +.ls o +Output the values of the coefficients. +The coefficients are stored internal to the CURFIT package. +However in some applications it is the coefficients which are of primary +interest. A package routine shall exist to extract the +the coefficients from the curve descriptor structure. +.le +.ls o +Evaluate the fitting function at arbitrary value(s) of x. The evaluating +routines shall use the coefficients calculated and +the user supplied x value(s). +.le +.ls o +Calculate the standard deviation of the coefficients and the standard deviation +of the fit. +.le +.le +.ls (3) +The program shall perform a weighted fit using a user supplied weight +array and weight flag. The weighting options are WTS_USER, WTS_UNIFORM and +WTS_SPACING. In WTS_USER mode the package routines apply user supplied +weights to the individual data points, otherwise the package routines +calculate the weights. In WTS_SPACING mode the program assumes that the data +are sorted in x, and sets the individual weights to the difference between +adjacent x values. In WTS_UNIFORM mode the weights are set to 1. +.le +.ls (4) +The input data set and output coefficent, error, and fitted y arrays are single +precision real quantities. All package arithmetic shall be done in single +precision. The package shall however be designed with +conversion to double precision arithmetic in mind. +.le +.le + +.sh +3. Specifications + +.sh +3.1. List of Routines + +The package prefix will be cv for curve fit. +The following procedures shall be part of the package. +Detailed documentation for each procedure can be found by invoking +the help facility. + +.nf + cvinit (cv, curvetype, order, xmin, xmax) + cvzero (cv) + cvaccum (cv, x, y, w, wtflag) + cvreject (cv, x, y, w) + cvsolve (cv, ier) + cvfit (cv, x, y, w, npts, wtflag, ier) + cvrefit (cv, x, y, w, ier) + y = cveval (cv, x) + cvvector (cv, x, yfit, npts) + cvcoeff (cv, coeff, ncoeff) + cverrors (cv, y, w, yfit, rms, errors) + cvsave (cv, fit) + cvrestore (cv, fit) + cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + cvfree (cv) +.fi + +.sh +3.2. Algorithms + +.sh +3.2.1. Polynomial Basis Functions + +The approximating function is assumed to be of the form + +.nf + f(x) = a(1)*F(1,x) + a(2)*F(2,x) + ... + a(ncoeff)*F(ncoeff,x) +.fi + +where the F(n,x) are polynomial basis functions containing terms +of order x**(n-1), and the a(n) are the coefficients. +In order to avoid a very ill-conditioned linear system for moderate or large n +the Legendre and Chebyshev polynomials were chosen for the basis functions. +The Chebyshev and Legendre polynomials are +orthogonal over -1. <= x <= 1. The data x values are normalized to +this regime using minimum and maximum x values supplied by the user. +For each data point the ncoeff basis functions are calculated using the +following recursion relations. + +.nf + Legendre series + F(1,x) = 1. + F(2,x) = x + F(n,x) = [(2*n-3)*x*F(n-1,x)-(n-2)*F(n-2,x)]/(n-1) + + Chebyshev series + F(1,x) = 1. + F(2,x) = x + F(n,x) = 2*x*F(n-1,x)-F(n-2,x) +.fi + +.sh +3.2.2. Cubic Cardinal B-Spline + +The approximating function is assumed to be of the form + +.nf + f(x) = a(1)*F(1,x) + a(2)*F(2,x) + ... a(ncoeff)*F(ncoeff,x) +.fi + +where the basis functions, F(n, x), are the cubic cardinal B-splines +(Prenter 1975). +The user supplies minimum and maximum x values and the number of polynomial +pieces, npieces, to be fit to the data set. The number of cubic spline +coefficents, ncoeff, will be + +.nf + ncoeff = npieces + 3 +.fi + +The cardinal B-spline is stored in a lookup table. For each x the appropriate +break point is selected and the four non-zero B-splines are calculated by +nearest neighbour interpolation in the lookup table. + +.sh +3.2.3. The Normal Equations + +The coefficients, a, are determined by the solution of the normal equations + +.nf + c * a = b +.fi + +where + +.nf + c[i,j] = (F(i,x), F(j,x)) + b[j] = (F(j,x), f(x)) +.fi + +F(i,x) is the ith basis function at x, f(x) is the function to be +approximated and the inner product of two functions G and H, (G,H), +is given by + +.nf + (G, H) = sum (G(x[i]) * H(x[i]) * weight[i]) i=1,...npts +.fi + +The resulting matrix is symmetric and positive semi-definite. +Therefore it is necessary to store the ncoeff bands at or below the +diagonal. Storage is particularly efficient for the cubic spline +as only the diagonal and three adjacent lower bands are non-zero +(deBoor 1978). + +.sh +3.2.4. Method of Solution + +Since the matrix is symmetric, positive semi-definite and banded +it may be solved by the Cholesky method. The data matrix c may be +written as + +.nf + c = l * d * l-transpose +.fi + +where l is a unit lower triangular matrix and d is the diagonal of c +(deBoor 1978). Near zero pivots are handled in the following way. +At the nth elimination step the current value of the nth diagonal +element is compared with the original nth diagonal element. If the diagonal +element has been reduced by one computer word length, the entire nth +row is declared linearly dependent on the previous n-1 rows and +a(n) = 0. + +The triangular system + +.nf + l * w = b +.fi + +is solved for w (forward substitution), the vector d ** (-1) * w +is computed and the triangular system + +.nf + l-transpose * a = d ** (-1) * w +.fi + +solved for the coefficients, a (backward substitution). + +.sh +3.2.5. Errors + +The reduced ch-squared of the fit is defined as the weighted sum of +the squares of the residuals divided by the number of degrees of +freedom. + +.nf + rms = sqrt (sum (weight * (y - yfit) ** 2) / nfree) + nfree = npts - ncoeff +.fi + +The error of the j-th coefficient, error[j], is equal to the square root +of the j-th diagonal element of inverse data matrix times a scale factor. + +.nf + error[j] = sqrt (c[j,j]-inverse) * scale +.fi + +The scale factor is the square root of the variance of the data when +all the weights are equal, otherwise scale is one. + +.sh +4. Usage + +.sh +4.1. User Notes + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Insert an include statement in the calling program to +make the CURFIT package definitions available to the user program. +.le +.ls (2) +Call CVINIT to initialize the curve fitting parameters. +.le +.ls (3) +Call CVACCUM to select a weighting function +and accumulate data points into the appropriate arrays and vectors. +.le +.ls (4) +Call CVSOLVE to solve the normal equations and calculate the coefficients +of the fitting function. Test for an error condition. +.le +.ls (5) +Call CVEVAL or CVVECTOR to evaluated the fitted function at the +x value(s) of interest. +.le +.ls (6) +Call CVCOEFF to fetch the number and value of the coefficients of the fitting +function. +.le +.ls (7) +Call CVERRORS to calculate the standard deviations in the +coefficients and the standard deviation of the fit. +.le +.ls (8) +Call CVFREE to release the space allocated for the fit. +.le +.le + +Steps (2) and (3) may be combined in a single step by calling CVFIT +and inputting an array of x, y and weight values. Individual points may +be rejected from the fit by calling CVREJECT and CVSOLVE to determine +a new set of coefficients. If the x and weight values remain the same +and only the y values change from fit to fit, CVREFIT can be called. + + +.sh +4.2. Examples + +.nf +Example 1: Fit curve to data, no weighting + + include + ... + call cvinit (cv, CHEBYSHEV, 4, 1., 512.) + + call cvfit (cv, x, y, w, 512, WTS_UNIFORM, ier) + if (ier != OK) + call error (...) + + do i = 1, 512 { + x = i + call printf ("%g %g\n") + call pargr (x) + call pargr (cveval (cv, x)) + } + + call cvfree (cv) + +Example 2: Fit curve using accumulate mode, weight based on spacing + + include + ... + call cvinit (cv, SPLINE3, npolypieces, 1., 512.) + + old_x = 0.0 + do i =1, 512 { + x = real (i) + if (y[i] != INDEF) { + call cvaccum (cv, x, y, x - old_x, WTS_USER) + old_x = x + } + } + + call cvsolve (cv, ier) + if (ier != OK) + call error (...) + ... + call cvfree (cv) + +Example 3: Fit and subtract smooth curve from image lines + + include + ... + call cvinit (cv, CHEBYSHEV, order, 1., 512.) + + do line = 1, nlines { + inpix = imgl2r (im, line) + outpix = impl2r (im, line) + if (line == 1) + call cvfit (cv, x, Memr[inpix], w, 512, WTS_USER, ier) + else + call cvrefit (cv, x, Memr[inpix], w, WTS_USER, ier) + if (ier != OK) + ... + call cvvector (cv, x, y, 512) + call asubr (Memr[inpix], y, Memr[outpix], 512) + } + + call cvfree (cv) + +Example 4: Fit curve and save parameters for later use by CVEVAL + Fit must be at least order + 7 elements long. + + include + + real fit[LEN_FIT) + ... + call cvinit (cv, LEGENDRE, order, xmin, xmax) + call cvfit (cv, x, y, w, npts, WTS_UNIFORM, ier) + if (ier != OK) + ... + call cvsave (cv, fit) + call cvfree (cv) + ... + call cvrestore (cv, fit) + do i = 1, npts + yfit[i] = cveval (cv, x[i]) + call cvfree (cv) + ... + +.fi + +.sh +5. Detailed Design + +.sh +5.1. Curve Descriptor Structure + +The CURFIT parameters, and the +size and location of the arrays and vectors used in the fitting procedure +are stored in the curve descriptor structure. The structure is referenced +by the pointer cv returned by the CVINIT routine. The curve +descriptor structure is defined in the package +header file curfit.h. The structure is listed below. + +.nf +define LEN_CVSTRUCT 17 + +# CURFIT parameters + +define CV_TYPE Memi[$1] # Type of curve to be fitted +define CV_ORDER Memi[$1+1] # Order of the fit +define CV_NPIECES Memi[$1+2] # Number of polynomial pieces (spline) +define CV_NCOEFF Memi[$1+3] # Number of coefficients +define CV_XMAX Memr[$1+4] # Maximum x value +define CV_XMIN Memr[$1+5] # Minimum x value +define CV_RANGE Memr[$1+6] # Xmax minus xmin +define CV_MAXMIN Memr[$1+7] # Xmax plus xmin +define CV_SPACING Memr[$1+8] # Break point spacing (spline) +define CV_NPTS Memi[$1+9] # Number of data points + +# Pointers to storage arrays and vectors + +define CV_XBASIS Memi[$1+10] # Basis functions single x +define CV_MATRIX Memi[$1+11] # Pointer to matrix +define CV_CHOFAC Memi[$1+12] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+13] # Pointer to vector +define CV_COEFF Memi[$1+14] # Pointer to coefficient vector + +# Used only by CVREFIT + +define CV_BASIS Memi[$1+15] # Pointer to basis functions all x +define CV_LEFT Memi[$1+16] # Pointer to index array (spline) +.fi + +.sh +5.2. Storage Requirements + +The storage requirements are listed below. + +.ls 4 +.ls real MATRIX[order,ncoeff] +The real array, matrix, stores the original accumulated data. Storage of this +array is required by the CURFIT routines CVACCUM and CVREJECT which accumulate +and reject individual points from the data set respectively. If the fitting +function is SPLINE3 then order = 4, otherwise order = ncoeff. +.le +.ls real CHOFAC[order, ncoeff] +The real array chofac stores the Cholesky factorization of matrix. +Storage of CHOFAC is required by the CURFIT routines CVERRORS and +CVREFIT. +.le +.ls real VECTOR[ncoeff] +Ncoeff real storage units must be allocated for the vector containing +the right side of the matrix equation. VECTOR is stored for use by the +CVREJECT and CVACCUM routines. Vector is zeroed before every CVREFIT call. +.le +.ls real COEFF[ncoeff] +The coefficients of the fitted function must be stored for use by +the CVEVAL, CVVECTOR, and CVCOEFF routines. +.le +.ls real BASIS[order,npts] +Space is allocated for the basis functions only if the routine CVREFIT is +called. The first call to CVREFIT generates an array of basis functions and +subsequent calls reference the array. +.le +.ls int LEFT[npts] +Space for the array left is allocated only if +CVREFIT is called. The array indicates to which element of +the matrix a given spline function should be accumulated. +.le +.le + +.sh +6. References + +.ls (1) +Carl de Boor, "A Practical Guide to Splines", 1978, Springer-Verlag New +York Inc. +.le +.ls (2) +P.M. Prenter, "Splines and Variational Methods", 1975, John Wiley and Sons +Inc. +.le +.endhelp diff --git a/math/curfit/doc/cvaccum.hlp b/math/curfit/doc/cvaccum.hlp new file mode 100644 index 00000000..4fc3a37b --- /dev/null +++ b/math/curfit/doc/cvaccum.hlp @@ -0,0 +1,51 @@ +.help cvaccum Jun84 "Curfit Package" +.ih +NAME +cvaccum -- accumulate a single data point into the matrix +.ih +SYNOPSIS +include + +cvaccum (cv, x, y, weight, wtflag) + +.nf +pointer cv # curve descriptor +real x # x value +real y # y value +real weight # weight +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value. Checking for out of bounds x values is the responsibility of the +user. +.le +.ls y +Y value. +.le +.ls weight +Weight assigned to the data point. +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_UNIFORM or WTS_SPACING. +If wtflag equals WTS_USER the weight for each point is supplied by the user. +If wtflag is either WTS_UNIFORM or WTS_SPACING the routine sets weight +to one. +.le +.ih +DESCRIPTION +Calculate the non-zero basis functions for the given value of x. +Compute the contribution of the data point to the normal equations and +sum into the appropriate arrays and vectors. +.ih +NOTES +The WTS_SPACING option cannot be used with CVACCUM. Weights will be set +to 1. +.ih +SEE ALSO +cvfit, cvrefit +.endhelp diff --git a/math/curfit/doc/cvacpts.hlp b/math/curfit/doc/cvacpts.hlp new file mode 100644 index 00000000..c5a6cffd --- /dev/null +++ b/math/curfit/doc/cvacpts.hlp @@ -0,0 +1,54 @@ +.help cvacpts Jun84 "Curfit Package" +.ih +NAME +include + +cvacpts -- fit a curve to a set of data values +.ih +SYNOPSIS +cvacpts (cv, x, y, weight, npts, wtflag) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int npts # number of data points +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values. +.le +.ls y +Array of y values +.le +.ls weight +Array of weights +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_SPACING and +WTS_UNIFORM. If wtflag = WTS_USER individual weights for each data point +are supplied by the calling program and points with zero-valued weights are +not included in the fit. If wtflag = WTS_UNIFORM, all weights are assigned +values of 1. If wtflag = WTS_SPACING, the weights are set equal to the +difference between adjacent data points. In order to correctly use the +WTS_SPACING option the data must be sorted in x. +.le +.ih +DESCRIPTION +CVACPTS zeroes the matrix and vectors, calculates the non-zero basis functions, +calculates the contribution +of each data point to the normal equations and accumulates it into the +appropriate array and vector elements. +.ih +NOTES +Checking for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvaccum +.endhelp diff --git a/math/curfit/doc/cvcoeff.hlp b/math/curfit/doc/cvcoeff.hlp new file mode 100644 index 00000000..6467cd60 --- /dev/null +++ b/math/curfit/doc/cvcoeff.hlp @@ -0,0 +1,36 @@ +.help cvcoeff Jun84 "Curfit Package" +.ih +NAME +cvcoeff -- get the number and values of the coefficients +.ih +SYNOPSIS +cvcoeff (cv, coeff, ncoeff) + +.nf +pointer cv # curve descriptor +real coeff[] # the coefficient array +int ncoeff # the number of coefficients +.fi +.ih +ARGUMENTS +.ls pointer +Pointer to the curve descriptor. +.le +.ls coeff +Array of coefficients. +.le +.ls ncoeff +The number of coefficients. +.le +.ih +DESCRIPTION +CVCOEFF fetches the coefficient array and the number of coefficients from the +curve descriptor structure. +.ih +NOTES +The variable ncoeff is only equal to the order specified in CVINIT if the +curve_type is LEGENDRE or CHEBYSHEV. If curve_type is SPLINE3 then +ncoeff = order + 3. If curve_type is SPLINE1 then ncoeff = order + 1. +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cvepower.hlp b/math/curfit/doc/cvepower.hlp new file mode 100644 index 00000000..58e78dae --- /dev/null +++ b/math/curfit/doc/cvepower.hlp @@ -0,0 +1,55 @@ +.help cvepower Jun95 "Curfit Package" +.ih +NAME +cvepower -- compute the errors of the equivalent power series +.ih +SYNOPSIS +cvepower (cv, y, weight, yfit, npts, chisqr, errors) + +.nf +pointer cv # curve descriptor +real y[] # array of y data points +weight weight[] # array of weights +real yfit[] # array of fitted data points +int npts # number of points +real chisqr # the standard deviation of the fit +real errors[] # standard deviations of the power series coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure +.le +.ls y +Array of y data points +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of points +.le +.ls chisqr +Reduced chi-squared of the fit. +.le +.ls errors +Array of standard deviations of the equivalent power series coefficients. +.le +.ih +DESCRIPTION +Calculate the reduced chi-squared of the fit and the standard deviation +of the equivalent power series coefficients for fitted Legendre and +Chebyshev polynomials. The errors are rescaled to the equivalent power +series and to the original data range. +.ih +NOTES +The standard deviation of the fit is the square root of the sum of the +weighted squares of the residuals divided by the number of degrees of freedom. +If the weights are equal, then the reduced chi-squared is the +variance of the fit +The error of the j-th coefficient is the square root of the j-th diagonal +element of the inverse of the data matrix. If the weights are equal to one, +then the errors are scaled by the square root of the variance of the data. +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cverrors.hlp b/math/curfit/doc/cverrors.hlp new file mode 100644 index 00000000..a0a0fbb2 --- /dev/null +++ b/math/curfit/doc/cverrors.hlp @@ -0,0 +1,53 @@ +.help cverrors Jun84 "Curfit Package" +.ih +NAME +cverrors -- calculate the standard deviation of the fit and errors +.ih +SYNOPSIS +cverrors (cv, y, weight, yfit, npts, chisqr, errors) + +.nf +pointer cv # curve descriptor +real y[] # array of y data points +weight weight[] # array of weights +real yfit[] # array of fitted data points +int npts # number of points +real chisqr # the standard deviation of the fit +real errors[] # standard deviations of the coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure +.le +.ls y +Array of y data points +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of points +.le +.ls chisqr +Reduced chi-squared of the fit. +.le +.ls errors +Array of standard deviations of the coefficients. +.le +.ih +DESCRIPTION +Calculate the reduced chi-squared of the fit and the standard deviation +of the coefficients. +.ih +NOTES +The standard deviation of the fit is the square root of the sum of the +weighted squares of the residuals divided by the number of degrees of freedom. +If the weights are equal, then the reduced chi-squared is the +variance of the fit +The error of the j-th coefficient is the square root of the j-th diagonal +element of the inverse of the data matrix. If the weights are equal to one, +then the errors are scaled by the square root of the variance of the data. +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cveval.hlp b/math/curfit/doc/cveval.hlp new file mode 100644 index 00000000..48cd7f10 --- /dev/null +++ b/math/curfit/doc/cveval.hlp @@ -0,0 +1,33 @@ +.help cveval Jun84 "Curfit Package" +.ih +NAME +cveval -- evaluate the fitted function at a single x value +.ih +SYNOPSIS +y = cveval (cv, x) + +.nf +pointer cv # curve descriptor +real x # x value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value at which the curve is to be evaluated. +.le +.ih +DESCRIPTION +Evaluate the curve at the specified value of x. CVEVAL is a real +function which returns the fitted y value. +.ih +NOTES +It uses the coefficient array stored in the curve descriptor structure. +The x values are assumed to lie in the region xmin <= x <= xmax. Checking +for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvvector +.endhelp diff --git a/math/curfit/doc/cvfit.hlp b/math/curfit/doc/cvfit.hlp new file mode 100644 index 00000000..cb6beb24 --- /dev/null +++ b/math/curfit/doc/cvfit.hlp @@ -0,0 +1,62 @@ +.help cvfit Jun84 "Curfit Package" +.ih +NAME +cvfit -- fit a curve to a set of data values +.ih +SYNOPSIS +cvfit (cv, x, y, weight, npts, wtflag, ier) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values. +.le +.ls y +Array of y values +.le +.ls weight +Array of weights +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_SPACING and +WTS_UNIFORM. If wtflag = WTS_USER individual weights for each data point +are supplied by the calling program and points with zero-valued weights are +not included in the fit. If wtflag = WTS_UNIFORM, all weights are assigned +values of 1. If wtflag = WTS_SPACING, the weights are set equal to the +difference between adjacent data points. In order to correctly use the +WTS_SPACING option the data must be sorted in x. +.le +.ls ier +Error code for the fit. The options are OK, SINGULAR and +NO_DEG_FREEDON. If ier = SINGULAR, the numerical routines will compute a +solution but one or more of the coefficients will be +zero. If ier = NO_DEG_FREEDOM, there were too few data points to solve the +matrix equations and the routine returns without fitting the data. +.le +.ih +DESCRIPTION +CVFIT zeroes the matrix and vectors, calculates the non-zero basis functions, +calculates the contribution +of each data point to the normal equations and accumulates it into the +appropriate array and vector elements. The Cholesky factorization of the +data array is computed and the coefficients of the fitting function are +calculated. +.ih +NOTES +Checking for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvrefit, cvaccum, cvsolve, cvchofac, cvcholsv +.endhelp diff --git a/math/curfit/doc/cvfree.hlp b/math/curfit/doc/cvfree.hlp new file mode 100644 index 00000000..c486b306 --- /dev/null +++ b/math/curfit/doc/cvfree.hlp @@ -0,0 +1,26 @@ +.help cvfree Jun84 "Curfit Package" +.ih +NAME +cvfree -- free the curve descriptor structure +.ih +SYNOPSIS +cvfree (cv) + +.nf +pointer cv # curve descriptor +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ih +DESCRIPTION +Frees the curve descriptor structure. +.ih +NOTES +CVFREE should be called after each curve fit. +.ih +SEE ALSO +cvinit +.endhelp diff --git a/math/curfit/doc/cvinit.hlp b/math/curfit/doc/cvinit.hlp new file mode 100644 index 00000000..dc891ed2 --- /dev/null +++ b/math/curfit/doc/cvinit.hlp @@ -0,0 +1,55 @@ +.help cvinit Jun84 "Curfit Package" +.ih +NAME +cvinit -- initialise curve descriptor +.ih +SYNOPSIS +include + +cvinit (cv, curve_type, order, xmin, xmax) + +.nf +pointer cv # curve descriptor +int curve_type # the fitting function +int order # order of the fit +real xmin # minimum x value +real xmax # maximum x value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls curve_type +Fitting function. +Permitted values are LEGENDRE and CHEBYSHEV, for Legendre and +Chebyshev polynomials and SPLINE3 and SPLINE1 for a cubic spline +and linear spline with uniformly spaced +break points. +.le +.ls order +Order of the polynomial to be fit or the number of polynomial pieces +to be fit by a cubic spline. Order must be greater than or equal to one. +If curve_type is set to LEGENDRE or CHEBYSHEV and order equals one, a constant +term is fit to the data. +.le +.ls xmax, xmin +Minimum and maximum x values. All x values of interest +including the data x values and the x values of any curve to be evaluated +must fall in the range xmin <= x <= xmax. Checking for out of bounds x +values is the responsibility of user. +.le +.ih +DESCRIPTION +Allocate space for the curve descriptor structure and the arrays and +vectors used by the numerical routines. Initialize all arrays and vectors +to zero. Return the +curve descriptor to the calling routine. +.ih +NOTES +CVINIT must be the first CURFIT routine called. CVINIT returns if an +illegal curve type is requested. +.ih +SEE ALSO +cvfree +.endhelp diff --git a/math/curfit/doc/cvpower.hlp b/math/curfit/doc/cvpower.hlp new file mode 100644 index 00000000..386558ce --- /dev/null +++ b/math/curfit/doc/cvpower.hlp @@ -0,0 +1,40 @@ +.help cvpower Jan86 "Curfit Package" +.ih +NAME +cvpower -- convert coefficients to power series coefficients. +.ih +SYNOPSIS +.nf +include +include "curfitdef.h" + +cvpower (cv, ps_coeff, ncoeff) + +pointer cv # Curve descriptor +real ps_coeff[ncoeff] # Power series coefficients +int ncoeff # Number of coefficients in fit +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls ps_coeff +The output array of power series coefficients. +.le +.ls ncoeff +The output number of coefficients in the fit. +.le +.ih +DESCRIPTION +This routine routines the equivlalent power series fit coefficients +and the number of coefficients. + +The coefficients of either a legendre or chebyshev solution can be converted +to power series coefficients of the form y = a0 + a1*x + a2*x**2 + a3*x**3... +The output coefficients are scaled to the original data range. +.ih +NOTES +Only legendre and chebyshev coefficients are converted. An error is +reported for other curve types. +.endhelp diff --git a/math/curfit/doc/cvrefit.hlp b/math/curfit/doc/cvrefit.hlp new file mode 100644 index 00000000..4612b4c6 --- /dev/null +++ b/math/curfit/doc/cvrefit.hlp @@ -0,0 +1,52 @@ +.help cvrefit Jun84 "Curfit Package" +.ih +NAME +cvrefit -- refit new y vector using old x vector and weights +.ih +SYNOPSIS +cvrefit (cv, x, y, w, ier) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor +.le +.ls x +Array of x values. +.le +.ls y +Array of y values. +.le +.ls weight +Array of weights. +.le +.ls ier +Error code. The options are OK, SINGULAR and NO_DEG_FREEDOM. If ier equals +singular a solution is computed but one or more of the coefficients may +be zero. If ier equals NO_DEG_FREEDOM, there are insufficient data points +to compute a solution and CVREFIT returns without solving for the coefficients. +.le +.ih +DESCRIPTION +In some application the x and weight values remain unchanged from fit to fit +and only the y values vary. In this case it is redundant to reaccumulate +the matrix and perform the Cholesky factorization. CVREFIT zeros and +reaccumulates the vector on the right hand side of the matrix equation +and performs the forward and back substitution phase to fit for a new +coefficient vector. +.ih +NOTES +In the first call to CVREFIT space is allocated for the non-zero basis +functions. Subsequent call to CVREFIT reference this array to avoid +recaculating basis functions at every call. +.ih +SEE ALSO +cvfit, cvaccum, cvsolve, cvchoslv +.endhelp diff --git a/math/curfit/doc/cvreject.hlp b/math/curfit/doc/cvreject.hlp new file mode 100644 index 00000000..52e5ca4f --- /dev/null +++ b/math/curfit/doc/cvreject.hlp @@ -0,0 +1,41 @@ +.help cvreject June84 "Curfit Package" +.ih +NAME +cvreject -- reject a single data point from the data set to be fit +.ih +SYNOPSIS +cvreject (cv, x, y, weight) + +.nf +pointer cv # curve descriptor +real x # x value +real y # y value +real weight # weight value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value. +.le +.ls y +Y value. +.le +.ls weight +The weight value. +.le +.ih +DESCRIPTION +CVREJECT removes an individul data point from the data set. +The non-zero basis functions for each x are calculated. The contribution +of each x to the normal equations is computed and subtracted from the +appropriate arrays and vectors. +An array of points can be removed from the fit by repeated calls to CVREJECT +followed by a single call to CVSOLVE to calculate a new set of coefficients. +.ih +NOTES +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cvrestore.hlp b/math/curfit/doc/cvrestore.hlp new file mode 100644 index 00000000..84d352ee --- /dev/null +++ b/math/curfit/doc/cvrestore.hlp @@ -0,0 +1,32 @@ +.help cvrestore Aug84 "Curfit Package" +.ih +NAME +cvrestore -- restore fit parameters +.ih +SYNOPSIS +cvrestore (cv, fit) + +.nf +pointer cv # pointer to curve descriptor +real fit[] # array containing curve parameters +.fi +.ih +ARGUMENTS +.ls cv +Pointer to curve descriptor structure. Returned by CVRESTORE. +.le +.ls fit +Array containing the curve parameters. Must have at least 7 + order +elements, where order is the parameter set in CVINIT. +.le +.ih +DESCRIPTION +CVRESTORE returns oldcv the pointer to the curve descriptor and +stores the curve parameters in fit in the structure ready for +use by cveval or cvvector. +.ih +NOTES +.ih +SEE ALSO +cvsave +.endhelp diff --git a/math/curfit/doc/cvsave.hlp b/math/curfit/doc/cvsave.hlp new file mode 100644 index 00000000..144beaff --- /dev/null +++ b/math/curfit/doc/cvsave.hlp @@ -0,0 +1,35 @@ +.help cvsave Aug84 "Curfit Package" +.ih +NAME +cvsave -- save parameters of fit +.ih +SYNOPSIS +call cvsave (cv, fit) + +.nf +pointer cv # curve descriptor +real fit[] # array containing the fit parameters +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls fit +Array containing the fit parameters. +Fit must contain at least 7 + order elements, where order is the order of the +fit as set in CVINIT. +.le +.ih +DESCRIPTION +CVSAVE saves the curve parameters in the real array fit. +The first four elements of fit contain the curve_type, order, xmin and xmax. +The coefficients are stored in the remaining array elements. +.ih +NOTES +CVSAVE does not preserve the matrices and vectors used by the fitting +routines. +.ih +SEE ALSO +cvrestore +.endhelp diff --git a/math/curfit/doc/cvset.hlp b/math/curfit/doc/cvset.hlp new file mode 100644 index 00000000..5eb79f30 --- /dev/null +++ b/math/curfit/doc/cvset.hlp @@ -0,0 +1,56 @@ +.help cvset Nov84 "Curfit Package" +.ih +NAME +cvset -- input fit parameters derived external to CURFIT +.ih +SYNOPSIS +include + +cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +.nf +pointer cv # pointer to curve descriptor +int curve_type # functional form of the curve to be fitted +real xmin, xmax # minimum and maximum x values +real coeff[ncoeff] # coefficient array +int ncoeff # number of coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to curve descriptor structure. Returned by CVSET. +.le +.ls curve_type +Type of curve to be input. Must be one of LEGENDRE, CHEBYSHEV, SPLINE3 +or SPLINE1. +.le +.ls xmin, xmax +The minimum and maximum data or fitted x values. The Legendre and +Chebyshev polynomials are assumed to be normalized over this range. +For the cubic and linear spline functions, the data range (xmax - xmin) is +divided into (ncoeff - 3) and (ncoeff - 1) evenly spaced polynomial pieces +respectively. +.le +.ls coeff +Array containing the coefficients. Must have at least 7 + order +elements, where order has the same meaning as the order parameter set in CVINIT. +.le +.ls ncoeff +The number of coefficients. For polynomial functions, ncoeff +equals 1 plus the order of the polynomial, e.g. a second order +polynomial curve will have three coefficients. For the cubic +and linear spline the number of polynomial pieces fit are +(ncoeff - 3) and (ncoeff - 1) respectively. +.le +.ih +DESCRIPTION +CVSET returns cv the pointer to the curve descriptor and +stores the curve parameters in the CURFIT structure ready for +use by CVEVAL or CVVECTOR. +.ih +NOTES +The splines are assumed to have been fit in the least squares sense. +.ih +SEE ALSO +cvsave +.endhelp diff --git a/math/curfit/doc/cvsolve.hlp b/math/curfit/doc/cvsolve.hlp new file mode 100644 index 00000000..16badae2 --- /dev/null +++ b/math/curfit/doc/cvsolve.hlp @@ -0,0 +1,39 @@ +.help cvsolve Jun84 "Curfit Package" +.ih +NAME +cvsolve -- solve a linear system of eqns by the Cholesky method +.ih +SYNOPSIS +cvsolve (cv, ier) + +.nf +pointer cv # curve descriptor +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor +.le +.ls ier +Error code returned by the fitting routines. The options are +OK, SINGULAR and NO_DEG_FREEDOM. If ier is SINGULAR the matrix is singular, +CVSOLVE will compute a solution to the normal equationsbut one or more of the +coefficients will be zero. +If ier equals NO_DEG_FREEDOM, too few data points exist for a reasonable +solution to be computed. CVSOLVE returns +without fitting the data. +.le +.ih +DESCRIPTION +CVSOLVE call two routines CVCHOFAC and CVCHOSLV. CVCHOFAC computes the +Cholesky factorization of the data matrix. CVCHOSLV solves for the +coefficients of the fitting function by forward and back substitution. +An error code is returned by CVSOLVE if it is unable to solve the normal +equations as formulated. +.ih +NOTES +.ih +SEE ALSO +cvchofac, cvchoslv +.endhelp diff --git a/math/curfit/doc/cvstati.hlp b/math/curfit/doc/cvstati.hlp new file mode 100644 index 00000000..ffd05d0a --- /dev/null +++ b/math/curfit/doc/cvstati.hlp @@ -0,0 +1,47 @@ +.help cvstati May85 "Curfit Package" +.ih +NAME +cvstati -- get integer parameter +.ih +SYNOPSIS +include + +ival = cvstati (cv, parameter) + +.nf +pointer cv # curve descriptor +int parameter # parameter to be returned +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls parameter +Parameter to be return. Definitions in curfit.h are: +.nf + define CVTYPE 1 # curve type + define CVORDER 2 # order + define CVNCOEFF 3 # number of coefficients + define CVNSAVE 4 # length of save buffer +.fi +.le +.ih +DESCRIPTION +The values of integer parameters are returned. The parameters include +the curve type, the order, the number of coefficients, and the length +of the buffer required by CVSAVE (which is of TY_REAL). +.ih +EXAMPLES +.nf + include + + int cvstati() + + call malloc (buf, cvstati (cv, CVNSAVE), TY_REAL) + call cvsave (cv, Memr[buf]) +.fi +.ih +SEE ALSO +cvstatr +.endhelp diff --git a/math/curfit/doc/cvstatr.hlp b/math/curfit/doc/cvstatr.hlp new file mode 100644 index 00000000..f4d959c2 --- /dev/null +++ b/math/curfit/doc/cvstatr.hlp @@ -0,0 +1,44 @@ +.help cvstatr May85 "Curfit Package" +.ih +NAME +cvstatr -- get real parameter +.ih +SYNOPSIS +include + +rval = cvstatr (cv, parameter) + +.nf +pointer cv # curve descriptor +int parameter # parameter to be returned +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls parameter +Parameter to be return. Definitions in curfit.h are: +.nf + define CVXMIN 5 # minimum ordinate + define CVORDER 6 # maximum ordinate +.fi +.le +.ih +DESCRIPTION +The values of real parameters are returned. The parameters include +the minimum and maximum ordinate values of the curve. +.ih +EXAMPLES +.nf + include + + real cvstatr() + + xmin = cvstatr (cv, CVXMIN) + xmax = cvstatr (cv, CVXMAX) +.fi +.ih +SEE ALSO +cvstati +.endhelp diff --git a/math/curfit/doc/cvvector.hlp b/math/curfit/doc/cvvector.hlp new file mode 100644 index 00000000..79c0282f --- /dev/null +++ b/math/curfit/doc/cvvector.hlp @@ -0,0 +1,41 @@ +.help cvvector Jun84 "Curfit Package" +.ih +NAME +cvvector -- evaluate the fitted curve at a set of points +.ih +SYNOPSIS +cvvector (cv, x, yfit, npts) + +.nf +pointer cv # curve descriptor +real x[] # x array +real yfit[] # array of fitted y values +int npts # number of x values +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of x values at which the curve is to be evaluated. +.le +.ih +DESCRIPTION +Fit the curve to an array of data points. CVVECTOR uses the coefficients +stored in the curve descriptor structure. +.ih +NOTES +The x values are assumed to lie +in the region xmin <= x <= xmax. Checking for out of bounds x values is the +responsibility of the user. +.ih +SEE ALSO +cveval +.endhelp diff --git a/math/curfit/doc/cvzero.hlp b/math/curfit/doc/cvzero.hlp new file mode 100644 index 00000000..7f9e07e2 --- /dev/null +++ b/math/curfit/doc/cvzero.hlp @@ -0,0 +1,26 @@ +.help cvzero Aug84 "Curfit Package" +.ih +NAME +cvzero -- set up for a new curve fit +.ih +SYNOPSIS +cvzero (cv) + +.nf +pointer cv # curve descriptor +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ih +DESCRIPTION +CVZERO zeros the matrix and right side of the matrix equation. +.ih +NOTES +CVZERO can be used to reinitialize the matrix and right side of the matrix +equation to begin a new fit in accumulate mode. +.ih +SEE ALSO +cvfit, cvinit diff --git a/math/curfit/mkpkg b/math/curfit/mkpkg new file mode 100644 index 00000000..345ec582 --- /dev/null +++ b/math/curfit/mkpkg @@ -0,0 +1,87 @@ +# Curve fitting tools library. + +$checkout libcurfit.a lib$ +$update libcurfit.a +$checkin libcurfit.a lib$ +$exit + +tfiles: + $set GEN = "$$generic -k -t rd" + + $ifolder (cv_b1evalr.x, cv_b1eval.gx) $(GEN) cv_b1eval.gx $endif + $ifolder (cv_bevalr.x, cv_beval.gx) $(GEN) cv_beval.gx $endif + $ifolder (cv_fevalr.x, cv_feval.gx) $(GEN) cv_feval.gx $endif + $ifolder (cv_userfncr.x, cv_userfnc.gx) $(GEN) cv_userfnc.gx $endif + $ifolder (cvaccumr.x, cvaccum.gx) $(GEN) cvaccum.gx $endif + $ifolder (cvacptsr.x, cvacpts.gx) $(GEN) cvacpts.gx $endif + $ifolder (cvchomatr.x, cvchomat.gx) $(GEN) cvchomat.gx $endif + $ifolder (cvcoeffr.x, cvcoeff.gx) $(GEN) cvcoeff.gx $endif + $ifolder (cverrorsr.x, cverrors.gx) $(GEN) cverrors.gx $endif + $ifolder (cvevalr.x, cveval.gx) $(GEN) cveval.gx $endif + $ifolder (cvfitr.x, cvfit.gx) $(GEN) cvfit.gx $endif + $ifolder (cvfreer.x, cvfree.gx) $(GEN) cvfree.gx $endif + $ifolder (cvinitr.x, cvinit.gx) $(GEN) cvinit.gx $endif + $ifolder (cvpowerr.x, cvpower.gx) $(GEN) cvpower.gx $endif + $ifolder (cvrefitr.x, cvrefit.gx) $(GEN) cvrefit.gx $endif + $ifolder (cvrejectr.x, cvreject.gx) $(GEN) cvreject.gx $endif + $ifolder (cvrestorer.x, cvrestore.gx) $(GEN) cvrestore.gx $endif + $ifolder (cvsaver.x, cvsave.gx) $(GEN) cvsave.gx $endif + $ifolder (cvsetr.x, cvset.gx) $(GEN) cvset.gx $endif + $ifolder (cvsolver.x, cvsolve.gx) $(GEN) cvsolve.gx $endif + $ifolder (cvstatr.x, cvstat.gx) $(GEN) cvstat.gx $endif + $ifolder (cvvectorr.x, cvvector.gx) $(GEN) cvvector.gx $endif + $ifolder (cvzeror.x, cvzero.gx) $(GEN) cvzero.gx $endif + ; + +libcurfit.a: + + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + cvaccumr.x curfitdef.h + cvacptsr.x curfitdef.h + cv_bevalr.x + cv_b1evalr.x + cvchomatr.x curfitdef.h + cvcoeffr.x curfitdef.h + cverrorsr.x curfitdef.h + cvevalr.x curfitdef.h + cv_fevalr.x + cvfitr.x curfitdef.h + cvfreer.x curfitdef.h + cvinitr.x curfitdef.h + cvpowerr.x curfitdef.h + cvrefitr.x curfitdef.h + cvrejectr.x curfitdef.h + cvrestorer.x curfitdef.h + cvsaver.x curfitdef.h + cvsetr.x curfitdef.h + cvsolver.x curfitdef.h + cvstatr.x curfitdef.h + cv_userfncr.x curfitdef.h + cvvectorr.x curfitdef.h + cvzeror.x curfitdef.h + + cvaccumd.x dcurfitdef.h + cvacptsd.x dcurfitdef.h + cv_bevald.x + cv_b1evald.x + cvchomatd.x dcurfitdef.h + cvcoeffd.x dcurfitdef.h + cverrorsd.x dcurfitdef.h + cvevald.x dcurfitdef.h + cv_fevald.x + cvfitd.x dcurfitdef.h + cvfreed.x dcurfitdef.h + cvinitd.x dcurfitdef.h + cvpowerd.x dcurfitdef.h + cvrefitd.x dcurfitdef.h + cvrejectd.x dcurfitdef.h + cvrestored.x dcurfitdef.h + cvsaved.x dcurfitdef.h + cvsetd.x dcurfitdef.h + cvsolved.x dcurfitdef.h + cvstatd.x dcurfitdef.h + cv_userfncd.x dcurfitdef.h + cvvectord.x dcurfitdef.h + cvzerod.x dcurfitdef.h + ; diff --git a/math/deboor/Notes b/math/deboor/Notes new file mode 100644 index 00000000..e3c51470 --- /dev/null +++ b/math/deboor/Notes @@ -0,0 +1,36 @@ + 0 4 20 chapter xii example 2 run 1 + 3 4 20 chapter xii example 2 run 2 + 8 4 20 chapter xii example 3 run 1 + 6 4 20 chapter xii example 3 run 2 + 4 4 20 chapter xii example 3 run 3 + 8 4 20 chapter xii example 4 run 1 + 6 4 20 chapter xii example 4 run 2 + 7 10 4 chapter xiii example 1 run 1 +.000001 chapter xiii example 1 run 1 +2. chapter xiii example 1 run 1 + 7 10 4 chapter xiii example 1 run 2 +0. chapter xiii example 1 run 2 +2. chapter xiii example 1 run 2 + 0 4 20 chapter xiii example 2 run 1 + 3 4 20 chapter xiii example 2 run 2 + 6 4 20 chapter xiii example 2 run 3 + 0 4 20 chapter xiii example 2m run 1 + 1 4 20 chapter xiii example 2m run 2 + 2 4 20 chapter xiii example 2m run 3 + 2 7 chapter xiv example 1 +600000. chapter xiv example 1 +60000. chapter xiv example 1 +6000. chapter xiv example 1 +600. chapter xiv example 1 +60. chapter xiv example 1 +6. chapter xiv example 1 +.6 chapter xiv example 1 + 1 0. chapter xiv example 2 +ononon chapter xiv example 2 + 20 1. chapter xiv example 3 need fake newnot routine which +ofofof chapter xiv example 3 returns uniform knots . + 4 2. chapter xiv example 4 +ononof chapter xiv example 4 +2.5 chapter xvi example 2 +-1. chapter xvi example 2 + end diff --git a/math/deboor/README b/math/deboor/README new file mode 100644 index 00000000..c0ecd1f4 --- /dev/null +++ b/math/deboor/README @@ -0,0 +1,20 @@ +These directories contain the codes described in the book "A Practical Guide +to Splines", by Carl DeBoor, Springer-Verlag, 1978. The directory math/deboor +contains the single precision routines. The same routines, edited to provide +double precision, are in the directory "dblprec", which may disappear at some +point in the future if we decide we don't need these. The directory "progs" +contains a number of example programs from the book. + +A number of the routines herein write error messages using Fortran i/o, +violating our convention that numerical routines should not perform i/o. +These routines have been flagged by adding the suffix "_io". These routines +have not been compiled and installed in the library "deboor.a". The most useful +routines either did not do i/o, or have had the i/o removed (e.g., splint.f). + +Note: use the new SPLLSQ for smoothing with splines, instead of L2APPR, if a +uniform knot sequence is desired. Use BSPLN to evaluate the coefficient array +from SPLLSQ. + +Oct 85 Rearranged the order of argument declarations in cwidth.f, dtblok.f, + factrb.f, fcblok.f, sbblok.f, shiftb.f, slvblk.f, subbak.f, subfor.f + to conform with Fortran standard diff --git a/math/deboor/Revisions b/math/deboor/Revisions new file mode 100644 index 00000000..bf131052 --- /dev/null +++ b/math/deboor/Revisions @@ -0,0 +1,7 @@ +.help revisions Sep99 math.deboor +.nf +From Davis, September 20, 1999 + +Added some missing file dependices to the mkpkg file. +pkg/math/deboor/mkpkg +.endhelp diff --git a/math/deboor/banfac.f b/math/deboor/banfac.f new file mode 100644 index 00000000..56906927 --- /dev/null +++ b/math/deboor/banfac.f @@ -0,0 +1,110 @@ + subroutine banfac ( w, nroww, nrow, nbandl, nbandu, iflag ) +c from * a practical guide to splines * by c. de boor +c returns in w the lu-factorization (without pivoting) of the banded +c matrix a of order nrow with (nbandl + 1 + nbandu) bands or diag- +c onals in the work array w . +c +c****** i n p u t ****** +c w.....work array of size (nroww,nrow) containing the interesting +c part of a banded matrix a , with the diagonals or bands of a +c stored in the rows of w , while columns of a correspond to +c columns of w . this is the storage mode used in linpack and +c results in efficient innermost loops. +c explicitly, a has nbandl bands below the diagonal +c + 1 (main) diagonal +c + nbandu bands above the diagonal +c and thus, with middle = nbandu + 1, +c a(i+j,j) is in w(i+middle,j) for i=-nbandu,...,nbandl +c j=1,...,nrow . +c for example, the interesting entries of a (1,2)-banded matrix +c of order 9 would appear in the first 1+1+2 = 4 rows of w +c as follows. +c 13 24 35 46 57 68 79 +c 12 23 34 45 56 67 78 89 +c 11 22 33 44 55 66 77 88 99 +c 21 32 43 54 65 76 87 98 +c +c all other entries of w not identified in this way with an en- +c try of a are never referenced . +c nroww.....row dimension of the work array w . +c must be .ge. nbandl + 1 + nbandu . +c nbandl.....number of bands of a below the main diagonal +c nbandu.....number of bands of a above the main diagonal . +c +c****** o u t p u t ****** +c iflag.....integer indicating success( = 1) or failure ( = 2) . +c if iflag = 1, then +c w.....contains the lu-factorization of a into a unit lower triangu- +c lar matrix l and an upper triangular matrix u (both banded) +c and stored in customary fashion over the corresponding entries +c of a . this makes it possible to solve any particular linear +c system a*x = b for x by a +c call banslv ( w, nroww, nrow, nbandl, nbandu, b ) +c with the solution x contained in b on return . +c if iflag = 2, then +c one of nrow-1, nbandl,nbandu failed to be nonnegative, or else +c one of the potential pivots was found to be zero indicating +c that a does not have an lu-factorization. this implies that +c a is singular in case it is totally positive . +c +c****** m e t h o d ****** +c gauss elimination w i t h o u t pivoting is used. the routine is +c intended for use with matrices a which do not require row inter- +c changes during factorization, especially for the t o t a l l y +c p o s i t i v e matrices which occur in spline calculations. +c the routine should not be used for an arbitrary banded matrix. +c + integer iflag,nbandl,nbandu,nrow,nroww, i,ipk,j,jmax,k,kmax + * ,middle,midmk,nrowm1 + real w(nroww,nrow), factor,pivot +c + iflag = 1 + middle = nbandu + 1 +c w(middle,.) contains the main diagonal of a . + nrowm1 = nrow - 1 + if (nrowm1) 999,900,1 + 1 if (nbandl .gt. 0) go to 10 +c a is upper triangular. check that diagonal is nonzero . + do 5 i=1,nrowm1 + if (w(middle,i) .eq. 0.) go to 999 + 5 continue + go to 900 + 10 if (nbandu .gt. 0) go to 20 +c a is lower triangular. check that diagonal is nonzero and +c divide each column by its diagonal . + do 15 i=1,nrowm1 + pivot = w(middle,i) + if(pivot .eq. 0.) go to 999 + jmax = min0(nbandl, nrow - i) + do 15 j=1,jmax + 15 w(middle+j,i) = w(middle+j,i)/pivot + return +c +c a is not just a triangular matrix. construct lu factorization + 20 do 50 i=1,nrowm1 +c w(middle,i) is pivot for i-th step . + pivot = w(middle,i) + if (pivot .eq. 0.) go to 999 +c jmax is the number of (nonzero) entries in column i +c below the diagonal . + jmax = min0(nbandl,nrow - i) +c divide each entry in column i below diagonal by pivot . + do 32 j=1,jmax + 32 w(middle+j,i) = w(middle+j,i)/pivot +c kmax is the number of (nonzero) entries in row i to +c the right of the diagonal . + kmax = min0(nbandu,nrow - i) +c subtract a(i,i+k)*(i-th column) from (i+k)-th column +c (below row i ) . + do 40 k=1,kmax + ipk = i + k + midmk = middle - k + factor = w(midmk,ipk) + do 40 j=1,jmax + 40 w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i)*factor + 50 continue +c check the last diagonal entry . + 900 if (w(middle,nrow) .ne. 0.) return + 999 iflag = 2 + return + end diff --git a/math/deboor/banslv.f b/math/deboor/banslv.f new file mode 100644 index 00000000..154ae051 --- /dev/null +++ b/math/deboor/banslv.f @@ -0,0 +1,53 @@ + subroutine banslv ( w, nroww, nrow, nbandl, nbandu, b ) +c from * a practical guide to splines * by c. de boor +c companion routine to banfac . it returns the solution x of the +c linear system a*x = b in place of b , given the lu-factorization +c for a in the workarray w . +c +c****** i n p u t ****** +c w, nroww,nrow,nbandl,nbandu.....describe the lu-factorization of a +c banded matrix a of roder nrow as constructed in banfac . +c for details, see banfac . +c b.....right side of the system to be solved . +c +c****** o u t p u t ****** +c b.....contains the solution x , of order nrow . +c +c****** m e t h o d ****** +c (with a = l*u, as stored in w,) the unit lower triangular system +c l(u*x) = b is solved for y = u*x, and y stored in b . then the +c upper triangular system u*x = y is solved for x . the calcul- +c ations are so arranged that the innermost loops stay within columns. +c + integer nbandl,nbandu,nrow,nroww, i,j,jmax,middle,nrowm1 + real w(nroww,nrow),b(nrow) + middle = nbandu + 1 + if (nrow .eq. 1) go to 49 + nrowm1 = nrow - 1 + if (nbandl .eq. 0) go to 30 +c forward pass +c for i=1,2,...,nrow-1, subtract right side(i)*(i-th column +c of l ) from right side (below i-th row) . + do 21 i=1,nrowm1 + jmax = min0(nbandl, nrow-i) + do 21 j=1,jmax + 21 b(i+j) = b(i+j) - b(i)*w(middle+j,i) +c backward pass +c for i=nrow,nrow-1,...,1, divide right side(i) by i-th diag- +c onal entry of u, then subtract right side(i)*(i-th column +c of u) from right side (above i-th row). + 30 if (nbandu .gt. 0) go to 40 +c a is lower triangular . + do 31 i=1,nrow + 31 b(i) = b(i)/w(1,i) + return + 40 i = nrow + 41 b(i) = b(i)/w(middle,i) + jmax = min0(nbandu,i-1) + do 45 j=1,jmax + 45 b(i-j) = b(i-j) - b(i)*w(middle-j,i) + i = i - 1 + if (i .gt. 1) go to 41 + 49 b(1) = b(1)/w(middle,1) + return + end diff --git a/math/deboor/bchfac.f b/math/deboor/bchfac.f new file mode 100644 index 00000000..a2a95471 --- /dev/null +++ b/math/deboor/bchfac.f @@ -0,0 +1,87 @@ + subroutine bchfac ( w, nbands, nrow, diag ) +c from * a practical guide to splines * by c. de boor +constructs cholesky factorization +c c = l * d * l-transpose +c with l unit lower triangular and d diagonal, for given matrix c of +c order n r o w , in case c is (symmetric) positive semidefinite +c and b a n d e d , having n b a n d s diagonals at and below the +c main diagonal. +c +c****** i n p u t ****** +c nrow.....is the order of the matrix c . +c nbands.....indicates its bandwidth, i.e., +c c(i,j) = 0 for abs(i-j) .gt. nbands . +c w.....workarray of size (nbands,nrow) containing the nbands diago- +c nals in its rows, with the main diagonal in row 1 . precisely, +c w(i,j) contains c(i+j-1,j), i=1,...,nbands, j=1,...,nrow. +c for example, the interesting entries of a seven diagonal sym- +c metric matrix c of order 9 would be stored in w as +c +c 11 22 33 44 55 66 77 88 99 +c 21 32 43 54 65 76 87 98 +c 31 42 53 64 75 86 97 +c 41 52 63 74 85 96 +c +c all other entries of w not identified in this way with an en- +c try of c are never referenced . +c diag.....is a work array of length nrow . +c +c****** o u t p u t ****** +c w.....contains the cholesky factorization c = l*d*l-transp, with +c w(1,i) containing 1/d(i,i) +c and w(i,j) containing l(i-1+j,j), i=2,...,nbands. +c +c****** m e t h o d ****** +c gauss elimination, adapted to the symmetry and bandedness of c , is +c used . +c near zero pivots are handled in a special way. the diagonal ele- +c ment c(n,n) = w(1,n) is saved initially in diag(n), all n. at the n- +c th elimination step, the current pivot element, viz. w(1,n), is com- +c pared with its original value, diag(n). if, as the result of prior +c elimination steps, this element has been reduced by about a word +c length, (i.e., if w(1,n)+diag(n) .le. diag(n)), then the pivot is de- +c clared to be zero, and the entire n-th row is declared to be linearly +c dependent on the preceding rows. this has the effect of producing +c x(n) = 0 when solving c*x = b for x, regardless of b. justific- +c ation for this is as follows. in contemplated applications of this +c program, the given equations are the normal equations for some least- +c squares approximation problem, diag(n) = c(n,n) gives the norm-square +c of the n-th basis function, and, at this point, w(1,n) contains the +c norm-square of the error in the least-squares approximation to the n- +c th basis function by linear combinations of the first n-1 . having +c w(1,n)+diag(n) .le. diag(n) signifies that the n-th function is lin- +c early dependent to machine accuracy on the first n-1 functions, there +c fore can safely be left out from the basis of approximating functions +c the solution of a linear system +c c*x = b +c is effected by the succession of the following t w o calls: +c call bchfac ( w, nbands, nrow, diag ) , to get factorization +c call bchslv ( w, nbands, nrow, b, x ) , to solve for x. +c + integer nbands,nrow, i,imax,j,jmax,n + real w(nbands,nrow),diag(nrow), ratio + if (nrow .gt. 1) go to 9 + if (w(1,1) .gt. 0.) w(1,1) = 1./w(1,1) + return +c store diagonal of c in diag. + 9 do 10 n=1,nrow + 10 diag(n) = w(1,n) +c factorization . + do 20 n=1,nrow + if (w(1,n)+diag(n) .gt. diag(n)) go to 15 + do 14 j=1,nbands + 14 w(j,n) = 0. + go to 20 + 15 w(1,n) = 1./w(1,n) + imax = min0(nbands-1,nrow - n) + if (imax .lt. 1) go to 20 + jmax = imax + do 18 i=1,imax + ratio = w(i+1,n)*w(1,n) + do 17 j=1,jmax + 17 w(j,n+i) = w(j,n+i) - w(j+i,n)*ratio + jmax = jmax - 1 + 18 w(i+1,n) = ratio + 20 continue + return + end diff --git a/math/deboor/bchslv.f b/math/deboor/bchslv.f new file mode 100644 index 00000000..ec848b8f --- /dev/null +++ b/math/deboor/bchslv.f @@ -0,0 +1,50 @@ + subroutine bchslv ( w, nbands, nrow, b ) +c from * a practical guide to splines * by c. de boor +c solves the linear system c*x = b of order n r o w for x +c provided w contains the cholesky factorization for the banded (sym- +c metric) positive definite matrix c as constructed in the subroutine +c b c h f a c (quo vide). +c +c****** i n p u t ****** +c nrow.....is the order of the matrix c . +c nbands.....indicates the bandwidth of c . +c w.....contains the cholesky factorization for c , as output from +c subroutine bchfac (quo vide). +c b.....the vector of length n r o w containing the right side. +c +c****** o u t p u t ****** +c b.....the vector of length n r o w containing the solution. +c +c****** m e t h o d ****** +c with the factorization c = l*d*l-transpose available, where l is +c unit lower triangular and d is diagonal, the triangular system +c l*y = b is solved for y (forward substitution), y is stored in b, +c the vector d**(-1)*y is computed and stored in b, then the triang- +c ular system l-transpose*x = d**(-1)*y is solved for x (backsubstit- +c ution). + integer nbands,nrow, j,jmax,n,nbndm1 + real w(nbands,nrow),b(nrow) + if (nrow .gt. 1) go to 21 + b(1) = b(1)*w(1,1) + return +c +c forward substitution. solve l*y = b for y, store in b. + 21 nbndm1 = nbands - 1 + do 30 n=1,nrow + jmax = min0(nbndm1,nrow-n) + if (jmax .lt. 1) go to 30 + do 25 j=1,jmax + 25 b(j+n) = b(j+n) - w(j+1,n)*b(n) + 30 continue +c +c backsubstitution. solve l-transp.x = d**(-1)*y for x, store in b. + n = nrow + 31 b(n) = b(n)*w(1,n) + jmax = min0(nbndm1,nrow-n) + if (jmax .lt. 1) go to 40 + do 35 j=1,jmax + 35 b(n) = b(n) - w(j+1,n)*b(j+n) + 40 n = n-1 + if (n.gt.0) go to 31 + return + end diff --git a/math/deboor/bsplbv.f b/math/deboor/bsplbv.f new file mode 100644 index 00000000..2187db14 --- /dev/null +++ b/math/deboor/bsplbv.f @@ -0,0 +1,91 @@ + subroutine bsplvb ( t, jhigh, index, x, left, biatx ) +c from * a practical guide to splines * by c. de boor +calculates the value of all possibly nonzero b-splines at x of order +c +c jout = max( jhigh , (j+1)*(index-1) ) +c +c with knot sequence t . +c +c****** i n p u t ****** +c t.....knot sequence, of length left + jout , assumed to be nonde- +c creasing. a s s u m p t i o n . . . . +c t(left) .lt. t(left + 1) . +c d i v i s i o n b y z e r o will result if t(left) = t(left+1) +c jhigh, +c index.....integers which determine the order jout = max(jhigh, +c (j+1)*(index-1)) of the b-splines whose values at x are to +c be returned. index is used to avoid recalculations when seve- +c ral columns of the triangular array of b-spline values are nee- +c ded (e.g., in bvalue or in bsplvd ). precisely, +c if index = 1 , +c the calculation starts from scratch and the entire triangular +c array of b-spline values of orders 1,2,...,jhigh is generated +c order by order , i.e., column by column . +c if index = 2 , +c only the b-spline values of order j+1, j+2, ..., jout are ge- +c nerated, the assumption being that biatx , j , deltal , deltar +c are, on entry, as they were on exit at the previous call. +c in particular, if jhigh = 0, then jout = j+1, i.e., just +c the next column of b-spline values is generated. +c +c w a r n i n g . . . the restriction jout .le. jmax (= 20) is im- +c posed arbitrarily by the dimension statement for deltal and +c deltar below, but is n o w h e r e c h e c k e d for . +c +c x.....the point at which the b-splines are to be evaluated. +c left.....an integer chosen (usually) so that +c t(left) .le. x .le. t(left+1) . +c +c****** o u t p u t ****** +c biatx.....array of length jout , with biatx(i) containing the val- +c ue at x of the polynomial of order jout which agrees with +c the b-spline b(left-jout+i,jout,t) on the interval (t(left), +c t(left+1)) . +c +c****** m e t h o d ****** +c the recurrence relation +c +c x - t(i) t(i+j+1) - x +c b(i,j+1)(x) = -----------b(i,j)(x) + ---------------b(i+1,j)(x) +c t(i+j)-t(i) t(i+j+1)-t(i+1) +c +c is used (repeatedly) to generate the (j+1)-vector b(left-j,j+1)(x), +c ...,b(left,j+1)(x) from the j-vector b(left-j+1,j)(x),..., +c b(left,j)(x), storing the new values in biatx over the old. the +c facts that +c b(i,1) = 1 if t(i) .le. x .lt. t(i+1) +c and that +c b(i,j)(x) = 0 unless t(i) .le. x .lt. t(i+j) +c are used. the particular organization of the calculations follows al- +c gorithm (8) in chapter x of the text. +c +c parameter jmax = 20 + integer index,jhigh,left, i,j,jp1 +c real biatx(jhigh),t(1),x, deltal(jmax),deltar(jmax),saved,term + real biatx(jhigh),t(1),x, deltal(20),deltar(20),saved,term +c dimension biatx(jout), t(left+jout) +current fortran standard makes it impossible to specify the length of +c t and of biatx precisely without the introduction of otherwise +c superfluous additional arguments. + data j/1/ +c save j,deltal,deltar (valid in fortran 77) +c + go to (10,20), index + 10 j = 1 + biatx(1) = 1. + if (j .ge. jhigh) go to 99 +c + 20 jp1 = j + 1 + deltar(j) = t(left+j) - x + deltal(j) = x - t(left+1-j) + saved = 0. + do 26 i=1,j + term = biatx(i)/(deltar(i) + deltal(jp1-i)) + biatx(i) = saved + deltar(i)*term + 26 saved = deltal(jp1-i)*term + biatx(jp1) = saved + j = jp1 + if (j .lt. jhigh) go to 20 +c + 99 return + end diff --git a/math/deboor/bspln.h b/math/deboor/bspln.h new file mode 100644 index 00000000..ccee7b64 --- /dev/null +++ b/math/deboor/bspln.h @@ -0,0 +1,14 @@ +define KMAX 20 # maximum order spline permitted + +# Spline descriptor structure -- stored at beginning of BSPLN array. +# All of the information needed to describe the spline is collected +# in one place. Space is left in the header for expansion. +# Space required: REAL BSPLN [2*N+30] + +define NCOEF bspln[1] # number of coeff in the spline +define ORDER bspln[2] # order of spline (cubic = 4) +define XMIN bspln[3] # minimum x-value +define XMAX bspln[4] # maximum x-value +define KINDEX bspln[5] # position during evaluation (SEVAL) +define KNOT1 NCOEF+10 # offset to the first knot +define COEF1 10 # offset to the first coefficient diff --git a/math/deboor/bsplpp.f b/math/deboor/bsplpp.f new file mode 100644 index 00000000..3af00b3b --- /dev/null +++ b/math/deboor/bsplpp.f @@ -0,0 +1,105 @@ + subroutine bsplpp ( t, bcoef, n, k, scrtch, break, coef, l ) +c from * a practical guide to splines * by c. de boor +calls bsplvb +c +converts the b-representation t, bcoef, n, k of some spline into its +c pp-representation break, coef, l, k . +c +c****** i n p u t ****** +c t.....knot sequence, of length n+k +c bcoef.....b-spline coefficient sequence, of length n +c n.....length of bcoef and dimension of spline space spline(k,t) +c k.....order of the spline +c +c w a r n i n g . . . the restriction k .le. kmax (= 20) is impo- +c sed by the arbitrary dimension statement for biatx below, but +c is n o w h e r e c h e c k e d for. +c +c****** w o r k a r e a ****** +c scrtch......of size (k,k) , needed to contain bcoeffs of a piece of +c the spline and its k-1 derivatives +c +c****** o u t p u t ****** +c break.....breakpoint sequence, of length l+1, contains (in increas- +c ing order) the distinct points in the sequence t(k),...,t(n+1) +c coef.....array of size (k,n), with coef(i,j) = (i-1)st derivative of +c spline at break(j) from the right +c l.....number of polynomial pieces which make up the spline in the in- +c terval (t(k), t(n+1)) +c +c****** m e t h o d ****** +c for each breakpoint interval, the k relevant b-coeffs of the +c spline are found and then differenced repeatedly to get the b-coeffs +c of all the derivatives of the spline on that interval. the spline and +c its first k-1 derivatives are then evaluated at the left end point +c of that interval, using bsplvb repeatedly to obtain the values of +c all b-splines of the appropriate order at that point. +c +c parameter kmax = 20 + integer k,l,n, i,j,jp1,kmj,left,lsofar + real bcoef(n),break(1),coef(k,1),t(1), scrtch(k,k) + * ,biatx(20),diff,fkmj,sum +c * ,biatx(kmax),diff,fkmj,sum +c dimension break(l+1),coef(k,l),t(n+k) +current fortran standard makes it impossible to specify the length of +c break , coef and t precisely without the introduction of otherwise +c superfluous additional arguments. + lsofar = 0 + break(1) = t(k) + do 50 left=k,n +c find the next nontrivial knot interval. + if (t(left+1) .eq. t(left)) go to 50 + lsofar = lsofar + 1 + break(lsofar+1) = t(left+1) + if (k .gt. 1) go to 9 + coef(1,lsofar) = bcoef(left) + go to 50 +c store the k b-spline coeff.s relevant to current knot interval +c in scrtch(.,1) . + 9 do 10 i=1,k + 10 scrtch(i,1) = bcoef(left-k+i) +c +c for j=1,...,k-1, compute the k-j b-spline coeff.s relevant to +c current knot interval for the j-th derivative by differencing +c those for the (j-1)st derivative, and store in scrtch(.,j+1) . + do 20 jp1=2,k + j = jp1 - 1 + kmj = k - j + fkmj = float(kmj) + do 20 i=1,kmj + diff = t(left+i) - t(left+i - kmj) + if (diff .gt. 0.) scrtch(i,jp1) = + * ((scrtch(i+1,j)-scrtch(i,j))/diff)*fkmj + 20 continue +c +c for j = 0, ..., k-1, find the values at t(left) of the j+1 +c b-splines of order j+1 whose support contains the current +c knot interval from those of order j (in biatx ), then comb- +c ine with the b-spline coeff.s (in scrtch(.,k-j) ) found earlier +c to compute the (k-j-1)st derivative at t(left) of the given +c spline. +c note. if the repeated calls to bsplvb are thought to gene- +c rate too much overhead, then replace the first call by +c biatx(1) = 1. +c and the subsequent call by the statement +c j = jp1 - 1 +c followed by a direct copy of the lines +c deltar(j) = t(left+j) - x +c ...... +c biatx(j+1) = saved +c from bsplvb . deltal(kmax) and deltar(kmax) would have to +c appear in a dimension statement, of course. +c + call bsplvb ( t, 1, 1, t(left), left, biatx ) + coef(k,lsofar) = scrtch(1,k) + do 30 jp1=2,k + call bsplvb ( t, jp1, 2, t(left), left, biatx ) + kmj = k+1 - jp1 + sum = 0. + do 28 i=1,jp1 + 28 sum = biatx(i)*scrtch(i,kmj) + sum + 30 coef(kmj,lsofar) = sum + 50 continue + l = lsofar + return + end diff --git a/math/deboor/bsplvd.f b/math/deboor/bsplvd.f new file mode 100644 index 00000000..d48d0adc --- /dev/null +++ b/math/deboor/bsplvd.f @@ -0,0 +1,111 @@ + subroutine bsplvd ( t, k, x, left, a, dbiatx, nderiv ) +c from * a practical guide to splines * by c. de boor +calls bsplvb +calculates value and deriv.s of all b-splines which do not vanish at x +c +c****** i n p u t ****** +c t the knot array, of length left+k (at least) +c k the order of the b-splines to be evaluated +c x the point at which these values are sought +c left an integer indicating the left endpoint of the interval of +c interest. the k b-splines whose support contains the interval +c (t(left), t(left+1)) +c are to be considered. +c a s s u m p t i o n - - - it is assumed that +c t(left) .lt. t(left+1) +c division by zero will result otherwise (in b s p l v b ). +c also, the output is as advertised only if +c t(left) .le. x .le. t(left+1) . +c nderiv an integer indicating that values of b-splines and their +c derivatives up to but not including the nderiv-th are asked +c for. ( nderiv is replaced internally by the integer m h i g h +c in (1,k) closest to it.) +c +c****** w o r k a r e a ****** +c a an array of order (k,k), to contain b-coeff.s of the derivat- +c ives of a certain order of the k b-splines of interest. +c +c****** o u t p u t ****** +c dbiatx an array of order (k,nderiv). its entry (i,m) contains +c value of (m-1)st derivative of (left-k+i)-th b-spline of +c order k for knot sequence t , i=m,...,k, m=1,...,nderiv. +c +c****** m e t h o d ****** +c values at x of all the relevant b-splines of order k,k-1,..., +c k+1-nderiv are generated via bsplvb and stored temporarily in +c dbiatx . then, the b-coeffs of the required derivatives of the b- +c splines of interest are generated by differencing, each from the pre- +c ceding one of lower order, and combined with the values of b-splines +c of corresponding order in dbiatx to produce the desired values . +c + integer k,left,nderiv, i,ideriv,il,j,jlow,jp1mid,kp1,kp1mm + * ,ldummy,m,mhigh + real a(k,k),dbiatx(k,nderiv),t(1),x, factor,fkp1mm,sum + mhigh = max0(min0(nderiv,k),1) +c mhigh is usually equal to nderiv. + kp1 = k+1 + call bsplvb(t,kp1-mhigh,1,x,left,dbiatx) + if (mhigh .eq. 1) go to 99 +c the first column of dbiatx always contains the b-spline values +c for the current order. these are stored in column k+1-current +c order before bsplvb is called to put values for the next +c higher order on top of it. + ideriv = mhigh + do 15 m=2,mhigh + jp1mid = 1 + do 11 j=ideriv,k + dbiatx(j,ideriv) = dbiatx(jp1mid,1) + 11 jp1mid = jp1mid + 1 + ideriv = ideriv - 1 + call bsplvb(t,kp1-ideriv,2,x,left,dbiatx) + 15 continue +c +c at this point, b(left-k+i, k+1-j)(x) is in dbiatx(i,j) for +c i=j,...,k and j=1,...,mhigh ('=' nderiv). in particular, the +c first column of dbiatx is already in final form. to obtain cor- +c responding derivatives of b-splines in subsequent columns, gene- +c rate their b-repr. by differencing, then evaluate at x. +c + jlow = 1 + do 20 i=1,k + do 19 j=jlow,k + 19 a(j,i) = 0. + jlow = i + 20 a(i,i) = 1. +c at this point, a(.,j) contains the b-coeffs for the j-th of the +c k b-splines of interest here. +c + do 40 m=2,mhigh + kp1mm = kp1 - m + fkp1mm = float(kp1mm) + il = left + i = k +c +c for j=1,...,k, construct b-coeffs of (m-1)st derivative of +c b-splines from those for preceding derivative by differencing +c and store again in a(.,j) . the fact that a(i,j) = 0 for +c i .lt. j is used. + do 25 ldummy=1,kp1mm + factor = fkp1mm/(t(il+kp1mm) - t(il)) +c the assumption that t(left).lt.t(left+1) makes denominator +c in factor nonzero. + do 24 j=1,i + 24 a(i,j) = (a(i,j) - a(i-1,j))*factor + il = il - 1 + 25 i = i - 1 +c +c for i=1,...,k, combine b-coeffs a(.,i) with b-spline values +c stored in dbiatx(.,m) to get value of (m-1)st derivative of +c i-th b-spline (of interest here) at x , and store in +c dbiatx(i,m). storage of this value over the value of a b-spline +c of order m there is safe since the remaining b-spline derivat- +c ives of the same order do not use this value due to the fact +c that a(j,i) = 0 for j .lt. i . + 30 do 40 i=1,k + sum = 0. + jlow = max0(i,m) + do 35 j=jlow,k + 35 sum = a(j,i)*dbiatx(j,m) + sum + 40 dbiatx(i,m) = sum + 99 return + end diff --git a/math/deboor/bspp2d.f b/math/deboor/bspp2d.f new file mode 100644 index 00000000..87c3433f --- /dev/null +++ b/math/deboor/bspp2d.f @@ -0,0 +1,122 @@ + subroutine bspp2d ( t, bcoef, n, k, m, scrtch, break, coef, l ) +c from * a practical guide to splines * by c. de boor +calls bsplvb +c this is an extended version of bsplpp for use with tensor products +c +converts the b-representation t, bcoef(.,j), n, k of some spline into +c its pp-representation break, coef(j,.,.), l, k , j=1, ..., m . +c +c****** i n p u t ****** +c t.....knot sequence, of length n+k +c bcoef(.,j) b-spline coefficient sequence, of length n ,j=1,...,m +c n.....length of bcoef and dimension of spline space spline(k,t) +c k.....order of the spline +c +c w a r n i n g . . . the restriction k .le. kmax (= 20) is impo- +c sed by the arbitrary dimension statement for biatx below, but +c is n o w h e r e c h e c k e d for. +c +c m number of data sets +c +c****** w o r k a r e a ****** +c scrtch of size (k,k,m), needed to contain bcoeffs of a piece of +c the spline and its k-1 derivatives for each of the m sets +c +c****** o u t p u t ****** +c break.....breakpoint sequence, of length l+1, contains (in increas- + +c ing order) the distinct points in the sequence t(k),...,t(n+1) +c coef(mm,.,.) array of size (k,n), with coef(mm,i,j) = (i-1)st der- +c ivative of mm-th spline at break(j) from the right, mm=1,.,m +c l.....number of polynomial pieces which make up the spline in the in- +c terval (t(k), t(n+1)) +c +c****** m e t h o d ****** +c for each breakpoint interval, the k relevant b-coeffs of the +c spline are found and then differenced repeatedly to get the b-coeffs + +c of all the derivatives of the spline on that interval. the spline and +c its first k-1 derivatives are then evaluated at the left end point + +c of that interval, using bsplvb repeatedly to obtain the values of +c all b-splines of the appropriate order at that point. +c +c parameter kmax = 20 + integer k,l,m,n, i,j,jp1,kmj,left,lsofar,mm + real bcoef(n,m),break(1),coef(m,k,1),t(1), scrtch(k,k,m) + * ,biatx(20),diff,fkmj,sum +c +c * ,biatx(kmax),diff,fkmj,sum +c dimension break(l+1),coef(k,l),t(n+k) +current fortran standard makes it impossible to specify the length of +c break , coef and t precisely without the introduction of otherwise +c superfluous additional arguments. + lsofar = 0 + break(1) = t(k) + do 50 left=k,n +c find the next nontrivial knot interval. + if (t(left+1) .eq. t(left)) go to 50 + lsofar = lsofar + 1 + break(lsofar+1) = t(left+1) + if (k .gt. 1) go to 9 + do 5 mm=1,m + 5 coef(mm,1,lsofar) = bcoef(left,mm) + go to 50 +c store the k b-spline coeff.s relevant to current knot interval + +c in scrtch(.,1) . + 9 do 10 i=1,k + do 10 mm=1,m + 10 scrtch(i,1,mm) = bcoef(left-k+i,mm) +c +c for j=1,...,k-1, compute the k-j b-spline coeff.s relevant to +c current knot interval for the j-th derivative by differencing +c those for the (j-1)st derivative, and store in scrtch(.,j+1) . + + do 20 jp1=2,k + j = jp1 - 1 + kmj = k - j + fkmj = float(kmj) + do 20 i=1,kmj + diff = (t(left+i) - t(left+i - kmj))/fkmj + if (diff .le. 0.) go to 20 + do 15 mm=1,m + 15 scrtch(i,jp1,mm) = + * (scrtch(i+1,j,mm) - scrtch(i,j,mm))/diff + 20 continue +c +c for j = 0, ..., k-1, find the values at t(left) of the j+1 + +c b-splines of order j+1 whose support contains the current +c knot interval from those of order j (in biatx ), then comb- + +c ine with the b-spline coeff.s (in scrtch(.,k-j) ) found earlier +c to compute the (k-j-1)st derivative at t(left) of the given +c spline. +c note. if the repeated calls to bsplvb are thought to gene- +c rate too much overhead, then replace the first call by +c biatx(1) = 1. +c and the subsequent call by the statement +c j = jp1 - 1 +c followed by a direct copy of the lines +c deltar(j) = t(left+j) - x +c ...... +c biatx(j+1) = saved +c from bsplvb . deltal(kmax) and deltar(kmax) would have to +c appear in a dimension statement, of course. +c + call bsplvb ( t, 1, 1, t(left), left, biatx ) + do 25 mm=1,m + 25 coef(mm,k,lsofar) = scrtch(1,k,mm) + do 30 jp1=2,k + call bsplvb ( t, jp1, 2, t(left), left, biatx ) + kmj = k+1 - jp1 + do 30 mm=1,m + sum = 0. + do 28 i=1,jp1 + 28 sum = biatx(i)*scrtch(i,kmj,mm) + sum + 30 coef(mm,kmj,lsofar) = sum + 50 continue + l = lsofar + return + end diff --git a/math/deboor/bvalue.f b/math/deboor/bvalue.f new file mode 100644 index 00000000..6b038939 --- /dev/null +++ b/math/deboor/bvalue.f @@ -0,0 +1,138 @@ + real function bvalue ( t, bcoef, n, k, x, jderiv ) +c from * a practical guide to splines * by c. de boor +calls interv +c +calculates value at x of jderiv-th derivative of spline from b-repr. +c the spline is taken to be continuous from the right. +c +c****** i n p u t ****** +c t, bcoef, n, k......forms the b-representation of the spline f to +c be evaluated. specifically, +c t.....knot sequence, of length n+k, assumed nondecreasing. +c bcoef.....b-coefficient sequence, of length n . +c n.....length of bcoef and dimension of spline(k,t), +c a s s u m e d positive . +c k.....order of the spline . +c +c w a r n i n g . . . the restriction k .le. kmax (=20) is imposed +c arbitrarily by the dimension statement for aj, dl, dr below, +c but is n o w h e r e c h e c k e d for. +c +c x.....the point at which to evaluate . +c jderiv.....integer giving the order of the derivative to be evaluated +c a s s u m e d to be zero or positive. +c +c****** o u t p u t ****** +c bvalue.....the value of the (jderiv)-th derivative of f at x . +c +c****** m e t h o d ****** +c the nontrivial knot interval (t(i),t(i+1)) containing x is lo- +c cated with the aid of interv . the k b-coeffs of f relevant for +c this interval are then obtained from bcoef (or taken to be zero if +c not explicitly available) and are then differenced jderiv times to +c obtain the b-coeffs of (d**jderiv)f relevant for that interval. +c precisely, with j = jderiv, we have from x.(12) of the text that +c +c (d**j)f = sum ( bcoef(.,j)*b(.,k-j,t) ) +c +c where +c / bcoef(.), , j .eq. 0 +c / +c bcoef(.,j) = / bcoef(.,j-1) - bcoef(.-1,j-1) +c / ----------------------------- , j .gt. 0 +c / (t(.+k-j) - t(.))/(k-j) +c +c then, we use repeatedly the fact that +c +c sum ( a(.)*b(.,m,t)(x) ) = sum ( a(.,x)*b(.,m-1,t)(x) ) +c with +c (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1) +c a(.,x) = --------------------------------------- +c (x - t(.)) + (t(.+m-1) - x) +c +c to write (d**j)f(x) eventually as a linear combination of b-splines +c of order 1 , and the coefficient for b(i,1,t)(x) must then be the +c desired number (d**j)f(x). (see x.(17)-(19) of text). +c +c parameter kmax = 20 + integer jderiv,k,n, i,ilo,imk,j,jc,jcmin,jcmax,jj,kmj,km1,mflag + * ,nmi,jdrvp1 + real bcoef(n),t(1),x, aj(20),dl(20),dr(20),fkmj +c real bcoef(n),t(1),x, aj(kmax),dl(kmax),dr(kmax),fkmj +c dimension t(n+k) +current fortran standard makes it impossible to specify the length of t +c precisely without the introduction of otherwise superfluous addition- +c al arguments. + bvalue = 0. + if (jderiv .ge. k) go to 99 +c +c *** find i s.t. 1 .le. i .lt. n+k and t(i) .lt. t(i+1) and +c t(i) .le. x .lt. t(i+1) . if no such i can be found, x lies +c outside the support of the spline f and bvalue = 0. +c (the asymmetry in this choice of i makes f rightcontinuous) + call interv ( t, n+k, x, i, mflag ) + if (mflag .ne. 0) go to 99 +c *** if k = 1 (and jderiv = 0), bvalue = bcoef(i). + km1 = k - 1 + if (km1 .gt. 0) go to 1 + bvalue = bcoef(i) + go to 99 +c +c *** store the k b-spline coefficients relevant for the knot interval +c (t(i),t(i+1)) in aj(1),...,aj(k) and compute dl(j) = x - t(i+1-j), +c dr(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable +c from input to zero. set any t.s not obtainable equal to t(1) or +c to t(n+k) appropriately. + 1 jcmin = 1 + imk = i - k + if (imk .ge. 0) go to 8 + jcmin = 1 - imk + do 5 j=1,i + 5 dl(j) = x - t(i+1-j) + do 6 j=i,km1 + aj(k-j) = 0. + 6 dl(j) = dl(i) + go to 10 + 8 do 9 j=1,km1 + 9 dl(j) = x - t(i+1-j) +c + 10 jcmax = k + nmi = n - i + if (nmi .ge. 0) go to 18 + jcmax = k + nmi + do 15 j=1,jcmax + 15 dr(j) = t(i+j) - x + do 16 j=jcmax,km1 + aj(j+1) = 0. + 16 dr(j) = dr(jcmax) + go to 20 + 18 do 19 j=1,km1 + 19 dr(j) = t(i+j) - x +c + 20 do 21 jc=jcmin,jcmax + 21 aj(jc) = bcoef(imk + jc) +c +c *** difference the coefficients jderiv times. + if (jderiv .eq. 0) go to 30 + do 23 j=1,jderiv + kmj = k-j + fkmj = float(kmj) + ilo = kmj + do 23 jj=1,kmj + aj(jj) = ((aj(jj+1) - aj(jj))/(dl(ilo) + dr(jj)))*fkmj + 23 ilo = ilo - 1 +c +c *** compute value at x in (t(i),t(i+1)) of jderiv-th derivative, +c given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv). + 30 if (jderiv .eq. km1) go to 39 + jdrvp1 = jderiv + 1 + do 33 j=jdrvp1,km1 + kmj = k-j + ilo = kmj + do 33 jj=1,kmj + aj(jj) = (aj(jj+1)*dl(ilo) + aj(jj)*dr(jj))/(dl(ilo)+dr(jj)) + 33 ilo = ilo - 1 + 39 bvalue = aj(1) +c + 99 return + end diff --git a/math/deboor/chol1d.f b/math/deboor/chol1d.f new file mode 100644 index 00000000..fa0434ab --- /dev/null +++ b/math/deboor/chol1d.f @@ -0,0 +1,58 @@ + subroutine chol1d ( p, v, qty, npoint, ncol, u, qu ) +c from * a practical guide to splines * by c. de boor +c from * a practical guide to splines * by c. de boor +c to be called in s m o o t h +constructs the upper three diags. in v(i,j), i=2,,npoint-1, j=1,3, of +c the matrix 6*(1-p)*q-transp.*(d**2)*q + p*r, then computes its +c l*l-transp. decomposition and stores it also in v, then applies +c forward and backsubstitution to the right side q-transp.*y in qty +c to obtain the solution in u . + integer ncol,npoint, i,npm1,npm2 + real p,qty(npoint),qu(npoint),u(npoint),v(npoint,7), prev,ratio + * ,six1mp,twop + npm1 = npoint - 1 +c construct 6*(1-p)*q-transp.*(d**2)*q + p*r + six1mp = 6.*(1.-p) + twop = 2.*p + do 2 i=2,npm1 + v(i,1) = six1mp*v(i,5) + twop*(v(i-1,4)+v(i,4)) + v(i,2) = six1mp*v(i,6) + p*v(i,4) + 2 v(i,3) = six1mp*v(i,7) + npm2 = npoint - 2 + if (npm2 .ge. 2) go to 10 + u(1) = 0. + u(2) = qty(2)/v(2,1) + u(3) = 0. + go to 41 +c factorization + 10 do 20 i=2,npm2 + ratio = v(i,2)/v(i,1) + v(i+1,1) = v(i+1,1) - ratio*v(i,2) + v(i+1,2) = v(i+1,2) - ratio*v(i,3) + v(i,2) = ratio + ratio = v(i,3)/v(i,1) + v(i+2,1) = v(i+2,1) - ratio*v(i,3) + 20 v(i,3) = ratio +c +c forward substitution + u(1) = 0. + v(1,3) = 0. + u(2) = qty(2) + do 30 i=2,npm2 + 30 u(i+1) = qty(i+1) - v(i,2)*u(i) - v(i-1,3)*u(i-1) +c back substitution + u(npoint) = 0. + u(npm1) = u(npm1)/v(npm1,1) + i = npm2 + 40 u(i) = u(i)/v(i,1)-u(i+1)*v(i,2)-u(i+2)*v(i,3) + i = i - 1 + if (i .gt. 1) go to 40 +c construct q*u + 41 prev = 0. + do 50 i=2,npoint + qu(i) = (u(i) - u(i-1))/v(i-1,4) + qu(i-1) = qu(i) - prev + 50 prev = qu(i) + qu(npoint) = -qu(npoint) + return + end diff --git a/math/deboor/colloc_io.f b/math/deboor/colloc_io.f new file mode 100644 index 00000000..023612f2 --- /dev/null +++ b/math/deboor/colloc_io.f @@ -0,0 +1,139 @@ + subroutine colloc(aleft,aright,lbegin,iorder,ntimes,addbrk,relerr,ier) +c from * a practical guide to splines * by c. de boor +chapter xv, example. solution of an ode by collocation. +calls colpnt, difequ(ppvalu(interv)), knots, eqblok(putit(difequ*, +c bsplvd(bsplvb)))), slvblk(various subprograms), bsplpp(bsplvb*), +c newnot +c +c****** i n p u t ****** +c aleft, aright endpoints of interval of approximation +c lbegin initial number of polynomial pieces in the approximation. +c a uniform breakpoint sequence is chosen. +c iorder order of polynomial pieces in the approximation +c ntimes number of passes through n e w n o t to be made +c addbrk the number (possibly fractional) of breaks to be added per +c pass through newnot. e.g., if addbrk = .33334, then a break- +c point will be added at every third pass through newnot. +c relerr a tolerance. newton iteration is stopped if the difference +c between the b-coeffs of two successive iterates is no more +c than relerr*(absol.largest b-coefficient). +c +c****** p r i n t e d o u t p u t ****** +c consists of the pp-representation of the approximate solution, +c and of the error at selected points. +c +c****** m e t h o d ****** +c the m-th order ordinary differential equation with m side condit- +c ions, to be specified in subroutine d i f e q u , is solved approx- +c imately by collocation. +c the approximation f to the solution g is pp of order k+m with +c l pieces and m-1 continuous derivatives. f is determined by the +c requirement that it satisfy the d.e. at k points per interval (to +c be specified in c o l p n t ) and the m side conditions. +c this usually nonlinear system of equations for f is solved by +c newton's method. the resulting linear system for the b-coeffs of an +c iterate is constructed appropriately in e q b l o k and then solved +c in s l v b l k , a program designed to solve a l m o s t b l o c k +c d i a g o n a l linear systems efficiently. +c there is an opportunity to attempt improvement of the breakpoint +c sequence (both in number and location) through use of n e w n o t . +c +c parameter npiece=100, ndim=200, ncoef=2000, lenblk=2000 +c integer iorder,lbegin,ntimes, i,iflag,ii,integs(3,npiece),iside +c * ,iter,itermx,k,kpm,l,lnew,m,n,nbloks,nncoef,nt + integer iorder,lbegin,ntimes, i,iflag,ii,integs(3,100),iside + * ,iter,itermx,k,kpm,l,lnew,m,n,nbloks,ncoef,nncoef,nt +c real addbrk,aleft,aright,relerr, a(ndim),amax,asave(ndim) +c * ,b(ndim),bloks(lenblk),break,coef,dx,err,rho,t(ndim) +c * ,templ(lenblk),temps(ndim),xside + real addbrk,aleft,aright,relerr, a(200),amax,asave(200) + * ,b(200),bloks(2000),break,coef,dx,err,rho,t(200) + * ,templ(2000),temps(200),xside + equivalence (bloks,templ) +c common /approx/ break(npiece), coef(ncoef), l,kpm + common /approx/ break(100), coef(2000), l,kpm + common /side/ m, iside, xside(10) + common /other/ itermx,k,rho(19) + data ncoef,lenblk / 2000,2000 / +c + ier = 0 + kpm = iorder + if (lbegin*kpm .gt. ncoef) go to 999 +c *** set the various parameters concerning the particular dif.equ. +c including a first approx. in case the de is to be solved by +c iteration ( itermx .gt. 0) . + call difequ (1, temps(1), temps ) +c *** obtain the k collocation points for the standard interval. + k = kpm - m + call colpnt ( k, rho ) +c *** the following five statements could be replaced by a read in or- +c der to obtain a specific (nonuniform) spacing of the breakpnts. + dx = (aright - aleft)/float(lbegin) + temps(1) = aleft + do 4 i=2,lbegin + 4 temps(i) = temps(i-1) + dx + temps(lbegin+1) = aright +c *** generate, in knots, the required knots t(1),...,t(n+kpm). + call knots ( temps, lbegin, kpm, t, n ) + nt = 1 +c *** generate the almost block diagonal coefficient matrix bloks and +c right side b from collocation equations and side conditions. +c then solve via slvblk , obtaining the b-representation of the ap- +c proximation in t , a , n , kpm . + 10 call eqblok(t,n,kpm,temps,a,bloks,lenblk,integs,nbloks,b) + call slvblk(bloks,integs,nbloks,b,temps,a,iflag) + iter = 1 + if (itermx .le. 1) go to 30 +c *** save b-spline coeff. of current approx. in asave , then get new +c approx. and compare with old. if coeff. are more than relerr +c apart (relatively) or if no. of iterations is less than itermx , +c continue iterating. + 20 call bsplpp(t,a,n,kpm,templ,break,coef,l) + do 25 i=1,n + 25 asave(i) = a(i) + call eqblok(t,n,kpm,temps,a,bloks,lenblk,integs,nbloks,b) + call slvblk(bloks,integs,nbloks,b,temps,a,iflag) + err = 0. + amax = 0. + do 26 i=1,n + amax = amax1(amax,abs(a(i))) + 26 err = amax1(err,abs(a(i)-asave(i))) + if (err .le. relerr*amax) go to 30 + iter = iter+1 + if (iter .lt. itermx) go to 20 +c *** iteration (if any) completed. print out approx. based on current +c breakpoint sequence, then try to improve the sequence. + 30 print 630,kpm,l,n,(break(i),i=2,l) + 630 format(47h approximation from a space of splines of order,i3 + * ,4h on ,i3,11h intervals,/13h of dimension,i4 + * ,16h. breakpoints -/(5e20.10)) + if (itermx .gt. 0) print 635,iter,itermx + 635 format(6h after,i3,3h of,i3,20h allowed iterations,) + call bsplpp(t,a,n,kpm,templ,break,coef,l) + print 637 + 637 format(46h the pp representation of the approximation is) + do 38 i=1,l + ii = (i-1)*kpm + 38 print 638, break(i),(coef(ii+j),j=1,kpm) + 638 format(f9.3,e13.6,10e11.3) +c *** the following call is provided here for possible further analysis +c of the approximation specific to the problem being solved. +c it is, of course, easily omitted. + call difequ ( 4, temps(1), temps ) +c + if (nt .gt. ntimes) return +c *** from the pp-rep. of the current approx., obtain in newnot a new +c (and possibly better) sequence of breakpoints, adding (on the ave- +c rage) a d d b r k breakpoints per pass through newnot. + lnew = lbegin + int(float(nt)*addbrk) + if (lnew*kpm .gt. ncoef) go to 999 + call newnot(break,coef,l,kpm,temps,lnew,templ) + call knots(temps,lnew,kpm,t,n) + nt = nt + 1 + go to 10 + 999 nncoef = ncoef + print 699,nncoef + 699 format(11h **********/23h the assigned dimension,i5 + * ,25h for coef is too small.) + return + end diff --git a/math/deboor/colpnt_io.f b/math/deboor/colpnt_io.f new file mode 100644 index 00000000..715541eb --- /dev/null +++ b/math/deboor/colpnt_io.f @@ -0,0 +1,65 @@ + subroutine colpnt(k,rho) +c from * a practical guide to splines * by c. de boor +c the k collocation points for the standard interval (-1,1) are sup- +c plied here as the zeros of the legendre polynomial of degree k , +c provided k .le. 8 . otherwise, uniformly spaced points are given. + integer k, j + real rho(k), fkm1o2 + if (k .gt. 8) go to 99 + go to (10,20,30,40,50,60,70,80),k + 10 rho(1) = 0. + return +c$ (single/double) dpdata + 20 rho(2) = .57735 02691 89626 d0 + rho(1) = - rho(2) + return + 30 rho(3) = .77459 66692 41483 d0 + rho(1) = - rho(3) + rho(2) = 0. + return + 40 rho(3) = .33998 10435 84856 d0 + rho(2) = - rho(3) + rho(4) = .86113 63115 94053 d0 + rho(1) = - rho(4) + return + 50 rho(4) = .53846 93101 05683 d0 + rho(2) = - rho(4) + rho(5) = .90617 98459 38664 d0 + rho(1) = - rho(5) + rho(3) = 0. + return + 60 rho(4) = .23861 91860 83197 d0 + rho(3) = - rho(4) + rho(5) = .66120 93864 66265 d0 + rho(2) = - rho(5) + rho(6) = .93246 95142 03152 d0 + rho(1) = - rho(6) + return + 70 rho(5) = .40584 51513 77397 d0 + rho(3) = - rho(5) + rho(6) = .74153 11855 99394 d0 + rho(2) = - rho(6) + rho(7) = .94910 79123 42759 d0 + rho(1) = - rho(7) + rho(4) = 0. + return + 80 rho(5) = .18343 46424 95650 d0 + rho(4) = - rho(5) + rho(6) = .52553 24099 16329 d0 + rho(3) = - rho(6) + rho(7) = .79666 64774 13627 d0 + rho(2) = - rho(7) + rho(8) = .96028 98564 97536 d0 + rho(1) = - rho(8) +c$lbl dpdata + return +c if k .gt. 8, use equispaced points, but print warning + 99 print 699,k + 699 format(11h **********/ + * 49h equispaced collocation points are used since k =,i2, + * 19h is greater than 8.) + fkm1o2 = float(k-1)/2. + do 100 j=1,k + 100 rho(j) = float(j-1)/fkm1o2 - 1. + return + end diff --git a/math/deboor/cubspl.f b/math/deboor/cubspl.f new file mode 100644 index 00000000..4bb54964 --- /dev/null +++ b/math/deboor/cubspl.f @@ -0,0 +1,119 @@ + subroutine cubspl ( tau, c, n, ibcbeg, ibcend ) +c from * a practical guide to splines * by c. de boor +c ************************ input *************************** +c n = number of data points. assumed to be .ge. 2. +c (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the +c data points. tau is assumed to be strictly increasing. +c ibcbeg, ibcend = boundary condition indicators, and +c c(2,1), c(2,n) = boundary condition information. specifically, +c ibcbeg = 0 means no boundary condition at tau(1) is given. +c in this case, the not-a-knot condition is used, i.e. the +c jump in the third derivative across tau(2) is forced to +c zero, thus the first and the second cubic polynomial pieces +c are made to coincide.) +c ibcbeg = 1 means that the slope at tau(1) is made to equal +c c(2,1), supplied by input. +c ibcbeg = 2 means that the second derivative at tau(1) is +c made to equal c(2,1), supplied by input. +c ibcend = 0, 1, or 2 has analogous meaning concerning the +c boundary condition at tau(n), with the additional infor- +c mation taken from c(2,n). +c *********************** output ************************** +c c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients +c of the cubic interpolating spline with interior knots (or +c joints) tau(2), ..., tau(n-1). precisely, in the interval +c interval (tau(i), tau(i+1)), the spline f is given by +c f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) +c where h = x - tau(i). the function program *ppvalu* may be +c used to evaluate f or its derivatives from tau,c, l = n-1, +c and k=4. + integer ibcbeg,ibcend,n, i,j,l,m + real c(4,n),tau(n), divdf1,divdf3,dtau,g +c****** a tridiagonal linear system for the unknown slopes s(i) of +c f at tau(i), i=1,...,n, is generated and then solved by gauss elim- +c ination, with s(i) ending up in c(2,i), all i. +c c(3,.) and c(4,.) are used initially for temporary storage. + l = n-1 +compute first differences of tau sequence and store in c(3,.). also, +compute first divided difference of data and store in c(4,.). + do 10 m=2,n + c(3,m) = tau(m) - tau(m-1) + 10 c(4,m) = (c(1,m) - c(1,m-1))/c(3,m) +construct first equation from the boundary condition, of the form +c c(4,1)*s(1) + c(3,1)*s(2) = c(2,1) + if (ibcbeg-1) 11,15,16 + 11 if (n .gt. 2) go to 12 +c no condition at left end and n = 2. + c(4,1) = 1. + c(3,1) = 1. + c(2,1) = 2.*c(4,2) + go to 25 +c not-a-knot condition at left end and n .gt. 2. + 12 c(4,1) = c(3,3) + c(3,1) = c(3,2) + c(3,3) + c(2,1) =((c(3,2)+2.*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1) + go to 19 +c slope prescribed at left end. + 15 c(4,1) = 1. + c(3,1) = 0. + go to 18 +c second derivative prescribed at left end. + 16 c(4,1) = 2. + c(3,1) = 1. + c(2,1) = 3.*c(4,2) - c(3,2)/2.*c(2,1) + 18 if(n .eq. 2) go to 25 +c if there are interior knots, generate the corresp. equations and car- +c ry out the forward pass of gauss elimination, after which the m-th +c equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m). + 19 do 20 m=2,l + g = -c(3,m+1)/c(4,m-1) + c(2,m) = g*c(2,m-1) + 3.*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m)) + 20 c(4,m) = g*c(3,m-1) + 2.*(c(3,m) + c(3,m+1)) +construct last equation from the second boundary condition, of the form +c (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n) +c if slope is prescribed at right end, one can go directly to back- +c substitution, since c array happens to be set up just right for it +c at this point. + if (ibcend-1) 21,30,24 + 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22 +c not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at +c left end point. + g = c(3,n-1) + c(3,n) + c(2,n) = ((c(3,n)+2.*g)*c(4,n)*c(3,n-1) + * + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g + g = -g/c(4,n-1) + c(4,n) = c(3,n-1) + go to 29 +c either (n=3 and not-a-knot also at left) or (n=2 and not not-a- +c knot at left end point). + 22 c(2,n) = 2.*c(4,n) + c(4,n) = 1. + go to 28 +c second derivative prescribed at right endpoint. + 24 c(2,n) = 3.*c(4,n) + c(3,n)/2.*c(2,n) + c(4,n) = 2. + go to 28 + 25 if (ibcend-1) 26,30,24 + 26 if (ibcbeg .gt. 0) go to 22 +c not-a-knot at right endpoint and at left endpoint and n = 2. + c(2,n) = c(4,n) + go to 30 + 28 g = -1./c(4,n-1) +complete forward pass of gauss elimination. + 29 c(4,n) = g*c(3,n-1) + c(4,n) + c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n) +carry out back substitution + 30 j = l + 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j) + j = j - 1 + if (j .gt. 0) go to 40 +c****** generate cubic coefficients in each interval, i.e., the deriv.s +c at its left endpoint, from value and slope at its endpoints. + do 50 i=2,n + dtau = c(3,i) + divdf1 = (c(1,i) - c(1,i-1))/dtau + divdf3 = c(2,i-1) + c(2,i) - 2.*divdf1 + c(3,i-1) = 2.*(divdf1 - c(2,i-1) - divdf3)/dtau + 50 c(4,i-1) = (divdf3/dtau)*(6./dtau) + return + end diff --git a/math/deboor/cwidth.f b/math/deboor/cwidth.f new file mode 100644 index 00000000..93b976b6 --- /dev/null +++ b/math/deboor/cwidth.f @@ -0,0 +1,220 @@ + subroutine cwidth ( w,b,nequ,ncols,integs,nbloks, d, x,iflag ) +c this program is a variation of the theme in the algorithm bandet1 +c by martin and wilkinson (numer.math. 9(1976)279-307). it solves +c the linear system +c a*x = b +c of nequ equations in case a is almost block diagonal with all +c blocks having ncols columns using no more storage than it takes to + +c store the interesting part of a . such systems occur in the determ- + +c ination of the b-spline coefficients of a spline approximation. +c +c parameters +c w on input, a two-dimensional array of size (nequ,ncols) contain- +c ing the interesting part of the almost block diagonal coeffici- +c ent matrix a (see description and example below). the array +c integs describes the storage scheme. +c on output, w contains the upper triangular factor u of the +c lu factorization of a possibly permuted version of a . in par- +c ticular, the determinant of a could now be found as +c iflag*w(1,1)*w(2,1)* ... * w(nequ,1) . +c b on input, the right side of the linear system, of length nequ. +c the contents of b are changed during execution. +c nequ number of equations in system +c ncols block width, i.e., number of columns in each block. +c integs integer array, of size (2,nequ), describing the block struct- +c ure of a . +c integs(1,i) = no. of rows in block i = nrow +c integs(2,i) = no. of elimination steps in block i +c = overhang over next block = last +c nbloks number of blocks +c d work array, to contain row sizes . if storage is scarce, the +c array x could be used in the calling sequence for d . +c x on output, contains computed solution (if iflag .ne. 0), of +c length nequ . +c iflag on output, integer +c = (-1)**(no.of interchanges during elimination) +c if a is invertible +c = 0 if a is singular +c +c ------ block structure of a ------ +c the interesting part of a is taken to consist of nbloks con- +c secutive blocks, with the i-th block made up of nrowi = integs(1,i) + +c consecutive rows and ncols consecutive columns of a , and with +c the first lasti = integs(2,i) columns to the left of the next block. +c these blocks are stored consecutively in the workarray w . +c for example, here is an 11th order matrix and its arrangement in +c the workarray w . (the interesting entries of a are indicated by +c their row and column index modulo 10.) +c +c --- a --- --- w --- + +c +c nrow1=3 +c 11 12 13 14 11 12 13 14 +c 21 22 23 24 21 22 23 24 +c 31 32 33 34 nrow2=2 31 32 33 34 +c last1=2 43 44 45 46 43 44 45 46 +c 53 54 55 56 nrow3=3 53 54 55 56 +c last2=3 66 67 68 69 66 67 68 69 +c 76 77 78 79 76 77 78 79 +c 86 87 88 89 nrow4=1 86 87 88 89 +c last3=1 97 98 99 90 nrow5=2 97 98 99 90 +c last4=1 08 09 00 01 08 09 00 01 +c 18 19 10 11 18 19 10 11 +c last5=4 +c +c for this interpretation of a as an almost block diagonal matrix, +c we have nbloks = 5 , and the integs array is +c +c i= 1 2 3 4 5 +c k= +c integs(k,i) = 1 3 2 3 1 2 +c 2 2 3 1 1 4 +c +c -------- method -------- +c gauss elimination with scaled partial pivoting is used, but mult- + +c ipliers are n o t s a v e d in order to save storage. rather, the + +c right side is operated on during elimination. +c the two parameters +c i p v t e q and l a s t e q +c are used to keep track of the action. ipvteq is the index of the +c variable to be eliminated next, from equations ipvteq+1,...,lasteq, + +c using equation ipvteq (possibly after an interchange) as the pivot +c equation. the entries in the pivot column are a l w a y s in column +c 1 of w . this is accomplished by putting the entries in rows +c ipvteq+1,...,lasteq revised by the elimination of the ipvteq-th +c variable one to the left in w . in this way, the columns of the +c equations in a given block (as stored in w ) will be aligned with +c those of the next block at the moment when these next equations be- +c come involved in the elimination process. +c thus, for the above example, the first elimination steps proceed +c as follows. +c +c *11 12 13 14 11 12 13 14 11 12 13 14 11 12 13 14 +c *21 22 23 24 *22 23 24 22 23 24 22 23 24 +c *31 32 33 34 *32 33 34 *33 34 33 34 +c 43 44 45 46 43 44 45 46 *43 44 45 46 *44 45 46 etc. +c 53 54 55 56 53 54 55 56 *53 54 55 56 *54 55 56 +c 66 67 68 69 66 67 68 69 66 67 68 69 66 67 68 69 +c . . . . +c +c in all other respects, the procedure is standard, including the +c scaled partial pivoting. +c + integer nbloks, ipvtp1, jmax + integer iflag,integs(2,nbloks),ncols,nequ, i,ii,icount,ipvteq + * ,istar,j,lastcl,lasteq,lasti,nexteq,nrowad + real b(nequ),d(nequ),w(nequ,ncols),x(nequ), awi1od,colmax + * ,ratio,sum ,rowmax,temp + iflag = 1 + ipvteq = 0 + lasteq = 0 +c the i-loop runs over the blocks + do 50 i=1,nbloks +c +c the equations for the current block are added to those current- +c ly involved in the elimination process, by increasing lasteq +c by integs(1,i) after the rowsize of these equations has been +c recorded in the array d . +c + nrowad = integs(1,i) + do 10 icount=1,nrowad + nexteq = lasteq + icount + rowmax = 0. + do 5 j=1,ncols + 5 rowmax = amax1(rowmax,abs(w(nexteq,j))) + if (rowmax .eq. 0.) go to 999 + 10 d(nexteq) = rowmax + lasteq = lasteq + nrowad +c +c there will be lasti = integs(2,i) elimination steps before +c the equations in the next block become involved. further, +c l a s t c l records the number of columns involved in the cur- +c rent elimination step. it starts equal to ncols when a block + +c first becomes involved and then drops by one after each elim- +c ination step. +c + lastcl = ncols + lasti = integs(2,i) + do 30 icount=1,lasti + ipvteq = ipvteq + 1 + if (ipvteq .lt. lasteq) go to 11 + if ( abs(w(ipvteq,1))+d(ipvteq) .gt. d(ipvteq) ) + * go to 50 + go to 999 +c +c determine the smallest i s t a r in (ipvteq,lasteq) for +c which abs(w(istar,1))/d(istar) is as large as possible, and +c interchange equations ipvteq and istar in case ipvteq +c .lt. istar . +c + 11 colmax = abs(w(ipvteq,1))/d(ipvteq) + istar = ipvteq + ipvtp1 = ipvteq + 1 + do 13 ii=ipvtp1,lasteq + awi1od = abs(w(ii,1))/d(ii) + if (awi1od .le. colmax) go to 13 + colmax = awi1od + istar = ii + 13 continue + if ( abs(w(istar,1))+d(istar) .eq. d(istar) ) + * go to 999 + if (istar .eq. ipvteq) go to 16 + iflag = -iflag + temp = d(istar) + d(istar) = d(ipvteq) + d(ipvteq) = temp + temp = b(istar) + b(istar) = b(ipvteq) + b(ipvteq) = temp + do 14 j=1,lastcl + temp = w(istar,j) + w(istar,j) = w(ipvteq,j) + 14 w(ipvteq,j) = temp +c +c subtract the appropriate multiple of equation ipvteq from +c equations ipvteq+1,...,lasteq to make the coefficient of the +c ipvteq-th unknown (presently in column 1 of w ) zero, but +c store the new coefficients in w one to the left from the old. +c + 16 do 20 ii=ipvtp1,lasteq + ratio = w(ii,1)/w(ipvteq,1) + do 18 j=2,lastcl + 18 w(ii,j-1) = w(ii,j) - ratio*w(ipvteq,j) + w(ii,lastcl) = 0. + 20 b(ii) = b(ii) - ratio*b(ipvteq) + 30 lastcl = lastcl - 1 + 50 continue +c +c at this point, w and b contain an upper triangular linear system + +c equivalent to the original one, with w(i,j) containing entry +c (i, i-1+j ) of the coefficient matrix. solve this system by backsub- + +c stitution, taking into account its block structure. +c +c i-loop over the blocks, in reverse order + i = nbloks + 59 lasti = integs(2,i) + jmax = ncols - lasti + do 70 icount=1,lasti + sum = 0. + if (jmax .eq. 0) go to 61 + do 60 j=1,jmax + 60 sum = sum + x(ipvteq+j)*w(ipvteq,j+1) + 61 x(ipvteq) = (b(ipvteq)-sum)/w(ipvteq,1) + jmax = jmax + 1 + 70 ipvteq = ipvteq - 1 + i = i - 1 + if (i .gt. 0) go to 59 + return + 999 iflag = 0 + return + end diff --git a/math/deboor/difequ_io.f b/math/deboor/difequ_io.f new file mode 100644 index 00000000..a8bc2709 --- /dev/null +++ b/math/deboor/difequ_io.f @@ -0,0 +1,100 @@ + subroutine difequ ( mode, xx, v ) +c from * a practical guide to splines * by c. de boor +calls ppvalu(interv) +c to be called by c o l l o c , p u t i t +c information about the differential equation is dispensed from here +c +c****** i n p u t ****** +c mode an integer indicating the task to be performed. +c = 1 initialization +c = 2 evaluate de at xx +c = 3 specify the next side condition +c = 4 analyze the approximation +c xx a point at which information is wanted +c +c****** o u t p u t ****** +c v depends on the mode . see comments below +c +c parameter npiece=100,ncoef=2000 + integer mode, i,iside,itermx,k,kpm,l,m + real v(20),xx, break,coef,eps,ep1,ep2,error,factor,rho,solutn + * ,s2ovep,un,x,xside + real ppvalu +c common /approx/ break(npiece),coef(ncoef),l,kpm + common /approx/ break(100),coef(2000),l,kpm + common /side/ m,iside,xside(10) + common /other/ itermx,k,rho(19) +c +c this sample of difequ is for the example in chapter xv. it is a +c nonlinear second order two point boundary value problem. +c + go to (10,20,30,40),mode +c initialize everything +c i.e. set the order m of the dif.equ., the nondecreasing sequence +c xside(i),i=1,...,m, of points at which side cond.s are given and +c anything else necessary. + 10 m = 2 + xside(1) = 0. + xside(2) = 1. +c *** print out heading + print 499 + 499 format(37h carrier,s nonlinear perturb. problem) + eps = .5e-2 + print 610, eps + 610 format(5h eps ,e20.10) +c *** set constants used in formula for solution below. + factor = (sqrt(2.) + sqrt(3.))**2 + s2ovep = sqrt(2./eps) +c *** initial guess for newton iteration. un(x) = x*x - 1. + l = 1 + break(1) = 0. + do 16 i=1,kpm + 16 coef(i) = 0. + coef(1) = -1. + coef(3) = 2. + itermx = 10 + return +c +c provide value of left side coeff.s and right side at xx . +c specifically, at xx the dif.equ. reads +c v(m+1)d**m + v(m)d**(m-1) + ... + v(1)d**0 = v(m+2) +c in terms of the quantities v(i),i=1,...,m+2, to be computed here. + 20 continue + v(3) = eps + v(2) = 0. + un = ppvalu(break,coef,l,kpm,xx,0) + v(1) = 2.*un + v(4) = un**2 + 1. + return +c +c provide the m side conditions. these conditions are of the form +c v(m+1)d**m + v(m)d**(m-1) + ... + v(1)d**0 = v(m+2) +c in terms of the quantities v(i),i=1,...,m+2, to be specified here. +c note that v(m+1) = 0 for customary side conditions. + 30 v(m+1) = 0. + go to (31,32,39),iside + 31 v(2) = 1. + v(1) = 0. + v(4) = 0. + go to 38 + 32 v(2) = 0. + v(1) = 1. + v(4) = 0. + 38 iside = iside + 1 + 39 return +c +c calculate the error near the boundary layer at 1. + 40 continue + print 640 + 640 format(44h x, g(x) and g(x)-f(x) at selected points) + x = .75 + do 41 i=1,9 + ep1 = exp(s2ovep*(1.-x))*factor + ep2 = exp(s2ovep*(1.+x))*factor + solutn = 12./(1.+ep1)**2*ep1 + 12./(1.+ep2)**2*ep2 - 1. + error = solutn - ppvalu(break,coef,l,kpm,x,0) + print 641,x,solutn,error + 641 format(3e20.10) + 41 x = x + .03125 + return + end diff --git a/math/deboor/dtblok.f b/math/deboor/dtblok.f new file mode 100644 index 00000000..57e67ae6 --- /dev/null +++ b/math/deboor/dtblok.f @@ -0,0 +1,36 @@ + subroutine dtblok ( bloks, integs, nbloks, ipivot, iflag, + * detsgn, detlog ) +c computes the determinant of an almost block diagonal matrix whose +c plu factorization has been obtained previously in fcblok. +c *** the logarithm of the determinant is computed instead of the +c determinant itself to avoid the danger of overflow or underflow +c inherent in this calculation. +c +c parameters +c bloks, integs, nbloks, ipivot, iflag are as on return from fcblok. +c in particular, iflag = (-1)**(number of interchanges dur- +c ing factorization) if successful, otherwise iflag = 0. +c detsgn on output, contains the sign of the determinant. +c detlog on output, contains the natural logarithm of the determi- +c nant if determinant is not zero. otherwise contains 0. +c + integer nbloks, index, nrow + integer integs(3,nbloks),ipivot(1),iflag, i,indexp,ip,k,last + real bloks(1),detsgn,detlog +c + detsgn = iflag + detlog = 0. + if (iflag .eq. 0) return + index = 0 + indexp = 0 + do 2 i=1,nbloks + nrow = integs(1,i) + last = integs(3,i) + do 1 k=1,last + ip = index + nrow*(k-1) + ipivot(indexp+k) + detlog = detlog + alog(abs(bloks(ip))) + 1 detsgn = detsgn*sign(1.,bloks(ip)) + index = nrow*integs(2,i) + index + 2 indexp = indexp + nrow + return + end diff --git a/math/deboor/eqblok_io.f b/math/deboor/eqblok_io.f new file mode 100644 index 00000000..9c8f4f5b --- /dev/null +++ b/math/deboor/eqblok_io.f @@ -0,0 +1,91 @@ + subroutine eqblok ( t, n, kpm, work1, work2, + * bloks, lenblk, integs, nbloks, b ) +c from * a practical guide to splines * by c. de boor +calls putit(difequ,bsplvd(bsplvb)) +c to be called in c o l l o c +c +c****** i n p u t ****** +c t the knot sequence, of length n+kpm +c n the dimension of the approximating spline space, i.e., the order +c of the linear system to be constructed. +c kpm = k+m, the order of the approximating spline +c lenblk the maximum length of the array bloks as allowed by the +c dimension statement in colloc . +c +c****** w o r k a r e a s ****** +c work1 used in putit, of size (kpm,kpm) +c work2 used in putit, of size (kpm,m+1) +c +c****** o u t p u t ****** +c bloks the coefficient matrix of the linear system, stored in al- +c most block diagonal form, of size +c kpm*sum(integs(1,i) , i=1,...,nbloks) +c integs an integer array, of size (3,nbloks), describing the block +c structure. +c integs(1,i) = number of rows in block i +c integs(2,i) = number of columns in block i +c integs(3,i) = number of elimination steps which can be +c carried out in block i before pivoting might +c bring in an equation from the next block. +c nbloks number of blocks, equals number of polynomial pieces +c b the right side of the linear system, stored corresponding to the +c almost block diagonal form, of size sum(integs(1,i) , i=1,..., +c nbloks). +c +c****** m e t h o d ****** +c each breakpoint interval gives rise to a block in the linear system. +c this block is determined by the k colloc.equations in the interval +c with the side conditions (if any) in the interval interspersed ap- +c propriately, and involves the kpm b-splines having the interval in +c their support. correspondingly, such a block has nrow = k + isidel +c rows, with isidel = number of side conditions in this and the prev- +c ious intervals, and ncol = kpm columns. +c further, because the interior knots have multiplicity k, we can +c carry out (in slvblk) k elimination steps in a block before pivot- +c ing might involve an equation from the next block. in the last block, +c of course, all kpm elimination steps will be carried out (in slvblk). +c +c see the detailed comments in the solveblok package for further in- +c formation about the almost block diagonal form used here. + integer integs(3,1),kpm,lenblk,n,nbloks, i,index,indexb,iside + * ,isidel,itermx,k,left,m,nrow + real b(1),bloks(1),t(1),work1(1),work2(1), rho,xside + common /side/ m, iside, xside(10) + common /other/ itermx,k,rho(19) + index = 1 + indexb = 1 + i = 0 + iside = 1 + do 20 left=kpm,n,k + i = i+1 +c determine integs(.,i) + integs(2,i) = kpm + if (left .lt. n) go to 14 + integs(3,i) = kpm + isidel = m + go to 16 + 14 integs(3,i) = k +c at this point, iside-1 gives the number of side conditions +c incorporated so far. adding to this the side conditions in the +c current interval gives the number isidel . + isidel = iside-1 + 15 if (isidel .eq. m) go to 16 + if (xside(isidel+1) .ge. t(left+1)) + * go to 16 + isidel = isidel+1 + go to 15 + 16 nrow = k + isidel + integs(1,i) = nrow +c the detailed equations for this block are generated and put +c together in p u t i t . + if (lenblk .lt. index+nrow*kpm-1)go to 999 + call putit(t,kpm,left,work1,work2,bloks(index),nrow,b(indexb)) + index = index + nrow*kpm + 20 indexb = indexb + nrow + nbloks = i + return + 999 print 699,lenblk + 699 format(11h **********/23h the assigned dimension,i5 + * ,38h for bloks in colloc is too small.) + stop + end diff --git a/math/deboor/factrb.f b/math/deboor/factrb.f new file mode 100644 index 00000000..4bb88e13 --- /dev/null +++ b/math/deboor/factrb.f @@ -0,0 +1,87 @@ + subroutine factrb ( w, ipivot, d, nrow, ncol, last, iflag ) +c adapted from p.132 of 'element.numer.analysis' by conte-de boor +c +c constructs a partial plu factorization, corresponding to steps 1,..., +c l a s t in gauss elimination, for the matrix w of order +c ( n r o w , n c o l ), using pivoting of scaled rows. +c +c parameters +c w contains the (nrow,ncol) matrix to be partially factored +c on input, and the partial factorization on output. +c ipivot an integer array of length nrow containing a record of the +c pivoting strategy used; row ipivot(i) is used during the +c i-th elimination step, i=1,...,last. +c d a work array of length nrow used to store row sizes +c temporarily. +c nrow number of rows of w. +c ncol number of columns of w. +c last number of elimination steps to be carried out. +c iflag on output, equals iflag on input times (-1)**(number of +c row interchanges during the factorization process), in +c case no zero pivot was encountered. +c otherwise, iflag = 0 on output. +c + integer nrow + integer ipivot(nrow),ncol,last,iflag, i,ipivi,ipivk,j,k,kp1 + real w(nrow,ncol),d(nrow), awikdi,colmax,ratio,rowmax +c initialize ipivot, d + do 10 i=1,nrow + ipivot(i) = i + rowmax = 0. + do 9 j=1,ncol + 9 rowmax = amax1(rowmax, abs(w(i,j))) + if (rowmax .eq. 0.) go to 999 + 10 d(i) = rowmax +c gauss elimination with pivoting of scaled rows, loop over k=1,.,last + k = 1 +c as pivot row for k-th step, pick among the rows not yet used, +c i.e., from rows ipivot(k),...,ipivot(nrow), the one whose k-th +c entry (compared to the row size) is largest. then, if this row +c does not turn out to be row ipivot(k), redefine ipivot(k) ap- +c propriately and record this interchange by changing the sign +c of i f l a g . + 11 ipivk = ipivot(k) + if (k .eq. nrow) go to 21 + j = k + kp1 = k+1 + colmax = abs(w(ipivk,k))/d(ipivk) +c find the (relatively) largest pivot + do 15 i=kp1,nrow + ipivi = ipivot(i) + awikdi = abs(w(ipivi,k))/d(ipivi) + if (awikdi .le. colmax) go to 15 + colmax = awikdi + j = i + 15 continue + if (j .eq. k) go to 16 + ipivk = ipivot(j) + ipivot(j) = ipivot(k) + ipivot(k) = ipivk + iflag = -iflag + 16 continue +c if pivot element is too small in absolute value, declare +c matrix to be noninvertible and quit. + if (abs(w(ipivk,k))+d(ipivk) .le. d(ipivk)) + * go to 999 +c otherwise, subtract the appropriate multiple of the pivot +c row from remaining rows, i.e., the rows ipivot(k+1),..., +c ipivot(nrow), to make k-th entry zero. save the multiplier in +c its place. + do 20 i=kp1,nrow + ipivi = ipivot(i) + w(ipivi,k) = w(ipivi,k)/w(ipivk,k) + ratio = -w(ipivi,k) + do 20 j=kp1,ncol + 20 w(ipivi,j) = ratio*w(ipivk,j) + w(ipivi,j) + k = kp1 +c check for having reached the next block. + if (k .le. last) go to 11 + return +c if last .eq. nrow , check now that pivot element in last row +c is nonzero. + 21 if( abs(w(ipivk,nrow))+d(ipivk) .gt. d(ipivk) ) + * return +c singularity flag set + 999 iflag = 0 + return + end diff --git a/math/deboor/fcblok.f b/math/deboor/fcblok.f new file mode 100644 index 00000000..db7b20ec --- /dev/null +++ b/math/deboor/fcblok.f @@ -0,0 +1,56 @@ + subroutine fcblok ( bloks, integs, nbloks, ipivot, scrtch, iflag ) +calls subroutines f a c t r b and s h i f t b . +c +c f c b l o k supervises the plu factorization with pivoting of +c scaled rows of the almost block diagonal matrix stored in the arrays +c b l o k s and i n t e g s . +c +c factrb = subprogram which carries out steps 1,...,last of gauss +c elimination (with pivoting) for an individual block. +c shiftb = subprogram which shifts the remaining rows to the top of +c the next block +c +c parameters +c bloks an array that initially contains the almost block diagonal +c matrix a to be factored, and on return contains the com- +c puted factorization of a . +c integs an integer array describing the block structure of a . +c nbloks the number of blocks in a . +c ipivot an integer array of dimension sum (integs(1,n) ; n=1, +c ...,nbloks) which, on return, contains the pivoting stra- +c tegy used. +c scrtch work area required, of length max (integs(1,n) ; n=1, +c ...,nbloks). +c iflag output parameter; +c = 0 in case matrix was found to be singular. +c otherwise, +c = (-1)**(number of row interchanges during factorization) +c + integer nbloks + integer integs(3,nbloks),ipivot(1),iflag, i,index,indexb,indexn, + * last,ncol,nrow + real bloks(1),scrtch(1) + iflag = 1 + indexb = 1 + indexn = 1 + i = 1 +c loop over the blocks. i is loop index + 10 index = indexn + nrow = integs(1,i) + ncol = integs(2,i) + last = integs(3,i) +c carry out elimination on the i-th block until next block +c enters, i.e., for columns 1,...,last of i-th block. + call factrb(bloks(index),ipivot(indexb),scrtch,nrow,ncol,last, + * iflag) +c check for having reached a singular block or the last block + if (iflag .eq. 0 .or. i .eq. nbloks) + * return + i = i+1 + indexn = nrow*ncol + index +c put the rest of the i-th block onto the next block + call shiftb(bloks(index),ipivot(indexb),nrow,ncol,last, + * bloks(indexn),integs(1,i),integs(2,i)) + indexb = indexb + nrow + go to 10 + end diff --git a/math/deboor/fsplin.x b/math/deboor/fsplin.x new file mode 100644 index 00000000..ba290e05 --- /dev/null +++ b/math/deboor/fsplin.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include "bspln.h" + +.help fsplin 2 "math library" +.ih +NAME +fsplin -- fast fit of b-spline interpolant. +.ih +USAGE +fsplin (y, q, bspln) +.ih +PARAMETERS +.ls y +(real[n]). Array of y-values of new data set. +.le +.ls q +(real[(2*k-1)*n]). Array containing the triangular factorization of the +coefficient matrix of the linear system for the b-spline coefficients of +the spline interpolant of dimension N and order K. Q is produced by a +prior call to SPLINE. +.le +.ls bspln +(real[2*n+30]). The spline descriptor array. On input to FSPLIN, should +contain a valid spline header (containing N, K, etc.), and knot array. +As long as SPLINE is called before FSPLIN, the bspln array will be set up +properly. On output, the N b-spline coefficients are stored in BSPLN, +ready for immediate input to SEVAL to evaluate the spline. +.le +.ih +DESCRIPTION +Fsplin is used following an initial SPLINE to efficiently fit a Kth order +b-spline to a data set that differs from the data set input to SPLINE only +in the y-values of the data points. SPLINE and FSPLIN are used to +interpolate an arbitrary array of data points (x,y), by fitting a piecewise +Kth order curve, continuous in the first K-1 derivatives, through the +data points. +.ih +SOURCE +See Carl De Boor, "A Practical Guide to Splines", pg. 204-207. +.ih +SEE ALSO +spline(2), seval(2) +.endhelp ______________________________________________________________ + + +procedure fsplin (y, q, bspln) + +real y[ARB], q[ARB] +real bspln[ARB] +int n, k, offset, i + +begin + offset = COEF1 - 1 #copy data into COEF array + do i = 1, NCOEF + bspln[offset+i] = y[i] + + n = NCOEF + k = ORDER + + call banslv (q, 2*k - 1, n, k-1, k-1, bspln[offset+1]) +end diff --git a/math/deboor/interv.f b/math/deboor/interv.f new file mode 100644 index 00000000..e2116616 --- /dev/null +++ b/math/deboor/interv.f @@ -0,0 +1,95 @@ + subroutine interv ( xt, lxt, x, left, mflag ) +c from * a practical guide to splines * by c. de boor +computes left = max( i , 1 .le. i .le. lxt .and. xt(i) .le. x ) . +c +c****** i n p u t ****** +c xt.....a real sequence, of length lxt , assumed to be nondecreasing +c lxt.....number of terms in the sequence xt . +c x.....the point whose location with respect to the sequence xt is +c to be determined. +c +c****** o u t p u t ****** +c left, mflag.....both integers, whose value is +c +c 1 -1 if x .lt. xt(1) +c i 0 if xt(i) .le. x .lt. xt(i+1) +c lxt 1 if xt(lxt) .le. x +c +c in particular, mflag = 0 is the 'usual' case. mflag .ne. 0 +c indicates that x lies outside the halfopen interval +c xt(1) .le. y .lt. xt(lxt) . the asymmetric treatment of the +c interval is due to the decision to make all pp functions cont- +c inuous from the right. +c +c****** m e t h o d ****** +c the program is designed to be efficient in the common situation that +c it is called repeatedly, with x taken from an increasing or decrea- +c sing sequence. this will happen, e.g., when a pp function is to be +c graphed. the first guess for left is therefore taken to be the val- +c ue returned at the previous call and stored in the l o c a l varia- +c ble ilo . a first check ascertains that ilo .lt. lxt (this is nec- +c essary since the present call may have nothing to do with the previ- +c ous call). then, if xt(ilo) .le. x .lt. xt(ilo+1), we set left = +c ilo and are done after just three comparisons. +c otherwise, we repeatedly double the difference istep = ihi - ilo +c while also moving ilo and ihi in the direction of x , until +c xt(ilo) .le. x .lt. xt(ihi) , +c after which we use bisection to get, in addition, ilo+1 = ihi . +c left = ilo is then returned. +c + integer left,lxt,mflag, ihi,ilo,istep,middle + real x,xt(lxt) + data ilo /1/ +c save ilo (a valid fortran statement in the new 1977 standard) + ihi = ilo + 1 + if (ihi .lt. lxt) go to 20 + if (x .ge. xt(lxt)) go to 110 + if (lxt .le. 1) go to 90 + ilo = lxt - 1 + ihi = lxt +c + 20 if (x .ge. xt(ihi)) go to 40 + if (x .ge. xt(ilo)) go to 100 +c +c **** now x .lt. xt(ilo) . decrease ilo to capture x . + istep = 1 + 31 ihi = ilo + ilo = ihi - istep + if (ilo .le. 1) go to 35 + if (x .ge. xt(ilo)) go to 50 + istep = istep*2 + go to 31 + 35 ilo = 1 + if (x .lt. xt(1)) go to 90 + go to 50 +c **** now x .ge. xt(ihi) . increase ihi to capture x . + 40 istep = 1 + 41 ilo = ihi + ihi = ilo + istep + if (ihi .ge. lxt) go to 45 + if (x .lt. xt(ihi)) go to 50 + istep = istep*2 + go to 41 + 45 if (x .ge. xt(lxt)) go to 110 + ihi = lxt +c +c **** now xt(ilo) .le. x .lt. xt(ihi) . narrow the interval. + 50 middle = (ilo + ihi)/2 + if (middle .eq. ilo) go to 100 +c note. it is assumed that middle = ilo in case ihi = ilo+1 . + if (x .lt. xt(middle)) go to 53 + ilo = middle + go to 50 + 53 ihi = middle + go to 50 +c**** set output and return. + 90 mflag = -1 + left = 1 + return + 100 mflag = 0 + left = ilo + return + 110 mflag = 1 + left = lxt + return + end diff --git a/math/deboor/knots.f b/math/deboor/knots.f new file mode 100644 index 00000000..ad73f964 --- /dev/null +++ b/math/deboor/knots.f @@ -0,0 +1,38 @@ + subroutine knots ( break, l, kpm, t, n ) +c from * a practical guide to splines * by c. de boor +c to be called in c o l l o c . +c constructs from the given breakpoint sequence b r e a k the knot +c sequence t so that +c spline(k+m,t) = pp(k+m,break) with m-1 continuous derivatives . +c this means that +c t(1),...,t(n+kpm) = break(1) kpm times, then break(2),..., +c break(l) each k times, then, finally, break(l+1) kpm times. +c +c****** i n p u t ****** +c break(1),...,break(l+1) breakpoint sequence +c l number of intervals or pieces +c kpm = k + m, order of the pp function or spline +c +c****** o u t p u t ****** +c t(1),...,t(n+kpm) the knot sequence. +c n = l*k + m = dimension of spline(k+m,t). +c + integer l,kpm,n, iside,j,jj,jjj,k,ll,m + real break(1),t(1), xside + common /side/ m,iside,xside(10) + k = kpm - m + n = l*k + m + jj = n + kpm + jjj = l + 1 + do 11 ll=1,kpm + t(jj) = break(jjj) + 11 jj = jj - 1 + do 12 j=1,l + jjj = jjj - 1 + do 12 ll=1,k + t(jj) = break(jjj) + 12 jj = jj - 1 + do 13 ll=1,kpm + 13 t(ll) = break(1) + return + end diff --git a/math/deboor/l2appr.f b/math/deboor/l2appr.f new file mode 100644 index 00000000..6f61150c --- /dev/null +++ b/math/deboor/l2appr.f @@ -0,0 +1,109 @@ + subroutine l2appr ( t, n, k, q, diag, bcoef ) +c from * a practical guide to splines * by c. de boor +c to be called in main program l 2 m a i n . +calls subprograms bsplvb, bchfac/slv +c +constructs the (weighted discrete) l2-approximation by splines of order +c k with knot sequence t(1), ..., t(n+k) to given data points +c ( tau(i), gtau(i) ), i=1,...,ntau. the b-spline coefficients +c b c o e f of the approximating spline are determined from the +c normal equations using cholesky's method. +c +c****** i n p u t ****** +c t(1), ..., t(n+k) the knot sequence +c n.....the dimension of the space of splines of order k with knots t. +c k.....the order +c +c w a r n i n g . . . the restriction k .le. kmax (= 20) is impo- +c sed by the arbitrary dimension statement for biatx below, but +c is n o w h e r e c h e c k e d for. +c +c****** w o r k a r r a y s ****** +c q....a work array of size (at least) k*n. its first k rows are used +c for the k lower diagonals of the gramian matrix c . +c diag.....a work array of length n used in bchfac . +c +c****** i n p u t via c o m m o n /data/ ****** +c ntau.....number of data points +c (tau(i),gtau(i)), i=1,...,ntau are the ntau data points to be +c fitted . +c weight(i), i=1,...,ntau are the corresponding weights . +c +c****** o u t p u t ****** +c bcoef(1), ..., bcoef(n) the b-spline coeffs. of the l2-appr. +c +c****** m e t h o d ****** +c the b-spline coefficients of the l2-appr. are determined as the sol- +c ution of the normal equations +c sum ( (b(i),b(j))*bcoef(j) : j=1,...,n) = (b(i),g), +c i = 1, ..., n . +c here, b(i) denotes the i-th b-spline, g denotes the function to +c be approximated, and the i n n e r p r o d u c t of two funct- +c ions f and g is given by +c (f,g) := sum ( f(tau(i))*g(tau(i))*weight(i) : i=1,...,ntau) . +c the arrays t a u and w e i g h t are given in common block +c d a t a , as is the array g t a u containing the sequence +c g(tau(i)), i=1,...,ntau. +c the relevant function values of the b-splines b(i), i=1,...,n, are +c supplied by the subprogram b s p l v b . +c the coeff.matrix c , with +c c(i,j) := (b(i), b(j)), i,j=1,...,n, +c of the normal equations is symmetric and (2*k-1)-banded, therefore +c can be specified by giving its k bands at or below the diagonal. for +c i=1,...,n, we store +c (b(i),b(j)) = c(i,j) in q(i-j+1,j), j=i,...,min0(i+k-1,n) +c and the right side +c (b(i), g ) in bcoef(i) . +c since b-spline values are most efficiently generated by finding sim- +c ultaneously the value of e v e r y nonzero b-spline at one point, +c the entries of c (i.e., of q ), are generated by computing, for +c each ll, all the terms involving tau(ll) simultaneously and adding +c them to all relevant entries. +c parameter kmax=20,ntmax=200 + integer k,n, i,j,jj,left,leftmk,ll,mm,ntau +c real bcoef(n),diag(n),q(k,n),t(1), biatx(kmax),dw,gtau,tau,weight + real bcoef(n),diag(n),q(k,n),t(1), biatx( 20),dw,gtau,tau,weight +c dimension t(n+k) +current fortran standard makes it impossible to specify the exact dimen- +c sion of t without the introduction of additional otherwise super- +c fluous arguments. +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax) + common / data / ntau, tau( 200),gtau( 200),weight( 200) + do 7 j=1,n + bcoef(j) = 0. + do 7 i=1,k + 7 q(i,j) = 0. + left = k + leftmk = 0 + do 20 ll=1,ntau +c locate l e f t s.t. tau(ll) in (t(left),t(left+1)) + 10 if (left .eq. n) go to 15 + if (tau(ll) .lt. t(left+1)) go to 15 + left = left+1 + leftmk = leftmk + 1 + go to 10 + 15 call bsplvb ( t, k, 1, tau(ll), left, biatx ) +c biatx(mm) contains the value of b(left-k+mm) at tau(ll). +c hence, with dw := biatx(mm)*weight(ll), the number dw*gtau(ll) +c is a summand in the inner product +c (b(left-k+mm), g) which goes into bcoef(left-k+mm) +c and the number biatx(jj)*dw is a summand in the inner product +c (b(left-k+jj), b(left-k+mm)), into q(jj-mm+1,left-k+mm) +c since (left-k+jj) - (left-k+mm) + 1 = jj - mm + 1 . + do 20 mm=1,k + dw = biatx(mm)*weight(ll) + j = leftmk + mm + bcoef(j) = dw*gtau(ll) + bcoef(j) + i = 1 + do 20 jj=mm,k + q(i,j) = biatx(jj)*dw + q(i,j) + 20 i = i + 1 +c +c construct cholesky factorization for c in q , then use +c it to solve the normal equations +c c*x = bcoef +c for x , and store x in bcoef . + call bchfac ( q, k, n, diag ) + call bchslv ( q, k, n, bcoef ) + return + end diff --git a/math/deboor/l2err_io.f b/math/deboor/l2err_io.f new file mode 100644 index 00000000..ac7fcf01 --- /dev/null +++ b/math/deboor/l2err_io.f @@ -0,0 +1,69 @@ + subroutine l2err ( prfun , ftau , error ) +c from * a practical guide to splines * by c. de boor +c this routine is to be called in the main program l 2 m a i n . +calls subprogram ppvalu(interv) +c this subroutine computes various errors of the current l2-approxi- +c mation , whose pp-repr. is contained in common block approx , +c to the given data contained in common block data . it prints out +c the average error e r r l 1 , the l2-error e r r l 2, and the +c maximum error e r r m a x . +c +c****** i n p u t ****** +c prfun a hollerith string. if prfun = 2hon, the routine prints out +c the value of the approximation as well as its error at +c every data point. +c +c****** o u t p u t ****** +c ftau(1), ..., ftau(ntau), with ftau(i) the approximation f at +c tau(i), all i. +c error(1), ..., error(ntau), with error(i) = scale*(g - f) +c at tau(i), all i. here, s c a l e equals 1. in case +c prfun .ne. 2hon , or the abs.error is greater than 100 some- +c where. otherwise, s c a l e is such that the maximum of +c abs(error)) over all i lies between 10 and 100. this +c makes the printed output more illustrative. +c + integer prfun, ie,k,l,ll,ntau,on + real ftau(1),error(1), break,coef,err,errmax,errl1,errl2 + * ,gtau,scale,tau,totalw,weight +c dimension ftau(ntau),error(ntau) + real ppvalu +c parameter lpkmax=100,ntmax=200,ltkmax=2000 +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw +c common /approx/ break(lpkmax),coef(ltkmax),l,k + common / data / ntau, tau(200),gtau(200),weight(200),totalw + common /approx/ break(100),coef(2000),l,k + data on /2hon / + errl1 = 0. + errl2 = 0. + errmax = 0. + do 10 ll=1,ntau + ftau(ll) = ppvalu (break, coef, l, k, tau(ll), 0 ) + error(ll) = gtau(ll) - ftau(ll) + err = abs(error(ll)) + if (errmax .lt. err) errmax = err + errl1 = errl1 + err*weight(ll) + 10 errl2 = errl2 + err**2*weight(ll) + errl1 = errl1/totalw + errl2 = sqrt(errl2/totalw) + print 615,errl2,errl1,errmax + 615 format(///21h least square error =,e20.6/ + 1 21h average error =,e20.6/ + 2 21h maximum error =,e20.6//) + if (prfun .ne. on) return +c ** scale error curve and print ** + ie = 0 + scale = 1. + if (errmax .ge. 10.) go to 18 + do 17 ie=1,9 + scale = scale*10. + if (errmax*scale .ge. 10.) go to 18 + 17 continue + 18 do 19 ll=1,ntau + 19 error(ll) = error(ll)*scale + print 620,ie,(ll,tau(ll),ftau(ll),error(ll),ll=1,ntau) + 620 format(///14x,36happroximation and scaled error curve/7x, + 110hdata point,7x,13happroximation,3x,16hdeviation x 10**,i1/ + 2(i4,f16.8,f16.8,f17.6)) + return + end diff --git a/math/deboor/l2knts.f b/math/deboor/l2knts.f new file mode 100644 index 00000000..5f11b1e4 --- /dev/null +++ b/math/deboor/l2knts.f @@ -0,0 +1,33 @@ + subroutine l2knts ( break, l, k, t, n ) +c from * a practical guide to splines * by c. de boor +c to be called in main program l 2 m a i n . +converts the breakpoint sequence b r e a k into a corresponding knot +c sequence t to allow the repr. of a pp function of order k with +c k-2 continuous derivatives as a spline of order k with knot +c sequence t . this means that +c t(1), ..., t(n+k) = break(1) k times, then break(i), i=2,...,l, each +c once, then break(l+1) k times . +c therefore, n = k-1 + l. +c +c****** i n p u t ****** +c k the order +c l the number of polynomial pieces +c break(1), ...,break(l+1) the breakpoint sequence +c +c****** o u t p u t ****** +c t(1),...,t(n+k) the knot sequence +c n the dimension of the corresp. spline space of order k . +c + integer k,l,n, i,km1 + real break(1),t(1) +c dimension break(l+1),t(n+k) + km1 = k - 1 + do 5 i=1,km1 + 5 t(i) = break(1) + do 6 i=1,l + 6 t(km1+i) = break(i) + n = km1 + l + do 7 i=1,k + 7 t(n+i) = break(l+1) + return + end diff --git a/math/deboor/mkpkg b/math/deboor/mkpkg new file mode 100644 index 00000000..95e084a8 --- /dev/null +++ b/math/deboor/mkpkg @@ -0,0 +1,49 @@ +# Makelib for the single precision Deboor spline package. + +$checkout libdeboor.a lib$ +$update libdeboor.a +$checkin libdeboor.a lib$ +$exit + +libdeboor.a: + banfac.f + banslv.f + bchfac.f + bchslv.f + bsplbv.f + bsplpp.f + bsplvd.f + bspp2d.f + bvalue.f + chol1d.f + cubspl.f + cwidth.f + dtblok.f + factrb.f + fcblok.f + fsplin.x bspln.h + interv.f + knots.f + l2appr.f + l2knts.f + newnot_fake.f + ppvalu.f + round.f + sbblok.f + setdat.f + setdat2.f + setdat3.f + setupq.f + seval.x bspln.h + shiftb.f + slvblk.f + smooth.f + spline.x bspln.h + splint.f + spllsq.x bspln.h + splsqv.x bspln.h + subbak.f + subfor.f + tautsp.f + titand.f + ; diff --git a/math/deboor/newnot_fake.f b/math/deboor/newnot_fake.f new file mode 100644 index 00000000..a4d27eb3 --- /dev/null +++ b/math/deboor/newnot_fake.f @@ -0,0 +1,30 @@ + subroutine newnot ( break, coef, l, k, brknew, lnew, coefg ) +c from * a practical guide to splines * by c. de boor +c this is a fake version of n e w n o t , of use in example 3 of +c chapter xiv . +c returns lnew+1 knots in brknew which are equidistributed on (a,b) +c = (break(1),break(l+1)) . +c + integer k,l,lnew, i + real break(1),brknew(1),coef(k,l),coefg(2,l), step +c****** i n p u t ****** +c break, coef, l, k.....contains the pp-representation of a certain +c function f of order k . specifically, +c d**(k-1)f(x) = coef(k,i) for break(i).le. x .lt.break(i+1) +c lnew.....number of intervals into which the interval (a,b) is to be +c sectioned by the new breakpoint sequence brknew . +c +c****** o u t p u t ****** +c brknew.....array of length lnew+1 containing the new breakpoint se- +c quence +c coefg.....the coefficient part of the pp-repr. break, coefg, l, 2 +c for the monotone p.linear function g wrto which brknew will +c be equidistributed. +c + brknew(1) = break(1) + brknew(lnew+1) = break(l+1) + step = (break(l+1) - break(1))/float(lnew) + do 93 i=2,lnew + 93 brknew(i) = break(1) + float(i-1)*step + return + end diff --git a/math/deboor/newnot_io.f b/math/deboor/newnot_io.f new file mode 100644 index 00000000..8788dd11 --- /dev/null +++ b/math/deboor/newnot_io.f @@ -0,0 +1,108 @@ + subroutine newnot ( break, coef, l, k, brknew, lnew, coefg ) +c from * a practical guide to splines * by c. de boor +c returns lnew+1 knots in brknew which are equidistributed on (a,b) +c = (break(1),break(l+1)) wrto a certain monotone fctn g related to +c the k-th root of the k-th derivative of the pp function f whose pp- +c representation is contained in break, coef, l, k . +c +c****** i n p u t ****** +c break, coef, l, k.....contains the pp-representation of a certain +c function f of order k . specifically, +c d**(k-1)f(x) = coef(k,i) for break(i).le. x .lt.break(i+1) +c lnew.....number of intervals into which the interval (a,b) is to be +c sectioned by the new breakpoint sequence brknew . +c +c****** o u t p u t ****** +c brknew.....array of length lnew+1 containing the new breakpoint se- +c quence +c coefg.....the coefficient part of the pp-repr. break, coefg, l, 2 +c for the monotone p.linear function g wrto which brknew will +c be equidistributed. +c +c****** optional p r i n t e d o u t p u t ****** +c coefg.....the pp coeffs of g are printed out if iprint is set +c .gt. 0 in data statement below. +c +c****** m e t h o d ****** +c the k-th derivative of the given pp function f does not exist +c (except perhaps as a linear combination of delta functions). never- +c theless, we construct a p.constant function h with breakpoint se- +c quence break which is approximately proportional to abs(d**k(f)). +c specifically, on (break(i), break(i+1)), +c +c abs(jump at break(i) of pc) abs(jump at break(i+1) of pc) +c h = -------------------------- + ---------------------------- +c break(i+1) - break(i-1) break(i+2) - break(i) +c +c with pc the p.constant (k-1)st derivative of f . +c then, the p.linear function g is constructed as +c +c g(x) = integral of h(y)**(1/k) for y from a to x +c +c and its pp coeffs. stored in coefg . +c then brknew is determined by +c +c brknew(i) = a + g**(-1)((i-1)*step) , i=1,...,lnew+1 +c +c where step = g(b)/lnew and (a,b) = (break(1),break(l+1)) . +c in the event that pc = d**(k-1)(f) is constant in (a,b) and +c therefore h = 0 identically, brknew is chosen uniformly spaced. +c + integer k,l,lnew, i,iprint,j + real break(1),brknew(1),coef(k,l),coefg(2,l), dif,difprv,oneovk + * ,step,stepi +c dimension break(l+1), brknew(lnew+1) +current fortran standard makes it impossible to specify the dimension +c of break and brknew without the introduction of additional +c otherwise superfluous arguments. + data iprint /0/ +c + brknew(1) = break(1) + brknew(lnew+1) = break(l+1) +c if g is constant, brknew is uniform. + if (l .le. 1) go to 90 +c construct the continuous p.linear function g . + oneovk = 1./float(k) + coefg(1,1) = 0. + difprv = abs(coef(k,2) - coef(k,1))/(break(3)-break(1)) + do 10 i=2,l + dif = abs(coef(k,i) - coef(k,i-1))/(break(i+1) - break(i-1)) + coefg(2,i-1) = (dif + difprv)**oneovk + coefg(1,i) = coefg(1,i-1)+coefg(2,i-1)*(break(i)-break(i-1)) + 10 difprv = dif + coefg(2,l) = (2.*difprv)**oneovk +c step = g(b)/lnew + step = (coefg(1,l)+coefg(2,l)*(break(l+1)-break(l)))/float(lnew) +c + if (iprint .gt. 0) print 600, step,(i,coefg(1,i),coefg(2,i),i=1,l) + 600 format(7h step =,e16.7/(i5,2e16.5)) +c if g is constant, brknew is uniform . + if (step .le. 0.) go to 90 +c +c for i=2,...,lnew, construct brknew(i) = a + g**(-1)(stepi), +c with stepi = (i-1)*step . this requires inversion of the p.lin- +c ear function g . for this, j is found so that +c g(break(j)) .le. stepi .le. g(break(j+1)) +c and then +c brknew(i) = break(j) + (stepi-g(break(j)))/dg(break(j)) . +c the midpoint is chosen if dg(break(j)) = 0 . + j = 1 + do 30 i=2,lnew + stepi = float(i-1)*step + 21 if (j .eq. l) go to 27 + if (stepi .le. coefg(1,j+1))go to 27 + j = j + 1 + go to 21 + 27 if (coefg(2,j) .eq. 0.) go to 29 + brknew(i) = break(j) + (stepi - coefg(1,j))/coefg(2,j) + go to 30 + 29 brknew(i) = (break(j) + break(j+1))/2. + 30 continue + return +c +c if g is constant, brknew is uniform . + 90 step = (break(l+1) - break(1))/float(lnew) + do 93 i=2,lnew + 93 brknew(i) = break(1) + float(i-1)*step + return + end diff --git a/math/deboor/ppvalu.f b/math/deboor/ppvalu.f new file mode 100644 index 00000000..edb04002 --- /dev/null +++ b/math/deboor/ppvalu.f @@ -0,0 +1,48 @@ + real function ppvalu (break, coef, l, k, x, jderiv ) +c from * a practical guide to splines * by c. de boor +calls interv +calculates value at x of jderiv-th derivative of pp fct from pp-repr +c +c****** i n p u t ****** +c break, coef, l, k.....forms the pp-representation of the function f +c to be evaluated. specifically, the j-th derivative of f is +c given by +c +c (d**j)f(x) = coef(j+1,i) + h*(coef(j+2,i) + h*( ... (coef(k-1,i) + +c + h*coef(k,i)/(k-j-1))/(k-j-2) ... )/2)/1 +c +c with h = x - break(i), and +c +c i = max( 1 , max( j , break(j) .le. x , 1 .le. j .le. l ) ). +c +c x.....the point at which to evaluate. +c jderiv.....integer giving the order of the derivative to be evaluat- +c ed. a s s u m e d to be zero or positive. +c +c****** o u t p u t ****** +c ppvalu.....the value of the (jderiv)-th derivative of f at x. +c +c****** m e t h o d ****** +c the interval index i , appropriate for x , is found through a +c call to interv . the formula above for the jderiv-th derivative +c of f is then evaluated (by nested multiplication). +c + integer jderiv,k,l, i,m,ndummy + real break(l),coef(k,l),x, fmmjdr,h + ppvalu = 0. + fmmjdr = k - jderiv +c derivatives of order k or higher are identically zero. + if (fmmjdr .le. 0.) go to 99 +c +c find index i of largest breakpoint to the left of x . + call interv ( break, l, x, i, ndummy ) +c +c evaluate jderiv-th derivative of i-th polynomial piece at x . + h = x - break(i) + m = k + 9 ppvalu = (ppvalu/fmmjdr)*h + coef(m,i) + m = m - 1 + fmmjdr = fmmjdr - 1. + if (fmmjdr .gt. 0.) go to 9 + 99 return + end diff --git a/math/deboor/progs/prog1.f b/math/deboor/progs/prog1.f new file mode 100644 index 00000000..2a0b869c --- /dev/null +++ b/math/deboor/progs/prog1.f @@ -0,0 +1,45 @@ +chapter ii. runge example +c from * a practical guide to splines * by c. de boor + integer i,istep,j,k,n,nmk,nm1 + real aloger,algerp,d(20),decay,dx,errmax,g,h,pnatx,step,tau(20),x + data step, istep /20., 20/ + g(x) = 1./(1.+(5.*x)**2) + print 600 + 600 format(28h n max.error decay exp.//) + decay = 0. + do 40 n=2,20,2 +c choose interpolation points tau(1), ..., tau(n) , equally +c spaced in (-1,1), and set d(i) = g(tau(i)), i=1,...,n. + nm1 = n-1 + h = 2./float(nm1) + do 10 i=1,n + tau(i) = float(i-1)*h - 1. + 10 d(i) = g(tau(i)) +c calculate the divided differences for the newton form. +c + do 20 k=1,nm1 + nmk = n-k + do 20 i=1,nmk + 20 d(i) = (d(i+1)-d(i))/(tau(i+k)-tau(i)) +c +c estimate max.interpolation error on (-1,1). + errmax = 0. + do 30 i=2,n + dx = (tau(i)-tau(i-1))/step + do 30 j=1,istep + x = tau(i-1) + float(j)*dx +c evaluate interp.pol. by nested multiplication +c + pnatx = d(1) + do 29 k=2,n + 29 pnatx = d(k) + (x-tau(k))*pnatx +c + 30 errmax = amax1(errmax,abs(g(x)-pnatx)) + aloger = alog(errmax) + if (n .gt. 2) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog10.f b/math/deboor/progs/prog10.f new file mode 100644 index 00000000..dc580c99 --- /dev/null +++ b/math/deboor/progs/prog10.f @@ -0,0 +1,76 @@ +chapter xii, example 4. quasi-interpolant with good knots. +c from * a practical guide to splines * by c. de boor +calls bsplpp(bsplvb) +c + integer i,irate,istep,j,l,m,mmk,n,nlow,nhigh,nm1 + real algerp,aloger,bcoef(22),break(20),c(4,20),decay,dg,ddg,x + * ,dtip1,dtip2,dx,errmax,g,h,pnatx,scrtch(4,4),step,t(26),taui +c istep and step = float(istep) specify point density for error det- +c ermination. + data step, istep /20., 20/ +c g is the function to be approximated, dg is its first, and +c ddg its second derivative . + g(x) = sqrt(x+1.) + dg(x) = .5/g(x) + ddg(x) = -.5*dg(x)/(x+1.) + decay = 0. +c read in the exponent irate for the knot distribution and the +c lower and upper limit for the number n . + read 500,irate,nlow,nhigh + 500 format(3i3) + print 600 + 600 format(28h n max.error decay exp./) +c loop over n = dim( spline(4,t) ) - 2 . +c n is chosen as the parameter in order to afford compar- +c ison with examples 2 and 3 in which cubic spline interp- +c olation at n data points was used . + do 40 n=nlow,nhigh,2 + nm1 = n-1 + h = 1./float(nm1) + m = n+2 + mmk = m-4 + do 5 i=1,4 + t(i) = -1. + 5 t(m+i) = 1. +c interior knots are equidistributed with respect to the +c function (x + 1)**(1/irate) . + do 6 i=1,mmk + 6 t(i+4) = 2.*(float(i)*h)**irate - 1. +c construct quasi-interpolant. +c bcoef(1) = g(-1.) = 0. + bcoef(1) = 0. + dtip2 = t(5) - t(4) + taui = t(5) +c special choice of tau(2) to avoid infinite +c derivatives of g at left endpoint . + bcoef(2) = g(taui) - 2.*dtip2*dg(taui)/3. + * + dtip2**2*ddg(taui)/6. + do 15 i=3,m + taui = t(i+2) + dtip1 = dtip2 + dtip2 = t(i+3) - t(i+2) +c formula xii(30) of text is used . + 15 bcoef(i) = g(taui) + (dtip2-dtip1)*dg(taui)/3. + * - dtip1*dtip2*ddg(taui)/6. +c convert to pp-representation . + call bsplpp(t,bcoef,m,4,scrtch,break,c,l) +c estimate max.interpolation error on (-1,1). + errmax = 0. +c loop over cubic pieces ... + do 30 i=1,l + dx = (break(i+1)-break(i))/step +c error is calculated at istep points per piece. + do 30 j=1,istep + h = float(j)*dx + pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) + 30 errmax = amax1(errmax,abs(g(break(i)+h)-pnatx)) +c calculate decay exponent . + aloger = alog(errmax) + if (n .gt. nlow) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger +c + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog11.f b/math/deboor/progs/prog11.f new file mode 100644 index 00000000..2deea951 --- /dev/null +++ b/math/deboor/progs/prog11.f @@ -0,0 +1,69 @@ +chapter xiii, example 1. a large norm amplifies noise. +c from * a practical guide to splines * by c. de boor +calls splint(banfac/slv,bsplvb),bsplpp(bsplvb*),ppvalu(interv),round +c an initially uniform data point distribution of n points is +c changed i t e r m x times by moving the j c l o s e -th data point +c toward its left neighbor, cutting the distance between the two by a +c factor of r a t e each time . to demonstrate the corresponding +c increase in the norm of cubic spline interpolation at these data +c points, the data are taken from a cubic polynomial (which would be +c interpolated exactly) but with noise of size s i z e added. the re- +c sulting noise or error in the interpolant (compared to the cubic) +c gives the norm or noise amplification factor and is printed out +c together with the diminishing distance h between the two data +c points. +c parameter nmax=200,nmaxt4=800,nmaxt7=1400,nmaxp4=204 + integer i,iflag,istep,iter,itermx,j,jclose,l,n,nm1 +c real amax,bcoef(nmax),break(nmax),coef(nmaxt4),dx,fltnm1,fx +c * ,gtau(nmax),h,rate,scrtch(nmaxt7),size,step,t(nmaxp4),tau(nmax),x + real amax,bcoef(200),break(200),coef(800),dx,fltnm1,fx + * ,gtau(200),h,rate,scrtch(1400),size,step,t(204),tau(200),x + real ppvalu,round,g + common /rount/ size + data step, istep / 20., 20 / +c function to be interpolated . + g(x) = 1.+x*(1.+x*(1.+x)) + read 500,n,itermx,jclose,size,rate + 500 format(3i3/e10.3/e10.3) + print 600,size + 600 format(16h size of noise =,e8.2// + * 25h h max.error) +c start with uniform data points . + nm1 = n - 1 + fltnm1 = float(nm1) + do 10 i=1,n + 10 tau(i) = float(i-1)/fltnm1 +c set up knot sequence for not-a-knot end condition . + do 11 i=1,4 + t(i) = tau(1) + 11 t(n+i) = tau(n) + do 12 i=5,n + 12 t(i) = tau(i-2) +c + do 100 iter=1,itermx + do 21 i=1,n + 21 gtau(i) = round(g(tau(i))) + call splint ( tau, gtau, t, n, 4, scrtch, bcoef, iflag ) + go to (24,23),iflag + 23 print 623 + 623 format(27h something wrong in splint.) + stop + 24 call bsplpp ( t, bcoef, n, 4, scrtch, break, coef, l ) +c calculate max.interpolation error . + amax = 0. + do 30 i=4,n + dx = (break(i-2) - break(i-3))/step + do 25 j=2,istep + x = break(i-2) - dx*float(j-1) + fx = ppvalu(break,coef,l,4,x,0) + 25 amax = amax1(amax,abs(fx-g(x))) + 30 continue + h = tau(jclose) - tau(jclose-1) + print 630,h,amax + 630 format(e9.2,e15.3) +c move tau(jclose) toward its left neighbor so as to cut +c their distance by a factor of rate . + tau(jclose) = (tau(jclose) + (rate-1.)*tau(jclose-1))/rate + 100 continue + stop + end diff --git a/math/deboor/progs/prog12.f b/math/deboor/progs/prog12.f new file mode 100644 index 00000000..6efe8614 --- /dev/null +++ b/math/deboor/progs/prog12.f @@ -0,0 +1,70 @@ +chapter xiii, example 2. cubic spline interpolant at knot averages +c with good knots. +c from * a practical guide to splines * by c. de boor +calls splint(banfac/slv,bsplvb),newnot,bsplpp(bsplvb*) +c parameter nmax=20,nmaxp6=26,nmaxp2=22,nmaxt7=140 + integer i,istep,iter,itermx,n,nhigh,nmk,nlow +c real algerp,aloger,bcoef(nmaxp2),break(nmax),decay,dx,errmax, +c * c(4,nmax),g,gtau(nmax),h,pnatx,scrtch(nmaxt7),step,t(nmaxp6), +c * tau(nmax),tnew(nmax) + real algerp,aloger,bcoef(22),break(20),decay,dx,errmax, + * c(4,20),g,gtau(20),h,pnatx,scrtch(140),step,t(26), + * tau(20),tnew(20),x +c istep and step = float(istep) specify point density for error det- +c ermination. + data step, istep /20., 20/ +c the function g is to be interpolated . + g(x) = sqrt(x+1.) + decay = 0. +c read in the number of iterations to be carried out and the lower +c and upper limit for the number n of data points to be used. + read 500,itermx,nlow,nhigh + 500 format(3i3) + print 600, itermx + 600 format(i4,22h cycles through newnot// + * 28h n max.error decay exp./) +c loop over n = number of data points . + do 40 n=nlow,nhigh,2 + 4 nmk = n-4 + h = 2./float(nmk+1) + do 5 i=1,4 + t(i) = -1. + 5 t(n+i) = 1. + if (nmk .lt. 1) go to 10 + do 6 i=1,nmk + 6 t(i+4) = float(i)*h - 1. + 10 iter = 1 +c construct cubic spline interpolant. then, itermx times, +c determine new knots from it and find a new interpolant. + 11 do 12 i=1,n + tau(i) = (t(i+1)+t(i+2)+t(i+3))/3. + 12 gtau(i) = g(tau(i)) + call splint ( tau, gtau, t, n, 4, scrtch, bcoef, iflag ) + call bsplpp ( t, bcoef, n, 4, scrtch, break, c, l ) + if (iter .gt. itermx) go to 19 + iter = iter + 1 + call newnot ( break, c, l, 4, tnew, l, scrtch ) + 15 do 18 i=2,l + 18 t(3+i) = tnew(i) + go to 11 +c estimate max.interpolation error on (-1,1) . + 19 errmax = 0. +c loop over polynomial pieces of interpolant . + do 30 i=1,l + dx = (break(i+1)-break(i))/step +c interpolation error is calculated at istep points per +c polynomial piece . + do 30 j=1,istep + h = float(j)*dx + pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) + 30 errmax = amax1(errmax,abs(g(break(i)+h)-pnatx)) +c calculate decay exponent . + aloger = alog(errmax) + if (n .gt. nlow) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger +c + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog13.f b/math/deboor/progs/prog13.f new file mode 100644 index 00000000..45e6362f --- /dev/null +++ b/math/deboor/progs/prog13.f @@ -0,0 +1,77 @@ +chapter xiii, example 2m. cubic spline interpolant at knot averages +c with good knots. modified around label 4. +c from * a practical guide to splines * by c. de boor +calls splint(banfac/slv,bsplvb),newnot,bsplpp(bsplvb*) +c parameter nmax=20,nmaxp6=26,nmaxp2=22,nmaxt7=140 + integer i,istep,iter,itermx,n,nhigh,nmk,nlow +c real algerp,aloger,bcoef(nmaxp2),break(nmax),decay,dx,errmax, +c * c(4,nmax),g,gtau(nmax),h,pnatx,scrtch(nmaxt7),step,t(nmaxp6), +c * tau(nmax),tnew(nmax) + real algerp,aloger,bcoef(22),break(20),decay,dx,errmax, + * c(4,20),g,gtau(20),h,pnatx,scrtch(140),step,t(26), + * tau(20),tnew(20),x +c istep and step = float(istep) specify point density for error det- +c ermination. + data step, istep /20., 20/ +c the function g is to be interpolated . + g(x) = sqrt(x+1.) + decay = 0. +c read in the number of iterations to be carried out and the lower +c and upper limit for the number n of data points to be used. + read 500,itermx,nlow,nhigh + 500 format(3i3) + print 600, itermx + 600 format(i4,22h cycles through newnot// + * 28h n max.error decay exp./) +c loop over n = number of data points . + do 40 n=nlow,nhigh,2 + if (n .eq. nlow) go to 4 + call newnot ( break, c, l, 4, tnew, l+2, scrtch ) + l = l + 2 + t(5+l) = 1. + t(6+l) = 1. + iter = 1 + go to 15 + 4 nmk = n-4 + h = 2./float(nmk+1) + do 5 i=1,4 + t(i) = -1. + 5 t(n+i) = 1. + if (nmk .lt. 1) go to 10 + do 6 i=1,nmk + 6 t(i+4) = float(i)*h - 1. + 10 iter = 1 +c construct cubic spline interpolant. then, itermx times, +c determine new knots from it and find a new interpolant. + 11 do 12 i=1,n + tau(i) = (t(i+1)+t(i+2)+t(i+3))/3. + 12 gtau(i) = g(tau(i)) + call splint ( tau, gtau, t, n, 4, scrtch, bcoef, iflag ) + call bsplpp ( t, bcoef, n, 4, scrtch, break, c, l ) + if (iter .gt. itermx) go to 19 + iter = iter + 1 + call newnot ( break, c, l, 4, tnew, l, scrtch ) + 15 do 18 i=2,l + 18 t(3+i) = tnew(i) + go to 11 +c estimate max.interpolation error on (-1,1) . + 19 errmax = 0. +c loop over polynomial pieces of interpolant . + do 30 i=1,l + dx = (break(i+1)-break(i))/step +c interpolation error is calculated at istep points per +c polynomial piece . + do 30 j=1,istep + h = float(j)*dx + pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) + 30 errmax = amax1(errmax,abs(g(break(i)+h)-pnatx)) +c calculate decay exponent . + aloger = alog(errmax) + if (n .gt. nlow) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger +c + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog14.f b/math/deboor/progs/prog14.f new file mode 100644 index 00000000..03804f47 --- /dev/null +++ b/math/deboor/progs/prog14.f @@ -0,0 +1,37 @@ +chapter xiii, example 3 . test of optimal spline interpolation routine +c on titanium heat data . +c from * a practical guide to splines * by c. de boor +calls titand,splopt(bsplvb,banfac/slv),splint(*),bvalue(interv) +c +c lenscr = (n-k)(2k+3)+5k+3 is the length of scrtch required in +c splopt . +c parameter n=12,ntitan=49,k=5,npk=17,lenscr=119 +c integer i,iflag,ipick(n),ipicki,lx,nmk +c real a(n),gtitan(ntitan),gtau(ntitan),scrtch(lenscr),t(npk),tau(n) +c * ,x(ntitan) + real bvalue + integer i,iflag,ipick(12),ipicki,lx,nmk + real a(12),gtitan(49),gtau(49),scrtch(119),t(17),tau(12) + * ,x(49) + data n,k /12,5/ + data ipick /1,5,11,21,27,29,31,33,35,40,45,49/ + call titand ( x, gtitan, lx ) + do 10 i=1,n + ipicki = ipick(i) + tau(i) = x(ipicki) + 10 gtau(i) = gtitan(ipicki) + call splopt ( tau, n, k, scrtch, t, iflag ) + if (iflag .gt. 1) stop + call splint ( tau, gtau, t, n, k, scrtch, a, iflag ) + if (iflag .gt. 1) stop + do 20 i=1,lx + gtau(i) = bvalue ( t, a, n, k, x(i), 0 ) + 20 scrtch(i) = gtitan(i) - gtau(i) + print 620,(i,x(i),gtitan(i),gtau(i),scrtch(i),i=1,lx) + 620 format(41h i, data point, data, interpolant, error// + 2 (i3,f8.0,f10.4,f9.4,e11.3)) + nmk = n-k + print 621,(i,t(k+i),i=1,nmk) + 621 format(///16h optimal knots =/(i5,f15.9)) + stop + end diff --git a/math/deboor/progs/prog15.f b/math/deboor/progs/prog15.f new file mode 100644 index 00000000..2158931e --- /dev/null +++ b/math/deboor/progs/prog15.f @@ -0,0 +1,48 @@ +chapter xiv, example 1. cubic smoothing spline +c from * a practical guide to splines * by c. de boor +calls bsplpp(bsplvb), ppvalu(interv), smooth(setupq,chol1d) +c values from a cubic b-spline are rounded to n d i g i t places +c after the decimal point, then smoothed via s m o o t h for +c various values of the control parameter s . + integer i,is,j,l,lsm,ndigit,npoint,ns + real a(61,4),bcoef(7),break(5),coef(4,4),coefsm(4,60),dely,dy(61) + * ,s(20),scrtch(427),sfp,t(11),tenton,x(61),y(61) + real ppvalu,smooth + equivalence (scrtch,coefsm) + data t /4*0.,1.,3.,4.,4*6./ + data bcoef /3*0.,1.,3*0./ + call bsplpp(t,bcoef,7,4,scrtch,break,coef,l) + npoint = 61 + read 500,ndigit,ns,(s(i),i=1,ns) + 500 format(2i3/(e10.4)) + print 600,ndigit + 600 format(24h exact values rounded to,i2,21h digits after decimal + * ,7h point./) + tenton = 10.**ndigit + dely = .5/tenton + do 10 i=1,npoint + x(i) = .1*float(i-1) + y(i) = ppvalu(break,coef,l,4,x(i),0) + y(i) = float(int(y(i)*tenton + .5))/tenton + 10 dy(i) = dely + do 15 i=1,npoint,5 + do 15 j=1,4 + 15 a(i,j) = ppvalu(break,coef,l,4,x(i),j-1) + print 615,(i,(a(i,j),j=1,4),i=1,npoint,5) + 615 format(52h value and derivatives of noisefree function at some + * ,7h points/(i4,4e15.7)) + do 20 is=1,ns + sfp = smooth ( x, y, dy, npoint, s(is), scrtch, a ) + lsm = npoint - 1 + do 16 i=1,lsm + do 16 j=1,4 + 16 coefsm(j,i) = a(i,j) + do 18 i=1,npoint,5 + do 18 j=1,4 + 18 a(i,j) = ppvalu(x,coefsm,lsm,4,x(i),j-1) + 20 print 620, s(is), sfp, (i,(a(i,j),j=1,4),i=1,npoint,5) + 620 format(15h prescribed s =,e10.3,23h, s(smoothing spline) =,e10.3/ + * 54h value and derivatives of smoothing spline at corresp. + * ,7h points/(i4,4e15.7)) + stop + end diff --git a/math/deboor/progs/prog16.f b/math/deboor/progs/prog16.f new file mode 100644 index 00000000..4dd39911 --- /dev/null +++ b/math/deboor/progs/prog16.f @@ -0,0 +1,115 @@ +c main program for least-squares approximation by splines +c from * a practical guide to splines * by c. de boor +calls setdat,l2knts,l2appr(bsplvb,bchfac,bchslv),bsplpp(bsplvb*) +c ,l2err(ppvalu(interv)),ppvalu*,newnot +c +c the program, though ostensibly written for l2-approximation, is typ- +c ical for programs constructing a pp approximation to a function gi- +c ven in some sense. the subprogram l 2 a p p r , for instance, could +c easily be replaced by one carrying out interpolation or some other +c form of approximation. +c +c****** i n p u t ****** +c is expected in s e t d a t (quo vide), specifying both the data to +c be approximated and the order and breakpoint sequence of the pp ap- +c proximating function to be used. further, s e t d a t is expected +c to t e r m i n a t e the run (for lack of further input or because +c i c o u n t has reached a critical value). +c the number n t i m e s is read in in the main program. it speci +c fies the number of passes through the knot improvement algorithm in +c n e w n o t to be made. also, a d d b r k is read in to specify +c that, on the average, addbrk knots are to be added per pass through +c newnot. for example, addbrk = .34 would cause a knot to be added +c every third pass (as long as ntimes .lt. 50). +c +c****** p r i n t e d o u t p u t ****** +c is governed by the three print control hollerith strings +c p r b c o = 2hon gives printout of b-spline coeffs. of approxim. +c p r p c o = 2hon gives printout of pp repr. of approximation. +c p r f u n = 2hon gives printout of approximation and error at +c every data point. +c the order k , the number of pieces l, and the interior breakpoints +c are always printed out as are (in l2err) the mean, mean square, and +c maximum errors in the approximation. +c +c parameter lpkmax=100,ntmax=200,ltkmax=2000 + integer i,icount,ii,j,k,l,lbegin,lnew,ll,n,nt,ntimes,ntau + * ,on,prbco,prfun,prpco +c real addbrk,bcoef(lpkmax),break,coef,gtau,q(ltkmax),scrtch(ntmax) +c * ,t(ntmax),tau,totalw,weight +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw + real addbrk,bcoef(100),break,coef,gtau,q(2000),scrtch(200) + * ,t(200),tau,totalw,weight + common / data / ntau, tau(200),gtau(200),weight(200),totalw +c common /data/ also occurs in setdat, l2appr and l2err. it is ment- +c ioned here only because it might otherwise become undefined be- +c tween calls to those subroutines. +c common /approx/ break(lpkmax),coef(ltkmax),l,k + common /approx/ break(100),coef(2000),l,k +c common /approx/ also occurs in setdat and l2err. + data on /2hon / +c + icount = 0 +c i c o u n t provides communication with the data-input-and- +c termination routine s e t d a t . it is initialized to 0 to +c signal to setdat when it is being called for the first time. after +c that, it is up to setdat to use icount for keeping track of the +c passes through setdat . +c +c information about the function to be approximated and order and +c breakpoint sequence of the approximating pp functions is gathered +c by a + 1 call setdat(icount) +c +c breakpoints are translated into knots, and the number n of +c b-splines to be used is obtained by a + call l2knts ( break, l, k, t, n ) +c +c the integer n t i m e s and the real a d d b r k are requested +c as well as the print controls p r b c o , p r p c o and +c p r f u n . ntimes passes are made through the subroutine new- +c not, with an increase of addbrk knots for every pass . + print 600 + 600 format(52h ntimes,addbrk , prbco,prpco,prfun =? (i3,f10.5/3a2)) + read 500,ntimes,addbrk,prbco,prpco,prfun + 500 format(i3,f10.5/3a2) +c + lbegin = l + nt = 1 +c the b-spline coeffs. b c o e f of the l2-approx. are obtain- +c ed by a + 10 call l2appr ( t, n, k, q, scrtch, bcoef ) + if (prbco .eq. on) print 609, (bcoef(i),i=1,n) + 609 format(//22h b-spline coefficients/(5e16.9)) +c +c convert the b-repr. of the approximation to pp repr. + call bsplpp ( t, bcoef, n, k, q, break, coef, l ) + print 610, k, l, (break(ll),ll=2,l) + 610 format(//34h approximation by splines of order,i3,4h on , + * i3,25h intervals. breakpoints -/(5e16.9)) + if (prpco .ne. on) go to 15 + print 611 + 611 format(/36h pp-representation for approximation) + do 12 i=1,l + ii = (i-1)*k + 12 print 613,break(i),(coef(ii+j),j=1,k) + 613 format(f9.3,5e16.9/(11x,5e16.9)) +c +c compute and print out various error norms by a + 15 call l2err ( prfun, scrtch, q ) +c +c if newnot has been applied less than n t i m e s times, try +c it again to obtain, from the current approx. a possibly improv- +c ed sequence of breakpoints with addbrk more breakpoints (on +c the average) than the current approximation has. +c if only an increase in breakpoints is wanted, without the +c adjustment that newnot provides, a fake newnot routine could be +c used here which merely returns the breakpoints for l n e w +c equal intervals . + if (nt .ge. ntimes) go to 1 + lnew = lbegin + float(nt)*addbrk + call newnot (break, coef, l, k, scrtch, lnew, t ) + call l2knts ( scrtch, lnew, k, t, n ) + nt = nt + 1 + go to 10 + end diff --git a/math/deboor/progs/prog17.f b/math/deboor/progs/prog17.f new file mode 100644 index 00000000..1008c3a1 --- /dev/null +++ b/math/deboor/progs/prog17.f @@ -0,0 +1,10 @@ +c main program for example in chapter xv. +c from * a practical guide to splines * by c. de boor +c solution of a second order nonlinear two point boundary value +c problem on (0., 1.) , by collocation with pp functions having 4 +c pieces of order 6 . 2 passes through newnot are to be made, +c without any knots being added. newton iteration is to be stopped +c when two iterates agree to 6 decimal places. + call colloc(0.,1.,4,6,2,0.,1.e-6) + stop + end diff --git a/math/deboor/progs/prog18.f b/math/deboor/progs/prog18.f new file mode 100644 index 00000000..fad18c62 --- /dev/null +++ b/math/deboor/progs/prog18.f @@ -0,0 +1,35 @@ +chapter xvi, example 2, taut spline interpolation to the +c titanium heat data of example xiii.3. +c from * a practical guide to splines * by c. de boor +calls titand,tautsp,ppvalu(interv) + integer i,iflag,ipick(12),ipicki,k,l,lx,n,npoint + real break(122),coef(4,22),gamma,gtau(49),gtitan(49),plotf(201) + * ,plott(201),plotts(201),scrtch(119),step,tau(12),x(49) + real ppvalu + data n,ipick /12,1,5,11,21,27,29,31,33,35,40,45,49/ + data k,npoint /4,201/ + call titand ( x, gtitan, lx ) + do 10 i=1,n + ipicki = ipick(i) + tau(i) = x(ipicki) + 10 gtau(i) = gtitan(ipicki) + call tautsp(tau,gtau,n,0.,scrtch,break,coef,l,k,iflag) + if (iflag .gt. 1) stop + step = (tau(n) - tau(1))/float(npoint-1) + do 20 i=1,npoint + plott(i) = tau(1) + step*float(i-1) + 20 plotf(i) = ppvalu(break,coef,l,k,plott(i),0) + 1 print 601 + 601 format(18h gamma = ? (f10.3)) + read 500,gamma + 500 format(f10.3) + if (gamma .lt. 0.) stop + call tautsp(tau,gtau,n,gamma,scrtch,break,coef,l,k,iflag) + if (iflag .gt. 1) stop + do 30 i=1,npoint + 30 plotts(i) = ppvalu(break,coef,l,k,plott(i),0) + print 602,gamma,(plott(i),plotf(i),plotts(i),i=1,npoint) + 602 format(/42h cubic spline vs. taut spline with gamma =,f6.3// + * (f15.7,2e20.8)) + go to 1 + end diff --git a/math/deboor/progs/prog19.f b/math/deboor/progs/prog19.f new file mode 100644 index 00000000..6595b76c --- /dev/null +++ b/math/deboor/progs/prog19.f @@ -0,0 +1,58 @@ +chapter xvi, example 3. two parametrizations of some data +c from * a practical guide to splines * by c. de boor +calls splint(bsplvb,banfac/slv),bsplpp(bsplvb*),banslv*,ppvalu(interv) +c parameter k=4,kpkm1=7, n=8,npk=12, npiece=6,npoint=21 +c integer i,icount,iflag,kp1,l +c real bcoef(n),break(npiece),ds,q(n,kpkm1),s(n),scrtch(k,k) +c * ,ss,t(npk),x(n),xcoef(k,npiece),xx(npoint),y(n) +c * ,ycoef(k,npiece),yy(npoint) + integer i,icount,iflag,k,kpkm1,kp1,l,n,npoint + real bcoef(8),break(6),ds,q(8,7),s(8),scrtch(4,4) + * ,ss,t(12),x(8),xcoef(4,6),xx(21),y(8) + * ,ycoef(4,6),yy(21) + real ppvalu + data k,kpkm1,n,npoint /4,7,8,21/ + data x /0.,.1,.2,.3,.301,.4,.5,.6/ +c *** compute y-component and set 'natural' parametrization + do 1 i=1,n + y(i) = (x(i)-.3)**2 + 1 s(i) = x(i) + print 601 + 601 format(26h 'natural' parametrization/6x,1hx,11x,1hy) + icount = 1 +c *** convert data abscissae to knots. note that second and second +c last data abscissae are not knots. + 5 do 6 i=1,k + t(i) = s(1) + 6 t(n+i) = s(n) + kp1 = k+1 + do 7 i=kp1,n + 7 t(i) = s(i+2-k) +c *** interpolate to x-component + call splint(s,x,t,n,k,q,bcoef,iflag) + call bsplpp(t,bcoef,n,k,scrtch,break,xcoef,l) +c *** interpolate to y-component. since data abscissae and knots are +c the same for both components, we only need to use backsubstitution + do 10 i=1,n + 10 bcoef(i) = y(i) + call banslv(q,kpkm1,n,k-1,k-1,bcoef) + call bsplpp(t,bcoef,n,k,scrtch,break,ycoef,l) +c *** evaluate curve at some points near the potential trouble spot, +c the fourth and fifth data points. + ss = s(3) + ds = (s(6)-s(3))/float(npoint-1) + do 20 i=1,npoint + xx(i) = ppvalu(break,xcoef,l,k,ss,0) + yy(i) = ppvalu(break,ycoef,l,k,ss,0) + 20 ss = ss + ds + print 620,(xx(i),yy(i),i=1,npoint) + 620 format(2f12.7) + if (icount .ge. 2) stop +c *** now repeat the whole process with uniform parametrization + icount = icount + 1 + do 30 i=1,n + 30 s(i) = float(i) + print 630 + 630 format(/26h 'uniform' parametrization/6x,1hx,11x,1hy) + go to 5 + end diff --git a/math/deboor/progs/prog2.f b/math/deboor/progs/prog2.f new file mode 100644 index 00000000..1da20d52 --- /dev/null +++ b/math/deboor/progs/prog2.f @@ -0,0 +1,48 @@ +chapter iv. runge example, with cubic hermite interpolation +c from * a practical guide to splines * by c. de boor + integer i,istep,j,n,nm1 + real aloger,algerp,c(4,20),decay,divdf1,divdf3,dtau,dx,errmax,g,h + * ,pnatx,step,tau(20),x + data step, istep /20., 20/ + g(x) = 1./(1.+(5.*x)**2) + print 600 + 600 format(28h n max.error decay exp.//) + decay = 0. + do 40 n=2,20,2 +c choose interpolation points tau(1), ..., tau(n) , equally +c spaced in (-1,1), and set c(1,i) = g(tau(i)), c(2,i) = +c gprime(tau(i)) = -50.*tau(i)*g(tau(i))**2, i=1,...,n. + nm1 = n-1 + h = 2./float(nm1) + do 10 i=1,n + tau(i) = float(i-1)*h - 1. + c(1,i) = g(tau(i)) + 10 c(2,i) = -50.*tau(i)*c(1,i)**2 +c calculate the coefficients of the polynomial pieces +c + do 20 i=1,nm1 + dtau = tau(i+1) - tau(i) + divdf1 = (c(1,i+1) - c(1,i))/dtau + divdf3 = c(2,i) + c(2,i+1) - 2.*divdf1 + c(3,i) = (divdf1 - c(2,i) - divdf3)/dtau + 20 c(4,i) = (divdf3/dtau)/dtau +c +c estimate max.interpolation error on (-1,1). + errmax = 0. + do 30 i=2,n + dx = (tau(i)-tau(i-1))/step + do 30 j=1,istep + h = float(j)*dx +c evaluate (i-1)st cubic piece +c + pnatx = c(1,i-1)+h*(c(2,i-1)+h*(c(3,i-1)+h*c(4,i-1))) +c + 30 errmax = amax1(errmax,abs(g(tau(i-1)+h)-pnatx)) + aloger = alog(errmax) + if (n .gt. 2) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog20.f b/math/deboor/progs/prog20.f new file mode 100644 index 00000000..78143095 --- /dev/null +++ b/math/deboor/progs/prog20.f @@ -0,0 +1,62 @@ +chapter xvii, example 2. bivariate spline interpolation +c from * a practical guide to splines * by c. de boor +calls spli2d(bsplvb,banfac/slv),interv,bvalue(bsplvb*,interv*) +c parameter nx=7,kx=3,ny=6,ky=4 +c integer i,iflag,j,jj,lefty,mflag, +c real bcoef(nx,ny),taux(nx),tauy(ny),tx(10),ty(10) +c * ,work1(nx,ny),work2(nx),work3(42) + integer i,iflag,j,jj,kp1,kx,ky,lefty,mflag,nx,ny + real bcoef(7,6),taux(7),tauy(6),tx(10),ty(10) + * ,work1(7,6),work2(7),work3(42) + real bvalue,g,x,y + data nx,kx,ny,ky /7,3,6,4/ + g(x,y) = amax1(x-3.5,0.)**2 + amax1(y-3.,0.)**3 +c *** set up data points and knots +c in x, interpolate between knots by parabolic splines, using +c not-a-knot end condition + do 10 i=1,nx + 10 taux(i) = float(i) + do 11 i=1,kx + tx(i) = taux(1) + 11 tx(nx+i) = taux(nx) + kp1 = kx+1 + do 12 i=kp1,nx + 12 tx(i) = (taux(i-kx+1) + taux(i-kx+2))/2. +c in y, interpolate at knots by cubic splines, using not-a-knot +c end condition + do 20 i=1,ny + 20 tauy(i) = float(i) + do 21 i=1,ky + ty(i) = tauy(1) + 21 ty(ny+i) = tauy(ny) + kp1 = ky+1 + do 22 i=kp1,ny + 22 ty(i) = tauy(i-ky+2) +c *** generate and print out function values + print 620,(tauy(i),i=1,ny) + 620 format(11h given data//6f12.1) + do 32 i=1,nx + do 31 j=1,ny + 31 bcoef(i,j) = g(taux(i),tauy(j)) + 32 print 632,taux(i),(bcoef(i,j),j=1,ny) + 632 format(f5.1,6e12.5) +c +c *** construct b-coefficients of interpolant +c + call spli2d(taux,bcoef,tx,nx,kx,ny,work2,work3,work1,iflag) + call spli2d(tauy,work1,ty,ny,ky,nx,work2,work3,bcoef,iflag) +c +c *** evaluate interpolation error at mesh points and print out + print 640,(tauy(j),j=1,ny) + 640 format(//20h interpolation error//6f12.1) + do 45 j=1,ny + call interv(ty,ny,tauy(j),lefty,mflag) + do 45 i=1,nx + do 41 jj=1,ky + 41 work2(jj)=bvalue(tx,bcoef(1,lefty-ky+jj),nx,kx,taux(i),0) + 45 work1(i,j) = g(taux(i),tauy(j)) - + * bvalue(ty(lefty-ky+1),work2,ky,ky,tauy(j),0) + do 46 i=1,nx + 46 print 632,taux(i),(work1(i,j),j=1,ny) + stop + end diff --git a/math/deboor/progs/prog21.f b/math/deboor/progs/prog21.f new file mode 100644 index 00000000..6d8ca62a --- /dev/null +++ b/math/deboor/progs/prog21.f @@ -0,0 +1,74 @@ +chapter xvii, example 3. bivariate spline interpolation +c followed by conversion to pp-repr and evaluation +c from * a practical guide to splines * by c. de boor +calls spli2d(bsplvb,banfac/slv),interv,bspp2d(bsplvb*),ppvalu(interv*) +c parameter nx=7,kx=3,ny=6,ky=4 +c integer i,iflag,j,jj,lefty,lx,ly,mflag +c real bcoef(nx,ny),breakx(6),breaky(4),coef(kx,5,ky,3),taux(nx) +c * ,tauy(ny),tx(10),ty(10) +c * ,work1(nx,ny),work2(nx),work3(42) +c * ,work4(kx,kx,ny),work5(ny,kx,5),work6(ky,ky,21) + integer i,iflag,j,jj,kp1,kx,ky,lefty,lx,ly,mflag,nx,ny + real bcoef(7,6),breakx(6),breaky(4),coef(3,5,4,3),taux(7) + * ,tauy(6),tx(10),ty(10) + * ,work1(7,6),work2(7),work3(42) + * ,work4(3,3,6),work5(6,3,5),work6(4,4,21) + real ppvalu,g,x,y + data nx,kx,ny,ky / 7,3,6,4 / +c note that , with the above parameters, lx=5, ly = 3 + equivalence (work4,work6) + g(x,y) = amax1(x-3.5,0.)**2 + amax1(y-3.,0.)**3 +c *** set up data points and knots +c in x, interpolate between knots by parabolic splines, using +c not-a-knot end condition + do 10 i=1,nx + 10 taux(i) = float(i) + do 11 i=1,kx + tx(i) = taux(1) + 11 tx(nx+i) = taux(nx) + kp1 = kx+1 + do 12 i=kp1,nx + 12 tx(i) = (taux(i-kx+1) + taux(i-kx+2))/2. +c in y, interpolate at knots by cubic splines, using not-a-knot +c end condition + do 20 i=1,ny + 20 tauy(i) = float(i) + do 21 i=1,ky + ty(i) = tauy(1) + 21 ty(ny+i) = tauy(ny) + kp1 = ky+1 + do 22 i=kp1,ny + 22 ty(i) = tauy(i-ky+2) +c *** generate and print out function values + print 620,(tauy(i),i=1,ny) + 620 format(11h given data//6f12.1) + do 32 i=1,nx + do 31 j=1,ny + 31 bcoef(i,j) = g(taux(i),tauy(j)) + 32 print 632,taux(i),(bcoef(i,j),j=1,ny) + 632 format(f5.1,6e12.5) +c +c *** construct b-coefficients of interpolant +c + call spli2d(taux,bcoef,tx,nx,kx,ny,work2,work3,work1,iflag) + call spli2d(tauy,work1,ty,ny,ky,nx,work2,work3,bcoef,iflag) +c +c *** convert to pp-representation +c + call bspp2d(tx,bcoef,nx,kx,ny,work4,breakx,work5,lx) + call bspp2d(ty,work5,ny,ky,lx*kx,work6,breaky,coef,ly) +c +c *** evaluate interpolation error at mesh points and print out + print 640,(tauy(j),j=1,ny) + 640 format(//20h interpolation error//6f12.1) + do 45 j=1,ny + call interv(breaky,ly,tauy(j),lefty,mflag) + do 45 i=1,nx + do 41 jj=1,ky + 41 work2(jj)=ppvalu(breakx,coef(1,1,jj,lefty),lx,kx,taux(i),0) + 45 work1(i,j) = g(taux(i),tauy(j)) - + * ppvalu(breaky(lefty),work2,1,ky,tauy(j),0) + do 46 i=1,nx + 46 print 632,taux(i),(work1(i,j),j=1,ny) + stop + end diff --git a/math/deboor/progs/prog3.f b/math/deboor/progs/prog3.f new file mode 100644 index 00000000..337fe7ef --- /dev/null +++ b/math/deboor/progs/prog3.f @@ -0,0 +1,44 @@ +chapter ix. example comparing the b-representation of a cubic f with +c its values at knot averages. +c from * a practical guide to splines * by c. de boor +c + integer i,id,j,jj,n,nm4 + real bcoef(23),d(4),d0(4),dtip1,dtip2,f(23),t(27),tave(23),x +c the taylor coefficients at 0 for the polynomial f are + data d0 /-162.,99.,-18.,1./ +c +c set up knot sequence in the array t . + n = 13 + do 5 i=1,4 + t(i) = 0. + 5 t(n+i) = 10. + nm4 = n-4 + do 6 i=1,nm4 + 6 t(i+4) = float(i) +c + do 50 i=1,n +c use nested multiplication to get taylor coefficients d at +c t(i+2) from those at 0 . + do 20 j=1,4 + 20 d(j) = d0(j) + do 21 j=1,3 + id = 4 + do 21 jj=j,3 + id = id-1 + 21 d(id) = d(id) + d(id+1)*t(i+2) +c +c compute b-spline coefficients by formula (9). + dtip1 = t(i+2) - t(i+1) + dtip2 = t(i+3) - t(i+2) + bcoef(i) = d(1) + (d(2)*(dtip2-dtip1)-d(3)*dtip1*dtip2)/3. +c +c evaluate f at corresp. knot average. + tave(i) = (t(i+1) + t(i+2) + t(i+3))/3. + x = tave(i) + 50 f(i) = d0(1) + x*(d0(2) + x*(d0(3) + x*d0(4))) +c + print 650, (i,tave(i), f(i), bcoef(i),i=1,n) + 650 format(45h i tave(i) f at tave(i) bcoef(i)// + * (i3,f10.5,2f16.5)) + stop + end diff --git a/math/deboor/progs/prog4.f b/math/deboor/progs/prog4.f new file mode 100644 index 00000000..8fc73304 --- /dev/null +++ b/math/deboor/progs/prog4.f @@ -0,0 +1,35 @@ +chapter x. example 1. plotting some b-splines +c from * a practical guide to splines * by c. de boor +calls bsplvb, interv + integer i,j,k,left,leftmk,mflag,n,npoint + real dx,t(10),values(7),x,xl +c dimension, order and knot sequence for spline space are specified... + data n,k /7,3/, t /3*0.,2*1.,3.,4.,3*6./ +c b-spline values are initialized to 0., number of evaluation points... + data values /7*0./, npoint /31/ +c set leftmost evaluation point xl , and spacing dx to be used... + xl = t(k) + dx = (t(n+1)-t(k))/float(npoint-1) +c + print 600,(i,i=1,5) + 600 format(4h1 x,8x,5(1hb,i1,3h(x),7x)) +c + do 10 i=1,npoint + x = xl + float(i-1)*dx +c locate x with respect to knot array t . + call interv ( t, n, x, left, mflag ) + leftmk = left - k +c get b(i,k)(x) in values(i) , i=1,...,n . k of these, +c viz. b(left-k+1,k)(x), ..., b(left,k)(x), are supplied by +c bsplvb . all others are known to be zero a priori. + call bsplvb ( t, k, 1, x, left, values(leftmk+1) ) +c + print 610, x, (values(j),j=3,7) + 610 format(f7.3,5f12.7) +c +c zero out the values just computed in preparation for next +c evalulation point . + do 10 j=1,k + 10 values(leftmk+j) = 0. + stop + end diff --git a/math/deboor/progs/prog5.f b/math/deboor/progs/prog5.f new file mode 100644 index 00000000..b1fbb927 --- /dev/null +++ b/math/deboor/progs/prog5.f @@ -0,0 +1,27 @@ +chapter x. example 2. plotting the pol,s which make up a b-spline +c from * a practical guide to splines * by c. de boor +calls bsplvb +c + integer ia,left + real biatx(4),t(11),values(4),x +c knot sequence set here.... + data t / 4*0.,1.,3.,4.,4*6. / + do 20 ia=1,40 + x = float(ia)*.2 - 1. + do 10 left=4,7 + call bsplvb ( t, 4, 1, x, left, biatx ) +c +c according to bsplvb listing, biatx(.) now contains value +c at x of polynomial which agrees on the interval (t(left), +c t(left+1) ) with the b-spline b(left-4 + . ,4,t) . hence, +c biatx(8-left) now contains value of that polynomial for +c b(left-4 +(8-left) ,4,t) = b(4,4,t) . since this b-spline +c has support (t(4),t(8)), it makes sense to run left = 4, +c ...,7, storing the resulting values in values(1),..., +c values(4) for later printing. +c + 10 values(left-3) = biatx(8-left) + 20 print 620, x, values + 620 format(f10.1,4f20.8) + stop + end diff --git a/math/deboor/progs/prog6.f b/math/deboor/progs/prog6.f new file mode 100644 index 00000000..10c55c1f --- /dev/null +++ b/math/deboor/progs/prog6.f @@ -0,0 +1,23 @@ +chapter x. example 3. construction and evaluation of the pp-representat- +c ion of a b-spline. +c from * a practical guide to splines * by c. de boor +calls bsplpp(bsplvb),ppvalu(interv) +c + integer ia,l + real bcoef(7),break(5),coef(4,4),scrtch(4,4),t(11),value,x + real ppvalu +c set knot sequence t and b-coeffs for b(4,4,t) .... + data t / 4*0.,1.,3.,4.,4*6. /, bcoef / 3*0.,1.,3*0. / +c construct pp-representation .... + call bsplpp ( t, bcoef, 7, 4, scrtch, break, coef, l ) +c +c as a check, evaluate b(4,4,t) from its pp-repr. on a fine mesh. +c the values should agree with (some of) those generated in +c example 2 . + do 20 ia=1,40 + x = float(ia)*.2 - 1. + value = ppvalu ( break, coef, l, 4, x, 0 ) + 20 print 620, x, value + 620 format(f10.1,f20.8) + stop + end diff --git a/math/deboor/progs/prog7.f b/math/deboor/progs/prog7.f new file mode 100644 index 00000000..e08ab120 --- /dev/null +++ b/math/deboor/progs/prog7.f @@ -0,0 +1,17 @@ +chapter x. example 4. construction of a b-spline via bvalue +c from * a practical guide to splines * by c. de boor +calls bvalue(interv) + integer ia + real bcoef(1),t(5),value,x + real bvalue +c set knot sequence t and b-coeffs for b(1,4,t) + data t / 0.,1.,3.,4.,6. / , bcoef / 1. / +c evaluate b(1,4,t) on a fine mesh. on (0,6), the values should +c coincide with those obtained in example 3 . + do 20 ia=1,40 + x = float(ia)*.2 - 1. + value = bvalue ( t, bcoef, 1, 4, x, 0 ) + 20 print 620, x, value + 620 format(f10.1,f20.8) + stop + end diff --git a/math/deboor/progs/prog8.f b/math/deboor/progs/prog8.f new file mode 100644 index 00000000..197f56f3 --- /dev/null +++ b/math/deboor/progs/prog8.f @@ -0,0 +1,63 @@ +chapter xii, example 2. cubic spline interpolation with good knots +c from * a practical guide to splines * by c. de boor +calls cubspl, newnot +c parameter nmax=20 + integer i,istep,iter,itermx,j,n,nhigh,nlow,nm1 +c real algerp,aloger,decay,dx,errmax,c(4,nmax),g,h,pnatx +c * ,scrtch(2,nmax),step,tau(nmax),taunew(nmax) + real algerp,aloger,decay,dx,errmax,c(4,20),g,h,pnatx + * ,scrtch(2,20),step,tau(20),taunew(20),x +c istep and step = float(istep) specify point density for error det- +c ermination. + data step, istep /20., 20/ +c the function g is to be interpolated . + g(x) = sqrt(x+1.) + decay = 0. +c read in the number of iterations to be carried out and the lower +c and upper limit for the number n of data points to be used. + read 500,itermx,nlow,nhigh + 500 format(3i3) + print 600, itermx + 600 format(i4,22h cycles through newnot// + * 28h n max.error decay exp./) +c loop over n = number of data points . + do 40 n=nlow,nhigh,2 +c knots are initially equispaced. + nm1 = n-1 + h = 2./float(nm1) + do 10 i=1,n + 10 tau(i) = float(i-1)*h - 1. + iter = 1 +c construct cubic spline interpolant. then, itermx times, +c determine new knots from it and find a new interpolant. + 11 do 15 i=1,n + 15 c(1,i) = g(tau(i)) + call cubspl ( tau, c, n, 0, 0 ) + if (iter .gt. itermx) go to 19 + iter = iter+1 + call newnot(tau,c,nm1,4,taunew,nm1,scrtch) + do 18 i=1,n + 18 tau(i) = taunew(i) + go to 11 + 19 continue +c estimate max.interpolation error on (-1,1). + errmax = 0. +c loop over polynomial pieces of interpolant . + do 30 i=1,nm1 + dx = (tau(i+1)-tau(i))/step +c interpolation error is calculated at istep points per +c polynomial piece . + do 30 j=1,istep + h = float(j)*dx + pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) + 30 errmax = amax1(errmax,abs(g(tau(i)+h)-pnatx)) +c calculate decay exponent . + aloger = alog(errmax) + if (n .gt. nlow) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger +c + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/progs/prog9.f b/math/deboor/progs/prog9.f new file mode 100644 index 00000000..a0dcfd60 --- /dev/null +++ b/math/deboor/progs/prog9.f @@ -0,0 +1,38 @@ +chapter xii, example 3. cubic spline interpolation with good knots +c from * a practical guide to splines * by c. de boor +calls cubspl + integer i,irate,istep,j,n,nhigh,nlow,nm1 + real algerp,aloger,c(4,20),decay,dx,errmax,g,h,pnatx,step,tau(20) + * ,x + data step, istep /20., 20/ + g(x) = sqrt(x+1.) + decay = 0. + read 500,irate,nlow,nhigh + 500 format(3i3) + print 600 + 600 format(28h n max.error decay exp./) + do 40 n=nlow,nhigh,2 + nm1 = n-1 + h = 1./float(nm1) + do 10 i=1,n + tau(i) = 2.*(float(i-1)*h)**irate - 1. + 10 c(1,i) = g(tau(i)) +c construct cubic spline interpolant. + call cubspl ( tau, c, n, 0, 0 ) +c estimate max.interpolation error on (-1,1). + errmax = 0. + do 30 i=1,nm1 + dx = (tau(i+1)-tau(i))/step + do 30 j=1,istep + h = float(j)*dx + pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) + x = tau(i) + h + 30 errmax = amax1(errmax,abs(g(x)-pnatx)) + aloger = alog(errmax) + if (n .gt. nlow) decay = + * (aloger - algerp)/alog(float(n)/float(n-2)) + algerp = aloger + 40 print 640,n,errmax,decay + 640 format(i3,e12.4,f11.2) + stop + end diff --git a/math/deboor/putit_io.f b/math/deboor/putit_io.f new file mode 100644 index 00000000..c3e97c5a --- /dev/null +++ b/math/deboor/putit_io.f @@ -0,0 +1,82 @@ + subroutine putit ( t, kpm, left, scrtch, dbiatx, q, nrow, b ) +c from * a practical guide to splines * by c. de boor +calls bsplvd(bsplvb),difequ(*) +c to be called by e q b l o k . +c +c puts together one block of the collocation equation system +c +c****** i n p u t ****** +c t knot sequence, of size left+kpm (at least) +c kpm order of spline +c left integer indicating interval of interest, viz the interval +c (t(left), t(left+1)) +c nrow number of rows in block to be put together +c +c****** w o r k a r e a ****** +c scrtch used in bsplvd, of size (kpm,kpm) +c dbiatx used to contain derivatives of b-splines, of size (kpm,m+1) +c with dbiatx(j,i+1) containing the i-th derivative of the +c j-th b-spline of interest +c +c****** o u t p u t ****** +c q the block, of size (nrow,kpm) +c b the corresponding piece of the right side, of size (nrow) +c +c****** m e t h o d ****** +c the k collocation equations for the interval (t(left),t(left+1)) +c are constructed with the aid of the subroutine d i f e q u ( 2, ., +c . ) and interspersed (in order) with the side conditions (if any) in +c this interval, using d i f e q u ( 3, ., . ) for the information. +c the block q has kpm columns, corresponding to the kpm b- +c splines of order kpm which have the interval (t(left),t(left+1)) +c in their support. the block's diagonal is part of the diagonal of the +c total system. the first equation in this block not overlapped by the +c preceding block is therefore equation l o w r o w , with lowrow = +c number of side conditions in preceding intervals (or blocks). +c + integer kpm,left,nrow, i,irow,iside,itermx,j,k,ll,lowrow,m,mode + * ,mp1 + real b(1),dbiatx(kpm,1),q(nrow,kpm),scrtch(1),t(1), dx,rho,sum + * ,v(20),xm,xside,xx + common /side/ m, iside, xside(10) + common /other/ itermx,k,rho(19) + mp1 = m+1 + do 10 j=1,kpm + do 10 i=1,nrow + 10 q(i,j) = 0. + xm = (t(left+1)+t(left))/2. + dx = (t(left+1)-t(left))/2. +c + ll = 1 + lowrow = iside + do 30 irow=lowrow,nrow + if (ll .gt. k) go to 22 + mode = 2 +c next collocation point is ... + xx = xm + dx*rho(ll) + ll = ll + 1 +c the corresp.collocation equation is next unless the next side +c condition occurs at a point at, or to the left of, the next +c collocation point. + if (iside .gt. m) go to 24 + if (xside(iside) .gt. xx) go to 24 + ll = ll - 1 + 22 mode = 3 + xx = xside(iside) + 24 call difequ ( mode, xx, v ) +c the next equation, a collocation equation (mode = 2) or a side +c condition (mode = 3), reads +c (*) (v(m+1)*d**m + v(m)*d**(m-1) +...+ v(1)*d**0)f(xx) = v(m+2) +c in terms of the info supplied by difequ . the corresponding +c equation for the b-coeffs of f therefore has the left side of +c (*), evaluated at each of the kpm b-splines having xx in +c their support, as its kpm possibly nonzero coefficients. + call bsplvd ( t, kpm, xx, left, scrtch, dbiatx, mp1 ) + do 26 j=1,kpm + sum = 0. + do 25 i=1,mp1 + 25 sum = v(i)*dbiatx(j,i) + sum + 26 q(irow,j) = sum + 30 b(irow) = v(m+2) + return + end diff --git a/math/deboor/round.f b/math/deboor/round.f new file mode 100644 index 00000000..df02c939 --- /dev/null +++ b/math/deboor/round.f @@ -0,0 +1,10 @@ + real function round ( x ) +c from * a practical guide to splines * by c. de boor +called in example 1 of chapter xiii + real x, flip,size + common /rount/ size + data flip /-1./ + flip = -flip + round = x + flip*size + return + end diff --git a/math/deboor/sbblok.f b/math/deboor/sbblok.f new file mode 100644 index 00000000..8c4a77fb --- /dev/null +++ b/math/deboor/sbblok.f @@ -0,0 +1,48 @@ + subroutine sbblok ( bloks, integs, nbloks, ipivot, b, x ) +calls subroutines s u b f o r and s u b b a k . +c +c supervises the solution (by forward and backward substitution) of +c the linear system a*x = b for x, with the plu factorization of a +c already generated in f c b l o k . individual blocks of equations +c are solved via s u b f o r and s u b b a k . +c +c parameters +c bloks, integs, nbloks, ipivot are as on return from fcblok. +c b the right side, stored corresponding to the storage of +c the equations. see comments in s l v b l k for details. +c x solution vector +c + integer nbloks + integer integs(3,nbloks),ipivot(1), i,index,indexb,indexx,j,last, + * nbp1,ncol,nrow + real bloks(1),b(1),x(1) +c +c forward substitution pass +c + index = 1 + indexb = 1 + indexx = 1 + do 20 i=1,nbloks + nrow = integs(1,i) + last = integs(3,i) + call subfor(bloks(index),ipivot(indexb),nrow,last,b(indexb), + * x(indexx)) + index = nrow*integs(2,i) + index + indexb = indexb + nrow + 20 indexx = indexx + last +c +c back substitution pass +c + nbp1 = nbloks + 1 + do 30 j=1,nbloks + i = nbp1 - j + nrow = integs(1,i) + ncol = integs(2,i) + last = integs(3,i) + index = index - nrow*ncol + indexb = indexb - nrow + indexx = indexx - last + 30 call subbak(bloks(index),ipivot(indexb),nrow,ncol,last, + * x(indexx)) + return + end diff --git a/math/deboor/setdat.f b/math/deboor/setdat.f new file mode 100644 index 00000000..40012a38 --- /dev/null +++ b/math/deboor/setdat.f @@ -0,0 +1,41 @@ + subroutine setdat(icount) +c from * a practical guide to splines * by c. de boor +c to be called in main program l 2 m a i n . +c this routine is set up to provide the specific data for example 2 +c in chapter xiv. for a general purpose l2-approximation program, it +c would have to be replaced by a subroutine reading in +c ntau, tau(i), gtau(i), i=1,...,ntau +c and reading in or setting +c k, l, break(i),i=1,...,l+1, and weight(i),i=1,...,ntau, +c as well as totalw = sum( weight(i) , i=1,...,ntau). +c i c o u n t is equal to zero when setdat is called in l 2 m a i n +c for the first time. after that, it is up to setdat to use icount +c for keeping track of the passes through setdat . this is important +c since l2main relies on setdat for t e r m i n a t i o n . + integer icount, i,k,l,lp1,ntau,ntaum1 + real break,coef,gtau,step,tau,totalw,weight +c parameter lpkmax=100,ntmax=200,ltkmax=2000 +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw +c common /approx/ break(lpkmax),coef(ltkmax),l,k + common / data / ntau, tau(200),gtau(200),weight(200),totalw + common /approx/ break(100),coef(2000),l,k + if (icount .gt. 0) stop + icount = icount + 1 + ntau = 10 + ntaum1 = ntau-1 + do 8 i=1,ntaum1 + 8 tau(i) = 1. - .5**(i-1) + tau(ntau) = 1. + do 9 i=1,ntau + 9 gtau(i) = tau(i)**2 + 1. + do 10 i=1,ntau + 10 weight(i) = 1. + totalw = ntau + l = 6 + lp1 = l+1 + step = 1./float(l) + k = 2 + do 11 i=1,lp1 + 11 break(i) = (i-1)*step + return + end diff --git a/math/deboor/setdat2.f b/math/deboor/setdat2.f new file mode 100644 index 00000000..cf767a59 --- /dev/null +++ b/math/deboor/setdat2.f @@ -0,0 +1,29 @@ + subroutine setdt2(icount) +c from * a practical guide to splines * by c. de boor +c to be called in main program l 2 m a i n . +c this routine is set up to provide the specific data for example 3 +c in chapter xiv. +c + integer icount, i,k,l,ntau + real break,coef,gtau,step,tau,totalw,weight,x,round +c parameter lpkmax=100,ntmax=200,ltkmax=2000 +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw +c common /approx/ break(lpkmax),coef(ltkmax),l,k + common / data / ntau, tau(200),gtau(200),weight(200),totalw + common /approx/ break(100),coef(2000),l,k + round(x) = float(ifix(x*100.))/100. + if (icount .gt. 0) stop + icount = icount + 1 + ntau = 65 + step = 3./float(ntau-1) + do 10 i=1,ntau + tau(i) = i*step + gtau(i) = round(exp(tau(i))) + 10 weight(i) = 1. + totalw = ntau + l = 1 + break(1) = tau(1) + break(2) = tau(ntau) + k = 3 + return + end diff --git a/math/deboor/setdat3.f b/math/deboor/setdat3.f new file mode 100644 index 00000000..3524e489 --- /dev/null +++ b/math/deboor/setdat3.f @@ -0,0 +1,27 @@ + subroutine setdt3(icount) +c from * a practical guide to splines * by c. de boor +c to be called in main program l 2 m a i n . +c calls titand +c this routine is set up to provide the specific data for example 4 +c in chapter xiv. + integer icount, i,k,l,n,ntau + real break,brkpic(9),coef,gtau,tau,totalw,weight +c parameter lpkmax=100,ntmax=200,ltkmax=2000 +c common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw +c common /approx/ break(lpkmax),coef(ltkmax),l,k + common / data / ntau, tau(200),gtau(200),weight(200),totalw + common /approx/ break(100),coef(2000),l,k + data brkpic,n/595.,730.985,794.414,844.476,880.06,907.814, + * 938.001,976.752,1075.,9/ + if (icount .gt. 0) stop + icount = icount + 1 + call titand ( tau, gtau, ntau ) + do 10 i=1,ntau + 10 weight(i) = 1. + totalw = ntau + l = n-1 + k = 5 + do 11 i=1,n + 11 break(i) = brkpic(i) + return + end diff --git a/math/deboor/setupq.f b/math/deboor/setupq.f new file mode 100644 index 00000000..dea21a3b --- /dev/null +++ b/math/deboor/setupq.f @@ -0,0 +1,40 @@ + subroutine setupq ( x, dx, y, npoint, v, qty ) +c from * a practical guide to splines * by c. de boor +c to be called in s m o o t h +c put delx = x(.+1) - x(.) into v(.,4), +c put the three bands of q-transp*d into v(.,1-3), and +c put the three bands of (d*q)-transp*(d*q) at and above the diagonal +c into v(.,5-7) . +c here, q is the tridiagonal matrix of order (npoint-2,npoint) +c with general row 1/delx(i) , -1/delx(i) - 1/delx(i+1) , 1/delx(i+1) +c and d is the diagonal matrix with general row dx(i) . + integer npoint, i,npm1 + real dx(npoint),qty(npoint),v(npoint,7),x(npoint),y(npoint), + * diff, prev + npm1 = npoint - 1 + v(1,4) = x(2) - x(1) + do 11 i=2,npm1 + v(i,4) = x(i+1) - x(i) + v(i,1) = dx(i-1)/v(i-1,4) + v(i,2) = - dx(i)/v(i,4) - dx(i)/v(i-1,4) + 11 v(i,3) = dx(i+1)/v(i,4) + v(npoint,1) = 0. + do 12 i=2,npm1 + 12 v(i,5) = v(i,1)**2 + v(i,2)**2 + v(i,3)**2 + if (npm1 .lt. 3) go to 14 + do 13 i=3,npm1 + 13 v(i-1,6) = v(i-1,2)*v(i,1) + v(i-1,3)*v(i,2) + 14 v(npm1,6) = 0. + if (npm1 .lt. 4) go to 16 + do 15 i=4,npm1 + 15 v(i-2,7) = v(i-2,3)*v(i,1) + 16 v(npm1-1,7) = 0. + v(npm1,7) = 0. +construct q-transp. * y in qty. + prev = (y(2) - y(1))/v(1,4) + do 21 i=2,npm1 + diff = (y(i+1)-y(i))/v(i,4) + qty(i) = diff - prev + 21 prev = diff + return + end diff --git a/math/deboor/seval.x b/math/deboor/seval.x new file mode 100644 index 00000000..ee9cd1e9 --- /dev/null +++ b/math/deboor/seval.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include +include "bspln.h" + +.help seval 2 "math library" +.ih +NAME +seval -- evaluate the Dth derivative of a Kth order b-spline at X. +.ih +USAGE +y = seval (x, deriv, bspln) +.ih +PARAMETERS +The single precision real value returned by SEVAL is the value of the D-th +derivative of the b-spline at X. INDEF is returned if X lies outside the +domain of the spline. +.ls x +(real). Logical x-value at which the spline is to be evaluated. +.le +.ls deriv +The derivative to be evaluated. The zeroth derivative is the function value. +.le +.ls bspln +(real[2*n+30]). B-spline descriptor structure, generated by a previous +call to SPLINE, SPLLSQ, etc. +.le +.ih +DESCRIPTION +Calculate the Dth derivative of a Kth order B-spline. Based on BVALUE, from +"A Practical Guide to Splines", by C. DeBoor. The main changes incorporated +in SEVAL involve the use of the BSPLN array to convey all of the information +needed to describe the spline. This simplifies the calling sequences, and +improves the communication between routines. SEVAL is designed to be easy to +use, and reasonably efficient in the case where a N point spline is to be +evaluated N times or less. If a spline is to be fitted and then evaluated +many times, conversion to PP representation may be warranted to gain maximum +efficiency. +.ih +METHOD +See DeBoor, pg. 144, or the listing of BVALUE, for a detailed explanation +of the mathematics involved. In short, we find the knot interval containing +X, choosing the next interval to the left if X happens to fall square on a +knot. The distances of X from the K-1 knots to the left and right are then +calculated, and the K b-spline coefficients contributing to the interval are +extracted. Calculation of divided differences follows, if a derivative is +to be calculated. Finally the value of the b-spline at X is evaluated and +returned. +.ih +BUGS +The special case ND == 0 and ORDER == 4 (cubic spline) should be recognized, +and specially optimized code used to evaluate the spline in that case. +.ih +SEE ALSO +spline(2), fsplin(2), spllsq(2). +.endhelp _____________________________________________________________ + + +real procedure seval (x, deriv, bspln) + +real x # logical x value +real bspln[ARB] # ARB = [2 * NCOEF + 30] +int deriv # derivative = 0,1,2,...,k-1 + +int i, j, k, n, jj, ilo, kmj, km1, offset, knots, coefs +real aj[KMAX], dl[KMAX], dr[KMAX], fkmj + +begin + if (x < XMIN || x > XMAX) # x out of range? + return (INDEF) + + k = ORDER # fetch k from bspln header + if (deriv >= k) # Kth deriv K degree polyn is zero + return (0.) + +# Find i such that X is in the interval T[i] <= X < T[i+1]. First we fetch +# KINDEX from the bspln header. This is the index into the knot array from +# the last call (many, if not most, calls to SEVAL are sequential in nature). +# Usually, KINDEX will already be the right interval, or will be one off. If +# more than one off, DeBoors INTERV is called to find the correct index via a +# binary search. INTERV handles the special cases (x == XMAX). + + i = KINDEX # previous index for this spline + n = NCOEF + knots = KNOT1 + + if (x >= bspln[i+1]) { # go right + i = i + 1 + if (x >= bspln[i+1]) { + call interv (bspln[knots], n, x, i, j) + i = i + knots - 1 + } + + } else if (x < bspln[i]) { # go left + i = i - 1 + if (x < bspln[i]) { + call interv (bspln[knots], n, x, i, j) + i = i + knots - 1 + } + } + KINDEX = i + + + km1 = k - 1 + coefs = i - knots - k + COEF1 + + if (km1 <= 0) # if order=1 (& deriv=0), bvalue = bspln[i]. + return (bspln[coefs+1]) + + +# Store the ORDER b-spline coefficients relevant for the knot interval +# (T[i],T[i+1]) in aj[1],...,aj[k] and compute dl[j] = x - t[i+k-j], +# dr[j] = t[i+k-1+j] - x, j=1,...,k-1. Note that the K knots at each endpoint +# all have the same T-value, hence we use the lookup table T, rather than +# calculate the DL and DR from the knot spacing. + + offset = i + 1 + do j = 1, km1 + dl[j] = x - bspln[offset-j] + + offset = offset - 1 + do j = 1, km1 + dr[j] = bspln[i+j] - x + + do j = 1, k # fetch K coefficients + aj[j] = bspln[coefs+j] + + +# Difference the coefficients deriv times. + + if (deriv != 0) { # only if taking a derivative + do j = 1, deriv { + kmj = k - j + fkmj = real (kmj) + ilo = kmj + do jj = 1, kmj { + aj[jj] = ((aj[jj+1] - aj[jj]) / (dl[ilo] + dr[jj])) * fkmj + ilo = ilo - 1 + } + } + } + + +# Compute value at X in (t[i],t[i+])) of deriv-th derivative, given its +# relevant b-spline coeffs in aj[1],...,aj[k-deriv]. + + if (deriv != km1) { + do j = deriv + 1, km1 { + kmj = k - j + ilo = kmj + do jj = 1, kmj { + aj[jj] = (aj[jj+1] * dl[ilo] + aj[jj] * dr[jj]) / (dl[ilo] + dr[jj]) + ilo = ilo - 1 + } + } + } + return (aj[1]) +end diff --git a/math/deboor/shiftb.f b/math/deboor/shiftb.f new file mode 100644 index 00000000..144c60f8 --- /dev/null +++ b/math/deboor/shiftb.f @@ -0,0 +1,50 @@ + subroutine shiftb ( ai, ipivot, nrowi, ncoli, last, + * ai1, nrowi1, ncoli1 ) +c shifts the rows in current block, ai, not used as pivot rows, if +c any, i.e., rows ipivot(last+1),...,ipivot(nrowi), onto the first +c mmax = nrow-last rows of the next block, ai1, with column last+j of +c ai going to column j , j=1,...,jmax=ncoli-last. the remaining col- +c umns of these rows of ai1 are zeroed out. +c +c picture +c +c original situation after results in a new block i+1 +c last = 2 columns have been created and ready to be +c done in factrb (assuming no factored by next factrb call. +c interchanges of rows) +c 1 +c x x 1x x x x x x x x +c 1 +c 0 x 1x x x 0 x x x x +c block i 1 --------------- +c nrowi = 4 0 0 1x x x 0 0 1x x x 0 01 +c ncoli = 5 1 1 1 +c last = 2 0 0 1x x x 0 0 1x x x 0 01 +c ------------------------------- 1 1 new +c 1x x x x x 1x x x x x1 block +c 1 1 1 i+1 +c block i+1 1x x x x x 1x x x x x1 +c nrowi1= 5 1 1 1 +c ncoli1= 5 1x x x x x 1x x x x x1 +c ------------------------------- 1-------------1 +c 1 +c + integer nrowi, ncoli, nrowi1, ncoli1 + integer ipivot(nrowi),last, ip,j,jmax,jmaxp1,m,mmax + real ai(nrowi,ncoli),ai1(nrowi1,ncoli1) + mmax = nrowi - last + jmax = ncoli - last + if (mmax .lt. 1 .or. jmax .lt. 1) return +c put the remainder of block i into ai1 + do 10 m=1,mmax + ip = ipivot(last+m) + do 10 j=1,jmax + 10 ai1(m,j) = ai(ip,last+j) + if (jmax .eq. ncoli1) return +c zero out the upper right corner of ai1 + jmaxp1 = jmax + 1 + do 20 j=jmaxp1,ncoli1 + do 20 m=1,mmax + 20 ai1(m,j) = 0. + return + end diff --git a/math/deboor/slvblk.f b/math/deboor/slvblk.f new file mode 100644 index 00000000..80be1302 --- /dev/null +++ b/math/deboor/slvblk.f @@ -0,0 +1,127 @@ + subroutine slvblk ( bloks, integs, nbloks, b, ipivot, x, iflag ) +c this program solves the linear system a*x = b where a is an +c almost block diagonal matrix. such almost block diagonal matrices +c arise naturally in piecewise polynomial interpolation or approx- +c imation and in finite element methods for two-point boundary value +c problems. the plu factorization method is implemented here to take +c advantage of the special structure of such systems for savings in +c computing time and storage requirements. +c +c parameters +c bloks a one-dimenional array, of length +c sum( integs(1,i)*integs(2,i) ; i = 1,nbloks ) +c on input, contains the blocks of the almost block diagonal +c matrix a . the array integs (see below and the example) +c describes the block structure. +c on output, contains correspondingly the plu factorization +c of a (if iflag .ne. 0). certain of the entries into bloks +c are arbitrary (where the blocks overlap). +c integs integer array description of the block structure of a . +c integs(1,i) = no. of rows of block i = nrow +c integs(2,i) = no. of colums of block i = ncol +c integs(3,i) = no. of elim. steps in block i = last +c i = 1,2,...,nbloks +c the linear system is of order +c n = sum ( integs(3,i) , i=1,...,nbloks ), +c but the total number of rows in the blocks is +c nbrows = sum( integs(1,i) ; i = 1,...,nbloks) +c nbloks number of blocks +c b right side of the linear system, array of length nbrows. +c certain of the entries are arbitrary, corresponding to +c rows of the blocks which overlap (see block structure and +c the example below). +c ipivot on output, integer array containing the pivoting sequence +c used. length is nbrows +c x on output, contains the computed solution (if iflag .ne. 0) +c length is n. +c iflag on output, integer +c = (-1)**(no. of interchanges during factorization) +c if a is invertible +c = 0 if a is singular +c +c auxiliary programs +c fcblok (bloks,integs,nbloks,ipivot,scrtch,iflag) factors the matrix +c a , and is used for this purpose in slvblk. its arguments +c are as in slvblk, except for +c scrtch = a work array of length max(integs(1,i)). +c +c sbblok (bloks,integs,nbloks,ipivot,b,x) solves the system a*x = b +c once a is factored. this is done automatically by slvblk +c for one right side b, but subsequent solutions may be +c obtained for additional b-vectors. the arguments are all +c as in slvblk. +c +c dtblok (bloks,integs,nbloks,ipivot,iflag,detsgn,detlog) computes the +c determinant of a once slvblk or fcblok has done the fact- +c orization.the first five arguments are as in slvblk. +c detsgn = sign of the determinant +c detlog = natural log of the determinant +c +c ------ block structure of a ------ +c the nbloks blocks are stored consecutively in the array bloks . +c the first block has its (1,1)-entry at bloks(1), and, if the i-th +c block has its (1,1)-entry at bloks(index(i)), then +c index(i+1) = index(i) + nrow(i)*ncol(i) . +c the blocks are pieced together to give the interesting part of a +c as follows. for i = 1,2,...,nbloks-1, the (1,1)-entry of the next +c block (the (i+1)st block ) corresponds to the (last+1,last+1)-entry +c of the current i-th block. recall last = integs(3,i) and note that +c this means that +c a. every block starts on the diagonal of a . +c b. the blocks overlap (usually). the rows of the (i+1)st block +c which are overlapped by the i-th block may be arbitrarily de- +c fined initially. they are overwritten during elimination. +c the right side for the equations in the i-th block are stored cor- +c respondingly as the last entries of a piece of b of length nrow +c (= integs(1,i)) and following immediately in b the corresponding +c piece for the right side of the preceding block, with the right side +c for the first block starting at b(1) . in this, the right side for +c an equation need only be specified once on input, in the first block +c in which the equation appears. +c +c ------ example and test driver ------ +c the test driver for this package contains an example, a linear +c system of order 11, whose nonzero entries are indicated in the fol- +c lowing schema by their row and column index modulo 10. next to it +c are the contents of the integs arrray when the matrix is taken to +c be almost block diagonal with nbloks = 5, and below it are the five +c blocks. +c +c nrow1 = 3, ncol1 = 4 +c 11 12 13 14 +c 21 22 23 24 nrow2 = 3, ncol2 = 3 +c 31 32 33 34 +c last1 = 2 43 44 45 +c 53 54 55 nrow3 = 3, ncol3 = 4 +c last2 = 3 66 67 68 69 nrow4 = 3, ncol4 = 4 +c 76 77 78 79 nrow5 = 4, ncol5 = 4 +c 86 87 88 89 +c last3 = 1 97 98 99 90 +c last4 = 1 08 09 00 01 +c 18 19 10 11 +c last5 = 4 +c +c actual input to bloks shown by rows of blocks of a . +c (the ** items are arbitrary, this storage is used by slvblk) +c +c 11 12 13 14 / ** ** ** / 66 67 68 69 / ** ** ** ** / ** ** ** ** +c 21 22 23 24 / 43 44 45 / 76 77 78 79 / ** ** ** ** / ** ** ** ** +c 31 32 33 34/ 53 54 55/ 86 87 88 89/ 97 98 99 90/ 08 09 00 01 +c 18 19 10 11 +c +c index = 1 index = 13 index = 22 index = 34 index = 46 +c +c actual right side values with ** for arbitrary values +c b1 b2 b3 ** b4 b5 b6 b7 b8 ** ** b9 ** ** b10 b11 +c +c (it would have been more efficient to combine block 3 with block 4) +c + integer nbloks + integer integs(3,nbloks),ipivot(1),iflag + real bloks(1),b(1),x(1) +c in the call to fcblok, x is used for temporary storage. + call fcblok(bloks,integs,nbloks,ipivot,x,iflag) + if (iflag .eq. 0) return + call sbblok(bloks,integs,nbloks,ipivot,b,x) + return + end diff --git a/math/deboor/smooth.f b/math/deboor/smooth.f new file mode 100644 index 00000000..9ae041a7 --- /dev/null +++ b/math/deboor/smooth.f @@ -0,0 +1,112 @@ + real function smooth ( x, y, dy, npoint, s, v, a ) +c from * a practical guide to splines * by c. de boor +calls setupq, chol1d +c +c constructs the cubic smoothing spline f to given data (x(i),y(i)), +c i=1,...,npoint, which has as small a second derivative as possible +c while +c s(f) = sum( ((y(i)-f(x(i)))/dy(i))**2 , i=1,...,npoint ) .le. s . +c +c****** i n p u t ****** +c x(1),...,x(npoint) data abscissae, a s s u m e d to be strictly +c increasing . +c y(1),...,y(npoint) corresponding data ordinates . +c dy(1),...,dy(npoint) estimate of uncertainty in data, a s s u m- +c e d to be positive . +c npoint.....number of data points, a s s u m e d .gt. 1 +c s.....upper bound on the discrete weighted mean square distance of +c the approximation f from the data . +c +c****** w o r k a r r a y s ***** +c v.....of size (npoint,7) +c a.....of size (npoint,4) +c +c***** o u t p u t ***** +c a(.,1).....contains the sequence of smoothed ordinates . +c a(i,j) = d**(j-1)f(x(i)), j=2,3,4, i=1,...,npoint-1 , i.e., the +c first three derivatives of the smoothing spline f at the +c left end of each of the data intervals . +c w a r n i n g . . . a would have to be transposed before it +c could be used in ppvalu . +c +c****** m e t h o d ****** +c the matrices q-transp*d and q-transp*d**2*q are constructed in +c s e t u p q from x and dy , as is the vector qty = q-transp*y . +c then, for given p , the vector u is determined in c h o l 1 d as +c the solution of the linear system +c (6(1-p)q-transp*d**2*q + p*r)u = qty . +c from u , the smoothing spline f (for this choice of smoothing par- +c ameter p ) is obtained in the sense that +c f(x(.)) = y - 6(1-p)d**2*q*u and +c (d**2)f(x(.)) = 6*p*u . +c the smoothing parameter p is found (if possible) so that +c sf(p) = s , +c with sf(p) = s(f) , where f is the smoothing spline as it depends +c on p . if s = 0, then p = 1 . if sf(0) .le. s , then p = 0 . +c otherwise, the secant method is used to locate an appropriate p in +c the open interval (0,1) . specifically, +c p(0) = 0, p(1) = (s - sf(0))/dsf +c with dsf = -24*u-transp*r*u a good approximation to d(sf(0)) = dsf +c + 60*(d*q*u)-transp*(d*q*u) , and u as obtained for p = 0 . +c after that, for n=1,2,... until sf(p(n)) .le. 1.01*s, do.... +c determine p(n+1) as the point at which the secant to sf at the +c points p(n) and p(n-1) takes on the value s . +c if p(n+1) .ge. 1 , choose instead p(n+1) as the point at which +c the parabola sf(p(n))*((1-.)/(1-p(n)))**2 takes on the value s. +c note that, in exact arithmetic, always p(n+1) .lt. p(n) , hence +c sf(p(n+1)) .lt. sf(p(n)) . therefore, also stop the iteration, +c with final p = 1 , in case sf(p(n+1)) .ge. sf(p(n)) . +c + integer npoint, i,npm1 + real a(npoint,4),dy(npoint),s,v(npoint,7),x(npoint),y(npoint) + * ,change,p,prevsf,prevp,sfp,sixp,six1mp,utru + call setupq(x,dy,y,npoint,v,a(1,4)) + if (s .gt. 0.) go to 20 + 10 p = 1. + call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1)) + sfp = 0. + go to 60 + 20 p = 0. + call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1)) + sfp = 0. + do 21 i=1,npoint + 21 sfp = sfp + (a(i,1)*dy(i))**2 + sfp = sfp*36. + if (sfp .le. s) go to 60 + prevp = 0. + prevsf = sfp + utru = 0. + do 25 i=2,npoint + 25 utru = utru + v(i-1,4)*(a(i-1,3)*(a(i-1,3)+a(i,3))+a(i,3)**2) + p = (sfp-s)/(24.*utru) +c secant iteration for the determination of p starts here. + 30 call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1)) + sfp = 0. + do 35 i=1,npoint + 35 sfp = sfp+ (a(i,1)*dy(i))**2 + sfp = sfp*36.*(1.-p)**2 + if (sfp .le. 1.01*s) go to 60 + if (sfp .ge. prevsf) go to 10 + change = (p-prevp)/(sfp-prevsf)*(sfp-s) + prevp = p + p = p - change + prevsf = sfp + if (p .lt. 1.) go to 30 + p = 1. - sqrt(s/prevsf)*(1.-prevp) + go to 30 +correct value of p has been found. +compute pol.coefficients from q*u (in a(.,1)). + 60 smooth = sfp + six1mp = 6.*(1.-p) + do 61 i=1,npoint + 61 a(i,1) = y(i) - six1mp*dy(i)**2*a(i,1) + sixp = 6.*p + do 62 i=1,npoint + 62 a(i,3) = a(i,3)*sixp + npm1 = npoint - 1 + do 63 i=1,npm1 + a(i,4) = (a(i+1,3)-a(i,3))/v(i,4) + 63 a(i,2) = (a(i+1,1)-a(i,1))/v(i,4) + * - (a(i,3)+a(i,4)/3.*v(i,4))/2.*v(i,4) + return + end diff --git a/math/deboor/spli2d_io.f b/math/deboor/spli2d_io.f new file mode 100644 index 00000000..a39f7db5 --- /dev/null +++ b/math/deboor/spli2d_io.f @@ -0,0 +1,130 @@ + subroutine spli2d ( tau, gtau, t, n, k, m, work, q, bcoef, iflag ) +c from * a practical guide to splines * by c. de boor +calls bsplvb, banfac/slv +c this is an extended version of splint , for the use in tensor prod- +c uct interpolation. +c +c spli2d produces the b-spline coeff.s bcoef(j,.) of the spline of +c order k with knots t (i), i=1,..., n + k , which takes on the +c value gtau (i,j) at tau (i), i=1,..., n , j=1,..., m . +c +c****** i n p u t ****** +c tau.....array of length n , containing data point abscissae. +c a s s u m p t i o n . . . tau is strictly increasing +c gtau(.,j)..corresponding array of length n , containing data point +c ordinates, j=1,...,m +c t.....knot sequence, of length n+k +c n.....number of data points and dimension of spline space s(k,t) +c k.....order of spline +c m.....number of data sets +c +c****** w o r k a r e a ****** +c work a vector of length n +c +c****** o u t p u t ****** +c q.....array of size (2*k-1)*n , containing the triangular factoriz- + +c ation of the coefficient matrix of the linear system for the b- +c coefficients of the spline interpolant. +c the b-coeffs for the interpolant of an additional data set +c (tau(i),htau(i)), i=1,...,n with the same data abscissae can +c be obtained without going through all the calculations in this + +c routine, simply by loading htau into bcoef and then execut- +c ing the call banslv ( q, 2*k-1, n, k-1, k-1, bcoef ) +c bcoef.....the b-coefficients of the interpolant, of length n +c iflag.....an integer indicating success (= 1) or failure (= 2) +c the linear system to be solved is (theoretically) invertible if +c and only if +c t(i) .lt. tau(i) .lt. tau(i+k), all i. +c violation of this condition is certain to lead to iflag = 2 . + +c +c****** m e t h o d ****** +c the i-th equation of the linear system a*bcoef = b for the b-co- +c effs of the interpolant enforces interpolation at tau(i), i=1,...,n. +c hence, b(i) = gtau(i), all i, and a is a band matrix with 2k-1 +c bands (if it is invertible). +c the matrix a is generated row by row and stored, diagonal by di- +c agonal, in the r o w s of the array q , with the main diagonal go- +c ing into row k . see comments in the program below. +c the banded system is then solved by a call to banfac (which con- + +c structs the triangular factorization for a and stores it again in +c q ), followed by a call to banslv (which then obtains the solution + +c bcoef by substitution). +c banfac does no pivoting, since the total positivity of the matrix +c a makes this unnecessary. +c + integer iflag,k,m,n, i,ilp1mx,j,jj,km1,kpkm2,left,lenq,np1 + real bcoef(m,n),gtau(n,m),q(1),t(1),tau(n),work(n), taui +c dimension q(2*k-1,n), t(n+k) +current fortran standard makes it impossible to specify precisely the +c dimension of q and t without the introduction of otherwise super- +c fluous additional arguments. + np1 = n + 1 + km1 = k - 1 + kpkm2 = 2*km1 + left = k +c zero out all entries of q + lenq = n*(k+km1) + do 5 i=1,lenq + 5 q(i) = 0. +c +c *** loop over i to construct the n interpolation equations + do 30 i=1,n + taui = tau(i) + ilp1mx = min0(i+k,np1) +c *** find left in the closed interval (i,i+k-1) such that +c t(left) .le. tau(i) .lt. t(left+1) +c matrix is singular if this is not possible + left = max0(left,i) + if (taui .lt. t(left)) go to 998 + 15 if (taui .lt. t(left+1)) go to 16 + left = left + 1 + if (left .lt. ilp1mx) go to 15 + left = left - 1 + if (taui .gt. t(left+1)) go to 998 +c *** the i-th equation enforces interpolation at taui, hence +c a(i,j) = b(j,k,t)(taui), all j. only the k entries with j = + +c left-k+1,...,left actually might be nonzero. these k numbers + +c are returned, in work (used for temp.storage here), by the +c following + 16 call bsplvb ( t, k, 1, taui, left, work ) +c we therefore want work(j) = b(left -k+j)(taui) to go into +c a(i,left-k+j), i.e., into q(i-(left+j)+2*k,(left+j)-k) since +c a(i+j,j) is to go into q(i+k,j), all i,j, if we consider q + +c as a two-dim. array , with 2*k-1 rows (see comments in +c banfac). in the present program, we treat q as an equivalent + +c one-dimensional array (because of fortran restrictions on +c dimension statements) . we therefore want work(j) to go into +c entry +c i -(left+j) + 2*k + ((left+j) - k-1)*(2*k-1) +c = i-left+1 + (left -k)*(2*k-1) + (2*k-2)*j +c of q . + jj = i-left+1 + (left-k)*(k+km1) + do 30 j=1,k + jj = jj+kpkm2 + 30 q(jj) = work(j) +c +c ***obtain factorization of a , stored again in q. + call banfac ( q, k+km1, n, km1, km1, iflag ) + go to (40,999), iflag +c *** solve a*bcoef = gtau by backsubstitution + 40 do 50 j=1,m + do 41 i=1,n + 41 work(i) = gtau(i,j) + call banslv ( q, k+km1, n, km1, km1, work ) + do 50 i=1,n + 50 bcoef(j,i) = work(i) + return + 998 iflag = 2 + 999 print 699 + 699 format(41h linear system in splint not invertible) + return + end diff --git a/math/deboor/spline.x b/math/deboor/spline.x new file mode 100644 index 00000000..d77c8122 --- /dev/null +++ b/math/deboor/spline.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include "bspln.h" + +.help spline 2 "math library" +.ih +NAME +spline -- generalized spline interpolation with b-splines. +.ih +USAGE +spline (x, y, n, bspln, q, k, ier) +.ih +PARAMETERS +.ls x,y +(real[n]). Abcissae and ordinates of the N data points. +.le +.ls n +The number of input data points, and the number of spline coefficients +to be generated. +.le +.ls bspln +(real[2*n+30]). Output array of N b-spline coefficients, N+K knots, +and the spline descriptor array. +.le +.ls q +(real[(2*K-1)*N]). On output, will contain the +triangular factorization of the coefficient matrix of the linear +system for the b-coefficients of the spline interpolant. If a new +data set differs only in the Y values, Q may be input to FSPLIN to +efficiently solve for the b-spline coefficients of the new data set. +.le +.ls k +The order of the spline (2-20). Must be EVEN at present +(k=4 is the cubic spline). +.le +.ls ier +Zero if ok, nonzero if error (invalid input parameters). +.le +.ih +DESCRIPTION +General spline interpolation. SPLINE is a thinly disguised version of SPLINT +(DeBoor, pg. 204). SPLINE differs from SPLINT in that the knot spacing T is +calculated automatically, using the not-a-knot boundary conditions. Only even +K are permitted at present (K = 2, 4, 6,...). The cubic spline interpolant +corresponds to K = 4. SPLINE saves a complete description of the spline in the +BSPLN array, for use later by SEVAL (used to evaluate the fitted spline) and +FSPLIN (used after a call to SPLINE to more efficiently fit subsequent data +sets). +.ih +SOURCE +See the listing of SPLINT, or Chapter XIII of DeBoors book. +.ih +SEE ALSO +seval(2), fsplin(2). +.endhelp ______________________________________________________________ + + +procedure spline (x, y, n, bspln, q, k, ier) + +real x[n], y[n] +int n, k, ier +real q[ARB], bspln[ARB] #q[(2*k-1)*n], bspln[2*n+30] +int m, i, knot + +begin + if (k < 2 || mod (k, 2) != 0) { + ier = 1 + return + } + + NCOEF = n #set up spline descriptor + ORDER = k + XMIN = x[1] + XMAX = x[n] + + knot = int (KNOT1) - 1 #offset to knot array in bspln + KINDEX = knot + k #initial posn for SEVAL + + m = knot + n + do i = 1, k { #not-a-knot knot boundary conditions + bspln[knot+i] = XMIN + bspln[m+i] = XMAX + } + + m = k / 2 #use data x-values inside + do i = k+1, n + bspln[knot+i] = x[i+m-k] + + call splint (x, y, bspln[knot+1], n, k, q, bspln[COEF1], ier) + if (ier == 1) #1=success, 2==failure + ier = 0 +end diff --git a/math/deboor/splint.f b/math/deboor/splint.f new file mode 100644 index 00000000..3354dadf --- /dev/null +++ b/math/deboor/splint.f @@ -0,0 +1,113 @@ + subroutine splint ( tau, gtau, t, n, k, q, bcoef, iflag ) +c from * a practical guide to splines * by c. de boor +calls bsplvb, banfac/slv +c +c splint produces the b-spline coeff.s bcoef of the spline of order +c k with knots t(i), i=1,..., n + k , which takes on the value +c gtau(i) at tau(i), i=1,..., n . +c +c****** i n p u t ****** +c tau.....array of length n , containing data point abscissae. +c a s s u m p t i o n . . . tau is strictly increasing +c gtau.....corresponding array of length n , containing data point or- +c dinates +c t.....knot sequence, of length n+k +c n.....number of data points and dimension of spline space s(k,t) +c k.....order of spline +c +c****** o u t p u t ****** +c q.....array of size (2*k-1)*n , containing the triangular factoriz- +c ation of the coefficient matrix of the linear system for the b- +c coefficients of the spline interpolant. +c the b-coeffs for the interpolant of an additional data set +c (tau(i),htau(i)), i=1,...,n with the same data abscissae can +c be obtained without going through all the calculations in this +c routine, simply by loading htau into bcoef and then execut- +c ing the call banslv ( q, 2*k-1, n, k-1, k-1, bcoef ) +c bcoef.....the b-coefficients of the interpolant, of length n +c iflag.....an integer indicating success (= 1) or failure (= 2) +c the linear system to be solved is (theoretically) invertible if +c and only if +c t(i) .lt. tau(i) .lt. tau(i+k), all i. +c violation of this condition is certain to lead to iflag = 2 . +c +c****** m e t h o d ****** +c the i-th equation of the linear system a*bcoef = b for the b-co- +c effs of the interpolant enforces interpolation at tau(i), i=1,...,n. +c hence, b(i) = gtau(i), all i, and a is a band matrix with 2k-1 +c bands (if it is invertible). +c the matrix a is generated row by row and stored, diagonal by di- +c agonal, in the r o w s of the array q , with the main diagonal go- +c ing into row k . see comments in the program below. +c the banded system is then solved by a call to banfac (which con- +c structs the triangular factorization for a and stores it again in +c q ), followed by a call to banslv (which then obtains the solution +c bcoef by substitution). +c banfac does no pivoting, since the total positivity of the matrix +c a makes this unnecessary. +c + integer iflag,k,n, i,ilp1mx,j,jj,km1,kpkm2,left,lenq,np1 + real bcoef(n),gtau(n),q(1),t(1),tau(n), taui +c dimension q(2*k-1,n), t(n+k) +current fortran standard makes it impossible to specify precisely the +c dimension of q and t without the introduction of otherwise super- +c fluous additional arguments. + np1 = n + 1 + km1 = k - 1 + kpkm2 = 2*km1 + left = k +c zero out all entries of q + lenq = n*(k+km1) + do 5 i=1,lenq + 5 q(i) = 0. +c +c *** loop over i to construct the n interpolation equations + do 30 i=1,n + taui = tau(i) + ilp1mx = min0(i+k,np1) +c *** find left in the closed interval (i,i+k-1) such that +c t(left) .le. tau(i) .lt. t(left+1) +c matrix is singular if this is not possible + left = max0(left,i) + if (taui .lt. t(left)) go to 998 + 15 if (taui .lt. t(left+1)) go to 16 + left = left + 1 + if (left .lt. ilp1mx) go to 15 + left = left - 1 + if (taui .gt. t(left+1)) go to 998 +c *** the i-th equation enforces interpolation at taui, hence +c a(i,j) = b(j,k,t)(taui), all j. only the k entries with j = +c left-k+1,...,left actually might be nonzero. these k numbers +c are returned, in bcoef (used for temp.storage here), by the +c following + 16 call bsplvb ( t, k, 1, taui, left, bcoef ) +c we therefore want bcoef(j) = b(left-k+j)(taui) to go into +c a(i,left-k+j), i.e., into q(i-(left+j)+2*k,(left+j)-k) since +c a(i+j,j) is to go into q(i+k,j), all i,j, if we consider q +c as a two-dim. array , with 2*k-1 rows (see comments in +c banfac). in the present program, we treat q as an equivalent +c one-dimensional array (because of fortran restrictions on +c dimension statements) . we therefore want bcoef(j) to go into +c entry +c i -(left+j) + 2*k + ((left+j) - k-1)*(2*k-1) +c = i-left+1 + (left -k)*(2*k-1) + (2*k-2)*j +c of q . + jj = i-left+1 + (left-k)*(k+km1) + do 30 j=1,k + jj = jj+kpkm2 + 30 q(jj) = bcoef(j) +c +c ***obtain factorization of a , stored again in q. + call banfac ( q, k+km1, n, km1, km1, iflag ) + go to (40,999), iflag +c *** solve a*bcoef = gtau by backsubstitution + 40 do 41 i=1,n + 41 bcoef(i) = gtau(i) + call banslv ( q, k+km1, n, km1, km1, bcoef ) + return + 998 iflag = 2 + 999 return +c 999 print 699 +c 699 format(41h linear system in splint not invertible) +c return + end diff --git a/math/deboor/spllsq.x b/math/deboor/spllsq.x new file mode 100644 index 00000000..8760c8a0 --- /dev/null +++ b/math/deboor/spllsq.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "bspln.h" + +.help spllsq 2 "math library" +.ih ___________________________________________________________________________ +NAME +spllsq -- general smoothing b-spline with uniform knots. +.ih +USAGE +spllsq (x, y, w, npts, bspln, q, work, k, n, wflg, ier) +.ih +PARAMETERS +See the listing of SPLSQV if a more detailed discussion of the parameters +than that given here is desired. +.ls x,y,w +(real[npts]). Abscissae, ordinates, and weights of the data points. +X[1] and X[NPTS] determine the range of the spline (the interval over which +it can be evaluated). Dummy data points with zero weight can be supplied +to fix the range if desired. +.le +.ls npts +The number of data points. +.le +.ls bspln +(real[2*n+30]). Output array of N b-spline coefficients, N+K knots, +and the spline descriptor structure. +.le +.ls q +(real[n,k]). Work array. +.le +.ls work +(real[n]). Work array. +.le +.ls k +The order of the desired spline (1-20) (Cubic == 4). +.le +.ls n +N is the number of b-spline coefficients to be output. The relationship +between N and the number of polynomial pieces in the spline (NPP) +is given by NPP = N-K-1. Note that NPP is the important parameter. +N is used in the parameter list rather than NPP because it is used in +dimensioning the arrays. +.le +.ls wflg +Weight generation flag. Options: + +.nf + 0 pass W on to SPLSQV as is + 1 calculate default weights + 2 same as 1, but set W[i] only + if W[i] already NONZERO +.fi + +If WFLG==2, data points may be rejected from the fit by setting their +corresponding weight to zero, before calling SPLLSQ (good points must be +assigned nonzero ws before calling SPLLSQ). Use WFLG==1 if no points +are to be rejected, to avoid having to initialize the W array on every +call. +.le +.ls ier +Error return. Zero if no error. Nonzero indicates invalid combination +of N, K, and NPTS. +.le +.ih +DESCRIPTION +A general algorithm for smoothing with uniform B-splines of arbitrary order. +Calls SPLSQV, which is adapted from L2APPR, as described in "A Practical +Guide To Splines", by C. DeBoor. + +SPLLSQ is identical to SPLSQV, except that (1): the array T[n+k], giving +the x-positions of the knots of the b-spline, is generated internally, +rather than by the calling program, and (2): the weights associated with +the data points may be calculated automatically. The knots are generated +with a uniform spacing. Note that the x-values of the data points do not +have to be uniformly spaced, but they must be monotonically increasing, and +(1) both must span the same range, and (2) if N spline coefficients are +desired, there must be at least N+K data points. +.ih +BUGS +A routine FSPLSQ needs to be written to make use of the Cholesky factorization +returned by SPLSQV in W1, for more efficient fitting of subsequent data sets +that differ only in the y-values of the data points. +.ih +SEE ALSO +seval(2) +.endhelp _______________________________________________________________________ + + +procedure spllsq (x, y, w, npts, bspln, q, work, k, n, wflg, ier) + +real x[npts], y[npts], w[npts] +real q[n,k], work[n] +real bspln[ARB] +int wflg, npts, n, k, ier +int i, npp, km1, knot +real dx + +begin + ier = 0 #successful return value + npp = n - k + 1 #number of polynomial pieces + if (npp <= 0) { + ier = 1 + return + } + + # Set up spline descriptor in the array BCOEF, for later evaluation + # of the spline by BSPLN (see "bcoef.h" for definitions of the fields). + + NCOEF = n #number of b-spline coeff + ORDER = k #order of the spline + XMIN = x[1] #x at left endpoint + XMAX = x[npts] #x at right endpoint + KINDEX = KNOT1 - 1 + k #for SEVAL + + + # Set values of knots. First K knots take on the value of the first + # breakpoint, next npp-1 knots have spacing DX, and the last K knots + # take on the value of the last breakpoint. + + dx = (XMAX - XMIN ) / npp #span(x) = span(t) + + km1 = k - 1 + knot = KNOT1 - 1 + + do i = 1, km1 + bspln[knot+i] = XMIN + + knot = knot + km1 + do i = 1, npp + bspln[knot+i] = XMIN + (i-1) * dx + + knot = knot + npp + do i = 1, k + bspln[knot+i] = XMAX + + + # Calculate default weights. The default weight of a datapoint is + # proportional to the spacing. + + if (wflg > 0) { + if (w[1] > 0 || wflg == 1) + w[1] = x[2] - x[1] + + do i = 2, npts - 1 { + if (w[i] > 0 || wflg == 1) + w[i] = (x[i+1] - x[i-1]) / 2. + } + if (w[npts] > 0 || wflg == 1) + w[npts] = x[npts] - x[npts-1] + } + + + # Call SPLSQV to do the actual spline fit. The N b-spline coefficients + # of order K, N+K knots, and the spline descriptor are returned in + # BSPLN, for evaluation of the spline via SEVAL. + + call splsqv (x, y, w, npts, bspln[nint(KNOT1)], n, k, q, + work, bspln[COEF1], ier) +end diff --git a/math/deboor/splopt_io.f b/math/deboor/splopt_io.f new file mode 100644 index 00000000..7ee5e1a1 --- /dev/null +++ b/math/deboor/splopt_io.f @@ -0,0 +1,196 @@ + subroutine splopt ( tau, n, k, scrtch, t, iflag ) +c from * a practical guide to splines * by c. de boor +calls bsplvb, banfac/slv +computes the knots t for the optimal recovery scheme of order k +c for data at tau(i), i=1,...,n . +c +c****** i n p u t ****** +c tau.....array of length n , containing the interpolation points. +c a s s u m e d to be nondecreasing, with tau(i).lt.tau(i+k),all i. +c n.....number of data points . +c k.....order of the optimal recovery scheme to be used . +c +c****** w o r k a r r a y ***** +c scrtch.....array of length (n-k)(2k+3) + 5k + 3 . the various +c contents are specified in the text below . +c +c****** o u t p u t ****** +c iflag.....integer indicating success (=1) or failure (=2) . +c if iflag = 1, then +c t.....array of length n+k containing the optimal knots ready for +c use in optimal recovery. specifically, t(1) = ... = t(k) = +c tau(1) and t(n+1) = ... = t(n+k) = tau(n) , while the n-k +c interior knots t(k+1), ..., t(n) are calculated as described +c below under *method* . +c if iflag = 2, then +c k .lt. 3, or n .lt. k, or a certain linear system was found to +c be singular. +c +c****** p r i n t e d o u t p u t ****** +c a comment will be printed in case ilfag = 2 or newton iterations +c failed to converge in n e w t m x iterations . +c +c****** m e t h o d ****** +c the (interior) knots t(k+1), ..., t(n) are determined by newtons +c method in such a way that the signum function which changes sign at +c t(k+1), ..., t(n) and nowhere else in (tau(1),tau(n)) is orthogon- +c al to the spline space spline( k , tau ) on that interval . +c let xi(j) be the current guess for t(k+j), j=1,...,n-k. then +c the next newton iterate is of the form +c xi(j) + (-)**(n-k-j)*x(j) , j=1,...,n-k, +c with x the solution of the linear system +c c*x = d . +c here, c(i,j) = b(i)(xi(j)), all j, with b(i) the i-th b-spline of +c order k for the knot sequence tau , all i, and d is the vector +c given by d(i) = sum( -a(j) , j=i,...,n )*(tau(i+k)-tau(i))/k, all i, +c with a(i) = sum ( (-)**(n-k-j)*b(i,k+1,tau)(xi(j)) , j=1,...,n-k ) +c for i=1,...,n-1, and a(n) = -.5 . +c (see chapter xiii of text and references there for a derivation) +c the first guess for t(k+j) is (tau(j+1)+...+tau(j+k-1))/(k-1) . +c iteration terminates if max(abs(x(j))) .lt. t o l , with +c t o l = t o l r t e *(tau(n)-tau(1))/(n-k) , +c or else after n e w t m x iterations , currently, +c newtmx, tolrte / 10, .000001 +c + integer iflag,k,n, i,id,index,j,km1,kpk,kpkm1,kpn,kp1,l,left + *,leftmk,lenw,ll,llmax,llmin,na,nb,nc,nd,newtmx,newton,nmk,nmkm1,nx + real scrtch(1),t(1),tau(n), del,delmax,floatk,sign,signst,sum + * ,tol,tolrte,xij +c dimension scrtch((n-k)*(2*k+3)+5*k+3), t(n+k) +current fortran standard makes it impossible to specify the precise dim- +c ensions of scrtch and t without the introduction of otherwise +c superfluous additional arguments . + data newtmx,tolrte / 10,.000001/ + nmk = n-k + if (nmk) 1,56,2 + 1 print 601,n,k + 601 format(13h argument n =,i4,29h in splopt is less than k =,i3) + go to 999 + 2 if (k .gt. 2) go to 3 + print 602,k + 602 format(13h argument k =,i3,27h in splopt is less than 3) + go to 999 + 3 nmkm1 = nmk - 1 + floatk = k + kpk = k+k + kp1 = k+1 + km1 = k-1 + kpkm1 = kpk-1 + kpn = k+n + signst = -1. + if (nmk .gt. (nmk/2)*2) signst = 1. +c scrtch(i) = tau-extended(i), i=1,...,n+k+k + nx = n+kpk+1 +c scrtch(i+nx) = xi(i),i=0,...,n-k+1 + na = nx + nmk + 1 +c scrtch(i+na) = -a(i), i=1,...,n + nd = na + n +c scrtch(i+nd) = x(i) or d(i), i=1,...,n-k + nb = nd + nmk +c scrtch(i+nb) = biatx(i),i=1,...,k+1 + nc = nb + kp1 +c scrtch(i+(j-1)*(2k-1) + nc) = w(i,j) = c(i-k+j,j), i=j-k,...,j+k, +c j=1,...,n-k. + lenw = kpkm1*nmk +c extend tau to a knot sequence and store in scrtch. + do 5 j=1,k + scrtch(j) = tau(1) + 5 scrtch(kpn+j) = tau(n) + do 6 j=1,n + 6 scrtch(k+j) = tau(j) +c first guess for scrtch (.+nx) = xi . + scrtch(nx) = tau(1) + scrtch(nmk+1+nx) = tau(n) + do 10 j=1,nmk + sum = 0. + do 9 l=1,km1 + 9 sum = sum + tau(j+l) + 10 scrtch(j+nx) = sum/float(km1) +c last entry of scrtch (.+na) = - a is always ... + scrtch(n+na) = .5 +c start newton iteration. + newton = 1 + tol = tolrte*(tau(n) - tau(1))/float(nmk) +c start newton step +compute the 2k-1 bands of the matrix c and store in scrtch(.+nc), +c and compute the vector scrtch(.+na) = -a. + 20 do 21 i=1,lenw + 21 scrtch(i+nc) = 0. + do 22 i=2,n + 22 scrtch(i-1+na) = 0. + sign = signst + left = kp1 + do 28 j=1,nmk + xij = scrtch(j+nx) + 23 if (xij .lt. scrtch(left+1))go to 25 + left = left + 1 + if (left .lt. kpn) go to 23 + left = left - 1 + 25 call bsplvb(scrtch,k,1,xij,left,scrtch(1+nb)) +c the tau sequence in scrtch is preceded by k additional knots +c therefore, scrtch(ll+nb) now contains b(left-2k+ll)(xij) +c which is destined for c(left-2k+ll,j), and therefore for +c w(left-k-j+ll,j)= scrtch(left-k-j+ll + (j-1)*kpkm1 + nc) +c since we store the 2k-1 bands of c in the 2k-1 r o w s of +c the work array w, and w in turn is stored in s c r t c h , +c with w(1,1) = scrtch(1 + nc) . +c also, c being of order n-k, we would want 1 .le. +c left-2k+ll .le. n-k or +c llmin = 2k-left .le. ll .le. n-left+k = llmax . + leftmk = left-k + index = leftmk-j + (j-1)*kpkm1 + nc + llmin = max0(1,k-leftmk) + llmax = min0(k,n-leftmk) + do 26 ll=llmin,llmax + 26 scrtch(ll+index) = scrtch(ll+nb) + call bsplvb(scrtch,kp1,2,xij,left,scrtch(1+nb)) + id = max0(0,leftmk-kp1) + llmin = 1 - min0(0,leftmk-kp1) + do 27 ll=llmin,kp1 + id = id + 1 + 27 scrtch(id+na) = scrtch(id+na) - sign*scrtch(ll+nb) + 28 sign = -sign + call banfac(scrtch(1+nc),kpkm1,nmk,km1,km1,iflag) + go to (45,44),iflag + 44 print 644 + 644 format(32h c in splopt is not invertible) + return +compute scrtch (.+nd) = d from scrtch (.+na) = - a . + 45 i=n + 46 scrtch(i-1+na) = scrtch(i-1+na) + scrtch(i+na) + i = i-1 + if (i .gt. 1) go to 46 + do 49 i=1,nmk + 49 scrtch(i+nd) = scrtch(i+na)*(tau(i+k)-tau(i))/floatk +compute scrtch (.+nd) = x . + call banslv(scrtch(1+nc),kpkm1,nmk,km1,km1,scrtch(1+nd)) +compute scrtch (.+nd) = change in xi . modify, if necessary, to +c prevent new xi from moving more than 1/3 of the way to its +c neighbors. then add to xi to obtain new xi in scrtch(.+nx). + delmax = 0. + sign = signst + do 53 i=1,nmk + del = sign*scrtch(i+nd) + delmax = amax1(delmax,abs(del)) + if (del .gt. 0.) go to 51 + del = amax1(del,(scrtch(i-1+nx)-scrtch(i+nx))/3.) + go to 52 + 51 del = amin1(del,(scrtch(i+1+nx)-scrtch(i+nx))/3.) + 52 sign = -sign + 53 scrtch(i+nx) = scrtch(i+nx) + del +call it a day in case change in xi was small enough or too many +c steps were taken. + if (delmax .lt. tol) go to 54 + newton = newton + 1 + if (newton .le. newtmx) go to 20 + print 653,newtmx + 653 format(33h no convergence in splopt after,i3,14h newton steps.) + 54 do 55 i=1,nmk + 55 t(k+i) = scrtch(i+nx) + 56 do 57 i=1,k + t(i) = tau(1) + 57 t(n+i) = tau(n) + return + 999 iflag = 2 + return + end diff --git a/math/deboor/splsqv.x b/math/deboor/splsqv.x new file mode 100644 index 00000000..1b4db248 --- /dev/null +++ b/math/deboor/splsqv.x @@ -0,0 +1,149 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include "bspln.h" +define ILLEGAL_ORDER 2 #error returns +define NO_DEG_FREEDOM 3 + + +.help splsqv 2 "IRAF Math Library" + +Adapted from L2APPR, * A Practical Guide To Splines * by C. DeBoor. +Eliminated data entry via the common /data/ (D.Tody, 4-july-82). Calls +subprograms BSPLVB, BCHFAC, BCHSLV. + +SPLSQV constructs the (weighted discrete) l2-approximation by splines of +order K with knot sequence T[1], ..., t[nt+k] to given data points +(TAU[i], GTAU[i]), i=1,...,ntau. The b-spline coefficients BCOEF of the +approximating spline are determined from the normal equations using +Cholesky'smethod. + +SPLSQV (tau, gtau, weight, ntau, t, nt, k, work, diag, bcoef, ier) + + +INPUT ----- + +ntau Number of data points +tau[ntau] x-value of the data points. +gtau[ntau] y-value of the data points. +weight[ntau] The corresponding weights. +t[nt] The knot sequence +nt The dimension of the space of splines of order k with knots t. +k The order of the b-spline to be fitted. + + +WORK ARRAYS ----- + +work[k,nt] A work array of size (at least) K*NT. its first K rows are used + for the K lower diagonals of the gramian matrix C. +diag[nt] A work array of length NT used in BCHFAC. + + +OUTPUT ----- + +bcoef[nt] The b-spline coefficients of the l2-approximation. +ier Error code: zero if ok, else small integer error code. + + +METHOD ----- + +The b-spline coefficients of the l2-appr. are determined as the solution +of the normal equations + + sum ((B[i],B[j]) * BCOEF[j] : j=1:nt) = (B[i],G), i = 1 to nt. + +where, B[i] denotes the i-th b-spline, G denotes the function to be +approximated, and the INNER PRODUCT of two functions F and G is given by + + (F,G) := sum (F(TAU[i]) * G(TAU[i]) * WEIGHT[i] : i=1:ntau). + +The relevant function values of the b-splines B[i], i=1:nt, are supplied +by the subprogram BSPLVB. The coeff. matrix C, with + + C(i,j) := (B[i], B[j]), i,j=1:n, + +of the normal equations is symmetric and (2*k-1)-banded, therefore can be +specified by giving its k bands at or below the diagonal. for i=1,...,n, +we store + + (B[i],B[j]) = B[i,j] in WORK[i-j+1,j], j=i,...,min0(i+k-1,nt) + +and the right side + + (B[i], G) in BCOEF[i]. + +since b-spline values are most efficiently generated by finding simultaneously +the value of EVERY nonzero b-spline at one point, the entries of C (i.e., of +WORK), are generated by computing, for each ll, all the terms involving +TAU(ll) simultaneously and adding them to all relevant entries. +.endhelp _______________________________________________________________ + + +procedure splsqv (tau, gtau, weight, ntau, t, nt, k, work, diag, bcoef, ier) + +real tau[ntau], gtau[ntau], weight[ntau] +real t[nt], work[k,nt], diag[nt], bcoef[nt] +int ntau, nt, k, ier +int i, j, jj, left, leftmk, ll, mm +real biatx[KMAX], dw + +begin + ier = 0 + if (k < 1 || k > KMAX) { + ier = ILLEGAL_ORDER + return + } + if (nt <= k || nt >= ntau+k) { + ier = NO_DEG_FREEDOM + return + } + + do j = 1, nt { + bcoef[j] = 0. + do i = 1, k + work[i,j] = 0. + } + + left = k + leftmk = 0 + + do ll = 1, ntau { + while (left != nt) { + if (tau[ll] < t[left+1]) + break + left = left + 1 + leftmk = leftmk + 1 + } + + call bsplvb (t, k, 1, tau[ll], left, biatx) + +# BIATX[mm] contains the value of B[left-k+mm] at TAU[ll]. +# hence, with DW := BIATX[mm] * WEIGHT[ll], the number DW * GTAU[ll] +# is a summand in the inner product +# (B[left-k+mm],G) which goes into BCOEF[left-k+mm] +# and the number BIATX[jj] * dw is a summand in the inner product +# (B[left-k+jj], B[left-k+mm]), into WORK[jj-mm+1,left-k+mm] +# since (left-k+jj) - (left-k+mm) + 1 = jj - mm + 1. + + do mm = 1, k { + dw = biatx[mm] * weight[ll] + j = leftmk + mm + bcoef[j] = dw * gtau[ll] + bcoef[j] + i = 1 + + do jj = mm, k { + work[i,j] = biatx[jj] * dw + work[i,j] + i = i + 1 + } + } + } + +# construct cholesky factorization for C in WORK, then use it to solve +# the normal equations +# c * x = bcoef +# for X, and store X in BCOEF. + + call bchfac (work, k, nt, diag) + call bchslv (work, k, nt, bcoef) + return +end diff --git a/math/deboor/subbak.f b/math/deboor/subbak.f new file mode 100644 index 00000000..7851c216 --- /dev/null +++ b/math/deboor/subbak.f @@ -0,0 +1,33 @@ + subroutine subbak ( w, ipivot, nrow, ncol, last, x ) +c carries out backsubstitution for current block. +c +c parameters +c w, ipivot, nrow, ncol, last are as on return from factrb. +c x(1),...,x(ncol) contains, on input, the right side for the +c equations in this block after backsubstitution has been +c carried up to but not including equation ipivot(last). +c means that x(j) contains the right side of equation ipi- +c vot(j) as modified during elimination, j=1,...,last, while +c for j .gt. last, x(j) is already a component of the solut- +c ion vector. +c x(1),...,x(ncol) contains, on output, the components of the solut- +c ion corresponding to the present block. +c + integer nrow, ncol + integer ipivot(nrow),last, ip,j,k,kp1 + real w(nrow,ncol),x(ncol), sum + k = last + ip = ipivot(k) + sum = 0. + if (k .eq. ncol) go to 4 + kp1 = k+1 + 2 do 3 j=kp1,ncol + 3 sum = w(ip,j)*x(j) + sum + 4 x(k) = (x(k) - sum)/w(ip,k) + if (k .eq. 1) return + kp1 = k + k = k-1 + ip = ipivot(k) + sum = 0. + go to 2 + end diff --git a/math/deboor/subfor.f b/math/deboor/subfor.f new file mode 100644 index 00000000..344aff0c --- /dev/null +++ b/math/deboor/subfor.f @@ -0,0 +1,45 @@ + subroutine subfor ( w, ipivot, nrow, last, b, x ) +c carries out the forward pass of substitution for the current block, +c i.e., the action on the right side corresponding to the elimination +c carried out in f a c t r b for this block. +c at the end, x(j) contains the right side of the transformed +c ipivot(j)-th equation in this block, j=1,...,nrow. then, since +c for i=1,...,nrow-last, b(nrow+i) is going to be used as the right +c side of equation i in the next block (shifted over there from +c this block during factorization), it is set equal to x(last+i) here. +c +c parameters +c w, ipivot, nrow, last are as on return from factrb. +c b(j) is expected to contain, on input, the right side of j-th +c equation for this block, j=1,...,nrow. +c b(nrow+j) contains, on output, the appropriately modified right +c side for equation j in next block, j=1,...,nrow-last. +c x(j) contains, on output, the appropriately modified right +c side of equation ipivot(j) in this block, j=1,...,last (and +c even for j=last+1,...,nrow). +c + integer nrow + integer ipivot(nrow), ip,jmax,k, j + integer last, nrowml, lastp1 +c dimension b(nrow + nrow-last) + real w(nrow,last),b(1),x(nrow),sum + ip = ipivot(1) + x(1) = b(ip) + if (nrow .eq. 1) go to 99 + do 15 k=2,nrow + ip = ipivot(k) + jmax = amin0(k-1,last) + sum = 0. + do 14 j=1,jmax + 14 sum = w(ip,j)*x(j) + sum + 15 x(k) = b(ip) - sum +c +c transfer modified right sides of equations ipivot(last+1),..., +c ipivot(nrow) to next block. + nrowml = nrow - last + if (nrowml .eq. 0) go to 99 + lastp1 = last+1 + do 25 k=lastp1,nrow + 25 b(nrowml+k) = x(k) + 99 return + end diff --git a/math/deboor/tautsp.f b/math/deboor/tautsp.f new file mode 100644 index 00000000..86e8eeb4 --- /dev/null +++ b/math/deboor/tautsp.f @@ -0,0 +1,313 @@ + subroutine tautsp ( tau, gtau, ntau, gamma, s, + * break, coef, l, k, iflag ) +c from * a practical guide to splines * by c. de boor +constructs cubic spline interpolant to given data +c tau(i), gtau(i), i=1,...,ntau. +c if gamma .gt. 0., additional knots are introduced where needed to +c make the interpolant more flexible locally. this avoids extraneous +c inflection points typical of cubic spline interpolation at knots to +c rapidly changing data. +c +c parameters +c input +c tau sequence of data points. must be strictly increasing. +c gtau corresponding sequence of function values. +c ntau number of data points. must be at least 4 . +c gamma indicates whether additional flexibility is desired. +c = 0., no additional knots +c in (0.,3.), under certain conditions on the given data at +c points i-1, i, i+1, and i+2, a knot is added in the +c i-th interval, i=2,...,ntau-2. see description of meth- +c od below. the interpolant gets rounded with increasing +c gamma. a value of 2.5 for gamma is typical. +c in (3.,6.), same , except that knots might also be added in +c intervals in which an inflection point would be permit- +c ted. a value of 5.5 for gamma is typical. +c output +c break, coef, l, k give the pp-representation of the interpolant. +c specifically, for break(i) .le. x .le. break(i+1), the +c interpolant has the form +c f(x) = coef(1,i) +dx(coef(2,i) +(dx/2)(coef(3,i) +(dx/3)coef(4,i))) +c with dx = x - break(i) and i=1,...,l . +c iflag = 1, ok +c = 2, input was incorrect. a printout specifying the mistake +c was made. +c workspace +c s is required, of size (ntau,6). the individual columns of this +c array contain the following quantities mentioned in the write- +c up and below. +c s(.,1) = dtau = tau(.+1) - tau +c s(.,2) = diag = diagonal in linear system +c s(.,3) = u = upper diagonal in linear system +c s(.,4) = r = right side for linear system (initially) +c = fsecnd = solution of linear system , namely the second +c derivatives of interpolant at tau +c s(.,5) = z = indicator of additional knots +c s(.,6) = 1/hsecnd(1,x) with x = z or = 1-z. see below. +c +c ------ m e t h o d ------ +c on the i-th interval, (tau(i), tau(i+1)), the interpolant is of the +c form +c (*) f(u(x)) = a + b*u + c*h(u,z) + d*h(1-u,1-z) , +c with u = u(x) = (x - tau(i))/dtau(i). here, +c z = z(i) = addg(i+1)/(addg(i) + addg(i+1)) +c (= .5, in case the denominator vanishes). with +c addg(j) = abs(ddg(j)), ddg(j) = dg(j+1) - dg(j), +c dg(j) = divdif(j) = (gtau(j+1) - gtau(j))/dtau(j) +c and +c h(u,z) = alpha*u**3 + (1 - alpha)*(max(((u-zeta)/(1-zeta)),0)**3 +c with +c alpha(z) = (1-gamma/3)/zeta +c zeta(z) = 1 - gamma*min((1 - z), 1/3) +c thus, for 1/3 .le. z .le. 2/3, f is just a cubic polynomial on +c the interval i. otherwise, it has one additional knot, at +c tau(i) + zeta*dtau(i) . +c as z approaches 1, h(.,z) has an increasingly sharp bend near 1, +c thus allowing f to turn rapidly near the additional knot. +c in terms of f(j) = gtau(j) and +c fsecnd(j) = 2.derivative of f at tau(j), +c the coefficients for (*) are given as +c a = f(i) - d +c b = (f(i+1) - f(i)) - (c - d) +c c = fsecnd(i+1)*dtau(i)**2/hsecnd(1,z) +c d = fsecnd(i)*dtau(i)**2/hsecnd(1,1-z) +c hence can be computed once fsecnd(i),i=1,...,ntau, is fixed. +c f is automatically continuous and has a continuous second derivat- +c ive (except when z = 0 or 1 for some i). we determine fscnd(.) from +c the requirement that also the first derivative of f be contin- +c uous. in addition, we require that the third derivative be continuous +c across tau(2) and across tau(ntau-1) . this leads to a strictly +c diagonally dominant tridiagonal linear system for the fsecnd(i) +c which we solve by gauss elimination without pivoting. +c + integer iflag,k,l,ntau, i,method,ntaum1 + real break(1),coef(4,1),gamma,gtau(ntau),s(ntau,6),tau(ntau) + * ,alpha,c,d,del,denom,divdif,entry,entry3,factor,factr2,gam + * ,onemg3,onemzt,ratio,sixth,temp,x,z,zeta,zt2 + real alph + alph(x) = amin1(1.,onemg3/x) +c +c there must be at least 4 interpolation points. + if (ntau .ge. 4) go to 5 +c print 600,ntau +c 600 format(8h ntau = ,i4,20h. should be .ge. 4 .) + go to 999 +c +construct delta tau and first and second (divided) differences of data +c + 5 ntaum1 = ntau - 1 + do 6 i=1,ntaum1 + s(i,1) = tau(i+1) - tau(i) + if (s(i,1) .gt. 0.) go to 6 +c print 610,i,tau(i),tau(i+1) +c 610 format(7h point ,i3,13h and the next,2e15.6,15h are disordered) + go to 999 + 6 s(i+1,4) = (gtau(i+1)-gtau(i))/s(i,1) + do 7 i=2,ntaum1 + 7 s(i,4) = s(i+1,4) - s(i,4) +c +construct system of equations for second derivatives at tau. at each +c interior data point, there is one continuity equation, at the first +c and the last interior data point there is an additional one for a +c total of ntau equations in ntau unknowns. +c + i = 2 + s(2,2) = s(1,1)/3. + sixth = 1./6. + method = 2 + gam = gamma + if (gam .le. 0.) method = 1 + if ( gam .le. 3.) go to 9 + method = 3 + gam = gam - 3. + 9 onemg3 = 1. - gam/3. +c ------ loop over i ------ + 10 continue +c construct z(i) and zeta(i) + z = .5 + go to (19,11,12),method + 11 if (s(i,4)*s(i+1,4) .lt. 0.) go to 19 + 12 temp = abs(s(i+1,4)) + denom = abs(s(i,4)) + temp + if (denom .eq. 0.) go to 19 + z = temp/denom + if (abs(z - .5) .le. sixth) z = .5 + 19 s(i,5) = z +c ******set up part of the i-th equation which depends on +c the i-th interval + if (z - .5) 21,22,23 + 21 zeta = gam*z + onemzt = 1. - zeta + zt2 = zeta**2 + alpha = alph(onemzt) + factor = zeta/(alpha*(zt2-1.) + 1.) + s(i,6) = zeta*factor/6. + s(i,2) = s(i,2) + s(i,1)*((1.-alpha*onemzt)*factor/2. - s(i,6)) +c if z = 0 and the previous z = 1, then d(i) = 0. since then +c also u(i-1) = l(i+1) = 0, its value does not matter. reset +c d(i) = 1 to insure nonzero pivot in elimination. + if (s(i,2) .le. 0.) s(i,2) = 1. + s(i,3) = s(i,1)/6. + go to 25 + 22 s(i,2) = s(i,2) + s(i,1)/3. + s(i,3) = s(i,1)/6. + go to 25 + 23 onemzt = gam*(1. - z) + zeta = 1. - onemzt + alpha = alph(zeta) + factor = onemzt/(1. - alpha*zeta*(1.+onemzt)) + s(i,6) = onemzt*factor/6. + s(i,2) = s(i,2) + s(i,1)/3. + s(i,3) = s(i,6)*s(i,1) + 25 if (i .gt. 2) go to 30 + s(1,5) = .5 +c ******the first two equations enforce continuity of the first and of +c the third derivative across tau(2). + s(1,2) = s(1,1)/6. + s(1,3) = s(2,2) + entry3 = s(2,3) + if (z - .5) 26,27,28 + 26 factr2 = zeta*(alpha*(zt2-1.) + 1.)/(alpha*(zeta*zt2-1.)+1.) + ratio = factr2*s(2,1)/s(1,2) + s(2,2) = factr2*s(2,1) + s(1,1) + s(2,3) = -factr2*s(1,1) + go to 29 + 27 ratio = s(2,1)/s(1,2) + s(2,2) = s(2,1) + s(1,1) + s(2,3) = -s(1,1) + go to 29 + 28 ratio = s(2,1)/s(1,2) + s(2,2) = s(2,1) + s(1,1) + s(2,3) = -s(1,1)*6.*alpha*s(2,6) +c at this point, the first two equations read +c diag(1)*x1 + u(1)*x2 + entry3*x3 = r(2) +c -ratio*diag(1)*x1 + diag(2)*x2 + u(2)*x3 = 0. +c eliminate first unknown from second equation + 29 s(2,2) = ratio*s(1,3) + s(2,2) + s(2,3) = ratio*entry3 + s(2,3) + s(1,4) = s(2,4) + s(2,4) = ratio*s(1,4) + go to 35 + 30 continue +c ******the i-th equation enforces continuity of the first derivative +c across tau(i). it has been set up in statements 35 up to 40 +c and 21 up to 25 and reads now +c -ratio*diag(i-1)*xi-1 + diag(i)*xi + u(i)*xi+1 = r(i) . +c eliminate (i-1)st unknown from this equation + s(i,2) = ratio*s(i-1,3) + s(i,2) + s(i,4) = ratio*s(i-1,4) + s(i,4) +c +c ******set up the part of the next equation which depends on the +c i-th interval. + 35 if (z - .5) 36,37,38 + 36 ratio = -s(i,6)*s(i,1)/s(i,2) + s(i+1,2) = s(i,1)/3. + go to 40 + 37 ratio = -(s(i,1)/6.)/s(i,2) + s(i+1,2) = s(i,1)/3. + go to 40 + 38 ratio = -(s(i,1)/6.)/s(i,2) + s(i+1,2) = s(i,1)*((1.-zeta*alpha)*factor/2. - s(i,6)) +c ------ end of i loop ------ + 40 i = i+1 + if (i .lt. ntaum1) go to 10 + s(i,5) = .5 +c +c ------ last two equations ------ +c the last two equations enforce continuity of third derivative and +c of first derivative across tau(ntau-1). + entry = ratio*s(i-1,3) + s(i,2) + s(i,1)/3. + s(i+1,2) = s(i,1)/6. + s(i+1,4) = ratio*s(i-1,4) + s(i,4) + if (z - .5) 41,42,43 + 41 ratio = s(i,1)*6.*s(i-1,6)*alpha/s(i-1,2) + s(i,2) = ratio*s(i-1,3) + s(i,1) + s(i-1,1) + s(i,3) = -s(i-1,1) + go to 45 + 42 ratio = s(i,1)/s(i-1,2) + s(i,2) = ratio*s(i-1,3) + s(i,1) + s(i-1,1) + s(i,3) = -s(i-1,1) + go to 45 + 43 factr2 = onemzt*(alpha*(onemzt**2-1.)+1.)/ + * (alpha*(onemzt**3-1.)+1.) + ratio = factr2*s(i,1)/s(i-1,2) + s(i,2) = ratio*s(i-1,3) + factr2*s(i-1,1) + s(i,1) + s(i,3) = -factr2*s(i-1,1) +c at this point, the last two equations read +c diag(i)*xi + u(i)*xi+1 = r(i) +c -ratio*diag(i)*xi + diag(i+1)*xi+1 = r(i+1) +c eliminate xi from last equation + 45 s(i,4) = ratio*s(i-1,4) + ratio = -entry/s(i,2) + s(i+1,2) = ratio*s(i,3) + s(i+1,2) + s(i+1,4) = ratio*s(i,4) + s(i+1,4) +c +c ------ back substitution ------ +c + s(ntau,4) = s(ntau,4)/s(ntau,2) + 50 s(i,4) = (s(i,4) - s(i,3)*s(i+1,4))/s(i,2) + i = i - 1 + if (i .gt. 1) go to 50 + s(1,4) = (s(1,4)-s(1,3)*s(2,4)-entry3*s(3,4))/s(1,2) +c +c ------ construct polynomial pieces ------ +c + break(1) = tau(1) + l = 1 + do 70 i=1,ntaum1 + coef(1,l) = gtau(i) + coef(3,l) = s(i,4) + divdif = (gtau(i+1)-gtau(i))/s(i,1) + z = s(i,5) + if (z - .5) 61,62,63 + 61 if (z .eq. 0.) go to 65 + zeta = gam*z + onemzt = 1. - zeta + c = s(i+1,4)/6. + d = s(i,4)*s(i,6) + l = l + 1 + del = zeta*s(i,1) + break(l) = tau(i) + del + zt2 = zeta**2 + alpha = alph(onemzt) + factor = onemzt**2*alpha + coef(1,l) = gtau(i) + divdif*del + * + s(i,1)**2*(d*onemzt*(factor-1.)+c*zeta*(zt2-1.)) + coef(2,l) = divdif + s(i,1)*(d*(1.-3.*factor)+c*(3.*zt2-1.)) + coef(3,l) = 6.*(d*alpha*onemzt + c*zeta) + coef(4,l) = 6.*(c - d*alpha)/s(i,1) + coef(4,l-1) = coef(4,l) - 6.*d*(1.-alpha)/(del*zt2) + coef(2,l-1) = coef(2,l) - del*(coef(3,l) -(del/2.)*coef(4,l-1)) + go to 68 + 62 coef(2,l) = divdif - s(i,1)*(2.*s(i,4) + s(i+1,4))/6. + coef(4,l) = (s(i+1,4)-s(i,4))/s(i,1) + go to 68 + 63 onemzt = gam*(1. - z) + if (onemzt .eq. 0.) go to 65 + zeta = 1. - onemzt + alpha = alph(zeta) + c = s(i+1,4)*s(i,6) + d = s(i,4)/6. + del = zeta*s(i,1) + break(l+1) = tau(i) + del + coef(2,l) = divdif - s(i,1)*(2.*d + c) + coef(4,l) = 6.*(c*alpha - d)/s(i,1) + l = l + 1 + coef(4,l) = coef(4,l-1) + 6.*(1.-alpha)*c/(s(i,1)*onemzt**3) + coef(3,l) = coef(3,l-1) + del*coef(4,l-1) + coef(2,l) = coef(2,l-1)+del*(coef(3,l-1)+(del/2.)*coef(4,l-1)) + coef(1,l) = coef(1,l-1)+del*(coef(2,l-1)+(del/2.)*(coef(3,l-1) + * +(del/3.)*coef(4,l-1))) + go to 68 + 65 coef(2,l) = divdif + coef(3,l) = 0. + coef(4,l) = 0. + 68 l = l + 1 + 70 break(l) = tau(i+1) + l = l - 1 + k = 4 + iflag = 1 + return + 999 iflag = 2 + return + end diff --git a/math/deboor/titand.f b/math/deboor/titand.f new file mode 100644 index 00000000..3b323923 --- /dev/null +++ b/math/deboor/titand.f @@ -0,0 +1,18 @@ + subroutine titand ( tau, gtau, n ) +c from * a practical guide to splines * by c. de boor +c these data represent a property of titanium as a function of +c temperature. they have been used extensively as an example in spline +c approximation with variable knots. + integer n, i + real gtau(49),tau(49),gtitan(49) + data gtitan /.644,.622,.638,.649,.652,.639,.646,.657,.652,.655, + 2 .644,.663,.663,.668,.676,.676,.686,.679,.678,.683, + 3 .694,.699,.710,.730,.763,.812,.907,1.044,1.336,1.881, + 4 2.169,2.075,1.598,1.211,.916,.746,.672,.627,.615,.607 + 5 ,.606,.609,.603,.601,.603,.601,.611,.601,.608/ + n = 49 + do 10 i=1,n + tau(i) = 585. + 10.*float(i) + 10 gtau(i) = gtitan(i) + return + end diff --git a/math/gsurfit/README b/math/gsurfit/README new file mode 100644 index 00000000..4ab4a0f3 --- /dev/null +++ b/math/gsurfit/README @@ -0,0 +1,6 @@ +Linear least squares surface fitting package. +Contains routines to fit Legendre and Chebyshev polynomials +in the least squares sense to 2-dimensional data. +The normal equations are accumulated and solved using Cholesky factorization. +The package contains separate entry points for accumulating points, +solving the matrix equations, rejecting points and evaluating the surface. diff --git a/math/gsurfit/dgsurfitdef.h b/math/gsurfit/dgsurfitdef.h new file mode 100644 index 00000000..5888cb81 --- /dev/null +++ b/math/gsurfit/dgsurfitdef.h @@ -0,0 +1,61 @@ +# Header file for the surface fitting package + +# set up the curve descriptor structure + +define LEN_GSSTRUCT 64 + +define GS_XREF Memd[P2D($1)] # x reference value +define GS_YREF Memd[P2D($1+2)] # y reference value +define GS_ZREF Memd[P2D($1+4)] # z reference value +define GS_XMAX Memd[P2D($1+6)] # Maximum x value +define GS_XMIN Memd[P2D($1+8)] # Minimum x value +define GS_YMAX Memd[P2D($1+10)]# Maximum y value +define GS_YMIN Memd[P2D($1+12)]# Minimum y value +define GS_XRANGE Memd[P2D($1+14)]# 2. / (xmax - xmin), polynomials +define GS_XMAXMIN Memd[P2D($1+16)]# - (xmax + xmin) / 2., polynomials +define GS_YRANGE Memd[P2D($1+18)]# 2. / (ymax - ymin), polynomials +define GS_YMAXMIN Memd[P2D($1+20)]# - (ymax + ymin) / 2., polynomials +define GS_TYPE Memi[$1+22] # Type of curve to be fitted +define GS_XORDER Memi[$1+23] # Order of the fit in x +define GS_YORDER Memi[$1+24] # Order of the fit in y +define GS_XTERMS Memi[$1+25] # Cross terms for polynomials +define GS_NXCOEFF Memi[$1+26] # Number of x coefficients +define GS_NYCOEFF Memi[$1+27] # Number of y coefficients +define GS_NCOEFF Memi[$1+28] # Total number of coefficients +define GS_NPTS Memi[$1+29] # Number of data points + +define GS_MATRIX Memi[$1+30] # Pointer to original matrix +define GS_CHOFAC Memi[$1+31] # Pointer to Cholesky factorization +define GS_VECTOR Memi[$1+32] # Pointer to vector +define GS_COEFF Memi[$1+33] # Pointer to coefficient vector +define GS_XBASIS Memi[$1+34] # Pointer to basis functions (all x) +define GS_YBASIS Memi[$1+35] # Pointer to basis functions (all y) +define GS_WZ Memi[$1+36] # Pointer to w * z (gsrefit) + +# matrix and vector element definitions + +define XBASIS Memd[$1] # Non zero basis for all x +define YBASIS Memd[$1] # Non zero basis for all y +define XBS Memd[$1] # Non zero basis for single x +define YBS Memd[$1] # Non zero basis for single y +define MATRIX Memd[$1] # Element of MATRIX +define CHOFAC Memd[$1] # Element of CHOFAC +define VECTOR Memd[$1] # Element of VECTOR +define COEFF Memd[$1] # Element of COEFF + +# structure definitions for restore + +define GS_SAVETYPE $1[1] +define GS_SAVEXORDER $1[2] +define GS_SAVEYORDER $1[3] +define GS_SAVEXTERMS $1[4] +define GS_SAVEXMIN $1[5] +define GS_SAVEXMAX $1[6] +define GS_SAVEYMIN $1[7] +define GS_SAVEYMAX $1[8] + +# data type + +define DELTA EPSILON + +# miscellaneous diff --git a/math/gsurfit/doc/gsaccum.hlp b/math/gsurfit/doc/gsaccum.hlp new file mode 100644 index 00000000..afa63f70 --- /dev/null +++ b/math/gsurfit/doc/gsaccum.hlp @@ -0,0 +1,51 @@ +.help gsaccum Aug85 "Gsurfit Package" +.ih +NAME +gsaccum -- accumulate a single data point into the fit +.ih +SYNOPSIS +include + +gsaccum (sf, x, y, weight, wtflag) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +real z # z value +real weight # weight +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +The x and y values. +.le +.ls z +Data value. +.le +.ls weight +The weight assigned to the data point. +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag +equals WTS_USER the weight for each data point is supplied by the user. +If wtflag equals WTS_UNIFORM the routine sets the weight to 1. +.le +.ih +DESCRIPTION +GSACCUM calculates the non-zero basis functions for the given x and +y values, computes the contribution of each data point to the normal +equations and sums that contribution into the appropriate arrays and +vectors. +.ih +NOTES +Checking for out of bounds x and y values and INDEF valued data points is +the responsibility of the calling program. +.ih +SEE ALSO +gsacpts, gsfit, gsrefit +.endhelp diff --git a/math/gsurfit/doc/gsacpts.hlp b/math/gsurfit/doc/gsacpts.hlp new file mode 100644 index 00000000..1e253c61 --- /dev/null +++ b/math/gsurfit/doc/gsacpts.hlp @@ -0,0 +1,56 @@ +.help gsacpts Aug85 "Gsurfit Package" +.ih +NAME +gsacpts -- accumulate an array of data points into the fit +.ih +SYNOPSIS +include + +gsacpts (sf, x, y, z, weight, npts, wtflag) + +.nf +pointer sf # surface descriptor +real x[npts] # x values, xmin <= x <= xmax +real y[npts] # y values, ymin <= y <= ymax +real z[npts] # z values +real weight[npts] # array of weights +int npts # the number of data points +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls z +Array of data values. +.le +.ls weight +The weights assigned to the data points. +.le +.ls npts +The number of data points. +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag +equals WTS_USER the weight for each data point is supplied by the user. +If wtflag equals WTS_UNIFORM the routine sets the weight to 1. +The weight definitions are contained in the package header file gsurfit.h. +.le +.ih +DESCRIPTION +GSACCUM calculates the non-zero basis functions for the given x and +y values, computes the contribution of each data point to the normal +equations and sums that contribution into the appropriate arrays and +vectors. +.ih +NOTES +Checking for out of bounds x and y values and INDEF valued data points is +the responsibility of the calling program. +.ih +SEE ALSO +gsaccum, gsfit, gsrefit +.endhelp diff --git a/math/gsurfit/doc/gsadd.hlp b/math/gsurfit/doc/gsadd.hlp new file mode 100644 index 00000000..84d388fd --- /dev/null +++ b/math/gsurfit/doc/gsadd.hlp @@ -0,0 +1,35 @@ +.help gsadd Aug85 "Gsurfit Package" +.ih +NAME +gsadd -- add two surface fits together +.ih +SYNOPSIS +gsadd (sf1, sf2, sf3) + +.nf +pointer sf1 # first surface descriptor +pointer sf2 # second surface descriptor +pointer sf3 # resultant surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the first surface descriptor. +.le +.ls sf2 +Pointer to the second surface descriptor. +.le +.ls sf3 +Pointer to the resultant surface descriptor. +.le +.ih +DESCRIPTION +The coefficients of the two surfaces are added together. GSADD checks +that the curve_types are the same and that the fits are normalized over +the same range of data. +.ih +NOTES +.ih +SEE ALSO +gscopy, gssub +.endhelp diff --git a/math/gsurfit/doc/gscoeff.hlp b/math/gsurfit/doc/gscoeff.hlp new file mode 100644 index 00000000..e4b792db --- /dev/null +++ b/math/gsurfit/doc/gscoeff.hlp @@ -0,0 +1,39 @@ +.help gscoeff Aug85 "Gsurfit Package" +.ih +NAME +gscoeff - get the number and values of the coefficients +.ih +SYNOPSIS +gscoeff (sf, coeff, ncoeff) + +.nf +pointer sf # surface descriptor +real coeff[ncoeff] # coefficient array +int ncoeff # number of coefficients +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls coeff +Array of coefficients. +.le +.ls ncoeff +The number of coefficients. Ncoeff may be obtained by a call +to gsstati. +.le + +.nf + ncoeff = gsstati (sf, GSNCOEFF) +.fi +.ih +DESCRIPTION +GSCOEFF fetches the coefficient array and the number of coefficients from +the surface descriptor structure. +.ih +NOTES +.ih +SEE ALSO +gserrors +.endhelp diff --git a/math/gsurfit/doc/gscopy.hlp b/math/gsurfit/doc/gscopy.hlp new file mode 100644 index 00000000..46a0935f --- /dev/null +++ b/math/gsurfit/doc/gscopy.hlp @@ -0,0 +1,32 @@ +.help gscopy Aug85 "Gsurfit Package" +.ih +NAME +gscopy -- copy a surface fit +.ih +SYNOPSIS +gscopy (sf1, sf2) + +.nf +pointer sf1 # old surface descriptor +pointer sf2 # new surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the old surface descriptor structure. +.le +.ls sf2 +Pointer to the new surface descriptor structure. +.le +.ih +DESCRIPTION +The surface fit and parameters are copied for later use by +GSEVAL or GSVECTOR. +.ih +NOTES +The matrices and vectors used by the numerical fitting routines are not +stored. +.ih +SEE ALSO +gsadd, gssub +.endhelp diff --git a/math/gsurfit/doc/gsder.hlp b/math/gsurfit/doc/gsder.hlp new file mode 100644 index 00000000..e1af66e9 --- /dev/null +++ b/math/gsurfit/doc/gsder.hlp @@ -0,0 +1,48 @@ +.help gsder Aug85 "Gsurfit Package" +.ih +NAME +gsder -- evaluate the derivatives of the fitted surface +.ih +SYNOPSIS +gsder (sf, x, y, zfit, npts, nxder, nyder) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x[i] <= xmax +real y[npts] # y array, ymin <= x[i] <= ymax +real zfit[npts] # data values +int npts # number of data points +int nxder # order of x derivative, 0 = function +int nyder # order of y derivative, 0 = function +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls zfit +Array of fitted values. +.le +.ls npts +The number of points to be fit. +.le +.ls nxder, nyder +The order of derivative to be fit. GSDER is the same as GSVECTOR if nxder = 0 +and nyder = 0. If nxder = 1 and nyder = 0 GSDER calculates the first +derivatives of the surface with respect to x. +.le +.ih +DESCRIPTION +Evaluate the derivatives of a surface at a set of data points. +GSDER uses the coefficients stored in the surface descriptor structure. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the +calling program. +.ih +SEE ALSO +gseval, gsvector +.endhelp diff --git a/math/gsurfit/doc/gserrors.hlp b/math/gsurfit/doc/gserrors.hlp new file mode 100644 index 00000000..fed9a82e --- /dev/null +++ b/math/gsurfit/doc/gserrors.hlp @@ -0,0 +1,61 @@ +.help gserrors Aug85 "Gsurfit Package" +.ih +NAME +.nf +gserrors -- calculate errors of the coefficients and the chi-square + of the fit +.fi +.ih +SYNOPSIS +gserrors (sf, y, weight, yfit, chi_square, errors) + +.nf +pointer sf # surface descriptor +real y[ARB] # array of data values +real weight[ARB] # array of weights +real yfit[ARB] # array of fitted values +real chi_square # chi_square of fit +real errors[ARB] # array of errors +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls y +Array of data values. +.le +.ls weight +Array of weights. +.le +.ls yfit +Array of fitted values. +.le +.ls chi_square +The reduced chi-square of the fit. +.le +.ls errors +The array of errors of the coefficients. The number of coefficients +can be obtained by a call to gsstati. +.le + +.nf + nerrors = gsstati (sf, GSNCOEFF) +.fi +.ih +DESCRIPTION +GSCOEFF calculates the reduced chi-square of the fit and the standard +deviation of the coefficients. +The chi-square of the fit is the square root of the sum of the +weighted squares of the residuals divided by the number of degrees +of freedom. If the weights are equal, then the reduced chi-square is +the variance of the fit. The error of the j-th coefficient is the +square root of the j-th diagonal element of the inverse of the data +matrix. If the weights are equal to one, then the errors are scaled +by the square root of the variance of the data. +.ih +NOTES +.ih +SEE ALSO +gscoeff +.endhelp diff --git a/math/gsurfit/doc/gseval.hlp b/math/gsurfit/doc/gseval.hlp new file mode 100644 index 00000000..b9cd08bb --- /dev/null +++ b/math/gsurfit/doc/gseval.hlp @@ -0,0 +1,34 @@ +.help gseval Aug85 "Gsurfit Package" +.ih +NAME +gseval -- evaluate the fitted surface at x and y +.ih +SYNOPSIS +y = gseval (sf, x, y) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y values at which the surface is to be evaluated. +.le +.ih +DESCRIPTION +Evaluate the surface at the specified value of x and y. GSEVAL is a real +valued function which returns the fitted value. +.ih +NOTES +GSEVAL uses the coefficient array stored in the surface descriptor structure. +Checking for out of bounds x and y values is the responsibility of the calling +program. +.ih +SEE ALSO +gsvector, gsder +.endhelp diff --git a/math/gsurfit/doc/gsfit.hlp b/math/gsurfit/doc/gsfit.hlp new file mode 100644 index 00000000..4abdc546 --- /dev/null +++ b/math/gsurfit/doc/gsfit.hlp @@ -0,0 +1,64 @@ +.help gsfit Aug85 "Gsurfit Package" +.ih +NAME +gsfit -- fit a surface to a set of data values +.ih +SYNOPSIS +include + +gsfit (sf, x, y, z, weight, npts, wtflag, ier) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x[i] <= xmax +real y[npts] # y array, ymin <= y[i] <= ymax +real z[npts] # data values +real weight[npts] # weight array +int npts # number of data points +int wtflag # type of weighting +int ier # error coded +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y value arrays. +.le +.ls z +Array of data values. +.le +.ls weight +Array of weights. +.le +.ls npts +Number of data points +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag = +WTS_USER individual weights for each data point are supplied by the calling +program and points with zero-valued weights are not included in the fit. +If wtflag = WTS_UNIFORM, all weights are assigned values of 1. +.le +.ls ier +Error code for the fit. The options are OK, SINGULAR and NO_DEG_FREEDOM. +If ier = SINGULAR, the numerical routines will compute a solution but one +or more of the coefficients will be zero. If ier = NO_DEG_FREEDOM there +were too few data points to solve the matrix equations and the routine +returns without fitting the data. +.le +.ih +DESCRIPTION +GSFIT zeroes the matrix and vectors, calculates the non-zero basis functions, +computes the contribution of each data point to the normal equations +and accumulates it into the appropriate array and vector elements. The +Cholesky factorization of the coefficient array is computed and the coefficients +of the fitting function are calculated. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the user. +.ih +SEE ALSO +gsrefit, gsaccum, gsacpts, gssolve, gszero +.endhelp diff --git a/math/gsurfit/doc/gsfree.hlp b/math/gsurfit/doc/gsfree.hlp new file mode 100644 index 00000000..a576b2e1 --- /dev/null +++ b/math/gsurfit/doc/gsfree.hlp @@ -0,0 +1,26 @@ +.help gsfree Aug85 "Gsurfit Package" +.ih +NAME +gsfree -- free the surface descriptor structure +.ih +SYNOPSIS +gsfree (sf) + +.nf +pointer sf # surface descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ih +DESCRIPTION +Frees the surface descriptor structure. +.ih +NOTES +GSFREE should be called after each surface fit. +.ih +SEE ALSO +gsinit +.endhelp diff --git a/math/gsurfit/doc/gsgcoeff.hlp b/math/gsurfit/doc/gsgcoeff.hlp new file mode 100644 index 00000000..78fdc707 --- /dev/null +++ b/math/gsurfit/doc/gsgcoeff.hlp @@ -0,0 +1,31 @@ +.help gsgcoeff Aug85 "Gsurfit Package" +.ih +NAME +gsgcoeff -- Procedure to fetch a coefficient +.ih +SYNOPSIS +rval = gsgcoeff (sf, xorder, yorder) + +.nf + pointer sf # surface descriptor + int xorder # x order of desired coefficient + int yorder # y order of desired coefficient +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls xorder, yorder +The x and y order of the desired coefficient. +.le +.ih +DESCRIPTION +GSGCOEFF fetches the coefficient of x ** (xorder - 1) * y ** (yorder - 1). +INDEF is returned if xorder and yorder are out of range. +.ih +NOTES +.ih +SEE ALSO +gsscoeff +.endhelp diff --git a/math/gsurfit/doc/gsinit.hlp b/math/gsurfit/doc/gsinit.hlp new file mode 100644 index 00000000..3a647a8c --- /dev/null +++ b/math/gsurfit/doc/gsinit.hlp @@ -0,0 +1,64 @@ +.help gsinit Aug85 "Gsurfit Package" +.ih +NAME +gsinit -- initialize surface descriptor +.ih +SYNOPSIS +include + +.nf +gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +.fi + +.nf +pointer sf # surface descriptor +int surface_type # surface function +int xorder # order of function in x +int yorder # order of function in y +int xterms # include cross-terms? (YES/NO) +real xmin # minimum x value +real xmax # maximum x value +real ymin # minimum y value +real ymax # maximum y value +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls surface_type +Fitting function. Permitted values are GS_LEGENDRE and GS_CHEBYSHEV for +Legendre and Chebyshev polynomials. +.le +.ls xorder, yorder +Order of the polynomial to be fit. The order must be greater than or +equal to 1. If xorder == 1 and yorder == 1 a constant is fit to the data. +.le +.ls xterms +Set the cross-terms type? The options are GS_XNONE (the old NO option) for +no cross terms, GS_XHALF for diagonal cross terms (new option), and GS_XFULL +for full cross terms (the old YES option). +.le +.ls xmin, xmax +Minimum and maximum x values. All the x values of interest including the +data x values and the x values of any surface to be evaluated must +fall in the range xmin <= x <= xmax. +.le +.ls ymin, ymax +Minimum and maximum y values. All the y values of interest including the +data y values and the y values of any surface to be evaluated must +fall in the range ymin <= y <= ymax. +.le +.ih +DESCRIPTION +GSINIT allocates space for the surface descriptor and the arrays and vectors +used by the numerical routines. It initializes all arrays and vectors to zero +and returns the surface descriptor to the calling routine. +.ih +NOTES +GSINIT must be the first GSURFIT routine called. +.ih +SEE ALSO +gsfree +.endhelp diff --git a/math/gsurfit/doc/gsrefit.hlp b/math/gsurfit/doc/gsrefit.hlp new file mode 100644 index 00000000..629697e8 --- /dev/null +++ b/math/gsurfit/doc/gsrefit.hlp @@ -0,0 +1,55 @@ +.help gsrefit Aug85 "Gsurfit Package" +.ih +NAME +gsrefit -- refit with new z vector using old x, y and weight vector +.ih +SYNOPSIS +include < math/gsurfit.h> + +gsrefit (sf, x, y, z, w, ier) + +.nf +pointer sf # surface descriptor +real x[ARB] # x array, xmin <= x[i] <= xmax +real y[ARB] # y array, ymin <= y[i] <= ymax +real z[ARB] # array of data values +real w[ARB] # array of weights +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls z +Array of data values. +.le +.ls w +Array of weights. +.le +.ls ier +Error code. The options are OK, SINGULAR and NO_DEG_FREEDOM. If ier = +SINGULAR a solution is computed but one or more coefficients may be zero. +If ier equals NO_DEG_FREEDOM, there are insufficient data points to +compute a solution and GSREFIT returns without solving for the coefficients. +.le +.ih +DESCRIPTION +In some applications the x, y and weight values remain unchanged from fit +to fit and only the z values vary. In this case it is redundant to +reaccumulate the matrix and perform the Cholesky factorization. GSREFIT +zeros and reaccumulates the vector on the right hand side of the matrix +equation and performs the forward and back substitution phase to fit for +a new coefficient vector. +.ih +NOTES +In the first call to GSREFIT space is allocated for the non-zero basis +functions. Subsequent calls to GSREFIT reference this array to avoid +recalculating basis functions at every call. +.ih +SEE ALSO +gsfit, gsaccum, gsacpts, gssolve +.endhelp diff --git a/math/gsurfit/doc/gsreject.hlp b/math/gsurfit/doc/gsreject.hlp new file mode 100644 index 00000000..96344ac2 --- /dev/null +++ b/math/gsurfit/doc/gsreject.hlp @@ -0,0 +1,44 @@ +.help gsreject Aug85 "Gsurfit Package" +.ih +NAME +gsreject -- reject a data point from the fit +.ih +SYNOPSIS +gsreject (sf, x, y, z, weight) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +real z # data value +real weight # weight +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y values. +.le +.ls z +Data value. +.le +.ls weight +Weight value. +.le +.ih +DESCRIPTION +GSREJECT removes a data point from the fit. The non-zero basis functions for +each x and y are calculated, and the contribution of the point to the normal +equations is computed and subtracted from the appropriate arrays and vectors. +An array of points can be removed from the fit by repeated calls to GSREJECT +followed by a single call to GSSOLVE to calculate a new set of coefficients. +.ih +NOTES +Out of bounds x and y values and INDEF valued data values are the responsibility +of the calling program. +.ih +SEE ALSO +gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/doc/gsrestore.hlp b/math/gsurfit/doc/gsrestore.hlp new file mode 100644 index 00000000..f71aab56 --- /dev/null +++ b/math/gsurfit/doc/gsrestore.hlp @@ -0,0 +1,36 @@ +.help gsrestore Aug85 "Gsurfit Package" +.ih +NAME +gsrestore -- restore fit parameters +.ih +SYNOPSIS +gsrestore (sf, fit) + +.nf +pointer sf # surface descriptor +real fit[ARB] # fit array +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. Returned by GSRESTORE. +.le +.ls fit +Array containing the surface parameters. The size of the fit array +can be determined by a call gsstati. + +.nf + len_fit = gsstati (gs, GSNSAVE) +.fi +.le +.ih +DESCRIPTION +GSRESTORE returns the surface descriptor to the calling program and +restores the surface parameters and fit ready for use by GSEVAL or +GSVECTOR. +.ih +NOTES +.ih +SEE ALSO +gssave +.endhelp diff --git a/math/gsurfit/doc/gssave.hlp b/math/gsurfit/doc/gssave.hlp new file mode 100644 index 00000000..a6faf568 --- /dev/null +++ b/math/gsurfit/doc/gssave.hlp @@ -0,0 +1,39 @@ +.help gssave Aug85 "Gsurfit Package" +.ih +NAME +gssave -- save parameters of the fit +.ih +SYNOPSIS +call gssave (sf, fit) + +.nf +pointer sf # surface descriptor +real fit[ARB] # fit array +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls fit +Array containing fit parameters. The size of the fit array can be determined +by a call to gsstati. +.le + +.nf + len_fit = gsstati (sf, GSNSAVE) +.fi +.ih +DESCRIPTION +GSSAVE saves the surface parameters in the real array fit. The first eight +elements of fit contain the surface_type, xorder, yorder, xterms, xmin, +xmax, ymin and ymax. The coefficients are stored in the remaining array +elements. +.ih +NOTES +GSSAVE does not preserve the matrices and vectors used by the fitting +routines. +.ih +SEE ALSO +gsrestore +.endhelp diff --git a/math/gsurfit/doc/gsscoeff.hlp b/math/gsurfit/doc/gsscoeff.hlp new file mode 100644 index 00000000..5f5e4a6a --- /dev/null +++ b/math/gsurfit/doc/gsscoeff.hlp @@ -0,0 +1,35 @@ +.help gsscoeff Aug85 "Gsurfit Package" +.ih +NAME +gsscoeff -- Procedure to set a coefficient +.ih +SYNOPSIS +gsscoeff (sf, xorder, yorder, coeff) + +.nf + pointer sf # surface descriptor + int xorder # x order of desired coefficient + int yorder # y order of desired coefficient + real coeff # coefficient value +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls xorder, yorder +The x and y order of the desired coefficient. +.le +.ls coeff +The value of the coefficient to be set. +.le +.ih +DESCRIPTION +GSSCOEFF sets the coefficient of x ** (xorder - 1) * y ** (yorder - 1). +GSSCOEFF returns if xorder and yorder are out of range. +.ih +NOTES +.ih +SEE ALSO +gsgcoeff +.endhelp diff --git a/math/gsurfit/doc/gssolve.hlp b/math/gsurfit/doc/gssolve.hlp new file mode 100644 index 00000000..8ddf42fc --- /dev/null +++ b/math/gsurfit/doc/gssolve.hlp @@ -0,0 +1,40 @@ +.help gssolve Aug85 "Gsurfit Package" +.ih +NAME +gssolve -- solve a linear system of equations by the Cholesky method +.ih +SYNOPSIS +include + +gssolve (sf, ier) + +.nf +pointer sf # surface descriptor +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls ier +Error code returned by the fitting routines. The options are OK, SINGULAR, +and NO_DEG_FREEDOM. If ier = SINGULAR the matrix is singular, GSSOLVE +will compute a solution to the normal equations but one or more of the +coefficients will be zero. If ier = NO_DEG_FREEDOM, too few data points +exist for a reasonable solution to be computed. GSSOLVE returns without +fitting the data. +.le +.ih +DESCRIPTION +GSSOLVE computes the Cholesky factorization of the data matrix and +solves for the coefficients +of the fitting function by forward and back substitution. An error code is +returned by GSSOLVE if it is unable to solve the normal equations as +formulated. +.ih +NOTES +.ih +SEE ALSO +gsfit, gsrefit, gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/doc/gsstati.hlp b/math/gsurfit/doc/gsstati.hlp new file mode 100644 index 00000000..7b1b7f2e --- /dev/null +++ b/math/gsurfit/doc/gsstati.hlp @@ -0,0 +1,35 @@ +.help gsstati Aug85 "Gsurfit Package" +.ih +NAME +include + +gsstati -- get integer parameter +.ih +SYNOPSIS +ival = gsstati (sf, parameter) + +.nf +pointer sf # surface descriptor +int parameter # integer parameter to be returned +.fi +.ih +ARGUMENTS +.ls sf +The pointer to the surface descriptor structure. +.le +.ls parameter +Parameter to be returned. The options are GSTYPE, GSXORDER, GSYORDER, +GSNXCOEFF, GSNYCOEFF, and GSNSAVE. The parameter definitions are +found in the package header file math/gsurfit.h. +.le +.ih +DESCRIPTION +The values of the integer parameters are returned. The parameters include +the surface_type, the x and y orders, the number of x and y coefficients +and the length of the buffer required by GSSAVE. +.ih +NOTES +.ih +SEE ALSO +gsstatr +.endhelp diff --git a/math/gsurfit/doc/gsstatr.hlp b/math/gsurfit/doc/gsstatr.hlp new file mode 100644 index 00000000..5a5578f2 --- /dev/null +++ b/math/gsurfit/doc/gsstatr.hlp @@ -0,0 +1,34 @@ +.help gsstatr Aug85 "Gsurfit Package" +.ih +NAME +gsstatr -- get real parameter +.ih +SYNOPSIS +include + +rval = gsstatr (sf, parameter) + +.nf +pointer sf # surface descriptor +real parameter # real parameter to be returned +.fi +.ih +ARGUMENTS +.ls sf +The pointer to the surface descriptor structure. +.le +.ls parameter +Parameter to be returned. The options are GSXMIN, GSXMAX, GSYMIN and +and GSYMAX. The parameter definitions are +found in the package header file math/gsurfit.h. +.le +.ih +DESCRIPTION +The values of the integer parameters are returned. The parameters include +the minimum and maximum x values and the minimum and maximum y values. +.ih +NOTES +.ih +SEE ALSO +gsstati +.endhelp diff --git a/math/gsurfit/doc/gssub.hlp b/math/gsurfit/doc/gssub.hlp new file mode 100644 index 00000000..2c771612 --- /dev/null +++ b/math/gsurfit/doc/gssub.hlp @@ -0,0 +1,35 @@ +.help gssub Aug85 "Gsurfit Package" +.ih +NAME +gssub -- subtract surface 1 from surface 2 +.ih +SYNOPSIS +gssub (sf1, sf2, sf3) + +.nf +pointer sf1 # first surface descriptor +pointer sf2 # second surface descriptor +pointer sf3 # resultant surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the first surface descriptor. +.le +.ls sf2 +Pointer to the second surface descriptor. +.le +.ls sf3 +Pointer to the resultant surface descriptor. +.le +.ih +DESCRIPTION +The coefficients of surface 2 are subtracted from surface 1. GSSUB checks +that the surface_types are the same and that the fits are normalized over +the same range of data. +.ih +NOTES +.ih +SEE ALSO +gscopy, gsadd +.endhelp diff --git a/math/gsurfit/doc/gsurfit.hd b/math/gsurfit/doc/gsurfit.hd new file mode 100644 index 00000000..169961f7 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.hd @@ -0,0 +1,25 @@ +# Help directory for the GSURFIT (surface fitting) package. + +$gsurfit = "math$gsurfit/" + +gsaccum hlp = gsaccum.hlp, src = gsurfit$gsaccum.x +gsacpts hlp = gsacpts.hlp, src = gsurfit$gsacpts.x +gsadd hlp = gsadd.hlp, src = gsurfit$gsadd.x +gscoeff hlp = gscoeff.hlp, src = gsurfit$gscoeff.x +gscopy hlp = gscopy.hlp, src = gsurfit$gscopy.x +gsder hlp = gsder.hlp, src = gsurfit$gsder.x +gserrors hlp = gserrors.hlp, src = gsurfit$gserrors.x +gseval hlp = gseval.hlp, src = gsurfit$gseval.x +gsinit hlp = gsinit.hlp, src = gsurfit$gsinit.x +gsfit hlp = gsfit.hlp, src = gsurfit$gsfit.x +gsfree hlp = gsfree.hlp, src = gsurfit$gsfree.x +gsrefit hlp = gsrefit.hlp, src = gsurfit$gsrefit.x +gsreject hlp = gsreject.hlp, src = gsurfit$gsreject.x +gsrestore hlp = gsrestore.hlp, src = gsurfit$gsrestore.x +gssave hlp = gssave.hlp, src = gsurfit$gssave.x +gssolve hlp = gssolve.hlp, src = gsurfit$gssolve.x +gsstati hlp = gsstati.hlp, src = gsurfit$gsstat.x +gsstatr hlp = gsstatr.hlp, src = gsurfit$gsstat.x +gssub hlp = gssub.hlp, src = gsurfit$gssub.x +gsvector hlp = gsvector.hlp, src = gsurfit$gsvector.x +gszero hlp = gszero.hlp, src = gsurfit$gszero.x diff --git a/math/gsurfit/doc/gsurfit.hlp b/math/gsurfit/doc/gsurfit.hlp new file mode 100644 index 00000000..99f42444 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.hlp @@ -0,0 +1,169 @@ +.help gsurfit Aug85 "Math Package" +.ih +NAME +gsurfit -- surface fitting package +.ih +SYNOPSIS + +.nf + gsinit (sf, surf_type, xorder, yorder, xterms, xmin, xmax, ymin, ymax) + gsaccum (sf, x, y, z, w, wtflag) + gsacpts (sf, x, y, z, w, npts, wtflag) + gsreject (sf, x, y, z, w) + gssolve (sf, ier) + gsfit (sf, x, y, z, w, npts, wtflag, ier) + gsrefit (sf, x, y, z, w, ier) + y = gseval (sf, x, y) + gsvector (sf, x, y, zfit, npts) + gsder (sf, x, y, zfit, npts, nxder, nyder) + gscoeff (sf, coeff, ncoeff) + gserrors (sf, z, w, zfit, rms, errors) + gssave (sf, fit) + gsrestore (sf, fit) +ival = gsstati (sf, param) +rval = gsstatr (sf, param) + gsadd (sf1, sf2, sf3) + gssub (sf1, sf2, sf3) + gscopy (sf1, sf2) + gsfree (sf) +.fi +.ih +DESCRIPTION +The gsurfit package provides a set of routines for fitting data to functions +of two variables, linear in their coefficients, using least squares +techniques. The numerical technique employed is the solution of the normal +equations by the Cholesky method. +.ih +NOTES +The fitting function is chosen at run time from the following list. + +.nf + GS_LEGENDRE # Lengendre polynomials in x and y + GS_CHEBYSHEV # Chebyshev polynomials in x and y +.fi + +The gsurfit package performs a weighted fit. The weighting options are +WTS_USER and WTS_UNIFORM. The user must supply a weight array. In the +WTS_UNIFORM mode the gsurfit routines set the weights to 1. In WTS_USER +mode the user must supply an array of weight values. + +In WTS_UNIFORM mode the reduced chi-square returned by GSERRORS is the +variance of the fit and the errors in the coefficients are scaled +by the square root of this variance. Otherwise the weights are +interpreted as one over the variance of the data and the true reduced +chi-square is returned. + +The routines assume that all the x and y values of interest lie in the +region xmin <= x <= xmax and ymin <= y <= ymax. Checking for out of +bounds x and y values is the responsibility of the calling program. +The package routines assume that INDEF valued data points have been removed +from the data set prior to entering the package routines. + +In order to make the package definitions available to the calling program +an include statement must be inserted in the calling program. +GSINIT must be called before each fit. GSFREE frees the space used by +the GSURFIT package. +.ih +EXAMPLES +.nf +Example 1: Fit surface to data, uniform weighting + +include + +... + +call gsinit (sf, GS_CHEBYSHEV, 4, 4, NO, 1., 512., 1., 512.) + +call gsfit (sf, x, y, z, w, npts, WTS_UNIFORM, ier) +if (ier != OK) + call error (...) + +do i = 1, 512 { + call printf ("x = %g y = %g z = %g zfit = %g\n") + call pargr (x[i]) + call pargr (y[i]) + call pargr (z[i]) + call pargr (gseval (sf, x[i], y[i])) +} + +call gsfree (sf) + +... + +Example 2: Fit a surface using accumulate mode, uniform weighting + +include + +... + +do i = 1, 512 { + if (y[i] != INDEF) + call gsaccum (sf, x[i], y[i], z[i], weight[i], WTS_UNIFORM) +} + +call gssolve (sf, ier) +if (ier != OK) + call error (...) + +... + +call gsfree (sf) + +... + +Example 3: Fit and subtract a smooth surface from image lines + +include + +... + +call gsinit (gs, GS_CHEBYSHEV, xorder, yorder, YES, 1., 512., 1., 512.) + +call gsfit (sf, xpts, ypts, zpts, w, WTS_UNIFORM, ier) +if (ier != OK) + call error (...) + +do i = 1, 512 + Memr[x+i-1] = i + +do line = 1, 512 { + + inpix = imgl2r (im, line) + outpix = imgl2r (im, line) + + yval = line + call amovkr (yval, Memr[y], 512) + call gsvector (sf, Memr[x], Memr[y], Memr[outpix], 512) + call asubr (Memr[inpix], Memr[outpix], Memr[outpix, 512) +} + +call gsfree (sf) + +... + +Example 4: Fit curve, save fit for later use for GSEVAL + +include + +call gsinit (sf, GS_LEGENDRE, xorder, yorder, YES, xmin, xmax, ymin, ymax) + +call gsfit (sf, x, y, z, w, npts, WTS_UNIFORM, ier) +if (ier != OK) + ... + +nsave = gsstati (sf, GSNSAVE) +call salloc (fit, nsave, TY_REAL) +call gssave (sf, Memr[fit]) +call gsfree (sf) + +... + +call gsrestore (sf, Memr[fit]) +do i = 1, npts + zfit[i] = gseval (sf, x[i], y[i]) + +call gsfree (sf) + +... +.fi +.endhelp diff --git a/math/gsurfit/doc/gsurfit.men b/math/gsurfit/doc/gsurfit.men new file mode 100644 index 00000000..0b938ac8 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.men @@ -0,0 +1,21 @@ + gsaccum - Accumulate point into data set + gsacpts - Accumulate points into a data set + gsadd - Add two surfaces + gscoeff - Get coefficients + gscopy - Copy one surface to another + gsder - Evaluate the derivatives of a surface + gserrors - Calculate chi-square and errors in coefficients + gseval - Evaluate surface at x and y + gsfit - Fit surface + gsfree - Free space allocated by gsinit + gsinit - Make ready to fit a surface; set up parameters of fit + gsrefit - Refit surface, same x, y and weight, different z + gsreject - Reject point from data set + gsrestore - Restore surface parameters and coefficients + gssave - Save surface parameters and coefficients + gssolve - Solve matrix for coefficients + gsstati - Get integer parameter + gsstatr - Get real parameter + gssub - Subtract one surface from another + gsvector - Evaluate surface at an array of x and y + gszero - Zero arrays for new fit diff --git a/math/gsurfit/doc/gsvector.hlp b/math/gsurfit/doc/gsvector.hlp new file mode 100644 index 00000000..16003101 --- /dev/null +++ b/math/gsurfit/doc/gsvector.hlp @@ -0,0 +1,41 @@ +.help gsvector Aug85 "Gsurfit Package" +.ih +NAME +gsvector -- evaluate the fitted surface at a set of points +.ih +SYNOPSIS +gsvector (sf, x, y, zfit, npts) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x <= xmax +real y[npts] # y array, ymin <= y <= ymax +real zfit[npts] # data values +int npts # number of data points +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls zfit +Array of fitted values. +.le +.ls npts +The number of points to be fit. +.le +.ih +DESCRIPTION +Fit the surface to an array of data points. GSVECTOR uses the coefficients +stored in the surface descriptor structure. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the +calling program. +.ih +SEE ALSO +gseval, gsder +.endhelp diff --git a/math/gsurfit/doc/gszero.hlp b/math/gsurfit/doc/gszero.hlp new file mode 100644 index 00000000..c7d411dd --- /dev/null +++ b/math/gsurfit/doc/gszero.hlp @@ -0,0 +1,27 @@ +.help gszero Aug85 "Gsurfit Package" +.ih +NAME +gszero -- set up for a new surface fit +.ih +SYNOPSIS +gszero (sf) + +.nf +pointer sf # surface descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ih +DESCRIPTION +GSZERO zeros the matrix and right side of the matrix equation. +.ih +NOTES +GSZERO can be used to reinitialize the matrix and right side of the +equation to begin a new fit in accumulate mode. +.ih +SEE ALSO +gsinit, gsfit, gsrefit, gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/gs_b1eval.gx b/math/gsurfit/gs_b1eval.gx new file mode 100644 index 00000000..6f474aa3 --- /dev/null +++ b/math/gsurfit/gs_b1eval.gx @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure $tgs_b1pol (x, order, k1, k2, basis) + +PIXEL x # data point +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # nomalizing constants, dummy in this case +PIXEL basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure $tgs_b1leg (x, order, k1, k2, basis) + +PIXEL x # data point +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int i +PIXEL ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure $tgs_b1cheb (x, order, k1, k2, basis) + +PIXEL x # number of data points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int i +PIXEL xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_b1evald.x b/math/gsurfit/gs_b1evald.x new file mode 100644 index 00000000..50fdf0bd --- /dev/null +++ b/math/gsurfit/gs_b1evald.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure dgs_b1pol (x, order, k1, k2, basis) + +double x # data point +int order # order of polynomial, order = 1, constant +double k1, k2 # nomalizing constants, dummy in this case +double basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure dgs_b1leg (x, order, k1, k2, basis) + +double x # data point +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int i +double ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure dgs_b1cheb (x, order, k1, k2, basis) + +double x # number of data points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int i +double xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_b1evalr.x b/math/gsurfit/gs_b1evalr.x new file mode 100644 index 00000000..a313a043 --- /dev/null +++ b/math/gsurfit/gs_b1evalr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure rgs_b1pol (x, order, k1, k2, basis) + +real x # data point +int order # order of polynomial, order = 1, constant +real k1, k2 # nomalizing constants, dummy in this case +real basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure rgs_b1leg (x, order, k1, k2, basis) + +real x # data point +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i +real ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure rgs_b1cheb (x, order, k1, k2, basis) + +real x # number of data points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i +real xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_beval.gx b/math/gsurfit/gs_beval.gx new file mode 100644 index 00000000..da45f122 --- /dev/null +++ b/math/gsurfit/gs_beval.gx @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure $tgs_bpol (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call amov$t (x, basis[bptr], npts) + else + call amul$t (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure $tgs_bcheb (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + $if (datatype == r) + call amulkr (basis[bptr], 2.0, basis[bptr], npts) + $else + call amulkd (basis[bptr], 2.0d0, basis[bptr], npts) + $endif + call asub$t (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure $tgs_bleg (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int k, bptr +PIXEL ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + $if (datatype == r) + ri = k + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + $else + ri = k + ri1 = (2.0d0 * ri - 3.0d0) / (ri - 1.0d0) + ri2 = - (ri - 2.0d0) / (ri - 1.0d0) + $endif + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsu$t (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_bevald.x b/math/gsurfit/gs_bevald.x new file mode 100644 index 00000000..7820fa39 --- /dev/null +++ b/math/gsurfit/gs_bevald.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure dgs_bpol (x, npts, order, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call amovd (x, basis[bptr], npts) + else + call amuld (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure dgs_bcheb (x, npts, order, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkd (basis[bptr], 2.0d0, basis[bptr], npts) + call asubd (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure dgs_bleg (x, npts, order, k1, k2, basis) + +double x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int k, bptr +double ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (2.0d0 * ri - 3.0d0) / (ri - 1.0d0) + ri2 = - (ri - 2.0d0) / (ri - 1.0d0) + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsud (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_bevalr.x b/math/gsurfit/gs_bevalr.x new file mode 100644 index 00000000..9d22e3dc --- /dev/null +++ b/math/gsurfit/gs_bevalr.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure rgs_bpol (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call amovr (x, basis[bptr], npts) + else + call amulr (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure rgs_bcheb (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkr (basis[bptr], 2.0, basis[bptr], npts) + call asubr (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure rgs_bleg (x, npts, order, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int k, bptr +real ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsur (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_chomat.gx b/math/gsurfit/gs_chomat.gx new file mode 100644 index 00000000..023b3c12 --- /dev/null +++ b/math/gsurfit/gs_chomat.gx @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure $tgschofac (matrix, nbands, nrows, matfac, ier) + +PIXEL matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +PIXEL matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +PIXEL ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_PIXEL) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure $tgschoslv (matfac, nbands, nrows, vector, coeff) + +PIXEL matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +PIXEL vector[nrows] # right side of matrix equation +PIXEL coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_chomatd.x b/math/gsurfit/gs_chomatd.x new file mode 100644 index 00000000..ce15a087 --- /dev/null +++ b/math/gsurfit/gs_chomatd.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "dgsurfitdef.h" + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure dgschofac (matrix, nbands, nrows, matfac, ier) + +double matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +double matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +double ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_DOUBLE) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure dgschoslv (matfac, nbands, nrows, vector, coeff) + +double matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +double vector[nrows] # right side of matrix equation +double coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_chomatr.x b/math/gsurfit/gs_chomatr.x new file mode 100644 index 00000000..deb4c198 --- /dev/null +++ b/math/gsurfit/gs_chomatr.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gsurfitdef.h" + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure rgschofac (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +real matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +real ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_REAL) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure rgschoslv (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +real vector[nrows] # right side of matrix equation +real coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_deval.gx b/math/gsurfit/gs_deval.gx new file mode 100644 index 00000000..38b90dac --- /dev/null +++ b/math/gsurfit/gs_deval.gx @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure $tgs_dpol (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int bptr, k, kk +PIXEL fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call $tgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call $tgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulk$t(basis[1+(k-1)*npts], PIXEL (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovk$t (PIXEL(1.0), basis, npts) + else if (k == 2) + call amov$t (x, basis[bptr], npts) + else + call amul$t (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = PIXEL(1.0) + do kk = 2, nder + fac = fac * PIXEL (kk) + } else { + fac = PIXEL(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * PIXEL(kk) + } + call amulk$t (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure $tgs_dcheb (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +PIXEL fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call $tgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_PIXEL) + call calloc (dfn, npts * (order + nder), TY_PIXEL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_PIXEL) + call alta$t (x, Mem$t[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(1.0), Mem$t[bptr], npts) + else if (k == 2) + call amov$t (Mem$t[xnorm], Mem$t[bptr], npts) + else { + call amul$t (Mem$t[xnorm], Mem$t[bptr-npts], Mem$t[bptr], npts) + call amulk$t (Mem$t[bptr], PIXEL(2.0), Mem$t[bptr], npts) + call asub$t (Mem$t[bptr], Mem$t[bptr-2*npts], Mem$t[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovk$t (PIXEL(1.0), Mem$t[fptr], npts) + else + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + } else { + call amul$t (Mem$t[xnorm], Mem$t[fptr-npts], Mem$t[fptr], + npts) + call amulk$t (Mem$t[fptr], PIXEL(2.0), Mem$t[fptr], npts) + call asub$t (Mem$t[fptr], Mem$t[fptr-2*npts], Mem$t[fptr], + npts) + fac = PIXEL (2.0) * PIXEL (i) + call awsu$t (Mem$t[bptr-npts], Mem$t[fptr], Mem$t[fptr], + npts, fac, PIXEL(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amov$t (Mem$t[dfn], Mem$t[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amov$t (Mem$t[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_PIXEL) + call mfree (fn, TY_PIXEL) + call mfree (dfn, TY_PIXEL) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure $tgs_dleg (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +PIXEL ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call $tgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_PIXEL) + call calloc (dfn, npts * (order + nder), TY_PIXEL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_PIXEL) + call alta$t (x, Mem$t[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(1.0), Mem$t[bptr], npts) + else if (k == 2) + call amov$t (Mem$t[xnorm], Mem$t[bptr], npts) + else { + ri = k + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (Mem$t[xnorm], Mem$t[bptr-npts], Mem$t[bptr], npts) + call awsu$t (Mem$t[bptr], Mem$t[bptr-2*npts], Mem$t[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovk$t (PIXEL(1.0), Mem$t[fptr], npts) + else + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + } else { + ri = k + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (Mem$t[xnorm], Mem$t[fptr-npts], Mem$t[fptr], + npts) + call awsu$t (Mem$t[fptr], Mem$t[fptr-2*npts], Mem$t[fptr], + npts, ri1, ri2) + fac = ri1 * PIXEL (i) + call awsu$t (Mem$t[bptr-npts], Mem$t[fptr], Mem$t[fptr], + npts, fac, PIXEL(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amov$t (Mem$t[dfn], Mem$t[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amov$t (Mem$t[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_PIXEL) + call mfree (fn, TY_PIXEL) + call mfree (dfn, TY_PIXEL) +end diff --git a/math/gsurfit/gs_devald.x b/math/gsurfit/gs_devald.x new file mode 100644 index 00000000..131b18dc --- /dev/null +++ b/math/gsurfit/gs_devald.x @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure dgs_dpol (x, npts, order, nder, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int bptr, k, kk +double fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call dgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call dgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulkd(basis[1+(k-1)*npts], double (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkd (double(1.0), basis, npts) + else if (k == 2) + call amovd (x, basis[bptr], npts) + else + call amuld (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = double(1.0) + do kk = 2, nder + fac = fac * double (kk) + } else { + fac = double(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * double(kk) + } + call amulkd (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure dgs_dcheb (x, npts, order, nder, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +double fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call dgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_DOUBLE) + call calloc (dfn, npts * (order + nder), TY_DOUBLE) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_DOUBLE) + call altad (x, Memd[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(1.0), Memd[bptr], npts) + else if (k == 2) + call amovd (Memd[xnorm], Memd[bptr], npts) + else { + call amuld (Memd[xnorm], Memd[bptr-npts], Memd[bptr], npts) + call amulkd (Memd[bptr], double(2.0), Memd[bptr], npts) + call asubd (Memd[bptr], Memd[bptr-2*npts], Memd[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(0.0), Memd[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkd (double(1.0), Memd[fptr], npts) + else + call amovkd (double(0.0), Memd[fptr], npts) + } else { + call amuld (Memd[xnorm], Memd[fptr-npts], Memd[fptr], + npts) + call amulkd (Memd[fptr], double(2.0), Memd[fptr], npts) + call asubd (Memd[fptr], Memd[fptr-2*npts], Memd[fptr], + npts) + fac = double (2.0) * double (i) + call awsud (Memd[bptr-npts], Memd[fptr], Memd[fptr], + npts, fac, double(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovd (Memd[dfn], Memd[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovd (Memd[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_DOUBLE) + call mfree (fn, TY_DOUBLE) + call mfree (dfn, TY_DOUBLE) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure dgs_dleg (x, npts, order, nder, k1, k2, basis) + +double x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +double ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call dgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_DOUBLE) + call calloc (dfn, npts * (order + nder), TY_DOUBLE) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_DOUBLE) + call altad (x, Memd[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(1.0), Memd[bptr], npts) + else if (k == 2) + call amovd (Memd[xnorm], Memd[bptr], npts) + else { + ri = k + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (Memd[xnorm], Memd[bptr-npts], Memd[bptr], npts) + call awsud (Memd[bptr], Memd[bptr-2*npts], Memd[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(0.0), Memd[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkd (double(1.0), Memd[fptr], npts) + else + call amovkd (double(0.0), Memd[fptr], npts) + } else { + ri = k + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (Memd[xnorm], Memd[fptr-npts], Memd[fptr], + npts) + call awsud (Memd[fptr], Memd[fptr-2*npts], Memd[fptr], + npts, ri1, ri2) + fac = ri1 * double (i) + call awsud (Memd[bptr-npts], Memd[fptr], Memd[fptr], + npts, fac, double(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovd (Memd[dfn], Memd[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovd (Memd[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_DOUBLE) + call mfree (fn, TY_DOUBLE) + call mfree (dfn, TY_DOUBLE) +end diff --git a/math/gsurfit/gs_devalr.x b/math/gsurfit/gs_devalr.x new file mode 100644 index 00000000..06449e38 --- /dev/null +++ b/math/gsurfit/gs_devalr.x @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure rgs_dpol (x, npts, order, nder, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int bptr, k, kk +real fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call rgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call rgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulkr(basis[1+(k-1)*npts], real (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkr (real(1.0), basis, npts) + else if (k == 2) + call amovr (x, basis[bptr], npts) + else + call amulr (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = real(1.0) + do kk = 2, nder + fac = fac * real (kk) + } else { + fac = real(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * real(kk) + } + call amulkr (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure rgs_dcheb (x, npts, order, nder, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +real fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call rgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_REAL) + call calloc (dfn, npts * (order + nder), TY_REAL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_REAL) + call altar (x, Memr[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(1.0), Memr[bptr], npts) + else if (k == 2) + call amovr (Memr[xnorm], Memr[bptr], npts) + else { + call amulr (Memr[xnorm], Memr[bptr-npts], Memr[bptr], npts) + call amulkr (Memr[bptr], real(2.0), Memr[bptr], npts) + call asubr (Memr[bptr], Memr[bptr-2*npts], Memr[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(0.0), Memr[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkr (real(1.0), Memr[fptr], npts) + else + call amovkr (real(0.0), Memr[fptr], npts) + } else { + call amulr (Memr[xnorm], Memr[fptr-npts], Memr[fptr], + npts) + call amulkr (Memr[fptr], real(2.0), Memr[fptr], npts) + call asubr (Memr[fptr], Memr[fptr-2*npts], Memr[fptr], + npts) + fac = real (2.0) * real (i) + call awsur (Memr[bptr-npts], Memr[fptr], Memr[fptr], + npts, fac, real(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovr (Memr[dfn], Memr[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovr (Memr[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_REAL) + call mfree (fn, TY_REAL) + call mfree (dfn, TY_REAL) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure rgs_dleg (x, npts, order, nder, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +real ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call rgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_REAL) + call calloc (dfn, npts * (order + nder), TY_REAL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_REAL) + call altar (x, Memr[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(1.0), Memr[bptr], npts) + else if (k == 2) + call amovr (Memr[xnorm], Memr[bptr], npts) + else { + ri = k + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (Memr[xnorm], Memr[bptr-npts], Memr[bptr], npts) + call awsur (Memr[bptr], Memr[bptr-2*npts], Memr[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(0.0), Memr[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkr (real(1.0), Memr[fptr], npts) + else + call amovkr (real(0.0), Memr[fptr], npts) + } else { + ri = k + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (Memr[xnorm], Memr[fptr-npts], Memr[fptr], + npts) + call awsur (Memr[fptr], Memr[fptr-2*npts], Memr[fptr], + npts, ri1, ri2) + fac = ri1 * real (i) + call awsur (Memr[bptr-npts], Memr[fptr], Memr[fptr], + npts, fac, real(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovr (Memr[dfn], Memr[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovr (Memr[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_REAL) + call mfree (fn, TY_REAL) + call mfree (dfn, TY_REAL) +end diff --git a/math/gsurfit/gs_f1deval.gx b/math/gsurfit/gs_f1deval.gx new file mode 100644 index 00000000..17981daf --- /dev/null +++ b/math/gsurfit/gs_f1deval.gx @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure $tgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altm$t (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + $if (datatype == r) + call salloc (temp, npts, TY_REAL) + $else + call salloc (temp, npts, TY_DOUBLE) + $endif + + # accumulate the output vector + call amov$t (x, Mem$t[temp], npts) + do i = 3, order { + call amul$t (Mem$t[temp], x, Mem$t[temp], npts) + $if (datatype == r) + call awsur (yfit, Memr[temp], yfit, npts, 1.0, coeff[i]) + $else + call awsud (yfit, Memd[temp], yfit, npts, 1.0d0, coeff[i]) + $endif + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL c1, c2 + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altm$t (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + $if (datatype == r) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + $else + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + $endif + + # a higher order polynomial + $if (datatype == r) + call amovkr (1., Memr[pnm2], npts) + $else + call amovkd (1.0d0, Memd[pnm2], npts) + $endif + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + call amulk$t (Mem$t[sx], 2$f, Mem$t[sx], npts) + do i = 3, order { + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call asub$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL ri, ri1, ri2 + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altm$t (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + $if (datatype == r) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + $else + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + $endif + + # a higher order polynomial + $if (datatype == r) + call amovkr (1., Memr[pnm2], npts) + $else + call amovkd (1.0d0, Memd[pnm2], npts) + $endif + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call awsu$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts, ri1, ri2) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_f1devald.x b/math/gsurfit/gs_f1devald.x new file mode 100644 index 00000000..6f20e7e7 --- /dev/null +++ b/math/gsurfit/gs_f1devald.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure dgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altmd (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + call salloc (temp, npts, TY_DOUBLE) + + # accumulate the output vector + call amovd (x, Memd[temp], npts) + do i = 3, order { + call amuld (Memd[temp], x, Memd[temp], npts) + call awsud (yfit, Memd[temp], yfit, npts, 1.0d0, coeff[i]) + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double c1, c2 + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmd (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (1.0d0, Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + call amulkd (Memd[sx], 2.0D0, Memd[sx], npts) + do i = 3, order { + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call asubd (Memd[pn], Memd[pnm2], Memd[pn], npts) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double ri, ri1, ri2 + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmd (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (1.0d0, Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call awsud (Memd[pn], Memd[pnm2], Memd[pn], npts, ri1, ri2) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_f1devalr.x b/math/gsurfit/gs_f1devalr.x new file mode 100644 index 00000000..5fdab143 --- /dev/null +++ b/math/gsurfit/gs_f1devalr.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure rgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altmr (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + call salloc (temp, npts, TY_REAL) + + # accumulate the output vector + call amovr (x, Memr[temp], npts) + do i = 3, order { + call amulr (Memr[temp], x, Memr[temp], npts) + call awsur (yfit, Memr[temp], yfit, npts, 1.0, coeff[i]) + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real c1, c2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmr (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + call amulkr (Memr[sx], 2.0, Memr[sx], npts) + do i = 3, order { + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call asubr (Memr[pn], Memr[pnm2], Memr[pn], npts) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real ri, ri1, ri2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmr (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call awsur (Memr[pn], Memr[pnm2], Memr[pn], npts, ri1, ri2) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_fder.gx b/math/gsurfit/gs_fder.gx new file mode 100644 index 00000000..1620e189 --- /dev/null +++ b/math/gsurfit/gs_fder.gx @@ -0,0 +1,288 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure $tgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dpol (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dpol (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + # accumulate the output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure $tgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + # accumulate thr output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure $tgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dleg (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dleg (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclr$t (Mem$t[accum], npts) + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_fderd.x b/math/gsurfit/gs_fderd.x new file mode 100644 index 00000000..8f5cd628 --- /dev/null +++ b/math/gsurfit/gs_fderd.x @@ -0,0 +1,231 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure dgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dpol (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dpol (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + # accumulate the output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure dgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure dgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dleg (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dleg (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrd (Memd[accum], npts) + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_fderr.x b/math/gsurfit/gs_fderr.x new file mode 100644 index 00000000..9d47dcb4 --- /dev/null +++ b/math/gsurfit/gs_fderr.x @@ -0,0 +1,228 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure rgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dpol (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dpol (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + # accumulate the output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure rgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure rgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dleg (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dleg (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrr (Memr[accum], npts) + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_feval.gx b/math/gsurfit/gs_feval.gx new file mode 100644 index 00000000..e28ad46d --- /dev/null +++ b/math/gsurfit/gs_feval.gx @@ -0,0 +1,332 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure $tgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altm$t (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altm$t (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bpol (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bpol (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + # accumulate the output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bcheb (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bcheb (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + # accumulate thr output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $else + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bleg (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bleg (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclr$t (Mem$t[accum], npts) + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvp$t (a, b, c, d, npts) + +PIXEL a[ARB] # first input vector +PIXEL b[ARB] # second input vector +PIXEL c[ARB] # third vector +PIXEL d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gs_fevald.x b/math/gsurfit/gs_fevald.x new file mode 100644 index 00000000..68265e9c --- /dev/null +++ b/math/gsurfit/gs_fevald.x @@ -0,0 +1,274 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure dgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altmd (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altmd (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bpol (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bpol (y, npts, yorder, k1y, k2y, Memd[yb]) + + # accumulate the output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bcheb (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bcheb (y, npts, yorder, k1y, k2y, Memd[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bleg (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bleg (y, npts, yorder, k1y, k2y, Memd[yb]) + + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrd (Memd[accum], npts) + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvpd (a, b, c, d, npts) + +double a[ARB] # first input vector +double b[ARB] # second input vector +double c[ARB] # third vector +double d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gs_fevalr.x b/math/gsurfit/gs_fevalr.x new file mode 100644 index 00000000..7988f66a --- /dev/null +++ b/math/gsurfit/gs_fevalr.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure rgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altmr (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altmr (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bpol (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bpol (y, npts, yorder, k1y, k2y, Memr[yb]) + + # accumulate the output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bcheb (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bcheb (y, npts, yorder, k1y, k2y, Memr[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bleg (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bleg (y, npts, yorder, k1y, k2y, Memr[yb]) + + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrr (Memr[accum], npts) + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvpr (a, b, c, d, npts) + +real a[ARB] # first input vector +real b[ARB] # second input vector +real c[ARB] # third vector +real d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gsaccum.gx b/math/gsurfit/gsaccum.gx new file mode 100644 index 00000000..f9958263 --- /dev/null +++ b/math/gsurfit/gsaccum.gx @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsaccum (sf, x, y, z, w, wtflag) +$else +procedure dgsaccum (sf, x, y, z, w, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL z # z value +PIXEL w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +PIXEL x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + $if (datatype == r) + w = 1. + $else + w = 1.0d0 + $endif + case WTS_USER: + # user supplied weights + default: + $if (datatype == r) + w = 1. + $else + w = 1.0d0 + $endif + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_PIXEL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_PIXEL) + + # subtract reference value + refsub = !(IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call $tgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call $tgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call $tgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsaccumd.x b/math/gsurfit/gsaccumd.x new file mode 100644 index 00000000..71ed9f90 --- /dev/null +++ b/math/gsurfit/gsaccumd.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsaccum (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +double x # x value +double y # y value +double z # z value +double w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +double x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1.0d0 + case WTS_USER: + # user supplied weights + default: + w = 1.0d0 + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + + # subtract reference value + refsub = !(IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call dgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call dgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call dgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsaccumr.x b/math/gsurfit/gsaccumr.x new file mode 100644 index 00000000..4e973cfa --- /dev/null +++ b/math/gsurfit/gsaccumr.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsaccum (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +real x # x value +real y # y value +real z # z value +real w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +real x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + + # subtract reference value + refsub = !(IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call rgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call rgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call rgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacpts.gx b/math/gsurfit/gsacpts.gx new file mode 100644 index 00000000..59a8ae72 --- /dev/null +++ b/math/gsurfit/gsacpts.gx @@ -0,0 +1,257 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsacpts (sf, x, y, z, w, npts, wtflag) +$else +procedure dgsacpts (sf, x, y, z, w, npts, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +PIXEL adot$t() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + $if (datatype == r) + call amovkr (1., w, npts) + $else + call amovkd (1.0d0, w, npts) + $endif + case WTS_SPACING: + if (npts == 1) + $if (datatype == r) + w[1] = 1. + $else + w[1] = 1.0d0 + $endif + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + $if (datatype == r) + w[npts] = 1. + $else + w[npts] = 1.0d0 + $endif + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + $if (datatype == r) + call amovkr (1., w, npts) + $else + call amovkd (1.0d0, w, npts) + $endif + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_PIXEL) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_PIXEL) + + # subtract reference value + refsub = !(IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_PIXEL) + call salloc (y1, npts, TY_PIXEL) + call salloc (z1, npts, TY_PIXEL) + call asubk$t (x, GS_XREF(sf), Mem$t[x1], npts) + call asubk$t (y, GS_YREF(sf), Mem$t[y1], npts) + call asubk$t (z, GS_ZREF(sf), Mem$t[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call $tgs_bleg (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call $tgs_bcheb (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call $tgs_bpol (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + $if (datatype == r) + call salloc (byw, npts, TY_REAL) + call salloc (bw, npts, TY_REAL) + $else + call salloc (byw, npts, TY_DOUBLE) + call salloc (bw, npts, TY_DOUBLE) + $endif + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amul$t (w, YBASIS(byptr), Mem$t[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amul$t (Mem$t[byw], XBASIS(bxptr), Mem$t[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adot$t (Mem$t[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacptsd.x b/math/gsurfit/gsacptsd.x new file mode 100644 index 00000000..0b0b1695 --- /dev/null +++ b/math/gsurfit/gsacptsd.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsacpts (sf, x, y, z, w, npts, wtflag) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +double adotd() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkd (1.0d0, w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1.0d0 + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1.0d0 + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + call amovkd (1.0d0, w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_DOUBLE) + + # subtract reference value + refsub = !(IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_DOUBLE) + call salloc (y1, npts, TY_DOUBLE) + call salloc (z1, npts, TY_DOUBLE) + call asubkd (x, GS_XREF(sf), Memd[x1], npts) + call asubkd (y, GS_YREF(sf), Memd[y1], npts) + call asubkd (z, GS_ZREF(sf), Memd[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call dgs_bleg (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call dgs_bcheb (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call dgs_bpol (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + call salloc (byw, npts, TY_DOUBLE) + call salloc (bw, npts, TY_DOUBLE) + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amuld (w, YBASIS(byptr), Memd[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amuld (Memd[byw], XBASIS(bxptr), Memd[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotd (Memd[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacptsr.x b/math/gsurfit/gsacptsr.x new file mode 100644 index 00000000..705bb8d7 --- /dev/null +++ b/math/gsurfit/gsacptsr.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsacpts (sf, x, y, z, w, npts, wtflag) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +real adotr() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkr (1., w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1. + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1. + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + call amovkr (1., w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_REAL) + + # subtract reference value + refsub = !(IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_REAL) + call salloc (y1, npts, TY_REAL) + call salloc (z1, npts, TY_REAL) + call asubkr (x, GS_XREF(sf), Memr[x1], npts) + call asubkr (y, GS_YREF(sf), Memr[y1], npts) + call asubkr (z, GS_ZREF(sf), Memr[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call rgs_bleg (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call rgs_bcheb (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call rgs_bpol (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + call salloc (byw, npts, TY_REAL) + call salloc (bw, npts, TY_REAL) + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amulr (w, YBASIS(byptr), Memr[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amulr (Memr[byw], XBASIS(bxptr), Memr[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotr (Memr[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsadd.gx b/math/gsurfit/gsadd.gx new file mode 100644 index 00000000..516f1b1f --- /dev/null +++ b/math/gsurfit/gsadd.gx @@ -0,0 +1,181 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +$if (datatype == r) +procedure gsadd (sf1, sf2, sf3) +$else +procedure dgsadd (sf1, sf2, sf3) +$endif + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequal$t() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + $if (datatype == r) + call gscopy (sf2, sf3) + $else + call dgscopy (sf2, sf3) + $endif + return + } else if (sf2 == NULL) { + $if (datatype == r) + call gscopy (sf1, sf3) + $else + call dgscopy (sf1, sf3) + $endif + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequal$t (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequal$t (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + $if (datatype == r) + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + $else + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + $endif + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amov$t (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aadd$t (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsaddd.x b/math/gsurfit/gsaddd.x new file mode 100644 index 00000000..f637d08a --- /dev/null +++ b/math/gsurfit/gsaddd.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure dgsadd (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequald() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + call dgscopy (sf2, sf3) + return + } else if (sf2 == NULL) { + call dgscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequald (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequald (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovd (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aaddd (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsaddr.x b/math/gsurfit/gsaddr.x new file mode 100644 index 00000000..4df5ee48 --- /dev/null +++ b/math/gsurfit/gsaddr.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure gsadd (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequalr() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + call gscopy (sf2, sf3) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequalr (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequalr (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovr (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aaddr (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gscoeff.gx b/math/gsurfit/gscoeff.gx new file mode 100644 index 00000000..84c495f7 --- /dev/null +++ b/math/gsurfit/gscoeff.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +$if (datatype == r) +procedure gscoeff (sf, coeff, ncoeff) +$else +procedure dgscoeff (sf, coeff, ncoeff) +$endif + +pointer sf # pointer to the surface fitting descriptor +PIXEL coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amov$t (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscoeffd.x b/math/gsurfit/gscoeffd.x new file mode 100644 index 00000000..2090eec1 --- /dev/null +++ b/math/gsurfit/gscoeffd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dgsurfitdef.h" + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +procedure dgscoeff (sf, coeff, ncoeff) + +pointer sf # pointer to the surface fitting descriptor +double coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amovd (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscoeffr.x b/math/gsurfit/gscoeffr.x new file mode 100644 index 00000000..96cccce5 --- /dev/null +++ b/math/gsurfit/gscoeffr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gsurfitdef.h" + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +procedure gscoeff (sf, coeff, ncoeff) + +pointer sf # pointer to the surface fitting descriptor +real coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amovr (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscopy.gx b/math/gsurfit/gscopy.gx new file mode 100644 index 00000000..9f0a6d09 --- /dev/null +++ b/math/gsurfit/gscopy.gx @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +$if (datatype == r) +procedure gscopy (sf1, sf2) +$else +procedure dgscopy (sf1, sf2) +$endif + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + $if (datatype == r) + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + $else + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + $endif + call amov$t (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gscopyd.x b/math/gsurfit/gscopyd.x new file mode 100644 index 00000000..b5b93912 --- /dev/null +++ b/math/gsurfit/gscopyd.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +procedure dgscopy (sf1, sf2) + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + call amovd (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gscopyr.x b/math/gsurfit/gscopyr.x new file mode 100644 index 00000000..251b5327 --- /dev/null +++ b/math/gsurfit/gscopyr.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +procedure gscopy (sf1, sf2) + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + call amovr (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gsder.gx b/math/gsurfit/gsder.gx new file mode 100644 index 00000000..e0ee95bd --- /dev/null +++ b/math/gsurfit/gsder.gx @@ -0,0 +1,264 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +$if (datatype == r) +procedure gsder (sf1, x, y, zfit, npts, nxd, nyd) +$else +procedure dgsder (sf1, x, y, zfit, npts, nxd, nyd) +$endif + +pointer sf1 # pointer to the previous surface +PIXEL x[npts] # x values +PIXEL y[npts] # y values +PIXEL zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +PIXEL norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + $if (datatype == r) + call gsvector (sf1, x, y, zfit, npts) + $else + call dgsvector (sf1, x, y, zfit, npts) + $endif + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovk$t (PIXEL(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_PIXEL) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_PIXEL) + $if (datatype == r) + call gscoeff (sf1, Mem$t[coeff], ncoeff) + $else + call dgscoeff (sf1, Mem$t[coeff], ncoeff) + $endif + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amov$t (Mem$t[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amov$t (Mem$t[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Mem$t[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amov$t (Mem$t[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call $tgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call $tgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call $tgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulk$t (zfit, norm, zfit, npts) + } + + # free the space + $if (datatype == r) + call gsfree (sf2) + $else + call dgsfree (sf2) + $endif + call sfree (sp) +end diff --git a/math/gsurfit/gsderd.x b/math/gsurfit/gsderd.x new file mode 100644 index 00000000..851b7b9b --- /dev/null +++ b/math/gsurfit/gsderd.x @@ -0,0 +1,244 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +procedure dgsder (sf1, x, y, zfit, npts, nxd, nyd) + +pointer sf1 # pointer to the previous surface +double x[npts] # x values +double y[npts] # y values +double zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +double norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + call dgsvector (sf1, x, y, zfit, npts) + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovkd (double(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_DOUBLE) + call dgscoeff (sf1, Memd[coeff], ncoeff) + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amovd (Memd[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amovd (Memd[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Memd[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amovd (Memd[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call dgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call dgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call dgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulkd (zfit, norm, zfit, npts) + } + + # free the space + call dgsfree (sf2) + call sfree (sp) +end diff --git a/math/gsurfit/gsderr.x b/math/gsurfit/gsderr.x new file mode 100644 index 00000000..00409c0b --- /dev/null +++ b/math/gsurfit/gsderr.x @@ -0,0 +1,244 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +procedure gsder (sf1, x, y, zfit, npts, nxd, nyd) + +pointer sf1 # pointer to the previous surface +real x[npts] # x values +real y[npts] # y values +real zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +real norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + call gsvector (sf1, x, y, zfit, npts) + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovkr (real(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_REAL) + call gscoeff (sf1, Memr[coeff], ncoeff) + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amovr (Memr[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amovr (Memr[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Memr[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amovr (Memr[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call rgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call rgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call rgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulkr (zfit, norm, zfit, npts) + } + + # free the space + call gsfree (sf2) + call sfree (sp) +end diff --git a/math/gsurfit/gserrors.gx b/math/gsurfit/gserrors.gx new file mode 100644 index 00000000..5f78cfab --- /dev/null +++ b/math/gsurfit/gserrors.gx @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +define COV Mem$t[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +$if (datatype == r) +procedure gserrors (sf, z, w, zfit, chisqr, errors) +$else +procedure dgserrors (sf, z, w, zfit, chisqr, errors) +$endif + +pointer sf # curve descriptor +PIXEL z[ARB] # data points +PIXEL w[ARB] # array of weights +PIXEL zfit[ARB] # fitted data points +PIXEL chisqr # reduced chi-squared of fit +PIXEL errors[ARB] # errors in coefficients + +int i, nfree +PIXEL variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + $if (datatype == r) + call salloc (covptr, GS_NCOEFF(sf), TY_REAL) + $else + call salloc (covptr, GS_NCOEFF(sf), TY_DOUBLE) + $endif + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclr$t (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gserrorsd.x b/math/gsurfit/gserrorsd.x new file mode 100644 index 00000000..6ebdc87e --- /dev/null +++ b/math/gsurfit/gserrorsd.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +define COV Memd[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure dgserrors (sf, z, w, zfit, chisqr, errors) + +pointer sf # curve descriptor +double z[ARB] # data points +double w[ARB] # array of weights +double zfit[ARB] # fitted data points +double chisqr # reduced chi-squared of fit +double errors[ARB] # errors in coefficients + +int i, nfree +double variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, GS_NCOEFF(sf), TY_DOUBLE) + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclrd (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gserrorsr.x b/math/gsurfit/gserrorsr.x new file mode 100644 index 00000000..594dff29 --- /dev/null +++ b/math/gsurfit/gserrorsr.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +define COV Memr[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure gserrors (sf, z, w, zfit, chisqr, errors) + +pointer sf # curve descriptor +real z[ARB] # data points +real w[ARB] # array of weights +real zfit[ARB] # fitted data points +real chisqr # reduced chi-squared of fit +real errors[ARB] # errors in coefficients + +int i, nfree +real variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, GS_NCOEFF(sf), TY_REAL) + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclrr (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gseval.gx b/math/gsurfit/gseval.gx new file mode 100644 index 00000000..d57d21c7 --- /dev/null +++ b/math/gsurfit/gseval.gx @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +$if (datatype == r) +real procedure gseval (sf, x, y) +$else +double procedure dgseval (sf, x, y) +$endif + +pointer sf # pointer to surface descriptor structure +PIXEL x # x value +PIXEL y # y value + +PIXEL sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + $if (datatype == r) + call salloc (xb, GS_NXCOEFF(sf), TY_REAL) + call salloc (yb, GS_NYCOEFF(sf), TY_REAL) + $else + call salloc (xb, GS_NXCOEFF(sf), TY_DOUBLE) + call salloc (yb, GS_NYCOEFF(sf), TY_DOUBLE) + $endif + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call $tgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call $tgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call $tgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsevald.x b/math/gsurfit/gsevald.x new file mode 100644 index 00000000..e7909d91 --- /dev/null +++ b/math/gsurfit/gsevald.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +double procedure dgseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +double x # x value +double y # y value + +double sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call salloc (xb, GS_NXCOEFF(sf), TY_DOUBLE) + call salloc (yb, GS_NYCOEFF(sf), TY_DOUBLE) + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call dgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call dgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call dgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsevalr.x b/math/gsurfit/gsevalr.x new file mode 100644 index 00000000..738e9915 --- /dev/null +++ b/math/gsurfit/gsevalr.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +real procedure gseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +real x # x value +real y # y value + +real sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call salloc (xb, GS_NXCOEFF(sf), TY_REAL) + call salloc (yb, GS_NYCOEFF(sf), TY_REAL) + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call rgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call rgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call rgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsfit.gx b/math/gsurfit/gsfit.gx new file mode 100644 index 00000000..60251596 --- /dev/null +++ b/math/gsurfit/gsfit.gx @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +$if (datatype == r) +procedure gsfit (sf, x, y, z, w, npts, wtflag, ier) +$else +procedure dgsfit (sf, x, y, z, w, npts, wtflag, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + $if (datatype == r) + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve (sf, ier) + $else + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve (sf, ier) + $endif +end diff --git a/math/gsurfit/gsfit1.gx b/math/gsurfit/gsfit1.gx new file mode 100644 index 00000000..4e7341e4 --- /dev/null +++ b/math/gsurfit/gsfit1.gx @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +$if (datatype == r) +procedure gsfit1 (sf, x, y, z, w, npts, wtflag, ier) +$else +procedure dgsfit1 (sf, x, y, z, w, npts, wtflag, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + $if (datatype == r) + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve1 (sf, ier) + $else + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve1 (sf, ier) + $endif +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +$if (datatype == r) +procedure gssolve1 (sf, ier) +$else +procedure dgssolve1 (sf, ier) +$endif + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_PIXEL) + call salloc (matrix, ncoeff*ncoeff, TY_PIXEL) + + # eliminate the first term from the vector and matrix + call amov$t (VECTOR(GS_VECTOR(sf)+offset), Mem$t[vector], ncoeff) + do i = 0, ncoeff-1 + call amov$t (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Mem$t[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call $tgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfit1d.x b/math/gsurfit/gsfit1d.x new file mode 100644 index 00000000..8937103f --- /dev/null +++ b/math/gsurfit/gsfit1d.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure dgsfit1 (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve1 (sf, ier) +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure dgssolve1 (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_DOUBLE) + call salloc (matrix, ncoeff*ncoeff, TY_DOUBLE) + + # eliminate the first term from the vector and matrix + call amovd (VECTOR(GS_VECTOR(sf)+offset), Memd[vector], ncoeff) + do i = 0, ncoeff-1 + call amovd (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Memd[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call dgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfit1r.x b/math/gsurfit/gsfit1r.x new file mode 100644 index 00000000..fe3be3ed --- /dev/null +++ b/math/gsurfit/gsfit1r.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure gsfit1 (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve1 (sf, ier) +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure gssolve1 (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_REAL) + call salloc (matrix, ncoeff*ncoeff, TY_REAL) + + # eliminate the first term from the vector and matrix + call amovr (VECTOR(GS_VECTOR(sf)+offset), Memr[vector], ncoeff) + do i = 0, ncoeff-1 + call amovr (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Memr[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call rgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfitd.x b/math/gsurfit/gsfitd.x new file mode 100644 index 00000000..b432cc3f --- /dev/null +++ b/math/gsurfit/gsfitd.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +procedure dgsfit (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve (sf, ier) +end diff --git a/math/gsurfit/gsfitr.x b/math/gsurfit/gsfitr.x new file mode 100644 index 00000000..f5321969 --- /dev/null +++ b/math/gsurfit/gsfitr.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +procedure gsfit (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve (sf, ier) +end diff --git a/math/gsurfit/gsfree.gx b/math/gsurfit/gsfree.gx new file mode 100644 index 00000000..b97e960a --- /dev/null +++ b/math/gsurfit/gsfree.gx @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFREE -- Procedure to free the surface descriptor + +$if (datatype == r) +procedure gsfree (sf) +$else +procedure dgsfree (sf) +$endif + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_REAL) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_REAL) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_REAL) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_REAL) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_DOUBLE) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_DOUBLE) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_DOUBLE) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_DOUBLE) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + $endif + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsfreed.x b/math/gsurfit/gsfreed.x new file mode 100644 index 00000000..498bf00c --- /dev/null +++ b/math/gsurfit/gsfreed.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dgsurfitdef.h" + +# GSFREE -- Procedure to free the surface descriptor + +procedure dgsfree (sf) + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_DOUBLE) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_DOUBLE) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_DOUBLE) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_DOUBLE) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsfreer.x b/math/gsurfit/gsfreer.x new file mode 100644 index 00000000..95148363 --- /dev/null +++ b/math/gsurfit/gsfreer.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gsurfitdef.h" + +# GSFREE -- Procedure to free the surface descriptor + +procedure gsfree (sf) + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_REAL) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_REAL) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_REAL) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_REAL) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsgcoeff.gx b/math/gsurfit/gsgcoeff.gx new file mode 100644 index 00000000..3d8a294d --- /dev/null +++ b/math/gsurfit/gsgcoeff.gx @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +$if (datatype == r) +real procedure gsgcoeff (sf, xorder, yorder) +$else +double procedure dgsgcoeff (sf, xorder, yorder) +$endif + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEF) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEF) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEF) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsgcoeffd.x b/math/gsurfit/gsgcoeffd.x new file mode 100644 index 00000000..32dead75 --- /dev/null +++ b/math/gsurfit/gsgcoeffd.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +double procedure dgsgcoeff (sf, xorder, yorder) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEFD) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEFD) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEFD) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsgcoeffr.x b/math/gsurfit/gsgcoeffr.x new file mode 100644 index 00000000..45ef51e4 --- /dev/null +++ b/math/gsurfit/gsgcoeffr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +real procedure gsgcoeff (sf, xorder, yorder) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEFR) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEFR) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEFR) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsinit.gx b/math/gsurfit/gsinit.gx new file mode 100644 index 00000000..1d94c027 --- /dev/null +++ b/math/gsurfit/gsinit.gx @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSINIT -- Procedure to initialize the surface descriptor. + +$if (datatype == r) +procedure gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +$else +procedure dgsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +$endif + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +PIXEL xmin # minimum value of x +PIXEL xmax # maximum value of x +PIXEL ymin # minimum value of y +PIXEL ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEF + GS_YREF(sf) = INDEF + GS_ZREF(sf) = INDEF + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + $if (datatype == r) + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_REAL) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + $else + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_DOUBLE) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + $endif + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsinitd.x b/math/gsurfit/gsinitd.x new file mode 100644 index 00000000..ad8e2650 --- /dev/null +++ b/math/gsurfit/gsinitd.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSINIT -- Procedure to initialize the surface descriptor. + +procedure dgsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +double xmin # minimum value of x +double xmax # maximum value of x +double ymin # minimum value of y +double ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEFD + GS_YREF(sf) = INDEFD + GS_ZREF(sf) = INDEFD + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_DOUBLE) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsinitr.x b/math/gsurfit/gsinitr.x new file mode 100644 index 00000000..8c44d6e4 --- /dev/null +++ b/math/gsurfit/gsinitr.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSINIT -- Procedure to initialize the surface descriptor. + +procedure gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +real xmin # minimum value of x +real xmax # maximum value of x +real ymin # minimum value of y +real ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEFR + GS_YREF(sf) = INDEFR + GS_ZREF(sf) = INDEFR + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_REAL) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsrefit.gx b/math/gsurfit/gsrefit.gx new file mode 100644 index 00000000..00327abb --- /dev/null +++ b/math/gsurfit/gsrefit.gx @@ -0,0 +1,174 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +$if (datatype == r) +procedure gsrefit (sf, x, y, z, w, ier) +$else +procedure dgsrefit (sf, x, y, z, w, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[ARB] # array of x values +PIXEL y[ARB] # array of y values +PIXEL z[ARB] # data array +PIXEL w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +PIXEL adot$t() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclr$t (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + $if (datatype == r) + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_REAL) + $else + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_DOUBLE) + $endif + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + $if (datatype == r) + call salloc (bwz, GS_NPTS(sf), TY_REAL) + $else + call salloc (bwz, GS_NPTS(sf), TY_DOUBLE) + $endif + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amul$t (w, z, Mem$t[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amul$t (Mem$t[GS_WZ(sf)], YBASIS(byptr), Mem$t[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adot$t (Mem$t[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsrefitd.x b/math/gsurfit/gsrefitd.x new file mode 100644 index 00000000..a7f7d706 --- /dev/null +++ b/math/gsurfit/gsrefitd.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +procedure dgsrefit (sf, x, y, z, w, ier) + +pointer sf # surface descriptor +double x[ARB] # array of x values +double y[ARB] # array of y values +double z[ARB] # data array +double w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +double adotd() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclrd (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_DOUBLE) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + call salloc (bwz, GS_NPTS(sf), TY_DOUBLE) + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amuld (w, z, Memd[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amuld (Memd[GS_WZ(sf)], YBASIS(byptr), Memd[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotd (Memd[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsrefitr.x b/math/gsurfit/gsrefitr.x new file mode 100644 index 00000000..6b550084 --- /dev/null +++ b/math/gsurfit/gsrefitr.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +procedure gsrefit (sf, x, y, z, w, ier) + +pointer sf # surface descriptor +real x[ARB] # array of x values +real y[ARB] # array of y values +real z[ARB] # data array +real w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +real adotr() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclrr (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_REAL) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + call salloc (bwz, GS_NPTS(sf), TY_REAL) + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amulr (w, z, Memr[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amulr (Memr[GS_WZ(sf)], YBASIS(byptr), Memr[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotr (Memr[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsreject.gx b/math/gsurfit/gsreject.gx new file mode 100644 index 00000000..b5d8e01e --- /dev/null +++ b/math/gsurfit/gsreject.gx @@ -0,0 +1,188 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsrej (sf, x, y, z, w, wtflag) +$else +procedure dgsrej (sf, x, y, z, w, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL z # z value +PIXEL w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +PIXEL byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrejectd.x b/math/gsurfit/gsrejectd.x new file mode 100644 index 00000000..da1d71dd --- /dev/null +++ b/math/gsurfit/gsrejectd.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsrej (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +double x # x value +double y # y value +double z # z value +double w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +double byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrejectr.x b/math/gsurfit/gsrejectr.x new file mode 100644 index 00000000..fea86cef --- /dev/null +++ b/math/gsurfit/gsrejectr.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsrej (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +real x # x value +real y # y value +real z # z value +real w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +real byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrestore.gx b/math/gsurfit/gsrestore.gx new file mode 100644 index 00000000..f8ced0a8 --- /dev/null +++ b/math/gsurfit/gsrestore.gx @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +$if (datatype == r) +procedure gsrestore (sf, fit) +$else +procedure dgsrestore (sf, fit) +$endif + +pointer sf # surface descriptor +PIXEL fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +PIXEL xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = PIXEL(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / PIXEL(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = PIXEL(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / PIXEL(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + $if (datatype == r) + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + $else + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + $endif + + # restore coefficient array + call amov$t (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsrestored.x b/math/gsurfit/gsrestored.x new file mode 100644 index 00000000..11008ec2 --- /dev/null +++ b/math/gsurfit/gsrestored.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +procedure dgsrestore (sf, fit) + +pointer sf # surface descriptor +double fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +double xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = double(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / double(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = double(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / double(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + + # restore coefficient array + call amovd (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsrestorer.x b/math/gsurfit/gsrestorer.x new file mode 100644 index 00000000..0b7b0e56 --- /dev/null +++ b/math/gsurfit/gsrestorer.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +procedure gsrestore (sf, fit) + +pointer sf # surface descriptor +real fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +real xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = real(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / real(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = real(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / real(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + + # restore coefficient array + call amovr (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssave.gx b/math/gsurfit/gssave.gx new file mode 100644 index 00000000..a4cbaa82 --- /dev/null +++ b/math/gsurfit/gssave.gx @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +$if (datatype == r) +procedure gssave (sf, fit) +$else +procedure dgssave (sf, fit) +$endif + +pointer sf # pointer to the surface descriptor +PIXEL fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amov$t (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssaved.x b/math/gsurfit/gssaved.x new file mode 100644 index 00000000..b2bddffd --- /dev/null +++ b/math/gsurfit/gssaved.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +procedure dgssave (sf, fit) + +pointer sf # pointer to the surface descriptor +double fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amovd (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssaver.x b/math/gsurfit/gssaver.x new file mode 100644 index 00000000..b4f5bf32 --- /dev/null +++ b/math/gsurfit/gssaver.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +procedure gssave (sf, fit) + +pointer sf # pointer to the surface descriptor +real fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amovr (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsscoeff.gx b/math/gsurfit/gsscoeff.gx new file mode 100644 index 00000000..09b894e3 --- /dev/null +++ b/math/gsurfit/gsscoeff.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +$if (datatype == r) +procedure gsscoeff (sf, xorder, yorder, coeff) +$else +procedure dgsscoeff (sf, xorder, yorder, coeff) +$endif + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +PIXEL coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gsscoeffd.x b/math/gsurfit/gsscoeffd.x new file mode 100644 index 00000000..452eb70b --- /dev/null +++ b/math/gsurfit/gsscoeffd.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +procedure dgsscoeff (sf, xorder, yorder, coeff) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +double coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gsscoeffr.x b/math/gsurfit/gsscoeffr.x new file mode 100644 index 00000000..dacb4bd0 --- /dev/null +++ b/math/gsurfit/gsscoeffr.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +procedure gsscoeff (sf, xorder, yorder, coeff) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +real coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gssolve.gx b/math/gsurfit/gssolve.gx new file mode 100644 index 00000000..9008e140 --- /dev/null +++ b/math/gsurfit/gssolve.gx @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +$if (datatype == r) +procedure gssolve (sf, ier) +$else +procedure dgssolve (sf, ier) +$endif + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +$if (datatype == r) +PIXEL gseval() +$else +PIXEL dgseval() +$endif + +begin + if (IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_PIXEL) + call salloc (matrix, ncoeff*ncoeff, TY_PIXEL) + + # eliminate the terms from the vector and matrix + call amov$t (VECTOR(GS_VECTOR(sf)+1), Mem$t[vector], ncoeff) + do i = 0, ncoeff-1 + call amov$t (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Mem$t[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call $tgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + $if (datatype == r) + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + gseval (sf, GS_XREF(sf), GS_YREF(sf)) + $else + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + dgseval (sf, GS_XREF(sf), GS_YREF(sf)) + $endif + call sfree (sp) + } +end diff --git a/math/gsurfit/gssolved.x b/math/gsurfit/gssolved.x new file mode 100644 index 00000000..e3ed43ce --- /dev/null +++ b/math/gsurfit/gssolved.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +procedure dgssolve (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +double dgseval() + +begin + if (IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_DOUBLE) + call salloc (matrix, ncoeff*ncoeff, TY_DOUBLE) + + # eliminate the terms from the vector and matrix + call amovd (VECTOR(GS_VECTOR(sf)+1), Memd[vector], ncoeff) + do i = 0, ncoeff-1 + call amovd (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Memd[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call dgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + dgseval (sf, GS_XREF(sf), GS_YREF(sf)) + call sfree (sp) + } +end diff --git a/math/gsurfit/gssolver.x b/math/gsurfit/gssolver.x new file mode 100644 index 00000000..5135298a --- /dev/null +++ b/math/gsurfit/gssolver.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +procedure gssolve (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +real gseval() + +begin + if (IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_REAL) + call salloc (matrix, ncoeff*ncoeff, TY_REAL) + + # eliminate the terms from the vector and matrix + call amovr (VECTOR(GS_VECTOR(sf)+1), Memr[vector], ncoeff) + do i = 0, ncoeff-1 + call amovr (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Memr[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call rgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + gseval (sf, GS_XREF(sf), GS_YREF(sf)) + call sfree (sp) + } +end diff --git a/math/gsurfit/gsstat.gx b/math/gsurfit/gsstat.gx new file mode 100644 index 00000000..d701ea9e --- /dev/null +++ b/math/gsurfit/gsstat.gx @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSGET -- Procedure to fetch a gsurfit parameter +$if (datatype == r) +real procedure gsgetr (sf, parameter) +$else +double procedure dgsgetd (sf, parameter) +$endif + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +$if (datatype == r) +procedure gsset (sf, parameter, val) +$else +procedure dgsset (sf, parameter, val) +$endif + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +PIXEL val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +$if (datatype == r) +int procedure gsgeti (sf, parameter) +$else +int procedure dgsgeti (sf, parameter) +$endif + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gsstatd.x b/math/gsurfit/gsstatd.x new file mode 100644 index 00000000..b8c551f1 --- /dev/null +++ b/math/gsurfit/gsstatd.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSGET -- Procedure to fetch a gsurfit parameter +double procedure dgsgetd (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +procedure dgsset (sf, parameter, val) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +double val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +int procedure dgsgeti (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gsstatr.x b/math/gsurfit/gsstatr.x new file mode 100644 index 00000000..826bcafa --- /dev/null +++ b/math/gsurfit/gsstatr.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSGET -- Procedure to fetch a gsurfit parameter +real procedure gsgetr (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +procedure gsset (sf, parameter, val) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +real val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +int procedure gsgeti (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gssub.gx b/math/gsurfit/gssub.gx new file mode 100644 index 00000000..533417a7 --- /dev/null +++ b/math/gsurfit/gssub.gx @@ -0,0 +1,198 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +$if (datatype == r) +procedure gssub (sf1, sf2, sf3) +$else +procedure dgssub (sf1, sf2, sf3) +$endif + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequal$t() +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { +$if (datatype == r) + ncoeff = gsgeti (sf2, GSNSAVE) +$else + ncoeff = dgsgeti (sf2, GSNSAVE) +$endif + call smark (sp) + $if (datatype == r) + call salloc (coeff, ncoeff, TY_REAL) + $else + call salloc (coeff, ncoeff, TY_DOUBLE) + $endif + call gssave (sf2, Mem$t[coeff]) + $if (datatype == r) + call amulk$t (Mem$t[coeff], -1.0, Mem$t[coeff], ncoeff) + $else + call amulk$t (Mem$t[coeff], -1.0d0, Mem$t[coeff], ncoeff) + $endif + call gsrestore (sf3, Mem$t[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequal$t (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequal$t (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + $if (datatype == r) + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + $else + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + $endif + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amov$t (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asub$t (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gssubd.x b/math/gsurfit/gssubd.x new file mode 100644 index 00000000..7f4dd1ba --- /dev/null +++ b/math/gsurfit/gssubd.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure dgssub (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequald() +int dgsgeti() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + ncoeff = dgsgeti (sf2, GSNSAVE) + call smark (sp) + call salloc (coeff, ncoeff, TY_DOUBLE) + call gssave (sf2, Memd[coeff]) + call amulkd (Memd[coeff], -1.0d0, Memd[coeff], ncoeff) + call gsrestore (sf3, Memd[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequald (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequald (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovd (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asubd (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gssubr.x b/math/gsurfit/gssubr.x new file mode 100644 index 00000000..748f7bee --- /dev/null +++ b/math/gsurfit/gssubr.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure gssub (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequalr() +int gsgeti() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + ncoeff = gsgeti (sf2, GSNSAVE) + call smark (sp) + call salloc (coeff, ncoeff, TY_REAL) + call gssave (sf2, Memr[coeff]) + call amulkr (Memr[coeff], -1.0, Memr[coeff], ncoeff) + call gsrestore (sf3, Memr[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequalr (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequalr (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovr (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asubr (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsurfit.h b/math/gsurfit/gsurfit.h new file mode 100644 index 00000000..5d46762b --- /dev/null +++ b/math/gsurfit/gsurfit.h @@ -0,0 +1,48 @@ +# definitions for the gsurfit package + +# define the permitted types of curves + +define GS_FUNCTIONS "|chebyshev|legendre|polynomial|" +define GS_CHEBYSHEV 1 # chebyshev polynomials +define GS_LEGENDRE 2 # legendre polynomials +define GS_POLYNOMIAL 3 # power series polynomials +define NTYPES 3 + +# define the xterms flags + +define GS_XTYPES "|none|full|half|" +define GS_XNONE 0 # no x-terms (old NO) +define GS_XFULL 1 # full x-terms (new YES) +define GS_XHALF 2 # half x-terms (new) + +# define the weighting flags + +define GS_WEIGHTS "|user|uniform|spacing|" +define WTS_USER 1 # user enters weights +define WTS_UNIFORM 2 # equal weights +define WTS_SPACING 3 # weight proportional to spacing of data points + +# error conditions + +define SINGULAR 1 +define NO_DEG_FREEDOM 2 + +# gsstat/gsset definitions + +define GSTYPE 1 +define GSXORDER 2 +define GSYORDER 3 +define GSXTERMS 4 +define GSNXCOEFF 5 +define GSNYCOEFF 6 +define GSNCOEFF 7 +define GSNSAVE 8 +define GSXMIN 9 +define GSXMAX 10 +define GSYMIN 11 +define GSYMAX 12 +define GSXREF 13 +define GSYREF 14 +define GSZREF 15 + +define GS_SAVECOEFF 8 diff --git a/math/gsurfit/gsurfitdef.h b/math/gsurfit/gsurfitdef.h new file mode 100644 index 00000000..7ee6cc1d --- /dev/null +++ b/math/gsurfit/gsurfitdef.h @@ -0,0 +1,61 @@ +# Header file for the surface fitting package + +# set up the curve descriptor structure + +define LEN_GSSTRUCT 64 + +define GS_TYPE Memi[$1] # Type of curve to be fitted +define GS_XORDER Memi[$1+1] # Order of the fit in x +define GS_YORDER Memi[$1+2] # Order of the fit in y +define GS_XTERMS Memi[$1+3] # Cross terms for polynomials +define GS_NXCOEFF Memi[$1+4] # Number of x coefficients +define GS_NYCOEFF Memi[$1+5] # Number of y coefficients +define GS_NCOEFF Memi[$1+6] # Total number of coefficients +define GS_XREF Memr[P2R($1+7)] # x reference value +define GS_YREF Memr[P2R($1+8)] # y reference value +define GS_ZREF Memr[P2R($1+9)] # z reference value +define GS_XMAX Memr[P2R($1+10)]# Maximum x value +define GS_XMIN Memr[P2R($1+11)]# Minimum x value +define GS_YMAX Memr[P2R($1+12)]# Maximum y value +define GS_YMIN Memr[P2R($1+13)]# Minimum y value +define GS_XRANGE Memr[P2R($1+14)]# 2. / (xmax - xmin), polynomials +define GS_XMAXMIN Memr[P2R($1+15)]# - (xmax + xmin) / 2., polynomials +define GS_YRANGE Memr[P2R($1+16)]# 2. / (ymax - ymin), polynomials +define GS_YMAXMIN Memr[P2R($1+17)]# - (ymax + ymin) / 2., polynomials +define GS_NPTS Memi[$1+18] # Number of data points + +define GS_MATRIX Memi[$1+19] # Pointer to original matrix +define GS_CHOFAC Memi[$1+20] # Pointer to Cholesky factorization +define GS_VECTOR Memi[$1+21] # Pointer to vector +define GS_COEFF Memi[$1+22] # Pointer to coefficient vector +define GS_XBASIS Memi[$1+23] # Pointer to basis functions (all x) +define GS_YBASIS Memi[$1+24] # Pointer to basis functions (all y) +define GS_WZ Memi[$1+25] # Pointer to w * z (gsrefit) + +# matrix and vector element definitions + +define XBASIS Memr[P2P($1)] # Non zero basis for all x +define YBASIS Memr[P2P($1)] # Non zero basis for all y +define XBS Memr[P2P($1)] # Non zero basis for single x +define YBS Memr[P2P($1)] # Non zero basis for single y +define MATRIX Memr[P2P($1)] # Element of MATRIX +define CHOFAC Memr[P2P($1)] # Element of CHOFAC +define VECTOR Memr[P2P($1)] # Element of VECTOR +define COEFF Memr[P2P($1)] # Element of COEFF + +# structure definitions for restore + +define GS_SAVETYPE $1[1] +define GS_SAVEXORDER $1[2] +define GS_SAVEYORDER $1[3] +define GS_SAVEXTERMS $1[4] +define GS_SAVEXMIN $1[5] +define GS_SAVEXMAX $1[6] +define GS_SAVEYMIN $1[7] +define GS_SAVEYMAX $1[8] + +# data type + +define DELTA EPSILON + +# miscellaneous diff --git a/math/gsurfit/gsvector.gx b/math/gsurfit/gsvector.gx new file mode 100644 index 00000000..60044dd6 --- /dev/null +++ b/math/gsurfit/gsvector.gx @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +$if (datatype == r) +procedure gsvector (sf, x, y, zfit, npts) +$else +procedure dgsvector (sf, x, y, zfit, npts) +$endif + +pointer sf # pointer to surface descriptor structure +PIXEL x[ARB] # x value +PIXEL y[ARB] # y value +PIXEL zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call $tgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call $tgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call $tgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gsvectord.x b/math/gsurfit/gsvectord.x new file mode 100644 index 00000000..8bb980e6 --- /dev/null +++ b/math/gsurfit/gsvectord.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +procedure dgsvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +double x[ARB] # x value +double y[ARB] # y value +double zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call dgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call dgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call dgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gsvectorr.x b/math/gsurfit/gsvectorr.x new file mode 100644 index 00000000..38213ecc --- /dev/null +++ b/math/gsurfit/gsvectorr.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +procedure gsvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +real x[ARB] # x value +real y[ARB] # y value +real zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call rgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call rgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call rgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszero.gx b/math/gsurfit/gszero.gx new file mode 100644 index 00000000..e99cbe4d --- /dev/null +++ b/math/gsurfit/gszero.gx @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gszero (sf) +$else +procedure dgszero (sf) +$endif + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclr$t (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclr$t (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszerod.x b/math/gsurfit/gszerod.x new file mode 100644 index 00000000..80c10883 --- /dev/null +++ b/math/gsurfit/gszerod.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "dgsurfitdef.h" + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +procedure dgszero (sf) + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclrd (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclrd (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszeror.x b/math/gsurfit/gszeror.x new file mode 100644 index 00000000..f7c4e5ed --- /dev/null +++ b/math/gsurfit/gszeror.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gsurfitdef.h" + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +procedure gszero (sf) + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclrr (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclrr (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/mkpkg b/math/gsurfit/mkpkg new file mode 100644 index 00000000..f7aaa08f --- /dev/null +++ b/math/gsurfit/mkpkg @@ -0,0 +1,111 @@ +# General surface fitting tools library. + +$checkout libgsurfit.a lib$ +$update libgsurfit.a +$checkin libgsurfit.a lib$ +$exit + +zzdebug: + $update libgsurfit.a + $omake zzdebug.x + $link zzdebug.o libgsurfit.a -o zzdebug + ; + +tfiles: + $set GEN = "$$generic -k -t rd" + + $ifolder (gs_b1evalr.x, gs_b1eval.gx) $(GEN) gs_b1eval.gx $endif + $ifolder (gs_bevalr.x, gs_beval.gx) $(GEN) gs_beval.gx $endif + $ifolder (gs_chomatr.x, gs_chomat.gx) $(GEN) gs_chomat.gx $endif + $ifolder (gs_f1devalr.x, gs_f1deval.gx) $(GEN) gs_f1deval.gx $endif + $ifolder (gs_fevalr.x, gs_feval.gx) $(GEN) gs_feval.gx $endif + $ifolder (gs_fderr.x, gs_fder.gx) $(GEN) gs_fder.gx $endif + $ifolder (gs_devalr.x, gs_deval.gx) $(GEN) gs_deval.gx $endif + $ifolder (gsaccumr.x, gsaccum.gx) $(GEN) gsaccum.gx $endif + $ifolder (gsacptsr.x, gsacpts.gx) $(GEN) gsacpts.gx $endif + $ifolder (gsaddr.x, gsadd.gx) $(GEN) gsadd.gx $endif + $ifolder (gscoeffr.x, gscoeff.gx) $(GEN) gscoeff.gx $endif + $ifolder (gscopyr.x, gscopy.gx) $(GEN) gscopy.gx $endif + $ifolder (gsderr.x, gsder.gx) $(GEN) gsder.gx $endif + $ifolder (gserrorsr.x, gserrors.gx) $(GEN) gserrors.gx $endif + $ifolder (gsevalr.x, gseval.gx) $(GEN) gseval.gx $endif + $ifolder (gsfitr.x, gsfit.gx) $(GEN) gsfit.gx $endif + $ifolder (gsfreer.x, gsfree.gx) $(GEN) gsfree.gx $endif + $ifolder (gsgcoeffr.x, gsgcoeff.gx) $(GEN) gsgcoeff.gx $endif + $ifolder (gsinitr.x, gsinit.gx) $(GEN) gsinit.gx $endif + $ifolder (gsrefitr.x, gsrefit.gx) $(GEN) gsrefit.gx $endif + $ifolder (gsrejectr.x, gsreject.gx) $(GEN) gsreject.gx $endif + $ifolder (gsrestorer.x, gsrestore.gx) $(GEN) gsrestore.gx $endif + $ifolder (gssaver.x, gssave.gx) $(GEN) gssave.gx $endif + $ifolder (gsscoeffr.x, gsscoeff.gx) $(GEN) gsscoeff.gx $endif + $ifolder (gssolver.x, gssolve.gx) $(GEN) gssolve.gx $endif + $ifolder (gsstatr.x, gsstat.gx) $(GEN) gsstat.gx $endif + $ifolder (gssubr.x, gssub.gx) $(GEN) gssub.gx $endif + $ifolder (gsvectorr.x, gsvector.gx) $(GEN) gsvector.gx $endif + $ifolder (gszeror.x, gszero.gx) $(GEN) gszero.gx $endif + ; + +libgsurfit.a: + + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + gs_b1evalr.x + gs_bevalr.x + gs_chomatr.x gsurfitdef.h + gs_f1devalr.x + gs_fevalr.x + gs_fderr.x + gs_devalr.x + gsaccumr.x gsurfitdef.h + gsacptsr.x gsurfitdef.h + gsaddr.x gsurfitdef.h + gscoeffr.x gsurfitdef.h + gscopyr.x gsurfitdef.h + gsderr.x gsurfitdef.h + gserrorsr.x gsurfitdef.h + gsevalr.x gsurfitdef.h + gsfitr.x gsurfitdef.h + gsfreer.x gsurfitdef.h + gsgcoeffr.x gsurfitdef.h + gsinitr.x gsurfitdef.h + gsrefitr.x gsurfitdef.h + gsrejectr.x gsurfitdef.h + gsrestorer.x gsurfitdef.h + gssaver.x gsurfitdef.h + gsscoeffr.x gsurfitdef.h + gssolver.x gsurfitdef.h + gsstatr.x gsurfitdef.h + gssubr.x gsurfitdef.h + gsvectorr.x gsurfitdef.h + gszeror.x gsurfitdef.h + + gs_b1evald.x + gs_bevald.x + gs_chomatd.x dgsurfitdef.h + gs_f1devald.x + gs_fevald.x + gs_fderd.x + gs_devald.x + gsaccumd.x dgsurfitdef.h + gsacptsd.x dgsurfitdef.h + gsaddd.x dgsurfitdef.h + gscoeffd.x dgsurfitdef.h + gscopyd.x dgsurfitdef.h + gsderd.x dgsurfitdef.h + gserrorsd.x dgsurfitdef.h + gsevald.x dgsurfitdef.h + gsfitd.x dgsurfitdef.h + gsfreed.x dgsurfitdef.h + gsgcoeffd.x dgsurfitdef.h + gsinitd.x dgsurfitdef.h + gsrefitd.x dgsurfitdef.h + gsrejectd.x dgsurfitdef.h + gsrestored.x dgsurfitdef.h + gssaved.x dgsurfitdef.h + gsscoeffd.x dgsurfitdef.h + gssolved.x dgsurfitdef.h + gsstatd.x dgsurfitdef.h + gssubd.x dgsurfitdef.h + gsvectord.x dgsurfitdef.h + gszerod.x dgsurfitdef.h + ; diff --git a/math/gsurfit/zzdebug.x b/math/gsurfit/zzdebug.x new file mode 100644 index 00000000..522da747 --- /dev/null +++ b/math/gsurfit/zzdebug.x @@ -0,0 +1,348 @@ +task test = t_test + +include + +procedure t_test() + +int i, j, k +int xorder, yorder, xterms, stype +int ncoeff, maxorder, xincr, npts, stype1, ier +pointer gs, ags, sgs +double dx, dy, const, accum, sum, rms1, rms2 +double x[121], y[121], z[121], w[121], zfit[121], coeff[121], save[121] +int clgeti() +double dgseval(), dgsgcoeff() + +begin + # Generate x and y grid. + dy = -1.0d0 + npts = 0 + do i = 1, 9 { + dx = -1.0d0 + do j = 1, 9 { + x[npts+1] = dx + y[npts+1] = dy + npts = npts + 1 + dx = dx + 0.25d0 + } + dy = dy + 0.25d0 + } + + stype = clgeti ("stype") + xorder = clgeti ("xorder") + yorder = clgeti ("yorder") + xterms = clgeti ("xterms") + call printf ("\n\nSURFACE: %d XORDER: %d YORDER: %d XTERMS: %d\n") + call pargi (stype) + call pargi (xorder) + call pargi (yorder) + call pargi (xterms) + + # Generate data + if (stype > 3) { + switch (xterms) { + case GS_XNONE: + + do i = 1, npts { + sum = 0.0d0 + do j = 2, yorder + sum = sum + j * y[i] ** (j - 1) + do j = 2, xorder + sum = sum + j * x[i] ** (j - 1) + z[i] = sum + } + + case GS_XHALF: + + maxorder = max (xorder + 1, yorder + 1) + do i = 1, npts { + sum = 0.0d0 + xincr = xorder + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum= 0.0d0 + do k = 1, xincr { + if (j > 1 || k > 1) + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + if ((j + xorder + 1) > maxorder) + xincr = xincr - 1 + } + z[i] = sum + } + + case GS_XFULL: + + do i = 1, npts { + sum = 0.0d0 + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum = 0.0d0 + do k = 1, xorder { + if (j > 1 || k > 1) + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + } + z[i] = sum + } + } + + stype1 = stype - 3 + } else { + switch (xterms) { + case GS_XNONE: + + do i = 1, npts { + sum = 0.0d0 + do j = 2, yorder + sum = sum + j * y[i] ** (j - 1) + do j = 1, xorder + sum = sum + j * x[i] ** (j - 1) + z[i] = sum + } + + case GS_XHALF: + + maxorder = max (xorder + 1, yorder + 1) + do i = 1, npts { + sum = 0.0d0 + xincr = xorder + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum= 0.0d0 + do k = 1, xincr { + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + if ((j + xorder + 1) > maxorder) + xincr = xincr - 1 + } + z[i] = sum + } + + case GS_XFULL: + + do i = 1, npts { + sum = 0.0d0 + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum = 0.0d0 + do k = 1, xorder { + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + } + z[i] = sum + } + } + + stype1 = stype + } + + # Print out the data. + call printf ("\nXIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (x[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call printf ("\nYIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (y[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call printf ("\nZIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (z[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + # Fit surface. + call dgsinit (gs, stype1, xorder, yorder, xterms, -1.0d0, 1.0d0, + -1.0d0, 1.0d0) + if (stype > 3) { + call dgsset (gs, GSXREF, 0d0) + call dgsset (gs, GSYREF, 0d0) + call dgsset (gs, GSZREF, 0d0) + } + call dgsfit (gs, x, y, z, w, npts, WTS_UNIFORM, ier) + call printf ("\nFIT ERROR CODE: %d\n") + call pargi (ier) + + # Evaluate the fit and its rms. + call dgsvector (gs, x, y, zfit, npts) + call printf ("\nZFIT:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + rms1 = 0.0d0 + do i = 1, npts + rms1 = rms1 + (z[i] - zfit[i]) ** 2 + rms1 = sqrt (rms1 / (npts - 1)) + rms2 = 0.0d0 + do i = 1, npts + rms2 = rms2 + (z[i] - dgseval (gs, x[i], y[i])) ** 2 + rms2 = sqrt (rms2 / (npts - 1)) + #call printf ("\nRMS: vector = %0.14g point = %0.14g\n\n") + call printf ("\nRMS: vector = %0.4f point = %0.4f\n\n") + call pargd (rms1) + call pargd (rms2) + + # Print the coefficients. + call dgscoeff (gs, coeff, ncoeff) + call printf ("GSFIT coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + call dgsfree (gs) + return + + # Evaluate the first derivatives. + call dgsder (gs, x, y, zfit, npts, 1, 0) + call printf ("\nZDER: 1 0\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call dgsder (gs, x, y, zfit, npts, 0, 1) + call printf ("\nZDER: 0 1\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call dgsder (gs, x, y, zfit, npts, 1, 1) + call printf ("\nZDER: 1 1\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + # Refit the surface point by point. + call dgszero (gs) + do i = 1, npts { + call dgsaccum (gs, x[i], y[i], z[i], w[i], WTS_UNIFORM) + } + if (stype > 3) + call dgssolve1 (gs, ier) + else + call dgssolve (gs, ier) + call printf ("\nACCUM FIT ERROR CODE: %d\n") + call pargi (ier) + call dgsrej (gs, x[1], y[1], z[1], w[1], WTS_UNIFORM) + call dgsrej (gs, x[npts], y[npts], z[npts], w[npts], WTS_UNIFORM) + call dgsaccum (gs, x[1], y[1], z[1], w[1], WTS_UNIFORM) + call dgsaccum (gs, x[npts], y[npts], z[npts], w[npts], WTS_UNIFORM) + call dgssolve (gs, ier) + call printf ("\nREJ FIT ERROR CODE: %d\n") + call pargi (ier) + + call dgscoeff (gs, coeff, ncoeff) + call printf ("GSACCUM coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + # Save and restore. + call dgssave (gs, save) + call dgsfree (gs) + call dgsrestore (gs, save) + + call dgscoeff (gs, coeff, ncoeff) + call printf ("RESTORE coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + # Add two surfaces. + call dgsadd (gs, gs, ags) + call dgscoeff (ags, coeff, ncoeff) + call printf ("GSADD coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (ags, 1, 1)) + call pargd (dgsgcoeff (ags, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (ags, 1, yorder)) + call pargd (dgsgcoeff (ags, xorder, yorder)) + call printf ("\n") + + # Subtract two surfaces. + call dgssub (gs, gs, sgs) + call dgscoeff (sgs, coeff, ncoeff) + call printf ("GSSUB coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (sgs, 1, 1)) + call pargd (dgsgcoeff (sgs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (sgs, 1, yorder)) + call pargd (dgsgcoeff (sgs, xorder, yorder)) + call printf ("\n") + + call dgsfree (gs) + call dgsfree (ags) + call dgsfree (sgs) +end diff --git a/math/ieee/README b/math/ieee/README new file mode 100644 index 00000000..80b30bfd --- /dev/null +++ b/math/ieee/README @@ -0,0 +1,8 @@ + This directory contians programs and subroutines from the +text "Programs for Digital Signal Processing" by the IEEE Press. +Directories of the name "chap*" correspond to each chapter of +the text. + The files "*mach*" are the machine dependent routines which +should be edited for the hardware which you are going to run the +routines on. The file "uni.c" is a uniform random number generator, +not the one from the text, but one which uses the UNIX generator. diff --git a/math/ieee/chap1/README b/math/ieee/chap1/README new file mode 100644 index 00000000..bf86b45f --- /dev/null +++ b/math/ieee/chap1/README @@ -0,0 +1,14 @@ + This directory contains the IEEE routines from Chapter 1 - +Discrete Fourier Transform Programs. Some of the routines are +provided here as separete files (fourea.f, wfta.f, ...) but are +purposely not put into the library, as these routines are not for +general use (fourea.f is an inefficient, demonstration version; +wfta.f is the Winograd DFT which is slower than the regular DFT +and uses far too much memory ona 16-bit machine to be of +practical use; ...). + The directory "test" contains the test routines from the chapter. +The directory "time" contains some routines to time various of the +routines. + The file "compall" compiles the appropiate routines and then +"mklib" will make the library, which one will probably want to +move to "/usr/lib/libieee.a". diff --git a/math/ieee/chap1/const.f b/math/ieee/chap1/const.f new file mode 100644 index 00000000..54eb4e41 --- /dev/null +++ b/math/ieee/chap1/const.f @@ -0,0 +1,114 @@ +c +c----------------------------------------------------------------------- +c subroutine: const +c computes the multipliers for the various modules +c----------------------------------------------------------------------- +c + subroutine const(co3,co8,co16,co9,cdc,cdd) + double precision dtheta,dtwopi,dsq32,dsq2 + double precision dcos1,dcos2,dcos3,dcos4 + double precision dsin1,dsin2,dsin3,dsin4 + dimension co3(3),co8(8),co16(18),co9(11),cdc(9),cdd(6) + dtwopi=8.0d0*datan(1.0d0) + dsq32=dsqrt(0.75d0) + dsq2=dsqrt(0.5d0) +c +c multipliers for the three point module +c + co3(1)=1.0 + co3(2)=-1.5 + co3(3)=-dsq32 +c +c multipliers for the five point module +c + dtheta=dtwopi/5.0d0 + dcos1=dcos(dtheta) + dcos2=dcos(2.0d0*dtheta) + dsin1=dsin(dtheta) + dsin2=dsin(2.0d0*dtheta) + cdd(1)=1.0 + cdd(2)=-1.25 + cdd(3)=-dsin1-dsin2 + cdd(4)=0.5*(dcos1-dcos2) + cdd(5)=dsin1-dsin2 + cdd(6)=dsin2 +c +c +c multipliers for the seven point module +c + dtheta=dtwopi/7.0d0 + dcos1=dcos(dtheta) + dcos2=dcos(2.0d0*dtheta) + dcos3=dcos(3.0d0*dtheta) + dsin1=dsin(dtheta) + dsin2=dsin(2.0d0*dtheta) + dsin3=dsin(3.0d0*dtheta) + cdc(1)=1.0 + cdc(2)=-7.0d0/6.0d0 + cdc(3)=-(dsin1+dsin2-dsin3)/3.0d0 + cdc(4)=(dcos1+dcos2-2.0d0*dcos3)/3.0d0 + cdc(5)=(2.0d0*dcos1-dcos2-dcos3)/3.0d0 + cdc(6)=-(2.0d0*dsin1-dsin2+dsin3)/3.0d0 + cdc(7)=-(dsin1+dsin2+2.0d0*dsin3)/3.0d0 + cdc(8)=(dcos1-2.0d0*dcos2+dcos3)/3.0d0 + cdc(9)=-(dsin1-2.0d0*dsin2-dsin3)/3.0d0 +c +c multipliers for the eight point module +c + co8(1)=1.0 + co8(2)=1.0 + co8(3)=1.0 + co8(4)=-1.0 + co8(5)=1.0 + co8(6)=-dsq2 + co8(7)=-1.0 + co8(8)=dsq2 +c +c multipliers for the nine point module +c + dtheta=dtwopi/9.0d0 + dcos1=dcos(dtheta) + dcos2=dcos(2.0d0*dtheta) + dcos4=dcos(4.0d0*dtheta) + dsin1=dsin(dtheta) + dsin2=dsin(2.0d0*dtheta) + dsin4=dsin(4.0d0*dtheta) + co9(1)=1.0 + co9(2)=-1.5 + co9(3)=-dsq32 + co9(4)=0.5 + co9(5)=(2.0d0*dcos1-dcos2-dcos4)/3.0d0 + co9(6)=(dcos1-2.0d0*dcos2+dcos4)/3.0d0 + co9(7)=(dcos1+dcos2-2.0d0*dcos4)/3.0d0 + co9(8)=-(2.0d0*dsin1+dsin2-dsin4)/3.0d0 + co9(9)=-(dsin1+2.0d0*dsin2+dsin4)/3.0d0 + co9(10)=-(dsin1-dsin2-2.0d0*dsin4)/3.0d0 + co9(11)=-dsq32 +c +c multipliers for the sixteen point module +c + dtheta=dtwopi/16.0d0 + dcos1=dcos(dtheta) + dcos3=dcos(3.0d0*dtheta) + dsin1=dsin(dtheta) + dsin3=dsin(3.0d0*dtheta) + co16(1)=1.0 + co16(2)=1.0 + co16(3)=1.0 + co16(4)=-1.0 + co16(5)=1.0 + co16(6)=-dsq2 + co16(7)=-1.0 + co16(8)=dsq2 + co16(9)=1.0 + co16(10)=-(dsin1-dsin3) + co16(11)=-dsq2 + co16(12)=-co16(10) + co16(13)=-1.0 + co16(14)=-(dsin1+dsin3) + co16(15)=dsq2 + co16(16)=-co16(14) + co16(17)=-dsin3 + co16(18)=dcos3 + return + end diff --git a/math/ieee/chap1/fast.f b/math/ieee/chap1/fast.f new file mode 100644 index 00000000..9a0ad713 --- /dev/null +++ b/math/ieee/chap1/fast.f @@ -0,0 +1,73 @@ +c +c----------------------------------------------------------------------- +c subroutine: fast +c replaces the real vector b(k), for k=1,2,...,n, +c with its finite discrete fourier transform +c----------------------------------------------------------------------- +c + subroutine fast(b, n) +c +c the dc term is returned in location b(1) with b(2) set to 0. +c thereafter the jth harmonic is returned as a complex +c number stored as b(2*j+1) + i b(2*j+2). +c the n/2 harmonic is returned in b(n+1) with b(n+2) set to 0. +c hence, b must be dimensioned to size n+2. +c the subroutine is called as fast(b,n) where n=2**m and +c b is the real array described above. +c + dimension b(2) + common /cons/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + do 10 i=1,15 + m = i + nt = 2**i + if (n.eq.nt) go to 20 + 10 continue + write (iw,9999) +9999 format (33h n is not a power of two for fast) + stop + 20 n4pow = m/2 +c +c do a radix 2 iteration first if one is required. +c + if (m-n4pow*2) 40, 40, 30 + 30 nn = 2 + int = n/nn + call fr2tr(int, b(1), b(int+1)) + go to 50 + 40 nn = 1 +c +c perform radix 4 iterations. +c + 50 if (n4pow.eq.0) go to 70 + do 60 it=1,n4pow + nn = nn*4 + int = n/nn + call fr4tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1), + * b(1), b(int+1), b(2*int+1), b(3*int+1)) + 60 continue +c +c perform in-place reordering. +c + 70 call ford1(m, b) + call ford2(m, b) + t = b(2) + b(2) = 0. + b(n+1) = t + b(n+2) = 0. + do 80 it=4,n,2 + b(it) = -b(it) + 80 continue + return + end diff --git a/math/ieee/chap1/ffa.f b/math/ieee/chap1/ffa.f new file mode 100644 index 00000000..dd62ea01 --- /dev/null +++ b/math/ieee/chap1/ffa.f @@ -0,0 +1,84 @@ +c +c----------------------------------------------------------------------- +c subroutine: ffa +c fast fourier analysis subroutine +c----------------------------------------------------------------------- +c + subroutine ffa(b, nfft) +c +c this subroutine replaces the real vector b(k), (k=1,2,...,n), +c with its finite discrete fourier transform. the dc term is +c returned in location b(1) with b(2) set to 0. thereafter, the +c jth harmonic is returned as a complex number stored as +c b(2*j+1) + i b(2*j+2). note that the n/2 harmonic is returned +c in b(n+1) with b(n+2) set to 0. hence, b must be dimensioned +c to size n+2. +c subroutine is called as ffa (b,n) where n=2**m and b is an +c n term real array. a real-valued, radix 8 algorithm is used +c with in-place reordering and the trig functions are computed as +c needed. +c + dimension b(2) + common /con/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,15 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue + write (iw,9999) +9999 format (30h nfft not a power of 2 for ffa) + stop + 20 continue + n8pow = m/3 +c +c do a radix 2 or radix 4 iteration first if one is required +c + if (m-n8pow*3-1) 50, 40, 30 + 30 nn = 4 + int = n/nn + call r4tr(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 60 + 40 nn = 2 + int = n/nn + call r2tr(int, b(1), b(int+1)) + go to 60 + 50 nn = 1 +c +c perform radix 8 iterations +c + 60 if (n8pow) 90, 90, 70 + 70 do 80 it=1,n8pow + nn = nn*8 + int = n/nn + call r8tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + 80 continue +c +c perform in-place reordering +c + 90 call ord1(m, b) + call ord2(m, b) + t = b(2) + b(2) = 0. + b(nfft+1) = t + b(nfft+2) = 0. + do 100 i=4,nfft,2 + b(i) = -b(i) + 100 continue + return + end diff --git a/math/ieee/chap1/ffs.f b/math/ieee/chap1/ffs.f new file mode 100644 index 00000000..2858fdb0 --- /dev/null +++ b/math/ieee/chap1/ffs.f @@ -0,0 +1,80 @@ +c +c----------------------------------------------------------------------- +c subroutine: ffs +c fast fourier synthesis subroutine +c radix 8-4-2 +c----------------------------------------------------------------------- +c + subroutine ffs(b, nfft) +c +c this subroutine synthesizes the real vector b(k), where +c k=1,2,...,n. the initial fourier coefficients are placed in +c the b array of size n+2. the dc term is in b(1) with +c b(2) equal to 0. +c the jth harmonic is stored as b(2*j+1) + i b(2*j+2). +c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0. +c the subroutine is called as ffs(b,n) where n=2**m and +c b is the n term real array discussed above. +c + dimension b(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,15 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue + write (iw,9999) +9999 format (30h nfft not a power of 2 for ffs) + stop + 20 continue + b(2) = b(nfft+1) + do 30 i=1,nfft + b(i) = b(i)/float(nfft) + 30 continue + do 40 i=4,nfft,2 + b(i) = -b(i) + 40 continue + n8pow = m/3 +c +c reorder the input fourier coefficients +c + call ord2(m, b) + call ord1(m, b) +c + if (n8pow.eq.0) go to 60 +c +c perform the radix 8 iterations +c + nn = n + do 50 it=1,n8pow + int = n/nn + call r8syn(int, nn, b, b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + nn = nn/8 + 50 continue +c +c do a radix 2 or radix 4 iteration if one is required +c + 60 if (m-n8pow*3-1) 90, 80, 70 + 70 int = n/4 + call r4syn(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 90 + 80 int = n/2 + call r2tr(int, b(1), b(int+1)) + 90 return + end diff --git a/math/ieee/chap1/fft842.f b/math/ieee/chap1/fft842.f new file mode 100644 index 00000000..37a3a651 --- /dev/null +++ b/math/ieee/chap1/fft842.f @@ -0,0 +1,116 @@ +c +c----------------------------------------------------------------------- +c subroutine: fft842 +c fast fourier transform for n=2**m +c complex input +c----------------------------------------------------------------------- +c + subroutine fft842(in, n, x, y) +c +c this program replaces the vector z=x+iy by its finite +c discrete, complex fourier transform if in=0. the inverse transform +c is calculated for in=1. it performs as many base +c 8 iterations as possible and then finishes with a base 4 iteration +c or a base 2 iteration if needed. +c +c the subroutine is called as subroutine fft842 (in,n,x,y). +c the integer n (a power of 2), the n real location array x, and +c the n real location array y must be supplied to the subroutine. +c + dimension x(2), y(2), l(15) + common /con2/ pi2, p7 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + pi2 = 8.*atan(1.) + p7 = 1./sqrt(2.) + do 10 i=1,15 + m = i + nt = 2**i + if (n.eq.nt) go to 20 + 10 continue + write (iw,9999) +9999 format (35h n is not a power of two for fft842) + stop + 20 n2pow = m + nthpo = n + fn = nthpo + if (in.eq.1) go to 40 + do 30 i=1,nthpo + y(i) = -y(i) + 30 continue + 40 n8pow = n2pow/3 + if (n8pow.eq.0) go to 60 +c +c radix 8 passes,if any. +c + do 50 ipass=1,n8pow + nxtlt = 2**(n2pow-3*ipass) + lengt = 8*nxtlt + call r8tx(nxtlt, nthpo, lengt, x(1), x(nxtlt+1), x(2*nxtlt+1), + * x(3*nxtlt+1), x(4*nxtlt+1), x(5*nxtlt+1), x(6*nxtlt+1), + * x(7*nxtlt+1), y(1), y(nxtlt+1), y(2*nxtlt+1), y(3*nxtlt+1), + * y(4*nxtlt+1), y(5*nxtlt+1), y(6*nxtlt+1), y(7*nxtlt+1)) + 50 continue +c +c is there a four factor left +c + 60 if (n2pow-3*n8pow-1) 90, 70, 80 +c +c go through the base 2 iteration +c +c + 70 call r2tx(nthpo, x(1), x(2), y(1), y(2)) + go to 90 +c +c go through the base 4 iteration +c + 80 call r4tx(nthpo, x(1), x(2), x(3), x(4), y(1), y(2), y(3), y(4)) +c + 90 do 110 j=1,15 + l(j) = 1 + if (j-n2pow) 100, 100, 110 + 100 l(j) = 2**(n2pow+1-j) + 110 continue + ij = 1 + do 130 j1=1,l1 + do 130 j2=j1,l2,l1 + do 130 j3=j2,l3,l2 + do 130 j4=j3,l4,l3 + do 130 j5=j4,l5,l4 + do 130 j6=j5,l6,l5 + do 130 j7=j6,l7,l6 + do 130 j8=j7,l8,l7 + do 130 j9=j8,l9,l8 + do 130 j10=j9,l10,l9 + do 130 j11=j10,l11,l10 + do 130 j12=j11,l12,l11 + do 130 j13=j12,l13,l12 + do 130 j14=j13,l14,l13 + do 130 ji=j14,l15,l14 + if (ij-ji) 120, 130, 130 + 120 r = x(ij) + x(ij) = x(ji) + x(ji) = r + fi = y(ij) + y(ij) = y(ji) + y(ji) = fi + 130 ij = ij + 1 + if (in.eq.1) go to 150 + do 140 i=1,nthpo + y(i) = -y(i) + 140 continue + go to 170 + 150 do 160 i=1,nthpo + x(i) = x(i)/fn + y(i) = y(i)/fn + 160 continue + 170 return + end diff --git a/math/ieee/chap1/fftaoh.f b/math/ieee/chap1/fftaoh.f new file mode 100644 index 00000000..f703c98b --- /dev/null +++ b/math/ieee/chap1/fftaoh.f @@ -0,0 +1,82 @@ +c +c----------------------------------------------------------------------- +c subroutine: fftaoh +c compute dft for real, antisymmetric, odd harmonic, n-point sequence +c using n/4-point fft +c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1 +c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m) +c x(m) has the property x(m)=x(n/2-m), m=0,1,...,n/4-1, x(0)=0 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine fftaoh(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the (n/4+1) points of the +c input sequence (antisymmetrical) +c on output x contains the n/4 imaginary points of the odd +c harmonics of the transform of the input--i.e. the zero +c valued real parts are not given nor are the zero-valued +c even harmonics +c n = true size of input +c y = scratch array of size n/4+2 +c +c +c handle n = 2 and n = 4 cases separately +c + if (n.gt.4) go to 20 + if (n.eq.4) go to 10 +c +c for n=2, assume x(1)=0, x(2)=0, compute dft directly +c + x(1) = 0. + return +c +c n = 4 case, assume x(1)=x(3)=0, x(2)=-x(4)=x0, compute dft directly +c + 10 x(1) = -2.*x(2) + return + 20 twopi = 8.*atan(1.0) +c +c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1)) +c + no2 = n/2 + no4 = n/4 + no8 = n/8 + if (no8.eq.1) go to 40 + do 30 i=2,no8 + ind = 2*i + t1 = x(ind) - x(ind-2) + y(i) = x(ind-1) + t1 + ind1 = n/4 + 2 - i + y(ind1) = x(ind-1) - t1 + 30 continue + 40 y(1) = 2.*x(2) + y(no8+1) = x(no4+1) +c +c the sequence y (n/4 points) has only odd harmonics +c call subroutine fftohm to exploit odd harmonics +c + call fftohm(y, no2) +c +c form original dft from complex odd harmonics of y(k) +c by unscrambling y(k) +c + tpn = twopi/float(n) + cosi = 2.*cos(tpn) + sini = 2.*sin(tpn) + cosd = cos(tpn*2.) + sind = sin(tpn*2.) + do 50 i=1,no8 + ind = 2*i + bk = y(ind-1)/sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + ak = y(ind) + x(i) = ak - bk + ind1 = n/4 + 1 - i + x(ind1) = -ak - bk + 50 continue + return + end diff --git a/math/ieee/chap1/fftasm.f b/math/ieee/chap1/fftasm.f new file mode 100644 index 00000000..30c84b79 --- /dev/null +++ b/math/ieee/chap1/fftasm.f @@ -0,0 +1,67 @@ +c +c----------------------------------------------------------------------- +c subroutine: fftasm +c compute dft for real, antisymmetric, n-point sequence x(m) using +c n/2-point fft +c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine fftasm(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/2 points of the +c input sequence (asymmetrical) +c on output x contains the n/2+1 imaginary points of the transform +c of the input--i.e. the zero valued real parts are not returned +c n = true size of input +c y = scratch array of size n/2+2 +c +c +c for n = 2, assume x(1)=0, x(2)=0, compute dft directly +c + if (n.eq.2) go to 30 + twopi = 8.*atan(1.0) +c +c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1)) +c + no2 = n/2 + no4 = n/4 + do 10 i=2,no4 + ind = 2*i + t1 = x(ind) - x(ind-2) + y(i) = x(ind-1) + t1 + ind1 = no2 + 2 - i + y(ind1) = -x(ind-1) + t1 + 10 continue + y(1) = 2.*x(2) + y(no4+1) = -2.*x(no2) +c +c take n/2 point (real) fft of y +c + call fast(y, no2) +c +c form original dft by unscrambling y(k) +c use recursion relation to generate sin(tpn*i) multiplier +c + tpn = twopi/float(n) + cosi = 2.*cos(tpn) + sini = 2.*sin(tpn) + cosd = cosi/2. + sind = sini/2. + nind = no4 + 1 + do 20 i=2,nind + ind = 2*i + bk = y(ind-1)/sini + ak = y(ind) + x(i) = ak - bk + ind1 = no2 + 2 - i + x(ind1) = -ak - bk + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 20 continue + 30 x(1) = 0. + x(no2+1) = 0. + return + end diff --git a/math/ieee/chap1/fftohm.f b/math/ieee/chap1/fftohm.f new file mode 100644 index 00000000..6e3ecc9d --- /dev/null +++ b/math/ieee/chap1/fftohm.f @@ -0,0 +1,101 @@ +c +c----------------------------------------------------------------------- +c subroutine: fftohm +c compute dft for real, n-point, odd harmonic sequences using an +c n/2 point fft +c odd harmonic means x(2*k)=0, all k where x(k) is the dft of x(m) +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine fftohm(x, n) + dimension x(1) +c +c x = real array which on input contains the first n/2 points of the +c input +c on output x contains the n/4 complex values of the odd +c harmonics of the input--stored in the sequence re(x(1)),im(x(1)), +c re(x(2)),im(x(2)),... +c ****note: x must be dimensioned to size n/2+2 for fft routine +c n = true size of x sequence +c +c first compute real(x(1)) and real(x(n/2-1)) separately +c also simultaneously multiply original sequence by sin(twopi*(m-1)/n) +c sin and cos are computed recursively +c +c +c for n = 2, assume x(1)=x0, x(2)=-x0, compute dft directly +c + if (n.gt.2) go to 10 + x(1) = 2.*x(1) + x(2) = 0. + return + 10 twopi = 8.*atan(1.0) + tpn = twopi/float(n) +c +c compute x1=real(x(1)) and x2=imaginary(x(n/2-1)) +c x(n) = x(n)*4.*sin(twopi*(i-1)/n) +c + t1 = 0. +c +c cosd and sind are multipliers for recursion for sin and cos +c cosi and sini are initial conditions for recursion for sin and cos +c + cosd = cos(tpn*2.) + sind = sin(tpn*2.) + cosi = 1. + sini = 0. + no2 = n/2 + do 20 i=1,no2,2 + t = x(i)*cosi + x(i) = x(i)*4.*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + t1 = t1 + t + 20 continue +c +c reset initial conditions (cosi,sini) for new recursion +c + cosi = cos(tpn) + sini = sin(tpn) + t2 = 0. + do 30 i=2,no2,2 + t = x(i)*cosi + x(i) = x(i)*4.*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + t2 = t2 + t + 30 continue + x1 = 2.*(t1+t2) + x2 = 2.*(t1-t2) +c +c take n/2 point (real) fft of preprocessed sequence x +c + call fast(x, no2) +c +c for n = 4--skip recursion and initial conditions +c + if (n.eq.4) go to 50 +c +c initial conditions for recursion +c + x(2) = -x(1)/2. + x(1) = x1 +c +c for n = 8, skip recursion +c + if (n.eq.8) go to 50 +c +c unscramble y(k) using recursion formula +c + nind = no2 - 2 + do 40 i=3,nind,2 + t = x(i) + x(i) = x(i-2) + x(i+1) + x(i+1) = x(i-1) - t + 40 continue + 50 x(no2) = x(no2+1)/2. + x(no2-1) = x2 + return + end diff --git a/math/ieee/chap1/fftsoh.f b/math/ieee/chap1/fftsoh.f new file mode 100644 index 00000000..afc18c17 --- /dev/null +++ b/math/ieee/chap1/fftsoh.f @@ -0,0 +1,81 @@ +c +c----------------------------------------------------------------------- +c subroutine: fftsoh +c compute dft for real, symmetric, odd harmonic, n-point sequence +c using n/4-point fft +c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1 +c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m) +c x(m) has the property x(m)=-x(n/2-m), m=0,1,...,n/4-1, x(n/4)=0 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine fftsoh(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/4 points of the +c input sequence (symmetrical) +c on output x contains the n/4 real points of the odd harmonics +c of the transform of the input--i.e. the zero valued imaginary +c parts are not given nor are the zero-valued even harmonics +c n = true size of input +c y = scratch array of size n/4+2 +c +c +c handle n = 2 and n = 4 cases separately +c + if (n.gt.4) go to 20 + if (n.eq.4) go to 10 +c +c for n=2, assume x(1)=x0, x(2)=-x0, compute dft directly +c + x(1) = 2.*x(1) + return +c +c n = 4 case, compute dft directly +c + 10 x(1) = 2.*x(1) + return + 20 twopi = 8.*atan(1.0) +c +c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1)) +c + no2 = n/2 + no4 = n/4 + no8 = n/8 + if (no8.eq.1) go to 40 + do 30 i=2,no8 + ind = 2*i + t1 = x(ind) - x(ind-2) + y(i) = x(ind-1) + t1 + ind1 = n/4 + 2 - i + y(ind1) = -x(ind-1) + t1 + 30 continue + 40 y(1) = x(1) + y(no8+1) = -2.*x(no4) +c +c the sequence y (n/4 points) has only odd harmonics +c call subroutine fftohm to exploit odd harmonics +c + call fftohm(y, no2) +c +c form original dft from complex odd harmonics of y(k) +c by unscrambling y(k) +c + tpn = twopi/float(n) + cosi = 2.*cos(tpn) + sini = 2.*sin(tpn) + cosd = cos(tpn*2.) + sind = sin(tpn*2.) + do 50 i=1,no8 + ind = 2*i + bk = y(ind)/sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + ak = y(ind-1) + x(i) = ak + bk + ind1 = n/4 + 1 - i + x(ind1) = ak - bk + 50 continue + return + end diff --git a/math/ieee/chap1/fftsym.f b/math/ieee/chap1/fftsym.f new file mode 100644 index 00000000..b1e795bb --- /dev/null +++ b/math/ieee/chap1/fftsym.f @@ -0,0 +1,84 @@ +c +c----------------------------------------------------------------------- +c subroutine: fftsym +c compute dft for real, symmetric, n-point sequence x(m) using +c n/2-point fft +c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine fftsym(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/2+1 points of the +c input sequence (symmetrical) +c on output x contains the n/2+1 real points of the transform of +c the input--i.e. the zero valued imaginary parts are not returned +c n = true size of input +c y = scratch array of size n/2+2 +c +c +c for n = 2, compute dft directly +c + if (n.gt.2) go to 10 + t = x(1) + x(2) + x(2) = x(1) - x(2) + x(1) = t + return + 10 twopi = 8.*atan(1.0) +c +c first compute b0 term, where b0=sum of odd values of x(m) +c + no2 = n/2 + no4 = n/4 + nind = no2 + 1 + b0 = 0. + do 20 i=2,nind,2 + b0 = b0 + x(i) + 20 continue + b0 = b0*2. +c +c for n = 4 skip recursion loop +c + if (n.eq.4) go to 40 +c +c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1)) +c + do 30 i=2,no4 + ind = 2*i + t1 = x(ind) - x(ind-2) + y(i) = x(ind-1) + t1 + ind1 = no2 + 2 - i + y(ind1) = x(ind-1) - t1 + 30 continue + 40 y(1) = x(1) + y(no4+1) = x(no2+1) +c +c take n/2 point (real) fft of y +c + call fast(y, no2) +c +c form original dft by unscrambling y(k) +c use recursion to give sin(tpn*i) multiplier +c + tpn = twopi/float(n) + cosi = 2.*cos(tpn) + sini = 2.*sin(tpn) + cosd = cosi/2. + sind = sini/2. + nind = no4 + 1 + do 50 i=2,nind + ind = 2*i + bk = y(ind)/sini + ak = y(ind-1) + x(i) = ak + bk + nind1 = n/2 + 2 - i + x(nind1) = ak - bk + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 50 continue + x(1) = b0 + y(1) + x(no2+1) = y(1) - b0 + return + end diff --git a/math/ieee/chap1/ford1.f b/math/ieee/chap1/ford1.f new file mode 100644 index 00000000..4982246f --- /dev/null +++ b/math/ieee/chap1/ford1.f @@ -0,0 +1,24 @@ +c +c----------------------------------------------------------------------- +c subroutine: ford1 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ford1(m, b) + dimension b(2) +c + k = 4 + kl = 2 + n = 2**m + do 40 j=4,n,2 + if (k-j) 20, 20, 10 + 10 t = b(j) + b(j) = b(k) + b(k) = t + 20 k = k - 2 + if (k-kl) 30, 30, 40 + 30 k = 2*j + kl = j + 40 continue + return + end diff --git a/math/ieee/chap1/ford2.f b/math/ieee/chap1/ford2.f new file mode 100644 index 00000000..8ee26d69 --- /dev/null +++ b/math/ieee/chap1/ford2.f @@ -0,0 +1,46 @@ +c +c----------------------------------------------------------------------- +c subroutine: ford2 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ford2(m, b) + dimension l(15), b(2) + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + n = 2**m + l(1) = n + do 10 k=2,m + l(k) = l(k-1)/2 + 10 continue + do 20 k=m,14 + l(k+1) = 2 + 20 continue + ij = 2 + do 40 j1=2,l1,2 + do 40 j2=j1,l2,l1 + do 40 j3=j2,l3,l2 + do 40 j4=j3,l4,l3 + do 40 j5=j4,l5,l4 + do 40 j6=j5,l6,l5 + do 40 j7=j6,l7,l6 + do 40 j8=j7,l8,l7 + do 40 j9=j8,l9,l8 + do 40 j10=j9,l10,l9 + do 40 j11=j10,l11,l10 + do 40 j12=j11,l12,l11 + do 40 j13=j12,l13,l12 + do 40 j14=j13,l14,l13 + do 40 ji=j14,l15,l14 + if (ij-ji) 30, 40, 40 + 30 t = b(ij-1) + b(ij-1) = b(ji-1) + b(ji-1) = t + t = b(ij) + b(ij) = b(ji) + b(ji) = t + 40 ij = ij + 2 + return + end diff --git a/math/ieee/chap1/fourea.f b/math/ieee/chap1/fourea.f new file mode 100644 index 00000000..d412c0e2 --- /dev/null +++ b/math/ieee/chap1/fourea.f @@ -0,0 +1,98 @@ +c +c----------------------------------------------------------------------- +c subroutine: fourea +c performs cooley-tukey fast fourier transform +c----------------------------------------------------------------------- +c + subroutine fourea(data, n, isi) +c +c the cooley-tukey fast fourier transform in ansi fortran +c +c data is a one-dimensional complex array whose length, n, is a +c power of two. isi is +1 for an inverse transform and -1 for a +c forward transform. transform values are returned in the input +c array, replacing the input. +c transform(j)=sum(data(i)*w**((i-1)*(j-1))), where i and j run +c from 1 to n and w = exp (isi*2*pi*sqrt(-1)/n). program also +c computes inverse transform, for which the defining expression +c is invtr(j)=(1/n)*sum(data(i)*w**((i-1)*(j-1))). +c running time is proportional to n*log2(n), rather than to the +c classical n**2. +c after program by brenner, june 1967. this is a very short version +c of the fft and is intended mainly for demonstration. programs +c are available in this collection which run faster and are not +c restricted to powers of 2 or to one-dimensional arrays. +c see -- ieee trans audio (june 1967), special issue on fft. +c + complex data(1) + complex temp, w + ioutd = i1mach(2) +c +c check for power of two up to 15 +c + nn = 1 + do 10 i=1,15 + m = i + nn = nn*2 + if (nn.eq.n) go to 20 + 10 continue + write (ioutd,9999) +9999 format (30h n not a power of 2 for fourea) + stop + 20 continue +c + pi = 4.*atan(1.) + fn = n +c +c this section puts data in bit-reversed order +c + j = 1 + do 80 i=1,n +c +c at this point, i and j are a bit reversed pair (except for the +c displacement of +1) +c + if (i-j) 30, 40, 40 +c +c exchange data(i) with data(j) if i.lt.j. +c + 30 temp = data(j) + data(j) = data(i) + data(i) = temp +c +c implement j=j+1, bit-reversed counter +c + 40 m = n/2 + 50 if (j-m) 70, 70, 60 + 60 j = j - m + m = (m+1)/2 + go to 50 + 70 j = j + m + 80 continue +c +c now compute the butterflies +c + mmax = 1 + 90 if (mmax-n) 100, 130, 130 + 100 istep = 2*mmax + do 120 m=1,mmax + theta = pi*float(isi*(m-1))/float(mmax) + w = cmplx(cos(theta),sin(theta)) + do 110 i=m,n,istep + j = i + mmax + temp = w*data(j) + data(j) = data(i) - temp + data(i) = data(i) + temp + 110 continue + 120 continue + mmax = istep + go to 90 + 130 if (isi) 160, 140, 140 +c +c for inv trans -- isi=1 -- multiply output by 1/n +c + 140 do 150 i=1,n + data(i) = data(i)/fn + 150 continue + 160 return + end diff --git a/math/ieee/chap1/fr2tr.f b/math/ieee/chap1/fr2tr.f new file mode 100644 index 00000000..24a103ff --- /dev/null +++ b/math/ieee/chap1/fr2tr.f @@ -0,0 +1,15 @@ +c +c----------------------------------------------------------------------- +c subroutine: fr2tr +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine fr2tr(int, b0, b1) + dimension b0(2), b1(2) + do 10 k=1,int + t = b0(k) + b1(k) + b1(k) = b0(k) - b1(k) + b0(k) = t + 10 continue + return + end diff --git a/math/ieee/chap1/fr4syn.f b/math/ieee/chap1/fr4syn.f new file mode 100644 index 00000000..5ce978f0 --- /dev/null +++ b/math/ieee/chap1/fr4syn.f @@ -0,0 +1,109 @@ +c +c----------------------------------------------------------------------- +c subroutine: fr4syn +c radix 4 synthesis +c----------------------------------------------------------------------- +c +c + subroutine fr4syn(int, nn, b0, b1, b2, b3, b4, b5, b6, b7) + dimension l(15), b0(2), b1(2), b2(2), b3(2), b4(2), b5(2), b6(2), + * b7(2) + common /const/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c + l(1) = nn/4 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue +c + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 +c + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = b0(k) + b1(k) + t1 = b0(k) - b1(k) + t2 = b2(k)*2.0 + t3 = b3(k)*2.0 + b0(k) = t0 + t2 + b2(k) = t0 - t2 + b1(k) = t1 + t3 + b3(k) = t1 - t3 + 60 continue +c + if (nn-4) 120, 120, 70 + 70 k0 = int*4 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + t2 = b0(k) - b2(k) + t3 = b1(k) + b3(k) + b0(k) = (b0(k)+b2(k))*2.0 + b2(k) = (b3(k)-b1(k))*2.0 + b1(k) = (t2+t3)*p7two + b3(k) = (t3-t2)*p7two + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = -sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 +c + int4 = int*4 + j0 = jr*int4 + 1 + k0 = ji*int4 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + t0 = b0(j) + b6(k) + t1 = b7(k) - b1(j) + t2 = b0(j) - b6(k) + t3 = b7(k) + b1(j) + t4 = b2(j) + b4(k) + t5 = b5(k) - b3(j) + t6 = b5(k) + b3(j) + t7 = b4(k) - b2(j) + b0(j) = t0 + t4 + b4(k) = t1 + t5 + b1(j) = (t2+t6)*c1 - (t3+t7)*s1 + b5(k) = (t2+t6)*s1 + (t3+t7)*c1 + b2(j) = (t0-t4)*c2 - (t1-t5)*s2 + b6(k) = (t0-t4)*s2 + (t1-t5)*c2 + b3(j) = (t2-t6)*c3 - (t3-t7)*s3 + b7(k) = (t2-t6)*s3 + (t3-t7)*c3 + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end diff --git a/math/ieee/chap1/fr4tr.f b/math/ieee/chap1/fr4tr.f new file mode 100644 index 00000000..16ba3fe6 --- /dev/null +++ b/math/ieee/chap1/fr4tr.f @@ -0,0 +1,118 @@ +c +c----------------------------------------------------------------------- +c subroutine: fr4tr +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine fr4tr(int, nn, b0, b1, b2, b3, b4, b5, b6, b7) + dimension l(15), b0(2), b1(2), b2(2), b3(2), b4(2), b5(2), b6(2), + * b7(2) + common /cons/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c jthet is a reversed binary counter, jr steps two at a time to +c locate the real parts of intermediate results, and ji locates +c the imaginary part corresponding to jr. +c + l(1) = nn/4 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue +c + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 +c + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = b0(k) + b2(k) + t1 = b1(k) + b3(k) + b2(k) = b0(k) - b2(k) + b3(k) = b1(k) - b3(k) + b0(k) = t0 + t1 + b1(k) = t0 - t1 + 60 continue +c + if (nn-4) 120, 120, 70 + 70 k0 = int*4 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + pr = p7*(b1(k)-b3(k)) + pi = p7*(b1(k)+b3(k)) + b3(k) = b2(k) + pi + b1(k) = pi - b2(k) + b2(k) = b0(k) - pr + b0(k) = b0(k) + pr + 80 continue + go to 120 +c + 90 arg = th2*piovn + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 +c + int4 = int*4 + j0 = jr*int4 + 1 + k0 = ji*int4 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + r1 = b1(j)*c1 - b5(k)*s1 + r5 = b1(j)*s1 + b5(k)*c1 + t2 = b2(j)*c2 - b6(k)*s2 + t6 = b2(j)*s2 + b6(k)*c2 + t3 = b3(j)*c3 - b7(k)*s3 + t7 = b3(j)*s3 + b7(k)*c3 + t0 = b0(j) + t2 + t4 = b4(k) + t6 + t2 = b0(j) - t2 + t6 = b4(k) - t6 + t1 = r1 + t3 + t5 = r5 + t7 + t3 = r1 - t3 + t7 = r5 - t7 + b0(j) = t0 + t1 + b7(k) = t4 + t5 + b6(k) = t0 - t1 + b1(j) = t5 - t4 + b2(j) = t2 - t7 + b5(k) = t6 + t3 + b4(k) = t2 + t7 + b3(j) = t3 - t6 + 100 continue +c + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end diff --git a/math/ieee/chap1/fsst.f b/math/ieee/chap1/fsst.f new file mode 100644 index 00000000..75ce56cb --- /dev/null +++ b/math/ieee/chap1/fsst.f @@ -0,0 +1,71 @@ +c +c----------------------------------------------------------------------- +c subroutine: fsst +c fourier synthesis subroutine +c----------------------------------------------------------------------- +c + subroutine fsst(b, n) +c +c this subroutine synthesizes the real vector b(k), for +c k=1,2,...,n, from the fourier coefficients stored in the +c b array of size n+2. the dc term is in b(1) with b(2) equal +c to 0. the jth harmonic is stored as b(2*j+1) + i b(2*j+2). +c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0. +c the subroutine is called as fsst(b,n) where n=2**m and +c b is the real array discussed above. +c + dimension b(2) + common /const/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + do 10 i=1,15 + m = i + nt = 2**i + if (n.eq.nt) go to 20 + 10 continue + write (iw,9999) +9999 format (33h n is not a power of two for fsst) + stop + 20 b(2) = b(n+1) + do 30 i=4,n,2 + b(i) = -b(i) + 30 continue +c +c scale the input by n +c + do 40 i=1,n + b(i) = b(i)/float(n) + 40 continue + n4pow = m/2 +c +c scramble the inputs +c + call ford2(m, b) + call ford1(m, b) +c + if (n4pow.eq.0) go to 60 + nn = 4*n + do 50 it=1,n4pow + nn = nn/4 + int = n/nn + call fr4syn(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1), + * b(1), b(int+1), b(2*int+1), b(3*int+1)) + 50 continue +c +c do a radix 2 iteration if one is required +c + 60 if (m-n4pow*2) 80, 80, 70 + 70 int = n/2 + call fr2tr(int, b(1), b(int+1)) + 80 return + end diff --git a/math/ieee/chap1/iftaoh.f b/math/ieee/chap1/iftaoh.f new file mode 100644 index 00000000..8cb0a908 --- /dev/null +++ b/math/ieee/chap1/iftaoh.f @@ -0,0 +1,87 @@ +c +c----------------------------------------------------------------------- +c subroutine: iftaoh +c compute idft for real, antisymmetric, odd harmonic, n-point sequence +c using n/4-point fft +c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1 +c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m) +c x(m)has the property x(m)=x(n/2-m), m=0,1,...,n/4-1, x(0)=0 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine iftaoh(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/4 imaginary points +c of the odd harmonics of the transform of the original time +c sequence--i.e. the zero valued real parts are not input nor +c are the zero-valued even harmonics +c on output x contains the first (n/4+1) points of the original +c time sequence (antisymmetrical) +c n = true size of input +c y = scratch array of size n/4+2 +c +c +c handle n = 2 and n = 4 cases separately +c + if (n.gt.4) go to 20 + if (n.eq.4) go to 10 +c +c for n=2 assume x(1)=0, x(2)=0, compute idft directly +c + x(1) = 0. + return +c +c for n=4, assume x(1)=x(3)=0, x(2)=-x(4)=x0, compute idft directly +c + 10 x(2) = -x(1)/2. + x(1) = 0. + return +c +c code for values of n which are multiples of 8 +c + 20 twopi = 8.*atan(1.0) + no2 = n/2 + no4 = n/4 + no8 = n/8 + tpn = twopi/float(n) +c +c scramble original dft (x(k)) to give y(k) +c use recursion to give sin multipliers +c + cosi = cos(tpn) + sini = sin(tpn) + cosd = cos(tpn*2.) + sind = sin(tpn*2.) + do 30 i=1,no8 + ind = 2*i + ind1 = no4 + 1 - i + ak = (x(i)-x(ind1))/2. + bk = -(x(i)+x(ind1)) + y(ind) = ak + y(ind-1) = bk*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 30 continue +c +c the sequence y(k) is an odd harmonic sequence +c use subroutine iftohm to give y(m) +c + call iftohm(y, no2) +c +c form x sequence from y sequence +c + x(2) = y(1)/2. + x(1) = 0. + if (n.eq.8) return + do 40 i=2,no8 + ind = 2*i + ind1 = no4 + 2 - i + x(ind-1) = (y(i)+y(ind1))/2. + t1 = (y(i)-y(ind1))/2. + x(ind) = t1 + x(ind-2) + 40 continue + x(no4+1) = y(no8+1) + return + end diff --git a/math/ieee/chap1/iftasm.f b/math/ieee/chap1/iftasm.f new file mode 100644 index 00000000..6ec12c7d --- /dev/null +++ b/math/ieee/chap1/iftasm.f @@ -0,0 +1,77 @@ +c +c----------------------------------------------------------------------- +c subroutine: iftasm +c compute idft for real, antisymmetric, n-point sequence x(m) using +c n/2-point fft +c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine iftasm(x, n, y) + dimension x(1), y(1) +c +c x = imaginary array which on input contains the n/2+1 real points of +c the transform of the input--i.e. the zero valued real parts +c are not given as input +c on output x contains the n/2 points of the time sequence +c (antisymmetrical) +c n = true size of input +c y = scratch array of size n/2+2 +c +c +c for n = 2, assume x(1)=0, x(2)=0 +c + if (n.gt.2) go to 10 + x(1) = 0 + x(2) = 0 + return + 10 twopi = 8.*atan(1.0) +c +c first compute x1=x(1) term directly +c use recursion on the sine cosine terms +c + no2 = n/2 + no4 = n/4 + tpn = twopi/float(n) +c +c scramble original dft (x(k)) to give y(k) +c use recursion relation to give sin(tpn*i) multiplier +c + cosi = cos(tpn) + sini = sin(tpn) + cosd = cosi + sind = sini + nind = no4 + 1 + do 20 i=2,nind + ind = 2*i + ind1 = no2 + 2 - i + ak = (x(i)-x(ind1))/2. + bk = -(x(i)+x(ind1)) + y(ind) = ak + y(ind-1) = bk*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 20 continue + y(1) = 0. + y(2) = 0. +c +c take n/2 point idft of y +c + call fsst(y, no2) +c +c form x sequence from y sequence +c + x(2) = y(1)/2. + x(1) = 0. + if (n.eq.4) go to 40 + do 30 i=2,no4 + ind = 2*i + ind1 = no2 + 2 - i + x(ind-1) = (y(i)-y(ind1))/2. + t1 = (y(i)+y(ind1))/2. + x(ind) = t1 + x(ind-2) + 30 continue + 40 x(no2) = -y(no4+1)/2. + return + end diff --git a/math/ieee/chap1/iftohm.f b/math/ieee/chap1/iftohm.f new file mode 100644 index 00000000..df084e87 --- /dev/null +++ b/math/ieee/chap1/iftohm.f @@ -0,0 +1,83 @@ +c +c----------------------------------------------------------------------- +c subroutine: iftohm +c compute idft for real, n-point, odd harmonic sequences using an +c n/2 point fft +c odd harmonic means x(2*k)=0, all k where x(k) is the dft of x(m) +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine iftohm(x, n) + dimension x(1) +c +c x = real array which on input contains the n/4 complex values of the +c odd harmonics of the input--stored in the sequence re(x(1)), +c im(x(1)),re(x(2)),im(x(2)),... +c on output x contains the first n/2 points of the input +c ****note: x must be dimensioned to size n/2+2 for fft routine +c n = true size of x sequence +c +c first compute real(x(1)) and real(x(n/2-1)) separately +c also simultaneously multiply original sequence by sin(twopi*(m-1)/n) +c sin and cos are computed recursively +c +c +c for n = 2, assume x(1)=x0, x(2)=-x0, compute idft directly +c + if (n.gt.2) go to 10 + x(1) = 0.5*x(1) + x(2) = -x(1) + return + 10 twopi = 8.*atan(1.0) + tpn = twopi/float(n) + no2 = n/2 + no4 = n/4 + nind = no2 +c +c solve for x(0)=x0 directly +c + x0 = 0. + do 20 i=1,no2,2 + x0 = x0 + 2.*x(i) + 20 continue + x0 = x0/float(n) +c +c form y(k)=j*(x(2k+1)-x(2k-1)) +c overwrite x array with y sequence +c + xpr = x(1) + xpi = x(2) + x(1) = -2.*x(2) + x(2) = 0. + if (no4.eq.1) go to 40 + do 30 i=3,nind,2 + ti = x(i) - xpr + tr = -x(i+1) + xpi + xpr = x(i) + xpi = x(i+1) + x(i) = tr + x(i+1) = ti + 30 continue + 40 x(no2+1) = 2.*xpi + x(no2+2) = 0. +c +c take n/2 point (real) ifft of preprocessed sequence x +c + call fsst(x, no2) +c +c solve for x(m) by dividing by 4*sin(twopi*m/n) for m=1,2,...,n/2-1 +c for m=0 substitute precomputed value x0 +c + cosi = 4. + sini = 0. + cosd = cos(tpn) + sind = sin(tpn) + do 50 i=2,no2 + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + x(i) = x(i)/sini + 50 continue + x(1) = x0 + return + end diff --git a/math/ieee/chap1/iftsoh.f b/math/ieee/chap1/iftsoh.f new file mode 100644 index 00000000..6098e6e4 --- /dev/null +++ b/math/ieee/chap1/iftsoh.f @@ -0,0 +1,94 @@ +c +c----------------------------------------------------------------------- +c subroutine: iftsoh +c compute idft for real, symmetric, odd harmonic, n-point sequence +c using n/4-point fft +c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1 +c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m) +c x(m) has the property x(m)=-x(n/2-m), m=0,1,...,n/4-1, x(n/4)=0 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine iftsoh(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/4 real points of +c the odd harmonics of the transform of the original time sequence +c i.e. the zero valued imaginary parts are not given nor are the +c zero valued even harmonics +c on output x contains the first n/4 points of the original input +c sequence (symmetrical) +c n = true size of input +c y = scratch array of size n/4+2 +c +c +c handle n = 2 and n = 4 cases separately +c + if (n.gt.4) go to 10 +c +c for n=2, 4 assume x(1)=x0, x(2)=-x0, compute idft directly +c + x(1) = x(1)/2. + return +c +c code for values of n which are multiples of 8 +c + 10 twopi = 8.*atan(1.0) + no2 = n/2 + no4 = n/4 + no8 = n/8 + tpn = twopi/float(n) +c +c first compute x1=x(1) term directly +c use recursion on the sine cosine terms +c + cosd = cos(tpn*2.) + sind = sin(tpn*2.) + cosi = 2.*cos(tpn) + sini = 2.*sin(tpn) + x1 = 0. + do 20 i=1,no4 + x1 = x1 + x(i)*cosi + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 20 continue + x1 = x1/float(n) +c +c scramble original dft (x(k)) to give y(k) +c use recursion relation to give sin multipliers +c + cosi = cos(tpn) + sini = sin(tpn) + do 30 i=1,no8 + ind = 2*i + ind1 = no4 + 1 - i + ak = (x(i)+x(ind1))/2. + bk = (x(i)-x(ind1)) + y(ind-1) = ak + y(ind) = bk*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 30 continue +c +c the sequence y(k) is the odd harmonics dft output +c use subroutine iftohm to obtain y(m), the inverse transform +c + call iftohm(y, no2) +c +c form x(m) sequence from y(m) sequence +c use x1 initial condition on the recursion +c + x(1) = y(1) + x(2) = x1 + if (no8.eq.1) return + do 40 i=2,no8 + ind = 2*i + ind1 = no4 + 2 - i + t1 = (y(i)+y(ind1))/2. + x(ind-1) = (y(i)-y(ind1))/2. + x(ind) = t1 + x(ind-2) + 40 continue + return + end diff --git a/math/ieee/chap1/iftsym.f b/math/ieee/chap1/iftsym.f new file mode 100644 index 00000000..e45c9a37 --- /dev/null +++ b/math/ieee/chap1/iftsym.f @@ -0,0 +1,90 @@ +c +c----------------------------------------------------------------------- +c subroutine: iftsym +c compute idft for real, symmetric, n-point sequence x(m) using +c n/2-point fft +c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1 +c note: index m is sequence index--not fortran index +c----------------------------------------------------------------------- +c + subroutine iftsym(x, n, y) + dimension x(1), y(1) +c +c x = real array which on input contains the n/2+1 real points of the +c transform of the input--i.e. the zero valued imaginary parts +c are not given as input +c on output x contains the n/2+1 points of the time sequence +c (symmetrical) +c n = true size of input +c y = scratch array of size n/2+2 +c +c +c for n = 2, compute idft directly +c + if (n.gt.2) go to 10 + t = (x(1)+x(2))/2. + x(2) = (x(1)-x(2))/2. + x(1) = t + return + 10 twopi = 8.*atan(1.0) +c +c first compute x1=x(1) term directly +c use recursion on the sine cosine terms +c + no2 = n/2 + no4 = n/4 + tpn = twopi/float(n) + cosd = cos(tpn) + sind = sin(tpn) + cosi = 2. + sini = 0. + x1 = x(1) - x(no2+1) + do 20 i=2,no2 + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + x1 = x1 + x(i)*cosi + 20 continue + x1 = x1/float(n) +c +c scramble original dft (x(k)) to give y(k) +c use recursion relation to generate sin(tpn*i) multiplier +c + cosi = cos(tpn) + sini = sin(tpn) + cosd = cosi + sind = sini + y(1) = (x(1)+x(no2+1))/2. + y(2) = 0. + nind = no4 + 1 + do 30 i=2,nind + ind = 2*i + nind1 = no2 + 2 - i + ak = (x(i)+x(nind1))/2. + bk = (x(i)-x(nind1)) + y(ind-1) = ak + y(ind) = bk*sini + temp = cosi*cosd - sini*sind + sini = cosi*sind + sini*cosd + cosi = temp + 30 continue +c +c take n/2 point idft of y +c + call fsst(y, no2) +c +c form x sequence from y sequence +c + x(1) = y(1) + x(2) = x1 + if (n.eq.4) go to 50 + do 40 i=2,no4 + ind = 2*i + ind1 = no2 + 2 - i + x(ind-1) = (y(i)+y(ind1))/2. + t1 = (y(i)-y(ind1))/2. + x(ind) = t1 + x(ind-2) + 40 continue + 50 x(no2+1) = y(no4+1) + return + end diff --git a/math/ieee/chap1/inishl.f b/math/ieee/chap1/inishl.f new file mode 100644 index 00000000..925cd657 --- /dev/null +++ b/math/ieee/chap1/inishl.f @@ -0,0 +1,179 @@ +c +c----------------------------------------------------------------------- +c subroutine: inishl +c this subroutine initializes the wfta routine for a given +c value of the transform length n. the factors of n are +c determined, the multiplication coefficients are calculated +c and stored in the array coef(.), the input and output +c permutation vectors are computed and stored in the arrays +c indx1(.) and indx2(.) +c +c----------------------------------------------------------------------- +c + subroutine inishl(n,coef,xr,xi,indx1,indx2,ierr) + dimension coef(1),xr(1),xi(1) + integer s1,s2,s3,s4,indx1(1),indx2(1),p1 + dimension co3(3),co4(4),co8(8),co9(11),co16(18),cda(18),cdb(11), + 1cdc(9),cdd(6) + common na,nb,nc,nd,nd1,nd2,nd3,nd4 +c +c data statements assign short dft coefficients. +c + data co4(1),co4(2),co4(3),co4(4)/4*1.0/ +c + data cda(1),cda(2),cda(3),cda(4),cda(5),cda(6),cda(7), + 1 cda(8),cda(9),cda(10),cda(11),cda(12),cda(13),cda(14), + 2 cda(15),cda(16),cda(17),cda(18)/18*1.0/ +c + data cdb(1),cdb(2),cdb(3),cdb(4),cdb(5),cdb(6),cdb(7),cdb(8), + 1 cdb(9),cdb(10),cdb(11)/11*1.0/ +c + data ionce/1/ +c +c get multiplier constants +c + if(ionce.ne.1) go to 20 + call const(co3,co8,co16,co9,cdc,cdd) +20 ionce=-1 +c +c following segment determines factors of n and chooses +c the appropriate short dft coefficients. +c + iout=i1mach(2) + ierr=0 + nd1=1 + na=1 + nb=1 + nd2=1 + nc=1 + nd3=1 + nd=1 + nd4=1 + if(n.le.0 .or. n.gt.5040) go to 190 + if(16*(n/16).eq.n) go to 30 + if(8*(n/8).eq.n) go to 40 + if(4*(n/4).eq.n) go to 50 + if(2*(n/2).ne.n) go to 70 + nd1=2 + na=2 + cda(2)=1.0 + go to 70 +30 nd1=18 + na=16 + do 31 j=1,18 +31 cda(j)=co16(j) + go to 70 +40 nd1=8 + na=8 + do 41 j=1,8 +41 cda(j)=co8(j) + go to 70 +50 nd1=4 + na=4 + do 51 j=1,4 +51 cda(j)=co4(j) +70 if(3*(n/3).ne.n) go to 120 + if(9*(n/9).eq.n) go to 100 + nd2=3 + nb=3 + do 71 j=1,3 +71 cdb(j)=co3(j) + go to 120 +100 nd2=11 + nb=9 + do 110 j=1,11 +110 cdb(j)=co9(j) +120 if(7*(n/7).ne.n) go to 160 + nd3=9 + nc=7 +160 if(5*(n/5).ne.n) go to 190 + nd4=6 + nd=5 +190 m=na*nb*nc*nd + if(m.eq.n) go to 250 + write(iout,210) +210 format(21h this n does not work) + ierr=-1 + return +c +c next segment generates the dft coefficients by +c multiplying together the short dft coefficients +c +250 j=1 + do 300 n4=1,nd4 + do 300 n3=1,nd3 + do 300 n2=1,nd2 + do 300 n1=1,nd1 + coef(j)=cda(n1)*cdb(n2)*cdc(n3)*cdd(n4) + j=j+1 +300 continue +c +c following segment forms the input indexing vector +c + j=1 + nu=nb*nc*nd + nv=na*nc*nd + nw=na*nb*nd + ny=na*nb*nc + k=1 + do 440 n4=1,nd + do 430 n3=1,nc + do 420 n2=1,nb + do 410 n1=1,na +405 if(k.le.n) go to 408 + k=k-n + go to 405 +408 indx1(j)=k + j=j+1 +410 k=k+nu +420 k=k+nv +430 k=k+nw +440 k=k+ny +c +c following segment forms the output indexing vector +c + m=1 + s1=0 + s2=0 + s3=0 + s4=0 + if(na.eq.1) go to 530 +520 p1=m*nu-1 + if((p1/na)*na.eq.p1) go to 510 + m=m+1 + go to 520 +510 s1=p1+1 +530 if(nb.eq.1) go to 540 + m=1 +550 p1=m*nv-1 + if((p1/nb)*nb.eq.p1) go to 560 + m=m+1 + go to 550 +560 s2=p1+1 +540 if(nc.eq.1) go to 630 + m=1 +620 p1=m*nw-1 + if((p1/nc)*nc.eq.p1) go to 610 + m=m+1 + go to 620 +610 s3=p1+1 +630 if(nd.eq.1) go to 660 + m=1 +640 p1=m*ny-1 + if((p1/nd)*nd.eq.p1) go to 650 + m=m+1 + go to 640 +650 s4=p1+1 +660 j=1 + do 810 n4=1,nd + do 810 n3=1,nc + do 810 n2=1,nb + do 810 n1=1,na + indx2(j)=s1*(n1-1)+s2*(n2-1)+s3*(n3-1)+s4*(n4-1)+1 +900 if(indx2(j).le.n) go to 910 + indx2(j)=indx2(j)-n + go to 900 +910 j=j+1 +810 continue + return + end diff --git a/math/ieee/chap1/ord1.f b/math/ieee/chap1/ord1.f new file mode 100644 index 00000000..21e4494e --- /dev/null +++ b/math/ieee/chap1/ord1.f @@ -0,0 +1,24 @@ +c +c----------------------------------------------------------------------- +c subroutine: ord1 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord1(m, b) + dimension b(2) +c + k = 4 + kl = 2 + n = 2**m + do 40 j=4,n,2 + if (k-j) 20, 20, 10 + 10 t = b(j) + b(j) = b(k) + b(k) = t + 20 k = k - 2 + if (k-kl) 30, 30, 40 + 30 k = 2*j + kl = j + 40 continue + return + end diff --git a/math/ieee/chap1/ord2.f b/math/ieee/chap1/ord2.f new file mode 100644 index 00000000..10f03ec7 --- /dev/null +++ b/math/ieee/chap1/ord2.f @@ -0,0 +1,46 @@ +c +c----------------------------------------------------------------------- +c subroutine: ord2 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord2(m, b) + dimension l(15), b(2) + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + n = 2**m + l(1) = n + do 10 k=2,m + l(k) = l(k-1)/2 + 10 continue + do 20 k=m,14 + l(k+1) = 2 + 20 continue + ij = 2 + do 40 j1=2,l1,2 + do 40 j2=j1,l2,l1 + do 40 j3=j2,l3,l2 + do 40 j4=j3,l4,l3 + do 40 j5=j4,l5,l4 + do 40 j6=j5,l6,l5 + do 40 j7=j6,l7,l6 + do 40 j8=j7,l8,l7 + do 40 j9=j8,l9,l8 + do 40 j10=j9,l10,l9 + do 40 j11=j10,l11,l10 + do 40 j12=j11,l12,l11 + do 40 j13=j12,l13,l12 + do 40 j14=j13,l14,l13 + do 40 ji=j14,l15,l14 + if (ij-ji) 30, 40, 40 + 30 t = b(ij-1) + b(ij-1) = b(ji-1) + b(ji-1) = t + t = b(ij) + b(ij) = b(ji) + b(ji) = t + 40 ij = ij + 2 + return + end diff --git a/math/ieee/chap1/r2tr.f b/math/ieee/chap1/r2tr.f new file mode 100644 index 00000000..510763fe --- /dev/null +++ b/math/ieee/chap1/r2tr.f @@ -0,0 +1,16 @@ +c +c----------------------------------------------------------------------- +c subroutine: r2tr +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c +c + subroutine r2tr(int, b0, b1) + dimension b0(2), b1(2) + do 10 k=1,int + t = b0(k) + b1(k) + b1(k) = b0(k) - b1(k) + b0(k) = t + 10 continue + return + end diff --git a/math/ieee/chap1/r2tx.f b/math/ieee/chap1/r2tx.f new file mode 100644 index 00000000..425c10f8 --- /dev/null +++ b/math/ieee/chap1/r2tx.f @@ -0,0 +1,18 @@ +c +c----------------------------------------------------------------------- +c subroutine: r2tx +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r2tx(nthpo, cr0, cr1, ci0, ci1) + dimension cr0(2), cr1(2), ci0(2), ci1(2) + do 10 k=1,nthpo,2 + r1 = cr0(k) + cr1(k) + cr1(k) = cr0(k) - cr1(k) + cr0(k) = r1 + fi1 = ci0(k) + ci1(k) + ci1(k) = ci0(k) - ci1(k) + ci0(k) = fi1 + 10 continue + return + end diff --git a/math/ieee/chap1/r4syn.f b/math/ieee/chap1/r4syn.f new file mode 100644 index 00000000..77c97bba --- /dev/null +++ b/math/ieee/chap1/r4syn.f @@ -0,0 +1,20 @@ +c +c----------------------------------------------------------------------- +c subroutine: r4syn +c radix 4 synthesis +c----------------------------------------------------------------------- +c + subroutine r4syn(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + t0 = b0(k) + b1(k) + t1 = b0(k) - b1(k) + t2 = b2(k) + b2(k) + t3 = b3(k) + b3(k) + b0(k) = t0 + t2 + b2(k) = t0 - t2 + b1(k) = t1 + t3 + b3(k) = t1 - t3 + 10 continue + return + end diff --git a/math/ieee/chap1/r4tr.f b/math/ieee/chap1/r4tr.f new file mode 100644 index 00000000..5fc46eab --- /dev/null +++ b/math/ieee/chap1/r4tr.f @@ -0,0 +1,18 @@ +c +c----------------------------------------------------------------------- +c subroutine: r4tr +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tr(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + r0 = b0(k) + b2(k) + r1 = b1(k) + b3(k) + b2(k) = b0(k) - b2(k) + b3(k) = b1(k) - b3(k) + b0(k) = r0 + r1 + b1(k) = r0 - r1 + 10 continue + return + end diff --git a/math/ieee/chap1/r4tx.f b/math/ieee/chap1/r4tx.f new file mode 100644 index 00000000..4e5649e8 --- /dev/null +++ b/math/ieee/chap1/r4tx.f @@ -0,0 +1,29 @@ +c +c----------------------------------------------------------------------- +c subroutine: r4tx +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tx(nthpo, cr0, cr1, cr2, cr3, ci0, ci1, ci2, ci3) + dimension cr0(2), cr1(2), cr2(2), cr3(2), ci0(2), ci1(2), ci2(2), + * ci3(2) + do 10 k=1,nthpo,4 + r1 = cr0(k) + cr2(k) + r2 = cr0(k) - cr2(k) + r3 = cr1(k) + cr3(k) + r4 = cr1(k) - cr3(k) + fi1 = ci0(k) + ci2(k) + fi2 = ci0(k) - ci2(k) + fi3 = ci1(k) + ci3(k) + fi4 = ci1(k) - ci3(k) + cr0(k) = r1 + r3 + ci0(k) = fi1 + fi3 + cr1(k) = r1 - r3 + ci1(k) = fi1 - fi3 + cr2(k) = r2 - fi4 + ci2(k) = fi2 + r4 + cr3(k) = r2 + fi4 + ci3(k) = fi2 - r4 + 10 continue + return + end diff --git a/math/ieee/chap1/r8syn.f b/math/ieee/chap1/r8syn.f new file mode 100644 index 00000000..054413d7 --- /dev/null +++ b/math/ieee/chap1/r8syn.f @@ -0,0 +1,186 @@ +c +c----------------------------------------------------------------------- +c subroutine: r8syn +c radix 8 synthesis subroutine +c----------------------------------------------------------------------- +c + subroutine r8syn(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 +c + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br1(k) + t1 = br0(k) - br1(k) + t2 = br2(k) + br2(k) + t3 = br3(k) + br3(k) + t4 = br4(k) + br6(k) + t6 = br7(k) - br5(k) + t5 = br4(k) - br6(k) + t7 = br7(k) + br5(k) + pr = p7*(t7+t5) + pi = p7*(t7-t5) + tt0 = t0 + t2 + tt1 = t1 + t3 + t2 = t0 - t2 + t3 = t1 - t3 + t4 = t4 + t4 + t5 = pr + pr + t6 = t6 + t6 + t7 = pi + pi + br0(k) = tt0 + t4 + br1(k) = tt1 + t5 + br2(k) = t2 + t6 + br3(k) = t3 + t7 + br4(k) = tt0 - t4 + br5(k) = tt1 - t5 + br6(k) = t2 - t6 + br7(k) = t3 - t7 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + t1 = bi0(k) + bi6(k) + t2 = bi7(k) - bi1(k) + t3 = bi0(k) - bi6(k) + t4 = bi7(k) + bi1(k) + pr = t3*c22 + t4*s22 + pi = t4*c22 - t3*s22 + t5 = bi2(k) + bi4(k) + t6 = bi5(k) - bi3(k) + t7 = bi2(k) - bi4(k) + t8 = bi5(k) + bi3(k) + rr = t8*c22 - t7*s22 + ri = -t8*s22 - t7*c22 + bi0(k) = (t1+t5) + (t1+t5) + bi4(k) = (t2+t6) + (t2+t6) + bi1(k) = (pr+rr) + (pr+rr) + bi5(k) = (pi+ri) + (pi+ri) + t5 = t1 - t5 + t6 = t2 - t6 + bi2(k) = p7two*(t6+t5) + bi6(k) = p7two*(t6-t5) + rr = pr - rr + ri = pi - ri + bi3(k) = p7two*(ri+rr) + bi7(k) = p7two*(ri-rr) + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = -sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr0 = br0(j) + bi6(k) + ti0 = bi7(k) - br1(j) + tr1 = br0(j) - bi6(k) + ti1 = bi7(k) + br1(j) + tr2 = br2(j) + bi4(k) + ti2 = bi5(k) - br3(j) + tr3 = bi5(k) + br3(j) + ti3 = bi4(k) - br2(j) + tr4 = br4(j) + bi2(k) + ti4 = bi3(k) - br5(j) + t0 = br4(j) - bi2(k) + t1 = bi3(k) + br5(j) + tr5 = p7*(t0+t1) + ti5 = p7*(t1-t0) + tr6 = br6(j) + bi0(k) + ti6 = bi1(k) - br7(j) + t0 = br6(j) - bi0(k) + t1 = bi1(k) + br7(j) + tr7 = -p7*(t0-t1) + ti7 = -p7*(t1+t0) + t0 = tr0 + tr2 + t1 = ti0 + ti2 + t2 = tr1 + tr3 + t3 = ti1 + ti3 + tr2 = tr0 - tr2 + ti2 = ti0 - ti2 + tr3 = tr1 - tr3 + ti3 = ti1 - ti3 + t4 = tr4 + tr6 + t5 = ti4 + ti6 + t6 = tr5 + tr7 + t7 = ti5 + ti7 + ttr6 = ti4 - ti6 + ti6 = tr6 - tr4 + ttr7 = ti5 - ti7 + ti7 = tr7 - tr5 + br0(j) = t0 + t4 + bi0(k) = t1 + t5 + br1(j) = c1*(t2+t6) - s1*(t3+t7) + bi1(k) = c1*(t3+t7) + s1*(t2+t6) + br2(j) = c2*(tr2+ttr6) - s2*(ti2+ti6) + bi2(k) = c2*(ti2+ti6) + s2*(tr2+ttr6) + br3(j) = c3*(tr3+ttr7) - s3*(ti3+ti7) + bi3(k) = c3*(ti3+ti7) + s3*(tr3+ttr7) + br4(j) = c4*(t0-t4) - s4*(t1-t5) + bi4(k) = c4*(t1-t5) + s4*(t0-t4) + br5(j) = c5*(t2-t6) - s5*(t3-t7) + bi5(k) = c5*(t3-t7) + s5*(t2-t6) + br6(j) = c6*(tr2-ttr6) - s6*(ti2-ti6) + bi6(k) = c6*(ti2-ti6) + s6*(tr2-ttr6) + br7(j) = c7*(tr3-ttr7) - s7*(ti3-ti7) + bi7(k) = c7*(ti3-ti7) + s7*(tr3-ttr7) + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end diff --git a/math/ieee/chap1/r8tr.f b/math/ieee/chap1/r8tr.f new file mode 100644 index 00000000..d49ef58c --- /dev/null +++ b/math/ieee/chap1/r8tr.f @@ -0,0 +1,201 @@ +c +c----------------------------------------------------------------------- +c subroutine: r8tr +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tr(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c set up counters such that jthet steps through the arguments +c of w, jr steps through starting locations for the real part of the +c intermediate results and ji steps through starting locations +c of the imaginary part of the intermediate results. +c + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br4(k) + t1 = br1(k) + br5(k) + t2 = br2(k) + br6(k) + t3 = br3(k) + br7(k) + t4 = br0(k) - br4(k) + t5 = br1(k) - br5(k) + t6 = br2(k) - br6(k) + t7 = br3(k) - br7(k) + br2(k) = t0 - t2 + br3(k) = t1 - t3 + t0 = t0 + t2 + t1 = t1 + t3 + br0(k) = t0 + t1 + br1(k) = t0 - t1 + pr = p7*(t5-t7) + pi = p7*(t5+t7) + br4(k) = t4 + pr + br7(k) = t6 + pi + br6(k) = t4 - pr + br5(k) = pi - t6 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + pr = p7*(bi2(k)-bi6(k)) + pi = p7*(bi2(k)+bi6(k)) + tr0 = bi0(k) + pr + ti0 = bi4(k) + pi + tr2 = bi0(k) - pr + ti2 = bi4(k) - pi + pr = p7*(bi3(k)-bi7(k)) + pi = p7*(bi3(k)+bi7(k)) + tr1 = bi1(k) + pr + ti1 = bi5(k) + pi + tr3 = bi1(k) - pr + ti3 = bi5(k) - pi + pr = tr1*c22 - ti1*s22 + pi = ti1*c22 + tr1*s22 + bi0(k) = tr0 + pr + bi6(k) = tr0 - pr + bi7(k) = ti0 + pi + bi1(k) = pi - ti0 + pr = -tr3*s22 - ti3*c22 + pi = tr3*c22 - ti3*s22 + bi2(k) = tr2 + pr + bi4(k) = tr2 - pr + bi5(k) = ti2 + pi + bi3(k) = pi - ti2 + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr1 = br1(j)*c1 - bi1(k)*s1 + ti1 = br1(j)*s1 + bi1(k)*c1 + tr2 = br2(j)*c2 - bi2(k)*s2 + ti2 = br2(j)*s2 + bi2(k)*c2 + tr3 = br3(j)*c3 - bi3(k)*s3 + ti3 = br3(j)*s3 + bi3(k)*c3 + tr4 = br4(j)*c4 - bi4(k)*s4 + ti4 = br4(j)*s4 + bi4(k)*c4 + tr5 = br5(j)*c5 - bi5(k)*s5 + ti5 = br5(j)*s5 + bi5(k)*c5 + tr6 = br6(j)*c6 - bi6(k)*s6 + ti6 = br6(j)*s6 + bi6(k)*c6 + tr7 = br7(j)*c7 - bi7(k)*s7 + ti7 = br7(j)*s7 + bi7(k)*c7 +c + t0 = br0(j) + tr4 + t1 = bi0(k) + ti4 + tr4 = br0(j) - tr4 + ti4 = bi0(k) - ti4 + t2 = tr1 + tr5 + t3 = ti1 + ti5 + tr5 = tr1 - tr5 + ti5 = ti1 - ti5 + t4 = tr2 + tr6 + t5 = ti2 + ti6 + tr6 = tr2 - tr6 + ti6 = ti2 - ti6 + t6 = tr3 + tr7 + t7 = ti3 + ti7 + tr7 = tr3 - tr7 + ti7 = ti3 - ti7 +c + tr0 = t0 + t4 + ti0 = t1 + t5 + tr2 = t0 - t4 + ti2 = t1 - t5 + tr1 = t2 + t6 + ti1 = t3 + t7 + tr3 = t2 - t6 + ti3 = t3 - t7 + t0 = tr4 - ti6 + t1 = ti4 + tr6 + t4 = tr4 + ti6 + t5 = ti4 - tr6 + t2 = tr5 - ti7 + t3 = ti5 + tr7 + t6 = tr5 + ti7 + t7 = ti5 - tr7 + br0(j) = tr0 + tr1 + bi7(k) = ti0 + ti1 + bi6(k) = tr0 - tr1 + br1(j) = ti1 - ti0 + br2(j) = tr2 - ti3 + bi5(k) = ti2 + tr3 + bi4(k) = tr2 + ti3 + br3(j) = tr3 - ti2 + pr = p7*(t2-t3) + pi = p7*(t2+t3) + br4(j) = t0 + pr + bi3(k) = t1 + pi + bi2(k) = t0 - pr + br5(j) = pi - t1 + pr = -p7*(t6+t7) + pi = p7*(t6-t7) + br6(j) = t4 + pr + bi1(k) = t5 + pi + bi0(k) = t4 - pr + br7(j) = pi - t5 + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end diff --git a/math/ieee/chap1/r8tx.f b/math/ieee/chap1/r8tx.f new file mode 100644 index 00000000..9cc4f591 --- /dev/null +++ b/math/ieee/chap1/r8tx.f @@ -0,0 +1,107 @@ +c +c----------------------------------------------------------------------- +c subroutine: r8tx +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tx(nxtlt, nthpo, lengt, cr0, cr1, cr2, cr3, cr4, + * cr5, cr6, cr7, ci0, ci1, ci2, ci3, ci4, ci5, ci6, ci7) + dimension cr0(2), cr1(2), cr2(2), cr3(2), cr4(2), cr5(2), cr6(2), + * cr7(2), ci1(2), ci2(2), ci3(2), ci4(2), ci5(2), ci6(2), + * ci7(2), ci0(2) + common /con2/ pi2, p7 +c + scale = pi2/float(lengt) + do 30 j=1,nxtlt + arg = float(j-1)*scale + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + do 20 k=j,nthpo,lengt + ar0 = cr0(k) + cr4(k) + ar1 = cr1(k) + cr5(k) + ar2 = cr2(k) + cr6(k) + ar3 = cr3(k) + cr7(k) + ar4 = cr0(k) - cr4(k) + ar5 = cr1(k) - cr5(k) + ar6 = cr2(k) - cr6(k) + ar7 = cr3(k) - cr7(k) + ai0 = ci0(k) + ci4(k) + ai1 = ci1(k) + ci5(k) + ai2 = ci2(k) + ci6(k) + ai3 = ci3(k) + ci7(k) + ai4 = ci0(k) - ci4(k) + ai5 = ci1(k) - ci5(k) + ai6 = ci2(k) - ci6(k) + ai7 = ci3(k) - ci7(k) + br0 = ar0 + ar2 + br1 = ar1 + ar3 + br2 = ar0 - ar2 + br3 = ar1 - ar3 + br4 = ar4 - ai6 + br5 = ar5 - ai7 + br6 = ar4 + ai6 + br7 = ar5 + ai7 + bi0 = ai0 + ai2 + bi1 = ai1 + ai3 + bi2 = ai0 - ai2 + bi3 = ai1 - ai3 + bi4 = ai4 + ar6 + bi5 = ai5 + ar7 + bi6 = ai4 - ar6 + bi7 = ai5 - ar7 + cr0(k) = br0 + br1 + ci0(k) = bi0 + bi1 + if (j.le.1) go to 10 + cr1(k) = c4*(br0-br1) - s4*(bi0-bi1) + ci1(k) = c4*(bi0-bi1) + s4*(br0-br1) + cr2(k) = c2*(br2-bi3) - s2*(bi2+br3) + ci2(k) = c2*(bi2+br3) + s2*(br2-bi3) + cr3(k) = c6*(br2+bi3) - s6*(bi2-br3) + ci3(k) = c6*(bi2-br3) + s6*(br2+bi3) + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = c1*(br4+tr) - s1*(bi4+ti) + ci4(k) = c1*(bi4+ti) + s1*(br4+tr) + cr5(k) = c5*(br4-tr) - s5*(bi4-ti) + ci5(k) = c5*(bi4-ti) + s5*(br4-tr) + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = c3*(br6+tr) - s3*(bi6+ti) + ci6(k) = c3*(bi6+ti) + s3*(br6+tr) + cr7(k) = c7*(br6-tr) - s7*(bi6-ti) + ci7(k) = c7*(bi6-ti) + s7*(br6-tr) + go to 20 + 10 cr1(k) = br0 - br1 + ci1(k) = bi0 - bi1 + cr2(k) = br2 - bi3 + ci2(k) = bi2 + br3 + cr3(k) = br2 + bi3 + ci3(k) = bi2 - br3 + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = br4 + tr + ci4(k) = bi4 + ti + cr5(k) = br4 - tr + ci5(k) = bi4 - ti + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = br6 + tr + ci6(k) = bi6 + ti + cr7(k) = br6 - tr + ci7(k) = bi6 - ti + 20 continue + 30 continue + return + end diff --git a/math/ieee/chap1/rad4sb.f b/math/ieee/chap1/rad4sb.f new file mode 100644 index 00000000..dfebf0cc --- /dev/null +++ b/math/ieee/chap1/rad4sb.f @@ -0,0 +1,38 @@ +c +c----------------------------------------------------------------------- +c subroutine: rad4sb +c used by subroutine radix4. never directly accessed by user. +c----------------------------------------------------------------------- +c + subroutine rad4sb(ntype) +c +c input: ntype = type of butterfly invoked +c output: parameters used by subroutine radix4 +c + dimension ix(2996) + common /xx/ix + common ntypl,kkp,index,ixc + if(ntype.eq.ntypl) go to 7 + ix(ixc)=0 + ix(ixc+1)=ntype + ixc=ixc+2 + if(ntype.ne.4) go to 4 + indexp=(index-1)*9 + ix(ixc)=kkp+1 + ix(ixc+1)=indexp+1 + ixc=ixc+2 + go to 6 +4 ix(ixc)=kkp+1 + ixc=ixc+1 +6 ntypl=ntype + return +7 if(ntype.ne.4) go to 8 + indexp=(index-1)*9 + ix(ixc)=kkp+1 + ix(ixc+1)=indexp+1 + ixc=ixc+2 + return +8 ix(ixc)=kkp+1 + ixc=ixc+1 + return + end diff --git a/math/ieee/chap1/radix4.f b/math/ieee/chap1/radix4.f new file mode 100644 index 00000000..cd703305 --- /dev/null +++ b/math/ieee/chap1/radix4.f @@ -0,0 +1,488 @@ +c +c----------------------------------------------------------------------- +c subroutine: radix4 +c computes forward or inverse complex dft via radix-4 fft. +c uses autogen technique to yield time efficient program. +c----------------------------------------------------------------------- +c + subroutine radix4(mm,iflag,jflag) +c +c input: +c mm = power of 4 (i.e., n = 4**mm complex point transform) +c (mm.ge.2 and mm.le.5) +c +c iflag = 1 on first pass for given n +c = 0 on subsequent passes for given n +c +c jflag = -1 for forward transform +c = +1 for inverse transform +c +c input/output: +c a = array of dimensions 2*n with real and imaginary parts +c of dft input/output in odd, even array components. +c +c for optimal time efficiency, common is used to pass arrays. +c this means that dimensions of arrays a, ix, and t can be +c modified to reflect maximum value of n = 4**mm to be used. note +c that array "ix" is also dimensioned in subroutine "rad4sb". +c +c i.e., a( ) ix( ) t( ) +c +c m =2 32 38 27 +c m<=3 128 144 135 +c m<=4 512 658 567 +c m<=5 2048 2996 2295 +c + dimension a(2048),ix(2996),t(2295) + dimension nfac(11),np(209) + common ntypl,kkp,index,ixc + common /aa/a + common /xx/ix +c +c check for mm<2 or mm>5 +c + if(mm.lt.2.or.mm.gt.5)stop +c +c initialize on first pass """""""""""""""""""""""""""""""""""""""" +c + if(iflag.eq.1) go to 9999 +c +c fast fourier transform start #################################### +c +8885 kspan=2*4**mm + if(jflag.eq.1) go to 8887 +c +c conjugate data for forward transform +c + do 8886 j=2,n2,2 +8886 a(j)=-a(j) + go to 8889 +c +c multiply data by n**(-1) if inverse transform +c +8887 do 8888 j=1,n2,2 + a(j)=a(j)*xp +8888 a(j+1)=a(j+1)*xp +8889 i=3 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8),it +c*********************************************************************** +c +c 8 multiply butterfly +c +1 kk=ix(i) +c +11 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan +c + akp=a(kk)+a(k2) + akm=a(kk)-a(k2) + ajp=a(k1)+a(k3) + ajm=a(k1)-a(k3) + a(kk)=akp+ajp +c + bkp=a(kk+1)+a(k2+1) + bkm=a(kk+1)-a(k2+1) + bjp=a(k1+1)+a(k3+1) + bjm=a(k1+1)-a(k3+1) + a(kk+1)=bkp+bjp +c + bjp=bkp-bjp +c + a(k2+1)=(akp+bjp-ajp)*c707 + a(k2)=a(k2+1)+bjp*cm141 +c + bkp=bkm+ajm + akp=akm-bjm +c + ac0=(akp+bkp)*c924 + a(k1+1)=ac0+akp*cm541 + a(k1) =ac0+bkp*cm131 +c + bkm=bkm-ajm + akm=akm+bjm +c + ac0=(akm+bkm)*c383 + a(k3+1)=ac0+akm*c541 + a(k3) =ac0+bkm*cm131 +c + i=i+1 + kk=ix(i) + if (kk) 111,111,11 +111 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c 4 multiply butterfly +c +2 kk=ix(i) +c +22 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan +c + akp=a(kk)+a(k2) + akm=a(kk)-a(k2) + ajp=a(k1)+a(k3) + ajm=a(k1)-a(k3) + a(kk)=akp+ajp +c + bkp=a(kk+1)+a(k2+1) + bkm=a(kk+1)-a(k2+1) + bjp=a(k1+1)+a(k3+1) + bjm=a(k1+1)-a(k3+1) + a(kk+1)=bkp+bjp + a(k2)=-bkp+bjp + a(k2+1)=akp-ajp +c + bkp=bkm+ajm +c + a(k1+1)=(bkp+akm-bjm)*c707 + a(k1)=a(k1+1)+bkp*cm141 +c + akm=akm+bjm +c + a(k3+1)=(akm+ajm-bkm)*c707 + a(k3)=a(k3+1)+akm*cm141 +c + i=i+1 + kk=ix(i) + if (kk) 222,222,22 +222 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c 8 multiply butterfly +c +3 kk=ix(i) +c +33 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan +c + akp=a(kk)+a(k2) + akm=a(kk)-a(k2) + ajp=a(k1)+a(k3) + ajm=a(k1)-a(k3) + a(kk)=akp+ajp +c + bkp=a(kk+1)+a(k2+1) + bkm=a(kk+1)-a(k2+1) + bjp=a(k1+1)+a(k3+1) + bjm=a(k1+1)-a(k3+1) + a(kk+1)=bkp+bjp +c + ajp=akp-ajp +c + a(k2+1)=(ajp+bjp-bkp)*c707 + a(k2)=a(k2+1)+ajp*cm141 +c + bkp=bkm+ajm + akp=akm-bjm +c + ac0=(akp+bkp)*c383 + a(k1+1)=ac0+akp*c541 + a(k1) =ac0+bkp*cm131 +c + bkm=bkm-ajm + akm=akm+bjm +c + ac0=(akm+bkm)*cm924 + a(k3+1)=ac0+akm*c541 + a(k3) =ac0+bkm*c131 +c + i=i+1 + kk=ix(i) + if (kk) 333,333,33 +333 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c general 9 multiply butterfly +c +4 kk=ix(i) +c +44 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan +c + akp=a(kk)+a(k2) + akm=a(kk)-a(k2) + ajp=a(k1)+a(k3) + ajm=a(k1)-a(k3) + a(kk)=akp+ajp +c + bkp=a(kk+1)+a(k2+1) + bkm=a(kk+1)-a(k2+1) + bjp=a(k1+1)+a(k3+1) + bjm=a(k1+1)-a(k3+1) + a(kk+1)=bkp+bjp +c + ajp=akp-ajp + bjp=bkp-bjp +c + j=ix(i+1) +c + ac0=(ajp+bjp)*t(j+8) + a(k2+1)=ac0+ajp*t(j+6) + a(k2) =ac0+bjp*t(j+7) +c + bkp=bkm+ajm + akp=akm-bjm +c + ac0=(akp+bkp)*t(j+5) + a(k1+1)=ac0+akp*t(j+3) + a(k1) =ac0+bkp*t(j+4) +c + bkm=bkm-ajm + akm=akm+bjm +c + ac0=(akm+bkm)*t(j+2) + a(k3+1)=ac0+akm*t(j) + a(k3) =ac0+bkm*t(j+1) +c + i=i+2 + kk=ix(i) + if (kk) 444,444,44 +444 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c 0 multiply butterfly +c +5 kk=ix(i) +c +55 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan +c + akp=a(kk)+a(k2) + akm=a(kk)-a(k2) + ajp=a(k1)+a(k3) + ajm=a(k1)-a(k3) + a(kk)=akp+ajp + a(k2)=akp-ajp +c + bkp=a(kk+1)+a(k2+1) + bkm=a(kk+1)-a(k2+1) + bjp=a(k1+1)+a(k3+1) + bjm=a(k1+1)-a(k3+1) + a(kk+1)=bkp+bjp + a(k2+1)=bkp-bjp +c + a(k3+1)=bkm-ajm + a(k1+1)=bkm+ajm + a(k3)=akm+bjm + a(k1)=akm-bjm +c + i=i+1 + kk=ix(i) + if (kk) 555,555,55 +555 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c offset reduced +c +6 kspan=kspan/4 + i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +c +c bit reversal (shuffling) +c +7 ip1=ix(i) +77 ip2=ix(i+1) + t1=a(ip2) + a(ip2)=a(ip1) + a(ip1)=t1 + t1=a(ip2+1) + a(ip2+1)=a(ip1+1) + a(ip1+1)=t1 + i=i+2 + ip1=ix(i) + if (ip1) 777,777,77 +777 i=i+2 + it=ix(i-1) + go to (1,2,3,4,5,6,7,8), it +c*********************************************************************** +8 if(jflag.eq.1) go to 888 +c +c conjugate output if forward transform +c + do 88 j=2,n2,2 +88 a(j)=-a(j) +888 return +c +c fast fourier transform ends ##################################### +c +c initialization phase starts. done only once +c +9999 ixc=1 + n=4**mm + xp=n + xp=1./xp + ntot=n + n2=n*2 + nspan=n + n1test=n/16 + n2test=n/8 + n3test=(3*n)/16 + nspan4=nspan/4 + ibase=0 + isn=1 + inc=isn + rad=8.0*atan(1.0) + pi=4.*atan(1.0) + c707=sin(pi/4.) + cm141=-2.*c707 + c383=sin(pi/8.) + c924=cos(pi/8.) + cm924=-c924 + c541=c924-c383 + cm541=-c541 + c131=c924+c383 + cm131=-c131 +10 nt=inc*ntot + ks=inc*nspan + kspan=ks + jc=ks/n + radf=rad*float(jc)*.5 + i=0 +c +c determine the factors of n +c all factors must be 4 for this version +c + m=0 + k=n +15 m=m+1 + nfac(m)=4 + k=k/4 +20 if(k-(k/4)*4.eq.0) go to 15 + kt=1 + if(n.ge.256) kt=2 + kspan0=kspan + ntypl=0 +c +100 ndelta=kspan0/kspan + index=0 + sd=radf/float(kspan) + cd=2.0*sin(sd)**2 + sd=sin(sd+sd) + kk=1 + i=i+1 +c +c transform for a factor of 4 +c + kspan=kspan/4 + ix(ixc)=0 + ix(ixc+1)=6 + ixc=ixc+2 +c +410 c1=1.0 + s1=0.0 +420 k1=kk+kspan + k2=k1+kspan + k3=k2+kspan + if(s1.eq.0.0) go to 460 +430 if(kspan.ne.nspan4) go to 431 + t(ibase+5)=-(s1+c1) + t(ibase+6)=c1 + t(ibase+4)=s1-c1 + t(ibase+8)=-(s2+c2) + t(ibase+9)=c2 + t(ibase+7)=s2-c2 + t(ibase+2)=-(s3+c3) + t(ibase+3)=c3 + t(ibase+1)=s3-c3 + ibase=ibase+9 +c +431 kkp=(kk-1)*2 + if(index.ne.n1test) go to 150 + call rad4sb(1) + go to 5035 +150 if(index.ne.n2test) go to 160 + call rad4sb(2) + go to 5035 +160 if(index.ne.n3test) go to 170 + call rad4sb(3) + go to 5035 +170 call rad4sb(4) +5035 kk=k3+kspan + if(kk.le.nt) go to 420 +440 index=index+ndelta + c2=c1-(cd*c1+sd*s1) + s1=(sd*c1-cd*s1)+s1 + c1=c2 + c2=c1*c1-s1*s1 + s2=c1*s1+c1*s1 + c3=c2*c1-s2*s1 + s3=c2*s1+s2*c1 + kk=kk-nt+jc + if(kk.le.kspan) go to 420 + kk=kk-kspan+inc + if(kk.le.jc) go to 410 + if(kspan.eq.jc) go to 800 + go to 100 +460 kkp=(kk-1)*2 + call rad4sb(5) +5050 kk=k3+kspan + if(kk.le.nt) go to 420 + go to 440 +c +800 ix(ixc)=0 + ix(ixc+1)=7 + ixc=ixc+2 +c +c compute parameters to permute the results to normal order +c done in two steps +c permutation for square factors of n +c + np(1)=ks + k=kt+kt+1 + if(m.lt.k) k=k-1 + j=1 + np(k+1)=jc +810 np(j+1)=np(j)/nfac(j) + np(k)=np(k+1)*nfac(j) + j=j+1 + k=k-1 + if(j.lt.k) go to 810 + k3=np(k+1) + kspan=np(2) + kk=jc+1 + k2=kspan+1 + j=1 +c +c permutation for single variate transform +c +820 kkp=(kk-1)*2 + k2p=(k2-1)*2 + ix(ixc)=kkp+1 + ix(ixc+1)=k2p+1 + ixc=ixc+2 + kk=kk+inc + k2=kspan+k2 + if(k2.lt.ks) go to 820 +830 k2=k2-np(j) + j=j+1 + k2=np(j+1)+k2 + if(k2.gt.np(j)) go to 830 + j=1 +840 if(kk.lt.k2) go to 820 + kk=kk+inc + k2=kspan+k2 + if(k2.lt.ks) go to 840 + if(kk.lt.ks) go to 830 + jc=k3 + ix(ixc)=0 + ix(ixc+1)=8 + go to 8885 + end diff --git a/math/ieee/chap1/test/test12.f b/math/ieee/chap1/test/test12.f new file mode 100644 index 00000000..a830ab2c --- /dev/null +++ b/math/ieee/chap1/test/test12.f @@ -0,0 +1,90 @@ +c +c----------------------------------------------------------------------- +c main program: fastmain - fast fourier transforms +c authors: g. d. bergland and m. t. dolan +c bell laboratories, murray hill, new jersey 07974 +c +c input: the program calls on a random number +c generator for input and checks dft and +c idft with a 32-point sequence +c----------------------------------------------------------------------- +c + dimension x(32), y(32), b(34) +c +c generate random numbers and store array in b so +c the same sequence can be used in all tests. +c note that b is dimensioned to size n+2. +c +c iw is a machine dependent write device number +c + iw = i1mach(2) +c + do 10 i=1,32 + x(i) = uni(0) + b(i) = x(i) + 10 continue + m = 5 + n = 2**m + np1 = n + 1 + np2 = n + 2 + knt = 1 +c +c test fast-fsst then ffa-ffs +c + write (iw,9999) + 20 write (iw,9998) (b(i),i=1,n) + if (knt.eq.1) call fast(b, n) + if (knt.eq.2) call ffa(b, n) + write (iw,9997) (b(i),i=1,np1,2) + write (iw,9996) (b(i),i=2,np2,2) + if (knt.eq.1) call fsst(b, n) + if (knt.eq.2) call ffs(b, n) + write (iw,9995) (b(i),i=1,n) + knt = knt + 1 + if (knt.eq.3) go to 40 +c + write (iw,9994) + do 30 i=1,n + b(i) = x(i) + 30 continue + go to 20 +c +c test fft842 with real input then complex +c + 40 write (iw,9993) + do 50 i=1,n + b(i) = x(i) + y(i) = 0. + 50 continue + 60 write (iw,9992) (b(i),i=1,n) + write (iw,9991) (y(i),i=1,n) + call fft842(0, n, b, y) + write (iw,9997) (b(i),i=1,n) + write (iw,9996) (y(i),i=1,n) + call fft842(1, n, b, y) + write (iw,9990) (b(i),i=1,n) + write (iw,9989) (y(i),i=1,n) + knt = knt + 1 + if (knt.eq.5) go to 80 +c + write (iw,9988) + do 70 i=1,n + b(i) = x(i) + y(i) = uni(0) + 70 continue + go to 60 +c +9999 format (19h1test fast and fsst) +9998 format (20h0real input sequence/(4e17.8)) +9997 format (29h0real components of transform/(4e17.8)) +9996 format (29h0imag components of transform/(4e17.8)) +9995 format (23h0real inverse transform/(4e17.8)) +9994 format (17h1test ffa and ffs) +9993 format (37h1test fft842 with real input sequence/(4e17.8)) +9992 format (34h0real components of input sequence/(4e17.8)) +9991 format (34h0imag components of input sequence/(4e17.8)) +9990 format (37h0real components of inverse transform/(4e17.8)) +9989 format (37h0imag components of inverse transform/(4e17.8)) +9988 format (40h1test fft842 with complex input sequence) + 80 stop + end diff --git a/math/ieee/chap1/test/test13.f b/math/ieee/chap1/test/test13.f new file mode 100644 index 00000000..d7157069 --- /dev/null +++ b/math/ieee/chap1/test/test13.f @@ -0,0 +1,260 @@ +c +c----------------------------------------------------------------------- +c main program: test program for fft subroutines +c author: l r rabiner +c bell laboratories, murray hill, new jersey, 07974 +c input: randomly chosen sequences to test fft subroutines +c for sequences with special properties +c n is the fft length (n must be a power of 2) +c 2<= n <= 4096 +c----------------------------------------------------------------------- +c + dimension x(4098), y(4098) +c +c define i/0 device codes +c input: input to this program is user-interactive +c that is - a question is written on the user +c terminal (iout1) ad the user types in the answer. +c +c output: all output is written on the standard +c output unit (iout2). +c + ind = i1mach(1) + iout1 = i1mach(4) + iout2 = i1mach(2) +c +c read in analysis size for fft +c + 10 write (iout1,9999) +9999 format (30h fft size(2.le.n.le.4096)(i4)=) + read (ind,9998) n +9998 format (i4) + if (n.eq.0) stop + do 20 i=1,12 + itest = 2**i + if (n.eq.itest) go to 30 + 20 continue + write (iout1,9997) +9997 format (45h n is not a power of 2 in the range 2 to 4096) + go to 10 + 30 write (iout2,9996) n +9996 format (11h testing n=, i5, 17h random sequences) + write (iout2,9992) + np2 = n + 2 + no2 = n/2 + no2p1 = no2 + 1 + no4 = n/4 + no4p1 = no4 + 1 +c +c create symmetrical sequence of size n +c + do 40 i=2,no2 + x(i) = uni(0) - 0.5 + ind1 = np2 - i + x(ind1) = x(i) + 40 continue + x(1) = uni(0) - 0.5 + x(no2p1) = uni(0) - 0.5 + do 50 i=1,no2p1 + y(i) = x(i) + 50 continue + write (iout2,9995) +9995 format (28h original symmetric sequence) + write (iout2,9993) (x(i),i=1,n) + write (iout2,9992) +c +c compute true fft of n point sequence +c + call fast(x, n) + write (iout2,9994) n +9994 format (1h , i4, 32h point fft of symmetric sequence) + write (iout2,9993) (x(i),i=1,np2) +9993 format (1h , 5e13.5) + write (iout2,9992) +9992 format (1h /1h ) +c +c use subroutine fftsym to obtain dft from no2 point fft +c + do 60 i=1,no2p1 + x(i) = y(i) + 60 continue + call fftsym(x, n, y) + write (iout2,9991) +9991 format (17h output of fftsym) + write (iout2,9993) (x(i),i=1,no2p1) + write (iout2,9992) +c +c use subroutine iftsym to obtain original sequence from no2 point dft +c + call iftsym(x, n, y) + write (iout2,9990) +9990 format (17h output of iftsym) + write (iout2,9993) (x(i),i=1,no2p1) + write (iout2,9992) +c +c create antisymmetric n point sequence +c + do 70 i=2,no2 + x(i) = uni(0) - 0.5 + ind1 = np2 - i + x(ind1) = -x(i) + 70 continue + x(1) = 0. + x(no2p1) = 0. + do 80 i=1,no2p1 + y(i) = x(i) + 80 continue + write (iout2,9989) +9989 format (32h original antisymmetric sequence) + write (iout2,9993) (x(i),i=1,n) + write (iout2,9992) +c +c obtain n point dft of antisymmetric sequence +c + call fast(x, n) + write (iout2,9988) n +9988 format (1h , i4, 36h point fft of antisymmetric sequence) + write (iout2,9993) (x(i),i=1,np2) + write (iout2,9992) +c +c use subroutine fftasm to obtain dft from no2 point fft +c + do 90 i=1,no2 + x(i) = y(i) + 90 continue + call fftasm(x, n, y) + write (iout2,9987) +9987 format (17h output of fftasm) + write (iout2,9993) (x(i),i=1,no2p1) + write (iout2,9992) +c +c use subroutine iftasm to obtain original sequence from no2 point dft +c + call iftasm(x, n, y) + write (iout2,9986) +9986 format (17h output of iftasm) + write (iout2,9993) (x(i),i=1,no2) + write (iout2,9992) +c +c create sequence with only odd harmonics--begin in frequency domain +c + do 100 i=1,np2,2 + x(i) = 0. + x(i+1) = 0. + if (mod(i,4).eq.1) go to 100 + x(i) = uni(0) - 0.5 + x(i+1) = uni(0) - 0.5 + if (n.eq.2) x(i+1) = 0. + 100 continue + write (iout2,9985) n +9985 format (1h , i4, 35h point fft of odd harmonic sequence) + write (iout2,9993) (x(i),i=1,np2) + write (iout2,9992) +c +c transform back to time sequence +c + call fsst(x, n) + write (iout2,9984) +9984 format (31h original odd harmonic sequence) + write (iout2,9993) (x(i),i=1,n) + write (iout2,9992) +c +c use subroutine fftohm to obtain dft from no2 point fft +c + call fftohm(x, n) + write (iout2,9983) +9983 format (17h output of fftohm) + write (iout2,9993) (x(i),i=1,no2) + write (iout2,9992) +c +c use subroutine iftohm to obtain original sequence from no2 point dft +c + call iftohm(x, n) + write (iout2,9982) +9982 format (17h output of iftohm) + write (iout2,9993) (x(i),i=1,no2) + write (iout2,9992) +c +c create sequence with only real valued odd harmonics +c + do 110 i=1,np2,2 + x(i) = 0. + x(i+1) = 0. + if (mod(i,4).eq.1) go to 110 + x(i) = uni(0) - 0.5 + 110 continue + write (iout2,9981) n +9981 format (1h , i4, 45h point fft of odd harmonic, symmetric sequenc, + * 1he) + write (iout2,9993) (x(i),i=1,np2) + write (iout2,9992) +c +c transform back to time sequence +c + call fsst(x, n) + write (iout2,9980) +9980 format (42h original odd harmonic, symmetric sequence) + write (iout2,9993) (x(i),i=1,n) + write (iout2,9992) +c +c use subroutine fftsoh to obtain dft from no4 point fft +c + call fftsoh(x, n, y) + write (iout2,9979) +9979 format (17h output of fftsoh) + write (iout2,9993) (x(i),i=1,no4) + write (iout2,9992) +c +c use subroutine iftsoh to obtain original sequence from no4 point dft +c + call iftsoh(x, n, y) + write (iout2,9978) +9978 format (17h output of iftsoh) + write (iout2,9993) (x(i),i=1,no4) + write (iout2,9992) +c +c create sequence with only imaginary valued odd harmonics--begin +c in frequency domain +c + do 120 i=1,np2,2 + x(i) = 0. + x(i+1) = 0. + if (mod(i,4).eq.1) go to 120 + x(i+1) = uni(0) - 0.5 + 120 continue + write (iout2,9977) n +9977 format (1h , i4, 41h point fft of odd harmonic, antisymmetric, + * 9h sequence) + write (iout2,9993) (x(i),i=1,np2) + write (iout2,9992) +c +c transform back to time sequence +c + call fsst(x, n) + write (iout2,9976) +9976 format (46h original odd harmonic, antisymmetric sequence) + write (iout2,9993) (x(i),i=1,n) + write (iout2,9992) +c +c use subroutine fftaoh to obtain dft from no4 point fft +c + call fftaoh(x, n, y) + write (iout2,9975) +9975 format (17h output of fftaoh) + write (iout2,9993) (x(i),i=1,no4) + write (iout2,9992) +c +c use subroutine iftaoh to obtain original sequence from n/4 point dft +c + call iftaoh(x, n, y) + write (iout2,9974) +9974 format (17h output of iftaoh) + write (iout2,9993) (x(i),i=1,no4p1) + write (iout2,9992) +c +c begin a new page +c + write (iout2,9973) +9973 format (1h1) + go to 10 + end diff --git a/math/ieee/chap1/test/test17.f b/math/ieee/chap1/test/test17.f new file mode 100644 index 00000000..15a34788 --- /dev/null +++ b/math/ieee/chap1/test/test17.f @@ -0,0 +1,147 @@ +c +c----------------------------------------------------------------------- +c main program: test program to exercise the wfta subroutine +c the test waveform is a complex exponential a**i whose +c transform is known analytically to be (1 - a**n)/(1 - a*w**k). +c +c authors: +c james h. mcclellan and hamid nawab +c department of electrical engineering and computer science +c massachusetts of technology +c cambridge, mass. 02139 +c +c inputs: +c n-- transform length. it must be formed as the product of +c relatively prime integers from the set: +c 2,3,4,5,7,8,9,16 +c invrs is the flag for forward or inverse transform. +c invrs = 1 yields inverse transform +c invrs .ne. 1 gives forward transform +c rad and phi are the magnitude and angle (as a fraction of +c 2*pi/n) of the complex exponential test signal. +c suggestion: rad = 0.98, phi = 0.5. +c----------------------------------------------------------------------- +c + double precision pi2,pin,xn,xj,xt + dimension xr(1260),xi(1260) + complex cone,ca,can,cnum,cden +c +c output will be punched +c + iout=i1mach(3) + input=i1mach(1) + cone=cmplx(1.0,0.0) + pi2=8.0d0*datan(1.0d0) +50 continue + read(input,130)n +130 format(i5) + write(iout,150) n +150 format(10h length = ,i5) + if(n.le.0 .or. n.gt.1260) stop +c +c enter a 1 to perform the inverse +c +c read(input,130) invrs + invrs = 0 +c +c enter magnitude and angle (in fraction of 2*pi/n) +c avoid multiples of n for the angle if the radius is +c close to one. suggestion: rad = 0.98, phi = 0.5. +c +c read(input,160) rad,phi + rad = 0.98 + phi = 0.5 +160 format(2f15.10) + xn=float(n) + pin=phi + pin=pin*pi2/xn +c +c generate z**j +c + init=0 + do 200 j=1,n + an=rad**(j-1) + xj=j-1 + xj=xj*pin + xt=dcos(xj) + xr(j)=xt + xr(j)=xr(j)*an + xt=dsin(xj) + xi(j)=xt + xi(j)=xi(j)*an +200 continue + can=cmplx(xr(n),xi(n)) + ca=cmplx(xr(2),xi(2)) + can=can*ca +c +c print first 50 values of input sequence +c + max=50 + if(n.lt.50)max=n + write(iout,300)(j,xr(j),xi(j),j=1,max) +c +c call the winograd fourier transform algorithm +c + call wfta(xr,xi,n,invrs,init,ierr) +c +c check for error return +c + if(ierr.lt.0) write(iout,250) ierr +250 format(1x,5herror,i5) + if(ierr.lt.0) go to 50 +c +c print first 50 values of the transformed sequence +c + write(iout,300)(j,xr(j),xi(j),j=1,max) +300 format(1x,3hj =,i3,6hreal =,e20.12,6himag =,e20.12) +c +c calculate absolute and relative deviations +c + devabs=0.0 + devrel=0.0 + cnum=cone-can + pin=pi2/xn + do 350 j=1,n + xj=j-1 + xj=-xj*pin + if(invrs.eq.1) xj=-xj + tr=dcos(xj) + ti=dsin(xj) + can=cmplx(tr,ti) + cden=cone-ca*can + cden=cnum/cden +c +c true value of the transform (1. - a**n)/(1. - a*w**k), +c where a = rad*exp(j*phi*(2*pi/n)), w = exp(-j*2*pi/n). +c for the inverse transform the complex exponential w +c is conjugated. +c + tr=real(cden) + ti=aimag(cden) + if(invrs.ne.1) go to 330 +c +c scale inverse transform by 1/n +c + tr=tr/float(n) + ti=ti/float(n) +330 tr=xr(j)-tr + ti=xi(j)-ti + devabs=sqrt(tr*tr+ti*ti) + xmag=sqrt(xr(j)*xr(j)+xi(j)*xi(j)) + devrel=100.0*devabs/xmag + if(devabs.le.devmx1)go to 340 + devmx1=devabs + labs=j-1 +340 if(devrel.le.devmx2)go to 350 + devmx2=devrel + lrel=j-1 +350 continue +c +c print the absolute and relative deviations together +c with their locations. +c + write(iout,380) devabs,labs,devrel,lrel +380 format(1x,21habsolute deviation = ,e20.12,9h at index,i5/ + 1 1x,21hrelative deviation = ,f11.7,8h percent,1x,9h at index,i5) + go to 50 + end diff --git a/math/ieee/chap1/test/test18.f b/math/ieee/chap1/test/test18.f new file mode 100644 index 00000000..cf550e01 --- /dev/null +++ b/math/ieee/chap1/test/test18.f @@ -0,0 +1,71 @@ +c +c----------------------------------------------------------------------- +c main program: time-efficient radix-4 fast fourier transform +c author: l. robert morris +c department of systems engineering and computing science +c carleton university, ottawa, canada k1s 5b6 +c +c input: the array "a" contains the data to be transformed +c----------------------------------------------------------------------- +c +c test program for autogen radix-4 fft +c + dimension a(2048),b(2048) + common /aa/a +c + ioutd=i1mach(2) +c +c compute dft and idft for n = 64, 256, and 1024 complex points +c + do 1 mm=3,5 + n=4**mm + do 2 j=1,n + a(2*j-1)=uni(0) + a(2*j )=uni(0) + b(2*j-1)=a(2*j-1) +2 b(2*j )=a(2*j) +c +c forward dft +c + call radix4(mm,1,-1) +c + if(mm.ne.3) go to 5 +c +c list dft input, output for n = 64 only +c + write(ioutd,98) + write(ioutd,100) + do 3 j=1,n + write(ioutd,96) b(2*j-1),b(2*j),a(2*j-1),a(2*j) +3 continue +c +c inverse dft +c +5 call radix4(mm,0, 1) +c +c list dft input, idft output for n = 64 only +c + if(mm.ne.3) go to 7 +c + write(ioutd,99) + write(ioutd,100) + do 6 j=1,n + write(ioutd,96) b(2*j-1),b(2*j),a(2*j-1),a(2*j) +6 continue +c +c calculate rms error +c +7 err=0.0 + do 8 j=1,n +8 err=err+(a(2*j-1)-b(2*j-1))**2+(a(2*j)-b(2*j))**2 + err=sqrt(err/float(n)) + write(ioutd,97) mm,err +1 continue +c +96 format(1x,4(f10.6,2x)) +97 format(1x,20h rms error for m =,i2,4h is ,e14.6/) +98 format(1x,43h dft input dft output/) +99 format(1x,43h dft input idft output/) +100 format(1x,44h real imag real imag/) + stop + end diff --git a/math/ieee/chap1/time/time12.f b/math/ieee/chap1/time/time12.f new file mode 100644 index 00000000..774c2cc9 --- /dev/null +++ b/math/ieee/chap1/time/time12.f @@ -0,0 +1,53 @@ +c----------------------------------------------------------------------- +c +c----------------------------------------------------------------------- +c + parameter (SIZE = 1024, ILOOP = 100) + complex a, w + real breal(SIZE), bimag(SIZE), qbreal(SIZE), qbimag(SIZE) +c + ioutd = i1mach(2) + nn = SIZE + tpi = 8.*atan(1.) + tpion = tpi/float(nn) + w = cmplx(cos(tpion),-sin(tpion)) +c +c generate a**k as test function +c result to b(i) for modification by dft and idft subroutines and +c a copy to qb(i) to compare final result with for error difference. +c + a = (.9,.3) + breal(1) = 1.0 + bimag(1) = 0.0 + qbreal(1) = 1.0 + qbimag(1) = 0.0 + do 10 k=2,nn + w = a**(k-1) + breal(k) = real(w) + bimag(k) = aimag(w) + qbreal(k) = breal(k) + qbimag(k) = bimag(k) + 10 continue +c +c now compute dft, idft, dft, idft, ... +c first dft is computed specially, in case subroutine needs to be started. +c + call fft842(0, SIZE, breal, bimag) + do 25 icount = 1, ILOOP + call fft842(1, SIZE, breal, bimag) + call fft842(0, SIZE, breal, bimag) + 25 continue + call fft842(1, SIZE, breal, bimag) +c +c calculate rms error between b(i) and qb(i). +c + err = 0. + do 30 i=1,nn + err = err + (breal(i)-qbreal(i))**2 + * + (bimag(i)-qbimag(i))**2 + 30 continue + err = sqrt(err / float(nn)) + write (ioutd,9994) ILOOP, err + 9994 format(' rms error, after ', i5, ' loops = ', e15.8) + stop + end diff --git a/math/ieee/chap1/time/time17.f b/math/ieee/chap1/time/time17.f new file mode 100644 index 00000000..adcce4c2 --- /dev/null +++ b/math/ieee/chap1/time/time17.f @@ -0,0 +1,53 @@ +c----------------------------------------------------------------------- +c +c----------------------------------------------------------------------- +c + parameter (SIZE = 1008, ILOOP = 100) + complex a, w + real breal(SIZE), bimag(SIZE), qbreal(SIZE), qbimag(SIZE) +c + ioutd = i1mach(2) + nn = SIZE + tpi = 8.*atan(1.) + tpion = tpi/float(nn) + w = cmplx(cos(tpion),-sin(tpion)) +c +c generate a**k as test function +c result to b(i) for modification by dft and idft subroutines and +c a copy to qb(i) to compare final result with for error difference. +c + a = (.9,.3) + breal(1) = 1.0 + bimag(1) = 0.0 + qbreal(1) = 1.0 + qbimag(1) = 0.0 + do 10 k=2,nn + w = a**(k-1) + breal(k) = real(w) + bimag(k) = aimag(w) + qbreal(k) = breal(k) + qbimag(k) = bimag(k) + 10 continue +c +c now compute dft, idft, dft, idft, ... +c first dft is computed specially, in case subroutine needs to be started. +c + call wfta(breal, bimag, SIZE, 0, 0, ierr) + do 25 icount = 1, ILOOP + call wfta(breal, bimag, SIZE, 1, 1, ierr) + call wfta(breal, bimag, SIZE, 0, 1, ierr) + 25 continue + call wfta(breal, bimag, SIZE, 1, 1, ierr) +c +c calculate rms error between b(i) and qb(i). +c + err = 0. + do 30 i=1,nn + err = err + (breal(i)-qbreal(i))**2 + * + (bimag(i)-qbimag(i))**2 + 30 continue + err = sqrt(err / float(nn)) + write (ioutd,9994) ILOOP, err + 9994 format(' rms error, after ', i5, ' loops = ', e15.8) + stop + end diff --git a/math/ieee/chap1/time/time18.f b/math/ieee/chap1/time/time18.f new file mode 100644 index 00000000..87680554 --- /dev/null +++ b/math/ieee/chap1/time/time18.f @@ -0,0 +1,48 @@ +c----------------------------------------------------------------------- +c +c----------------------------------------------------------------------- +c + parameter (SIZE = 1024, ILOOP = 100) + complex w, b(SIZE), qb(SIZE), a + common /aa/ b +c + ioutd = i1mach(2) + nn = SIZE + tpi = 8.*atan(1.) + tpion = tpi/float(nn) + w = cmplx(cos(tpion),-sin(tpion)) +c +c generate a**k as test function +c result to b(i) for modification by dft and idft subroutines and +c a copy to qb(i) to compare final result with for error difference. +c + a = (.9,.3) + b(1) = (1.,0.) + qb(1) = b(1) + do 10 k=2,nn + b(k) = a**(k-1) + qb(k) = b(k) + 10 continue +c +c now compute dft, idft, dft, idft, ... +c first dft is computed specially, in case subroutine needs to be started. +c + call radix4(5, 1, -1) + do 25 icount = 1, ILOOP + call radix4(5, 0, 1) + call radix4(5, 0, -1) + 25 continue + call radix4(5, 0, 1) +c +c calculate rms error between b(i) and qb(i). +c + err = 0. + do 30 i=1,nn + de = cabs(qb(i)-b(i)) + err = err + de**2 + 30 continue + err = sqrt(err / float(nn)) + write (ioutd,9994) ILOOP, err + 9994 format(' rms error, after ', i5, ' loops = ', e15.8) + stop + end diff --git a/math/ieee/chap1/weave1.f b/math/ieee/chap1/weave1.f new file mode 100644 index 00000000..9c83d0ea --- /dev/null +++ b/math/ieee/chap1/weave1.f @@ -0,0 +1,371 @@ +c +c----------------------------------------------------------------------- +c subroutine: weave1 +c this subroutine implements the different pre-weave +c modules of the wfta. the working arrays are sr and si. +c the routine checks to see which factors are present +c in the transform length n = na*nb*nc*nd and executes +c the pre-weave code for these factors. +c +c----------------------------------------------------------------------- +c + subroutine weave1(sr,si) + common na,nb,nc,nd,nd1,nd2,nd3,nd4 + dimension q(8),t(16) + dimension sr(1),si(1) + if(na.eq.1) go to 300 + if(na.ne.2) go to 800 +c +c ********************************************************************** +c +c the following code implements the 2 point pre-weave module +c +c ********************************************************************** +c + nlup2=2*(nd2-nb) + nlup23=2*nd2*(nd3-nc) + nbase=1 + do 240 n4=1,nd + do 230 n3=1,nc + do 220 n2=1,nb + nr1=nbase+1 + t0=sr(nbase)+sr(nr1) + sr(nr1)=sr(nbase)-sr(nr1) + sr(nbase)=t0 + t0=si(nbase)+si(nr1) + si(nr1)=si(nbase)-si(nr1) + si(nbase)=t0 +220 nbase=nbase+2 +230 nbase=nbase+nlup2 +240 nbase=nbase+nlup23 +800 if(na.ne.8) go to 1600 +c +c ********************************************************************** +c +c the following code implements the 8 point pre-weave module +c +c ********************************************************************** +c + nlup2=8*(nd2-nb) + nlup23=8*nd2*(nd3-nc) + nbase=1 + do 840 n4=1,nd + do 830 n3=1,nc + do 820 n2=1,nb + nr1=nbase+1 + nr2=nr1+1 + nr3=nr2+1 + nr4=nr3+1 + nr5=nr4+1 + nr6=nr5+1 + nr7=nr6+1 + t3=sr(nr3)+sr(nr7) + t7=sr(nr3)-sr(nr7) + t0=sr(nbase)+sr(nr4) + sr(nr4)=sr(nbase)-sr(nr4) + t1=sr(nr1)+sr(nr5) + t5=sr(nr1)-sr(nr5) + t2=sr(nr2)+sr(nr6) + sr(nr6)=sr(nr2)-sr(nr6) + sr(nbase)=t0+t2 + sr(nr2)=t0-t2 + sr(nr1)=t1+t3 + sr(nr3)=t1-t3 + sr(nr5)=t5+t7 + sr(nr7)=t5-t7 + t3=si(nr3)+si(nr7) + t7=si(nr3)-si(nr7) + t0=si(nbase)+si(nr4) + si(nr4)=si(nbase)-si(nr4) + t1=si(nr1)+si(nr5) + t5=si(nr1)-si(nr5) + t2=si(nr2)+si(nr6) + si(nr6)=si(nr2)-si(nr6) + si(nbase)=t0+t2 + si(nr2)=t0-t2 + si(nr1)=t1+t3 + si(nr3)=t1-t3 + si(nr5)=t5+t7 + si(nr7)=t5-t7 +820 nbase=nbase+8 +830 nbase=nbase+nlup2 +840 nbase=nbase+nlup23 +1600 if(na.ne.16) go to 300 +c +c ********************************************************************** +c +c the following code implements the 16 point pre-weave module +c +c ********************************************************************** +c + nlup2=18*(nd2-nb) + nlup23=18*nd2*(nd3-nc) + nbase=1 + do 1640 n4=1,nd + do 1630 n3=1,nc + do 1620 n2=1,nb + nr1=nbase+1 + nr2=nr1+1 + nr3=nr2+1 + nr4=nr3+1 + nr5=nr4+1 + nr6=nr5+1 + nr7=nr6+1 + nr8=nr7+1 + nr9=nr8+1 + nr10=nr9+1 + nr11=nr10+1 + nr12=nr11+1 + nr13=nr12+1 + nr14=nr13+1 + nr15=nr14+1 + nr16=nr15+1 + nr17=nr16+1 + jbase=nbase + do 1645 j=1,8 + t(j)=sr(jbase)+sr(jbase+8) + t(j+8)=sr(jbase)-sr(jbase+8) + jbase=jbase+1 +1645 continue + do 1650 j=1,4 + q(j)=t(j)+t(j+4) + q(j+4)=t(j)-t(j+4) +1650 continue + sr(nbase)=q(1)+q(3) + sr(nr2)=q(1)-q(3) + sr(nr1)=q(2)+q(4) + sr(nr3)=q(2)-q(4) + sr(nr5)=q(6)+q(8) + sr(nr7)=q(6)-q(8) + sr(nr4)=q(5) + sr(nr6)=q(7) + sr(nr8)=t(9) + sr(nr9)=t(10)+t(16) + sr(nr15)=t(10)-t(16) + sr(nr13)=t(14)+t(12) + sr(nr11)=t(14)-t(12) + sr(nr17)=sr(nr11)+sr(nr15) + sr(nr16)=sr(nr9)+sr(nr13) + sr(nr10)=t(11)+t(15) + sr(nr14)=t(11)-t(15) + sr(nr12)=t(13) + jbase=nbase + do 1745 j=1,8 + t(j)=si(jbase)+si(jbase+8) + t(j+8)=si(jbase)-si(jbase+8) + jbase=jbase+1 +1745 continue + do 1750 j=1,4 + q(j)=t(j)+t(j+4) + q(j+4)=t(j)-t(j+4) +1750 continue + si(nbase)=q(1)+q(3) + si(nr2)=q(1)-q(3) + si(nr1)=q(2)+q(4) + si(nr3)=q(2)-q(4) + si(nr5)=q(6)+q(8) + si(nr7)=q(6)-q(8) + si(nr4)=q(5) + si(nr6)=q(7) + si(nr8)=t(9) + si(nr9)=t(10)+t(16) + si(nr15)=t(10)-t(16) + si(nr13)=t(14)+t(12) + si(nr11)=t(14)-t(12) + si(nr17)=si(nr11)+si(nr15) + si(nr16)=si(nr9)+si(nr13) + si(nr10)=t(11)+t(15) + si(nr14)=t(11)-t(15) + si(nr12)=t(13) +1620 nbase=nbase+18 +1630 nbase=nbase+nlup2 +1640 nbase=nbase+nlup23 +300 if(nb.eq.1) go to 700 + if(nb.ne.3) go to 900 +c +c ********************************************************************** +c +c the following code implements the 3 point pre-weave module +c +c ********************************************************************** +c + nlup2=2*nd1 + nlup23=3*nd1*(nd3-nc) + nbase=1 + noff=nd1 + do 340 n4=1,nd + do 330 n3=1,nc + do 310 n2=1,nd1 + nr1=nbase+noff + nr2=nr1+noff + t1=sr(nr1)+sr(nr2) + sr(nbase)=sr(nbase)+t1 + sr(nr2)=sr(nr1)-sr(nr2) + sr(nr1)=t1 + t1=si(nr1)+si(nr2) + si(nbase)=si(nbase)+t1 + si(nr2)=si(nr1)-si(nr2) + si(nr1)=t1 +310 nbase=nbase+1 +330 nbase=nbase+nlup2 +340 nbase=nbase+nlup23 +900 if(nb.ne.9) go to 700 +c +c ********************************************************************** +c +c the following code implements the 9 point pre-weave module +c +c ********************************************************************** +c + nlup2=10*nd1 + nlup23=11*nd1*(nd3-nc) + nbase=1 + noff=nd1 + do 940 n4=1,nd + do 930 n3=1,nc + do 910 n2=1,nd1 + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + nr6=nr5+noff + nr7=nr6+noff + nr8=nr7+noff + nr9=nr8+noff + nr10=nr9+noff + t3=sr(nr3)+sr(nr6) + t6=sr(nr3)-sr(nr6) + sr(nbase)=sr(nbase)+t3 + t7=sr(nr7)+sr(nr2) + t2=sr(nr7)-sr(nr2) + sr(nr2)=t6 + t1=sr(nr1)+sr(nr8) + t8=sr(nr1)-sr(nr8) + sr(nr1)=t3 + t4=sr(nr4)+sr(nr5) + t5=sr(nr4)-sr(nr5) + sr(nr3)=t1+t4+t7 + sr(nr4)=t1-t7 + sr(nr5)=t4-t1 + sr(nr6)=t7-t4 + sr(nr10)=t2+t5+t8 + sr(nr7)=t8-t2 + sr(nr8)=t5-t8 + sr(nr9)=t2-t5 + t3=si(nr3)+si(nr6) + t6=si(nr3)-si(nr6) + si(nbase)=si(nbase)+t3 + t7=si(nr7)+si(nr2) + t2=si(nr7)-si(nr2) + si(nr2)=t6 + t1=si(nr1)+si(nr8) + t8=si(nr1)-si(nr8) + si(nr1)=t3 + t4=si(nr4)+si(nr5) + t5=si(nr4)-si(nr5) + si(nr3)=t1+t4+t7 + si(nr4)=t1-t7 + si(nr5)=t4-t1 + si(nr6)=t7-t4 + si(nr10)=t2+t5+t8 + si(nr7)=t8-t2 + si(nr8)=t5-t8 + si(nr9)=t2-t5 +910 nbase=nbase+1 +930 nbase=nbase+nlup2 +940 nbase=nbase+nlup23 +700 if(nc.ne.7) go to 500 +c +c ********************************************************************** +c +c the following code implements the 7 point pre-weave module +c +c ********************************************************************** +c + noff=nd1*nd2 + nbase=1 + nlup2=8*noff + do 740 n4=1,nd + do 710 n1=1,noff + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + nr6=nr5+noff + nr7=nr6+noff + nr8=nr7+noff + t1=sr(nr1)+sr(nr6) + t6=sr(nr1)-sr(nr6) + t4=sr(nr4)+sr(nr3) + t3=sr(nr4)-sr(nr3) + t2=sr(nr2)+sr(nr5) + t5=sr(nr2)-sr(nr5) + sr(nr5)=t6-t3 + sr(nr2)=t5+t3+t6 + sr(nr6)=t5-t6 + sr(nr8)=t3-t5 + sr(nr3)=t2-t1 + sr(nr4)=t1-t4 + sr(nr7)=t4-t2 + t1=t1+t4+t2 + sr(nbase)=sr(nbase)+t1 + sr(nr1)=t1 + t1=si(nr1)+si(nr6) + t6=si(nr1)-si(nr6) + t4=si(nr4)+si(nr3) + t3=si(nr4)-si(nr3) + t2=si(nr2)+si(nr5) + t5=si(nr2)-si(nr5) + si(nr5)=t6-t3 + si(nr2)=t5+t3+t6 + si(nr6)=t5-t6 + si(nr8)=t3-t5 + si(nr3)=t2-t1 + si(nr4)=t1-t4 + si(nr7)=t4-t2 + t1=t1+t4+t2 + si(nbase)=si(nbase)+t1 + si(nr1)=t1 +710 nbase=nbase+1 +740 nbase=nbase+nlup2 +500 if(nd.ne.5) return +c +c ********************************************************************** +c +c the following code implements the 5 point pre-weave module +c +c ********************************************************************** +c + noff=nd1*nd2*nd3 + nbase=1 + do 510 n1=1,noff + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + t4=sr(nr1)-sr(nr4) + t1=sr(nr1)+sr(nr4) + t3=sr(nr3)+sr(nr2) + t2=sr(nr3)-sr(nr2) + sr(nr3)=t1-t3 + sr(nr1)=t1+t3 + sr(nbase)=sr(nbase)+sr(nr1) + sr(nr5)=t2+t4 + sr(nr2)=t4 + sr(nr4)=t2 + t4=si(nr1)-si(nr4) + t1=si(nr1)+si(nr4) + t3=si(nr3)+si(nr2) + t2=si(nr3)-si(nr2) + si(nr3)=t1-t3 + si(nr1)=t1+t3 + si(nbase)=si(nbase)+si(nr1) + si(nr5)=t2+t4 + si(nr2)=t4 + si(nr4)=t2 +510 nbase=nbase+1 + return + end diff --git a/math/ieee/chap1/weave2.f b/math/ieee/chap1/weave2.f new file mode 100644 index 00000000..5c04ff91 --- /dev/null +++ b/math/ieee/chap1/weave2.f @@ -0,0 +1,412 @@ +c +c----------------------------------------------------------------------- +c +c subroutine: weave2 +c this subroutine implements the post-weave modules +c of the wfta. the working arrays are sr and si. +c the routine checks to see which factors are present +c in the transform length n = na*nb*nc*nd and executes +c the post-weave code for these factors. +c +c----------------------------------------------------------------------- +c + subroutine weave2(sr,si) + common na,nb,nc,nd,nd1,nd2,nd3,nd4 + dimension sr(1),si(1) + dimension q(8),t(16) + if(nd.ne.5) go to 700 +c +c ********************************************************************** +c +c the following code implements the 5 point post-weave module +c +c ********************************************************************** +c + noff=nd1*nd2*nd3 + nbase=1 + do 510 n1=1,noff + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + t1=sr(nbase)+sr(nr1) + t3=t1-sr(nr3) + t1=t1+sr(nr3) + t4=si(nr2)+si(nr5) + t2=si(nr4)+si(nr5) + sr(nr1)=t1-t4 + sr4=t1+t4 + sr2=t3+t2 + sr(nr3)=t3-t2 + t1=si(nbase)+si(nr1) + t3=t1-si(nr3) + t1=t1+si(nr3) + t4=sr(nr2)+sr(nr5) + t2=sr(nr4)+sr(nr5) + si(nr1)=t1+t4 + si(nr4)=t1-t4 + si(nr2)=t3-t2 + si(nr3)=t3+t2 + sr(nr2)=sr2 + sr(nr4)=sr4 +510 nbase=nbase+1 +700 if(nc.ne.7) go to 300 +c +c ********************************************************************** +c +c the following code implements the 7 point post-weave module +c +c ********************************************************************** +c + noff=nd1*nd2 + nbase=1 + nlup2=8*noff + do 740 n4=1,nd + do 710 n1=1,noff + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + nr6=nr5+noff + nr7=nr6+noff + nr8=nr7+noff + t1=sr(nr1)+sr(nbase) + t2=t1-sr(nr3)-sr(nr4) + t4=t1+sr(nr3)-sr(nr7) + t1=t1+sr(nr4)+sr(nr7) + t6=si(nr2)+si(nr5)+si(nr8) + t5=si(nr2)-si(nr5)-si(nr6) + t3=si(nr2)+si(nr6)-si(nr8) + sr(nr1)=t1-t6 + sr6=t1+t6 + sr2=t2-t5 + sr5=t2+t5 + sr(nr4)=t4-t3 + sr(nr3)=t4+t3 + t1=si(nr1)+si(nbase) + t2=t1-si(nr3)-si(nr4) + t4=t1+si(nr3)-si(nr7) + t1=t1+si(nr4)+si(nr7) + t6=sr(nr2)+sr(nr5)+sr(nr8) + t5=sr(nr2)-sr(nr5)-sr(nr6) + t3=sr(nr2)+sr(nr6)-sr(nr8) + si(nr1)=t1+t6 + si(nr6)=t1-t6 + si(nr2)=t2+t5 + si(nr5)=t2-t5 + si(nr4)=t4+t3 + si(nr3)=t4-t3 + sr(nr2)=sr2 + sr(nr5)=sr5 + sr(nr6)=sr6 +710 nbase=nbase+1 +740 nbase=nbase+nlup2 +300 if(nb.eq.1) go to 400 + if(nb.ne.3) go to 900 +c +c ********************************************************************** +c +c the following code implements the 3 point post-weave module +c +c ********************************************************************** +c + nlup2=2*nd1 + nlup23=3*nd1*(nd3-nc) + nbase=1 + noff=nd1 + do 340 n5=1,nd + do 330 n4=1,nc + do 310 n2=1,nd1 + nr1=nbase+noff + nr2=nr1+noff + t1=sr(nbase)+sr(nr1) + sr(nr1)=t1-si(nr2) + sr2=t1+si(nr2) + t1=si(nbase)+si(nr1) + si(nr1)=t1+sr(nr2) + si(nr2)=t1-sr(nr2) + sr(nr2)=sr2 +310 nbase=nbase+1 +330 nbase=nbase+nlup2 +340 nbase=nbase+nlup23 +900 if(nb.ne.9) go to 400 +c +c ********************************************************************** +c +c the following code implements the 9 point post-weave module +c +c ********************************************************************** +c + nlup2=10*nd1 + nlup23=11*nd1*(nd3-nc) + nbase=1 + noff=nd1 + do 940 n4=1,nd + do 930 n3=1,nc + do 910 n2=1,nd1 + nr1=nbase+noff + nr2=nr1+noff + nr3=nr2+noff + nr4=nr3+noff + nr5=nr4+noff + nr6=nr5+noff + nr7=nr6+noff + nr8=nr7+noff + nr9=nr8+noff + nr10=nr9+noff + t3=sr(nbase)-sr(nr3) + t7=sr(nbase)+sr(nr1) + sr(nbase)=sr(nbase)+sr(nr3)+sr(nr3) + t6=t3+si(nr10) + sr(nr3)=t3-si(nr10) + t4=t7+sr(nr5)-sr(nr6) + t1=t7-sr(nr4)-sr(nr5) + t7=t7+sr(nr4)+sr(nr6) + sr(nr6)=t6 + t8=si(nr2)-si(nr7)-si(nr8) + t5=si(nr2)+si(nr8)-si(nr9) + t2=si(nr2)+si(nr7)+si(nr9) + sr(nr1)=t7-t2 + sr8=t7+t2 + sr(nr4)=t1-t8 + sr(nr5)=t1+t8 + sr7=t4-t5 + sr2=t4+t5 + t3=si(nbase)-si(nr3) + t7=si(nbase)+si(nr1) + si(nbase)=si(nbase)+si(nr3)+si(nr3) + t6=t3-sr(nr10) + si(nr3)=t3+sr(nr10) + t4=t7+si(nr5)-si(nr6) + t1=t7-si(nr4)-si(nr5) + t7=t7+si(nr4)+si(nr6) + si(nr6)=t6 + t8=sr(nr2)-sr(nr7)-sr(nr8) + t5=sr(nr2)+sr(nr8)-sr(nr9) + t2=sr(nr2)+sr(nr7)+sr(nr9) + si(nr1)=t7+t2 + si(nr8)=t7-t2 + si(nr4)=t1+t8 + si(nr5)=t1-t8 + si(nr7)=t4+t5 + si(nr2)=t4-t5 + sr(nr2)=sr2 + sr(nr7)=sr7 + sr(nr8)=sr8 +910 nbase=nbase+1 +930 nbase=nbase+nlup2 +940 nbase=nbase+nlup23 +400 if(na.eq.1) return + if(na.ne.4) go to 800 +c +c ********************************************************************** +c +c the following code implements the 4 point post-weave module +c +c ********************************************************************** +c + nlup2=4*(nd2-nb) + nlup23=4*nd2*(nd3-nc) + nbase=1 + do 440 n4=1,nd + do 430 n3=1,nc + do 420 n2=1,nb + nr1=nbase+1 + nr2=nr1+1 + nr3=nr2+1 + tr0=sr(nbase)+sr(nr2) + tr2=sr(nbase)-sr(nr2) + tr1=sr(nr1)+sr(nr3) + tr3=sr(nr1)-sr(nr3) + ti1=si(nr1)+si(nr3) + ti3=si(nr1)-si(nr3) + sr(nbase)=tr0+tr1 + sr(nr2)=tr0-tr1 + sr(nr1)=tr2+ti3 + sr(nr3)=tr2-ti3 + ti0=si(nbase)+si(nr2) + ti2=si(nbase)-si(nr2) + si(nbase)=ti0+ti1 + si(nr2)=ti0-ti1 + si(nr1)=ti2-tr3 + si(nr3)=ti2+tr3 +420 nbase=nbase+4 +430 nbase=nbase+nlup2 +440 nbase=nbase+nlup23 +800 if(na.ne.8) go to 1600 +c +c ********************************************************************** +c +c the following code implements the 8 point post-weave module +c +c ********************************************************************** +c + nlup2=8*(nd2-nb) + nlup23=8*nd2*(nd3-nc) + nbase=1 + do 840 n4=1,nd + do 830 n3=1,nc + do 820 n2=1,nb + nr1=nbase+1 + nr2=nr1+1 + nr3=nr2+1 + nr4=nr3+1 + nr5=nr4+1 + nr6=nr5+1 + nr7=nr6+1 + t1=sr(nbase)-sr(nr1) + sr(nbase)=sr(nbase)+sr(nr1) + sr6=sr(nr2)+si(nr3) + sr(nr2)=sr(nr2)-si(nr3) + t4=sr(nr4)-si(nr5) + t5=sr(nr4)+si(nr5) + t6=sr(nr7)-si(nr6) + t7=sr(nr7)+si(nr6) + sr(nr4)=t1 + sr(nr1)=t4+t6 + sr3=t4-t6 + sr5=t5-t7 + sr(nr7)=t5+t7 + t1=si(nbase)-si(nr1) + si(nbase)=si(nbase)+si(nr1) + t3=si(nr2)-sr(nr3) + si(nr2)=si(nr2)+sr(nr3) + t4=si(nr4)+sr(nr5) + t5=si(nr4)-sr(nr5) + si(nr6)=t3 + t6=sr(nr6)+si(nr7) + t7=sr(nr6)-si(nr7) + si(nr4)=t1 + si(nr1)=t4+t6 + si(nr3)=t4-t6 + si(nr5)=t5+t7 + si(nr7)=t5-t7 + sr(nr3)=sr3 + sr(nr5)=sr5 + sr(nr6)=sr6 +820 nbase=nbase+8 +830 nbase=nbase+nlup2 +840 nbase=nbase+nlup23 +1600 if(na.ne.16) return +c +c ********************************************************************** +c +c the following code implements the 16 point post-weave module +c +c ********************************************************************** +c + nlup2=18*(nd2-nb) + nlup23=18*nd2*(nd3-nc) + nbase=1 + do 1640 n4=1,nd + do 1630 n3=1,nc + do 1620 n2=1,nb + nr1=nbase+1 + nr2=nr1+1 + nr3=nr2+1 + nr4=nr3+1 + nr5=nr4+1 + nr6=nr5+1 + nr7=nr6+1 + nr8=nr7+1 + nr9=nr8+1 + nr10=nr9+1 + nr11=nr10+1 + nr12=nr11+1 + nr13=nr12+1 + nr14=nr13+1 + nr15=nr14+1 + nr16=nr15+1 + nr17=nr16+1 + t(2)=sr(nbase)-sr(nr1) + sr(nbase)=sr(nr1)+sr(nbase) + t(4)=sr(nr2)+si(nr3) + t(3)=sr(nr2)-si(nr3) + t(6)=sr(nr4)+si(nr5) + t(5)=sr(nr4)-si(nr5) + t(8)=-si(nr6)-sr(nr7) + t(7)=-si(nr6)+sr(nr7) + t(9)=sr(nr8)+sr(nr14) + t(15)=sr(nr8)-sr(nr14) + t(13)=-si(nr10)-si(nr12) + t(11)=si(nr10)-si(nr12) + t(16)=sr(nr15)-sr(nr17) + t(12)=sr(nr11)-sr(nr17) + t(10)=-si(nr9)-si(nr16) + t(14)=-si(nr16)+si(nr13) + sr(nr2)=t(5)+t(7) + sr6=t(5)-t(7) + sr10=t(6)+t(8) + sr(nr14)=t(6)-t(8) + q(7)=t(9)+t(10) + q(8)=t(9)-t(10) + q(1)=t(11)+t(12) + q(2)=t(11)-t(12) + q(4)=t(14)+t(15) + q(5)=t(15)-t(14) + q(3)=t(13)+t(16) + q(6)=t(13)-t(16) + sr(nr1)=q(3)+q(7) + sr(nr7)=q(7)-q(3) + sr9=q(8)+q(6) + sr(nr15)=q(8)-q(6) + sr5=q(1)+q(4) + sr3=q(4)-q(1) + sr13=q(2)+q(5) + sr11=q(5)-q(2) + sr(nr8)=t(2) + sr(nr4)=t(3) + sr12=t(4) + t(2)=si(nbase)-si(nr1) + si(nbase)=si(nr1)+si(nbase) + t(4)=si(nr2)-sr(nr3) + t(3)=si(nr2)+sr(nr3) + t(6)=si(nr4)-sr(nr5) + t(5)=si(nr4)+sr(nr5) + t(8)=sr(nr6)-si(nr7) + t(7)=sr(nr6)+si(nr7) + t(9)=si(nr8)+si(nr14) + t(15)=si(nr8)-si(nr14) + t(13)=sr(nr10)+sr(nr12) + t(11)=sr(nr12)-sr(nr10) + t(16)=si(nr15)-si(nr17) + t(12)=si(nr11)-si(nr17) + t(10)=sr(nr9)+sr(nr16) + si(nr2)=t(5)+t(7) + si(nr6)=t(5)-t(7) + si(nr10)=t(6)+t(8) + si(nr14)=t(6)-t(8) + q(7)=t(9)+t(10) + q(8)=t(9)-t(10) + q(1)=t(11)+t(12) + q(2)=t(11)-t(12) + q(4)=t(14)+t(15) + q(5)=t(15)-t(14) + q(3)=t(13)+t(16) + q(6)=t(13)-t(16) + si(nr1)=q(3)+q(7) + si(nr7)=q(7)-q(3) + si(nr9)=q(8)+q(6) + si(nr15)=q(8)-q(6) + si(nr5)=q(1)+q(4) + si(nr3)=q(4)-q(1) + si(nr13)=q(2)+q(5) + si(nr11)=q(5)-q(2) + si(nr8)=t(2) + si(nr4)=t(3) + si(nr12)=t(4) + sr(nr3)=sr3 + sr(nr5)=sr5 + sr(nr6)=sr6 + sr(nr9)=sr9 + sr(nr10)=sr10 + sr(nr11)=sr11 + sr(nr12)=sr12 + sr(nr13)=sr13 +1620 nbase=nbase+18 +1630 nbase=nbase+nlup2 +1640 nbase=nbase+nlup23 + return + end diff --git a/math/ieee/chap1/wfta.f b/math/ieee/chap1/wfta.f new file mode 100644 index 00000000..9e819941 --- /dev/null +++ b/math/ieee/chap1/wfta.f @@ -0,0 +1,150 @@ +c +c----------------------------------------------------------------------- +c subroutine: wfta +c winograd fourier transform algorithm +c----------------------------------------------------------------------- +c + subroutine wfta(xr,xi,n,invrs,init,ierr) + dimension xr(1),xi(1) +c +c inputs: +c n-- transform length. must be formed as the product of +c relatively prime integers from the set: +c 2,3,4,5,7,8,9,16 +c thus the largest possible value of n is 5040. +c xr(.)-- array that holds the real part of the data +c to be transformed. +c xi(.)-- array that holds the imaginary part of the +c data to be transformed. +c invrs-- parameter that flags whether or not the inverse +c transform is to be calculated. a division by n +c is included in the inverse. +c invrs = 1 yields inverse transform +c invrs .ne. 1 gives forward transform +c init-- parameter that flags whether or not the program +c is to be initialized for this value of n. the +c initialization is performed only once in order to +c to speed up the computation on succeeding calls +c to the wfta routine, when n is held fixed. +c init = 0 results in initialization. +c ierr-- error code that is negative when the wfta +c terminates incorrectly. +c 0 = successful completion +c -1 = this value of n does not factor properly +c -2 = an initialization has not been done for +c this value of n. +c +c +c the following two cards may be changed if the maximum +c desired transform length is less than 5040 +c +c ********************************************************************* + dimension sr(1782),si(1782),coef(1782) + integer indx1(1008),indx2(1008) +c ********************************************************************* +c + common na,nb,nc,nd,nd1,nd2,nd3,nd4 +c +c test for initial run +c + if(init.eq.0) call inishl(n,coef,xr,xi,indx1,indx2,ierr) +c + if(ierr.lt.0) return + m=na*nb*nc*nd + if(m.eq.n) go to 100 + ierr=-2 + return +c +c error(-2)-- program not initialized for this value of n +c +100 nmult=nd1*nd2*nd3*nd4 +c +c the following code maps the data arrays xr and xi to +c the working arrays sr and si via the mapping vector +c indx1(.). the permutation of the data follows the +c sino correspondence of the chinese remainder theorem. +c + j=1 + k=1 + inc1=nd1-na + inc2=nd1*(nd2-nb) + inc3=nd1*nd2*(nd3-nc) + do 140 n4=1,nd + do 130 n3=1,nc + do 120 n2=1,nb + do 110 n1=1,na + ind=indx1(k) + sr(j)=xr(ind) + si(j)=xi(ind) + k=k+1 +110 j=j+1 +120 j=j+inc1 +130 j=j+inc2 +140 j=j+inc3 +c +c do the pre-weave modules +c + call weave1(sr,si) +c +c the following loop performs all the multiplications of the +c winograd fourier transform algorithm. the multiplication +c coefficients are stored on the initialization pass in the +c array coef(.). +c + do 200 j=1,nmult + sr(j)=sr(j)*coef(j) + si(j)=si(j)*coef(j) + 200 continue +c +c do the post-weave modules +c + call weave2(sr,si) +c +c +c the following code maps the working arrays sr and si +c to the data arrays xr and xi via the mapping vector +c indx2(.). the permutation of the data follows the +c chinese remainder theorem. +c + j=1 + k=1 + inc1=nd1-na + inc2=nd1*(nd2-nb) + inc3=nd1*nd2*(nd3-nc) +c +c check for inverse +c + if(invrs.eq.1) go to 400 + do 340 n4=1,nd + do 330 n3=1,nc + do 320 n2=1,nb + do 310 n1=1,na + kndx=indx2(k) + xr(kndx)=sr(j) + xi(kndx)=si(j) + k=k+1 +310 j=j+1 +320 j=j+inc1 +330 j=j+inc2 +340 j=j+inc3 + return +c +c different permutation for the inverse +c +400 fn=float(n) + np2=n+2 + indx2(1)=n+1 + do 440 n4=1,nd + do 430 n3=1,nc + do 420 n2=1,nb + do 410 n1=1,na + kndx=np2-indx2(k) + xr(kndx)=sr(j)/fn + xi(kndx)=si(j)/fn + k=k+1 +410 j=j+1 +420 j=j+inc1 +430 j=j+inc2 +440 j=j+inc3 + return + end diff --git a/math/ieee/d1mach.f b/math/ieee/d1mach.f new file mode 100644 index 00000000..699468ab --- /dev/null +++ b/math/ieee/d1mach.f @@ -0,0 +1,256 @@ +c +c---------------------------------------------------------------------- +c function: d1mach +c this routine is from the port mathematical subroutine library +c it is described in the bell laboratories computing science +c technical report #47 by p.a. fox, a.d. hall and n.l. schryer +c a modification to the "i out of bounds" error message +c has been made by c. a. mcgonegal - april, 1978 +c---------------------------------------------------------------------- +c + double precision function d1mach(i) +c +c double-precision machine constants +c +c d1mach( 1) = b**(emin-1), the smallest positive magnitude. +c +c d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c d1mach( 3) = b**(-t), the smallest relative spacing. +c +c d1mach( 4) = b**(1-t), the largest relative spacing. +c +c d1mach( 5) = log10(b) +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. +c +c where possible, octal or hexadecimal constants have been used +c to specify the constants exactly which has in some cases +c required the use of equivalent integer arrays. +c + integer small(4) + integer large(4) + integer right(4) + integer diver(4) + integer log10(4) +c + double precision dmach(5) +c + equivalence (dmach(1),small(1)) + equivalence (dmach(2),large(1)) + equivalence (dmach(3),right(1)) + equivalence (dmach(4),diver(1)) + equivalence (dmach(5),log10(1)) +c +c machine constants for the burroughs 1700 system. +c +c data small(1) / zc00800000 / +c data small(2) / z000000000 / +c +c data large(1) / zdffffffff / +c data large(2) / zfffffffff / +c +c data right(1) / zcc5800000 / +c data right(2) / z000000000 / +c +c data diver(1) / zcc6800000 / +c data diver(2) / z000000000 / +c +c data log10(1) / zd00e730e7 / +c data log10(2) / zc77800dc0 / +c +c machine constants for the burroughs 5700 system. +c +c data small(1) / o1771000000000000 / +c data small(2) / o0000000000000000 / +c +c data large(1) / o0777777777777777 / +c data large(2) / o0007777777777777 / +c +c data right(1) / o1461000000000000 / +c data right(2) / o0000000000000000 / +c +c data diver(1) / o1451000000000000 / +c data diver(2) / o0000000000000000 / +c +c data log10(1) / o1157163034761674 / +c data log10(2) / o0006677466732724 / +c +c machine constants for the burroughs 6700/7700 systems. +c +c data small(1) / o1771000000000000 / +c data small(2) / o7770000000000000 / +c +c data large(1) / o0777777777777777 / +c data large(2) / o7777777777777777 / +c +c data right(1) / o1461000000000000 / +c data right(2) / o0000000000000000 / +c +c data diver(1) / o1451000000000000 / +c data diver(2) / o0000000000000000 / +c +c data log10(1) / o1157163034761674 / +c data log10(2) / o0006677466732724 / +c +c machine constants for the cdc 6000/7000 series. +c +c data small(1) / 00604000000000000000b / +c data small(2) / 00000000000000000000b / +c +c data large(1) / 37767777777777777777b / +c data large(2) / 37167777777777777777b / +c +c data right(1) / 15604000000000000000b / +c data right(2) / 15000000000000000000b / +c +c data diver(1) / 15614000000000000000b / +c data diver(2) / 15010000000000000000b / +c +c data log10(1) / 17164642023241175717b / +c data log10(2) / 16367571421742254654b / +c +c machine constants for the cray 1 +c +c data small(1) / 200004000000000000000b / +c data small(2) / 000000000000000000000b / +c +c data large(1) / 577767777777777777777b / +c data large(2) / 000007777777777777776b / +c +c data right(1) / 376424000000000000000b / +c data right(2) / 000000000000000000000b / +c +c data diver(1) / 376434000000000000000b / +c data diver(2) / 000000000000000000000b / +c +c data log10(1) / 377774642023241175717b / +c data log10(2) / 000007571421742254654b / +c +c machine constants for the data general eclipse s/200 +c +c note - it may be appropriate to include the following card - +c static dmach(5) +c +c data small/20k,3*0/,large/77777k,3*177777k/ +c data right/31420k,3*0/,diver/32020k,3*0/ +c data log10/40423k,42023k,50237k,74776k/ +c +c machine constants for the harris slash 6 and slash 7 +c +c data small(1),small(2) / '20000000, '00000201 / +c data large(1),large(2) / '37777777, '37777577 / +c data right(1),right(2) / '20000000, '00000333 / +c data diver(1),diver(2) / '20000000, '00000334 / +c data log10(1),log10(2) / '23210115, '10237777 / +c +c machine constants for the honeywell 600/6000 series. +c +c data small(1),small(2) / o402400000000, o000000000000 / +c data large(1),large(2) / o376777777777, o777777777777 / +c data right(1),right(2) / o604400000000, o000000000000 / +c data diver(1),diver(2) / o606400000000, o000000000000 / +c data log10(1),log10(2) / o776464202324, o117571775714 / +c +c machine constants for the ibm 360/370 series, +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data small(1),small(2) / z00100000, z00000000 / +c data large(1),large(2) / z7fffffff, zffffffff / +c data right(1),right(2) / z33100000, z00000000 / +c data diver(1),diver(2) / z34100000, z00000000 / +c data log10(1),log10(2) / z41134413, z509f79ff / +c +c machine constants for the pdp-10 (ka processor). +c +c data small(1),small(2) / "033400000000, "000000000000 / +c data large(1),large(2) / "377777777777, "344777777777 / +c data right(1),right(2) / "113400000000, "000000000000 / +c data diver(1),diver(2) / "114400000000, "000000000000 / +c data log10(1),log10(2) / "177464202324, "144117571776 / +c +c machine constants for the pdp-10 (ki processor). +c +c data small(1),small(2) / "000400000000, "000000000000 / +c data large(1),large(2) / "377777777777, "377777777777 / +c data right(1),right(2) / "103400000000, "000000000000 / +c data diver(1),diver(2) / "104400000000, "000000000000 / +c data log10(1),log10(2) / "177464202324, "476747767461 / +c +c machine constants for pdp-11 fortran's supporting +c 32-bit integers (expressed in integer and octal). +c + data small(1),small(2) / 8388608, 0 / + data large(1),large(2) / 2147483647, -1 / + data right(1),right(2) / 612368384, 0 / + data diver(1),diver(2) / 620756992, 0 / + data log10(1),log10(2) / 1067065498, -2063872008 / +c +c data small(1),small(2) / o00040000000, o00000000000 / +c data large(1),large(2) / o17777777777, o37777777777 / +c data right(1),right(2) / o04440000000, o00000000000 / +c data diver(1),diver(2) / o04500000000, o00000000000 / +c data log10(1),log10(2) / o07746420232, o20476747770 / +c +c machine constants for pdp-11 fortran's supporting +c 16-bit integers (expressed in integer and octal). +c +c data small(1),small(2) / 128, 0 / +c data small(3),small(4) / 0, 0 / +c +c data large(1),large(2) / 32767, -1 / +c data large(3),large(4) / -1, -1 / +c +c data right(1),right(2) / 9344, 0 / +c data right(3),right(4) / 0, 0 / +c +c data diver(1),diver(2) / 9472, 0 / +c data diver(3),diver(4) / 0, 0 / +c +c data log10(1),log10(2) / 16282, 8346 / +c data log10(3),log10(4) / -31493, -12296 / +c +c data small(1),small(2) / o000200, o000000 / +c data small(3),small(4) / o000000, o000000 / +c +c data large(1),large(2) / o077777, o177777 / +c data large(3),large(4) / o177777, o177777 / +c +c data right(1),right(2) / o022200, o000000 / +c data right(3),right(4) / o000000, o000000 / +c +c data diver(1),diver(2) / o022400, o000000 / +c data diver(3),diver(4) / o000000, o000000 / +c +c data log10(1),log10(2) / o037632, o020232 / +c data log10(3),log10(4) / o102373, o147770 / +c +c machine constants for the univac 1100 series. +c +c data small(1),small(2) / o000040000000, o000000000000 / +c data large(1),large(2) / o377777777777, o777777777777 / +c data right(1),right(2) / o170540000000, o000000000000 / +c data diver(1),diver(2) / o170640000000, o000000000000 / +c data log10(1),log10(2) / o177746420232, o411757177572 / +c +c machine constants for the vax-11 with +c fortran iv-plus compiler +c +c data small(1),small(2) / z00000080, z00000000 / +c data large(1),large(2) / zffff7fff, zffffffff / +c data right(1),right(2) / z00002480, z00000000 / +c data diver(1),diver(2) / z00002500, z00000000 / +c data log10(1),log10(2) / z209a3f9a, zcffa84fb / +c + if (i .lt. 1 .or. i .gt. 5) goto 100 +c + d1mach = dmach(i) + return +c + 100 iwunit = i1mach(4) + write(iwunit, 99) + 99 format(24hd1mach - i out of bounds) + stop + end diff --git a/math/ieee/i1mach.f b/math/ieee/i1mach.f new file mode 100644 index 00000000..e7b9af2b --- /dev/null +++ b/math/ieee/i1mach.f @@ -0,0 +1,382 @@ +c +c---------------------------------------------------------------------- +c function: i1mach +c this routine is from the port mathematical subroutine library +c it is described in the bell laboratories computing science +c technical report #47 by p.a. fox, a.d. hall and n.l. schryer +c--------------------------------------------------------------------- +c + integer function i1mach(i) +c +c i/o unit numbers. +c +c i1mach( 1) = the standard input unit. +c +c i1mach( 2) = the standard output unit. +c +c i1mach( 3) = the standard punch unit. +c +c i1mach( 4) = the standard error message unit. +c +c words. +c +c i1mach( 5) = the number of bits per integer storage unit. +c +c i1mach( 6) = the number of characters per integer storage unit. +c +c integers. +c +c assume integers are represented in the s-digit, base-a form +c +c sign ( x(s-1)*a**(s-1) + ... + x(1)*a + x(0) ) +c +c where 0 .le. x(i) .lt. a for i=0,...,s-1. +c +c i1mach( 7) = a, the base. +c +c i1mach( 8) = s, the number of base-a digits. +c +c i1mach( 9) = a**s - 1, the largest magnitude. +c +c floating-point numbers. +c +c assume floating-point numbers are represented in the t-digit, +c base-b form +c +c sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) ) +c +c where 0 .le. x(i) .lt. b for i=1,...,t, +c 0 .lt. x(1), and emin .le. e .le. emax. +c +c i1mach(10) = b, the base. +c +c single-precision +c +c i1mach(11) = t, the number of base-b digits. +c +c i1mach(12) = emin, the smallest exponent e. +c +c i1mach(13) = emax, the largest exponent e. +c +c double-precision +c +c i1mach(14) = t, the number of base-b digits. +c +c i1mach(15) = emin, the smallest exponent e. +c +c i1mach(16) = emax, the largest exponent e. +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. also, the values of +c i1mach(1) - i1mach(4) should be checked for consistency +c with the local operating system. +c + integer imach(16),output +c + equivalence (imach(4),output) +c +c machine constants for the burroughs 1700 system. +c +c data imach( 1) / 7 / +c data imach( 2) / 2 / +c data imach( 3) / 2 / +c data imach( 4) / 2 / +c data imach( 5) / 36 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 33 / +c data imach( 9) / z1ffffffff / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -256 / +c data imach(13) / 255 / +c data imach(14) / 60 / +c data imach(15) / -256 / +c data imach(16) / 255 / +c +c machine constants for the burroughs 5700 system. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 48 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 39 / +c data imach( 9) / o0007777777777777 / +c data imach(10) / 8 / +c data imach(11) / 13 / +c data imach(12) / -50 / +c data imach(13) / 76 / +c data imach(14) / 26 / +c data imach(15) / -50 / +c data imach(16) / 76 / +c +c machine constants for the burroughs 6700/7700 systems. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 48 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 39 / +c data imach( 9) / o0007777777777777 / +c data imach(10) / 8 / +c data imach(11) / 13 / +c data imach(12) / -50 / +c data imach(13) / 76 / +c data imach(14) / 26 / +c data imach(15) / -32754 / +c data imach(16) / 32780 / +c +c machine constants for the cdc 6000/7000 series. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 60 / +c data imach( 6) / 10 / +c data imach( 7) / 2 / +c data imach( 8) / 48 / +c data imach( 9) / 00007777777777777777b / +c data imach(10) / 2 / +c data imach(11) / 48 / +c data imach(12) / -974 / +c data imach(13) / 1070 / +c data imach(14) / 96 / +c data imach(15) / -927 / +c data imach(16) / 1070 / +c +c machine constants for the cray 1 +c +c data imach( 1) / 100 / +c data imach( 2) / 101 / +c data imach( 3) / 102 / +c data imach( 4) / 101 / +c data imach( 5) / 64 / +c data imach( 6) / 8 / +c data imach( 7) / 2 / +c data imach( 8) / 63 / +c data imach( 9) / 777777777777777777777b / +c data imach(10) / 2 / +c data imach(11) / 47 / +c data imach(12) / -8192 / +c data imach(13) / 8190 / +c data imach(14) / 95 / +c data imach(15) / -8192 / +c data imach(16) / 8190 / +c +c machine constants for the data general eclipse s/200 +c +c data imach( 1) / 11 / +c data imach( 2) / 12 / +c data imach( 3) / 8 / +c data imach( 4) / 10 / +c data imach( 5) / 16 / +c data imach( 6) / 2 / +c data imach( 7) / 2 / +c data imach( 8) / 15 / +c data imach( 9) /32767 / +c data imach(10) / 16 / +c data imach(11) / 6 / +c data imach(12) / -64 / +c data imach(13) / 63 / +c data imach(14) / 14 / +c data imach(15) / -64 / +c data imach(16) / 63 / +c +c machine constants for the harris slash 6 and slash 7 +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 0 / +c data imach( 4) / 6 / +c data imach( 5) / 24 / +c data imach( 6) / 3 / +c data imach( 7) / 2 / +c data imach( 8) / 23 / +c data imach( 9) / 8388607 / +c data imach(10) / 2 / +c data imach(11) / 23 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 38 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the honeywell 600/6000 series. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 43 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / o377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 63 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the ibm 360/370 series, +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 32 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 31 / +c data imach( 9) / z7fffffff / +c data imach(10) / 16 / +c data imach(11) / 6 / +c data imach(12) / -64 / +c data imach(13) / 63 / +c data imach(14) / 14 / +c data imach(15) / -64 / +c data imach(16) / 63 / +c +c machine constants for the pdp-10 (ka processor). +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 5 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / "377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 54 / +c data imach(15) / -101 / +c data imach(16) / 127 / +c +c machine constants for the pdp-10 (ki processor). +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 5 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / "377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 62 / +c data imach(15) / -128 / +c data imach(16) / 127 / +c +c machine constants for pdp-11 fortran supporting +c 32-bit integer arithmetic. +c + data imach( 1) / 5 / + data imach( 2) / 6 / + data imach( 3) / 6 / + data imach( 4) / 0 / + data imach( 5) / 32 / + data imach( 6) / 4 / + data imach( 7) / 2 / + data imach( 8) / 31 / + data imach( 9) / 2147483647 / + data imach(10) / 2 / + data imach(11) / 24 / + data imach(12) / -127 / + data imach(13) / 127 / + data imach(14) / 56 / + data imach(15) / -127 / + data imach(16) / 127 / +c +c machine constants for pdp-11 fortran supporting +c 16-bit integer arithmetic. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 16 / +c data imach( 6) / 2 / +c data imach( 7) / 2 / +c data imach( 8) / 15 / +c data imach( 9) / 32767 / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 56 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c +c machine constants for the univac 1100 series. +c +c note that the punch unit, i1mach(3), has been set to 7 +c which is appropriate for the univac-for system. +c if you have the univac-ftn system, set it to 1. +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 7 / +c data imach( 4) / 6 / +c data imach( 5) / 36 / +c data imach( 6) / 6 / +c data imach( 7) / 2 / +c data imach( 8) / 35 / +c data imach( 9) / o377777777777 / +c data imach(10) / 2 / +c data imach(11) / 27 / +c data imach(12) / -128 / +c data imach(13) / 127 / +c data imach(14) / 60 / +c data imach(15) /-1024 / +c data imach(16) / 1023 / +c +c machine constants for the vax-11 with +c fortran iv-plus compiler +c +c data imach( 1) / 5 / +c data imach( 2) / 6 / +c data imach( 3) / 5 / +c data imach( 4) / 6 / +c data imach( 5) / 32 / +c data imach( 6) / 4 / +c data imach( 7) / 2 / +c data imach( 8) / 31 / +c data imach( 9) / 2147483647 / +c data imach(10) / 2 / +c data imach(11) / 24 / +c data imach(12) / -127 / +c data imach(13) / 127 / +c data imach(14) / 56 / +c data imach(15) / -127 / +c data imach(16) / 127 / +c + if (i .lt. 1 .or. i .gt. 16) go to 10 +c + i1mach=imach(i) + return +c + 10 write(output,9000) + 9000 format(39h1error 1 in i1mach - i out of bounds) +c + stop +c + end diff --git a/math/ieee/r1mach.f b/math/ieee/r1mach.f new file mode 100644 index 00000000..db71aa68 --- /dev/null +++ b/math/ieee/r1mach.f @@ -0,0 +1,177 @@ +c +c---------------------------------------------------------------------- +c function: r1mach +c this routine is from the port mathematical subroutine library +c it is described in the bell laboratories computing science +c technical report #47 by p.a. fox, a.d. hall and n.l. schryer +c a modification to the "i out of bounds" error message +c has been made by c. a. mcgonegal - april, 1978 +c---------------------------------------------------------------------- +c + real function r1mach(i) +c +c single-precision machine constants +c +c r1mach(1) = b**(emin-1), the smallest positive magnitude. +c +c r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c r1mach(3) = b**(-t), the smallest relative spacing. +c +c r1mach(4) = b**(1-t), the largest relative spacing. +c +c r1mach(5) = log10(b) +c +c to alter this function for a particular environment, +c the desired set of data statements should be activated by +c removing the c from column 1. +c +c where possible, octal or hexadecimal constants have been used +c to specify the constants exactly which has in some cases +c required the use of equivalent integer arrays. +c + integer small(2) + integer large(2) + integer right(2) + integer diver(2) + integer log10(2) +c + real rmach(5) +c + equivalence (rmach(1),small(1)) + equivalence (rmach(2),large(1)) + equivalence (rmach(3),right(1)) + equivalence (rmach(4),diver(1)) + equivalence (rmach(5),log10(1)) +c +c machine constants for the burroughs 1700 system. +c +c data rmach(1) / z400800000 / +c data rmach(2) / z5ffffffff / +c data rmach(3) / z4e9800000 / +c data rmach(4) / z4ea800000 / +c data rmach(5) / z500e730e8 / +c +c machine constants for the burroughs 5700/6700/7700 systems. +c +c data rmach(1) / o1771000000000000 / +c data rmach(2) / o0777777777777777 / +c data rmach(3) / o1311000000000000 / +c data rmach(4) / o1301000000000000 / +c data rmach(5) / o1157163034761675 / +c +c machine constants for the cdc 6000/7000 series. +c +c data rmach(1) / 00014000000000000000b / +c data rmach(2) / 37767777777777777777b / +c data rmach(3) / 16404000000000000000b / +c data rmach(4) / 16414000000000000000b / +c data rmach(5) / 17164642023241175720b / +c +c machine constants for the cray 1 +c +c data rmach(1) / 200004000000000000000b / +c data rmach(2) / 577767777777777777776b / +c data rmach(3) / 377224000000000000000b / +c data rmach(4) / 377234000000000000000b / +c data rmach(5) / 377774642023241175720b / +c +c machine constants for the data general eclipse s/200 +c +c note - it may be appropriate to include the following card - +c static rmach(5) +c +c data small/20k,0/,large/77777k,177777k/ +c data right/35420k,0/,diver/36020k,0/ +c data log10/40423k,42023k/ +c +c machine constants for the harris slash 6 and slash 7 +c +c data small(1),small(2) / '20000000, '00000201 / +c data large(1),large(2) / '37777777, '00000177 / +c data right(1),right(2) / '20000000, '00000352 / +c data diver(1),diver(2) / '20000000, '00000353 / +c data log10(1),log10(2) / '23210115, '00000377 / +c +c machine constants for the honeywell 600/6000 series. +c +c data rmach(1) / o402400000000 / +c data rmach(2) / o376777777777 / +c data rmach(3) / o714400000000 / +c data rmach(4) / o716400000000 / +c data rmach(5) / o776464202324 / +c +c machine constants for the ibm 360/370 series, +c the xerox sigma 5/7/9 and the sel systems 85/86. +c +c data rmach(1) / z00100000 / +c data rmach(2) / z7fffffff / +c data rmach(3) / z3b100000 / +c data rmach(4) / z3c100000 / +c data rmach(5) / z41134413 / +c +c machine constants for the pdp-10 (ka or ki processor). +c +c data rmach(1) / "000400000000 / +c data rmach(2) / "377777777777 / +c data rmach(3) / "146400000000 / +c data rmach(4) / "147400000000 / +c data rmach(5) / "177464202324 / +c +c machine constants for pdp-11 fortran's supporting +c 32-bit integers (expressed in integer and octal). +c + data small(1) / 8388608 / + data large(1) / 2147483647 / + data right(1) / 880803840 / + data diver(1) / 889192448 / + data log10(1) / 1067065499 / +c +c data rmach(1) / o00040000000 / +c data rmach(2) / o17777777777 / +c data rmach(3) / o06440000000 / +c data rmach(4) / o06500000000 / +c data rmach(5) / o07746420233 / +c +c machine constants for pdp-11 fortran's supporting +c 16-bit integers (expressed in integer and octal). +c +c data small(1),small(2) / 128, 0 / +c data large(1),large(2) / 32767, -1 / +c data right(1),right(2) / 13440, 0 / +c data diver(1),diver(2) / 13568, 0 / +c data log10(1),log10(2) / 16282, 8347 / +c +c data small(1),small(2) / o000200, o000000 / +c data large(1),large(2) / o077777, o177777 / +c data right(1),right(2) / o032200, o000000 / +c data diver(1),diver(2) / o032400, o000000 / +c data log10(1),log10(2) / o037632, o020233 / +c +c machine constants for the univac 1100 series. +c +c data rmach(1) / o000400000000 / +c data rmach(2) / o377777777777 / +c data rmach(3) / o146400000000 / +c data rmach(4) / o147400000000 / +c data rmach(5) / o177464202324 / +c +c machine constants for the vax-11 with +c fortran iv-plus compiler +c +c data rmach(1) / z00000080 / +c data rmach(2) / zffff7fff / +c data rmach(3) / z00003480 / +c data rmach(4) / z00003500 / +c data rmach(5) / z209b3f9a / +c + if (i .lt. 1 .or. i .gt. 5) goto 100 +c + r1mach = rmach(i) + return +c + 100 iwunit = i1mach(4) + write(iwunit, 99) + 99 format(24hr1mach - i out of bounds) + stop + end diff --git a/math/ieee/uni.c b/math/ieee/uni.c new file mode 100644 index 00000000..8e76c099 --- /dev/null +++ b/math/ieee/uni.c @@ -0,0 +1,8 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +float uni_(dummy) +float *dummy; +{ + return(rand()/ 2147483648.0); /* return a real [0.0, 1.0) */ +} diff --git a/math/iminterp/Revisions b/math/iminterp/Revisions new file mode 100644 index 00000000..b57a092b --- /dev/null +++ b/math/iminterp/Revisions @@ -0,0 +1,7 @@ +.help revisions Sep99 math.deboor +.nf +From Davis, September 20, 1999 + +Added some missing file dependices to the mkpkg file. +pkg/math/iminterp/mkpkg +.endhelp diff --git a/math/iminterp/arbpix.x b/math/iminterp/arbpix.x new file mode 100644 index 00000000..d22b47c6 --- /dev/null +++ b/math/iminterp/arbpix.x @@ -0,0 +1,339 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "im1interpdef.h" + +define MIN_BDX 0.05 # minimum distance from interpolation point for sinc + +# ARBPIX -- Replace INDEF valued pixels with interpolated values. In order to +# replace bad points the spline interpolator uses a limited data array whose +# maximum total length is given by SPLPTS. + +procedure arbpix (datain, dataout, npts, interp_type, boundary_type) + +real datain[ARB] # input data array +real dataout[ARB] # output data array - cannot be same as datain +int npts # number of data points +int interp_type # interpolator type +int boundary_type # boundary type, at present must be BOUNDARY_EXT + +int i, badnc, k, ka, kb +real ii_badpix() + +begin + if (interp_type < 1 || interp_type > II_NTYPES) + call error (0, "ARBPIX: Unknown interpolator type.") + + if (boundary_type < 1 || boundary_type > II_NBOUND) + call error (0, "ARBPIX: Unknown boundary type.") + + # Count bad points. + badnc = 0 + do i = 1, npts + if (IS_INDEFR(datain[i])) + badnc = badnc + 1 + + # Return an array of INDEFS if all points bad. + if (badnc == npts) { + call amovkr (INDEFR, dataout, npts) + return + } + + # Copy input array to output array if all points good. + if (badnc == 0) { + call amovr (datain, dataout, npts) + return + } + + # If sinc interpolator use a special routine. + if (interp_type == II_SINC || interp_type == II_LSINC) { + call ii_badsinc (datain, dataout, npts, NSINC, MIN_BDX) + return + } + + # Find the first good point. + for (ka = 1; IS_INDEFR (datain[ka]); ka = ka + 1) + ; + + # Bad points below first good point are set at first good value. + do k = 1, ka - 1 + dataout[k] = datain[ka] + + # Find last good point. + for (kb = npts; IS_INDEFR (datain[kb]); kb = kb - 1) + ; + + # Bad points beyond last good point get set at good last value. + do k = npts, kb + 1, -1 + dataout[k] = datain[kb] + + # Load the other points interpolating the bad points as needed. + do k = ka, kb { + + if (IS_INDEFR(datain[k])) + dataout[k] = ii_badpix (datain[ka], kb - ka + 1, k - ka + 1, + interp_type) + else + dataout[k] = datain[k] + + } +end + + +# II_BADPIX -- This procedure fills a temporary array with good points that +# bracket the bad point and calls the interpolating routine. + +real procedure ii_badpix (datain, npix, index, interp_type) + +real datain[ARB] # datain array, y[1] and y[n] guaranteed to be good +int npix # length of y array +int index # index of bad point to replace +int interp_type # interpolator type + +int j, jj, pdown, pup, npts, ngood +real tempdata[SPLPTS], tempx[SPLPTS] +real ii_newpix() + +begin + # This code will work only if subroutines are implemented using + # static storage - i.e. the old internal values survive. This avoids + # reloading of temporary arrays if there are consequetive bad points. + + # The following test is done to improve speed. + + if (! IS_INDEFR(datain[index-1])) { + + # Set number of good points needed on each side of bad point. + switch (interp_type) { + case II_NEAREST: + ngood = 1 + case II_LINEAR: + ngood = 1 + case II_POLY3: + ngood = 2 + case II_POLY5: + ngood = 3 + case II_SPLINE3: + ngood = SPLPTS / 2 + case II_DRIZZLE: + ngood = 1 + } + + # Search down. + pdown = 0 + for (j = index - 1; j >= 1 && pdown < ngood; j = j - 1) + if (! IS_INDEFR(datain[j])) + pdown = pdown + 1 + + # Load temporary arrays for values below our INDEF. + npts = 0 + for(jj = j + 1; jj < index; jj = jj + 1) + if (! IS_INDEFR(datain[jj])) { + npts = npts + 1 + tempdata[npts] = datain[jj] + tempx[npts] = jj + } + + # Search and load up from INDEF. + pup = 0 + for (j = index + 1; j <= npix && pup < ngood; j = j + 1) + if (! IS_INDEFR(datain[j])) { + pup = pup + 1 + npts = npts + 1 + tempdata[npts] = datain[j] + tempx[npts] = j + } + } + + # Return value interpolated from these arrays. + return (ii_newpix (real(index), tempx, tempdata, + npts, pdown, interp_type)) + +end + + +# II_NEWPIX -- This procedure interpolates the temporary arrays. For the +# purposes of bad pixel replacement the drizzle replacement algorithm is +# equated with the linear interpolation replacement algorithm, an equation +# which is exact if the drizzle integration interval is exactly 1.0 pixels. +# II_NEWPIX does not represent a general puprpose routine because the +# previous routine has determined the proper indices. + +real procedure ii_newpix (x, xarray, data, npts, index, interp_type) + +real x # point to interpolate +real xarray[ARB] # x values +real data[ARB] # data values +int npts # size of data array +int index # index such that xarray[index] < x < xarray[index+1] +int interp_type # interpolator type + +int i, left, right +real cc[SPLINE3_ORDER, SPLPTS], h +real ii_polterp() + +begin + switch (interp_type) { + + case II_NEAREST: + if (x - xarray[1] > xarray[2] - x) + return (data[2]) + else + return (data[1]) + + case II_LINEAR, II_DRIZZLE: + return (data[1] + (x - xarray[1]) * + (data[2] - data[1]) / (xarray[2] - xarray[1])) + + case II_SPLINE3: + do i = 1, npts + cc[1,i] = data[i] + + cc[2,1] = 0. + cc[2,npts] = 0. + + # Use spline routine from C. de Boor's book "A Practical Guide + # to Splines + + call iicbsp (xarray, cc, npts, 2, 2) + h = x - xarray[index] + + return (cc[1,index] + h * (cc[2,index] + h * + (cc[3,index] + h * cc[4,index]/3.)/2.)) + + # One of the polynomial types. + default: + + # Allow lower order if not enough points on one side. + right = npts + left = 1 + + if (npts - index < index) { + right = 2 * (npts - index) + left = 2 * index - npts + 1 + } + + if (npts - index > index) + right = 2 * index + + # Finally polynomial interpolate. + return (ii_polterp (xarray[left], data[left], right, x)) + } +end + + +# II_BADSINC -- Procedure to evaluate bad pixels with a sinc interpolant +# This is the average of interpolation to points +-0.05 from the bad pixel. +# Sinc interpolation exactly at a pixel is undefined. Since this routine +# is intended to be a bad pixel replacement routine, no attempt has been +# made to optimize the routine by precomputing the sinc function. + +procedure ii_badsinc (datain, dataout, npts, nsinc, min_bdx) + +real datain[ARB] # input data including bad pixels with INDEF values +real dataout[ARB] # output data +int npts # number of data values +int nsinc # sinc truncation length +real min_bdx # minimum distance from interpolation point + +int i, j, k, xc +real sconst, a2, a4, dx, dx2, dx4 +real w, d, z, w1, u1, v1 + +begin + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + + do i = 1, npts { + + if (! IS_INDEFR(datain[i])) { + dataout[i] = datain[i] + next + } + + # Initialize. + xc = i + w = 1. + u1 = 0.0; v1 = 0.0 + + do j = 1, nsinc { + + # Get the taper. + w = -w + + # Sum the low side. + k = xc - j + if (k >= 1) + d = datain[k] + else + d = datain[1] + if (! IS_INDEFR(d)) { + dx = min_bdx + j + dx2 = sconst * j * j + dx4 = dx2 * dx2 + z = 1. / dx + w1 = w * z * (1.0 + a2 * dx2 + a4 * dx4) ** 2 + u1 = u1 + d * w1 + v1 = v1 + w1 + dx = -min_bdx + j + dx2 = sconst * j * j + dx4 = dx2 * dx2 + z = 1. / dx + w1 = -w * z * (1.0 + a2 * dx2 + a4 * dx4) ** 2 + u1 = u1 + d * w1 + v1 = v1 + w1 + } + + # Sum the high side. + k = xc + j + if (k <= npts) + d = datain[k] + else + d = datain[npts] + if (! IS_INDEFR(d)) { + dx = min_bdx - j + dx2 = sconst * j * j + dx4 = dx2 * dx2 + z = 1. / dx + w1 = w * z * (1.0 + a2 * dx2 + a4 * dx4) ** 2 + u1 = u1 + d * w1 + v1 = v1 + w1 + dx = -min_bdx - j + dx2 = sconst * j * j + dx4 = dx2 * dx2 + z = 1. / dx + w1 = -w * z * (1.0 + a2 * dx2 + a4 * dx4) ** 2 + u1 = u1 + d * w1 + v1 = v1 + w1 + } + } + + # Compute the result. + if (v1 != 0.) { + dataout[i] = u1 / v1 + } else { + do j = 1, npts { + k = xc - j + if (k >= 1) + d = datain[k] + else + d = datain[1] + if (!IS_INDEFR(d)) { + dataout[i] = d + break + } + k = xc + j + if (k <= npts) + d = datain[k] + else + d = datain[npts] + if (!IS_INDEFR(d)) { + dataout[i] = d + break + } + } + } + } +end diff --git a/math/iminterp/arider.x b/math/iminterp/arider.x new file mode 100644 index 00000000..55b3ee32 --- /dev/null +++ b/math/iminterp/arider.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ARIDER -- Return the derivatives of the interpolant. The sinc function +# width and precision limits are hardwired to the builtin constants NSINC +# and DX. The look-up table sinc function is aliased to the sinc function. +# The drizzle function pixel fraction is harwired to the builtin constant +# PIXFRAC. If PIXFRAC is 1.0 then the drizzle results are identical to the +# linear interpolation results. + +procedure arider (x, datain, npix, derivs, nder, interp_type) + +real x[ARB] # need 1 <= x <= n +real datain[ARB] # data values +int npix # number of data values +real derivs[ARB] # derivatives out -- derivs[1] is function value +int nder # total number of values returned in derivs +int interp_type # type of interpolator + +int i, j, k, nterms, nd, nearx +real pcoeff[MAX_NDERIVS], accum, deltax, temp, tmpx[2] + +begin + if (nder <= 0) + return + + # Zero out the derivatives array. + do i = 1, nder + derivs[i] = 0. + + switch (interp_type) { + + case II_NEAREST: + derivs[1] = datain[int (x[1] + 0.5)] + return + + case II_LINEAR: + nearx = x[1] + if (nearx >= npix) + temp = 2. * datain[nearx] - datain[nearx-1] + else + temp = datain[nearx+1] + derivs[1] = (x[1] - nearx) * temp + (nearx + 1 - x[1]) * + datain[nearx] + if (nder >= 2) + derivs[2] = temp - datain[nearx] + return + + case II_SINC, II_LSINC: + call ii_sincder (x, derivs, nder, datain, npix, NSINC, DX) + return + + case II_DRIZZLE: + call ii_driz1 (x, derivs[1], 1, datain, BADVAL) + if (nder > 1) { + deltax = x[2] - x[1] + if (deltax == 0.0) + derivs[2] = 0.0 + else { + tmpx[1] = x[1] + tmpx[2] = (x[1] + x[2]) / 2.0 + call ii_driz1 (x, temp, 1, datain, BADVAL) + tmpx[1] = tmpx[2] + tmpx[2] = x[2] + call ii_driz1 (x, derivs[2], 1, datain, BADVAL) + derivs[2] = 2.0 * (derivs[2] - temp) / deltax + } + } + return + + case II_POLY3: + call ia_pcpoly3 (x, datain, npix, pcoeff) + nterms = 4 + + case II_POLY5: + call ia_pcpoly5 (x, datain, npix, pcoeff) + nterms = 6 + + case II_SPLINE3: + call ia_pcspline3 (x, datain, npix, pcoeff) + nterms = 4 + + } + + # Evaluate the polynomial derivatives. + + nearx = x[1] + deltax = x[1] - nearx + + nd = nder + if (nder > nterms) + nd = nterms + + do k = 1, nd { + + # Evaluate using nested multiplication + accum = pcoeff[nterms - k + 1] + do j = nterms - k, 1, -1 + accum = pcoeff[j] + deltax * accum + derivs[k] = accum + + # Differentiate. + do j = 1, nterms - k + pcoeff[j] = j * pcoeff[j + 1] + } +end diff --git a/math/iminterp/arieval.x b/math/iminterp/arieval.x new file mode 100644 index 00000000..56d2c07a --- /dev/null +++ b/math/iminterp/arieval.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ARIEVAL -- Evaluate the interpolant at a given value of x. Arieval allows +# the interpolation of a few isolated points without the storage required for +# the sequential version. With the exception of the sinc function, the +# interpolation code is expanded directly in this routine to avoid the +# overhead of an aditional function call. The precomputed sinc function is +# not supported and is aliased to the regular sinc function. The default +# sinc function width and precision limits are hardwired to the builtin +# constants NSINC and DX. The default drizzle function pixel fraction is +# hardwired to the builtin constant PIXFRAC. If PIXFRAC is 1.0 then the +# drizzle results are identical to the linear interpolation results. + +real procedure arieval (x, datain, npts, interp_type) + +real x # x value, 1 <= x <= n +real datain[ARB] # array of data values +int npts # number of data values +int interp_type # interpolant type + +int i, k, nearx, pindex +real a[MAX_NDERIVS], cd20, cd21, cd40, cd41, deltax, deltay, hold +real bcoeff[SPLPTS+3], temp[SPLPTS+3], pcoeff[SPLINE3_ORDER] + +begin + switch (interp_type) { + + case II_NEAREST: + return (datain[int (x + 0.5)]) + + case II_LINEAR: + nearx = x + + # Protect against x = n. + if (nearx >= npts) + hold = 2. * datain[nearx] - datain[nearx - 1] + else + hold = datain[nearx+1] + + return ((x - nearx) * hold + (nearx + 1 - x) * datain[nearx]) + + case II_POLY3: + nearx = x + + # Protect against the x = 1 or x = n case. + k = 0 + for (i = nearx - 1; i <= nearx + 2; i = i + 1) { + k = k + 1 + if (i < 1) + a[k] = 2. * datain[1] - datain[2-i] + else if (i > npts) + a[k] = 2. * datain[npts] - datain[2*npts-i] + else + a[k] = datain[i] + } + + deltax = x - nearx + deltay = 1. - deltax + + # Second central differences. + cd20 = 1./6. * (a[3] - 2. * a[2] + a[1]) + cd21 = 1./6. * (a[4] - 2. * a[3] + a[2]) + + return (deltax * (a[3] + (deltax * deltax - 1.) * cd21) + + deltay * (a[2] + (deltay * deltay - 1.) * cd20)) + + case II_POLY5: + nearx = x + + # Protect against the x = 1 or x = n case. + k = 0 + for (i = nearx - 2; i <= nearx + 3; i = i + 1) { + k = k + 1 + if (i < 1) + a[k] = 2. * datain[1] - datain[2-i] + else if (i > npts) + a[k] = 2. * datain[npts] - datain[2*npts-i] + else + a[k] = datain[i] + } + + deltax = x - nearx + deltay = 1. - deltax + + # Second central differences. + cd20 = 1./6. * (a[4] - 2. * a[3] + a[2]) + cd21 = 1./6. * (a[5] - 2. * a[4] + a[3]) + + # Fourth central differences. + cd40 = 1./120. * (a[1] - 4. * a[2] + 6. * a[3] - 4. * a[4] + a[5]) + cd41 = 1./120. * (a[2] - 4. * a[3] + 6. * a[4] - 4. * a[5] + a[6]) + + return (deltax * (a[4] + (deltax * deltax - 1.) * + (cd21 + (deltax * deltax - 4.) * cd41)) + + deltay * (a[3] + (deltay * deltay - 1.) * + (cd20 + (deltay * deltay - 4.) * cd40))) + + case II_SPLINE3: + nearx = x + + deltax = x - nearx + k = 0 + + # Get the data. + for (i = nearx - SPLPTS/2 + 1; i <= nearx + SPLPTS/2; i = i + 1) { + if (i < 1 || i > npts) + ; + else { + k = k + 1 + if (k == 1) + pindex = nearx - i + 1 + bcoeff[k+1] = datain[i] + } + } + bcoeff[1] = 0. + bcoeff[k+2] = 0. + + # Compute coefficients. + call ii_spline (bcoeff, temp, k) + + pindex = pindex + 1 + bcoeff[k+3] = 0. + + pcoeff[1] = bcoeff[pindex-1] + 4. * bcoeff[pindex] + + bcoeff[pindex+1] + pcoeff[2] = 3. * (bcoeff[pindex+1] - bcoeff[pindex-1]) + pcoeff[3] = 3. * (bcoeff[pindex-1] - 2. * bcoeff[pindex] + + bcoeff[pindex+1]) + pcoeff[4] = -bcoeff[pindex-1] + 3. * bcoeff[pindex] - 3. * + bcoeff[pindex+1] + bcoeff[pindex+2] + + return (pcoeff[1] + deltax * (pcoeff[2] + deltax * + (pcoeff[3] + deltax * pcoeff[4]))) + + case II_SINC, II_LSINC: + call ii_sinc (x, hold, 1, datain, npts, NSINC, DX) + return (hold) + + case II_DRIZZLE: + call ii_driz1 (x, hold, 1, datain, BADVAL) + return (hold) + + } +end diff --git a/math/iminterp/asider.x b/math/iminterp/asider.x new file mode 100644 index 00000000..73e93b4d --- /dev/null +++ b/math/iminterp/asider.x @@ -0,0 +1,154 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASIDER -- Calculate nder derivatives assuming that x lands in the region +# 1 <= x <= npts. + +procedure asider (asi, x, der, nder) + +pointer asi # interpolant descriptor +real x[ARB] # x value +real der[ARB] # derivatives, der[1] is value der[2] is f prime +int nder # number items returned = 1 + number of derivatives + +int nearx, i, j, k, nterms, nd +pointer c0ptr, n0 +real deltax, accum, tmpx[2], pcoeff[MAX_NDERIVS], diff[MAX_NDERIVS] + +begin + # Return zero for derivatives that are zero. + do i = 1, nder + der[i] = 0. + + # Nterms is number of terms in case polynomial type. + nterms = 0 + + # (c0ptr + 1) is the pointer to the first data point in COEFF. + c0ptr = ASI_COEFF(asi) - 1 + ASI_OFFSET(asi) + + switch (ASI_TYPE(asi)) { + + case II_NEAREST: + der[1] = COEFF(c0ptr + int(x[1] + 0.5)) + return + + case II_LINEAR: + nearx = x[1] + der[1] = (x[1] - nearx) * COEFF(c0ptr + nearx + 1) + + (nearx + 1 - x[1]) * COEFF(c0ptr + nearx) + if (nder > 1) + der[2] = COEFF(c0ptr + nearx + 1) - COEFF(c0ptr + nearx) + return + + case II_SINC, II_LSINC: + call ii_sincder (x[1], der, nder, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi)), ASI_NCOEFF(asi), + ASI_NSINC(asi), DX) + return + + case II_DRIZZLE: + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_driz1 (x, der[1], 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_BADVAL(asi)) + else + call ii_driz (x, der[1], 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi), ASI_BADVAL(asi)) + if (nder > 1) { + deltax = x[2] - x[1] + if (deltax == 0.0) + der[2] = 0.0 + else { + tmpx[1] = x[1] + tmpx[2] = (x[1] + x[2]) / 2.0 + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_driz1 (tmpx, accum, 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_BADVAL(asi)) + else + call ii_driz (tmpx, accum, 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi), ASI_BADVAL(asi)) + tmpx[1] = tmpx[2] + tmpx[2] = x[2] + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_driz1 (tmpx, der[2], 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_BADVAL(asi)) + else + call ii_driz (tmpx, der[2], 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi), ASI_BADVAL(asi)) + der[2] = 2.0 * (der[2] - accum) / deltax + } + } + return + + case II_POLY3: + nterms = 4 + + case II_POLY5: + nterms = 6 + + case II_SPLINE3: + nterms = 4 + + default: + call error (0, "ASIDER: Unknown interpolant type") + } + + # Routines falls through to this point if the interpolant is one of + # the higher order polynomial types or a third order spline. + + nearx = x[1] + n0 = c0ptr + nearx + deltax = x[1] - nearx + + # Compute the number of derivatives needed. + nd = nder + if (nder > nterms) + nd = nterms + + # Generate the polynomial coefficients. + + if (ASI_TYPE(asi) == II_SPLINE3) { + + pcoeff[1] = COEFF(n0-1) + 4. * COEFF(n0) + COEFF(n0+1) + pcoeff[2] = 3. * (COEFF(n0+1) - COEFF(n0-1)) + pcoeff[3] = 3. * (COEFF(n0-1) - 2. * COEFF(n0) + COEFF(n0+1)) + pcoeff[4] = -COEFF(n0-1) + 3. * COEFF(n0) - 3. * COEFF(n0+1) + + COEFF(n0+2) + + # Newton's form written in line to get polynomial from data + } else { + + # Load data. + do i = 1, nterms + diff[i] = COEFF(n0 - nterms/2 + i) + + # Generate difference table. + do k = 1, nterms - 1 + do i = 1, nterms - k + diff[i] = (diff[i+1] - diff[i]) / k + + # Shift to generate polynomial coefficients. + do k = nterms, 2, -1 + do i = 2,k + diff[i] = diff[i] + diff[i-1] * (k - i - nterms/2) + do i = 1,nterms + pcoeff[i] = diff[nterms + 1 - i] + } + + # Compute the derivatives. As the loop progresses pcoeff contains + # coefficients of higher and higher derivatives. + + do k = 1, nd { + + # Evaluate using nested multiplication. + accum = pcoeff[nterms - k + 1] + do j = nterms - k, 1, -1 + accum = pcoeff[j] + deltax * accum + der[k] = accum + + # Differentiate polynomial. + do j = 1, nterms - k + pcoeff[j] = j * pcoeff[j + 1] + } +end diff --git a/math/iminterp/asieval.x b/math/iminterp/asieval.x new file mode 100644 index 00000000..51f9a63b --- /dev/null +++ b/math/iminterp/asieval.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASIEVAL -- This procedure finds the interpolated value assuming that +# x lands in the array, i.e. 1 <= x <= npts. + +real procedure asieval (asi, x) + +pointer asi # interpolator descriptor +real x[ARB] # x value + +real value + +begin + switch (ASI_TYPE(asi)) { # switch on interpolator type + + case II_NEAREST: + call ii_nearest (x, value, 1, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + return (value) + + case II_LINEAR: + call ii_linear (x, value, 1, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + return (value) + + case II_POLY3: + call ii_poly3 (x, value, 1, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + return (value) + + case II_POLY5: + call ii_poly5 (x, value, 1, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + return (value) + + case II_SPLINE3: + call ii_spline3 (x, value, 1, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + return (value) + + case II_SINC: + call ii_sinc (x, value, 1, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi)), ASI_NCOEFF(asi), + ASI_NSINC(asi), DX) + return (value) + + case II_LSINC: + call ii_lsinc (x, value, 1, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi)), ASI_NCOEFF(asi), + LTABLE(ASI_LTABLE(asi)), 2 * ASI_NSINC(asi) + 1, + ASI_NINCR(asi), DX) + return (value) + + case II_DRIZZLE: + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_driz1 (x, value, 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_BADVAL(asi)) + else + call ii_driz (x, value, 1, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi), ASI_BADVAL(asi)) + return (value) + + default: + call error (0, "ASIEVAL: Unknown interpolator type.") + } +end diff --git a/math/iminterp/asifit.x b/math/iminterp/asifit.x new file mode 100644 index 00000000..3ea33041 --- /dev/null +++ b/math/iminterp/asifit.x @@ -0,0 +1,146 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +define TEMP Memr[P2P($1)] + +# ASIFIT -- Fit the interpolant to the data. + +procedure asifit (asi, datain, npix) + +pointer asi # interpolant descriptor +real datain[ARB] # data array +int npix # nunber of data points + +int i +pointer c0ptr, cdataptr, cnptr, temp + +begin + # Check the data array for size and allocate space for the coefficient + # array. + + switch (ASI_TYPE(asi)) { + + case II_SPLINE3: + if (npix < 4) + call error (0, "ASIFIT: too few points for SPLINE3") + else { + ASI_NCOEFF(asi) = npix + 3 + ASI_OFFSET(asi) = 1 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + call malloc (temp, ASI_NCOEFF(asi), TY_REAL) + } + + case II_POLY5: + if (npix < 6) + call error (0,"ASIFIT: too few points for POLY5") + else { + ASI_NCOEFF(asi) = npix + 5 + ASI_OFFSET(asi) = 2 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + } + + case II_POLY3: + if (npix < 4) + call error (0, "ASIFIT: too few points for POLY3") + else { + ASI_NCOEFF(asi) = npix + 3 + ASI_OFFSET(asi) = 1 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + } + + case II_DRIZZLE, II_LINEAR: + if (npix < 2) + call error (0, "ASIFIT: too few points for LINEAR") + else { + ASI_NCOEFF(asi) = npix + 1 + ASI_OFFSET(asi) = 0 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + } + + case II_SINC, II_LSINC: + if (npix < 1) + call error (0, "ASIFIT: too few points for SINC") + else { + ASI_NCOEFF(asi) = npix + ASI_OFFSET(asi) = 0 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + } + + default: + if (npix < 1) + call error (0," ASIFIT: too few points for NEAREST") + else { + ASI_NCOEFF(asi) = npix + ASI_OFFSET(asi) = 0 + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + } + + } + + + # Define the pointers. + # (c0ptr + 1) points to first element in the coefficient array. + # (cdataptr + 1) points to first data element in the coefficient array. + # (cnptr + 1) points to the first element after the last data point in + # coefficient array. + + c0ptr = ASI_COEFF(asi) - 1 + cdataptr = ASI_COEFF(asi) - 1 + ASI_OFFSET(asi) + cnptr = cdataptr + npix + + # Put data into the interpolant structure. + do i = 1, npix + COEFF(cdataptr + i) = datain[i] + + # Specify the end conditions. + switch (ASI_TYPE(asi)) { + + case II_SPLINE3: + # Natural end conditions - second deriv. zero + COEFF(c0ptr + 1) = 0. + COEFF(cnptr + 1) = 0. + COEFF(cnptr + 2) = 0. # if x = npts + + # Fit spline - generate b-spline coefficients. + call ii_spline (COEFF(ASI_COEFF(asi)), TEMP(temp), npix) + call mfree (temp, TY_REAL) + + case II_NEAREST, II_SINC, II_LSINC: + # No end conditions required. + + case II_LINEAR, II_DRIZZLE: + COEFF(cnptr + 1) = 2. * COEFF(cdataptr + npix) - # if x = npts + COEFF(cdataptr + npix - 1) + + case II_POLY3: + COEFF(c0ptr + 1) = 2. * COEFF(cdataptr + 1) - COEFF(cdataptr + 2) + COEFF(cnptr + 1) = 2. * COEFF(cdataptr + npix) - + COEFF(cdataptr + npix - 1) + COEFF(cnptr + 2) = 2. * COEFF(cdataptr + npix) - + COEFF(cdataptr + npix - 2) + + case II_POLY5: + COEFF(c0ptr + 1) = 2. * COEFF(cdataptr + 1) - COEFF(cdataptr + 3) + COEFF(c0ptr + 2) = 2. * COEFF(cdataptr + 1) - COEFF(cdataptr + 2) + COEFF(cnptr + 1) = 2. * COEFF(cdataptr + npix) - + COEFF(cdataptr + npix - 1) + COEFF(cnptr + 2) = 2. * COEFF(cdataptr + npix) - + COEFF(cdataptr + npix - 2) + COEFF(cnptr + 3) = 2. * COEFF(cdataptr + npix) - + COEFF(cdataptr + npix - 3) + } +end diff --git a/math/iminterp/asifree.x b/math/iminterp/asifree.x new file mode 100644 index 00000000..2feda49b --- /dev/null +++ b/math/iminterp/asifree.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" + +# ASIFREE -- Procedure to deallocate sequential interpolant structure + +procedure asifree (asi) + +pointer asi # interpolant descriptor + +begin + if (ASI_COEFF(asi) != NULL) + call mfree (ASI_COEFF(asi), TY_REAL) + if (ASI_LTABLE(asi) != NULL) + call mfree (ASI_LTABLE(asi), TY_REAL) + call mfree (asi, TY_STRUCT) +end diff --git a/math/iminterp/asigeti.x b/math/iminterp/asigeti.x new file mode 100644 index 00000000..fbf1ddc1 --- /dev/null +++ b/math/iminterp/asigeti.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" +include + +# ASIGETI -- Procedure to fetch an asi integer parameter + +int procedure asigeti (asi, param) + +pointer asi # interpolant descriptor +int param # parameter to be fetched + +begin + switch (param) { + case II_ASITYPE: + return (ASI_TYPE(asi)) + case II_ASINSAVE: + return (ASI_NSINC(asi) * ASI_NINCR(asi) + ASI_NCOEFF(asi) + + ASI_SAVECOEFF) + case II_ASINSINC: + return (ASI_NSINC(asi)) + default: + call error (0, "ASIGETI: Unknown ASI parameter.") + } +end diff --git a/math/iminterp/asigetr.x b/math/iminterp/asigetr.x new file mode 100644 index 00000000..57cdd07f --- /dev/null +++ b/math/iminterp/asigetr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" +include + +# ASIGETR -- Procedure to fetch an msi real parameter + +real procedure asigetr (asi, param) + +pointer asi # interpolant descriptor +int param # parameter to be fetched + +begin + switch (param) { + case II_ASIBADVAL: + return (ASI_BADVAL(asi)) + default: + call error (0, "ASIGETR: Unknown ASI parameter.") + } +end diff --git a/math/iminterp/asigrl.x b/math/iminterp/asigrl.x new file mode 100644 index 00000000..55f2395f --- /dev/null +++ b/math/iminterp/asigrl.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASIGRL -- Procedure to find the integral of the interpolant from a to +# b be assuming that both a and b land in the array. + +real procedure asigrl (asi, a, b) + +pointer asi # interpolant descriptor +real a # lower limit for integral +real b # upper limit for integral + +int neara, nearb, i, j, nterms, index +real deltaxa, deltaxb, accum, xa, xb, pcoeff[MAX_NDERIVS] +pointer c0ptr, n0ptr + +begin + # Flip order and sign at end. + xa = a + xb = b + if (a > b) { + xa = b + xb = a + } + + # Initialize. + c0ptr = ASI_COEFF(asi) - 1 + ASI_OFFSET(asi) + neara = xa + nearb = xb + accum = 0. + + switch (ASI_TYPE(asi)) { + case II_NEAREST, II_SINC, II_LSINC, II_DRIZZLE: + nterms = 0 + case II_LINEAR: + nterms = 1 + case II_POLY3: + nterms = 4 + case II_POLY5: + nterms = 6 + case II_SPLINE3: + nterms = 4 + } + + # NEAREST_NEIGHBOR, LINEAR, SINC and LSINC are handled differently + # because of storage. Also probably good for speed in the case of + # LINEAR and NEAREST_NEIGHBOUR. + + # NEAREST_NEIGHBOR + switch (ASI_TYPE(asi)) { + case II_NEAREST: + + # Reset segment to center values. + neara = xa + 0.5 + nearb = xb + 0.5 + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment involved. + if (nearb == neara) { + deltaxb = xb - nearb + n0ptr = c0ptr + neara + accum = accum + (deltaxb - deltaxa) * COEFF(n0ptr) + + # More than one segment. + } else { + + # First segment. + n0ptr = c0ptr + neara + accum = accum + (0.5 - deltaxa) * COEFF(n0ptr) + + # Middle segment. + do j = neara + 1, nearb - 1 { + n0ptr = c0ptr + j + accum = accum + COEFF(n0ptr) + } + + # Last segment. + n0ptr = c0ptr + nearb + deltaxb = xb - nearb + accum = accum + (deltaxb + 0.5) * COEFF(n0ptr) + } + + # LINEAR + case II_LINEAR: + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment is involved. + if (nearb == neara) { + deltaxb = xb - nearb + n0ptr = c0ptr + neara + accum = accum + (deltaxb - deltaxa) * COEFF(n0ptr) + + 0.5 * (COEFF(n0ptr+1) - COEFF(n0ptr)) * + (deltaxb * deltaxb - deltaxa * deltaxa) + + # More than one segment. + } else { + + # First segment. + n0ptr = c0ptr + neara + accum = accum + (1. - deltaxa) * COEFF(n0ptr) + + 0.5 * (COEFF(n0ptr+1) - COEFF(n0ptr)) * + (1. - deltaxa * deltaxa) + + # Middle segment. + do j = neara + 1, nearb - 1 { + n0ptr = c0ptr + j + accum = accum + 0.5 * (COEFF(n0ptr+1) + COEFF(n0ptr)) + } + + # Last segment. + n0ptr = c0ptr + nearb + deltaxb = xb - nearb + accum = accum + COEFF(n0ptr) * deltaxb + 0.5 * + (COEFF(n0ptr+1) - COEFF(n0ptr)) * deltaxb * deltaxb + } + + # SINC + case II_SINC, II_LSINC: + call ii_sincigrl (xa, xb, accum, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_NCOEFF(asi), ASI_NSINC(asi), DX) + + # DRIZZLE + case II_DRIZZLE: + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_dzigrl1 (xa, xb, accum, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi))) + else + call ii_dzigrl (xa, xb, accum, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi)) + + # A higher order interpolant. + default: + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment involved. + if (nearb == neara) { + + deltaxb = xb - nearb + n0ptr = c0ptr + neara + index = ASI_OFFSET(asi) + neara + call ii_getpcoeff (COEFF(ASI_COEFF(asi)), index, pcoeff, + ASI_TYPE(asi)) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * + (deltaxb ** i - deltaxa ** i) + + # More than one segment. + } else { + + # First segment. + index = ASI_OFFSET(asi) + neara + call ii_getpcoeff (COEFF(ASI_COEFF(asi)), index, pcoeff, + ASI_TYPE(asi)) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * (1. - deltaxa ** i) + + # Middle segment. + do j = neara + 1, nearb - 1 { + index = ASI_OFFSET(asi) + j + call ii_getpcoeff (COEFF(ASI_COEFF(asi)), + index, pcoeff, ASI_TYPE(asi)) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] + } + + # Last segment. + index = ASI_OFFSET(asi) + nearb + deltaxb = xb - nearb + call ii_getpcoeff (COEFF(ASI_COEFF(asi)), index, pcoeff, + ASI_TYPE(asi)) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * deltaxb ** i + } + } + + if (a < b) + return (accum) + else + return (-accum) +end diff --git a/math/iminterp/asiinit.x b/math/iminterp/asiinit.x new file mode 100644 index 00000000..daf99665 --- /dev/null +++ b/math/iminterp/asiinit.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASIINIT -- initialize the array sequential interpolant structure + +procedure asiinit (asi, interp_type) + +pointer asi # interpolant descriptor +int interp_type # interpolant type + +int nconv + +begin + if (interp_type < 1 || interp_type > II_NTYPES) + call error (0,"ASIINIT: Illegal interpolant type.") + else { + call calloc (asi, LEN_ASISTRUCT, TY_STRUCT) + ASI_TYPE(asi) = interp_type + switch (interp_type) { + case II_LSINC: + ASI_NSINC(asi) = NSINC + ASI_NINCR(asi) = NINCR + if (ASI_NINCR(asi) > 1) + ASI_NINCR(asi) = ASI_NINCR(asi) + 1 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + nconv = 2 * ASI_NSINC(asi) + 1 + call calloc (ASI_LTABLE(asi), nconv * ASI_NINCR(asi), + TY_REAL) + call ii_sinctable (Memr[ASI_LTABLE(asi)], nconv, ASI_NINCR(asi), + ASI_SHIFT(asi)) + case II_SINC: + ASI_NSINC(asi) = NSINC + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + ASI_LTABLE(asi) = NULL + case II_DRIZZLE: + ASI_NSINC(asi) = 0 + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + ASI_LTABLE(asi) = NULL + default: + ASI_NSINC(asi) = 0 + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + ASI_LTABLE(asi) = NULL + } + ASI_BADVAL(asi) = BADVAL + ASI_COEFF(asi) = NULL + } + +end diff --git a/math/iminterp/asirestore.x b/math/iminterp/asirestore.x new file mode 100644 index 00000000..7c6c81d0 --- /dev/null +++ b/math/iminterp/asirestore.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" +include + +# ASIRESTORE -- Procedure to restore the interpolant stored by ASISAVE +# for use by ASIEVAL, ASIVECTOR, ASIDER and ASIGRL. + +procedure asirestore (asi, interpolant) + +pointer asi # interpolant descriptor +real interpolant[ARB] # array containing the interpolant + +int interp_type, i, nconv +pointer cptr + +begin + interp_type = int (ASI_SAVETYPE(interpolant)) + if (interp_type < 1 || interp_type > II_NTYPES) + call error (0, "ASIRESTORE: Unknown interpolant type.") + + # Allocate the interpolant descriptor structure and restore + # interpolant parameters. + + call malloc (asi, LEN_ASISTRUCT, TY_STRUCT) + ASI_TYPE(asi) = interp_type + ASI_NSINC(asi) = nint (ASI_SAVENSINC(interpolant)) + ASI_NINCR(asi) = nint (ASI_SAVENINCR(interpolant)) + ASI_SHIFT(asi) = ASI_SAVESHIFT(interpolant) + ASI_PIXFRAC(asi) = ASI_SAVEPIXFRAC(interpolant) + ASI_NCOEFF(asi) = nint (ASI_SAVENCOEFF(interpolant)) + ASI_OFFSET(asi) = nint (ASI_SAVEOFFSET(interpolant)) + ASI_BADVAL(asi) = ASI_SAVEBADVAL(interpolant) + + # Allocate space for and restore coefficients. + call malloc (ASI_COEFF(asi), ASI_NCOEFF(asi), TY_REAL) + cptr = ASI_COEFF(asi) - 1 + do i = 1, ASI_NCOEFF(asi) + COEFF(cptr+i) = interpolant[ASI_SAVECOEFF+i] + + # Allocate space for and restore the look-up tables. + if (ASI_NINCR(asi) > 0) { + nconv = 2 * ASI_NSINC(asi) + 1 + call malloc (ASI_LTABLE(asi), nconv * ASI_NINCR(asi), TY_REAL) + cptr = ASI_LTABLE(asi) - 1 + do i = 1, nconv * ASI_NINCR(asi) + LTABLE(cptr+i) = interpolant[ASI_SAVECOEFF+ASI_NCOEFF(asi)+i] + } else + ASI_LTABLE(asi) = NULL +end diff --git a/math/iminterp/asisave.x b/math/iminterp/asisave.x new file mode 100644 index 00000000..6d6d83db --- /dev/null +++ b/math/iminterp/asisave.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" +include + +# ASISAVE -- Procedure to save the interpolant for later use by ASIEVAL, +# ASIVECTOR, ASIDER and ASIGRL. + +procedure asisave (asi, interpolant) + +pointer asi # interpolant descriptor +real interpolant[ARB] # array containing the interpolant + +int i, nconv +pointer cptr + +begin + # Save the interpolant type, number of coefficients, and position of + # first data point. + + ASI_SAVETYPE(interpolant) = ASI_TYPE(asi) + ASI_SAVENSINC(interpolant) = ASI_NSINC(asi) + ASI_SAVENINCR(interpolant) = ASI_NINCR(asi) + ASI_SAVESHIFT(interpolant) = ASI_SHIFT(asi) + ASI_SAVEPIXFRAC(interpolant) = ASI_PIXFRAC(asi) + ASI_SAVENCOEFF(interpolant) = ASI_NCOEFF(asi) + ASI_SAVEOFFSET(interpolant) = ASI_OFFSET(asi) + ASI_SAVEBADVAL(interpolant) = ASI_BADVAL(asi) + + # Save the coefficients. + cptr = ASI_COEFF(asi) - 1 + do i = 1, ASI_NCOEFF(asi) + interpolant[ASI_SAVECOEFF+i] = COEFF(cptr+i) + + # Save the lookup-tables. + if (ASI_NINCR(asi) > 0) { + nconv = 2 * ASI_NSINC(asi) + 1 + cptr = ASI_LTABLE(asi) - 1 + do i = 1, nconv * ASI_NINCR(asi) + interpolant[ASI_SAVECOEFF+ASI_NCOEFF(asi)+i] = LTABLE(cptr+i) + } +end diff --git a/math/iminterp/asisinit.x b/math/iminterp/asisinit.x new file mode 100644 index 00000000..dc09ac0e --- /dev/null +++ b/math/iminterp/asisinit.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASISINIT -- initialize the interpolant. This is a special entry point +# for the sinc interpolant although it will initialize the others too. + +procedure asisinit (asi, interp_type, nsinc, nincr, shift, badval) + +pointer asi # interpolant descriptor +int interp_type # interpolant type +int nsinc # sinc interpolant width +int nincr # number of sinc look-up table elements +real shift # sinc interpolant shift +real badval # drizzle bad pixel value + +int nconv + +begin + if (interp_type < 1 || interp_type > II_NTYPES) + call error (0, "ASISINIT: Illegal interpolant type") + else { + call calloc (asi, LEN_ASISTRUCT, TY_STRUCT) + ASI_TYPE(asi) = interp_type + switch (interp_type) { + case II_LSINC: + ASI_NSINC(asi) = (nsinc - 1) / 2 + ASI_NINCR(asi) = nincr + if (ASI_NINCR(asi) > 1) + ASI_NINCR(asi) = ASI_NINCR(asi) + 1 + if (nincr > 1) + ASI_SHIFT(asi) = INDEFR + else + ASI_SHIFT(asi) = shift + ASI_PIXFRAC(asi) = PIXFRAC + nconv = 2 * ASI_NSINC(asi) + 1 + call calloc (ASI_LTABLE(asi), nconv * ASI_NINCR(asi), + TY_REAL) + call ii_sinctable (Memr[ASI_LTABLE(asi)], nconv, ASI_NINCR(asi), + ASI_SHIFT(asi)) + case II_SINC: + ASI_NSINC(asi) = (nsinc - 1) / 2 + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + ASI_LTABLE(asi) = NULL + case II_DRIZZLE: + ASI_NSINC(asi) = 0 + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = max (MIN_PIXFRAC, min (shift, 1.0)) + ASI_LTABLE(asi) = NULL + default: + ASI_NSINC(asi) = 0 + ASI_NINCR(asi) = 0 + ASI_SHIFT(asi) = INDEFR + ASI_PIXFRAC(asi) = PIXFRAC + ASI_LTABLE(asi) = NULL + } + ASI_COEFF(asi) = NULL + ASI_BADVAL(asi) = badval + } +end diff --git a/math/iminterp/asitype.x b/math/iminterp/asitype.x new file mode 100644 index 00000000..708ebf58 --- /dev/null +++ b/math/iminterp/asitype.x @@ -0,0 +1,90 @@ +include "im1interpdef.h" +include + +# ASITYPE -- Decode the interpolation string input by the user. + +procedure asitype (interpstr, interp_type, nsinc, nincr, shift) + +char interpstr[ARB] # the input interpolation string +int interp_type # the interpolation type +int nsinc # the sinc interpolation width +int nincr # the sinc interpolation lut resolution +real shift # the predefined shift or pixfrac + +int ip +pointer sp, str +int strdic(), strncmp(), ctoi(), ctor() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + interp_type = strdic (interpstr, Memc[str], SZ_FNAME, II_FUNCTIONS) + + if (interp_type > 0) { + switch (interp_type) { + case II_LSINC: + nsinc = 2 * NSINC + 1 + nincr = NINCR + shift = INDEFR + case II_SINC: + nsinc = 2 * NSINC + 1 + nincr = 0 + shift = INDEFR + case II_DRIZZLE: + nsinc = 0 + nincr = 0 + shift = PIXFRAC + default: + nsinc = 0 + nincr = 0 + shift = INDEFR + } + } else if (strncmp (interpstr, "lsinc", 5) == 0) { + interp_type = II_LSINC + ip = 6 + if (ctoi (interpstr, ip, nsinc) <= 0) { + nsinc = 2 * NSINC + 1 + nincr = NINCR + shift = INDEFR + } else { + if (interpstr[ip] == '[') + ip = ip + 1 + if (ctor (interpstr, ip, shift) <= 0) + shift = INDEFR + if (IS_INDEFR(shift) || interpstr[ip] != ']') { + nincr = NINCR + shift = INDEFR + } else if (shift >= -0.5 && shift < 0.5) { + nincr = 1 + } else { + nincr = nint (shift) + shift = INDEFR + } + } + } else if (strncmp (interpstr, "sinc", 4) == 0) { + ip = 5 + interp_type = II_SINC + if (ctoi (interpstr, ip, nsinc) <= 0) + nsinc = 2 * NSINC + 1 + nincr = 0 + shift = INDEFR + } else if (strncmp (interpstr, "drizzle", 7) == 0) { + ip = 8 + if (interpstr[ip] == '[') + ip = ip + 1 + if (ctor (interpstr, ip, shift) <= 0) + shift = PIXFRAC + interp_type = II_DRIZZLE + nsinc = 0 + nincr = 0 + if (interpstr[ip] != ']') + shift = PIXFRAC + } else { + interp_type = 0 + nsinc = 0 + nincr = 0 + shift = INDEFR + } + + call sfree (sp) +end diff --git a/math/iminterp/asivector.x b/math/iminterp/asivector.x new file mode 100644 index 00000000..153a751a --- /dev/null +++ b/math/iminterp/asivector.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# ASIVECTOR -- Procedure to evaluate the interpolant at an array of ordered +# points assuming that all points land in 1 <= x <= npts. + +procedure asivector (asi, x, y, npix) + +pointer asi # interpolator descriptor +real x[ARB] # ordered x array +real y[ARB] # interpolated values +int npix # number of points in x + +begin + switch (ASI_TYPE(asi)) { + + case II_NEAREST: + call ii_nearest (x, y, npix, + COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + + case II_LINEAR: + call ii_linear (x, y, npix, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + + case II_POLY3: + call ii_poly3 (x, y, npix, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + + case II_POLY5: + call ii_poly5 (x, y, npix, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi))) + + case II_SPLINE3: + call ii_spline3 (x, y, npix, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi))) + + case II_SINC: + call ii_sinc (x, y, npix, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi)), + ASI_NCOEFF(asi), ASI_NSINC(asi), DX) + + case II_LSINC: + call ii_lsinc (x, y, npix, COEFF(ASI_COEFF(asi) + ASI_OFFSET(asi)), + ASI_NCOEFF(asi), LTABLE(ASI_LTABLE(asi)), + 2 * ASI_NSINC(asi) + 1, ASI_NINCR(asi), DX) + + case II_DRIZZLE: + if (ASI_PIXFRAC(asi) >= 1.0) + call ii_driz1 (x, y, npix, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_BADVAL(asi)) + else + call ii_driz (x, y, npix, COEFF(ASI_COEFF(asi) + + ASI_OFFSET(asi)), ASI_PIXFRAC(asi), ASI_BADVAL(asi)) + + default: + call error (0, "ASIVECTOR: Unknown interpolator type.") + } +end diff --git a/math/iminterp/doc/arbpix.hlp b/math/iminterp/doc/arbpix.hlp new file mode 100644 index 00000000..0d7ec9ec --- /dev/null +++ b/math/iminterp/doc/arbpix.hlp @@ -0,0 +1,57 @@ +.help arbpix Dec98 "Image Interpolator Package" +.ih +NAME +arbpix -- replace INDEF valued pixels with interpolated values +.ih +SYNOPSIS +include + +arbpix (datain, dataout, npix, interp_type, boundary_type) + +.nf + real datain[npix] #I input data + real dataout[npix] #O output array, dataout != datain + int npix #I number of data points + int interp_type #I type of interpolant + int boundary_type #I type of boundary condition +.fi +.ih +ARGUMENTS +.ls datain +Array of input data containing 0 or more INDEF valued pixels. +.le +.ls dataout +Array of output data with INDEFS replaced by interpolated values. +The dataout array must be different from the datain array. +.le +.ls npix +Number of data points. +.le +.ls interp_type +Type of interpolant. Options are II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, +II_SPLINE3, II_SINC / II_LSINC, and II_DRIZZLE. The look-up table sinc +interpolant is not supported, and defaults to the sinc interpolant. +The sinc interpolant width is 31 pixels. The drizzle interpolant is not +supported and defaults to the linear interpolant. The interpolant type +definitions are stored in the file math/iminterp.h. +.le +.ls boundary_type +Type of boundary extension. The only supported option is II_BOUNDARYEXT. +Polynomial interpolants of lower order are used if there are not enough +good pixels to define the requested interpolant. Nearest neighbor boundary +extension is used if there are not enough good points to define the sinc +interpolant. The boundary type definitions are stored in the header file +math/iminterp.h. +.le +.ih +DESCRIPTION +If there are no good points in datain, ARBPIX returns INDEFS in dataout. +Points below and above the first and last good point are replaced by the +first and last good point values respectively. +.ih +NOTES +The sinc function actually evaluates the interpolant by computing the +average of two interpolations at +-0.05 pixels about the bad pixel since +the interpolant is undefined exactly at a pixel. +.ih +SEE ALSO diff --git a/math/iminterp/doc/arider.hlp b/math/iminterp/doc/arider.hlp new file mode 100644 index 00000000..b8631eaa --- /dev/null +++ b/math/iminterp/doc/arider.hlp @@ -0,0 +1,59 @@ +.help arider Dec98 "Image Interpolator Package" +.ih +NAME +arider -- calculate the interpolant derivatives at x +.ih +SYNOPSIS +include + +arider (x, datain, npix, der, nder, interp_type) + +.nf + real x[2] #I x value, 1 <= x[1-2] <= npts + real datain[npix] #I array of data points + int npix #I number of data points + real der[nder] #O derivatives, der[1] = function value + int nder #I number of derivatives, 1 + max order + int interp_type #I interpolant type +.fi +.ih +ARGUMENTS +.ls x +Single X value, or pair of X values defining a range in the case of the +drizzle interpolant. +.le +.ls datain +Array of data values. +.le +.ls npix +Number of data points. +.le +.ls der +Array of derivatives. Der[1] contains the function value, der[2] the +first derivative, and so on. +.le +.ls nder +Number of derivatives. ARIDER checks that the requested number of derivatives +is sensible. The sinc interpolant returns the function value and the first +two derivatives. The drizzle interpolant returns the function and the first +derivative. +.le +.ls interp_type +Interpolant type. The options are II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, +II_SPLINE3, II_SINC / II_LSINC, and II_DRIZZLE. The look-up table sinc +is not supported and defaults to sinc. The sinc interpolant width is 31 pixels. +The drizzle pixel fraction is 1.0. The interpolant type definitions are found +in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +ARIDER permits the evaluation of the interpolant at a few randomly spaced +points within datain without the storage requirements of the sequential +version. +.ih +NOTES +Checking for INDEF valued or out of bounds pixels is the responsibility +of the user. +.ih +SEE ALSO +asider diff --git a/math/iminterp/doc/arieval.hlp b/math/iminterp/doc/arieval.hlp new file mode 100644 index 00000000..52c62148 --- /dev/null +++ b/math/iminterp/doc/arieval.hlp @@ -0,0 +1,48 @@ +.help arieval Dec98 "Image Interpolator Package" +.ih +NAME +arieval -- evaluate the interpolant at x +.ih +SYNOPSIS +include + +y = arieval (x, datain, npix, interp_type) + +.nf + real x[2] #I x value, 1 <= x[1-2] <= npix + real datain[npix] #I data values + int npix #I number of data values + int interp_type #I interpolant type +.fi +.ih +ARGUMENTS +.ls x +Single X value, or a pair of X values specifying a range in the case +of the drizzle interpolant. +.le +.ls datain +Array of input data. +.le +.ls npix +Number of data points. +.le +.ls interp_type +Interpolant type. Options are II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, +II_SPLINE3, II_SINC / II_LSINC, and II_DRIZZLE, for nearest neighbor, +linear, 3rd and fifth order polynomials, cubic spline, sinc, look-up +table sinc, and drizzle interpolants respectively. The look-up table sinc +interpolant is not supported and defaults to the sinc interpolant. The sinc +width is 31 pixels. The drizzle pixel fraction is 1.0. The interpolant +type definitions are contained in the package header file math/iminterp.h +.le +.ih +DESCRIPTION +ARIEVAL allows the evaluation of a few interpolated points without the +storage required for the sequential interpolant. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility of +the user. +.ih +SEE ALSO +arider, asieval, asivector diff --git a/math/iminterp/doc/asider.hlp b/math/iminterp/doc/asider.hlp new file mode 100644 index 00000000..0c27ffbc --- /dev/null +++ b/math/iminterp/doc/asider.hlp @@ -0,0 +1,52 @@ +.help asider Dec98 "Image Interpolator Package" +.ih +NAME +asider -- evaluate the interpolant derivatives at x +.ih +SYNOPSIS +asider (asi, x, der, nder) + +.nf + pointer asi #I interpolant descriptor + real x[2] #I x value, 1 <= x[1-2] <= npix + real der[] #O der[1] = interpolant, der[2] = 1st derivative + int nder #I number of derivatives +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor. +.le +.ls x +Single X value, or pair of X values defining a range in the case of +the drizzle interpolant. +.le +.ls der +Array containing the derivatives. Der[1] = interpolant at x, der[2] the +first derivative of the interpolant at x and so on. +.le +.ls nder +Number of derivatives. Nder = 1 + order of the maximum desired derivative. +ASIDER checks that nder is reasonable. The sinc interpolant returns the +interpolant value and first two derivatives. The drizzle interpolant returns +the interpolant value and the first derivative. +.le +.ih +DESCRIPTION +The polynomial coefficients are evaluated directly from the data points +for the polynomial interpolants and from the B-spline coefficients +for the cubic spline interpolant. The derivatives are evaluated from +the polynomial coefficients using nested multiplication. The sinc +derivatives are analytic but are defined only for the first two derivatives. +The drizzle derivative is an approximation defined for the first derivative +only. +.ih +NOTES +ASIDER checks that the number of derivatives requested is reasonable. +Checking for out of bounds and INDEF valued pixels is the responsibility +of the user. ASIINIT or ASISINIT and ASIFIT must be called before ASIDER +is called. +.ih +SEE ALSO +asieval, asivector, arieval, arider +.endhelp diff --git a/math/iminterp/doc/asieval.hlp b/math/iminterp/doc/asieval.hlp new file mode 100644 index 00000000..20f70abe --- /dev/null +++ b/math/iminterp/doc/asieval.hlp @@ -0,0 +1,44 @@ +.help asieval Dec98 "Image Interpolator Package" +.ih +NAME +asieval -- procedure to evaluate interpolant at x +.ih +SYNOPSIS +y = asieval (asi, x) + +.nf + pointer asi #I interpolant descriptor + real x[2] #I x value, 1 <= x[1-2] <= npts +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor structure. +.le +.ls x +Single X value, or pair of X values defining a range in the case of the +drizzle interpolant. +.le +.ih +DESCRIPTION +The polynomial coefficients are calculated directly from the data points +for the polynomial interpolants, and from the B-spline coefficients for +the cubic spline interpolant. The actual calculation is done by adding and +multiplying terms according to Everett's central difference interpolation +formula. The boundary extension algorithm is projection. + +The sinc interpolant is computed using a range of data points around +the desired position. Look-up table sinc interpolation is computed +using the most appropriate entry in a precomputed look-up table. +The boundary extension algorithm is nearest neighbor. + +The drizzle interpolant is computed by summing the data over the user +supplied X interval. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility of +the user. ASIINIT or ASISINIT and ASIFIT must be called before using ASIEVAL. +.ih +SEE ALSO +asivector, arieval +.endhelp diff --git a/math/iminterp/doc/asifit.hlp b/math/iminterp/doc/asifit.hlp new file mode 100644 index 00000000..bcd1fdc8 --- /dev/null +++ b/math/iminterp/doc/asifit.hlp @@ -0,0 +1,40 @@ +.help asifit Dec98 "Image Interpolator Package" +.ih +NAME +asifit - fit the interpolant to data +.ih +SYNOPSIS +asifit (asi, datain, npix) + +.nf + pointer asi #I interpolant descriptor + real datain[npix] #I input data + int npix #I the number of data points +.fi +.ih +ARGUMENTS +.ls asi +Pointer to sequential interpolant descriptor structure. +.le +.ls datain +Array of input data. +.le +.ls npix +Number of data points. +.le +.ih +DESCRIPTION +The datain array is checked for size, memory is allocated for the coefficient +array, and the end conditions are specified. The interior polynomial, sinc and +drizzle interpolants are saved as the data points. The polynomial coefficients +are calculated directly from the data points in the evaluation stage. The +B-spline coefficients are calculated in ASIFIT as they depend on the entire +data array. +.ih +NOTES +Checking for INDEF valued and out of bounds pixels is the responsibility +of the user. ASIINIT or ASISINIT and ASIFIT must be called before using +ASIEVAL, ASIVECTOR, ASIDER or ASIGRL. +.ih +SEE ALSO +.endhelp diff --git a/math/iminterp/doc/asifree.hlp b/math/iminterp/doc/asifree.hlp new file mode 100644 index 00000000..c61f2ce0 --- /dev/null +++ b/math/iminterp/doc/asifree.hlp @@ -0,0 +1,25 @@ +.help asifree Dec98 "Image Interpolator Package" +.ih +NAME +asifree - free sequential interpolant descriptor +.ih +SYNOPSIS +asifree (asi) + +.nf +pointer asi #U interpolant descriptor +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor structure. +.le +.ih +DESCRIPTION +ASIFREE frees the sequential interpolant descriptor structure allocated by +ASIINIT or ASISINIT. ASIFREE should be called when interpolation is complete. +.ih +NOTES +.ih +SEE ALSO +asiinit, asisinit diff --git a/math/iminterp/doc/asigeti.hlp b/math/iminterp/doc/asigeti.hlp new file mode 100644 index 00000000..0e9d1964 --- /dev/null +++ b/math/iminterp/doc/asigeti.hlp @@ -0,0 +1,36 @@ +.help asigeti Dec98 asigeti.hlp +.ih +NAME +asigeti -- fetch an asi integer parameter +.ih +SYNOPSIS +include + +value = asigeti (asi, param) + +.nf + pointer asi #I interpolant descriptor + int param #I parameter +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor structure. +.le +.ls param +The parameter to be fetched. The choices are: II_ASITYPE the interpolant +type, II_ASINSAVE the length of the saved coefficient array, and +II_ASINSINC the half-width of the sinc interpolant. The parameter +definitions are contained in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +ASIGETI is used to determine the size of the coefficient array that +must be allocated to save the sequential interpolant description structure, +and to fetch selected sequential interpolant parameters. +.ih +NOTES +.ih +SEE ALSO +asiinit, asisinit, asigetr +.endhelp diff --git a/math/iminterp/doc/asigetr.hlp b/math/iminterp/doc/asigetr.hlp new file mode 100644 index 00000000..8a31deef --- /dev/null +++ b/math/iminterp/doc/asigetr.hlp @@ -0,0 +1,36 @@ +.help asigetr Dec98 asigetr.hlp +.ih +NAME +asigetr -- fetch an asi integer parameter +.ih +SYNOPSIS +include + +value = asigetr (asi, param) + +.nf + pointer asi #I interpolant descriptor + int param #I parameter +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor structure. +.le +.ls param +The parameter to be fetched. The choices are: II_ASIBADVAL the undefined +pixel value for the drizzle interpolant. The parameter definitions are +contained in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +ASIGETR is used to set the value of undefined drizzle interpolant pixels. +Undefined pixels are those for which the interpolation coordinates do not +overlap the input coordinates, but are still, within the boundaries of the input +image, a situation which may occur when the pixel fraction is < 1.0. +.ih +NOTES +.ih +SEE ALSO +asiinit, asisinit, asigeti +.endhelp diff --git a/math/iminterp/doc/asigrl.hlp b/math/iminterp/doc/asigrl.hlp new file mode 100644 index 00000000..4c3087bb --- /dev/null +++ b/math/iminterp/doc/asigrl.hlp @@ -0,0 +1,40 @@ +.help asigrl Dec98 "Image Interpolator Package" +.ih +NAME +asigrl -- integrate interpolant from a to b +.ih +SYNOPSIS +integral = asigrl (asi, a, b) + +.nf + pointer asi #I interpolant descriptor + real a #I lower limit for integral, 1 <= a <= npix + real b #I upper limit for integral, 1 <= b <= npix +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolant descriptor structure. +.le +.ls a +Lower limit to the integral, where 1 <= a <= npix. +.le +.ls b +Upper limit to the integral, where 1 <= b <= npix. +.le +.ih +DESCRIPTION +The integral is calculated assuming that the interior polynomial, sinc, and +drizzle interpolants are stored as the data points, and that the spline +interpolant is stored as an array of B-spline coefficients. + +The integral of the sinc interpolant is computed by dividing the integration +interval into a number of equal size subintervals which are at most one pixel +wide. The integral of each subinterval is the central value times the interval +width. The look-up table sinc interpolant is not supported and defaults to +the sinc interpolant. +.ih +NOTES +ASIINIT or ASISINIT and ASIFIT must be called before using ASIGRL. +.ih +SEE ALSO diff --git a/math/iminterp/doc/asiinit.hlp b/math/iminterp/doc/asiinit.hlp new file mode 100644 index 00000000..711d7969 --- /dev/null +++ b/math/iminterp/doc/asiinit.hlp @@ -0,0 +1,39 @@ +.help asiinit Dec98 "Image Interpolator Package" +.ih +NAME +asiinit -- initialize the sequential interpolant descriptor using default parameters +.ih +SYNOPSIS +include + +asiinit (asi, interp_type) + +.nf + pointer asi #O interpolant descriptor + int interp_type #I interpolant type +.fi + +.ih +ARGUMENTS +.ls asi +Pointer to sequential interpolant descriptor. +.le +.ls interp_type +Interpolant type. The options are II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, +II_SPLINE3, II_SINC, II_LSINC, and II_DRIZZLE for nearest neighbor, linear, +3rd order polynomial, 5th order polynomial, cubic spline, sinc, look-up +table sinc, and drizzle respectively. The interpolant type definitions are +found in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +The interpolant descriptor is allocated and initialized. The pointer asi is +returned by ASIINIT. The sinc interpolant width defaults to 31 pixels. The +look-up table sinc interpolant resolution defaults to 20 intervals or +0.05 pixels. The drizzle pixel fraction defaults to 1.0. +.ih +NOTES +ASIINIT or ASISINIT must be called before using any other ASI routines. +.ih +SEE ALSO +asisinit, asifree diff --git a/math/iminterp/doc/asirestore.hlp b/math/iminterp/doc/asirestore.hlp new file mode 100644 index 00000000..6dd70262 --- /dev/null +++ b/math/iminterp/doc/asirestore.hlp @@ -0,0 +1,36 @@ +.help asirestore Dec98 "Image Interpolator Package" +.ih +NAME +asirestore -- restore interpolant +.ih +SYNOPSIS +asirestore (asi, interpolant) + +.nf + pointer asi #O interpolant descriptor + real interpolant[] #I array containing interpolant +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the interpolant descriptor structure. +.le +.ls interpolant +Array containing the interpolant. The length of interpolant can be determined +by a call to ASIGETI. +.le + +.nf + len_interpolant = asigeti (asi, II_ASINSAVE) +.fi +.ih +DESCRIPTION +ASIRESTORE allocates space for the interpolant descriptor and restores the +parameters and coefficients stored in the interpolant array to a structure +for use with ASIEVAL, ASIVECTOR, ASIDER and ASIGRL. +.ih +NOTES +.ih +SEE ALSO +asisave +.endhelp diff --git a/math/iminterp/doc/asisave.hlp b/math/iminterp/doc/asisave.hlp new file mode 100644 index 00000000..7c8ff37a --- /dev/null +++ b/math/iminterp/doc/asisave.hlp @@ -0,0 +1,39 @@ +.help asisave Dec98 "Image Interpolator Package" +.ih +NAME +asisave -- save interpolant +.ih +SYNOPSIS +asisave (asi, interpolant) + +.nf + pointer asi #I interpolant descriptor + real interpolant[] #O array containing the interpolant +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the interpolant descriptor structure. +.le +.ls interpolant +Array where the interpolant is stored. The size of interpolant can be +determined by a call to asigeti. +.le + +.nf + len_interpolant = asigeti (asi, II_ASINSAVE) +.fi +.ih +DESCRIPTION +The interpolant type, number of coefficients and the position of +the first data point in the coefficient array, along with various +parameters such as the sinc interpolant width, sinc look-up table +resolution, and drizzle pixel fraction, are stored in the first +7 elements of the interpolant array. The remaining elements contain +the coefficients calculated by ASIFIT. +.ih +NOTES +.ih +SEE ALSO +asirestore +.endhelp diff --git a/math/iminterp/doc/asisinit.hlp b/math/iminterp/doc/asisinit.hlp new file mode 100644 index 00000000..1ec9bc4e --- /dev/null +++ b/math/iminterp/doc/asisinit.hlp @@ -0,0 +1,60 @@ +.help asisinit Dec98 "Image Interpolator Package" +.ih +NAME +asisinit -- initialize the sequential interpolant descriptor using user parameters +.ih +SYNOPSIS +include + +asisinit (asi, interp_type, nsinc, nincr, rparam, badval) + +.nf + pointer asi #O interpolant descriptor + int interp_type #I interpolant type + int nsinc #I sinc interpolant width in pixels + int nincr #I sinc look-up table resolution + real pixfrac #I sinc shift or drizzle pixel fraction + real badval #I drizzle undefined pixel value +.fi + +.ih +ARGUMENTS +.ls asi +Pointer to sequential interpolant descriptor. +.le +.ls interp_type +Interpolant type. The options are II_NEAREST, II_LINEAR, II_POLY3, II_POLY5, +II_SPLINE3, II_SINC, II_LSINC, and II_DRIZZLE for the nearest neighbour, linear, +3rd order polynomial, 5th order polynomial, cubic spline, sinc, look-up +table sinc, and drizzle interpolants respectively. The interpolant type +definitions are found in the package header file math/iminterp.h. +.le +.ls nsinc +The sinc and look-up table sinc interpolant width in pixels. Nsinc is +rounded up internally to the nearest odd number. +.le +.ls nincr +The look-up table sinc resolution in number of entries. Nincr = 10 implies +a pixel resolution of 0.1 pixels, nincr = 20 a pixel resolution of 0.05 +pixels, etc. +.le +.ls pixfrac +The look-up table sinc fractional pixel shift if nincr = 1 in which case +-0.5 <= pixfrac <= 0.5 , or the drizzle pixel fraction in which case +0.0 <= pixfrac <= 1.0. A minimum value of 0.001 is imposed on pixfrac. +.le +.ls badval +The undefined pixel value for the drizzle interpolant. Pixels within +the boundaries of the input image which do not overlap the input image +pixels are assigned a value of badval. +.le +.ih +DESCRIPTION +The interpolant descriptor is allocated and initialized. The pointer asi is +returned by ASISINIT. +.ih +NOTES +ASIINIT or ASISINIT must be called before using any other ASI routines. +.ih +SEE ALSO +asisinit, asifree diff --git a/math/iminterp/doc/asitype.hlp b/math/iminterp/doc/asitype.hlp new file mode 100644 index 00000000..d8c78b44 --- /dev/null +++ b/math/iminterp/doc/asitype.hlp @@ -0,0 +1,95 @@ +.help asitype Dec98 "Image Interpolator Package" +.ih +NAME +asitype -- decode an interpolant string +.ih +SYNOPSIS +include + +asitype (interpstr, interp_type, nsinc, nincr, rparam) + +.nf + char interpstr #I the input interpolant string + int interp_type #O interpolant type + int nsinc #O sinc interpolant width in pixels + int nincr #O sinc look-up table resolution + real rparam #O sinc or drizzle pixel fraction +.fi + +.ih +ARGUMENTS +.ls interpstr +The user supplied interpolant string to be decoded. The options are +.ls nearest +Nearest neighbor interpolation. +.le +.ls linear +Linear interpolation +.le +.ls poly3 +Cubic polynomial interpolation. +.le +.ls poly5 +Quintic polynomial interpolation. +.le +.ls spline3 +Cubic spline interpolation. +.le +.ls sinc +Sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 pixels. Users can specify the resolution of the sinc lookup +up table by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 element sinc look-up +table interpolant with a pixel resolution of 0.05 pixels. The default +look-up table size and resolution are 20 and 0.05 pixels respectively. +The fractional pixel shift for a 1 element look-up table sinc may be +specified by replacing the number of lookup-table elements with the fractional +shift, e.g. sinc51[0.5] will precompute a lookup table for a 0.5 pixel shift. +.le +.ls drizzle +Drizzle interpolation. Users can specify the drizzle pixel fraction by +appending the pixel fraction value to the interpolant string in square +brackets, e.g. drizzle[0.5] specifies a pixel fraction of 0.5. +The default pixel fraction is 1.0. +.le +.le +.ls interp_type +The output interpolant type. The options are II_NEAREST, II_LINEAR, II_POLY3, +II_POLY5, II_SPLINE3, II_SINC, II_LSINC, and II_DRIZZLE for the nearest +neighbor, linear, 3rd order polynomial, 5th order polynomial, cubic spline, +sinc, look-up table sinc, and drizzle interpolants respectively. The +interpolant type definitions are found in the package header file +math/iminterp.h. +.le +.ls nsinc +The output sinc and look-up table sinc interpolant width in pixels. The +default value is 31 pixels. +.le +.ls nincr +The output sinc look-up table size. Nincr = 10 implies a pixel resolution +of 0.1 pixels, nincr = 20 a pixel resolution of 0.05 pixels, etc. The +default value of nincr is 20. +.le +.ls rparam +The output look-up table sinc fractional pixel shift if nincr = 1 in which case +-0.5 <= rparam <= 0.5 , or the drizzle pixel fraction in which case +0.0 <= rparam <= 1.0. +.le +.ih +DESCRIPTION +The interpolant string is decoded into values suitable for the ASISINIT +or ASIINIT routines. +.ih +NOTES +.ih +SEE ALSO +asinit, asisinit, asifree diff --git a/math/iminterp/doc/asivector.hlp b/math/iminterp/doc/asivector.hlp new file mode 100644 index 00000000..95bac138 --- /dev/null +++ b/math/iminterp/doc/asivector.hlp @@ -0,0 +1,52 @@ +.help asivector Dec98 "Image Interpolator Package" +.ih +NAME +asivector -- evaluate the interpolant +.ih +SYNOPSIS +asivector (asi, x, y, npix) + +.nf + pointer asi #I interpolator descriptor + real x[npix/2*npix] #I x array, 1 <= x[i] <= npix + real y[npix] #O array of interpolated values + int npix #I number of x values +.fi +.ih +ARGUMENTS +.ls asi +Pointer to the sequential interpolator descriptor structure. +.le +.ls x +Array of npix x values, or array of npix x ranges if the interpolant is +drizzle. +.le +.ls y +Array of interpolated values. +.le +.ls npix +The number of x values. +.le +.ih +DESCRIPTION +The polynomial coefficients are calculated directly from the data points +for the polynomial interpolants, and from the B-spline coefficients for +the cubic spline interpolant. The actual calculation is done by adding and +multiplying terms according to Everett's central difference interpolation +formula. The boundary extension algorithm is projection. + +The sinc interpolant is computed using a range of data points around +the desired position. Look-up table sinc interpolation is computed +using the most appropriate entry in a precomputed look-up table. +The boundary extension algorithm is nearest neighbor. + +The drizzle interpolant is computed by summing the data over the user +supplied X intervals. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility of the +user. ASIINIT or ASISINIT and ASIFIT must be called before calling ASIVECTOR. +.ih +SEE ALSO +asieval, asider, arieval, arider +.endhelp diff --git a/math/iminterp/doc/im1dinterp.spc b/math/iminterp/doc/im1dinterp.spc new file mode 100644 index 00000000..ce5b8680 --- /dev/null +++ b/math/iminterp/doc/im1dinterp.spc @@ -0,0 +1,525 @@ +.help iminterp Jul84 "Math Package" + +.ce +Specifications for the Image Interpolator Package +.ce +Lindsey Davis +.ce +Vesa Junkkarinen +.ce +August 1984 + +.sh +1. Introduction + + One of the most common operations in image processing is +interpolation in a data array. Due to the large amount of data involved, +efficiency is highly important. The advantage of having locally written +interpolators, includes the ability to optimize for uniformly spaced data +and the possibility of adding features that are useful to the final +application. + +.sh +2. Requirements + +.ls (1) +The package shall take as input a one-dimensional array containing image +data. The pixels are assumed to be equally spaced along a line. +The coordinates of a pixel are assumed to be +the same as the subscript of the pixel in the data array. +The coordinate of the first pixel in the array and the spacing between pixels +is assumed to be 1.0. All pixels are assumed to be good. +Checking for INDEF valued and out of bounds pixels is the responsibility of the +user. A routine to remove INDEF valued pixels from a data array shall be +included in the package. +.le +.ls (2) +The package is divided into array sequential interpolators and array +random interpolators. The sequential interpolators have been optimized +for returning many values as is the case when an array is shifted, or +oversampled at many points in order to produce a +smooth plot. +The random interpolators allow the evaluation of a few interpolated +points without the computing time and storage overhead required for +setting up the sequential version. +.le +.ls (3) +The quality of the interpolant will be set at run time. The options are: + +.nf + II_NEAREST - nearest neighbour + II_LINEAR - linear interpolation + II_POLY3 - 3rd order divided differences + II_POLY5 - 5th order divided differences + II_SPLINE3 - cubic spline +.fi + +The calling sequences shall be invariant to the interpolant selected. +Routines should be designed so that new interpolants can be added +with minimal changes to the code and no change to the calling sequences. +.le +.ls (4) +The interpolant parameters and the arrays necessary to store the coefficients +are stored in a structure referenced by a pointer. The pointer is returned +to the user program by the initial call to ASIINIT or ASIRESTORE and freed +by a call to ASIFREE (see section 3.1). +.le +.ls (5) +The package routines shall be able to: +.ls o +Calculate the coefficients of the interpolant and store these coefficients in +the appropriate part of the interpolant descriptor structure. +.le +.ls o +Evaluate the interplant at a given x(s) coordinate(s). +.le +.ls o +Calculate the derivatives of the interpolant at a given value of x. +.le +.ls o +Integrate the interpolant over a specified x interval. +.le +.ls o +Store the interpolant in a user supplied array. Restore the saved interpolant +to the interpolant descriptor structure for later use by ASIEVAL, ASIVECTOR, +ASIDER and ASIGRL. +.le + +.sh +3. Specifications + +.sh +3.1. The Array Sequential Interpolator Routines + + The package prefix is asi and the package routines are: + +.nf + asiinit (asi, interp_type) + asifit (asi, datain, npix) + y = asieval (asi, x) + asivector (asi, x, yfit, npix) + asider (asi, x, der, nder) + v = asigrl (asi, a, b) + asisave (asi, interpolant) + asirestore (asi, interpolant) + asifree (asi) +.fi + +.sh +3.2. The Array Random Interpolator Routines + + The package prefix is ari and the package routines are: + +.nf + y = arieval (x, datain, npix, interp_type) + arider (x, datain, npix, der, nder, interp_type) +.fi + +.sh +3.3. Miscellaneous + + A routine has been included in the package to remove INDEF valued +pixels from an array. + +.nf + arbpix (datain, dataout, npix, interp_type, boundary_type) +.fi + +.sh +3.4. Algorithms + +.sh +3.4.1. Coefficients + + The coefficient array used by the asi routines is calculated by ASIFIT. +ASIFIT accepts an array of data, checks that the number +of data points is appropriate for the interpolant selected, allocates +space for the interpolant, and calculates the coefficients. +Boundary coefficient values are calculated +using boundary projection. With the exception of the cubic spline interpolant, +the coefficients are stored as the data points. +The B-spline coefficients are +calculated using natural end conditions (Prenter 1975). +After a call to ASIFIT the coefficient array contains the following. + +.nf + case II_NEAREST: + + # no boundary conditions necessary + coeff[1] = datain[1] + . + . + . + coeff[npts] = datain[npix] + + case II_LINEAR: + + # coeff[npxix+1] required if x = npix + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + + case II_POLY3: + + # coeff[0] required if x = 1 + # coeff[npix+1], coeff[npix+2] required if x = npix + coeff[0] = 2. * datain[1] - datain[2] + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + coeff[npix+2] = 2. * datain[npix] - datain[npix-2] + + case II_POLY5: + + # coeff[1], coeff[0] reqired if x = 1 + # coeff[npix+1], coeff[npix+2], coeff[npix=3] + # required if x = npix + + coeff[-1] = 2. * datain[1] - datain[3] + coeff[0] = 2. * datain[1] - datain[2] + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + coeff[npix+2] = 2. * datain[npix] - datain[npix-2] + coeff[npix+3] = 2. * datain[npix] - datain[npix-3] + + case SPLINE3: + + # coeff[0] = 2nd der at x = 1, coeff[0] = 0. + # coeff[npix+1] = 2nd der at x = npts, coeff[npix+1] = 0. + # coeff[npix+2] = 0., required if x = npix + coeff[0] = b[1] + coeff[1] = b[2] + . + . + . + coeff[npix] = b[npix+1] + coeff[npix+1] = b[npix+2] + coeff[npix+2] = 0. +.fi + +.sh +3.4.2. Evaluation + + The ASIEVAL and ASIVECTOR routines have been optimized to be as efficient +as possible. The values of the II_NEAREST and II_LINEAR interpolants +are calculated directly. The II_SPLINE3 interpolant is evaluated using +polynomial coefficients calculated directly from the B-spline coefficients +(de Boor 1978). Values of the higher order polynomial interpolants +are calculated using central differences. The equations for each case are +listed below. + +.nf +case II_NEAREST: + + y = coeff[int (x + 0.5)] + +case II_LINEAR: + + nx = x + y = (x - nx) * coeff[nx+1] + (nx + 1 - x) * coeff[nx] + +case II_POLY3: + + nx = x + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (coeff[nx+1] - 2. * coeff[nx] + coeff[nx-1]) + cd21 = 1./6. * (coeff[nx+2] - 2. * coeff[nx+1] + coeff[nx]) + + y = s * (coeff[nx+1] + (s * s - 1.) * cd21) + t * (coeff[nx] + + (t * t - 1.) * cd20) + +case II_POLY5: + + nx = x + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (coeff[nx+1] - 2. * coeff[nx] + coeff[nx-1]) + cd21 = 1./6. * (coeff[nx+2] - 2. * coeff[nx+1] + coeff[nx]) + + # fourth central diffreences + cd40 = 1./120. * (coeff[nx-2] - 4. * coeff[nx-1] + 6. * coeff[nx] - 4. * + coeff[nx+1] + a[nx+2]) + cd41 = 1./120. * (coeff[nx-1] - 4. * coeff[nx] + 6. * coeff[nx+1] - 4. * + coeff[nx+2] + coeff[nx+3] + + y = s * (coeff[nx+1] + (s * s - 1.) * (cd21 + (s * s - 4.) * cd41)) + + t * (coeff[nx] + (t * t - 1.) * (cd20 + (t * t - 4.) * cd40)) + +case II_SPLINE3: + + nx = x + s = x - nx + + pc[1] = coeff[nx-1] + 4. * coeff[nx] + coeff[nx+1] + pc[2] = 3. * (coeff[nx+1] - coeff[nx-1]) + pc[3] = 3. * (coeff[nx-1] - 2. * coeff[nx] + coeff[nx+1]) + pc[4] = -coeff[nx-1] + 3. * coeff[nx] - 3. * coeff[nx+1] + coeff[nx+2] + + y = pc[1] + s * (pc[2] + s * (pc[3] + s * pc[4])) +.fi + + + The ARIEVAL routine uses the expressions above to evaluate the +interpolant. However unlike ASIEVAL, ARIEVAL does not use a previously +calculated coefficient array. Instead ARIEVAL selects the appropriate +portion of the data array, calculates the coefficients and boundary +coefficients if necessary, and evaluates the interpolant at the time it +is called. The cubic spline interpolant uses at most SPLTS (currently 16) +data points to calculate the B-spline coefficients. + +.sh +3.4.3. Derivatives + + Derivatives of the interpolant are calculated by evaluating the +derivatives of the interpolating polynomial. For all interpolants der[1] +equals the value of the interpolant at x. +For the sake of efficiency the derivatives +of the II_NEAREST and II_LINEAR interpolants are calculated directly. + +.nf + case II_NEAREST: + + der[1] = coeff[int (x+0.5)] + + case II_LINEAR: + + der[1] = (x - nx) * coeff [nx+1] + (nx + 1 - x) * coeff[nx] + der[2] = coeff[nx+1] - coeff[nx] +.fi + + In order to calculate the derivatives of the cubic spline and +polynomial interpolants +the coefficients of the interpolating polynomial must be calculated. +The polynomial +coefficients for the cubic spline interpolant are computed directly from the +B-spline coefficients (see 3.4.2.). The higher order polynomial +interpolant coefficients are calculated as follows. + +First the appropriate portion of the coefficient array is loaded. + +.nf + do i = 1, nterms + d[i] = coeff[nx - nterms/2 + i] +.fi + +Next the divided differences are calculated (Conte and de Boor 1972). + +.nf + do k = 1, nterms - 1 + do i = 1, nterms - k + d[i] = (d[i+1] - d[i]) / k +.fi + +The d[i] are the coefficients of an interpolating polynomial of the +following form. The x[i] are the nterms data points surrounding the +point of interest. + +.nf + p(x) = d[1] * (x-x[1]) * ... * (x-x[nterms-1) + + d[2] * (x-x[2]) * ... * (x-x[nterms-1]) + ... + d[nterms] +.fi + +Next a new set of polynomial coefficients are calculated +(Conte and de Boor 1972). + +.nf + do k = nterms, 2, -1 + do i = 2, k + d[i] = d[i] + d[i-1] * (k - i - nterms/2) +.fi + +The new d[i] are the coefficients of the follwoing polynomial. + +.nf + nx = x + p(x) = d[1] * (x-nx) ** (nterms-1) + d[2] * (x-nx) ** (nterms-2) + ... + d[nterms] +.fi + +The d[i] array is flipped. The value and derivatives +of the interpolant are then calculated using the d[i] array and +nested multiplication. + +.nf + s = x - nx + + do k = 1, nder { + + accum = d[nterms-k+1] + + do j = nterms - k, 1, -1 + accum = d[j] + s * accum + + der[k] = accum + + # differnetiate + do j = 1, nterms - k + d[j] = j * d[j + 1] + } +.fi + + ARIDER calculates the derivatives of the interpolant using the same +technique ASIDER. However ARIDER does not use a previously calculated +coefficient array like ASIDER. Instead ARIDER selects the appropriate portion +of the data array, calculates the coefficients and boundary coefficients, +and computes the derivatives at the time it is called. + +.sh +3.4.5. Integration + + ASIGRL calculates the integral of the interpolant between fixed limits +by integrating the interpolating polynomial. The coefficients of the +interpolating polynomial are calculated as discussed in section 3.4.4. + +.sh +4. Usage + +.sh +4.1. User Notes + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Insert an include statement in the calling program to make +the IINTERP definitions available to the user program. +.le +.ls (2) +Remove INDEF valued pixels from the data using ARBPIX. +.le +.ls (3) +Call ASIINIT to initialize the interpolant parameters. +.le +.ls (4) +Call ASIFIT to calculate the coefficients of the interpolant. +.le +.ls (5) +Evaluate the interpolant at a given value of x(s) using ASIEVAL or +ASIVECTOR. +.le +.ls (6) +Calculate the derivatives and integral or the interpolant using +ASIDER and ASIGRL. +.le +.ls (7) +Free the interpolator structure by calling ASIFREE. +.le +.le + + The interpolant can be saved and restored using ASISAVE and ASIRESTORE. +If the values and derivatives of only a few points in an array are desired +ARIEVAL and ARIDER can be called. + +.sh +4.2. Examples + +.nf +Example 1: Shift a data array by a constant amount + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, inrow, npix) + + do i = 1, npix + outrow[i] = asieval (asi, i + shift) + + call asifree (asi) + ... + +Example 2: Calculate the integral under the data array + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, datain, npix) + + integral = asigrl (asi, 1. real (npix)) + + call asifree (asi) + ... + +Example 2: Store interpolant for later use by ASIEVAL + LEN_INTERP must be at least npix + 8 units long where npix is + is defined in the call to ASIFIT. + + include + + real interpolant[LEN_INTERP] + ... + call asiinit (asi, II_POLY3) + call asifit (asi, datain, npix) + call asisave (asi, interpolant) + call asifree (asi) + ... + call asirestore (asi, interpolant) + do i = 1, npts + yfit[i] = asieval (asi, x[i]) + call asifree (asi) + ... +.fi +.sh +5. Detailed Design + +.sh +5.1. Interpolator Descriptor + + The interpolant parameters and coefficients are stored in a +structure listed below. + +.nf + define LEN_ASISTRUCT 4 # Length in structure units of + # interpolant descriptor + + define ASI_TYPE Memi[$1] # Interpolant type + define ASI_NCOEFF Memi[$1+1] # No. of coefficients + define ASI_OFFSET Memi[$1+2] # First "data" point in + # coefficient array + define ASI_COEFF Memi[$1+3] # Pointer to coefficient array +.fi + +.sh +5.2. Storage Requirements + + The interpolant descriptor requires LEN_ASISTRUCT storage units. The +coefficient array requires ASI_NCOEFF(asi) real storage elements, where +ASI_NCOEFF(asi) is defined as follows. + +.nf + ASI_NCOEFF(asi) = npix # II_NEAREST + ASI_NCOEFF(asi) = npix+1 # II_LINEAR + ASI_NCOEFF(asi) = npix+3 # II_POLY3 + ASI_NCOEFF(asi) = npix+5 # II_POLY5 + ASI_NCOEFF(asi) = npix+3 # II_SPLINE3 +.fi + +.sh +6. References + +.ls (1) +Carl de Boor, "A Practical Guide to Splines", 1978, Springer-Verlag New +York Inc. +.le +.ls (2) +S.D. Conte and C. de Boor, "Elementary Numerical Analysis", 1972, McGraw-Hill, +Inc. +.le +.ls (3) +P.M. Prenter, "Splines and Variational Methods", 1975, John Wiley and Sons Inc. +.le +.endhelp diff --git a/math/iminterp/doc/im2dinterp.spc b/math/iminterp/doc/im2dinterp.spc new file mode 100644 index 00000000..e4d88be3 --- /dev/null +++ b/math/iminterp/doc/im2dinterp.spc @@ -0,0 +1,432 @@ +.help iinterp Dec84 "Math Package" +.ce +Specifications for the 2D-Image Interpolator Package +.ce +Lindsey Davis +.ce +December 1984 + +.sh +1. Introduction + +One of the most common operations required in image processing is +two-dimensional interpolation in a data array. Any image operator which +physically moves pixels around requires image interpolation to calculate +the new gray levels of the pixels. The advantage +of having a locally written image interpolation package includes the ability to +optimize for uniformly spaced data and the possibility of adding features +that are useful to the final application. + +.sh +2. Requirements + +.ls (1) +The package shall take as input a 2-D array containing an image or image +section. The pixels are assumed to be equally spaced on a rectangular grid. +The coordinates of the pixels +are assumed to be the same as the subscripts of the pixel in the data array. +Therefore the coordinates of the first pixel in the array are assumed +to be (1,1). For operations on image sections the calling program must +keep track of any transformations between image and section coordinates. +All pixels are assumed to be good. +Checking for INDEF and out of bounds pixels is +the responsibility of the user. A routine to remove INDEF valued pixels +ARBPIX is available in the 1-D package. +.le +.ls (2) +The package is divided into array sequential interpolants and array random +interpolants. The sequential interpolants have been optimized for returning +many values as when an array is shifted or when an array is oversampled +at many points in order to produce a smooth surface plot. +The random interpolants +allow the evaluation of a few interpolated points without the computing +time and storage overhead required for setting up the sequential version. +.le +.ls (3) +The quality of the interpolant will be set at run time. The options are: + +.nf + II_BINEAREST # nearest neighbour + II_BILINEAR # bilinear + II_BIPOLY3 # bicubic interior polynomial + II_BIPOLY5 # biquintic interior polynomial + II_BISPLINE3 # bicubic spline +.fi + +The calling sequences shall be invariant to the interpolant selected. +Routines should be designed so that new interpolants can be added with +minimal changes to the code and no changes to the calling sequences. +.le +.ls (4) +The interpolant parameters and the arrays necessary to store the +coefficients are stored in a structure referenced by a pointer. The pointer +is returned to the user program by the initial call to MSIINIT or +MSIRESTORE and freed by a call to MSIFREE. +.le +.ls (5) +The package routines should be able to: +.ls o +Calculate the coefficients of the interpolant and store these coefficients +in the appropriate part of the interpolant descriptor structure. +.le +.ls o +Evaluate the interpolant at a given x-y(s) coordinate. +.le +.ls o +Evaluate the first nder derivatives at a given value of x-y. +.le +.ls o +Integrate the interpolant over a specified interval in x-y. +.le + +.sh +3. Specifications + +.sh +3.1. The Matrix Sequential Interpolator Routines + +The package prefix is msi and the package routines are: + +.nf + msiinit (msi, interp_type) + msifit (msi, datain, nxpix, nypix, len_datain) + y = msieval (msi, x, y) + msivector (msi, x, y, zfit, npix) + msigrid (msi, x, y, zfit, nx, ny, len_zfit) + msider (msi, x, y, der, nxder, nyder, len_der) + v = msigrl (msi, x, y, npts) + v = msisqgrl (msi, x1, x2, y1, y2) + msisave (msi, interpolant) + msirestore (msi, interpolant) + msifree (msi) +.fi + +.sh +3.2. The Matrix Random Interpolator Routines + +The package prefix is mri and the package routines are: + +.nf + y = mrieval (x, y, datain, nx, ny, len_datain, interp_type) + mrider (x, y, datain, nx, ny, len_datain, der, nxder, nyder, + len_der, interp_type) +.fi + +.sh +3.3. Miscellaneous + +A routine ARBPIX will remove INDEF valued pixels from an +array and is available in the 1-D package. + +.nf + arbpix (datain, dataout, npix, interp_type, boundary_type) +.fi + +.sh +3.4. Algorithms + +.sh +3.4.1. Coefficients + +The coefficients for the msi routines are calculated by MSIFIT. MSIFIT +accepts the input data, checks that the number of data pixels is +appropriate for the interpolant selected, and allocates space for the +interpolant. Boundary coefficient values are calculated using boundary +projection. With the exception of the II_BISPLINE3 option, the interpolant +is stored as the data points. The B-spline coefficients are calculated +using the "natural" end conditions in two steps. +First the B-spline coefficients in x at each value of y are calculated. +The B-x coefficients are then solved for the B-spline coefficients in x-y. +After a call to MSIFIT the coefficient +array contains the following. + +.nf + CASE II_BINEAREST: + + # no boundary extension required, coeff[1:nx,1:ny] + + coeff[i,j] = data[i,j] i = 1,...,nx + j = 1,...,ny + + case II_BILINEAR: + + # must extend nx by 1 and ny by 1, coeff[1:nx+1,1:ny+1] + + coeff[i,j] = data[i,j] i = 1,...,nx + j = 1,...,ny + + coeff[nx+1,j] = 2 * data[nx] - data[nx-1] j = 1,...,ny + coeff[i,ny+1] = 2 * data[ny] - data[ny-1] i = 1,...,nx + + coeff[nx+1,ny+1] = 2 * coeff[nx+1,ny] - data[nx,ny] + + case II_BIPOLY3: + + # must extend nx by -1 and 2 and ny by -1 and 2, coeff[0:nx+2,0:ny+2] + + coeff[i,j] = data[i,j] i = 1,...,nx + j = 1,...,ny + + coeff[0,j] = 2 * data[1,j] - data[2,j] j = 1,...,ny + coeff[nx+1,j] = 2 * data[nx,j] - data[nx-1,j] j = 1,...,ny + coeff[nx+2,j] = 2 * data[nx,j] - data[nx-2,j] j = 1,...,ny + + coeff[i,0] = 2 * data[i,1] - data[i,2] i = 1,...,ny + coeff[i,ny+1] = 2 * data[i,ny] - data[i,ny-1] i = 1,...,nx + coeff[i,ny+2] = 2 * data[i,ny] - data[i,ny-2] i = 1,...,nx + + # plus remaining points + + case II_BIPOLY5: + + # extend -2 and 3 in nx and -2 and 3 in ny, coeff[-1:nx+3,-1:ny+3] + + coeff[i,j] = data[i,j] i = 1,...,nx + j = 1,...,ny + + coeff[-1,j] = 2 * data[1,j] - data[3,j] j = 1,...,ny + coeff[0,j] = 2 * data[1,j] - data[2,j] j = 1,...,ny + coeff[nx+1,j] = 2 * data[nx,j] - data[nx-1,j] j = 1,...,ny + coeff[nx+2,j] = 2 * data[nx,j] - data[nx-2,j] j = 1,...,ny + coeff[nx+3,j] = 2 * data[nx,j] - data[nx-3,j] j = 1,...,ny + + coeff[i,-1] = 2 * data[i,1] - data[i,3] i = 1,...,nx + coeff[i,0] = 2 * data[i,1] - data[i,2] i = 1,...,nx + coeff[i,ny+1] = 2 * data[i,ny] - data[i,ny-1] i = 1,...,nx + coeff[i,ny+2] = 2 * data[i,ny] - data[i,ny-2] i = 1,...,nx + coeff[i,ny+3] = 2 * data[i,ny] - data[i,ny-3] i = 1,...,nx + + # plus remaining conditions + + case II_BISPLINE3: + + # the natural boundary conditions are used, coeff[0:nx+2,0:ny+2] + + coeff[i,j] = data[i,j] i = 1,...,nx + j = 1,...,ny + + coeff[i,0] = 0. i = 0,...,nx+2 + coeff[i,ny+1] = 0. i = 0,...,nx+2 + coeff[i,ny+2] = 0. i = 0,...,nx+2 + + coeff[0,j] = 0. j = 1,...,ny + coeff[nx+1,j] = 0. j = 1,...,ny + coeff[nx+2,j] = 0. j = 1,...,ny + + # plus remaining coefficients + +.fi + +.sh +3.4.2. Evaluation + +The MSIEVAL and MSIVECTOR routines will be optimized to be as efficient +as possible for evaluating arbitrarily spaced data. A special function +MSIGRID is included for evaluating closely spaced points on a rectangular grid. +For the options II_BINEAREST and II_BILINEAR the value of the +interpolant is calculated directly. The II_BISPLINE3 interpolant is +evaluated using polynomial coefficients calculated directly from the +B-spline coefficients. Values of the higher order polynomial interpolants +are calculated using Everett's central difference formula. The equations +are listed below. + +.nf +case II_BINEAREST: + + z = coeff[int (x + 0.5), int (y + 0.5)) + +case II_BILINEAR: + + sx = x - nx sy = y - ny + tx = 1. - sx ty = 1. - sy + + z = tx * ty * coeff[nx,ny] + sx * ty * coeff[nx+1,ny] + + sy * tx * coeff[nx,ny+1] + sx * sy * coeff[nx+1,ny+1] + + +case II_BIPOLY3: + + nx = x + sx = x - nx + tx = 1. - sx + + # interpolate in x + + i = 1 + + do j = ny-1, ny+2 { + + cd20[i] = 1./6. * (coeff[nx+1,j] - 2. * coeff[nx,j] + coeff[nx-1,j]) + cd21[i] = 1./6. * (coeff[nx+2,j] - 2. * coeff[nx+1,j] + coeff[nx,j]) + + z[i] = sx * (coeff[nx+1,j] + (sx * sx - 1.) * cd21[i]) + + tx * (coeff[nx,j] + (tx * tx - 1.) * cd20[i]) + + i = i + 1 + } + + ny = y + sy = y - ny + ty = 1. - sy + + # interpolate in y + + cd20y = 1./6. * (z[3] - 2. * z[2] + z[1]) + cd21y = 1./6. * (z[4] - 2. * z[3] + z[2]) + + value = sy * (z[3] + (sy * sy - 1.) * cd21y) + + ty * (z[2] + (ty * ty - 1.) *cd20y) + + +case II_BIPOLY5: + + nx = x + sx = x - nx + sx2 = sx * sx + tx = 1. - sx + tx2 = tx * tx + + # interpolate in x + + i = 1 + + do j = ny-2, ny+3 { + + cd20[i] = 1./6. * (coeff[nx+1,j] - 2. * coeff[nx,j] + coeff[nx-1,j]) + cd21[i] = 1./6. * (coeff[nx+2,j] - 2. * coeff[nx+1,j] + coeff[nx,j]) + cd40[i] = 1./120. * (coeff[nx-2,j] - 4. * coeff[nx-1,j] + + 6. * coeff[nx,j] - 4. * coeff[nx+1,j] + coeff[nx+2,j]) + cd41[i] = 1./120. * (coeff[nx-1,j] - 4. * coeff[nx,j] + + 6. * coeff[nx+1,j] - 4. * coeff[nx+2,j] + coeff[nx+3,j]) + + z[i] = sx * (coeff[nx+1,j] + (sx2 - 1.) * (cd21[j] + (sx2 - 4.) * + cd41[j])) + tx * (coeff[nx,j] + (tx2 - 1.) * + (cd20[j] + (tx2 - 4.) * cd40[j])) + + i = i + 1 + } + + ny = y + sy = y - ny + sy2 = sy * sy + ty = 1. - sy + ty2 = ty * ty + + # interpolate in y + + cd20y = 1./6. * (z[3] - 2. * z[2] + z[1]) + cd21y = 1./6. * (z[4] - 2. * z[3] + z[2]) + cd40y = 1./120. * (z[1] - 4. * z[2] + 6. * z[3] - 4. * z[4] + z[5]) + cd41y = 1./120. * (z[2] - 4. * z[3] + 6. * z[4] - 4. * z[5] + z[6]) + + value = sy * (z[4] + (sy2 - 1.) * (cd21y + (sy2 - 4.) * cd41y)) + + ty * (z[3] + (ty2 - 1.) * (cd20y + (ty2 - 4.) * cd40y)) + +case II_BISPLINE3: + + # use the B-spline representation + + value = coeff[i,j] * B[i](x) * B[j](y) + + # the B-splines are the following + + B1(x) = (x - x1) ** 3 + B2(x) = 1 + 3 * (x - x2) + 3 * (x - x2) ** 2 - 3 * (x - x2) ** 3 + B3(x) = 1 + 3 * (x3 - x) + 3 * (x3 - x) ** 2 - 3 * (x3 - x) ** 3 + B4(x) = (x4 - x) ** 3 + + # the y B-splines are identical + +.fi + +.sh +3.4.3. Derivatives + +The derivatives are calculated by evaluating the derivatives of the +interpolating polynomial. The 0-th derivative is the value of the +interpolant. The 1-st derivatives are d/dx and d/dy. The second are +d2/dx2, d2/dy2 and d2/dxdy. The derivatives in the case II_BINEAREST +and II_BILINEAR are calculated directly. + +.nf +case II_BINEAREST: + + der[1,1] = value # see previous section + +case II_BILINEAR: + + der[1] = value # see previous section + + # d/dx + der[2,1] = -ty * coeff[nx,ny] + ty * coeff[nx+1,ny] - + sy * coeff[nx,ny+1] + sy * coeff[nx+1,ny+1] + + # d/dy + der[1,2] = -tx * coeff[nx,ny] + sx * coeff[nx+1,ny] + + tx * coeff[nx,ny+1] + sx * coeff[nx+1,ny+1] + + # d2/dxdy + der[2,2] = coeff[nx,ny] - coeff[nx+1,ny] - coeff[nx,ny+1] + coeff[nx+1,ny+1] + +case II_BIPOLY3, II_BIPOLY5, II_BISPLINE3: +.fi + +For the higher order interpolants the coefficients of the interpolating +polynomial in x and y are calculated. In the case of II_BIPOLY3 and II_BIPOLY5 +this is the Everett polynomial of the 3-rd and 5-th order respectively. +In the case of II_BISPLINE3 the pp-representation is calculated for +the B-spline coefficients. The value of the interpolant and its +derivatives is calculated using nested multiplication. + +.sh +3.4.5. Integration + +Integration is most easily accomplished by integrating the interpolant in +x for each value of y. The resulting function of y can then be integrated +in y to derive the 2-D integral. The limits of the integral are assumed +to be the corners of a polygon. At minimum of three points which define +a triangular region in x-y are required. The integral will be an approximation. +A special function for integrating over a rectangular region is also +provided. + +.sh +4. Detailed Design + +.sh +4.1. Interpolant Descriptor + +The interpolant parameters and coefficients will be stored in a structure +as listed below. + +.nf + define LEN_MSISTRUCT 10 + + struct { + + int msi_type # interpolant type + int msi_nxcoeff # size of coefficient array in x + int msi_nycoeff # size of coefficient array in y + int msi_fstpnt # first datapoint in coefficient array + int asi_coeff # pointer to 1-D coefficient array + + } msistruct + +.fi + +.sh +4.2. Storage Requirements + +The interpolant descriptor requires LEN_MSISTRUCT storage units. +The coefficient array storage is dynamically allocated and requires +msi_nxcoeff * msi_nycoeff real storage elements. The requirements for +each interpolant type are listed below. + +.nf + II_BINEAREST nxpix * nypix + II_BILINEAR (nxpix + 1) * (nypix + 1) + II_BIPOLY3 (nxpix + 3) * (nypix + 3) + II_BIPOLY5 (nxpix + 5) * (nypix + 5) + II_BISPLINE3 (nxpix + 3) * (nypix + 3) +.fi + +.endhelp diff --git a/math/iminterp/doc/iminterp.hd b/math/iminterp/doc/iminterp.hd new file mode 100644 index 00000000..de836c3e --- /dev/null +++ b/math/iminterp/doc/iminterp.hd @@ -0,0 +1,37 @@ +# Help directory for the IMINTERP (image interpolator) package. + +$iminterp = "math$iminterp/" + +arbpix hlp = arbpix.hlp, src = iminterp$arbpix.x +arider hlp = arider.hlp, src = iminterp$arider.x +arieval hlp = arieval.hlp, src = iminterp$arieval.x +asider hlp = asider.hlp, src = iminterp$asider.x +asieval hlp = asieval.hlp, src = iminterp$asieval.x +asifit hlp = asifit.hlp, src = iminterp$asifit.x +asifree hlp = asifree.hlp, src = iminterp$asifree.x +asigeti hlp = asigeti.hlp, src = iminterp$asigeti.x +asigetr hlp = asigetr.hlp, src = iminterp$asigetr.x +asigrl hlp = asigrl.hlp, src = iminterp$asigrl.x +asiinit hlp = asiinit.hlp, src = iminterp$asiinit.x +asirestore hlp = asirestore.hlp, src = iminterp$asirestore.x +asisave hlp = asisave.hlp, src = iminterp$asisave.x +asisinit hlp = asisinit.hlp, src = iminterp$asisinit.x +asivector hlp = asivector.hlp, src = iminterp$asivector.x +asitype hlp = asitype.hlp, src = iminterp$asitype.x + +mrider hlp = mrider.hlp, src = iminterp$mrider.x +mrieval hlp = mrieval.hlp, src = iminterp$mrieval.x +msider hlp = msider.hlp, src = iminterp$msider.x +msieval hlp = msieval.hlp, src = iminterp$msieval.x +msifit hlp = msifit.hlp, src = iminterp$msifit.x +msifree hlp = msifree.hlp, src = iminterp$msifree.x +msigeti hlp = msigeti.hlp, src = iminterp$msigeti.x +msigetr hlp = msigetr.hlp, src = iminterp$msigetr.x +msigrid hlp = msigrid.hlp, src = iminterp$msigrid.x +msigrl hlp = msigrl.hlp, src = iminterp$msigrl.x +msiinit hlp = msiinit.hlp, src = iminterp$msiinit.x +msirestore hlp = msirestore.hlp, src = iminterp$msirestore.x +msisave hlp = msisave.hlp, src = iminterp$msisave.x +msisinit hlp = msisinit.hlp, src = iminterp$msisinit.x +msitype hlp = msitype.hlp, src = iminterp$msitype.x +msivector hlp = msivector.hlp, src = iminterp$msivector.x diff --git a/math/iminterp/doc/iminterp.hlp b/math/iminterp/doc/iminterp.hlp new file mode 100644 index 00000000..c602b43e --- /dev/null +++ b/math/iminterp/doc/iminterp.hlp @@ -0,0 +1,234 @@ +.help iminterp Dec98 "Math Package" +.ih +NAME +iminterp -- image interpolator package +.ih +SYNOPSIS + +.nf + asitype (interpstr, interp_type, nsinc, nincr, rparam) + asiinit (asi, interp_type) + asisinit (asi, interp_type, nsinc, nincr, rparam) + asifit (asi, datain, npix) +ivalue = asigeti (asi, param) +rvalue = asigetr (asi, param) + y = asieval (asi, x) + asivector (asi, x, yfit, npix) + asider (asi, x, der, nder) + v = asigrl (asi, a, b) + asisave (asi, interpolant) + asirestore (asi, interpolant) + asifree (asi) + + y = arieval (x, datain, npix, interp_type) + arider (x, datain, npix, der, nder, interp_type) + + arbpix (datain, dataout, npix, interp_type, boundary_type) +.fi + +.nf + msitype (interpstr, interp_type, nsinc, nincr, rparam) + msisinit (msi, interp_type, nsinc, nxincr, nyincr, rparam1, rparam2) + msiinit (msi, interp_type) + msifit (msi, datain, nxpix, nypix, len_datain) +ivalue = msigeti (msi, param) +rvalue = msigetr (msi, param) + y = msieval (msi, x, y) + msivector (msi, x, y, zfit, npts) + msider (msi, x, y, der, nxder, nyder, len_der) + v = msigrl (msi, x, y, npts) + v = msisqgrl (msi, x1, x2, y1, y2) + msisave (msi, interpolant) + msirestore (msi, interpolant) + msifree (msi) + + y = mrieval (x, y, datain, nxpix, nypix, len_dataina, interp_type) + mrider (x, y, datain, nxpix, nypix, len_datain, der, nxder, nyder, + len_der, interp_type) +.fi + +.ih +DESCRIPTION +The iminterp package provides a set of routines for interpolating uniformly +spaced data assuming that the spacing between data points is 1.0. The +package is divided into 1D and 2D array sequential interpolants, +prefixes asi and msi, and 1D and 2D +array random interpolants, prefixes ari and mri. +The sequential interpolants have +been optimized for returning many values as is the case when an array is +shifted. The random interpolants allow evaluation of a few interpolated +points without the computing time and storage overhead required for +setting up the sequential version. +.ih +NOTES +The interpolant is chosen at run time from the following list. + +.nf + II_NEAREST # nearest neighbour in x + II_LINEAR # linear interpolation in x + II_POLY3 # 3rd order interior polynomial in x + II_POLY5 # fifth order interior polynomial in x + II_SPLINE3 # cubic spline in x + II_SINC # sinc interpolation in x + II_LSINC # look-up table sinc interpolation in x + II_DRIZZLE # drizzle interpolation in x + + II_BINEAREST # nearest neighbour in x and y + II_BILINEAR # bilinear interpolation + II_BIPOLY3 # 3rd order interior polynomial in x and y + II_BIPOLY5 # 5th order interior polynomial in x and y + II_BISPLINE3 # bicubic spline + II_BISINC # sinc interpolation in x and y + II_BILSINC # look-up table sinc interpolation in x and y + II_BIDRIZZLE # drizzle interpolation in x and y +.fi + +The routines assume that all x (1D, 2D) and y (2D) values of interest lie in +the region 1 <= x <= nxpix, 1 <= y <= nypix. +Checking for out of bounds x and/or y values is the responsibility +of the calling program. The asi, ari, msi, and mri routines assume that INDEF +valued pixels have been removed from the data prior to entering the +package. The routine ARBPIX has been added to the package to facilitate +INDEF valued pixel removal. + +In order to make the package definitions available to the calling program +an include statement must appear in the calling program. +Either ASIINIT, ASISINIT or ASIRESTORE must be called before using the +asi routines. ASIFREE frees the space used by the asi routines. For the +msi routines the corresponding examples are MSIINIT, MSISINIT, MSIRESTORE +and MSIFREE. +.ih +EXAMPLES +.nf +Example 1: Shift a 1D data array by a constant amount using a 5th order +polynomial interpolant and the drizzle routine respectively. Note that +in this example the drizzle interpolant is equivalent to the linear +interpolant since the default drizzle pixel fraction is 1.0 and there +is no scale change. Out-of-bounds pixels are set to 0.0 + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, inrow, npix) + + do i = 1, npix + if (i + xshift < 1.0 || i + xshift > npix) + outrow[i] = 0.0 + else + outrow[i] = asieval (asi, i + xshift) + + call asifree (asi) + ... + + + include + + real tmpx[2] + ... + call asiinit (asi, II_DRIZZLE) + call asifit (asi, inrow, npix) + + do i = 1, npix + tmpx[1] = i + xshift - 0.5 + tmpx[2] = i + xshift + 0.5 + if (tmpx[1] < 1 || tmpx[2] > npix) + outrow[i] = 0.0 + else + outrow[i] = asieval (asi, tmpx) + + call asifree (asi) + ... + + +Example 2: Shift a 2D array by a constant amount using a 3rd order polynomial +interpolant and the drizzle interpolant respectively. Note that +in this example the drizzle interpolant is equivalent to the linear +interpolant since the default drizzle pixel fraction is 1.0 and there +is no scale change. Out-of-bounds pixels are set to 0.0. + + include + ... + call msiinit (msi, II_BIPOLY3) + call msifit (msi, insection, nxpix, nypix, nxpix) + + do j = 1, nypix + if (j + yshift < 1 || j + yshift > nypix) + do i = 1, nxpix + outsection[i,j] = 0.0 + else + do i = 1, nxpix + if (i + xshift < 1 || i + xshift > nxpix) + outsection[i,j] = 0.0 + else + outsection[i,j] = msieval (msi, i + xshift, j + yshift) + + call msifree (msi) + ... + + + include + ... + real tmpx[4], tmpy[4] + ... + call msiinit (msi, II_BIDRIZZLE) + call msifit (msi, insection, nxpix, nypix, nxpix) + + do j = 1, nypix { + tmpy[1] = j + yshift - 0.5 + tmpy[2] = j + yshift - 0.5 + tmpy[3] = j + yshift + 0.5 + tmpy[4] = j + yshift + 0.5 + if (tmpy[1] < 1 || tmpy[4] > nypix) + do i = 1, nxpix + outsection[i,j] = 0.0 + else + do i = 1, nxpix + tmpx[1] = i + xshift - 0.5 + tmpx[2] = i + xshift + 0.5 + tmpx[3] = i + xshift + 0.5 + tmpx[4] = i + xshift - 0.5 + if (tmpx[1] < 1 || tmpx[2] > nxpix) + outsection[i,j] = 0.0 + else + outsection[i,j] = msieval (msi, tmpx, tmpy) + } + + call msifree (msi) + ... + + +Example 3: Calculate the integral under a 1D data array + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, datain, npix) + + integral = asigrl (asi, 1. real (npix)) + + call asifree (asi) + ... + +Example 4: Store a 1D interpolant for later use by ASIEVAL + + include + + ... + call asiinit (asi, II_POLY3) + call asifit (asi, datain, npix) + + len_interpolant = asigeti (asi, ASINSAVE) + call salloc (interpolant, len_interpolant, TY_REAL) + call asisave (asi, Memr[interpolant]) + + call asifree (asi) + ... + call asirestore (asi, Memr[interpolant]) + + do i = 1, npts + yfit[i] = asieval (asi, x[i]) + + call asifree (asi) + ... +.fi +.endhelp diff --git a/math/iminterp/doc/iminterp.men b/math/iminterp/doc/iminterp.men new file mode 100644 index 00000000..9daf5883 --- /dev/null +++ b/math/iminterp/doc/iminterp.men @@ -0,0 +1,32 @@ + arbpix - Replace bad pixels in an array + arider - Calculate derivatives for a few points in a 1-D array + arieval - Evaluate the interpolant at a few points in a 1-D array + asider - Evaluate derivatives at x + asieval - Evaluate the interpolant at x + asifit - Fit the 1-D interpolant + asifree - Free space allocated by asiinit or asisinit + asigeti - Fetch an integer parameter + asigrl - Calculate the integral under an array + asiinit - Initialize 1-D interpolant using default parameters + asirestore - Restore interpolant parameters and coefficients + asisave - Save interpolant parameters and coefficients + asisinit - Initialize 1-D interpolant using user parameters + asitype - Decode string into interpolant type and parameters + asivector - Evaluate interpolant at an array of x + + mrider - Calculate derivatives for a few points in a 2-D array + mrieval - Evaluate the interpolant at a few points in a 2-D array + msider - Evaluate derivatives at x and y + msieval - Evaluate the interpolant at x and y + msifit - Fit the 2-D interpolant + msifree - Free space allocated by msiinit or msisinit + msigeti - Fetch an integer parameter + msigetr - Fetch a real parameter + msigrl - Calculate the integral inside a polygon + msiinit - Initialize the 2-D interpolant using default parameters + msirestore - Restore interpolant parameters and coefficients + msisave - Save 2-D interpolant parameters and coefficients + msisinit - Initialize the 2-D interpolant using user parameters + msisqgrl - Calculate the integral inside a rectangle + msitype - Decode string into interpolant type and parameters + msivector - Evaluate interpolant at an array of x and y diff --git a/math/iminterp/doc/iminterp.spc b/math/iminterp/doc/iminterp.spc new file mode 100644 index 00000000..ce5b8680 --- /dev/null +++ b/math/iminterp/doc/iminterp.spc @@ -0,0 +1,525 @@ +.help iminterp Jul84 "Math Package" + +.ce +Specifications for the Image Interpolator Package +.ce +Lindsey Davis +.ce +Vesa Junkkarinen +.ce +August 1984 + +.sh +1. Introduction + + One of the most common operations in image processing is +interpolation in a data array. Due to the large amount of data involved, +efficiency is highly important. The advantage of having locally written +interpolators, includes the ability to optimize for uniformly spaced data +and the possibility of adding features that are useful to the final +application. + +.sh +2. Requirements + +.ls (1) +The package shall take as input a one-dimensional array containing image +data. The pixels are assumed to be equally spaced along a line. +The coordinates of a pixel are assumed to be +the same as the subscript of the pixel in the data array. +The coordinate of the first pixel in the array and the spacing between pixels +is assumed to be 1.0. All pixels are assumed to be good. +Checking for INDEF valued and out of bounds pixels is the responsibility of the +user. A routine to remove INDEF valued pixels from a data array shall be +included in the package. +.le +.ls (2) +The package is divided into array sequential interpolators and array +random interpolators. The sequential interpolators have been optimized +for returning many values as is the case when an array is shifted, or +oversampled at many points in order to produce a +smooth plot. +The random interpolators allow the evaluation of a few interpolated +points without the computing time and storage overhead required for +setting up the sequential version. +.le +.ls (3) +The quality of the interpolant will be set at run time. The options are: + +.nf + II_NEAREST - nearest neighbour + II_LINEAR - linear interpolation + II_POLY3 - 3rd order divided differences + II_POLY5 - 5th order divided differences + II_SPLINE3 - cubic spline +.fi + +The calling sequences shall be invariant to the interpolant selected. +Routines should be designed so that new interpolants can be added +with minimal changes to the code and no change to the calling sequences. +.le +.ls (4) +The interpolant parameters and the arrays necessary to store the coefficients +are stored in a structure referenced by a pointer. The pointer is returned +to the user program by the initial call to ASIINIT or ASIRESTORE and freed +by a call to ASIFREE (see section 3.1). +.le +.ls (5) +The package routines shall be able to: +.ls o +Calculate the coefficients of the interpolant and store these coefficients in +the appropriate part of the interpolant descriptor structure. +.le +.ls o +Evaluate the interplant at a given x(s) coordinate(s). +.le +.ls o +Calculate the derivatives of the interpolant at a given value of x. +.le +.ls o +Integrate the interpolant over a specified x interval. +.le +.ls o +Store the interpolant in a user supplied array. Restore the saved interpolant +to the interpolant descriptor structure for later use by ASIEVAL, ASIVECTOR, +ASIDER and ASIGRL. +.le + +.sh +3. Specifications + +.sh +3.1. The Array Sequential Interpolator Routines + + The package prefix is asi and the package routines are: + +.nf + asiinit (asi, interp_type) + asifit (asi, datain, npix) + y = asieval (asi, x) + asivector (asi, x, yfit, npix) + asider (asi, x, der, nder) + v = asigrl (asi, a, b) + asisave (asi, interpolant) + asirestore (asi, interpolant) + asifree (asi) +.fi + +.sh +3.2. The Array Random Interpolator Routines + + The package prefix is ari and the package routines are: + +.nf + y = arieval (x, datain, npix, interp_type) + arider (x, datain, npix, der, nder, interp_type) +.fi + +.sh +3.3. Miscellaneous + + A routine has been included in the package to remove INDEF valued +pixels from an array. + +.nf + arbpix (datain, dataout, npix, interp_type, boundary_type) +.fi + +.sh +3.4. Algorithms + +.sh +3.4.1. Coefficients + + The coefficient array used by the asi routines is calculated by ASIFIT. +ASIFIT accepts an array of data, checks that the number +of data points is appropriate for the interpolant selected, allocates +space for the interpolant, and calculates the coefficients. +Boundary coefficient values are calculated +using boundary projection. With the exception of the cubic spline interpolant, +the coefficients are stored as the data points. +The B-spline coefficients are +calculated using natural end conditions (Prenter 1975). +After a call to ASIFIT the coefficient array contains the following. + +.nf + case II_NEAREST: + + # no boundary conditions necessary + coeff[1] = datain[1] + . + . + . + coeff[npts] = datain[npix] + + case II_LINEAR: + + # coeff[npxix+1] required if x = npix + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + + case II_POLY3: + + # coeff[0] required if x = 1 + # coeff[npix+1], coeff[npix+2] required if x = npix + coeff[0] = 2. * datain[1] - datain[2] + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + coeff[npix+2] = 2. * datain[npix] - datain[npix-2] + + case II_POLY5: + + # coeff[1], coeff[0] reqired if x = 1 + # coeff[npix+1], coeff[npix+2], coeff[npix=3] + # required if x = npix + + coeff[-1] = 2. * datain[1] - datain[3] + coeff[0] = 2. * datain[1] - datain[2] + coeff[1] = datain[1] + . + . + . + coeff[npix] = datain[npix] + coeff[npix+1] = 2. * datain[npix] - datain[npix-1] + coeff[npix+2] = 2. * datain[npix] - datain[npix-2] + coeff[npix+3] = 2. * datain[npix] - datain[npix-3] + + case SPLINE3: + + # coeff[0] = 2nd der at x = 1, coeff[0] = 0. + # coeff[npix+1] = 2nd der at x = npts, coeff[npix+1] = 0. + # coeff[npix+2] = 0., required if x = npix + coeff[0] = b[1] + coeff[1] = b[2] + . + . + . + coeff[npix] = b[npix+1] + coeff[npix+1] = b[npix+2] + coeff[npix+2] = 0. +.fi + +.sh +3.4.2. Evaluation + + The ASIEVAL and ASIVECTOR routines have been optimized to be as efficient +as possible. The values of the II_NEAREST and II_LINEAR interpolants +are calculated directly. The II_SPLINE3 interpolant is evaluated using +polynomial coefficients calculated directly from the B-spline coefficients +(de Boor 1978). Values of the higher order polynomial interpolants +are calculated using central differences. The equations for each case are +listed below. + +.nf +case II_NEAREST: + + y = coeff[int (x + 0.5)] + +case II_LINEAR: + + nx = x + y = (x - nx) * coeff[nx+1] + (nx + 1 - x) * coeff[nx] + +case II_POLY3: + + nx = x + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (coeff[nx+1] - 2. * coeff[nx] + coeff[nx-1]) + cd21 = 1./6. * (coeff[nx+2] - 2. * coeff[nx+1] + coeff[nx]) + + y = s * (coeff[nx+1] + (s * s - 1.) * cd21) + t * (coeff[nx] + + (t * t - 1.) * cd20) + +case II_POLY5: + + nx = x + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (coeff[nx+1] - 2. * coeff[nx] + coeff[nx-1]) + cd21 = 1./6. * (coeff[nx+2] - 2. * coeff[nx+1] + coeff[nx]) + + # fourth central diffreences + cd40 = 1./120. * (coeff[nx-2] - 4. * coeff[nx-1] + 6. * coeff[nx] - 4. * + coeff[nx+1] + a[nx+2]) + cd41 = 1./120. * (coeff[nx-1] - 4. * coeff[nx] + 6. * coeff[nx+1] - 4. * + coeff[nx+2] + coeff[nx+3] + + y = s * (coeff[nx+1] + (s * s - 1.) * (cd21 + (s * s - 4.) * cd41)) + + t * (coeff[nx] + (t * t - 1.) * (cd20 + (t * t - 4.) * cd40)) + +case II_SPLINE3: + + nx = x + s = x - nx + + pc[1] = coeff[nx-1] + 4. * coeff[nx] + coeff[nx+1] + pc[2] = 3. * (coeff[nx+1] - coeff[nx-1]) + pc[3] = 3. * (coeff[nx-1] - 2. * coeff[nx] + coeff[nx+1]) + pc[4] = -coeff[nx-1] + 3. * coeff[nx] - 3. * coeff[nx+1] + coeff[nx+2] + + y = pc[1] + s * (pc[2] + s * (pc[3] + s * pc[4])) +.fi + + + The ARIEVAL routine uses the expressions above to evaluate the +interpolant. However unlike ASIEVAL, ARIEVAL does not use a previously +calculated coefficient array. Instead ARIEVAL selects the appropriate +portion of the data array, calculates the coefficients and boundary +coefficients if necessary, and evaluates the interpolant at the time it +is called. The cubic spline interpolant uses at most SPLTS (currently 16) +data points to calculate the B-spline coefficients. + +.sh +3.4.3. Derivatives + + Derivatives of the interpolant are calculated by evaluating the +derivatives of the interpolating polynomial. For all interpolants der[1] +equals the value of the interpolant at x. +For the sake of efficiency the derivatives +of the II_NEAREST and II_LINEAR interpolants are calculated directly. + +.nf + case II_NEAREST: + + der[1] = coeff[int (x+0.5)] + + case II_LINEAR: + + der[1] = (x - nx) * coeff [nx+1] + (nx + 1 - x) * coeff[nx] + der[2] = coeff[nx+1] - coeff[nx] +.fi + + In order to calculate the derivatives of the cubic spline and +polynomial interpolants +the coefficients of the interpolating polynomial must be calculated. +The polynomial +coefficients for the cubic spline interpolant are computed directly from the +B-spline coefficients (see 3.4.2.). The higher order polynomial +interpolant coefficients are calculated as follows. + +First the appropriate portion of the coefficient array is loaded. + +.nf + do i = 1, nterms + d[i] = coeff[nx - nterms/2 + i] +.fi + +Next the divided differences are calculated (Conte and de Boor 1972). + +.nf + do k = 1, nterms - 1 + do i = 1, nterms - k + d[i] = (d[i+1] - d[i]) / k +.fi + +The d[i] are the coefficients of an interpolating polynomial of the +following form. The x[i] are the nterms data points surrounding the +point of interest. + +.nf + p(x) = d[1] * (x-x[1]) * ... * (x-x[nterms-1) + + d[2] * (x-x[2]) * ... * (x-x[nterms-1]) + ... + d[nterms] +.fi + +Next a new set of polynomial coefficients are calculated +(Conte and de Boor 1972). + +.nf + do k = nterms, 2, -1 + do i = 2, k + d[i] = d[i] + d[i-1] * (k - i - nterms/2) +.fi + +The new d[i] are the coefficients of the follwoing polynomial. + +.nf + nx = x + p(x) = d[1] * (x-nx) ** (nterms-1) + d[2] * (x-nx) ** (nterms-2) + ... + d[nterms] +.fi + +The d[i] array is flipped. The value and derivatives +of the interpolant are then calculated using the d[i] array and +nested multiplication. + +.nf + s = x - nx + + do k = 1, nder { + + accum = d[nterms-k+1] + + do j = nterms - k, 1, -1 + accum = d[j] + s * accum + + der[k] = accum + + # differnetiate + do j = 1, nterms - k + d[j] = j * d[j + 1] + } +.fi + + ARIDER calculates the derivatives of the interpolant using the same +technique ASIDER. However ARIDER does not use a previously calculated +coefficient array like ASIDER. Instead ARIDER selects the appropriate portion +of the data array, calculates the coefficients and boundary coefficients, +and computes the derivatives at the time it is called. + +.sh +3.4.5. Integration + + ASIGRL calculates the integral of the interpolant between fixed limits +by integrating the interpolating polynomial. The coefficients of the +interpolating polynomial are calculated as discussed in section 3.4.4. + +.sh +4. Usage + +.sh +4.1. User Notes + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Insert an include statement in the calling program to make +the IINTERP definitions available to the user program. +.le +.ls (2) +Remove INDEF valued pixels from the data using ARBPIX. +.le +.ls (3) +Call ASIINIT to initialize the interpolant parameters. +.le +.ls (4) +Call ASIFIT to calculate the coefficients of the interpolant. +.le +.ls (5) +Evaluate the interpolant at a given value of x(s) using ASIEVAL or +ASIVECTOR. +.le +.ls (6) +Calculate the derivatives and integral or the interpolant using +ASIDER and ASIGRL. +.le +.ls (7) +Free the interpolator structure by calling ASIFREE. +.le +.le + + The interpolant can be saved and restored using ASISAVE and ASIRESTORE. +If the values and derivatives of only a few points in an array are desired +ARIEVAL and ARIDER can be called. + +.sh +4.2. Examples + +.nf +Example 1: Shift a data array by a constant amount + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, inrow, npix) + + do i = 1, npix + outrow[i] = asieval (asi, i + shift) + + call asifree (asi) + ... + +Example 2: Calculate the integral under the data array + + include + ... + call asiinit (asi, II_POLY5) + call asifit (asi, datain, npix) + + integral = asigrl (asi, 1. real (npix)) + + call asifree (asi) + ... + +Example 2: Store interpolant for later use by ASIEVAL + LEN_INTERP must be at least npix + 8 units long where npix is + is defined in the call to ASIFIT. + + include + + real interpolant[LEN_INTERP] + ... + call asiinit (asi, II_POLY3) + call asifit (asi, datain, npix) + call asisave (asi, interpolant) + call asifree (asi) + ... + call asirestore (asi, interpolant) + do i = 1, npts + yfit[i] = asieval (asi, x[i]) + call asifree (asi) + ... +.fi +.sh +5. Detailed Design + +.sh +5.1. Interpolator Descriptor + + The interpolant parameters and coefficients are stored in a +structure listed below. + +.nf + define LEN_ASISTRUCT 4 # Length in structure units of + # interpolant descriptor + + define ASI_TYPE Memi[$1] # Interpolant type + define ASI_NCOEFF Memi[$1+1] # No. of coefficients + define ASI_OFFSET Memi[$1+2] # First "data" point in + # coefficient array + define ASI_COEFF Memi[$1+3] # Pointer to coefficient array +.fi + +.sh +5.2. Storage Requirements + + The interpolant descriptor requires LEN_ASISTRUCT storage units. The +coefficient array requires ASI_NCOEFF(asi) real storage elements, where +ASI_NCOEFF(asi) is defined as follows. + +.nf + ASI_NCOEFF(asi) = npix # II_NEAREST + ASI_NCOEFF(asi) = npix+1 # II_LINEAR + ASI_NCOEFF(asi) = npix+3 # II_POLY3 + ASI_NCOEFF(asi) = npix+5 # II_POLY5 + ASI_NCOEFF(asi) = npix+3 # II_SPLINE3 +.fi + +.sh +6. References + +.ls (1) +Carl de Boor, "A Practical Guide to Splines", 1978, Springer-Verlag New +York Inc. +.le +.ls (2) +S.D. Conte and C. de Boor, "Elementary Numerical Analysis", 1972, McGraw-Hill, +Inc. +.le +.ls (3) +P.M. Prenter, "Splines and Variational Methods", 1975, John Wiley and Sons Inc. +.le +.endhelp diff --git a/math/iminterp/doc/mrider.hlp b/math/iminterp/doc/mrider.hlp new file mode 100644 index 00000000..47515c48 --- /dev/null +++ b/math/iminterp/doc/mrider.hlp @@ -0,0 +1,79 @@ +.help mrider Dec98 "Image Interpolation Package" +.ih +NAME +mrider -- calculate the derivatives at x and y +.ih +SYNOPSIS +include + +.nf +mrider (x, y, datain, nxpix, nypix, len_datain, der, nxder, nyder, len_der, + interp_type) +.fi + +.nf +real x[4] #I x value, 1. <= x[1-4] <= nxpix +real y[4] #I y value, 1. <= y[1-4] <= nypix +real datain[len_datain, ARB] #I data array +int nxpix #I number of data pixels in x +int nypix #I number of data pixels in y +int len_datain #I length of datain, len_datain >= nxpix +real der[len_der, ARB] #O derivative array +int nxder #I x order of the derivatives +int nyder #I y order of the derivatives +int len_der #I row length of der, len_der >= nxder +int interp_type #I interpolant type +.fi +.ih +ARGUMENTS +.ls x, y +The single x and y points or in the case of the drizzle interpolant the +single quadrilateral at / over which the derivatives are to be evaluated. +The quadrilateral vertices may be stored in clock-wise or counter-clockwise +order. +.le +.ls datain +Array of data values. +.le +.ls nxpix, nypix +The number of data values in the x and y directions +.le +.ls len_datain +The row length of the datain array. Len_datain must be >= nxpix. +.le +.ls der +The derivative array. Der[1,1] equals the function value at x and y and +der[2,1], der[1,2] are the first derivatives with respect to x and y +respectively. +.le +.ls nxder, nyder +The number of the derivatives in x and y to be returned. MRIDER checks +that the requested number of derivatives is sensible. The sinc interpolants +return the interpolant value and all the first and second order derivatives. +The drizzle interpolant returns the interpolant value and the first +derivative in x and y. +.le +.ls len_der +The row length of the derivative array. Len_der must be >= nxder. +.le +.ls interp_type +Interpolant type. The options are II_BINEAREST, II_BILINEAR, II_BIPOLY3, +II_BIPOLY5, II_BISPLINE3, II_SINC / II_LSINC, and II_DRIZZLE. The look-up +table sinc is not supported and defaults to the sinc interpolant. The +interpolant width is 31 pixels. The drizzle pixel fraction is 1.0. The +interpolant type definitions are found in the package header file +math/iminterp.h. +.le +.ih +DESCRIPTION +MRIDER is useful for evaluating the function and derivatives at a few +widely spaced points in a data array without the storage space required +by the sequential version. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the +responsibility of the user. +.ih +SEE ALSO +msider +.endhelp diff --git a/math/iminterp/doc/mrieval.hlp b/math/iminterp/doc/mrieval.hlp new file mode 100644 index 00000000..35477614 --- /dev/null +++ b/math/iminterp/doc/mrieval.hlp @@ -0,0 +1,57 @@ +.help mrieval Dec98 "Image Interpolation Package" +.ih +NAME +mrieval -- evaluate the interpolant at x and y +.ih +SYNOPSIS +include + +y = mrieval (x, y, datain, nxpix, nypix, len_datain, interp_type) + +.nf + real x[4] #I x value, 1 <= x[1-4] <= nxpix + real y[4] #I y value, 1 <= y[1-4] <= nypix + real datain[len_datain, ARB] #I data array + int nxpix #I number of x values + int nypix #I number of y values + int len_datain #I length datain, len_datain >= nxpix + int interp_type #I interpolant type +.fi +.ih +ARGUMENTS +.ls x, y +The single x and y values or in the case of the drizzle interpolant the +single quadrilateral at / over which the interpolant is to be evaluated. +The vertices of the quadilateral must be defined in clock-wise or +counter-clockwise order. +.le +.ls datain +The array of data values. +.le +.ls nxpix, nypix +The number of data pixels in x and y. +.le +.ls len_datain +The row length of datain. Len_datain must be >= nxpix. +.le +.ls interp_type +Interpolant type. The options are II_BINEAREST, II_BILINEAR, II_BIPOLY3, +II_BIPOLY5, II_BISPLINE3, II_SINC / II_LSINC, and II_DRIZZLE. The look-up +table sinc interpolant is not supported and defaults to the sinc interpolant. +The sinc interpolant width is 31 pixels. The drizzle pixel fraction is 1.0. +The interpolant type definitions are found in the package header file +math/iminterp.h. +.le +.ih +DESCRIPTION +MRIEVAL is useful for evaluating the interpolant at a few selected points +in the datain array without the storage overhead required for the sequential +version. +.ih +NOTES +Checking for INDEF valued or out of bounds pixels is the +responsibility of the user. +.ih +SEE ALSO +msieval, msivector, mrider +.endhelp diff --git a/math/iminterp/doc/msider.hlp b/math/iminterp/doc/msider.hlp new file mode 100644 index 00000000..0139c0a0 --- /dev/null +++ b/math/iminterp/doc/msider.hlp @@ -0,0 +1,52 @@ +.help msider Dec98 "Image Interpolation Package" +.ih +NAME +msider -- evaluate the interpolant derivatives at x and y +.ih +SYNOPSIS +msider (msi, x, y, der, nxder, nyder, len_der) + +.nf + pointer msi #I interpolant descriptor + real x[4] #I x value, 1 <= x[1-4] <= nxpix + real y[4] #I y value, 1 <= y[1-4] <= nypix + real der[len_der, ARB] #O derivative array + int nxder #I number of x derivatives + int nyder #I number of y derivatives + int len_der #I row length of der, len_der >= nxder +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the 2D sequential interpolant descriptor. +.le +.ls x, y +The single x and y values or in the case of the drizzle interpolant the +single quadrilateral at / over which the point is to be evaluated. +.le +.ls der +The array containing the derivatives. Der[1,1] contains the value of +the interpolant at x and y. Der[2,1] and der[1,2] contain the 1st +derivatives of x and y respectively. +.le +.ls nxder, nyder +The number derivatives in x and y. +.le +.ls len_der +The row length of der. Len_der must be >= nxder. +.le +.ih +DESCRIPTION +The polynomial and spline interpolants are evaluated using the polynomial +coefficients and nested multiplication. The polynomial interpolants are +stored as the data points. The spline interpolant is stored as a set of +B-spline coefficients. +.ih +NOTES +MRIDER checks that the number of derivatives requested is reasonable. +Checking for out of bounds and INDEF valued pixels is the responsibility of the +user. MSIINIT and MSIFIT must be called before using MSIDER. +.ih +SEE ALSO +mrider +.endhelp diff --git a/math/iminterp/doc/msieval.hlp b/math/iminterp/doc/msieval.hlp new file mode 100644 index 00000000..9a77c006 --- /dev/null +++ b/math/iminterp/doc/msieval.hlp @@ -0,0 +1,46 @@ +.help msieval Dec98 "Image Interpolation Package" +.ih +NAME +msieval -- procedure to evaluate the interpolant at x and y +.ih +SYNOPSIS +z = msieval (msi, x, y) + +.nf +pointer msi #I interpolant descriptor +real x[4] #I x value, 1 <= x[1-4] <= nxpix +real y[4] #I y value, 1 <= y[1-4] <= nypix +.fi +.ih +ARGUMENTS +.ls msi +The pointer to the sequential interpolant descriptor structure. +.le +.ls x, y +The single x and y values of or in the case of the drizzle interpolant +the single quadrilateral over which the point is to be evaluated. +.le +.ih +DESCRIPTION +The polynomial coefficients are calculated from the data points in the +case of the polynomial interpolants and the B-spline coefficients in +the case of the spline interpolant. The polynomial interpolants +are evaluated using Everett's central difference formula. The boundary +extension algorithm is projection. + +The sinc interpolant is evaluated using an array of data points around +the desired position. The look-up table sinc interpolant is computed +using an a pre-computed look--up table entry. The boundary extension +algorithm is nerest neighbor. + +The drizzle interpolant is computed by computing the mean value of the +data within the user supplied quadrilateral. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility of +the user. MSIINIT or MSISINIT and MSIFIT must be called before calling +MSIEVAL. +.ih +SEE ALSO +msivector, mrieval, mrider +.endhelp diff --git a/math/iminterp/doc/msifit.hlp b/math/iminterp/doc/msifit.hlp new file mode 100644 index 00000000..9a63ae2d --- /dev/null +++ b/math/iminterp/doc/msifit.hlp @@ -0,0 +1,45 @@ +.help msifit Dec98 "Image Interpolation Package" +.ih +NAME +msifit - fit the interpolant to the data +.ih +SYNOPSIS +msifit (msi, datain, nxpix, nypix, len_datain) + +.nf + pointer msi #I interpolant descriptor + real datain[len_datain,ARB] #I data array + int nxpix #I number of x pixels + int nypix #I number of y pixels + int len_datain #I length of datain, len_datain >= nxpix +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor. +.le +.ls datain +Array containing the data. +.le +.ls nxpix, nypix +The number of pixels in x and y. +.le +.ls len_datain +The row length of the datain array. Len_datain must be >= nxpix. +.le +.ih +DESCRIPTION +The datain array is checked for size, memory is allocated for the coefficient +array and the end conditions are specified. The interior polynomial, sinc, +and drizzle interpolants are saved as the data points. The polynomial +coefficients are calculated from the data points in the evaluation stage. +The B-spline coefficients are calculated in MSIFIT as they depend on the +entire data array. +.ih +NOTES +Checking for INDEF valued pixels is the responsibility of the user. +MSIINIT or MSISINIT must be called before using MSIFIT. MSIFIT must be +called before using MSIEVAL, MSIVECTOR, MSIDER, MSIGRL or MSISQGRL. +.ih +SEE ALSO +.endhelp diff --git a/math/iminterp/doc/msifree.hlp b/math/iminterp/doc/msifree.hlp new file mode 100644 index 00000000..79b1966d --- /dev/null +++ b/math/iminterp/doc/msifree.hlp @@ -0,0 +1,26 @@ +.help msifree Dec98 "Image Interpolation Package" +.ih +NAME +msifree -- free sequential interpolant descriptor +.ih +SYNOPSIS +msifree (msi) + +.nf + pointer msi #U interpolant descriptor +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor structure. +.le +.ih +DESCRIPTION +MSIFREE frees the sequential interpolant descriptor structure. +MSIFREE should be called when interpolation is complete. +.ih +NOTES +.ih +SEE ALSO +msiinit, msisinit +.endhelp diff --git a/math/iminterp/doc/msigeti.hlp b/math/iminterp/doc/msigeti.hlp new file mode 100644 index 00000000..5ab46156 --- /dev/null +++ b/math/iminterp/doc/msigeti.hlp @@ -0,0 +1,35 @@ +.help msigeti Dec98 msigeti.hlp +.ih +NAME +msigeti -- fetch an msi integer parameter +.ih +SYNOPSIS +include + +ivalue = msigeti (msi, param) + +.nf + pointer msi #I interpolant descriptor + int param #I parameter +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor structure. +.le +.ls param +The parameter to be fetched. The choices are: II_MSITYPE, the interpolant +type, II_MSINSAVE, the length of the saved coefficient array, and +II_MSINSINC, the half-width of the sinc interpolant. +.le +.ih +DESCRIPTION +MSIGETI is used to determine the size of the coefficient array that +must be allocated to save the sequential interpolant description structure, +and to fetch selected sequential interpolant parameters. +.ih +NOTES +.ih +SEE ALSO +msiinit, msisinit, msigetr +.endhelp diff --git a/math/iminterp/doc/msigetr.hlp b/math/iminterp/doc/msigetr.hlp new file mode 100644 index 00000000..dadac5c2 --- /dev/null +++ b/math/iminterp/doc/msigetr.hlp @@ -0,0 +1,37 @@ +.help msigetr Dec98 msigetr.hlp +.ih +NAME +msigetr -- fetch an msi real parameter +.ih +SYNOPSIS +include + +rvalue = msigetr (msi, param) + +.nf + pointer msi #I interpolant descriptor + int param #I parameter +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor structure. +.le +.ls param +The parameter to be fetched. The choices are: II_MSIBADVAL, the undefined +pixel value for the drizzle interpolant. The parameter definitions are +contained in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +MSIGETR is used to set the value of undefined drizzle interpolant pixels. +Undefined pixels are those for which the interpolation coordinates do not +overlap the input coordinates, but are still, within the boundaries of the input +image, a situation which may occur when the pixel fraction is < 1.0. +.ih +.ih +NOTES +.ih +SEE ALSO +msiinit, msisinit, msigeti +.endhelp diff --git a/math/iminterp/doc/msigrid.hlp b/math/iminterp/doc/msigrid.hlp new file mode 100644 index 00000000..6bc110d5 --- /dev/null +++ b/math/iminterp/doc/msigrid.hlp @@ -0,0 +1,51 @@ +.help msigrid Dec98 "Image Interpolation Package" +.ih +NAME +msigrid -- evaluate the interpolant on a grid of points +.ih +SYNOPSIS +msigrid (msi, x, y, zfit, nx, ny, len_zfit) + +.nf + pointer msi #I interpolant descriptor + real x[2*nx] #I x values, 1 <= x[i] <= nx + real y[2*ny] #I y values, 1 <= y[i] <= ny + real zfit[len_zfit,ARB] #O grid of interpolated values + int nx #I number of x points + int ny #I number of y points + int len_zfit #I length zfit, len_zfit >= nx +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the interpolant descriptor structure. +.le +.ls x, y +The x and y arrays of points to be evaluated, or in the case of the drizzle +interpolant the x and y ranges over which the points are to be evaluated. +The x and y arrays must be ordered in increasing values of x and y respectively. +.le +.ls zfit +The array of interpolated points. +.le +.ls nx, ny +The number of points in the x and y directions respectively. +.le +.ls len_zfit +The row length of the zfit array. Len_zfit >= nx. +.le +.ih +DESCRIPTION +MSIGRID evaluates the interpolant at a set of x and y values on a +rectangular grid or in the case of the drizzle interpolant within +rectangular regions. It is most efficient for evaluating the interpolant +at many values which are closely spaced in x and y. For widely spaced +points MSIVECTOR should be used. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility +of the user. +.ih +SEE ALSO +msieval, msivector, msider, mrieval, mrider +.endhelp diff --git a/math/iminterp/doc/msigrl.hlp b/math/iminterp/doc/msigrl.hlp new file mode 100644 index 00000000..f6e2326a --- /dev/null +++ b/math/iminterp/doc/msigrl.hlp @@ -0,0 +1,43 @@ +.help msigrl Dec98 "Image Interpolation Package" +.ih +NAME +msigrl -- integrate the interpolant inside a polygon +.ih +SYNOPSIS +y = msigrl (msi, x, y, npts) + +.nf + pointer msi #I interpolant descriptor + real x[npts] #I x values, 1 <= x <= npts, x[1] = x[npts] + real y[npts] #I y values, 1 <= y <= npts, y[1] = y[npts] + int npts #I number of points +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor structure. +.le +.ls x, y +An array of x and y values describing a polygon, where x[1] = x[npts] and +y[1] = y[npts]. X and y describe a closed curve where any horizontal line +segment intersects the domain of integration at at most one point. +.le +.ls npts +The number of points describing the polygon. Npts must >= 4 (triangle). +.le +.ih +DESCRIPTION +MSIGRL integrates the interpolant exactly for rectangular domains +of integration. For more irregular regions of integration MSIGRL +returns an approximation whose accuracy depends on the size of the +integration region and the shape of the polygon. +.ih +NOTES +Checking for out of bound integration regimes is the responsibility of +the user. Non-rectangular partial pixel domains of integration default +to rectangular regions. MSIINIT or MSISINIT and MSIFIT must be called +before using MSIGRL. +.ih +SEE ALSO +msisqrgl +.endhelp diff --git a/math/iminterp/doc/msiinit.hlp b/math/iminterp/doc/msiinit.hlp new file mode 100644 index 00000000..68dba684 --- /dev/null +++ b/math/iminterp/doc/msiinit.hlp @@ -0,0 +1,41 @@ +.help msiinit Dec98 "Image Interpolation Package" +.ih +NAME +msiinit -- initialize the sequential interpolant descriptor +.ih +SYNOPSIS +include + +msiinit (msi, interp_type) + +.nf + pointer msi #U interpolant descriptor + int interp_type #I interpolant type +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor. +.le +.ls interp_type +Interpolant type. The options are II_BINEAREST, II_BILINEAR, II_BIPOLY3, +II_BIPOLY5, II_BISPLINE3, II_BISINC, II_BILSINC, and II_BIDRIZZLE, for +nearest neighbour, bilinear, 3rd and 5th order interior polynomials, bicubic +spline, sinc, look-up table sinc, and drizzle respectively. The interpolant +definitions are found in the package header file math/iminterp.h. +.le +.ih +DESCRIPTION +The interpolant type is allocated and initialized. The pointer msi is +returned by MSIINIT. The sinc interpolant width defaults to 31 pixels +in x and y. The look-up table sinc resolution defaults to 20 resolution +elements or 0.05 pixels in x and y. The drizzle pixel fraction defaults +to 1.0. +.ih +NOTES +MSIINIT, MSISINIT or MSIRESTORE must be called before using any other +MSI routines. +.ih +SEE ALSO +msirestore, msifree +.endhelp diff --git a/math/iminterp/doc/msirestore.hlp b/math/iminterp/doc/msirestore.hlp new file mode 100644 index 00000000..664c9b50 --- /dev/null +++ b/math/iminterp/doc/msirestore.hlp @@ -0,0 +1,36 @@ +.help msirestore Dec98 "Image Interpolator Package" +.ih +NAME +msirestore -- restore interpolant +.ih +SYNOPSIS +msirestore (msi, interpolant) + +.nf + pointer msi #U interpolant descriptor + real interpolant[] #I array containing interpolant +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the interpolant descriptor structure. +.le +.ls interpolant +Array containing the interpolant. The amount of space required by interpolant +can be determined by a call to msigeti. +.le + +.nf + len_interpolant = msigeti (msi, II_MSINSAVE) +.fi +.ih +DESCRIPTION +MSIRESTORE allocates space for the interpolant descriptor and restores the +parameters and coefficients stored in the interpolant array to the +interpolant structure for use by MSIEVAL, MSIVECTOR, MSIDER and MSIGRL. +.ih +NOTES +.ih +SEE ALSO +msisave +.endhelp diff --git a/math/iminterp/doc/msisave.hlp b/math/iminterp/doc/msisave.hlp new file mode 100644 index 00000000..7d5f67ef --- /dev/null +++ b/math/iminterp/doc/msisave.hlp @@ -0,0 +1,38 @@ +.help msisave Dec98 "Image Interpolator Package" +.ih +NAME +msisave -- save interpolant +.ih +SYNOPSIS +msisave (msi, interpolant) + +.nf + pointer msi #I interpolant descriptor + real interpolant[] #O array containing the interpolant +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the interpolant descriptor structure. +.le +.ls interpolant +Array where the interpolant is stored. The required interpolant array length +required can be determined by a call to msigeti. +.le + +.nf + len_interpolant = msigeti (msi, II_MSINSAVE) +.fi +.ih +DESCRIPTION +The interpolant type, number of coefficients in x and y, the position of +the first data point in the coefficient array, and the sinc and drizzle +interpolant parameters are stored in the first eleven elements of interpolant. +The remaining elements contain the coefficients and look-up tables +calculated by MSIFIT. +.ih +NOTES +.ih +SEE ALSO +msirestore +.endhelp diff --git a/math/iminterp/doc/msisinit.hlp b/math/iminterp/doc/msisinit.hlp new file mode 100644 index 00000000..0a05e7ab --- /dev/null +++ b/math/iminterp/doc/msisinit.hlp @@ -0,0 +1,61 @@ +.help msisinit Dec98 "Image Interpolator Package" +.ih +NAME +msisinit -- initialize the sequential interpolant descriptor using user parameters +.ih +SYNOPSIS +include + +msisinit (msi, interp_type, nsinc, nxincr, nyincr, pixfrac1, pixfrac2, badval) + +.nf + pointer msi #O interpolant descriptor + int interp_type #I interpolant type + int nsinc #I sinc interpolant width in pixels + int nxincr,nyincr #I sinc look-up table resolution + real pixfrac1,pixfrac2 #I sinc or drizzle pixel fractions + real badval #I drizzle undefined pixel value +.fi + +.ih +ARGUMENTS +.ls msi +Pointer to sequential interpolant descriptor. +.le +.ls interp_type +Interpolant type. The options are II_BINEAREST, II_BILINEAR, II_BIPOLY3, +II_BIPOLY5, II_BISPLINE3, II_BISINC, II_BILSINC, and II_BIDRIZZLE for the +nearest neighbour, linear, 3rd order polynomial, 5th order polynomial, +cubic spline, sinc, look-up table sinc, and drizzle interpolants respectively. +The interpolant type definitions are found in the package header file +math/iminterp.h. +.le +.ls nsinc +The sinc and look-up table sinc interpolant width in pixels. Nsinc is +rounded up internally to the nearest odd number. +.le +.ls nxincr, nyincr +The look-up table sinc resolution in x and y in number of entries. Nxincr = 10 +implies a pixel resolution of 0.1 pixels in x, nxincr = 20 a pixel resolution +of 0.05 pixels in x, etc. The default value of nxincr and nyincr are 20 and 20 +.le +.ls pixfrac1, pixfrac2 +The look-up table sinc fractional pixel shifts in x and y if nincr = 1 in +which case -0.5 <= rparam[1/2] <= 0.5 , or the drizzle pixel fractions in +which case 0.0 <= rparam[1/2] <= 1.0. +.le +.ls badval +The undefined pixel value for the drizzle interpolant. Pixels within +the boundaries of the input image which do not overlap the input image +pixels are assigned a value of badval. +.le +.ih +DESCRIPTION +The interpolant descriptor is allocated and initialized. The pointer msi is +returned by MSISINIT. +.ih +NOTES +MSIINIT or MSISINIT must be called before using any other MSI routines. +.ih +SEE ALSO +msisinit, msifree diff --git a/math/iminterp/doc/msisqgrl.hlp b/math/iminterp/doc/msisqgrl.hlp new file mode 100644 index 00000000..fc49514d --- /dev/null +++ b/math/iminterp/doc/msisqgrl.hlp @@ -0,0 +1,38 @@ +.help msisqgrl Dec98 "Image Interpolation Package" +.ih +NAME +msisqgrl -- integrate the interpolant over a rectangular region +.ih +SYNOPSIS +y = msisqgrl (msi, x1, x2, y1, y2) + +.nf + pointer msi #I interpolant descriptor + real x1 #I lower x limit, 1 <= x1 <= nxpix + real x2 #I upper x limit, 1 <= x2 <= nxpix + real y1 #I lower y limit, 1 <= y1 <= nypix + real y2 #I upper y limit, 1 <= y2 <= nypix +.fi +.ih +ARGUMENTS +.ls msi +Pointer to the sequential interpolant descriptor structure. +.le +.ls x1, x2 +The x limits of integration +.le +.ls y1, y2 +The y limits of integration. +.le +.ih +DESCRIPTION +MSISQGRL integrates the interpolant exactly for rectangular domains +of integration, including partial pixel regions. +.ih +NOTES +Checking for out of bound integration regimes is the responsibility of +the user. MSIFIT must be called before using MSISQGRL. +.ih +SEE ALSO +msigrl +.endhelp diff --git a/math/iminterp/doc/msitype.hlp b/math/iminterp/doc/msitype.hlp new file mode 100644 index 00000000..5da6dc6d --- /dev/null +++ b/math/iminterp/doc/msitype.hlp @@ -0,0 +1,95 @@ +.help msitype Dec98 "Image Interpolator Package" +.ih +NAME +msitype -- decode an interpolant string +.ih +SYNOPSIS +include + +msitype (interpstr, interp_type, nsinc, nincr, pixfrac) + +.nf + char interpstr #I the input interpolant string + int interp_type #O interpolant type + int nsinc #O sinc interpolant width in pixels + int nincr #O sinc look-up table resolution + real pixfrac #O sinc or drizzle pixel fraction +.fi + +.ih +ARGUMENTS +.ls interpstr +The user supplied interpolant string to be decoded. The options are +.ls nearest +Nearest neighbor interpolation. +.le +.ls linear +Bilinear interpolation +.le +.ls poly3 +Bicubic polynomial interpolation. +.le +.ls poly5 +Biquintic polynomial interpolation. +.le +.ls spline3 +Bicubic spline interpolation. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +Drizzle interpolation. Users can specify the drizzle pixel fraction by +appending the pixel fraction value to the interpolant string in square +brackets, e.g. drizzle[0.5] specifies a pixel fraction of 0.5 in x and y. +The default pixel fraction is 1.0. If either of the x or y pixel +fractions are 0.0, then both are set to 0.0. A minimum value of 0.001 +is imposed on the actual value of pixfrac. +.le +.le +.ls interp_type +The output interpolant type. The options are II_BINEAREST, II_BILINEAR, +II_BIPOLY3, II_BIPOLY5, II_BISPLINE3, II_BISINC, II_BILSINC, and II_BIDRIZZLE +for the nearest neighbor, linear, 3rd order polynomial, 5th order polynomial, +cubic spline, sinc, look-up table sinc, and drizzle interpolants respectively. +The interpolant type definitions are found in the package header file +math/iminterp.h. +.le +.ls nsinc +The output sinc and look-up table sinc interpolant width in pixels. The +default value is 31 pixels in x and y. +.le +.ls nincr +The output sinc look-up table size. Nincr = 10 implies a pixel resolution +of 0.1 pixels in x, nincr = 20 a pixel resolution of 0.05 pixels in y, etc. The +default value of nincr is 20. +.le +.ls pixfrac +The output look-up table sinc fractional pixel shift if nincr = 1 +in which case -0.5 <= pixfrac <= 0.5 , or the drizzle pixel +fraction in which case 0.0 <= pixfrac <= 1.0. +.le +.ih +DESCRIPTION +The interpolant string is decoded into values suitable for the MSISINIT +or MSIINIT routines. +.ih +NOTES +.ih +SEE ALSO +msinit, msisinit, msifree diff --git a/math/iminterp/doc/msivector.hlp b/math/iminterp/doc/msivector.hlp new file mode 100644 index 00000000..d6561be7 --- /dev/null +++ b/math/iminterp/doc/msivector.hlp @@ -0,0 +1,54 @@ +.help msivector Dec98 "Image Interpolation Package" +.ih +NAME +msivector -- evaluate the interpolant at an array of x and y points +.ih +SYNOPSIS +msivector (msi, x, y, zfit, npts) + +.nf + pointer msi #I interpolant descriptor + real x[npts/4*npts] #I x values, 1 <= x <= nxpix + real y[npts/4*npts] #I y values, 1 <= y <= nypix + real zfit[npts] #O interpolated values + int npts #I number of points +.fi +.ih +ARGUMENTS +.ls msi +The pointer to the sequential interpolant descriptor +.le +.ls x, y +The array of x and y values at or in the case tof the drizzle interpolant the +array of quadrilaterals over which to evaluate the interpolant. +.le +.ls zfit +The interpolated values. +.le +.ls npts +The number of points. +.le +.ih +DESCRIPTION +The polynomial coefficients are calculated directly from the data points, +The polynomial interpolants are evaluated using Everett's central difference +formula. The spline interpolant uses the B-spline coefficients +calculated using the MSIFIT routine. The boundary extension algorithm is +projection. + +The sinc interpolant is evaluated using a array of data points around +the point in question. The look-up table since is computed by convolving +the data with a pre-computed look-up table entry. The boundary extension +algorithm is nearest neighbor. + +The drizzle interpolant is evaluated by summing the data over the +list of user supplied quadrilaterals. +.ih +NOTES +Checking for out of bounds and INDEF valued pixels is the responsibility +of the user. MSIINIT or MSISINIT and MSIFIT must be called before using +MSIVECTOR. +.ih +SEE ALSO +msieval, mrieval +.endhelp diff --git a/math/iminterp/ii_1dinteg.x b/math/iminterp/ii_1dinteg.x new file mode 100644 index 00000000..05b80542 --- /dev/null +++ b/math/iminterp/ii_1dinteg.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" +include + +# II_1DINTEG -- Find the integral of the interpolant from a to b be assuming +# that both a and b land in the array. This routine is not used directly +# in the 1D interpolation package but is actually called repeatedly from the +# 2D interpolation package. Therefore the SINC function interpolator has +# not been implemented, although it has been blocked in. + +real procedure ii_1dinteg (coeff, len_coeff, a, b, interp_type, nsinc, dx, + pixfrac) + +real coeff[ARB] # 1D array of coefficients +int len_coeff # length of coefficient array (used in sinc only) +real a # lower limit for integral +real b # upper limit for integral +int interp_type # type of 1D interpolant +int nsinc # width of sinc function +real dx # sinc precision +real pixfrac # drizzle pixel fraction + +int neara, nearb, i, j, nterms +real deltaxa, deltaxb, accum, xa, xb, pcoeff[MAX_NDERIVS] + +begin + # Flip order and sign at end. + xa = a + xb = b + if (a > b) { + xa = b + xb = a + } + + # Initialize. + neara = xa + nearb = xb + accum = 0. + + switch (interp_type) { + case II_NEAREST: + nterms = 0 + case II_LINEAR: + nterms = 1 + case II_DRIZZLE: + nterms = 0 + case II_POLY3: + nterms = 4 + case II_POLY5: + nterms = 6 + case II_SPLINE3: + nterms = 4 + case II_SINC, II_LSINC: + nterms = 0 + } + + switch (interp_type) { + # NEAREST + case II_NEAREST: + + # Reset segment to center values. + neara = xa + 0.5 + nearb = xb + 0.5 + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment involved. + if (nearb == neara) { + + deltaxb = xb - nearb + accum = accum + (deltaxb - deltaxa) * coeff[neara] + + # More than one segment. + } else { + + # First segment. + accum = accum + (0.5 - deltaxa) * coeff[neara] + + # Middle segment. + do j = neara + 1, nearb - 1 { + accum = accum + coeff[j] + } + + # Last segment. + deltaxb = xb - nearb + accum = accum + (deltaxb + 0.5) * coeff[nearb] + } + + # LINEAR + case II_LINEAR: + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment involved. + if (nearb == neara) { + + deltaxb = xb - nearb + accum = accum + (deltaxb - deltaxa) * coeff[neara] + + 0.5 * (coeff[neara+1] - coeff[neara]) * + (deltaxb * deltaxb - deltaxa * deltaxa) + + # More than one segment. + } else { + + # First segment. + accum = accum + (1. - deltaxa) * coeff[neara] + + 0.5 * (coeff[neara+1] - coeff[neara]) * + (1. - deltaxa * deltaxa) + + # Middle segment. + do j = neara + 1, nearb - 1 { + accum = accum + 0.5 * (coeff[j+1] + coeff[j]) + } + + # Last segment. + deltaxb = xb - nearb + accum = accum + coeff[nearb] * deltaxb + 0.5 * + (coeff[nearb+1] - coeff[nearb]) * deltaxb * deltaxb + } + + # DRIZZLE-- Note that to get get pixfrac an interface change was + # required. + case II_DRIZZLE: + if (pixfrac >= 1.0) + call ii_dzigrl1 (a, b, accum, coeff) + else + call ii_dzigrl (a, b, accum, coeff, pixfrac) + + # SINC -- Note that to get ncoeff, nsinc, and dx, an interface change + # was required. + case II_SINC, II_LSINC: + call ii_sincigrl (xa, xb, accum, coeff, len_coeff, nsinc, dx) + + # A higher order interpolant. + default: + + # Set up for first segment. + deltaxa = xa - neara + + # For clarity one segment case is handled separately. + + # Only one segment involved. + if (nearb == neara) { + + deltaxb = xb - nearb + call ii_getpcoeff (coeff, neara, pcoeff, interp_type) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * + (deltaxb ** i - deltaxa ** i) + + # More than one segment. + } else { + + # First segment. + call ii_getpcoeff (coeff, neara, pcoeff, interp_type) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * (1. - deltaxa ** i) + + # Middle segment. + do j = neara + 1, nearb - 1 { + call ii_getpcoeff (coeff, j, pcoeff, interp_type) + + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] + } + + # Last segment. + deltaxb = xb - nearb + call ii_getpcoeff (coeff, nearb, pcoeff, interp_type) + do i = 1, nterms + accum = accum + (1./i) * pcoeff[i] * deltaxb ** i + } + } + + if (a < b) + return (accum) + else + return (-accum) +end + + +# II_GETPCOEFF -- Generates polynomial coefficients if the interpolant is +# SPLINE3, POLY3 or POLY5. + +procedure ii_getpcoeff (coeff, index, pcoeff, interp_type) + +real coeff[ARB] # coefficient array +int index # coefficients wanted for index < x < index + 1 +real pcoeff[ARB] # polynomial coefficients +int interp_type # type of interpolant + +int i, k, nterms +real diff[MAX_NDERIVS] + +begin + # generate polynomial coefficients, first for spline + + if (interp_type == II_SPLINE3) { + + pcoeff[1] = coeff[index-1] + 4. * coeff[index] + coeff[index+1] + pcoeff[2] = 3. * (coeff[index+1] - coeff[index-1]) + pcoeff[3] = 3. * (coeff[index-1] - 2. * coeff[index] + + coeff[index+1]) + pcoeff[4] = -coeff[index-1] + 3. * coeff[index] - + 3. * coeff[index+1] + coeff[index+2] + } else { + + if (interp_type == II_POLY5) + nterms = 6 + + # must be POLY3 + else + nterms = 4 + + # Newton's form written in line to get polynomial from data + + # load data + do i = 1, nterms + diff[i] = coeff[index - nterms/2 + i] + + # generate difference table + do k = 1, nterms - 1 + do i = 1, nterms - k + diff[i] = (diff[i+1] - diff[i]) / k + + # shift to generate polynomial coefficients of (x - index) + do k = nterms, 2, -1 + do i = 2, k + diff[i] = diff[i] + diff[i-1] * (k - i - nterms/2) + + do i = 1, nterms + pcoeff[i] = diff[nterms + 1 - i] + } +end + + +# II_SINCIGRL -- Evaluate integral of sinc interpolator. +# The integral is computed by dividing interval into a number of equal +# size subintervals which are at most one pixel wide. The integral +# of each subinterval is the central value times the interval width. + +procedure ii_sincigrl (a, b, sum, data, npix, nsinc, mindx) + +real a, b # integral limits +real sum # output integral value +real data[npix] # input data array +int npix # number of pixels +int nsinc # sinc truncation length +real mindx # interpolation minimum + +int n +real x, y, dx, x1, x2 + +begin + x1 = min (a, b) + x2 = max (a, b) + n = max (1, nint (x2 - x1)) + dx = (x2 - x1) / n + + sum = 0. + for (x = x1 + dx / 2; x < x2; x = x + dx) { + call ii_sinc (x, y, 1, data, npix, nsinc, mindx) + sum = sum + y * dx + } +end + + +# II_DZIGRL -- Procedure to integrate the drizzle interpolant. + +procedure ii_dzigrl (a, b, sum, data, pixfrac) + +real a, b # x start and stop values, must be within [1,npts] +real sum # integgral value returned to the user +real data[ARB] # data to be interpolated +real pixfrac # the drizzle pixel fraction + +int j, neara, nearb +real hpixfrac, xa, xb, dx, accum + +begin + hpixfrac = pixfrac / 2.0 + + # Define the interval of integration. + xa = min (a, b) + xb = max (a, b) + neara = xa + 0.5 + nearb = xb + 0.5 + + # Initialize the integration + accum = 0.0 + if (neara == nearb) { + + dx = min (xb, nearb + hpixfrac) - max (xa, neara - hpixfrac) + if (dx > 0.0) + accum = accum + dx * data[neara] + + } else { + + # first segement + dx = neara + hpixfrac - max (xa, neara - hpixfrac) + if (dx > 0.0) + accum = accum + dx * data[neara] + + # interior segments. + do j = neara + 1, nearb - 1 + accum = accum + pixfrac * data[j] + + # last segment + dx = min (xb, nearb + hpixfrac) - (nearb - hpixfrac) + if (dx > 0.0) + accum = accum + dx * data[nearb] + } + + if (a > b) + sum = -accum + else + sum = accum +end + + +# II_DZIGRL1 -- Procedure to integrate the drizzle interpolant in the case +# where pixfrac = 1.0. + +procedure ii_dzigrl1 (a, b, sum, data) + +real a, b # x start and stop values, must be within [1,npts] +real sum # integgral value returned to the user +real data[ARB] # data to be interpolated + +int j, neara, nearb +real xa, xb, deltaxa, deltaxb, accum + +begin + # Define the interval of integration. + xa = min (a, b) + xb = max (a, b) + neara = xa + 0.5 + nearb = xb + 0.5 + deltaxa = xa - neara + deltaxb = xb - nearb + + # Only one segment involved. + accum = 0.0 + if (neara == nearb) { + + accum = accum + (deltaxb - deltaxa) * data[neara] + + } else { + + # First segment. + accum = accum + (0.5 - deltaxa) * data[neara] + + # Middle segment. + do j = neara + 1, nearb - 1 + accum = accum + data[j] + + # Last segment. + accum = accum + (deltaxb + 0.5) * data[nearb] + } + + if (a > b) + sum = -accum + else + sum = accum +end diff --git a/math/iminterp/ii_bieval.x b/math/iminterp/ii_bieval.x new file mode 100644 index 00000000..3469128e --- /dev/null +++ b/math/iminterp/ii_bieval.x @@ -0,0 +1,1080 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# II_BINEAREST -- Procedure to evaluate the nearest neighbour interpolant. +# The real array coeff contains the coefficients of the 2D interpolant. +# The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix and that +# coeff[1+first_point] = datain[1,1]. + +procedure ii_binearest (coeff, first_point, len_coeff, x, y, zfit, npts) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated + +int nx, ny +int index +int i + +begin + do i = 1, npts { + + nx = x[i] + 0.5 + ny = y[i] + 0.5 + + # define pointer to data[nx,ny] + index = first_point + (ny - 1) * len_coeff + nx + + zfit[i] = coeff[index] + + } +end + + +# II_BILINEAR -- Procedure to evaluate the bilinear interpolant. +# The real array coeff contains the coefficients of the 2D interpolant. +# The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = datain[1,1]. + +procedure ii_bilinear (coeff, first_point, len_coeff, x, y, zfit, npts) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of data points + +int nx, ny +int index +int i +real sx, sy, tx, ty + +begin + do i = 1, npts { + + nx = x[i] + ny = y[i] + + sx = x[i] - nx + tx = 1. - sx + sy = y[i] - ny + ty = 1. - sy + + # define pointer to data[nx,ny] + index = first_point + (ny - 1) * len_coeff + nx + + zfit[i] = tx * ty * coeff[index] + sx * ty * coeff[index + 1] + + sy * tx * coeff[index+len_coeff] + + sx * sy * coeff[index+len_coeff+1] + } +end + + +# II_BIPOLY3 -- Procedure to evaluate the bicubic polynomial interpolant. +# The real array coeff contains the coefficients of the 2D interpolant. +# The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = datain[1,1]. The interpolant is +# evaluated using Everett's central difference formula. + +procedure ii_bipoly3 (coeff, first_point, len_coeff, x, y, zfit, npts) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset first point +int len_coeff # row length of the coefficient array +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of fitted values +int npts # number of points to be evaluated + +int nxold, nyold, nx, ny +int first_row, index +int i, j +real sx, tx, sx2m1, tx2m1, sy, ty +real cd20[4], cd21[4], ztemp[4], cd20y, cd21y + +begin + nxold = -1 + nyold = -1 + + do i = 1, npts { + + nx = x[i] + sx = x[i] - nx + tx = 1. - sx + sx2m1 = sx * sx - 1. + tx2m1 = tx * tx - 1. + + ny = y[i] + sy = y[i] - ny + ty = 1. - sy + + # define pointer to datain[nx,ny-1] + first_row = first_point + (ny - 2) * len_coeff + nx + + # loop over the 4 surrounding rows of data + # calculate the central differences at each value of y + + # if new data point caculate the central differnences in x + # for each y + + index = first_row + if (nx != nxold || ny != nyold) { + do j = 1, 4 { + cd20[j] = 1./6. * (coeff[index+1] - 2. * coeff[index] + + coeff[index-1]) + cd21[j] = 1./6. * (coeff[index+2] - 2. * coeff[index+1] + + coeff[index]) + index = index + len_coeff + } + } + + # interpolate in x at each value of y + index = first_row + do j = 1, 4 { + ztemp[j] = sx * (coeff[index+1] + sx2m1 * cd21[j]) + + tx * (coeff[index] + tx2m1 * cd20[j]) + index = index + len_coeff + } + + # calculate y central differences + cd20y = 1./6. * (ztemp[3] - 2. * ztemp[2] + ztemp[1]) + cd21y = 1./6. * (ztemp[4] - 2. * ztemp[3] + ztemp[2]) + + # interpolate in y + zfit[i] = sy * (ztemp[3] + (sy * sy - 1.) * cd21y) + + ty * (ztemp[2] + (ty * ty - 1.) * cd20y) + + nxold = nx + nyold = ny + + } +end + + +# II_BIPOLY5 -- Procedure to evaluate a biquintic polynomial. +# The real array coeff contains the coefficents of the 2D interpolant. +# The routine assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = datain[1,1]. The interpolant is evaluated +# using Everett's central difference formula. + +procedure ii_bipoly5 (coeff, first_point, len_coeff, x, y, zfit, npts) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset to first data point +int len_coeff # row length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of fitted values +int npts # number of points + +int nxold, nyold, nx, ny +int first_row, index +int i, j +real sx, sx2, sx2m1, sx2m4, tx, tx2, tx2m1, tx2m4, sy, sy2, ty, ty2 +real cd20[6], cd21[6], cd40[6], cd41[6], ztemp[6] +real cd20y, cd21y, cd40y, cd41y + +begin + nxold = -1 + nyold = -1 + + do i = 1, npts { + + nx = x[i] + sx = x[i] - nx + sx2 = sx * sx + sx2m1 = sx2 - 1. + sx2m4 = sx2 - 4. + tx = 1. - sx + tx2 = tx * tx + tx2m1 = tx2 - 1. + tx2m4 = tx2 - 4. + + ny = y[i] + sy = y[i] - ny + sy2 = sy * sy + ty = 1. - sy + ty2 = ty * ty + + # calculate value of pointer to data[nx,ny-2] + first_row = first_point + (ny - 3) * len_coeff + nx + + # calculate the central differences in x at each value of y + index = first_row + if (nx != nxold || ny != nyold) { + do j = 1, 6 { + cd20[j] = 1./6. * (coeff[index+1] - 2. * coeff[index] + + coeff[index-1]) + cd21[j] = 1./6. * (coeff[index+2] - 2. * coeff[index+1] + + coeff[index]) + cd40[j] = 1./120. * (coeff[index-2] - 4. * coeff[index-1] + + 6. * coeff[index] - 4. * coeff[index+1] + + coeff[index+2]) + cd41[j] = 1./120. * (coeff[index-1] - 4. * coeff[index] + + 6. * coeff[index+1] - 4. * coeff[index+2] + + coeff[index+3]) + index = index + len_coeff + } + } + + # interpolate in x at each value of y + index = first_row + do j = 1, 6 { + ztemp[j] = sx * (coeff[index+1] + sx2m1 * (cd21[j] + sx2m4 * + cd41[j])) + tx * (coeff[index] + tx2m1 * + (cd20[j] + tx2m4 * cd40[j])) + index = index + len_coeff + } + + # central differences in y + cd20y = 1./6. * (ztemp[4] - 2. * ztemp[3] + ztemp[2]) + cd21y = 1./6. * (ztemp[5] - 2. * ztemp[4] + ztemp[3]) + cd40y = 1./120. * (ztemp[1] - 4. * ztemp[2] + 6. * ztemp[3] - + 4. * ztemp[4] + ztemp[5]) + cd41y = 1./120. * (ztemp[2] - 4. * ztemp[3] + 6. * ztemp[4] - + 4. * ztemp[5] + ztemp[6]) + + # interpolate in y + zfit[i] = sy * (ztemp[4] + (sy2 - 1.) * (cd21y + (sy2 - 4.) * + cd41y)) + ty * (ztemp[3] + (ty2 - 1.) * (cd20y + + (ty2 - 4.) * cd40y)) + + nxold = nx + nyold = ny + + } +end + + +# II_BISPLINE3 -- Procedure to evaluate a bicubic spline. +# The real array coeff contains the B-spline coefficients. +# The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = B-spline[2]. + +procedure ii_bispline3 (coeff, first_point, len_coeff, x, y, zfit, npts) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset to first data point +int len_coeff # row length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated + +int nx, ny +int first_row, index +int i, j +real sx, tx, sy, ty +real bx[4], by[4], accum, sum + +begin + do i = 1, npts { + + nx = x[i] + sx = x[i] - nx + tx = 1. - sx + + ny = y[i] + sy = y[i] - ny + ty = 1. - sy + + + # calculate the x B-splines + bx[1] = tx ** 3 + bx[2] = 1. + tx * (3. + tx * (3. - 3. * tx)) + bx[3] = 1. + sx * (3. + sx * (3. - 3. * sx)) + bx[4] = sx ** 3 + + # calculate the y B-splines + by[1] = ty ** 3 + by[2] = 1. + ty * (3. + ty * (3. - 3. * ty)) + by[3] = 1. + sy * (3. + sy * (3. - 3. * sy)) + by[4] = sy ** 3 + + # calculate the pointer to data[nx,ny-1] + first_row = first_point + (ny - 2) * len_coeff + nx + + # evaluate spline + accum = 0. + index = first_row + do j = 1, 4 { + sum = coeff[index-1] * bx[1] + coeff[index] * bx[2] + + coeff[index+1] * bx[3] + coeff[index+2] * bx[4] + accum = accum + sum * by[j] + index = index + len_coeff + } + + zfit[i] = accum + } +end + + +# II_BISINC -- Procedure to evaluate the 2D sinc function. The real array +# coeff contains the data. The procedure assumes that 1 <= x <= nxpix and +# 1 <= y <= nypix and that coeff[1+first_point] = datain[1,1]. The since +# truncation length is nsinc. The taper is a cosbell function which is +# valid for 0 <= x <= PI / 2 (Abramowitz and Stegun, 1972, Dover Publications, +# p 76). If the point to be interpolated is less than mindx and mindy from +# a data point no interpolation is done and the data point is returned. This +# routine does not use precomputed arrays. + +procedure ii_bisinc (coeff, first_point, len_coeff, len_array, x, y, zfit, + npts, nsinc, mindx, mindy) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset to first data point +int len_coeff # row length of coeff +int len_array # column length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of interpolated values +int npts # the number of input points. +int nsinc # sinc truncation length +real mindx # interpolation mininmum in x +real mindy # interpolation mininmum in y + +int i, j, k, nconv, nx, ny, index, mink, maxk, offk, minj, maxj, offj +int last_point +pointer sp, taper, ac, ar +real sconst, a2, a4, sdx, dx, dy, dxn, dyn, ax, ay, px, py, sumx, sumy, sum +real dx2 + +begin + # Compute the length of the convolution. + nconv = 2 * nsinc + 1 + + # Allocate working array space. + call smark (sp) + call salloc (taper, nconv, TY_REAL) + call salloc (ac, nconv, TY_REAL) + call salloc (ar, nconv, TY_REAL) + + # Compute the constants for the cosine bell taper. + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + + # Precompute the taper array. Incorporate the sign change portion + # of the sinc interpolator into the taper array. + if (mod (nsinc, 2) == 0) + sdx = 1.0 + else + sdx = -1.0 + do j = -nsinc, nsinc { + dx2 = sconst * j * j + Memr[taper+j+nsinc] = sdx * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + sdx = -sdx + } + + do i = 1, npts { + + # define the fractional pixel interpolation. + nx = nint (x[i]) + ny = nint (y[i]) + if (nx < 1 || nx > len_coeff || ny < 1 || ny > len_array) { + zfit[i] = 0.0 + next + } + dx = x[i] - nx + dy = y[i] - ny + + # define pointer to data[nx,ny] + if (abs (dx) < mindx && abs (dy) < mindy) { + index = first_point + (ny - 1) * len_coeff + nx + zfit[i] = coeff[index] + next + } + + # initialize. + #dxn = -1-nsinc-dx + #dyn = -1-nsinc-dy + dxn = 1 + nsinc + dx + dyn = 1 + nsinc + dy + + # Compute the x and y sinc arrays using a cosbell taper. + sumx = 0.0 + sumy = 0.0 + do j = 1, nconv { + + #ax = j + dxn + #ay = j + dyn + ax = dxn - j + ay = dyn - j + if (ax == 0.0) + px = 1.0 + else if (dx == 0.0) + px = 0.0 + else + px = Memr[taper+j-1] / ax + if (ay == 0.0) + py = 1.0 + else if (dy == 0.0) + py = 0.0 + else + py = Memr[taper+j-1] / ay + + Memr[ac+j-1] = px + Memr[ar+j-1] = py + sumx = sumx + px + sumy = sumy + py + } + + # Compute the limits of the convolution. + minj = max (1, ny - nsinc) + maxj = min (len_array, ny + nsinc) + offj = ar - ny + nsinc + mink = max (1, nx - nsinc) + maxk = min (len_coeff, nx + nsinc) + offk = ac - nx + nsinc + + # Initialize + zfit[i] = 0.0 + + # Do the convolution. + do j = ny - nsinc, minj - 1 { + sum = 0.0 + do k = nx - nsinc, mink - 1 + sum = sum + Memr[k+offk] * coeff[first_point+1] + do k = mink, maxk + sum = sum + Memr[k+offk] * coeff[first_point+k] + do k = maxk + 1, nx + nsinc + sum = sum + Memr[k+offk] * coeff[first_point+len_coeff] + + zfit[i] = zfit[i] + Memr[j+offj] * sum + } + + do j = minj, maxj { + index = first_point + (j - 1) * len_coeff + sum = 0.0 + do k = nx - nsinc, mink - 1 + sum = sum + Memr[k+offk] * coeff[index+1] + do k = mink, maxk + sum = sum + Memr[k+offk] * coeff[index+k] + do k = maxk + 1, nx + nsinc + sum = sum + Memr[k+offk] * coeff[index+len_coeff] + + zfit[i] = zfit[i] + Memr[j+offj] * sum + } + + do j = maxj + 1, ny + nsinc { + last_point = first_point + (len_array - 1) * len_coeff + sum = 0.0 + do k = nx - nsinc, mink - 1 + sum = sum + Memr[k+offk] * coeff[last_point+1] + do k = mink, maxk + sum = sum + Memr[k+offk] * coeff[last_point+k] + do k = maxk + 1, nx + nsinc + sum = sum + Memr[k+offk] * coeff[last_point+len_coeff] + + zfit[i] = zfit[i] + Memr[j+offj] * sum + } + + # Normalize. + zfit[i] = zfit[i] / sumx / sumy + } + + call sfree (sp) +end + + +# II_BILSINC -- Procedure to evaluate the 2D sinc function. The real array +# coeff contains the data. The procedure assumes that 1 <= x <= nxpix and +# 1 <= y <= nypix and that coeff[1+first_point] = datain[1,1]. The since +# truncation length is nsinc. The taper is a cosbell function which is +# valid for 0 <= x <= PI / 2 (Abramowitz and Stegun, 1972, Dover Publications, +# p 76). If the point to be interpolated is less than mindx and mindy from +# a data point no interpolation is done and the data point is returned. This +# routine does use precomputed arrays. + +procedure ii_bilsinc (coeff, first_point, len_coeff, len_array, x, y, zfit, + npts, ltable, nconv, nxincr, nyincr, mindx, mindy) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset to first data point +int len_coeff # row length of coeff +int len_array # column length of coeff +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of interpolated values +int npts # the number of input points. +real ltable[nconv,nconv,nxincr,nyincr] # the pre-computed look-up table +int nconv # the sinc truncation full width +int nxincr # the interpolation resolution in x +int nyincr # the interpolation resolution in y +real mindx # interpolation mininmum in x +real mindy # interpolation mininmum in y + +int i, j, k, nsinc, xc, yc, lutx, luty, minj, maxj, offj, mink, maxk, offk +int index, last_point +real dx, dy, sum + +begin + nsinc = (nconv - 1) / 2 + do i = 1, npts { + + # Return zero outside of data. + xc = nint (x[i]) + yc = nint (y[i]) + if (xc < 1 || xc > len_coeff || yc < 1 || yc > len_array) { + zfit[i] = 0.0 + next + } + + dx = x[i] - xc + dy = y[i] - yc + if (abs(dx) < mindx && abs(dy) < mindy) { + index = first_point + (yc - 1) * len_coeff + xc + zfit[i] = coeff[index] + } + + # Find the correct look-up table entry. + if (nxincr == 1) + lutx = 1 + else + lutx = nint ((-dx + 0.5) * (nxincr - 1)) + 1 + #lutx = int ((-dx + 0.5) * (nxincr - 1) + 0.5) + 1 + if (nyincr == 1) + luty = 1 + else + luty = nint ((-dy + 0.5) * (nyincr - 1)) + 1 + #luty = int ((-dy + 0.5) * (nyincr - 1) + 0.5) + 1 + + # Compute the convolution limits. + minj = max (1, yc - nsinc) + maxj = min (len_array, yc + nsinc) + offj = 1 - yc + nsinc + mink = max (1, xc - nsinc) + maxk = min (len_coeff, xc + nsinc) + offk = 1 - xc + nsinc + + # Initialize + zfit[i] = 0.0 + + # Do the convolution. + do j = yc - nsinc, minj - 1 { + sum = 0.0 + do k = xc - nsinc, mink - 1 + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[first_point+1] + do k = mink, maxk + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[first_point+k] + do k = maxk + 1, xc + nsinc + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[first_point+len_coeff] + zfit[i] = zfit[i] + sum + } + + do j = minj, maxj { + index = first_point + (j - 1) * len_coeff + sum = 0.0 + do k = xc - nsinc, mink - 1 + sum = sum + ltable[k+offk,j+offj,lutx,luty] * coeff[index+1] + do k = mink, maxk + sum = sum + ltable[k+offk,j+offj,lutx,luty] * coeff[index+k] + do k = maxk + 1, xc + nsinc + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[index+len_coeff] + zfit[i] = zfit[i] + sum + } + + do j = maxj + 1, yc + nsinc { + last_point = first_point + (len_array - 1) * len_coeff + sum = 0.0 + do k = xc - nsinc, mink - 1 + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[last_point+1] + do k = mink, maxk + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[last_point+k] + do k = maxk + 1, xc + nsinc + sum = sum + ltable[k+offk,j+offj,lutx,luty] * + coeff[last_point+len_coeff] + zfit[i] = zfit[i] + sum + } + + } +end + + +# II_BIDRIZ -- Procedure to evaluate the drizzle interpolant. +# The real array coeff contains the coefficients of the 2D interpolant. +# The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix and that +# coeff[1+first_point] = datain[1,1]. Each x and y value is a set of 4 +# values describing the vertices of a quadrilateral in the input data. The +# integration routine was adapted from the one developed by Bill Sparks at +# ST and used the DITHER / DRIZZLE software. The 4 points describing the +# corners of each quadrilateral integration region must be in order, e.g. +# describe the vertices of a polygon in either CW or CCW order. + +procedure ii_bidriz (coeff, first_point, len_coeff, x, y, zfit, npts, + xfrac, yfrac, badval) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated +real xfrac, yfrac # the x and y drizzle pixel fractions +real badval # undefined pixel value + +int i, ii, jj, kk, index, nearax, nearbx, nearay, nearby +real px[5], py[5], dx, xmin, xmax, m, c, ymin, ymax, xtop +real ovlap, accum, waccum, dxfrac, dyfrac, hxfrac, hyfrac, dhxfrac, dhyfrac +bool negdx + +begin + dxfrac = max (0.0, min (1.0, 1.0 - xfrac)) + hxfrac = max (0.0, min (0.5, dxfrac / 2.0)) + dhxfrac = max (0.5, min (1.0, 1.0 - hxfrac)) + dyfrac = max (0.0, min (1.0, 1.0 - yfrac)) + hyfrac = max (0.0, min (0.5, dyfrac / 2.0)) + dhyfrac = max (0.5, min (1.0, 1.0 - hyfrac)) + + do i = 1, npts { + + # Compute the limits of the integration in x and y. + nearax = nint (min (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearbx = nint (max (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearay = nint (min (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + nearby = nint (max (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + + # Initialize. + accum = 0.0 + waccum = 0.0 + + # Loop over all pixels which contribute to the integral. + do jj = nearay, nearby { + index = first_point + (jj - 1) * len_coeff + do kk = 1, 4 + py[kk] = y[4*i+kk-4] - jj + 0.5 + py[5] = py[1] + do ii = nearax, nearbx { + + # Transform the coordinates relative to a unit + # square centered at the origin of the pixel. We + # are going to approximate the new pixel area by + # a quadilateral. Close the quadilateral. + + do kk = 1, 4 + px[kk] = x[4*i+kk-4] - ii + 0.5 + px[5] = px[1] + + # Compute the area overlap of the output pixel with + # the input pixels. + ovlap = 0.0 + do kk = 1, 4 { + + # Check for vertical line segment. + dx = px[kk+1] - px[kk] + if (dx == 0.0) + next + + # Order the x integration limits. + if (px[kk] < px[kk+1]) { + xmin = px[kk] + xmax = px[kk+1] + } else { + xmin = px[kk+1] + xmax = px[kk] + } + + # Check the x limits ignoring y for now. + if ((xmin >= dhxfrac) || (xmax <= hxfrac)) + next + xmin = max (xmin, hxfrac) + xmax = min (xmax, dhxfrac) + + # Get basic info about the line y = mx + c. + if (dx < 0.0) + negdx = true + else + negdx = false + m = (py[kk+1] - py[kk]) / dx + c = py[kk] - m * px[kk] + ymin = m * xmin + c + ymax = m * xmax + c + + # Trap segment entirely below axis. + if (ymin <= hyfrac && ymax <= hyfrac) + next + + # Adjust bounds if segment crosses axis in order + # to exclude anything below the axis. + if (ymin < hyfrac) { + ymin = hyfrac + xmin = (hyfrac - c) / m + } + if (ymax < hyfrac) { + ymax = hyfrac + xmax = (hyfrac - c) / m + } + + # There are four possibilities. + + # Both y above 1.0 - hyfrac. Line segment is entirely + # above square. + if ((ymin >= dhyfrac) && (ymax >= dhyfrac)) { + + if (negdx) + ovlap = ovlap + (xmin - xmax) * yfrac + else + ovlap = ovlap + (xmax - xmin) * yfrac + + # Both y below 1.0 - hyfrac. Segment is entirely + # within square. + } else if ((ymin <= dhyfrac) && (ymax <= dhyfrac)) { + + if (negdx) + ovlap = ovlap + 0.5 * (xmin - xmax) * + (ymax + ymin - dyfrac) + else + ovlap = ovlap + 0.5 * (xmax - xmin) * + (ymax + ymin - dyfrac) + + # One of each. Segment must cross top of square. + } else { + + xtop = (dhyfrac - c) / m + + # insert precision check ? + + if (ymin < dhyfrac) { + if (negdx) + ovlap = ovlap - (0.5 * (xtop - xmin) * + (ymin + 1.0 - 3.0 * hyfrac) + + (xmax - xtop) * yfrac) + else + ovlap = ovlap + (0.5 * (xtop - xmin) * + (ymin + 1.0 - 3.0 * hyfrac) + + (xmax - xtop) * yfrac) + } else { + if (negdx) + ovlap = ovlap - (0.5 * (xmax - xtop) * + (ymax + 1.0 - 3.0 * hyfrac) + + (xtop - xmin) * yfrac) + else + ovlap = ovlap + (0.5 * (xmax - xtop) * + (ymax + 1.0 - 3.0 * hyfrac) + + (xtop - xmin) * yfrac) + } + + } + } + + accum = accum + coeff[index+ii] * ovlap + waccum = waccum + ovlap + } + } + + if (waccum == 0.0) + zfit[i] = badval + else + zfit[i] = accum / waccum + } +end + + +# II_BIDRIZ1 -- Procedure to evaluate the drizzle interpolant when xfrac and +# yfrac are 1.0. The real array coeff contains the coefficients of the 2D +# interpolant. The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = datain[1,1]. Each x and y point is a set of 4 +# values describing the vertices of a quadrilateral in the input data. The +# integration routine was adapted from the one developed by Bill Sparks at +# ST and used the DITHER / DRIZZLE software. The 4 points describing the +# corners of each quadrilateral integration region must be in order, e.g. +# describe the vertices of a polygon in either CW or CCW order. + +procedure ii_bidriz1 (coeff, first_point, len_coeff, x, y, zfit, npts, badval) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated +real badval # undefined pixel value + +int i, ii, jj, kk, index, nearax, nearbx, nearay, nearby +real px[5], py[5], dx, xmin, xmax, m, c, ymin, ymax, xtop +real ovlap, accum, waccum +bool negdx + +begin + do i = 1, npts { + + # Compute the limits of the integration in x and y. + nearax = nint (min (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearbx = nint (max (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearay = nint (min (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + nearby = nint (max (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + + # Initialize. + accum = 0.0 + waccum = 0.0 + + # Loop over all pixels which contribute to the integral. + do jj = nearay, nearby { + index = first_point + (jj - 1) * len_coeff + do kk = 1, 4 + py[kk] = y[4*i+kk-4] - jj + 0.5 + py[5] = py[1] + do ii = nearax, nearbx { + + # Transform the coordinates relative to a unit + # square centered at the origin of the pixel. We + # are going to approximate the new pixel area by + # a quadilateral. Close the polygon. + + do kk = 1, 4 + px[kk] = x[4*i+kk-4] - ii + 0.5 + px[5] = px[1] + + # Compute the area overlap of the output pixel with + # the input pixels. + ovlap = 0.0 + do kk = 1, 4 { + + # Check for vertical line segment. + dx = px[kk+1] - px[kk] + if (dx == 0.0) + next + + # Order the x integration limits. + if (px[kk] < px[kk+1]) { + xmin = px[kk] + xmax = px[kk+1] + } else { + xmin = px[kk+1] + xmax = px[kk] + } + + # Check the x limits ignoring y for now. + if (xmin >= 1.0 || xmax <= 0.0) + next + xmin = max (xmin, 0.0) + xmax = min (xmax, 1.0) + + # Get basic info about the line y = mx + c. + if (dx < 0.0) + negdx = true + else + negdx = false + m = (py[kk+1] - py[kk]) / dx + c = py[kk] - m * px[kk] + ymin = m * xmin + c + ymax = m * xmax + c + + # Trap segment entirely below axis. + if (ymin <= 0.0 && ymax <= 0.0) + next + + # Adjust bounds if segment crosses axis in order + # to exclude anything below the axis. + if (ymin < 0.0) { + ymin = 0.0 + xmin = - c / m + } + if (ymax < 0.0) { + ymax = 0.0 + xmax = - c / m + } + + # There are four possibilities. + + # Both y above 1.0. Line segment is entirely above + # square. + if (ymin >= 1.0 && ymax >= 1.0) { + + if (negdx) + ovlap = ovlap + (xmin - xmax) + else + ovlap = ovlap + (xmax - xmin) + + # Both y below 1.0. Segment is entirely within square. + } else if (ymin <= 1.0 && ymax <= 1.0) { + + if (negdx) + ovlap = ovlap + 0.5 * (xmin - xmax) * + (ymax + ymin) + else + ovlap = ovlap + 0.5 * (xmax - xmin) * + (ymax + ymin) + + # One of each. Segment must cross top of square. + } else { + + xtop = (1.0 - c) / m + + # insert precision check, e.g. possible pixel + # overlap ? need to decide what action to take ... + + if (ymin < 1.0) { + if (negdx) + ovlap = ovlap - (0.5 * (xtop - xmin) * + (1.0 + ymin) + (xmax - xtop)) + else + ovlap = ovlap + (0.5 * (xtop - xmin) * + (1.0 + ymin) + (xmax - xtop)) + } else { + if (negdx) + ovlap = ovlap - (0.5 * (xmax - xtop) * + (1.0 + ymax) + (xtop - xmin)) + else + ovlap = ovlap + (0.5 * (xmax - xtop) * + (1.0 + ymax) + (xtop - xmin)) + } + + } + } + + accum = accum + coeff[index+ii] * ovlap + waccum = waccum + ovlap + } + } + + if (waccum == 0.0) + zfit[i] = badval + else + zfit[i] = accum / waccum + } +end + + +# II_BIDRIZ0-- Procedure to evaluate the drizzle interpolant when xfrac and +# yfrac are 0.0. The real array coeff contains the coefficients of the 2D +# interpolant. The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix +# and that coeff[1+first_point] = datain[1,1]. Each x and y point is a set of 4 +# values describing the vertices of a quadrilateral in the input data. The +# integration routine determines whether a pixel is in, out, on the edge +# of or at a vertex of a polygon. The 4 points describing the corners of +# each quadrilateral integration region must be in order, e.g. describe +# the vertices of a polygon in either CW or CCW order. +# THIS ROUTINE IS NOT CURRENTLY BEING USED. + +procedure ii_bidriz0 (coeff, first_point, len_coeff, x, y, zfit, npts, badval) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated +real badval # the undefined pixel value + +bool boundary, vertex +int i, jj, ii, kk, nearax, nearbx, nearay, nearby, ninter +real accum, waccum, px[5], py[5], lx, ld, u1, u2, u1u2, dx, dy, dd +real xi, ovlap, xmin, xmax + +begin + do i = 1, npts { + + # Compute the limits of the integration in x and y. + nearax = nint (min (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearbx = nint (max (x[4*i-3], x[4*i-2], x[4*i-1], x[4*i])) + nearay = nint (min (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + nearby = nint (max (y[4*i-3], y[4*i-2], y[4*i-1], y[4*i])) + + # Initialize. + accum = 0.0 + waccum = 0.0 + + # Loop over all pixels which contribute to the integral. + do jj = nearay, nearby { + do ii = nearax, nearbx { + + # Transform the coordinates relative to a unit + # square centered at the origin of the pixel. We + # are going to approximate the new pixel area by + # a quadilateral. Close the quadrilateral. + + do kk = 1, 4 { + px[kk] = x[4*i+kk-4] - ii + 0.5 + py[kk] = y[4*i+kk-4] - jj + 0.5 + } + px[5] = px[1] + py[5] = py[1] + + # Initialize the integration. + ovlap = 0.0 + ninter = 0 + + # Define a line segment which begins at the point x = 0.5 + # y = 0.5 and runs parallel to the y axis. + call alimr (px, 5, xmin, xmax) + lx = xmax - xmin + ld = 0.5 * lx + u1 = -lx * py[1] + ld + boundary = false + vertex = false + do kk = 2, 5 { + + u2 = -lx * py[kk] + ld + u1u2 = u1 * u2 + + # No intersection. + if (u1*u2 > 0.0) { + ; + + # Intersection with polygon line segment. + } else if (u1 != 0.0 && u2 != 0.0) { + dy = py[kk-1] - py[kk] + dx = px[kk-1] - px[kk] + dd = px[kk-1] * py[kk] - py[kk-1] * px[kk] + xi = (dx * ld - lx * dd) / (dy * lx) + if (xi > 0.5) + ninter = ninter + 1 + if (xi == 0.5) + boundary = true + + # Collinearity. + } else if (u1 == 0.0 && u2 == 0.0) { + xmin = min (px[kk-1], px[kk]) + xmax = max (px[kk-1], px[kk]) + if (xmin == 0.5 || xmax == 0.5) + vertex = true + else if (xmin < 0.5 && xmax > 0.5) + boundary = true + + # Vertex. + } else if (u1 != 0.0) { + if (px[kk] == 0.5) + vertex = true + } + + u1 = u2 + } + + if (vertex) + ovlap = 0.25 + else if (boundary) + ovlap = 0.5 + else if (mod (ninter, 2) == 0) + ovlap = 0.0 + else + ovlap = 1.0 + waccum = waccum + ovlap + accum = accum + ovlap * + coeff[first_point+(jj-1)*len_coeff+ii] + } + } + + if (waccum == 0.0) + zfit[i] = badval + else + zfit[i] = accum / waccum + } + +end diff --git a/math/iminterp/ii_cubspl.f b/math/iminterp/ii_cubspl.f new file mode 100644 index 00000000..29407862 --- /dev/null +++ b/math/iminterp/ii_cubspl.f @@ -0,0 +1,119 @@ + subroutine iicbsp (tau, c, n, ibcbeg, ibcend) +c from * a practical guide to splines * by c. de boor +c ************************ input *************************** +c n = number of data points. assumed to be .ge. 2. +c (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the +c data points. tau is assumed to be strictly increasing. +c ibcbeg, ibcend = boundary condition indicators, and +c c(2,1), c(2,n) = boundary condition information. specifically, +c ibcbeg = 0 means no boundary condition at tau(1) is given. +c in this case, the not-a-knot condition is used, i.e. the +c jump in the third derivative across tau(2) is forced to +c zero, thus the first and the second cubic polynomial pieces +c are made to coincide.) +c ibcbeg = 1 means that the slope at tau(1) is made to equal +c c(2,1), supplied by input. +c ibcbeg = 2 means that the second derivative at tau(1) is +c made to equal c(2,1), supplied by input. +c ibcend = 0, 1, or 2 has analogous meaning concerning the +c boundary condition at tau(n), with the additional infor- +c mation taken from c(2,n). +c *********************** output ************************** +c c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients +c of the cubic interpolating spline with interior knots (or +c joints) tau(2), ..., tau(n-1). precisely, in the interval +c interval (tau(i), tau(i+1)), the spline f is given by +c f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) +c where h = x - tau(i). the function program *ppvalu* may be +c used to evaluate f or its derivatives from tau,c, l = n-1, +c and k=4. + integer ibcbeg,ibcend,n, i,j,l,m + real c(4,n),tau(n), divdf1,divdf3,dtau,g +c****** a tridiagonal linear system for the unknown slopes s(i) of +c f at tau(i), i=1,...,n, is generated and then solved by gauss elim- +c ination, with s(i) ending up in c(2,i), all i. +c c(3,.) and c(4,.) are used initially for temporary storage. + l = n-1 +compute first differences of tau sequence and store in c(3,.). also, +compute first divided difference of data and store in c(4,.). + do 10 m=2,n + c(3,m) = tau(m) - tau(m-1) + 10 c(4,m) = (c(1,m) - c(1,m-1))/c(3,m) +construct first equation from the boundary condition, of the form +c c(4,1)*s(1) + c(3,1)*s(2) = c(2,1) + if (ibcbeg-1) 11,15,16 + 11 if (n .gt. 2) go to 12 +c no condition at left end and n = 2. + c(4,1) = 1. + c(3,1) = 1. + c(2,1) = 2.*c(4,2) + go to 25 +c not-a-knot condition at left end and n .gt. 2. + 12 c(4,1) = c(3,3) + c(3,1) = c(3,2) + c(3,3) + c(2,1) =((c(3,2)+2.*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1) + go to 19 +c slope prescribed at left end. + 15 c(4,1) = 1. + c(3,1) = 0. + go to 18 +c second derivative prescribed at left end. + 16 c(4,1) = 2. + c(3,1) = 1. + c(2,1) = 3.*c(4,2) - c(3,2)/2.*c(2,1) + 18 if(n .eq. 2) go to 25 +c if there are interior knots, generate the corresp. equations and car- +c ry out the forward pass of gauss elimination, after which the m-th +c equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m). + 19 do 20 m=2,l + g = -c(3,m+1)/c(4,m-1) + c(2,m) = g*c(2,m-1) + 3.*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m)) + 20 c(4,m) = g*c(3,m-1) + 2.*(c(3,m) + c(3,m+1)) +construct last equation from the second boundary condition, of the form +c (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n) +c if slope is prescribed at right end, one can go directly to back- +c substitution, since c array happens to be set up just right for it +c at this point. + if (ibcend-1) 21,30,24 + 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22 +c not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at +c left end point. + g = c(3,n-1) + c(3,n) + c(2,n) = ((c(3,n)+2.*g)*c(4,n)*c(3,n-1) + * + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g + g = -g/c(4,n-1) + c(4,n) = c(3,n-1) + go to 29 +c either (n=3 and not-a-knot also at left) or (n=2 and not not-a- +c knot at left end point). + 22 c(2,n) = 2.*c(4,n) + c(4,n) = 1. + go to 28 +c second derivative prescribed at right endpoint. + 24 c(2,n) = 3.*c(4,n) + c(3,n)/2.*c(2,n) + c(4,n) = 2. + go to 28 + 25 if (ibcend-1) 26,30,24 + 26 if (ibcbeg .gt. 0) go to 22 +c not-a-knot at right endpoint and at left endpoint and n = 2. + c(2,n) = c(4,n) + go to 30 + 28 g = -1./c(4,n-1) +complete forward pass of gauss elimination. + 29 c(4,n) = g*c(3,n-1) + c(4,n) + c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n) +carry out back substitution + 30 j = l + 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j) + j = j - 1 + if (j .gt. 0) go to 40 +c****** generate cubic coefficients in each interval, i.e., the deriv.s +c at its left endpoint, from value and slope at its endpoints. + do 50 i=2,n + dtau = c(3,i) + divdf1 = (c(1,i) - c(1,i-1))/dtau + divdf3 = c(2,i-1) + c(2,i) - 2.*divdf1 + c(3,i-1) = 2.*(divdf1 - c(2,i-1) - divdf3)/dtau + 50 c(4,i-1) = (divdf3/dtau)*(6./dtau) + return + end diff --git a/math/iminterp/ii_eval.x b/math/iminterp/ii_eval.x new file mode 100644 index 00000000..2e4cbb37 --- /dev/null +++ b/math/iminterp/ii_eval.x @@ -0,0 +1,430 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# II_NEAREST -- Procedure to evaluate the nearest neighbour interpolant. + +procedure ii_nearest (x, y, npts, data) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated + +int i + +begin + do i = 1, npts + y[i] = data[int(x[i] + 0.5)] +end + + +# II_LINEAR -- Procedure to evaluate the linear interpolant. + +procedure ii_linear (x, y, npts, data) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated + +int i, nx + +begin + do i = 1, npts { + nx = x[i] + y[i] = (x[i] - nx) * data[nx + 1] + (nx + 1 - x[i]) * data[nx] + } +end + + +# II_POLY3 -- Procedure to evaluate the cubic polynomial interpolant. + +procedure ii_poly3 (x, y, npts, data) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated from a[0] to a[npts+2] + +int i, nx, nxold +real deltax, deltay, cd20, cd21 + +begin + nxold = -1 + do i = 1, npts { + nx = x[i] + deltax = x[i] - nx + deltay = 1. - deltax + + if (nx != nxold) { + # second central differences: + cd20 = 1./6. * (data[nx+1] - 2. * data[nx] + data[nx-1]) + cd21 = 1./6. * (data[nx+2] - 2. * data[nx+1] + data[nx]) + nxold = nx + } + + y[i] = deltax * (data[nx+1] + (deltax * deltax - 1.) * cd21) + + deltay * (data[nx] + (deltay * deltay - 1.) * cd20) + } +end + + +# II_POLY5 -- Procedure to evaluate the fifth order polynomial interpolant. + +procedure ii_poly5 (x, y, npts, data) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated - from a[-1] to a[npts+3] + +int i, nx, nxold +real deltax, deltay, cd20, cd21, cd40, cd41 + +begin + nxold = -1 + do i = 1, npts { + nx = x[i] + deltax = x[i] - nx + deltay = 1. - deltax + + if (nx != nxold) { + cd20 = 1./6. * (data[nx+1] - 2. * data[nx] + data[nx-1]) + cd21 = 1./6. * (data[nx+2] - 2. * data[nx+1] + data[nx]) + # fourth central differences + cd40 = 1./120. * (data[nx-2] - 4. * data[nx-1] + + 6. * data[nx] - 4. * data[nx+1] + data[nx+2]) + cd41 = 1./120. * (data[nx-1] - 4. * data[nx] + + 6. * data[nx+1] - 4. * data[nx+2] + data[nx+3]) + nxold = nx + } + + y[i] = deltax * (data[nx+1] + (deltax * deltax - 1.) * + (cd21 + (deltax * deltax - 4.) * cd41)) + + deltay * (data[nx] + (deltay * deltay - 1.) * + (cd20 + (deltay * deltay - 4.) * cd40)) + } +end + + +# II_SPLINE3 -- Procedure to evaluate the cubic spline interpolant. + +procedure ii_spline3 (x, y, npts, bcoeff) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real bcoeff[ARB] # basis spline coefficients - from a[0] to a[npts+1] + +int i, nx, nxold +real deltax, c0, c1, c2, c3 + +begin + nxold = -1 + do i = 1, npts { + nx = x[i] + deltax = x[i] - nx + + if (nx != nxold) { + # convert b-spline coeff's to poly. coeff's + c0 = bcoeff[nx-1] + 4. * bcoeff[nx] + bcoeff[nx+1] + c1 = 3. * (bcoeff[nx+1] - bcoeff[nx-1]) + c2 = 3. * (bcoeff[nx-1] - 2. * bcoeff[nx] + bcoeff[nx+1]) + c3 = -bcoeff[nx-1] + 3. * bcoeff[nx] - 3. * bcoeff[nx+1] + + bcoeff[nx+2] + nxold = nx + } + + y[i] = c0 + deltax * (c1 + deltax * (c2 + deltax * c3)) + } +end + + +# II_SINC -- Procedure to evaluate the sinc interpolant. The sinc +# truncation length is nsinc. The taper is a cosbell function which is +# approximated by a quartic polynomial which is valid for 0 <= x <= PI / 2 +# (Abramowitz and Stegun, 1972, Dover Publications, p 76). If the point to +# be interpolated is less than mindx from a data point no interpolation is +# done and the data point itself is returned. + +procedure ii_sinc (x, y, npts, data, npix, nsinc, mindx) + +real x[ARB] # x values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated +int npix # number of data pixels +int nsinc # sinc truncation length +real mindx # interpolation minimum + +int i, j, xc, minj, maxj, offj +pointer sp, taper +real dx, dxn, dx2, w1, sconst, a2, a4, sum, sumw + +begin + # Compute the constants for the cosine bell taper. + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + + # Pre-compute the taper array. Incorporate the sign change portion + # of the sinc interpolator into the taper array. + call smark (sp) + call salloc (taper, 2 * nsinc + 1, TY_REAL) + if (mod (nsinc, 2) == 0) + w1 = 1.0 + else + w1 = -1.0 + do j = -nsinc, nsinc { + dx2 = sconst * j * j + Memr[taper+j+nsinc] = w1 * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + w1 = -w1 + } + + do i = 1, npts { + + # Return zero outside of data. + xc = nint (x[i]) + if (xc < 1 || xc > npix) { + y[i] = 0. + next + } + + # Return the data value if x is too close to x[i]. + dx = x[i] - xc + if (abs (dx) < mindx) { + y[i] = data[xc] + next + } + + # Compute the limits of the true convolution. + minj = max (1, xc - nsinc) + maxj = min (npix, xc + nsinc) + offj = -xc + nsinc + + # Do the convolution. + sum = 0.0 + sumw = 0.0 + dxn = dx + xc + do j = xc - nsinc, minj - 1 { + w1 = Memr[taper+j+offj] / (dxn - j) + sum = sum + w1 * data[1] + sumw = sumw + w1 + } + do j = minj, maxj { + w1 = Memr[taper+j+offj] / (dxn - j) + sum = sum + w1 * data[j] + sumw = sumw + w1 + } + do j = maxj + 1, xc + nsinc { + w1 = Memr[taper+j+offj] / (dxn - j) + sum = sum + w1 * data[npix] + sumw = sumw + w1 + } + + # Compute value. + y[i] = sum / sumw + } + + call sfree (sp) +end + + +# II_LSINC -- Procedure to evaluate the sinc interpolant using a +# precomputed look-up table. The sinc truncation length is nsinc. The taper +# is a cosbell function which is approximated by a quartic polynomial which +# is valid for 0 <= x <= PI / 2 (Abramowitz and Stegun, 1972, Dover +# Publications, p 76). If the point to be interpolated is less than mindx +# from a data point no interpolation is done and the data point itself is +# returned. + +procedure ii_lsinc (x, y, npts, data, npix, ltable, nconv, nincr, mindx) + +real x[ARB] # x values, must be within [1,npix] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated +int npix # number of data pixels +real ltable[nconv,nincr] # the sinc look-up table +int nconv # sinc truncation length +int nincr # the number of look-up table entries +real mindx # interpolation minimum (don't use) + +int i, j, nsinc, xc, lut, minj, maxj, offj +real dx, sum + +begin + nsinc = (nconv - 1) / 2 + do i = 1, npts { + + # Return zero outside of data. + xc = nint (x[i]) + if (xc < 1 || xc > npix) { + y[i] = 0. + next + } + + # Return data point if dx is too small. + dx = x[i] - xc + if (abs (dx) < mindx) { + y[i] = data[xc] + next + } + + # Find the correct look-up table entry. + if (nincr == 1) + lut = 1 + else + lut = nint ((-dx + 0.5) * (nincr - 1)) + 1 + #lut = int ((-dx + 0.5) * (nincr - 1) + 0.5) + 1 + + # Compute the convolution limits. + minj = max (1, xc - nsinc) + maxj = min (npix, xc + nsinc) + offj = -xc + nsinc + 1 + + # Do the convolution. + sum = 0.0 + do j = xc - nsinc, minj - 1 + sum = sum + ltable[j+offj,lut] * data[1] + do j = minj, maxj + sum = sum + ltable[j+offj,lut] * data[j] + do j = maxj + 1, xc + nsinc + sum = sum + ltable[j+offj,lut] * data[npix] + + # Compute the value. + y[i] = sum + } +end + + +# II_DRIZ -- Procedure to evaluate the drizzle interpolant. + +procedure ii_driz (x, y, npts, data, pixfrac, badval) + +real x[ARB] # x start and stop values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated +real pixfrac # the drizzle pixel fraction +real badval # value for undefined pixels + +int i, j, neara, nearb +real hpixfrac, xa, xb, dx, accum, waccum + +begin + hpixfrac = pixfrac / 2.0 + do i = 1, npts { + + # Define the interval of integration. + xa = min (x[2*i-1], x[2*i]) + xb = max (x[2*i-1], x[2*i]) + neara = xa + 0.5 + nearb = xb + 0.5 + + # Initialize the integration + accum = 0.0 + waccum = 0.0 + if (neara == nearb) { + + dx = min (xb, nearb + hpixfrac) - max (xa, neara - hpixfrac) + + if (dx > 0.0) { + accum = accum + dx * data[neara] + waccum = waccum + dx + } + + } else { + + # first segement + dx = neara + hpixfrac - max (xa, neara - hpixfrac) + + if (dx > 0.0) { + accum = accum + dx * data[neara] + waccum = waccum + dx + } + + # interior segments. + do j = neara + 1, nearb - 1 { + accum = accum + pixfrac * data[j] + waccum = waccum + pixfrac + } + + # last segment + dx = min (xb, nearb + hpixfrac) - (nearb - hpixfrac) + + if (dx > 0.0) { + accum = accum + dx * data[nearb] + waccum = waccum + dx + } + } + + if (waccum == 0.0) + y[i] = badval + else + y[i] = accum / waccum + } +end + + +# II_DRIZ1 -- Procedure to evaluate the drizzle interpolant in the case where +# pixfrac = 1.0. + +procedure ii_driz1 (x, y, npts, data, badval) + +real x[ARB] # x start and stop values, must be within [1,npts] +real y[ARB] # interpolated values returned to user +int npts # number of x values +real data[ARB] # data to be interpolated +real badval # undefined pixel value + +int i, j, neara, nearb +real xa, xb, deltaxa, deltaxb, dx, accum, waccum + +begin + do i = 1, npts { + + # Define the interval of integration. + xa = min (x[2*i-1], x[2*i]) + xb = max (x[2*i-1], x[2*i]) + neara = xa + 0.5 + nearb = xb + 0.5 + deltaxa = xa - neara + deltaxb = xb - nearb + + # Only one segment involved. + accum = 0.0 + waccum = 0.0 + if (neara == nearb) { + + dx = deltaxb - deltaxa + accum = accum + dx * data[neara] + waccum = waccum + dx + + } else { + + # First segment. + dx = 0.5 - deltaxa + accum = accum + dx * data[neara] + waccum = waccum + dx + + # Middle segment. + do j = neara + 1, nearb - 1 { + accum = accum + data[j] + waccum = waccum + 1.0 + } + + # Last segment. + dx = deltaxb + 0.5 + accum = accum + dx * data[nearb] + waccum = waccum + dx + } + + if (waccum == 0.0) + y[i] = badval + else + y[i] = accum / waccum + } +end diff --git a/math/iminterp/ii_greval.x b/math/iminterp/ii_greval.x new file mode 100644 index 00000000..6b5d75b2 --- /dev/null +++ b/math/iminterp/ii_greval.x @@ -0,0 +1,859 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# II_GRNEAREST -- Procedure to evaluate the nearest neighbour interpolant on +# a rectangular grid. The procedure assumes that 1 <= x <= nxpix and +# that 1 <= y <= nypix. The x and y vectors must be sorted in increasing +# value of x and y such that x[i] < x[i+1] and y[i] < y[i+1]. The routine +# outputs a grid of nxpix by nypix points using the coeff array where +# coeff[1+first_point] = datain[1,1] + +procedure ii_grnearest (coeff, first_point, len_coeff, x, y, zfit, nxpts, + nypts, len_zfit) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolatedvalues +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit + +int ny +int index +int i, j +pointer sp, nx + +errchk smark, salloc, sfree + +begin + call smark (sp) + call salloc (nx, nxpts, TY_INT) + + # calculate the nearest x + do i = 1, nxpts + Memi[nx+i-1] = x[i] + 0.5 + + # loop over the rows + do j = 1, nypts { + + # calculate pointer to the ny-th row of data + ny = y[j] + 0.5 + index = first_point + (ny - 1) * len_coeff + + # loop over the columns + do i = 1, nxpts + zfit[i,j] = coeff[index + Memi[nx+i-1]] + } + + call sfree (sp) +end + + +# II_GRLINEAR -- Procedure to evaluate the bilinear interpolant +# on a rectangular grid. The procedure assumes that 1 <= x <= nxpix and that +# 1 <= y <= nypix. The x and y vectors are assumed to be sorted in increasing +# order of x and y such that x[i] < x[i+1] and y[i] < y[i+1]. The routine +# produces a grid of nxpix * nypix evaluated points using the coeff array +# where coeff[1+first_point] = datain[1,1]. + +procedure ii_grlinear (coeff, first_point, len_coeff, x, y, zfit, nxpts, + nypts, len_zfit) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolated values +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit + +int i, j, ny +int nymin, nymax, nylines +int row_index, xindex +pointer sp, nx, sx, tx, work, lbuf1, lbuf2 +real sy, ty + +errchk smark, salloc, sfree + +begin + # calculate the x and y limits + nymin = y[1] + nymax = int (y[nypts]) + 1 + nylines = nymax - nymin + 1 + + # allocate storage for work array + call smark (sp) + call salloc (nx, nxpts, TY_INT) + call salloc (sx, nxpts, TY_REAL) + call salloc (tx, nxpts, TY_REAL) + call salloc (work, nxpts * nylines, TY_REAL) + + # initialize + call achtri (x, Memi[nx], nxpts) + do i = 1, nxpts { + Memr[sx+i-1] = x[i] - Memi[nx+i-1] + Memr[tx+i-1] = 1. - Memr[sx+i-1] + } + + # for each value of y interpolate in x and store in work array + lbuf1 = work + do j = 1, nylines { + + # define pointer to appropriate row + row_index = first_point + (j + nymin - 2) * len_coeff + + # interpolate in x at each y + do i = 1, nxpts { + xindex = row_index + Memi[nx+i-1] + Memr[lbuf1+i-1] = Memr[tx+i-1] * coeff[xindex] + + Memr[sx+i-1] * coeff[xindex+1] + } + + lbuf1 = lbuf1 + nxpts + } + + # at each x interpolate in y and store in temporary work array + do j = 1, nypts { + + ny = y[j] + sy = y[j] - ny + ty = 1. - sy + + lbuf1 = work + nxpts * (ny - nymin) + lbuf2 = lbuf1 + nxpts + + call awsur (Memr[lbuf1], Memr[lbuf2], zfit[1,j], nxpts, + ty, sy) + + } + + # deallocate work space + call sfree (sp) +end + + +# II_GRPOLY3 -- Procedure to evaluate the bicubic polynomial interpolant +# on a rectangular grid. The points to be evaluated are assumed +# to lie in the range 1 <= x <= nxpix and 1 <= y <= nypix. The x and y vectors +# are assumed to be sorted in increasing order of x and y such that +# x[i] < x[i+1] and y[i] < y[i+1]. The interpolation is done using +# Everett's central difference formula and separation of variables +# and assuming that coeff[1+first_point] = datain[1,1]. + +procedure ii_grpoly3 (coeff, first_point, len_coeff, x, y, zfit, nxpts, nypts, + len_zfit) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset of first data point +int len_coeff # length of row of coeffcient +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolatedvalues +int nxpts # number of x points +int nypts # number of y points +int len_zfit # row length of zfit + +int nymin, nymax, nylines +int nxold, nyold +int row_index, xindex +int i, j, ny +pointer sp, nx, sx, sx2m1, tx, tx2m1, work +pointer lbuf, lbufp1, lbufp2, lbufm1 +real cd20x, cd21x, cd20y, cd21y +real sy, ty, sy2m1, ty2m1 + +errchk smark, salloc, sfree + +begin + # find y limits + nymin = int (y[1]) - 1 + nymax = int (y[nypts]) + 2 + nylines = nymax - nymin + 1 + + # allocate work space + call smark (sp) + call salloc (nx, nxpts, TY_INT) + call salloc (sx, nxpts, TY_REAL) + call salloc (sx2m1, nxpts, TY_REAL) + call salloc (tx, nxpts, TY_REAL) + call salloc (tx2m1, nxpts, TY_REAL) + call salloc (work, nxpts * nylines, TY_REAL) + + # initialize + call achtri (x, Memi[nx], nxpts) + do i = 1, nxpts { + Memr[sx+i-1] = x[i] - Memi[nx+i-1] + Memr[sx2m1+i-1] = Memr[sx+i-1] * Memr[sx+i-1] - 1. + Memr[tx+i-1] = 1. - Memr[sx+i-1] + Memr[tx2m1+i-1] = Memr[tx+i-1] * Memr[tx+i-1] - 1. + } + + # for each value of y interpolate in x + lbuf = work + do j = 1, nylines { + + # calculate pointer to a row + row_index = first_point + (j + nymin - 2) * len_coeff + + # interpolate in x at each y + nxold = -1 + do i = 1, nxpts { + + xindex= row_index + Memi[nx+i-1] + + if (Memi[nx+i-1] != nxold) { + #cd20x = 1./6. * (coeff[xindex+1] - 2. * coeff[xindex] + + #coeff[xindex-1]) + #cd21x = 1./6. * (coeff[xindex+2] - 2. * coeff[xindex+1] + + #coeff[xindex]) + cd20x = (coeff[xindex+1] - 2. * coeff[xindex] + + coeff[xindex-1]) / 6. + cd21x = (coeff[xindex+2] - 2. * coeff[xindex+1] + + coeff[xindex]) / 6.0 + } + + Memr[lbuf+i-1] = Memr[sx+i-1] * (coeff[xindex+1] + + Memr[sx2m1+i-1] * cd21x) + + Memr[tx+i-1] * (coeff[xindex] + + Memr[tx2m1+i-1] * cd20x) + + nxold = Memi[nx+i-1] + } + + lbuf = lbuf + nxpts + } + + # interpolate in y at each x + nyold = -1 + do j = 1, nypts { + + ny = y[j] + sy = y[j] - ny + ty = 1. - sy + sy2m1 = sy ** 2 - 1. + ty2m1 = ty ** 2 - 1. + + lbuf = work + nxpts * (ny - nymin) + lbufm1 = lbuf - nxpts + lbufp1 = lbuf + nxpts + lbufp2 = lbufp1 + nxpts + + do i = 1, nxpts { + + # calculate central differences in y + #if (nyold != ny) { + #cd20y = 1./6. * (Memr[lbufp1+i-1] - 2. * Memr[lbuf+i-1] + + #Memr[lbufm1+i-1]) + #cd21y = 1./6. * (Memr[lbufp2+i-1] - 2. * + #Memr[lbufp1+i-1] + Memr[lbuf+i-1]) + cd20y = (Memr[lbufp1+i-1] - 2. * Memr[lbuf+i-1] + + Memr[lbufm1+i-1]) / 6.0 + cd21y = (Memr[lbufp2+i-1] - 2. * Memr[lbufp1+i-1] + + Memr[lbuf+i-1]) / 6.0 + #} + + # interpolate in y + zfit[i,j] = sy * (Memr[lbufp1+i-1] + sy2m1 * cd21y) + + ty * (Memr[lbuf+i-1] + ty2m1 * cd20y) + + } + + #nyold = ny + } + + # free work space + call sfree (sp) +end + + +# II_GRPOLY5 -- Procedure to evaluate the biquintic polynomial interpolant +# on a rectangular grid. The routine assumes that 1 <= x <= nxpix and +# 1 <= y <= nypix. The vectors x and y are assumed to be sorted in +# increasing order such that x[i] < x[i+1] and y[i] < y[i+1]. The +# interpolation is done using Everett's interpolation formula and +# separation of variables and assuming that coeff[1+first_point] = +# datain[1,1]. + +procedure ii_grpoly5 (coeff, first_point, len_coeff, x, y, zfit, nxpts, + nypts, len_zfit) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of fitted values +int nxpts # number of x points +int nypts # number of y points +int len_zfit # row length of zfit + +int nymax, nymin, nylines, nxold, nyold +int row_index, xindex +int i, j, ny +pointer sp, nx, sx, tx, sx2m1, sx2m4, tx2m1, tx2m4, work +pointer lbuf, lbufp1, lbufp2, lbufp3, lbufm1, lbufm2 +real cd20x, cd21x, cd40x, cd41x +real cd20y, cd21y, cd40y, cd41y +real sy, ty, sy2m1, sy2m4, ty2m1, ty2m4 + +errchk smark, salloc, sfree + +begin + # find the y limits + nymin = int (y[1]) - 2 + nymax = int (y[nypts]) + 3 + nylines = nymax - nymin + 1 + + # allocate space + call smark (sp) + call salloc (nx, nxpts, TY_INT) + call salloc (sx, nxpts, TY_REAL) + call salloc (sx2m1, nxpts, TY_REAL) + call salloc (sx2m4, nxpts, TY_REAL) + call salloc (tx, nxpts, TY_REAL) + call salloc (tx2m1, nxpts, TY_REAL) + call salloc (tx2m4, nxpts, TY_REAL) + call salloc (work, nxpts * nylines, TY_REAL) + + # intialize + call achtri (x, Memi[nx], nxpts) + do i = 1, nxpts { + Memr[sx+i-1] = x[i] - Memi[nx+i-1] + Memr[sx2m1+i-1] = Memr[sx+i-1] ** 2 - 1. + Memr[sx2m4+i-1] = Memr[sx2m1+i-1] - 3. + Memr[tx+i-1] = 1. - Memr[sx+i-1] + Memr[tx2m1+i-1] = Memr[tx+i-1] ** 2 - 1. + Memr[tx2m4+i-1] = Memr[tx2m1+i-1] - 3. + } + + + # for each value of y interpolate in x + lbuf = work + do j = 1, nylines { + + # calculate pointer to a row + row_index = first_point + (j + nymin - 2) * len_coeff + + # interpolate in x at each y + nxold = -1 + do i = 1, nxpts { + + xindex = row_index + Memi[nx+i-1] + + if (Memi[nx+i-1] != nxold) { + #cd20x = 1./6. * (coeff[xindex+1] - 2. * coeff[xindex] + + #coeff[xindex-1]) + #cd21x = 1./6. * (coeff[xindex+2] - 2. * coeff[xindex+1] + + #coeff[xindex]) + cd20x = (coeff[xindex+1] - 2. * coeff[xindex] + + coeff[xindex-1]) / 6.0 + cd21x = (coeff[xindex+2] - 2. * coeff[xindex+1] + + coeff[xindex]) / 6.0 + #cd40x = 1./120. * (coeff[xindex-2] - 4. * coeff[xindex-1] + + #6. * coeff[xindex] - 4. * coeff[xindex+1] + + #coeff[xindex+2]) + #cd41x = 1./120. * (coeff[xindex-1] - 4. * coeff[xindex] + + #6. * coeff[xindex+1] - 4. * coeff[xindex+2] + + #coeff[xindex+3]) + cd40x = (coeff[xindex-2] - 4. * coeff[xindex-1] + + 6. * coeff[xindex] - 4. * coeff[xindex+1] + + coeff[xindex+2]) / 120.0 + cd41x = (coeff[xindex-1] - 4. * coeff[xindex] + + 6. * coeff[xindex+1] - 4. * coeff[xindex+2] + + coeff[xindex+3]) / 120.0 + } + + Memr[lbuf+i-1] = Memr[sx+i-1] * (coeff[xindex+1] + + Memr[sx2m1+i-1] * (cd21x + + Memr[sx2m4+i-1] * cd41x)) + + Memr[tx+i-1] * (coeff[xindex] + + Memr[tx2m1+i-1] * (cd20x + + Memr[tx2m4+i-1] * cd40x)) + + + nxold = Memi[nx+i-1] + + } + + lbuf = lbuf + nxpts + } + + # at each x interpolate in y + nyold = -1 + do j = 1, nypts { + + ny = y[j] + sy = y[j] - ny + sy2m1 = sy ** 2 - 1. + sy2m4 = sy2m1 - 3. + ty = 1. - sy + ty2m1 = ty ** 2 - 1. + ty2m4 = ty2m1 - 3. + + lbuf = work + nxpts * (ny - nymin) + lbufp1 = lbuf + nxpts + lbufp2 = lbufp1 + nxpts + lbufp3 = lbufp2 + nxpts + lbufm1 = lbuf - nxpts + lbufm2 = lbufm1 - nxpts + + do i = 1, nxpts { + + # calculate central differences + #if (nyold != ny) { + #cd20y = 1./6. * (Memr[lbufp1+i-1] - 2. * Memr[lbuf+i-1] + + #Memr[lbufm1+i-1]) + #cd21y = 1./6. * (Memr[lbufp2+i-1] - 2. * + #Memr[lbufp1+i-1] + Memr[lbuf+i-1]) + cd20y = (Memr[lbufp1+i-1] - 2. * Memr[lbuf+i-1] + + Memr[lbufm1+i-1]) / 6. + cd21y = (Memr[lbufp2+i-1] - 2. * + Memr[lbufp1+i-1] + Memr[lbuf+i-1]) / 6. + #cd40y = 1./120. * (Memr[lbufm2+i-1] - + #4. * Memr[lbufm1+i-1] + 6. * Memr[lbuf+i-1] - + #4. * Memr[lbufp1+i-1] + Memr[lbufp2+i-1]) + #cd41y = 1./120. * (Memr[lbufm1+i-1] - 4. * + #Memr[lbuf+i-1] + 6. * Memr[lbufp1+i-1] - 4. * + #Memr[lbufp2+i-1] + Memr[lbufp3+i-1]) + cd40y = (Memr[lbufm2+i-1] - + 4. * Memr[lbufm1+i-1] + 6. * Memr[lbuf+i-1] - + 4. * Memr[lbufp1+i-1] + Memr[lbufp2+i-1]) / 120. + cd41y = (Memr[lbufm1+i-1] - 4. * + Memr[lbuf+i-1] + 6. * Memr[lbufp1+i-1] - 4. * + Memr[lbufp2+i-1] + Memr[lbufp3+i-1]) / 120.0 + #} + + # interpolate in y + zfit[i,j] = sy * (Memr[lbufp1+i-1] + sy2m1 * + (cd21y + sy2m4 * cd41y)) + + ty * (Memr[lbuf+i-1] + ty2m1 * + (cd20y + ty2m4 * cd40y)) + + } + + #nyold = ny + } + + # release work space + call sfree (sp) + +end + + +# II_GRSPLINE3 -- Procedure to evaluate the bicubic spline interpolant +# on a rectangular grid. The program assumes that 1 <= x <= nxpix and +# 1 <= y <= nypix. The routine assumes that x and y vectors are sorted +# such that x[i] < x[i+1] and y[i] < y[i+1]. The interpolant is evaluated +# by calculating the polynomial coefficients in x and y. + +procedure ii_grspline3 (coeff, first_point, len_coeff, x, y, zfit, nxpts, + nypts, len_zfit) + +real coeff[ARB] # 1D array of coefficients +int first_point # offset of first data point +int len_coeff # row length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolated values +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit + +int ny, nymin, nymax, nylines +int row_index, xindex +int i, j +pointer sp, nx, sx, tx, sx3, tx3, work, lbuf, lbufp1, lbufp2, lbufm1 +real sy, ty, ty3, sy3 + +errchk smark, salloc, sfree + +begin + # find the y limits + nymin = int (y[1]) - 1 + nymax = int (y[nypts]) + 2 + nylines = nymax - nymin + 1 + + # allocate space for work array + call smark (sp) + call salloc (nx, nxpts, TY_INT) + call salloc (sx, nxpts, TY_REAL) + call salloc (sx3, nxpts, TY_REAL) + call salloc (tx, nxpts, TY_REAL) + call salloc (tx3, nxpts, TY_REAL) + call salloc (work, nylines * nxpts, TY_REAL) + + # intialize + call achtri (x, Memi[nx], nxpts) + do j = 1, nxpts { + Memr[sx+j-1] = x[j] - Memi[nx+j-1] + Memr[tx+j-1] = 1. - Memr[sx+j-1] + } + call apowkr (Memr[sx], 3, Memr[sx3], nxpts) + call apowkr (Memr[tx], 3, Memr[tx3], nxpts) + do j = 1, nxpts { + Memr[sx+j-1] = 1. + Memr[sx+j-1] * (3. + Memr[sx+j-1] * + (3. - 3. * Memr[sx+j-1])) + Memr[tx+j-1] = 1. + Memr[tx+j-1] * (3. + Memr[tx+j-1] * + (3. - 3. * Memr[tx+j-1])) + } + + # interpolate in x for each y + lbuf = work + do i = 1, nylines { + + # find appropriate row + row_index = first_point + (i + nymin - 2) * len_coeff + + # x interpolation + do j = 1, nxpts { + + xindex = row_index + Memi[nx+j-1] + Memr[lbuf+j-1] = Memr[tx3+j-1] * coeff[xindex-1] + + Memr[tx+j-1] * coeff[xindex] + + Memr[sx+j-1] * coeff[xindex+1] + + Memr[sx3+j-1] * coeff[xindex+2] + } + lbuf = lbuf + nxpts + } + + # interpolate in y + do i = 1, nypts { + + ny = y[i] + sy = y[i] - ny + ty = 1. - sy + sy3 = sy ** 3 + ty3 = ty ** 3 + sy = 1. + sy * (3. + sy * (3. - 3. * sy)) + ty = 1. + ty * (3. + ty * (3. - 3. * ty)) + + lbuf = work + nxpts * (ny - nymin) + lbufp1 = lbuf + nxpts + lbufp2 = lbufp1 + nxpts + lbufm1 = lbuf - nxpts + + do j = 1, nxpts + zfit[j,i] = ty3 * Memr[lbufm1+j-1] + ty * Memr[lbuf+j-1] + + sy * Memr[lbufp1+j-1] + sy3 * Memr[lbufp2+j-1] + } + + # release working space + call sfree (sp) +end + +# II_GRSINC -- Procedure to evaluate the sinc interpolant on a rectangular +# grid. The procedure assumes that 1 <= x <= nxpix and that 1 <= y <= nypix. +# The x and y vectors must be sorted in increasing value of x and y such that +# x[i] < x[i+1] and y[i] < y[i+1]. The routine outputs a grid of nxpix by +# nypix points using the coeff array where coeff[1+first_point] = datain[1,1] +# The sinc truncation length is nsinc. The taper is a cosine bell function +# which is approximated by a quartic polynomial which is valid for 0 <= x +# <= PI / 2 (Abramowitz and Stegun 1972, Dover Publications, p 76). If the +# point to be interpolated is less than mindx and mindy from a data point +# no interpolation is done and the data point itself is returned. + +procedure ii_grsinc (coeff, first_point, len_coeff, len_array, x, y, zfit, + nxpts, nypts, len_zfit, nsinc, mindx, mindy) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +int len_array # column length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolatedvalues +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit +int nsinc # sinc interpolant truncation length +real mindx, mindy # the precision of the interpolant. + +int i, j, k, nconv, nymin, nymax, nylines +int ixy, index, minj, maxj, offj +pointer sp, taper, ac, ixn, work, pac, pwork, ppwork +real sconst, a2, a4, dxy, dxyn, dx2, axy, pxy, sumxy, fdxy + +begin + # Compute the limits of the convolution in y. + nconv = 2 * nsinc + 1 + nymin = max (1, nint (y[1]) - nsinc) + #nymin = max (1, int (y[1]) - nsinc) + nymax = min (len_array, nint (y[nypts]) + nsinc) + #nymax = min (len_array, int (y[nypts]) + nsinc) + nylines = nymax - nymin + 1 + + # Allocate working space. + call smark (sp) + call salloc (taper, nconv, TY_REAL) + call salloc (ac, nconv * max (nxpts, nypts), TY_REAL) + call salloc (ixn, max (nxpts, nypts), TY_INT) + call salloc (work, nxpts * nylines, TY_REAL) + + # Compute the parameters of the cosine bell taper. + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + if (mod (nsinc, 2) == 0) + fdxy = 1.0 + else + fdxy = -1.0 + do i = -nsinc, nsinc { + dx2 = sconst * i * i + Memr[taper+i+nsinc] = fdxy * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + fdxy = -fdxy + } + + # Compute the x interpolants for each shift in x. + pac = ac + do i = 1, nxpts { + ixy = nint (x[i]) + Memi[ixn+i-1] = ixy + dxy = x[i] - ixy + #dxyn = -1 - nsinc - dxy + dxyn = 1 + nsinc + dxy + sumxy = 0.0 + do j = 1, nconv { + #axy = j + dxyn + axy = dxyn - j + if (axy == 0.0) + pxy = 1.0 + else if (dxy == 0.0) + pxy = 0.0 + else + pxy = Memr[taper+j-1] / axy + Memr[pac+j-1] = pxy + sumxy = sumxy + pxy + } + call adivkr (Memr[pac], sumxy, Memr[pac], nconv) + pac = pac + nconv + } + + # Do the convolutions in the x direction. + pwork = work + do k = nymin, nymax { + index = first_point + (k - 1) * len_coeff + pac = ac + do i = 1, nxpts { + sumxy = 0.0 + ixy = Memi[ixn+i-1] + minj = max (1, ixy - nsinc) + maxj = min (len_coeff, ixy + nsinc) + offj = -ixy + nsinc + do j = ixy - nsinc, minj - 1 + sumxy = sumxy + Memr[pac+j+offj] * coeff[index+1] + do j = minj, maxj + sumxy = sumxy + Memr[pac+j+offj] * coeff[index+j] + do j = maxj + 1, ixy + nsinc + sumxy = sumxy + Memr[pac+j+offj] * coeff[index+len_coeff] + Memr[pwork+i-1] = sumxy + pac = pac + nconv + } + pwork = pwork + nxpts + } + + # Compute the y interpolants for each shift in y. + pac = ac + do i = 1, nypts { + ixy = nint (y[i]) + dxy = y[i] - ixy + Memi[ixn+i-1] = ixy - nsinc - nymin + 1 + #dxyn = -1 - nsinc - dxy + dxyn = 1 + nsinc + dxy + sumxy = 0.0 + do j = 1, nconv { + #axy = j + dxyn + axy = dxyn - j + if (axy == 0.0) + pxy = 1.0 + else if (dxy == 0.0) + pxy = 0.0 + else + pxy = Memr[taper+j-1] / axy + Memr[pac+j-1] = pxy + sumxy = sumxy + pxy + } + call adivkr (Memr[pac], sumxy, Memr[pac], nconv) + pac = pac + nconv + } + + # Do the interpolation in y. + do k = 1, nxpts { + pwork = work + k - 1 + pac = ac + do i = 1, nypts { + ixy = min (nylines, max (1, Memi[ixn+i-1])) + ppwork = pwork + (ixy - 1) * nxpts + sumxy = 0.0 + do j = 1, nconv { + sumxy = sumxy + Memr[pac+j-1] * Memr[ppwork] + ppwork = ppwork + nxpts + } + pac = pac + nconv + zfit[k,i] = sumxy + } + } + + call sfree (sp) +end + + +# II_GRLSINC -- Procedure to evaluate the sinc interpolant on a rectangular +# grid. The procedure assumes that 1 <= x <= nxpix and that 1 <= y <= nypix. +# The x and y vectors must be sorted in increasing value of x and y such that +# x[i] < x[i+1] and y[i] < y[i+1]. The routine outputs a grid of nxpix by +# nypix points using the coeff array where coeff[1+first_point] = datain[1,1] +# The sinc truncation length is nsinc. The taper is a cosine bell function +# which is approximated by a quartic polynomial which is valid for 0 <= x +# <= PI / 2 (Abramowitz and Stegun 1972, Dover Publications, p 76). If the +# point to be interpolated is less than mindx and mindy from a data point +# no interpolation is done and the data point itself is returned. + +procedure ii_grlsinc (coeff, first_point, len_coeff, len_array, x, y, zfit, + nxpts, nypts, len_zfit, ltable, nconv, nxincr, nyincr, + mindx, mindy) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +int len_array # column length of coeff +real x[nxpts] # array of x values +real y[nypts] # array of y values +real zfit[len_zfit,ARB] # array of interpolated values +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit +real ltable[nconv,nconv,nxincr,nyincr] # pre-computed sinc lut +int nconv # sinc trunction full-width +int nxincr, nyincr # resolution of look-up table +real mindx, mindy # the precision of interpolant + +int j +pointer sp, ytmp + +begin + # Allocate working space. + call smark (sp) + call salloc (ytmp, nxpts, TY_REAL) + + do j = 1, nypts { + call amovkr (y[j], Memr[ytmp], nxpts) + call ii_bilsinc (coeff, first_point, len_coeff, len_array, x, + Memr[ytmp], zfit[1,j], nxpts, ltable, nconv, nxincr, nyincr, + mindx, mindy) + } + + call sfree (sp) +end + + +# II_GRDRIZ -- Procedure to evaluate the drizzle interpolant on a rectangular +# grid. The procedure assumes that the x and y intervals are ordered from +# smallest to largest + +procedure ii_grdriz (coeff, first_point, len_coeff, len_array, x, y, zfit, + nxpts, nypts, len_zfit, xfrac, yfrac, badval) + +real coeff[ARB] # 1D coefficient array +int first_point # offset of first data point +int len_coeff # row length of coeff +int len_array # column length of coeff +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[len_zfit,ARB] # array of interpolatedvalues +int nxpts # number of x values +int nypts # number of y values +int len_zfit # row length of zfit +real xfrac, yfrac # the x and y pixel fractions +real badval # bad value + +int i, j, jj, nylmin, nylmax, nylines +int cindex, neara, nearb +pointer sp, work, xindex +real ymin, ymax, dy, accum, waccum, hyfrac + +begin + ymin = min (y[1], y[2]) + ymax = max (y[2*nypts-1], y[2*nypts]) + nylmin = int (ymin + 0.5) + nylmax = int (ymax + 0.5) + nylines = nylmax - nylmin + 1 + + call smark (sp) + call salloc (work, nxpts * nylines, TY_REAL) + + # For each in range y integrate in x. + cindex = 1 + first_point + (nylmin - 1) * len_coeff + xindex = work + do j = nylmin, nylmax { + if (xfrac >= 1.0) + call ii_driz1 (x, Memr[xindex], nxpts, coeff[cindex], badval) + else + call ii_driz (x, Memr[xindex], nxpts, coeff[cindex], xfrac, + badval) + xindex = xindex + nxpts + cindex = cindex + len_coeff + } + + # For each range in x integrate in y. This may need to be vectorized? + hyfrac = yfrac / 2.0 + do i = 1, nxpts { + + xindex = work + i - 1 + + do j = 1, nypts { + + ymin = min (y[2*j-1], y[2*j]) + ymax = max (y[2*j-1], y[2*j]) + neara = ymin + 0.5 + nearb = ymax + 0.5 + + accum = 0.0 + waccum = 0.0 + if (neara == nearb) { + + dy = min (ymax, nearb + hyfrac) - max (ymin, + neara - hyfrac) + if (dy > 0.0) { + accum = accum + dy * Memr[xindex+(neara-nylmin)*nxpts] + waccum = waccum + dy + } + + } else { + + # First segment. + dy = neara + hyfrac - max (ymin, neara - hyfrac) + if (dy > 0.0) { + accum = accum + dy * Memr[xindex+(neara-nylmin)*nxpts] + waccum = waccum + dy + } + + # Interior segments. + do jj = neara + 1, nearb - 1 { + accum = accum + yfrac * Memr[xindex+(jj-nylmin)*nxpts] + waccum = waccum + yfrac + } + + # Last segment. + dy = min (ymax, nearb + hyfrac) - (nearb - hyfrac) + if (dy > 0.0) { + accum = accum + dy * Memr[xindex+(nearb-nylmin)*nxpts] + waccum = waccum + dy + } + } + + if (waccum <= 0.0) + zfit[i,j] = 0.0 + else + zfit[i,j] = accum / waccum + } + } + + call sfree (sp) +end diff --git a/math/iminterp/ii_pc1deval.x b/math/iminterp/ii_pc1deval.x new file mode 100644 index 00000000..7eca5304 --- /dev/null +++ b/math/iminterp/ii_pc1deval.x @@ -0,0 +1,291 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im1interpdef.h" + +# IA_PCPOLY3 -- Calculate the coefficients of a 3rd order polynomial. + +procedure ia_pcpoly3 (x, datain, npts, pcoeff) + +real x # x value +real datain[ARB] # array of input data +int npts # number of data points +real pcoeff[ARB] # array of polynomial coefficients + +int i, k, nearx, nterms +real temp[POLY3_ORDER] + +begin + nearx = x + + # Check for edge problems. + k = 0 + for(i = nearx - 1; i <= nearx + 2; i = i + 1) { + k = k + 1 + + # project data points into temporary array + if (i < 1) + temp[k] = 2. * datain[1] - datain[2-i] + else if (i > npts) + temp[k] = 2. * datain[npts] - datain[2*npts-i] + else + temp[k] = datain[i] + } + + nterms = 4 + + # Generate the difference table for Newton's form. + do k = 1, nterms - 1 + do i = 1, nterms - k + temp[i] = (temp[i+1] - temp[i]) / k + + # Shift to generate polynomial coefficients. + do k = nterms, 2, -1 + do i = 2, k + temp[i] = temp[i] + temp[i-1] * (k- i - nterms/2) + do i = 1, nterms + pcoeff[i] = temp[nterms+1-i] +end + + +# IA_PCPOLY5 -- Calculate the coefficients of a fifth order polynomial. + +procedure ia_pcpoly5 (x, datain, npts, pcoeff) + +real x # x value +real datain[ARB] # array of input data +int npts # number of data points +real pcoeff[ARB] # array of polynomial coefficients + +int i, k, nearx, nterms +real temp[POLY5_ORDER] + +begin + nearx = x + + # Check for edge effects. + k = 0 + for (i = nearx - 2; i <= nearx + 3; i = i + 1) { + k = k + 1 + # project data points into temporary array + if (i < 1) + temp[k] = 2. * datain[1] - datain[2-i] + else if (i > npts) + temp[k] = 2. * datain[npts] - datain[2*npts-i] + else + temp[k] = datain[i] + } + + nterms = 6 + + # Generate difference table for Newton's form. + do k = 1, nterms - 1 + do i = 1, nterms - k + temp[i] = (temp[i+1] - temp[i]) / k + + # Shift to generate polynomial coefficients. + do k = nterms, 2, -1 + do i = 2, k + temp[i] = temp[i] + temp[i-1] * (k - i - nterms/2) + do i = 1, nterms + pcoeff[i] = temp[nterms+1-i] +end + + +# IA_PCSPLINE3 -- Calculate the derivatives of a cubic spline. + +procedure ia_pcspline3 (x, datain, npts, pcoeff) + +real x # x value +real datain[ARB] # data array +int npts # number of data points +real pcoeff[ARB] # array of polynomial coefficients + +int i, k, nearx, px +real temp[SPLPTS+3], bcoeff[SPLPTS+3] + +begin + nearx = x + k = 0 + + # Check for edge effects. + for (i = nearx - SPLPTS/2 + 1; i <= nearx + SPLPTS/2; i = i + 1) { + if(i < 1 || i > npts) + ; + else { + k = k + 1 + if (k == 1) + px = nearx - i + 1 + bcoeff[k+1] = datain[i] + } + } + + bcoeff[1] = 0. + bcoeff[k+2] = 0. + + # Use special routine for cardinal splines. + call ii_spline (bcoeff, temp, k) + + px = px + 1 + bcoeff[k+3] = 0. + + # Calculate polynomial coefficients. + pcoeff[1] = bcoeff[px-1] + 4. * bcoeff[px] + bcoeff[px+1] + pcoeff[2] = 3. * (bcoeff[px+1] - bcoeff[px-1]) + pcoeff[3] = 3. * (bcoeff[px-1] - 2. * bcoeff[px] + bcoeff[px+1]) + pcoeff[4] = -bcoeff[px-1] + 3. * bcoeff[px] - 3. * bcoeff[px+1] + + bcoeff[px+2] +end + + +# II_SINCDER -- Evaluate derivatives of the sinc interpolator. If the +# function value only is needed call ii_sinc. This routine computes only +# the first two derivatives. The second derivative is computed even if only +# the first derivative is needed. The sinc truncation length is nsinc. +# The taper is a cosbell function approximated by a quartic polynomial. +# The data value is returned if x is closer to x[i] than mindx. + +procedure ii_sincder (x, der, nder, data, npix, nsinc, mindx) + +real x # x value +real der[ARB] # derivatives to return +int nder # number of derivatives +real data[npix] # data to be interpolated +int npix # number of pixels +int nsinc # sinc truncation length +real mindx # interpolation minimum + +int i, j, xc +real dx, w, a, d, z, sconst, a2, a4, dx2, taper +real w1, w2, w3, u1, u2, u3, v1, v2, v3 + +begin + # Return if no derivatives. + if (nder == 0) + return + + # Set derivatives intially to zero. + do i = 1, nder + der[i] = 0. + + # Return if outside data range. + xc = nint (x) + if (xc < 1 || xc > npix) + return + + # Call ii_sinc if only the function value is needed. + if (nder == 1) { + call ii_sinc (x, der, 1, data, npix, nsinc, mindx) + return + } + + # Compute the constants for the cosine bell taper approximation. + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + + # Compute the derivatives by doing the required convolutions. + dx = x - xc + if (abs (dx) < mindx) { + + w = 1. + d = data[xc] + w1 = 1.; u1 = d * w1; v1 = w1 + w2 = 0.; u2 = 0.; v2 = 0. + w3 = -1./3.; u3 = d * w3; v3 = w3 + + # Derivative at the center of a pixel. + do i = 1, nsinc { + + w = -w + dx2 = sconst * i * i + taper = (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + + j = xc - i + z = 1. / i + if (j >= 1) + d = data[j] + else + d = data[1] + w2 = w * z * taper + u2 = u2 + d * w2 + v2 = v2 + w2 + w3 = -2 * w2 * z + u3 = u3 + d * w3 + v3 = v3 + w3 + + j = xc + i + if (j <= npix) + d = data[j] + else + d = data[npix] + w2 = -w * z * taper + u2 = u2 + d * w2 + v2 = v2 + w2 + w3 = 2 * w2 * z + u3 = u3 + d * w3 + v3 = v3 + w3 + } + + } else { + + w = 1.0 + a = 1 / tan (PI * dx) + + d = data[xc] + z = 1. / dx + w1 = w * z; u1 = d * w1; v1 = w1 + w2 = w1 * (a - z); u2 = d * w2; v2 = w2 + w3 = -w1 * (1 + 2 * z * (a - z)); u3 = d * w3; v3 = w3 + + # Derivative off center of a pixel. + do i = 1, nsinc { + + w = -w + dx2 = sconst * i * i + taper = (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + + j = xc - i + if (j >= 1) + d = data[j] + else + d = data[1] + z = 1. / (dx + i) + w1 = w * z * taper + u1 = u1 + d * w1 + v1 = v1 + w1 + w2 = w1 * (a - z) + u2 = u2 + d * w2 + v2 = v2 + w2 + w3 = -w1 * (1 + 2*z*(a-z)) + u3 = u3 + d * w3 + v3 = v3 + w3 + + j = xc + i + if (j <= npix) + d = data[j] + else + d = data[npix] + z = 1. / (dx - i) + w1 = w * z * taper + u1 = u1 + d * w1 + v1 = v1 + w1 + w2 = w1 * (a - z) + u2 = u2 + d * w2 + v2 = v2 + w2 + w3 = -w1 * (1 + 2*z*(a-z)) + u3 = u3 + d * w3 + v3 = v3 + w3 + } + } + + # Compute the derivatives. + w1 = v1 + w2 = v1 * w1 + w3 = v1 * w2 + der[1] = u1 / w1 + if (nder > 1) + der[2] = (u2 * v1 - u1 * v2) / w2 + if (nder > 2) + der[3] = u3 / w1 - 2*u2*v2 / w2 + 2*u1*v2*v2 / w3 - u1*v3 / w2 +end diff --git a/math/iminterp/ii_pc2deval.x b/math/iminterp/ii_pc2deval.x new file mode 100644 index 00000000..c26d2095 --- /dev/null +++ b/math/iminterp/ii_pc2deval.x @@ -0,0 +1,444 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# II_PCPOLY3 -- Procedure to evaluate the polynomial coefficients +# of third order in x and y using Everetts formuala. + +procedure ii_pcpoly3 (coeff, index, len_coeff, pcoeff, len_pcoeff) + +real coeff[ARB] # 1D array of interpolant coeffcients +int index # pointer into coeff array +int len_coeff # row length of coeffcients +real pcoeff[len_pcoeff,ARB] # polynomial coefficients +int len_pcoeff # row length of pcoeff + +int tptr +int i, j +real cd20, cd21, temp[4] + +begin + # determine polynomial coefficients in x + tptr = index + do i = 1, 4 { + + # calculate the central differences + cd20 = 1./6. * (coeff[tptr+1] - 2. * coeff[tptr] + coeff[tptr-1]) + cd21 = 1./6. * (coeff[tptr+2] - 2. * coeff[tptr+1] + coeff[tptr]) + + # calculate the polynomial coefficients in x at each y + pcoeff[1,i] = coeff[tptr] + pcoeff[2,i] = coeff[tptr+1] - coeff[tptr] - 2. * cd20 - cd21 + pcoeff[3,i] = 3. * cd20 + pcoeff[4,i] = cd21 - cd20 + + tptr = tptr + len_coeff + } + + # calculate polynomial coefficients in y + do j = 1, 4 { + + # calculate the central differences + cd20 = 1./6. * (pcoeff[j,3] - 2. * pcoeff[j,2] + pcoeff[j,1]) + cd21 = 1./6. * (pcoeff[j,4] - 2. * pcoeff[j,3] + pcoeff[j,2]) + + # calculate the final coefficients + temp[1] = pcoeff[j,2] + temp[2] = pcoeff[j,3] - pcoeff[j,2] - 2. * cd20 - cd21 + temp[3] = 3. * cd20 + temp[4] = cd21 - cd20 + + do i = 1, 4 + pcoeff[j,i] = temp[i] + } +end + + +# II_PCPOLY5 -- Procedure to evaluate the polynomial coefficients +# of fifth order in x and y using Everetts formuala. + +procedure ii_pcpoly5 (coeff, index, len_coeff, pcoeff, len_pcoeff) + +real coeff[ARB] # 1D array of interpolant coeffcients +int index # pointer into coeff array +int len_coeff # row length of coeffcients +real pcoeff[len_pcoeff,ARB] # polynomial coefficients +int len_pcoeff # row length of pcoeff array + +int tptr +int i, j +real cd20, cd21, cd40, cd41, temp[6] + +begin + # determine polynomial coefficients in x + tptr = index + do i = 1, 6 { + + # calculate the central differences + cd20 = 1./6. * (coeff[tptr+1] - 2. * coeff[tptr] + coeff[tptr-1]) + cd21 = 1./6. * (coeff[tptr+2] - 2. * coeff[tptr+1] + coeff[tptr]) + cd40 = 1./120. * (coeff[tptr-2] - 4. * coeff[tptr-1] + + 6. * coeff[tptr] - 4. * coeff[tptr+1] + + coeff[tptr+2]) + cd41 = 1./120. * (coeff[tptr-1] - 4. * coeff[tptr] + + 6. * coeff[tptr+1] - 4. * coeff[tptr+2] + + coeff[tptr+3]) + + # calculate coefficients in x for each y + pcoeff[1,i] = coeff[tptr] + pcoeff[2,i] = coeff[tptr+1] - coeff[tptr] - 2. * cd20 - cd21 + + 6. * cd40 + 4. * cd41 + pcoeff[3,i] = 3. * cd20 - 5. * cd40 + pcoeff[4,i] = cd21 - cd20 - 5. * (cd40 + cd41) + pcoeff[5,i] = 5. * cd40 + pcoeff[6,i] = cd41 - cd40 + + tptr = tptr + len_coeff + } + + # calculate polynomial coefficients in y + do j = 1, 6 { + + # calculate the central differences + cd20 = 1./6. * (pcoeff[j,4] - 2. * pcoeff[j,3] + pcoeff[j,2]) + cd21 = 1./6. * (pcoeff[j,5] - 2. * pcoeff[j,4] + pcoeff[j,3]) + cd40 = 1./120. * (pcoeff[j,1] - 4. * pcoeff[j,2] + + 6. * pcoeff[j,3] - 4. * pcoeff[j,4] + pcoeff[j,5]) + cd41 = 1./120. * (pcoeff[j,2] - 4. * pcoeff[j,3] + + 6. * pcoeff[j,4] - 4. * pcoeff[j,5] + pcoeff[j,6]) + + # calculate the final coefficients + temp[1] = pcoeff[j,3] + temp[2] = pcoeff[j,4] - pcoeff[j,3] - 2. * cd20 - cd21 + + 6. * cd40 + 4. * cd41 + temp[3] = 3. * cd20 - 5. * cd40 + temp[4] = cd21 - cd20 - 5. * (cd40 + cd41) + temp[5] = 5. * cd40 + temp[6] = cd41 - cd40 + + do i = 1, 6 + pcoeff[j,i] = temp[i] + + } + +end + + +# II_PCSPLINE3 -- Procedure to evaluate the polynomial coefficients +# of bicubic spline. + +procedure ii_pcspline3 (coeff, index, len_coeff, pcoeff, len_pcoeff) + +real coeff[ARB] # 1D array of interpolant coeffcients +int index # pointer into coeff array +int len_coeff # row length of coeffcients +real pcoeff[len_pcoeff,ARB] # polynomial coefficients +int len_pcoeff # row length of pcoeff + +int tptr +int i, j +real temp[4] + +begin + # determine polynomial coefficients in x + tptr = index + do i = 1, 4 { + + pcoeff[1,i] = coeff[tptr+1] + 4. * coeff[tptr] + coeff[tptr-1] + pcoeff[2,i] = 3. * (coeff[tptr+1] - coeff[tptr-1]) + pcoeff[3,i] = 3. * (coeff[tptr-1] - 2. * coeff[tptr] + + coeff[tptr+1]) + pcoeff[4,i] = -coeff[tptr-1] + 3. * coeff[tptr] - + 3. * coeff[tptr+1] + coeff[tptr+2] + + tptr = tptr + len_coeff + } + + # calculate polynomial coefficients in y + do j = 1, 4 { + + temp[1] = pcoeff[j,3] + 4. * pcoeff[j,2] + pcoeff[j,1] + temp[2] = 3. * (pcoeff[j,3] - pcoeff[j,1]) + temp[3] = 3. * (pcoeff[j,1] - 2. * pcoeff[j,2] + pcoeff[j,3]) + temp[4] = -pcoeff[j,1] + 3. * pcoeff[j,2] - 3. * pcoeff[j,3] + + pcoeff[j,4] + + do i = 1, 4 + pcoeff[j,i] = temp[i] + } +end + +# II_BISINCDER -- Evaluate the derivatives of the 2D sinc interpolator. If the +# function value only is needed call ii_bisinc. This routine computes only +# the first 2 derivatives in x and y. The second derivative is computed +# even if only the first derivative is needed. The sinc truncation length +# is nsinc. The taper is a cosbell approximated by a quartic polynomial. +# The data value if returned if x is closer to x[i] than mindx and y is +# closer to y[i] than mindy. + +procedure ii_bisincder (x, y, der, nxder, nyder, len_der, coeff, first_point, + nxpix, nypix, nsinc, mindx, mindy) + +real x, y # the input x and y values +real der[len_der,ARB] # the output derivatives array +int nxder, nyder # the number of derivatives to compute +int len_der # the width of the derivatives array +real coeff[ARB] # the coefficient array +int first_point # offset of first data point into the array +int nxpix, nypix # size of the coefficient array +int nsinc # the sinc truncation length +real mindx, mindy # the precision of the sinc interpolant + +double sumx, normx[3], normy[3], norm[3,3], sum[3,3] +int i, j, k, jj, kk, xc, yc, nconv, index +int minj, maxj, offj, mink, maxk, offk, last_point +pointer sp, ac, ar +real sconst, a2, a4, dx, dy, dxn, dyn, dx2, taper, sdx, ax, ay, ctanx, ctany +real zx, zy +real px[3], py[3] + +begin + # Return if no derivatives ar to be computed. + if (nxder == 0 || nyder == 0) + return + + # Initialize the derivatives to zero. + do jj = 1, nyder { + do kk = 1, nxder + der[kk,jj] = 0.0 + } + + # Return if the data is outside range. + xc = nint (x) + yc = nint (y) + if (xc < 1 || xc > nxpix || yc < 1 || yc > nypix) + return + + # Call ii_bsinc if only the function value is requested. + if (nxder == 1 && nyder == 1) { + call ii_bisinc (coeff, first_point, nxpix, nypix, x, y, der[1,1], + 1, nsinc, mindx, mindy) + return + } + + # Compute the constants for the cosine bell taper approximation. + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + + # Allocate some working space. + nconv = 2 * nsinc + 1 + call smark (sp) + call salloc (ac, 3 * nconv, TY_REAL) + call salloc (ar, 3 * nconv, TY_REAL) + call aclrr (Memr[ac], 3 * nconv) + call aclrr (Memr[ar], 3 * nconv) + + # Initialize. + dx = x - xc + dy = y - yc + if (dx == 0.0) + ctanx = 0.0 + else + ctanx = 1.0 / tan (PI * dx) + if (dy == 0.0) + ctany = 0.0 + else + ctany = 1.0 / tan (PI * dy) + index = - 1 - nsinc + dxn = -1 - nsinc - dx + dyn = -1 - nsinc - dy + if (mod (nsinc, 2) == 0) + sdx = 1.0 + else + sdx = -1.0 + do jj = 1, 3 { + normy[jj] = 0.0d0 + normx[jj] = 0.0d0 + } + + do i = 1, nconv { + dx2 = sconst * (i + index) ** 2 + taper = sdx * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + #ax = dxn + i + #ay = dyn + i + ax = -dxn - i + ay = -dyn - i + if (ax == 0.0) { + px[1] = 1.0 + px[2] = 0.0 + px[3] = - 1.0 / 3.0 + } else if (dx == 0.0) { + px[1] = 0.0 + px[2] = 0.0 + px[3] = 0.0 + } else { + zx = 1.0 / ax + px[1] = taper * zx + px[2] = px[1] * (ctanx - zx) + px[3] = -px[1] * (1.0 + 2.0 * zx * (ctanx - zx)) + } + if (ay == 0.0) { + py[1] = 1.0 + py[2] = 0.0 + py[3] = - 1.0 / 3.0 + } else if (dy == 0.0) { + py[1] = 0.0 + py[2] = 0.0 + py[3] = 0.0 + } else { + zy = 1.0 / ay + py[1] = taper * zy + py[2] = py[1] * (ctany - zy) + py[3] = -py[1] * (1.0 + 2.0 * zy * (ctany - zy)) + } + + Memr[ac+i-1] = px[1] + Memr[ac+nconv+i-1] = px[2] + Memr[ac+2*nconv+i-1] = px[3] + Memr[ar+i-1] = py[1] + Memr[ar+nconv+i-1] = py[2] + Memr[ar+2*nconv+i-1] = py[3] + + do jj = 1, 3 { + normx[jj] = normx[jj] + px[jj] + normy[jj] = normy[jj] + py[jj] + } + + sdx = -sdx + } + + # Normalize. + do jj = 1, 3 { + do kk = 1, 3 + norm[kk,jj] = normx[kk] * normy[jj] + } + + + # Do the convolution. + minj = max (1, yc - nsinc) + maxj = min (nypix, yc + nsinc) + mink = max (1, xc - nsinc) + maxk = min (nxpix, xc + nsinc) + do jj = 1, nyder { + offj = ar + (jj - 1) * nconv - yc + nsinc + do kk = 1, nxder { + offk = ac + (kk - 1) * nconv - xc + nsinc + sum[kk,jj] = 0.0d0 + + # Do the convolutions. + do j = yc - nsinc, minj - 1 { + sumx = 0.0d0 + do k = xc - nsinc, mink - 1 + sumx = sumx + Memr[k+offk] * coeff[first_point+1] + do k = mink, maxk + sumx = sumx + Memr[k+offk] * coeff[first_point+k] + do k = maxk + 1, xc + nsinc + sumx = sumx + Memr[k+offk] * coeff[first_point+nxpix] + + sum[kk,jj] = sum[kk,jj] + Memr[j+offj] * sumx + } + + + do j = minj, maxj { + index = first_point + (j - 1) * nxpix + sumx = 0.0d0 + do k = xc - nsinc, mink - 1 + sumx = sumx + Memr[k+offk] * coeff[index+1] + do k = mink, maxk + sumx = sumx + Memr[k+offk] * coeff[index+k] + do k = maxk + 1, xc + nsinc + sumx = sumx + Memr[k+offk] * coeff[index+nxpix] + + sum[kk,jj] = sum[kk,jj] + Memr[j+offj] * sumx + } + + do j = maxj + 1, yc + nsinc { + last_point = first_point + (nypix - 1) * nxpix + sumx = 0.0d0 + do k = xc - nsinc, mink - 1 + sumx = sumx + Memr[k+offk] * coeff[last_point+1] + do k = mink, maxk + sumx = sumx + Memr[k+offk] * coeff[last_point+k] + do k = maxk + 1, xc + nsinc + sumx = sumx + Memr[k+offk] * coeff[last_point+nxpix] + + sum[kk,jj] = sum[kk,jj] + Memr[j+offj] * sumx + } + + } + } + + # Build the derivatives. + der[1,1] = sum[1,1] / norm[1,1] + if (nxder > 1) + der[2,1] = sum[2,1] / norm[1,1] - (sum[1,1] * norm[2,1]) / + norm[1,1] ** 2 + if (nxder > 2) + der[3,1] = sum[3,1] / norm[1,1] - (norm[3,1] * sum[1,1] + + 2.0d0 * sum[2,1] * norm[2,1]) / norm[1,1] ** 2 + + 2.0d0 * sum[1,1] * norm[2,1] * norm[2,1] / norm[1,1] ** 3 + if (nyder > 1) { + der[1,2] = sum[1,2] / norm[1,1] - (sum[1,1] * norm[1,2]) / + norm[1,1] ** 2 + if (nxder > 1) + der[2,2] = sum[2,2] / norm[1,1] - (sum[2,1] * norm[1,2] + + sum[1,2] * norm[2,1] + norm[2,2] * sum[1,1]) / + norm[1,1] ** 2 + (2.0d0 * sum[1,1] * norm[2,1] * + norm[1,2]) / norm[1,1] ** 3 + if (nxder > 2) + der[3,2] = sum[3,2] / norm[1,1] - (sum[3,1] * norm[1,2] + + 2.0 * norm[2,2] * sum[2,1] + 2.0 * sum[2,2] * + norm[2,1] + norm[3,1] * sum[1,2] + norm[3,2] * + sum[1,1]) / norm[1,1] ** 2 + (4.0 * norm[2,1] * + sum[2,1] * norm[1,2] + 2.0 * norm[2,1] * sum[1,2] * + norm[2,1] + 4.0 * norm[2,1] * norm[2,2] * sum[1,1] + + 2.0 * norm[3,1] * norm[1,2] * sum[1,1]) / + norm[1,1] ** 3 - 6.0 * norm[2,1] * norm[2,1] * + norm[1,2] * sum[1,1] / norm[1,1] ** 4 + + } + if (nyder > 2) { + der[1,3] = sum[1,3] / norm[1,1] - (norm[1,3] * sum[1,1] + + 2.0d0 * sum[1,2] * norm[1,2]) / norm[1,1] ** 2 + + 2.0d0 * sum[1,1] * norm[1,2] * norm[1,2] / norm[1,1] ** 3 + if (nxder > 1) + der[2,3] = sum[2,3] / norm[1,1] - (sum[1,3] * norm[2,1] + + 2.0 * norm[2,2] * sum[1,2] + 2.0 * sum[2,2] * + norm[1,2] + norm[1,3] * sum[2,1] + norm[2,3] * + sum[1,1]) / norm[1,1] ** 2 + (4.0 * norm[1,2] * + sum[1,2] * norm[2,1] + 2.0 * norm[1,2] * sum[2,1] * + norm[1,2] + 4.0 * norm[1,2] * norm[2,2] * sum[1,1] + + 2.0 * norm[1,3] * norm[2,1] * sum[1,1]) / + norm[1,1] ** 3 - 6.0 * norm[1,2] * norm[1,2] * + norm[2,1] * sum[1,1] / norm[1,1] ** 4 + if (nxder > 2) + der[3,3] = sum[3,3] / norm[1,1] - (2.0 * sum[2,3] * norm[2,1] + + norm[3,1] * sum[1,3] + 2.0 * norm[3,2] * sum[1,2] + + 4.0 * sum[2,2] * norm[2,2] + 2.0 * sum[3,2] * + norm[1,2] + 2.0 * norm[2,3] * sum[2,1] + sum[3,1] * + norm[1,3] + norm[3,3] * sum[1,1]) / norm[1,1] ** 2 + + (2.0 * norm[2,1] * norm[2,1] * sum[1,3] + 8.0 * + norm[2,1] * sum[1,2] * norm[2,2] + 8.0 * norm[2,1] * + norm[1,2] * sum[2,2] + 4.0 * norm[2,1] * sum[2,1] * + norm[1,3] + 4.0 * norm[2,1] * norm[2,3] * sum[1,1] + + 4.0 * norm[1,2] * sum[1,2] * norm[3,1] + 8.0 * + norm[2,2] * sum[2,1] * norm[1,2] + 2.0 * norm[1,2] * + norm[1,2] * sum[3,1] + 4.0 * norm[2,2] * norm[2,2] * + sum[1,1] + 4.0 * norm[1,2] * norm[3,2] * sum[1,1] + + 2.0 * norm[1,3] * norm[3,1] * sum[1,1]) / + norm[1,1] ** 3 - (12.0 * norm[2,1] * norm[2,1] * + norm[1,2] * sum[1,2] + 12.0 * norm[2,1] * norm[1,2] * + norm[1,2] * sum[2,1] + 24.0 * norm[2,1] * norm[1,2] * + norm[2,2] * sum[1,1] + 6.0 * norm[2,1] * norm[2,1] * + norm[1,3] * sum[1,1] + 6.0 * norm[1,2] * norm[1,2] * + norm[3,1] * sum[1,1]) / norm[1,1] ** 4 + ( 24.0 * + norm[1,2] * norm[1,2] * norm[2,1] * norm[2,1] * + sum[1,1]) / norm[1,1] ** 5 + } + + + + + call sfree (sp) +end diff --git a/math/iminterp/ii_polterp.x b/math/iminterp/ii_polterp.x new file mode 100644 index 00000000..24216751 --- /dev/null +++ b/math/iminterp/ii_polterp.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im1interpdef.h" + +# II_POLTERP -- polynomial interpolator with x and y arrays given. +# This algorithm is based on the Newton form as described in +# C. de Boor's book, "A Practical Guide to Splines", 1978. +# There is no error checking - this is meant to be used only by calls +# from more complete routines that take care of such things. + +# Maximum number of terms is MAX_NDERIVS. + +real procedure ii_polterp (x, y, n, x0) + +real x[ARB],y[ARB] # x and y array +real x0 # desired x +int n # number of points in x and y = number of + # terms in polynomial = order + 1 + +int k,i +real d[MAX_NDERIVS] + +begin + + # Fill in entries for divided difference table. + do i = 1, n + d[i] = y[i] + + # Generate divided differences + do k = 1, n - 1 + do i = 1, n - k + d[i] = (d[i+1] - d[i])/(x[i+k] - x[i]) + + # Shift divided difference table to center on x0 + do i = 2, n + d[i] = d[i] + d[i-1] * (x0 - x[i]) + + return (d[n]) +end diff --git a/math/iminterp/ii_sinctable.x b/math/iminterp/ii_sinctable.x new file mode 100644 index 00000000..e062e9d0 --- /dev/null +++ b/math/iminterp/ii_sinctable.x @@ -0,0 +1,123 @@ +include + +# II_SINCTABLE -- Compute the 1D sinc function look-up tables given the +# width of the sinc function and the number of increments. + +procedure ii_sinctable (table, nconv, nincr, xshift) + +real table[nconv,nincr] #O the computed look-up table +int nconv #I the sinc truncation length +int nincr #I the number of look-up tables +real xshift #I the shift of the look up table + +int i, j, nsinc +real sconst, a2, a4, fsign, xsign, sum, dx, dx2, x, f + +begin + # Set up some constants. + nsinc = (nconv - 1) / 2 + sconst = (HALFPI / nsinc) ** 2 + a2 = -0.49670 + a4 = 0.03705 + if (mod (nsinc, 2) == 0) + fsign = 1.0 + else + fsign = -1.0 + + # Create a one entry look-up table. + if (! IS_INDEFR(xshift)) { + + dx = xshift + x = -nsinc - dx + xsign = fsign + sum = 0.0 + do j = 1, nconv { + if (x == 0.0) + f = 1.0 + else if (dx == 0.0) + f = 0.0 + else { + dx2 = sconst * (j - nsinc - 1) ** 2 + f = xsign / x * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + } + table[j,1] = f + sum = sum + f + x = x + 1.0 + xsign = -xsign + } + do j = 1, nconv + table[j,1] = table[j,1] / sum + + # Create a multi-entry evenly spaced look-up table. + } else { + + do i = 1, nincr { + dx = -0.5 + real (i - 1) / real (nincr - 1) + x = -nsinc + dx + xsign = fsign + sum = 0.0 + do j = 1, nconv { + if ((x >= - 0.5 / (nincr - 1)) && (x < 0.5 / (nincr - 1))) + f = 1.0 + else if ((dx >= -0.5 / (nincr - 1)) && + (dx < 0.5 / (nincr - 1))) + f = 0.0 + else { + dx2 = sconst * (j - nsinc - 1) ** 2 + f = xsign / x * (1.0 + a2 * dx2 + a4 * dx2 * dx2) ** 2 + } + table[j,i] = f + sum = sum + f + x = x + 1.0 + xsign = -xsign + } + do j = 1, nconv + table[j,i] = table[j,i] / sum + } + } +end + + +# II_BISINCTABLE -- Compute the 2D sinc function look-up tables given the +# width of the sinc function and the number of increments. + +procedure ii_bisinctable (table, nconv, nxincr, nyincr, xshift, yshift) + +real table[nconv,nconv,nxincr,nyincr] #O the computed look-up table +int nconv #I the sinc truncation length +int nxincr, nyincr #I the number of look-up tables +real xshift, yshift #I the shift of the look up table + +int j, ii, jj +pointer sp, fx, fy + +begin + # Allocate some working memory. + call smark (sp) + call salloc (fx, nconv * nxincr, TY_REAL) + call salloc (fy, nconv * nyincr, TY_REAL) + + # Create a one entry look-up table. + if (! IS_INDEFR(xshift) && ! IS_INDEFR(yshift)) { + + call ii_sinctable (Memr[fx], nconv, 1, xshift) + call ii_sinctable (Memr[fy], nconv, 1, yshift) + do j = 1, nconv { + call amulkr (Memr[fx], Memr[fy+j-1], table[1,j,1,1], nconv) + } + + } else { + + call ii_sinctable (Memr[fx], nconv, nxincr, xshift) + call ii_sinctable (Memr[fy], nconv, nyincr, yshift) + do jj = 1, nyincr { + do ii = 1, nxincr { + do j = 1, nconv + call amulkr (Memr[fx+(ii-1)*nconv], + Memr[fy+(jj-1)*nconv+j-1], table[1,j,ii,jj], nconv) + } + } + } + + call sfree (sp) +end diff --git a/math/iminterp/ii_spline.x b/math/iminterp/ii_spline.x new file mode 100644 index 00000000..c04a94de --- /dev/null +++ b/math/iminterp/ii_spline.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# II_SPLINE -- This procedure fits uniformly spaced data with a cubic +# spline. The spline is given as basis-spline coefficients that replace +# the data values. +# +# Storage at call time: +# +# bcoeff[1] = second derivative at x = 1 +# bcoeff[2] = first data point y[1] +# bcoeff[3] = y[2] +# +# bcoeff[n+1] = y[n] +# bcoeff[n+2] = second derivative at x = n +# +# Storage after call: +# +# bcoeff[1] ... bcoeff[n+2] = the n + 2 basis-spline coefficients for the +# basis splines as defined in P.M. Prenter's book "Splines and Variational +# Methods", Wiley, 1975. + +procedure ii_spline (bcoeff, diag, npts) + +real bcoeff[ARB] # data in and also bspline coefficients out +real diag[ARB] # needed for offdiagnol matrix elements +int npts # number of data points + +int i + +begin + diag[1] = -2. + bcoeff[1] = bcoeff[1] / 6. + + diag[2] = 0. + bcoeff[2] = (bcoeff[2] - bcoeff[1]) / 6. + + # Gaussian elimination - diagnol below main is made zero + # and main diagnol is made all 1's + do i = 3, npts + 1 { + diag[i] = 1. / (4. - diag[i-1]) + bcoeff[i] = diag[i] * (bcoeff[i] - bcoeff[i-1]) + } + + # Find last b spline coefficient first - overlay r.h.s.'s + bcoeff[npts+2] = ((diag[npts] + 2.) * bcoeff[npts+1] - bcoeff[npts] + + bcoeff[npts+2] / 6.) / (1. + diag[npts+1] * (diag[npts] + 2.)) + + # back substitute filling in coefficients for b splines + # note bcoeff[npts+1] is evaluated correctly as can be checked + # bcoeff[2] is already set since offdiagnol is 0. + do i = npts + 1, 3, -1 + bcoeff[i] = bcoeff[i] - diag[i] * bcoeff[i+1] + + # evaluate bcoeff[1] + bcoeff[1] = bcoeff[1] + 2. * bcoeff[2] - bcoeff[3] +end diff --git a/math/iminterp/ii_spline2d.x b/math/iminterp/ii_spline2d.x new file mode 100644 index 00000000..037e799c --- /dev/null +++ b/math/iminterp/ii_spline2d.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# II_SPLINE2D -- This procedure calculates the univariate B-spline coefficients +# for each row of data. The data are assumed to be uniformly spaced with a +# spacing of 1. The first element of each row of data is assumed to contain +# the second derivative of the data at x = 1. The nxpix + 2-th element of each +# row is assumed to contain the second derivative of the function at x = nxpix. +# Therfore if each row of data contains nxpix points, nxpix+2 B-spline +# coefficients will be calculated. The univariate B-spline coefficients +# for the i-th row of data are output to the i-th column of coeff. +# Therefore two calls to II_SPLINE2D are required to calculate the 2D B-spline +# coefficients. + +procedure ii_spline2d (data, coeff, nxpix, nvectors, len_data, len_coeff) + +real data[len_data,ARB] # input data array +real coeff[len_coeff,ARB] # output array of univariate coefficients in x +int nxpix # number of x data points +int nvectors # number of univariate splines to calculate +int len_data # row dimension of data +int len_coeff # row dimension of coeff + +int i, j +pointer diag + +errchk malloc, mfree + +begin + # allocate space for off-diagonal elements + call malloc (diag, nxpix+1, TY_REAL) + + # calculate off-diagonal elements by Gaussian elimination + Memr[diag] = -2. + Memr[diag+1] = 0. + do i = 3, nxpix + 1 + Memr[diag+i-1] = 1. / (4. - Memr[diag+i-2]) + + # loop over the nvectors rows of input data + do j = 1, nvectors { + + # copy the j-th row of data to the j-th column of coeff + do i = 1, nxpix + 2 + coeff[j,i] = data[i,j] + + # forward substitution + coeff[j,1] = coeff[j,1] / 6. + coeff[j,2] = (coeff[j,2] - coeff[j,1]) / 6. + do i = 3, nxpix + 1 + coeff[j,i] = Memr[diag+i-1] * (coeff[j,i] - coeff[j,i-1]) + + # back subsitution + coeff[j,nxpix+2] = ((Memr[diag+nxpix-1] + 2.) * coeff[j,nxpix+1] - + coeff[j,nxpix] + coeff[j,nxpix+2] / 6.) / + (1. + Memr[diag+nxpix] * (Memr[diag+nxpix-1] + 2.)) + do i = nxpix + 1, 3, - 1 + coeff[j,i] = coeff[j,i] - Memr[diag+i-1] * coeff[j,i+1] + coeff[j,1] = coeff[j,1] + 2. * coeff[j,2] - coeff[j,3] + + } + + # free space used for off-diagonal element storage + call mfree (diag, TY_REAL) +end diff --git a/math/iminterp/im1interpdef.h b/math/iminterp/im1interpdef.h new file mode 100644 index 00000000..3e6c69e7 --- /dev/null +++ b/math/iminterp/im1interpdef.h @@ -0,0 +1,55 @@ +# Header file for asi package + +# set up the asi descriptor + +define LEN_ASISTRUCT 10 + +define ASI_TYPE Memi[$1] # interpolator type +define ASI_NSINC Memi[$1+1] # sinc interpolator half-width +define ASI_NINCR Memi[$1+2] # number of sinc interpolator luts +define ASI_SHIFT Memr[P2R($1+3)] # sinc interpolator shift +define ASI_PIXFRAC Memr[P2R($1+4)] # pixel fraction for drizzle +define ASI_NCOEFF Memi[$1+5] # number of coefficients +define ASI_OFFSET Memi[$1+6] # offset of first data point +define ASI_COEFF Memi[$1+7] # pointer to coefficient array +define ASI_LTABLE Memi[$1+8] # pointer to sinc look-up table array +define ASI_BADVAL Memr[P2R($1+9)] # bad value for drizzle + +# define element of the coefficient array + +define COEFF Memr[P2P($1)] # element of the coefficient matrix +define LTABLE Memr[P2P($1)] # element of the look-up table + +# define structure for ASISAVE and ASIRESTORE + +define ASI_SAVETYPE $1[1] +define ASI_SAVENSINC $1[2] +define ASI_SAVENINCR $1[3] +define ASI_SAVESHIFT $1[4] +define ASI_SAVEPIXFRAC $1[5] +define ASI_SAVENCOEFF $1[6] +define ASI_SAVEOFFSET $1[7] +define ASI_SAVEBADVAL $1[8] +define ASI_SAVECOEFF 8 + +# define the sinc function truncation length, taper and precision parameters +# These should be identical to the definitions in im2interpdef.h. + +define NSINC 15 # the sinc truncation length +define NINCR 20 # the number of sinc look-up tables +define DX 0.001 # sinc interpolation minimum +define PIXFRAC 1.0 # drizzle pixel fraction +define MIN_PIXFRAC 0.001 # the minimum drizzle pixel fraction +define BADVAL 0.0 + +# define number of points used in spline interpolation for ARIEVAL, ARIDER +# and ARBPIX + +define SPLPTS 16 + +# miscellaneous + +define SPLINE3_ORDER 4 +define POLY3_ORDER 4 +define POLY5_ORDER 6 +define MAX_NDERIVS 6 diff --git a/math/iminterp/im2interpdef.h b/math/iminterp/im2interpdef.h new file mode 100644 index 00000000..6be7366d --- /dev/null +++ b/math/iminterp/im2interpdef.h @@ -0,0 +1,63 @@ +# Internal definitions for the 2D interpolator structure + +define LEN_MSISTRUCT 14 + +define MSI_TYPE Memi[$1] # interpolant type +define MSI_NSINC Memi[$1+1] # interpolant type +define MSI_NXINCR Memi[$1+2] # interpolant type +define MSI_NYINCR Memi[$1+3] # interpolant type +define MSI_XSHIFT Memr[P2R($1+4)] # x shift +define MSI_YSHIFT Memr[P2R($1+5)] # y shift +define MSI_XPIXFRAC Memr[P2R($1+6)] # x pixel fraction for drizzle +define MSI_YPIXFRAC Memr[P2R($1+7)] # y pixel fraction for drizzle +define MSI_NXCOEFF Memi[$1+8] # x dimension of coefficient array +define MSI_NYCOEFF Memi[$1+9] # y dimension of coefficient array +define MSI_COEFF Memi[$1+10] # pointer to coefficient array +define MSI_FSTPNT Memi[$1+11] # offset to first data point in coeff +define MSI_LTABLE Memi[$1+12] # offset to first data point in coeff +define MSI_BADVAL Memr[P2R($1+13)]# undefined pixel value for drizzle + +# Definitions for msisave and msirestore + +define MSI_SAVETYPE $1[1] +define MSI_SAVENSINC $1[2] +define MSI_SAVENXINCR $1[3] +define MSI_SAVENYINCR $1[4] +define MSI_SAVEXSHIFT $1[5] +define MSI_SAVEYSHIFT $1[6] +define MSI_SAVEXPIXFRAC $1[7] +define MSI_SAVEYPIXFRAC $1[8] +define MSI_SAVENXCOEFF $1[9] +define MSI_SAVENYCOEFF $1[10] +define MSI_SAVEFSTPNT $1[11] +define MSI_SAVEBADVAL $1[12] +define MSI_SAVECOEFF 12 + +# Array element definitions +# TEMP and DIAG for spline only + +define COEFF Memr[P2P($1)] # element of coefficient array +define LTABLE Memr[P2P($1)] # element of look-up array +define TEMP Memr[P2P($1)] # element of temporary array +define DIAG Memr[P2P($1)] # element of diagonal + +# The since function truncation length, taper, and precision definitions +# These should be identical to those in im1interpdef.h except for the DY +# definition. + +define NSINC 15 +define NINCR 20 +define DX 0.001 +define DY 0.001 +define PIXFRAC 1.0 +define MIN_PIXFRAC 0.001 +define BADVAL 0.0 + +# miscellaneous defintions + +define FNROWS 5 # maximum number or rows involved in + # boundary extension low side +define LNROWS 7 # maximum number of rows involved in + # high side boundary extension +define SPLPTS 16 # number of points for spline in mrieval +define MAX_NTERMS 6 # maximun number of terms in polynomials diff --git a/math/iminterp/mkpkg b/math/iminterp/mkpkg new file mode 100644 index 00000000..21941853 --- /dev/null +++ b/math/iminterp/mkpkg @@ -0,0 +1,53 @@ +# Image interpolator tools library. + +$checkout libiminterp.a ../ +$update libiminterp.a +$checkin libiminterp.a ../ +$exit + +libiminterp.a: + arbpix.x im1interpdef.h + arider.x im1interpdef.h + arieval.x im1interpdef.h + asider.x im1interpdef.h + asieval.x im1interpdef.h + asifit.x im1interpdef.h + asifree.x im1interpdef.h + asigeti.x im1interpdef.h + asigetr.x im1interpdef.h + asigrl.x im1interpdef.h + asiinit.x im1interpdef.h + asisinit.x im1interpdef.h + asirestore.x im1interpdef.h + asisave.x im1interpdef.h + asitype.x im1interpdef.h + asivector.x im1interpdef.h + ii_1dinteg.x im1interpdef.h + ii_bieval.x + ii_cubspl.f + ii_eval.x + ii_greval.x + ii_pc1deval.x im1interpdef.h + ii_pc2deval.x + ii_polterp.x im1interpdef.h + ii_sinctable.x + ii_spline.x + ii_spline2d.x + mrider.x im2interpdef.h + mrieval.x im2interpdef.h + msider.x im2interpdef.h + msieval.x im2interpdef.h + msifit.x im2interpdef.h + msifree.x im2interpdef.h + msigeti.x im2interpdef.h + msigetr.x im2interpdef.h + msigrid.x im2interpdef.h + msigrl.x im2interpdef.h + msiinit.x im2interpdef.h + msisinit.x im2interpdef.h + msirestore.x im2interpdef.h + msisave.x im2interpdef.h + msisqgrl.x im2interpdef.h + msivector.x im2interpdef.h + msitype.x im2interpdef.h + ; diff --git a/math/iminterp/mrider.x b/math/iminterp/mrider.x new file mode 100644 index 00000000..8413df55 --- /dev/null +++ b/math/iminterp/mrider.x @@ -0,0 +1,420 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MRIDER -- Procedure to evaluate the derivatives of the interpolant +# without the storage overhead required by the sequential version. +# The derivatives are stored such that der[1,1] = the value of the +# interpolant at x and y, der[2,1] = the first derivative in x and +# der[2,1] = the first derivative in y. + +procedure mrider (x, y, datain, nxpix, nypix, len_datain, der, nxder, nyder, + len_der, interp_type) + +real x[ARB] # x value +real y[ARB] # y value +real datain[len_datain,ARB] # data array +int nxpix # number of x data points +int nypix # number of y data points +int len_datain # row length of datain +real der[len_der, ARB] # array of derivatives +int nxder # number of derivatives in x +int nyder # number of derivatives in y +int len_der # row length of der, len_der >= nxder +int interp_type # interpolant type + +int nx, ny, nxterms, nyterms, row_length +int index, xindex, yindex, first_row, last_row +int i, j, ii, jj, kx, ky +pointer tmp +real coeff[SPLPTS+3,SPLPTS+3], pcoeff[MAX_NTERMS,MAX_NTERMS] +real pctemp[MAX_NTERMS,MAX_NTERMS], sum[MAX_NTERMS] +real hold21, hold12, hold22, accum, deltax, deltay, tmpx[4], tmpy[4] +real xmin, xmax, ymin, ymax, sx, sy, tx, ty + +errchk malloc, calloc, mfree + +begin + if (nxder < 1 || nyder < 1) + return + + # zero the derivatives + do j = 1, nyder { + do i = 1, nxder + der[i,j] = 0. + } + + switch (interp_type) { + + case II_BINEAREST: + + der[1,1] = datain[int (x[1]+.5), int (y[1]+.5)] + + return + + case II_BISINC, II_BILSINC: + + call ii_bisincder (x[1], y[1], der, nxder, nyder, len_der, datain, + 0, len_datain, nypix, NSINC, DX, DY) + + return + + case II_BILINEAR: + + nx = x[1] + sx = x[1] - nx + tx = 1. - sx + + ny = y[1] + sy = y[1] - ny + ty = 1. - sy + + # protect against the case where x = nxpix and/or y = nypix + if (nx >= nxpix) + hold21 = 2. * datain[nx,ny] - datain[nx-1,ny] + else + hold21 = datain[nx+1,ny] + if (ny >= nypix) + hold12 = 2. * datain[nx,ny] - datain[nx,ny-1] + else + hold12 = datain[nx,ny+1] + if (nx >= nxpix && ny >= nypix) + hold22 = 2. * hold21 - (2. * datain[nx,ny-1] - + datain[nx-1,ny-1]) + else if (nx >= nxpix) + hold22 = 2. * hold12 - datain[nx-1,ny+1] + else if (ny >= nypix) + hold 22 = 2. * hold21 - datain[nx+1,ny-1] + else + hold22 = datain[nx+1,ny+1] + + # evaluate the derivatives + der[1,1] = tx * ty * datain[nx,ny] + sx * ty * hold21 + + sy * tx * hold12 + sx * sy * hold22 + if (nxder > 1) + der[2,1] = - ty * datain[nx,ny] + ty * hold21 - + sy * hold12 + sy * hold22 + if (nyder > 1) + der[1,2] = - tx * datain[nx,ny] - sx * hold21 + + tx * hold12 + sx * hold22 + if (nxder > 1 && nyder > 1) + der[2,2] = datain[nx,ny] - hold21 - hold12 + hold22 + + + return + + case II_BIDRIZZLE: + call ii_bidriz1 (datain, 0, len_datain, x, y, der[1,1], 1, BADVAL) + if (nxder > 1) { + xmax = max (x[1], x[2], x[3], x[4]) + xmin = min (x[1], x[2], x[3], x[4]) + ymax = max (y[1], y[2], y[3], y[4]) + ymin = min (y[1], y[2], y[3], y[4]) + deltax = xmax - xmin + if (deltax == 0.0) + der[2,1] = 0.0 + else { + tmpx[1] = xmin; tmpy[1] = ymin + tmpx[2] = (xmax - xmin) / 2.0; tmpy[2] = ymin + tmpx[3] = (xmax - xmin) / 2.0; tmpy[3] = ymax + tmpx[4] = xmin; tmpy[4] = ymax + call ii_bidriz1 (datain, 0, len_datain, tmpx, tmpy, + accum, 1, BADVAL) + tmpx[1] = (xmax - xmin) / 2.0; tmpy[1] = ymin + tmpx[2] = xmax; tmpy[2] = ymin + tmpx[3] = xmax; tmpy[3] = ymax + tmpx[4] = (xmax - xmin) / 2.0; tmpy[4] = ymax + call ii_bidriz1 (datain, 0, len_datain, tmpx, tmpy, + der[2,1], 1, BADVAL) + der[2,1] = 2.0 * (der[2,1] - accum) / deltax + } + } + if (nyder > 1) { + deltay = ymax - ymin + if (deltay == 0.0) + der[1,2] = 0.0 + else { + tmpx[1] = xmin; tmpy[1] = ymin + tmpx[2] = xmax; tmpy[2] = ymin + tmpx[3] = xmax; tmpy[3] = (ymax - ymin) / 2.0 + tmpx[4] = xmin; tmpy[4] = (ymax - ymin) / 2.0 + call ii_bidriz1 (datain, 0, len_datain, tmpx, tmpy, + accum, 1, BADVAL) + tmpx[1] = xmin; tmpy[1] = (ymax - ymin) / 2.0 + tmpx[2] = xmax; tmpy[2] = (ymax - ymin) / 2.0 + tmpx[3] = xmax; tmpy[3] = ymax + tmpx[4] = xmin; tmpy[4] = ymax + call ii_bidriz1 (datain, 0, len_datain, tmpx, tmpy, + der[1,2], 1, BADVAL) + der[1,2] = 2.0 * (der[1,2] - accum) / deltay + } + } + + return + + case II_BIPOLY3: + + row_length = SPLPTS + 3 + + nxterms = 4 + nyterms = 4 + + nx = x[1] + ny = y[1] + + sx = x[1] - nx + sy = y[1] - ny + + # use boundary projection to extend the data rows + yindex = 1 + for (j = ny - 1; j <= ny + 2; j = j + 1) { + + # check that the data row is defined + if (j >= 1 && j <= nypix) { + + # extend the rows + xindex = 1 + for (i = nx - 1; i <= nx + 2; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,j] - + datain[2-i,j] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,j] - + datain[2*nxpix-i,j] + else + coeff[xindex,yindex] = datain[i,j] + xindex = xindex + 1 + } + } else if (j == (nypix + 2)) { + + # allow for the final row + xindex = 1 + for (i = nx - 1; i <= nx + 2; i = i + 1) { + if (i < 1) + coeff[xindex,nyterms] = 2. * datain[1,nypix-2] - + datain[2-i,nypix-2] + else if (i > nxpix) + coeff[xindex,nyterms] = 2. * datain[nxpix,nypix-2] - + datain[2*nxpix-i,nypix-2] + else + coeff[xindex,nyterms] = datain[i,nypix-2] + xindex = xindex + 1 + } + + } + + yindex = yindex + 1 + } + + + # project columns + first_row = max (1, 3 - ny) + if (first_row > 1) { + for (j = 1; j < first_row; j = j + 1) + call awsur (coeff[1, first_row], coeff[1, 2*first_row-j], + coeff[1,j], nxterms, 2., -1.) + } + + last_row = min (nxterms, nypix - ny + 2) + if (last_row < nxterms) { + for (j = last_row + 1; j <= nxterms - 1; j = j + 1) + call awsur (coeff[1,last_row], coeff[1,2*last_row-j], + coeff[1,j], nxterms, 2., -1.) + if (last_row == 2) + call awsur (coeff[1,last_row], coeff[1,4], coeff[1,4], + nxterms, 2., -1.) + else + call awsur (coeff[1,last_row], coeff[1,2*last_row-4], + coeff[1,4], nxterms, 2., -1.) + } + + # calculate the coefficients of the bicubic polynomial + call ii_pcpoly3 (coeff, 2, row_length, pcoeff, MAX_NTERMS) + + case II_BIPOLY5: + row_length = SPLPTS + 3 + + nxterms = 6 + nyterms = 6 + + nx = x[1] + ny = y[1] + + sx = x[1] - nx + sy = y[1] - ny + + # extend rows of data + yindex = 1 + for (j = ny - 2; j <= ny + 3; j = j + 1) { + + # select the rows containing data + if (j >= 1 && j <= nypix) { + + # extend the rows + xindex = 1 + for (i = nx - 2; i <= nx + 3; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,j] - + datain[2-i,j] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,j] - + datain[2*nxpix-i,j] + else + coeff[xindex,yindex] = datain[i,j] + xindex = xindex + 1 + } + + } else if (j == (ny + 3)) { + + # extend the rows + xindex = 1 + for (i = nx - 2; i <= nx + 3; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,nypix-3] - + datain[2-i,nypix-3] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,nypix-3] - + datain[2*nxpix-i,nypix-3] + else + coeff[xindex,yindex] = datain[i,nypix-3] + xindex = xindex + 1 + } + + } + + yindex = yindex + 1 + } + + # project columns + + first_row = max (1, 4 - ny) + if (first_row > 1) { + for (j = 1; j < first_row; j = j + 1) + call awsur (coeff[1,first_row], coeff[1,2*first_row-j], + coeff[1,j], nxterms, 2., -1.) + } + + last_row = min (nxterms, nypix - ny + 3) + if (last_row < nxterms) { + for (j = last_row + 1; j <= nxterms - 1; j = j + 1) + call awsur (coeff[1,last_row], coeff[1,2*last_row-j], + coeff[1,j], nxterms, 2., -1.) + if (last_row == 3) + call awsur (coeff[1,last_row], coeff[1,6], coeff[1,6], + nxterms, 2., -1.) + else + call awsur (coeff[1,last_row], coeff[1,2*last_row-6], + coeff[1,6], nxterms, 2., -1.) + } + + # caculate the polynomial coeffcients + call ii_pcpoly5 (coeff, 3, row_length, pcoeff, MAX_NTERMS) + + + case II_BISPLINE3: + row_length = SPLPTS + 3 + + nxterms = 4 + nyterms = 4 + + nx = x[1] + ny = y[1] + + sx = x[1] - nx + sy = y[1] - ny + + # allocate space for temporary array and 0 file + call calloc (tmp, row_length * row_length, TY_REAL) + + ky = 0 + # maximum number of points used in each direction is SPLPTS + for (j = ny - SPLPTS/2 + 1; j <= ny + SPLPTS/2; j = j + 1) { + + if (j < 1 || j > nypix) + ; + else { + ky = ky + 1 + if (ky == 1) + yindex = ny - j + 1 + + kx = 0 + for (i = nx - SPLPTS/2 + 1; i <= nx + SPLPTS/2; i = i + 1) { + if (i < 1 || i > nxpix) + ; + else { + kx = kx + 1 + if (kx == 1) + xindex = nx - i + 1 + coeff[kx+1,ky+1] = datain[i,j] + } + } + + coeff[1,ky+1] = 0. + coeff[kx+2,ky+1] = 0. + coeff[kx+3,ky+1] = 0. + + } + } + + # zero out 1st and last 2 rows + call amovkr (0., coeff[1,1], kx+3) + call amovkr (0., coeff[1,ky+2], kx+3) + call amovkr (0., coeff[1,ky+3],kx+3) + + # calculate the spline coefficients + call ii_spline2d (coeff, Memr[tmp], kx, ky+2, row_length, + row_length) + call ii_spline2d (Memr[tmp], coeff, ky, kx+2, row_length, + row_length) + + # calculate the polynomial coefficients + index = (yindex - 1) * row_length + xindex + 1 + call ii_pcspline3 (coeff, index, row_length, pcoeff, MAX_NTERMS) + + # free space + call mfree (tmp, TY_REAL) + } + + # evaluate the derivatives of the higher order interpolants + do j = 1, nyder { + + # set pctemp + do jj = nyterms, j, -1 { + do ii = 1, nxterms + pctemp[ii,jj] = pcoeff[ii,jj] + } + + do i = 1, nxder { + + # accumulate the partial sums in x + do jj = nyterms, j, -1 { + sum[jj] = pctemp[nxterms,jj] + do ii = nxterms - 1, i, -1 + sum[jj] = pctemp[ii,jj] + sum[jj] * sx + } + + # accumulate the sum in y + accum = sum[nyterms] + do jj = nyterms - 1, j, -1 + accum = sum[jj] + accum * sy + + # evaulate the derivative + der[i,j] = accum + + # differentiate in x + do jj = nyterms, j, -1 { + do ii = nxterms, i + 1, -1 + pctemp[ii,jj] = (ii - i) * pctemp[ii,jj] + } + + } + + # differentiate in y + do jj = 1, nxterms { + do ii = nyterms, j + 1, -1 + pcoeff[jj,ii] = (ii - j) * pcoeff[jj,ii] + } + + } +end diff --git a/math/iminterp/mrieval.x b/math/iminterp/mrieval.x new file mode 100644 index 00000000..6d89c456 --- /dev/null +++ b/math/iminterp/mrieval.x @@ -0,0 +1,303 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MRIEVAL -- Procedure to evaluate the 2D interpolant at a given value +# of x and y. MRIEVAL allows the interpolation of a few interpolated +# points without the computing time and storage required for the +# sequential version. The routine assumes that 1 <= x <= nxpix and +# 1 <= y <= nypix. + +real procedure mrieval (x, y, datain, nxpix, nypix, len_datain, interp_type) + +real x[ARB] # x value +real y[ARB] # y value +real datain[len_datain,ARB] # data array +int nxpix # number of x data points +int nypix # number of y data points +int len_datain # row length of datain +int interp_type # interpolant type + +int nx, ny, nterms, row_length +int xindex, yindex, first_row, last_row +int kx, ky +int i, j +pointer tmp +real coeff[SPLPTS+3,SPLPTS+3] +real hold21, hold12, hold22 +real sx, sy, tx, ty +real xval, yval, value +errchk malloc, calloc, mfree + +begin + switch (interp_type) { + + case II_BINEAREST: + return (datain[int (x[1]+0.5), int (y[1]+0.5)]) + + case II_BILINEAR: + nx = x[1] + sx = x[1] - nx + tx = 1. - sx + + ny = y[1] + sy = y[1] - ny + ty = 1. - sy + + # protect against the case where x = nxpix and/or y = nypix + if (nx >= nxpix) + hold21 = 2. * datain[nx,ny] - datain[nx-1,ny] + else + hold21 = datain[nx+1,ny] + if (ny >= nypix) + hold12 = 2. * datain[nx,ny] - datain[nx,ny-1] + else + hold12 = datain[nx,ny+1] + if (nx >= nxpix && ny >= nypix) + hold22 = 2. * hold21 - (2. * datain[nx,ny-1] - + datain[nx-1,ny-1]) + else if (nx >= nxpix) + hold22 = 2. * hold12 - datain[nx-1,ny+1] + else if (ny >= nypix) + hold22 = 2. * hold21 - datain[nx+1,ny-1] + else + hold22 = datain[nx+1,ny+1] + + # evaluate the interpolant + value = tx * ty * datain[nx,ny] + sx * ty * hold21 + + sy * tx * hold12 + sx * sy * hold22 + + return (value) + + case II_BIDRIZZLE: + call ii_bidriz1 (datain, 0, len_datain, x, y, value, 1, BADVAL) + + return (value) + + case II_BIPOLY3: + row_length = SPLPTS + 3 + nterms = 4 + nx = x[1] + ny = y[1] + + # major problem is that near the edge the interior polynomial + # must be defined + + # use boundary projection to extend the data rows + yindex = 1 + for (j = ny - 1; j <= ny + 2; j = j + 1) { + + # check that the data row is defined + if (j >= 1 && j <= nypix) { + + # extend the rows + xindex = 1 + for (i = nx - 1; i <= nx + 2; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,j] - + datain[2-i,j] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,j] - + datain[2*nxpix-i,j] + else + coeff[xindex,yindex] = datain[i,j] + xindex = xindex + 1 + } + + } else if (j == (ny + 2)) { + + # extend the rows + xindex = 1 + for (i = nx - 1; i <= nx + 2; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,nypix-2] - + datain[2-i,nypix-2] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,nypix-2] - + datain[2*nxpix-i,nypix-2] + else + coeff[xindex,yindex] = datain[i,nypix-2] + xindex = xindex + 1 + } + + } + + yindex = yindex + 1 + } + + # project columns + + first_row = max (1, 3 - ny) + if (first_row > 1) { + for (j = 1; j < first_row; j = j + 1) + call awsur (coeff[1, first_row], coeff[1, 2*first_row-j], + coeff[1,j], nterms, 2., -1.) + } + + last_row = min (nterms, nypix - ny + 2) + if (last_row < nterms) { + for (j = last_row + 1; j <= nterms - 1; j = j + 1) + call awsur (coeff[1,last_row], coeff[1,2*last_row-j], + coeff[1,j], nterms, 2., -1.) + if (last_row == 2) + call awsur (coeff[1,last_row], coeff[1,4], coeff[1,4], + nterms, 2., -1.) + else + call awsur (coeff[1,last_row], coeff[1,2*last_row-4], + coeff[1,4], nterms, 2., -1.) + } + + + # center the x value and call evaluation routine + xval = 2 + (x[1] - nx) + yval = 2 + (y[1] - ny) + call ii_bipoly3 (coeff, 0, row_length, xval, yval, value, 1) + + return (value) + + case II_BIPOLY5: + row_length = SPLPTS + 3 + nterms = 6 + nx = x[1] + ny = y[1] + + # major problem is to define interior polynomial near the edge + + # loop over the rows of data + yindex = 1 + for (j = ny - 2; j <= ny + 3; j = j + 1) { + + # select the rows containing data + if (j >= 1 && j <= nypix) { + + # extend the rows + xindex = 1 + for (i = nx - 2; i <= nx + 3; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,j] - + datain[2-i,j] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,j] - + datain[2*nxpix-i,j] + else + coeff[xindex,yindex] = datain[i,j] + xindex = xindex + 1 + } + + } else if (j == (ny + 3)) { + + # extend the rows + xindex = 1 + for (i = nx - 2; i <= nx + 3; i = i + 1) { + if (i < 1) + coeff[xindex,yindex] = 2. * datain[1,nypix-3] - + datain[2-i,nypix-3] + else if (i > nxpix) + coeff[xindex,yindex] = 2. * datain[nxpix,nypix-3] - + datain[2*nxpix-i,nypix-3] + else + coeff[xindex,yindex] = datain[i,nypix-3] + xindex = xindex + 1 + } + + } + + yindex = yindex + 1 + } + + # project columns + + first_row = max (1, 4 - ny) + if (first_row > 1) { + for (j = 1; j < first_row; j = j + 1) + call awsur (coeff[1,first_row], coeff[1,2*first_row-j], + coeff[1,j], nterms, 2., -1.) + } + + last_row = min (nterms, nypix - ny + 3) + if (last_row < nterms) { + for (j = last_row + 1; j <= nterms - 1; j = j + 1) + call awsur (coeff[1,last_row], coeff[1,2*last_row-j], + coeff[1,j], nterms, 2., -1.) + if (last_row == 3) + call awsur (coeff[1,last_row], coeff[1,6], coeff[1,6], + nterms, 2., -1.) + else + call awsur (coeff[1,last_row], coeff[1,2*last_row-6], + coeff[1,6], nterms, 2., -1.) + } + + # call evaluation routine + xval = 3 + (x[1] - nx) + yval = 3 + (y[1] - ny) + call ii_bipoly5 (coeff, 0, row_length, xval, yval, value, 1) + + return (value) + + case II_BISPLINE3: + row_length = SPLPTS + 3 + nx = x[1] + ny = y[1] + + # allocate space for temporary array and 0 file + call calloc (tmp, row_length * row_length, TY_REAL) + + ky = 0 + # maximum number of points used in each direction is SPLPTS + for (j = ny - SPLPTS/2 + 1; j <= ny + SPLPTS/2; j = j + 1) { + + if (j < 1 || j > nypix) + ; + else { + ky = ky + 1 + if (ky == 1) + yindex = ny - j + 1 + + kx = 0 + for (i = nx - SPLPTS/2 + 1; i <= nx + SPLPTS/2; i = i + 1) { + if (i < 1 || i > nxpix) + ; + else { + kx = kx + 1 + if (kx == 1) + xindex = nx - i + 1 + coeff[kx+1,ky+1] = datain[i,j] + } + } + + coeff[1,ky+1] = 0. + coeff[kx+2,ky+1] = 0. + coeff[kx+3,ky+1] = 0. + + } + } + + # zero out 1st and last 2 rows + call amovkr (0., coeff[1,1], kx+3) + call amovkr (0., coeff[1,ky+2], kx+3) + call amovkr (0., coeff[1,ky+3],kx+3) + + # calculate the spline coefficients + call ii_spline2d (coeff, Memr[tmp], kx, ky+2, row_length, + row_length) + call ii_spline2d (Memr[tmp], coeff, ky, kx+2, row_length, + row_length) + + # evaluate spline + xval = xindex + 1 + (x[1] - nx) + yval = yindex + 1 + (y[1] - ny) + call ii_bispline3 (coeff, 0, row_length, xval, yval, value, 1) + + # free space + call mfree (tmp, TY_REAL) + + return (value) + + case II_BISINC, II_BILSINC: + call ii_bisinc (datain, 0, len_datain, nypix, x, y, value, 1, + NSINC, DX, DY) + + return (value) + } +end diff --git a/math/iminterp/msider.x b/math/iminterp/msider.x new file mode 100644 index 00000000..e66d9119 --- /dev/null +++ b/math/iminterp/msider.x @@ -0,0 +1,294 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIDER -- Calculate the derivatives of the interpolant. The derivative +# der[i,j] = d f(x,y) / dx (i-1) dy (j-1). Therefore der[1,1] contains +# the value of the interpolant, der[2,1] the 1st derivative in x and +# der[1,2] the first derivative in y. + +procedure msider (msi, x, y, der, nxder, nyder, len_der) + +pointer msi # pointer to interpolant descriptor structure +real x[ARB] # x value +real y[ARB] # y value +real der[len_der,ARB] # derivative array +int nxder # number of x derivatives +int nyder # number of y derivatives +int len_der # row length of der, len_der >= nxder + +int first_point, len_coeff +int nxterms, nyterms, nx, ny, nyd, nxd +int i, j, ii, jj +real sx, sy, tx, ty, xmin, xmax, ymin, ymax +real pcoeff[MAX_NTERMS,MAX_NTERMS], pctemp[MAX_NTERMS,MAX_NTERMS] +real sum[MAX_NTERMS], accum, deltax, deltay, tmpx[4], tmpy[4] +pointer index, ptr + +begin + if (nxder < 1 || nyder < 1) + return + + # set up coefficient array parameters + len_coeff = MSI_NXCOEFF(msi) + index = MSI_COEFF(msi) + MSI_FSTPNT(msi) - 1 + + # zero the derivatives + do j = 1, nyder { + do i = 1, nxder + der[i,j] = 0. + } + + # calculate the appropriate number of terms of the polynomials in + # x and y + + switch (MSI_TYPE(msi)) { + + case II_BINEAREST: + + nx = x[1] + 0.5 + ny = y[1] + 0.5 + + ptr = index + (ny - 1) * len_coeff + nx + der[1,1] = COEFF(ptr) + + return + + case II_BISINC, II_BILSINC: + + call ii_bisincder (x[1], y[1], der, nxder, nyder, len_der, + COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), MSI_NXCOEFF(msi), + MSI_NYCOEFF(msi), MSI_NSINC(msi), DX, DY) + + return + + case II_BILINEAR: + + nx = x[1] + ny = y[1] + sx = x[1] - nx + sy = y[1] - ny + tx = 1. - sx + ty = 1. - sy + + ptr = index + (ny - 1) * len_coeff + nx + der[1,1] = tx * ty * COEFF(ptr) + sx * ty * COEFF(ptr+1) + + sy * tx * COEFF(ptr+len_coeff) + + sx * sy * COEFF(ptr+len_coeff+1) + + if (nxder > 1) + der[2,1] = -ty * COEFF(ptr) + ty * COEFF(ptr+1) - + sy * COEFF(ptr+len_coeff) + + sy * COEFF(ptr+len_coeff+1) + + if (nyder > 1) + der[1,2] = -tx * COEFF(ptr) - sx * COEFF(ptr+1) + + tx * COEFF(ptr+len_coeff) + + sx * COEFF(ptr+len_coeff+1) + + if (nyder > 1 && nxder > 1) + der[2,2] = COEFF(ptr) - COEFF(ptr+1) - COEFF(ptr+len_coeff) + + COEFF(ptr+len_coeff+1) + + return + + case II_BIDRIZZLE: + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, der[1,1], 1, MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + #MSI_NXCOEFF(msi), x, y, der[1,1], 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, der[1,1], 1, MSI_XPIXFRAC(msi), + MSI_YPIXFRAC(msi), MSI_BADVAL(msi)) + + if (nxder > 1) { + xmax = max (x[1], x[2], x[3], x[4]) + xmin = min (x[1], x[2], x[3], x[4]) + ymax = max (y[1], y[2], y[3], y[4]) + ymin = min (y[1], y[2], y[3], y[4]) + deltax = xmax - xmin + if (deltax == 0.0) + der[2,1] = 0.0 + else { + tmpx[1] = xmin; tmpy[1] = ymin + tmpx[2] = (xmax - xmin) / 2.0; tmpy[2] = ymin + tmpx[3] = (xmax - xmin) / 2.0; tmpy[3] = ymax + tmpx[4] = xmin; tmpy[4] = ymax + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, accum, 1, + MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && + #MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), + #MSI_FSTPNT(msi), MSI_NXCOEFF(msi), tmpx, tmpy, + #accum, 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, accum, 1, + MSI_XPIXFRAC(msi), MSI_YPIXFRAC(msi), + MSI_BADVAL(msi)) + tmpx[1] = (xmax - xmin) / 2.0; tmpy[1] = ymin + tmpx[2] = xmax; tmpy[2] = ymin + tmpx[3] = xmax; tmpy[3] = ymax + tmpx[4] = (xmax - xmin) / 2.0; tmpy[4] = ymax + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, der[2,1], 1, + MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && + #MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), + #MSI_FSTPNT(msi), MSI_NXCOEFF(msi), tmpx, tmpy, + #der[2,1], 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, der[2,1], 1, + MSI_XPIXFRAC(msi), MSI_YPIXFRAC(msi), + MSI_BADVAL(msi)) + der[2,1] = 2.0 * (der[2,1] - accum) / deltax + } + } + if (nyder > 1) { + deltay = ymax - ymin + if (deltay == 0.0) + der[1,2] = 0.0 + else { + tmpx[1] = xmin; tmpy[1] = ymin + tmpx[2] = xmax; tmpy[2] = ymin + tmpx[3] = xmax; tmpy[3] = (ymax - ymin) / 2.0 + tmpx[4] = xmin; tmpy[4] = (ymax - ymin) / 2.0 + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, accum, 1, + MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && + #MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), + #MSI_FSTPNT(msi), MSI_NXCOEFF(msi), tmpx, tmpy, + #accum, 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, accum, 1, + MSI_XPIXFRAC(msi), MSI_YPIXFRAC(msi), + MSI_BADVAL(msi)) + tmpx[1] = xmin; tmpy[1] = (ymax - ymin) / 2.0 + tmpx[2] = xmax; tmpy[2] = (ymax - ymin) / 2.0 + tmpx[3] = xmax; tmpy[3] = ymax + tmpx[4] = xmin; tmpy[4] = ymax + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, der[1,2], 1, + MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && + #MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), + #MSI_FSTPNT(msi), MSI_NXCOEFF(msi), tmpx, tmpy, + #der[1,2], 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), tmpx, tmpy, der[1,2], 1, + MSI_XPIXFRAC(msi), MSI_YPIXFRAC(msi), + MSI_BADVAL(msi)) + der[1,2] = 2.0 * (der[1,2] - accum) / deltay + } + } + + return + + case II_BIPOLY3: + + nxterms = 4 + nyterms = 4 + + nxd = min (nxder, 4) + nyd = min (nyder, 4) + + nx = x[1] + sx = x[1] - nx + ny = y[1] + sy = y[1] - ny + + first_point = MSI_FSTPNT(msi) + (ny - 2) * len_coeff + nx + call ii_pcpoly3 (COEFF(MSI_COEFF(msi)), first_point, len_coeff, + pcoeff, 6) + + case II_BIPOLY5: + + nxterms = 6 + nyterms = 6 + + nxd = min (nxder, 6) + nyd = min (nyder, 6) + + nx = x[1] + sx = x[1] - nx + ny = y[1] + sy = y[1] - ny + + first_point = MSI_FSTPNT(msi) + (ny - 3) * len_coeff + nx + call ii_pcpoly5 (COEFF(MSI_COEFF(msi)), first_point, len_coeff, + pcoeff, 6) + + case II_BISPLINE3: + + nxterms = 4 + nyterms = 4 + + nxd = min (nxder, 4) + nyd = min (nyder, 4) + + nx = x[1] + sx = x[1] - nx + ny = y[1] + sy = y[1] - ny + + first_point = MSI_FSTPNT(msi) + (ny - 2) * len_coeff + nx + call ii_pcspline3 (COEFF(MSI_COEFF(msi)), first_point, len_coeff, + pcoeff, 6) + } + + # evaluate the derivatives by nested multiplication + do j = 1, nyd { + + # set pctemp + do jj = nyterms, j, -1 { + do ii = 1, nxterms + pctemp[ii,jj] = pcoeff[ii,jj] + } + + do i = 1, nxd { + + # accumulate the partial sums in x + do jj = nyterms, j, -1 { + sum[jj] = pctemp[nxterms,jj] + do ii = nxterms - 1, i, -1 + sum[jj] = pctemp[ii,jj] + sum[jj] * sx + } + + # accumulate the sum in y + accum = sum[nyterms] + do jj = nyterms - 1, j, -1 + accum = sum[jj] + accum * sy + + # evaluate derivative + der[i,j] = accum + + # differentiate in x + do jj = nyterms, j, -1 { + do ii = nxterms, i + 1, -1 + pctemp[ii,jj] = (ii - i) * pctemp[ii,jj] + } + } + + # differentiate in y + do jj = 1, nxterms { + do ii = nyterms, j + 1, -1 + pcoeff[jj,ii] = (ii - j) * pcoeff[jj,ii] + } + } +end diff --git a/math/iminterp/msieval.x b/math/iminterp/msieval.x new file mode 100644 index 00000000..26af75b6 --- /dev/null +++ b/math/iminterp/msieval.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIEVAL -- Procedure to evaluate the interpolant at a single point. +# The procedure assumes that 1 <= x <= nxpix and that 1 <= y <= nypix. +# Checking for out of bounds pixels is the responsibility of the calling +# program. + +real procedure msieval (msi, x, y) + +pointer msi # pointer to the interpolant descriptor +real x[ARB] # x data value +real y[ARB] # y data value + +real value + +begin + switch (MSI_TYPE(msi)) { + + case II_BINEAREST: + call ii_binearest (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1) + return (value) + + case II_BILINEAR: + call ii_bilinear (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1) + return (value) + + case II_BIPOLY3: + call ii_bipoly3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1) + return (value) + + case II_BIPOLY5: + call ii_bipoly5 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1) + return (value) + + case II_BISPLINE3: + call ii_bispline3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1) + return (value) + + case II_BISINC: + call ii_bisinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, value, 1, + MSI_NSINC(msi), DX, DY) + return (value) + + case II_BILSINC: + call ii_bilsinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, value, 1, + LTABLE(MSI_LTABLE(msi)), 2 * MSI_NSINC(msi) + 1, + MSI_NXINCR(msi), MSI_NYINCR(msi), DX, DY) + return (value) + + case II_BIDRIZZLE: + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1, MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + #MSI_NXCOEFF(msi), x, y, value, 1, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, value, 1, MSI_XPIXFRAC(msi), + MSI_YPIXFRAC(msi), MSI_BADVAL(msi)) + return (value) + + } +end diff --git a/math/iminterp/msifit.x b/math/iminterp/msifit.x new file mode 100644 index 00000000..27d861ff --- /dev/null +++ b/math/iminterp/msifit.x @@ -0,0 +1,275 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIFIT -- MSIFIT calculates the coefficients of the interpolant. +# With the exception of the bicubic spline interpolant the coefficients +# are stored as the data points. The 2D B-spline coefficients are +# calculated using the routines II_SPLINE2D. MSIFIT checks that the +# dimensions of the data array are appropriate for the interpolant selected +# and allocates space for the coefficient array. +# Boundary extension is performed using boundary projection. + +procedure msifit (msi, datain, nxpix, nypix, len_datain) + +pointer msi # pointer to interpolant descriptor structure +real datain[len_datain,ARB] # data array +int nxpix # number of points in the x dimension +int nypix # number of points in the y dimension +int len_datain # row length of datain + +int i, j +pointer fptr, nptr, rptr +pointer tmp +pointer rptrf[FNROWS] +pointer rptrl[LNROWS] + +errchk calloc, mfree + +begin + # check the row length of datain + if (len_datain < nxpix) + call error (0, "MSIFIT: Row length of datain too small.") + + # check that the number of data points in x and y is + # appropriate for the interpolant type selected and + # allocate space for the coefficient array allowing + # sufficient storage for boundary extension + + switch (MSI_TYPE(msi)) { + + case II_BINEAREST: + + if (nxpix < 1 || nypix < 1) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + MSI_NYCOEFF(msi) = nypix + MSI_FSTPNT(msi) = 0 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call malloc (MSI_COEFF(msi), nxpix * nypix, TY_REAL) + } + + case II_BILINEAR, II_BIDRIZZLE: + + if (nxpix < 2 || nypix < 2) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + 1 + MSI_NYCOEFF(msi) = nypix + 1 + MSI_FSTPNT(msi) = 0 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call malloc (MSI_COEFF(msi), + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), TY_REAL) + } + + case II_BIPOLY3: + + if (nxpix < 4 || nypix < 4) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + 3 + MSI_NYCOEFF(msi) = nypix + 3 + MSI_FSTPNT(msi) = MSI_NXCOEFF(msi) + 1 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call malloc (MSI_COEFF(msi), + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), TY_REAL) + } + + case II_BIPOLY5: + + if (nxpix < 6 || nypix < 6) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + 5 + MSI_NYCOEFF(msi) = nypix + 5 + MSI_FSTPNT(msi) = 2 * MSI_NXCOEFF(msi) + 2 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call malloc (MSI_COEFF(msi), + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), TY_REAL) + } + + case II_BISPLINE3: + + if (nxpix < 4 || nypix < 4) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + 3 + MSI_NYCOEFF(msi) = nypix + 3 + MSI_FSTPNT(msi) = MSI_NXCOEFF(msi) + 1 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call calloc (MSI_COEFF(msi), + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), TY_REAL) + } + + case II_BISINC, II_BILSINC: + + if (nxpix < 1 || nypix < 1) { + call error (0, "MSIFIT: Too few data points.") + return + } else { + MSI_NXCOEFF(msi) = nxpix + MSI_NYCOEFF(msi) = nypix + MSI_FSTPNT(msi) = 0 + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + call calloc (MSI_COEFF(msi), nxpix * nypix, TY_REAL) + } + + } + + # index the coefficient pointer so that COEFF(fptr+1) points to the + # first data point in the coefficient array + fptr = MSI_COEFF(msi) - 1 + MSI_FSTPNT(msi) + + # load data into coefficient array + rptr = fptr + do j = 1, nypix { + call amovr (datain[1,j], COEFF(rptr+1), nxpix) + rptr = rptr + MSI_NXCOEFF(msi) + } + + # calculate the coefficients of the interpolant + # boundary extension is performed using boundary projection + + switch (MSI_TYPE(msi)) { + + case II_BINEAREST, II_BISINC, II_BILSINC: + + # no end conditions necessary, coefficients stored as data + + case II_BILINEAR, II_BIDRIZZLE: + + # extend the rows + rptr = fptr + nxpix + do j = 1, nypix { + COEFF(rptr+1) = 2. * COEFF(rptr) - COEFF(rptr-1) + rptr = rptr + MSI_NXCOEFF(msi) + } + + # define the pointers to the last, 2nd last and third last rows + rptrl[1] = MSI_COEFF(msi) + (MSI_NYCOEFF(msi) - 1) * + MSI_NXCOEFF(msi) + do i = 2, 3 + rptrl[i] = rptrl[i-1] - MSI_NXCOEFF(msi) + + # define the last row by extending the columns + call awsur (COEFF(rptrl[2]), COEFF(rptrl[3]), COEFF(rptrl[1]), + MSI_NXCOEFF(msi), 2., -1.) + + case II_BIPOLY3: + + # extend the rows + rptr = fptr + nptr = fptr + nxpix + do j = 1, nypix { + COEFF(rptr) = 2. * COEFF(rptr+1) - COEFF(rptr+2) + COEFF(nptr+1) = 2. * COEFF(nptr) - COEFF(nptr-1) + COEFF(nptr+2) = 2. * COEFF(nptr) - COEFF(nptr-2) + rptr = rptr + MSI_NXCOEFF(msi) + nptr = nptr + MSI_NXCOEFF(msi) + } + + # define pointers to first, second and third rows + rptrf[1] = MSI_COEFF(msi) + do i = 2, 3 + rptrf[i] = rptrf[i-1] + MSI_NXCOEFF(msi) + + # extend the columns, first row + call awsur (COEFF(rptrf[2]), COEFF(rptrf[3]), COEFF(rptrf[1]), + MSI_NXCOEFF(msi), 2., -1.) + + # define the pointers to the last to fifth last rows + rptrl[1] = MSI_COEFF(msi) + (MSI_NYCOEFF(msi) - 1) * + MSI_NXCOEFF(msi) + do i = 2, 5 + rptrl[i] = rptrl[i-1] - MSI_NXCOEFF(msi) + + # extend the columns, define 2nd last row + call awsur (COEFF(rptrl[3]), COEFF(rptrl[4]), COEFF(rptrl[2]), + MSI_NXCOEFF(msi), 2., -1.) + + # extend the columns, define last row + call awsur (COEFF(rptrl[3]), COEFF(rptrl[5]), COEFF(rptrl[1]), + MSI_NXCOEFF(msi), 2., -1.) + + case II_BIPOLY5: + + # extend the rows + rptr = fptr + nptr = fptr + nxpix + do j = 1, nypix { + COEFF(rptr-1) = 2. * COEFF(rptr+1) - COEFF(rptr+3) + COEFF(rptr) = 2. * COEFF(rptr+1) - COEFF(rptr+2) + COEFF(nptr+1) = 2. * COEFF(nptr) - COEFF(nptr-1) + COEFF(nptr+2) = 2. * COEFF(nptr) - COEFF(nptr-2) + COEFF(nptr+3) = 2. * COEFF(nptr) - COEFF(nptr-3) + rptr = rptr + MSI_NXCOEFF(msi) + nptr = nptr + MSI_NXCOEFF(msi) + } + + # define pointers to first five rows + rptrf[1] = MSI_COEFF(msi) + do i = 2, 5 + rptrf[i] = rptrf[i-1] + MSI_NXCOEFF(msi) + + # extend the columns, define first row + call awsur (COEFF(rptrf[3]), COEFF(rptrf[5]), COEFF(rptrf[1]), + MSI_NXCOEFF(msi), 2., -1.) + + # extend the columns, define second row + call awsur (COEFF(rptrf[3]), COEFF(rptrf[4]), COEFF(rptrf[2]), + MSI_NXCOEFF(msi), 2., -1.) + + # define pointers last seven rows + rptrl[1] = MSI_COEFF(msi) + (MSI_NYCOEFF(msi) - 1) * + MSI_NXCOEFF(msi) + do i = 2, 7 + rptrl[i] = rptrl[i-1] - MSI_NXCOEFF(msi) + + # extend the columns, last row + call awsur (COEFF(rptrl[4]), COEFF(rptrl[7]), COEFF(rptrl[1]), + MSI_NXCOEFF(msi), 2., -1.) + + # extend the columns, 2nd last row + call awsur (COEFF(rptrl[4]), COEFF(rptrl[6]), COEFF(rptrl[2]), + MSI_NXCOEFF(msi), 2., -1.) + + # extend the columns, 3rd last row + call awsur (COEFF(rptrl[4]), COEFF(rptrl[5]), COEFF(rptrl[3]), + MSI_NXCOEFF(msi), 2., -1.) + + case II_BISPLINE3: + + # allocate space for a temporary work arrays + call calloc (tmp, MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), TY_REAL) + + # the B-spline coefficients are calculated using the + # natural end conditions, end coefficents are set to + # zero + + # calculate the univariate B_spline coefficients in x + call ii_spline2d (COEFF(MSI_COEFF(msi)), TEMP(tmp), + nxpix, MSI_NYCOEFF(msi), MSI_NXCOEFF(msi), MSI_NYCOEFF(msi)) + + + # calculate the univariate B-spline coefficients in y to + # results of x interpolation + call ii_spline2d (TEMP(tmp), COEFF(MSI_COEFF(msi)), + nypix, MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), MSI_NXCOEFF(msi)) + + # deallocate storage for temporary arrays + call mfree (tmp, TY_REAL) + } +end diff --git a/math/iminterp/msifree.x b/math/iminterp/msifree.x new file mode 100644 index 00000000..0740e2ee --- /dev/null +++ b/math/iminterp/msifree.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" + +# MSIFREE -- Procedure to deallocate the interpolant descriptor structure. + +procedure msifree (msi) + +pointer msi # pointer to the interpolant descriptor structure +errchk mfree + +begin + # free coefficient array + if (MSI_COEFF(msi) != NULL) + call mfree (MSI_COEFF(msi), TY_REAL) + if (MSI_LTABLE(msi) != NULL) + call mfree (MSI_LTABLE(msi), TY_REAL) + + # free interpolant descriptor + call mfree (msi, TY_STRUCT) +end diff --git a/math/iminterp/msigeti.x b/math/iminterp/msigeti.x new file mode 100644 index 00000000..5ff14bfc --- /dev/null +++ b/math/iminterp/msigeti.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIGETI -- Procedure to fetch an asi integer parameter + +int procedure msigeti (msi, param) + +pointer msi # interpolant descriptor +int param # parameter to be fetched + +begin + switch (param) { + case II_MSITYPE: + return (MSI_TYPE(msi)) + case II_MSINSAVE: + return (MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi) + MSI_SAVECOEFF) + case II_MSINSINC: + return (MSI_NSINC(msi)) + default: + call error (0, "MSIGETI: Unknown MSI parameter.") + } +end diff --git a/math/iminterp/msigetr.x b/math/iminterp/msigetr.x new file mode 100644 index 00000000..7fd66597 --- /dev/null +++ b/math/iminterp/msigetr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIGETR -- Procedure to fetch an msi real parameter + +real procedure msigetr (msi, param) + +pointer msi # interpolant descriptor +int param # parameter to be fetched + +begin + switch (param) { + case II_MSIBADVAL: + return (MSI_BADVAL(msi)) + default: + call error (0, "MSIGETR: Unknown MSI parameter.") + } +end diff --git a/math/iminterp/msigrid.x b/math/iminterp/msigrid.x new file mode 100644 index 00000000..01d114a2 --- /dev/null +++ b/math/iminterp/msigrid.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIGRID -- Procedure to evaluate the interpolant on a rectangular +# grid. The procedure assumes that 1 <= x <= nxpix and 1 <= y <= nypix. +# The x and y vectors must be ordered such that x[i] < x[i+1] and +# y[i] < y[i+1]. + +procedure msigrid (msi, x, y, zfit, nx, ny, len_zfit) + +pointer msi # pointer to interpolant descriptor structure +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[len_zfit,ARB] # array of fitted values +int nx # number of x points +int ny # number of y points +int len_zfit # row length of zfit + +errchk ii_grnearest, ii_grlinear, ii_grpoly3, ii_grpoly5, ii_grspline3 +errchk ii_grsinc, ii_grlsinc, ii_grdirz + +begin + + switch (MSI_TYPE(msi)) { + + case II_BINEAREST: + call ii_grnearest (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, nx, ny, len_zfit) + + case II_BILINEAR: + call ii_grlinear (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, nx, ny, len_zfit) + + case II_BIPOLY3: + call ii_grpoly3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, nx, ny, len_zfit) + + case II_BIPOLY5: + call ii_grpoly5 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, nx, ny, len_zfit) + + case II_BISPLINE3: + call ii_grspline3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, nx, ny, len_zfit) + + case II_BISINC: + call ii_grsinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, zfit, nx, ny, len_zfit, + MSI_NSINC(msi), DX, DY) + + case II_BILSINC: + call ii_grlsinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, zfit, nx, ny, len_zfit, + LTABLE(MSI_LTABLE(msi)), 2 * MSI_NSINC(msi) + 1, MSI_NXINCR(msi), + MSI_NYINCR(msi), DX, DY) + + case II_BIDRIZZLE: + call ii_grdriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, zfit, nx, ny, + len_zfit, MSI_XPIXFRAC(msi), MSI_YPIXFRAC(msi), + MSI_BADVAL(msi)) + } +end diff --git a/math/iminterp/msigrl.x b/math/iminterp/msigrl.x new file mode 100644 index 00000000..7baeac34 --- /dev/null +++ b/math/iminterp/msigrl.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im2interpdef.h" +include + +# MSIGRL -- Procedure to integrate the 2D interpolant over a specified area. +# The x and y arrays are assumed to describe a polygon which is the domain over +# which the integration is to be performed. The x and y must describe a closed +# curve and npts must be >= 4 with the last vertex equal to the first vertex. +# The routine uses the technique of separation of variables. The restriction on +# the polygon is that horizontal lines have at most one segment in common with +# the domain of integration. Polygons which do not fit this restriction can be +# split into one or more polygons before calling msigrl and the results can +# then be summed. + +real procedure msigrl (msi, x, y, npts) + +pointer msi # pointer to the interpolant descriptor structure +real x[npts] # array of x values +real y[npts] # array of y values +int npts # number of points which describe the boundary + +int i, interp_type, nylmin, nylmax, offset +pointer x1lim, x2lim, xintegrl, ptr +real xmin, xmax, ymin, ymax, accum +real ii_1dinteg() + +begin + # set up 1D interpolant type + switch (MSI_TYPE(msi)) { + case II_BINEAREST: + interp_type = II_NEAREST + case II_BILINEAR: + interp_type = II_LINEAR + case II_BIDRIZZLE: + interp_type = II_DRIZZLE + case II_BIPOLY3: + interp_type = II_POLY3 + case II_BIPOLY5: + interp_type = II_POLY5 + case II_BISPLINE3: + interp_type = II_SPLINE3 + case II_BISINC: + interp_type = II_SINC + case II_BILSINC: + interp_type = II_LSINC + } + + # set up temporary storage for x limits and the x integrals + call calloc (x1lim, MSI_NYCOEFF(msi), TY_REAL) + call calloc (x2lim, MSI_NYCOEFF(msi), TY_REAL) + call calloc (xintegrl, MSI_NYCOEFF(msi), TY_REAL) + + # offset of first data point from edge of coefficient array + offset = mod (MSI_FSTPNT(msi), MSI_NXCOEFF(msi)) + + # convert the (x,y) points which describe the polygon into + # two arrays of x limits x1lim and x2lim and two y limits ymin and ymax + call ii_find_limits (x, y, npts, 0, 0, MSI_NYCOEFF(msi), + Memr[x1lim+offset], Memr[x2lim+offset], ymin, ymax, nylmin, nylmax) + nylmin = nylmin + offset + nylmax = nylmax + offset + + # integrate in x + ptr = MSI_COEFF(msi) + offset + (nylmin - 1) * MSI_NXCOEFF(msi) + do i = nylmin, nylmax { + xmin = min (Memr[x1lim+i-1], Memr[x2lim+i-1]) + xmax = max (Memr[x1lim+i-1], Memr[x2lim+i-1]) + Memr[xintegrl+i-1] = ii_1dinteg (COEFF(ptr), MSI_NXCOEFF(msi), + xmin, xmax, interp_type, MSI_NSINC(msi), DX, MSI_XPIXFRAC(msi)) + ptr = ptr + MSI_NXCOEFF(msi) + } + + # integrate in y + if (interp_type == II_SPLINE3) { + call amulkr (Memr[xintegrl], 6.0, Memr[xintegrl], MSI_NYCOEFF(msi)) + accum = ii_1dinteg (Memr[xintegrl+offset], MSI_NYCOEFF(msi), ymin, + ymax, II_NEAREST, MSI_NSINC(msi), DY, MSI_YPIXFRAC(msi)) + } else { + accum = ii_1dinteg (Memr[xintegrl+offset], MSI_NYCOEFF(msi), ymin, + ymax, II_NEAREST, MSI_NSINC(msi), DY, MSI_YPIXFRAC(msi)) + } + + # free space + call mfree (xintegrl, TY_REAL) + call mfree (x1lim, TY_REAL) + call mfree (x2lim, TY_REAL) + + return (accum) +end + + +# II_FIND_LIMITS -- Procedure to transform a set of (x,y)'s describing a +# polygon into a set of limits. + +procedure ii_find_limits (x, y, npts, xboff, xeoff, max_nylines, x1lim, x2lim, +ymin, ymax, nylmin, nylmax) + +real x[npts] # array of x values +real y[npts] # array of y values +int npts # number of data points +int xboff, xeoff # boundary extension limits +int max_nylines # max number of lines to integrate +real x1lim[ARB] # array of x1 limits +real x2lim[ARB] # array of x2 limits +real ymin # minimum y value for integration +real ymax # maximum y value for integration +int nylmin # minimum line number for x integration +int nylmax # maximum line number for x integration + +int i, ninter +pointer sp, xintr, yintr +real xmin, xmax, lx, ld +int ii_pyclip() + +begin + call smark (sp) + call salloc (xintr, npts, TY_REAL) + call salloc (yintr, npts, TY_REAL) + + # find x and y limits and their indicess + call alimr (x, npts, xmin, xmax) + call alimr (y, npts, ymin, ymax) + + # calculate the line limits for integration + nylmin = max (1, min (int (ymin + 0.5) - xboff, max_nylines)) + nylmax = min (max_nylines, max (1, int (ymax + 0.5) + xeoff)) + + # initialize + lx = xmax - xmin + + # calculate the limits + for (i = nylmin; i <= nylmax; i = i + 1) { + + if (ymin > i) + ld = min (i + 0.5, ymax) * lx + else if (ymax < i) + ld = max (i - 0.5, ymin) * lx + else + ld = i * lx + ninter = ii_pyclip (x, y, Memr[xintr], Memr[yintr], npts, lx, ld) + if (ninter <= 0) { + x1lim[i] = xmin + x2lim[i] = xmin + } else { + x1lim[i] = min (Memr[xintr], Memr[xintr+1]) + x2lim[i] = max (Memr[xintr], Memr[xintr+1]) + } + } + + call sfree (sp) +end + + +# II_YCLIP -- Procedure to determine the intersection points of a +# horizontal image line with an arbitrary polygon. + +int procedure ii_pyclip (xver, yver, xintr, yintr, nver, lx, ld) + +real xver[ARB] # x vertex coords +real yver[ARB] # y vertex coords +real xintr[ARB] # x intersection coords +real yintr[ARB] # y intersection coords +int nver # number of vertices +real lx, ld # equation of image line + +int i, nintr +real u1, u2, u1u2, dx, dy, dd, xa, ya, wa + +begin + nintr = 0 + u1 = - lx * yver[1] + ld + do i = 2, nver { + + u2 = - lx * yver[i] + ld + u1u2 = u1 * u2 + + # Test whether polygon line segment intersects image line or not. + if (u1u2 <= 0.0) { + + + # Compute the intersection coords. + if (u1 != 0.0 && u2 != 0.0) { + + dy = yver[i-1] - yver[i] + dx = xver[i-1] - xver[i] + dd = xver[i-1] * yver[i] - yver[i-1] * xver[i] + xa = (dx * ld - lx * dd) + ya = dy * ld + wa = dy * lx + nintr = nintr + 1 + xintr[nintr] = xa / wa + yintr[nintr] = ya / wa + + # Test for collinearity. + } else if (u1 == 0.0 && u2 == 0.0) { + + nintr = nintr + 1 + xintr[nintr] = xver[i-1] + yintr[nintr] = yver[i-1] + nintr = nintr + 1 + xintr[nintr] = xver[i] + yintr[nintr] = yver[i] + + } else if (u1 != 0.0) { + + if (i == 1) { + dy = (yver[2] - yver[1]) + dd = (yver[nver-1] - yver[1]) + } else if (i == nver) { + dy = (yver[2] - yver[nver]) + dd = dy * (yver[nver-1] - yver[nver]) + } else { + dy = (yver[i+1] - yver[i]) + dd = dy * (yver[i-1] - yver[i]) + } + + if (dy != 0.0) { + nintr = nintr + 1 + xintr[nintr] = xver[i] + yintr[nintr] = yver[i] + } + + if (dd > 0.0) { + nintr = nintr + 1 + xintr[nintr] = xver[i] + yintr[nintr] = yver[i] + } + + } + } + + u1 = u2 + } + + return (nintr) +end diff --git a/math/iminterp/msiinit.x b/math/iminterp/msiinit.x new file mode 100644 index 00000000..895470e4 --- /dev/null +++ b/math/iminterp/msiinit.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIINIT -- Procedure to initialize the sewquential 2D image interpolation +# package. MSIINIT checks that the interpolant is one of the permitted +# types and allocates space for the interpolant descriptor structure. +# MSIINIT returns the pointer to the interpolant descriptor structure. + +procedure msiinit (msi, interp_type) + +pointer msi # pointer to the interpolant descriptor structure +int interp_type # interpolant type + +int nconv +errchk malloc + +begin + if (interp_type < 1 || interp_type > II_NTYPES2D) { + call error (0, "MSIINIT: Illegal interpolant.") + } else { + call calloc (msi, LEN_MSISTRUCT, TY_STRUCT) + MSI_TYPE(msi) = interp_type + switch (interp_type) { + case II_BILSINC: + MSI_NSINC(msi) = NSINC + MSI_NXINCR(msi) = NINCR + if (MSI_NXINCR(msi) > 1) + MSI_NXINCR(msi) = MSI_NXINCR(msi) + 1 + MSI_NYINCR(msi) = NINCR + if (MSI_NYINCR(msi) > 1) + MSI_NYINCR(msi) = MSI_NYINCR(msi) + 1 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + nconv = 2 * MSI_NSINC(msi) + 1 + call calloc (MSI_LTABLE(msi), nconv * MSI_NXINCR(msi) * nconv * + MSI_NYINCR(msi), TY_REAL) + call ii_bisinctable (LTABLE(MSI_LTABLE(msi)), nconv, + MSI_NXINCR(msi), MSI_NYINCR(msi), MSI_XSHIFT(msi), + MSI_YSHIFT(msi)) + case II_BISINC: + MSI_NSINC(msi) = NSINC + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_LTABLE(msi) = NULL + case II_BIDRIZZLE: + MSI_NSINC(msi) = 0 + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_XPIXFRAC(msi) = PIXFRAC + MSI_YPIXFRAC(msi) = PIXFRAC + MSI_LTABLE(msi) = NULL + default: + MSI_NSINC(msi) = 0 + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_LTABLE(msi) = NULL + } + MSI_COEFF(msi) = NULL + MSI_BADVAL(msi) = BADVAL + } +end diff --git a/math/iminterp/msirestore.x b/math/iminterp/msirestore.x new file mode 100644 index 00000000..1a6b4c1c --- /dev/null +++ b/math/iminterp/msirestore.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIRESTORE -- Procedure to restore the interpolant stored by MSISAVE +# for use by MSIEVAL, MSIVECTOR, MSIDER and MSIGRL. + +procedure msirestore (msi, interpolant) + +pointer msi # interpolant descriptor +real interpolant[ARB] # array containing the interpolant + +int interp_type, npix + +begin + interp_type = nint (MSI_SAVETYPE(interpolant)) + if (interp_type < 1 || interp_type > II_NTYPES) + call error (0, "MSIRESTORE: Unknown interpolant type.") + + # allocate the interpolant descriptor structure and restore + # interpolant parameters + call malloc (msi, LEN_MSISTRUCT, TY_STRUCT) + MSI_TYPE(msi) = interp_type + MSI_NSINC(msi) = nint (MSI_SAVENSINC(interpolant)) + MSI_NXINCR(msi) = nint (MSI_SAVENXINCR(interpolant)) + MSI_NYINCR(msi) = nint (MSI_SAVENYINCR(interpolant)) + MSI_XSHIFT(msi) = MSI_SAVEXSHIFT(interpolant) + MSI_YSHIFT(msi) = MSI_SAVEYSHIFT(interpolant) + MSI_XPIXFRAC(msi) = MSI_SAVEXPIXFRAC(interpolant) + MSI_YPIXFRAC(msi) = MSI_SAVEYPIXFRAC(interpolant) + MSI_NXCOEFF(msi) = nint (MSI_SAVENXCOEFF(interpolant)) + MSI_NYCOEFF(msi) = nint (MSI_SAVENYCOEFF(interpolant)) + MSI_FSTPNT(msi) = nint (MSI_SAVEFSTPNT(interpolant)) + MSI_BADVAL(msi) = MSI_SAVEBADVAL(interpolant) + + # allocate space for and restore coefficients + call malloc (MSI_COEFF(msi), MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi), + TY_REAL) + call amovr (interpolant[1+MSI_SAVECOEFF], COEFF(MSI_COEFF(msi)), + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi)) + + # allocate space for and restore the look-up table + if (MSI_NXINCR(msi) > 0 && MSI_NYINCR(msi) > 0) { + npix = (2.0 * MSI_NSINC(msi) + 1) ** 2 * MSI_NXINCR(msi) * + MSI_NYINCR(msi) + call amovr (interpolant[1+MSI_SAVECOEFF+MSI_NXCOEFF(msi) * + MSI_NYCOEFF(msi)], LTABLE(MSI_LTABLE(msi)), npix) + } +end diff --git a/math/iminterp/msisave.x b/math/iminterp/msisave.x new file mode 100644 index 00000000..109e9698 --- /dev/null +++ b/math/iminterp/msisave.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSISAVE -- Procedure to save the interpolant for later use by MSIEVAL, +# MSIVECTOR, MSIDER and MSIGRL. + +procedure msisave (msi, interpolant) + +pointer msi # interpolant descriptor +real interpolant[ARB] # array containing the interpolant + +int npix + +begin + # save interpolant type, number of coefficients and position of + # first data point + MSI_SAVETYPE(interpolant) = MSI_TYPE(msi) + MSI_SAVENSINC(interpolant) = MSI_NSINC(msi) + MSI_SAVENXINCR(interpolant) = MSI_NXINCR(msi) + MSI_SAVENYINCR(interpolant) = MSI_NYINCR(msi) + MSI_SAVEXSHIFT(interpolant) = MSI_XSHIFT(msi) + MSI_SAVEYSHIFT(interpolant) = MSI_YSHIFT(msi) + MSI_SAVEXPIXFRAC(interpolant) = MSI_XPIXFRAC(msi) + MSI_SAVEYPIXFRAC(interpolant) = MSI_YPIXFRAC(msi) + MSI_SAVENXCOEFF(interpolant) = MSI_NXCOEFF(msi) + MSI_SAVENYCOEFF(interpolant) = MSI_NYCOEFF(msi) + MSI_SAVEFSTPNT(interpolant) = MSI_FSTPNT(msi) + MSI_SAVEBADVAL(interpolant) = MSI_BADVAL(msi) + + # save coefficients + call amovr (COEFF(MSI_COEFF(msi)), interpolant[MSI_SAVECOEFF+1], + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi)) + + # save look-up table + if (MSI_NXINCR(msi) > 0 && MSI_NYINCR(msi) > 0) { + npix = (2 * MSI_NSINC(msi) + 1) ** 2 * + MSI_NXINCR(msi) * MSI_NYINCR(msi) + call amovr (LTABLE(MSI_LTABLE(msi)), interpolant[MSI_SAVECOEFF+1+ + MSI_NXCOEFF(msi) * MSI_NYCOEFF(msi)], npix) + } +end diff --git a/math/iminterp/msisinit.x b/math/iminterp/msisinit.x new file mode 100644 index 00000000..6208331c --- /dev/null +++ b/math/iminterp/msisinit.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSISINIT -- Procedure to initialize the sewquential 2D image interpolation +# package. MSISINIT checks that the interpolant is one of the permitted +# types and allocates space for the interpolant descriptor structure. +# MSIINIT returns the pointer to the interpolant descriptor structure. + +procedure msisinit (msi, interp_type, nsinc, nxincr, nyincr, xshift, yshift, + badval) + +pointer msi # pointer to the interpolant descriptor structure +int interp_type # interpolant type +int nsinc # nsinc interpolation width +int nxincr, nyincr # number of look-up table elements in x and y +real xshift, yshift # the x and y shifts +real badval # undefined value for drizzle interpolant + +int nconv +errchk malloc + +begin + if (interp_type < 1 || interp_type > II_NTYPES2D) { + call error (0, "MSIINIT: Illegal interpolant.") + } else { + call calloc (msi, LEN_MSISTRUCT, TY_STRUCT) + MSI_TYPE(msi) = interp_type + switch (interp_type) { + + case II_BILSINC: + MSI_NSINC(msi) = (nsinc - 1) / 2 + MSI_NXINCR(msi) = nxincr + MSI_NYINCR(msi) = nyincr + if (nxincr > 1) { + MSI_NXINCR(msi) = MSI_NXINCR(msi) + 1 + MSI_XSHIFT(msi) = INDEFR + } else { + MSI_XSHIFT(msi) = xshift + } + if (nyincr > 1) { + MSI_YSHIFT(msi) = INDEFR + MSI_NYINCR(msi) = MSI_NYINCR(msi) + 1 + } else { + MSI_YSHIFT(msi) = yshift + } + MSI_XPIXFRAC(msi) = PIXFRAC + MSI_YPIXFRAC(msi) = PIXFRAC + nconv = 2 * MSI_NSINC(msi) + 1 + call calloc (MSI_LTABLE(msi), nconv * MSI_NXINCR(msi) * nconv * + MSI_NYINCR(msi), TY_REAL) + call ii_bisinctable (LTABLE(MSI_LTABLE(msi)), nconv, + MSI_NXINCR(msi), MSI_NYINCR(msi), MSI_XSHIFT(msi), + MSI_YSHIFT(msi)) + + case II_BISINC: + MSI_NSINC(msi) = (nsinc - 1) / 2 + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_XPIXFRAC(msi) = PIXFRAC + MSI_YPIXFRAC(msi) = PIXFRAC + MSI_LTABLE(msi) = NULL + + case II_BIDRIZZLE: + MSI_NSINC(msi) = 0 + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_XPIXFRAC(msi) = max (MIN_PIXFRAC, min (xshift, 1.0)) + MSI_YPIXFRAC(msi) = max (MIN_PIXFRAC, min (yshift, 1.0)) + MSI_LTABLE(msi) = NULL + + default: + MSI_NSINC(msi) = 0 + MSI_NXINCR(msi) = 0 + MSI_NYINCR(msi) = 0 + MSI_XSHIFT(msi) = INDEFR + MSI_YSHIFT(msi) = INDEFR + MSI_XPIXFRAC(msi) = PIXFRAC + MSI_YPIXFRAC(msi) = PIXFRAC + MSI_LTABLE(msi) = NULL + + } + MSI_COEFF(msi) = NULL + MSI_BADVAL(msi) = badval + } +end diff --git a/math/iminterp/msisqgrl.x b/math/iminterp/msisqgrl.x new file mode 100644 index 00000000..82a3122b --- /dev/null +++ b/math/iminterp/msisqgrl.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "im2interpdef.h" +include + +# MSISQGRL -- Procedure to integrate the 2D interpolant over a rectangular +# region. + +real procedure msisqgrl (msi, x1, x2, y1, y2) + +pointer msi # pointer to the interpolant descriptor structure +real x1, x2 # x integration limits +real y1, y2 # y integration limits + +int i, interp_type, nylmin, nylmax, offset +pointer xintegrl, ptr +real xmin, xmax, ymin, ymax, accum +real ii_1dinteg() + +begin + # set up 1D interpolant type to match 2-D interpolant + switch (MSI_TYPE(msi)) { + case II_BINEAREST: + interp_type = II_NEAREST + case II_BILINEAR: + interp_type = II_LINEAR + case II_BIDRIZZLE: + interp_type = II_DRIZZLE + case II_BIPOLY3: + interp_type = II_POLY3 + case II_BIPOLY5: + interp_type = II_POLY5 + case II_BISPLINE3: + interp_type = II_SPLINE3 + case II_BISINC: + interp_type = II_SINC + case II_BILSINC: + interp_type = II_LSINC + } + + # set up temporary storage for x integrals + call calloc (xintegrl, MSI_NYCOEFF(msi), TY_REAL) + + # switch order of x integration at the end + xmin = x1 + xmax = x2 + if (x2 < x1) { + xmax = x2 + xmin = x1 + } + + # switch order of y integration at end + ymin = y1 + ymax = y2 + if (y2 < y1) { + ymax = y2 + ymin = y1 + } + + # find the appropriate range in y in the coeff array + offset = mod (MSI_FSTPNT(msi), MSI_NXCOEFF(msi)) + nylmin = max (1, min (MSI_NYCOEFF(msi), int (ymin + 0.5))) + nylmax = min (MSI_NYCOEFF(msi), max (1, int (ymax + 0.5))) + nylmin = nylmin + offset + nylmax = nylmax + offset + + # integrate in x + ptr = MSI_COEFF(msi) + offset + (nylmin - 1) * MSI_NXCOEFF(msi) + do i = nylmin, nylmax { + Memr[xintegrl+i-1] = ii_1dinteg (COEFF(ptr), MSI_NXCOEFF(msi), + xmin, xmax, interp_type, MSI_NSINC(msi), DX, MSI_XPIXFRAC(msi)) + if (x2 < x1) + Memr[xintegrl+i-1] = - Memr[xintegrl+i-1] + ptr = ptr + MSI_NXCOEFF(msi) + } + + # integrate in y + if (interp_type == II_SPLINE3) { + call amulkr (Memr[xintegrl], 6.0, Memr[xintegrl], + MSI_NYCOEFF(msi)) + accum = ii_1dinteg (Memr[xintegrl+offset], MSI_NYCOEFF(msi), + ymin, ymax, II_NEAREST, MSI_NSINC(msi), DY, MSI_YPIXFRAC(msi)) + } else + accum = ii_1dinteg (Memr[xintegrl+offset], MSI_NYCOEFF(msi), + ymin, ymax, II_NEAREST, MSI_NSINC(msi), DY, MSI_YPIXFRAC(msi)) + + # free space + call mfree (xintegrl, TY_REAL) + + # correct for integration error. + if (y2 < y1) + return (-accum) + else + return (accum) +end diff --git a/math/iminterp/msitype.x b/math/iminterp/msitype.x new file mode 100644 index 00000000..27bea8ac --- /dev/null +++ b/math/iminterp/msitype.x @@ -0,0 +1,97 @@ +include "im2interpdef.h" +include + +# MSITYPE -- Decode the interpolation string input by the user. + +procedure msitype (interpstr, interp_type, nsinc, nincr, shift) + +char interpstr[ARB] # the input interpolation string +int interp_type # the interpolation type +int nsinc # the sinc interpolation width +int nincr # the sinc interpolation lut resolution +real shift # the predefined shift / pixfrac + +int ip +pointer sp, str +int strdic(), strncmp(), ctoi(), ctor() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + interp_type = strdic (interpstr, Memc[str], SZ_FNAME, II_BFUNCTIONS) + + # Use the default interpolant parameters. + if (interp_type > 0) { + switch (interp_type) { + case II_BILSINC: + nsinc = 2 * NSINC + 1 + nincr = NINCR + shift = INDEFR + case II_BISINC: + nsinc = 2 * NSINC + 1 + nincr = 0 + shift = INDEFR + case II_BIDRIZZLE: + nsinc = 0 + nincr = 0 + shift = PIXFRAC + default: + nsinc = 0 + nincr = 0 + shift = INDEFR + } + + # Try to decode the look-up table sinc parameters. + } else if (strncmp (interpstr, "lsinc", 5) == 0) { + ip = 6 + interp_type = II_BILSINC + if (ctoi (interpstr, ip, nsinc) <= 0) { + nsinc = 2 * NSINC + 1 + nincr = NINCR + shift = INDEFR + } else { + if (interpstr[ip] == '[') + ip = ip + 1 + if (ctor (interpstr, ip, shift) <= 0) + shift = INDEFR + if (IS_INDEFR(shift) || interpstr[ip] != ']') { + nincr = NINCR + shift = INDEFR + } else if (shift >= -0.5 && shift < 0.5) { + nincr = 1 + } else { + nincr = nint (shift) + shift = INDEFR + } + } + + # Try to decode the sinc parameters. + } else if (strncmp (interpstr, "sinc", 4) == 0) { + ip = 5 + interp_type = II_BISINC + if (ctoi (interpstr, ip, nsinc) <= 0) + nsinc = 2 * NSINC + 1 + nincr = 0 + shift = INDEFR + } else if (strncmp (interpstr, "drizzle", 7) == 0) { + ip = 8 + if (interpstr[ip] == '[') + ip = ip + 1 + if (ctor (interpstr, ip, shift) <= 0) + shift = PIXFRAC + interp_type = II_DRIZZLE + nsinc = 0 + nincr = 0 + if (interpstr[ip] != ']') + shift = PIXFRAC + else if (shift < 0.0 || shift > 1.0) + shift = PIXFRAC + } else { + interp_type = 0 + nsinc = 0 + nincr = 0 + shift = INDEFR + } + + call sfree (sp) +end diff --git a/math/iminterp/msivector.x b/math/iminterp/msivector.x new file mode 100644 index 00000000..dcc0915d --- /dev/null +++ b/math/iminterp/msivector.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "im2interpdef.h" +include + +# MSIVECTOR -- Procedure to evaluate the interpolant at an array of arbitrarily +# spaced points. The routines assume that 1 <= x <= nxpix and 1 <= y <= nypix. +# Checking for out of bounds pixels is the responsibility of the calling +# program. + +procedure msivector (msi, x, y, zfit, npts) + +pointer msi # pointer to the interpolant descriptor structure +real x[ARB] # array of x values +real y[ARB] # array of y values +real zfit[npts] # array of interpolated values +int npts # number of points to be evaluated + +begin + switch (MSI_TYPE(msi)) { + + case II_BINEAREST: + call ii_binearest (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts) + + case II_BILINEAR: + call ii_bilinear (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts) + + case II_BIPOLY3: + call ii_bipoly3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts) + + case II_BIPOLY5: + call ii_bipoly5 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts) + + case II_BISPLINE3: + call ii_bispline3 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts) + + case II_BISINC: + call ii_bisinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, zfit, npts, + MSI_NSINC(msi), DX, DY) + + case II_BILSINC: + call ii_bilsinc (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), MSI_NYCOEFF(msi), x, y, zfit, npts, + LTABLE(MSI_LTABLE(msi)), 2 * MSI_NSINC(msi) + 1, + MSI_NXINCR(msi), MSI_NYINCR(msi), DX, DY) + + case II_BIDRIZZLE: + if (MSI_XPIXFRAC(msi) >= 1.0 && MSI_YPIXFRAC(msi) >= 1.0) + call ii_bidriz1 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts, MSI_BADVAL(msi)) + #else if (MSI_XPIXFRAC(msi) <= 0.0 && MSI_YPIXFRAC(msi) <= 0.0) + #call ii_bidriz0 (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + #MSI_NXCOEFF(msi), x, y, zfit, npts, MSI_BADVAL(msi)) + else + call ii_bidriz (COEFF(MSI_COEFF(msi)), MSI_FSTPNT(msi), + MSI_NXCOEFF(msi), x, y, zfit, npts, MSI_XPIXFRAC(msi), + MSI_YPIXFRAC(msi), MSI_BADVAL(msi)) + } +end diff --git a/math/interp/Iinterp.hlp b/math/interp/Iinterp.hlp new file mode 100644 index 00000000..527f0375 --- /dev/null +++ b/math/interp/Iinterp.hlp @@ -0,0 +1,293 @@ + +.help INTERP Jan83 "Image Interpolation Package" +.sh +Introduction + + One of the most common operations in image processing is interpolation. +Due to the very large amount of data involved, efficiency is quite important, +and the general purpose routines available from many sources cannot be used. + + +The task of interpolating image data is simplified by the following +considerations: +.ls 4 +.ls o +The pixels (data points) are equally spaced along a line or on a rectangular +grid. +.le +.ls o +There is no need for coordinate transformations. The coordinates of a pixel +or point to be interpolated are the same as the subscript of the pixel in the +data array. The coordinate of the first pixel in the array may be assumed +to be 1.0, and the spacing between pixels is also 1.0. +.le +.le + + +The task of interpolating image data is complicated by the following +considerations: +.ls +.ls o +We would like the "quality" of the interpolator to be something that can +be set at run time by the user. This is done by permitting the user to +select the type of interpolator to be used, and the order of interpolation. +The following interpolators will be provided: + +.nf + - nearest neighbor + - linear + - natural cubic spline + - divided differences, either 3rd or 5th order. +.fi +.le +.ls o +The interpolator must be able to deal with indefinite valued pixels. +In the IRAF, an indefinite valued pixel has the special value INDEF. +If the interpolator cannot return a meaningful interpolated value +(due to the presence of indefinite pixels in the data, or because the +coordinates of the point to be interpolated are out of bounds) the value +INDEF should be returned instead. +.le +.le + +.sh +Sequential Interpolation of One Dimensional Arrays + + Ideally, we should be able to define a single set of procedures +which can perform interpolation by any of the techniques mentioned above. +The procedures for interpolating one dimensional arrays are optimized +for the case where the entire array is to be sampled, probably in a sequential +fashion. + +The following calls should suffice. The package prefix is "asi", meaning +array sequential interpolate, and the last three letters of each procedure +name are used to describe the action performed by the procedure. The +interpolator is restricted to single precision real data, so there is no +need for a type suffix. + +.ks +.nf + asiset (coeff, interpolator_type, boundary_type) + asifit (data, npts, coeff) + y = asival (x, coeff) # evaluate y(x) + asider (x, derivs, nderiv, coeff) # derivatives + v = asigrl (x1, x2, coeff) # take integral +.fi +.ke + +Here, COEFF is a structure used to describe the interpolant, and +the interpolator type is chosen from the following set of options: + +.ks +.nf + NEAREST return value of nearest neighbor + LINEAR linear interpolation + DIVDIF3 third order divided differences + DIVDIF5 fifth order divided differences + SPLINE3 cubic spline +.fi +.ke + +When the VAL procedure is called to evaluate the interpolant at a point X, +the code must check to see if X is out of bounds. If so, the type of value +returned may be specified by the third and final argument to the SET procedure. + +.ks +.nf + B_NEAREST return nearest boundary (nb) value + B_INDEF (default; return indefinite) + B_REFLECT interpolate at abs(x) + B_WRAP wrap around to opposite boundary + B_PROJECT return y(nb) - (y(abs(x)) - y(nb)) +.fi +.ke + +For example, the following subset preprocessor code fragment uses +the array interpolation routines to shift a data array by a constant +amount: + + +.ks +.nf + real shift, coeff[NPIX+SZ_ASIHDR] + real inrow[NPIX], outrow[NPIX], asival() + int i, interpolator_type, boundary_type, clgeti() + + begin + # get parameters from CL, setup interpolator + interpolator_type = clgeti ("interpolator") + boundary_type = clgeti ("boundary_type") + call asiset (coeff, interpolator_type, boundary_type) + + [code to read pixels into inrow] + call asifit (inrow, NPIX, coeff) + + do i = 1, NPIX # do the interpolation + outrow[i] = asival (i + shift, coeff) +.fi +.ke + + +The array COEFF is actually a simple structure. An initial call to ASISET +is required to save the interpolator parameters in the COEFF structure. +ASIFIT computes the coefficients of the interpolator curve, leaving the +coefficients in the appropriate part of the COEFF structure. Thereafter, +COEFF is read only. ASIVAL evaluates the zeroth derivative of the curve +at the given X coordinate. ASIDER evaluates the first NDERIV derivatives +at X, writing the values of these derivatives into the DERIVS output array. +ASIGRL integrates the interpolant over the indicated range (returning INDEF +if there are any indefinite pixels in that range). + +.ks +.nf + element usage + + 1 type of interpolator + 2 type of boundary condition + 3 number of pixels in x + 4 number of pixels in y + 5-9 reserved for future use + 10-N coefficients + + The COEFF structure +.fi +.ke + + +In the case of the nearest neighbor and linear interpolation algorithms, +the coefficient array will contain the same data as the input data array. +The cubic spline algorithm requires space for NPIX+2 b-spline coefficients. +The space requirements of the divided differences algorithm are similar. +The constant SZ_ASIHDR should allow enough space for the worst case. + +Note that both 3rd and 5th order divided differences interpolators are +provided, but only the 3rd order (cubic) spline. This is because the +5th order spline is considerably harder than the cubic spline. We can easily +add a 5th order spline, or indeed a completely new algorithm such as the sinc +function interpolator, without changing the calling sequences or data +structures. + +.sh +Random Interpolation of One Dimensional Arrays + + If we wish only to interpolate a small region of an array, or a few +points scattered along the array at random, or if memory space is more +precious than execution speed, then a different sort of interpolator is +desirable. We can dispense with the coefficient array in this case, and +operate directly on the data array. + +.ks +.nf + ariset (interpolator_type, boundary_type) + arifit (data, npts) + y = arival (x, data) + arider (x, derivs, nderiv, data) +.fi +.ke + +Since the number of points required to interpolate at a given X value +is fixed, these routines are internally quite different than the sequential +procedures. + +.sh +Sequential Interpolation of Two Dimensional Arrays + + None of the interpolation algorithms mentioned above are difficult +to generalize to two dimensions. The calling sequences should be kept as +similar as possible. The sequential two dimensional procedures are limited +by the size of the two dimensional array which can be kept in memory, and +therefore are most useful for subrasters. The COEFF array should be +declared as a one dimensional array, even though it used to store a two +dimensional array of coefficients. + +.ks +.nf + msiset (coeff, interpolator_type), boundary_type) + msifit (data, nx, ny, coeff) + y = msival (x, y, coeff) + msider (x, y, derivs, nderiv, coeff) +.fi +.ke + +Note that the coefficients of the bicubic spline are obtained by first +doing a one dimensional spline fit to the rows of the data array, leaving +the resultant coefficients in the rows of the coeff array, followed by +a series of one dimensional fits to the coefficients in the coeff array. +The row coefficients are overwritten by the coefficients of the tensor +product spline. Since all the work is done by the one dimensional spline +fitting routine, little extra code is required to handle the two dimensional +case. + +The bicubic spline is evaluated by summing the product C(i,j)*Bi(x)*Bj(y) +at each of the sixteen coefficients contributing to the point (x,y). +Once again, the one dimensional routines for evaluating the b-spline +(the functions Bi(x) and Bj(y)) do most of the work. + +Although it is not required by very many applications, it would also +be useful to be able to compute the surface integral of the interpolant +over an arbitrary surface (this is useful for surface photometry +applications). Never having done this, I do not have any recommendations +on how to set up the calling sequence. + +.sh +Random Interpolation of Two Dimensional Arrays + + The random interpolation procedures are particularly useful for two +dimensional arrays due to the increased size of the arrays. Also, if an +application generally finds linear interpolation to be sufficient, and rarely +uses a more expensive interpolator, the random routines will be more +efficient overall. + +.ks +.nf + mriset (interpolator_type, boundary_type) + msifit (data, nx, ny) + y = mrival (x, y, data) + mrider (x, y, derivs, nderiv, data) +.fi +.ke + +.sh +Cardinal B-Splines + + There are many different kinds of splines. One of the best +for the case where the data points are equally spaced is the cardinal spline. +The so called "natural" end point conditions are probably the best one can +do with noisy data. Other end point conditions, such as not-a-knot, may be +best for approximating analytic functions, but they are unreliable with +noisy data. The natural cubic cardinal spline is fitted by solving the +following tridiagonal system of equations (Prenter, 1975). + + +.ks +.nf + / : \ + | 6 -12 6 : 0 | + | 1 4 1 : y(1) | + | 1 4 1 : y(2) | + | ... : | + | 1 4 1 : y(n-1) | + | 1 4 1 : y(n) | + | 6 -12 6 : 0 | + \ : / +.fi +.ke + + +This matrix can most efficiently be solved by hardwiring the appropriate +recursion relations into a procedure. The problem of what to do when some +of the Y(i) are indefinite has not yet been solved. + +The b-spline basis function used above is defined by + +.ks +.nf + B(x) = (x-x1)**3 x:[x1,x2] + B(x) = 1 + 3(x-x2) + 3(x-x2)**2 - 3(x-x2)**3 x:[x2,x3] + B(x) = 1 + 3(x3-x) + 3(x3-x)**2 - 3(x3-x)**3 x:[x3,x4] + B(x) = (x4-x)**3 x:[x4,x5] +.fi +.ke + +where X1 through X4 are the X coordinates of the four b-spline +coefficients contributing to the b-spline function at X. diff --git a/math/interp/README b/math/interp/README new file mode 100644 index 00000000..915afd6e --- /dev/null +++ b/math/interp/README @@ -0,0 +1,7 @@ +Image interpolation package. Contains interpolator routines specially +designed to interpolate image data. This interpolator task is characterized +by data arrays in which the data points are equally spaced. Data points +and interpolation points are referenced simply by array index. Indefinite +valued pixels may be present in the data. Since the interpolation routines +will be applied to very large data arrays, efficiency is emphasized in these +routines. diff --git a/math/interp/arbpix.x b/math/interp/arbpix.x new file mode 100644 index 00000000..0b61f3d2 --- /dev/null +++ b/math/interp/arbpix.x @@ -0,0 +1,203 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + arbpix -- fix bad data + +Takes care of bad pixels by replacing the indef's with interpolated values. + +In order to replace bad points, the spline interpolator uses a limited +data array, the maximum total length is given by SPLPTS. + +The process is divided as follows: + 1. Take care of points below first good point and above last good + good point. + 2. Load an array with only good points. + 3. Interpolate that array. + +.endhelp + +procedure arbpix(datain,n,dataout,terptype) +include "interpdef.h" +include "asidef.h" + +real datain[ARB] # data in array +int n # no. of data points +real dataout[ARB] # data out array - cannot be same as data in +int terptype # interpolator type - see interpdef.h + +int i, badnc +int k, ka, kb + +real iirbfval() + +begin + + # count bad points + badnc = 0 + do i = 1,n + if (IS_INDEFR (datain[i])) + badnc = badnc + 1 + + # return if all bad or all good + if(badnc == n || badnc == 0) + return + + + # find first good point + for (ka = 1; IS_INDEFR (datain[ka]); ka = ka + 1) + ; + + # bad points below first good point are set at first value + do k = 1,ka-1 + dataout[k] = datain[ka] + + # find last good point + for (kb = n; IS_INDEFR (datain[kb]); kb = kb - 1) + ; + + # bad points beyond last good point get set at last value + do k = n, kb+1, -1 + dataout[k] = datain[kb] + + # load the other points interpolating the bad points as needed + do k = ka, kb { + if (!IS_INDEFR (datain[k])) # good point + dataout[k] = datain[k] + + else # bad point -- generate interpolated value + dataout[k] = iirbfval(datain[ka],kb-ka+1,k-ka+1,terptype) + } + +end + +# This part fills a temporary array with good points that bracket the +# bad point and calls the interpolating routine. + +real procedure iirbfval(y, n, k, terptype) + +real y[ARB] # data_in array, y[1] and y[n] guaranteed to be good. +int n # length of data_in array. +int k # index of bad point to replace. +int terptype + +int j, jj, pd, pu, tk, pns +real td[SPLPTS], tx[SPLPTS] # temporary arrays for interpolation + +real iirbint() + +begin + # The following test is done to improve speed. + # This code will work only if subroutines are implemented by + # using static storage - i.e. the old internal values survive. + # This avoids reloading of temporary arrays if + # there are consequetive bad points. + + if (!IS_INDEFR (y[k-1])) { + # set number of good points needed on each side of bad point + switch (terptype) { + case IT_NEAREST : + pns = 1 + case IT_LINEAR : + pns = 1 + case IT_POLY3 : + pns = 2 + case IT_POLY5 : + pns = 3 + case IT_SPLINE3 : + pns = SPLPTS / 2 + } + + # search down + pd = 0 + for (j = k-1; j >= 1 && pd < pns; j = j-1) + if (!IS_INDEFR (y[j])) + pd = pd + 1 + + # load temp. arrays for values below our indef. + tk = 0 + for(jj = j + 1; jj < k; jj = jj + 1) + if (!IS_INDEFR (y[jj])) { + tk = tk + 1 + td[tk] = y[jj] + tx[tk] = jj + } + + # search and load up from indef. + pu = 0 + for (j = k + 1; j <= n && pu < pns; j = j + 1) + if (!IS_INDEFR (y[j])) { + pu = pu + 1 + tk = tk + 1 + td[tk] = y[j] + tx[tk] = j + } + } + + # return value interpolated from these arrays. + return(iirbint(real(k), tx, td, tk, pd, terptype)) + +end + + +# This part interpolates the temporary arrays. +# It does not represent a general purpose routine because the +# previous part has determined the proper indices etc. so that +# effort is not duplicated here. + +real procedure iirbint (x, tx, td, tk, pd, terptype) + +real x # point to interpolate +real tx[ARB] # xvalues +real td[ARB] # data values +int tk # size of data array +int pd # index such that tx[pd] < x < tx[pd+1] +int terptype + +int i, ks, tpol +real cc[4,SPLPTS] +real h + +real iipol_terp() + +begin + switch (terptype) { + + case IT_NEAREST : + if (x - tx[1] > tx[2] - x) + return(td[2]) + else + return(td[1]) + + case IT_LINEAR : + return(td[1] + (x - tx[1]) * + (td[2] - td[1]) / (tx[2] - tx[1])) + + case IT_SPLINE3 : + do i = 1,tk + cc[1,i] = td[i] + cc[2,1] = 0. + cc[2,tk] = 0. + + # use spline routine from C. de Boor's book + # A Practical Guide to Splines + call cubspl(tx,cc,tk,2,2) + h = x - tx[pd] + return(cc[1,pd] + h * (cc[2,pd] + h * + (cc[3,pd] + h * cc[4,pd]/3.)/2.)) + + default : # one of the polynomial types + # allow lower order if not enough points on one side + tpol = tk + ks = 1 + if (tk - pd < pd) { + tpol = 2 * (tk - pd) + ks = 2 * pd - tk + 1 + } + if (tk - pd > pd) + tpol = 2 * pd + + # finally polynomial interpolate + return(iipol_terp(tx[ks], td[ks], tpol, x)) + } + +end diff --git a/math/interp/arider.x b/math/interp/arider.x new file mode 100644 index 00000000..fef55e0e --- /dev/null +++ b/math/interp/arider.x @@ -0,0 +1,214 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + arider -- random interpolator returns derivatives + +First looks at type of interpolator requested, then calls routine +to evaluate. +No error traps are included -- unreasonable values for the number of +data points or the x position will either produce hard errors or garbage. + +.endhelp + +procedure arider(x, datain, n, derivs, nderiv, interptype) +include "interpdef.h" + +real x # need 1 <= x <= n +real datain[ARB] # data values +int n # number of data values +real derivs[ARB] # derivatives out -- beware derivs[1] is + # function value +int nderiv # total number of values returned in derivs +int interptype + +int i, j, k, nt, nd, nx +real pc[6], ac, s + +begin + if(nderiv <= 0) + return + + # zero out derivs array + do i = 1, nderiv + derivs[i] = 0. + + switch (interptype) { + case IT_NEAREST : + derivs[1] = datain[int(x + 0.5)] + return + case IT_LINEAR : + nx = x + if( nx >= n ) + nx = nx - 1 + derivs[1] = (x - nx) * datain[nx+1] + (nx + 1 - x) * datain[nx] + if(nderiv >= 2) + derivs[2] = datain[nx+1] - datain[nx] + return + # The other cases call subroutines to generate polynomial coeff. + case IT_POLY3 : + call iidr_poly3(x, datain, n, pc) + nt = 4 + case IT_POLY5 : + call iidr_poly5(x, datain, n, pc) + nt = 6 + case IT_SPLINE3 : + call iidr_spline3(x, datain, n, pc) + nt = 4 + } + + nx = x + s = x - nx + nd = nderiv + if (nderiv > nt) + nd = nt + + do k = 1,nd { + ac = pc[nt - k + 1] # evluate using nested multiplication + do j = nt - k, 1, -1 + ac = pc[j] + s * ac + + derivs[k] = ac + + do j = 1, nt - k # differentiate + pc[j] = j * pc[j + 1] + } +end + +procedure iidr_poly3(x, datain, n, pc) + +real x +real datain[ARB] +int n +real pc[ARB] + +int i, k, nx, nt +real a[4] + +begin + + nx = x + + # The major complication is that near the edge interior polynomial + # must somehow be defined. + k = 0 + for(i = nx - 1; i <= nx + 2; i = i + 1){ + k = k + 1 + # project data points into temporary array + if ( i < 1 ) + a[k] = 2. * datain[1] - datain[2 - i] + else if ( i > n ) + a[k] = 2. * datain[n] - datain[2 * n - i] + else + a[k] = datain[i] + } + + nt = 4 + + # generate diffrence table for Newton's form + do k = 1, nt-1 + do i = 1, nt-k + a[i] = (a[i+1] - a[i]) / k + + # shift to generate polynomial coefficients + do k = nt,2,-1 + do i = 2,k + a[i] = a[i] + a[i-1] * (k - i - nt/2) + + do i = 1,nt + pc[i] = a[nt+1-i] + + return + +end + +procedure iidr_poly5(x, datain, n, pc) + +real x +real datain[ARB] +int n +real pc[ARB] + +int i, k, nx, nt +real a[6] + +begin + + nx = x + + # The major complication is that near the edge interior polynomial + # must somehow be defined. + k = 0 + for(i = nx - 2; i <= nx + 3; i = i + 1){ + k = k + 1 + # project data points into temporary array + if ( i < 1 ) + a[k] = 2. * datain[1] - datain[2 - i] + else if ( i > n ) + a[k] = 2. * datain[n] - datain[2 * n - i] + else + a[k] = datain[i] + } + + nt = 6 + + # generate diffrence table for Newton's form + do k = 1, nt-1 + do i = 1, nt-k + a[i] = (a[i+1] - a[i]) / k + + # shift to generate polynomial coefficients + do k = nt,2,-1 + do i = 2,k + a[i] = a[i] + a[i-1] * (k - i - nt/2) + + do i = 1,nt + pc[i] = a[nt+1-i] + + return + +end + +procedure iidr_spline3(x, datain, n, pc) + +real x +real datain[ARB] +int n +real pc[ARB] + +int i, k, nx, px +real temp[SPLPTS+2], bcoeff[SPLPTS+2], h + +begin + + nx = x + + h = x - nx + k = 0 + # maximum number of points used is SPLPTS + for(i = nx - SPLPTS/2 + 1; i <= nx + SPLPTS/2; i = i + 1){ + if(i < 1 || i > n) + ; + else { + k = k + 1 + if(k == 1) + px = nx - i + 1 + bcoeff[k+1] = datain[i] + } + } + + bcoeff[1] = 0. + bcoeff[k+2] = 0. + + # Use special routine for cardinal splines. + call iif_spline(bcoeff, temp, k) + + px = px + 1 + + pc[1] = bcoeff[px-1] + 4. * bcoeff[px] + bcoeff[px+1] + pc[2] = 3. * (bcoeff[px+1] - bcoeff[px-1]) + pc[3] = 3. * (bcoeff[px-1] - 2. * bcoeff[px] + bcoeff[px+1]) + pc[4] = -bcoeff[px-1] + 3. * bcoeff[px] - 3. * bcoeff[px+1] + + bcoeff[px+2] + + return +end diff --git a/math/interp/arival.x b/math/interp/arival.x new file mode 100644 index 00000000..50ee1c3e --- /dev/null +++ b/math/interp/arival.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + arival -- random interpolator returns value + +No error traps are included -- unreasonable values for the number of +data points or the x position will either produce hard errors or garbage. +This version is written in-line for speed. + +.endhelp + +real procedure arival(x, datain, n, interptype) +include "interpdef.h" + +real x # need 1 <= x <= n +real datain[ARB] # data values +int n # number of data values +int interptype + +int i, k, nx, px +real a[6], cd20, cd21, cd40, cd41, s, t, h +real bcoeff[SPLPTS+2], temp[SPLPTS+2], pc[4] + +begin + switch (interptype) { + case IT_NEAREST : + return(datain[int(x + 0.5)]) + case IT_LINEAR : + nx = x + # protect against x = n case + # else it will reference datain[n + 1] + if(nx >= n) + nx = nx - 1 + return((x - nx) * datain[nx+1] + (nx + 1 - x) * datain[nx]) + case IT_POLY3 : + nx = x + + # The major complication is that near the edge interior polynomial + # must somehow be defined. + k = 0 + for(i = nx - 1; i <= nx + 2; i = i + 1){ + k = k + 1 + # project data points into temporary array + if ( i < 1 ) + a[k] = 2. * datain[1] - datain[2 - i] + else if ( i > n ) + a[k] = 2. * datain[n] - datain[2 * n - i] + else + a[k] = datain[i] + } + + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (a[3] - 2. * a[2] + a[1]) + cd21 = 1./6. * (a[4] - 2. * a[3] + a[2]) + + return( s * (a[3] + (s * s - 1.) * cd21) + + t * (a[2] + (t * t - 1.) * cd20) ) + case IT_POLY5 : + nx = x + + # The major complication is that near the edge interior polynomial + # must somehow be defined. + k = 0 + for(i = nx - 2; i <= nx + 3; i = i + 1){ + k = k + 1 + # project data points into temporary array + if ( i < 1 ) + a[k] = 2. * datain[1] - datain[2 - i] + else if ( i > n ) + a[k] = 2. * datain[n] - datain[2 * n - i] + else + a[k] = datain[i] + } + + s = x - nx + t = 1. - s + + # second central differences + cd20 = 1./6. * (a[4] - 2. * a[3] + a[2]) + cd21 = 1./6. * (a[5] - 2. * a[4] + a[3]) + + # fourth central differences + cd40 = 1./120. * (a[1] - 4. * a[2] + 6. * a[3] - 4. * a[4] + a[5]) + cd41 = 1./120. * (a[2] - 4. * a[3] + 6. * a[4] - 4. * a[5] + a[6]) + + return( s * (a[4] + (s * s - 1.) * (cd21 + (s * s - 4.) * cd41)) + + t * (a[3] + (t * t - 1.) * (cd20 + (t * t - 4.) * cd40)) ) + case IT_SPLINE3 : + nx = x + + h = x - nx + k = 0 + # maximum number of points used is SPLPTS + for(i = nx - SPLPTS/2 + 1; i <= nx + SPLPTS/2; i = i + 1){ + if(i < 1 || i > n) + ; + else { + k = k + 1 + if(k == 1) + px = nx - i + 1 + bcoeff[k+1] = datain[i] + } + } + + bcoeff[1] = 0. + bcoeff[k+2] = 0. + + # Use special routine for cardinal splines. + call iif_spline(bcoeff, temp, k) + + px = px + 1 + + pc[1] = bcoeff[px-1] + 4. * bcoeff[px] + bcoeff[px+1] + pc[2] = 3. * (bcoeff[px+1] - bcoeff[px-1]) + pc[3] = 3. * (bcoeff[px-1] - 2. * bcoeff[px] + bcoeff[px+1]) + pc[4] = -bcoeff[px-1] + 3. * bcoeff[px] - 3. * bcoeff[px+1] + + bcoeff[px+2] + + return(pc[1] + h * (pc[2] + h * (pc[3] + h * pc[4]))) + } +end diff --git a/math/interp/asidef.h b/math/interp/asidef.h new file mode 100644 index 00000000..9fd06084 --- /dev/null +++ b/math/interp/asidef.h @@ -0,0 +1,16 @@ +# defines for use with interpolator package +# intended for internal consumption only +# used to set up storage in coeff array + +define TYPEI coeff[1] # code for interpolator type +define NPTS coeff[2] # no. of data points + +define ITYPEI int(coeff[1]) +define INPTS int(coeff[2]) + +define ASITYPEERR 1 +define ASIFITERR 2 + +define COFF 10 # offset into coeff array + # beware coeff[COFF - 2] is first + # location used !! diff --git a/math/interp/asider.x b/math/interp/asider.x new file mode 100644 index 00000000..2c9a2819 --- /dev/null +++ b/math/interp/asider.x @@ -0,0 +1,121 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + procedure asider + + This procedure finds derivatives assuming that x lands in +array i.e. 1 <= x <= npts. +It must be called by a routine that checks for out of bound references +and takes care of bad points and checks to make sure that the number +of derivatives requested is reasonable (max. is 5 derivatives or nder +can be 6 at most and min. nder is 1) + + This version assumes interior polynomial interpolants are stored as +the data points with corections for bad points, and the spline interpolant +is stored as a series of b-spline coefficients. + + The storage and evaluation for nearest neighbor and linear interpolation +are simpler so they are evaluated separately from other piecewise +polynomials. +.endhelp + +procedure asider(x,der,nder,coeff) +include "interpdef.h" +include "asidef.h" + +real x +real coeff[ARB] +int nder # no. items returned = 1 + no. of deriv. + +real der[ARB] # der[1] is value der[2] is f prime etc. + +int nx,n0,i,j,k,nt,nd +real s,ac,pc[6],d[6] + +begin + do i = 1, nder # return zero for derivatives that are zero + der[i] = 0. + + nt = 0 # nt is number of terms in case polynomial type + + switch (ITYPEI) { # switch on interpolator type + + case IT_NEAREST : + der[1] = (coeff[COFF + nint(x)]) + return + + case IT_LINEAR : + nx = x + der[1] = (x - nx) * coeff[COFF + nx + 1] + + (nx + 1 - x) * coeff[COFF + nx] + if ( nder > 1 ) # try to return exact number requested + der[2] = coeff[COFF + nx + 1] - coeff[COFF + nx] + return + + case IT_POLY3 : + nt = 4 + + case IT_POLY5 : + nt = 6 + + case IT_SPLINE3 : + nt = 4 + + } + + # falls through to here if interpolant is one of + # the higher order polynomial types or third order spline + + nx = x + n0 = COFF + nx + s = x - nx + + nd = nder # no. of derivatives needed + if ( nder > nt ) + nd = nt + + # generate polynomial coefficients, first for spline. + if (ITYPEI == IT_SPLINE3) { + pc[1] = coeff[n0-1] + 4. * coeff[n0] + coeff[n0+1] + pc[2] = 3. * (coeff[n0+1] - coeff[n0-1]) + pc[3] = 3. * (coeff[n0-1] - 2. * coeff[n0] + coeff[n0+1]) + pc[4] = -coeff[n0-1] + 3. * coeff[n0] - 3. * coeff[n0+1] + + coeff[n0+2] + + } else { + + # Newton's form written in line to get polynomial from data + # load data + do i = 1,nt + d[i] = coeff[n0 - nt/2 + i] + + # generate difference table + do k = 1, nt-1 + do i = 1,nt-k + d[i] = (d[i+1] - d[i]) / k + + # shift to generate polynomial coefficients of (x - n0) + do k = nt,2,-1 + do i = 2,k + d[i] = d[i] + d[i-1] * (k - i - nt/2) + + do i = 1,nt + pc[i] = d[nt + 1 - i] + } + + do k = 1,nd { # as loop progresses pc contains coefficients of + # higher and higher derivatives + + ac = pc[nt - k + 1] + do j = nt - k, 1, -1 # evaluate using nested mult. + ac = pc[j] + s * ac + + der[k] = ac + + do j = 1,nt - k # differentiate polynomial + pc[j] = j * pc[j + 1] + } + + return + +end diff --git a/math/interp/asieva.x b/math/interp/asieva.x new file mode 100644 index 00000000..bc5fcbb3 --- /dev/null +++ b/math/interp/asieva.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# procedure to evaluate interpolator at a sequence of ordered points +# aasumes that all x_values land within [1,n]. + +procedure asieva(x, y, n, coeff) +include "interpdef.h" +include "asidef.h" + +real x[ARB] # ordered x array +int n # no. of points in x +real coeff[ARB] + +real y[ARB] # interpolated values + +begin + switch (ITYPEI) { # switch on interpolator type + + case IT_NEAREST : + call iievne(x, y, n, coeff[COFF + 1]) + + case IT_LINEAR : + call iievli(x, y, n, coeff[COFF + 1]) + + case IT_POLY3 : + call iievp3(x, y, n, coeff[COFF + 1]) + + case IT_POLY5 : + call iievp5(x, y, n, coeff[COFF + 1]) + + case IT_SPLINE3 : + call iievs3(x, y, n, coeff[COFF + 1]) + + } + + return + +end diff --git a/math/interp/asifit.x b/math/interp/asifit.x new file mode 100644 index 00000000..12b16b0f --- /dev/null +++ b/math/interp/asifit.x @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + asifit -- fit interpolator to data + +This version uses the "basis-spline" representation for the spline. +It stores the data array itself for the polynomial interpolants. + +.endhelp + +procedure asifit(datain,n,coeff) +include "interpdef.h" +include "asidef.h" + +real datain[ARB] # data array +int n # no. of data points +real coeff[ARB] + +int i + +begin + NPTS = n + + # error trap - check data array for size + switch (ITYPEI) { + case IT_SPLINE3: + if(n < 4) + call error(ASIFITERR,"too few points for spline") + case IT_POLY5: + if(n < 6) + call error(ASIFITERR,"too few points for poly5") + case IT_POLY3: + if(n < 4) + call error(ASIFITERR,"too few points for poly3") + case IT_LINEAR: + if(n < 2) + call error(ASIFITERR,"too few points for linear") + default: + if(n < 1) + call error(ASIFITERR,"too few points for interpolation") + + } + + do i = 1,n + coeff[COFF + i] = datain[i] + + + if (ITYPEI == IT_SPLINE3) { + + # specify natural end conditions - second deriv. zero + coeff[COFF] = 0. + coeff[COFF+n+1] = 0. + + # fit spline - generate b-spline coefficients. + call iif_spline(coeff[COFF],coeff[COFF + n + 2],n) + + + } else { # not the spline + # We extend array to take care of values near edge. + + # Assign arbitrary values in case there are only a few points. + for(i = n + 1; i < 5; i = i + 1) + coeff[COFF + i] = coeff[COFF + n] + + # Extend for worst case - poly 5 may need 3 extra points. + do i = 1,3 { # same recipe as project + coeff[COFF+1 - i] = 2. * coeff[COFF + 1] - + coeff[COFF + 1 + i] + coeff[COFF+n + i] = 2. * coeff[COFF + n] - + coeff[COFF + n - i] + } + } + + return +end diff --git a/math/interp/asigrl.x b/math/interp/asigrl.x new file mode 100644 index 00000000..d528d0be --- /dev/null +++ b/math/interp/asigrl.x @@ -0,0 +1,201 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + procedure asigrl + + This procedure finds the integral of the interpolant from a to b +assuming both a and b land in the array. +.endhelp + +real procedure asigrl(a,b,coeff) # returns value of integral +include "interpdef.h" +include "asidef.h" + +real a,b # integral limits +real coeff[ARB] + +int na,nb,i,j,n0,nt +real s,t,ac,xa,xb,pc[6] + +begin + xa = a + xb = b + if ( a > b ) { # flip order and sign at end + xa = b + xb = a + } + + na = xa + nb = xb + ac = 0. # zero accumulator + + # set number of terms + switch (ITYPEI) { # switch on interpolator type + case IT_NEAREST : + nt = 0 + case IT_LINEAR : + nt = 1 + case IT_POLY3 : + nt = 4 + case IT_POLY5 : + nt = 6 + case IT_SPLINE3 : + nt = 4 + } + + # NEAREST_NEIGHBOR and LINEAR are handled differently because of + # storage. Also probably good for speed. + + if (nt == 0) { # NEAREST_NEIGHBOR + # reset segment to center values + na = xa + 0.5 + nb = xb + 0.5 + + # set up for first segment + s = xa - na + + # for clarity one segment case is handled separately + if ( nb == na ) { # only one segment involved + t = xb - nb + n0 = COFF + na + ac = ac + (t - s) * coeff[n0] + } else { # more than one segment + + # first segment + n0 = COFF + na + ac = ac + (0.5 - s) * coeff[n0] + + # middle segments + do j = na+1, nb-1 { + n0 = COFF + j + ac = ac + coeff[n0] + } + + # last segment + n0 = COFF + nb + t = xb - nb + ac = ac + (t + 0.5) * coeff[n0] + } + + } else if (nt == 1) { # LINEAR + # set up for first segment + s = xa - na + + # for clarity one segment case is handled separately + if ( nb == na ) { # only one segment involved + t = xb - nb + n0 = COFF + na + ac = ac + (t - s) * coeff[n0] + + 0.5 * (coeff[n0+1] - coeff[n0]) * (t*t - s*s) + } else { # more than one segment + + # first segment + n0 = COFF + na + ac = ac + (1. - s) * coeff[n0] + + 0.5 * (coeff[n0+1] - coeff[n0]) * (1. - s*s) + + # middle segments + do j = na+1, nb-1 { + n0 = COFF + j + ac = ac + 0.5 * (coeff[n0+1] + coeff[n0]) + } + + # last segment + n0 = COFF + nb + t = xb - nb + ac = ac + coeff[n0] * t + 0.5 * + (coeff[n0+1] - coeff[n0]) * t * t + } + + } else { # A higher order interpolant + + # set up for first segment + s = xa - na + + # for clarity one segment case is handled separately + if ( nb == na ) { # only one segment involved + t = xb - nb + n0 = COFF + na + call iigetpc(n0,pc,coeff) + do i = 1,nt + ac = ac + (1./i) * pc[i] * (t ** i - s ** i) + } else { # more than one segment + + # first segment + n0 = COFF + na + call iigetpc(n0,pc,coeff) + do i = 1,nt + ac = ac + (1./i) * pc[i] * (1. - s ** i) + + # middle segments + do j = na+1, nb-1 { + n0 = COFF + j + call iigetpc(n0,pc,coeff) + do i = 1,nt + ac = ac + (1./i) * pc[i] + } + + # last segment + n0 = COFF + nb + t = xb - nb + call iigetpc(n0,pc,coeff) + do i = 1,nt + ac = ac + (1./i) * pc[i] * t ** i + } + } + + if ( a < b ) + return(ac) + else + return(-ac) +end + + +procedure iigetpc(n0, pc, coeff) # generates polynomial coefficients + # if spline or poly3 or poly5 + +int n0 # coefficients wanted for n0 < x n0 + 1 +real coeff[ARB] + +real pc[ARB] + +int i,k,nt +real d[6] + +begin + # generate polynomial coefficients, first for spline. + if (ITYPEI == IT_SPLINE3) { + pc[1] = coeff[n0-1] + 4. * coeff[n0] + coeff[n0+1] + pc[2] = 3. * (coeff[n0+1] - coeff[n0-1]) + pc[3] = 3. * (coeff[n0-1] - 2. * coeff[n0] + coeff[n0+1]) + pc[4] = -coeff[n0-1] + 3. * coeff[n0] - 3. * coeff[n0+1] + + coeff[n0+2] + + } else { + if (ITYPEI == IT_POLY5) + nt = 6 + else # must be POLY3 + nt = 4 + + # Newton's form written in line to get polynomial from data + + # load data + do i = 1,nt + d[i] = coeff[n0 - nt/2 + i] + + # generate difference table + do k = 1, nt-1 + do i = 1,nt-k + d[i] = (d[i+1] - d[i]) / k + + # shift to generate polynomial coefficients of (x - n0) + do k = nt,2,-1 + do i = 2,k + d[i] = d[i] + d[i-1] * (k - i - 2) + + do i = 1,nt + pc[i] = d[nt + 1 - i] + } + + return +end diff --git a/math/interp/asiset.x b/math/interp/asiset.x new file mode 100644 index 00000000..126f4e39 --- /dev/null +++ b/math/interp/asiset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# sets sequential interpolator type + +procedure asiset(coeff,interptype) +include "interpdef.h" +include "asidef.h" + +int interptype +real coeff[ARB] + +begin + + if(interptype <= 0 || interptype > ITNIT) + call error(ASITYPEERR,"illegal interpolator type") + else + TYPEI = interptype + + return +end diff --git a/math/interp/asival.x b/math/interp/asival.x new file mode 100644 index 00000000..56f18938 --- /dev/null +++ b/math/interp/asival.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + procedure asival + + This procedure finds interpolated value assuming that x lands in +array i.e. 1 <= x < npts. +It must be called by a routine that checks for out of bound references +and takes care of bad pixels. + This version assumes that the data are stored for polynomials and +the spline appears as basis-spline coefficients. + Also the sequential evaluators are used to obtain the values in +order to reduce the amount of duplicated code. +.endhelp + +real procedure asival(x,coeff) +include "interpdef.h" +include "asidef.h" + +real x +real coeff[ARB] + +real t + +begin + switch (ITYPEI) { # switch on interpolator type + + case IT_NEAREST : + call iievne(x,t,1,coeff[COFF+1]) + return(t) + + case IT_LINEAR : + call iievli(x,t,1,coeff[COFF+1]) + return(t) + + case IT_POLY3 : + call iievp3(x,t,1,coeff[COFF+1]) + return(t) + + case IT_POLY5 : + call iievp5(x,t,1,coeff[COFF+1]) + return(t) + + case IT_SPLINE3 : + call iievs3(x,t,1,coeff[COFF+1]) + return(t) + + } +end diff --git a/math/interp/bench.x b/math/interp/bench.x new file mode 100644 index 00000000..539ddf67 --- /dev/null +++ b/math/interp/bench.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include "/usr/vesa/spec/terpdef.h" + +# Quickie benchmark, 1-d sequential image interpolators. + +define MAX_PIXELS 2048 +define SZ_NAME 20 + + +task interp + + +procedure interp() + +real data[MAX_PIXELS], x[MAX_PIXELS], y[MAX_PIXELS] +real coeff[2 * MAX_PIXELS + SZ_ASI] +char interp_name[SZ_NAME] +int i, j, npix, nlines, interpolant +bool streq() +int clgeti() + +begin + npix = min (MAX_PIXELS, clgeti ("npix")) + nlines = npix # square image + call clgstr ("interpolant", interp_name, SZ_NAME) + + if (streq (interp_name, "nearest")) + interpolant = IT_NEAR + else if (streq (interp_name, "linear")) + interpolant = IT_LINEAR + else if (streq (interp_name, "poly3")) + interpolant = IT_POLY3 + else if (streq (interp_name, "poly5")) + interpolant = IT_POLY5 + else if (streq (interp_name, "spline3")) + interpolant = IT_SPLINE3 + else + call error (0, "Unknown interpolant keyword") + + call asiset (coeff, II_INIT, 0) + call asiset (coeff, II_INTERPOLANT, interpolant) + call asiset (coeff, II_ALLGOODPIX, YES) + + do i = 1, npix { # initialize data, x arrays + data[i] = max(1.0, min(real(npix), real(i) + 0.15151)) + x[i] = i + } + + do j = 1, nlines { # interpolate npix ** 2 + call asifit (data, npix, coeff) + call asieva (x, y, npix, coeff) + } +end diff --git a/math/interp/cubspl.f b/math/interp/cubspl.f new file mode 100644 index 00000000..4bb54964 --- /dev/null +++ b/math/interp/cubspl.f @@ -0,0 +1,119 @@ + subroutine cubspl ( tau, c, n, ibcbeg, ibcend ) +c from * a practical guide to splines * by c. de boor +c ************************ input *************************** +c n = number of data points. assumed to be .ge. 2. +c (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the +c data points. tau is assumed to be strictly increasing. +c ibcbeg, ibcend = boundary condition indicators, and +c c(2,1), c(2,n) = boundary condition information. specifically, +c ibcbeg = 0 means no boundary condition at tau(1) is given. +c in this case, the not-a-knot condition is used, i.e. the +c jump in the third derivative across tau(2) is forced to +c zero, thus the first and the second cubic polynomial pieces +c are made to coincide.) +c ibcbeg = 1 means that the slope at tau(1) is made to equal +c c(2,1), supplied by input. +c ibcbeg = 2 means that the second derivative at tau(1) is +c made to equal c(2,1), supplied by input. +c ibcend = 0, 1, or 2 has analogous meaning concerning the +c boundary condition at tau(n), with the additional infor- +c mation taken from c(2,n). +c *********************** output ************************** +c c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients +c of the cubic interpolating spline with interior knots (or +c joints) tau(2), ..., tau(n-1). precisely, in the interval +c interval (tau(i), tau(i+1)), the spline f is given by +c f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.) +c where h = x - tau(i). the function program *ppvalu* may be +c used to evaluate f or its derivatives from tau,c, l = n-1, +c and k=4. + integer ibcbeg,ibcend,n, i,j,l,m + real c(4,n),tau(n), divdf1,divdf3,dtau,g +c****** a tridiagonal linear system for the unknown slopes s(i) of +c f at tau(i), i=1,...,n, is generated and then solved by gauss elim- +c ination, with s(i) ending up in c(2,i), all i. +c c(3,.) and c(4,.) are used initially for temporary storage. + l = n-1 +compute first differences of tau sequence and store in c(3,.). also, +compute first divided difference of data and store in c(4,.). + do 10 m=2,n + c(3,m) = tau(m) - tau(m-1) + 10 c(4,m) = (c(1,m) - c(1,m-1))/c(3,m) +construct first equation from the boundary condition, of the form +c c(4,1)*s(1) + c(3,1)*s(2) = c(2,1) + if (ibcbeg-1) 11,15,16 + 11 if (n .gt. 2) go to 12 +c no condition at left end and n = 2. + c(4,1) = 1. + c(3,1) = 1. + c(2,1) = 2.*c(4,2) + go to 25 +c not-a-knot condition at left end and n .gt. 2. + 12 c(4,1) = c(3,3) + c(3,1) = c(3,2) + c(3,3) + c(2,1) =((c(3,2)+2.*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1) + go to 19 +c slope prescribed at left end. + 15 c(4,1) = 1. + c(3,1) = 0. + go to 18 +c second derivative prescribed at left end. + 16 c(4,1) = 2. + c(3,1) = 1. + c(2,1) = 3.*c(4,2) - c(3,2)/2.*c(2,1) + 18 if(n .eq. 2) go to 25 +c if there are interior knots, generate the corresp. equations and car- +c ry out the forward pass of gauss elimination, after which the m-th +c equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m). + 19 do 20 m=2,l + g = -c(3,m+1)/c(4,m-1) + c(2,m) = g*c(2,m-1) + 3.*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m)) + 20 c(4,m) = g*c(3,m-1) + 2.*(c(3,m) + c(3,m+1)) +construct last equation from the second boundary condition, of the form +c (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n) +c if slope is prescribed at right end, one can go directly to back- +c substitution, since c array happens to be set up just right for it +c at this point. + if (ibcend-1) 21,30,24 + 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22 +c not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at +c left end point. + g = c(3,n-1) + c(3,n) + c(2,n) = ((c(3,n)+2.*g)*c(4,n)*c(3,n-1) + * + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g + g = -g/c(4,n-1) + c(4,n) = c(3,n-1) + go to 29 +c either (n=3 and not-a-knot also at left) or (n=2 and not not-a- +c knot at left end point). + 22 c(2,n) = 2.*c(4,n) + c(4,n) = 1. + go to 28 +c second derivative prescribed at right endpoint. + 24 c(2,n) = 3.*c(4,n) + c(3,n)/2.*c(2,n) + c(4,n) = 2. + go to 28 + 25 if (ibcend-1) 26,30,24 + 26 if (ibcbeg .gt. 0) go to 22 +c not-a-knot at right endpoint and at left endpoint and n = 2. + c(2,n) = c(4,n) + go to 30 + 28 g = -1./c(4,n-1) +complete forward pass of gauss elimination. + 29 c(4,n) = g*c(3,n-1) + c(4,n) + c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n) +carry out back substitution + 30 j = l + 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j) + j = j - 1 + if (j .gt. 0) go to 40 +c****** generate cubic coefficients in each interval, i.e., the deriv.s +c at its left endpoint, from value and slope at its endpoints. + do 50 i=2,n + dtau = c(3,i) + divdf1 = (c(1,i) - c(1,i-1))/dtau + divdf3 = c(2,i-1) + c(2,i) - 2.*divdf1 + c(3,i-1) = 2.*(divdf1 - c(2,i-1) - divdf3)/dtau + 50 c(4,i-1) = (divdf3/dtau)*(6./dtau) + return + end diff --git a/math/interp/iieval.x b/math/interp/iieval.x new file mode 100644 index 00000000..87538525 --- /dev/null +++ b/math/interp/iieval.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + procedures to evaluate interpolants + + These procedures are seperated from the other programs in order +to make it easier to optimise these in case it becomes necessary to +obtain the fastest possible interpolants. The interpolation package +spends most of its time in these routines. +.endhelp + +procedure iievne(x,y,n,a) # nearest neighbor + +real x[ARB] # x values, must be within [1,n] +real y[ARB] # interpolated values returned to user +int n # number of x values +real a[ARB] # data to be interpolated + +int i + +begin + do i = 1, n + y[i] = a[int(x[i] + 0.5)] + return +end + +procedure iievli(x,y,n,a) # linear + +real x[ARB] # x values, must be within [1,n] +real y[ARB] # interpolated values returned to user +int n # number of x values +real a[ARB] # data to be interpolated + +int i,nx + +begin + + do i = 1,n { + nx = x[i] + y[i] = (x[i] - nx) * a[nx + 1] + (nx + 1 - x[i]) * a[nx] + } + return +end + +procedure iievp3(x,y,n,a) # interior third order polynomial + +real x[ARB] # x values, must be within [1,n] +real y[ARB] # interpolated values returned to user +int n # number of x values +real a[ARB] # data to be interpolated from a[0] to a[n+2] + +int i,nx,nxold +real s,t,cd20,cd21 + +begin + nxold = -1 + do i = 1,n { + nx = x[i] + s = x[i] - nx + t = 1. - s + if (nx != nxold) { + + # second central differences: + cd20 = 1./6. * (a[nx+1] - 2. * a[nx] + a[nx-1]) + cd21 = 1./6. * (a[nx+2] - 2. * a[nx+1] + a[nx]) + nxold = nx + } + y[i] = s * (a[nx+1] + (s * s - 1.) * cd21) + + t * (a[nx] + (t * t - 1.) * cd20) + + } + return +end + +procedure iievp5(x,y,n,a) # interior fifth order polynomial + +real x[ARB] # x values, must be within [1,n] +real y[ARB] # interpolated values returned to user +int n # number of x values +real a[ARB] # data to be interpolated - from a[-1] to a[n+3] + +int i,nx,nxold +real s,t,cd20,cd21,cd40,cd41 + +begin + nxold = -1 + do i = 1,n { + nx = x[i] + s = x[i] - nx + t = 1. - s + if (nx != nxold) { + cd20 = 1./6. * (a[nx+1] - 2. * a[nx] + a[nx-1]) + cd21 = 1./6. * (a[nx+2] - 2. * a[nx+1] + a[nx]) + + # fourth central differences + cd40 = 1./120. * (a[nx-2] - 4. * a[nx-1] + + 6. * a[nx] - 4. * a[nx+1] + a[nx+2]) + cd41 = 1./120. * (a[nx-1] - 4. * a[nx] + + 6. * a[nx+1] - 4. * a[nx+2] + a[nx+3]) + nxold = nx + } + y[i] = s * (a[nx+1] + (s * s - 1.) * + (cd21 + (s * s - 4.) * cd41)) + + t * (a[nx] + (t * t - 1.) * + (cd20 + (t * t - 4.) * cd40)) + } + return +end + +procedure iievs3(x,y,n,a) # cubic spline evaluator + +real x[ARB] # x values, must be within [1,n] +real y[ARB] # interpolated values returned to user +int n # number of x values +real a[ARB] # basis spline coefficients - from a[0] to a[n+1] + +int i,nx,nxold +real s,c0,c1,c2,c3 + +begin + nxold = -1 + do i = 1,n { + nx = x[i] + s = x[i] - nx + if (nx != nxold) { + + # convert b-spline coeff's to poly. coeff's + c0 = a[nx-1] + 4. * a[nx] + a[nx+1] + c1 = 3. * (a[nx+1] - a[nx-1]) + c2 = 3. * (a[nx-1] - 2. * a[nx] + a[nx+1]) + c3 = -a[nx-1] + 3. * a[nx] - 3. * a[nx+1] + a[nx+2] + nxold = nx + } + y[i] = c0 + s * (c1 + s * (c2 + s * c3) ) + } + return +end diff --git a/math/interp/iif_spline.x b/math/interp/iif_spline.x new file mode 100644 index 00000000..a8574e0b --- /dev/null +++ b/math/interp/iif_spline.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + procedure iif_spline + + This fits uniformly spaced data with a cubic spline. The spline is +given as basis-spline coefficients that replace the data values. + +Storage at call time: + +b[1] = second derivative at x = 1 +b[2] = first data point y[1] +b[3] = y[2] +. +. +. +b[n+1] = y[n] +b[n+2] = second derivative at x = n + +Storage after call: + +b[1] ... b[n+2] = the n + 2 basis-spline coefficients for the basis splines + as defined in P. M. Prenter's book Splines and Variational Methods, + Wiley, 1975. + +.endhelp + +procedure iif_spline(b,d,n) + +real b[ARB] # data in and also bspline coefficients out +real d[ARB] # needed for offdiagnol matrix elements +int n # number of data points + +int i + +begin + + d[1] = -2. + b[1] = b[1] / 6. + + d[2] = 0. + b[2] = (b[2] - b[1]) / 6. + + # Gaussian elimination - diagnol below main is made zero + # and main diagnol is made all 1's + do i = 3,n+1 { + d[i] = 1. / (4. - d[i-1]) + b[i] = d[i] * (b[i] - b[i-1]) + } + + # Find last b spline coefficient first - overlay r.h.s.'s + b[n+2] = ( (d[n] + 2.) * b[n+1] - b[n] + b[n+2]/6.) / (1. + + d[n+1] * (d[n] + 2.)) + + # back substitute filling in coefficients for b splines + do i = n+1, 3, -1 + b[i] = b[i] - d[i] * b[i+1] + + # note b[n+1] is evaluated correctly as can be checked + + # b[2] is already set since offdiagnol is 0. + + # evaluate b[1] + b[1] = b[1] + 2. * b[2] - b[3] + + return +end diff --git a/math/interp/iimail b/math/interp/iimail new file mode 100644 index 00000000..69c19e9f --- /dev/null +++ b/math/interp/iimail @@ -0,0 +1,213 @@ +From tody Wed Apr 20 18:50:45 1983 +Date: 20 Apr 1983 18:50-MST +To: vesa +Subject: ii comments +Cc: tody + +I read through "tnotes1", and felt that enough information was conveyed +to explain how the asi___ routines work, and how to use them. It is +good documentation for the package, though some sections are probably +to technical for the general user, and should probably be moved to an +appendix in the final documentation. + +I only have one minor suggestion, and that is that there seems little +reason to abbreviate NEAR, REFL, and PROJ, since only three characters +are saved in each case, and the other parameter names are all spelled out. + +I also looked at the code for ASIFIT. I noticed that the recursion +relations for the cubic spline are coded inline. I suspect that this +is actually LESS efficient than using a separate procedure, due to +the complex coeff offset expressions appearing in the inner loops +(unless the Fortran compiler does a very good job of optimizing loops). + +By using a separate procedure, for example, the statement + + coeff[COFF+i] = coeff[off2+i] * (coeff[COFF+i] - coeff[COFF+i-1]) + +can be converted to something like + + bcoeff[i] = acoeff[i] * (bcoeff[i] - bcoeff[i-1]) + +where in the main routine, there is a procedure call something like the +following: + + call fit_bspline3 (coeff[COFF], coeff[off2], ...) + +In other words, the routines that actually do the work do not need to +know that everything is saved in a single coeff array. This simplifies +the code, as well as making it run faster on some machines. The technique +has an additional advantage: by isolating the compute bound code into +a separate (small) procedure, it becomes easy to hand optimize that procedure +in assembler, should we wish to do so. + +From tody Wed Apr 20 19:48:51 1983 +Date: 20 Apr 1983 19:48-MST +To: vesa +Subject: first benchmarks +Cc: tody + +I ran some preliminary benchmarks on the asi code, assuming no bad pixels. +The benchmark routine is in math/interp. Results: + +512 by 512 image interpolation, no bad pixels, using ASIEVA: + + nearest 47 (cpu seconds) + linear 22 + poly3 50 + poly5 89 + spline3 94 + +This is quite encouraging. I expect that these timings can be decreased by +a factor of from 3 to 5, given a good Fortran compiler (the current UNIX +compiler is very poor), and possibly hand optimising critical sections of +the code in assembler. + +The nearest neighbor timings don't make any sense (that should be the +fastest interpolant). Are you using sqrt, or something like that? +The spline timings are worse than I expected, compared to poly3. May +be due to complex offset expressions, which F77 does not optimize. + +From tody Fri Feb 18 14:10:36 1983 +To: vesa +Subject: x code +Cc: tody + + +We want to make IRAF source code as readable as possible, therefore there +is a (currently unofficial) standard for ".x" code. Your code is pretty +close to the standard, but here are some things to consider: + + (1) It is preferable to enclose large blocks of documentation in + .help .. .endhelp sections, rather than making each line a comment. + This has two advantages: (1) it is awkward to edit text set off with + a # on each line, and (2) the help utilities can only extract + source code documentation which is set in help blocks. It is not + necessary to use text formatter commands in help blocks, i.e., + you can simply type it in as it will appear on the terminal. + + In the same vein, it is better to put the discussion of the input + and output parameters in the help text, rather than in the + declarations section of the procedure. Placing each input and + output parameter on a single line, followed at the right by a short + comment, gets the job done without cluttering up the declarations + section. More extensive comments should be placed in the help text. + + + (2) It is mostly up to the programmer to decide where to put whitespace + to make the structure of a program clearest. Whitespace should + be inserted in a statement to make the important logical components + of the statement stand out. + + In particular, there should be a space after every keyword, before + the left parenthesis. If the statement is compound, the left brace + should be set off from the right paren by a space. In short + expressions, operators should be set off by whitespace. + + Adding whitespace between a function name and the left paren is + optional, as is whitespace between the elements of an argument list + (after commas). + + Blank lines should be used to set off sections of code, just as + blank lines are used to separate paragraphs of text. + + It is possible to overcomment code, making it hard to read. If + more than a third of the lines in a procedure are comments, the + code is probably overcommented. Place detailed discussion of the + algorithm in the help text. + + + (3) Indenting structures by full tab stops is acceptable, but 4 space + indents are preferred (the code rapidly runs off the right side of + the screen if full tab indents are used, encouraging use of too + short identifiers and omission of whitespace). The autoindent + feature of VI makes this easy (in .login file: 'set ai sw=4'). + + + (4) The standard form of the if .. else construct is + + if (expr) { + stmt + } else { + stmt + + or (if "stmt" is several lines, and whitespace is desired) + + if (expr) { + stmt + + } else { + stmt + + rather than + + if (expr) { + stmt + } + else { + stmt + +From tody Fri Feb 18 15:21:33 1983 +Date: 18 Feb 1983 15:21-MST +To: vesa +Subject: spec changes +Cc: tody + + +Now that Garth, Harvey, Steve and others have had a chance to comment on the +specs for the interpolator routines, it is time to make the final revisions +to the specifications. Often ones perspective on a problem changes when one +actually begins coding, and even the most carefully prepared specifications +need to be changed. Please feel free to suggest further changes. + + +Modifications + + (1) Everyone wanted the interpolators to be able to generate estimated + values to replace indefinites (as an option). + + (2) Steve wanted sinc function interpolation added to the set of + interpolators. I would also like to try this for undersampled + CCD data. A fairly high "order" (basis function size) seems + justified for this interpolant. + + (3) A surface integration routine is desired (MSIGRL). + + +SET Routines + + I think we should generalize the form of the "set" routines to permit +options such as (1), and others we may wish to add in the future (such +as telling the interpolator not to check for indefinites in the data). + +Set routines are also used in the FIO, IMIO, VSIO, and GIO packages in +the program interface. For example, in FIO, the number of buffers for a +file could be set by a call of the form + + call fset (fd, NBUFFERS, 2) + +The form of a set call is therefore + + call ___set (object, parameter, value) + +i.e., + + call asiset (coeff, II_INTERPOLANT, II_DIVDIF3) + call asiset (coeff, II_TYBNDRY, II_NEAREST) + call asiset (coeff, II_REPLACE_INDEFS, YES) + +Note that the prefix "II_" must be added to all Image Interpolation +defined parameters and parameter values. This is unattractive, but necessary +to avoid redefinitions of identifiers in other packages, such as IMIO (IMIO +has the same boundary extension options as II). + + +Surface Integration + + I suggest the following calling sequence for the surface integration +routine: + + integral = msigrl (x, y, npts, coeff) + +where the surface to be integrated is defined by the closed curve {x[i],y[i]}, +where 1 <= i <= npts, defined by the caller. + diff --git a/math/interp/iipol_terp.x b/math/interp/iipol_terp.x new file mode 100644 index 00000000..030d1964 --- /dev/null +++ b/math/interp/iipol_terp.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help + Procedure iipol_terp + +A polynomial interpolator with x and y arrays given. +This algorithm is based on the Newton form as described in +de Boor's book, A Practical Guide to Splines, 1978. +There is no error checking - this is meant to be used only by calls +from more complete routines that take care of such things. + +Maximum number of terms is 6. +.endhelp + +real procedure iipol_terp(x,y,n,x0) + +real x[ARB],y[ARB] # x and y array +real x0 # desired x +int n # number of points in x and y = number of + # terms in polynomial = order + 1 + +int k,i +real d[6] + +begin + + # Fill in entries for divided difference table. + do i = 1,n + d[i] = y[i] + + # Generate divided differences + do k = 1,n-1 + do i = 1,n-k + d[i] = (d[i+1] - d[i])/(x[i+k] - x[i]) + + # Shift divided difference table to center on x0 + do i = 2,n + d[i] = d[i] + d[i-1] * (x0 - x[i]) + + return(d[n]) +end diff --git a/math/interp/interp.h b/math/interp/interp.h new file mode 100644 index 00000000..e54fc1b5 --- /dev/null +++ b/math/interp/interp.h @@ -0,0 +1,19 @@ +# File of definitions for interpolator package. + +# Interpolator Types: + +define IT_NEAREST 1 +define IT_LINEAR 2 +define IT_POLY3 3 +define IT_POLY5 4 +define IT_SPLINE3 5 +define ITNIT 5 # number of types + +# Size of header etc. used for part of coeff dimension + +define SZ_ASI 20 + +# Total number of points used in spline interpolation of of bad pixels by +# subroutine arbpix. + +define SPLPTS 16 diff --git a/math/interp/interpdef.h b/math/interp/interpdef.h new file mode 100644 index 00000000..e54fc1b5 --- /dev/null +++ b/math/interp/interpdef.h @@ -0,0 +1,19 @@ +# File of definitions for interpolator package. + +# Interpolator Types: + +define IT_NEAREST 1 +define IT_LINEAR 2 +define IT_POLY3 3 +define IT_POLY5 4 +define IT_SPLINE3 5 +define ITNIT 5 # number of types + +# Size of header etc. used for part of coeff dimension + +define SZ_ASI 20 + +# Total number of points used in spline interpolation of of bad pixels by +# subroutine arbpix. + +define SPLPTS 16 diff --git a/math/interp/mkpkg b/math/interp/mkpkg new file mode 100644 index 00000000..55ab29c6 --- /dev/null +++ b/math/interp/mkpkg @@ -0,0 +1,21 @@ +# Old image interpolator tools library. + +$checkout libinterp.a lib$ +$update libinterp.a +$checkin libinterp.a lib$ +$exit + +libinterp.a: + arbpix.x interpdef.h asidef.h + arider.x interpdef.h + arival.x interpdef.h + asider.x interpdef.h asidef.h + asieva.x interpdef.h asidef.h + asifit.x interpdef.h asidef.h + asigrl.x interpdef.h asidef.h + asiset.x interpdef.h asidef.h + asival.x interpdef.h asidef.h + iieval.x + iif_spline.x + iipol_terp.x + ; diff --git a/math/interp/noteari b/math/interp/noteari new file mode 100644 index 00000000..d42ed48b --- /dev/null +++ b/math/interp/noteari @@ -0,0 +1,64 @@ + Using the Random One Dimensional Interpolation Routines + A Quick Note for Programmers + + +I. GENERAL NOTES: + + 1. Defines are found in file interpdef.h. The routines + are in library interplib.a. + + 2. All pixels are assumed to be good. Except for routine + arbpix. + + 3. This is for uniformly spaced data -- thus for the i-th + data value, y[i], the corresponding x[i] = i by assumption. + + 4. All x references are assumed to land in the closed interval + 1 <= x <= NPTS, where NPTS is the number of points in the + data array. If x is outside this range, the result is + not specified. + + +II. PROCEDURES: + + + **** Subroutine to replace INDEF's with interpolated values. + * + * arbpix (datain, n, dataout, interpolator_type) + * + * real datain[ARB] # data_in array + * int n # number of points in data_in + * real dataout[ARB] # array out, may not be same as + * # data_in + * int interpolator_type + * + * The interpolator type can be set to: + * + * IT_NEAREST nearest neighbor + * IT_LINEAR linear interpolation + * IT_POLY3 interior polynomial 3rd order + * IT_POLY5 interior polynomial 5th order + **** IT_SPLINE3 cubic natural spline + + + **** Subroutine to return interpolated value + * + * real arival (x, datain, n , interpolator_type) + * + * real x + * real datain[ARB] # data array + * int n # number of points in data array + **** int interpolator_type # see above + + + **** Subroutine to evaluate derivatives at a point. + * + * arider (x, datain, n, derivs, nder, interpolator_type) + * + * real x + * real datain[ARB] # data array + * int n # number of points in data array + * real derivs[ARB] # output array containing derivatives + * # derivs[1] is function value + * int nder # input: nder - 1 derivs are evaluated + **** int interpolator_type # see above diff --git a/math/interp/noteasi b/math/interp/noteasi new file mode 100644 index 00000000..ae22df83 --- /dev/null +++ b/math/interp/noteasi @@ -0,0 +1,101 @@ + Using the Sequential One Dimensional Interpolation Routines + A Quick Note for Programmers + + +I. GENERAL NOTES: + + 1. Defines are found in file interpdef.h. The routines + are in library interplib.a. + + 2. All pixels are assumed to be good. Except for routine + arbpix. + + 3. This is for uniformly spaced data -- thus for the i-th + data value, y[i], the corresponding x[i] = i by assumption. + + 4. All x references are assumed to land in the closed interval + 1 <= x <= NPTS, where NPTS is the number of points in the + data array. If x is outside this range, the result is + not specified. + + 5. A storage area and work space array must be provided. + It is of type real and the size is 2 * NPTS + SZ_ASI + + + +II. PROCEDURES: + + + **** Subroutine to replace INDEF's with interpolated values. + * + * arbpix (datain, n, dataout, interpolator_type) + * + * real datain[ARB] # data_in array + * int n # number of points in data_in + * real dataout[ARB] # array out, may not be same as + * # data_in + * int interpolator_type + * + * The interpolator type can be set to: + * + * IT_NEAREST nearest neighbor + * IT_LINEAR linear interpolation + * IT_POLY3 interior polynomial 3rd order + * IT_POLY5 interior polynomial 5th order + **** IT_SPLINE3 cubic natural spline + + + **** Subroutine to set interpolator type. + * + * asiset(coeff,interpolator_type) + * + * real coeff[ARB] # work + storage array, dimension + * # 2 * NPTS + SZ_ASI + **** int interpolator_type # see above + + + **** Subroutine to fit interpolator to data. + * + * asifit (datain, npts, coeff) + * + * real datain[ARB] # data array + * int npts # number of points in data array + **** real coeff[ARB] # work+storage area dim 2*npts + SZ_ASI + + + **** Subroutine to return interpolated value after fitting. + * + * real asival (x, coeff) + * + * real x + **** real coeff[ARB] + + + **** Subroutine to evaluate an ordered sequence of values. + * + * asieva (x, y, n, coeff) + * + * real x[ARB] # input array of x values + * real y[ARB] # output array of interpolated values + * int n # number of x values + **** real coeff[ARB] + + + **** Subroutine to evaluate derivatives at a point. + * + * asider (x, derivs, nder, coeff) + * + * real x + * real derivs[ARB] # output array containing derivatives + * # derivs[1] is function value + * int nder # input: nder - 1 derivatives are evaluated + **** real coeff[ARB] + + + **** Subroutine to integrate the interpolated data. + * + * real asigrl (a, b, coeff) + * + * real a # lower limit + * real b # upper limit + **** real coeff[ARB] diff --git a/math/interp/notes3 b/math/interp/notes3 new file mode 100644 index 00000000..e7121c99 --- /dev/null +++ b/math/interp/notes3 @@ -0,0 +1,216 @@ + Notes on the Interpolator Package for IRAF Version 2 + + Some parts of the image interpolator package are available. +This is a reminder of changes to the document TRP prepared by +Doug Tody. Also it is a place to keep track of why things were +done the way they were. The individual procedures (subroutines) +will be discussed; making it easy to add, subtract and change things. + +************************************************************************** +** ** +** ** + + GENERAL NOTES FOR 1-D PACKAGE: + +1. Handling of errors. + + Some routines call the error routines of the IRAF package. + Logically it is reasonable to trap silly errors at certain points. + For instance if the interpolator type is set to a nonexistant type + an error call is generated. + + To the programmer, the two most important error features are: + + 1. All pixels are assumed to be good. + + 2. All x references are assumed to land in the closed interval + 1 <= x <= NPTS. + + Point 2 probably needs some explanation, because at first hand + it seems rather easy to test for x < 1 || x > NPTS and take + appropriate action. There are two objections to including this + test. First it is often possible to generate x values in such + a way that they are guaranteed to lie in the given interval. + Testing again within the interpolator package is a waste of + computer time. Second the interpolator package becomes too large + if code is included to handle out of bounds references and such + code duplicates other parts of the IRAF package that handles + out of bound values. The alternative is to return INDEF when + x is out of bounds. This is not very appealing for many + routine applications such as picture shifting. + +2. Size of "coeff" array: + + coeff is a real 1-d array of size -- 2 * NPTS + SZ_ASI + + where SZ_ASI is currently 30. It, like the other defines needed for + the interp package, is available in the file -- terpdef.h . + + This coeff array serves as work area for asifit, a structure to save + interpolator type, flags etc., an array to save data points or b-spline + coefficients as needed. + + The polynomial interpolators are saved as the data points and the +interpolation is done "on the fly". Rather than compute polynomial +coefficients before-hand, the interpolated value is calculated from +the data values at time of request. (The actual calculation is done +by adding and multiplying things in an order suggested by Everett's +interpolation formula rather than the polynomial coefficient form. +The resulting values are the same up to differences due to numerical +roundoff. As a practical matter, all forms work except polynomials +shifted far from the point of interest. Polynomials shifted to a +center far away suffer from bad roundoff errors.) + + The splines must be calculated at a single pass because (formally) +they are global (i.e use all of the data points). The b-splines (b for +basis) are just certain piecewise polynomials for solving the interpo- +lation problem, it is convenient to calculate the coefficients of these +b-splines and to save these in the array. + +3. Method of solution: + +************************************************************************** +** ** +** ** +** ** + PROCEDURES: + +*************************************************************************** + + ***** asiset(coeff,interptype) ***** + +The interpolator type can be set to: + + IT_NEAREST nearest neighbor + IT_LINEAR linear interpolation + IT_POLY3 interior polynomial 3rd order + IT_POLY5 interior polynomial 5th order + IT_SPLINE3 cubic natural spline + +Subroutines needed: + + NONE + + + +************************************************************************* + + ******* asifit (data, npts, coeff) ***** + + This fits the interpolator to the data. Takes care of bad points by +replacing them with interpolated values to generate a +uniformly spaced array. For polynomial interpolators, this array is +sent to the evaluation routines. For the spline interpolator, the uniform +array is fitted and the basis-spline coefficients are saved. + +Interior polynomial near boundary: + Array is extended according to choice of boundary conditions. +Out of bounds values and values near the edge depend on choice of +boundary conditions. + +Spline near boundary: + Natural (second derivative equals zero at edge) spline is fitted to +data only. The resulting function is reflected, wrapped etc. to generate +out of bounds values. Out of bounds values depend on choice of boundary +conditions but values within the array near the edges do not. + For the wrap boundary condition, the one segment connecting point +number n to point 1 is not generated by the spline fit. Instead the +polynomial that is continuous and has a continuous first and second +derivative n is inserted. In this one case, the first and second derivative +are not continuous at 1. + +Replacing bad points: + The same kind of interpolator is used to replace bad points as that +used to generate interpolated values. The boundary conditions are not +handled in the same manner. Bad points near the edge are replaced by +using lower order polynomial interpolators if there are not enough +points on both sides of the bad point. Bad points that are not +straddled by good points are assigned the value of the nearest good +point. This is done in the temporary array before the uniformly spaced +interpolator is applied. + +subroutines needed: + + real iipint(x,y,nterm,x0) + Returns interpolated value at x0 using polynomial with + terms to connect the data pairs + in x,y. + + cubspl(tau,c,n,ibcbeg,ibcend) + Unmodified cubic spline interpolator for non-uniformly + spaced data taken from C. de Boor's book: + A Practical Guide to Splines, (1978 + Springer-Verlag). + + iifits(b,d,n) + Fits cubic spline to uniformly spaced array of y values + using a basis-spline representation for + the spline. + + + +***************************************************************************** + + ***** y = asival (x, coeff) ***** + + Subroutine to return interpolated value after fitting. + +Subroutines needed: + + real iivalu (x, coeff) + Returns interpolated value assuming x is in array. Also + has no code for bad point propagation. + + + + +*************************************************************************** + + ***** asieva (x, y, n, coeff) ***** + + Given an ordered array of x values returns interpolated values in y. +This is needed for speed. Reduces number of subroutine calls per point, +reduces the number of tests for out of bounds, and bad pixel +propagation can be made more efficient. + +Subroutines needed: + + real iivalu (x, coeff) + + + +************************************************************************** + + ***** asider (x, derivs, nderiv, coeff) ***** + + This evaluates derivatives at point x. Returns the first +nderiv - 1 derivatives. derivs[1] is function value, derivs[2] is +first derivative, derivs[3] is second derivative etc. + There is no check that nderiv is a reasonable value. Polynomials +have a limited number of non-zero derivatives, if more are asked for +they come back as zero. + +Subroutines needed: + + iivalu (x, coeff) + + iiderv (x, derivs, nderiv, coeff) + Assumes x lands in array returns derivatives. No handling + of bad points. + +**************************************************************************** + + ****** integral = asigrl (a, b, coeff) ******* + + This integrates the array from to a to b. The boundary conditions are +incorporated into the code so if function values can be returned from all +points between a and b, the integral will be defined. Thus for WRAP, +REFLECT and PROJECT boundary conditions, the distance from a to b can be +as large as 3 times the array length if a and b are chosen appropriately. +For these boundary conditions, attempts to extend beyond +/- one cycle +produce INDEF. + +Subroutines needed: + + iiigrl (a, b, coeff) + returns integral when a and b land in array. diff --git a/math/interp/overview b/math/interp/overview new file mode 100644 index 00000000..4ad813ca --- /dev/null +++ b/math/interp/overview @@ -0,0 +1,43 @@ +Interpolation Package + + The routines here are intended to allow programmers to interpolate +one dimensional arrays and two dimensional +images in the IRAF system. The routines are +mathematical in nature and are not heavily tied into the IRAF package. +The advantages of having locally written interpolators include the +ability to optimize for uniformly spaced data and the possibility of +adding features that are useful for the final application. The +one major feature that has been implemented is the ability to change +the kind of interpolator used at run time by carrying along a variable +that gives the interpolator type in the higher level code. + + The kinds of interpolators include: + 1. Nearest neighbor + 2. Linear + 3. Interior polynomial order = 3 + 4 Interior polynomial order = 5 + 5 Spline order = 3 + + The package is divided into array interpolators and image +interpolators. Within the array interpolators, there is further +division into sequential and random interpolators. The sequential +interpolators are optimized for returning many values as is the +case when an array is shifted or when an array is oversampled +at many points in order to produce a smooth plot. The random interpolators +allow the evaluation of a few interpolated points without the computing +time and storage overhead required for setting up the sequential version. + + The original specification called for the interpolator package +to deal with indefinite valued pixels and references out of bounds. +A version of the array sequential interpolators was written that handled +both situations allowing some options to the user. The extension of +these features to the two dimensional case becomes more dependent on +details within IRAF and less mathematical in nature. It would also +duplicate other code within IRAF that deals with out of bound references. +Finally the need to test for the various situations slows down the operation. +So all features referring to indefinite valued pixels and out of bound +references have been removed. The user is responsible for ensuring that +"x" values land within the array. The code does not test to see if x +is in bounds. A routine has been added that interpolates +an array with indefinites and returns an array with all legitimate +real numbers. diff --git a/math/interp/usernote b/math/interp/usernote new file mode 100644 index 00000000..55483022 --- /dev/null +++ b/math/interp/usernote @@ -0,0 +1,118 @@ + Using the Sequential One Dimensional Interpolation Routines + A Quick Note for Programmers + + +I. GENERAL NOTES: + + 1. Defines are found in file interpdef.h. The routines + are in library interplib.a. + + 2. All pixels are assumed to be good. Except for routine + arbpix. + + 3. This is for uniformly spaced data -- thus for the i-th + data value, y[i], the corresponding x[i] = i by assumption. + + 4. All x references are assumed to land in the closed interval + 1 <= x <= NPTS, where NPTS is the number of points in the + data array. If x is outside this range, the result is + not specified. + + 5. A storage area and work space array must be provided. + It is of type real and the size is 2 * NPTS + SZ_ASI + + + +II. PROCEDURES: + + + **** Subroutine to select the interpolator type + * + * interpolator_type = clginterp (param) + * + * char param[ARB] + * + * The parameter prompt string is sent to the CL and the + * routine evaluates the returned string to select one of the + * interpolator types given in interpdef.h. The input string + * may be one of the following with possible abbreviations: + * nearest + * linear + * 3rd order poly + * 5th order poly + **** cubic spline + + + **** Subroutine to replace INDEF's with interpolated values. + * + * arbpix (datain, n, dataout, interpolator_type) + * + * real datain[ARB] # data_in array + * int n # number of points in data_in + * real dataout[ARB] # array out, may not be same as + * # data_in + * int interpolator_type + * + * The interpolator type can be set to: + * + * IT_NEAREST nearest neighbor + * IT_LINEAR linear interpolation + * IT_POLY3 interior polynomial 3rd order + * IT_POLY5 interior polynomial 5th order + **** IT_SPLINE3 cubic natural spline + + + **** Subroutine to set interpolator type. + * + * asiset(coeff,interpolator_type) + * + * real coeff[ARB] # work + storage array, dimension + * # 2 * NPTS + SZ_ASI + **** int interpolator_type # see above + + + **** Subroutine to fit interpolator to data. + * + * asifit (datain, npts, coeff) + * + * real datain[ARB] # data array + * int npts # number of points in data array + **** real coeff[ARB] # work+storage area dim 2*npts + SZ_ASI + + + **** Subroutine to return interpolated value after fitting. + * + * real asival (x, coeff) + * + * real x + **** real coeff[ARB] + + + **** Subroutine to evaluate an ordered sequence of values. + * + * asieva (x, y, n, coeff) + * + * real x[ARB] # input array of x values + * real y[ARB] # output array of interpolated values + * int n # number of x values + **** real coeff[ARB] + + + **** Subroutine to evaluate derivatives at a point. + * + * asider (x, derivs, nder, coeff) + * + * real x + * real derivs[ARB] # output array containing derivatives + * # derivs[1] is function value + * int nder # input: nder - 1 derivatives are evaluated + **** real coeff[ARB] + + + **** Subroutine to integrate the interpolated data. + * + * real asigrl (a, b, coeff) + * + * real a # lower limit + * real b # upper limit + **** real coeff[ARB] diff --git a/math/llsq/README b/math/llsq/README new file mode 100644 index 00000000..bfaabb58 --- /dev/null +++ b/math/llsq/README @@ -0,0 +1,33 @@ +This directory contains a collection of routines for solving linear least +squares problems by the Singular Value Decomposition (SVD) method, as +described in "Solving Least Squares Problems", by Charles L. Lawson and +Richard J. Hanson, Prentice Hall, 1974. The appendix of this book contains +full listings of the Fortran codes, as well as a users guide. + +The numerical subroutines are in this directory. The directory "progs" +contains a number of examples of the use of these routines in Fortran programs. + +The numerical routines have been modified to eliminate the use of Fortran +i/o for error conditions. The integer status return IER has been added to +all such routines, and the Fortran write statement(s) removed. A successful +call returns zero in IER, while an unsucessful call returns a positive integer +error code, identifying the error. The original codes are in the directory +"original_f". + +The affected routines and the new calling sequences are as follows: + + subroutine BNDSOL (mode,g,mdg,nb,ip,ir,x,n,rnorm,ier) + subroutine LDP (g,mdg,m,n,h,x,xnorm,w,index,ier) + subroutine NNLS (a,mda,m,n,b,x,rnorm,w,zz,index,ier) + subroutine SVDRS (a,mda,mm,nn,b,mdb,nb,s,ier) + +The routines SVA and MFEOUT were not installed in the library, since they +do extensive i/o, but have been modified to reflect the changes to the +above subroutines. + +See "lsq.x" and "band.x" in progs/ for examples demonstrating the use +of these routines in IRAF spp programs. + +20Nov82 D.Tody + +Oct85 Added comma after P edit descriptor in sva.f diff --git a/math/llsq/bndacc.f b/math/llsq/bndacc.f new file mode 100644 index 00000000..80b9914c --- /dev/null +++ b/math/llsq/bndacc.f @@ -0,0 +1,74 @@ + subroutine bndacc (g,mdg,nb,ip,ir,mt,jt) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c sequential algorithm for banded least squares problem.. +c accumulation phase. for solution phase use bndsol. +c +c the calling program must set ir=1 and ip=1 before the first call +c to bndacc for a new case. +c +c the second subscript of g( ) must be dimensioned at least +c nb+1 in the calling program. + dimension g(mdg,1) + zero=0. +c +c alg. steps 1-4 are performed external to this subroutine. +c + nbp1=nb+1 + if (mt.le.0) return +c alg. step 5 + if (jt.eq.ip) go to 70 +c alg. steps 6-7 + if (jt.le.ir) go to 30 +c alg. steps 8-9 + do 10 i=1,mt + ig1=jt+mt-i + ig2=ir+mt-i + do 10 j=1,nbp1 + 10 g(ig1,j)=g(ig2,j) +c alg. step 10 + ie=jt-ir + do 20 i=1,ie + ig=ir+i-1 + do 20 j=1,nbp1 + 20 g(ig,j)=zero +c alg. step 11 + ir=jt +c alg. step 12 + 30 mu=min0(nb-1,ir-ip-1) + if (mu.eq.0) go to 60 +c alg. step 13 + do 50 l=1,mu +c alg. step 14 + k=min0(l,jt-ip) +c alg. step 15 + lp1=l+1 + ig=ip+l + do 40 i=lp1,nb + jg=i-k + 40 g(ig,jg)=g(ig,i) +c alg. step 16 + do 50 i=1,k + jg=nbp1-i + 50 g(ig,jg)=zero +c alg. step 17 + 60 ip=jt +c alg. steps 18-19 + 70 mh=ir+mt-ip + kh=min0(nbp1,mh) +c alg. step 20 + do 80 i=1,kh + 80 call h12 (1,i,max0(i+1,ir-ip+1),mh,g(ip,i),1,rho, + 1 g(ip,i+1),1,mdg,nbp1-i) +c alg. step 21 + ir=ip+kh +c alg. step 22 + if (kh.lt.nbp1) go to 100 +c alg. step 23 + do 90 i=1,nb + 90 g(ir-1,i)=zero +c alg. step 24 + 100 continue +c alg. step 25 + return + end diff --git a/math/llsq/bndsol.f b/math/llsq/bndsol.f new file mode 100644 index 00000000..4c4bd973 --- /dev/null +++ b/math/llsq/bndsol.f @@ -0,0 +1,71 @@ + subroutine bndsol (mode,g,mdg,nb,ip,ir,x,n,rnorm,ier) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c sequential solution of a banded least squares problem.. +c solution phase. for the accumulation phase use bndacc. +c +c mode = 1 solve r*x=y where r and y are in the g( ) array +c and x will be stored in the x( ) array. +c 2 solve (r**t)*x=y where r is in g( ), +c y is initially in x( ), and x replaces y in x( ), +c 3 solve r*x=y where r is in g( ). +c y is initially in x( ), and x replaces y in x( ). +c +c the second subscript of g( ) must be dimensioned at least +c nb+1 in the calling program. + dimension g(mdg,1),x(n) + zero=0. + ier = 0 +c + rnorm=zero + go to (10,90,50), mode +c ********************* mode = 1 +c algc step 26 + 10 do 20 j=1,n + 20 x(j)=g(j,nb+1) + rsq=zero + np1=n+1 + irm1=ir-1 + if (np1.gt.irm1) go to 40 + do 30 j=np1,irm1 + 30 rsq=rsq+g(j,nb+1)**2 + rnorm=sqrt(rsq) + 40 continue +c ********************* mode = 3 +c alg. step 27 + 50 do 80 ii=1,n + i=n+1-ii +c alg. step 28 + s=zero + l=max0(0,i-ip) +c alg. step 29 + if (i.eq.n) go to 70 +c alg. step 30 + ie=min0(n+1-i,nb) + do 60 j=2,ie + jg=j+l + ix=i-1+j + 60 s=s+g(i,jg)*x(ix) +c alg. step 31 + 70 if (g(i,l+1)) 80,130,80 + 80 x(i)=(x(i)-s)/g(i,l+1) +c alg. step 32 + return +c ********************* mode = 2 + 90 do 120 j=1,n + s=zero + if (j.eq.1) go to 110 + i1=max0(1,j-nb+1) + i2=j-1 + do 100 i=i1,i2 + l=j-i+1+max0(0,i-ip) + 100 s=s+x(i)*g(i,l) + 110 l=max0(0,j-ip) + if (g(j,l+1)) 120,130,120 + 120 x(j)=(x(j)-s)/g(j,l+1) + return +c +c error return: zero diagonal term in bndsol + 130 ier = 1 + return + end diff --git a/math/llsq/diff.f b/math/llsq/diff.f new file mode 100644 index 00000000..79dacb92 --- /dev/null +++ b/math/llsq/diff.f @@ -0,0 +1,6 @@ + function diff(x,y) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 june 7 +c to appear in 'solving least squares problems', prentice-hall, 1974 + diff=x-y + return + end diff --git a/math/llsq/g1.f b/math/llsq/g1.f new file mode 100644 index 00000000..5d44c50b --- /dev/null +++ b/math/llsq/g1.f @@ -0,0 +1,33 @@ + subroutine g1 (a,b,cos,sin,sig) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c +c compute orthogonal rotation matrix.. +c compute.. matrix (c, s) so that (c, s)(a) = (sqrt(a**2+b**2)) +c (-s,c) (-s,c)(b) ( 0 ) +c compute sig = sqrt(a**2+b**2) +c sig is computed last to allow for the possibility that +c sig may be in the same location as a or b . +c + zero=0. + one=1. + if (abs(a).le.abs(b)) go to 10 + xr=b/a + yr=sqrt(one+xr**2) + cos=sign(one/yr,a) + sin=cos*xr + sig=abs(a)*yr + return + 10 if (b) 20,30,20 + 20 xr=a/b + yr=sqrt(one+xr**2) + sin=sign(one/yr,b) + cos=sin*xr + sig=abs(b)*yr + return + 30 sig=zero + cos=zero + sin=one + return + end diff --git a/math/llsq/g2.f b/math/llsq/g2.f new file mode 100644 index 00000000..6f01a582 --- /dev/null +++ b/math/llsq/g2.f @@ -0,0 +1,9 @@ + subroutine g2 (cos,sin,x,y) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1972 dec 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c apply the rotation computed by g1 to (x,y). + xr=cos*x+sin*y + y=-sin*x+cos*y + x=xr + return + end diff --git a/math/llsq/gen.f b/math/llsq/gen.f new file mode 100644 index 00000000..e7933d6d --- /dev/null +++ b/math/llsq/gen.f @@ -0,0 +1,31 @@ + function gen(anoise) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1972 dec 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c generate numbers for construction of test cases. + mi=891 + mj=457 + i=5 + j=7 + aj=0. +c + if (anoise) 10,30,20 + 10 gen=0. + return +c +c the sequence of values of j is bounded between 1 and 996 +c if initial j = 1,2,3,4,5,6,7,8, or 9, the period is 332 +c + 20 j=j*mj + j=j-997*(j/997) + aj=j-498 +c the sequence of values of i is bounded between 1 and 999 +c if initial i = 1,2,3,6,7, or 9, the period will be 50 +c if initial i = 4 or 8 the period will be 25 +c if initial i = 5 the period will be 10 +c + 30 i=i*mi + i=i-1000*(i/1000) + ai=i-500 + gen=ai+aj*anoise + return + end diff --git a/math/llsq/h12.f b/math/llsq/h12.f new file mode 100644 index 00000000..81daa629 --- /dev/null +++ b/math/llsq/h12.f @@ -0,0 +1,80 @@ +c subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c construction and/or application of a single +c householder transformation.. q = i + u*(u**t)/b +c +c mode = 1 or 2 to select algorithm h1 or h2 . +c lpivot is the index of the pivot element. +c l1,m if l1 .le. m the transformation will be constructed to +c zero elements indexed from l1 through m. if l1 gt. m +c the subroutine does an identity transformation. +c u(),iue,up on entry to h1 u() contains the pivot vector. +c iue is the storage increment between elements. +c on exit from h1 u() and up +c contain quantities defining the vector u of the +c householder transformation. on entry to h2 u() +c and up should contain quantities previously computed +c by h1. these will not be modified by h2. +c c() on entry to h1 or h2 c() contains a matrix which will be +c regarded as a set of vectors to which the householder +c transformation is to be applied. on exit c() contains the +c set of transformed vectors. +c ice storage increment between elements of vectors in c(). +c icv storage increment between vectors in c(). +c ncv number of vectors in c() to be transformed. if ncv .le. 0 +c no operations will be done on c(). +c + subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv) + dimension u(iue,m), c(1) + double precision sm,b + one=1. +c + if (0.ge.lpivot.or.lpivot.ge.l1.or.l1.gt.m) return + cl=abs(u(1,lpivot)) + if (mode.eq.2) go to 60 +c ****** construct the transformation. ****** + do 10 j=l1,m + 10 cl=amax1(abs(u(1,j)),cl) + if (cl) 130,130,20 + 20 clinv=one/cl + sm=(dble(u(1,lpivot))*clinv)**2 + do 30 j=l1,m + 30 sm=sm+(dble(u(1,j))*clinv)**2 +c convert dble. prec. sm to sngl. prec. sm1 + sm1=sm + cl=cl*sqrt(sm1) + if (u(1,lpivot)) 50,50,40 + 40 cl=-cl + 50 up=u(1,lpivot)-cl + u(1,lpivot)=cl + go to 70 +c ****** apply the transformation i+u*(u**t)/b to c. ****** +c + 60 if (cl) 130,130,70 + 70 if (ncv.le.0) return + b=dble(up)*u(1,lpivot) +c b must be nonpositive here. if b = 0., return. +c + if (b) 80,130,130 + 80 b=one/b + i2=1-icv+ice*(lpivot-1) + incr=ice*(l1-lpivot) + do 120 j=1,ncv + i2=i2+icv + i3=i2+incr + i4=i3 + sm=c(i2)*dble(up) + do 90 i=l1,m + sm=sm+c(i3)*dble(u(1,i)) + 90 i3=i3+ice + if (sm) 100,120,100 + 100 sm=sm*b + c(i2)=c(i2)+sm*dble(up) + do 110 i=l1,m + c(i4)=c(i4)+sm*dble(u(1,i)) + 110 i4=i4+ice + 120 continue + 130 return + end diff --git a/math/llsq/hfti.f b/math/llsq/hfti.f new file mode 100644 index 00000000..62dcebe4 --- /dev/null +++ b/math/llsq/hfti.f @@ -0,0 +1,136 @@ + subroutine hfti (a,mda,m,n,b,mdb,nb,tau,krank,rnorm,h,g,ip) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c solve least squares problem using algorithm, hfti. +c + dimension a(mda,n),b(mdb,nb),h(n),g(n),rnorm(nb) + integer ip(n) + double precision sm,dzero + szero=0. + dzero=0.d0 + factor=0.001 +c + k=0 + ldiag=min0(m,n) + if (ldiag.le.0) go to 270 + do 80 j=1,ldiag + if (j.eq.1) go to 20 +c +c update squared column lengths and find lmax +c .. + lmax=j + do 10 l=j,n + h(l)=h(l)-a(j-1,l)**2 + if (h(l).gt.h(lmax)) lmax=l + 10 continue + if(diff(hmax+factor*h(lmax),hmax)) 20,20,50 +c +c compute squared column lengths and find lmax +c .. + 20 lmax=j + do 40 l=j,n + h(l)=0. + do 30 i=j,m + 30 h(l)=h(l)+a(i,l)**2 + if (h(l).gt.h(lmax)) lmax=l + 40 continue + hmax=h(lmax) +c .. +c lmax has been determined +c +c do column interchanges if needed. +c .. + 50 continue + ip(j)=lmax + if (ip(j).eq.j) go to 70 + do 60 i=1,m + tmp=a(i,j) + a(i,j)=a(i,lmax) + 60 a(i,lmax)=tmp + h(lmax)=h(j) +c +c compute the j-th transformation and apply it to a and b. +c .. + 70 call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j) + 80 call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb) +c +c determine the pseudorank, k, using the tolerance, tau. +c .. + do 90 j=1,ldiag + if (abs(a(j,j)).le.tau) go to 100 + 90 continue + k=ldiag + go to 110 + 100 k=j-1 + 110 kp1=k+1 +c +c compute the norms of the residual vectors. +c + if (nb.le.0) go to 140 + do 130 jb=1,nb + tmp=szero + if (kp1.gt.m) go to 130 + do 120 i=kp1,m + 120 tmp=tmp+b(i,jb)**2 + 130 rnorm(jb)=sqrt(tmp) + 140 continue +c special for pseudorank = 0 + if (k.gt.0) go to 160 + if (nb.le.0) go to 270 + do 150 jb=1,nb + do 150 i=1,n + 150 b(i,jb)=szero + go to 270 +c +c if the pseudorank is less than n compute householder +c decomposition of first k rows. +c .. + 160 if (k.eq.n) go to 180 + do 170 ii=1,k + i=kp1-ii + 170 call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1) + 180 continue +c +c + if (nb.le.0) go to 270 + do 260 jb=1,nb +c +c solve the k by k triangular system. +c .. + do 210 l=1,k + sm=dzero + i=kp1-l + if (i.eq.k) go to 200 + ip1=i+1 + do 190 j=ip1,k + 190 sm=sm+a(i,j)*dble(b(j,jb)) + 200 sm1=sm + 210 b(i,jb)=(b(i,jb)-sm1)/a(i,i) +c +c complete computation of solution vector. +c .. + if (k.eq.n) go to 240 + do 220 j=kp1,n + 220 b(j,jb)=szero + do 230 i=1,k + 230 call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1) +c +c re-order the solution vector to compensate for the +c column interchanges. +c .. + 240 do 250 jj=1,ldiag + j=ldiag+1-jj + if (ip(j).eq.j) go to 250 + l=ip(j) + tmp=b(l,jb) + b(l,jb)=b(j,jb) + b(j,jb)=tmp + 250 continue + 260 continue +c .. +c the solution vectors, x, are now +c in the first n rows of the array b(,). +c + 270 krank=k + return + end diff --git a/math/llsq/ldp.f b/math/llsq/ldp.f new file mode 100644 index 00000000..a083f35b --- /dev/null +++ b/math/llsq/ldp.f @@ -0,0 +1,79 @@ + subroutine ldp (g,mdg,m,n,h,x,xnorm,w,index,ier) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1974 mar 1 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c ********** least distance programming ********** +c + integer index(m) + dimension g(mdg,n), h(m), x(n), w(1) + zero=0. + one=1. + if (n.le.0) go to 120 + do 10 j=1,n + 10 x(j)=zero + xnorm=zero + if (m.le.0) go to 110 +c +c the declared dimension of w() must be at least (n+1)*(m+2)+2*m. +c +c first (n+1)*m locs of w() = matrix e for problem nnls. +c next n+1 locs of w() = vector f for problem nnls. +c next n+1 locs of w() = vector z for problem nnls. +c next m locs of w() = vector y for problem nnls. +c next m locs of w() = vector wdual for problem nnls. +c copy g**t into first n rows and m columns of e. +c copy h**t into row n+1 of e. +c + iw=0 + do 30 j=1,m + do 20 i=1,n + iw=iw+1 + 20 w(iw)=g(j,i) + iw=iw+1 + 30 w(iw)=h(j) + if=iw+1 +c store n zeros followed by a one into f. + do 40 i=1,n + iw=iw+1 + 40 w(iw)=zero + w(iw+1)=one +c + np1=n+1 + iz=iw+2 + iy=iz+np1 + iwdual=iy+m +c + call nnls (w,np1,np1,m,w(if),w(iy),rnorm,w(iwdual),w(iz),index, + * ier) +c use the following return if unsuccessful in nnls. + if (ier.ne.0) return + if (rnorm) 130,130,50 + 50 fac=one + iw=iy-1 + do 60 i=1,m + iw=iw+1 +c here we are using the solution vector y. + 60 fac=fac-h(i)*w(iw) +c + if (diff(one+fac,one)) 130,130,70 + 70 fac=one/fac + do 90 j=1,n + iw=iy-1 + do 80 i=1,m + iw=iw+1 +c here we are using the solution vector y. + 80 x(j)=x(j)+g(i,j)*w(iw) + 90 x(j)=x(j)*fac + do 100 j=1,n + 100 xnorm=xnorm+x(j)**2 + xnorm=sqrt(xnorm) +c successful return. + 110 ier=0 + return +c error return. n .le. 0. + 120 ier=2 + return +c returning with constraints not compatible. + 130 ier=4 + return + end diff --git a/math/llsq/mfeout.f b/math/llsq/mfeout.f new file mode 100644 index 00000000..fb439e40 --- /dev/null +++ b/math/llsq/mfeout.f @@ -0,0 +1,64 @@ + subroutine mfeout (a,mda,m,n,names,mode) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c subroutine for matrix output with labeling. +c +c a( ) matrix to be output +c mda first dimension of a array +c m no. of rows in a matrix +c n no. of cols in a matrix +c names() array of names. if names(1) = 1h , the rest +c of the names() array will be ignored. +c mode =1 for 4p8f15.0 format for v matrix. +c =2 for 8e15.8 format for candidate solutions. +c + dimension a(mda,01) + integer names(m),ihead(2) + logical notblk + data maxcol/8/, iblank/1h /,ihead(1)/4h col/,ihead(2)/4hsoln/ +c + notblk=names(1).ne.iblank + if (m.le.0.or.n.le.0) return +c + if (mode.eq.2) go to 10 + write (6,70) + go to 20 + 10 write (6,80) + 20 continue +c + nblock=n/maxcol + last=n-nblock*maxcol + ncol=maxcol + j1=1 +c +c main loop starts here +c + 30 if (nblock.gt.0) go to 40 + if (last.le.0) return + ncol=last + last=0 +c + 40 j2=j1+ncol-1 + write (6,90) (ihead(mode),j,j=j1,j2) +c + do 60 i=1,m + name=iblank + if (notblk) name=names(i) +c + if (mode.eq.2) go to 50 + write (6,100) i,name,(a(i,j),j=j1,j2) + go to 60 + 50 write (6,110) i,name,(a(i,j),j=j1,j2) + 60 continue +c + j1=j1+maxcol + nblock=nblock-1 + go to 30 +c + 70 format (45h0v-matrix of the singular value decomposition, + * 8h of a*d./47h (elements of v scaled up by a factor of 10**4)) + 80 format (35h0sequence of candidate solutions, x) + 90 format (1h0,11x,8(6x,a4,i4,1x)/1x) + 100 format (1x,i3,1x,a6,1x,4p8f15.0) + 110 format (1x,i3,1x,a6,1x,8e15.8) + end diff --git a/math/llsq/mkpkg b/math/llsq/mkpkg new file mode 100644 index 00000000..1d2cf4a5 --- /dev/null +++ b/math/llsq/mkpkg @@ -0,0 +1,23 @@ +# Update Lawson's and Hanson's linear least squares package (LIBLLSQ). + +$checkout libllsq.a lib$ +$update libllsq.a +$checkin libllsq.a lib$ +$exit + +libllsq.a: + bndacc.f + bndsol.f + diff.f + g1.f + g2.f + gen.f + h12.f + hfti.f + ldp.f + mfeout.f + nnls.f + qrbd.f + sva.f + svdrs.f + ; diff --git a/math/llsq/nnls.f b/math/llsq/nnls.f new file mode 100644 index 00000000..58337147 --- /dev/null +++ b/math/llsq/nnls.f @@ -0,0 +1,276 @@ +c subroutine nnls (a,mda,m,n,b,x,rnorm,w,zz,index,ier) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 june 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c ********** nonnegative least squares ********** +c +c given an m by n matrix, a, and an m-vector, b, compute an +c n-vector, x, which solves the least squares problem +c +c a * x = b subject to x .ge. 0 +c +c a(),mda,m,n mda is the first dimensioning parameter for the +c array, a(). on entry a() contains the m by n +c matrix, a. on exit a() contains +c the product matrix, q*a , where q is an +c m by m orthogonal matrix generated implicitly by +c this subroutine. +c b() on entry b() contains the m-vector, b. on exit b() con- +c tains q*b. +c x() on entry x() need not be initialized. on exit x() will +c contain the solution vector. +c rnorm on exit rnorm contains the euclidean norm of the +c residual vector. +c w() an n-array of working space. on exit w() will contain +c the dual solution vector. w will satisfy w(i) = 0. +c for all i in set p and w(i) .le. 0. for all i in set z +c zz() an m-array of working space. +c index() an integer working array of length at least n. +c on exit the contents of this array define the sets +c p and z as follows.. +c +c index(1) thru index(nsetp) = set p. +c index(iz1) thru index(iz2) = set z. +c iz1 = nsetp + 1 = npp1 +c iz2 = n +c ier this is a success-failure flag with the following +c meanings. +c 0 the solution has been computed successfully. +c 2 the dimensions of the problem are bad. +c either m .le. 0 or n .le. 0. +c 3 iteration count exceeded. more than 3*n iterations. +c + subroutine nnls (a,mda,m,n,b,x,rnorm,w,zz,index,ier) + dimension a(mda,n), b(m), x(n), w(n), zz(m) + integer index(n) + zero=0. + one=1. + two=2. + factor=0.01 +c + ier=0 + if (m.gt.0.and.n.gt.0) go to 10 + ier=2 + return + 10 iter=0 + itmax=3*n +c +c initialize the arrays index() and x(). +c + do 20 i=1,n + x(i)=zero + 20 index(i)=i +c + iz2=n + iz1=1 + nsetp=0 + npp1=1 +c ****** main loop begins here ****** + 30 continue +c quit if all coefficients are already in the solution. +c or if m cols of a have been triangularized. +c + if (iz1.gt.iz2.or.nsetp.ge.m) go to 350 +c +c compute components of the dual (negative gradient) vector w(). +c + do 50 iz=iz1,iz2 + j=index(iz) + sm=zero + do 40 l=npp1,m + 40 sm=sm+a(l,j)*b(l) + 50 w(j)=sm +c find largest positive w(j). + 60 wmax=zero + do 70 iz=iz1,iz2 + j=index(iz) + if (w(j).le.wmax) go to 70 + wmax=w(j) + izmax=iz + 70 continue +c +c if wmax .le. 0. go to termination. +c this indicates satisfaction of the kuhn-tucker conditions. +c + if (wmax) 350,350,80 + 80 iz=izmax + j=index(iz) +c +c the sign of w(j) is ok for j to be moved to set p. +c begin the transformation and check new diagonal element to avoid +c near linear dependence. +c + asave=a(npp1,j) + call h12 (1,npp1,npp1+1,m,a(1,j),1,up,dummy,1,1,0) + unorm=zero + if (nsetp.eq.0) go to 100 + do 90 l=1,nsetp + 90 unorm=unorm+a(l,j)**2 + 100 unorm=sqrt(unorm) + if (diff(unorm+abs(a(npp1,j))*factor,unorm)) 130,130,110 +c +c col j is sufficiently independent. copy b into zz, update zz and +c > solve for ztest ( = proposed new value for x(j) ). +c + 110 do 120 l=1,m + 120 zz(l)=b(l) + call h12 (2,npp1,npp1+1,m,a(1,j),1,up,zz,1,1,1) + ztest=zz(npp1)/a(npp1,j) +c +c see if ztest is positive +c reject j as a candidate to be moved from set z to set p. +c restore a(npp1,j), set w(j)=0., and loop back to test dual +c + if (ztest) 130,130,140 +c +c coeffs again. +c + 130 a(npp1,j)=asave + w(j)=zero + go to 60 +c +c the index j=index(iz) has been selected to be moved from +c set z to set p. update b, update indices, apply householder +c transformations to cols in new set z, zero subdiagonal elts in +c col j, set w(j)=0. +c + 140 do 150 l=1,m + 150 b(l)=zz(l) +c + index(iz)=index(iz1) + index(iz1)=j + iz1=iz1+1 + nsetp=npp1 + npp1=npp1+1 +c + if (iz1.gt.iz2) go to 170 + do 160 jz=iz1,iz2 + jj=index(jz) + 160 call h12 (2,nsetp,npp1,m,a(1,j),1,up,a(1,jj),1,mda,1) + 170 continue +c + if (nsetp.eq.m) go to 190 + do 180 l=npp1,m + 180 a(l,j)=zero + 190 continue +c + w(j)=zero +c solve the triangular system. +c store the solution temporarily in zz(). + assign 200 to next + go to 400 + 200 continue +c +c ****** secondary loop begins here ****** +c +c iteration counter. +c + 210 iter=iter+1 + if (iter.le.itmax) go to 220 + ier=3 + go to 350 + 220 continue +c +c see if all new constrained coeffs are feasible. +c if not compute alpha. +c + alpha=two + do 240 ip=1,nsetp + l=index(ip) + if (zz(ip)) 230,230,240 +c + 230 t=-x(l)/(zz(ip)-x(l)) + if (alpha.le.t) go to 240 + alpha=t + jj=ip + 240 continue +c +c if all new constrained coeffs are feasible then alpha will +c still = 2. if so exit from secondary loop to main loop. +c + if (alpha.eq.two) go to 330 +c +c otherwise use alpha which will be between 0. and 1. to +c interpolate between the old x and the new zz. +c + do 250 ip=1,nsetp + l=index(ip) + 250 x(l)=x(l)+alpha*(zz(ip)-x(l)) +c +c modify a and b and the index arrays to move coefficient i +c from set p to set z. +c + i=index(jj) + 260 x(i)=zero +c + if (jj.eq.nsetp) go to 290 + jj=jj+1 + do 280 j=jj,nsetp + ii=index(j) + index(j-1)=ii + call g1 (a(j-1,ii),a(j,ii),cc,ss,a(j-1,ii)) + a(j,ii)=zero + do 270 l=1,n + if (l.ne.ii) call g2 (cc,ss,a(j-1,l),a(j,l)) + 270 continue + 280 call g2 (cc,ss,b(j-1),b(j)) + 290 npp1=nsetp + nsetp=nsetp-1 + iz1=iz1-1 + index(iz1)=i +c +c see if the remaining coeffs in set p are feasible. they should +c be because of the way alpha was determined. +c if any are infeasible it is due to round-off error. any +c that are nonpositive will be set to zero +c and moved from set p to set z. +c + do 300 jj=1,nsetp + i=index(jj) + if (x(i)) 260,260,300 + 300 continue +c +c copy b( ) into zz( ). then solve again and loop back. +c + + do 310 i=1,m + 310 zz(i)=b(i) + assign 320 to next + go to 400 + 320 continue + go to 210 +c ****** end of secondary loop ****** +c + 330 do 340 ip=1,nsetp + i=index(ip) + 340 x(i)=zz(ip) +c all new coeffs are positive. loop back to beginning. + go to 30 +c +c ****** end of main loop ****** +c +c come to here for termination. +c compute the norm of the final residual vector. +c + 350 sm=zero + if (npp1.gt.m) go to 370 + do 360 i=npp1,m + 360 sm=sm+b(i)**2 + go to 390 + 370 do 380 j=1,n + 380 w(j)=zero + 390 rnorm=sqrt(sm) + return +c +c the following block of code is used as an internal subroutine +c to solve the triangular system, putting the solution in zz(). +c + 400 do 430 l=1,nsetp + ip=nsetp+1-l + if (l.eq.1) go to 420 + do 410 ii=1,ip + 410 zz(ii)=zz(ii)-a(ii,jj)*zz(ip+1) + 420 jj=index(ip) + 430 zz(ip)=zz(ip)/a(ip,jj) + go to next, (200,320) + end diff --git a/math/llsq/original_f/bndacc.f b/math/llsq/original_f/bndacc.f new file mode 100644 index 00000000..80b9914c --- /dev/null +++ b/math/llsq/original_f/bndacc.f @@ -0,0 +1,74 @@ + subroutine bndacc (g,mdg,nb,ip,ir,mt,jt) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c sequential algorithm for banded least squares problem.. +c accumulation phase. for solution phase use bndsol. +c +c the calling program must set ir=1 and ip=1 before the first call +c to bndacc for a new case. +c +c the second subscript of g( ) must be dimensioned at least +c nb+1 in the calling program. + dimension g(mdg,1) + zero=0. +c +c alg. steps 1-4 are performed external to this subroutine. +c + nbp1=nb+1 + if (mt.le.0) return +c alg. step 5 + if (jt.eq.ip) go to 70 +c alg. steps 6-7 + if (jt.le.ir) go to 30 +c alg. steps 8-9 + do 10 i=1,mt + ig1=jt+mt-i + ig2=ir+mt-i + do 10 j=1,nbp1 + 10 g(ig1,j)=g(ig2,j) +c alg. step 10 + ie=jt-ir + do 20 i=1,ie + ig=ir+i-1 + do 20 j=1,nbp1 + 20 g(ig,j)=zero +c alg. step 11 + ir=jt +c alg. step 12 + 30 mu=min0(nb-1,ir-ip-1) + if (mu.eq.0) go to 60 +c alg. step 13 + do 50 l=1,mu +c alg. step 14 + k=min0(l,jt-ip) +c alg. step 15 + lp1=l+1 + ig=ip+l + do 40 i=lp1,nb + jg=i-k + 40 g(ig,jg)=g(ig,i) +c alg. step 16 + do 50 i=1,k + jg=nbp1-i + 50 g(ig,jg)=zero +c alg. step 17 + 60 ip=jt +c alg. steps 18-19 + 70 mh=ir+mt-ip + kh=min0(nbp1,mh) +c alg. step 20 + do 80 i=1,kh + 80 call h12 (1,i,max0(i+1,ir-ip+1),mh,g(ip,i),1,rho, + 1 g(ip,i+1),1,mdg,nbp1-i) +c alg. step 21 + ir=ip+kh +c alg. step 22 + if (kh.lt.nbp1) go to 100 +c alg. step 23 + do 90 i=1,nb + 90 g(ir-1,i)=zero +c alg. step 24 + 100 continue +c alg. step 25 + return + end diff --git a/math/llsq/original_f/bndsol.f b/math/llsq/original_f/bndsol.f new file mode 100644 index 00000000..05dd35d7 --- /dev/null +++ b/math/llsq/original_f/bndsol.f @@ -0,0 +1,70 @@ + subroutine bndsol (mode,g,mdg,nb,ip,ir,x,n,rnorm) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c sequential solution of a banded least squares problem.. +c solution phase. for the accumulation phase use bndacc. +c +c mode = 1 solve r*x=y where r and y are in the g( ) array +c and x will be stored in the x( ) array. +c 2 solve (r**t)*x=y where r is in g( ), +c y is initially in x( ), and x replaces y in x( ), +c 3 solve r*x=y where r is in g( ). +c y is initially in x( ), and x replaces y in x( ). +c +c the second subscript of g( ) must be dimensioned at least +c nb+1 in the calling program. + dimension g(mdg,1),x(n) + zero=0. +c + rnorm=zero + go to (10,90,50), mode +c ********************* mode = 1 +c algc step 26 + 10 do 20 j=1,n + 20 x(j)=g(j,nb+1) + rsq=zero + np1=n+1 + irm1=ir-1 + if (np1.gt.irm1) go to 40 + do 30 j=np1,irm1 + 30 rsq=rsq+g(j,nb+1)**2 + rnorm=sqrt(rsq) + 40 continue +c ********************* mode = 3 +c alg. step 27 + 50 do 80 ii=1,n + i=n+1-ii +c alg. step 28 + s=zero + l=max0(0,i-ip) +c alg. step 29 + if (i.eq.n) go to 70 +c alg. step 30 + ie=min0(n+1-i,nb) + do 60 j=2,ie + jg=j+l + ix=i-1+j + 60 s=s+g(i,jg)*x(ix) +c alg. step 31 + 70 if (g(i,l+1)) 80,130,80 + 80 x(i)=(x(i)-s)/g(i,l+1) +c alg. step 32 + return +c ********************* mode = 2 + 90 do 120 j=1,n + s=zero + if (j.eq.1) go to 110 + i1=max0(1,j-nb+1) + i2=j-1 + do 100 i=i1,i2 + l=j-i+1+max0(0,i-ip) + 100 s=s+x(i)*g(i,l) + 110 l=max0(0,j-ip) + if (g(j,l+1)) 120,130,120 + 120 x(j)=(x(j)-s)/g(j,l+1) + return +c + 130 write (6,140) mode,i,j,l + stop + 140 format (30h0zero diagonal term in bndsol.,12h mode,i,j,l=,4i6) + end diff --git a/math/llsq/original_f/diff.f b/math/llsq/original_f/diff.f new file mode 100644 index 00000000..79dacb92 --- /dev/null +++ b/math/llsq/original_f/diff.f @@ -0,0 +1,6 @@ + function diff(x,y) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 june 7 +c to appear in 'solving least squares problems', prentice-hall, 1974 + diff=x-y + return + end diff --git a/math/llsq/original_f/g1.f b/math/llsq/original_f/g1.f new file mode 100644 index 00000000..5d44c50b --- /dev/null +++ b/math/llsq/original_f/g1.f @@ -0,0 +1,33 @@ + subroutine g1 (a,b,cos,sin,sig) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c +c compute orthogonal rotation matrix.. +c compute.. matrix (c, s) so that (c, s)(a) = (sqrt(a**2+b**2)) +c (-s,c) (-s,c)(b) ( 0 ) +c compute sig = sqrt(a**2+b**2) +c sig is computed last to allow for the possibility that +c sig may be in the same location as a or b . +c + zero=0. + one=1. + if (abs(a).le.abs(b)) go to 10 + xr=b/a + yr=sqrt(one+xr**2) + cos=sign(one/yr,a) + sin=cos*xr + sig=abs(a)*yr + return + 10 if (b) 20,30,20 + 20 xr=a/b + yr=sqrt(one+xr**2) + sin=sign(one/yr,b) + cos=sin*xr + sig=abs(b)*yr + return + 30 sig=zero + cos=zero + sin=one + return + end diff --git a/math/llsq/original_f/g2.f b/math/llsq/original_f/g2.f new file mode 100644 index 00000000..6f01a582 --- /dev/null +++ b/math/llsq/original_f/g2.f @@ -0,0 +1,9 @@ + subroutine g2 (cos,sin,x,y) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1972 dec 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c apply the rotation computed by g1 to (x,y). + xr=cos*x+sin*y + y=-sin*x+cos*y + x=xr + return + end diff --git a/math/llsq/original_f/gen.f b/math/llsq/original_f/gen.f new file mode 100644 index 00000000..98181a93 --- /dev/null +++ b/math/llsq/original_f/gen.f @@ -0,0 +1,28 @@ + function gen(anoise) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1972 dec 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c generate numbers for construction of test cases. + if (anoise) 10,30,20 + 10 mi=891 + mj=457 + i=5 + j=7 + aj=0. + gen=0. + return +c +c the sequence of values of j is bounded between 1 and 996 +c if initial j = 1,2,3,4,5,6,7,8, or 9, the period is 332 + 20 j=j*mj + j=j-997*(j/997) + aj=j-498 +c the sequence of values of i is bounded between 1 and 999 +c if initial i = 1,2,3,6,7, or 9, the period will be 50 +c if initial i = 4 or 8 the period will be 25 +c if initial i = 5 the period will be 10 + 30 i=i*mi + i=i-1000*(i/1000) + ai=i-500 + gen=ai+aj*anoise + return + end diff --git a/math/llsq/original_f/h12.f b/math/llsq/original_f/h12.f new file mode 100644 index 00000000..81daa629 --- /dev/null +++ b/math/llsq/original_f/h12.f @@ -0,0 +1,80 @@ +c subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c construction and/or application of a single +c householder transformation.. q = i + u*(u**t)/b +c +c mode = 1 or 2 to select algorithm h1 or h2 . +c lpivot is the index of the pivot element. +c l1,m if l1 .le. m the transformation will be constructed to +c zero elements indexed from l1 through m. if l1 gt. m +c the subroutine does an identity transformation. +c u(),iue,up on entry to h1 u() contains the pivot vector. +c iue is the storage increment between elements. +c on exit from h1 u() and up +c contain quantities defining the vector u of the +c householder transformation. on entry to h2 u() +c and up should contain quantities previously computed +c by h1. these will not be modified by h2. +c c() on entry to h1 or h2 c() contains a matrix which will be +c regarded as a set of vectors to which the householder +c transformation is to be applied. on exit c() contains the +c set of transformed vectors. +c ice storage increment between elements of vectors in c(). +c icv storage increment between vectors in c(). +c ncv number of vectors in c() to be transformed. if ncv .le. 0 +c no operations will be done on c(). +c + subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv) + dimension u(iue,m), c(1) + double precision sm,b + one=1. +c + if (0.ge.lpivot.or.lpivot.ge.l1.or.l1.gt.m) return + cl=abs(u(1,lpivot)) + if (mode.eq.2) go to 60 +c ****** construct the transformation. ****** + do 10 j=l1,m + 10 cl=amax1(abs(u(1,j)),cl) + if (cl) 130,130,20 + 20 clinv=one/cl + sm=(dble(u(1,lpivot))*clinv)**2 + do 30 j=l1,m + 30 sm=sm+(dble(u(1,j))*clinv)**2 +c convert dble. prec. sm to sngl. prec. sm1 + sm1=sm + cl=cl*sqrt(sm1) + if (u(1,lpivot)) 50,50,40 + 40 cl=-cl + 50 up=u(1,lpivot)-cl + u(1,lpivot)=cl + go to 70 +c ****** apply the transformation i+u*(u**t)/b to c. ****** +c + 60 if (cl) 130,130,70 + 70 if (ncv.le.0) return + b=dble(up)*u(1,lpivot) +c b must be nonpositive here. if b = 0., return. +c + if (b) 80,130,130 + 80 b=one/b + i2=1-icv+ice*(lpivot-1) + incr=ice*(l1-lpivot) + do 120 j=1,ncv + i2=i2+icv + i3=i2+incr + i4=i3 + sm=c(i2)*dble(up) + do 90 i=l1,m + sm=sm+c(i3)*dble(u(1,i)) + 90 i3=i3+ice + if (sm) 100,120,100 + 100 sm=sm*b + c(i2)=c(i2)+sm*dble(up) + do 110 i=l1,m + c(i4)=c(i4)+sm*dble(u(1,i)) + 110 i4=i4+ice + 120 continue + 130 return + end diff --git a/math/llsq/original_f/hfti.f b/math/llsq/original_f/hfti.f new file mode 100644 index 00000000..62dcebe4 --- /dev/null +++ b/math/llsq/original_f/hfti.f @@ -0,0 +1,136 @@ + subroutine hfti (a,mda,m,n,b,mdb,nb,tau,krank,rnorm,h,g,ip) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c solve least squares problem using algorithm, hfti. +c + dimension a(mda,n),b(mdb,nb),h(n),g(n),rnorm(nb) + integer ip(n) + double precision sm,dzero + szero=0. + dzero=0.d0 + factor=0.001 +c + k=0 + ldiag=min0(m,n) + if (ldiag.le.0) go to 270 + do 80 j=1,ldiag + if (j.eq.1) go to 20 +c +c update squared column lengths and find lmax +c .. + lmax=j + do 10 l=j,n + h(l)=h(l)-a(j-1,l)**2 + if (h(l).gt.h(lmax)) lmax=l + 10 continue + if(diff(hmax+factor*h(lmax),hmax)) 20,20,50 +c +c compute squared column lengths and find lmax +c .. + 20 lmax=j + do 40 l=j,n + h(l)=0. + do 30 i=j,m + 30 h(l)=h(l)+a(i,l)**2 + if (h(l).gt.h(lmax)) lmax=l + 40 continue + hmax=h(lmax) +c .. +c lmax has been determined +c +c do column interchanges if needed. +c .. + 50 continue + ip(j)=lmax + if (ip(j).eq.j) go to 70 + do 60 i=1,m + tmp=a(i,j) + a(i,j)=a(i,lmax) + 60 a(i,lmax)=tmp + h(lmax)=h(j) +c +c compute the j-th transformation and apply it to a and b. +c .. + 70 call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j) + 80 call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb) +c +c determine the pseudorank, k, using the tolerance, tau. +c .. + do 90 j=1,ldiag + if (abs(a(j,j)).le.tau) go to 100 + 90 continue + k=ldiag + go to 110 + 100 k=j-1 + 110 kp1=k+1 +c +c compute the norms of the residual vectors. +c + if (nb.le.0) go to 140 + do 130 jb=1,nb + tmp=szero + if (kp1.gt.m) go to 130 + do 120 i=kp1,m + 120 tmp=tmp+b(i,jb)**2 + 130 rnorm(jb)=sqrt(tmp) + 140 continue +c special for pseudorank = 0 + if (k.gt.0) go to 160 + if (nb.le.0) go to 270 + do 150 jb=1,nb + do 150 i=1,n + 150 b(i,jb)=szero + go to 270 +c +c if the pseudorank is less than n compute householder +c decomposition of first k rows. +c .. + 160 if (k.eq.n) go to 180 + do 170 ii=1,k + i=kp1-ii + 170 call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1) + 180 continue +c +c + if (nb.le.0) go to 270 + do 260 jb=1,nb +c +c solve the k by k triangular system. +c .. + do 210 l=1,k + sm=dzero + i=kp1-l + if (i.eq.k) go to 200 + ip1=i+1 + do 190 j=ip1,k + 190 sm=sm+a(i,j)*dble(b(j,jb)) + 200 sm1=sm + 210 b(i,jb)=(b(i,jb)-sm1)/a(i,i) +c +c complete computation of solution vector. +c .. + if (k.eq.n) go to 240 + do 220 j=kp1,n + 220 b(j,jb)=szero + do 230 i=1,k + 230 call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1) +c +c re-order the solution vector to compensate for the +c column interchanges. +c .. + 240 do 250 jj=1,ldiag + j=ldiag+1-jj + if (ip(j).eq.j) go to 250 + l=ip(j) + tmp=b(l,jb) + b(l,jb)=b(j,jb) + b(j,jb)=tmp + 250 continue + 260 continue +c .. +c the solution vectors, x, are now +c in the first n rows of the array b(,). +c + 270 krank=k + return + end diff --git a/math/llsq/original_f/ldp.f b/math/llsq/original_f/ldp.f new file mode 100644 index 00000000..65d4c77e --- /dev/null +++ b/math/llsq/original_f/ldp.f @@ -0,0 +1,79 @@ + subroutine ldp (g,mdg,m,n,h,x,xnorm,w,index,mode) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1974 mar 1 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c ********** least distance programming ********** +c + integer index(m) + dimension g(mdg,n), h(m), x(n), w(1) + zero=0. + one=1. + if (n.le.0) go to 120 + do 10 j=1,n + 10 x(j)=zero + xnorm=zero + if (m.le.0) go to 110 +c +c the declared dimension of w() must be at least (n+1)*(m+2)+2*m. +c +c first (n+1)*m locs of w() = matrix e for problem nnls. +c next n+1 locs of w() = vector f for problem nnls. +c next n+1 locs of w() = vector z for problem nnls. +c next m locs of w() = vector y for problem nnls. +c next m locs of w() = vector wdual for problem nnls. +c copy g**t into first n rows and m columns of e. +c copy h**t into row n+1 of e. +c + iw=0 + do 30 j=1,m + do 20 i=1,n + iw=iw+1 + 20 w(iw)=g(j,i) + iw=iw+1 + 30 w(iw)=h(j) + if=iw+1 +c store n zeros followed by a one into f. + do 40 i=1,n + iw=iw+1 + 40 w(iw)=zero + w(iw+1)=one +c + np1=n+1 + iz=iw+2 + iy=iz+np1 + iwdual=iy+m +c + call nnls (w,np1,np1,m,w(if),w(iy),rnorm,w(iwdual),w(iz),index, + * mode) +c use the following return if unsuccessful in nnls. + if (mode.ne.1) return + if (rnorm) 130,130,50 + 50 fac=one + iw=iy-1 + do 60 i=1,m + iw=iw+1 +c here we are using the solution vector y. + 60 fac=fac-h(i)*w(iw) +c + if (diff(one+fac,one)) 130,130,70 + 70 fac=one/fac + do 90 j=1,n + iw=iy-1 + do 80 i=1,m + iw=iw+1 +c here we are using the solution vector y. + 80 x(j)=x(j)+g(i,j)*w(iw) + 90 x(j)=x(j)*fac + do 100 j=1,n + 100 xnorm=xnorm+x(j)**2 + xnorm=sqrt(xnorm) +c successful return. + 110 mode=1 + return +c error return. n .le. 0. + 120 mode=2 + return +c returning with constraints not compatible. + 130 mode=4 + return + end diff --git a/math/llsq/original_f/nnls.f b/math/llsq/original_f/nnls.f new file mode 100644 index 00000000..fb5aa767 --- /dev/null +++ b/math/llsq/original_f/nnls.f @@ -0,0 +1,278 @@ +c subroutine nnls (a,mda,m,n,b,x,rnorm,w,zz,index,mode) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 june 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c +c ********** nonnegative least squares ********** +c +c given an m by n matrix, a, and an m-vector, b, compute an +c n-vector, x, which solves the least squares problem +c +c a * x = b subject to x .ge. 0 +c +c a(),mda,m,n mda is the first dimensioning parameter for the +c array, a(). on entry a() contains the m by n +c matrix, a. on exit a() contains +c the product matrix, q*a , where q is an +c m by m orthogonal matrix generated implicitly by +c this subroutine. +c b() on entry b() contains the m-vector, b. on exit b() con- +c tains q*b. +c x() on entry x() need not be initialized. on exit x() will +c contain the solution vector. +c rnorm on exit rnorm contains the euclidean norm of the +c residual vector. +c w() an n-array of working space. on exit w() will contain +c the dual solution vector. w will satisfy w(i) = 0. +c for all i in set p and w(i) .le. 0. for all i in set z +c zz() an m-array of working space. +c index() an integer working array of length at least n. +c on exit the contents of this array define the sets +c p and z as follows.. +c +c index(1) thru index(nsetp) = set p. +c index(iz1) thru index(iz2) = set z. +c iz1 = nsetp + 1 = npp1 +c iz2 = n +c mode this is a success-failure flag with the following +c meanings. +c 1 the solution has been computed successfully. +c 2 the dimensions of the problem are bad. +c either m .le. 0 or n .le. 0. +c 3 iteration count exceeded. more than 3*n iterations. +c + subroutine nnls (a,mda,m,n,b,x,rnorm,w,zz,index,mode) + dimension a(mda,n), b(m), x(n), w(n), zz(m) + integer index(n) + zero=0. + one=1. + two=2. + factor=0.01 +c + mode=1 + if (m.gt.0.and.n.gt.0) go to 10 + mode=2 + return + 10 iter=0 + itmax=3*n +c +c initialize the arrays index() and x(). +c + do 20 i=1,n + x(i)=zero + 20 index(i)=i +c + iz2=n + iz1=1 + nsetp=0 + npp1=1 +c ****** main loop begins here ****** + 30 continue +c quit if all coefficients are already in the solution. +c or if m cols of a have been triangularized. +c + if (iz1.gt.iz2.or.nsetp.ge.m) go to 350 +c +c compute components of the dual (negative gradient) vector w(). +c + do 50 iz=iz1,iz2 + j=index(iz) + sm=zero + do 40 l=npp1,m + 40 sm=sm+a(l,j)*b(l) + 50 w(j)=sm +c find largest positive w(j). + 60 wmax=zero + do 70 iz=iz1,iz2 + j=index(iz) + if (w(j).le.wmax) go to 70 + wmax=w(j) + izmax=iz + 70 continue +c +c if wmax .le. 0. go to termination. +c this indicates satisfaction of the kuhn-tucker conditions. +c + if (wmax) 350,350,80 + 80 iz=izmax + j=index(iz) +c +c the sign of w(j) is ok for j to be moved to set p. +c begin the transformation and check new diagonal element to avoid +c near linear dependence. +c + asave=a(npp1,j) + call h12 (1,npp1,npp1+1,m,a(1,j),1,up,dummy,1,1,0) + unorm=zero + if (nsetp.eq.0) go to 100 + do 90 l=1,nsetp + 90 unorm=unorm+a(l,j)**2 + 100 unorm=sqrt(unorm) + if (diff(unorm+abs(a(npp1,j))*factor,unorm)) 130,130,110 +c +c col j is sufficiently independent. copy b into zz, update zz and +c > solve for ztest ( = proposed new value for x(j) ). +c + 110 do 120 l=1,m + 120 zz(l)=b(l) + call h12 (2,npp1,npp1+1,m,a(1,j),1,up,zz,1,1,1) + ztest=zz(npp1)/a(npp1,j) +c +c see if ztest is positive +c reject j as a candidate to be moved from set z to set p. +c restore a(npp1,j), set w(j)=0., and loop back to test dual +c + if (ztest) 130,130,140 +c +c coeffs again. +c + 130 a(npp1,j)=asave + w(j)=zero + go to 60 +c +c the index j=index(iz) has been selected to be moved from +c set z to set p. update b, update indices, apply householder +c transformations to cols in new set z, zero subdiagonal elts in +c col j, set w(j)=0. +c + 140 do 150 l=1,m + 150 b(l)=zz(l) +c + index(iz)=index(iz1) + index(iz1)=j + iz1=iz1+1 + nsetp=npp1 + npp1=npp1+1 +c + if (iz1.gt.iz2) go to 170 + do 160 jz=iz1,iz2 + jj=index(jz) + 160 call h12 (2,nsetp,npp1,m,a(1,j),1,up,a(1,jj),1,mda,1) + 170 continue +c + if (nsetp.eq.m) go to 190 + do 180 l=npp1,m + 180 a(l,j)=zero + 190 continue +c + w(j)=zero +c solve the triangular system. +c store the solution temporarily in zz(). + assign 200 to next + go to 400 + 200 continue +c +c ****** secondary loop begins here ****** +c +c iteration counter. +c + 210 iter=iter+1 + if (iter.le.itmax) go to 220 + mode=3 + write (6,440) + go to 350 + 220 continue +c +c see if all new constrained coeffs are feasible. +c if not compute alpha. +c + alpha=two + do 240 ip=1,nsetp + l=index(ip) + if (zz(ip)) 230,230,240 +c + 230 t=-x(l)/(zz(ip)-x(l)) + if (alpha.le.t) go to 240 + alpha=t + jj=ip + 240 continue +c +c if all new constrained coeffs are feasible then alpha will +c still = 2. if so exit from secondary loop to main loop. +c + if (alpha.eq.two) go to 330 +c +c otherwise use alpha which will be between 0. and 1. to +c interpolate between the old x and the new zz. +c + do 250 ip=1,nsetp + l=index(ip) + 250 x(l)=x(l)+alpha*(zz(ip)-x(l)) +c +c modify a and b and the index arrays to move coefficient i +c from set p to set z. +c + i=index(jj) + 260 x(i)=zero +c + if (jj.eq.nsetp) go to 290 + jj=jj+1 + do 280 j=jj,nsetp + ii=index(j) + index(j-1)=ii + call g1 (a(j-1,ii),a(j,ii),cc,ss,a(j-1,ii)) + a(j,ii)=zero + do 270 l=1,n + if (l.ne.ii) call g2 (cc,ss,a(j-1,l),a(j,l)) + 270 continue + 280 call g2 (cc,ss,b(j-1),b(j)) + 290 npp1=nsetp + nsetp=nsetp-1 + iz1=iz1-1 + index(iz1)=i +c +c see if the remaining coeffs in set p are feasible. they should +c be because of the way alpha was determined. +c if any are infeasible it is due to round-off error. any +c that are nonpositive will be set to zero +c and moved from set p to set z. +c + do 300 jj=1,nsetp + i=index(jj) + if (x(i)) 260,260,300 + 300 continue +c +c copy b( ) into zz( ). then solve again and loop back. +c + + do 310 i=1,m + 310 zz(i)=b(i) + assign 320 to next + go to 400 + 320 continue + go to 210 +c ****** end of secondary loop ****** +c + 330 do 340 ip=1,nsetp + i=index(ip) + 340 x(i)=zz(ip) +c all new coeffs are positive. loop back to beginning. + go to 30 +c +c ****** end of main loop ****** +c +c come to here for termination. +c compute the norm of the final residual vector. +c + 350 sm=zero + if (npp1.gt.m) go to 370 + do 360 i=npp1,m + 360 sm=sm+b(i)**2 + go to 390 + 370 do 380 j=1,n + 380 w(j)=zero + 390 rnorm=sqrt(sm) + return +c +c the following block of code is used as an internal subroutine +c to solve the triangular system, putting the solution in zz(). +c + 400 do 430 l=1,nsetp + ip=nsetp+1-l + if (l.eq.1) go to 420 + do 410 ii=1,ip + 410 zz(ii)=zz(ii)-a(ii,jj)*zz(ip+1) + 420 jj=index(ip) + 430 zz(ip)=zz(ip)/a(ip,jj) + go to next, (200,320) + 440 format (35h0 nnls quitting on iteration count.) + end diff --git a/math/llsq/original_f/qrbd.f b/math/llsq/original_f/qrbd.f new file mode 100644 index 00000000..d9a12a24 --- /dev/null +++ b/math/llsq/original_f/qrbd.f @@ -0,0 +1,208 @@ +c subroutine qrbd (ipass,q,e,nn,v,mdv,nrv,c,mdc,ncc) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c qr algorithm for singular values of a bidiagonal matrix. +c +c the bidiagonal matrix +c +c (q1,e2,0... ) +c ( q2,e3,0... ) +c d= ( . ) +c ( . 0) +c ( .en) +c ( 0,qn) +c +c is pre and post multiplied by +c elementary rotation matrices +c ri and pi so that +c +c rk...r1*d*p1**(t)...pk**(t) = diag(s1,...,sn) +c +c to within working accuracy. +c +c 1. ei and qi occupy e(i) and q(i) as input. +c +c 2. rm...r1*c replaces 'c' in storage as output. +c +c 3. v*p1**(t)...pm**(t) replaces 'v' in storage as output. +c +c 4. si occupies q(i) as output. +c +c 5. the si's are nonincreasing and nonnegative. +c +c this code is based on the paper and 'algol' code.. +c ref.. +c 1. reinsch,c.h. and golub,g.h. 'singular value decomposition +c and least squares solutions' (numer. math.), vol. 14,(1970). +c + subroutine qrbd (ipass,q,e,nn,v,mdv,nrv,c,mdc,ncc) + logical wntv ,havers,fail + dimension q(nn),e(nn),v(mdv,nn),c(mdc,ncc) + zero=0. + one=1. + two=2. +c + n=nn + ipass=1 + if (n.le.0) return + n10=10*n + wntv=nrv.gt.0 + havers=ncc.gt.0 + fail=.false. + nqrs=0 + e(1)=zero + dnorm=zero + do 10 j=1,n + 10 dnorm=amax1(abs(q(j))+abs(e(j)),dnorm) + do 200 kk=1,n + k=n+1-kk +c +c test for splitting or rank deficiencies.. +c first make test for last diagonal term, q(k), being small. + 20 if(k.eq.1) go to 50 + if(diff(dnorm+q(k),dnorm)) 50,25,50 +c +c since q(k) is small we will make a special pass to +c transform e(k) to zero. +c + 25 cs=zero + sn=-one + do 40 ii=2,k + i=k+1-ii + f=-sn*e(i+1) + e(i+1)=cs*e(i+1) + call g1 (q(i),f,cs,sn,q(i)) +c transformation constructed to zero position (i,k). +c + if (.not.wntv) go to 40 + do 30 j=1,nrv + 30 call g2 (cs,sn,v(j,i),v(j,k)) +c accumulate rt. transformations in v. +c + 40 continue +c +c the matrix is now bidiagonal, and of lower order +c since e(k) .eq. zero.. +c + 50 do 60 ll=1,k + l=k+1-ll + if(diff(dnorm+e(l),dnorm)) 55,100,55 + 55 if(diff(dnorm+q(l-1),dnorm)) 60,70,60 + 60 continue +c this loop can't complete since e(1) = zero. +c + go to 100 +c +c cancellation of e(l), l.gt.1. + 70 cs=zero + sn=-one + do 90 i=l,k + f=-sn*e(i) + e(i)=cs*e(i) + if(diff(dnorm+f,dnorm)) 75,100,75 + 75 call g1 (q(i),f,cs,sn,q(i)) + if (.not.havers) go to 90 + do 80 j=1,ncc + 80 call g2 (cs,sn,c(i,j),c(l-1,j)) + 90 continue +c +c test for convergence.. + 100 z=q(k) + if (l.eq.k) go to 170 +c +c shift from bottom 2 by 2 minor of b**(t)*b. + x=q(l) + y=q(k-1) + g=e(k-1) + h=e(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(two*h*y) + g=sqrt(one+f**2) + if (f.lt.zero) go to 110 + t=f+g + go to 120 + 110 t=f-g + 120 f=((x-z)*(x+z)+h*(y/t-h))/x +c +c next qr sweep.. + cs=one + sn=one + lp1=l+1 + do 160 i=lp1,k + g=e(i) + y=q(i) + h=sn*g + g=cs*g + call g1 (f,h,cs,sn,e(i-1)) + f=x*cs+g*sn + g=-x*sn+g*cs + h=y*sn + y=y*cs + if (.not.wntv) go to 140 +c +c accumulate rotations (from the right) in 'v' + do 130 j=1,nrv + 130 call g2 (cs,sn,v(j,i-1),v(j,i)) + 140 call g1 (f,h,cs,sn,q(i-1)) + f=cs*g+sn*y + x=-sn*g+cs*y + if (.not.havers) go to 160 + do 150 j=1,ncc + 150 call g2 (cs,sn,c(i-1,j),c(i,j)) +c apply rotations from the left to +c right hand sides in 'c'.. +c + 160 continue + e(l)=zero + e(k)=f + q(k)=x + nqrs=nqrs+1 + if (nqrs.le.n10) go to 20 +c return to 'test for splitting'. +c + fail=.true. +c .. +c cutoff for convergence failure. 'nqrs' will be 2*n usually. + 170 if (z.ge.zero) go to 190 + q(k)=-z + if (.not.wntv) go to 190 + do 180 j=1,nrv + 180 v(j,k)=-v(j,k) + 190 continue +c convergence. q(k) is made nonnegative.. +c + 200 continue + if (n.eq.1) return + do 210 i=2,n + if (q(i).gt.q(i-1)) go to 220 + 210 continue + if (fail) ipass=2 + return +c .. +c every singular value is in order.. + 220 do 270 i=2,n + t=q(i-1) + k=i-1 + do 230 j=i,n + if (t.ge.q(j)) go to 230 + t=q(j) + k=j + 230 continue + if (k.eq.i-1) go to 270 + q(k)=q(i-1) + q(i-1)=t + if (.not.havers) go to 250 + do 240 j=1,ncc + t=c(i-1,j) + c(i-1,j)=c(k,j) + 240 c(k,j)=t + 250 if (.not.wntv) go to 270 + do 260 j=1,nrv + t=v(j,i-1) + v(j,i-1)=v(j,k) + 260 v(j,k)=t + 270 continue +c end of ordering algorithm. +c + if (fail) ipass=2 + return + end diff --git a/math/llsq/original_f/sfeout.f b/math/llsq/original_f/sfeout.f new file mode 100644 index 00000000..fb439e40 --- /dev/null +++ b/math/llsq/original_f/sfeout.f @@ -0,0 +1,64 @@ + subroutine mfeout (a,mda,m,n,names,mode) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c subroutine for matrix output with labeling. +c +c a( ) matrix to be output +c mda first dimension of a array +c m no. of rows in a matrix +c n no. of cols in a matrix +c names() array of names. if names(1) = 1h , the rest +c of the names() array will be ignored. +c mode =1 for 4p8f15.0 format for v matrix. +c =2 for 8e15.8 format for candidate solutions. +c + dimension a(mda,01) + integer names(m),ihead(2) + logical notblk + data maxcol/8/, iblank/1h /,ihead(1)/4h col/,ihead(2)/4hsoln/ +c + notblk=names(1).ne.iblank + if (m.le.0.or.n.le.0) return +c + if (mode.eq.2) go to 10 + write (6,70) + go to 20 + 10 write (6,80) + 20 continue +c + nblock=n/maxcol + last=n-nblock*maxcol + ncol=maxcol + j1=1 +c +c main loop starts here +c + 30 if (nblock.gt.0) go to 40 + if (last.le.0) return + ncol=last + last=0 +c + 40 j2=j1+ncol-1 + write (6,90) (ihead(mode),j,j=j1,j2) +c + do 60 i=1,m + name=iblank + if (notblk) name=names(i) +c + if (mode.eq.2) go to 50 + write (6,100) i,name,(a(i,j),j=j1,j2) + go to 60 + 50 write (6,110) i,name,(a(i,j),j=j1,j2) + 60 continue +c + j1=j1+maxcol + nblock=nblock-1 + go to 30 +c + 70 format (45h0v-matrix of the singular value decomposition, + * 8h of a*d./47h (elements of v scaled up by a factor of 10**4)) + 80 format (35h0sequence of candidate solutions, x) + 90 format (1h0,11x,8(6x,a4,i4,1x)/1x) + 100 format (1x,i3,1x,a6,1x,4p8f15.0) + 110 format (1x,i3,1x,a6,1x,8e15.8) + end diff --git a/math/llsq/original_f/sva.f b/math/llsq/original_f/sva.f new file mode 100644 index 00000000..469a90ef --- /dev/null +++ b/math/llsq/original_f/sva.f @@ -0,0 +1,193 @@ + subroutine sva (a,mda,m,n,mdata,b,sing,names,iscale,d) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c singular value analysis printout +c +c iscale set by user to 1, 2, or 3 to select column scaling +c option. +c 1 subr will use identity scaling and ignore the d() +c array. +c 2 subr will scale nonzero cols to have unit euclide +c length and will store reciprocal lengths of +c original nonzero cols in d(). +c 3 user supplies col scale factors in d(). subr +c will mult col j by d(j) and remove the scaling +c from the soln at the end. +c + dimension a(mda,n), b(m), sing(01),d(n) +c sing(3*n) + dimension names(n) + logical test + double precision sb, dzero + dzero=0.d0 + one=1. + zero=0. + if (m.le.0 .or. n.le.0) return + np1=n+1 + write (6,270) + write (6,260) m,n,mdata + go to (60,10,10), iscale +c +c apply column scaling to a +c + 10 do 50 j=1,n + a1=d(j) + go to (20,20,40), iscale + 20 sb=dzero + do 30 i=1,m + 30 sb=sb+dble(a(i,j))**2 + a1=dsqrt(sb) + if (a1.eq.zero) a1=one + a1=one/a1 + d(j)=a1 + 40 do 50 i=1,m + 50 a(i,j)=a(i,j)*a1 + write (6,280) iscale,(d(j),j=1,n) + go to 70 + 60 continue + write (6,290) + 70 continue +c +c obtain sing. value decomp. of scaled matrix. +c +c********************************************************** + call svdrs (a,mda,m,n,b,1,1,sing) +c********************************************************** +c +c print the v matrix. +c + call mfeout (a,mda,n,n,names,1) + if (iscale.eq.1) go to 90 +c +c replace v by d*v in the array a() +c + do 80 i=1,n + do 80 j=1,n + 80 a(i,j)=d(i)*a(i,j) +c +c g now in b array. v now in a array. +c +c +c obtain summary output. +c + 90 continue + write (6,220) +c +c compute cumulative sums of squares of components of +c g and store them in sing(i), i=minmn+1,...,2*minmn+1 +c + sb=dzero + minmn=min0(m,n) + minmn1=minmn+1 + if (m.eq.minmn) go to 110 + do 100 i=minmn1,m + 100 sb=sb+dble(b(i))**2 + 110 sing(2*minmn+1)=sb + do 120 jj=1,minmn + j=minmn+1-jj + sb=sb+dble(b(j))**2 + js=minmn+j + 120 sing(js)=sb + a3=sing(minmn+1) + a4=sqrt(a3/float(max0(1,mdata))) + write (6,230) a3,a4 +c + nsol=0 +c +c +c + do 160 k=1,minmn + if (sing(k).eq.zero) go to 130 + nsol=k + pi=b(k)/sing(k) + a1=one/sing(k) + a2=b(k)**2 + a3=sing(minmn1+k) + a4=sqrt(a3/float(max0(1,mdata-k))) + test=sing(k).ge.100..or.sing(k).lt..001 + if (test) write (6,240) k,sing(k),pi,a1,b(k),a2,a3,a4 + if (.not.test) write (6,250) k,sing(k),pi,a1,b(k),a2,a3,a4 + go to 140 + 130 write (6,240) k,sing(k) + pi=zero + 140 do 150 i=1,n + a(i,k)=a(i,k)*pi + 150 if (k.gt.1) a(i,k)=a(i,k)+a(i,k-1) + 160 continue +c +c compute and print values of ynorm and rnorm. +c + write (6,300) + j=0 + ysq=zero + go to 180 + 170 j=j+1 + ysq=ysq+(b(j)/sing(j))**2 + 180 ynorm=sqrt(ysq) + js=minmn1+j + rnorm=sqrt(sing(js)) + yl=-1000. + if (ynorm.gt.0.) yl=alog10(ynorm) + rl=-1000. + if (rnorm.gt.0.) rl=alog10(rnorm) + write (6,310) j,ynorm,rnorm,yl,rl + if (j.lt.nsol) go to 170 +c +c compute values of xnorm and rnorm for a sequence of values of +c the levenberg-marquardt parameter. +c + if (sing(1).eq.zero) go to 210 + el=alog10(sing(1))+one + el2=alog10(sing(nsol))-one + del=(el2-el)/20. + ten=10. + aln10=alog(ten) + write (6,320) + do 200 ie=1,21 +c compute alamb=10.**el + alamb=exp(aln10*el) + ys=0. + js=minmn1+nsol + rs=sing(js) + do 190 i=1,minmn + sl=sing(i)**2+alamb**2 + ys=ys+(b(i)*sing(i)/sl)**2 + rs=rs+(b(i)*(alamb**2)/sl)**2 + 190 continue + ynorm=sqrt(ys) + rnorm=sqrt(rs) + rl=-1000. + if (rnorm.gt.zero) rl=alog10(rnorm) + yl=-1000. + if (ynorm.gt.zero) yl=alog10(ynorm) + write (6,330) alamb,ynorm,rnorm,el,yl,rl + el=el+del + 200 continue +c +c print candidate solutions. +c + 210 if (nsol.ge.1) call mfeout (a,mda,n,nsol,names,2) + return + 220 format (42h0 index sing. value p coef ,48hrecip. s. + 1v. g coef g**2 ,39h c.s.s. + 2 n.s.r.c.s.s.) + 230 format (1h ,5x,1h0,88x,1pe15.4,1pe17.4) + 240 format (1h ,i6,e12.4,1p(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4, + 12x,e15.4)) + 250 format (1h ,i6,f12.4,1p(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4, + 12x,e15.4)) + 260 format (5h0m = ,i6,8h, n = ,i4,12h, mdata = ,i8) + 270 format (45h0singular value analysis of the least squares,42h probl + 1em, a*x=b, scaled as (a*d)*y=b .) + 280 format (19h0scaling option no.,i2,18h. d is a diagonal,46h matrix + 1 with the following diagonal elements../(5x,10e12.4)) + 290 format (50h0scaling option no. 1. d is the identity matrix./1x) + 300 format (6h0index,13x,28h ynorm rnorm,14x,28h log1 + 10(ynorm) log10(rnorm)/1x) + 310 format (1h ,i4,14x,2e14.5,14x,2f14.5) + 320 format (54h0norms of solution and residual vectors for a range of, + 144h values of the levenberg-marquardt parameter,9h, lambda./1h0,4x + 2,42h lambda ynorm rnorm,42h log10(lambda) + 3log10(ynorm) log10(rnorm)) + 330 format (5x,3e14.5,3f14.5) + end diff --git a/math/llsq/original_f/svdrs.f b/math/llsq/original_f/svdrs.f new file mode 100644 index 00000000..66e488dc --- /dev/null +++ b/math/llsq/original_f/svdrs.f @@ -0,0 +1,205 @@ +c subroutine svdrs (a,mda,mm,nn,b,mdb,nb,s) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1974 mar 1 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c singular value decomposition also treating right side vector. +c +c the array s occupies 3*n cells. +c a occupies m*n cells +c b occupies m*nb cells. +c +c special singular value decomposition subroutine. +c we have the m x n matrix a and the system a*x=b to solve. +c either m .ge. n or m .lt. n is permitted. +c the singular value decomposition +c a = u*s*v**(t) is made in such a way that one gets +c (1) the matrix v in the first n rows and columns of a. +c (2) the diagonal matrix of ordered singular values in +c the first n cells of the array s(ip), ip .ge. 3*n. +c (3) the matrix product u**(t)*b=g gets placed back in b. +c (4) the user must complete the solution and do his own +c singular value analysis. +c ******* +c give special +c treatment to rows and columns which are entirely zero. this +c causes certain zero sing. vals. to appear as exact zeros rather +c than as about eta times the largest sing. val. it similarly +c cleans up the associated columns of u and v. +c method.. +c 1. exchange cols of a to pack nonzero cols to the left. +c set n = no. of nonzero cols. +c use locations a(1,nn),a(1,nn-1),...,a(1,n+1) to record the +c col permutations. +c 2. exchange rows of a to pack nonzero rows to the top. +c quit packing if find n nonzero rows. make same row exchanges +c in b. set m so that all nonzero rows of the permuted a +c are in first m rows. if m .le. n then all m rows are +c nonzero. if m .gt. n then the first n rows are known +c to be nonzero,and rows n+1 thru m may be zero or nonzero. +c 3. apply original algorithm to the m by n problem. +c 4. move permutation record from a(,) to s(i),i=n+1,...,nn. +c 5. build v up from n by n to nn by nn by placing ones on +c the diagonal and zeros elsewhere. this is only partly done +c explicitly. it is completed during step 6. +c 6. exchange rows of v to compensate for col exchanges of step 2. +c 7. place zeros in s(i),i=n+1,nn to represent zero sing vals. +c + subroutine svdrs (a,mda,mm,nn,b,mdb,nb,s) + dimension a(mda,nn),b(mdb,nb),s(nn,3) + zero=0. + one=1. +c +c begin.. special for zero rows and cols. +c +c pack the nonzero cols to the left +c + n=nn + if (n.le.0.or.mm.le.0) return + j=n + 10 continue + do 20 i=1,mm + if (a(i,j)) 50,20,50 + 20 continue +c +c col j is zero. exchange it with col n. +c + if (j.eq.n) go to 40 + do 30 i=1,mm + 30 a(i,j)=a(i,n) + 40 continue + a(1,n)=j + n=n-1 + 50 continue + j=j-1 + if (j.ge.1) go to 10 +c if n=0 then a is entirely zero and svd +c computation can be skipped + ns=0 + if (n.eq.0) go to 240 +c pack nonzero rows to the top +c quit packing if find n nonzero rows + i=1 + m=mm + 60 if (i.gt.n.or.i.ge.m) go to 150 + if (a(i,i)) 90,70,90 + 70 do 80 j=1,n + if (a(i,j)) 90,80,90 + 80 continue + go to 100 + 90 i=i+1 + go to 60 +c row i is zero +c exchange rows i and m + 100 if(nb.le.0) go to 115 + do 110 j=1,nb + t=b(i,j) + b(i,j)=b(m,j) + 110 b(m,j)=t + 115 do 120 j=1,n + 120 a(i,j)=a(m,j) + if (m.gt.n) go to 140 + do 130 j=1,n + 130 a(m,j)=zero + 140 continue +c exchange is finished + m=m-1 + go to 60 +c + 150 continue +c end.. special for zero rows and columns +c begin.. svd algorithm +c method.. +c (1) reduce the matrix to upper bidiagonal form with +c householder transformations. +c h(n)...h(1)aq(1)...q(n-2) = (d**t,0)**t +c where d is upper bidiagonal. +c +c (2) apply h(n)...h(1) to b. here h(n)...h(1)*b replaces b +c in storage. +c +c (3) the matrix product w= q(1)...q(n-2) overwrites the first +c n rows of a in storage. +c +c (4) an svd for d is computed. here k rotations ri and pi are +c computed so that +c rk...r1*d*p1**(t)...pk**(t) = diag(s1,...,sm) +c to working accuracy. the si are nonnegative and nonincreasing. +c here rk...r1*b overwrites b in storage while +c a*p1**(t)...pk**(t) overwrites a in storage. +c +c (5) it follows that,with the proper definitions, +c u**(t)*b overwrites b, while v overwrites the first n row and +c columns of a. +c + l=min0(m,n) +c the following loop reduces a to upper bidiagonal and +c also applies the premultiplying transformations to b. +c + do 170 j=1,l + if (j.ge.m) go to 160 + call h12 (1,j,j+1,m,a(1,j),1,t,a(1,j+1),1,mda,n-j) + call h12 (2,j,j+1,m,a(1,j),1,t,b,1,mdb,nb) + 160 if (j.ge.n-1) go to 170 + call h12 (1,j+1,j+2,n,a(j,1),mda,s(j,3),a(j+1,1),mda,1,m-j) + 170 continue +c +c copy the bidiagonal matrix into the array s() for qrbd. +c + if (n.eq.1) go to 190 + do 180 j=2,n + s(j,1)=a(j,j) + 180 s(j,2)=a(j-1,j) + 190 s(1,1)=a(1,1) +c + ns=n + if (m.ge.n) go to 200 + ns=m+1 + s(ns,1)=zero + s(ns,2)=a(m,m+1) + 200 continue +c +c construct the explicit n by n product matrix, w=q1*q2*...*ql*i +c in the array a(). +c + do 230 k=1,n + i=n+1-k + if(i.gt.min0(m,n-2)) go to 210 + call h12 (2,i+1,i+2,n,a(i,1),mda,s(i,3),a(1,i+1),1,mda,n-i) + 210 do 220 j=1,n + 220 a(i,j)=zero + 230 a(i,i)=one +c +c compute the svd of the bidiagonal matrix +c + call qrbd (ipass,s(1,1),s(1,2),ns,a,mda,n,b,mdb,nb) +c + go to (240,310), ipass + 240 continue + if (ns.ge.n) go to 260 + nsp1=ns+1 + do 250 j=nsp1,n + 250 s(j,1)=zero + 260 continue + if (n.eq.nn) return + np1=n+1 +c move record of permutations +c and store zeros + do 280 j=np1,nn + s(j,1)=a(1,j) + do 270 i=1,n + 270 a(i,j)=zero + 280 continue +c permute rows and set zero singular values. + do 300 k=np1,nn + i=s(k,1) + s(k,1)=zero + do 290 j=1,nn + a(k,j)=a(i,j) + 290 a(i,j)=zero + a(i,k)=one + 300 continue +c end.. special for zero rows and columns + return + 310 write (6,320) + stop + 320 format (49h convergence failure in qr bidiagonal svd routine) + end diff --git a/math/llsq/progs/README b/math/llsq/progs/README new file mode 100644 index 00000000..e0c5a142 --- /dev/null +++ b/math/llsq/progs/README @@ -0,0 +1,5 @@ + +This directory contains both Fortran and IRAF preprocessor programs +demonstrating the use of the Lawson-Hanson llsq procedures. The Fortran +programs have not been modified to reflect the removal of Fortran i/o +from the library procedures as installed in the IRAF llsq.a library. diff --git a/math/llsq/progs/band.x b/math/llsq/progs/band.x new file mode 100644 index 00000000..f65290ba --- /dev/null +++ b/math/llsq/progs/band.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +define MAXPTS 1024 + +task band + +# This procedure solves for the natural cubic spline which interpolates +# the curve y[i] = 100., for i = 1 to n. The matrix is of length n+2, +# and has a bandwidth of 3. Lawsons and Hansons routines BNDACC and +# BNDSOL (modified to return an error code IER) are used to solve the +# system. The computations are carried out in single precision. + + +procedure band() + +real g[MAXPTS,4], c[MAXPTS], rnorm +int ip, ir, i, n, ier, geti() +real marktime, cptime() + +begin + n = min (MAXPTS, geti ("npts")) + marktime = cptime() + + ip = 1 + ir = 1 + + g[ir,1] = 6. # first row + g[ir,2] = -12. + g[ir,3] = 6. + g[ir,4] = 0. + call bndacc (g, MAXPTS, 3, ip, ir, 1, 1) + + do i = 2, n-1 { # tridiagonal elements + g[ir,1] = 1. + g[ir,2] = 4. + g[ir,3] = 1. + g[ir,4] = 100. + call bndacc (g, MAXPTS, 3, ip, ir, 1, i-1) + } + + g[ir,1] = 6. # last row + g[ir,2] = -12. + g[ir,3] = 6. + g[ir,4] = 0. + call bndacc (g, MAXPTS, 3, ip, ir, 1, n-2) + + call printf ("matrix accumulation took %8.2f cpu seconds\n") + call pargr (cptime() - marktime) + marktime = cptime() + + # solve for the b-spline coeff C + call bndsol (1, g, MAXPTS, 3, ip, ir, c, n, rnorm, ier) + + call printf ("solution took %8.2f cpu seconds (rnorm=%g, ier=%d)\n") + call pargr (cptime() - marktime) + call pargr (rnorm) + call pargi (ier) + + call printf ("selected coefficients:\n") + for (i=1; i <= n;) { # print the first and last 4 coeff + call printf ("%8d%15.6f\n") + call pargi (i) + call pargr (c[i]) + if (i == 4) + i = max(i+1, n-3) + else + i = i + 1 + } +end diff --git a/math/llsq/progs/data4 b/math/llsq/progs/data4 new file mode 100644 index 00000000..33bf1b08 --- /dev/null +++ b/math/llsq/progs/data4 @@ -0,0 +1,15 @@ + -.13405547 -.20162827 -.16930778 -.18971990 -.17387234 -.4361 + -.10379475 -.15766336 -.13346256 -.14848550 -.13597690 -.3437 + -.08779597 -.12883867 -.10683007 -.12011796 -.10932972 -.2657 + .02058554 .00335331 -.01641270 .00078606 .00271659 -.0392 + -.03248093 -.01876799 .00410639 -.01405894 -.01384391 .0193 + .05967662 .06667714 .04352153 .05740438 .05024962 .0747 + .06712457 .07352437 .04489770 .06471862 .05876455 .0935 + .08687186 .09368296 .05672327 .08141043 .07302320 .1079 + .02149662 .06222662 .07213486 .06200069 .05570931 .1930 + .06687407 .10344506 .09153849 .09508223 .08393667 .2058 + .15879069 .18088339 .11540692 .16160727 .14796479 .2606 + .17642887 .20361830 .13057860 .18385729 .17005549 .3142 + .11414080 .17259611 .14816471 .16007466 .14374096 .3529 + .07846038 .14669563 .14365800 .14003842 .12571177 .3615 + .10803175 .16994623 .14971519 .15885312 .14301547 .3647 diff --git a/math/llsq/progs/lsq.x b/math/llsq/progs/lsq.x new file mode 100644 index 00000000..ae002a16 --- /dev/null +++ b/math/llsq/progs/lsq.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +define M 256 +define N 256 + +task lsq + +# This procedure fits a natural cubic spline to an array of n data points. +# The system being solved is a tridiagonal matrix of n+2 rows. The system +# is solved by Lawsons and Hansons routine HFTI, which solves a general +# m by n linear system of equations. This is enormous overkill for this +# problem (see "band.x"), but serves to give timing estimates for the code. + + +procedure lsq() + +real a[M,N], b[M], tau, rnorm, h[N], g[N] +int krank, ip[N] +int i, j, m, n, geti() +real marktime, cptime() + +begin + m = min (M, geti ("npts")) # size of matrix + n = min (N, m) + tau = 1e-6 + + do j = 1, n # set up b-spline matrix + do i = 1, m + a[i,j] = 0. + + a[1,1] = 6. # first row + a[1,2] = -12. + a[1,3] = 6. + + a[m,n] = 6. # last row + a[m,n-1] = -12. + a[m,n-2] = 6. + + do j = 2, m-1 { # tridiagonal elements + a[j,j-1] = 1. + a[j,j] = 4. + a[j,j+1] = 1. + } + + b[1] = 0. # natural spline bndry conditions + b[m] = 0. + + do i = 2, m-1 # set up data vector + b[i] = 100. + + marktime = cptime() + call hfti (a,M,m,n, b,1,1, tau, krank,rnorm, h,g,ip) + + call printf ("took %8.2f cpu seconds (krank=%d, rnorm=%g)\n") + call pargr (cptime() - marktime) + call pargi (krank) + call pargr (rnorm) + + call printf ("selected coefficients:\n") + for (i=1; i <= m;) { # print first, last 4 coeff + call printf ("%8d%15.5f\n") + call pargi (i) + call pargr (b[i]) + if (i == 4) + i = max(i+1, m-3) + else + i = i + 1 + } +end diff --git a/math/llsq/progs/prog1.f b/math/llsq/progs/prog1.f new file mode 100644 index 00000000..13f64929 --- /dev/null +++ b/math/llsq/progs/prog1.f @@ -0,0 +1,124 @@ +c prog1 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c demonstrate algorithms hft and hs1 for solving least squares +c problems and algorithm cov for omputing the associated covariance +c matrices. +c + dimension a(8,8),h(8),b(8) + real gen,anoise + double precision sm + data mda/8/ +c + do 180 noise=1,2 + anoise=0. + if (noise.eq.2) anoise=1.e-4 + write (6,230) + write (6,240) anoise +c initialize the data generation function +c .. + dummy=gen(-1.) + do 180 mn1=1,6,5 + mn2=mn1+2 + do 180 m=mn1,mn2 + do 180 n=mn1,mn2 + np1=n+1 + write (6,250) m,n +c generate data +c .. + do 10 i=1,m + do 10 j=1,n + 10 a(i,j)=gen(anoise) + do 20 i=1,m + 20 b(i)=gen(anoise) + if(m .lt. n) go to 180 +c +c ****** begin algorithm hft ****** +c .. + do 30 j=1,n + 30 call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j) +c .. +c the algorithm 'hft' is completed. +c +c ****** begin algorithm hs1 ****** +c apply the transformations q(n)...q(1)=q to b +c replacing the previous contents of the array, b . +c .. + do 40 j=1,n + 40 call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,1,1) +c solve the triangular system for the solution x. +c store x in the array, b . +c .. + do 80 k=1,n + i=np1-k + sm=0.d0 + if (i.eq.n) go to 60 + ip1=i+1 + do 50 j=ip1,n + 50 sm=sm+a(i,j)*dble(b(j)) + 60 if (a(i,i)) 80,70,80 + 70 write (6,260) + go to 180 + 80 b(i)=(b(i)-sm)/a(i,i) +c compute length of residual vector. +c .. + srsmsq=0. + if (n.eq.m) go to 100 + mmn=m-n + do 90 j=1,mmn + npj=n+j + 90 srsmsq=srsmsq+b(npj)**2 + srsmsq=sqrt(srsmsq) +c ****** begin algorithm cov ****** +c compute unscaled covariance matrix ((a**t)*a)**(-1) +c .. + 100 do 110 j=1,n + 110 a(j,j)=1./a(j,j) + if (n.eq.1) go to 140 + nm1=n-1 + do 130 i=1,nm1 + ip1=i+1 + do 130 j=ip1,n + jm1=j-1 + sm=0.d0 + do 120 l=i,jm1 + 120 sm=sm+a(i,l)*dble(a(l,j)) + 130 a(i,j)=-sm*a(j,j) +c .. +c the upper triangle of a has been inverted +c upon itself. + 140 do 160 i=1,n + do 160 j=i,n + sm=0.d0 + do 150 l=j,n + 150 sm=sm+a(i,l)*dble(a(j,l)) + 160 a(i,j)=sm +c .. +c the upper triangular part of the +c symmetric matrix (a**t*a)**(-1) has +c replaced the upper triangular part of +c the a array. + write (6,200) (i,b(i),i=1,n) + write (6,190) srsmsq + write (6,210) + do 170 i=1,n + 170 write (6,220) (i,j,a(i,j),j=i,n) + 180 continue + stop + 190 format (1h0,8x,17hresidual length =,e12.4) + 200 format (1h0,8x,34hestimated parameters, x=a**(+)*b,,22h computed + 1by 'hft,hs1'//(9x,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8)) + 210 format (1h0,8x,31hcovariance matrix (unscaled) of,22h estimated pa + 1rameters.,19h computed by 'cov'./1x) + 220 format (9x,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8) + 230 format (52h1 prog1. this program demonstrates the algorithms,19 + 1h hft, hs1, and cov.//40h caution.. 'prog1' does no checking for , + 252hnear rank deficient matrices. results in such cases,20h may be + 3 meaningless.,/34h such cases are handled by 'prog2',11h or 'pro + 4') + 240 format (1h0,54hthe relative noise level of the generated data will + 1 be,e16.4) + 250 format (1h0////9h0 m n/1x,2i4) + 260 format (1h0,8x,36h****** terminating this case due to,37h a divis + 1or being exactly zero. ******) + end diff --git a/math/llsq/progs/prog2.f b/math/llsq/progs/prog2.f new file mode 100644 index 00000000..5fb601cc --- /dev/null +++ b/math/llsq/progs/prog2.f @@ -0,0 +1,125 @@ +c prog2 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c demonstrate algorithm hfti for solving least squares problems +c and algorithm cov for computing the associated unscaled +c covariance matrix. +c + dimension a(8,8),h(8),b(8),g(8) + real gen,anoise + integer ip(8) + double precision sm + data mda /8/ +c + do 180 noise=1,2 + anorm=500. + anoise=0. + tau=.5 + if (noise.eq.1) go to 10 + anoise=1.e-4 + tau=anorm*anoise*10. + 10 continue +c initialize the data generation function +c .. + dummy=gen(-1.) + write (6,230) + write (6,240) anoise,anorm,tau +c + do 180 mn1=1,6,5 + mn2=mn1+2 + do 180 m=mn1,mn2 + do 180 n=mn1,mn2 + write (6,250) m,n +c generate data +c .. + do 20 i=1,m + do 20 j=1,n + 20 a(i,j)=gen(anoise) + do 30 i=1,m + 30 b(i)=gen(anoise) +c +c ****** call hfti ****** +c + call hfti(a,mda,m,n,b,1,1,tau,krank,srsmsq,h,g,ip) +c +c + write (6,260) krank + write (6,200) (i,b(i),i=1,n) + write (6,190) srsmsq + if (krank.lt.n) go to 180 +c ****** algorithm cov bigins here ****** +c .. + do 40 j=1,n + 40 a(j,j)=1./a(j,j) + if (n.eq.1) go to 70 + nm1=n-1 + do 60 i=1,nm1 + ip1=i+1 + do 60 j=ip1,n + jm1=j-1 + sm=0.d0 + do 50 l=i,jm1 + 50 sm=sm+a(i,l)*dble(a(l,j)) + 60 a(i,j)=-sm*a(j,j) +c .. +c the upper triangle of a has been inverted +c upon itself. + 70 do 90 i=1,n + do 90 j=i,n + sm=0.d0 + do 80 l=j,n + 80 sm=sm+a(i,l)*dble(a(j,l)) + 90 a(i,j)=sm + if (n.lt.2) go to 160 + do 150 ii=2,n + i=n+1-ii + if (ip(i).eq.i) go to 150 + k=ip(i) + tmp=a(i,i) + a(i,i)=a(k,k) + a(k,k)=tmp + if (i.eq.1) go to 110 + do 100 l=2,i + tmp=a(l-1,i) + a(l-1,i)=a(l-1,k) + 100 a(l-1,k)=tmp + 110 ip1=i+1 + km1=k-1 + if (ip1.gt.km1) go to 130 + do 120 l=ip1,km1 + tmp=a(i,l) + a(i,l)=a(l,k) + 120 a(l,k)=tmp + 130 if (k.eq.n) go to 150 + kp1=k+1 + do 140 l=kp1,n + tmp=a(i,l) + a(i,l)=a(k,l) + 140 a(k,l)=tmp + 150 continue + 160 continue +c .. +c covariance has been computed and repermuted. +c the upper triangular part of the +c symmetric matrix (a**t*a)**(-1) has +c replaced the upper triangular part of +c the a array. + write (6,210) + do 170 i=1,n + 170 write (6,220) (i,j,a(i,j),j=i,n) + 180 continue + stop + 190 format (1h0,8x,17hresidual length =,e12.4) + 200 format (1h0,8x,34hestimated parameters, x=a**(+)*b,,22h computed + 1by 'hfti' //(9x,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8)) + 210 format (1h0,8x,31hcovariance matrix (unscaled) of,22h estimated pa + 1rameters.,19h computed by 'cov'./1x) + 220 format (9x,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8) + 230 format (52h1 prog2. this program demonstates the algorithms,16 + 1h hfti and cov.) + 240 format (1h0,54hthe relative noise level of the generated data will + 1 be,e16.4/33h0the matrix norm is approximately,e12.4/43h0the absol + 2ute pseudorank tolerance, tau, is,e12.4) + 250 format (1h0////9h0 m n/1x,2i4) + 260 format (1h0,8x,12hpseudorank =,i4) + end diff --git a/math/llsq/progs/prog3.f b/math/llsq/progs/prog3.f new file mode 100644 index 00000000..290f8161 --- /dev/null +++ b/math/llsq/progs/prog3.f @@ -0,0 +1,138 @@ +c prog3 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c demonstrate the use of subroutine svdrs to compute the +c singular value decomposition of a matrix, a, and solve a least +c squares problem, a*x=b. +c +c the s.v.d. a= u*(s,0)**t*v**t is +c computed so that.. +c (1) u**t*b replaces the m+1 st. col. of b. +c +c (2) u**t replaces the m by m identity in +c the first m cols. of b. +c +c (3) v replaces the first n rows and cols. +c of a. +c +c (4) the diagonal entries of the s matrix +c replace the first n entries of the array s. +c +c the array s( ) must be dimensioned at least 3*n . +c + dimension a(8,8),b(8,9),s(24),x(8),aa(8,8) + real gen,anoise + double precision sm + data mda,mdb/8,8/ +c + do 150 noise=1,2 + anoise = 0. + rho = 1.e-3 + if(noise .eq. 1) go to 5 + anoise = 1.e-4 + rho = 10. * anoise + 5 continue + write(6,230) + write(6,240) anoise,rho +c initialize data generation function +c .. + dummy= gen(-1.) +c + do 150 mn1=1,6,5 + mn2=mn1+2 + do 150 m=mn1,mn2 + do 150 n=mn1,mn2 + write (6,160) m,n + do 20 i=1,m + do 10 j=1,m + 10 b(i,j)=0. + b(i,i)=1. + do 20 j=1,n + a(i,j)= gen(anoise) + 20 aa(i,j)=a(i,j) + do 30 i=1,m + 30 b(i,m+1)= gen(anoise) +c +c the arrays are now filled in.. +c compute the s.v.d. +c ****************************************************** + call svdrs (a,mda,m,n,b,mdb,m+1,s) +c ****************************************************** +c + write (6,170) + write (6,220) (i,s(i),i=1,n) + write (6,180) + write (6,220) (i,b(i,m+1),i=1,m) +c +c test for disparity of ratio of singular values. +c .. + krank=n + tau=rho*s(1) + do 40 i=1,n + if (s(i).le.tau) go to 50 + 40 continue + go to 55 + 50 krank=i-1 + 55 write(6,250) tau, krank +c compute solution vector assuming pseudorank is krank +c .. + 60 do 70 i=1,krank + 70 b(i,m+1)=b(i,m+1)/s(i) + do 90 i=1,n + sm=0.d0 + do 80 j=1,krank + 80 sm=sm+a(i,j)*dble(b(j,m+1)) + 90 x(i)=sm +c compute predicted norm of residual vector. +c .. + srsmsq=0. + if (krank.eq.m) go to 110 + kp1=krank+1 + do 100 i=kp1,m + 100 srsmsq=srsmsq+b(i,m+1)**2 + srsmsq=sqrt(srsmsq) +c + 110 continue + write (6,190) + write (6,220) (i,x(i),i=1,n) + write (6,200) srsmsq +c compute the frobenius norm of a**t- v*(s,0)*u**t. +c +c compute v*s first. +c + minmn=min0(m,n) + do 120 j=1,minmn + do 120 i=1,n + 120 a(i,j)=a(i,j)*s(j) + dn=0. + do 140 j=1,m + do 140 i=1,n + sm=0.d0 + do 130 l=1,minmn + 130 sm=sm+a(i,l)*dble(b(l,j)) +c computed difference of (i,j) th entry +c of a**t-v*(s,0)*u**t. +c .. + t=aa(j,i)-sm + 140 dn=dn+t**2 + dn=sqrt(dn)/(sqrt(float(n))*s(1)) + write (6,210) dn + 150 continue + stop + 160 format (1h0////9h0 m n/1x,2i4) + 170 format (1h0,8x,25hsingular values of matrix) + 180 format (1h0,8x,30htransformed right side, u**t*b) + 190 format (1h0,8x,33hestimated parameters, x=a**(+)*b,21h computed b + 1y 'svdrs' ) + 200 format (1h0,8x,24hresidual vector length =,e12.4) + 210 format (1h0,8x,43hfrobenius norm (a-u*(s,0)**t*v**t)/(sqrt(n), + *22h*spectral norm of a) =,e12.4) + 220 format (9x,i5,e16.8,i5,e16.8,i5,e16.8,i5,e16.8,i5,e16.8) + 230 format(51h1prog3. this program demonstrates the algorithm, + * 9h, svdrs. ) + 240 format(55h0the relative noise level of the generated data will be, + *e16.4/44h0the relative tolerance, rho, for pseudorank, + *17h determination is,e16.4) + 250 format(1h0,8x,36habsolute pseudorank tolerance, tau =, + *e12.4,10x,12hpseudorank =,i5) + end diff --git a/math/llsq/progs/prog4.f b/math/llsq/progs/prog4.f new file mode 100644 index 00000000..090b1865 --- /dev/null +++ b/math/llsq/progs/prog4.f @@ -0,0 +1,22 @@ +c prog4 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c demonstrate singular value analysis. +c + dimension a(15,5),b(15),sing(15) + data names/1h / +c + read (5,10) ((a(i,j),j=1,5),b(i),i=1,15) + write (6,20) + write (6,30) ((a(i,j),j=1,5),b(i),i=1,15) + write (6,40) +c + call sva (a,15,15,5,15,b,sing,names,1,d) +c + stop + 10 format (6f12.0) + 20 format (46h1prog4. demonstrate singular value analysis/53h list + 1ing of input matrix, a, and vector, b, follows..) + 30 format (1h /(5f12.8,f20.4)) + 40 format (1h1) + end diff --git a/math/llsq/progs/prog5.f b/math/llsq/progs/prog5.f new file mode 100644 index 00000000..5484b846 --- /dev/null +++ b/math/llsq/progs/prog5.f @@ -0,0 +1,146 @@ +c prog5 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c example of the use of subroutines bndacc and bndsol to solve +c sequentially the banded least squares problem which arises in +c spline curve fitting. +c + dimension x(12),y(12),b(10),g(12,5),c(12),q(4),cov(12) +c +c define functions p1 and p2 to be used in constructing +c cubic splines over uniformly spaced breakpoints. +c + p1(t)=.25*t**2*t + p2(t)=-(1.-t)**2*(1.+t)*.75+1. + zero=0. +c + write (6,230) + mdg=12 + nband=4 + m=12 +c set ordinates of data + y(1)=2.2 + y(2)=4.0 + y(3)=5.0 + y(4)=4.6 + y(5)=2.8 + y(6)=2.7 + y(7)=3.8 + y(8)=5.1 + y(9)=6.1 + y(10)=6.3 + y(11)=5.0 + y(12)=2.0 +c set abcissas of data + do 10 i=1,m + 10 x(i)=2*i +c +c begin loop thru cases using increasing nos of breakpoints. +c + do 150 nbp=5,10 + nc=nbp+2 +c set breakpoints + b(1)=x(1) + b(nbp)=x(m) + h=(b(nbp)-b(1))/float(nbp-1) + if (nbp.le.2) go to 30 + do 20 i=3,nbp + 20 b(i-1)=b(i-2)+h + 30 continue + write (6,240) nbp,(b(i),i=1,nbp) +c +c initialize ir and ip before first call to bndacc. +c + ir=1 + ip=1 + i=1 + jt=1 + 40 mt=0 + 50 continue + if (x(i).gt.b(jt+1)) go to 60 +c +c set row for ith data point +c + u=(x(i)-b(jt))/h + ig=ir+mt + g(ig,1)=p1(1.-u) + g(ig,2)=p2(1.-u) + g(ig,3)=p2(u) + g(ig,4)=p1(u) + g(ig,5)=y(i) + mt=mt+1 + if (i.eq.m) go to 60 + i=i+1 + go to 50 +c +c send block of data to processor +c + 60 continue + call bndacc (g,mdg,nband,ip,ir,mt,jt) + if (i.eq.m) go to 70 + jt=jt+1 + go to 40 +c compute solution c() + 70 continue + call bndsol (1,g,mdg,nband,ip,ir,c,nc,rnorm) +c write solution coefficients + write (6,180) (c(l),l=1,nc) + write (6,210) rnorm +c +c compute and print x,y,yfit,r=y-yfit +c + write (6,160) + jt=1 + do 110 i=1,m + 80 if (x(i).le.b(jt+1)) go to 90 + jt=jt+1 + go to 80 +c + 90 u=(x(i)-b(jt))/h + q(1)=p1(1.-u) + q(2)=p2(1.-u) + q(3)=p2(u) + q(4)=p1(u) + yfit=zero + do 100 l=1,4 + ic=jt-1+l + 100 yfit=yfit+c(ic)*q(l) + r=y(i)-yfit + write (6,170) i,x(i),y(i),yfit,r + 110 continue +c +c compute residual vector norm. +c + if (m.le.nc) go to 150 + sigsq=(rnorm**2)/float(m-nc) + sigfac=sqrt(sigsq) + write (6,220) sigfac + write (6,200) +c +c compute and print cols. of covariance. +c + do 140 j=1,nc + do 120 i=1,nc + 120 cov(i)=zero + cov(j)=1. + call bndsol (2,g,mdg,nband,ip,ir,cov,nc,rdummy) + call bndsol (3,g,mdg,nband,ip,ir,cov,nc,rdummy) +c +c compute the jth col. of the covariance matrix. + do 130 i=1,nc + 130 cov(i)=cov(i)*sigsq + 140 write (6,190) (l,j,cov(l),l=1,nc) + 150 continue + stop + 160 format (4h0 i,8x,1hx,10x,1hy,6x,4hyfit,4x,8hr=y-yfit/1x) + 170 format (1x,i3,4x,f6.0,4x,f6.2,4x,f6.2,4x,f8.4) + 180 format (4h0c =,10f10.5/(4x,10f10.5)) + 190 format (4(02x,2i5,e15.7)) + 200 format (46h0covariance matrix of the spline coefficients.) + 210 format (9h0rnorm =,e15.8) + 220 format (9h0sigfac =,e15.8) + 230 format (50h1prog5. execute a sequence of cubic spline fits,27h + 1to a discrete set of data.) + 240 format (1x////,11h0new case..,/47h0number of breakpoints, includin + 1g endpoints, is,i5/14h0breakpoints =,10f10.5,/(14x,10f10.5)) + end diff --git a/math/llsq/progs/prog6.f b/math/llsq/progs/prog6.f new file mode 100644 index 00000000..71364ec4 --- /dev/null +++ b/math/llsq/progs/prog6.f @@ -0,0 +1,116 @@ +c prog6 +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 15 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c demonstrate the use of the subroutine ldp for least +c distance programming by solving the constrained line data fitting +c problem of chapter 23. +c + dimension e(4,2), f(4), g(3,2), h(3), g2(3,2), h2(3), x(2), z(2), + 1w(4) + dimension wldp(21), s(6), t(4) + integer index(3) +c + write (6,110) + mde=4 + mdgh=3 +c + me=4 + mg=3 + n=2 +c define the least squares and constraint matrices. + t(1)=0.25 + t(2)=0.5 + t(3)=0.5 + t(4)=0.8 +c + w(1)=0.5 + w(2)=0.6 + w(3)=0.7 + w(4)=1.2 +c + do 10 i=1,me + e(i,1)=t(i) + e(i,2)=1. + 10 f(i)=w(i) +c + g(1,1)=1. + g(1,2)=0. + g(2,1)=0. + g(2,2)=1. + g(3,1)=-1. + g(3,2)=-1. +c + h(1)=0. + h(2)=0. + h(3)=-1. +c +c compute the singular value decomposition of the matrix, e. +c + call svdrs (e,mde,me,n,f,1,1,s) +c + write (6,120) ((e(i,j),j=1,n),i=1,n) + write (6,130) f,(s(j),j=1,n) +c +c generally rank determination and levenberg-marquardt +c stabilization could be inserted here. +c +c define the constraint matrix for the z coordinate system. + do 30 i=1,mg + do 30 j=1,n + sm=0. + do 20 l=1,n + 20 sm=sm+g(i,l)*e(l,j) + 30 g2(i,j)=sm/s(j) +c define constraint rt side for the z coordinate system. + do 50 i=1,mg + sm=0. + do 40 j=1,n + 40 sm=sm+g2(i,j)*f(j) + 50 h2(i)=h(i)-sm +c + write (6,140) ((g2(i,j),j=1,n),i=1,mg) + write (6,150) h2 +c +c solve the constrained problem in z-coordinates. +c + call ldp (g2,mdgh,mg,n,h2,z,znorm,wldp,index,mode) +c + write (6,200) mode,znorm + write (6,160) z +c +c transform back from z-coordinates to x-coordinates. + do 60 j=1,n + 60 z(j)=(z(j)+f(j))/s(j) + do 80 i=1,n + sm=0. + do 70 j=1,n + 70 sm=sm+e(i,j)*z(j) + 80 x(i)=sm + res=znorm**2 + np1=n+1 + do 90 i=np1,me + 90 res=res+f(i)**2 + res=sqrt(res) +c compute the residuals. + do 100 i=1,me + 100 f(i)=w(i)-x(1)*t(i)-x(2) + write (6,170) (x(j),j=1,n) + write (6,180) (i,f(i),i=1,me) + write (6,190) res + stop +c + 110 format (46h0prog6.. example of constrained curve fitting,26h usin + 1g the subroutine ldp.,/43h0related intermediate quantities are giv + 2en.) + 120 format (10h0v = ,2f10.5/(10x,2f10.5)) + 130 format (10h0f tilda =,4f10.5/10h0s = ,2f10.5) + 140 format (10h0g tilda =,2f10.5/(10x,2f10.5)) + 150 format (10h0h tilda =,3f10.5) + 160 format (10h0z = ,2f10.5) + 170 format (52h0the coeficients of the fitted line f(t)=x(1)*t+x(2),12 + 1h are x(1) = ,f10.5,14h and x(2) = ,f10.5) + 180 format (30h0the consecutive residuals are/1x,4(i10,f10.5)) + 190 format (23h0the residuals norm is ,f10.5) + 200 format (18h0mode (from ldp) =,i3,2x,7hznorm =,f10.5) +c + end diff --git a/math/llsq/qrbd.f b/math/llsq/qrbd.f new file mode 100644 index 00000000..d9a12a24 --- /dev/null +++ b/math/llsq/qrbd.f @@ -0,0 +1,208 @@ +c subroutine qrbd (ipass,q,e,nn,v,mdv,nrv,c,mdc,ncc) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c qr algorithm for singular values of a bidiagonal matrix. +c +c the bidiagonal matrix +c +c (q1,e2,0... ) +c ( q2,e3,0... ) +c d= ( . ) +c ( . 0) +c ( .en) +c ( 0,qn) +c +c is pre and post multiplied by +c elementary rotation matrices +c ri and pi so that +c +c rk...r1*d*p1**(t)...pk**(t) = diag(s1,...,sn) +c +c to within working accuracy. +c +c 1. ei and qi occupy e(i) and q(i) as input. +c +c 2. rm...r1*c replaces 'c' in storage as output. +c +c 3. v*p1**(t)...pm**(t) replaces 'v' in storage as output. +c +c 4. si occupies q(i) as output. +c +c 5. the si's are nonincreasing and nonnegative. +c +c this code is based on the paper and 'algol' code.. +c ref.. +c 1. reinsch,c.h. and golub,g.h. 'singular value decomposition +c and least squares solutions' (numer. math.), vol. 14,(1970). +c + subroutine qrbd (ipass,q,e,nn,v,mdv,nrv,c,mdc,ncc) + logical wntv ,havers,fail + dimension q(nn),e(nn),v(mdv,nn),c(mdc,ncc) + zero=0. + one=1. + two=2. +c + n=nn + ipass=1 + if (n.le.0) return + n10=10*n + wntv=nrv.gt.0 + havers=ncc.gt.0 + fail=.false. + nqrs=0 + e(1)=zero + dnorm=zero + do 10 j=1,n + 10 dnorm=amax1(abs(q(j))+abs(e(j)),dnorm) + do 200 kk=1,n + k=n+1-kk +c +c test for splitting or rank deficiencies.. +c first make test for last diagonal term, q(k), being small. + 20 if(k.eq.1) go to 50 + if(diff(dnorm+q(k),dnorm)) 50,25,50 +c +c since q(k) is small we will make a special pass to +c transform e(k) to zero. +c + 25 cs=zero + sn=-one + do 40 ii=2,k + i=k+1-ii + f=-sn*e(i+1) + e(i+1)=cs*e(i+1) + call g1 (q(i),f,cs,sn,q(i)) +c transformation constructed to zero position (i,k). +c + if (.not.wntv) go to 40 + do 30 j=1,nrv + 30 call g2 (cs,sn,v(j,i),v(j,k)) +c accumulate rt. transformations in v. +c + 40 continue +c +c the matrix is now bidiagonal, and of lower order +c since e(k) .eq. zero.. +c + 50 do 60 ll=1,k + l=k+1-ll + if(diff(dnorm+e(l),dnorm)) 55,100,55 + 55 if(diff(dnorm+q(l-1),dnorm)) 60,70,60 + 60 continue +c this loop can't complete since e(1) = zero. +c + go to 100 +c +c cancellation of e(l), l.gt.1. + 70 cs=zero + sn=-one + do 90 i=l,k + f=-sn*e(i) + e(i)=cs*e(i) + if(diff(dnorm+f,dnorm)) 75,100,75 + 75 call g1 (q(i),f,cs,sn,q(i)) + if (.not.havers) go to 90 + do 80 j=1,ncc + 80 call g2 (cs,sn,c(i,j),c(l-1,j)) + 90 continue +c +c test for convergence.. + 100 z=q(k) + if (l.eq.k) go to 170 +c +c shift from bottom 2 by 2 minor of b**(t)*b. + x=q(l) + y=q(k-1) + g=e(k-1) + h=e(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(two*h*y) + g=sqrt(one+f**2) + if (f.lt.zero) go to 110 + t=f+g + go to 120 + 110 t=f-g + 120 f=((x-z)*(x+z)+h*(y/t-h))/x +c +c next qr sweep.. + cs=one + sn=one + lp1=l+1 + do 160 i=lp1,k + g=e(i) + y=q(i) + h=sn*g + g=cs*g + call g1 (f,h,cs,sn,e(i-1)) + f=x*cs+g*sn + g=-x*sn+g*cs + h=y*sn + y=y*cs + if (.not.wntv) go to 140 +c +c accumulate rotations (from the right) in 'v' + do 130 j=1,nrv + 130 call g2 (cs,sn,v(j,i-1),v(j,i)) + 140 call g1 (f,h,cs,sn,q(i-1)) + f=cs*g+sn*y + x=-sn*g+cs*y + if (.not.havers) go to 160 + do 150 j=1,ncc + 150 call g2 (cs,sn,c(i-1,j),c(i,j)) +c apply rotations from the left to +c right hand sides in 'c'.. +c + 160 continue + e(l)=zero + e(k)=f + q(k)=x + nqrs=nqrs+1 + if (nqrs.le.n10) go to 20 +c return to 'test for splitting'. +c + fail=.true. +c .. +c cutoff for convergence failure. 'nqrs' will be 2*n usually. + 170 if (z.ge.zero) go to 190 + q(k)=-z + if (.not.wntv) go to 190 + do 180 j=1,nrv + 180 v(j,k)=-v(j,k) + 190 continue +c convergence. q(k) is made nonnegative.. +c + 200 continue + if (n.eq.1) return + do 210 i=2,n + if (q(i).gt.q(i-1)) go to 220 + 210 continue + if (fail) ipass=2 + return +c .. +c every singular value is in order.. + 220 do 270 i=2,n + t=q(i-1) + k=i-1 + do 230 j=i,n + if (t.ge.q(j)) go to 230 + t=q(j) + k=j + 230 continue + if (k.eq.i-1) go to 270 + q(k)=q(i-1) + q(i-1)=t + if (.not.havers) go to 250 + do 240 j=1,ncc + t=c(i-1,j) + c(i-1,j)=c(k,j) + 240 c(k,j)=t + 250 if (.not.wntv) go to 270 + do 260 j=1,nrv + t=v(j,i-1) + v(j,i-1)=v(j,k) + 260 v(j,k)=t + 270 continue +c end of ordering algorithm. +c + if (fail) ipass=2 + return + end diff --git a/math/llsq/sva.f b/math/llsq/sva.f new file mode 100644 index 00000000..ee7f893d --- /dev/null +++ b/math/llsq/sva.f @@ -0,0 +1,198 @@ + subroutine sva (a,mda,m,n,mdata,b,sing,names,iscale,d) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c singular value analysis printout +c +c iscale set by user to 1, 2, or 3 to select column scaling +c option. +c 1 subr will use identity scaling and ignore the d() +c array. +c 2 subr will scale nonzero cols to have unit euclide +c length and will store reciprocal lengths of +c original nonzero cols in d(). +c 3 user supplies col scale factors in d(). subr +c will mult col j by d(j) and remove the scaling +c from the soln at the end. +c + dimension a(mda,n), b(m), sing(01),d(n) +c sing(3*n) + dimension names(n) + logical test + double precision sb, dzero + dzero=0.d0 + one=1. + zero=0. + if (m.le.0 .or. n.le.0) return + np1=n+1 + write (6,270) + write (6,260) m,n,mdata + go to (60,10,10), iscale +c +c apply column scaling to a +c + 10 do 50 j=1,n + a1=d(j) + go to (20,20,40), iscale + 20 sb=dzero + do 30 i=1,m + 30 sb=sb+dble(a(i,j))**2 + a1=dsqrt(sb) + if (a1.eq.zero) a1=one + a1=one/a1 + d(j)=a1 + 40 do 50 i=1,m + 50 a(i,j)=a(i,j)*a1 + write (6,280) iscale,(d(j),j=1,n) + go to 70 + 60 continue + write (6,290) + 70 continue +c +c obtain sing. value decomp. of scaled matrix. +c +c********************************************************** + call svdrs (a,mda,m,n,b,1,1,sing,ier) + if (ier.eq.0) goto 75 + write (6,295) + return + 75 continue +c********************************************************** +c +c print the v matrix. +c + call mfeout (a,mda,n,n,names,1) + if (iscale.eq.1) go to 90 +c +c replace v by d*v in the array a() +c + do 80 i=1,n + do 80 j=1,n + 80 a(i,j)=d(i)*a(i,j) +c +c g now in b array. v now in a array. +c +c +c obtain summary output. +c + 90 continue + write (6,220) +c +c compute cumulative sums of squares of components of +c g and store them in sing(i), i=minmn+1,...,2*minmn+1 +c + sb=dzero + minmn=min0(m,n) + minmn1=minmn+1 + if (m.eq.minmn) go to 110 + do 100 i=minmn1,m + 100 sb=sb+dble(b(i))**2 + 110 sing(2*minmn+1)=sb + do 120 jj=1,minmn + j=minmn+1-jj + sb=sb+dble(b(j))**2 + js=minmn+j + 120 sing(js)=sb + a3=sing(minmn+1) + a4=sqrt(a3/float(max0(1,mdata))) + write (6,230) a3,a4 +c + nsol=0 +c +c +c + do 160 k=1,minmn + if (sing(k).eq.zero) go to 130 + nsol=k + pi=b(k)/sing(k) + a1=one/sing(k) + a2=b(k)**2 + a3=sing(minmn1+k) + a4=sqrt(a3/float(max0(1,mdata-k))) + test=sing(k).ge.100..or.sing(k).lt..001 + if (test) write (6,240) k,sing(k),pi,a1,b(k),a2,a3,a4 + if (.not.test) write (6,250) k,sing(k),pi,a1,b(k),a2,a3,a4 + go to 140 + 130 write (6,240) k,sing(k) + pi=zero + 140 do 150 i=1,n + a(i,k)=a(i,k)*pi + 150 if (k.gt.1) a(i,k)=a(i,k)+a(i,k-1) + 160 continue +c +c compute and print values of ynorm and rnorm. +c + write (6,300) + j=0 + ysq=zero + go to 180 + 170 j=j+1 + ysq=ysq+(b(j)/sing(j))**2 + 180 ynorm=sqrt(ysq) + js=minmn1+j + rnorm=sqrt(sing(js)) + yl=-1000. + if (ynorm.gt.0.) yl=alog10(ynorm) + rl=-1000. + if (rnorm.gt.0.) rl=alog10(rnorm) + write (6,310) j,ynorm,rnorm,yl,rl + if (j.lt.nsol) go to 170 +c +c compute values of xnorm and rnorm for a sequence of values of +c the levenberg-marquardt parameter. +c + if (sing(1).eq.zero) go to 210 + el=alog10(sing(1))+one + el2=alog10(sing(nsol))-one + del=(el2-el)/20. + ten=10. + aln10=alog(ten) + write (6,320) + do 200 ie=1,21 +c compute alamb=10.**el + alamb=exp(aln10*el) + ys=0. + js=minmn1+nsol + rs=sing(js) + do 190 i=1,minmn + sl=sing(i)**2+alamb**2 + ys=ys+(b(i)*sing(i)/sl)**2 + rs=rs+(b(i)*(alamb**2)/sl)**2 + 190 continue + ynorm=sqrt(ys) + rnorm=sqrt(rs) + rl=-1000. + if (rnorm.gt.zero) rl=alog10(rnorm) + yl=-1000. + if (ynorm.gt.zero) yl=alog10(ynorm) + write (6,330) alamb,ynorm,rnorm,el,yl,rl + el=el+del + 200 continue +c +c print candidate solutions. +c + 210 if (nsol.ge.1) call mfeout (a,mda,n,nsol,names,2) + return + 220 format (42h0 index sing. value p coef ,48hrecip. s. + 1v. g coef g**2 , + 234h c.s.s. n.s.r.c.s.s.) + 230 format (1h ,5x,1h0,88x,1pe15.4,1pe17.4) + 240 format (1h ,i6,e12.4,1p,(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4 + 1,2x,e15.4)) + 250 format (1h ,i6,f12.4,1p,(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4 + 1,2x,e15.4)) + 260 format (5h0m = ,i6,8h, n = ,i4,12h, mdata = ,i8) + 270 format (45h0singular value analysis of the least squares,42h probl + 1em, a*x=b, scaled as (a*d)*y=b .) + 280 format (19h0scaling option no.,i2,18h. d is a diagonal,46h matrix + 1 with the following diagonal elements../(5x,10e12.4)) + 290 format (50h0scaling option no. 1. d is the identity matrix./1x) + 295 format (49h convergence failure in qr bidiagonal svd routine) + 300 format (6h0index,13x,28h ynorm rnorm,14x,28h log1 + 10(ynorm) log10(rnorm)/1x) + 310 format (1h ,i4,14x,2e14.5,14x,2f14.5) + 320 format (54h0norms of solution and residual vectors for a range of, + 144h values of the levenberg-marquardt parameter,9h, lambda./1h0,4x + 2,42h lambda ynorm rnorm, + 345h log10(lambda) log10(ynorm) log10(rnorm)) + 330 format (5x,3e14.5,3f14.5) + end diff --git a/math/llsq/svdrs.f b/math/llsq/svdrs.f new file mode 100644 index 00000000..46dba02d --- /dev/null +++ b/math/llsq/svdrs.f @@ -0,0 +1,205 @@ +c subroutine svdrs (a,mda,mm,nn,b,mdb,nb,s,ier) +c c.l.lawson and r.j.hanson, jet propulsion laboratory, 1974 mar 1 +c to appear in 'solving least squares problems', prentice-hall, 1974 +c singular value decomposition also treating right side vector. +c +c the array s occupies 3*n cells. +c a occupies m*n cells +c b occupies m*nb cells. +c +c special singular value decomposition subroutine. +c we have the m x n matrix a and the system a*x=b to solve. +c either m .ge. n or m .lt. n is permitted. +c the singular value decomposition +c a = u*s*v**(t) is made in such a way that one gets +c (1) the matrix v in the first n rows and columns of a. +c (2) the diagonal matrix of ordered singular values in +c the first n cells of the array s(ip), ip .ge. 3*n. +c (3) the matrix product u**(t)*b=g gets placed back in b. +c (4) the user must complete the solution and do his own +c singular value analysis. +c ******* +c give special +c treatment to rows and columns which are entirely zero. this +c causes certain zero sing. vals. to appear as exact zeros rather +c than as about eta times the largest sing. val. it similarly +c cleans up the associated columns of u and v. +c method.. +c 1. exchange cols of a to pack nonzero cols to the left. +c set n = no. of nonzero cols. +c use locations a(1,nn),a(1,nn-1),...,a(1,n+1) to record the +c col permutations. +c 2. exchange rows of a to pack nonzero rows to the top. +c quit packing if find n nonzero rows. make same row exchanges +c in b. set m so that all nonzero rows of the permuted a +c are in first m rows. if m .le. n then all m rows are +c nonzero. if m .gt. n then the first n rows are known +c to be nonzero,and rows n+1 thru m may be zero or nonzero. +c 3. apply original algorithm to the m by n problem. +c 4. move permutation record from a(,) to s(i),i=n+1,...,nn. +c 5. build v up from n by n to nn by nn by placing ones on +c the diagonal and zeros elsewhere. this is only partly done +c explicitly. it is completed during step 6. +c 6. exchange rows of v to compensate for col exchanges of step 2. +c 7. place zeros in s(i),i=n+1,nn to represent zero sing vals. +c + subroutine svdrs (a,mda,mm,nn,b,mdb,nb,s,ier) + dimension a(mda,nn),b(mdb,nb),s(nn,3) + zero=0. + ier = 0 + one=1. +c +c begin.. special for zero rows and cols. +c +c pack the nonzero cols to the left +c + n=nn + if (n.le.0.or.mm.le.0) return + j=n + 10 continue + do 20 i=1,mm + if (a(i,j)) 50,20,50 + 20 continue +c +c col j is zero. exchange it with col n. +c + if (j.eq.n) go to 40 + do 30 i=1,mm + 30 a(i,j)=a(i,n) + 40 continue + a(1,n)=j + n=n-1 + 50 continue + j=j-1 + if (j.ge.1) go to 10 +c if n=0 then a is entirely zero and svd +c computation can be skipped + ns=0 + if (n.eq.0) go to 240 +c pack nonzero rows to the top +c quit packing if find n nonzero rows + i=1 + m=mm + 60 if (i.gt.n.or.i.ge.m) go to 150 + if (a(i,i)) 90,70,90 + 70 do 80 j=1,n + if (a(i,j)) 90,80,90 + 80 continue + go to 100 + 90 i=i+1 + go to 60 +c row i is zero +c exchange rows i and m + 100 if(nb.le.0) go to 115 + do 110 j=1,nb + t=b(i,j) + b(i,j)=b(m,j) + 110 b(m,j)=t + 115 do 120 j=1,n + 120 a(i,j)=a(m,j) + if (m.gt.n) go to 140 + do 130 j=1,n + 130 a(m,j)=zero + 140 continue +c exchange is finished + m=m-1 + go to 60 +c + 150 continue +c end.. special for zero rows and columns +c begin.. svd algorithm +c method.. +c (1) reduce the matrix to upper bidiagonal form with +c householder transformations. +c h(n)...h(1)aq(1)...q(n-2) = (d**t,0)**t +c where d is upper bidiagonal. +c +c (2) apply h(n)...h(1) to b. here h(n)...h(1)*b replaces b +c in storage. +c +c (3) the matrix product w= q(1)...q(n-2) overwrites the first +c n rows of a in storage. +c +c (4) an svd for d is computed. here k rotations ri and pi are +c computed so that +c rk...r1*d*p1**(t)...pk**(t) = diag(s1,...,sm) +c to working accuracy. the si are nonnegative and nonincreasing. +c here rk...r1*b overwrites b in storage while +c a*p1**(t)...pk**(t) overwrites a in storage. +c +c (5) it follows that,with the proper definitions, +c u**(t)*b overwrites b, while v overwrites the first n row and +c columns of a. +c + l=min0(m,n) +c the following loop reduces a to upper bidiagonal and +c also applies the premultiplying transformations to b. +c + do 170 j=1,l + if (j.ge.m) go to 160 + call h12 (1,j,j+1,m,a(1,j),1,t,a(1,j+1),1,mda,n-j) + call h12 (2,j,j+1,m,a(1,j),1,t,b,1,mdb,nb) + 160 if (j.ge.n-1) go to 170 + call h12 (1,j+1,j+2,n,a(j,1),mda,s(j,3),a(j+1,1),mda,1,m-j) + 170 continue +c +c copy the bidiagonal matrix into the array s() for qrbd. +c + if (n.eq.1) go to 190 + do 180 j=2,n + s(j,1)=a(j,j) + 180 s(j,2)=a(j-1,j) + 190 s(1,1)=a(1,1) +c + ns=n + if (m.ge.n) go to 200 + ns=m+1 + s(ns,1)=zero + s(ns,2)=a(m,m+1) + 200 continue +c +c construct the explicit n by n product matrix, w=q1*q2*...*ql*i +c in the array a(). +c + do 230 k=1,n + i=n+1-k + if(i.gt.min0(m,n-2)) go to 210 + call h12 (2,i+1,i+2,n,a(i,1),mda,s(i,3),a(1,i+1),1,mda,n-i) + 210 do 220 j=1,n + 220 a(i,j)=zero + 230 a(i,i)=one +c +c compute the svd of the bidiagonal matrix +c + call qrbd (ipass,s(1,1),s(1,2),ns,a,mda,n,b,mdb,nb) +c + go to (240,310), ipass + 240 continue + if (ns.ge.n) go to 260 + nsp1=ns+1 + do 250 j=nsp1,n + 250 s(j,1)=zero + 260 continue + if (n.eq.nn) return + np1=n+1 +c move record of permutations +c and store zeros + do 280 j=np1,nn + s(j,1)=a(1,j) + do 270 i=1,n + 270 a(i,j)=zero + 280 continue +c permute rows and set zero singular values. + do 300 k=np1,nn + i=s(k,1) + s(k,1)=zero + do 290 j=1,nn + a(k,j)=a(i,j) + 290 a(i,j)=zero + a(i,k)=one + 300 continue +c end.. special for zero rows and columns + return +c convergence failure in qr bidiagonal svd routine + 310 ier = 1 + end diff --git a/math/math.hd b/math/math.hd new file mode 100644 index 00000000..b5557997 --- /dev/null +++ b/math/math.hd @@ -0,0 +1,58 @@ +# Help directory file for the MATH package, a collection of mathematical +# (numerical) packages. + +$bev = "math$bevington/doc/" +$curfit = "math$curfit/doc/" +$deboor = "math$deboor/doc/" +$gsurfit = "math$gsurfit/doc/" +$ieee = "math$ieee/doc/" +$iminterp = "math$iminterp/doc/" +$interp = "math$interp/doc/" +$llsq = "math$llsq/doc/" +$nlfit = "math$nlfit/doc/" +$slalib = "math$slalib/doc/" +$surfit = "math$surfit/doc/" + +bevington hlp = bev$bev.men, + sys = bev$bev.hlp, + pkg = bev$bev.hd + +curfit hlp = curfit$curfit.men, + sys = curfit$curfit.hlp, + pkg = curfit$curfit.hd + +deboor hlp = deboor$deboor.men, + sys = deboor$deboor.hlp, + pkg = deboor$deboor.hd + +ieee hlp = ieee$ieee.men, + sys = ieee$ieee.hlp, + pkg = ieee$ieee.hd + +iminterp hlp = iminterp$iminterp.men, + sys = iminterp$iminterp.hlp, + pkg = iminterp$iminterp.hd + +interp hlp = interp$interp.men, + sys = interp$interp.hlp, + pkg = interp$interp.hd + +llsq hlp = llsq$llsq.men, + sys = llsq$llsq.hlp, + pkg = llsq$llsq.hd + +nlfit hlp = nlfit$nlfit.men, + sys = nlfit$nllmfit.hlp, + pkg = nlfit$nlfit.hd + +surfit hlp = surfit$surfit.men, + sys = surfit$surfit.hlp, + pkg = surfit$surfit.hd + +gsurfit hlp = gsurfit$gsurfit.men, + sys = gsurfit$gsurfit.hlp, + pkg = gsurfit$gsurfit.hd + +slalib hlp = slalib$slalib.men, + sys = slalib$slalib.hlp, + pkg = slalib$slalib.hd diff --git a/math/math.men b/math/math.men new file mode 100644 index 00000000..c1f3c57c --- /dev/null +++ b/math/math.men @@ -0,0 +1,11 @@ + bevington - P.R. Bevington's statistical analysis package + curfit - IRAF curve fitting package + deboor - C.DeBoor's spline package + gsurfit - IRAF general surface fitting package + ieee - IEEE signal processing routines + iminterp - IRAF image interpolation package + interp - Old 1D image interpolation routines + llsq - Lawson's & Hanson's linear least squares package + nlfit - IRAF Levenberg-Marquardt non-linear least squares package + slalib - Starlink positional astronomy library + surfit - IRAF image surface fitting package diff --git a/math/minpack/chkder.f b/math/minpack/chkder.f new file mode 100644 index 00000000..29578fc4 --- /dev/null +++ b/math/minpack/chkder.f @@ -0,0 +1,140 @@ + subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) + integer m,n,ldfjac,mode + double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m), + * err(m) +c ********** +c +c subroutine chkder +c +c this subroutine checks the gradients of m nonlinear functions +c in n variables, evaluated at a point x, for consistency with +c the functions themselves. the user must call chkder twice, +c first with mode = 1 and then with mode = 2. +c +c mode = 1. on input, x must contain the point of evaluation. +c on output, xp is set to a neighboring point. +c +c mode = 2. on input, fvec must contain the functions and the +c rows of fjac must contain the gradients +c of the respective functions each evaluated +c at x, and fvecp must contain the functions +c evaluated at xp. +c on output, err contains measures of correctness of +c the respective gradients. +c +c the subroutine does not perform reliably if cancellation or +c rounding errors cause a severe loss of significance in the +c evaluation of a function. therefore, none of the components +c of x should be unusually small (in particular, zero) or any +c other value which may cause loss of significance. +c +c the subroutine statement is +c +c subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) +c +c where +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. +c +c x is an input array of length n. +c +c fvec is an array of length m. on input when mode = 2, +c fvec must contain the functions evaluated at x. +c +c fjac is an m by n array. on input when mode = 2, +c the rows of fjac must contain the gradients of +c the respective functions evaluated at x. +c +c ldfjac is a positive integer input parameter not less than m +c which specifies the leading dimension of the array fjac. +c +c xp is an array of length n. on output when mode = 1, +c xp is set to a neighboring point of x. +c +c fvecp is an array of length m. on input when mode = 2, +c fvecp must contain the functions evaluated at xp. +c +c mode is an integer input variable set to 1 on the first call +c and 2 on the second. other values of mode are equivalent +c to mode = 1. +c +c err is an array of length m. on output when mode = 2, +c err contains measures of correctness of the respective +c gradients. if there is no severe loss of significance, +c then if err(i) is 1.0 the i-th gradient is correct, +c while if err(i) is 0.0 the i-th gradient is incorrect. +c for values of err between 0.0 and 1.0, the categorization +c is less certain. in general, a value of err(i) greater +c than 0.5 indicates that the i-th gradient is probably +c correct, while a value of err(i) less than 0.5 indicates +c that the i-th gradient is probably incorrect. +c +c subprograms called +c +c minpack supplied ... dpmpar +c +c fortran supplied ... dabs,dlog10,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j + double precision eps,epsf,epslog,epsmch,factor,one,temp,zero + double precision dpmpar + data factor,one,zero /1.0d2,1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(epsmch) +c + if (mode .eq. 2) go to 20 +c +c mode = 1. +c + do 10 j = 1, n + temp = eps*dabs(x(j)) + if (temp .eq. zero) temp = eps + xp(j) = x(j) + temp + 10 continue + go to 70 + 20 continue +c +c mode = 2. +c + epsf = factor*epsmch + epslog = dlog10(eps) + do 30 i = 1, m + err(i) = zero + 30 continue + do 50 j = 1, n + temp = dabs(x(j)) + if (temp .eq. zero) temp = one + do 40 i = 1, m + err(i) = err(i) + temp*fjac(i,j) + 40 continue + 50 continue + do 60 i = 1, m + temp = one + if (fvec(i) .ne. zero .and. fvecp(i) .ne. zero + * .and. dabs(fvecp(i)-fvec(i)) .ge. epsf*dabs(fvec(i))) + * temp = eps*dabs((fvecp(i)-fvec(i))/eps-err(i)) + * /(dabs(fvec(i)) + dabs(fvecp(i))) + err(i) = one + if (temp .gt. epsmch .and. temp .lt. eps) + * err(i) = (dlog10(temp) - epslog)/epslog + if (temp .ge. eps) err(i) = zero + 60 continue + 70 continue +c + return +c +c last card of subroutine chkder. +c + end diff --git a/math/minpack/dogleg.f b/math/minpack/dogleg.f new file mode 100644 index 00000000..b812f196 --- /dev/null +++ b/math/minpack/dogleg.f @@ -0,0 +1,177 @@ + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + integer n,lr + double precision delta + double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) +c ********** +c +c subroutine dogleg +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, the +c problem is to determine the convex combination x of the +c gauss-newton and scaled gradient directions that minimizes +c (a*x - b) in the least squares sense, subject to the +c restriction that the euclidean norm of d*x be at most delta. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization of a. that is, if a = q*r, where q has +c orthogonal columns and r is an upper triangular matrix, +c then dogleg expects the full upper triangle of r and +c the first n components of (q transpose)*b. +c +c the subroutine statement is +c +c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an input array of length lr which must contain the upper +c triangular matrix r stored by rows. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c x is an output array of length n which contains the desired +c convex combination of the gauss-newton direction and the +c scaled gradient direction. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jj,jp1,k,l + double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, + * temp,zero + double precision dpmpar,enorm + data one,zero /1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c first, calculate the gauss-newton direction. +c + jj = (n*(n + 1))/2 + 1 + do 50 k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + sum = zero + if (n .lt. jp1) go to 20 + do 10 i = jp1, n + sum = sum + r(l)*x(i) + l = l + 1 + 10 continue + 20 continue + temp = r(jj) + if (temp .ne. zero) go to 40 + l = j + do 30 i = 1, j + temp = dmax1(temp,dabs(r(l))) + l = l + n - i + 30 continue + temp = epsmch*temp + if (temp .eq. zero) temp = epsmch + 40 continue + x(j) = (qtb(j) - sum)/temp + 50 continue +c +c test whether the gauss-newton direction is acceptable. +c + do 60 j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + 60 continue + qnorm = enorm(n,wa2) + if (qnorm .le. delta) go to 140 +c +c the gauss-newton direction is not acceptable. +c next, calculate the scaled gradient direction. +c + l = 1 + do 80 j = 1, n + temp = qtb(j) + do 70 i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + 70 continue + wa1(j) = wa1(j)/diag(j) + 80 continue +c +c calculate the norm of the scaled gradient and test for +c the special case in which the scaled gradient is zero. +c + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm .eq. zero) go to 120 +c +c calculate the point along the scaled gradient +c at which the quadratic is minimized. +c + do 90 j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + 90 continue + l = 1 + do 110 j = 1, n + sum = zero + do 100 i = j, n + sum = sum + r(l)*wa1(i) + l = l + 1 + 100 continue + wa2(j) = sum + 110 continue + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +c +c test whether the scaled gradient direction is acceptable. +c + alpha = zero + if (sgnorm .ge. delta) go to 120 +c +c the scaled gradient direction is not acceptable. +c finally, calculate the point along the dogleg +c at which the quadratic is minimized. +c + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 + * + dsqrt((temp-(delta/qnorm))**2 + * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + 120 continue +c +c form appropriate convex combination of the gauss-newton +c direction and the scaled gradient direction. +c + temp = (one - alpha)*dmin1(sgnorm,delta) + do 130 j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + 130 continue + 140 continue + return +c +c last card of subroutine dogleg. +c + end diff --git a/math/minpack/dpmpar.f b/math/minpack/dpmpar.f new file mode 100644 index 00000000..776bf3d1 --- /dev/null +++ b/math/minpack/dpmpar.f @@ -0,0 +1,171 @@ + double precision function dpmpar(i) + integer i +c ********** +c +c function dpmpar +c +c This function provides double precision machine parameters +c when the appropriate set of data statements is activated (by +c removing the c from column 1) and all other data statements are +c rendered inactive. Most of the parameter values were obtained +c from the corresponding Bell Laboratories Port Library function. +c +c The function statement is +c +c double precision function dpmpar(i) +c +c where +c +c i is an integer input variable set to 1, 2, or 3 which +c selects the desired machine parameter. If the machine has +c t base b digits and its smallest and largest exponents are +c emin and emax, respectively, then these parameters are +c +c dpmpar(1) = b**(1 - t), the machine precision, +c +c dpmpar(2) = b**(emin - 1), the smallest magnitude, +c +c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c Argonne National Laboratory. MINPACK Project. June 1983. +c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +c +c ********** + integer mcheps(4) + integer minmag(4) + integer maxmag(4) + double precision dmach(3) + equivalence (dmach(1),mcheps(1)) + equivalence (dmach(2),minmag(1)) + equivalence (dmach(3),maxmag(1)) +c +c Machine constants for the IBM 360/370 series, +c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, +c the Xerox Sigma 5/7/9 and the Sel systems 85/86. +c +c data mcheps(1),mcheps(2) / z34100000, z00000000 / +c data minmag(1),minmag(2) / z00100000, z00000000 / +c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / +c +c Machine constants for the Honeywell 600/6000 series. +c +c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / +c data minmag(1),minmag(2) / o402400000000, o000000000000 / +c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / +c +c Machine constants for the CDC 6000/7000 series. +c +c data mcheps(1) / 15614000000000000000b / +c data mcheps(2) / 15010000000000000000b / +c +c data minmag(1) / 00604000000000000000b / +c data minmag(2) / 00000000000000000000b / +c +c data maxmag(1) / 37767777777777777777b / +c data maxmag(2) / 37167777777777777777b / +c +c Machine constants for the PDP-10 (KA processor). +c +c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / +c data minmag(1),minmag(2) / "033400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / +c +c Machine constants for the PDP-10 (KI processor). +c +c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / +c data minmag(1),minmag(2) / "000400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / +c +c Machine constants for the PDP-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data mcheps(3),mcheps(4) / 0, 0 / +c +c data minmag(1),minmag(2) / 128, 0 / +c data minmag(3),minmag(4) / 0, 0 / +c +c data maxmag(1),maxmag(2) / 32767, -1 / +c data maxmag(3),maxmag(4) / -1, -1 / +c +c Machine constants for the Burroughs 6700/7700 systems. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o7770000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o7777777777777777 / +c +c Machine constants for the Burroughs 5700 system. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o0000000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o0007777777777777 / +c +c Machine constants for the Burroughs 1700 system. +c +c data mcheps(1) / zcc6800000 / +c data mcheps(2) / z000000000 / +c +c data minmag(1) / zc00800000 / +c data minmag(2) / z000000000 / +c +c data maxmag(1) / zdffffffff / +c data maxmag(2) / zfffffffff / +c +c Machine constants for the Univac 1100 series. +c +c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / +c data minmag(1),minmag(2) / o000040000000, o000000000000 / +c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / +c +c Machine constants for the Data General Eclipse S/200. +c +c Note - it may be appropriate to include the following card - +c static dmach(3) +c +c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ +c data mcheps/32020k,3*0/ +c +c Machine constants for the Harris 220. +c +c data mcheps(1),mcheps(2) / '20000000, '00000334 / +c data minmag(1),minmag(2) / '20000000, '00000201 / +c data maxmag(1),maxmag(2) / '37777777, '37777577 / +c +c Machine constants for the Cray-1. +c +c data mcheps(1) / 0376424000000000000000b / +c data mcheps(2) / 0000000000000000000000b / +c +c data minmag(1) / 0200034000000000000000b / +c data minmag(2) / 0000000000000000000000b / +c +c data maxmag(1) / 0577777777777777777777b / +c data maxmag(2) / 0000007777777777777776b / +c +c Machine constants for the Prime 400. +c +c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / +c data minmag(1),minmag(2) / :10000000000, :00000100000 / +c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / +c +c Machine constants for the VAX-11. +c + data mcheps(1),mcheps(2) / 9472, 0 / + data minmag(1),minmag(2) / 128, 0 / + data maxmag(1),maxmag(2) / -32769, -1 / +c + dpmpar = dmach(i) + return +c +c Last card of function dpmpar. +c + end diff --git a/math/minpack/enorm.f b/math/minpack/enorm.f new file mode 100644 index 00000000..2cb5b607 --- /dev/null +++ b/math/minpack/enorm.f @@ -0,0 +1,108 @@ + double precision function enorm(n,x) + integer n + double precision x(n) +c ********** +c +c function enorm +c +c given an n-vector x, this function calculates the +c euclidean norm of x. +c +c the euclidean norm is computed by accumulating the sum of +c squares in three different sums. the sums of squares for the +c small and large components are scaled so that no overflows +c occur. non-destructive underflows are permitted. underflows +c and overflows do not occur in the computation of the unscaled +c sum of squares for the intermediate components. +c the definitions of small, intermediate and large components +c depend on two constants, rdwarf and rgiant. the main +c restrictions on these constants are that rdwarf**2 not +c underflow and rgiant**2 not overflow. the constants +c given here are suitable for every known computer. +c +c the function statement is +c +c double precision function enorm(n,x) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i + double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, + * x1max,x3max,zero + data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do 90 i = 1, n + xabs = dabs(x(i)) + if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 + if (xabs .le. rdwarf) go to 30 +c +c sum for large components. +c + if (xabs .le. x1max) go to 10 + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + go to 20 + 10 continue + s1 = s1 + (xabs/x1max)**2 + 20 continue + go to 60 + 30 continue +c +c sum for small components. +c + if (xabs .le. x3max) go to 40 + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + go to 50 + 40 continue + if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 + 50 continue + 60 continue + go to 80 + 70 continue +c +c sum for intermediate components. +c + s2 = s2 + xabs**2 + 80 continue + 90 continue +c +c calculation of norm. +c + if (s1 .eq. zero) go to 100 + enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) + go to 130 + 100 continue + if (s2 .eq. zero) go to 110 + if (s2 .ge. x3max) + * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 .lt. x3max) + * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) + go to 120 + 110 continue + enorm = x3max*dsqrt(s3) + 120 continue + 130 continue + return +c +c last card of function enorm. +c + end diff --git a/math/minpack/fdjac1.f b/math/minpack/fdjac1.f new file mode 100644 index 00000000..aa058010 --- /dev/null +++ b/math/minpack/fdjac1.f @@ -0,0 +1,150 @@ + subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, + * wa1,wa2) + integer n,ldfjac,iflag,ml,mu + double precision epsfcn + double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n) +c ********** +c +c subroutine fdjac1 +c +c this subroutine computes a forward-difference approximation +c to the n by n jacobian matrix associated with a specified +c problem of n functions in n variables. if the jacobian has +c a banded form, then function evaluations are saved by only +c approximating the nonzero terms. +c +c the subroutine statement is +c +c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, +c wa1,wa2) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an input array of length n. +c +c fvec is an input array of length n which must contain the +c functions evaluated at x. +c +c fjac is an output n by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac1. see description of fcn. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at +c least n, then the jacobian is considered dense, and wa2 is +c not referenced. +c +c subprograms called +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,k,msum + double precision eps,epsmch,h,temp,zero + double precision dpmpar + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + msum = ml + mu + 1 + if (msum .lt. n) go to 40 +c +c computation of dense approximate jacobian. +c + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, n + fjac(i,j) = (wa1(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + go to 110 + 40 continue +c +c computation of banded approximate jacobian. +c + do 90 k = 1, msum + do 60 j = k, n, msum + wa2(j) = x(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + x(j) = wa2(j) + h + 60 continue + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 100 + do 80 j = k, n, msum + x(j) = wa2(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + do 70 i = 1, n + fjac(i,j) = zero + if (i .ge. j - mu .and. i .le. j + ml) + * fjac(i,j) = (wa1(i) - fvec(i))/h + 70 continue + 80 continue + 90 continue + 100 continue + 110 continue + return +c +c last card of subroutine fdjac1. +c + end diff --git a/math/minpack/fdjac2.f b/math/minpack/fdjac2.f new file mode 100644 index 00000000..218ab94c --- /dev/null +++ b/math/minpack/fdjac2.f @@ -0,0 +1,107 @@ + subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) + integer m,n,ldfjac,iflag + double precision epsfcn + double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) +c ********** +c +c subroutine fdjac2 +c +c this subroutine computes a forward-difference approximation +c to the m by n jacobian matrix associated with a specified +c problem of m functions in n variables. +c +c the subroutine statement is +c +c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac2. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an input array of length n. +c +c fvec is an input array of length m which must contain the +c functions evaluated at x. +c +c fjac is an output m by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac2. see description of fcn. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c wa is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j + double precision eps,epsmch,h,temp,zero + double precision dpmpar + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(m,n,x,wa,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, m + fjac(i,j) = (wa(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + return +c +c last card of subroutine fdjac2. +c + end diff --git a/math/minpack/hybrd.f b/math/minpack/hybrd.f new file mode 100644 index 00000000..fc0b4c26 --- /dev/null +++ b/math/minpack/hybrd.f @@ -0,0 +1,459 @@ + subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, + * mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, + * qtf,wa1,wa2,wa3,wa4) + integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr + double precision xtol,epsfcn,factor + double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) + external fcn +c ********** +c +c subroutine hybrd +c +c the purpose of hybrd is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least maxfev +c by the end of an iteration. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn has reached or exceeded +c maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dpmpar,enorm,fdjac1, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,min0,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dpmpar,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 + * .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero + * .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c determine the number of calls to fcn needed to compute +c the jacobian matrix. +c + msum = min0(ml+mu+1,n) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, + * wa2) + nfev = nfev + msum + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian approximation +c by forward differences. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,iflag) + return +c +c last card of subroutine hybrd. +c + end diff --git a/math/minpack/hybrd1.f b/math/minpack/hybrd1.f new file mode 100644 index 00000000..c0a85927 --- /dev/null +++ b/math/minpack/hybrd1.f @@ -0,0 +1,123 @@ + subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) + integer n,info,lwa + double precision tol + double precision x(n),fvec(n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrd1 +c +c the purpose of hybrd1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrd. the user +c must provide a subroutine which calculates the functions. +c the jacobian is then calculated by a forward-difference +c approximation. +c +c the subroutine statement is +c +c subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn has reached or exceeded +c 200*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(3*n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrd +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint + double precision epsfcn,factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) + * go to 20 +c +c call hybrd. +c + maxfev = 200*(n + 1) + xtol = tol + ml = n - 1 + mu = n - 1 + epsfcn = zero + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + index = 6*n + lr + call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, + * factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, + * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrd1. +c + end diff --git a/math/minpack/hybrj.f b/math/minpack/hybrj.f new file mode 100644 index 00000000..3070dad3 --- /dev/null +++ b/math/minpack/hybrj.f @@ -0,0 +1,440 @@ + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, + * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, + * wa3,wa4) + integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr + double precision xtol,factor + double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) +c ********** +c +c subroutine hybrj +c +c the purpose of hybrj is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +c mode,factor,nprint,info,nfev,njev,r,lr,qtf, +c wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. fvec and fjac should not be altered. +c if nprint is not positive, no special calls of fcn +c with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dpmpar,enorm, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dpmpar,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero + * .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine hybrj. +c + end diff --git a/math/minpack/hybrj1.f b/math/minpack/hybrj1.f new file mode 100644 index 00000000..9f51c496 --- /dev/null +++ b/math/minpack/hybrj1.f @@ -0,0 +1,127 @@ + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + integer n,ldfjac,info,lwa + double precision tol + double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrj1 +c +c the purpose of hybrj1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrj. the user +c must provide a subroutine which calculates the functions +c and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrj +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer j,lr,maxfev,mode,nfev,njev,nprint + double precision factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. (n*(n + 13))/2) go to 20 +c +c call hybrj. +c + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, + * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrj1. +c + end diff --git a/math/minpack/lmder.f b/math/minpack/lmder.f new file mode 100644 index 00000000..8797d8be --- /dev/null +++ b/math/minpack/lmder.f @@ -0,0 +1,452 @@ + subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, + * maxfev,diag,mode,factor,nprint,info,nfev,njev, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev + integer ipvt(n) + double precision ftol,xtol,gtol,factor + double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) +c ********** +c +c subroutine lmder +c +c the purpose of lmder is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, +c maxfev,diag,mode,factor,nprint,info,nfev, +c njev,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) +c integer m,n,ldfjac,iflag +c double precision x(n),fvec(m),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmder. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.).100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x, fvec, and fjac +c available for printing. fvec and fjac should not be +c altered. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine lmder. +c + end diff --git a/math/minpack/lmder1.f b/math/minpack/lmder1.f new file mode 100644 index 00000000..d691940f --- /dev/null +++ b/math/minpack/lmder1.f @@ -0,0 +1,156 @@ + subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, + * lwa) + integer m,n,ldfjac,info,lwa + integer ipvt(n) + double precision tol + double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine lmder1 +c +c the purpose of lmder1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of the +c levenberg-marquardt algorithm. this is done by using the more +c general least-squares solver lmder. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, +c ipvt,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) +c integer m,n,ldfjac,iflag +c double precision x(n),fvec(m),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmder1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than 5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmder +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer maxfev,mode,nfev,njev,nprint + double precision factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero + * .or. lwa .lt. 5*n + m) go to 10 +c +c call lmder. +c + maxfev = 100*(n + 1) + ftol = tol + xtol = tol + gtol = zero + mode = 1 + nprint = 0 + call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, + * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmder1. +c + end diff --git a/math/minpack/lmdif.f b/math/minpack/lmdif.f new file mode 100644 index 00000000..dd3d4ee2 --- /dev/null +++ b/math/minpack/lmdif.f @@ -0,0 +1,454 @@ + subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, + * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,maxfev,mode,nprint,info,nfev,ldfjac + integer ipvt(n) + double precision ftol,xtol,gtol,epsfcn,factor + double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) + external fcn +c ********** +c +c subroutine lmdif +c +c the purpose of lmdif is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmdif. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least +c maxfev by the end of an iteration. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn has reached or +c exceeded maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) + nfev = nfev + n + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) + return +c +c last card of subroutine lmdif. +c + end diff --git a/math/minpack/lmdif1.f b/math/minpack/lmdif1.f new file mode 100644 index 00000000..70f8aae0 --- /dev/null +++ b/math/minpack/lmdif1.f @@ -0,0 +1,135 @@ + subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) + integer m,n,info,lwa + integer iwa(n) + double precision tol + double precision x(n),fvec(m),wa(lwa) + external fcn +c ********** +c +c subroutine lmdif1 +c +c the purpose of lmdif1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of the +c levenberg-marquardt algorithm. this is done by using the more +c general least-squares solver lmdif. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmdif1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn has reached or +c exceeded 200*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c iwa is an integer work array of length n. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c m*n+5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmdif +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer maxfev,mode,mp5n,nfev,nprint + double precision epsfcn,factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. tol .lt. zero + * .or. lwa .lt. m*n + 5*n + m) go to 10 +c +c call lmdif. +c + maxfev = 200*(n + 1) + ftol = tol + xtol = tol + gtol = zero + epsfcn = zero + mode = 1 + nprint = 0 + mp5n = m + 5*n + call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), + * mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, + * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmdif1. +c + end diff --git a/math/minpack/lmpar.f b/math/minpack/lmpar.f new file mode 100644 index 00000000..26c422a7 --- /dev/null +++ b/math/minpack/lmpar.f @@ -0,0 +1,264 @@ + subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, + * wa2) + integer n,ldr + integer ipvt(n) + double precision delta,par + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), + * wa2(n) +c ********** +c +c subroutine lmpar +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, +c the problem is to determine a value for the parameter +c par such that if x solves the system +c +c a*x = b , sqrt(par)*d*x = 0 , +c +c in the least squares sense, and dxnorm is the euclidean +c norm of d*x, then either par is zero and +c +c (dxnorm-delta) .le. 0.1*delta , +c +c or par is positive and +c +c abs(dxnorm-delta) .le. 0.1*delta . +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then lmpar expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. on output +c lmpar also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + par*d*d)*p = s *s . +c +c s is employed within lmpar and may be of separate interest. +c +c only a few iterations are generally needed for convergence +c of the algorithm. if, however, the limit of 10 iterations +c is reached, then the output par will contain the best +c value obtained so far. +c +c the subroutine statement is +c +c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, +c wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c par is a nonnegative variable. on input par contains an +c initial estimate of the levenberg-marquardt parameter. +c on output par contains the final estimate. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, sqrt(par)*d*x = 0, +c for the output par. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm,qrsolv +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iter,j,jm1,jp1,k,l,nsing + double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, + * sum,temp,zero + double precision dpmpar,enorm + data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ +c +c dwarf is the smallest positive magnitude. +c + dwarf = dpmpar(2) +c +c compute and store in x the gauss-newton direction. if the +c jacobian is rank-deficient, obtain a least squares solution. +c + nsing = n + do 10 j = 1, n + wa1(j) = qtb(j) + if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa1(j) = zero + 10 continue + if (nsing .lt. 1) go to 50 + do 40 k = 1, nsing + j = nsing - k + 1 + wa1(j) = wa1(j)/r(j,j) + temp = wa1(j) + jm1 = j - 1 + if (jm1 .lt. 1) go to 30 + do 20 i = 1, jm1 + wa1(i) = wa1(i) - r(i,j)*temp + 20 continue + 30 continue + 40 continue + 50 continue + do 60 j = 1, n + l = ipvt(j) + x(l) = wa1(j) + 60 continue +c +c initialize the iteration counter. +c evaluate the function at the origin, and test +c for acceptance of the gauss-newton direction. +c + iter = 0 + do 70 j = 1, n + wa2(j) = diag(j)*x(j) + 70 continue + dxnorm = enorm(n,wa2) + fp = dxnorm - delta + if (fp .le. p1*delta) go to 220 +c +c if the jacobian is not rank deficient, the newton +c step provides a lower bound, parl, for the zero of +c the function. otherwise set this bound to zero. +c + parl = zero + if (nsing .lt. n) go to 120 + do 80 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 80 continue + do 110 j = 1, n + sum = zero + jm1 = j - 1 + if (jm1 .lt. 1) go to 100 + do 90 i = 1, jm1 + sum = sum + r(i,j)*wa1(i) + 90 continue + 100 continue + wa1(j) = (wa1(j) - sum)/r(j,j) + 110 continue + temp = enorm(n,wa1) + parl = ((fp/delta)/temp)/temp + 120 continue +c +c calculate an upper bound, paru, for the zero of the function. +c + do 140 j = 1, n + sum = zero + do 130 i = 1, j + sum = sum + r(i,j)*qtb(i) + 130 continue + l = ipvt(j) + wa1(j) = sum/diag(l) + 140 continue + gnorm = enorm(n,wa1) + paru = gnorm/delta + if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) +c +c if the input par lies outside of the interval (parl,paru), +c set par to the closer endpoint. +c + par = dmax1(par,parl) + par = dmin1(par,paru) + if (par .eq. zero) par = gnorm/dxnorm +c +c beginning of an iteration. +c + 150 continue + iter = iter + 1 +c +c evaluate the function at the current value of par. +c + if (par .eq. zero) par = dmax1(dwarf,p001*paru) + temp = dsqrt(par) + do 160 j = 1, n + wa1(j) = temp*diag(j) + 160 continue + call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) + do 170 j = 1, n + wa2(j) = diag(j)*x(j) + 170 continue + dxnorm = enorm(n,wa2) + temp = fp + fp = dxnorm - delta +c +c if the function is small enough, accept the current value +c of par. also test for the exceptional cases where parl +c is zero or the number of iterations has reached 10. +c + if (dabs(fp) .le. p1*delta + * .or. parl .eq. zero .and. fp .le. temp + * .and. temp .lt. zero .or. iter .eq. 10) go to 220 +c +c compute the newton correction. +c + do 180 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 180 continue + do 210 j = 1, n + wa1(j) = wa1(j)/sdiag(j) + temp = wa1(j) + jp1 = j + 1 + if (n .lt. jp1) go to 200 + do 190 i = jp1, n + wa1(i) = wa1(i) - r(i,j)*temp + 190 continue + 200 continue + 210 continue + temp = enorm(n,wa1) + parc = ((fp/delta)/temp)/temp +c +c depending on the sign of the function, update parl or paru. +c + if (fp .gt. zero) parl = dmax1(parl,par) + if (fp .lt. zero) paru = dmin1(paru,par) +c +c compute an improved estimate for par. +c + par = dmax1(parl,par+parc) +c +c end of an iteration. +c + go to 150 + 220 continue +c +c termination. +c + if (iter .eq. 0) par = zero + return +c +c last card of subroutine lmpar. +c + end diff --git a/math/minpack/lmstr.f b/math/minpack/lmstr.f new file mode 100644 index 00000000..d9a7893f --- /dev/null +++ b/math/minpack/lmstr.f @@ -0,0 +1,466 @@ + subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, + * maxfev,diag,mode,factor,nprint,info,nfev,njev, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev + integer ipvt(n) + logical sing + double precision ftol,xtol,gtol,factor + double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) +c ********** +c +c subroutine lmstr +c +c the purpose of lmstr is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm which uses minimal storage. +c the user must provide a subroutine which calculates the +c functions and the rows of the jacobian. +c +c the subroutine statement is +c +c subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, +c maxfev,diag,mode,factor,nprint,info,nfev, +c njev,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the rows of the jacobian. +c fcn must be declared in an external statement in the +c user calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjrow,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m),fjrow(n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. +c if iflag = i calculate the (i-1)-st row of the +c jacobian at x and return this vector in fjrow. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmstr. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array. the upper triangle of fjac +c contains an upper triangular matrix r such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower triangular +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,lmpar,qrfac,rwupdt +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 340 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 340 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,wa3,iflag) + nfev = 1 + if (iflag .lt. 0) go to 340 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,wa3,iflag) + if (iflag .lt. 0) go to 340 + 40 continue +c +c compute the qr factorization of the jacobian matrix +c calculated one row at a time, while simultaneously +c forming (q transpose)*fvec and storing the first +c n components in qtf. +c + do 60 j = 1, n + qtf(j) = zero + do 50 i = 1, n + fjac(i,j) = zero + 50 continue + 60 continue + iflag = 2 + do 70 i = 1, m + call fcn(m,n,x,fvec,wa3,iflag) + if (iflag .lt. 0) go to 340 + temp = fvec(i) + call rwupdt(n,fjac,ldfjac,wa3,qtf,temp,wa1,wa2) + iflag = iflag + 1 + 70 continue + njev = njev + 1 +c +c if the jacobian is rank deficient, call qrfac to +c reorder its columns and update the components of qtf. +c + sing = .false. + do 80 j = 1, n + if (fjac(j,j) .eq. zero) sing = .true. + ipvt(j) = j + wa2(j) = enorm(j,fjac(1,j)) + 80 continue + if (.not.sing) go to 130 + call qrfac(n,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + fjac(j,j) = wa1(j) + 120 continue + 130 continue +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 170 + if (mode .eq. 2) go to 150 + do 140 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 140 continue + 150 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 160 j = 1, n + wa3(j) = diag(j)*x(j) + 160 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 170 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 210 + do 200 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 190 + sum = zero + do 180 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 180 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 190 continue + 200 continue + 210 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 340 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 230 + do 220 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 220 continue + 230 continue +c +c beginning of the inner loop. +c + 240 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 250 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 250 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,wa3,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 340 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 270 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 260 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 260 continue + 270 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 280 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 300 + 280 continue + if (par .ne. zero .and. ratio .lt. p75) go to 290 + delta = pnorm/p5 + par = p5*par + 290 continue + 300 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 330 +c +c successful iteration. update x, fvec, and their norms. +c + do 310 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 310 continue + do 320 i = 1, m + fvec(i) = wa4(i) + 320 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 330 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 340 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 340 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 240 +c +c end of the outer loop. +c + go to 30 + 340 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,wa3,iflag) + return +c +c last card of subroutine lmstr. +c + end diff --git a/math/minpack/lmstr1.f b/math/minpack/lmstr1.f new file mode 100644 index 00000000..2fa8ee1c --- /dev/null +++ b/math/minpack/lmstr1.f @@ -0,0 +1,156 @@ + subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, + * lwa) + integer m,n,ldfjac,info,lwa + integer ipvt(n) + double precision tol + double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine lmstr1 +c +c the purpose of lmstr1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm which uses minimal storage. +c this is done by using the more general least-squares solver +c lmstr. the user must provide a subroutine which calculates +c the functions and the rows of the jacobian. +c +c the subroutine statement is +c +c subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, +c ipvt,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the rows of the jacobian. +c fcn must be declared in an external statement in the +c user calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjrow,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m),fjrow(n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. +c if iflag = i calculate the (i-1)-st row of the +c jacobian at x and return this vector in fjrow. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmstr1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array. the upper triangle of fjac +c contains an upper triangular matrix r such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower triangular +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular. +c column j of p is column ipvt(j) of the identity matrix. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than 5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmstr +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer maxfev,mode,nfev,njev,nprint + double precision factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. 5*n + m) go to 10 +c +c call lmstr. +c + maxfev = 100*(n + 1) + ftol = tol + xtol = tol + gtol = zero + mode = 1 + nprint = 0 + call lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, + * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmstr1. +c + end diff --git a/math/minpack/qform.f b/math/minpack/qform.f new file mode 100644 index 00000000..087b2478 --- /dev/null +++ b/math/minpack/qform.f @@ -0,0 +1,95 @@ + subroutine qform(m,n,q,ldq,wa) + integer m,n,ldq + double precision q(ldq,m),wa(m) +c ********** +c +c subroutine qform +c +c this subroutine proceeds from the computed qr factorization of +c an m by n matrix a to accumulate the m by m orthogonal matrix +c q from its factored form. +c +c the subroutine statement is +c +c subroutine qform(m,n,q,ldq,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a and the order of q. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c q is an m by m array. on input the full lower trapezoid in +c the first min(m,n) columns of q contains the factored form. +c on output q has been accumulated into a square matrix. +c +c ldq is a positive integer input variable not less than m +c which specifies the leading dimension of the array q. +c +c wa is a work array of length m. +c +c subprograms called +c +c fortran-supplied ... min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jm1,k,l,minmn,np1 + double precision one,sum,temp,zero + data one,zero /1.0d0,0.0d0/ +c +c zero out upper triangle of q in the first min(m,n) columns. +c + minmn = min0(m,n) + if (minmn .lt. 2) go to 30 + do 20 j = 2, minmn + jm1 = j - 1 + do 10 i = 1, jm1 + q(i,j) = zero + 10 continue + 20 continue + 30 continue +c +c initialize remaining columns to those of the identity matrix. +c + np1 = n + 1 + if (m .lt. np1) go to 60 + do 50 j = np1, m + do 40 i = 1, m + q(i,j) = zero + 40 continue + q(j,j) = one + 50 continue + 60 continue +c +c accumulate q from its factored form. +c + do 120 l = 1, minmn + k = minmn - l + 1 + do 70 i = k, m + wa(i) = q(i,k) + q(i,k) = zero + 70 continue + q(k,k) = one + if (wa(k) .eq. zero) go to 110 + do 100 j = k, m + sum = zero + do 80 i = k, m + sum = sum + q(i,j)*wa(i) + 80 continue + temp = sum/wa(k) + do 90 i = k, m + q(i,j) = q(i,j) - temp*wa(i) + 90 continue + 100 continue + 110 continue + 120 continue + return +c +c last card of subroutine qform. +c + end diff --git a/math/minpack/qrfac.f b/math/minpack/qrfac.f new file mode 100644 index 00000000..cb686086 --- /dev/null +++ b/math/minpack/qrfac.f @@ -0,0 +1,164 @@ + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + integer m,n,lda,lipvt + integer ipvt(lipvt) + logical pivot + double precision a(lda,n),rdiag(n),acnorm(n),wa(n) +c ********** +c +c subroutine qrfac +c +c this subroutine uses householder transformations with column +c pivoting (optional) to compute a qr factorization of the +c m by n matrix a. that is, qrfac determines an orthogonal +c matrix q, a permutation matrix p, and an upper trapezoidal +c matrix r with diagonal elements of nonincreasing magnitude, +c such that a*p = q*r. the householder transformation for +c column k, k = 1,2,...,min(m,n), is of the form +c +c t +c i - (1/u(k))*u*u +c +c where u has zeros in the first k-1 positions. the form of +c this transformation and the method of pivoting first +c appeared in the corresponding linpack subroutine. +c +c the subroutine statement is +c +c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a contains the matrix for +c which the qr factorization is to be computed. on output +c the strict upper trapezoidal part of a contains the strict +c upper trapezoidal part of r, and the lower trapezoidal +c part of a contains a factored form of q (the non-trivial +c elements of the u vectors described above). +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c pivot is a logical input variable. if pivot is set true, +c then column pivoting is enforced. if pivot is set false, +c then no column pivoting is done. +c +c ipvt is an integer output array of length lipvt. ipvt +c defines the permutation matrix p such that a*p = q*r. +c column j of p is column ipvt(j) of the identity matrix. +c if pivot is false, ipvt is not referenced. +c +c lipvt is a positive integer input variable. if pivot is false, +c then lipvt may be as small as 1. if pivot is true, then +c lipvt must be at least n. +c +c rdiag is an output array of length n which contains the +c diagonal elements of r. +c +c acnorm is an output array of length n which contains the +c norms of the corresponding columns of the input matrix a. +c if this information is not needed, then acnorm can coincide +c with rdiag. +c +c wa is a work array of length n. if pivot is false, then wa +c can coincide with rdiag. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dmax1,dsqrt,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kmax,minmn + double precision ajnorm,epsmch,one,p05,sum,temp,zero + double precision dpmpar,enorm + data one,p05,zero /1.0d0,5.0d-2,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c compute the initial column norms and initialize several arrays. +c + do 10 j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + 10 continue +c +c reduce a to r with householder transformations. +c + minmn = min0(m,n) + do 110 j = 1, minmn + if (.not.pivot) go to 40 +c +c bring the column of largest norm into the pivot position. +c + kmax = j + do 20 k = j, n + if (rdiag(k) .gt. rdiag(kmax)) kmax = k + 20 continue + if (kmax .eq. j) go to 40 + do 30 i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + 30 continue + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + 40 continue +c +c compute the householder transformation to reduce the +c j-th column of a to a multiple of the j-th unit vector. +c + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm .eq. zero) go to 100 + if (a(j,j) .lt. zero) ajnorm = -ajnorm + do 50 i = j, m + a(i,j) = a(i,j)/ajnorm + 50 continue + a(j,j) = a(j,j) + one +c +c apply the transformation to the remaining columns +c and update the norms. +c + jp1 = j + 1 + if (n .lt. jp1) go to 100 + do 90 k = jp1, n + sum = zero + do 60 i = j, m + sum = sum + a(i,j)*a(i,k) + 60 continue + temp = sum/a(j,j) + do 70 i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + 70 continue + if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + 80 continue + 90 continue + 100 continue + rdiag(j) = -ajnorm + 110 continue + return +c +c last card of subroutine qrfac. +c + end diff --git a/math/minpack/qrsolv.f b/math/minpack/qrsolv.f new file mode 100644 index 00000000..f48954b3 --- /dev/null +++ b/math/minpack/qrsolv.f @@ -0,0 +1,193 @@ + subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) + integer n,ldr + integer ipvt(n) + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) +c ********** +c +c subroutine qrsolv +c +c given an m by n matrix a, an n by n diagonal matrix d, +c and an m-vector b, the problem is to determine an x which +c solves the system +c +c a*x = b , d*x = 0 , +c +c in the least squares sense. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then qrsolv expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. the system +c a*x = b, d*x = 0, is then equivalent to +c +c t t +c r*z = q *b , p *d*p*z = 0 , +c +c where x = p*z. if this system does not have full rank, +c then a least squares solution is obtained. on output qrsolv +c also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + d*d)*p = s *s . +c +c s is computed within qrsolv and may be of separate interest. +c +c the subroutine statement is +c +c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, d*x = 0. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa is a work array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kp1,l,nsing + double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero + data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ +c +c copy r and (q transpose)*b to preserve input and initialize s. +c in particular, save the diagonal elements of r in x. +c + do 20 j = 1, n + do 10 i = j, n + r(i,j) = r(j,i) + 10 continue + x(j) = r(j,j) + wa(j) = qtb(j) + 20 continue +c +c eliminate the diagonal matrix d using a givens rotation. +c + do 100 j = 1, n +c +c prepare the row of d to be eliminated, locating the +c diagonal element using p from the qr factorization. +c + l = ipvt(j) + if (diag(l) .eq. zero) go to 90 + do 30 k = j, n + sdiag(k) = zero + 30 continue + sdiag(j) = diag(l) +c +c the transformations to eliminate the row of d +c modify only a single element of (q transpose)*b +c beyond the first n, which is initially zero. +c + qtbpj = zero + do 80 k = j, n +c +c determine a givens rotation which eliminates the +c appropriate element in the current row of d. +c + if (sdiag(k) .eq. zero) go to 70 + if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 + cotan = r(k,k)/sdiag(k) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + go to 50 + 40 continue + tan = sdiag(k)/r(k,k) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + 50 continue +c +c compute the modified diagonal element of r and +c the modified element of ((q transpose)*b,0). +c + r(k,k) = cos*r(k,k) + sin*sdiag(k) + temp = cos*wa(k) + sin*qtbpj + qtbpj = -sin*wa(k) + cos*qtbpj + wa(k) = temp +c +c accumulate the tranformation in the row of s. +c + kp1 = k + 1 + if (n .lt. kp1) go to 70 + do 60 i = kp1, n + temp = cos*r(i,k) + sin*sdiag(i) + sdiag(i) = -sin*r(i,k) + cos*sdiag(i) + r(i,k) = temp + 60 continue + 70 continue + 80 continue + 90 continue +c +c store the diagonal element of s and restore +c the corresponding diagonal element of r. +c + sdiag(j) = r(j,j) + r(j,j) = x(j) + 100 continue +c +c solve the triangular system for z. if the system is +c singular, then obtain a least squares solution. +c + nsing = n + do 110 j = 1, n + if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa(j) = zero + 110 continue + if (nsing .lt. 1) go to 150 + do 140 k = 1, nsing + j = nsing - k + 1 + sum = zero + jp1 = j + 1 + if (nsing .lt. jp1) go to 130 + do 120 i = jp1, nsing + sum = sum + r(i,j)*wa(i) + 120 continue + 130 continue + wa(j) = (wa(j) - sum)/sdiag(j) + 140 continue + 150 continue +c +c permute the components of z back to components of x. +c + do 160 j = 1, n + l = ipvt(j) + x(l) = wa(j) + 160 continue + return +c +c last card of subroutine qrsolv. +c + end diff --git a/math/minpack/r1mpyq.f b/math/minpack/r1mpyq.f new file mode 100644 index 00000000..ec99b96c --- /dev/null +++ b/math/minpack/r1mpyq.f @@ -0,0 +1,92 @@ + subroutine r1mpyq(m,n,a,lda,v,w) + integer m,n,lda + double precision a(lda,n),v(n),w(n) +c ********** +c +c subroutine r1mpyq +c +c given an m by n matrix a, this subroutine computes a*q where +c q is the product of 2*(n - 1) transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c and gv(i), gw(i) are givens rotations in the (i,n) plane which +c eliminate elements in the i-th and n-th planes, respectively. +c q itself is not given, rather the information to recover the +c gv, gw rotations is supplied. +c +c the subroutine statement is +c +c subroutine r1mpyq(m,n,a,lda,v,w) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a must contain the matrix +c to be postmultiplied by the orthogonal matrix q +c described above. on output a*q has replaced a. +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c v is an input array of length n. v(i) must contain the +c information necessary to recover the givens rotation gv(i) +c described above. +c +c w is an input array of length n. w(i) must contain the +c information necessary to recover the givens rotation gw(i) +c described above. +c +c subroutines called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,nmj,nm1 + double precision cos,one,sin,temp + data one /1.0d0/ +c +c apply the first set of givens rotations to a. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 50 + do 20 nmj = 1, nm1 + j = n - nmj + if (dabs(v(j)) .gt. one) cos = one/v(j) + if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(v(j)) .le. one) sin = v(j) + if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) + do 10 i = 1, m + temp = cos*a(i,j) - sin*a(i,n) + a(i,n) = sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 10 continue + 20 continue +c +c apply the second set of givens rotations to a. +c + do 40 j = 1, nm1 + if (dabs(w(j)) .gt. one) cos = one/w(j) + if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(w(j)) .le. one) sin = w(j) + if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) + do 30 i = 1, m + temp = cos*a(i,j) + sin*a(i,n) + a(i,n) = -sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 30 continue + 40 continue + 50 continue + return +c +c last card of subroutine r1mpyq. +c + end diff --git a/math/minpack/r1updt.f b/math/minpack/r1updt.f new file mode 100644 index 00000000..e034973d --- /dev/null +++ b/math/minpack/r1updt.f @@ -0,0 +1,207 @@ + subroutine r1updt(m,n,s,ls,u,v,w,sing) + integer m,n,ls + logical sing + double precision s(ls),u(m),v(n),w(m) +c ********** +c +c subroutine r1updt +c +c given an m by n lower trapezoidal matrix s, an m-vector u, +c and an n-vector v, the problem is to determine an +c orthogonal matrix q such that +c +c t +c (s + u*v )*q +c +c is again lower trapezoidal. +c +c this subroutine determines q as the product of 2*(n - 1) +c transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c where gv(i), gw(i) are givens rotations in the (i,n) plane +c which eliminate elements in the i-th and n-th planes, +c respectively. q itself is not accumulated, rather the +c information to recover the gv, gw rotations is returned. +c +c the subroutine statement is +c +c subroutine r1updt(m,n,s,ls,u,v,w,sing) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of s. +c +c n is a positive integer input variable set to the number +c of columns of s. n must not exceed m. +c +c s is an array of length ls. on input s must contain the lower +c trapezoidal matrix s stored by columns. on output s contains +c the lower trapezoidal matrix produced as described above. +c +c ls is a positive integer input variable not less than +c (n*(2*m-n+1))/2. +c +c u is an input array of length m which must contain the +c vector u. +c +c v is an array of length n. on input v must contain the vector +c v. on output v(i) contains the information necessary to +c recover the givens rotation gv(i) described above. +c +c w is an output array of length m. w(i) contains information +c necessary to recover the givens rotation gw(i) described +c above. +c +c sing is a logical output variable. sing is set true if any +c of the diagonal elements of the output s are zero. otherwise +c sing is set false. +c +c subprograms called +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more, +c john l. nazareth +c +c ********** + integer i,j,jj,l,nmj,nm1 + double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, + * zero + double precision dpmpar + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c +c giant is the largest magnitude. +c + giant = dpmpar(3) +c +c initialize the diagonal element pointer. +c + jj = (n*(2*m - n + 1))/2 - (m - n) +c +c move the nontrivial part of the last column of s into w. +c + l = jj + do 10 i = n, m + w(i) = s(l) + l = l + 1 + 10 continue +c +c rotate the vector v into a multiple of the n-th unit vector +c in such a way that a spike is introduced into w. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) .eq. zero) go to 50 +c +c determine a givens rotation which eliminates the +c j-th element of v. +c + if (dabs(v(n)) .ge. dabs(v(j))) go to 20 + cotan = v(n)/v(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 30 + 20 continue + tan = v(j)/v(n) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 30 continue +c +c apply the transformation to v and store the information +c necessary to recover the givens rotation. +c + v(n) = sin*v(j) + cos*v(n) + v(j) = tau +c +c apply the transformation to s and extend the spike in w. +c + l = jj + do 40 i = j, m + temp = cos*s(l) - sin*w(i) + w(i) = sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 40 continue + 50 continue + 60 continue + 70 continue +c +c add the spike from the rank 1 update to w. +c + do 80 i = 1, m + w(i) = w(i) + v(n)*u(i) + 80 continue +c +c eliminate the spike. +c + sing = .false. + if (nm1 .lt. 1) go to 140 + do 130 j = 1, nm1 + if (w(j) .eq. zero) go to 120 +c +c determine a givens rotation which eliminates the +c j-th element of the spike. +c + if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 + cotan = s(jj)/w(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 100 + 90 continue + tan = w(j)/s(jj) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 100 continue +c +c apply the transformation to s and reduce the spike in w. +c + l = jj + do 110 i = j, m + temp = cos*s(l) + sin*w(i) + w(i) = -sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 110 continue +c +c store the information necessary to recover the +c givens rotation. +c + w(j) = tau + 120 continue +c +c test for zero diagonal elements in the output s. +c + if (s(jj) .eq. zero) sing = .true. + jj = jj + (m - j + 1) + 130 continue + 140 continue +c +c move w back into the last column of the output s. +c + l = jj + do 150 i = n, m + s(l) = w(i) + l = l + 1 + 150 continue + if (s(jj) .eq. zero) sing = .true. + return +c +c last card of subroutine r1updt. +c + end diff --git a/math/minpack/rwupdt.f b/math/minpack/rwupdt.f new file mode 100644 index 00000000..05282b55 --- /dev/null +++ b/math/minpack/rwupdt.f @@ -0,0 +1,113 @@ + subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) + integer n,ldr + double precision alpha + double precision r(ldr,n),w(n),b(n),cos(n),sin(n) +c ********** +c +c subroutine rwupdt +c +c given an n by n upper triangular matrix r, this subroutine +c computes the qr decomposition of the matrix formed when a row +c is added to r. if the row is specified by the vector w, then +c rwupdt determines an orthogonal matrix q such that when the +c n+1 by n matrix composed of r augmented by w is premultiplied +c by (q transpose), the resulting matrix is upper trapezoidal. +c the matrix (q transpose) is the product of n transformations +c +c g(n)*g(n-1)* ... *g(1) +c +c where g(i) is a givens rotation in the (i,n+1) plane which +c eliminates elements in the (n+1)-st plane. rwupdt also +c computes the product (q transpose)*c where c is the +c (n+1)-vector (b,alpha). q itself is not accumulated, rather +c the information to recover the g rotations is supplied. +c +c the subroutine statement is +c +c subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the upper triangular part of +c r must contain the matrix to be updated. on output r +c contains the updated triangular matrix. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c w is an input array of length n which must contain the row +c vector to be added to r. +c +c b is an array of length n. on input b must contain the +c first n elements of the vector c. on output b contains +c the first n elements of the vector (q transpose)*c. +c +c alpha is a variable. on input alpha must contain the +c (n+1)-st element of the vector c. on output alpha contains +c the (n+1)-st element of the vector (q transpose)*c. +c +c cos is an output array of length n which contains the +c cosines of the transforming givens rotations. +c +c sin is an output array of length n which contains the +c sines of the transforming givens rotations. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer i,j,jm1 + double precision cotan,one,p5,p25,rowj,tan,temp,zero + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c + do 60 j = 1, n + rowj = w(j) + jm1 = j - 1 +c +c apply the previous transformations to +c r(i,j), i=1,2,...,j-1, and to w(j). +c + if (jm1 .lt. 1) go to 20 + do 10 i = 1, jm1 + temp = cos(i)*r(i,j) + sin(i)*rowj + rowj = -sin(i)*r(i,j) + cos(i)*rowj + r(i,j) = temp + 10 continue + 20 continue +c +c determine a givens rotation which eliminates w(j). +c + cos(j) = one + sin(j) = zero + if (rowj .eq. zero) go to 50 + if (dabs(r(j,j)) .ge. dabs(rowj)) go to 30 + cotan = r(j,j)/rowj + sin(j) = p5/dsqrt(p25+p25*cotan**2) + cos(j) = sin(j)*cotan + go to 40 + 30 continue + tan = rowj/r(j,j) + cos(j) = p5/dsqrt(p25+p25*tan**2) + sin(j) = cos(j)*tan + 40 continue +c +c apply the current transformation to r(j,j), b(j), and alpha. +c + r(j,j) = cos(j)*r(j,j) + sin(j)*rowj + temp = cos(j)*b(j) + sin(j)*alpha + alpha = -sin(j)*b(j) + cos(j)*alpha + b(j) = temp + 50 continue + 60 continue + return +c +c last card of subroutine rwupdt. +c + end diff --git a/math/mkpkg b/math/mkpkg new file mode 100644 index 00000000..47aa33d7 --- /dev/null +++ b/math/mkpkg @@ -0,0 +1,138 @@ +# Update the IRAF MATH libraries. + +$ifeq (hostid, unix) !(clear;date) $endif +$call mathgen +$echo "-------------- (done) -------------------" +$ifeq (hostid, unix) !(date) $endif +$exit + +# MATHGEN -- Update the math libraries. The source for each library is +# maintained in a separate subidrectory. The binary libraries are in lib$. +# To update a single library type "mkpkg" in the source directory for the +# library, or type "mkpkg libname" in this directory, e.g. "mkpkg llsq". + +mathgen: + $call bev + $call curfit + $call deboor + $call gsurfit + # $call ieee + $call iminterp + $call interp + $call llsq + $call nlfit + $call slalib + $call surfit + $purge lib$ + ; + +bev: + $echo "-------------- LIBBEV -------------------" + $checkout libbev.a lib$ + $update libbev.a + $checkin libbev.a lib$ + ; +curfit: + $echo "-------------- LIBCURFIT ----------------" + $checkout libcurfit.a lib$ + $update libcurfit.a + $checkin libcurfit.a lib$ + ; +deboor: + $echo "-------------- LIBDEBOOR ----------------" + $checkout libdeboor.a lib$ + $update libdeboor.a + $checkin libdeboor.a lib$ + ; +gsurfit: + $echo "-------------- LIBGSURFIT ---------------" + $checkout libgsurfit.a lib$ + $update libgsurfit.a + $checkin libgsurfit.a lib$ + ; +ieee: + $echo "-------------- LIBIEEE ------------------" + $checkout libieee.a lib$ + $update libieee.a + $checkin libieee.a lib$ + ; +iminterp: + $echo "-------------- LIBIMINTERP --------------" + $checkout libiminterp.a lib$ + $update libiminterp.a + $checkin libiminterp.a lib$ + ; +interp: + $echo "-------------- LIBINTERP ----------------" + $checkout libinterp.a lib$ + $update libinterp.a + $checkin libinterp.a lib$ + ; +llsq: + $echo "-------------- LIBLLSQ ------------------" + $checkout libllsq.a lib$ + $update libllsq.a + $checkin libllsq.a lib$ + ; +nlfit: + $echo "-------------- LIBNLFIT -----------------" + $checkout libnlfit.a lib$ + $update libnlfit.a + $checkin libnlfit.a lib$ + ; +slalib: + $echo "-------------- LIBSLALIB ----------------" + $checkout libslalib.a lib$ + $update libslalib.a + $checkin libslalib.a lib$ + ; +surfit: + $echo "-------------- LIBSURFIT ----------------" + $checkout libsurfit.a lib$ + $update libsurfit.a + $checkin libsurfit.a lib$ + ; + +libbev.a: # Bevington routines + @bevington + ; + +libcurfit.a: # Curve fitting package + @curfit + ; + +libdeboor.a: # DeBoor spline package + @deboor + ; + +libgsurfit.a: # Generalized 2d surface fitting pkg + @gsurfit + ; + +libieee.a: # IEEE signal processing package + @ieee + ; + +libiminterp.a: # Image interpolation package + @iminterp + ; + +libinterp.a: # Obsolete version of iminterp pkg + @interp + ; + +libllsq.a: # Lawson and Hanson Least Squares pkg + @llsq + ; + +libnlfit.a: # Levenberg-Marquardt fitting package + @nlfit + ; + +libslalib.a: # Starlink positional astronomy library + @slalib + ; + +libsurfit.a: # Surface fitting on an even grid + @surfit + ; diff --git a/math/nlfit/README b/math/nlfit/README new file mode 100644 index 00000000..c47732af --- /dev/null +++ b/math/nlfit/README @@ -0,0 +1,81 @@ + THE NLFIT PACKAGE + +This subdirectory contains the routines in the non-linear least squares +fitting package NLFIT. NLFIT uses the Levenberg-Marquardt method to +to solve for the parameters of a user specified non-linear equation. +The user must supply two routines. The first routine evaluates the function +in terms of its parameters. The second routine evaluates the function and its +derivatives in terms of its parameters. The user must also supply initial +guesses for the parameters and parameter increments, the list of +parameters to be varied during the fitting processa, a fitting +tolerance and the maximum number of iterations. + +The principal entry points into the NLFIT are listed below. + + nlinit - Initialize the fitting routines + nlstati - Get the value of an integer NLFIT parameter + nlstat - Get the value of floating point NLFIT parameter + nlpget - Get the values of the fitted parameters + nlfree - Free memory allocated by nlinit + nlfit - Fit the function + nleval - Evaluate the curve at a given point + nlvector - Evaluate the curve at an array of points + nlerrors - Compute the fits statistics and errors in the parameters + +The calling sequences for the above routines are listed below. The [ird] +stand for integer, real and double precision versions of each routine +respectively. + + nlinit[rd] (nl, address(fnc), address(dfnc), params, dparams, + nparams, plist, nfparams, tol, itmax) + ival = nlstati (nl, param) + [rd]val = nlstat[rd] (nl, param) + nlpget[rd] (nl, params, nparams) + nlfree[rd] (nl) + nlfit[rd] (nl, x, z, w, npts, nvars, wtflag, ier) + [rd]val = nleval[rd] (nl, x, nvars) + nlvector[rd] (nl, x, zfit, npts, nvars) + nlerrors[rd] (nl, z, zfit, wts, npts, variance, chisqr, errors) + +The user supplied functions fnc and dfnc have the following calling +sequences. + + fnc (x, nvars, params, nparams, zfit) + dfnc (x, nvars, params, dparams, nparams, zfit, derivs) + + The address of the user supplied function can be determined with a +call to locpr as in + + address = locpr (fnc) + +The user definitions for the NLFIT package can be found in the file +lib$math/nlfit.h and can be made available to user applications programs +with the statement "include ". + +The permitted values for the param argument in nlstat[ird] are the following. + +define NLNPARAMS integer # Number of parameters +define NLNFPARAMS integer # Number of fitted parameters +define NLITMAX integer # Maximum number of iterations +define NLITER integer # Current number of iterations +define NLNPTS integer # Number of points +define NLSUMSQ real/double # Current reduced chi-squared +define NLOLDSQ real/double # Previous reduced chi-squared +define NLLAMBDA real/double # Value of lambda factor +define NLTOL real/double # Fitting tolerance in %chi-squared +define NLSCATTER real/double # Mean scatter in the fit + +The permitted values of the wtflag argument in nlfit[rd] are the following. + +define WTS_USER # User enters weights +define WTS_UNIFORM # Equal weights +define WTS_CHISQ # Chi-squared weights +define WTS_SCATTER # Weights include scatter term + +The permitted error values returned from nlfit[rd] are the following. + +define DONE 0 # Solution converged +define SINGULAR 1 # Singular matrix +define NO_DEG_FREEDOM 2 # Too few points +define NOT_DONE 3 # Solution did not converge + diff --git a/math/nlfit/doc/nlerrors.hlp b/math/nlfit/doc/nlerrors.hlp new file mode 100644 index 00000000..3b463c14 --- /dev/null +++ b/math/nlfit/doc/nlerrors.hlp @@ -0,0 +1,67 @@ +.help nlerrors Feb91 "Nlfit Package" +.ih +NAME +nlerrors -- compute the fit statistics and errors in the parameters +.ih +SYNOPSIS +nlerrors[rd] (nl, z, zfit, w, npts, variance, chisqr, errors) + +.nf +pointer nl # curve descriptor +real/double z[npts] # array of input function values +real/double zfit[npts] # array of fitted function values +real/double w[npts] # array of weights +int npts # number of data points +real/double variance # the computed variance of the fit +real/double chisqr # the computed reduced chi-square of the fit +real/double errors[*] # errors in the fitted parameters +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ls z +Array of function values. +.le +.ls zfit +Array of fitted function values. +.le +.ls w +Array of weights. +.le +.ls npts +The number of data points. +.le +.ls variance +The computed variance of the fit. +.le +.ls chisqr +The computed reduced chi-squared of the fit. +.le +.ls errors +Array of errors in the computed parameters. +.le +.ih +DESCRIPTION +Compute the variance and reduced chi-squared of the fit and the +errors in the fitted parameters. +.ih +NOTES +The reduced chi-squared of the fit is the square root of the sum of the +weighted squares of the residuals divided by the number of degrees of freedom. +The variance of the fit is the square root of the sum of the +squares of the residuals divided by the number of degrees of freedom. +If the weighting is uniform, then the reduced chi-squared is equal to the +variance of the fit. +The error of the j-th parameter is the square root of the j-th diagonal +element of the inverse of the data matrix. If the weighting is uniform, +then the errors are scaled by the square root of the variance of the data. + +The zfit array can be computed by a call to the nlvector[rd] routine. +The size of the array required to hold the output error array can be +determined by a call to nlstati. +.ih +SEE ALSO +nlvector,nlstat +.endhelp diff --git a/math/nlfit/doc/nleval.hlp b/math/nlfit/doc/nleval.hlp new file mode 100644 index 00000000..f0bbb400 --- /dev/null +++ b/math/nlfit/doc/nleval.hlp @@ -0,0 +1,35 @@ +.help nleval Feb91 "Nlfit Package" +.ih +NAME +nleval -- evaluate the fitted function at a single point +.ih +SYNOPSIS +z = nleval[rd] (nl, x, nvars) + +.nf +pointer nl # curve descriptor +real/double x[nvars] # array of variables +int nvars # the number of variables +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ls x +Array of variable values at which the curve is to be evaluated. +.le +.ls nvars +The number of variables. +.le +.ih +DESCRIPTION +Evaluate the curve at the specified point. NLEVAL is a real or double +function which returns the fitted z value. +.ih +NOTES +NLEVAL uses the parameter array stored in the curve descriptor structure. +.ih +SEE ALSO +nlvector +.endhelp diff --git a/math/nlfit/doc/nlfit.hd b/math/nlfit/doc/nlfit.hd new file mode 100644 index 00000000..13bb3065 --- /dev/null +++ b/math/nlfit/doc/nlfit.hd @@ -0,0 +1,12 @@ +# Help directory for the NLFIT (non-linear least-squares fitting) package. + +$nlfit = "math$nlfit/" + +nlerrors hlp = nlerrors.hlp, src = nlfit$nlerrorsr.x +nleval hlp = nleval.hlp, src = nlfit$nlevalr.x +nlinit hlp = nlinit.hlp, src = nlfit$nlinitr.x +nlfit hlp = nlfit.hlp, src = nlfit$nlfitr.x +nlfree hlp = nlfree.hlp, src = nlfit$nlfreer.x +nlpget hlp = nlpget.hlp, src = nlfit$nlpgetr.x +nlstat hlp = nlstat.hlp, src = nlfit$nlstatr.x +nlvector hlp = nlvector.hlp, src = nlfit$nlvectorr.x diff --git a/math/nlfit/doc/nlfit.hlp b/math/nlfit/doc/nlfit.hlp new file mode 100644 index 00000000..8ed82512 --- /dev/null +++ b/math/nlfit/doc/nlfit.hlp @@ -0,0 +1,81 @@ +.help nlfit Feb91 "Nlfit Package" +.ih +NAME +nlfit -- fit a curve to a set of data values +.ih +SYNOPSIS +nlfit (nl, x, z, w, npts, nvars, wtflag, ier) + +.nf +pointer nl # curve descriptor +real/double x[npts*nvars] # variable values (stored as x[nvars,npts]) +real/double z[npts] # array of z values +real/double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values. +.le +.ls z +Array of function values. +.le +.ls w +Array of weights. +.le +.ls npts +The number of data points. +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_UNIFORM, WTS_CHISQ and +WTS_SCATTER. If wtflag = WTS_USER individual weights for each data point +are supplied by the calling program and points with zero-valued weights are +not included in the fit. If wtflag = WTS_UNIFORM, all weights are assigned +values of 1. If wtflag = WTS_CHISQ the weights are set equal to the +reciprocal of the function value. If wtflag = WTS_SCATTER the fitting +routine adds a scatter term to the weights if the reduced chi-squared of +the fit is significantly greater than 1. +.le +.ls ier +Error code for the fit. The options are DONE, SINGULAR, +NO_DEG_FREEDOM and NOT_DONE. If ier = SINGULAR, the numerical routines +will compute a +solution but one or more of the coefficients will be +zero. If ier = NO_DEG_FREEDOM, there were too few data points to solve the +matrix equations and the routine returns without fitting the data. +If ier = NOT_DONE, the fit could not achieve the desired tolerance with +the given input data in the specified maximum number of iterations. +.le +.ih +DESCRIPTION +NLFIT accumulate the data into the appropriate internal matrices and vectors +and does the fit. +.ih +NOTES +The permitted values of the input wtflag argument to nlfit[rd] are the +following. + +.nf +define WTS_USER # User enters weights +define WTS_UNIFORM # Equal weights +define WTS_CHISQ # Chi-squared weights +define WTS_SCATTER # Weights include scatter term +.fi + +The permitted error values returned from nlfit[rd] are the following. + +.nf +define DONE 0 # Solution converged +define SINGULAR 1 # Singular matrix +define NO_DEG_FREEDOM 2 # Too few points +define NOT_DONE 3 # Solution did not converge +.fi +.ih +SEE ALSO +.endhelp diff --git a/math/nlfit/doc/nlfit.men b/math/nlfit/doc/nlfit.men new file mode 100644 index 00000000..5fb68623 --- /dev/null +++ b/math/nlfit/doc/nlfit.men @@ -0,0 +1,8 @@ + nlerrors - Compute the fits statistics and errors in the parameters + nlfit - Fit the function + nlfree - Free memory allocated by nlinit + nlinit - Initialize the fitting routines + nlpget - Get the values of the fitted parameters + nlstat - Get the value of an NLFIT parameter + nleval - Evaluate the curve at a given point + nlvector - Evaluate the curve at an array of points diff --git a/math/nlfit/doc/nlfree.hlp b/math/nlfit/doc/nlfree.hlp new file mode 100644 index 00000000..9688d5e7 --- /dev/null +++ b/math/nlfit/doc/nlfree.hlp @@ -0,0 +1,26 @@ +.help nlfree Feb91 "Nlfit Package" +.ih +NAME +nlfree -- free the curve descriptor structure +.ih +SYNOPSIS +nlfree[rd] (nl) + +.nf +pointer nl # curve descriptor +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ih +DESCRIPTION +Frees the curve descriptor structure. +.ih +NOTES +NLFREE should be called after each curve fit. +.ih +SEE ALSO +nlinit +.endhelp diff --git a/math/nlfit/doc/nlinit.hlp b/math/nlfit/doc/nlinit.hlp new file mode 100644 index 00000000..94e5e5a9 --- /dev/null +++ b/math/nlfit/doc/nlinit.hlp @@ -0,0 +1,86 @@ +.help nlinit Feb91 "Nlfit Package" +.ih +NAME +nlinit -- initialise curve descriptor +.ih +SYNOPSIS +include + +nlinit[rd] (nl, fnc, dfnc, params, dparams, nparams, plist, nfparams, + tol, itmax) + +.nf +pointer nl # curve descriptor +int fnc # address of first user-supplied function +int dfnc # address of second user-supplied function +real/double params[nparams] # list of initial parameter values +real/double dparams[nparams]# list of parameter increments +int nparams # number of parameters +int plist[nparams] # list of parameters to be fit +int nfparams # number of parameters to be fit +real/double tol # fitting tolerance +int itmax # maximum number of iterations +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ls fnc +The address of the user-supplied subroutine fncname for evaluating the function +to be fit. The calling sequence of fncname is the following. + +.nf +fncname (x, nvars, params, nparams, zfit) +.fi +.le +.ls dfnc +The address of the user-supplied subroutine dfncname for evaluating the +function to be fit and its derivatives with respect to the parameters. +The calling sequence of dfncname is the following. + +.nf +dfncname (x, nvars, params, dparams, nparams, zfit, derivs) +.fi +.le +.ls params +An array containing initial values of all the parameters, including both +those to be fit and those that are to be held constant. +.le +.ls dparams +An array parameter increment values over which the derivatives are to be +computed empirically. If equations are supplied for the derivatives +inside dfnc, the dparams array is not used. +.le +.ls nparams +The total number of parameters in the user-supplied function. +.le +.ls plist +The list of parameters to be fit. Plist is an integer array containing +the indices of those parameters in params to be fit. +.le +.ls nfparams +The total number of parameters to be fit. +.le +.ls tol +The fitting tolerance. If the difference in the chi-squared +from one iteration to the next is less than the fitting tolerance +times the current chi-squared, the fit has converged. +.le +.ls itmax +The maximum number of fitting iterations. Itmax must be greater than +or equal to 3. +.le +.ih +DESCRIPTION +Allocate space for the curve descriptor structure and the arrays and +vectors used by the numerical routines. Initialize all arrays and vectors +to zero. Return the curve descriptor to the calling routine. +.ih +NOTES +NLINIT must be the first NLFIT routine called. NLINIT returns a NULL pointer +if it encounters an illegal parameter list. +.ih +SEE ALSO +nlfree +.endhelp diff --git a/math/nlfit/doc/nllmfit.hlp b/math/nlfit/doc/nllmfit.hlp new file mode 100644 index 00000000..59309133 --- /dev/null +++ b/math/nlfit/doc/nllmfit.hlp @@ -0,0 +1,172 @@ +.help nlfit Feb91 "Math Package" +.ih +NAME +nlfit -- Levenberg-Marquardt non-linear least-squares fitting package +.ih +SYNOPSIS +The principal entry points into the NLFIT package are listed below. + +.nf + nlinit - Initialize the fitting routines + nlstat - Get the value of an NLFIT parameter + nlpget - Get the values of the fitted parameters + nlfree - Free memory allocated by nlinit + nlfit - Fit the function + nleval - Evaluate the curve at a given point + nlvector - Evaluate the curve at an array of points + nlerrors - Compute the fits statistics and errors in the parameters +.fi + +The calling sequences for the above routines are listed below. The [ird] +stand for integer, real and double precision versions of each routine +respectively. + +.nf + nlinit[rd] (nl, address(fnc), address(dfnc), params, dparams, + nparams, plist, nfparams, tol, itmax) + ival = nlstati (nl, param) + [rd]val = nlstat[rd] (nl, param) + nlpget[rd] (nl, params, nparams) + nlfree[rd] (nl) + nlfit[rd] (nl, x, z, w, npts, nvars, wtflag, ier) + [rd]val = nleval[rd] (nl, x, nvars) + nlvector[rd] (nl, x, zfit, npts, nvars) + nlerrors[rd] (nl, z, zfit, wts, npts, variance, chisqr, errors) +.fi + +The user supplied functions fnc and dfnc must have the following form. + +.nf + fnc (x, nvars, params, nparams, zfit) + dfnc (x, nvars, params, dparams, nparams, zfit, derivs) +.fi + +The addresses of these functions can be obtained by a call to lcopr as +follows. + +.nf + address = locpr (fnc) +.fi + +.ih +DESCRIPTION +The NLFIT package provides a set of routines for fitting data to non-linear +functions of several variables using least squares techniques. +NLFIT uses the Levenberg-Marquardt +method to solve for the parameters of a user specified non-linear equation. +The user must supply two subroutines. The first subroutine evaluates the +function in terms of its parameters. The second subroutine evaluates the +function and its derivatives in terms of its parameters. The user must +also supply initial +guesses for the parameters and parameter increments, the list of +parameters to be varied during the fitting process, a fitting +tolerance and the maximum number of iterations. +.ih +NOTES +The poackage definitions for NLFIT can be found in the file +lib$math/nlfit.h. In order to make these definitions available +to the calling program, the user must insert the statement +"include " inside the calling program. + +The permitted values for the param argument in nlstat[ird] are the following. + +.nf +define NLNPARAMS integer # Number of parameters +define NLNFPARAMS integer # Number of fitted parameters +define NLITMAX integer # Maximum number of iterations +define NLITER integer # Current number of iterations +define NLNPTS integer # Number of points +define NLSUMSQ real/double # Current reduced chi-squared +define NLOLDSQ real/double # Previous reduced chi-squared +define NLLAMBDA real/double # Value of lambda factor +define NLTOL real/double # Fitting tolerance in %chi-squared +define NLSCATTER real/double # Mean scatter in the fit +.fi + +The permitted values of the wtflag argument in nlfit[rd] are the following. + +.nf +define WTS_USER # User enters weights +define WTS_UNIFORM # Equal weights +define WTS_CHISQ # Chi-squared weights +define WTS_SCATTER # Weights include scatter term +.fi + +The permitted error values returned from nlfit[rd] are the following. + +.nf +define DONE 0 # Solution converged +define SINGULAR 1 # Singular matrix +define NO_DEG_FREEDOM 2 # Too few points +define NOT_DONE 3 # Solution did not converge +.fi +.ih +REFERENCES +1. Bevington,P.R., 1969, Data Reduction and Error Analysis for the Physical +Sciences, Chapter 11, page 235. + +2. Press, W.H. et al., 1986, Numerical Recipes: The Art of Scientific +Computing, Chapter 14, page 523 +.ih +EXAMPLES +.nf +Example 1: Fit a curve to the data using uniform weighting. Fit all the +parameters. + + # Include nlfit definitions + include + + # Declare the variables + int nparams, nfparams, itmax, npts, nvars, ier + int plist[nparams] + real tol, variance, chisqr + real params[nparams], dparams[nparams], vars[nvars,npts], z[npts] + real w[npts], zfit[npts], errors[nparams] + + # Declare the functions + extern fncname(), dfncname() + int locpr() + + begin + ... get data, set initial values of all parameters, parameter + ... increments, tol and itmax + + # Define list of variables to be fitted + nfparams = nparams + do i = 1, nparams + plist[i] = i + + # Fit only parameters 1,3 and 5 + #nfparams = 3 + #plist[1] = 1 + #plist[2] = 3 + #plist[3] = 5 + + # Initialize the fitting routines + call nlinitr (nl, locpr (fncname), locpr (dfncname), + params, dparams, nparams, plist, nfparams, tol, itmax) + + # Fit the data + call nlfitr (nl, x, z, w, npts, nvars, WTS_UNIFORM, ier) + if (ier != DONE) + ... take error action + + # Compute the statistics of the fit + call nlvectorr (nl, x, zfit, npts, nvars) + call nlerrorsr (nl, z, zfit, wts, npts, variance, chisqr, + errors) + + # Get the values of the fitted parameters + call nlpgetr (nl, params, nparams) + call nlfreer (nl) + + # Print the parameters and their errors. + do i = 1, nparams { + call printf ("%d %g %g\n") + call pargi (i) + call pargr (params[i]) + call pargr (errors[i]) + } + end +.fi +.endhelp diff --git a/math/nlfit/doc/nlpget.hlp b/math/nlfit/doc/nlpget.hlp new file mode 100644 index 00000000..07f2ef5e --- /dev/null +++ b/math/nlfit/doc/nlpget.hlp @@ -0,0 +1,38 @@ +.help nlpget Feb91 "Nlfit Package" + +.ih +NAME +nlpget -- get the number and values of the fitted parameters +.ih +SYNOPSIS +nlpget[rd] (nl, params, nparams) + +.nf +pointer nl # curve descriptor +real/double params[nparams] # the parameters array +int nparams # the number of parameters +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor. +.le +.ls params +Array of fitted parameters. +.le +.ls nparameters +The total number of parameters. +.le +.ih +DESCRIPTION +NLPGET fetches the parameters array and the number of parameters from the +curve descriptor structure. All the parameters, both those that were +fit and those that were held constant are output. +.ih +NOTES +The array size required to hold the output parameters can be determined +by a call to nlstati. +.ih +SEE ALSO +nlstat +.endhelp diff --git a/math/nlfit/doc/nlstat.hlp b/math/nlfit/doc/nlstat.hlp new file mode 100644 index 00000000..a745a663 --- /dev/null +++ b/math/nlfit/doc/nlstat.hlp @@ -0,0 +1,57 @@ +.help nlstat Feb91 "Nlfit Package" +.ih +NAME +nlstat[ird] -- get an NLFIT parameter +.ih +SYNOPSIS +include + +[ird]val = nlstat[ird] (nl, parameter) + +.nf +pointer nl # curve descriptor +int parameter # parameter to be returned +.fi +.ih +ARGUMENTS +.ls nl +The pointer to the curve descriptor structure. +.le +.ls parameter +Parameter to be return. Definitions in nlfit.h are: + +.nf +NLNPARAMS integer # Number of parameters +NLNFPARAMS integer # Number of fitted parameters +NLITMAX integer # Maximum number of iterations +NLITER integer # Current number of iterations +NLNPTS integer # Number of points +NLSUMSQ real/double # Current reduced chi-squared +NLOLDSQ real/double # Previous reduced chi-squared +NLLAMBDA real/double # Value of lambda factor +NLTOL real/double # Fitting tolerance in %chi-squared +NLSCATTER real/double # Mean scatter in the fit +.fi +.le +.ih +DESCRIPTION +The values of integer, real or double parameters are returned. +The parameters include the number of parameters, the number of fitted +parameters, the maximum number of iterations, the number of iterations, +the total number of points, the current chi-squared, the previous +chi-squared, the lambda factor, the fitting tolerance and the fitted +scatter term. +.ih +EXAMPLES +.nf +include + +int nlstati() + +call malloc (buf, nlstati (nl, NLNPARAMS), TY_REAL) +call nlpgetr (nl, Memr[buf], nparams) +.fi +.ih +SEE ALSO +nlpget +.endhelp diff --git a/math/nlfit/doc/nlvector.hlp b/math/nlfit/doc/nlvector.hlp new file mode 100644 index 00000000..98308cc3 --- /dev/null +++ b/math/nlfit/doc/nlvector.hlp @@ -0,0 +1,43 @@ +.help nlvector Feb91 "Nlfit Package" +.ih +NAME +nlvector -- evaluate the fitted curve at a set of points +.ih +SYNOPSIS +nlvector[rd] (nl, x, zfit, npts, nvars) + +.nf +pointer nl # curve descriptor +real/double x[nvars*npts] # array of variables stored as x[nvars,npts] +real/double zfit[npts] # array of fitted function values +int npts # number of data points +int nvars # number of variables +.fi +.ih +ARGUMENTS +.ls nl +Pointer to the curve descriptor structure. +.le +.ls x +Array of variable values for all the data points. +.le +.ls zfit +Array of fitted function values. +.le +.ls npts +The number of data points at which the curve is to be evaluated. +.le +.ls nvars +The number of variables in the fitted function. +.le +.ih +DESCRIPTION +Fit the curve to an array of data points. +.ih +NOTES +NLVECTOR uses the coefficient array stored in the curfit descriptor +structure. +.ih +SEE ALSO +nleval +.endhelp diff --git a/math/nlfit/mkpkg b/math/nlfit/mkpkg new file mode 100644 index 00000000..4573dfbf --- /dev/null +++ b/math/nlfit/mkpkg @@ -0,0 +1,63 @@ +# The Non-linear Least-squares Fitting Package + +$checkout libnlfit.a lib$ +$update libnlfit.a +$checkin libnlfit.a lib$ +$exit + +tfiles: + $set GEN = "$$generic -k -t rd" + + $ifnewer (nlacpts.gx, nlacptsr.x) $(GEN) nlacpts.gx $endif + $ifnewer (nlchomat.gx, nlchomatr.x) $(GEN) nlchomat.gx $endif + $ifnewer (nldump.gx, nldumpr.x) $(GEN) nldump.gx $endif + $ifnewer (nlerrors.gx, nlerrorsr.x) $(GEN) nlerrors.gx $endif + $ifnewer (nleval.gx, nlevalr.x) $(GEN) nleval.gx $endif + $ifnewer (nlfit.gx, nlfitr.x) $(GEN) nlfit.gx $endif + $ifnewer (nlfitdef.gh, nlfitdefr.h) $(GEN) nlfitdef.gh $endif + $ifnewer (nlfree.gx, nlfreer.x) $(GEN) nlfree.gx $endif + $ifnewer (nlinit.gx, nlinitr.x) $(GEN) nlinit.gx $endif + $ifnewer (nliter.gx, nliterr.x) $(GEN) nliter.gx $endif + $ifnewer (nlpget.gx, nlpgetr.x) $(GEN) nlpget.gx $endif + $ifnewer (nlsolve.gx, nlsolver.x) $(GEN) nlsolve.gx $endif + $ifnewer (nlstat.gx, nlstatr.x) $(GEN) nlstat.gx $endif + $ifnewer (nlvector.gx, nlvectorr.x) $(GEN) nlvector.gx $endif + $ifnewer (nlzero.gx, nlzeror.x) $(GEN) nlzero.gx $endif + ; + +libnlfit.a: + + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + nlacptsd.x "nlfitdefd.h" + nlacptsr.x "nlfitdefr.h" + nlchomatd.x "nlfitdefd.h" + nlchomatr.x "nlfitdefr.h" + nldumpd.x "nlfitdefd.h" + nldumpr.x "nlfitdefr.h" + nlerrmsg.x + nlerrorsd.x "nlfitdefd.h" + nlerrorsr.x "nlfitdefr.h" + nlevald.x "nlfitdefd.h" + nlevalr.x "nlfitdefr.h" + nlfitd.x "nlfitdefd.h" + nlfitr.x "nlfitdefr.h" + nlfreed.x "nlfitdefd.h" + nlfreer.x "nlfitdefr.h" + nlinitd.x "nlfitdefd.h" + nlinitr.x "nlfitdefr.h" + nliterd.x "nlfitdefd.h" + nliterr.x "nlfitdefr.h" + nllist.x + nlpgetd.x "nlfitdefd.h" + nlpgetr.x "nlfitdefr.h" + nlsolved.x "nlfitdefd.h" + nlsolver.x "nlfitdefr.h" + nlstati.x "nlfitdefr.h" + nlstatd.x "nlfitdefd.h" + nlstatr.x "nlfitdefr.h" + nlvectord.x "nlfitdefd.h" + nlvectorr.x "nlfitdefr.h" + nlzerod.x "nlfitdefd.h" + nlzeror.x "nlfitdefr.h" + ; diff --git a/math/nlfit/nlacpts.gx b/math/nlfit/nlacpts.gx new file mode 100644 index 00000000..a9f947ba --- /dev/null +++ b/math/nlfit/nlacpts.gx @@ -0,0 +1,111 @@ +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +define VAR (($1 - 1) * $2 + 1) + +# NLACPTS - Accumulate a series of data points. + +PIXEL procedure nlacpts$t (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL z[ARB] # function values (npts) +PIXEL w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +PIXEL sum, z0, dz + +begin + # Zero the accumulators. + call aclr$t (ALPHA(NL_ALPHA(nl)), NL_NFPARAMS(nl) ** 2) + call aclr$t (BETA(NL_BETA(nl)), NL_NFPARAMS(nl)) + + # Accumulate the points into the fit. + NL_NPTS (nl) = npts + sum = PIXEL(0.0) + do i = 1, npts { + call zcall7 (NL_DFUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), DPARAM(NL_DELPARAM(nl)), NL_NPARAMS(nl), + z0, DERIV(NL_DERIV(nl))) + dz = z[i] - z0 + call nl_accum$t (DERIV(NL_DERIV(nl)), PLIST(NL_PLIST(nl)), + w[i], dz, NL_NFPARAMS(nl), ALPHA(NL_ALPHA(nl)), + BETA(NL_BETA(nl))) + sum = sum + w[i] * dz * dz + } + + # Return the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (PIXEL (0.0)) + else + return (sum / nfree) +end + + +# NLRESID -- Recompute the residuals + +PIXEL procedure nlresid$t (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL z[ARB] # function values (npts) +PIXEL w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +PIXEL sum, z0, dz + +begin + # Accumulate the residuals. + NL_NPTS(nl) = npts + sum = PIXEL (0.0) + do i = 1, npts { + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, TRY(NL_TRY(nl)), + NL_NPARAMS(nl), z0) + dz = z[i] - z0 + sum = sum + dz * dz * w[i] + } + + # Compute the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (PIXEL (0.0)) + else + return (sum / nfree) +end + + +# NL_ACCUM -- Accumulate a single point into the fit + +procedure nl_accum$t (deriv, list, w, dz, nfit, alpha, beta) + +PIXEL deriv[ARB] # derivatives +int list[ARB] # list of active parameters +PIXEL w # weight +PIXEL dz # difference between data and model +int nfit # number of fitted parameters +PIXEL alpha[nfit,ARB] # alpha matrix +PIXEL beta[nfit] # beta matrix + +int i, j, k +PIXEL wt + +begin + do i = 1, nfit { + wt = deriv[list[i]] * w + k = 1 + do j = i, nfit { + alpha[k,i] = alpha[k,i] + wt * deriv[list[j]] + k = k + 1 + } + beta[i] = beta[i] + dz * wt + } +end diff --git a/math/nlfit/nlacptsd.x b/math/nlfit/nlacptsd.x new file mode 100644 index 00000000..b08a897f --- /dev/null +++ b/math/nlfit/nlacptsd.x @@ -0,0 +1,107 @@ +include +include "nlfitdefd.h" + +define VAR (($1 - 1) * $2 + 1) + +# NLACPTS - Accumulate a series of data points. + +double procedure nlacptsd (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +double x[ARB] # independent variables (npts * nvars) +double z[ARB] # function values (npts) +double w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +double sum, z0, dz + +begin + # Zero the accumulators. + call aclrd (ALPHA(NL_ALPHA(nl)), NL_NFPARAMS(nl) ** 2) + call aclrd (BETA(NL_BETA(nl)), NL_NFPARAMS(nl)) + + # Accumulate the points into the fit. + NL_NPTS (nl) = npts + sum = double(0.0) + do i = 1, npts { + call zcall7 (NL_DFUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), DPARAM(NL_DELPARAM(nl)), NL_NPARAMS(nl), + z0, DERIV(NL_DERIV(nl))) + dz = z[i] - z0 + call nl_accumd (DERIV(NL_DERIV(nl)), PLIST(NL_PLIST(nl)), + w[i], dz, NL_NFPARAMS(nl), ALPHA(NL_ALPHA(nl)), + BETA(NL_BETA(nl))) + sum = sum + w[i] * dz * dz + } + + # Return the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (double (0.0)) + else + return (sum / nfree) +end + + +# NLRESID -- Recompute the residuals + +double procedure nlresidd (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +double x[ARB] # independent variables (npts * nvars) +double z[ARB] # function values (npts) +double w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +double sum, z0, dz + +begin + # Accumulate the residuals. + NL_NPTS(nl) = npts + sum = double (0.0) + do i = 1, npts { + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, TRY(NL_TRY(nl)), + NL_NPARAMS(nl), z0) + dz = z[i] - z0 + sum = sum + dz * dz * w[i] + } + + # Compute the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (double (0.0)) + else + return (sum / nfree) +end + + +# NL_ACCUM -- Accumulate a single point into the fit + +procedure nl_accumd (deriv, list, w, dz, nfit, alpha, beta) + +double deriv[ARB] # derivatives +int list[ARB] # list of active parameters +double w # weight +double dz # difference between data and model +int nfit # number of fitted parameters +double alpha[nfit,ARB] # alpha matrix +double beta[nfit] # beta matrix + +int i, j, k +double wt + +begin + do i = 1, nfit { + wt = deriv[list[i]] * w + k = 1 + do j = i, nfit { + alpha[k,i] = alpha[k,i] + wt * deriv[list[j]] + k = k + 1 + } + beta[i] = beta[i] + dz * wt + } +end diff --git a/math/nlfit/nlacptsr.x b/math/nlfit/nlacptsr.x new file mode 100644 index 00000000..d68daf72 --- /dev/null +++ b/math/nlfit/nlacptsr.x @@ -0,0 +1,107 @@ +include +include "nlfitdefr.h" + +define VAR (($1 - 1) * $2 + 1) + +# NLACPTS - Accumulate a series of data points. + +real procedure nlacptsr (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +real x[ARB] # independent variables (npts * nvars) +real z[ARB] # function values (npts) +real w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +real sum, z0, dz + +begin + # Zero the accumulators. + call aclrr (ALPHA(NL_ALPHA(nl)), NL_NFPARAMS(nl) ** 2) + call aclrr (BETA(NL_BETA(nl)), NL_NFPARAMS(nl)) + + # Accumulate the points into the fit. + NL_NPTS (nl) = npts + sum = real(0.0) + do i = 1, npts { + call zcall7 (NL_DFUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), DPARAM(NL_DELPARAM(nl)), NL_NPARAMS(nl), + z0, DERIV(NL_DERIV(nl))) + dz = z[i] - z0 + call nl_accumr (DERIV(NL_DERIV(nl)), PLIST(NL_PLIST(nl)), + w[i], dz, NL_NFPARAMS(nl), ALPHA(NL_ALPHA(nl)), + BETA(NL_BETA(nl))) + sum = sum + w[i] * dz * dz + } + + # Return the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (real (0.0)) + else + return (sum / nfree) +end + + +# NLRESID -- Recompute the residuals + +real procedure nlresidr (nl, x, z, w, npts, nvars) + +pointer nl # pointer to nl fitting structure +real x[ARB] # independent variables (npts * nvars) +real z[ARB] # function values (npts) +real w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +int i, nfree +real sum, z0, dz + +begin + # Accumulate the residuals. + NL_NPTS(nl) = npts + sum = real (0.0) + do i = 1, npts { + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, TRY(NL_TRY(nl)), + NL_NPARAMS(nl), z0) + dz = z[i] - z0 + sum = sum + dz * dz * w[i] + } + + # Compute the reduced chisqr. + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree <= 0) + return (real (0.0)) + else + return (sum / nfree) +end + + +# NL_ACCUM -- Accumulate a single point into the fit + +procedure nl_accumr (deriv, list, w, dz, nfit, alpha, beta) + +real deriv[ARB] # derivatives +int list[ARB] # list of active parameters +real w # weight +real dz # difference between data and model +int nfit # number of fitted parameters +real alpha[nfit,ARB] # alpha matrix +real beta[nfit] # beta matrix + +int i, j, k +real wt + +begin + do i = 1, nfit { + wt = deriv[list[i]] * w + k = 1 + do j = i, nfit { + alpha[k,i] = alpha[k,i] + wt * deriv[list[j]] + k = k + 1 + } + beta[i] = beta[i] + dz * wt + } +end diff --git a/math/nlfit/nlchomat.gx b/math/nlfit/nlchomat.gx new file mode 100644 index 00000000..5a36c63c --- /dev/null +++ b/math/nlfit/nlchomat.gx @@ -0,0 +1,130 @@ +include +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + + +# NL_CHFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure nl_chfac$t (matrix, nbands, nrows, matfac, ier) + +PIXEL matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +PIXEL matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +PIXEL ratio + +begin + # Test for a single element matrix. + if (nrows == 1) { + if (matrix[1,1] > PIXEL (0.0)) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # Copy the original matrix into matfac. + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + # Compute the factorization of the matrix. + do n = 1, nrows { + + # Test to see if matrix is singular. + if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= EPSILON$T) { + #if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= PIXEL(0.0)) { + do j = 1, nbands + matfac[j,n] = PIXEL (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = PIXEL (1.0) / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# NL_CHSLV -- Solve the matrix whose Cholesky factorization was calculated in +# NL_CHFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure nl_chslv$t (matfac, nbands, nrows, vector, coeff) + +PIXEL matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +PIXEL vector[nrows] # right side of matrix equation +PIXEL coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + # Test for a single element matrix. + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # Copy input vector to coefficients vector. + do i = 1, nrows + coeff[i] = vector[i] + + # Perform forward substitution. + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # Perform backward substitution. + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end + + +# NL_DAMP -- Procedure to add damping to matrix + +procedure nl_damp$t (inmatrix, outmatrix, constant, nbands, nrows) + +PIXEL inmatrix[nbands,ARB] # input matrix +PIXEL outmatrix[nbands,ARB] # output matrix +PIXEL constant # damping constant +int nbands, nrows # dimensions of matrix + +int i + +begin + do i = 1, nrows + outmatrix[1,i] = inmatrix[1,i] * constant +end diff --git a/math/nlfit/nlchomatd.x b/math/nlfit/nlchomatd.x new file mode 100644 index 00000000..775793ac --- /dev/null +++ b/math/nlfit/nlchomatd.x @@ -0,0 +1,126 @@ +include +include +include "nlfitdefd.h" + + +# NL_CHFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure nl_chfacd (matrix, nbands, nrows, matfac, ier) + +double matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +double matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +double ratio + +begin + # Test for a single element matrix. + if (nrows == 1) { + if (matrix[1,1] > double (0.0)) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # Copy the original matrix into matfac. + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + # Compute the factorization of the matrix. + do n = 1, nrows { + + # Test to see if matrix is singular. + if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= EPSILOND) { + #if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= PIXEL(0.0)) { + do j = 1, nbands + matfac[j,n] = double (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = double (1.0) / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# NL_CHSLV -- Solve the matrix whose Cholesky factorization was calculated in +# NL_CHFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure nl_chslvd (matfac, nbands, nrows, vector, coeff) + +double matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +double vector[nrows] # right side of matrix equation +double coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + # Test for a single element matrix. + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # Copy input vector to coefficients vector. + do i = 1, nrows + coeff[i] = vector[i] + + # Perform forward substitution. + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # Perform backward substitution. + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end + + +# NL_DAMP -- Procedure to add damping to matrix + +procedure nl_dampd (inmatrix, outmatrix, constant, nbands, nrows) + +double inmatrix[nbands,ARB] # input matrix +double outmatrix[nbands,ARB] # output matrix +double constant # damping constant +int nbands, nrows # dimensions of matrix + +int i + +begin + do i = 1, nrows + outmatrix[1,i] = inmatrix[1,i] * constant +end diff --git a/math/nlfit/nlchomatr.x b/math/nlfit/nlchomatr.x new file mode 100644 index 00000000..09f3a7b3 --- /dev/null +++ b/math/nlfit/nlchomatr.x @@ -0,0 +1,126 @@ +include +include +include "nlfitdefr.h" + + +# NL_CHFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure nl_chfacr (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +real matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +real ratio + +begin + # Test for a single element matrix. + if (nrows == 1) { + if (matrix[1,1] > real (0.0)) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # Copy the original matrix into matfac. + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + # Compute the factorization of the matrix. + do n = 1, nrows { + + # Test to see if matrix is singular. + if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= EPSILONR) { + #if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= PIXEL(0.0)) { + do j = 1, nbands + matfac[j,n] = real (0.0) + ier = SINGULAR + next + } + + matfac[1,n] = real (1.0) / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# NL_CHSLV -- Solve the matrix whose Cholesky factorization was calculated in +# NL_CHFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure nl_chslvr (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +real vector[nrows] # right side of matrix equation +real coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + # Test for a single element matrix. + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # Copy input vector to coefficients vector. + do i = 1, nrows + coeff[i] = vector[i] + + # Perform forward substitution. + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # Perform backward substitution. + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end + + +# NL_DAMP -- Procedure to add damping to matrix + +procedure nl_dampr (inmatrix, outmatrix, constant, nbands, nrows) + +real inmatrix[nbands,ARB] # input matrix +real outmatrix[nbands,ARB] # output matrix +real constant # damping constant +int nbands, nrows # dimensions of matrix + +int i + +begin + do i = 1, nrows + outmatrix[1,i] = inmatrix[1,i] * constant +end diff --git a/math/nlfit/nldump.gx b/math/nlfit/nldump.gx new file mode 100644 index 00000000..aa5899bd --- /dev/null +++ b/math/nlfit/nldump.gx @@ -0,0 +1,164 @@ +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NL_DUMP -- Dump NLFIT structure to a file + +procedure nl_dump$t (fd, nl) + +int fd # file descriptor +pointer nl # NLFIT descriptor + +int i, npars, nfpars + +begin + # Test NLFIT pointer + if (nl == NULL) { + call fprintf (fd, "\n****** nl_dump: Null NLFIT pointer\n") + call flush (fd) + return + } + + # File and NLFIT descriptors + call fprintf (fd, "\n****** nl_dump: (fd=%d), (nl=%d)\n") + call pargi (fd) + call pargi (nl) + call flush (fd) + + # Dump function and derivative addresses + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (NL_FUNC (nl)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (NL_DFUNC (nl)) + call flush (fd) + + # Number of parameters + npars = NL_NPARAMS (nl) + nfpars = NL_NFPARAMS (nl) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call flush (fd) + + # Fit parameters + call fprintf (fd, "Max number of iterations = %d\n") + call pargi (NL_ITMAX (nl)) + call fprintf (fd, "Tolerance for convergence = %g\n") + call parg$t (NL_TOL (nl)) + call flush (fd) + + # Sums + call fprintf (fd, "Damping factor = %g\n") + call parg$t (NL_LAMBDA (nl)) + call fprintf (fd, "Sum of residuals squared last iteration = %g\n") + call parg$t (NL_OLDSQ (nl)) + call fprintf (fd, "Sum of residuals squared = %g\n") + call parg$t (NL_SUMSQ (nl)) + call flush (fd) + + # Counters + call fprintf (fd, "Iteration counter = %d\n") + call pargi (NL_ITER (nl)) + call fprintf (fd, "Number of points in fit = %d\n") + call pargi (NL_NPTS (nl)) + call flush (fd) + + # Parameter values + call fprintf (fd, "Parameter values (%d):\n") + call pargi (NL_PARAM (nl)) + if (NL_PARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t[NL_PARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter errors + call fprintf (fd, "Parameter errors (%d):\n") + call pargi (NL_DPARAM (nl)) + if (NL_DPARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call parg$t (Mem$t[NL_DPARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter list + call fprintf (fd, "Parameter list (%d):\n") + call pargi (NL_PLIST (nl)) + if (NL_PLIST (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[NL_PLIST (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Alpha matrix + call fprintf (fd, "Alpha matrix (%d):\n") + call pargi (NL_ALPHA (nl)) + if (NL_ALPHA (nl) != NULL) + call nl_adump$t (fd, Mem$t[NL_ALPHA (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Beta matrix + call fprintf (fd, "Beta matrix (%d):\n") + call pargi (NL_BETA (nl)) + if (NL_BETA (nl) != NULL) + call nl_adump$t (fd, Mem$t[NL_BETA (nl)], nfpars, 1) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Covariance matrix + call fprintf (fd, "Covariance matrix (%d):\n") + call pargi (NL_COVAR (nl)) + if (NL_COVAR (nl) != NULL) + call nl_adump$t (fd, Mem$t[NL_COVAR (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Cholesky factorization + call fprintf (fd, "Cholesky factorization matrix (%d):\n") + call pargi (NL_CHOFAC (nl)) + if (NL_CHOFAC (nl) != NULL) + call nl_adump$t (fd, Mem$t[NL_CHOFAC (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) +end + + +# NL_ADUMP -- Dump array to file + +procedure nl_adump$t (fd, a, nrows, ncols) + +int fd # file descriptor +PIXEL a[nrows, ncols] # array +int nrows, ncols # dimension + +int i, j + +begin + do i = 1, nrows { + do j = 1, ncols { + call fprintf (fd, "%g ") + call parg$t (a[i, j]) + } + call fprintf (fd, "\n") + } +end diff --git a/math/nlfit/nldumpd.x b/math/nlfit/nldumpd.x new file mode 100644 index 00000000..f4c31d7d --- /dev/null +++ b/math/nlfit/nldumpd.x @@ -0,0 +1,160 @@ +include "nlfitdefd.h" + +# NL_DUMP -- Dump NLFIT structure to a file + +procedure nl_dumpd (fd, nl) + +int fd # file descriptor +pointer nl # NLFIT descriptor + +int i, npars, nfpars + +begin + # Test NLFIT pointer + if (nl == NULL) { + call fprintf (fd, "\n****** nl_dump: Null NLFIT pointer\n") + call flush (fd) + return + } + + # File and NLFIT descriptors + call fprintf (fd, "\n****** nl_dump: (fd=%d), (nl=%d)\n") + call pargi (fd) + call pargi (nl) + call flush (fd) + + # Dump function and derivative addresses + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (NL_FUNC (nl)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (NL_DFUNC (nl)) + call flush (fd) + + # Number of parameters + npars = NL_NPARAMS (nl) + nfpars = NL_NFPARAMS (nl) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call flush (fd) + + # Fit parameters + call fprintf (fd, "Max number of iterations = %d\n") + call pargi (NL_ITMAX (nl)) + call fprintf (fd, "Tolerance for convergence = %g\n") + call pargd (NL_TOL (nl)) + call flush (fd) + + # Sums + call fprintf (fd, "Damping factor = %g\n") + call pargd (NL_LAMBDA (nl)) + call fprintf (fd, "Sum of residuals squared last iteration = %g\n") + call pargd (NL_OLDSQ (nl)) + call fprintf (fd, "Sum of residuals squared = %g\n") + call pargd (NL_SUMSQ (nl)) + call flush (fd) + + # Counters + call fprintf (fd, "Iteration counter = %d\n") + call pargi (NL_ITER (nl)) + call fprintf (fd, "Number of points in fit = %d\n") + call pargi (NL_NPTS (nl)) + call flush (fd) + + # Parameter values + call fprintf (fd, "Parameter values (%d):\n") + call pargi (NL_PARAM (nl)) + if (NL_PARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd[NL_PARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter errors + call fprintf (fd, "Parameter errors (%d):\n") + call pargi (NL_DPARAM (nl)) + if (NL_DPARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargd (Memd[NL_DPARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter list + call fprintf (fd, "Parameter list (%d):\n") + call pargi (NL_PLIST (nl)) + if (NL_PLIST (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[NL_PLIST (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Alpha matrix + call fprintf (fd, "Alpha matrix (%d):\n") + call pargi (NL_ALPHA (nl)) + if (NL_ALPHA (nl) != NULL) + call nl_adumpd (fd, Memd[NL_ALPHA (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Beta matrix + call fprintf (fd, "Beta matrix (%d):\n") + call pargi (NL_BETA (nl)) + if (NL_BETA (nl) != NULL) + call nl_adumpd (fd, Memd[NL_BETA (nl)], nfpars, 1) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Covariance matrix + call fprintf (fd, "Covariance matrix (%d):\n") + call pargi (NL_COVAR (nl)) + if (NL_COVAR (nl) != NULL) + call nl_adumpd (fd, Memd[NL_COVAR (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Cholesky factorization + call fprintf (fd, "Cholesky factorization matrix (%d):\n") + call pargi (NL_CHOFAC (nl)) + if (NL_CHOFAC (nl) != NULL) + call nl_adumpd (fd, Memd[NL_CHOFAC (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) +end + + +# NL_ADUMP -- Dump array to file + +procedure nl_adumpd (fd, a, nrows, ncols) + +int fd # file descriptor +double a[nrows, ncols] # array +int nrows, ncols # dimension + +int i, j + +begin + do i = 1, nrows { + do j = 1, ncols { + call fprintf (fd, "%g ") + call pargd (a[i, j]) + } + call fprintf (fd, "\n") + } +end diff --git a/math/nlfit/nldumpr.x b/math/nlfit/nldumpr.x new file mode 100644 index 00000000..a81c6366 --- /dev/null +++ b/math/nlfit/nldumpr.x @@ -0,0 +1,160 @@ +include "nlfitdefr.h" + +# NL_DUMP -- Dump NLFIT structure to a file + +procedure nl_dumpr (fd, nl) + +int fd # file descriptor +pointer nl # NLFIT descriptor + +int i, npars, nfpars + +begin + # Test NLFIT pointer + if (nl == NULL) { + call fprintf (fd, "\n****** nl_dump: Null NLFIT pointer\n") + call flush (fd) + return + } + + # File and NLFIT descriptors + call fprintf (fd, "\n****** nl_dump: (fd=%d), (nl=%d)\n") + call pargi (fd) + call pargi (nl) + call flush (fd) + + # Dump function and derivative addresses + call fprintf (fd, "Fitting function pointer = %d\n") + call pargi (NL_FUNC (nl)) + call fprintf (fd, "Derivative function pointer = %d\n") + call pargi (NL_DFUNC (nl)) + call flush (fd) + + # Number of parameters + npars = NL_NPARAMS (nl) + nfpars = NL_NFPARAMS (nl) + call fprintf (fd, "Number of parameters = %d\n") + call pargi (npars) + call fprintf (fd, "Number of fitted parameters = %d\n") + call pargi (nfpars) + call flush (fd) + + # Fit parameters + call fprintf (fd, "Max number of iterations = %d\n") + call pargi (NL_ITMAX (nl)) + call fprintf (fd, "Tolerance for convergence = %g\n") + call pargr (NL_TOL (nl)) + call flush (fd) + + # Sums + call fprintf (fd, "Damping factor = %g\n") + call pargr (NL_LAMBDA (nl)) + call fprintf (fd, "Sum of residuals squared last iteration = %g\n") + call pargr (NL_OLDSQ (nl)) + call fprintf (fd, "Sum of residuals squared = %g\n") + call pargr (NL_SUMSQ (nl)) + call flush (fd) + + # Counters + call fprintf (fd, "Iteration counter = %d\n") + call pargi (NL_ITER (nl)) + call fprintf (fd, "Number of points in fit = %d\n") + call pargi (NL_NPTS (nl)) + call flush (fd) + + # Parameter values + call fprintf (fd, "Parameter values (%d):\n") + call pargi (NL_PARAM (nl)) + if (NL_PARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr[NL_PARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter errors + call fprintf (fd, "Parameter errors (%d):\n") + call pargi (NL_DPARAM (nl)) + if (NL_DPARAM (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %g\n") + call pargi (i) + call pargr (Memr[NL_DPARAM (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Parameter list + call fprintf (fd, "Parameter list (%d):\n") + call pargi (NL_PLIST (nl)) + if (NL_PLIST (nl) != NULL) { + do i = 1, npars { + call fprintf (fd, "%d -> %d\n") + call pargi (i) + call pargi (Memi[NL_PLIST (nl) + i - 1]) + } + } else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Alpha matrix + call fprintf (fd, "Alpha matrix (%d):\n") + call pargi (NL_ALPHA (nl)) + if (NL_ALPHA (nl) != NULL) + call nl_adumpr (fd, Memr[NL_ALPHA (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Beta matrix + call fprintf (fd, "Beta matrix (%d):\n") + call pargi (NL_BETA (nl)) + if (NL_BETA (nl) != NULL) + call nl_adumpr (fd, Memr[NL_BETA (nl)], nfpars, 1) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Covariance matrix + call fprintf (fd, "Covariance matrix (%d):\n") + call pargi (NL_COVAR (nl)) + if (NL_COVAR (nl) != NULL) + call nl_adumpr (fd, Memr[NL_COVAR (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) + + # Cholesky factorization + call fprintf (fd, "Cholesky factorization matrix (%d):\n") + call pargi (NL_CHOFAC (nl)) + if (NL_CHOFAC (nl) != NULL) + call nl_adumpr (fd, Memr[NL_CHOFAC (nl)], nfpars, nfpars) + else + call fprintf (fd, " Null pointer\n") + call flush (fd) +end + + +# NL_ADUMP -- Dump array to file + +procedure nl_adumpr (fd, a, nrows, ncols) + +int fd # file descriptor +real a[nrows, ncols] # array +int nrows, ncols # dimension + +int i, j + +begin + do i = 1, nrows { + do j = 1, ncols { + call fprintf (fd, "%g ") + call pargr (a[i, j]) + } + call fprintf (fd, "\n") + } +end diff --git a/math/nlfit/nlerrmsg.x b/math/nlfit/nlerrmsg.x new file mode 100644 index 00000000..e2b04b73 --- /dev/null +++ b/math/nlfit/nlerrmsg.x @@ -0,0 +1,24 @@ +include + +# NLERRMSG -- Convert NLFIT error code into an error message. + +procedure nlerrmsg (ier, errmsg, maxch) + +int ier # NLFIT error code +char errmsg[maxch] # output error message +int maxch # maximum number of chars + +begin + switch (ier) { + case DONE: + call strcpy ("Solution converged", errmsg, maxch) + case SINGULAR: + call strcpy ("Singular matrix", errmsg, maxch) + case NO_DEG_FREEDOM: + call strcpy ("Too few points", errmsg, maxch) + case NOT_DONE: + call strcpy ("Solution did not converge", errmsg, maxch) + default: + call strcpy ("Unknown error code", errmsg, maxch) + } +end diff --git a/math/nlfit/nlerrors.gx b/math/nlfit/nlerrors.gx new file mode 100644 index 00000000..061d2214 --- /dev/null +++ b/math/nlfit/nlerrors.gx @@ -0,0 +1,111 @@ +include +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +define COV Mem$t[P2P($1)] # element of COV + + +# NLERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the errors of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure nlerrors$t (nl, z, zfit, w, npts, variance, chisqr, errors) + +pointer nl # curve descriptor +PIXEL z[ARB] # data points +PIXEL zfit[ARB] # fitted data points +PIXEL w[ARB] # array of weights +int npts # number of points +PIXEL variance # variance of the fit +PIXEL chisqr # reduced chi-squared of fit (output) +PIXEL errors[ARB] # errors in coefficients (output) + +int i, n, nfree +pointer sp, covptr +PIXEL factor + +begin + # Allocate space for covariance vector. + call smark (sp) + call salloc (covptr, NL_NPARAMS(nl), TY_PIXEL) + + # Estimate the variance and reduce chi-squared of the fit. + n = 0 + variance = PIXEL (0.0) + chisqr = PIXEL (0.0) + do i = 1, npts { + if (w[i] <= PIXEL (0.0)) + next + factor = (z[i] - zfit[i]) ** 2 + variance = variance + factor + chisqr = chisqr + factor * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - NL_NFPARAMS(nl) + if (nfree > 0) { + variance = variance / nfree + chisqr = chisqr / nfree + } else { + variance = PIXEL (0.0) + chisqr = PIXEL (0.0) + } + + # If the variance equals the reduced chi_squared as in the case + # of uniform weights then scale the errors in the coefficients + # by the variance and not the reduced chi-squared + + if (abs (chisqr - variance) <= EPSILON$T) { + if (nfree > 0) + factor = chisqr + else + factor = PIXEL (0.0) + } else + factor = 1. + + # Calculate the errors in the coefficients. + call aclr$t (errors, NL_NPARAMS(nl)) + call nlinvert$t (ALPHA(NL_ALPHA(nl)), CHOFAC(NL_CHOFAC(nl)), + COV(covptr), errors, PLIST(NL_PLIST(nl)), NL_NFPARAMS(nl), factor) + + call sfree (sp) +end + + +# NLINVERT -- Procedure to invert matrix and compute errors + +procedure nlinvert$t (alpha, chofac, cov, errors, list, nfit, variance) + +PIXEL alpha[nfit,ARB] # data matrix +PIXEL chofac[nfit, ARB] # cholesky factorization +PIXEL cov[ARB] # covariance vector +PIXEL errors[ARB] # computed errors +int list[ARB] # list of active parameters +int nfit # number of fitted parameters +PIXEL variance # variance of the fit + +int i, ier + +begin + # Factorize the data matrix to determine the errors. + call nl_chfac$t (alpha, nfit, nfit, chofac, ier) + + # Estimate the errors. + do i = 1, nfit { + call aclr$t (cov, nfit) + cov[i] = PIXEL (1.0) + call nl_chslv$t (chofac, nfit, nfit, cov, cov) + if (cov[i] >= PIXEL (0.0)) + errors[list[i]] = sqrt (cov[i] * variance) + else + errors[list[i]] = PIXEL (0.0) + } +end diff --git a/math/nlfit/nlerrorsd.x b/math/nlfit/nlerrorsd.x new file mode 100644 index 00000000..b23a7b36 --- /dev/null +++ b/math/nlfit/nlerrorsd.x @@ -0,0 +1,107 @@ +include +include +include "nlfitdefd.h" + +define COV Memd[P2P($1)] # element of COV + + +# NLERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the errors of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure nlerrorsd (nl, z, zfit, w, npts, variance, chisqr, errors) + +pointer nl # curve descriptor +double z[ARB] # data points +double zfit[ARB] # fitted data points +double w[ARB] # array of weights +int npts # number of points +double variance # variance of the fit +double chisqr # reduced chi-squared of fit (output) +double errors[ARB] # errors in coefficients (output) + +int i, n, nfree +pointer sp, covptr +double factor + +begin + # Allocate space for covariance vector. + call smark (sp) + call salloc (covptr, NL_NPARAMS(nl), TY_DOUBLE) + + # Estimate the variance and reduce chi-squared of the fit. + n = 0 + variance = double (0.0) + chisqr = double (0.0) + do i = 1, npts { + if (w[i] <= double (0.0)) + next + factor = (z[i] - zfit[i]) ** 2 + variance = variance + factor + chisqr = chisqr + factor * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - NL_NFPARAMS(nl) + if (nfree > 0) { + variance = variance / nfree + chisqr = chisqr / nfree + } else { + variance = double (0.0) + chisqr = double (0.0) + } + + # If the variance equals the reduced chi_squared as in the case + # of uniform weights then scale the errors in the coefficients + # by the variance and not the reduced chi-squared + + if (abs (chisqr - variance) <= EPSILOND) { + if (nfree > 0) + factor = chisqr + else + factor = double (0.0) + } else + factor = 1. + + # Calculate the errors in the coefficients. + call aclrd (errors, NL_NPARAMS(nl)) + call nlinvertd (ALPHA(NL_ALPHA(nl)), CHOFAC(NL_CHOFAC(nl)), + COV(covptr), errors, PLIST(NL_PLIST(nl)), NL_NFPARAMS(nl), factor) + + call sfree (sp) +end + + +# NLINVERT -- Procedure to invert matrix and compute errors + +procedure nlinvertd (alpha, chofac, cov, errors, list, nfit, variance) + +double alpha[nfit,ARB] # data matrix +double chofac[nfit, ARB] # cholesky factorization +double cov[ARB] # covariance vector +double errors[ARB] # computed errors +int list[ARB] # list of active parameters +int nfit # number of fitted parameters +double variance # variance of the fit + +int i, ier + +begin + # Factorize the data matrix to determine the errors. + call nl_chfacd (alpha, nfit, nfit, chofac, ier) + + # Estimate the errors. + do i = 1, nfit { + call aclrd (cov, nfit) + cov[i] = double (1.0) + call nl_chslvd (chofac, nfit, nfit, cov, cov) + if (cov[i] >= double (0.0)) + errors[list[i]] = sqrt (cov[i] * variance) + else + errors[list[i]] = double (0.0) + } +end diff --git a/math/nlfit/nlerrorsr.x b/math/nlfit/nlerrorsr.x new file mode 100644 index 00000000..40057b9c --- /dev/null +++ b/math/nlfit/nlerrorsr.x @@ -0,0 +1,107 @@ +include +include +include "nlfitdefr.h" + +define COV Memr[P2P($1)] # element of COV + + +# NLERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the errors of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure nlerrorsr (nl, z, zfit, w, npts, variance, chisqr, errors) + +pointer nl # curve descriptor +real z[ARB] # data points +real zfit[ARB] # fitted data points +real w[ARB] # array of weights +int npts # number of points +real variance # variance of the fit +real chisqr # reduced chi-squared of fit (output) +real errors[ARB] # errors in coefficients (output) + +int i, n, nfree +pointer sp, covptr +real factor + +begin + # Allocate space for covariance vector. + call smark (sp) + call salloc (covptr, NL_NPARAMS(nl), TY_REAL) + + # Estimate the variance and reduce chi-squared of the fit. + n = 0 + variance = real (0.0) + chisqr = real (0.0) + do i = 1, npts { + if (w[i] <= real (0.0)) + next + factor = (z[i] - zfit[i]) ** 2 + variance = variance + factor + chisqr = chisqr + factor * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - NL_NFPARAMS(nl) + if (nfree > 0) { + variance = variance / nfree + chisqr = chisqr / nfree + } else { + variance = real (0.0) + chisqr = real (0.0) + } + + # If the variance equals the reduced chi_squared as in the case + # of uniform weights then scale the errors in the coefficients + # by the variance and not the reduced chi-squared + + if (abs (chisqr - variance) <= EPSILONR) { + if (nfree > 0) + factor = chisqr + else + factor = real (0.0) + } else + factor = 1. + + # Calculate the errors in the coefficients. + call aclrr (errors, NL_NPARAMS(nl)) + call nlinvertr (ALPHA(NL_ALPHA(nl)), CHOFAC(NL_CHOFAC(nl)), + COV(covptr), errors, PLIST(NL_PLIST(nl)), NL_NFPARAMS(nl), factor) + + call sfree (sp) +end + + +# NLINVERT -- Procedure to invert matrix and compute errors + +procedure nlinvertr (alpha, chofac, cov, errors, list, nfit, variance) + +real alpha[nfit,ARB] # data matrix +real chofac[nfit, ARB] # cholesky factorization +real cov[ARB] # covariance vector +real errors[ARB] # computed errors +int list[ARB] # list of active parameters +int nfit # number of fitted parameters +real variance # variance of the fit + +int i, ier + +begin + # Factorize the data matrix to determine the errors. + call nl_chfacr (alpha, nfit, nfit, chofac, ier) + + # Estimate the errors. + do i = 1, nfit { + call aclrr (cov, nfit) + cov[i] = real (1.0) + call nl_chslvr (chofac, nfit, nfit, cov, cov) + if (cov[i] >= real (0.0)) + errors[list[i]] = sqrt (cov[i] * variance) + else + errors[list[i]] = real (0.0) + } +end diff --git a/math/nlfit/nleval.gx b/math/nlfit/nleval.gx new file mode 100644 index 00000000..e116982b --- /dev/null +++ b/math/nlfit/nleval.gx @@ -0,0 +1,25 @@ +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + + +# NLEVAL -- Evaluate the fit at a point. + +PIXEL procedure nleval$t (nl, x, nvars) + +pointer nl # nlfit descriptor +PIXEL x[ARB] # x values +int nvars # number of variables + +real zfit + +begin + # Evaluate the function. + call zcall5 (NL_FUNC(nl), x, nvars, PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl), zfit) + + return (zfit) +end diff --git a/math/nlfit/nlevald.x b/math/nlfit/nlevald.x new file mode 100644 index 00000000..c7710acc --- /dev/null +++ b/math/nlfit/nlevald.x @@ -0,0 +1,21 @@ +include +include "nlfitdefd.h" + + +# NLEVAL -- Evaluate the fit at a point. + +double procedure nlevald (nl, x, nvars) + +pointer nl # nlfit descriptor +double x[ARB] # x values +int nvars # number of variables + +real zfit + +begin + # Evaluate the function. + call zcall5 (NL_FUNC(nl), x, nvars, PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl), zfit) + + return (zfit) +end diff --git a/math/nlfit/nlevalr.x b/math/nlfit/nlevalr.x new file mode 100644 index 00000000..4c68d865 --- /dev/null +++ b/math/nlfit/nlevalr.x @@ -0,0 +1,21 @@ +include +include "nlfitdefr.h" + + +# NLEVAL -- Evaluate the fit at a point. + +real procedure nlevalr (nl, x, nvars) + +pointer nl # nlfit descriptor +real x[ARB] # x values +int nvars # number of variables + +real zfit + +begin + # Evaluate the function. + call zcall5 (NL_FUNC(nl), x, nvars, PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl), zfit) + + return (zfit) +end diff --git a/math/nlfit/nlfit.gx b/math/nlfit/nlfit.gx new file mode 100644 index 00000000..50dc0b21 --- /dev/null +++ b/math/nlfit/nlfit.gx @@ -0,0 +1,171 @@ +include +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLFIT -- Routine to perform a non-linear least squares fit. At least MINITER +# iterations must be performed before the fit is complete. + +procedure nlfit$t (nl, x, z, w, npts, nvars, wtflag, stat) + +pointer nl # pointer to nlfit structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL z[ARB] # function values (npts) +PIXEL w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int wtflag # weighting type +int stat # error code + +int i, miniter, ier +PIXEL scatter, dscatter +PIXEL nlscatter$t() + +begin + # Initialize. + NL_ITER(nl) = 0 + NL_LAMBDA(nl) = PIXEL (.001) + NL_REFSQ(nl) = PIXEL (0.0) + NL_SCATTER(nl) = PIXEL(0.0) + + # Initialize the weights. + switch (wtflag) { + case WTS_UNIFORM: + do i = 1, npts + w[i] = PIXEL (1.0) + case WTS_SCATTER: + ; + case WTS_USER: + ; + case WTS_CHISQ: + do i = 1, npts { + if (z[i] > PIXEL (0.0)) + w[i] = PIXEL (1.0) / z[i] + else if (z[i] < PIXEL (0.0)) + w[i] = PIXEL (-1.0) / z[i] + else + w[i] = PIXEL (0.0) + } + default: + do i = 1, npts + w[i] = PIXEL (1.0) + } + + # Initialize. + scatter = PIXEL(0.0) + if (wtflag == WTS_SCATTER) + miniter = MINITER + 1 + else + miniter = MINITER + + repeat { + + # Perform a single iteration. + call nliter$t (nl, x, z, w, npts, nvars, ier) + NL_ITER(nl) = NL_ITER(nl) + 1 + #call eprintf ("niter=%d refsq=%g oldsq=%g sumsq=%g\n") + #call pargi (NL_ITER(nl)) + #call parg$t (NL_REFSQ(nl)) + #call parg$t (NL_OLDSQ(nl)) + #call parg$t (NL_SUMSQ(nl)) + stat = ier + if (stat == NO_DEG_FREEDOM) + break + + # Make the convergence checks. + if (NL_ITER(nl) < miniter) + stat = NOT_DONE + else if (NL_SUMSQ(nl) <= PIXEL (10.0) * EPSILON$T) + stat = DONE + else if (NL_REFSQ(nl) < NL_SUMSQ(nl)) + stat = NOT_DONE + else if (((NL_REFSQ(nl) - NL_SUMSQ(nl)) / NL_SUMSQ(nl)) < + NL_TOL(nl)) + stat = DONE + else + stat = NOT_DONE + + # Check for a singular solution. + if (stat == DONE) { + if (ier == SINGULAR) + stat = ier + break + } + + # Quit if the lambda parameter goes to zero. + if (NL_LAMBDA(nl) <= 0.0) + break + + # Check the number of iterations. + if ((NL_ITER(nl) >= miniter) && (NL_ITER(nl) >= NL_ITMAX(nl))) + break + + # Adjust the weights if necessary. + switch (wtflag) { + case WTS_SCATTER: + dscatter = nlscatter$t (nl, x, z, w, npts, nvars) + if ((NL_ITER(nl) >= MINITER) && (dscatter >= PIXEL (10.0) * + EPSILON$T)) { + do i = 1, npts { + if (w[i] <= PIXEL(0.0)) + w[i] = PIXEL(0.0) + else { + w[i] = PIXEL(1.0) / (PIXEL(1.0) / w[i] + dscatter) + } + } + scatter = scatter + dscatter + } + default: + ; + } + + # Get ready for next iteration. + NL_REFSQ(nl) = min (NL_OLDSQ(nl), NL_SUMSQ(nl)) + } + + NL_SCATTER(nl) = NL_SCATTER(nl) + scatter +end + + +# NLSCATTER -- Routine to estimate the original scatter in the fit. + +PIXEL procedure nlscatter$t (nl, x, z, w, npts, nvars) + +pointer nl # Pointer to nl fitting structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL z[ARB] # function values (npts) +PIXEL w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +pointer sp, zfit, errors +PIXEL scatter, variance, chisqr +int nlstati() + +begin + # Allocate working memory. + call smark (sp) + call salloc (zfit, npts, TY_PIXEL) + call salloc (errors, nlstati (nl, NLNPARAMS), TY_PIXEL) + + # Initialize + scatter = PIXEL (0.0) + + # Compute the fit and the errors. + call nlvector$t (nl, x, Mem$t[zfit], npts, nvars) + call nlerrors$t (nl, z, Mem$t[zfit], w, npts, variance, chisqr, + Mem$t[errors]) + + # Estimate the scatter. + if (chisqr <= PIXEL(0.0) || variance <= PIXEL(0.0)) + scatter = PIXEL (0.0) + else + scatter = PIXEL(0.5) * variance * (chisqr - PIXEL(1.0)) / chisqr + + call sfree (sp) + + return (scatter) +end diff --git a/math/nlfit/nlfitd.x b/math/nlfit/nlfitd.x new file mode 100644 index 00000000..975284ab --- /dev/null +++ b/math/nlfit/nlfitd.x @@ -0,0 +1,167 @@ +include +include +include "nlfitdefd.h" + +# NLFIT -- Routine to perform a non-linear least squares fit. At least MINITER +# iterations must be performed before the fit is complete. + +procedure nlfitd (nl, x, z, w, npts, nvars, wtflag, stat) + +pointer nl # pointer to nlfit structure +double x[ARB] # independent variables (npts * nvars) +double z[ARB] # function values (npts) +double w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int wtflag # weighting type +int stat # error code + +int i, miniter, ier +double scatter, dscatter +double nlscatterd() + +begin + # Initialize. + NL_ITER(nl) = 0 + NL_LAMBDA(nl) = double (.001) + NL_REFSQ(nl) = double (0.0) + NL_SCATTER(nl) = double(0.0) + + # Initialize the weights. + switch (wtflag) { + case WTS_UNIFORM: + do i = 1, npts + w[i] = double (1.0) + case WTS_SCATTER: + ; + case WTS_USER: + ; + case WTS_CHISQ: + do i = 1, npts { + if (z[i] > double (0.0)) + w[i] = double (1.0) / z[i] + else if (z[i] < double (0.0)) + w[i] = double (-1.0) / z[i] + else + w[i] = double (0.0) + } + default: + do i = 1, npts + w[i] = double (1.0) + } + + # Initialize. + scatter = double(0.0) + if (wtflag == WTS_SCATTER) + miniter = MINITER + 1 + else + miniter = MINITER + + repeat { + + # Perform a single iteration. + call nliterd (nl, x, z, w, npts, nvars, ier) + NL_ITER(nl) = NL_ITER(nl) + 1 + #call eprintf ("niter=%d refsq=%g oldsq=%g sumsq=%g\n") + #call pargi (NL_ITER(nl)) + #call parg$t (NL_REFSQ(nl)) + #call parg$t (NL_OLDSQ(nl)) + #call parg$t (NL_SUMSQ(nl)) + stat = ier + if (stat == NO_DEG_FREEDOM) + break + + # Make the convergence checks. + if (NL_ITER(nl) < miniter) + stat = NOT_DONE + else if (NL_SUMSQ(nl) <= double (10.0) * EPSILOND) + stat = DONE + else if (NL_REFSQ(nl) < NL_SUMSQ(nl)) + stat = NOT_DONE + else if (((NL_REFSQ(nl) - NL_SUMSQ(nl)) / NL_SUMSQ(nl)) < + NL_TOL(nl)) + stat = DONE + else + stat = NOT_DONE + + # Check for a singular solution. + if (stat == DONE) { + if (ier == SINGULAR) + stat = ier + break + } + + # Quit if the lambda parameter goes to zero. + if (NL_LAMBDA(nl) <= 0.0) + break + + # Check the number of iterations. + if ((NL_ITER(nl) >= miniter) && (NL_ITER(nl) >= NL_ITMAX(nl))) + break + + # Adjust the weights if necessary. + switch (wtflag) { + case WTS_SCATTER: + dscatter = nlscatterd (nl, x, z, w, npts, nvars) + if ((NL_ITER(nl) >= MINITER) && (dscatter >= double (10.0) * + EPSILOND)) { + do i = 1, npts { + if (w[i] <= double(0.0)) + w[i] = double(0.0) + else { + w[i] = double(1.0) / (double(1.0) / w[i] + dscatter) + } + } + scatter = scatter + dscatter + } + default: + ; + } + + # Get ready for next iteration. + NL_REFSQ(nl) = min (NL_OLDSQ(nl), NL_SUMSQ(nl)) + } + + NL_SCATTER(nl) = NL_SCATTER(nl) + scatter +end + + +# NLSCATTER -- Routine to estimate the original scatter in the fit. + +double procedure nlscatterd (nl, x, z, w, npts, nvars) + +pointer nl # Pointer to nl fitting structure +double x[ARB] # independent variables (npts * nvars) +double z[ARB] # function values (npts) +double w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +pointer sp, zfit, errors +double scatter, variance, chisqr +int nlstati() + +begin + # Allocate working memory. + call smark (sp) + call salloc (zfit, npts, TY_DOUBLE) + call salloc (errors, nlstati (nl, NLNPARAMS), TY_DOUBLE) + + # Initialize + scatter = double (0.0) + + # Compute the fit and the errors. + call nlvectord (nl, x, Memd[zfit], npts, nvars) + call nlerrorsd (nl, z, Memd[zfit], w, npts, variance, chisqr, + Memd[errors]) + + # Estimate the scatter. + if (chisqr <= double(0.0) || variance <= double(0.0)) + scatter = double (0.0) + else + scatter = double(0.5) * variance * (chisqr - double(1.0)) / chisqr + + call sfree (sp) + + return (scatter) +end diff --git a/math/nlfit/nlfitdef.gh b/math/nlfit/nlfitdef.gh new file mode 100644 index 00000000..62a542a8 --- /dev/null +++ b/math/nlfit/nlfitdef.gh @@ -0,0 +1,51 @@ +# The NLFIT data structure. + +# Structure length +define LEN_NLSTRUCT 35 + + +# Structure definition +define NL_TOL Mem$t[P2$T($1+0)] # Tolerance for convergence +define NL_LAMBDA Mem$t[P2$T($1+2)] # Damping factor +define NL_OLDSQ Mem$t[P2$T($1+4)] # Sum resid. squared last iter. +define NL_SUMSQ Mem$t[P2$T($1+6)] # Sum of residuals squared +define NL_REFSQ Mem$t[P2$T($1+8)] # Reference sum of squares +define NL_SCATTER Mem$t[P2$T($1+10)] # Additional scatter + +define NL_FUNC Memi[$1+12] # Fitting function +define NL_DFUNC Memi[$1+13] # Derivative function +define NL_NPARAMS Memi[$1+14] # Number of parameters +define NL_NFPARAMS Memi[$1+15] # Number of fitted parameters +define NL_ITMAX Memi[$1+16] # Max number of iterations +define NL_ITER Memi[$1+17] # Iteration counter +define NL_NPTS Memi[$1+18] # Number of points in fit + +define NL_PARAM Memi[$1+19] # Pointer to parameter vector +define NL_OPARAM Memi[$1+20] # Pointer to orignal parameter vector +define NL_DPARAM Memi[$1+21] # Pointer to parameter change vector +define NL_DELPARAM Memi[$1+22] # Pointer to delta param vector +define NL_PLIST Memi[$1+23] # Pointer to parameter list +define NL_ALPHA Memi[$1+24] # Pointer to alpha matrix +define NL_COVAR Memi[$1+25] # Pointer to covariance matrix +define NL_BETA Memi[$1+26] # Pointer to beta matrix +define NL_TRY Memi[$1+27] # Pointer to trial vector +define NL_DERIV Memi[$1+28] # Pointer to derivatives +define NL_CHOFAC Memi[$1+29] # Pointer to Cholesky factorization + +# next free location ($1 + 30) + +# Access to buffers +define PLIST Memi[$1] # Parameter list +define OPARAM Mem$t[P2P($1)] # Original parameter vector +define PARAM Mem$t[P2P($1)] # Parameter vector +define DPARAM Mem$t[P2P($1)] # Parameter change vector +define ALPHA Mem$t[P2P($1)] # Alpha matrix +define BETA Mem$t[P2P($1)] # Beta matrix +define TRY Mem$t[P2P($1)] # Trial vector +define DERIV Mem$t[P2P($1)] # Derivatives +define CHOFAC Mem$t[P2P($1)] # Cholesky factorization +define COVAR Mem$t[P2P($1)] # Covariance matrix + +# Defined constants alter for tricky problems +define LAMBDAMAX 1000.0 +define MINITER 3 diff --git a/math/nlfit/nlfitdefd.h b/math/nlfit/nlfitdefd.h new file mode 100644 index 00000000..b5ed3bf3 --- /dev/null +++ b/math/nlfit/nlfitdefd.h @@ -0,0 +1,52 @@ +# The NLFIT data structure. + +# Structure length +define LEN_NLSTRUCT 35 + + +# Structure definition +define NL_TOL Memd[P2D($1+0)] # Tolerance for convergence +define NL_LAMBDA Memd[P2D($1+2)] # Damping factor +define NL_OLDSQ Memd[P2D($1+4)] # Sum resid. squared last iter. +define NL_SUMSQ Memd[P2D($1+6)] # Sum of residuals squared +define NL_REFSQ Memd[P2D($1+8)] # Reference sum of squares +define NL_SCATTER Memd[P2D($1+10)] # Additional scatter + +define NL_FUNC Memi[$1+12] # Fitting function +define NL_DFUNC Memi[$1+13] # Derivative function +define NL_NPARAMS Memi[$1+14] # Number of parameters +define NL_NFPARAMS Memi[$1+15] # Number of fitted parameters +define NL_ITMAX Memi[$1+16] # Max number of iterations +define NL_ITER Memi[$1+17] # Iteration counter +define NL_NPTS Memi[$1+18] # Number of points in fit + +define NL_PARAM Memi[$1+19] # Pointer to parameter vector +define NL_OPARAM Memi[$1+20] # Pointer to orignal parameter vector +define NL_DPARAM Memi[$1+21] # Pointer to parameter change vector +define NL_DELPARAM Memi[$1+22] # Pointer to delta param vector +define NL_PLIST Memi[$1+23] # Pointer to parameter list +define NL_ALPHA Memi[$1+24] # Pointer to alpha matrix +define NL_COVAR Memi[$1+25] # Pointer to covariance matrix +define NL_BETA Memi[$1+26] # Pointer to beta matrix +define NL_TRY Memi[$1+27] # Pointer to trial vector +define NL_DERIV Memi[$1+28] # Pointer to derivatives +define NL_CHOFAC Memi[$1+29] # Pointer to Cholesky factorization + +# next free location ($1 + 30) + +# Access to buffers +define PLIST Memi[$1] # Parameter list +define OPARAM Memd[$1] # Original parameter vector +define PARAM Memd[$1] # Parameter vector +define DPARAM Memd[$1] # Parameter change vector +define ALPHA Memd[$1] # Alpha matrix +define BETA Memd[$1] # Beta matrix +define TRY Memd[$1] # Trial vector +define DERIV Memd[$1] # Derivatives +define CHOFAC Memd[$1] # Cholesky factorization +define COVAR Memd[$1] # Covariance matrix + + +# Defined constants alter for tricky problems +define LAMBDAMAX 1000.0 +define MINITER 3 diff --git a/math/nlfit/nlfitdefr.h b/math/nlfit/nlfitdefr.h new file mode 100644 index 00000000..e3bf3ae0 --- /dev/null +++ b/math/nlfit/nlfitdefr.h @@ -0,0 +1,52 @@ +# The NLFIT data structure. + +# Structure length +define LEN_NLSTRUCT 35 + + +# Structure definition +define NL_TOL Memr[P2R($1+0)] # Tolerance for convergence +define NL_LAMBDA Memr[P2R($1+2)] # Damping factor +define NL_OLDSQ Memr[P2R($1+4)] # Sum resid. squared last iter. +define NL_SUMSQ Memr[P2R($1+6)] # Sum of residuals squared +define NL_REFSQ Memr[P2R($1+8)] # Reference sum of squares +define NL_SCATTER Memr[P2R($1+10)] # Additional scatter + +define NL_FUNC Memi[$1+12] # Fitting function +define NL_DFUNC Memi[$1+13] # Derivative function +define NL_NPARAMS Memi[$1+14] # Number of parameters +define NL_NFPARAMS Memi[$1+15] # Number of fitted parameters +define NL_ITMAX Memi[$1+16] # Max number of iterations +define NL_ITER Memi[$1+17] # Iteration counter +define NL_NPTS Memi[$1+18] # Number of points in fit + +define NL_PARAM Memi[$1+19] # Pointer to parameter vector +define NL_OPARAM Memi[$1+20] # Pointer to orignal parameter vector +define NL_DPARAM Memi[$1+21] # Pointer to parameter change vector +define NL_DELPARAM Memi[$1+22] # Pointer to delta param vector +define NL_PLIST Memi[$1+23] # Pointer to parameter list +define NL_ALPHA Memi[$1+24] # Pointer to alpha matrix +define NL_COVAR Memi[$1+25] # Pointer to covariance matrix +define NL_BETA Memi[$1+26] # Pointer to beta matrix +define NL_TRY Memi[$1+27] # Pointer to trial vector +define NL_DERIV Memi[$1+28] # Pointer to derivatives +define NL_CHOFAC Memi[$1+29] # Pointer to Cholesky factorization + +# next free location ($1 + 30) + +# Access to buffers +define PLIST Memi[$1] # Parameter list +define OPARAM Memr[$1] # Original parameter vector +define PARAM Memr[$1] # Parameter vector +define DPARAM Memr[$1] # Parameter change vector +define ALPHA Memr[$1] # Alpha matrix +define BETA Memr[$1] # Beta matrix +define TRY Memr[$1] # Trial vector +define DERIV Memr[$1] # Derivatives +define CHOFAC Memr[$1] # Cholesky factorization +define COVAR Memr[$1] # Covariance matrix + + +# Defined constants alter for tricky problems +define LAMBDAMAX 1000.0 +define MINITER 3 diff --git a/math/nlfit/nlfitr.x b/math/nlfit/nlfitr.x new file mode 100644 index 00000000..dc06b720 --- /dev/null +++ b/math/nlfit/nlfitr.x @@ -0,0 +1,167 @@ +include +include +include "nlfitdefr.h" + +# NLFIT -- Routine to perform a non-linear least squares fit. At least MINITER +# iterations must be performed before the fit is complete. + +procedure nlfitr (nl, x, z, w, npts, nvars, wtflag, stat) + +pointer nl # pointer to nlfit structure +real x[ARB] # independent variables (npts * nvars) +real z[ARB] # function values (npts) +real w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int wtflag # weighting type +int stat # error code + +int i, miniter, ier +real scatter, dscatter +real nlscatterr() + +begin + # Initialize. + NL_ITER(nl) = 0 + NL_LAMBDA(nl) = real (.001) + NL_REFSQ(nl) = real (0.0) + NL_SCATTER(nl) = real(0.0) + + # Initialize the weights. + switch (wtflag) { + case WTS_UNIFORM: + do i = 1, npts + w[i] = real (1.0) + case WTS_SCATTER: + ; + case WTS_USER: + ; + case WTS_CHISQ: + do i = 1, npts { + if (z[i] > real (0.0)) + w[i] = real (1.0) / z[i] + else if (z[i] < real (0.0)) + w[i] = real (-1.0) / z[i] + else + w[i] = real (0.0) + } + default: + do i = 1, npts + w[i] = real (1.0) + } + + # Initialize. + scatter = real(0.0) + if (wtflag == WTS_SCATTER) + miniter = MINITER + 1 + else + miniter = MINITER + + repeat { + + # Perform a single iteration. + call nliterr (nl, x, z, w, npts, nvars, ier) + NL_ITER(nl) = NL_ITER(nl) + 1 + #call eprintf ("niter=%d refsq=%g oldsq=%g sumsq=%g\n") + #call pargi (NL_ITER(nl)) + #call parg$t (NL_REFSQ(nl)) + #call parg$t (NL_OLDSQ(nl)) + #call parg$t (NL_SUMSQ(nl)) + stat = ier + if (stat == NO_DEG_FREEDOM) + break + + # Make the convergence checks. + if (NL_ITER(nl) < miniter) + stat = NOT_DONE + else if (NL_SUMSQ(nl) <= real (10.0) * EPSILONR) + stat = DONE + else if (NL_REFSQ(nl) < NL_SUMSQ(nl)) + stat = NOT_DONE + else if (((NL_REFSQ(nl) - NL_SUMSQ(nl)) / NL_SUMSQ(nl)) < + NL_TOL(nl)) + stat = DONE + else + stat = NOT_DONE + + # Check for a singular solution. + if (stat == DONE) { + if (ier == SINGULAR) + stat = ier + break + } + + # Quit if the lambda parameter goes to zero. + if (NL_LAMBDA(nl) <= 0.0) + break + + # Check the number of iterations. + if ((NL_ITER(nl) >= miniter) && (NL_ITER(nl) >= NL_ITMAX(nl))) + break + + # Adjust the weights if necessary. + switch (wtflag) { + case WTS_SCATTER: + dscatter = nlscatterr (nl, x, z, w, npts, nvars) + if ((NL_ITER(nl) >= MINITER) && (dscatter >= real (10.0) * + EPSILONR)) { + do i = 1, npts { + if (w[i] <= real(0.0)) + w[i] = real(0.0) + else { + w[i] = real(1.0) / (real(1.0) / w[i] + dscatter) + } + } + scatter = scatter + dscatter + } + default: + ; + } + + # Get ready for next iteration. + NL_REFSQ(nl) = min (NL_OLDSQ(nl), NL_SUMSQ(nl)) + } + + NL_SCATTER(nl) = NL_SCATTER(nl) + scatter +end + + +# NLSCATTER -- Routine to estimate the original scatter in the fit. + +real procedure nlscatterr (nl, x, z, w, npts, nvars) + +pointer nl # Pointer to nl fitting structure +real x[ARB] # independent variables (npts * nvars) +real z[ARB] # function values (npts) +real w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables + +pointer sp, zfit, errors +real scatter, variance, chisqr +int nlstati() + +begin + # Allocate working memory. + call smark (sp) + call salloc (zfit, npts, TY_REAL) + call salloc (errors, nlstati (nl, NLNPARAMS), TY_REAL) + + # Initialize + scatter = real (0.0) + + # Compute the fit and the errors. + call nlvectorr (nl, x, Memr[zfit], npts, nvars) + call nlerrorsr (nl, z, Memr[zfit], w, npts, variance, chisqr, + Memr[errors]) + + # Estimate the scatter. + if (chisqr <= real(0.0) || variance <= real(0.0)) + scatter = real (0.0) + else + scatter = real(0.5) * variance * (chisqr - real(1.0)) / chisqr + + call sfree (sp) + + return (scatter) +end diff --git a/math/nlfit/nlfree.gx b/math/nlfit/nlfree.gx new file mode 100644 index 00000000..507dce57 --- /dev/null +++ b/math/nlfit/nlfree.gx @@ -0,0 +1,41 @@ +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLFREE -- Deallocate all assigned space + +procedure nlfree$t (nl) + +pointer nl # pointer to non-linear fitting structure + +errchk mfree + +begin + if (nl == NULL) + return + if (NL_PARAM(nl) != NULL) + call mfree (NL_PARAM(nl), TY_PIXEL) + if (NL_OPARAM(nl) != NULL) + call mfree (NL_OPARAM(nl), TY_PIXEL) + if (NL_DPARAM(nl) != NULL) + call mfree (NL_DPARAM(nl), TY_PIXEL) + if (NL_DELPARAM(nl) != NULL) + call mfree (NL_DELPARAM(nl), TY_PIXEL) + if (NL_PLIST(nl) != NULL) + call mfree (NL_PLIST(nl), TY_INT) + if (NL_ALPHA(nl) != NULL) + call mfree (NL_ALPHA(nl), TY_PIXEL) + if (NL_CHOFAC(nl) != NULL) + call mfree (NL_CHOFAC(nl), TY_PIXEL) + if (NL_COVAR(nl) != NULL) + call mfree (NL_COVAR(nl), TY_PIXEL) + if (NL_BETA(nl) != NULL) + call mfree (NL_BETA(nl), TY_PIXEL) + if (NL_TRY(nl) != NULL) + call mfree (NL_TRY(nl), TY_PIXEL) + if (NL_DERIV(nl) != NULL) + call mfree (NL_DERIV(nl), TY_PIXEL) + call mfree (nl, TY_STRUCT) +end diff --git a/math/nlfit/nlfreed.x b/math/nlfit/nlfreed.x new file mode 100644 index 00000000..56bcda62 --- /dev/null +++ b/math/nlfit/nlfreed.x @@ -0,0 +1,37 @@ +include "nlfitdefd.h" + +# NLFREE -- Deallocate all assigned space + +procedure nlfreed (nl) + +pointer nl # pointer to non-linear fitting structure + +errchk mfree + +begin + if (nl == NULL) + return + if (NL_PARAM(nl) != NULL) + call mfree (NL_PARAM(nl), TY_DOUBLE) + if (NL_OPARAM(nl) != NULL) + call mfree (NL_OPARAM(nl), TY_DOUBLE) + if (NL_DPARAM(nl) != NULL) + call mfree (NL_DPARAM(nl), TY_DOUBLE) + if (NL_DELPARAM(nl) != NULL) + call mfree (NL_DELPARAM(nl), TY_DOUBLE) + if (NL_PLIST(nl) != NULL) + call mfree (NL_PLIST(nl), TY_INT) + if (NL_ALPHA(nl) != NULL) + call mfree (NL_ALPHA(nl), TY_DOUBLE) + if (NL_CHOFAC(nl) != NULL) + call mfree (NL_CHOFAC(nl), TY_DOUBLE) + if (NL_COVAR(nl) != NULL) + call mfree (NL_COVAR(nl), TY_DOUBLE) + if (NL_BETA(nl) != NULL) + call mfree (NL_BETA(nl), TY_DOUBLE) + if (NL_TRY(nl) != NULL) + call mfree (NL_TRY(nl), TY_DOUBLE) + if (NL_DERIV(nl) != NULL) + call mfree (NL_DERIV(nl), TY_DOUBLE) + call mfree (nl, TY_STRUCT) +end diff --git a/math/nlfit/nlfreer.x b/math/nlfit/nlfreer.x new file mode 100644 index 00000000..639c4ecc --- /dev/null +++ b/math/nlfit/nlfreer.x @@ -0,0 +1,37 @@ +include "nlfitdefr.h" + +# NLFREE -- Deallocate all assigned space + +procedure nlfreer (nl) + +pointer nl # pointer to non-linear fitting structure + +errchk mfree + +begin + if (nl == NULL) + return + if (NL_PARAM(nl) != NULL) + call mfree (NL_PARAM(nl), TY_REAL) + if (NL_OPARAM(nl) != NULL) + call mfree (NL_OPARAM(nl), TY_REAL) + if (NL_DPARAM(nl) != NULL) + call mfree (NL_DPARAM(nl), TY_REAL) + if (NL_DELPARAM(nl) != NULL) + call mfree (NL_DELPARAM(nl), TY_REAL) + if (NL_PLIST(nl) != NULL) + call mfree (NL_PLIST(nl), TY_INT) + if (NL_ALPHA(nl) != NULL) + call mfree (NL_ALPHA(nl), TY_REAL) + if (NL_CHOFAC(nl) != NULL) + call mfree (NL_CHOFAC(nl), TY_REAL) + if (NL_COVAR(nl) != NULL) + call mfree (NL_COVAR(nl), TY_REAL) + if (NL_BETA(nl) != NULL) + call mfree (NL_BETA(nl), TY_REAL) + if (NL_TRY(nl) != NULL) + call mfree (NL_TRY(nl), TY_REAL) + if (NL_DERIV(nl) != NULL) + call mfree (NL_DERIV(nl), TY_REAL) + call mfree (nl, TY_STRUCT) +end diff --git a/math/nlfit/nlinit.gx b/math/nlfit/nlinit.gx new file mode 100644 index 00000000..be6e436a --- /dev/null +++ b/math/nlfit/nlinit.gx @@ -0,0 +1,66 @@ +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLINIT -- Initialize for non-linear fitting + +procedure nlinit$t (nl, fnc, dfnc, params, dparams, nparams, plist, nfparams, + tol, itmax) + +pointer nl # pointer to nl fitting structure +int fnc # fitting function address +int dfnc # derivative function address +PIXEL params[ARB] # initial values for the parameters +PIXEL dparams[ARB] # initial guess at uncertainties in parameters +int nparams # number of parameters +int plist[ARB] # list of active parameters +int nfparams # number of fitted parameters +PIXEL tol # fitting tolerance +int itmax # maximum number of iterations + +errchk malloc, calloc, nl_list + +begin + # Allocate space for the non-linear package structure. + call calloc (nl, LEN_NLSTRUCT, TY_STRUCT) + + # Store the addresses of the non-linear functions. + NL_FUNC(nl) = fnc + NL_DFUNC(nl) = dfnc + + # Allocate temporary space for arrays. + call calloc (NL_ALPHA(nl), nfparams * nfparams, TY_PIXEL) + call calloc (NL_COVAR(nl), nfparams * nfparams, TY_PIXEL) + call calloc (NL_CHOFAC(nl), nfparams * nfparams, TY_PIXEL) + call calloc (NL_BETA(nl), nfparams, TY_PIXEL) + + # Allocate space for parameter and trial parameter vectors. + call calloc (NL_DERIV(nl), nparams, TY_PIXEL) + call calloc (NL_PARAM(nl), nparams, TY_PIXEL) + call calloc (NL_OPARAM(nl), nparams, TY_PIXEL) + call calloc (NL_TRY(nl), nparams, TY_PIXEL) + call calloc (NL_DPARAM(nl), nparams, TY_PIXEL) + call calloc (NL_DELPARAM(nl), nparams, TY_PIXEL) + call calloc (NL_PLIST(nl), nparams, TY_INT) + + # Initialize the parameters. + NL_NPARAMS(nl) = nparams + NL_NFPARAMS(nl) = nfparams + call amov$t (params, PARAM(NL_PARAM(nl)), nparams) + call amov$t (params, PARAM(NL_OPARAM(nl)), nparams) + call amov$t (dparams, DPARAM(NL_DELPARAM(nl)), nparams) + call amovi (plist, PLIST(NL_PLIST(nl)), nfparams) + NL_TOL(nl) = tol + NL_ITMAX(nl) = itmax + NL_SCATTER(nl) = PIXEL(0.0) + + # Set up the parameter list. + iferr { + call nl_list (PLIST(NL_PLIST(nl)), NL_NPARAMS(nl), NL_NFPARAMS(nl)) + } then { + call nlfree$t (nl) + nl = NULL + } +end diff --git a/math/nlfit/nlinitd.x b/math/nlfit/nlinitd.x new file mode 100644 index 00000000..16804764 --- /dev/null +++ b/math/nlfit/nlinitd.x @@ -0,0 +1,62 @@ +include "nlfitdefd.h" + +# NLINIT -- Initialize for non-linear fitting + +procedure nlinitd (nl, fnc, dfnc, params, dparams, nparams, plist, nfparams, + tol, itmax) + +pointer nl # pointer to nl fitting structure +int fnc # fitting function address +int dfnc # derivative function address +double params[ARB] # initial values for the parameters +double dparams[ARB] # initial guess at uncertainties in parameters +int nparams # number of parameters +int plist[ARB] # list of active parameters +int nfparams # number of fitted parameters +double tol # fitting tolerance +int itmax # maximum number of iterations + +errchk malloc, calloc, nl_list + +begin + # Allocate space for the non-linear package structure. + call calloc (nl, LEN_NLSTRUCT, TY_STRUCT) + + # Store the addresses of the non-linear functions. + NL_FUNC(nl) = fnc + NL_DFUNC(nl) = dfnc + + # Allocate temporary space for arrays. + call calloc (NL_ALPHA(nl), nfparams * nfparams, TY_DOUBLE) + call calloc (NL_COVAR(nl), nfparams * nfparams, TY_DOUBLE) + call calloc (NL_CHOFAC(nl), nfparams * nfparams, TY_DOUBLE) + call calloc (NL_BETA(nl), nfparams, TY_DOUBLE) + + # Allocate space for parameter and trial parameter vectors. + call calloc (NL_DERIV(nl), nparams, TY_DOUBLE) + call calloc (NL_PARAM(nl), nparams, TY_DOUBLE) + call calloc (NL_OPARAM(nl), nparams, TY_DOUBLE) + call calloc (NL_TRY(nl), nparams, TY_DOUBLE) + call calloc (NL_DPARAM(nl), nparams, TY_DOUBLE) + call calloc (NL_DELPARAM(nl), nparams, TY_DOUBLE) + call calloc (NL_PLIST(nl), nparams, TY_INT) + + # Initialize the parameters. + NL_NPARAMS(nl) = nparams + NL_NFPARAMS(nl) = nfparams + call amovd (params, PARAM(NL_PARAM(nl)), nparams) + call amovd (params, PARAM(NL_OPARAM(nl)), nparams) + call amovd (dparams, DPARAM(NL_DELPARAM(nl)), nparams) + call amovi (plist, PLIST(NL_PLIST(nl)), nfparams) + NL_TOL(nl) = tol + NL_ITMAX(nl) = itmax + NL_SCATTER(nl) = double(0.0) + + # Set up the parameter list. + iferr { + call nl_list (PLIST(NL_PLIST(nl)), NL_NPARAMS(nl), NL_NFPARAMS(nl)) + } then { + call nlfreed (nl) + nl = NULL + } +end diff --git a/math/nlfit/nlinitr.x b/math/nlfit/nlinitr.x new file mode 100644 index 00000000..cb97f269 --- /dev/null +++ b/math/nlfit/nlinitr.x @@ -0,0 +1,62 @@ +include "nlfitdefr.h" + +# NLINIT -- Initialize for non-linear fitting + +procedure nlinitr (nl, fnc, dfnc, params, dparams, nparams, plist, nfparams, + tol, itmax) + +pointer nl # pointer to nl fitting structure +int fnc # fitting function address +int dfnc # derivative function address +real params[ARB] # initial values for the parameters +real dparams[ARB] # initial guess at uncertainties in parameters +int nparams # number of parameters +int plist[ARB] # list of active parameters +int nfparams # number of fitted parameters +real tol # fitting tolerance +int itmax # maximum number of iterations + +errchk malloc, calloc, nl_list + +begin + # Allocate space for the non-linear package structure. + call calloc (nl, LEN_NLSTRUCT, TY_STRUCT) + + # Store the addresses of the non-linear functions. + NL_FUNC(nl) = fnc + NL_DFUNC(nl) = dfnc + + # Allocate temporary space for arrays. + call calloc (NL_ALPHA(nl), nfparams * nfparams, TY_REAL) + call calloc (NL_COVAR(nl), nfparams * nfparams, TY_REAL) + call calloc (NL_CHOFAC(nl), nfparams * nfparams, TY_REAL) + call calloc (NL_BETA(nl), nfparams, TY_REAL) + + # Allocate space for parameter and trial parameter vectors. + call calloc (NL_DERIV(nl), nparams, TY_REAL) + call calloc (NL_PARAM(nl), nparams, TY_REAL) + call calloc (NL_OPARAM(nl), nparams, TY_REAL) + call calloc (NL_TRY(nl), nparams, TY_REAL) + call calloc (NL_DPARAM(nl), nparams, TY_REAL) + call calloc (NL_DELPARAM(nl), nparams, TY_REAL) + call calloc (NL_PLIST(nl), nparams, TY_INT) + + # Initialize the parameters. + NL_NPARAMS(nl) = nparams + NL_NFPARAMS(nl) = nfparams + call amovr (params, PARAM(NL_PARAM(nl)), nparams) + call amovr (params, PARAM(NL_OPARAM(nl)), nparams) + call amovr (dparams, DPARAM(NL_DELPARAM(nl)), nparams) + call amovi (plist, PLIST(NL_PLIST(nl)), nfparams) + NL_TOL(nl) = tol + NL_ITMAX(nl) = itmax + NL_SCATTER(nl) = real(0.0) + + # Set up the parameter list. + iferr { + call nl_list (PLIST(NL_PLIST(nl)), NL_NPARAMS(nl), NL_NFPARAMS(nl)) + } then { + call nlfreer (nl) + nl = NULL + } +end diff --git a/math/nlfit/nliter.gx b/math/nlfit/nliter.gx new file mode 100644 index 00000000..7857f852 --- /dev/null +++ b/math/nlfit/nliter.gx @@ -0,0 +1,59 @@ +include +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLITER - Routine to compute one iteration of the fitting process + +procedure nliter$t (nl, x, z, w, npts, nvars, ier) + +pointer nl # pointer to nl fitting structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL z[ARB] # function values (npts) +PIXEL w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int ier # error code + +int i, index +PIXEL nlacpts$t(), nlresid$t() + +begin + # Do the initial accumulation. + NL_OLDSQ(nl) = nlacpts$t (nl, x, z, w, npts, nvars) + + # Set up temporary parameter array. + call amov$t (PARAM(NL_PARAM(nl)), TRY(NL_TRY(nl)), NL_NPARAMS(nl)) + + repeat { + + # Solve the matrix. + call nlsolve$t (nl, ier) + if (ier == NO_DEG_FREEDOM) + return + + # Increment the parameters. + do i = 1, NL_NFPARAMS(nl) { + index = PLIST(NL_PLIST(nl)+i-1) + TRY(NL_TRY(nl)+index-1) = TRY(NL_TRY(nl)+index-1) + + DPARAM(NL_DPARAM(nl)+i-1) + } + + # Reaccumulate the residuals and increment lambda. + NL_SUMSQ(nl) = nlresid$t (nl, x, z, w, npts, nvars) + #if (NL_OLDSQ(nl) > (NL_SUMSQ(nl) + NL_TOL(nl) * NL_SUMSQ(nl))) { + if (NL_OLDSQ(nl) >= NL_SUMSQ(nl)) { + call amov$t (TRY(NL_TRY(nl)), PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl)) + NL_LAMBDA(nl) = PIXEL (0.10) * NL_LAMBDA(nl) + break + } else + NL_LAMBDA(nl) = min (PIXEL(LAMBDAMAX), + PIXEL (10.0) * NL_LAMBDA(nl)) + + } until (NL_LAMBDA(nl) <= PIXEL(0.0) || + NL_LAMBDA(nl) >= PIXEL(LAMBDAMAX)) +end diff --git a/math/nlfit/nliterd.x b/math/nlfit/nliterd.x new file mode 100644 index 00000000..418ab8fa --- /dev/null +++ b/math/nlfit/nliterd.x @@ -0,0 +1,55 @@ +include +include +include "nlfitdefd.h" + +# NLITER - Routine to compute one iteration of the fitting process + +procedure nliterd (nl, x, z, w, npts, nvars, ier) + +pointer nl # pointer to nl fitting structure +double x[ARB] # independent variables (npts * nvars) +double z[ARB] # function values (npts) +double w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int ier # error code + +int i, index +double nlacptsd(), nlresidd() + +begin + # Do the initial accumulation. + NL_OLDSQ(nl) = nlacptsd (nl, x, z, w, npts, nvars) + + # Set up temporary parameter array. + call amovd (PARAM(NL_PARAM(nl)), TRY(NL_TRY(nl)), NL_NPARAMS(nl)) + + repeat { + + # Solve the matrix. + call nlsolved (nl, ier) + if (ier == NO_DEG_FREEDOM) + return + + # Increment the parameters. + do i = 1, NL_NFPARAMS(nl) { + index = PLIST(NL_PLIST(nl)+i-1) + TRY(NL_TRY(nl)+index-1) = TRY(NL_TRY(nl)+index-1) + + DPARAM(NL_DPARAM(nl)+i-1) + } + + # Reaccumulate the residuals and increment lambda. + NL_SUMSQ(nl) = nlresidd (nl, x, z, w, npts, nvars) + #if (NL_OLDSQ(nl) > (NL_SUMSQ(nl) + NL_TOL(nl) * NL_SUMSQ(nl))) { + if (NL_OLDSQ(nl) >= NL_SUMSQ(nl)) { + call amovd (TRY(NL_TRY(nl)), PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl)) + NL_LAMBDA(nl) = double (0.10) * NL_LAMBDA(nl) + break + } else + NL_LAMBDA(nl) = min (double(LAMBDAMAX), + double (10.0) * NL_LAMBDA(nl)) + + } until (NL_LAMBDA(nl) <= double(0.0) || + NL_LAMBDA(nl) >= double(LAMBDAMAX)) +end diff --git a/math/nlfit/nliterr.x b/math/nlfit/nliterr.x new file mode 100644 index 00000000..cbc5a80a --- /dev/null +++ b/math/nlfit/nliterr.x @@ -0,0 +1,55 @@ +include +include +include "nlfitdefr.h" + +# NLITER - Routine to compute one iteration of the fitting process + +procedure nliterr (nl, x, z, w, npts, nvars, ier) + +pointer nl # pointer to nl fitting structure +real x[ARB] # independent variables (npts * nvars) +real z[ARB] # function values (npts) +real w[ARB] # weights (npts) +int npts # number of points +int nvars # number of independent variables +int ier # error code + +int i, index +real nlacptsr(), nlresidr() + +begin + # Do the initial accumulation. + NL_OLDSQ(nl) = nlacptsr (nl, x, z, w, npts, nvars) + + # Set up temporary parameter array. + call amovr (PARAM(NL_PARAM(nl)), TRY(NL_TRY(nl)), NL_NPARAMS(nl)) + + repeat { + + # Solve the matrix. + call nlsolver (nl, ier) + if (ier == NO_DEG_FREEDOM) + return + + # Increment the parameters. + do i = 1, NL_NFPARAMS(nl) { + index = PLIST(NL_PLIST(nl)+i-1) + TRY(NL_TRY(nl)+index-1) = TRY(NL_TRY(nl)+index-1) + + DPARAM(NL_DPARAM(nl)+i-1) + } + + # Reaccumulate the residuals and increment lambda. + NL_SUMSQ(nl) = nlresidr (nl, x, z, w, npts, nvars) + #if (NL_OLDSQ(nl) > (NL_SUMSQ(nl) + NL_TOL(nl) * NL_SUMSQ(nl))) { + if (NL_OLDSQ(nl) >= NL_SUMSQ(nl)) { + call amovr (TRY(NL_TRY(nl)), PARAM(NL_PARAM(nl)), + NL_NPARAMS(nl)) + NL_LAMBDA(nl) = real (0.10) * NL_LAMBDA(nl) + break + } else + NL_LAMBDA(nl) = min (real(LAMBDAMAX), + real (10.0) * NL_LAMBDA(nl)) + + } until (NL_LAMBDA(nl) <= real(0.0) || + NL_LAMBDA(nl) >= real(LAMBDAMAX)) +end diff --git a/math/nlfit/nllist.x b/math/nlfit/nllist.x new file mode 100644 index 00000000..d96351c9 --- /dev/null +++ b/math/nlfit/nllist.x @@ -0,0 +1,30 @@ +# NL_LIST -- Procedure to order the list used when the NLFIT structure +# is initialized. + +procedure nl_list (list, nlist, nfit) + +int list[ARB] # list +int nlist # number of elements in the list +int nfit # number of active list elments + +int i, j, nfitp1, ifound + +begin + nfitp1 = nfit + 1 + + do i = 1, nlist { + ifound = 0 + do j = 1, nfit { + if (list[j] == i) + ifound = ifound + 1 + } + if (ifound == 0) { + list[nfitp1] = i + nfitp1 = nfitp1 + 1 + } else if (ifound > 1) + call error (0, "Incorrect parameter ordering in plist") + } + + if (nfitp1 != (nlist + 1)) + call error (0, "Incorrect parameter ordering in plist") +end diff --git a/math/nlfit/nlpget.gx b/math/nlfit/nlpget.gx new file mode 100644 index 00000000..3a74fa6f --- /dev/null +++ b/math/nlfit/nlpget.gx @@ -0,0 +1,18 @@ +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLPGET - Retreive parameter values + +procedure nlpget$t (nl, params, nparams) + +pointer nl # pointer to the nlfit structure +PIXEL params[ARB] # parameter array +int nparams # the number of the parameters + +begin + nparams = NL_NPARAMS(nl) + call amov$t (PARAM(NL_PARAM(nl)), params, nparams) +end diff --git a/math/nlfit/nlpgetd.x b/math/nlfit/nlpgetd.x new file mode 100644 index 00000000..419bde09 --- /dev/null +++ b/math/nlfit/nlpgetd.x @@ -0,0 +1,14 @@ +include "nlfitdefd.h" + +# NLPGET - Retreive parameter values + +procedure nlpgetd (nl, params, nparams) + +pointer nl # pointer to the nlfit structure +double params[ARB] # parameter array +int nparams # the number of the parameters + +begin + nparams = NL_NPARAMS(nl) + call amovd (PARAM(NL_PARAM(nl)), params, nparams) +end diff --git a/math/nlfit/nlpgetr.x b/math/nlfit/nlpgetr.x new file mode 100644 index 00000000..73fd7cbb --- /dev/null +++ b/math/nlfit/nlpgetr.x @@ -0,0 +1,14 @@ +include "nlfitdefr.h" + +# NLPGET - Retreive parameter values + +procedure nlpgetr (nl, params, nparams) + +pointer nl # pointer to the nlfit structure +real params[ARB] # parameter array +int nparams # the number of the parameters + +begin + nparams = NL_NPARAMS(nl) + call amovr (PARAM(NL_PARAM(nl)), params, nparams) +end diff --git a/math/nlfit/nlsolve.gx b/math/nlfit/nlsolve.gx new file mode 100644 index 00000000..a4055520 --- /dev/null +++ b/math/nlfit/nlsolve.gx @@ -0,0 +1,41 @@ +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLSOLVE -- Procedure to solve nonlinear system + +procedure nlsolve$t (nl, ier) + +pointer nl # pointer to the nlfit structure +int ier # error code + +int nfree + +begin + # Make temporary arrays. + call amov$t (ALPHA(NL_ALPHA(nl)), COVAR(NL_COVAR(nl)), + NL_NFPARAMS(nl) ** 2) + call amov$t (BETA(NL_BETA(nl)), DPARAM(NL_DPARAM(nl)), NL_NFPARAMS(nl)) + + # Add the lambda damping factor. + call nl_damp$t (COVAR(NL_COVAR(nl)), COVAR(NL_COVAR(nl)), + (1.0 + NL_LAMBDA(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl)) + + ier = OK + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # Compute the factorization of the matrix. + call nl_chfac$t (COVAR(NL_COVAR(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + CHOFAC(NL_CHOFAC(nl)), ier) + + # Solve the equations for the parameter increments. + call nl_chslv$t (CHOFAC(NL_CHOFAC(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + DPARAM(NL_DPARAM(nl)), DPARAM(NL_DPARAM(nl))) +end diff --git a/math/nlfit/nlsolved.x b/math/nlfit/nlsolved.x new file mode 100644 index 00000000..77a43337 --- /dev/null +++ b/math/nlfit/nlsolved.x @@ -0,0 +1,37 @@ +include +include "nlfitdefd.h" + +# NLSOLVE -- Procedure to solve nonlinear system + +procedure nlsolved (nl, ier) + +pointer nl # pointer to the nlfit structure +int ier # error code + +int nfree + +begin + # Make temporary arrays. + call amovd (ALPHA(NL_ALPHA(nl)), COVAR(NL_COVAR(nl)), + NL_NFPARAMS(nl) ** 2) + call amovd (BETA(NL_BETA(nl)), DPARAM(NL_DPARAM(nl)), NL_NFPARAMS(nl)) + + # Add the lambda damping factor. + call nl_dampd (COVAR(NL_COVAR(nl)), COVAR(NL_COVAR(nl)), + (1.0 + NL_LAMBDA(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl)) + + ier = OK + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # Compute the factorization of the matrix. + call nl_chfacd (COVAR(NL_COVAR(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + CHOFAC(NL_CHOFAC(nl)), ier) + + # Solve the equations for the parameter increments. + call nl_chslvd (CHOFAC(NL_CHOFAC(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + DPARAM(NL_DPARAM(nl)), DPARAM(NL_DPARAM(nl))) +end diff --git a/math/nlfit/nlsolver.x b/math/nlfit/nlsolver.x new file mode 100644 index 00000000..85d238d6 --- /dev/null +++ b/math/nlfit/nlsolver.x @@ -0,0 +1,37 @@ +include +include "nlfitdefr.h" + +# NLSOLVE -- Procedure to solve nonlinear system + +procedure nlsolver (nl, ier) + +pointer nl # pointer to the nlfit structure +int ier # error code + +int nfree + +begin + # Make temporary arrays. + call amovr (ALPHA(NL_ALPHA(nl)), COVAR(NL_COVAR(nl)), + NL_NFPARAMS(nl) ** 2) + call amovr (BETA(NL_BETA(nl)), DPARAM(NL_DPARAM(nl)), NL_NFPARAMS(nl)) + + # Add the lambda damping factor. + call nl_dampr (COVAR(NL_COVAR(nl)), COVAR(NL_COVAR(nl)), + (1.0 + NL_LAMBDA(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl)) + + ier = OK + nfree = NL_NPTS(nl) - NL_NFPARAMS(nl) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # Compute the factorization of the matrix. + call nl_chfacr (COVAR(NL_COVAR(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + CHOFAC(NL_CHOFAC(nl)), ier) + + # Solve the equations for the parameter increments. + call nl_chslvr (CHOFAC(NL_CHOFAC(nl)), NL_NFPARAMS(nl), NL_NFPARAMS(nl), + DPARAM(NL_DPARAM(nl)), DPARAM(NL_DPARAM(nl))) +end diff --git a/math/nlfit/nlstat.gx b/math/nlfit/nlstat.gx new file mode 100644 index 00000000..c17d5940 --- /dev/null +++ b/math/nlfit/nlstat.gx @@ -0,0 +1,30 @@ +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +# NLSTAT[RD] - Fetch an NLFIT real/double parameter + +PIXEL procedure nlstat$t (nl, param) + +pointer nl # pointer to NLFIT structure +int param # parameter to be fetched + +begin + switch (param) { + case NLSUMSQ: + return (NL_SUMSQ(nl)) + case NLOLDSQ: + return (NL_OLDSQ(nl)) + case NLTOL: + return (NL_TOL(nl)) + case NLLAMBDA: + return (NL_LAMBDA(nl)) + case NLSCATTER: + return (NL_SCATTER(nl)) + default: + return ($INDEF$T) + } +end diff --git a/math/nlfit/nlstatd.x b/math/nlfit/nlstatd.x new file mode 100644 index 00000000..73661ce8 --- /dev/null +++ b/math/nlfit/nlstatd.x @@ -0,0 +1,26 @@ +include +include "nlfitdefd.h" + +# NLSTAT[RD] - Fetch an NLFIT real/double parameter + +double procedure nlstatd (nl, param) + +pointer nl # pointer to NLFIT structure +int param # parameter to be fetched + +begin + switch (param) { + case NLSUMSQ: + return (NL_SUMSQ(nl)) + case NLOLDSQ: + return (NL_OLDSQ(nl)) + case NLTOL: + return (NL_TOL(nl)) + case NLLAMBDA: + return (NL_LAMBDA(nl)) + case NLSCATTER: + return (NL_SCATTER(nl)) + default: + return (INDEFD) + } +end diff --git a/math/nlfit/nlstati.x b/math/nlfit/nlstati.x new file mode 100644 index 00000000..04c8cf27 --- /dev/null +++ b/math/nlfit/nlstati.x @@ -0,0 +1,26 @@ +include "nlfitdefr.h" +include + +# NLSTATI - Fetch a NLFIT integer parameter + +int procedure nlstati (nl, param) + +pointer nl # pointer to NLFIT structure +int param # parameter to be fetched + +begin + switch (param) { + case NLNPARAMS: + return (NL_NPARAMS(nl)) + case NLNFPARAMS: + return (NL_NFPARAMS(nl)) + case NLITMAX: + return (NL_ITMAX(nl)) + case NLITER: + return (NL_ITER(nl)) + case NLNPTS: + return (NL_NPTS(nl)) + default: + return (INDEFI) + } +end diff --git a/math/nlfit/nlstatr.x b/math/nlfit/nlstatr.x new file mode 100644 index 00000000..c6360017 --- /dev/null +++ b/math/nlfit/nlstatr.x @@ -0,0 +1,26 @@ +include +include "nlfitdefr.h" + +# NLSTAT[RD] - Fetch an NLFIT real/double parameter + +real procedure nlstatr (nl, param) + +pointer nl # pointer to NLFIT structure +int param # parameter to be fetched + +begin + switch (param) { + case NLSUMSQ: + return (NL_SUMSQ(nl)) + case NLOLDSQ: + return (NL_OLDSQ(nl)) + case NLTOL: + return (NL_TOL(nl)) + case NLLAMBDA: + return (NL_LAMBDA(nl)) + case NLSCATTER: + return (NL_SCATTER(nl)) + default: + return (INDEFR) + } +end diff --git a/math/nlfit/nlvector.gx b/math/nlfit/nlvector.gx new file mode 100644 index 00000000..f33d063c --- /dev/null +++ b/math/nlfit/nlvector.gx @@ -0,0 +1,27 @@ +include +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + +define VAR (($1 - 1) * $2 + 1) + +# NLVECTOR -- Evaluate the fit for a series of data points. + +procedure nlvector$t (nl, x, zfit, npts, nvars) + +pointer nl # pointer to nl fitting structure +PIXEL x[ARB] # independent variables (npts * nvars) +PIXEL zfit[ARB] # function values (npts) +int npts # number of points +int nvars # number of independent variables + +int i + +begin + # Compute the fitted function. + do i = 1, npts + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), NL_NPARAMS(nl), zfit[i]) +end diff --git a/math/nlfit/nlvectord.x b/math/nlfit/nlvectord.x new file mode 100644 index 00000000..34bce9a5 --- /dev/null +++ b/math/nlfit/nlvectord.x @@ -0,0 +1,23 @@ +include +include "nlfitdefd.h" + +define VAR (($1 - 1) * $2 + 1) + +# NLVECTOR -- Evaluate the fit for a series of data points. + +procedure nlvectord (nl, x, zfit, npts, nvars) + +pointer nl # pointer to nl fitting structure +double x[ARB] # independent variables (npts * nvars) +double zfit[ARB] # function values (npts) +int npts # number of points +int nvars # number of independent variables + +int i + +begin + # Compute the fitted function. + do i = 1, npts + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), NL_NPARAMS(nl), zfit[i]) +end diff --git a/math/nlfit/nlvectorr.x b/math/nlfit/nlvectorr.x new file mode 100644 index 00000000..43450695 --- /dev/null +++ b/math/nlfit/nlvectorr.x @@ -0,0 +1,23 @@ +include +include "nlfitdefr.h" + +define VAR (($1 - 1) * $2 + 1) + +# NLVECTOR -- Evaluate the fit for a series of data points. + +procedure nlvectorr (nl, x, zfit, npts, nvars) + +pointer nl # pointer to nl fitting structure +real x[ARB] # independent variables (npts * nvars) +real zfit[ARB] # function values (npts) +int npts # number of points +int nvars # number of independent variables + +int i + +begin + # Compute the fitted function. + do i = 1, npts + call zcall5 (NL_FUNC(nl), x[VAR (i, nvars)], nvars, + PARAM(NL_PARAM(nl)), NL_NPARAMS(nl), zfit[i]) +end diff --git a/math/nlfit/nlzero.gx b/math/nlfit/nlzero.gx new file mode 100644 index 00000000..ffd1458b --- /dev/null +++ b/math/nlfit/nlzero.gx @@ -0,0 +1,38 @@ +$if (datatype == r) +include "nlfitdefr.h" +$else +include "nlfitdefd.h" +$endif + + +# NLZERO -- Zero the accumulators and reset the fitting parameter values to +# their original values set by nlinit(). + +procedure nlzero$t (nl) + +pointer nl # pointer to nl fitting structure + +int nparams # number of parameters +int nfparams # number of fitted parameters + +begin + # Get number of parameters and fitting parameters. + nparams = NL_NPARAMS(nl) + nfparams = NL_NFPARAMS(nl) + + # Clear temporary array space. + call aclr$t (ALPHA(NL_ALPHA(nl)), nfparams * nfparams) + call aclr$t (COVAR(NL_COVAR(nl)), nfparams * nfparams) + call aclr$t (CHOFAC(NL_CHOFAC(nl)), nfparams * nfparams) + call aclr$t (BETA(NL_BETA(nl)), nfparams) + + # Clear space for derivatives and trial parameter vectors. + call aclr$t (DERIV(NL_DERIV(nl)), nparams) + call aclr$t (TRY(NL_TRY(nl)), nparams) + + # Reset parameters. + call amov$t (OPARAM(NL_OPARAM(nl)), PARAM(NL_PARAM(nl)), nparams) + call aclr$t (DPARAM(NL_DPARAM(nl)), nparams) + + NL_SCATTER(nl) = PIXEL(0.0) +end diff --git a/math/nlfit/nlzerod.x b/math/nlfit/nlzerod.x new file mode 100644 index 00000000..2ee86562 --- /dev/null +++ b/math/nlfit/nlzerod.x @@ -0,0 +1,34 @@ +include "nlfitdefd.h" + + +# NLZERO -- Zero the accumulators and reset the fitting parameter values to +# their original values set by nlinit(). + +procedure nlzerod (nl) + +pointer nl # pointer to nl fitting structure + +int nparams # number of parameters +int nfparams # number of fitted parameters + +begin + # Get number of parameters and fitting parameters. + nparams = NL_NPARAMS(nl) + nfparams = NL_NFPARAMS(nl) + + # Clear temporary array space. + call aclrd (ALPHA(NL_ALPHA(nl)), nfparams * nfparams) + call aclrd (COVAR(NL_COVAR(nl)), nfparams * nfparams) + call aclrd (CHOFAC(NL_CHOFAC(nl)), nfparams * nfparams) + call aclrd (BETA(NL_BETA(nl)), nfparams) + + # Clear space for derivatives and trial parameter vectors. + call aclrd (DERIV(NL_DERIV(nl)), nparams) + call aclrd (TRY(NL_TRY(nl)), nparams) + + # Reset parameters. + call amovd (OPARAM(NL_OPARAM(nl)), PARAM(NL_PARAM(nl)), nparams) + call aclrd (DPARAM(NL_DPARAM(nl)), nparams) + + NL_SCATTER(nl) = double(0.0) +end diff --git a/math/nlfit/nlzeror.x b/math/nlfit/nlzeror.x new file mode 100644 index 00000000..1cceba31 --- /dev/null +++ b/math/nlfit/nlzeror.x @@ -0,0 +1,34 @@ +include "nlfitdefr.h" + + +# NLZERO -- Zero the accumulators and reset the fitting parameter values to +# their original values set by nlinit(). + +procedure nlzeror (nl) + +pointer nl # pointer to nl fitting structure + +int nparams # number of parameters +int nfparams # number of fitted parameters + +begin + # Get number of parameters and fitting parameters. + nparams = NL_NPARAMS(nl) + nfparams = NL_NFPARAMS(nl) + + # Clear temporary array space. + call aclrr (ALPHA(NL_ALPHA(nl)), nfparams * nfparams) + call aclrr (COVAR(NL_COVAR(nl)), nfparams * nfparams) + call aclrr (CHOFAC(NL_CHOFAC(nl)), nfparams * nfparams) + call aclrr (BETA(NL_BETA(nl)), nfparams) + + # Clear space for derivatives and trial parameter vectors. + call aclrr (DERIV(NL_DERIV(nl)), nparams) + call aclrr (TRY(NL_TRY(nl)), nparams) + + # Reset parameters. + call amovr (OPARAM(NL_OPARAM(nl)), PARAM(NL_PARAM(nl)), nparams) + call aclrr (DPARAM(NL_DPARAM(nl)), nparams) + + NL_SCATTER(nl) = real(0.0) +end diff --git a/math/slalib/Makefile.am b/math/slalib/Makefile.am new file mode 100644 index 00000000..547240a7 --- /dev/null +++ b/math/slalib/Makefile.am @@ -0,0 +1,76 @@ +## Process this file with automake to produce Makefile.in + +cincludedir = $(includedir)/star +dist_bin_SCRIPTS = sla_link sla_link_adam +dist_pkgdata_DATA = SLA_CONDITIONS read.me + +EXTRA_DIST = Notes + +lib_LTLIBRARIES = libsla.la + +stardocs_DATA = @STAR_LATEX_DOCUMENTATION@ + +libsla_la_SOURCES = \ + $(PRIVATE_INCLUDES) \ + $(PUBLIC_INCLUDES) \ + $(F_ROUTINES) \ + $(C_ROUTINES) \ + $(FPP_ROUTINES) +libsla_la_LIBADD = $(LTLIBOBJS) +libsla_la_LDFLAGS = -version-info $(libsla_la_version_info) + +cinclude_HEADERS = $(PUBLIC_C_INCLUDES) + +# Make all library code position independent. This is handy for creating +# shareable libraries from the static ones (Java JNI libraries). +if !NOPIC +libsla_la_FCFLAGS = $(AM_FCFLAGS) -prefer-pic +endif + +PUBLIC_F_INCLUDES = +PUBLIC_C_INCLUDES = slalib.h +PRIVATE_INCLUDES = f77.h +PUBLIC_INCLUDES = $(PUBLIC_F_INCLUDES) $(PUBLIC_C_INCLUDES) + +FPP_ROUTINES = \ + random.F \ + gresid.F + +C_ROUTINES = sla.c + +F_ROUTINES = addet.f afin.f airmas.f altaz.f amp.f ampqk.f aop.f \ + aoppa.f aoppat.f aopqk.f atmdsp.f atms.f atmt.f av2m.f bear.f \ + caf2r.f caldj.f calyd.f cc2s.f cc62s.f cd2tf.f cldj.f clyd.f \ + combn.f cr2af.f cr2tf.f cs2c.f cs2c6.f ctf2d.f ctf2r.f daf2r.f \ + dafin.f dat.f dav2m.f dbear.f dbjin.f dc62s.f dcc2s.f dcmpf.f \ + dcs2c.f dd2tf.f de2h.f deuler.f dfltin.f dh2e.f dimxv.f djcal.f \ + djcl.f dm2av.f dmat.f dmoon.f dmxm.f dmxv.f dpav.f dr2af.f dr2tf.f \ + drange.f dranrm.f ds2c6.f ds2tp.f dsep.f dsepv.f dt.f dtf2d.f \ + dtf2r.f dtp2s.f dtp2v.f dtps2c.f dtpv2c.f dtt.f dv2tp.f dvdv.f \ + dvn.f dvxv.f e2h.f earth.f ecleq.f ecmat.f ecor.f eg50.f el2ue.f \ + epb.f epb2d.f epco.f epj.f epj2d.f epv.f eqecl.f eqeqx.f eqgal.f \ + etrms.f euler.f evp.f fitxy.f fk425.f fk45z.f fk524.f fk52h.f \ + fk54z.f fk5hz.f flotin.f galeq.f galsup.f ge50.f geoc.f gmst.f \ + gmsta.f h2e.f h2fk5.f hfk5z.f idchf.f idchi.f imxv.f intin.f \ + invf.f kbj.f m2av.f map.f mappa.f mapqk.f mapqkz.f moon.f mxm.f \ + mxv.f nut.f nutc.f nutc80.f oap.f oapqk.f obs.f pa.f pav.f pcd.f \ + pda2h.f pdq2h.f permut.f pertel.f pertue.f planel.f planet.f \ + plante.f plantu.f pm.f polmo.f prebn.f prec.f precl.f preces.f \ + prenut.f pv2el.f pv2ue.f pvobs.f pxy.f range.f ranorm.f rcc.f \ + rdplan.f refco.f refcoq.f refro.f refv.f refz.f rverot.f rvgalc.f \ + rvlg.f rvlsrd.f rvlsrk.f s2tp.f sep.f sepv.f smat.f subet.f \ + supgal.f svd.f svdcov.f svdsol.f tp2s.f tp2v.f tps2c.f tpv2c.f \ + ue2el.f ue2pv.f unpcd.f v2tp.f vdv.f veri.f vers.f vn.f vxv.f \ + wait.f xy2xy.f zd.f + +TESTS = sla_test slaTest +check_PROGRAMS = sla_test slaTest + +sla_test_SOURCES = sla_test.f +sla_test_LDADD = libsla.la + +slaTest_SOURCES = slaTest.c +slaTest_LDADD = libsla.la @FCLIBS@ + +dist_starnews_DATA = sla.news +DISTCLEANFILES = gresid.F random.F wait.f diff --git a/math/slalib/Notes b/math/slalib/Notes new file mode 100644 index 00000000..ffb5efca --- /dev/null +++ b/math/slalib/Notes @@ -0,0 +1,23 @@ + +SLALIB imported into CVS and autoconfed, January 2003. + +Platform-dependencies: there were three platform-dependent files, for +random.f, gresid.f (both requiring a random number function) and +wait.f (sleeps). The original set of files had extensions alpha_OSF1, +convex, ix86_Linux, mips, pcm, sun4, sun4_Solaris, and vax. In each +case, there were a number of files for unix-like platforms, one +Windows/MSFortran (pcm) and one VAX one. For random and gresid, the +unix ones were largely the same, differing only in whether they called +a function random() or ran(), and with different calls -- these could +be handled using fpp. + +The Windows and VMS ones were sufficiently different that they've +remained in separate files. Each of the three has a __win file, +specific to MSFortran (or to Windows, I'm not sure). In each of the +three cases, the __vms file is the original _vax file -- it's specific +to VMS, not the VAX. For random and gresid, the files are called +random.fpp{__win,_dec_osf} even though there's nothing preprocessable +in them. + +I _think_ I've got the __vms and __win dependencies right, but I've no +way of testing them. diff --git a/math/slalib/README b/math/slalib/README new file mode 100644 index 00000000..606d3784 --- /dev/null +++ b/math/slalib/README @@ -0,0 +1,233 @@ +This directory contains the Fortran source for the SLALIB version 2.5-2 +routines. The SLALIB Fortran library has been made available to the IRAF +project courtesy of Patrick Wallace of the Starlink project, the version +distributed here is derived from the Starlink 2012 release in order to +include the GPL'd version of the code. All the documentation normally +provided with the Starlink routines can be found in the doc subdirectory, +and in the sun67.tex file. See the 'read.me' and 'SLA_CONDITIONS' file +in this directory for additional information and license restrictions. + +In order to complete the port to iraf the following name changes were +made to the package routines. The package prefix was changed from "sla_" +to "sl". Routines with root names that were longer than four characters +have been renamed so that all the package routines have unique six +character names. The complete name change list is shown below. +A Unix sed script for implementing the changes automatically can be found +in the file sedscript, using the editing commands in the files SED1, +SED2, SED3. + +The machine dependent routines gresid, random, and wait have been removed +from the IRAF version of SLALIB. The IRAF routines urand in osb$urand.x +and tsleep in etc$tsleep.x can be used to replace the SLALIB routines +random and wait. + +No other changes have been made to any of the routines. However a new +routine precss.f has been added to the package. Precss.f is identical to +preces.f except that the system argument is an integer code rather +than a Fortran string. This avoids having to deal with Fortran strings +and conversions in spp programs for this commonly used routine. + +The complete name translation list. + +sla_ADDET slADET +sla_AFIN slAFIN +sla_AIRMAS slARMS +sla_ALTAZ slALAZ +sla_AMP slAMP +sla_AMPQK slAMPQ +sla_AOP slAOP +sla_AOPPA slAOPA +sla_AOPPAT slAOPT +sla_AOPQK slAOPQ +sla__ATMS slATMS +sla__ATMT slATMT +sla_ATMDSP slATMD +sla_AV2M slAV2M + +sla_BEAR slBEAR + +sla_CAF2R slCAFR +sla_CALDJ slCADJ +sla_CALYD slCAYD +sla_CC2S slCC2S +sla_CC62S slC62S +sla_CD2TF slCDTF +sla_CLDJ slCLDJ +sla_CLYD slCLYD +sla_CR2AF slCRAF +sla_CR2TF slCRTF +sla_CS2C slCS2C +sla_CS2C6 slS2C6 +sla_CTF2D slCTFD +sla_CTF2R slCTFR + +sla_DAF2R slDAFR +sla_DAFIN slDAFN +sla_DAT slDAT +sla_DAV2M slDAVM +sla_DBEAR slDBER +sla_DBJIN slDBJI +sla_DC62S slDC6S +sla_DCC2S slDC2S +sla_DCMPF slDCMF +sla_DCS2C slDS2C +sla_DD2TF slDDTF +sla_DE2H slDE2H +sla_DEULER slDEUL +sla_DFLTIN slDFLI +sla_DH2E slDH2E +sla_DIMXV slDIMV +sla_DJCAL slDJCA +sla_DJCL slDJCL +sla_DM2AV slDMAV +sla_DMAT slDMAT +sla_DMOON slDMON +sla_DMXM slDMXM +sla_DMXV slDMXV +sla_DPAV slDPAV +sla_DR2AF slDRAF +sla_DR2TF slDRTF +sla_DRANGE slDA1P +sla_DRANRM slDA2P +sla_DS2C6 slDSC6 +sla_DS2TP slDSTP +sla_DSEP slDSEP +sla_DT slDT +sla_DTF2D slDTFD +sla_DTF2R slDTFR +sla_DTP2S slDTPS +sla_DTP2V slDTPV +sla_DTPS2C slDPSC +sla_DTPV2C slDPVC +sla_DTT slDTT +sla_DV2TP slDVTP +sla_DVDV slDVDV +sla_DVN slDVN +sla_DVXV slDVXV + +sla_E2H slE2H +sla_EARTH slERTH +sla_ECLEQ slECEQ +sla_ECMAT slECMA +sla_ECOR slECOR +sla_EG50 slEG50 +sla_EL2UE slELUE +sla_EPB slEPB +sla_EPB2D slEB2D +sla_EPCO slEPCO +sla_EPJ slEPJ +sla_EPJ2D slEJ2D +sla_EQECL slEQEC +sla_EQEQX slEQEX +sla_EQGAL slEQGA +sla_ETRMS slETRM +sla_EULER slEULR +sla_EVP slEVP + +sla_FITXY slFTXY +sla_FK425 slFK45 +sla_FK45Z slF45Z +sla_FK524 slFK54 +sla_FK52H slFK5H +sla_FK54Z slF54Z +sla_FK5HZ slF5HZ +sla_FLOTIN slRFLI + +sla_GALEQ slGAEQ +sla_GALSUP slGASU +sla_GE50 slGE50 +sla_GEOC slGEOC +sla_GMST slGMST +sla_GMSTA slGMSA + +sla_H2E slH2E +sla_H2FK5 slHFK5 +sla_HFK5Z slHF5Z + +sla__IDCHI slICHI +sla__IDCHF slICHF +sla_IMXV slIMXV +sla_INTIN slINTI +sla_INVF slINVF + +sla_KBJ slKBJ + +sla_M2AV slM2AV +sla_MAP slMAP +sla_MAPPA slMAPA +sla_MAPQK slMAPQ +sla_MAPQKZ slMAPZ +sla_MOON slMOON +sla_MXM slMXM +sla_MXV slMXV + +sla_NUT slNUT +sla_NUTC slNUTC + +sla_OBS slOBS +sla_OAP slOAP +sla_OAPQK slOAPQ + +sla_PA slPA +sla_PAV slPAV +sla_PCD slPCD +sla_PDA2H slPDAH +sla_PDQ2H slPDQH +sla_PERTEL slPRTL +sla_PERTUE slPRTE +sla_PLANEL slPLNE +sla_PLANET slPLNT +sla_PLANTE slPLTE +sla_PM slPM +sla_POLMO slPLMO +sla_PREBN slPRBN +sla_PREC slPREC +sla_PRECES slPRCE +sla_PRECL slPREL +sla_PRECSS slPRCS # no SLALIB version +sla_PRENUT slPRNU +sla_PV2EL slPVEL +sla_PV2UE slPVUE +sla_PVOBS slPVOB +sla_PXY slPXY + +sla_RANGE slRA1P +sla_RANORM slRA2P +sla_RCC slRCC +sla_RDPLAN slRDPL +sla_REFCO slRFCO +sla_REFCOQ slRFCQ +sla_REFRO slRFRO +sla_REFV slREFV +sla_REFZ slREFZ +sla_RVEROT slRVER +sla_RVGALC slRVGA +sla_RVLG slRVLG +sla_RVLSRD slRVLD +sla_RVLSRK slRVLK + +sla_S2TP slS2TP +sla_SEP slSEP +sla_SMAT slSMAT +sla_SUBET slSUET +sla_SUPGAL slSUGA +sla_SVD slSVD +sla_SVDCOV slSVDC +sla_SVDSOL slSVDS + +sla_TP2S slTP2S +sla_TP2V slTP2V +sla_TPS2C slTPSC +sla_TPV2C slTPVC + +sla_UE2EL slUEEL +sla_UE2PV slUEPV +sla_UNPCD slUPCD + +sla_V2TP slV2TP +sla_VDV slVDV +sla_VN slVN +sla_VXV slVXV + +sla_XY2XY slXYXY +sla_ZD slZD diff --git a/math/slalib/SED1 b/math/slalib/SED1 new file mode 100644 index 00000000..8fdff423 --- /dev/null +++ b/math/slalib/SED1 @@ -0,0 +1,214 @@ +1,$s/sla_ADDET/slADET/g +1,$s/sla_AFIN/slAFIN/g +1,$s/sla_AIRMAS/slARMS/g +1,$s/sla_ALTAZ/slALAZ/g +1,$s/sla_AMPQK/slAMPQ/g +1,$s/sla_AMP/slAMP/g +1,$s/sla_AOPPAT/slAOPT/g +1,$s/sla_AOPPA/slAOPA/g +1,$s/sla_AOPQK/slAOPQ/g +1,$s/sla_AOP/slAOP/g +1,$s/sla_ATMDSP/slATMD/g +1,$s/sla__ATMS/slATMS/g +1,$s/sla__ATMT/slATMT/g +1,$s/sla_AV2M/slAV2M/g + +1,$s/sla_BEAR/slBEAR/g + +1,$s/sla_CAF2R/slCAFR/g +1,$s/sla_CALDJ/slCADJ/g +1,$s/sla_CALYD/slCAYD/g +1,$s/sla_CC2S/slCC2S/g +1,$s/sla_CC62S/slC62S/g +1,$s/sla_CD2TF/slCDTF/g +1,$s/sla_CLDJ/slCLDJ/g +1,$s/sla_CLYD/slCLYD/g +1,$s/sla_CR2AF/slCRAF/g +1,$s/sla_CR2TF/slCRTF/g +1,$s/sla_CS2C6/slS2C6/g +1,$s/sla_CS2C/slCS2C/g +1,$s/sla_CTF2D/slCTFD/g +1,$s/sla_CTF2R/slCTFR/g + +1,$s/sla_DAF2R/slDAFR/g +1,$s/sla_DAFIN/slDAFN/g +1,$s/sla_DAT/slDAT/g +1,$s/sla_DAV2M/slDAVM/g +1,$s/sla_DBEAR/slDBER/g +1,$s/sla_DBJIN/slDBJI/g +1,$s/sla_DC62S/slDC6S/g +1,$s/sla_DCC2S/slDC2S/g +1,$s/sla_DCMPF/slDCMF/g +1,$s/sla_DCS2C/slDS2C/g +1,$s/sla_DD2TF/slDDTF/g +1,$s/sla_DE2H/slDE2H/g +1,$s/sla_DEULER/slDEUL/g +1,$s/sla_DFLTIN/slDFLI/g +1,$s/sla_DH2E/slDH2E/g +1,$s/sla_DIMXV/slDIMV/g +1,$s/sla_DJCAL/slDJCA/g +1,$s/sla_DJCL/slDJCL/g +1,$s/sla_DM2AV/slDMAV/g +1,$s/sla_DMAT/slDMAT/g +1,$s/sla_DMOON/slDMON/g +1,$s/sla_DMXM/slDMXM/g +1,$s/sla_DMXV/slDMXV/g +1,$s/sla_DPAV/slDPAV/g +1,$s/sla_DR2AF/slDRAF/g +1,$s/sla_DR2TF/slDRTF/g +1,$s/sla_DRANGE/slDA1P/g +1,$s/sla_DRANRM/slDA2P/g +1,$s/sla_DS2C6/slDSC6/g +1,$s/sla_DS2TP/slDSTP/g +1,$s/sla_DSEP/slDSEP/g +1,$s/sla_DTF2D/slDTFD/g +1,$s/sla_DTF2R/slDTFR/g +1,$s/sla_DTP2S/slDTPS/g +1,$s/sla_DTP2V/slDTPV/g +1,$s/sla_DTPS2C/slDPSC/g +1,$s/sla_DTPV2C/slDPVC/g +1,$s/sla_DTT/slDTT/g +1,$s/sla_DT/slDT/g + +1,$s/sla_DV2TP/slDVTP/g +1,$s/sla_DVDV/slDVDV/g +1,$s/sla_DVN/slDVN/g +1,$s/sla_DVXV/slDVXV/g + +1,$s/sla_E2H/slE2H/g +1,$s/sla_EARTH/slERTH/g +1,$s/sla_ECLEQ/slECEQ/g +1,$s/sla_ECMAT/slECMA/g +1,$s/sla_ECOR/slECOR/g +1,$s/sla_EG50/slEG50/g +1,$s/sla_EL2UE/slELUE/g +1,$s/sla_EPB2D/slEB2D/g +1,$s/sla_EPB/slEPB/g +1,$s/sla_EPCO/slEPCO/g +1,$s/sla_EPJ2D/slEJ2D/g +1,$s/sla_EPJ/slEPJ/g +1,$s/sla_EQECL/slEQEC/g +1,$s/sla_EQEQX/slEQEX/g +1,$s/sla_EQGAL/slEQGA/g +1,$s/sla_ETRMS/slETRM/g +1,$s/sla_EULER/slEULR/g +1,$s/sla_EVP/slEVP/g + +1,$s/sla_FITXY/slFTXY/g +1,$s/sla_FK425/slFK45/g +1,$s/sla_FK45Z/slF45Z/g +1,$s/sla_FK524/slFK54/g +1,$s/sla_FK52H/slFK5H/g +1,$s/sla_FK54Z/slF54Z/g +1,$s/sla_FK5HZ/slF5HZ/g +1,$s/sla_FLOTIN/slRFLI/g + +1,$s/sla_GALEQ/slGAEQ/g +1,$s/sla_GALSUP/slGASU/g +1,$s/sla_GE50/slGE50/g +1,$s/sla_GEOC/slGEOC/g +1,$s/sla_GMSTA/slGMSA/g +1,$s/sla_GMST/slGMST/g +1,$s/sla_GRESID/slGRES/g + +1,$s/sla_H2E/slH2E/g +1,$s/sla_H2FK5/slHFK5/g +1,$s/sla_HFK5Z/slHF5Z/g + +1,$s/sla__IDCHI/slICHI/g +1,$s/sla__IDCHF/slICHF/g +1,$s/sla_IMXV/slIMXV/g +1,$s/sla_INTIN/slINTI/g +1,$s/sla_INVF/slINVF/g + +1,$s/sla_KBJ/slKBJ/g + +1,$s/sla_M2AV/slM2AV/g +1,$s/sla_MAPPA/slMAPA/g +1,$s/sla_MAPQKZ/slMAPZ/g +1,$s/sla_MAPQK/slMAPQ/g +1,$s/sla_MAP/slMAP/g +1,$s/sla_MOON/slMOON/g +1,$s/sla_MXM/slMXM/g +1,$s/sla_MXV/slMXV/g + +1,$s/sla_NUTC/slNUTC/g +1,$s/sla_NUT/slNUT/g + +1,$s/sla_OAPQK/slOAPQ/g +1,$s/sla_OAP/slOAP/g +1,$s/sla_OBS/slOBS/g + +1,$s/sla_PA/slPA/g +1,$s/sla_PAV/slPAV/g +1,$s/sla_PCD/slPCD/g +1,$s/sla_PDA2H/slPDAH/g +1,$s/sla_PDQ2H/slPDQH/g +1,$s/sla_PERTEL/slPRTL/g +1,$s/sla_PERTUE/slPRTE/g +1,$s/sla_PLANEL/slPLNE/g +1,$s/sla_PLANET/slPLNT/g +1,$s/sla_PLANTE/slPLTE/g +1,$s/sla_PM/slPM/g +1,$s/sla_POLMO/slPLMO/g +1,$s/sla_PREBN/slPRBN/g +1,$s/sla_PRECES/slPRCE/g +1,$s/sla_PRECL/slPREL/g +1,$s/sla_PREC/slPREC/g +1,$s/sla_PRENUT/slPRNU/g +1,$s/sla_PV2EL/slPVEL/g +1,$s/sla_PV2UE/slPVUE/g +1,$s/sla_PVOBS/slPVOB/g +1,$s/sla_PXY/slPXY/g + +1,$s/sla_RANDOM/slRNDM/g +1,$s/sla_RANGE/slRA1P/g +1,$s/sla_RANORM/slRA2P/g +1,$s/sla_RCC/slRCC/g +1,$s/sla_RDPLAN/slRDPL/g +1,$s/sla_REFCOQ/slRFCQ/g +1,$s/sla_REFCO/slRFCO/g +1,$s/sla_REFRO/slRFRO/g +1,$s/sla_REFV/slREFV/g +1,$s/sla_REFZ/slREFZ/g +1,$s/sla_RVEROT/slRVER/g +1,$s/sla_RVGALC/slRVGA/g +1,$s/sla_RVLG/slRVLG/g +1,$s/sla_RVLSRD/slRVLD/g +1,$s/sla_RVLSRK/slRVLK/g + +1,$s/sla_S2TP/slS2TP/g +1,$s/sla_SEP/slSEP/g +1,$s/sla_SMAT/slSMAT/g +1,$s/sla_SUBET/slSUET/g +1,$s/sla_SUPGAL/slSUGA/g +1,$s/sla_SVDCOV/slSVDC/g +1,$s/sla_SVDSOL/slSVDS/g +1,$s/sla_SVD/slSVD/g + +1,$s/sla_TP2S/slTP2S/g +1,$s/sla_TP2V/slTP2V/g +1,$s/sla_TPS2C/slTPSC/g +1,$s/sla_TPV2C/slTPVC/g + +1,$s/sla_UE2EL/slUEEL/g +1,$s/sla_UE2PV/slUEPV/g +1,$s/sla_UNPCD/slUPCD/g + +1,$s/sla_V2TP/slV2TP/g +1,$s/sla_VDV/slVDV/g +1,$s/sla_VN/slVN/g +1,$s/sla_VXV/slVXV/g + +1,$s/sla_WAIT/slWAIT/g +1,$s/sla_XY2XY/slXYXY/g + +1,$s/sla_ZD/slZD/g + + +1,$s/sla_COMBN/slCMBN/g +1,$s/sla_EPV/slEPV/g +1,$s/sla_PERMUT/slPERM/g +1,$s/sla_PLANTU/slPLTU/g +1,$s/sla_VERI/slVERI/g +1,$s/sla_WAIT/slWAIT/g diff --git a/math/slalib/SED2 b/math/slalib/SED2 new file mode 100644 index 00000000..e63ffd7a --- /dev/null +++ b/math/slalib/SED2 @@ -0,0 +1,132 @@ +1,$s/A D D E T/A D E T/g +1,$s/A I R M A S/A R M S/g +1,$s/A L T A Z/A L A Z/g +1,$s/A M P Q K/A M P Q/g +1,$s/A O P P A T/A O P T/g +1,$s/A O P P A/A O P A/g +1,$s/A O P Q K/A O P Q/g +1,$s/A T M D S P/A T M D/g + + +1,$s/C A F 2 R/C A F R/g +1,$s/C A L D J/C A D J/g +1,$s/C A L Y D/C A Y D/g +1,$s/C C 6 2 S/C 6 2 S/g +1,$s/C D 2 T F/C D T F/g +1,$s/C R 2 A F/C R A F/g +1,$s/C R 2 T F/C R T F/g +1,$s/C S 2 C 6/S 2 C 6/g +1,$s/C T F 2 D/C T F D/g +1,$s/C T F 2 R/C T F R/g + +1,$s/D A F 2 R/D A F R/g +1,$s/D A F I N/D A F N/g +1,$s/D A V 2 M/D A V M/g +1,$s/D B E A R/D B E R/g +1,$s/D B J I N/D B J I/g +1,$s/D C 6 2 S/D C 6 S/g +1,$s/D C C 2 S/D C 2 S/g +1,$s/D C M P F/D C M F/g +1,$s/D C S 2 C/D S 2 C/g +1,$s/D D 2 T F/D D T F/g +1,$s/D E U L E R/D E U L/g +1,$s/D F L T I N/D F L I/g +1,$s/D I M X V/D I M V/g +1,$s/D J C A L/D J C A/g +1,$s/D M 2 A V/D M A V/g +1,$s/D M O O N/D M O N/g +1,$s/D R 2 A F/D R A F/g +1,$s/D R 2 T F/D R T F/g +1,$s/D R A N G E/D A 1 P/g +1,$s/D R A N R M/D A 2 P/g +1,$s/D S 2 C 6/D S C 6/g +1,$s/D S 2 T P/D S T P/g +1,$s/D T F 2 D/D T F D/g +1,$s/D T F 2 R/D T F R/g +1,$s/D T P 2 S/D T P S/g +1,$s/D T P 2 V/D T P V/g +1,$s/D T P S 2 C/D P S C/g +1,$s/D T P V 2 C/D P V C/g +1,$s/D V 2 T P/D V T P/g + +1,$s/E A R T H/E R T H/g +1,$s/E C L E Q/E C E Q/g +1,$s/E C M A T/E C M A/g +1,$s/E L 2 U E/E L U E/g +1,$s/E P B 2 D/E B 2 D/g +1,$s/E P J 2 D/E J 2 D/g +1,$s/E Q E C L/E Q E C/g +1,$s/E Q E Q X/E Q E X/g +1,$s/E Q G A L/E Q G A/g +1,$s/E T R M S/E T R M/g +1,$s/E U L E R/E U L R/g + +1,$s/F I T X Y/F T X Y/g +1,$s/F K 4 2 5/F K 4 5/g +1,$s/F K 4 5 Z/F 4 5 Z/g +1,$s/F K 5 2 4/F K 5 4/g +1,$s/F K 5 2 H/F K 5 H/g +1,$s/F K 5 4 Z/F 5 4 Z/g +1,$s/F K 5 H Z/F 5 H Z/g + +1,$s/F L O T I N/R F L I/g + +1,$s/G A L E Q/G A E Q/g +1,$s/G A L S U P/G A S U/g +1,$s/G M S T A/G M S A/g +1,$s/G R E S I D/G R E S/g + +1,$s/H 2 F K 5/H F K 5/g +1,$s/H F K 5 Z/H F 5 Z/g + +1,$s/I D C H I/I C H I/g +1,$s/I D C H F/I C H F/g +1,$s/I N T I N/I N T I/g + +1,$s/M A P P A/M A P A/g +1,$s/M A P Q K Z/M A P Z/g +1,$s/M A P Q K/M A P Q/g + +1,$s/O A P Q K/O A P Q/g + +1,$s/P D A 2 H/P D A H/g +1,$s/P D Q 2 H/P D Q H/g +1,$s/P E R T E L/P R T L/g +1,$s/P E R T U E/P R T E/g +1,$s/P L A N E L/P L N L/g +1,$s/P L A N E T/P L N T/g +1,$s/P L A N T E/P L T E/g +1,$s/P O L M O/P L M O/g +1,$s/P R E B N/P R B N/g +1,$s/P R E C E S/P R C E/g +1,$s/P R E C L/P R E L/g +1,$s/P R E N U T/P R N U/g +1,$s/P V 2 U E/P V U E/g +1,$s/P V 2 E L/P V E L/g +1,$s/P V O B S/P V O B/g + +1,$s/R A N D O M/R N D M/g +1,$s/R A N G E/R A 1 P/g +1,$s/R A N O R M/R A 2 P/g +1,$s/R D P L A N/R D P L/g +1,$s/R E F C O Q/R F C Q/g +1,$s/R E F C O/R F C O/g +1,$s/R E F R O/R F R O/g +1,$s/R V E R O T/R V E R/g +1,$s/R V G A L C/R V G A/g +1,$s/R V L S R D/R V L D/g +1,$s/R V L S R K/R V L K/g + +1,$s/S U B E T/S U E T/g +1,$s/S U P G A L/S U G A/g +1,$s/S V D C O V/S V D C/g +1,$s/S V D S O L/S V D S/g + +1,$s/T P S 2 C/T P S C/g +1,$s/T P V 2 C/T P V C/g + +1,$s/U E 2 E L/U E E L/g +1,$s/U E 2 P V/U E P V/g +1,$s/U N P C D/U P C D/g + +1,$s/X Y 2 X Y/X Y X Y/g diff --git a/math/slalib/SLA_CONDITIONS b/math/slalib/SLA_CONDITIONS new file mode 100644 index 00000000..2bc1e36b --- /dev/null +++ b/math/slalib/SLA_CONDITIONS @@ -0,0 +1,280 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/math/slalib/addet.f b/math/slalib/addet.f new file mode 100644 index 00000000..4c58c8a8 --- /dev/null +++ b/math/slalib/addet.f @@ -0,0 +1,85 @@ + SUBROUTINE slADET (RM, DM, EQ, RC, DC) +*+ +* - - - - - - +* A D E T +* - - - - - - +* +* Add the E-terms (elliptic component of annual aberration) +* to a pre IAU 1976 mean place to conform to the old +* catalogue convention (double precision) +* +* Given: +* RM,DM dp RA,Dec (radians) without E-terms +* EQ dp Besselian epoch of mean equator and equinox +* +* Returned: +* RC,DC dp RA,Dec (radians) with E-terms included +* +* Note: +* +* Most star positions from pre-1984 optical catalogues (or +* derived from astrometry using such stars) embody the +* E-terms. If it is necessary to convert a formal mean +* place (for example a pulsar timing position) to one +* consistent with such a star catalogue, then the RA,Dec +* should be adjusted using this routine. +* +* Reference: +* Explanatory Supplement to the Astronomical Ephemeris, +* section 2D, page 48. +* +* Called: slETRM, slDS2C, slDC2S, slDA2P, slDA1P +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RM,DM,EQ,RC,DC + + DOUBLE PRECISION slDA2P + + DOUBLE PRECISION A(3),V(3) + + INTEGER I + + + +* E-terms vector + CALL slETRM(EQ,A) + +* Spherical to Cartesian + CALL slDS2C(RM,DM,V) + +* Include the E-terms + DO I=1,3 + V(I)=V(I)+A(I) + END DO + +* Cartesian to spherical + CALL slDC2S(V,RC,DC) + +* Bring RA into conventional range + RC=slDA2P(RC) + + END diff --git a/math/slalib/afin.f b/math/slalib/afin.f new file mode 100644 index 00000000..7e7fac4f --- /dev/null +++ b/math/slalib/afin.f @@ -0,0 +1,120 @@ + SUBROUTINE slAFIN (STRING, IPTR, A, J) +*+ +* - - - - - +* A F I N +* - - - - - +* +* Sexagesimal character string to angle (single precision) +* +* Given: +* STRING c*(*) string containing deg, arcmin, arcsec fields +* IPTR i pointer to start of decode (1st = 1) +* +* Returned: +* IPTR i advanced past the decoded angle +* A r angle in radians +* J i status: 0 = OK +* +1 = default, A unchanged +* -1 = bad degrees ) +* -2 = bad arcminutes ) (note 3) +* -3 = bad arcseconds ) +* +* Example: +* +* argument before after +* +* STRING '-57 17 44.806 12 34 56.7' unchanged +* IPTR 1 16 (points to 12...) +* A ? -1.00000 +* J ? 0 +* +* A further call to slAFIN, without adjustment of IPTR, will +* decode the second angle, 12deg 34min 56.7sec. +* +* Notes: +* +* 1) The first three "fields" in STRING are degrees, arcminutes, +* arcseconds, separated by spaces or commas. The degrees field +* may be signed, but not the others. The decoding is carried +* out by the DFLTIN routine and is free-format. +* +* 2) Successive fields may be absent, defaulting to zero. For +* zero status, the only combinations allowed are degrees alone, +* degrees and arcminutes, and all three fields present. If all +* three fields are omitted, a status of +1 is returned and A is +* unchanged. In all other cases A is changed. +* +* 3) Range checking: +* +* The degrees field is not range checked. However, it is +* expected to be integral unless the other two fields are +* absent. +* +* The arcminutes field is expected to be 0-59, and integral if +* the arcseconds field is present. If the arcseconds field +* is absent, the arcminutes is expected to be 0-59.9999... +* +* The arcseconds field is expected to be 0-59.9999... +* +* 4) Decoding continues even when a check has failed. Under these +* circumstances the field takes the supplied value, defaulting +* to zero, and the result A is computed and returned. +* +* 5) Further fields after the three expected ones are not treated +* as an error. The pointer IPTR is left in the correct state +* for further decoding with the present routine or with DFLTIN +* etc. See the example, above. +* +* 6) If STRING contains hours, minutes, seconds instead of degrees +* etc, or if the required units are turns (or days) instead of +* radians, the result A should be multiplied as follows: +* +* for to obtain multiply +* STRING A in A by +* +* d ' " radians 1 = 1.0 +* d ' " turns 1/2pi = 0.1591549430918953358 +* h m s radians 15 = 15.0 +* h m s days 15/2pi = 2.3873241463784300365 +* +* Called: slDAFN +* +* P.T.Wallace Starlink 13 September 1990 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER IPTR + REAL A + INTEGER J + + DOUBLE PRECISION AD + + + +* Call the double precision version + CALL slDAFN(STRING,IPTR,AD,J) + IF (J.LE.0) A=REAL(AD) + + END diff --git a/math/slalib/airmas.f b/math/slalib/airmas.f new file mode 100644 index 00000000..aa9d08f0 --- /dev/null +++ b/math/slalib/airmas.f @@ -0,0 +1,76 @@ + DOUBLE PRECISION FUNCTION slARMS (ZD) +*+ +* - - - - - - - +* A R M S +* - - - - - - - +* +* Air mass at given zenith distance (double precision) +* +* Given: +* ZD d Observed zenith distance (radians) +* +* The result is an estimate of the air mass, in units of that +* at the zenith. +* +* Notes: +* +* 1) The "observed" zenith distance referred to above means "as +* affected by refraction". +* +* 2) Uses Hardie's (1962) polynomial fit to Bemporad's data for +* the relative air mass, X, in units of thickness at the zenith +* as tabulated by Schoenberg (1929). This is adequate for all +* normal needs as it is accurate to better than 0.1% up to X = +* 6.8 and better than 1% up to X = 10. Bemporad's tabulated +* values are unlikely to be trustworthy to such accuracy +* because of variations in density, pressure and other +* conditions in the atmosphere from those assumed in his work. +* +* 3) The sign of the ZD is ignored. +* +* 4) At zenith distances greater than about ZD = 87 degrees the +* air mass is held constant to avoid arithmetic overflows. +* +* References: +* Hardie, R.H., 1962, in "Astronomical Techniques" +* ed. W.A. Hiltner, University of Chicago Press, p180. +* Schoenberg, E., 1929, Hdb. d. Ap., +* Berlin, Julius Springer, 2, 268. +* +* Original code by P.W.Hill, St Andrews +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ZD + + DOUBLE PRECISION SECZM1 + + + SECZM1 = 1D0/(COS(MIN(1.52D0,ABS(ZD))))-1D0 + slARMS = 1D0 + SECZM1*(0.9981833D0 + : - SECZM1*(0.002875D0 + 0.0008083D0*SECZM1)) + + END diff --git a/math/slalib/altaz.f b/math/slalib/altaz.f new file mode 100644 index 00000000..ca34a0d4 --- /dev/null +++ b/math/slalib/altaz.f @@ -0,0 +1,163 @@ + SUBROUTINE slALAZ (HA, DEC, PHI, + : AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD) +*+ +* - - - - - - +* A L A Z +* - - - - - - +* +* Positions, velocities and accelerations for an altazimuth +* telescope mount. +* +* (double precision) +* +* Given: +* HA d hour angle +* DEC d declination +* PHI d observatory latitude +* +* Returned: +* AZ d azimuth +* AZD d " velocity +* AZDD d " acceleration +* EL d elevation +* ELD d " velocity +* ELDD d " acceleration +* PA d parallactic angle +* PAD d " " velocity +* PADD d " " acceleration +* +* Notes: +* +* 1) Natural units are used throughout. HA, DEC, PHI, AZ, EL +* and ZD are in radians. The velocities and accelerations +* assume constant declination and constant rate of change of +* hour angle (as for tracking a star); the units of AZD, ELD +* and PAD are radians per radian of HA, while the units of AZDD, +* ELDD and PADD are radians per radian of HA squared. To +* convert into practical degree- and second-based units: +* +* angles * 360/2pi -> degrees +* velocities * (2pi/86400)*(360/2pi) -> degree/sec +* accelerations * ((2pi/86400)**2)*(360/2pi) -> degree/sec/sec +* +* Note that the seconds here are sidereal rather than SI. One +* sidereal second is about 0.99727 SI seconds. +* +* The velocity and acceleration factors assume the sidereal +* tracking case. Their respective numerical values are (exactly) +* 1/240 and (approximately) 1/3300236.9. +* +* 2) Azimuth is returned in the range 0-2pi; north is zero, +* and east is +pi/2. Elevation and parallactic angle are +* returned in the range +/-pi. Parallactic angle is +ve for +* a star west of the meridian and is the angle NP-star-zenith. +* +* 3) The latitude is geodetic as opposed to geocentric. The +* hour angle and declination are topocentric. Refraction and +* deficiencies in the telescope mounting are ignored. The +* purpose of the routine is to give the general form of the +* quantities. The details of a real telescope could profoundly +* change the results, especially close to the zenith. +* +* 4) No range checking of arguments is carried out. +* +* 5) In applications which involve many such calculations, rather +* than calling the present routine it will be more efficient to +* use inline code, having previously computed fixed terms such +* as sine and cosine of latitude, and (for tracking a star) +* sine and cosine of declination. +* +* This revision: 29 October 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION HA,DEC,PHI,AZ,AZD,AZDD,EL,ELD,ELDD,PA,PAD,PADD + + DOUBLE PRECISION DPI,D2PI,TINY + PARAMETER (DPI=3.1415926535897932384626433832795D0, + : D2PI=6.283185307179586476925286766559D0, + : TINY=1D-30) + + DOUBLE PRECISION SH,CH,SD,CD,SP,CP,CHCD,SDCP,X,Y,Z,RSQ,R,A,E,C,S, + : Q,QD,AD,ED,EDR,ADD,EDD,QDD + + +* Useful functions + SH=SIN(HA) + CH=COS(HA) + SD=SIN(DEC) + CD=COS(DEC) + SP=SIN(PHI) + CP=COS(PHI) + CHCD=CH*CD + SDCP=SD*CP + X=-CHCD*SP+SDCP + Y=-SH*CD + Z=CHCD*CP+SD*SP + RSQ=X*X+Y*Y + R=SQRT(RSQ) + +* Azimuth and elevation + IF (RSQ.EQ.0D0) THEN + A=0D0 + ELSE + A=ATAN2(Y,X) + END IF + IF (A.LT.0D0) A=A+D2PI + E=ATAN2(Z,R) + +* Parallactic angle + C=CD*SP-CH*SDCP + S=SH*CP + IF (C*C+S*S.GT.0) THEN + Q=ATAN2(S,C) + ELSE + Q=DPI-HA + END IF + +* Velocities and accelerations (clamped at zenith/nadir) + IF (RSQ.LT.TINY) THEN + RSQ=TINY + R=SQRT(RSQ) + END IF + QD=-X*CP/RSQ + AD=SP+Z*QD + ED=CP*Y/R + EDR=ED/R + ADD=EDR*(Z*SP+(2D0-RSQ)*QD) + EDD=-R*QD*AD + QDD=EDR*(SP+2D0*Z*QD) + +* Results + AZ=A + AZD=AD + AZDD=ADD + EL=E + ELD=ED + ELDD=EDD + PA=Q + PAD=QD + PADD=QDD + + END diff --git a/math/slalib/amp.f b/math/slalib/amp.f new file mode 100644 index 00000000..d6aff8df --- /dev/null +++ b/math/slalib/amp.f @@ -0,0 +1,89 @@ + SUBROUTINE slAMP (RA, DA, DATE, EQ, RM, DM) +*+ +* - - - - +* A M P +* - - - - +* +* Convert star RA,Dec from geocentric apparent to mean place +* +* The mean coordinate system is the post IAU 1976 system, +* loosely called FK5. +* +* Given: +* RA d apparent RA (radians) +* DA d apparent Dec (radians) +* DATE d TDB for apparent place (JD-2400000.5) +* EQ d equinox: Julian epoch of mean place +* +* Returned: +* RM d mean RA (radians) +* DM d mean Dec (radians) +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Notes: +* +* 1) The distinction between the required TDB and TT is always +* negligible. Moreover, for all but the most critical +* applications UTC is adequate. +* +* 2) Iterative techniques are used for the aberration and light +* deflection corrections so that the routines slAMP (or +* slAMPQ) and slMAP (or slMAPQ) are accurate inverses; +* even at the edge of the Sun's disc the discrepancy is only +* about 1 nanoarcsecond. +* +* 3) Where multiple apparent places are to be converted to mean +* places, for a fixed date and equinox, it is more efficient to +* use the slMAPA routine to compute the required parameters +* once, followed by one call to slAMPQ per star. +* +* 4) The accuracy is sub-milliarcsecond, limited by the +* precession-nutation model (IAU 1976 precession, Shirai & +* Fukushima 2001 forced nutation and precession corrections). +* +* 5) The accuracy is further limited by the routine slEVP, called +* by slMAPA, which computes the Earth position and velocity +* using the methods of Stumpff. The maximum error is about +* 0.3 mas. +* +* Called: slMAPA, slAMPQ +* +* P.T.Wallace Starlink 17 September 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RA,DA,DATE,EQ,RM,DM + + DOUBLE PRECISION AMPRMS(21) + + + + CALL slMAPA(EQ,DATE,AMPRMS) + CALL slAMPQ(RA,DA,AMPRMS,RM,DM) + + END diff --git a/math/slalib/ampqk.f b/math/slalib/ampqk.f new file mode 100644 index 00000000..4bf95b69 --- /dev/null +++ b/math/slalib/ampqk.f @@ -0,0 +1,140 @@ + SUBROUTINE slAMPQ (RA, DA, AMPRMS, RM, DM) +*+ +* - - - - - - +* A M P Q +* - - - - - - +* +* Convert star RA,Dec from geocentric apparent to mean place +* +* The mean coordinate system is the post IAU 1976 system, +* loosely called FK5. +* +* Use of this routine is appropriate when efficiency is important +* and where many star positions are all to be transformed for +* one epoch and equinox. The star-independent parameters can be +* obtained by calling the slMAPA routine. +* +* Given: +* RA d apparent RA (radians) +* DA d apparent Dec (radians) +* +* AMPRMS d(21) star-independent mean-to-apparent parameters: +* +* (1) time interval for proper motion (Julian years) +* (2-4) barycentric position of the Earth (AU) +* (5-7) heliocentric direction of the Earth (unit vector) +* (8) (grav rad Sun)*2/(Sun-Earth distance) +* (9-11) ABV: barycentric Earth velocity in units of c +* (12) sqrt(1-v**2) where v=modulus(ABV) +* (13-21) precession/nutation (3,3) matrix +* +* Returned: +* RM d mean RA (radians) +* DM d mean Dec (radians) +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Note: +* +* Iterative techniques are used for the aberration and +* light deflection corrections so that the routines +* slAMP (or slAMPQ) and slMAP (or slMAPQ) are +* accurate inverses; even at the edge of the Sun's disc +* the discrepancy is only about 1 nanoarcsecond. +* +* Called: slDS2C, slDIMV, slDVDV, slDVN, slDC2S, +* slDA2P +* +* P.T.Wallace Starlink 7 May 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RA,DA,AMPRMS(21),RM,DM + + INTEGER I,J + + DOUBLE PRECISION GR2E,AB1,EHN(3),ABV(3),P3(3),P2(3), + : AB1P1,P1DV,P1DVP1,P1(3),W,PDE,PDEP1,P(3) + + DOUBLE PRECISION slDVDV,slDA2P + + + +* Unpack scalar and vector parameters + GR2E = AMPRMS(8) + AB1 = AMPRMS(12) + DO I=1,3 + EHN(I) = AMPRMS(I+4) + ABV(I) = AMPRMS(I+8) + END DO + +* Apparent RA,Dec to Cartesian + CALL slDS2C(RA,DA,P3) + +* Precession and nutation + CALL slDIMV(AMPRMS(13),P3,P2) + +* Aberration + AB1P1 = AB1+1D0 + DO I=1,3 + P1(I) = P2(I) + END DO + DO J=1,2 + P1DV = slDVDV(P1,ABV) + P1DVP1 = 1D0+P1DV + W = 1D0+P1DV/AB1P1 + DO I=1,3 + P1(I) = (P1DVP1*P2(I)-W*ABV(I))/AB1 + END DO + CALL slDVN(P1,P3,W) + DO I=1,3 + P1(I) = P3(I) + END DO + END DO + +* Light deflection + DO I=1,3 + P(I) = P1(I) + END DO + DO J=1,5 + PDE = slDVDV(P,EHN) + PDEP1 = 1D0+PDE + W = PDEP1-GR2E*PDE + DO I=1,3 + P(I) = (PDEP1*P1(I)-GR2E*EHN(I))/W + END DO + CALL slDVN(P,P2,W) + DO I=1,3 + P(I) = P2(I) + END DO + END DO + +* Mean RA,Dec + CALL slDC2S(P,RM,DM) + RM = slDA2P(RM) + + END diff --git a/math/slalib/aop.f b/math/slalib/aop.f new file mode 100644 index 00000000..0155deb1 --- /dev/null +++ b/math/slalib/aop.f @@ -0,0 +1,192 @@ + SUBROUTINE slAOP ( RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, + : XP, YP, TDK, PMB, RH, WL, TLR, + : AOB, ZOB, HOB, DOB, ROB ) +*+ +* - - - - +* A O P +* - - - - +* +* Apparent to observed place, for sources distant from the solar +* system. +* +* Given: +* RAP d geocentric apparent right ascension +* DAP d geocentric apparent declination +* DATE d UTC date/time (Modified Julian Date, JD-2400000.5) +* DUT d delta UT: UT1-UTC (UTC seconds) +* ELONGM d mean longitude of the observer (radians, east +ve) +* PHIM d mean geodetic latitude of the observer (radians) +* HM d observer's height above sea level (metres) +* XP d polar motion x-coordinate (radians) +* YP d polar motion y-coordinate (radians) +* TDK d local ambient temperature (K; std=273.15D0) +* PMB d local atmospheric pressure (mb; std=1013.25D0) +* RH d local relative humidity (in the range 0D0-1D0) +* WL d effective wavelength (micron, e.g. 0.55D0) +* TLR d tropospheric lapse rate (K/metre, e.g. 0.0065D0) +* +* Returned: +* AOB d observed azimuth (radians: N=0,E=90) +* ZOB d observed zenith distance (radians) +* HOB d observed Hour Angle (radians) +* DOB d observed Declination (radians) +* ROB d observed Right Ascension (radians) +* +* Notes: +* +* 1) This routine returns zenith distance rather than elevation +* in order to reflect the fact that no allowance is made for +* depression of the horizon. +* +* 2) The accuracy of the result is limited by the corrections for +* refraction. Providing the meteorological parameters are +* known accurately and there are no gross local effects, the +* predicted apparent RA,Dec should be within about 0.1 arcsec +* for a zenith distance of less than 70 degrees. Even at a +* topocentric zenith distance of 90 degrees, the accuracy in +* elevation should be better than 1 arcmin; useful results +* are available for a further 3 degrees, beyond which the +* slRFRO routine returns a fixed value of the refraction. +* The complementary routines slAOP (or slAOPQ) and slOAP +* (or slOAPQ) are self-consistent to better than 1 micro- +* arcsecond all over the celestial sphere. +* +* 3) It is advisable to take great care with units, as even +* unlikely values of the input parameters are accepted and +* processed in accordance with the models used. +* +* 4) "Apparent" place means the geocentric apparent right ascension +* and declination, which is obtained from a catalogue mean place +* by allowing for space motion, parallax, precession, nutation, +* annual aberration, and the Sun's gravitational lens effect. For +* star positions in the FK5 system (i.e. J2000), these effects can +* be applied by means of the slMAP etc routines. Starting from +* other mean place systems, additional transformations will be +* needed; for example, FK4 (i.e. B1950) mean places would first +* have to be converted to FK5, which can be done with the +* slFK45 etc routines. +* +* 5) "Observed" Az,El means the position that would be seen by a +* perfect theodolite located at the observer. This is obtained +* from the geocentric apparent RA,Dec by allowing for Earth +* orientation and diurnal aberration, rotating from equator +* to horizon coordinates, and then adjusting for refraction. +* The HA,Dec is obtained by rotating back into equatorial +* coordinates, using the geodetic latitude corrected for polar +* motion, and is the position that would be seen by a perfect +* equatorial located at the observer and with its polar axis +* aligned to the Earth's axis of rotation (n.b. not to the +* refracted pole). Finally, the RA is obtained by subtracting +* the HA from the local apparent ST. +* +* 6) To predict the required setting of a real telescope, the +* observed place produced by this routine would have to be +* adjusted for the tilt of the azimuth or polar axis of the +* mounting (with appropriate corrections for mount flexures), +* for non-perpendicularity between the mounting axes, for the +* position of the rotator axis and the pointing axis relative +* to it, for tube flexure, for gear and encoder errors, and +* finally for encoder zero points. Some telescopes would, of +* course, exhibit other properties which would need to be +* accounted for at the appropriate point in the sequence. +* +* 7) This routine takes time to execute, due mainly to the +* rigorous integration used to evaluate the refraction. +* For processing multiple stars for one location and time, +* call slAOPA once followed by one call per star to slAOPQ. +* Where a range of times within a limited period of a few hours +* is involved, and the highest precision is not required, call +* slAOPA once, followed by a call to slAOPT each time the +* time changes, followed by one call per star to slAOPQ. +* +* 8) The DATE argument is UTC expressed as an MJD. This is, +* strictly speaking, wrong, because of leap seconds. However, +* as long as the delta UT and the UTC are consistent there +* are no difficulties, except during a leap second. In this +* case, the start of the 61st second of the final minute should +* begin a new MJD day and the old pre-leap delta UT should +* continue to be used. As the 61st second completes, the MJD +* should revert to the start of the day as, simultaneously, +* the delta UTC changes by one second to its post-leap new value. +* +* 9) The delta UT (UT1-UTC) is tabulated in IERS circulars and +* elsewhere. It increases by exactly one second at the end of +* each UTC leap second, introduced in order to keep delta UT +* within +/- 0.9 seconds. +* +* 10) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. +* The longitude required by the present routine is east-positive, +* in accordance with geographical convention (and right-handed). +* In particular, note that the longitudes returned by the +* slOBS routine are west-positive, following astronomical +* usage, and must be reversed in sign before use in the present +* routine. +* +* 11) The polar coordinates XP,YP can be obtained from IERS +* circulars and equivalent publications. The maximum amplitude +* is about 0.3 arcseconds. If XP,YP values are unavailable, +* use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac +* for a definition of the two angles. +* +* 12) The height above sea level of the observing station, HM, +* can be obtained from the Astronomical Almanac (Section J +* in the 1988 edition), or via the routine slOBS. If P, +* the pressure in millibars, is available, an adequate +* estimate of HM can be obtained from the expression +* +* HM ~ -29.3D0*TSL*LOG(P/1013.25D0). +* +* where TSL is the approximate sea-level air temperature in K +* (see Astrophysical Quantities, C.W.Allen, 3rd edition, +* section 52). Similarly, if the pressure P is not known, +* it can be estimated from the height of the observing +* station, HM, as follows: +* +* P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). +* +* Note, however, that the refraction is nearly proportional to the +* pressure and that an accurate P value is important for precise +* work. +* +* 13) The azimuths etc produced by the present routine are with +* respect to the celestial pole. Corrections to the terrestrial +* pole can be computed using slPLMO. +* +* Called: slAOPA, slAOPQ +* +* Last revision: 2 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RAP,DAP,DATE,DUT,ELONGM,PHIM,HM, + : XP,YP,TDK,PMB,RH,WL,TLR,AOB,ZOB,HOB,DOB,ROB + + DOUBLE PRECISION AOPRMS(14) + + + CALL slAOPA(DATE,DUT,ELONGM,PHIM,HM,XP,YP,TDK,PMB,RH,WL,TLR, + : AOPRMS) + CALL slAOPQ(RAP,DAP,AOPRMS,AOB,ZOB,HOB,DOB,ROB) + + END diff --git a/math/slalib/aoppa.f b/math/slalib/aoppa.f new file mode 100644 index 00000000..a8d51ccc --- /dev/null +++ b/math/slalib/aoppa.f @@ -0,0 +1,194 @@ + SUBROUTINE slAOPA ( DATE, DUT, ELONGM, PHIM, HM, + : XP, YP, TDK, PMB, RH, WL, TLR, AOPRMS ) +*+ +* - - - - - - +* A O P A +* - - - - - - +* +* Precompute apparent to observed place parameters required by +* slAOPQ and slOAPQ. +* +* Given: +* DATE d UTC date/time (modified Julian Date, JD-2400000.5) +* DUT d delta UT: UT1-UTC (UTC seconds) +* ELONGM d mean longitude of the observer (radians, east +ve) +* PHIM d mean geodetic latitude of the observer (radians) +* HM d observer's height above sea level (metres) +* XP d polar motion x-coordinate (radians) +* YP d polar motion y-coordinate (radians) +* TDK d local ambient temperature (K; std=273.15D0) +* PMB d local atmospheric pressure (mb; std=1013.25D0) +* RH d local relative humidity (in the range 0D0-1D0) +* WL d effective wavelength (micron, e.g. 0.55D0) +* TLR d tropospheric lapse rate (K/metre, e.g. 0.0065D0) +* +* Returned: +* AOPRMS d(14) star-independent apparent-to-observed parameters: +* +* (1) geodetic latitude (radians) +* (2,3) sine and cosine of geodetic latitude +* (4) magnitude of diurnal aberration vector +* (5) height (HM) +* (6) ambient temperature (TDK) +* (7) pressure (PMB) +* (8) relative humidity (RH) +* (9) wavelength (WL) +* (10) lapse rate (TLR) +* (11,12) refraction constants A and B (radians) +* (13) longitude + eqn of equinoxes + sidereal DUT (radians) +* (14) local apparent sidereal time (radians) +* +* Notes: +* +* 1) It is advisable to take great care with units, as even +* unlikely values of the input parameters are accepted and +* processed in accordance with the models used. +* +* 2) The DATE argument is UTC expressed as an MJD. This is, +* strictly speaking, improper, because of leap seconds. However, +* as long as the delta UT and the UTC are consistent there +* are no difficulties, except during a leap second. In this +* case, the start of the 61st second of the final minute should +* begin a new MJD day and the old pre-leap delta UT should +* continue to be used. As the 61st second completes, the MJD +* should revert to the start of the day as, simultaneously, +* the delta UTC changes by one second to its post-leap new value. +* +* 3) The delta UT (UT1-UTC) is tabulated in IERS circulars and +* elsewhere. It increases by exactly one second at the end of +* each UTC leap second, introduced in order to keep delta UT +* within +/- 0.9 seconds. +* +* 4) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. +* The longitude required by the present routine is east-positive, +* in accordance with geographical convention (and right-handed). +* In particular, note that the longitudes returned by the +* slOBS routine are west-positive, following astronomical +* usage, and must be reversed in sign before use in the present +* routine. +* +* 5) The polar coordinates XP,YP can be obtained from IERS +* circulars and equivalent publications. The maximum amplitude +* is about 0.3 arcseconds. If XP,YP values are unavailable, +* use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac +* for a definition of the two angles. +* +* 6) The height above sea level of the observing station, HM, +* can be obtained from the Astronomical Almanac (Section J +* in the 1988 edition), or via the routine slOBS. If P, +* the pressure in millibars, is available, an adequate +* estimate of HM can be obtained from the expression +* +* HM ~ -29.3D0*TSL*LOG(P/1013.25D0). +* +* where TSL is the approximate sea-level air temperature in K +* (see Astrophysical Quantities, C.W.Allen, 3rd edition, +* section 52). Similarly, if the pressure P is not known, +* it can be estimated from the height of the observing +* station, HM, as follows: +* +* P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). +* +* Note, however, that the refraction is nearly proportional to the +* pressure and that an accurate P value is important for precise +* work. +* +* 7) Repeated, computationally-expensive, calls to slAOPA for +* times that are very close together can be avoided by calling +* slAOPA just once and then using slAOPT for the subsequent +* times. Fresh calls to slAOPA will be needed only when +* changes in the precession have grown to unacceptable levels or +* when anything affecting the refraction has changed. +* +* Called: slGEOC, slRFCO, slEQEX, slAOPT +* +* Last revision: 2 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,DUT,ELONGM,PHIM,HM,XP,YP,TDK,PMB, + : RH,WL,TLR,AOPRMS(14) + + DOUBLE PRECISION slEQEX + +* 2Pi + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925287D0) + +* Seconds of time to radians + DOUBLE PRECISION S2R + PARAMETER (S2R=7.272205216643039903848712D-5) + +* Speed of light (AU per day) + DOUBLE PRECISION C + PARAMETER (C=173.14463331D0) + +* Ratio between solar and sidereal time + DOUBLE PRECISION SOLSID + PARAMETER (SOLSID=1.00273790935D0) + + DOUBLE PRECISION CPHIM,XT,YT,ZT,XC,YC,ZC,ELONG,PHI,UAU,VAU + + + +* Observer's location corrected for polar motion + CPHIM = COS(PHIM) + XT = COS(ELONGM)*CPHIM + YT = SIN(ELONGM)*CPHIM + ZT = SIN(PHIM) + XC = XT-XP*ZT + YC = YT+YP*ZT + ZC = XP*XT-YP*YT+ZT + IF (XC.EQ.0D0.AND.YC.EQ.0D0) THEN + ELONG = 0D0 + ELSE + ELONG = ATAN2(YC,XC) + END IF + PHI = ATAN2(ZC,SQRT(XC*XC+YC*YC)) + AOPRMS(1) = PHI + AOPRMS(2) = SIN(PHI) + AOPRMS(3) = COS(PHI) + +* Magnitude of the diurnal aberration vector + CALL slGEOC(PHI,HM,UAU,VAU) + AOPRMS(4) = D2PI*UAU*SOLSID/C + +* Copy the refraction parameters and compute the A & B constants + AOPRMS(5) = HM + AOPRMS(6) = TDK + AOPRMS(7) = PMB + AOPRMS(8) = RH + AOPRMS(9) = WL + AOPRMS(10) = TLR + CALL slRFCO(HM,TDK,PMB,RH,WL,PHI,TLR,1D-10, + : AOPRMS(11),AOPRMS(12)) + +* Longitude + equation of the equinoxes + sidereal equivalent of DUT +* (ignoring change in equation of the equinoxes between UTC and TDB) + AOPRMS(13) = ELONG+slEQEX(DATE)+DUT*SOLSID*S2R + +* Sidereal time + CALL slAOPT(DATE,AOPRMS) + + END diff --git a/math/slalib/aoppat.f b/math/slalib/aoppat.f new file mode 100644 index 00000000..f086f7f7 --- /dev/null +++ b/math/slalib/aoppat.f @@ -0,0 +1,63 @@ + SUBROUTINE slAOPT (DATE, AOPRMS) +*+ +* - - - - - - - +* A O P T +* - - - - - - - +* +* Recompute the sidereal time in the apparent to observed place +* star-independent parameter block. +* +* Given: +* DATE d UTC date/time (modified Julian Date, JD-2400000.5) +* (see AOPPA source for comments on leap seconds) +* +* AOPRMS d(14) star-independent apparent-to-observed parameters +* +* (1-12) not required +* (13) longitude + eqn of equinoxes + sidereal DUT +* (14) not required +* +* Returned: +* AOPRMS d(14) star-independent apparent-to-observed parameters: +* +* (1-13) not changed +* (14) local apparent sidereal time (radians) +* +* For more information, see slAOPA. +* +* Called: slGMST +* +* P.T.Wallace Starlink 1 July 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,AOPRMS(14) + + DOUBLE PRECISION slGMST + + + + AOPRMS(14) = slGMST(DATE)+AOPRMS(13) + + END diff --git a/math/slalib/aopqk.f b/math/slalib/aopqk.f new file mode 100644 index 00000000..5e327d34 --- /dev/null +++ b/math/slalib/aopqk.f @@ -0,0 +1,260 @@ + SUBROUTINE slAOPQ (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB) +*+ +* - - - - - - +* A O P Q +* - - - - - - +* +* Quick apparent to observed place (but see note 8, below, for +* remarks about speed). +* +* Given: +* RAP d geocentric apparent right ascension +* DAP d geocentric apparent declination +* AOPRMS d(14) star-independent apparent-to-observed parameters: +* +* (1) geodetic latitude (radians) +* (2,3) sine and cosine of geodetic latitude +* (4) magnitude of diurnal aberration vector +* (5) height (HM) +* (6) ambient temperature (T) +* (7) pressure (P) +* (8) relative humidity (RH) +* (9) wavelength (WL) +* (10) lapse rate (TLR) +* (11,12) refraction constants A and B (radians) +* (13) longitude + eqn of equinoxes + sidereal DUT (radians) +* (14) local apparent sidereal time (radians) +* +* Returned: +* AOB d observed azimuth (radians: N=0,E=90) +* ZOB d observed zenith distance (radians) +* HOB d observed Hour Angle (radians) +* DOB d observed Declination (radians) +* ROB d observed Right Ascension (radians) +* +* Notes: +* +* 1) This routine returns zenith distance rather than elevation +* in order to reflect the fact that no allowance is made for +* depression of the horizon. +* +* 2) The accuracy of the result is limited by the corrections for +* refraction. Providing the meteorological parameters are +* known accurately and there are no gross local effects, the +* observed RA,Dec predicted by this routine should be within +* about 0.1 arcsec for a zenith distance of less than 70 degrees. +* Even at a topocentric zenith distance of 90 degrees, the +* accuracy in elevation should be better than 1 arcmin; useful +* results are available for a further 3 degrees, beyond which +* the slRFRO routine returns a fixed value of the refraction. +* The complementary routines slAOP (or slAOPQ) and sla_OaAP +* (or slOAPQ) are self-consistent to better than 1 micro- +* arcsecond all over the celestial sphere. +* +* 3) It is advisable to take great care with units, as even +* unlikely values of the input parameters are accepted and +* processed in accordance with the models used. +* +* 4) "Apparent" place means the geocentric apparent right ascension +* and declination, which is obtained from a catalogue mean place +* by allowing for space motion, parallax, precession, nutation, +* annual aberration, and the Sun's gravitational lens effect. For +* star positions in the FK5 system (i.e. J2000), these effects can +* be applied by means of the slMAP etc routines. Starting from +* other mean place systems, additional transformations will be +* needed; for example, FK4 (i.e. B1950) mean places would first +* have to be converted to FK5, which can be done with the +* slFK45 etc routines. +* +* 5) "Observed" Az,El means the position that would be seen by a +* perfect theodolite located at the observer. This is obtained +* from the geocentric apparent RA,Dec by allowing for Earth +* orientation and diurnal aberration, rotating from equator +* to horizon coordinates, and then adjusting for refraction. +* The HA,Dec is obtained by rotating back into equatorial +* coordinates, using the geodetic latitude corrected for polar +* motion, and is the position that would be seen by a perfect +* equatorial located at the observer and with its polar axis +* aligned to the Earth's axis of rotation (n.b. not to the +* refracted pole). Finally, the RA is obtained by subtracting +* the HA from the local apparent ST. +* +* 6) To predict the required setting of a real telescope, the +* observed place produced by this routine would have to be +* adjusted for the tilt of the azimuth or polar axis of the +* mounting (with appropriate corrections for mount flexures), +* for non-perpendicularity between the mounting axes, for the +* position of the rotator axis and the pointing axis relative +* to it, for tube flexure, for gear and encoder errors, and +* finally for encoder zero points. Some telescopes would, of +* course, exhibit other properties which would need to be +* accounted for at the appropriate point in the sequence. +* +* 7) The star-independent apparent-to-observed-place parameters +* in AOPRMS may be computed by means of the slAOPA routine. +* If nothing has changed significantly except the time, the +* slAOPT routine may be used to perform the requisite +* partial recomputation of AOPRMS. +* +* 8) At zenith distances beyond about 76 degrees, the need for +* special care with the corrections for refraction causes a +* marked increase in execution time. Moreover, the effect +* gets worse with increasing zenith distance. Adroit +* programming in the calling application may allow the +* problem to be reduced. Prepare an alternative AOPRMS array, +* computed for zero air-pressure; this will disable the +* refraction corrections and cause rapid execution. Using +* this AOPRMS array, a preliminary call to the present routine +* will, depending on the application, produce a rough position +* which may be enough to establish whether the full, slow +* calculation (using the real AOPRMS array) is worthwhile. +* For example, there would be no need for the full calculation +* if the preliminary call had already established that the +* source was well below the elevation limits for a particular +* telescope. +* +* 9) The azimuths etc produced by the present routine are with +* respect to the celestial pole. Corrections to the terrestrial +* pole can be computed using slPLMO. +* +* Called: slDS2C, slREFZ, slRFRO, slDC2S, slDA2P +* +* P.T.Wallace Starlink 24 October 2003 +* +* Copyright (C) 2003 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RAP,DAP,AOPRMS(14),AOB,ZOB,HOB,DOB,ROB + +* Breakpoint for fast/slow refraction algorithm: +* ZD greater than arctan(4), (see slRFCO routine) +* or vector Z less than cosine(arctan(Z)) = 1/sqrt(17) + DOUBLE PRECISION ZBREAK + PARAMETER (ZBREAK=0.242535625D0) + + INTEGER I + + DOUBLE PRECISION SPHI,CPHI,ST,V(3),XHD,YHD,ZHD,DIURAB,F, + : XHDT,YHDT,ZHDT,XAET,YAET,ZAET,AZOBS, + : ZDT,REFA,REFB,ZDOBS,DZD,DREF,CE, + : XAEO,YAEO,ZAEO,HMOBS,DCOBS,RAOBS + + DOUBLE PRECISION slDA2P + + + +* Sin, cos of latitude + SPHI = AOPRMS(2) + CPHI = AOPRMS(3) + +* Local apparent sidereal time + ST = AOPRMS(14) + +* Apparent RA,Dec to Cartesian -HA,Dec + CALL slDS2C(RAP-ST,DAP,V) + XHD = V(1) + YHD = V(2) + ZHD = V(3) + +* Diurnal aberration + DIURAB = AOPRMS(4) + F = (1D0-DIURAB*YHD) + XHDT = F*XHD + YHDT = F*(YHD+DIURAB) + ZHDT = F*ZHD + +* Cartesian -HA,Dec to Cartesian Az,El (S=0,E=90) + XAET = SPHI*XHDT-CPHI*ZHDT + YAET = YHDT + ZAET = CPHI*XHDT+SPHI*ZHDT + +* Azimuth (N=0,E=90) + IF (XAET.EQ.0D0.AND.YAET.EQ.0D0) THEN + AZOBS = 0D0 + ELSE + AZOBS = ATAN2(YAET,-XAET) + END IF + +* Topocentric zenith distance + ZDT = ATAN2(SQRT(XAET*XAET+YAET*YAET),ZAET) + +* +* Refraction +* ---------- + +* Fast algorithm using two constant model + REFA = AOPRMS(11) + REFB = AOPRMS(12) + CALL slREFZ(ZDT,REFA,REFB,ZDOBS) + +* Large zenith distance? + IF (COS(ZDOBS).LT.ZBREAK) THEN + +* Yes: use rigorous algorithm + +* Initialize loop (maximum of 10 iterations) + I = 1 + DZD = 1D1 + DO WHILE (ABS(DZD).GT.1D-10.AND.I.LE.10) + +* Compute refraction using current estimate of observed ZD + CALL slRFRO(ZDOBS,AOPRMS(5),AOPRMS(6),AOPRMS(7), + : AOPRMS(8),AOPRMS(9),AOPRMS(1), + : AOPRMS(10),1D-8,DREF) + +* Remaining discrepancy + DZD = ZDOBS+DREF-ZDT + +* Update the estimate + ZDOBS = ZDOBS-DZD + +* Increment the iteration counter + I = I+1 + END DO + END IF + +* To Cartesian Az/ZD + CE = SIN(ZDOBS) + XAEO = -COS(AZOBS)*CE + YAEO = SIN(AZOBS)*CE + ZAEO = COS(ZDOBS) + +* Cartesian Az/ZD to Cartesian -HA,Dec + V(1) = SPHI*XAEO+CPHI*ZAEO + V(2) = YAEO + V(3) = -CPHI*XAEO+SPHI*ZAEO + +* To spherical -HA,Dec + CALL slDC2S(V,HMOBS,DCOBS) + +* Right Ascension + RAOBS = slDA2P(ST+HMOBS) + +* Return the results + AOB = AZOBS + ZOB = ZDOBS + HOB = -HMOBS + DOB = DCOBS + ROB = RAOBS + + END diff --git a/math/slalib/atmdsp.f b/math/slalib/atmdsp.f new file mode 100644 index 00000000..76d43261 --- /dev/null +++ b/math/slalib/atmdsp.f @@ -0,0 +1,141 @@ + SUBROUTINE slATMD (TDK, PMB, RH, WL1, A1, B1, WL2, A2, B2) +*+ +* - - - - - - - +* A T M D +* - - - - - - - +* +* Apply atmospheric-dispersion adjustments to refraction coefficients. +* +* Given: +* TDK d ambient temperature, K +* PMB d ambient pressure, millibars +* RH d ambient relative humidity, 0-1 +* WL1 d reference wavelength, micrometre (0.4D0 recommended) +* A1 d refraction coefficient A for wavelength WL1 (radians) +* B1 d refraction coefficient B for wavelength WL1 (radians) +* WL2 d wavelength for which adjusted A,B required +* +* Returned: +* A2 d refraction coefficient A for wavelength WL2 (radians) +* B2 d refraction coefficient B for wavelength WL2 (radians) +* +* Notes: +* +* 1 To use this routine, first call slRFCO specifying WL1 as the +* wavelength. This yields refraction coefficients A1,B1, correct +* for that wavelength. Subsequently, calls to slATMD specifying +* different wavelengths will produce new, slightly adjusted +* refraction coefficients which apply to the specified wavelength. +* +* 2 Most of the atmospheric dispersion happens between 0.7 micrometre +* and the UV atmospheric cutoff, and the effect increases strongly +* towards the UV end. For this reason a blue reference wavelength +* is recommended, for example 0.4 micrometres. +* +* 3 The accuracy, for this set of conditions: +* +* height above sea level 2000 m +* latitude 29 deg +* pressure 793 mb +* temperature 17 degC +* humidity 50% +* lapse rate 0.0065 degC/m +* reference wavelength 0.4 micrometre +* star elevation 15 deg +* +* is about 2.5 mas RMS between 0.3 and 1.0 micrometres, and stays +* within 4 mas for the whole range longward of 0.3 micrometres +* (compared with a total dispersion from 0.3 to 20.0 micrometres +* of about 11 arcsec). These errors are typical for ordinary +* conditions and the given elevation; in extreme conditions values +* a few times this size may occur, while at higher elevations the +* errors become much smaller. +* +* 4 If either wavelength exceeds 100 micrometres, the radio case +* is assumed and the returned refraction coefficients are the +* same as the given ones. Note that radio refraction coefficients +* cannot be turned into optical values using this routine, nor +* vice versa. +* +* 5 The algorithm consists of calculation of the refractivity of the +* air at the observer for the two wavelengths, using the methods +* of the slRFRO routine, and then scaling of the two refraction +* coefficients according to classical refraction theory. This +* amounts to scaling the A coefficient in proportion to (n-1) and +* the B coefficient almost in the same ratio (see R.M.Green, +* "Spherical Astronomy", Cambridge University Press, 1985). +* +* Last revision 2 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION TDK,PMB,RH,WL1,A1,B1,WL2,A2,B2 + + DOUBLE PRECISION F,TDKOK,PMBOK,RHOK, + : PSAT,PWO,W1,WLOK,WLSQ,W2,DN1,DN2 + + +* Check for radio wavelengths + IF (WL1.GT.100D0.OR.WL2.GT.100D0) THEN + +* Radio: no dispersion + A2 = A1 + B2 = B1 + ELSE + +* Optical: keep arguments within safe bounds + TDKOK = MIN(MAX(TDK,100D0),500D0) + PMBOK = MIN(MAX(PMB,0D0),10000D0) + RHOK = MIN(MAX(RH,0D0),1D0) + +* Atmosphere parameters at the observer + PSAT = 10D0**(-8.7115D0+0.03477D0*TDKOK) + PWO = RHOK*PSAT + W1 = 11.2684D-6*PWO + +* Refractivity at the observer for first wavelength + WLOK = MAX(WL1,0.1D0) + WLSQ = WLOK*WLOK + W2 = 77.5317D-6+(0.43909D-6+0.00367D-6/WLSQ)/WLSQ + DN1 = (W2*PMBOK-W1)/TDKOK + +* Refractivity at the observer for second wavelength + WLOK = MAX(WL2,0.1D0) + WLSQ = WLOK*WLOK + W2 = 77.5317D-6+(0.43909D-6+0.00367D-6/WLSQ)/WLSQ + DN2 = (W2*PMBOK-W1)/TDKOK + +* Scale the refraction coefficients (see Green 4.31, p93) + IF (DN1.NE.0D0) THEN + F = DN2/DN1 + A2 = A1*F + B2 = B1*F + IF (DN1.NE.A1) B2=B2*(1D0+DN1*(DN1-DN2)/(2D0*(DN1-A1))) + ELSE + A2 = A1 + B2 = B1 + END IF + END IF + + END diff --git a/math/slalib/atms.f b/math/slalib/atms.f new file mode 100644 index 00000000..fcee9c68 --- /dev/null +++ b/math/slalib/atms.f @@ -0,0 +1,58 @@ + SUBROUTINE slATMS (RT, TT, DNT, GAMAL, R, DN, RDNDR) +*+ +* - - - - - +* A T M S +* - - - - - +* +* Internal routine used by REFRO +* +* Refractive index and derivative with respect to height for the +* stratosphere. +* +* Given: +* RT d height of tropopause from centre of the Earth (metre) +* TT d temperature at the tropopause (K) +* DNT d refractive index at the tropopause +* GAMAL d constant of the atmospheric model = G*MD/R +* R d current distance from the centre of the Earth (metre) +* +* Returned: +* DN d refractive index at R +* RDNDR d R * rate the refractive index is changing at R +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RT,TT,DNT,GAMAL,R,DN,RDNDR + + DOUBLE PRECISION B,W + + + B = GAMAL/TT + W = (DNT-1D0)*EXP(-B*(R-RT)) + DN = 1D0+W + RDNDR = -R*B*W + + END diff --git a/math/slalib/atmt.f b/math/slalib/atmt.f new file mode 100644 index 00000000..4534e7ed --- /dev/null +++ b/math/slalib/atmt.f @@ -0,0 +1,72 @@ + SUBROUTINE slATMT (R0, T0, ALPHA, GAMM2, DELM2, + : C1, C2, C3, C4, C5, C6, R, T, DN, RDNDR) +*+ +* - - - - - +* A T M T +* - - - - - +* +* Internal routine used by REFRO +* +* Refractive index and derivative with respect to height for the +* troposphere. +* +* Given: +* R0 d height of observer from centre of the Earth (metre) +* T0 d temperature at the observer (K) +* ALPHA d alpha ) +* GAMM2 d gamma minus 2 ) see HMNAO paper +* DELM2 d delta minus 2 ) +* C1 d useful term ) +* C2 d useful term ) +* C3 d useful term ) see source +* C4 d useful term ) of slRFRO +* C5 d useful term ) +* C6 d useful term ) +* R d current distance from the centre of the Earth (metre) +* +* Returned: +* T d temperature at R (K) +* DN d refractive index at R +* RDNDR d R * rate the refractive index is changing at R +* +* Note that in the optical case C5 and C6 are zero. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R0,T0,ALPHA,GAMM2,DELM2,C1,C2,C3,C4,C5,C6, + : R,T,DN,RDNDR + + DOUBLE PRECISION TT0,TT0GM2,TT0DM2 + + + T = MAX(MIN(T0-ALPHA*(R-R0),320D0),100D0) + TT0 = T/T0 + TT0GM2 = TT0**GAMM2 + TT0DM2 = TT0**DELM2 + DN = 1D0+(C1*TT0GM2-(C2-C5/T)*TT0DM2)*TT0 + RDNDR = R*(-C3*TT0GM2+(C4-C6/TT0)*TT0DM2) + + END diff --git a/math/slalib/av2m.f b/math/slalib/av2m.f new file mode 100644 index 00000000..69dab510 --- /dev/null +++ b/math/slalib/av2m.f @@ -0,0 +1,85 @@ + SUBROUTINE slAV2M (AXVEC, RMAT) +*+ +* - - - - - +* A V 2 M +* - - - - - +* +* Form the rotation matrix corresponding to a given axial vector. +* +* (single precision) +* +* A rotation matrix describes a rotation about some arbitrary axis, +* called the Euler axis. The "axial vector" supplied to this routine +* has the same direction as the Euler axis, and its magnitude is the +* amount of rotation in radians. +* +* Given: +* AXVEC r(3) axial vector (radians) +* +* Returned: +* RMAT r(3,3) rotation matrix +* +* If AXVEC is null, the unit matrix is returned. +* +* The reference frame rotates clockwise as seen looking along +* the axial vector from the origin. +* +* Last revision: 26 November 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL AXVEC(3),RMAT(3,3) + + REAL X,Y,Z,PHI,S,C,W + + + +* Rotation angle - magnitude of axial vector - and functions + X = AXVEC(1) + Y = AXVEC(2) + Z = AXVEC(3) + PHI = SQRT(X*X+Y*Y+Z*Z) + S = SIN(PHI) + C = COS(PHI) + W = 1.0-C + +* Euler axis - direction of axial vector (perhaps null) + IF (PHI.NE.0.0) THEN + X = X/PHI + Y = Y/PHI + Z = Z/PHI + END IF + +* Compute the rotation matrix + RMAT(1,1) = X*X*W+C + RMAT(1,2) = X*Y*W+Z*S + RMAT(1,3) = X*Z*W-Y*S + RMAT(2,1) = X*Y*W-Z*S + RMAT(2,2) = Y*Y*W+C + RMAT(2,3) = Y*Z*W+X*S + RMAT(3,1) = X*Z*W+Y*S + RMAT(3,2) = Y*Z*W-X*S + RMAT(3,3) = Z*Z*W+C + + END diff --git a/math/slalib/bear.f b/math/slalib/bear.f new file mode 100644 index 00000000..e023d533 --- /dev/null +++ b/math/slalib/bear.f @@ -0,0 +1,60 @@ + REAL FUNCTION slBEAR (A1, B1, A2, B2) +*+ +* - - - - - +* B E A R +* - - - - - +* +* Bearing (position angle) of one point on a sphere relative to another +* (single precision) +* +* Given: +* A1,B1 r spherical coordinates of one point +* A2,B2 r spherical coordinates of the other point +* +* (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) +* +* The result is the bearing (position angle), in radians, of point +* A2,B2 as seen from point A1,B1. It is in the range +/- pi. If +* A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned +* if the two points are coincident. +* +* P.T.Wallace Starlink 23 March 1991 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL A1,B1,A2,B2 + + REAL DA,X,Y + + + DA=A2-A1 + Y=SIN(DA)*COS(B2) + X=SIN(B2)*COS(B1)-COS(B2)*SIN(B1)*COS(DA) + IF (X.NE.0.0.OR.Y.NE.0.0) THEN + slBEAR=ATAN2(Y,X) + ELSE + slBEAR=0.0 + END IF + + END diff --git a/math/slalib/caf2r.f b/math/slalib/caf2r.f new file mode 100644 index 00000000..59a6c908 --- /dev/null +++ b/math/slalib/caf2r.f @@ -0,0 +1,75 @@ + SUBROUTINE slCAFR (IDEG, IAMIN, ASEC, RAD, J) +*+ +* - - - - - - +* C A F R +* - - - - - - +* +* Convert degrees, arcminutes, arcseconds to radians +* (single precision) +* +* Given: +* IDEG int degrees +* IAMIN int arcminutes +* ASEC real arcseconds +* +* Returned: +* RAD real angle in radians +* J int status: 0 = OK +* 1 = IDEG outside range 0-359 +* 2 = IAMIN outside range 0-59 +* 3 = ASEC outside range 0-59.999... +* +* Notes: +* +* 1) The result is computed even if any of the range checks +* fail. +* +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IDEG,IAMIN + REAL ASEC,RAD + INTEGER J + +* Arc seconds to radians + REAL AS2R + PARAMETER (AS2R=0.484813681109535994E-5) + + + +* Preset status + J=0 + +* Validate arcsec, arcmin, deg + IF (ASEC.LT.0.0.OR.ASEC.GE.60.0) J=3 + IF (IAMIN.LT.0.OR.IAMIN.GT.59) J=2 + IF (IDEG.LT.0.OR.IDEG.GT.359) J=1 + +* Compute angle + RAD=AS2R*(60.0*(60.0*REAL(IDEG)+REAL(IAMIN))+ASEC) + + END diff --git a/math/slalib/caldj.f b/math/slalib/caldj.f new file mode 100644 index 00000000..34104ca8 --- /dev/null +++ b/math/slalib/caldj.f @@ -0,0 +1,75 @@ + SUBROUTINE slCADJ (IY, IM, ID, DJM, J) +*+ +* - - - - - - +* C A D J +* - - - - - - +* +* Gregorian Calendar to Modified Julian Date +* +* (Includes century default feature: use slCLDJ for years +* before 100AD.) +* +* Given: +* IY,IM,ID int year, month, day in Gregorian calendar +* +* Returned: +* DJM dp modified Julian Date (JD-2400000.5) for 0 hrs +* J int status: +* 0 = OK +* 1 = bad year (MJD not computed) +* 2 = bad month (MJD not computed) +* 3 = bad day (MJD computed) +* +* Acceptable years are 00-49, interpreted as 2000-2049, +* 50-99, " " 1950-1999, +* 100 upwards, interpreted literally. +* +* Called: slCLDJ +* +* P.T.Wallace Starlink November 1985 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,IM,ID + DOUBLE PRECISION DJM + INTEGER J + + INTEGER NY + + + + +* Default century if appropriate + IF (IY.GE.0.AND.IY.LE.49) THEN + NY=IY+2000 + ELSE IF (IY.GE.50.AND.IY.LE.99) THEN + NY=IY+1900 + ELSE + NY=IY + END IF + +* Modified Julian Date + CALL slCLDJ(NY,IM,ID,DJM,J) + + END diff --git a/math/slalib/calyd.f b/math/slalib/calyd.f new file mode 100644 index 00000000..0f65cb98 --- /dev/null +++ b/math/slalib/calyd.f @@ -0,0 +1,83 @@ + SUBROUTINE slCAYD (IY, IM, ID, NY, ND, J) +*+ +* - - - - - - +* C A Y D +* - - - - - - +* +* Gregorian calendar date to year and day in year (in a Julian +* calendar aligned to the 20th/21st century Gregorian calendar). +* +* (Includes century default feature: use slCLYD for years +* before 100AD.) +* +* Given: +* IY,IM,ID int year, month, day in Gregorian calendar +* (year may optionally omit the century) +* Returned: +* NY int year (re-aligned Julian calendar) +* ND int day in year (1 = January 1st) +* J int status: +* 0 = OK +* 1 = bad year (before -4711) +* 2 = bad month +* 3 = bad day (but conversion performed) +* +* Notes: +* +* 1 This routine exists to support the low-precision routines +* slERTH, slMOON and slECOR. +* +* 2 Between 1900 March 1 and 2100 February 28 it returns answers +* which are consistent with the ordinary Gregorian calendar. +* Outside this range there will be a discrepancy which increases +* by one day for every non-leap century year. +* +* 3 Years in the range 50-99 are interpreted as 1950-1999, and +* years in the range 00-49 are interpreted as 2000-2049. +* +* Called: slCLYD +* +* P.T.Wallace Starlink 23 November 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,IM,ID,NY,ND,J + + INTEGER I + + + +* Default century if appropriate + IF (IY.GE.0.AND.IY.LE.49) THEN + I=IY+2000 + ELSE IF (IY.GE.50.AND.IY.LE.99) THEN + I=IY+1900 + ELSE + I=IY + END IF + +* Perform the conversion + CALL slCLYD(I,IM,ID,NY,ND,J) + + END diff --git a/math/slalib/cc2s.f b/math/slalib/cc2s.f new file mode 100644 index 00000000..c9187e3a --- /dev/null +++ b/math/slalib/cc2s.f @@ -0,0 +1,70 @@ + SUBROUTINE slCC2S (V, A, B) +*+ +* - - - - - +* C C 2 S +* - - - - - +* +* Cartesian to spherical coordinates (single precision) +* +* Given: +* V r(3) x,y,z vector +* +* Returned: +* A,B r spherical coordinates in radians +* +* The spherical coordinates are longitude (+ve anticlockwise looking +* from the +ve latitude pole) and latitude. The Cartesian coordinates +* are right handed, with the x axis at zero longitude and latitude, and +* the z axis at the +ve latitude pole. +* +* If V is null, zero A and B are returned. At either pole, zero A is +* returned. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V(3),A,B + + REAL X,Y,Z,R + + + X = V(1) + Y = V(2) + Z = V(3) + R = SQRT(X*X+Y*Y) + + IF (R.EQ.0.0) THEN + A = 0.0 + ELSE + A = ATAN2(Y,X) + END IF + + IF (Z.EQ.0.0) THEN + B = 0.0 + ELSE + B = ATAN2(Z,R) + END IF + + END diff --git a/math/slalib/cc62s.f b/math/slalib/cc62s.f new file mode 100644 index 00000000..a3ad4f38 --- /dev/null +++ b/math/slalib/cc62s.f @@ -0,0 +1,100 @@ + SUBROUTINE slC62S (V, A, B, R, AD, BD, RD) +*+ +* - - - - - - +* C 6 2 S +* - - - - - - +* +* Conversion of position & velocity in Cartesian coordinates +* to spherical coordinates (single precision) +* +* Given: +* V r(6) Cartesian position & velocity vector +* +* Returned: +* A r longitude (radians) +* B r latitude (radians) +* R r radial coordinate +* AD r longitude derivative (radians per unit time) +* BD r latitude derivative (radians per unit time) +* RD r radial derivative +* +* P.T.Wallace Starlink 28 April 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V(6),A,B,R,AD,BD,RD + + REAL X,Y,Z,XD,YD,ZD,RXY2,RXY,R2,XYP + + + +* Components of position/velocity vector + X=V(1) + Y=V(2) + Z=V(3) + XD=V(4) + YD=V(5) + ZD=V(6) + +* Component of R in XY plane squared + RXY2=X*X+Y*Y + +* Modulus squared + R2=RXY2+Z*Z + +* Protection against null vector + IF (R2.EQ.0.0) THEN + X=XD + Y=YD + Z=ZD + RXY2=X*X+Y*Y + R2=RXY2+Z*Z + END IF + +* Position and velocity in spherical coordinates + RXY=SQRT(RXY2) + XYP=X*XD+Y*YD + IF (RXY2.NE.0.0) THEN + A=ATAN2(Y,X) + B=ATAN2(Z,RXY) + AD=(X*YD-Y*XD)/RXY2 + BD=(ZD*RXY2-Z*XYP)/(R2*RXY) + ELSE + A=0.0 + IF (Z.NE.0.0) THEN + B=ATAN2(Z,RXY) + ELSE + B=0.0 + END IF + AD=0.0 + BD=0.0 + END IF + R=SQRT(R2) + IF (R.NE.0.0) THEN + RD=(XYP+Z*ZD)/R + ELSE + RD=0.0 + END IF + + END diff --git a/math/slalib/cd2tf.f b/math/slalib/cd2tf.f new file mode 100644 index 00000000..87884372 --- /dev/null +++ b/math/slalib/cd2tf.f @@ -0,0 +1,73 @@ + SUBROUTINE slCDTF (NDP, DAYS, SIGN, IHMSF) +*+ +* - - - - - - +* C D T F +* - - - - - - +* +* Convert an interval in days into hours, minutes, seconds +* +* (single precision) +* +* Given: +* NDP int number of decimal places of seconds +* DAYS real interval in days +* +* Returned: +* SIGN char '+' or '-' +* IHMSF int(4) hours, minutes, seconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size of +* DAYS, the format of REAL floating-point numbers on the target +* machine, and the risk of overflowing IHMSF(4). On some +* architectures, for DAYS up to 1.0, the available floating- +* point precision corresponds roughly to NDP=3. This is well +* below the ultimate limit of NDP=9 set by the capacity of a +* typical 32-bit IHMSF(4). +* +* 3) The absolute value of DAYS may exceed 1.0. In cases where it +* does not, it is up to the caller to test for and handle the +* case where DAYS is very nearly 1.0 and rounds up to 24 hours, +* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +* +* Called: slDDTF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + REAL DAYS + CHARACTER SIGN*(*) + INTEGER IHMSF(4) + + + +* Call double precision version + CALL slDDTF(NDP,DBLE(DAYS),SIGN,IHMSF) + + END diff --git a/math/slalib/cldj.f b/math/slalib/cldj.f new file mode 100644 index 00000000..ed593ca3 --- /dev/null +++ b/math/slalib/cldj.f @@ -0,0 +1,95 @@ + SUBROUTINE slCLDJ (IY, IM, ID, DJM, J) +*+ +* - - - - - +* C L D J +* - - - - - +* +* Gregorian Calendar to Modified Julian Date +* +* Given: +* IY,IM,ID int year, month, day in Gregorian calendar +* +* Returned: +* DJM dp modified Julian Date (JD-2400000.5) for 0 hrs +* J int status: +* 0 = OK +* 1 = bad year (MJD not computed) +* 2 = bad month (MJD not computed) +* 3 = bad day (MJD computed) +* +* The year must be -4699 (i.e. 4700BC) or later. +* +* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55). +* +* Last revision: 27 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,IM,ID + DOUBLE PRECISION DJM + INTEGER J + +* Month lengths in days + INTEGER MTAB(12) + DATA MTAB / 31,28,31,30,31,30,31,31,30,31,30,31 / + + + +* Preset status. + J = 0 + +* Validate year. + IF ( IY .LT. -4699 ) THEN + J = 1 + ELSE + +* Validate month. + IF ( IM.GE.1 .AND. IM.LE.12 ) THEN + +* Allow for leap year. + IF ( MOD(IY,4) .EQ. 0 ) THEN + MTAB(2) = 29 + ELSE + MTAB(2) = 28 + END IF + IF ( MOD(IY,100).EQ.0 .AND. MOD(IY,400).NE.0 ) + : MTAB(2) = 28 + +* Validate day. + IF ( ID.LT.1 .OR. ID.GT.MTAB(IM) ) J=3 + +* Modified Julian Date. + DJM = DBLE ( ( 1461 * ( IY - (12-IM)/10 + 4712 ) ) / 4 + : + ( 306 * MOD ( IM+9, 12 ) + 5 ) / 10 + : - ( 3 * ( ( IY - (12-IM)/10 + 4900 ) / 100 ) ) / 4 + : + ID - 2399904 ) + +* Bad month. + ELSE + J=2 + END IF + + END IF + + END diff --git a/math/slalib/clyd.f b/math/slalib/clyd.f new file mode 100644 index 00000000..957a6ec8 --- /dev/null +++ b/math/slalib/clyd.f @@ -0,0 +1,119 @@ + SUBROUTINE slCLYD (IY, IM, ID, NY, ND, JSTAT) +*+ +* - - - - - +* C L Y D +* - - - - - +* +* Gregorian calendar to year and day in year (in a Julian calendar +* aligned to the 20th/21st century Gregorian calendar). +* +* Given: +* IY,IM,ID i year, month, day in Gregorian calendar +* +* Returned: +* NY i year (re-aligned Julian calendar) +* ND i day in year (1 = January 1st) +* JSTAT i status: +* 0 = OK +* 1 = bad year (before -4711) +* 2 = bad month +* 3 = bad day (but conversion performed) +* +* Notes: +* +* 1 This routine exists to support the low-precision routines +* slERTH, slMOON and slECOR. +* +* 2 Between 1900 March 1 and 2100 February 28 it returns answers +* which are consistent with the ordinary Gregorian calendar. +* Outside this range there will be a discrepancy which increases +* by one day for every non-leap century year. +* +* 3 The essence of the algorithm is first to express the Gregorian +* date as a Julian Day Number and then to convert this back to +* a Julian calendar date, with day-in-year instead of month and +* day. See 12.92-1 and 12.95-1 in the reference. +* +* Reference: Explanatory Supplement to the Astronomical Almanac, +* ed P.K.Seidelmann, University Science Books (1992), +* p604-606. +* +* P.T.Wallace Starlink 26 November 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,IM,ID,NY,ND,JSTAT + + INTEGER I,J,K,L,N + +* Month lengths in days + INTEGER MTAB(12) + DATA MTAB/31,28,31,30,31,30,31,31,30,31,30,31/ + + + +* Preset status + JSTAT=0 + +* Validate year + IF (IY.GE.-4711) THEN + +* Validate month + IF (IM.GE.1.AND.IM.LE.12) THEN + +* Allow for (Gregorian) leap year + IF (MOD(IY,4).EQ.0.AND. + : (MOD(IY,100).NE.0.OR.MOD(IY,400).EQ.0)) THEN + MTAB(2)=29 + ELSE + MTAB(2)=28 + END IF + +* Validate day + IF (ID.LT.1.OR.ID.GT.MTAB(IM)) JSTAT=3 + +* Perform the conversion + I=(14-IM)/12 + K=IY-I + J=(1461*(K+4800))/4+(367*(IM-2+12*I))/12 + : -(3*((K+4900)/100))/4+ID-30660 + K=(J-1)/1461 + L=J-1461*K + N=(L-1)/365-L/1461 + J=((80*(L-365*N+30))/2447)/11 + I=N+J + ND=59+L-365*I+((4-N)/4)*(1-J) + NY=4*K+I-4716 + +* Bad month + ELSE + JSTAT=2 + END IF + ELSE + +* Bad year + JSTAT=1 + END IF + + END diff --git a/math/slalib/combn.f b/math/slalib/combn.f new file mode 100644 index 00000000..8f0dd64b --- /dev/null +++ b/math/slalib/combn.f @@ -0,0 +1,160 @@ + SUBROUTINE slCMBN ( NSEL, NCAND, LIST, J ) +*+ +* - - - - - - +* C O M B N +* - - - - - - +* +* Generate the next combination, a subset of a specified size chosen +* from a specified number of items. +* +* Given: +* NSEL i number of items (subset size) +* NCAND i number of candidates (set size) +* +* Given and returned: +* LIST i(NSEL) latest combination, LIST(1)=0 to initialize +* +* Returned: +* J i status: -1 = illegal NSEL or NCAND +* 0 = OK +* +1 = no more combinations available +* +* Notes: +* +* 1) NSEL and NCAND must both be at least 1, and NSEL must be less +* than or equal to NCAND. +* +* 2) This routine returns, in the LIST array, a subset of NSEL integers +* chosen from the range 1 to NCAND inclusive, in ascending order. +* Before calling the routine for the first time, the caller must set +* the first element of the LIST array to zero (any value less than 1 +* will do) to cause initialization. +* +* 2) The first combination to be generated is: +* +* LIST(1)=1, LIST(2)=2, ..., LIST(NSEL)=NSEL +* +* This is also the combination returned for the "finished" (J=1) +* case. +* +* The final permutation to be generated is: +* +* LIST(1)=NCAND, LIST(2)=NCAND-1, ..., LIST(NSEL)=NCAND-NSEL+1 +* +* 3) If the "finished" (J=1) status is ignored, the routine +* continues to deliver combinations, the pattern repeating +* every NCAND!/(NSEL!*(NCAND-NSEL)!) calls. +* +* 4) The algorithm is by R.F.Warren-Smith (private communication). +* +* P.T.Wallace Starlink 25 August 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NSEL,NCAND,LIST(NSEL),J + + INTEGER I,LISTI,NMAX,M + LOGICAL MORE + + +* Validate, and set status. + IF (NSEL.LT.1.OR.NCAND.LT.1.OR.NSEL.GT.NCAND) THEN + J = -1 + GO TO 9999 + ELSE + J = 0 + END IF + +* Just starting? + IF (LIST(1).LT.1) THEN + +* Yes: return 1,2,3... + DO I=1,NSEL + LIST(I) = I + END DO + + ELSE + +* No: find the first selection that we can increment. + +* Start with the first list item. + I = 1 + +* Loop. + MORE = .TRUE. + DO WHILE (MORE) + +* Current list item. + LISTI = LIST(I) + +* Is this the final list item? + IF (I.GE.NSEL) THEN + +* Yes: comparison value is number of candidates plus one. + NMAX = NCAND+1 + ELSE + +* No: comparison value is next list item. + NMAX = LIST(I+1) + END IF + +* Can the current item be incremented? + IF (NMAX-LISTI.GT.1) THEN + +* Yes: increment it. + LIST(I) = LISTI+1 + +* Reinitialize the preceding items. + DO M=1,I-1 + LIST(M) = M + END DO + +* Break. + MORE = .FALSE. + ELSE + +* Can't increment the current item: is it the final one? + IF (I.GE.NSEL) THEN + +* Yes: set the status. + J = 1 + +* Restart the sequence. + DO I=1,NSEL + LIST(I) = I + END DO + +* Break. + MORE = .FALSE. + ELSE + +* No: next list item. + I = I+1 + END IF + END IF + END DO + END IF + 9999 CONTINUE + + END diff --git a/math/slalib/configure.ac b/math/slalib/configure.ac new file mode 100644 index 00000000..deeead59 --- /dev/null +++ b/math/slalib/configure.ac @@ -0,0 +1,134 @@ +dnl Process this file with autoconf to produce a configure script +AC_REVISION($Revision$) + +dnl Initialisation: package name and version number +AC_INIT(sla, 2.5-7, starlink@jiscmail.ac.uk) +# Version-info specifications. See SSN/78 for guidelines, and update the table +# below for ANY change of version number. +# +# The library version numbers below match PTW's LIB_VERS 1.6 and 1.7 +# respectively, as it happens. There is no need to continue this pattern +# with any future changes, since these should respect the rather different +# rules for the -version-info numbers. Instead the PTW makefile LIB_VERS +# changes should be regarded as guidelines for which changes are and are +# not backwards-compatible. +# +# Release libsla.la +# 2.4-12 6:0:0 +# 2.5-2 7:0:0 +AC_SUBST(libsla_la_version_info, 7:0:0) + +dnl Require autoconf-2.50 at least +AC_PREREQ(2.50) +dnl Require automake-1.8.2-starlink at least +AM_INIT_AUTOMAKE(1.8.2-starlink) + +dnl Sanity-check: name a file in the source directory -- if this +dnl isn't found then configure will complain +AC_CONFIG_SRCDIR([sla_link]) + +dnl Include defaults for Starlink configurations +STAR_DEFAULTS + +dnl Find required versions of the programs we need for configuration +AC_PROG_FC +AC_PROG_FPP +AC_PROG_LIBTOOL + +dnl If --with-pic=no is set we should honour that. +AM_CONDITIONAL(NOPIC, test x$pic_mode = xno) + +dnl Platform-dependent/preprocessed sources. This is slightly +dnl subtle: file random.F is a preprocessable file. However, +dnl there are also versions available for VAX/VMS +dnl (random.F__vms) and Microsoft Fortran (random.F__win), and +dnl these are sufficiently distinct that it's not worth just +dnl configuring the function name. +dnl +dnl The random and gresid VMS and Windows files have a .F +dnl extension: there's no preprocessable code in them, but they +dnl have to have the same name as the file which does have. +dnl +dnl Problem: Is the code in the *__win files specific to Windows +dnl or to MSFortran? Since you'd only get MSFortran on Windows, I +dnl suppose it's the former (or might as well be). +dnl +dnl The __vms files will never be matched by this macro (will the +dnl __win files?), since config.guess doesn't cover VMS at all, but +dnl the following, as well as documenting the relationship, also +dnl causes the corresponding files to be included in the +dnl distribution, where they might be of use to someone. +STAR_PLATFORM_SOURCES([random.F gresid.F wait.f], + [__vms __win default]) + +if cmp -s random.F random.Fdefault; then + # The unix version, to be configured + found_random=false + AC_CHECK_FUNCS([rand random], [found_random=true]) + if $found_random; then + : OK + else + AC_LIBOBJ([rtl_random]) + fi +fi + +dnl Conditional defining whether we build the thread-safe C wrappers +AC_ARG_WITH([pthreads], + [ --with-pthreads Build package with POSIX threads support], + if test "$withval" = "yes"; then + use_pthreads="yes" + else + use_pthreads="no" + fi, + use_pthreads="no") +if test "$use_pthreads" = "yes"; then +AC_CHECK_LIB([pthread], [pthread_create], ,[use_pthreads="no"]) + if test "$use_pthreads" = "yes"; then + AC_DEFINE([USE_PTHREADS], [1], [Build with POSIX threads support]) + fi +fi + +dnl Conditional defining whether we use CNF or not +AC_ARG_WITH([cnf], + [ --with-cnf Use Starlink CNF library for thread locking], + if test "$withval" = "yes"; then + use_cnf="yes" + else + use_cnf="no" + fi, + use_cnf="yes") +if test "$use_cnf" = "yes"; then + AC_DEFINE([USE_CNF], [1], [Use Starlink CNF library for thread locking]) +fi + +STAR_CNF_COMPATIBLE_SYMBOLS + +dnl We need this for the tests +AC_FC_MAIN +AC_FC_LIBRARY_LDFLAGS + +# Perform the check that configures f77.h.in for the return type of REAL +# Fortran functions. On 64-bit g77 with f2c compatibility this is double +# not float. +STAR_CNF_F2C_COMPATIBLE + +# Determine type of Fortran character string lengths. +STAR_CNF_TRAIL_TYPE + +AC_CONFIG_HEADERS([config.h]) + +dnl Declare the build and use dependencies for this package +dnl There are neither build nor use dependencies + +STAR_LATEX_DOCUMENTATION(sun67) + +dnl Declare the build and use dependencies for this package +dnl NOTE, cnf should be a link dependency rather than a build +dnl dependency, but there is clearly a bug in starconf somewhere +dbl because making it a link dependency results in no CNF dependency +dnl being added to Makefile.dependencies. +STAR_DECLARE_DEPENDENCIES([build], [cnf]) + +AC_CONFIG_FILES(Makefile component.xml vers.f veri.f f77.h) + +AC_OUTPUT diff --git a/math/slalib/cr2af.f b/math/slalib/cr2af.f new file mode 100644 index 00000000..f12058a1 --- /dev/null +++ b/math/slalib/cr2af.f @@ -0,0 +1,76 @@ + SUBROUTINE slCRAF (NDP, ANGLE, SIGN, IDMSF) +*+ +* - - - - - - +* C R A F +* - - - - - - +* +* Convert an angle in radians into degrees, arcminutes, arcseconds +* (single precision) +* +* Given: +* NDP int number of decimal places of arcseconds +* ANGLE real angle in radians +* +* Returned: +* SIGN char '+' or '-' +* IDMSF int(4) degrees, arcminutes, arcseconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size of +* ANGLE, the format of REAL floating-point numbers on the target +* machine, and the risk of overflowing IDMSF(4). On some +* architectures, for ANGLE up to 2pi, the available floating- +* point precision corresponds roughly to NDP=3. This is well +* below the ultimate limit of NDP=9 set by the capacity of a +* typical 32-bit IDMSF(4). +* +* 3) The absolute value of ANGLE may exceed 2pi. In cases where it +* does not, it is up to the caller to test for and handle the +* case where ANGLE is very nearly 2pi and rounds up to 360 deg, +* by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. +* +* Called: slCDTF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + REAL ANGLE + CHARACTER SIGN*(*) + INTEGER IDMSF(4) + +* Hours to degrees * radians to turns + REAL F + PARAMETER (F=15.0/6.283185307179586476925287) + + + +* Scale then use days to h,m,s routine + CALL slCDTF(NDP,ANGLE*F,SIGN,IDMSF) + + END diff --git a/math/slalib/cr2tf.f b/math/slalib/cr2tf.f new file mode 100644 index 00000000..b23cbd2e --- /dev/null +++ b/math/slalib/cr2tf.f @@ -0,0 +1,76 @@ + SUBROUTINE slCRTF (NDP, ANGLE, SIGN, IHMSF) +*+ +* - - - - - - +* C R T F +* - - - - - - +* +* Convert an angle in radians into hours, minutes, seconds +* (single precision) +* +* Given: +* NDP int number of decimal places of seconds +* ANGLE real angle in radians +* +* Returned: +* SIGN char '+' or '-' +* IHMSF int(4) hours, minutes, seconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size of +* ANGLE, the format of REAL floating-point numbers on the target +* machine, and the risk of overflowing IHMSF(4). On some +* architectures, for ANGLE up to 2pi, the available floating-point +* precision corresponds roughly to NDP=3. This is well below +* the ultimate limit of NDP=9 set by the capacity of a typical +* 32-bit IHMSF(4). +* +* 3) The absolute value of ANGLE may exceed 2pi. In cases where it +* does not, it is up to the caller to test for and handle the +* case where ANGLE is very nearly 2pi and rounds up to 24 hours, +* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +* +* Called: slCDTF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + REAL ANGLE + CHARACTER SIGN*(*) + INTEGER IHMSF(4) + +* Turns to radians + REAL T2R + PARAMETER (T2R=6.283185307179586476925287) + + + +* Scale then use days to h,m,s routine + CALL slCDTF(NDP,ANGLE/T2R,SIGN,IHMSF) + + END diff --git a/math/slalib/cs2c.f b/math/slalib/cs2c.f new file mode 100644 index 00000000..a74ac4bd --- /dev/null +++ b/math/slalib/cs2c.f @@ -0,0 +1,58 @@ + SUBROUTINE slCS2C (A, B, V) +*+ +* - - - - - +* C S 2 C +* - - - - - +* +* Spherical coordinates to direction cosines (single precision) +* +* Given: +* A,B real spherical coordinates in radians +* (RA,Dec), (long,lat) etc. +* +* Returned: +* V real(3) x,y,z unit vector +* +* The spherical coordinates are longitude (+ve anticlockwise looking +* from the +ve latitude pole) and latitude. The Cartesian coordinates +* are right handed, with the x axis at zero longitude and latitude, and +* the z axis at the +ve latitude pole. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL A,B,V(3) + + REAL COSB + + + + COSB = COS(B) + + V(1) = COS(A)*COSB + V(2) = SIN(A)*COSB + V(3) = SIN(B) + + END diff --git a/math/slalib/cs2c6.f b/math/slalib/cs2c6.f new file mode 100644 index 00000000..a8c4d402 --- /dev/null +++ b/math/slalib/cs2c6.f @@ -0,0 +1,73 @@ + SUBROUTINE slS2C6 ( A, B, R, AD, BD, RD, V ) +*+ +* - - - - - - +* S 2 C 6 +* - - - - - - +* +* Conversion of position & velocity in spherical coordinates +* to Cartesian coordinates (single precision) +* +* Given: +* A r longitude (radians) +* B r latitude (radians) +* R r radial coordinate +* AD r longitude derivative (radians per unit time) +* BD r latitude derivative (radians per unit time) +* RD r radial derivative +* +* Returned: +* V r(6) Cartesian position & velocity vector +* +* Last revision: 11 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL A, B, R, AD, BD, RD, V(6) + + REAL SA, CA, SB, CB, RCB, X, Y, RBD, W + + + +* Useful functions. + SA = SIN(A) + CA = COS(A) + SB = SIN(B) + CB = COS(B) + RCB = R*CB + X = RCB*CA + Y = RCB*SA + RBD = R*BD + W = RBD*SB-CB*RD + +* Position. + V(1) = X + V(2) = Y + V(3) = R*SB + +* Velocity. + V(4) = -Y*AD-W*CA + V(5) = X*AD-W*SA + V(6) = RBD*CB+SB*RD + + END diff --git a/math/slalib/ctf2d.f b/math/slalib/ctf2d.f new file mode 100644 index 00000000..a427c38d --- /dev/null +++ b/math/slalib/ctf2d.f @@ -0,0 +1,74 @@ + SUBROUTINE slCTFD (IHOUR, IMIN, SEC, DAYS, J) +*+ +* - - - - - - +* C T F D +* - - - - - - +* +* Convert hours, minutes, seconds to days (single precision) +* +* Given: +* IHOUR int hours +* IMIN int minutes +* SEC real seconds +* +* Returned: +* DAYS real interval in days +* J int status: 0 = OK +* 1 = IHOUR outside range 0-23 +* 2 = IMIN outside range 0-59 +* 3 = SEC outside range 0-59.999... +* +* Notes: +* +* 1) The result is computed even if any of the range checks +* fail. +* +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink November 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IHOUR,IMIN + REAL SEC,DAYS + INTEGER J + +* Seconds per day + REAL D2S + PARAMETER (D2S=86400.0) + + + +* Preset status + J=0 + +* Validate sec, min, hour + IF (SEC.LT.0.0.OR.SEC.GE.60.0) J=3 + IF (IMIN.LT.0.OR.IMIN.GT.59) J=2 + IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1 + +* Compute interval + DAYS=(60.0*(60.0*REAL(IHOUR)+REAL(IMIN))+SEC)/D2S + + END diff --git a/math/slalib/ctf2r.f b/math/slalib/ctf2r.f new file mode 100644 index 00000000..fb841054 --- /dev/null +++ b/math/slalib/ctf2r.f @@ -0,0 +1,72 @@ + SUBROUTINE slCTFR (IHOUR, IMIN, SEC, RAD, J) +*+ +* - - - - - - +* C T F R +* - - - - - - +* +* Convert hours, minutes, seconds to radians (single precision) +* +* Given: +* IHOUR int hours +* IMIN int minutes +* SEC real seconds +* +* Returned: +* RAD real angle in radians +* J int status: 0 = OK +* 1 = IHOUR outside range 0-23 +* 2 = IMIN outside range 0-59 +* 3 = SEC outside range 0-59.999... +* +* Called: +* slCTFD +* +* Notes: +* +* 1) The result is computed even if any of the range checks +* fail. +* +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink November 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IHOUR,IMIN + REAL SEC,RAD + INTEGER J + + REAL TURNS + +* Turns to radians + REAL T2R + PARAMETER (T2R=6.283185307179586476925287) + + + +* Convert to turns then radians + CALL slCTFD(IHOUR,IMIN,SEC,TURNS,J) + RAD=T2R*TURNS + + END diff --git a/math/slalib/daf2r.f b/math/slalib/daf2r.f new file mode 100644 index 00000000..ddd07b74 --- /dev/null +++ b/math/slalib/daf2r.f @@ -0,0 +1,73 @@ + SUBROUTINE slDAFR (IDEG, IAMIN, ASEC, RAD, J) +*+ +* - - - - - - +* D A F R +* - - - - - - +* +* Convert degrees, arcminutes, arcseconds to radians +* (double precision) +* +* Given: +* IDEG int degrees +* IAMIN int arcminutes +* ASEC dp arcseconds +* +* Returned: +* RAD dp angle in radians +* J int status: 0 = OK +* 1 = IDEG outside range 0-359 +* 2 = IAMIN outside range 0-59 +* 3 = ASEC outside range 0-59.999... +* +* Notes: +* 1) The result is computed even if any of the range checks +* fail. +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IDEG,IAMIN + DOUBLE PRECISION ASEC,RAD + INTEGER J + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + + +* Preset status + J=0 + +* Validate arcsec, arcmin, deg + IF (ASEC.LT.0D0.OR.ASEC.GE.60D0) J=3 + IF (IAMIN.LT.0.OR.IAMIN.GT.59) J=2 + IF (IDEG.LT.0.OR.IDEG.GT.359) J=1 + +* Compute angle + RAD=AS2R*(60D0*(60D0*DBLE(IDEG)+DBLE(IAMIN))+ASEC) + + END diff --git a/math/slalib/dafin.f b/math/slalib/dafin.f new file mode 100644 index 00000000..68ecc5f9 --- /dev/null +++ b/math/slalib/dafin.f @@ -0,0 +1,181 @@ + SUBROUTINE slDAFN (STRING, IPTR, A, J) +*+ +* - - - - - - +* D A F N +* - - - - - - +* +* Sexagesimal character string to angle (double precision) +* +* Given: +* STRING c*(*) string containing deg, arcmin, arcsec fields +* IPTR i pointer to start of decode (1st = 1) +* +* Returned: +* IPTR i advanced past the decoded angle +* A d angle in radians +* J i status: 0 = OK +* +1 = default, A unchanged +* -1 = bad degrees ) +* -2 = bad arcminutes ) (note 3) +* -3 = bad arcseconds ) +* +* Example: +* +* argument before after +* +* STRING '-57 17 44.806 12 34 56.7' unchanged +* IPTR 1 16 (points to 12...) +* A ? -1.00000D0 +* J ? 0 +* +* A further call to slDAFN, without adjustment of IPTR, will +* decode the second angle, 12deg 34min 56.7sec. +* +* Notes: +* +* 1) The first three "fields" in STRING are degrees, arcminutes, +* arcseconds, separated by spaces or commas. The degrees field +* may be signed, but not the others. The decoding is carried +* out by the DFLTIN routine and is free-format. +* +* 2) Successive fields may be absent, defaulting to zero. For +* zero status, the only combinations allowed are degrees alone, +* degrees and arcminutes, and all three fields present. If all +* three fields are omitted, a status of +1 is returned and A is +* unchanged. In all other cases A is changed. +* +* 3) Range checking: +* +* The degrees field is not range checked. However, it is +* expected to be integral unless the other two fields are absent. +* +* The arcminutes field is expected to be 0-59, and integral if +* the arcseconds field is present. If the arcseconds field +* is absent, the arcminutes is expected to be 0-59.9999... +* +* The arcseconds field is expected to be 0-59.9999... +* +* 4) Decoding continues even when a check has failed. Under these +* circumstances the field takes the supplied value, defaulting +* to zero, and the result A is computed and returned. +* +* 5) Further fields after the three expected ones are not treated +* as an error. The pointer IPTR is left in the correct state +* for further decoding with the present routine or with DFLTIN +* etc. See the example, above. +* +* 6) If STRING contains hours, minutes, seconds instead of degrees +* etc, or if the required units are turns (or days) instead of +* radians, the result A should be multiplied as follows: +* +* for to obtain multiply +* STRING A in A by +* +* d ' " radians 1 = 1D0 +* d ' " turns 1/2pi = 0.1591549430918953358D0 +* h m s radians 15 = 15D0 +* h m s days 15/2pi = 2.3873241463784300365D0 +* +* Called: slDFLI +* +* P.T.Wallace Starlink 1 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER IPTR + DOUBLE PRECISION A + INTEGER J + + DOUBLE PRECISION AS2R + PARAMETER (AS2R=4.84813681109535993589914102358D-6) + INTEGER JF,JD,JM,JS + DOUBLE PRECISION DEG,ARCMIN,ARCSEC + + + +* Preset the status to OK + JF=0 + +* Defaults + DEG=0D0 + ARCMIN=0D0 + ARCSEC=0D0 + +* Decode degrees, arcminutes, arcseconds + CALL slDFLI(STRING,IPTR,DEG,JD) + IF (JD.GT.1) THEN + JF=-1 + ELSE + CALL slDFLI(STRING,IPTR,ARCMIN,JM) + IF (JM.LT.0.OR.JM.GT.1) THEN + JF=-2 + ELSE + CALL slDFLI(STRING,IPTR,ARCSEC,JS) + IF (JS.LT.0.OR.JS.GT.1) THEN + JF=-3 + +* See if the combination of fields is credible + ELSE IF (JD.GT.0) THEN +* No degrees: arcmin, arcsec ought also to be absent + IF (JM.EQ.0) THEN +* Suspect arcmin + JF=-2 + ELSE IF (JS.EQ.0) THEN +* Suspect arcsec + JF=-3 + ELSE +* All three fields absent + JF=1 + END IF +* Degrees present: if arcsec present so ought arcmin to be + ELSE IF (JM.NE.0.AND.JS.EQ.0) THEN + JF=-3 + +* Tests for range and integrality + +* Degrees + ELSE IF (JM.EQ.0.AND.DINT(DEG).NE.DEG) THEN + JF=-1 +* Arcminutes + ELSE IF ((JS.EQ.0.AND.DINT(ARCMIN).NE.ARCMIN).OR. + : ARCMIN.GE.60D0) THEN + JF=-2 +* Arcseconds + ELSE IF (ARCSEC.GE.60D0) THEN + JF=-3 + END IF + END IF + END IF + +* Unless all three fields absent, compute angle value + IF (JF.LE.0) THEN + A=AS2R*(60D0*(60D0*ABS(DEG)+ARCMIN)+ARCSEC) + IF (JD.LT.0) A=-A + END IF + +* Return the status + J=JF + + END diff --git a/math/slalib/dat.f b/math/slalib/dat.f new file mode 100644 index 00000000..67620144 --- /dev/null +++ b/math/slalib/dat.f @@ -0,0 +1,232 @@ + DOUBLE PRECISION FUNCTION slDAT (UTC) +*+ +* - - - - +* D A T +* - - - - +* +* Increment to be applied to Coordinated Universal Time UTC to give +* International Atomic Time TAI (double precision) +* +* Given: +* UTC d UTC date as a modified JD (JD-2400000.5) +* +* Result: TAI-UTC in seconds +* +* Notes: +* +* 1 The UTC is specified to be a date rather than a time to indicate +* that care needs to be taken not to specify an instant which lies +* within a leap second. Though in most cases UTC can include the +* fractional part, correct behaviour on the day of a leap second +* can only be guaranteed up to the end of the second 23:59:59. +* +* 2 For epochs from 1961 January 1 onwards, the expressions from the +* file ftp://maia.usno.navy.mil/ser7/tai-utc.dat are used. +* +* 3 The 5ms time step at 1961 January 1 is taken from 2.58.1 (p87) of +* the 1992 Explanatory Supplement. +* +* 4 UTC began at 1960 January 1.0 (JD 2436934.5) and it is improper +* to call the routine with an earlier epoch. However, if this +* is attempted, the TAI-UTC expression for the year 1960 is used. +* +* +* :-----------------------------------------: +* : : +* : IMPORTANT : +* : : +* : This routine must be updated on each : +* : occasion that a leap second is : +* : announced : +* : : +* : Latest leap second: 2012 July 1 : +* : : +* :-----------------------------------------: +* +* Last revision: 5 July 2008 +* +* Copyright P.T.Wallace. All rights reserved. +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION UTC + + DOUBLE PRECISION DT + + + + IF (.FALSE.) THEN + +* - - - - - - - - - - - - - - - - - - - - - - * +* Add new code here on each occasion that a * +* leap second is announced, and update the * +* preamble comments appropriately. * +* - - - - - - - - - - - - - - - - - - - - - - * + +* 2012 July 1 + ELSE IF (UTC.GE.56109D0) THEN + DT=35D0 + +* 2009 January 1 + ELSE IF (UTC.GE.54832D0) THEN + DT=34D0 + +* 2006 January 1 + ELSE IF (UTC.GE.53736D0) THEN + DT=33D0 + +* 1999 January 1 + ELSE IF (UTC.GE.51179D0) THEN + DT=32D0 + +* 1997 July 1 + ELSE IF (UTC.GE.50630D0) THEN + DT=31D0 + +* 1996 January 1 + ELSE IF (UTC.GE.50083D0) THEN + DT=30D0 + +* 1994 July 1 + ELSE IF (UTC.GE.49534D0) THEN + DT=29D0 + +* 1993 July 1 + ELSE IF (UTC.GE.49169D0) THEN + DT=28D0 + +* 1992 July 1 + ELSE IF (UTC.GE.48804D0) THEN + DT=27D0 + +* 1991 January 1 + ELSE IF (UTC.GE.48257D0) THEN + DT=26D0 + +* 1990 January 1 + ELSE IF (UTC.GE.47892D0) THEN + DT=25D0 + +* 1988 January 1 + ELSE IF (UTC.GE.47161D0) THEN + DT=24D0 + +* 1985 July 1 + ELSE IF (UTC.GE.46247D0) THEN + DT=23D0 + +* 1983 July 1 + ELSE IF (UTC.GE.45516D0) THEN + DT=22D0 + +* 1982 July 1 + ELSE IF (UTC.GE.45151D0) THEN + DT=21D0 + +* 1981 July 1 + ELSE IF (UTC.GE.44786D0) THEN + DT=20D0 + +* 1980 January 1 + ELSE IF (UTC.GE.44239D0) THEN + DT=19D0 + +* 1979 January 1 + ELSE IF (UTC.GE.43874D0) THEN + DT=18D0 + +* 1978 January 1 + ELSE IF (UTC.GE.43509D0) THEN + DT=17D0 + +* 1977 January 1 + ELSE IF (UTC.GE.43144D0) THEN + DT=16D0 + +* 1976 January 1 + ELSE IF (UTC.GE.42778D0) THEN + DT=15D0 + +* 1975 January 1 + ELSE IF (UTC.GE.42413D0) THEN + DT=14D0 + +* 1974 January 1 + ELSE IF (UTC.GE.42048D0) THEN + DT=13D0 + +* 1973 January 1 + ELSE IF (UTC.GE.41683D0) THEN + DT=12D0 + +* 1972 July 1 + ELSE IF (UTC.GE.41499D0) THEN + DT=11D0 + +* 1972 January 1 + ELSE IF (UTC.GE.41317D0) THEN + DT=10D0 + +* 1968 February 1 + ELSE IF (UTC.GE.39887D0) THEN + DT=4.2131700D0+(UTC-39126D0)*0.002592D0 + +* 1966 January 1 + ELSE IF (UTC.GE.39126D0) THEN + DT=4.3131700D0+(UTC-39126D0)*0.002592D0 + +* 1965 September 1 + ELSE IF (UTC.GE.39004D0) THEN + DT=3.8401300D0+(UTC-38761D0)*0.001296D0 + +* 1965 July 1 + ELSE IF (UTC.GE.38942D0) THEN + DT=3.7401300D0+(UTC-38761D0)*0.001296D0 + +* 1965 March 1 + ELSE IF (UTC.GE.38820D0) THEN + DT=3.6401300D0+(UTC-38761D0)*0.001296D0 + +* 1965 January 1 + ELSE IF (UTC.GE.38761D0) THEN + DT=3.5401300D0+(UTC-38761D0)*0.001296D0 + +* 1964 September 1 + ELSE IF (UTC.GE.38639D0) THEN + DT=3.4401300D0+(UTC-38761D0)*0.001296D0 + +* 1964 April 1 + ELSE IF (UTC.GE.38486D0) THEN + DT=3.3401300D0+(UTC-38761D0)*0.001296D0 + +* 1964 January 1 + ELSE IF (UTC.GE.38395D0) THEN + DT=3.2401300D0+(UTC-38761D0)*0.001296D0 + +* 1963 November 1 + ELSE IF (UTC.GE.38334D0) THEN + DT=1.9458580D0+(UTC-37665D0)*0.0011232D0 + +* 1962 January 1 + ELSE IF (UTC.GE.37665D0) THEN + DT=1.8458580D0+(UTC-37665D0)*0.0011232D0 + +* 1961 August 1 + ELSE IF (UTC.GE.37512D0) THEN + DT=1.3728180D0+(UTC-37300D0)*0.001296D0 + +* 1961 January 1 + ELSE IF (UTC.GE.37300D0) THEN + DT=1.4228180D0+(UTC-37300D0)*0.001296D0 + +* Before that + ELSE + DT=1.4178180D0+(UTC-37300D0)*0.001296D0 + + END IF + + slDAT=DT + + END diff --git a/math/slalib/dav2m.f b/math/slalib/dav2m.f new file mode 100644 index 00000000..7eb1f68b --- /dev/null +++ b/math/slalib/dav2m.f @@ -0,0 +1,84 @@ + SUBROUTINE slDAVM (AXVEC, RMAT) +*+ +* - - - - - - +* D A V M +* - - - - - - +* +* Form the rotation matrix corresponding to a given axial vector. +* (double precision) +* +* A rotation matrix describes a rotation about some arbitrary axis, +* called the Euler axis. The "axial vector" supplied to this routine +* has the same direction as the Euler axis, and its magnitude is the +* amount of rotation in radians. +* +* Given: +* AXVEC d(3) axial vector (radians) +* +* Returned: +* RMAT d(3,3) rotation matrix +* +* If AXVEC is null, the unit matrix is returned. +* +* The reference frame rotates clockwise as seen looking along +* the axial vector from the origin. +* +* Last revision: 26 November 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION AXVEC(3),RMAT(3,3) + + DOUBLE PRECISION X,Y,Z,PHI,S,C,W + + + +* Rotation angle - magnitude of axial vector - and functions + X = AXVEC(1) + Y = AXVEC(2) + Z = AXVEC(3) + PHI = SQRT(X*X+Y*Y+Z*Z) + S = SIN(PHI) + C = COS(PHI) + W = 1D0-C + +* Euler axis - direction of axial vector (perhaps null) + IF (PHI.NE.0D0) THEN + X = X/PHI + Y = Y/PHI + Z = Z/PHI + END IF + +* Compute the rotation matrix + RMAT(1,1) = X*X*W+C + RMAT(1,2) = X*Y*W+Z*S + RMAT(1,3) = X*Z*W-Y*S + RMAT(2,1) = X*Y*W-Z*S + RMAT(2,2) = Y*Y*W+C + RMAT(2,3) = Y*Z*W+X*S + RMAT(3,1) = X*Z*W+Y*S + RMAT(3,2) = Y*Z*W-X*S + RMAT(3,3) = Z*Z*W+C + + END diff --git a/math/slalib/dbear.f b/math/slalib/dbear.f new file mode 100644 index 00000000..417c4bdf --- /dev/null +++ b/math/slalib/dbear.f @@ -0,0 +1,60 @@ + DOUBLE PRECISION FUNCTION slDBER (A1, B1, A2, B2) +*+ +* - - - - - - +* D B E R +* - - - - - - +* +* Bearing (position angle) of one point on a sphere relative to another +* (double precision) +* +* Given: +* A1,B1 d spherical coordinates of one point +* A2,B2 d spherical coordinates of the other point +* +* (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) +* +* The result is the bearing (position angle), in radians, of point +* A2,B2 as seen from point A1,B1. It is in the range +/- pi. If +* A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned +* if the two points are coincident. +* +* P.T.Wallace Starlink 23 March 1991 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION A1,B1,A2,B2 + + DOUBLE PRECISION DA,X,Y + + + DA=A2-A1 + Y=SIN(DA)*COS(B2) + X=SIN(B2)*COS(B1)-COS(B2)*SIN(B1)*COS(DA) + IF (X.NE.0D0.OR.Y.NE.0D0) THEN + slDBER=ATAN2(Y,X) + ELSE + slDBER=0D0 + END IF + + END diff --git a/math/slalib/dbjin.f b/math/slalib/dbjin.f new file mode 100644 index 00000000..6c4b31f5 --- /dev/null +++ b/math/slalib/dbjin.f @@ -0,0 +1,131 @@ + SUBROUTINE slDBJI (STRING, NSTRT, DRESLT, J1, J2) +*+ +* - - - - - - +* D B J I +* - - - - - - +* +* Convert free-format input into double precision floating point, +* using DFLTIN but with special syntax extensions. +* +* The purpose of the syntax extensions is to help cope with mixed +* FK4 and FK5 data. In addition to the syntax accepted by DFLTIN, +* the following two extensions are recognized by DBJIN: +* +* 1) A valid non-null field preceded by the character 'B' +* (or 'b') is accepted. +* +* 2) A valid non-null field preceded by the character 'J' +* (or 'j') is accepted. +* +* The calling program is notified of the incidence of either of these +* extensions through an supplementary status argument. The rest of +* the arguments are as for DFLTIN. +* +* Given: +* STRING char string containing field to be decoded +* NSTRT int pointer to 1st character of field in string +* +* Returned: +* NSTRT int incremented +* DRESLT double result +* J1 int DFLTIN status: -1 = -OK +* 0 = +OK +* +1 = null field +* +2 = error +* J2 int syntax flag: 0 = normal DFLTIN syntax +* +1 = 'B' or 'b' +* +2 = 'J' or 'j' +* +* Called: slDFLI +* +* For details of the basic syntax, see slDFLI. +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NSTRT + DOUBLE PRECISION DRESLT + INTEGER J1,J2 + + INTEGER J2A,LENSTR,NA,J1A,NB,J1B + CHARACTER C + + + +* Preset syntax flag + J2A=0 + +* Length of string + LENSTR=LEN(STRING) + +* Pointer to current character + NA=NSTRT + +* Attempt normal decode + CALL slDFLI(STRING,NA,DRESLT,J1A) + +* Proceed only if pointer still within string + IF (NA.GE.1.AND.NA.LE.LENSTR) THEN + +* See if DFLTIN reported a null field + IF (J1A.EQ.1) THEN + +* It did: examine character it stuck on + C=STRING(NA:NA) + IF (C.EQ.'B'.OR.C.EQ.'b') THEN +* 'B' - provisionally note + J2A=1 + ELSE IF (C.EQ.'J'.OR.C.EQ.'j') THEN +* 'J' - provisionally note + J2A=2 + END IF + +* Following B or J, attempt to decode a number + IF (J2A.EQ.1.OR.J2A.EQ.2) THEN + NB=NA+1 + CALL slDFLI(STRING,NB,DRESLT,J1B) + +* If successful, copy pointer and status + IF (J1B.LE.0) THEN + NA=NB + J1A=J1B +* If not, forget about the B or J + ELSE + J2A=0 + END IF + + END IF + + END IF + + END IF + +* Return argument values and exit + NSTRT=NA + J1=J1A + J2=J2A + + END diff --git a/math/slalib/dc62s.f b/math/slalib/dc62s.f new file mode 100644 index 00000000..7bb64e0d --- /dev/null +++ b/math/slalib/dc62s.f @@ -0,0 +1,100 @@ + SUBROUTINE slDC6S (V, A, B, R, AD, BD, RD) +*+ +* - - - - - - +* D C 6 S +* - - - - - - +* +* Conversion of position & velocity in Cartesian coordinates +* to spherical coordinates (double precision) +* +* Given: +* V d(6) Cartesian position & velocity vector +* +* Returned: +* A d longitude (radians) +* B d latitude (radians) +* R d radial coordinate +* AD d longitude derivative (radians per unit time) +* BD d latitude derivative (radians per unit time) +* RD d radial derivative +* +* P.T.Wallace Starlink 28 April 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V(6),A,B,R,AD,BD,RD + + DOUBLE PRECISION X,Y,Z,XD,YD,ZD,RXY2,RXY,R2,XYP + + + +* Components of position/velocity vector + X=V(1) + Y=V(2) + Z=V(3) + XD=V(4) + YD=V(5) + ZD=V(6) + +* Component of R in XY plane squared + RXY2=X*X+Y*Y + +* Modulus squared + R2=RXY2+Z*Z + +* Protection against null vector + IF (R2.EQ.0D0) THEN + X=XD + Y=YD + Z=ZD + RXY2=X*X+Y*Y + R2=RXY2+Z*Z + END IF + +* Position and velocity in spherical coordinates + RXY=SQRT(RXY2) + XYP=X*XD+Y*YD + IF (RXY2.NE.0D0) THEN + A=ATAN2(Y,X) + B=ATAN2(Z,RXY) + AD=(X*YD-Y*XD)/RXY2 + BD=(ZD*RXY2-Z*XYP)/(R2*RXY) + ELSE + A=0D0 + IF (Z.NE.0D0) THEN + B=ATAN2(Z,RXY) + ELSE + B=0D0 + END IF + AD=0D0 + BD=0D0 + END IF + R=SQRT(R2) + IF (R.NE.0D0) THEN + RD=(XYP+Z*ZD)/R + ELSE + RD=0D0 + END IF + + END diff --git a/math/slalib/dcc2s.f b/math/slalib/dcc2s.f new file mode 100644 index 00000000..cbbbd625 --- /dev/null +++ b/math/slalib/dcc2s.f @@ -0,0 +1,70 @@ + SUBROUTINE slDC2S (V, A, B) +*+ +* - - - - - - +* D C 2 S +* - - - - - - +* +* Cartesian to spherical coordinates (double precision) +* +* Given: +* V d(3) x,y,z vector +* +* Returned: +* A,B d spherical coordinates in radians +* +* The spherical coordinates are longitude (+ve anticlockwise looking +* from the +ve latitude pole) and latitude. The Cartesian coordinates +* are right handed, with the x axis at zero longitude and latitude, and +* the z axis at the +ve latitude pole. +* +* If V is null, zero A and B are returned. At either pole, zero A is +* returned. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V(3),A,B + + DOUBLE PRECISION X,Y,Z,R + + + X = V(1) + Y = V(2) + Z = V(3) + R = SQRT(X*X+Y*Y) + + IF (R.EQ.0D0) THEN + A = 0D0 + ELSE + A = ATAN2(Y,X) + END IF + + IF (Z.EQ.0D0) THEN + B = 0D0 + ELSE + B = ATAN2(Z,R) + END IF + + END diff --git a/math/slalib/dcmpf.f b/math/slalib/dcmpf.f new file mode 100644 index 00000000..93d0d0c2 --- /dev/null +++ b/math/slalib/dcmpf.f @@ -0,0 +1,160 @@ + SUBROUTINE slDCMF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT) +*+ +* - - - - - - +* D C M F +* - - - - - - +* +* Decompose an [X,Y] linear fit into its constituent parameters: +* zero points, scales, nonperpendicularity and orientation. +* +* Given: +* COEFFS d(6) transformation coefficients (see note) +* +* Returned: +* XZ d x zero point +* YZ d y zero point +* XS d x scale +* YS d y scale +* PERP d nonperpendicularity (radians) +* ORIENT d orientation (radians) +* +* Called: slDA1P +* +* The model relates two sets of [X,Y] coordinates as follows. +* Naming the elements of COEFFS: +* +* COEFFS(1) = A +* COEFFS(2) = B +* COEFFS(3) = C +* COEFFS(4) = D +* COEFFS(5) = E +* COEFFS(6) = F +* +* the model transforms coordinates [X1,Y1] into coordinates +* [X2,Y2] as follows: +* +* X2 = A + B*X1 + C*Y1 +* Y2 = D + E*X1 + F*Y1 +* +* The transformation can be decomposed into four steps: +* +* 1) Zero points: +* +* x' = XZ + X1 +* y' = YZ + Y1 +* +* 2) Scales: +* +* x'' = XS*x' +* y'' = YS*y' +* +* 3) Nonperpendicularity: +* +* x''' = cos(PERP/2)*x'' + sin(PERP/2)*y'' +* y''' = sin(PERP/2)*x'' + cos(PERP/2)*y'' +* +* 4) Orientation: +* +* X2 = cos(ORIENT)*x''' + sin(ORIENT)*y''' +* Y2 =-sin(ORIENT)*y''' + cos(ORIENT)*y''' +* +* See also slFTXY, slPXY, slINVF, slXYXY +* +* P.T.Wallace Starlink 19 December 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION COEFFS(6),XZ,YZ,XS,YS,PERP,ORIENT + + DOUBLE PRECISION A,B,C,D,E,F,RB2E2,RC2F2,XSC,YSC,P1,P2,P,WS,WC, + : OR,HP,SHP,CHP,SOR,COR,DET,X0,Y0,slDA1P + + + +* Copy the six coefficients. + A = COEFFS(1) + B = COEFFS(2) + C = COEFFS(3) + D = COEFFS(4) + E = COEFFS(5) + F = COEFFS(6) + +* Scales. + RB2E2 = SQRT(B*B+E*E) + RC2F2 = SQRT(C*C+F*F) + IF (B*F-C*E.GE.0D0) THEN + XSC = RB2E2 + ELSE + B = -B + E = -E + XSC = -RB2E2 + END IF + YSC = RC2F2 + +* Non-perpendicularity. + IF (C.NE.0D0.OR.F.NE.0D0) THEN + P1 = ATAN2(C,F) + ELSE + P1 = 0D0 + END IF + IF (E.NE.0D0.OR.B.NE.0D0) THEN + P2 = ATAN2(E,B) + ELSE + P2 = 0D0 + END IF + P = slDA1P(P1+P2) + +* Orientation. + WS = C*RB2E2-E*RC2F2 + WC = B*RC2F2+F*RB2E2 + IF (WS.NE.0D0.OR.WC.NE.0D0) THEN + OR = ATAN2(WS,WC) + ELSE + OR = 0D0 + END IF + +* Zero points. + HP = P/2D0 + SHP = SIN(HP) + CHP = COS(HP) + SOR = SIN(OR) + COR = COS(OR) + DET = XSC*YSC*(CHP+SHP)*(CHP-SHP) + IF (ABS(DET).GT.0D0) THEN + X0 = YSC*(A*(CHP*COR-SHP*SOR)-D*(CHP*SOR+SHP*COR))/DET + Y0 = XSC*(A*(CHP*SOR-SHP*COR)+D*(CHP*COR+SHP*SOR))/DET + ELSE + X0 = 0D0 + Y0 = 0D0 + END IF + +* Results. + XZ = X0 + YZ = Y0 + XS = XSC + YS = YSC + PERP = P + ORIENT = OR + + END diff --git a/math/slalib/dcs2c.f b/math/slalib/dcs2c.f new file mode 100644 index 00000000..59a70b98 --- /dev/null +++ b/math/slalib/dcs2c.f @@ -0,0 +1,57 @@ + SUBROUTINE slDS2C (A, B, V) +*+ +* - - - - - - +* D S 2 C +* - - - - - - +* +* Spherical coordinates to direction cosines (double precision) +* +* Given: +* A,B d spherical coordinates in radians +* (RA,Dec), (long,lat) etc. +* +* Returned: +* V d(3) x,y,z unit vector +* +* The spherical coordinates are longitude (+ve anticlockwise looking +* from the +ve latitude pole) and latitude. The Cartesian coordinates +* are right handed, with the x axis at zero longitude and latitude, and +* the z axis at the +ve latitude pole. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION A,B,V(3) + + DOUBLE PRECISION COSB + + + COSB = COS(B) + + V(1) = COS(A)*COSB + V(2) = SIN(A)*COSB + V(3) = SIN(B) + + END diff --git a/math/slalib/dd2tf.f b/math/slalib/dd2tf.f new file mode 100644 index 00000000..e3227631 --- /dev/null +++ b/math/slalib/dd2tf.f @@ -0,0 +1,107 @@ + SUBROUTINE slDDTF (NDP, DAYS, SIGN, IHMSF) +*+ +* - - - - - - +* D D T F +* - - - - - - +* +* Convert an interval in days into hours, minutes, seconds +* (double precision) +* +* Given: +* NDP i number of decimal places of seconds +* DAYS d interval in days +* +* Returned: +* SIGN c '+' or '-' +* IHMSF i(4) hours, minutes, seconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size +* of DAYS, the format of DOUBLE PRECISION floating-point numbers +* on the target machine, and the risk of overflowing IHMSF(4). +* On some architectures, for DAYS up to 1D0, the available +* floating-point precision corresponds roughly to NDP=12. +* However, the practical limit is NDP=9, set by the capacity of +* a typical 32-bit IHMSF(4). +* +* 3) The absolute value of DAYS may exceed 1D0. In cases where it +* does not, it is up to the caller to test for and handle the +* case where DAYS is very nearly 1D0 and rounds up to 24 hours, +* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + DOUBLE PRECISION DAYS + CHARACTER SIGN*(*) + INTEGER IHMSF(4) + +* Days to seconds + DOUBLE PRECISION D2S + PARAMETER (D2S=86400D0) + + INTEGER NRS,N + DOUBLE PRECISION RS,RM,RH,A,AH,AM,AS,AF + + + +* Handle sign + IF (DAYS.GE.0D0) THEN + SIGN='+' + ELSE + SIGN='-' + END IF + +* Field units in terms of least significant figure + NRS=1 + DO N=1,NDP + NRS=NRS*10 + END DO + RS=DBLE(NRS) + RM=RS*60D0 + RH=RM*60D0 + +* Round interval and express in smallest units required + A=ANINT(RS*D2S*ABS(DAYS)) + +* Separate into fields + AH=AINT(A/RH) + A=A-AH*RH + AM=AINT(A/RM) + A=A-AM*RM + AS=AINT(A/RS) + AF=A-AS*RS + +* Return results + IHMSF(1)=MAX(NINT(AH),0) + IHMSF(2)=MAX(MIN(NINT(AM),59),0) + IHMSF(3)=MAX(MIN(NINT(AS),59),0) + IHMSF(4)=MAX(NINT(MIN(AF,RS-1D0)),0) + + END diff --git a/math/slalib/de2h.f b/math/slalib/de2h.f new file mode 100644 index 00000000..9d023e9f --- /dev/null +++ b/math/slalib/de2h.f @@ -0,0 +1,107 @@ + SUBROUTINE slDE2H (HA, DEC, PHI, AZ, EL) +*+ +* - - - - - +* D E 2 H +* - - - - - +* +* Equatorial to horizon coordinates: HA,Dec to Az,El +* +* (double precision) +* +* Given: +* HA d hour angle +* DEC d declination +* PHI d observatory latitude +* +* Returned: +* AZ d azimuth +* EL d elevation +* +* Notes: +* +* 1) All the arguments are angles in radians. +* +* 2) Azimuth is returned in the range 0-2pi; north is zero, +* and east is +pi/2. Elevation is returned in the range +* +/-pi/2. +* +* 3) The latitude must be geodetic. In critical applications, +* corrections for polar motion should be applied. +* +* 4) In some applications it will be important to specify the +* correct type of hour angle and declination in order to +* produce the required type of azimuth and elevation. In +* particular, it may be important to distinguish between +* elevation as affected by refraction, which would +* require the "observed" HA,Dec, and the elevation +* in vacuo, which would require the "topocentric" HA,Dec. +* If the effects of diurnal aberration can be neglected, the +* "apparent" HA,Dec may be used instead of the topocentric +* HA,Dec. +* +* 5) No range checking of arguments is carried out. +* +* 6) In applications which involve many such calculations, rather +* than calling the present routine it will be more efficient to +* use inline code, having previously computed fixed terms such +* as sine and cosine of latitude, and (for tracking a star) +* sine and cosine of declination. +* +* P.T.Wallace Starlink 9 July 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION HA,DEC,PHI,AZ,EL + + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925286766559D0) + + DOUBLE PRECISION SH,CH,SD,CD,SP,CP,X,Y,Z,R,A + + +* Useful trig functions + SH=SIN(HA) + CH=COS(HA) + SD=SIN(DEC) + CD=COS(DEC) + SP=SIN(PHI) + CP=COS(PHI) + +* Az,El as x,y,z + X=-CH*CD*SP+SD*CP + Y=-SH*CD + Z=CH*CD*CP+SD*SP + +* To spherical + R=SQRT(X*X+Y*Y) + IF (R.EQ.0D0) THEN + A=0D0 + ELSE + A=ATAN2(Y,X) + END IF + IF (A.LT.0D0) A=A+D2PI + AZ=A + EL=ATAN2(Z,R) + + END diff --git a/math/slalib/deuler.f b/math/slalib/deuler.f new file mode 100644 index 00000000..1ae50acf --- /dev/null +++ b/math/slalib/deuler.f @@ -0,0 +1,181 @@ + SUBROUTINE slDEUL (ORDER, PHI, THETA, PSI, RMAT) +*+ +* - - - - - - - +* D E U L +* - - - - - - - +* +* Form a rotation matrix from the Euler angles - three successive +* rotations about specified Cartesian axes (double precision) +* +* Given: +* ORDER c*(*) specifies about which axes the rotations occur +* PHI d 1st rotation (radians) +* THETA d 2nd rotation ( " ) +* PSI d 3rd rotation ( " ) +* +* Returned: +* RMAT d(3,3) rotation matrix +* +* A rotation is positive when the reference frame rotates +* anticlockwise as seen looking towards the origin from the +* positive region of the specified axis. +* +* The characters of ORDER define which axes the three successive +* rotations are about. A typical value is 'ZXZ', indicating that +* RMAT is to become the direction cosine matrix corresponding to +* rotations of the reference frame through PHI radians about the +* old Z-axis, followed by THETA radians about the resulting X-axis, +* then PSI radians about the resulting Z-axis. +* +* The axis names can be any of the following, in any order or +* combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal +* axis labelling/numbering conventions apply; the xyz (=123) +* triad is right-handed. Thus, the 'ZXZ' example given above +* could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ'). ORDER +* is terminated by length or by the first unrecognized character. +* +* Fewer than three rotations are acceptable, in which case the later +* angle arguments are ignored. If all rotations are zero, the +* identity matrix is produced. +* +* P.T.Wallace Starlink 23 May 1997 +* +* Copyright (C) 1997 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) ORDER + DOUBLE PRECISION PHI,THETA,PSI,RMAT(3,3) + + INTEGER J,I,L,N,K + DOUBLE PRECISION RESULT(3,3),ROTN(3,3),ANGLE,S,C,W,WM(3,3) + CHARACTER AXIS + + + +* Initialize result matrix + DO J=1,3 + DO I=1,3 + IF (I.NE.J) THEN + RESULT(I,J) = 0D0 + ELSE + RESULT(I,J) = 1D0 + END IF + END DO + END DO + +* Establish length of axis string + L = LEN(ORDER) + +* Look at each character of axis string until finished + DO N=1,3 + IF (N.LE.L) THEN + +* Initialize rotation matrix for the current rotation + DO J=1,3 + DO I=1,3 + IF (I.NE.J) THEN + ROTN(I,J) = 0D0 + ELSE + ROTN(I,J) = 1D0 + END IF + END DO + END DO + +* Pick up the appropriate Euler angle and take sine & cosine + IF (N.EQ.1) THEN + ANGLE = PHI + ELSE IF (N.EQ.2) THEN + ANGLE = THETA + ELSE + ANGLE = PSI + END IF + S = SIN(ANGLE) + C = COS(ANGLE) + +* Identify the axis + AXIS = ORDER(N:N) + IF (AXIS.EQ.'X'.OR. + : AXIS.EQ.'x'.OR. + : AXIS.EQ.'1') THEN + +* Matrix for x-rotation + ROTN(2,2) = C + ROTN(2,3) = S + ROTN(3,2) = -S + ROTN(3,3) = C + + ELSE IF (AXIS.EQ.'Y'.OR. + : AXIS.EQ.'y'.OR. + : AXIS.EQ.'2') THEN + +* Matrix for y-rotation + ROTN(1,1) = C + ROTN(1,3) = -S + ROTN(3,1) = S + ROTN(3,3) = C + + ELSE IF (AXIS.EQ.'Z'.OR. + : AXIS.EQ.'z'.OR. + : AXIS.EQ.'3') THEN + +* Matrix for z-rotation + ROTN(1,1) = C + ROTN(1,2) = S + ROTN(2,1) = -S + ROTN(2,2) = C + + ELSE + +* Unrecognized character - fake end of string + L = 0 + + END IF + +* Apply the current rotation (matrix ROTN x matrix RESULT) + DO I=1,3 + DO J=1,3 + W = 0D0 + DO K=1,3 + W = W+ROTN(I,K)*RESULT(K,J) + END DO + WM(I,J) = W + END DO + END DO + DO J=1,3 + DO I=1,3 + RESULT(I,J) = WM(I,J) + END DO + END DO + + END IF + + END DO + +* Copy the result + DO J=1,3 + DO I=1,3 + RMAT(I,J) = RESULT(I,J) + END DO + END DO + + END diff --git a/math/slalib/dfltin.f b/math/slalib/dfltin.f new file mode 100644 index 00000000..7d514f39 --- /dev/null +++ b/math/slalib/dfltin.f @@ -0,0 +1,298 @@ + SUBROUTINE slDFLI (STRING, NSTRT, DRESLT, JFLAG) +*+ +* - - - - - - - +* D F L I +* - - - - - - - +* +* Convert free-format input into double precision floating point +* +* Given: +* STRING c string containing number to be decoded +* NSTRT i pointer to where decoding is to start +* DRESLT d current value of result +* +* Returned: +* NSTRT i advanced to next number +* DRESLT d result +* JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error +* +* Notes: +* +* 1 The reason DFLTIN has separate OK status values for + +* and - is to enable minus zero to be detected. This is +* of crucial importance when decoding mixed-radix numbers. +* For example, an angle expressed as deg, arcmin, arcsec +* may have a leading minus sign but a zero degrees field. +* +* 2 A TAB is interpreted as a space, and lowercase characters +* are interpreted as uppercase. +* +* 3 The basic format is the sequence of fields #^.^@#^, where +* # is a sign character + or -, ^ means a string of decimal +* digits, and @, which indicates an exponent, means D or E. +* Various combinations of these fields can be omitted, and +* embedded blanks are permissible in certain places. +* +* 4 Spaces: +* +* . Leading spaces are ignored. +* +* . Embedded spaces are allowed only after +, -, D or E, +* and after the decomal point if the first sequence of +* digits is absent. +* +* . Trailing spaces are ignored; the first signifies +* end of decoding and subsequent ones are skipped. +* +* 5 Delimiters: +* +* . Any character other than +,-,0-9,.,D,E or space may be +* used to signal the end of the number and terminate +* decoding. +* +* . Comma is recognized by DFLTIN as a special case; it +* is skipped, leaving the pointer on the next character. +* See 13, below. +* +* 6 Both signs are optional. The default is +. +* +* 7 The mantissa ^.^ defaults to 1. +* +* 8 The exponent @#^ defaults to D0. +* +* 9 The strings of decimal digits may be of any length. +* +* 10 The decimal point is optional for whole numbers. +* +* 11 A "null result" occurs when the string of characters being +* decoded does not begin with +,-,0-9,.,D or E, or consists +* entirely of spaces. When this condition is detected, JFLAG +* is set to 1 and DRESLT is left untouched. +* +* 12 NSTRT = 1 for the first character in the string. +* +* 13 On return from DFLTIN, NSTRT is set ready for the next +* decode - following trailing blanks and any comma. If a +* delimiter other than comma is being used, NSTRT must be +* incremented before the next call to DFLTIN, otherwise +* all subsequent calls will return a null result. +* +* 14 Errors (JFLAG=2) occur when: +* +* . a +, -, D or E is left unsatisfied; or +* +* . the decimal point is present without at least +* one decimal digit before or after it; or +* +* . an exponent more than 100 has been presented. +* +* 15 When an error has been detected, NSTRT is left +* pointing to the character following the last +* one used before the error came to light. This +* may be after the point at which a more sophisticated +* program could have detected the error. For example, +* DFLTIN does not detect that '1D999' is unacceptable +* (on a computer where this is so) until the entire number +* has been decoded. +* +* 16 Certain highly unlikely combinations of mantissa & +* exponent can cause arithmetic faults during the +* decode, in some cases despite the fact that they +* together could be construed as a valid number. +* +* 17 Decoding is left to right, one pass. +* +* 18 See also FLOTIN and INTIN +* +* Called: slICHF +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NSTRT + DOUBLE PRECISION DRESLT + INTEGER JFLAG + + INTEGER NPTR,MSIGN,NEXP,NDP,NVEC,NDIGIT,ISIGNX,J + DOUBLE PRECISION DMANT,DIGIT + + + +* Current character + NPTR=NSTRT + +* Set defaults: mantissa & sign, exponent & sign, decimal place count + DMANT=0D0 + MSIGN=1 + NEXP=0 + ISIGNX=1 + NDP=0 + +* Look for sign + 100 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO ( 400, 100, 800, 500, 300, 200, 9110, 9100, 9110),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Negative + 200 CONTINUE + MSIGN=-1 + +* Look for first leading decimal + 300 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO ( 400, 300, 800, 500, 9200, 9200, 9200, 9200, 9210),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Accept leading decimals + 400 CONTINUE + DMANT=DMANT*1D1+DIGIT + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO ( 400, 1310, 900, 600, 1300, 1300, 1300, 1300, 1310),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Look for decimal when none preceded the point + 500 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO ( 700, 500, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Look for trailing decimals + 600 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO ( 700, 1310, 900, 1300, 1300, 1300, 1300, 1300, 1310),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Accept trailing decimals + 700 CONTINUE + NDP=NDP+1 + DMANT=DMANT*1D1+DIGIT + GO TO 600 + +* Exponent symbol first in field: default mantissa to 1 + 800 CONTINUE + DMANT=1D0 + +* Look for sign of exponent + 900 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO (1200, 900, 9200, 9200, 1100, 1000, 9200, 9200, 9210),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Exponent negative + 1000 CONTINUE + ISIGNX=-1 + +* Look for first digit of exponent + 1100 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO (1200, 1100, 9200, 9200, 9200, 9200, 9200, 9200, 9210),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Use exponent digit + 1200 CONTINUE + NEXP=NEXP*10+NDIGIT + IF (NEXP.GT.100) GO TO 9200 + +* Look for subsequent digits of exponent + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO (1200, 1310, 1300, 1300, 1300, 1300, 1300, 1300, 1310),NVEC +* 0-9 SP D/E . + - , ELSE END + +* Combine exponent and decimal place count + 1300 CONTINUE + NPTR=NPTR-1 + 1310 CONTINUE + NEXP=NEXP*ISIGNX-NDP + +* Skip if net exponent negative + IF (NEXP.LT.0) GO TO 1500 + +* Positive exponent: scale up + 1400 CONTINUE + IF (NEXP.LT.10) GO TO 1410 + DMANT=DMANT*1D10 + NEXP=NEXP-10 + GO TO 1400 + 1410 CONTINUE + IF (NEXP.LT.1) GO TO 1600 + DMANT=DMANT*1D1 + NEXP=NEXP-1 + GO TO 1410 + +* Negative exponent: scale down + 1500 CONTINUE + IF (NEXP.GT.-10) GO TO 1510 + DMANT=DMANT/1D10 + NEXP=NEXP+10 + GO TO 1500 + 1510 CONTINUE + IF (NEXP.GT.-1) GO TO 1600 + DMANT=DMANT/1D1 + NEXP=NEXP+1 + GO TO 1510 + +* Get result & status + 1600 CONTINUE + J=0 + IF (MSIGN.EQ.1) GO TO 1610 + J=-1 + DMANT=-DMANT + 1610 CONTINUE + DRESLT=DMANT + +* Skip to end of field + 1620 CONTINUE + CALL slICHF(STRING,NPTR,NVEC,NDIGIT,DIGIT) + GO TO (1720, 1620, 1720, 1720, 1720, 1720, 9900, 1720, 9900),NVEC +* 0-9 SP D/E . + - , ELSE END + + 1720 CONTINUE + NPTR=NPTR-1 + GO TO 9900 + + +* Exits + +* Null field + 9100 CONTINUE + NPTR=NPTR-1 + 9110 CONTINUE + J=1 + GO TO 9900 + +* Errors + 9200 CONTINUE + NPTR=NPTR-1 + 9210 CONTINUE + J=2 + +* Return + 9900 CONTINUE + NSTRT=NPTR + JFLAG=J + + END diff --git a/math/slalib/dh2e.f b/math/slalib/dh2e.f new file mode 100644 index 00000000..0ef9946c --- /dev/null +++ b/math/slalib/dh2e.f @@ -0,0 +1,101 @@ + SUBROUTINE slDH2E (AZ, EL, PHI, HA, DEC) +*+ +* - - - - - +* D E 2 H +* - - - - - +* +* Horizon to equatorial coordinates: Az,El to HA,Dec +* +* (double precision) +* +* Given: +* AZ d azimuth +* EL d elevation +* PHI d observatory latitude +* +* Returned: +* HA d hour angle +* DEC d declination +* +* Notes: +* +* 1) All the arguments are angles in radians. +* +* 2) The sign convention for azimuth is north zero, east +pi/2. +* +* 3) HA is returned in the range +/-pi. Declination is returned +* in the range +/-pi/2. +* +* 4) The latitude is (in principle) geodetic. In critical +* applications, corrections for polar motion should be applied. +* +* 5) In some applications it will be important to specify the +* correct type of elevation in order to produce the required +* type of HA,Dec. In particular, it may be important to +* distinguish between the elevation as affected by refraction, +* which will yield the "observed" HA,Dec, and the elevation +* in vacuo, which will yield the "topocentric" HA,Dec. If the +* effects of diurnal aberration can be neglected, the +* topocentric HA,Dec may be used as an approximation to the +* "apparent" HA,Dec. +* +* 6) No range checking of arguments is done. +* +* 7) In applications which involve many such calculations, rather +* than calling the present routine it will be more efficient to +* use inline code, having previously computed fixed terms such +* as sine and cosine of latitude. +* +* P.T.Wallace Starlink 21 February 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION AZ,EL,PHI,HA,DEC + + DOUBLE PRECISION SA,CA,SE,CE,SP,CP,X,Y,Z,R + + +* Useful trig functions + SA=SIN(AZ) + CA=COS(AZ) + SE=SIN(EL) + CE=COS(EL) + SP=SIN(PHI) + CP=COS(PHI) + +* HA,Dec as x,y,z + X=-CA*CE*SP+SE*CP + Y=-SA*CE + Z=CA*CE*CP+SE*SP + +* To HA,Dec + R=SQRT(X*X+Y*Y) + IF (R.EQ.0D0) THEN + HA=0D0 + ELSE + HA=ATAN2(Y,X) + END IF + DEC=ATAN2(Z,R) + + END diff --git a/math/slalib/dimxv.f b/math/slalib/dimxv.f new file mode 100644 index 00000000..3eec08e4 --- /dev/null +++ b/math/slalib/dimxv.f @@ -0,0 +1,69 @@ + SUBROUTINE slDIMV (DM, VA, VB) +*+ +* - - - - - - +* D I M V +* - - - - - - +* +* Performs the 3-D backward unitary transformation: +* +* vector VB = (inverse of matrix DM) * vector VA +* +* (double precision) +* +* (n.b. the matrix must be unitary, as this routine assumes that +* the inverse and transpose are identical) +* +* Given: +* DM dp(3,3) matrix +* VA dp(3) vector +* +* Returned: +* VB dp(3) result vector +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DM(3,3),VA(3),VB(3) + + INTEGER I,J + DOUBLE PRECISION W,VW(3) + + + +* Inverse of matrix DM * vector VA -> vector VW + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DM(I,J)*VA(I) + END DO + VW(J)=W + END DO + +* Vector VW -> vector VB + DO J=1,3 + VB(J)=VW(J) + END DO + + END diff --git a/math/slalib/djcal.f b/math/slalib/djcal.f new file mode 100644 index 00000000..31766d18 --- /dev/null +++ b/math/slalib/djcal.f @@ -0,0 +1,93 @@ + SUBROUTINE slDJCA (NDP, DJM, IYMDF, J) +*+ +* - - - - - - +* D J C A +* - - - - - - +* +* Modified Julian Date to Gregorian Calendar, expressed +* in a form convenient for formatting messages (namely +* rounded to a specified precision, and with the fields +* stored in a single array) +* +* Given: +* NDP i number of decimal places of days in fraction +* DJM d modified Julian Date (JD-2400000.5) +* +* Returned: +* IYMDF i(4) year, month, day, fraction in Gregorian +* calendar +* J i status: nonzero = out of range +* +* Any date after 4701BC March 1 is accepted. +* +* NDP should be 4 or less if internal overflows are to be avoided +* on machines which use 32-bit integers. +* +* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55). +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + DOUBLE PRECISION DJM + INTEGER IYMDF(4),J + + INTEGER NFD + DOUBLE PRECISION FD,DF,F,D + INTEGER JD,N4,ND10 + + +* Validate. + IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN + J = -1 + ELSE + J = 0 + +* Denominator of fraction. + NFD = 10**MAX(NDP,0) + FD = DBLE(NFD) + +* Round date and express in units of fraction. + DF = ANINT(DJM*FD) + +* Separate day and fraction. + F = MOD(DF,FD) + IF (F.LT.0D0) F = F+FD + D = (DF-F)/FD + +* Express day in Gregorian calendar. + JD = NINT(D)+2400001 + + N4 = 4*(JD+((2*((4*JD-17918)/146097)*3)/4+1)/2-37) + ND10 = 10*(MOD(N4-237,1461)/4)+5 + + IYMDF(1) = N4/1461-4712 + IYMDF(2) = MOD(ND10/306+2,12)+1 + IYMDF(3) = MOD(ND10,306)/10+1 + IYMDF(4) = NINT(F) + + END IF + + END diff --git a/math/slalib/djcl.f b/math/slalib/djcl.f new file mode 100644 index 00000000..7164ea37 --- /dev/null +++ b/math/slalib/djcl.f @@ -0,0 +1,84 @@ + SUBROUTINE slDJCL (DJM, IY, IM, ID, FD, J) +*+ +* - - - - - +* D J C L +* - - - - - +* +* Modified Julian Date to Gregorian year, month, day, +* and fraction of a day. +* +* Given: +* DJM dp modified Julian Date (JD-2400000.5) +* +* Returned: +* IY int year +* IM int month +* ID int day +* FD dp fraction of day +* J int status: +* 0 = OK +* -1 = unacceptable date (before 4701BC March 1) +* +* The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55). +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DJM + INTEGER IY,IM,ID + DOUBLE PRECISION FD + INTEGER J + + DOUBLE PRECISION F,D + INTEGER JD,N4,ND10 + + +* Check if date is acceptable. + IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN + J = -1 + ELSE + J = 0 + +* Separate day and fraction. + F = MOD(DJM,1D0) + IF (F.LT.0D0) F = F+1D0 + D = ANINT(DJM-F) + +* Express day in Gregorian calendar. + JD = NINT(D)+2400001 + + N4 = 4*(JD+((6*((4*JD-17918)/146097))/4+1)/2-37) + ND10 = 10*(MOD(N4-237,1461)/4)+5 + + IY = N4/1461-4712 + IM = MOD(ND10/306+2,12)+1 + ID = MOD(ND10,306)/10+1 + FD = F + + J=0 + + END IF + + END diff --git a/math/slalib/dm2av.f b/math/slalib/dm2av.f new file mode 100644 index 00000000..5cabe620 --- /dev/null +++ b/math/slalib/dm2av.f @@ -0,0 +1,75 @@ + SUBROUTINE slDMAV (RMAT, AXVEC) +*+ +* - - - - - - +* D M A V +* - - - - - - +* +* From a rotation matrix, determine the corresponding axial vector. +* (double precision) +* +* A rotation matrix describes a rotation about some arbitrary axis, +* called the Euler axis. The "axial vector" returned by this routine +* has the same direction as the Euler axis, and its magnitude is the +* amount of rotation in radians. (The magnitude and direction can be +* separated by means of the routine slDVN.) +* +* Given: +* RMAT d(3,3) rotation matrix +* +* Returned: +* AXVEC d(3) axial vector (radians) +* +* The reference frame rotates clockwise as seen looking along +* the axial vector from the origin. +* +* If RMAT is null, so is the result. +* +* Last revision: 26 November 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RMAT(3,3),AXVEC(3) + + DOUBLE PRECISION X,Y,Z,S2,C2,PHI,F + + + + X = RMAT(2,3)-RMAT(3,2) + Y = RMAT(3,1)-RMAT(1,3) + Z = RMAT(1,2)-RMAT(2,1) + S2 = SQRT(X*X+Y*Y+Z*Z) + IF (S2.NE.0D0) THEN + C2 = RMAT(1,1)+RMAT(2,2)+RMAT(3,3)-1D0 + PHI = ATAN2(S2,C2) + F = PHI/S2 + AXVEC(1) = X*F + AXVEC(2) = Y*F + AXVEC(3) = Z*F + ELSE + AXVEC(1) = 0D0 + AXVEC(2) = 0D0 + AXVEC(3) = 0D0 + END IF + + END diff --git a/math/slalib/dmat.f b/math/slalib/dmat.f new file mode 100644 index 00000000..9209b062 --- /dev/null +++ b/math/slalib/dmat.f @@ -0,0 +1,158 @@ + SUBROUTINE slDMAT (N, A, Y, D, JF, IW) +*+ +* - - - - - +* D M A T +* - - - - - +* +* Matrix inversion & solution of simultaneous equations +* (double precision) +* +* For the set of n simultaneous equations in n unknowns: +* A.Y = X +* +* where: +* A is a non-singular N x N matrix +* Y is the vector of N unknowns +* X is the known vector +* +* DMATRX computes: +* the inverse of matrix A +* the determinant of matrix A +* the vector of N unknowns +* +* Arguments: +* +* symbol type dimension before after +* +* N i no. of unknowns unchanged +* A d (N,N) matrix inverse +* Y d (N) known vector solution vector +* D d - determinant +* * JF i - singularity flag +* IW i (N) - workspace +* +* * JF is the singularity flag. If the matrix is non-singular, JF=0 +* is returned. If the matrix is singular, JF=-1 & D=0D0 are +* returned. In the latter case, the contents of array A on return +* are undefined. +* +* Algorithm: +* Gaussian elimination with partial pivoting. +* +* Speed: +* Very fast. +* +* Accuracy: +* Fairly accurate - errors 1 to 4 times those of routines optimized +* for accuracy. +* +* P.T.Wallace Starlink 4 December 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER N + DOUBLE PRECISION A(N,N),Y(N),D + INTEGER JF + INTEGER IW(N) + + DOUBLE PRECISION SFA + PARAMETER (SFA=1D-20) + + INTEGER K,IMX,I,J,NP1MK,KI + DOUBLE PRECISION AMX,T,AKK,YK,AIK + + + JF=0 + D=1D0 + DO K=1,N + AMX=DABS(A(K,K)) + IMX=K + IF (K.NE.N) THEN + DO I=K+1,N + T=DABS(A(I,K)) + IF (T.GT.AMX) THEN + AMX=T + IMX=I + END IF + END DO + END IF + IF (AMX.LT.SFA) THEN + JF=-1 + ELSE + IF (IMX.NE.K) THEN + DO J=1,N + T=A(K,J) + A(K,J)=A(IMX,J) + A(IMX,J)=T + END DO + T=Y(K) + Y(K)=Y(IMX) + Y(IMX)=T + D=-D + END IF + IW(K)=IMX + AKK=A(K,K) + D=D*AKK + IF (DABS(D).LT.SFA) THEN + JF=-1 + ELSE + AKK=1D0/AKK + A(K,K)=AKK + DO J=1,N + IF (J.NE.K) A(K,J)=A(K,J)*AKK + END DO + YK=Y(K)*AKK + Y(K)=YK + DO I=1,N + AIK=A(I,K) + IF (I.NE.K) THEN + DO J=1,N + IF (J.NE.K) A(I,J)=A(I,J)-AIK*A(K,J) + END DO + Y(I)=Y(I)-AIK*YK + END IF + END DO + DO I=1,N + IF (I.NE.K) A(I,K)=-A(I,K)*AKK + END DO + END IF + END IF + END DO + IF (JF.NE.0) THEN + D=0D0 + ELSE + DO K=1,N + NP1MK=N+1-K + KI=IW(NP1MK) + IF (NP1MK.NE.KI) THEN + DO I=1,N + T=A(I,NP1MK) + A(I,NP1MK)=A(I,KI) + A(I,KI)=T + END DO + END IF + END DO + END IF + + END diff --git a/math/slalib/dmoon.f b/math/slalib/dmoon.f new file mode 100644 index 00000000..f16aadf1 --- /dev/null +++ b/math/slalib/dmoon.f @@ -0,0 +1,659 @@ + SUBROUTINE slDMON (DATE, PV) +*+ +* - - - - - - +* D M O N +* - - - - - - +* +* Approximate geocentric position and velocity of the Moon +* (double precision) +* +* Given: +* DATE D TDB (loosely ET) as a Modified Julian Date +* (JD-2400000.5) +* +* Returned: +* PV D(6) Moon x,y,z,xdot,ydot,zdot, mean equator and +* equinox of date (AU, AU/s) +* +* Notes: +* +* 1 This routine is a full implementation of the algorithm +* published by Meeus (see reference). +* +* 2 Meeus quotes accuracies of 10 arcsec in longitude, 3 arcsec in +* latitude and 0.2 arcsec in HP (equivalent to about 20 km in +* distance). Comparison with JPL DE200 over the interval +* 1960-2025 gives RMS errors of 3.7 arcsec and 83 mas/hour in +* longitude, 2.3 arcsec and 48 mas/hour in latitude, 11 km +* and 81 mm/s in distance. The maximum errors over the same +* interval are 18 arcsec and 0.50 arcsec/hour in longitude, +* 11 arcsec and 0.24 arcsec/hour in latitude, 40 km and 0.29 m/s +* in distance. +* +* 3 The original algorithm is expressed in terms of the obsolete +* timescale Ephemeris Time. Either TDB or TT can be used, but +* not UT without incurring significant errors (30 arcsec at +* the present time) due to the Moon's 0.5 arcsec/sec movement. +* +* 4 The algorithm is based on pre IAU 1976 standards. However, +* the result has been moved onto the new (FK5) equinox, an +* adjustment which is in any case much smaller than the +* intrinsic accuracy of the procedure. +* +* 5 Velocity is obtained by a complete analytical differentiation +* of the Meeus model. +* +* Reference: +* Meeus, l'Astronomie, June 1984, p348. +* +* P.T.Wallace Starlink 22 January 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,PV(6) + +* Degrees, arcseconds and seconds of time to radians + DOUBLE PRECISION D2R,DAS2R,DS2R + PARAMETER (D2R=0.0174532925199432957692369D0, + : DAS2R=4.848136811095359935899141D-6, + : DS2R=7.272205216643039903848712D-5) + +* Seconds per Julian century (86400*36525) + DOUBLE PRECISION CJ + PARAMETER (CJ=3155760000D0) + +* Julian epoch of B1950 + DOUBLE PRECISION B1950 + PARAMETER (B1950=1949.9997904423D0) + +* Earth equatorial radius in AU ( = 6378.137 / 149597870 ) + DOUBLE PRECISION ERADAU + PARAMETER (ERADAU=4.2635212653763D-5) + + DOUBLE PRECISION T,THETA,SINOM,COSOM,DOMCOM,WA,DWA,WB,DWB,WOM, + : DWOM,SINWOM,COSWOM,V,DV,COEFF,EMN,EMPN,DN,FN,EN, + : DEN,DTHETA,FTHETA,EL,DEL,B,DB,BF,DBF,P,DP,SP,R, + : DR,X,Y,Z,XD,YD,ZD,SEL,CEL,SB,CB,RCB,RBD,W,EPJ, + : EQCOR,EPS,SINEPS,COSEPS,ES,EC + INTEGER N,I + +* +* Coefficients for fundamental arguments +* +* at J1900: T**0, T**1, T**2, T**3 +* at epoch: T**0, T**1 +* +* Units are degrees for position and Julian centuries for time +* + +* Moon's mean longitude + DOUBLE PRECISION ELP0,ELP1,ELP2,ELP3,ELP,DELP + PARAMETER (ELP0=270.434164D0, + : ELP1=481267.8831D0, + : ELP2=-0.001133D0, + : ELP3=0.0000019D0) + +* Sun's mean anomaly + DOUBLE PRECISION EM0,EM1,EM2,EM3,EM,DEM + PARAMETER (EM0=358.475833D0, + : EM1=35999.0498D0, + : EM2=-0.000150D0, + : EM3=-0.0000033D0) + +* Moon's mean anomaly + DOUBLE PRECISION EMP0,EMP1,EMP2,EMP3,EMP,DEMP + PARAMETER (EMP0=296.104608D0, + : EMP1=477198.8491D0, + : EMP2=0.009192D0, + : EMP3=0.0000144D0) + +* Moon's mean elongation + DOUBLE PRECISION D0,D1,D2,D3,D,DD + PARAMETER (D0=350.737486D0, + : D1=445267.1142D0, + : D2=-0.001436D0, + : D3=0.0000019D0) + +* Mean distance of the Moon from its ascending node + DOUBLE PRECISION F0,F1,F2,F3,F,DF + PARAMETER (F0=11.250889D0, + : F1=483202.0251D0, + : F2=-0.003211D0, + : F3=-0.0000003D0) + +* Longitude of the Moon's ascending node + DOUBLE PRECISION OM0,OM1,OM2,OM3,OM,DOM + PARAMETER (OM0=259.183275D0, + : OM1=-1934.1420D0, + : OM2=0.002078D0, + : OM3=0.0000022D0) + +* Coefficients for (dimensionless) E factor + DOUBLE PRECISION E1,E2,E,DE,ESQ,DESQ + PARAMETER (E1=-0.002495D0,E2=-0.00000752D0) + +* Coefficients for periodic variations etc + DOUBLE PRECISION PAC,PA0,PA1 + PARAMETER (PAC=0.000233D0,PA0=51.2D0,PA1=20.2D0) + DOUBLE PRECISION PBC + PARAMETER (PBC=-0.001778D0) + DOUBLE PRECISION PCC + PARAMETER (PCC=0.000817D0) + DOUBLE PRECISION PDC + PARAMETER (PDC=0.002011D0) + DOUBLE PRECISION PEC,PE0,PE1,PE2 + PARAMETER (PEC=0.003964D0, + : PE0=346.560D0,PE1=132.870D0,PE2=-0.0091731D0) + DOUBLE PRECISION PFC + PARAMETER (PFC=0.001964D0) + DOUBLE PRECISION PGC + PARAMETER (PGC=0.002541D0) + DOUBLE PRECISION PHC + PARAMETER (PHC=0.001964D0) + DOUBLE PRECISION PIC + PARAMETER (PIC=-0.024691D0) + DOUBLE PRECISION PJC,PJ0,PJ1 + PARAMETER (PJC=-0.004328D0,PJ0=275.05D0,PJ1=-2.30D0) + DOUBLE PRECISION CW1 + PARAMETER (CW1=0.0004664D0) + DOUBLE PRECISION CW2 + PARAMETER (CW2=0.0000754D0) + +* +* Coefficients for Moon position +* +* Tx(N) = coefficient of L, B or P term (deg) +* ITx(N,1-5) = coefficients of M, M', D, F, E**n in argument +* + INTEGER NL,NB,NP + PARAMETER (NL=50,NB=45,NP=31) + DOUBLE PRECISION TL(NL),TB(NB),TP(NP) + INTEGER ITL(5,NL),ITB(5,NB),ITP(5,NP) +* +* Longitude +* M M' D F n + DATA TL( 1)/ +6.288750D0 /, + : (ITL(I, 1),I=1,5)/ +0, +1, +0, +0, 0 / + DATA TL( 2)/ +1.274018D0 /, + : (ITL(I, 2),I=1,5)/ +0, -1, +2, +0, 0 / + DATA TL( 3)/ +0.658309D0 /, + : (ITL(I, 3),I=1,5)/ +0, +0, +2, +0, 0 / + DATA TL( 4)/ +0.213616D0 /, + : (ITL(I, 4),I=1,5)/ +0, +2, +0, +0, 0 / + DATA TL( 5)/ -0.185596D0 /, + : (ITL(I, 5),I=1,5)/ +1, +0, +0, +0, 1 / + DATA TL( 6)/ -0.114336D0 /, + : (ITL(I, 6),I=1,5)/ +0, +0, +0, +2, 0 / + DATA TL( 7)/ +0.058793D0 /, + : (ITL(I, 7),I=1,5)/ +0, -2, +2, +0, 0 / + DATA TL( 8)/ +0.057212D0 /, + : (ITL(I, 8),I=1,5)/ -1, -1, +2, +0, 1 / + DATA TL( 9)/ +0.053320D0 /, + : (ITL(I, 9),I=1,5)/ +0, +1, +2, +0, 0 / + DATA TL(10)/ +0.045874D0 /, + : (ITL(I,10),I=1,5)/ -1, +0, +2, +0, 1 / + DATA TL(11)/ +0.041024D0 /, + : (ITL(I,11),I=1,5)/ -1, +1, +0, +0, 1 / + DATA TL(12)/ -0.034718D0 /, + : (ITL(I,12),I=1,5)/ +0, +0, +1, +0, 0 / + DATA TL(13)/ -0.030465D0 /, + : (ITL(I,13),I=1,5)/ +1, +1, +0, +0, 1 / + DATA TL(14)/ +0.015326D0 /, + : (ITL(I,14),I=1,5)/ +0, +0, +2, -2, 0 / + DATA TL(15)/ -0.012528D0 /, + : (ITL(I,15),I=1,5)/ +0, +1, +0, +2, 0 / + DATA TL(16)/ -0.010980D0 /, + : (ITL(I,16),I=1,5)/ +0, -1, +0, +2, 0 / + DATA TL(17)/ +0.010674D0 /, + : (ITL(I,17),I=1,5)/ +0, -1, +4, +0, 0 / + DATA TL(18)/ +0.010034D0 /, + : (ITL(I,18),I=1,5)/ +0, +3, +0, +0, 0 / + DATA TL(19)/ +0.008548D0 /, + : (ITL(I,19),I=1,5)/ +0, -2, +4, +0, 0 / + DATA TL(20)/ -0.007910D0 /, + : (ITL(I,20),I=1,5)/ +1, -1, +2, +0, 1 / + DATA TL(21)/ -0.006783D0 /, + : (ITL(I,21),I=1,5)/ +1, +0, +2, +0, 1 / + DATA TL(22)/ +0.005162D0 /, + : (ITL(I,22),I=1,5)/ +0, +1, -1, +0, 0 / + DATA TL(23)/ +0.005000D0 /, + : (ITL(I,23),I=1,5)/ +1, +0, +1, +0, 1 / + DATA TL(24)/ +0.004049D0 /, + : (ITL(I,24),I=1,5)/ -1, +1, +2, +0, 1 / + DATA TL(25)/ +0.003996D0 /, + : (ITL(I,25),I=1,5)/ +0, +2, +2, +0, 0 / + DATA TL(26)/ +0.003862D0 /, + : (ITL(I,26),I=1,5)/ +0, +0, +4, +0, 0 / + DATA TL(27)/ +0.003665D0 /, + : (ITL(I,27),I=1,5)/ +0, -3, +2, +0, 0 / + DATA TL(28)/ +0.002695D0 /, + : (ITL(I,28),I=1,5)/ -1, +2, +0, +0, 1 / + DATA TL(29)/ +0.002602D0 /, + : (ITL(I,29),I=1,5)/ +0, +1, -2, -2, 0 / + DATA TL(30)/ +0.002396D0 /, + : (ITL(I,30),I=1,5)/ -1, -2, +2, +0, 1 / + DATA TL(31)/ -0.002349D0 /, + : (ITL(I,31),I=1,5)/ +0, +1, +1, +0, 0 / + DATA TL(32)/ +0.002249D0 /, + : (ITL(I,32),I=1,5)/ -2, +0, +2, +0, 2 / + DATA TL(33)/ -0.002125D0 /, + : (ITL(I,33),I=1,5)/ +1, +2, +0, +0, 1 / + DATA TL(34)/ -0.002079D0 /, + : (ITL(I,34),I=1,5)/ +2, +0, +0, +0, 2 / + DATA TL(35)/ +0.002059D0 /, + : (ITL(I,35),I=1,5)/ -2, -1, +2, +0, 2 / + DATA TL(36)/ -0.001773D0 /, + : (ITL(I,36),I=1,5)/ +0, +1, +2, -2, 0 / + DATA TL(37)/ -0.001595D0 /, + : (ITL(I,37),I=1,5)/ +0, +0, +2, +2, 0 / + DATA TL(38)/ +0.001220D0 /, + : (ITL(I,38),I=1,5)/ -1, -1, +4, +0, 1 / + DATA TL(39)/ -0.001110D0 /, + : (ITL(I,39),I=1,5)/ +0, +2, +0, +2, 0 / + DATA TL(40)/ +0.000892D0 /, + : (ITL(I,40),I=1,5)/ +0, +1, -3, +0, 0 / + DATA TL(41)/ -0.000811D0 /, + : (ITL(I,41),I=1,5)/ +1, +1, +2, +0, 1 / + DATA TL(42)/ +0.000761D0 /, + : (ITL(I,42),I=1,5)/ -1, -2, +4, +0, 1 / + DATA TL(43)/ +0.000717D0 /, + : (ITL(I,43),I=1,5)/ -2, +1, +0, +0, 2 / + DATA TL(44)/ +0.000704D0 /, + : (ITL(I,44),I=1,5)/ -2, +1, -2, +0, 2 / + DATA TL(45)/ +0.000693D0 /, + : (ITL(I,45),I=1,5)/ +1, -2, +2, +0, 1 / + DATA TL(46)/ +0.000598D0 /, + : (ITL(I,46),I=1,5)/ -1, +0, +2, -2, 1 / + DATA TL(47)/ +0.000550D0 /, + : (ITL(I,47),I=1,5)/ +0, +1, +4, +0, 0 / + DATA TL(48)/ +0.000538D0 /, + : (ITL(I,48),I=1,5)/ +0, +4, +0, +0, 0 / + DATA TL(49)/ +0.000521D0 /, + : (ITL(I,49),I=1,5)/ -1, +0, +4, +0, 1 / + DATA TL(50)/ +0.000486D0 /, + : (ITL(I,50),I=1,5)/ +0, +2, -1, +0, 0 / +* +* Latitude +* M M' D F n + DATA TB( 1)/ +5.128189D0 /, + : (ITB(I, 1),I=1,5)/ +0, +0, +0, +1, 0 / + DATA TB( 2)/ +0.280606D0 /, + : (ITB(I, 2),I=1,5)/ +0, +1, +0, +1, 0 / + DATA TB( 3)/ +0.277693D0 /, + : (ITB(I, 3),I=1,5)/ +0, +1, +0, -1, 0 / + DATA TB( 4)/ +0.173238D0 /, + : (ITB(I, 4),I=1,5)/ +0, +0, +2, -1, 0 / + DATA TB( 5)/ +0.055413D0 /, + : (ITB(I, 5),I=1,5)/ +0, -1, +2, +1, 0 / + DATA TB( 6)/ +0.046272D0 /, + : (ITB(I, 6),I=1,5)/ +0, -1, +2, -1, 0 / + DATA TB( 7)/ +0.032573D0 /, + : (ITB(I, 7),I=1,5)/ +0, +0, +2, +1, 0 / + DATA TB( 8)/ +0.017198D0 /, + : (ITB(I, 8),I=1,5)/ +0, +2, +0, +1, 0 / + DATA TB( 9)/ +0.009267D0 /, + : (ITB(I, 9),I=1,5)/ +0, +1, +2, -1, 0 / + DATA TB(10)/ +0.008823D0 /, + : (ITB(I,10),I=1,5)/ +0, +2, +0, -1, 0 / + DATA TB(11)/ +0.008247D0 /, + : (ITB(I,11),I=1,5)/ -1, +0, +2, -1, 1 / + DATA TB(12)/ +0.004323D0 /, + : (ITB(I,12),I=1,5)/ +0, -2, +2, -1, 0 / + DATA TB(13)/ +0.004200D0 /, + : (ITB(I,13),I=1,5)/ +0, +1, +2, +1, 0 / + DATA TB(14)/ +0.003372D0 /, + : (ITB(I,14),I=1,5)/ -1, +0, -2, +1, 1 / + DATA TB(15)/ +0.002472D0 /, + : (ITB(I,15),I=1,5)/ -1, -1, +2, +1, 1 / + DATA TB(16)/ +0.002222D0 /, + : (ITB(I,16),I=1,5)/ -1, +0, +2, +1, 1 / + DATA TB(17)/ +0.002072D0 /, + : (ITB(I,17),I=1,5)/ -1, -1, +2, -1, 1 / + DATA TB(18)/ +0.001877D0 /, + : (ITB(I,18),I=1,5)/ -1, +1, +0, +1, 1 / + DATA TB(19)/ +0.001828D0 /, + : (ITB(I,19),I=1,5)/ +0, -1, +4, -1, 0 / + DATA TB(20)/ -0.001803D0 /, + : (ITB(I,20),I=1,5)/ +1, +0, +0, +1, 1 / + DATA TB(21)/ -0.001750D0 /, + : (ITB(I,21),I=1,5)/ +0, +0, +0, +3, 0 / + DATA TB(22)/ +0.001570D0 /, + : (ITB(I,22),I=1,5)/ -1, +1, +0, -1, 1 / + DATA TB(23)/ -0.001487D0 /, + : (ITB(I,23),I=1,5)/ +0, +0, +1, +1, 0 / + DATA TB(24)/ -0.001481D0 /, + : (ITB(I,24),I=1,5)/ +1, +1, +0, +1, 1 / + DATA TB(25)/ +0.001417D0 /, + : (ITB(I,25),I=1,5)/ -1, -1, +0, +1, 1 / + DATA TB(26)/ +0.001350D0 /, + : (ITB(I,26),I=1,5)/ -1, +0, +0, +1, 1 / + DATA TB(27)/ +0.001330D0 /, + : (ITB(I,27),I=1,5)/ +0, +0, -1, +1, 0 / + DATA TB(28)/ +0.001106D0 /, + : (ITB(I,28),I=1,5)/ +0, +3, +0, +1, 0 / + DATA TB(29)/ +0.001020D0 /, + : (ITB(I,29),I=1,5)/ +0, +0, +4, -1, 0 / + DATA TB(30)/ +0.000833D0 /, + : (ITB(I,30),I=1,5)/ +0, -1, +4, +1, 0 / + DATA TB(31)/ +0.000781D0 /, + : (ITB(I,31),I=1,5)/ +0, +1, +0, -3, 0 / + DATA TB(32)/ +0.000670D0 /, + : (ITB(I,32),I=1,5)/ +0, -2, +4, +1, 0 / + DATA TB(33)/ +0.000606D0 /, + : (ITB(I,33),I=1,5)/ +0, +0, +2, -3, 0 / + DATA TB(34)/ +0.000597D0 /, + : (ITB(I,34),I=1,5)/ +0, +2, +2, -1, 0 / + DATA TB(35)/ +0.000492D0 /, + : (ITB(I,35),I=1,5)/ -1, +1, +2, -1, 1 / + DATA TB(36)/ +0.000450D0 /, + : (ITB(I,36),I=1,5)/ +0, +2, -2, -1, 0 / + DATA TB(37)/ +0.000439D0 /, + : (ITB(I,37),I=1,5)/ +0, +3, +0, -1, 0 / + DATA TB(38)/ +0.000423D0 /, + : (ITB(I,38),I=1,5)/ +0, +2, +2, +1, 0 / + DATA TB(39)/ +0.000422D0 /, + : (ITB(I,39),I=1,5)/ +0, -3, +2, -1, 0 / + DATA TB(40)/ -0.000367D0 /, + : (ITB(I,40),I=1,5)/ +1, -1, +2, +1, 1 / + DATA TB(41)/ -0.000353D0 /, + : (ITB(I,41),I=1,5)/ +1, +0, +2, +1, 1 / + DATA TB(42)/ +0.000331D0 /, + : (ITB(I,42),I=1,5)/ +0, +0, +4, +1, 0 / + DATA TB(43)/ +0.000317D0 /, + : (ITB(I,43),I=1,5)/ -1, +1, +2, +1, 1 / + DATA TB(44)/ +0.000306D0 /, + : (ITB(I,44),I=1,5)/ -2, +0, +2, -1, 2 / + DATA TB(45)/ -0.000283D0 /, + : (ITB(I,45),I=1,5)/ +0, +1, +0, +3, 0 / +* +* Parallax +* M M' D F n + DATA TP( 1)/ +0.950724D0 /, + : (ITP(I, 1),I=1,5)/ +0, +0, +0, +0, 0 / + DATA TP( 2)/ +0.051818D0 /, + : (ITP(I, 2),I=1,5)/ +0, +1, +0, +0, 0 / + DATA TP( 3)/ +0.009531D0 /, + : (ITP(I, 3),I=1,5)/ +0, -1, +2, +0, 0 / + DATA TP( 4)/ +0.007843D0 /, + : (ITP(I, 4),I=1,5)/ +0, +0, +2, +0, 0 / + DATA TP( 5)/ +0.002824D0 /, + : (ITP(I, 5),I=1,5)/ +0, +2, +0, +0, 0 / + DATA TP( 6)/ +0.000857D0 /, + : (ITP(I, 6),I=1,5)/ +0, +1, +2, +0, 0 / + DATA TP( 7)/ +0.000533D0 /, + : (ITP(I, 7),I=1,5)/ -1, +0, +2, +0, 1 / + DATA TP( 8)/ +0.000401D0 /, + : (ITP(I, 8),I=1,5)/ -1, -1, +2, +0, 1 / + DATA TP( 9)/ +0.000320D0 /, + : (ITP(I, 9),I=1,5)/ -1, +1, +0, +0, 1 / + DATA TP(10)/ -0.000271D0 /, + : (ITP(I,10),I=1,5)/ +0, +0, +1, +0, 0 / + DATA TP(11)/ -0.000264D0 /, + : (ITP(I,11),I=1,5)/ +1, +1, +0, +0, 1 / + DATA TP(12)/ -0.000198D0 /, + : (ITP(I,12),I=1,5)/ +0, -1, +0, +2, 0 / + DATA TP(13)/ +0.000173D0 /, + : (ITP(I,13),I=1,5)/ +0, +3, +0, +0, 0 / + DATA TP(14)/ +0.000167D0 /, + : (ITP(I,14),I=1,5)/ +0, -1, +4, +0, 0 / + DATA TP(15)/ -0.000111D0 /, + : (ITP(I,15),I=1,5)/ +1, +0, +0, +0, 1 / + DATA TP(16)/ +0.000103D0 /, + : (ITP(I,16),I=1,5)/ +0, -2, +4, +0, 0 / + DATA TP(17)/ -0.000084D0 /, + : (ITP(I,17),I=1,5)/ +0, +2, -2, +0, 0 / + DATA TP(18)/ -0.000083D0 /, + : (ITP(I,18),I=1,5)/ +1, +0, +2, +0, 1 / + DATA TP(19)/ +0.000079D0 /, + : (ITP(I,19),I=1,5)/ +0, +2, +2, +0, 0 / + DATA TP(20)/ +0.000072D0 /, + : (ITP(I,20),I=1,5)/ +0, +0, +4, +0, 0 / + DATA TP(21)/ +0.000064D0 /, + : (ITP(I,21),I=1,5)/ -1, +1, +2, +0, 1 / + DATA TP(22)/ -0.000063D0 /, + : (ITP(I,22),I=1,5)/ +1, -1, +2, +0, 1 / + DATA TP(23)/ +0.000041D0 /, + : (ITP(I,23),I=1,5)/ +1, +0, +1, +0, 1 / + DATA TP(24)/ +0.000035D0 /, + : (ITP(I,24),I=1,5)/ -1, +2, +0, +0, 1 / + DATA TP(25)/ -0.000033D0 /, + : (ITP(I,25),I=1,5)/ +0, +3, -2, +0, 0 / + DATA TP(26)/ -0.000030D0 /, + : (ITP(I,26),I=1,5)/ +0, +1, +1, +0, 0 / + DATA TP(27)/ -0.000029D0 /, + : (ITP(I,27),I=1,5)/ +0, +0, -2, +2, 0 / + DATA TP(28)/ -0.000029D0 /, + : (ITP(I,28),I=1,5)/ +1, +2, +0, +0, 1 / + DATA TP(29)/ +0.000026D0 /, + : (ITP(I,29),I=1,5)/ -2, +0, +2, +0, 2 / + DATA TP(30)/ -0.000023D0 /, + : (ITP(I,30),I=1,5)/ +0, +1, -2, +2, 0 / + DATA TP(31)/ +0.000019D0 /, + : (ITP(I,31),I=1,5)/ -1, -1, +4, +0, 1 / + + + +* Centuries since J1900 + T=(DATE-15019.5D0)/36525D0 + +* +* Fundamental arguments (radians) and derivatives (radians per +* Julian century) for the current epoch +* + +* Moon's mean longitude + ELP=D2R*MOD(ELP0+(ELP1+(ELP2+ELP3*T)*T)*T,360D0) + DELP=D2R*(ELP1+(2D0*ELP2+3D0*ELP3*T)*T) + +* Sun's mean anomaly + EM=D2R*MOD(EM0+(EM1+(EM2+EM3*T)*T)*T,360D0) + DEM=D2R*(EM1+(2D0*EM2+3D0*EM3*T)*T) + +* Moon's mean anomaly + EMP=D2R*MOD(EMP0+(EMP1+(EMP2+EMP3*T)*T)*T,360D0) + DEMP=D2R*(EMP1+(2D0*EMP2+3D0*EMP3*T)*T) + +* Moon's mean elongation + D=D2R*MOD(D0+(D1+(D2+D3*T)*T)*T,360D0) + DD=D2R*(D1+(2D0*D2+3D0*D3*T)*T) + +* Mean distance of the Moon from its ascending node + F=D2R*MOD(F0+(F1+(F2+F3*T)*T)*T,360D0) + DF=D2R*(F1+(2D0*F2+3D0*F3*T)*T) + +* Longitude of the Moon's ascending node + OM=D2R*MOD(OM0+(OM1+(OM2+OM3*T)*T)*T,360D0) + DOM=D2R*(OM1+(2D0*OM2+3D0*OM3*T)*T) + SINOM=SIN(OM) + COSOM=COS(OM) + DOMCOM=DOM*COSOM + +* Add the periodic variations + THETA=D2R*(PA0+PA1*T) + WA=SIN(THETA) + DWA=D2R*PA1*COS(THETA) + THETA=D2R*(PE0+(PE1+PE2*T)*T) + WB=PEC*SIN(THETA) + DWB=D2R*PEC*(PE1+2D0*PE2*T)*COS(THETA) + ELP=ELP+D2R*(PAC*WA+WB+PFC*SINOM) + DELP=DELP+D2R*(PAC*DWA+DWB+PFC*DOMCOM) + EM=EM+D2R*PBC*WA + DEM=DEM+D2R*PBC*DWA + EMP=EMP+D2R*(PCC*WA+WB+PGC*SINOM) + DEMP=DEMP+D2R*(PCC*DWA+DWB+PGC*DOMCOM) + D=D+D2R*(PDC*WA+WB+PHC*SINOM) + DD=DD+D2R*(PDC*DWA+DWB+PHC*DOMCOM) + WOM=OM+D2R*(PJ0+PJ1*T) + DWOM=DOM+D2R*PJ1 + SINWOM=SIN(WOM) + COSWOM=COS(WOM) + F=F+D2R*(WB+PIC*SINOM+PJC*SINWOM) + DF=DF+D2R*(DWB+PIC*DOMCOM+PJC*DWOM*COSWOM) + +* E-factor, and square + E=1D0+(E1+E2*T)*T + DE=E1+2D0*E2*T + ESQ=E*E + DESQ=2D0*E*DE + +* +* Series expansions +* + +* Longitude + V=0D0 + DV=0D0 + DO N=NL,1,-1 + COEFF=TL(N) + EMN=DBLE(ITL(1,N)) + EMPN=DBLE(ITL(2,N)) + DN=DBLE(ITL(3,N)) + FN=DBLE(ITL(4,N)) + I=ITL(5,N) + IF (I.EQ.0) THEN + EN=1D0 + DEN=0D0 + ELSE IF (I.EQ.1) THEN + EN=E + DEN=DE + ELSE + EN=ESQ + DEN=DESQ + END IF + THETA=EMN*EM+EMPN*EMP+DN*D+FN*F + DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF + FTHETA=SIN(THETA) + V=V+COEFF*FTHETA*EN + DV=DV+COEFF*(COS(THETA)*DTHETA*EN+FTHETA*DEN) + END DO + EL=ELP+D2R*V + DEL=(DELP+D2R*DV)/CJ + +* Latitude + V=0D0 + DV=0D0 + DO N=NB,1,-1 + COEFF=TB(N) + EMN=DBLE(ITB(1,N)) + EMPN=DBLE(ITB(2,N)) + DN=DBLE(ITB(3,N)) + FN=DBLE(ITB(4,N)) + I=ITB(5,N) + IF (I.EQ.0) THEN + EN=1D0 + DEN=0D0 + ELSE IF (I.EQ.1) THEN + EN=E + DEN=DE + ELSE + EN=ESQ + DEN=DESQ + END IF + THETA=EMN*EM+EMPN*EMP+DN*D+FN*F + DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF + FTHETA=SIN(THETA) + V=V+COEFF*FTHETA*EN + DV=DV+COEFF*(COS(THETA)*DTHETA*EN+FTHETA*DEN) + END DO + BF=1D0-CW1*COSOM-CW2*COSWOM + DBF=CW1*DOM*SINOM+CW2*DWOM*SINWOM + B=D2R*V*BF + DB=D2R*(DV*BF+V*DBF)/CJ + +* Parallax + V=0D0 + DV=0D0 + DO N=NP,1,-1 + COEFF=TP(N) + EMN=DBLE(ITP(1,N)) + EMPN=DBLE(ITP(2,N)) + DN=DBLE(ITP(3,N)) + FN=DBLE(ITP(4,N)) + I=ITP(5,N) + IF (I.EQ.0) THEN + EN=1D0 + DEN=0D0 + ELSE IF (I.EQ.1) THEN + EN=E + DEN=DE + ELSE + EN=ESQ + DEN=DESQ + END IF + THETA=EMN*EM+EMPN*EMP+DN*D+FN*F + DTHETA=EMN*DEM+EMPN*DEMP+DN*DD+FN*DF + FTHETA=COS(THETA) + V=V+COEFF*FTHETA*EN + DV=DV+COEFF*(-SIN(THETA)*DTHETA*EN+FTHETA*DEN) + END DO + P=D2R*V + DP=D2R*DV/CJ + +* +* Transformation into final form +* + +* Parallax to distance (AU, AU/sec) + SP=SIN(P) + R=ERADAU/SP + DR=-R*DP*COS(P)/SP + +* Longitude, latitude to x,y,z (AU) + SEL=SIN(EL) + CEL=COS(EL) + SB=SIN(B) + CB=COS(B) + RCB=R*CB + RBD=R*DB + W=RBD*SB-CB*DR + X=RCB*CEL + Y=RCB*SEL + Z=R*SB + XD=-Y*DEL-W*CEL + YD=X*DEL-W*SEL + ZD=RBD*CB+SB*DR + +* Julian centuries since J2000 + T=(DATE-51544.5D0)/36525D0 + +* Fricke equinox correction + EPJ=2000D0+T*100D0 + EQCOR=DS2R*(0.035D0+0.00085D0*(EPJ-B1950)) + +* Mean obliquity (IAU 1976) + EPS=DAS2R*(84381.448D0+(-46.8150D0+(-0.00059D0+0.001813D0*T)*T)*T) + +* To the equatorial system, mean of date, FK5 system + SINEPS=SIN(EPS) + COSEPS=COS(EPS) + ES=EQCOR*SINEPS + EC=EQCOR*COSEPS + PV(1)=X-EC*Y+ES*Z + PV(2)=EQCOR*X+Y*COSEPS-Z*SINEPS + PV(3)=Y*SINEPS+Z*COSEPS + PV(4)=XD-EC*YD+ES*ZD + PV(5)=EQCOR*XD+YD*COSEPS-ZD*SINEPS + PV(6)=YD*SINEPS+ZD*COSEPS + + END diff --git a/math/slalib/dmxm.f b/math/slalib/dmxm.f new file mode 100644 index 00000000..0d319eef --- /dev/null +++ b/math/slalib/dmxm.f @@ -0,0 +1,73 @@ + SUBROUTINE slDMXM (A, B, C) +*+ +* - - - - - +* D M X M +* - - - - - +* +* Product of two 3x3 matrices: +* +* matrix C = matrix A x matrix B +* +* (double precision) +* +* Given: +* A dp(3,3) matrix +* B dp(3,3) matrix +* +* Returned: +* C dp(3,3) matrix result +* +* To comply with the ANSI Fortran 77 standard, A, B and C must +* be different arrays. However, the routine is coded so as to +* work properly on many platforms even if this rule is violated. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION A(3,3),B(3,3),C(3,3) + + INTEGER I,J,K + DOUBLE PRECISION W,WM(3,3) + + +* Multiply into scratch matrix + DO I=1,3 + DO J=1,3 + W=0D0 + DO K=1,3 + W=W+A(I,K)*B(K,J) + END DO + WM(I,J)=W + END DO + END DO + +* Return the result + DO J=1,3 + DO I=1,3 + C(I,J)=WM(I,J) + END DO + END DO + + END diff --git a/math/slalib/dmxv.f b/math/slalib/dmxv.f new file mode 100644 index 00000000..28b8102d --- /dev/null +++ b/math/slalib/dmxv.f @@ -0,0 +1,69 @@ + SUBROUTINE slDMXV (DM, VA, VB) +*+ +* - - - - - +* D M X V +* - - - - - +* +* Performs the 3-D forward unitary transformation: +* +* vector VB = matrix DM * vector VA +* +* (double precision) +* +* Given: +* DM dp(3,3) matrix +* VA dp(3) vector +* +* Returned: +* VB dp(3) result vector +* +* To comply with the ANSI Fortran 77 standard, VA and VB must be +* different arrays. However, the routine is coded so as to work +* properly on many platforms even if this rule is violated. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DM(3,3),VA(3),VB(3) + + INTEGER I,J + DOUBLE PRECISION W,VW(3) + + +* Matrix DM * vector VA -> vector VW + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DM(J,I)*VA(I) + END DO + VW(J)=W + END DO + +* Vector VW -> vector VB + DO J=1,3 + VB(J)=VW(J) + END DO + + END diff --git a/math/slalib/doc/addet.hlp b/math/slalib/doc/addet.hlp new file mode 100644 index 00000000..464dd86a --- /dev/null +++ b/math/slalib/doc/addet.hlp @@ -0,0 +1,42 @@ +.help addet Jun99 "Slalib Package" +.nf + + SUBROUTINE slADET (RM, DM, EQ, RC, DC) + + - - - - - - + A D E T + - - - - - - + + Add the E-terms (elliptic component of annual aberration) + to a pre IAU 1976 mean place to conform to the old + catalogue convention (double precision) + + Given: + RM,DM dp RA,Dec (radians) without E-terms + EQ dp Besselian epoch of mean equator and equinox + + Returned: + RC,DC dp RA,Dec (radians) with E-terms included + + Note: + + Most star positions from pre-1984 optical catalogues (or + derived from astrometry using such stars) embody the + E-terms. If it is necessary to convert a formal mean + place (for example a pulsar timing position) to one + consistent with such a star catalogue, then the RA,Dec + should be adjusted using this routine. + + Reference: + Explanatory Supplement to the Astronomical Ephemeris, + section 2D, page 48. + + Called: slETRM, slDS2C, slDC2S, slDA2P, slDA1P + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/afin.hlp b/math/slalib/doc/afin.hlp new file mode 100644 index 00000000..f3c5a22c --- /dev/null +++ b/math/slalib/doc/afin.hlp @@ -0,0 +1,91 @@ +.help afin Jun99 "Slalib Package" +.nf + + SUBROUTINE slAFIN (STRING, IPTR, A, J) + + - - - - - + A F I N + - - - - - + + Sexagesimal character string to angle (single precision) + + Given: + STRING c*(*) string containing deg, arcmin, arcsec fields + IPTR i pointer to start of decode (1st = 1) + + Returned: + IPTR i advanced past the decoded angle + A r angle in radians + J i status: 0 = OK + +1 = default, A unchanged + -1 = bad degrees ) + -2 = bad arcminutes ) (note 3) + -3 = bad arcseconds ) + + Example: + + argument before after + + STRING '-57 17 44.806 12 34 56.7' unchanged + IPTR 1 16 (points to 12...) + A ? -1.00000 + J ? 0 + + A further call to slAFIN, without adjustment of IPTR, will + decode the second angle, 12deg 34min 56.7sec. + + Notes: + + 1) The first three "fields" in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the DFLTIN routine and is free-format. + + 2) Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and A is + unchanged. In all other cases A is changed. + + 3) Range checking: + + The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are + absent. + + The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + + The arcseconds field is expected to be 0-59.9999... + + 4) Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting + to zero, and the result A is computed and returned. + + 5) Further fields after the three expected ones are not treated + as an error. The pointer IPTR is left in the correct state + for further decoding with the present routine or with DFLTIN + etc. See the example, above. + + 6) If STRING contains hours, minutes, seconds instead of degrees + etc, or if the required units are turns (or days) instead of + radians, the result A should be multiplied as follows: + + for to obtain multiply + STRING A in A by + + d ' " radians 1 = 1.0 + d ' " turns 1/2pi = 0.1591549430918953358 + h m s radians 15 = 15.0 + h m s days 15/2pi = 2.3873241463784300365 + + Called: slDAFN + + P.T.Wallace Starlink 13 September 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/airmas.hlp b/math/slalib/doc/airmas.hlp new file mode 100644 index 00000000..c347bb50 --- /dev/null +++ b/math/slalib/doc/airmas.hlp @@ -0,0 +1,51 @@ +.help airmas Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slARMS (ZD) + + - - - - - - - + A R M S + - - - - - - - + + Air mass at given zenith distance (double precision) + + Given: + ZD d Observed zenith distance (radians) + + The result is an estimate of the air mass, in units of that + at the zenith. + + Notes: + + 1) The "observed" zenith distance referred to above means "as + affected by refraction". + + 2) Uses Hardie's (1962) polynomial fit to Bemporad's data for + the relative air mass, X, in units of thickness at the zenith + as tabulated by Schoenberg (1929). This is adequate for all + normal needs as it is accurate to better than 0.1% up to X = + 6.8 and better than 1% up to X = 10. Bemporad's tabulated + values are unlikely to be trustworthy to such accuracy + because of variations in density, pressure and other + conditions in the atmosphere from those assumed in his work. + + 3) The sign of the ZD is ignored. + + 4) At zenith distances greater than about ZD = 87 degrees the + air mass is held constant to avoid arithmetic overflows. + + References: + Hardie, R.H., 1962, in "Astronomical Techniques" + ed. W.A. Hiltner, University of Chicago Press, p180. + Schoenberg, E., 1929, Hdb. d. Ap., + Berlin, Julius Springer, 2, 268. + + Original code by P.W.Hill, St Andrews + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/altaz.hlp b/math/slalib/doc/altaz.hlp new file mode 100644 index 00000000..0f701093 --- /dev/null +++ b/math/slalib/doc/altaz.hlp @@ -0,0 +1,79 @@ +.help altaz Jun99 "Slalib Package" +.nf + + SUBROUTINE slALAZ (HA, DEC, PHI, + : AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD) + + - - - - - - + A L A Z + - - - - - - + + Positions, velocities and accelerations for an altazimuth + telescope mount. + + (double precision) + + Given: + HA d hour angle + DEC d declination + PHI d observatory latitude + + Returned: + AZ d azimuth + AZD d " velocity + AZDD d " acceleration + EL d elevation + ELD d " velocity + ELDD d " acceleration + PA d parallactic angle + PAD d " " velocity + PADD d " " acceleration + + Notes: + + 1) Natural units are used throughout. HA, DEC, PHI, AZ, EL + and ZD are in radians. The velocities and accelerations + assume constant declination and constant rate of change of + hour angle (as for tracking a star); the units of AZD, ELD + and PAD are radians per radian of HA, while the units of AZDD, + ELDD and PADD are radians per radian of HA squared. To + convert into practical degree- and second-based units: + + angles * 360/2pi -> degrees + velocities * (2pi/86400)*(360/2pi) -> degree/sec + accelerations * ((2pi/86400)**2)*(360/2pi) -> degree/sec/sec + + Note that the seconds here are sidereal rather than SI. One + sidereal second is about 0.99727 SI seconds. + + The velocity and acceleration factors assume the sidereal + tracking case. Their respective numerical values are (exactly) + 1/240 and (approximately) 1/3300236.9. + + 2) Azimuth is returned in the range 0-2pi; north is zero, + and east is +pi/2. Elevation and parallactic angle are + returned in the range +/-pi/2. Position angle is +ve + for a star west of the meridian and is the angle NP-star-zenith. + + 3) The latitude is geodetic as opposed to geocentric. The + hour angle and declination are topocentric. Refraction and + deficiencies in the telescope mounting are ignored. The + purpose of the routine is to give the general form of the + quantities. The details of a real telescope could profoundly + change the results, especially close to the zenith. + + 4) No range checking of arguments is carried out. + + 5) In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + + P.T.Wallace Starlink 14 March 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/amp.hlp b/math/slalib/doc/amp.hlp new file mode 100644 index 00000000..f5d4dfc4 --- /dev/null +++ b/math/slalib/doc/amp.hlp @@ -0,0 +1,61 @@ +.help amp Jun99 "Slalib Package" +.nf + + SUBROUTINE slAMP (RA, DA, DATE, EQ, RM, DM) + + - - - - + A M P + - - - - + + Convert star RA,Dec from geocentric apparent to mean place + + The mean coordinate system is the post IAU 1976 system, + loosely called FK5. + + Given: + RA d apparent RA (radians) + DA d apparent Dec (radians) + DATE d TDB for apparent place (JD-2400000.5) + EQ d equinox: Julian epoch of mean place + + Returned: + RM d mean RA (radians) + DM d mean Dec (radians) + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Notes: + + 1) The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + + 2) The accuracy is limited by the routine slEVP, called + by slMAPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3 milliarcsecond. + + 3) Iterative techniques are used for the aberration and + light deflection corrections so that the routines + slAMP (or slAMPQ) and slMAP (or slMAPQ) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1 nanoarcsecond. + + 4) Where multiple apparent places are to be converted to + mean places, for a fixed date and equinox, it is more + efficient to use the slMAPA routine to compute the + required parameters once, followed by one call to + slAMPQ per star. + + Called: slMAPA, slAMPQ + + P.T.Wallace Starlink 19 January 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ampqk.hlp b/math/slalib/doc/ampqk.hlp new file mode 100644 index 00000000..a4b8dee6 --- /dev/null +++ b/math/slalib/doc/ampqk.hlp @@ -0,0 +1,65 @@ +.help ampqk Jun99 "Slalib Package" +.nf + + SUBROUTINE slAMPQ (RA, DA, AMPRMS, RM, DM) + + - - - - - - + A M P Q + - - - - - - + + Convert star RA,Dec from geocentric apparent to mean place + + The mean coordinate system is the post IAU 1976 system, + loosely called FK5. + + Use of this routine is appropriate when efficiency is important + and where many star positions are all to be transformed for + one epoch and equinox. The star-independent parameters can be + obtained by calling the slMAPA routine. + + Given: + RA d apparent RA (radians) + DA d apparent Dec (radians) + + AMPRMS d(21) star-independent mean-to-apparent parameters: + + (1) time interval for proper motion (Julian years) + (2-4) barycentric position of the Earth (AU) + (5-7) heliocentric direction of the Earth (unit vector) + (8) (grav rad Sun)*2/(Sun-Earth distance) + (9-11) ABV: barycentric Earth velocity in units of c + (12) sqrt(1-v**2) where v=modulus(ABV) + (13-21) precession/nutation (3,3) matrix + + Returned: + RM d mean RA (radians) + DM d mean Dec (radians) + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Notes: + + 1) The accuracy is limited by the routine slEVP, called + by slMAPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3 milliarcsecond. + + 2) Iterative techniques are used for the aberration and + light deflection corrections so that the routines + slAMP (or slAMPQ) and slMAP (or slMAPQ) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1 nanoarcsecond. + + Called: slDS2C, slDIMV, slDVDV, slDVN, slDC2S, + slDA2P + + P.T.Wallace Starlink 21 June 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/aop.hlp b/math/slalib/doc/aop.hlp new file mode 100644 index 00000000..dc3343bf --- /dev/null +++ b/math/slalib/doc/aop.hlp @@ -0,0 +1,166 @@ +.help aop Jun99 "Slalib Package" +.nf + + SUBROUTINE slAOP (RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, + : XP, YP, TDK, PMB, RH, WL, TLR, + : AOB, ZOB, HOB, DOB, ROB) + + - - - - + A O P + - - - - + + Apparent to observed place, for optical sources distant from + the solar system. + + Given: + RAP d geocentric apparent right ascension + DAP d geocentric apparent declination + DATE d UTC date/time (Modified Julian Date, JD-2400000.5) + DUT d delta UT: UT1-UTC (UTC seconds) + ELONGM d mean longitude of the observer (radians, east +ve) + PHIM d mean geodetic latitude of the observer (radians) + HM d observer's height above sea level (metres) + XP d polar motion x-coordinate (radians) + YP d polar motion y-coordinate (radians) + TDK d local ambient temperature (DegK; std=273.155D0) + PMB d local atmospheric pressure (mB; std=1013.25D0) + RH d local relative humidity (in the range 0D0-1D0) + WL d effective wavelength (micron, e.g. 0.55D0) + TLR d tropospheric lapse rate (DegK/metre, e.g. 0.0065D0) + + Returned: + AOB d observed azimuth (radians: N=0,E=90) + ZOB d observed zenith distance (radians) + HOB d observed Hour Angle (radians) + DOB d observed Declination (radians) + ROB d observed Right Ascension (radians) + + Notes: + + 1) This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + + 2) The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted apparent RA,Dec should be within about 0.1 arcsec + for a zenith distance of less than 70 degrees. Even at a + topocentric zenith distance of 90 degrees, the accuracy in + elevation should be better than 1 arcmin; useful results + are available for a further 3 degrees, beyond which the + slRFRO routine returns a fixed value of the refraction. + The complementary routines slAOP (or slAOPQ) and slOAP + (or slOAPQ) are self-consistent to better than 1 micro- + arcsecond all over the celestial sphere. + + 3) It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + + 4) "Apparent" place means the geocentric apparent right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, precession, nutation, + annual aberration, and the Sun's gravitational lens effect. For + star positions in the FK5 system (i.e. J2000), these effects can + be applied by means of the slMAP etc routines. Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 (i.e. B1950) mean places would first + have to be converted to FK5, which can be done with the + slFK45 etc routines. + + 5) "Observed" Az,El means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent RA,Dec by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The HA,Dec is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation (n.b. not to the + refracted pole). Finally, the RA is obtained by subtracting + the HA from the local apparent ST. + + 6) To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + + 7) This routine takes time to execute, due mainly to the + rigorous integration used to evaluate the refraction. + For processing multiple stars for one location and time, + call slAOPA once followed by one call per star to slAOPQ. + Where a range of times within a limited period of a few hours + is involved, and the highest precision is not required, call + slAOPA once, followed by a call to slAOPT each time the + time changes, followed by one call per star to slAOPQ. + + 8) The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the delta UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap delta UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the delta UTC changes by one second to its post-leap new value. + + 9) The delta UT (UT1-UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep delta UT + within +/- 0.9 seconds. + + 10) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. + The longitude required by the present routine is east-positive, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + slOBS routine are west-positive, following astronomical + usage, and must be reversed in sign before use in the present + routine. + + 11) The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The maximum amplitude + is about 0.3 arcseconds. If XP,YP values are unavailable, + use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac + for a definition of the two angles. + + 12) The height above sea level of the observing station, HM, + can be obtained from the Astronomical Almanac (Section J + in the 1988 edition), or via the routine slOBS. If P, + the pressure in millibars, is available, an adequate + estimate of HM can be obtained from the expression + + HM ~ -29.3D0*TSL*LOG(P/1013.25D0). + + where TSL is the approximate sea-level air temperature in + deg K (see Astrophysical Quantities, C.W.Allen, 3rd edition, + section 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + + P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). + + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + + 13) The azimuths etc produced by the present routine are with + respect to the celestial pole. Corrections to the terrestrial + pole can be computed using slPLMO. + + Called: slAOPA, slAOPQ + + P.T.Wallace Starlink 9 June 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/aoppa.hlp b/math/slalib/doc/aoppa.hlp new file mode 100644 index 00000000..f96d835b --- /dev/null +++ b/math/slalib/doc/aoppa.hlp @@ -0,0 +1,114 @@ +.help aoppa Jun99 "Slalib Package" +.nf + + SUBROUTINE slAOPA (DATE, DUT, ELONGM, PHIM, HM, + : XP, YP, TDK, PMB, RH, WL, TLR, AOPRMS) + + - - - - - - + A O P A + - - - - - - + + Precompute apparent to observed place parameters required by + slAOPQ and slOAPQ. + + Given: + DATE d UTC date/time (modified Julian Date, JD-2400000.5) + DUT d delta UT: UT1-UTC (UTC seconds) + ELONGM d mean longitude of the observer (radians, east +ve) + PHIM d mean geodetic latitude of the observer (radians) + HM d observer's height above sea level (metres) + XP d polar motion x-coordinate (radians) + YP d polar motion y-coordinate (radians) + TDK d local ambient temperature (DegK; std=273.155D0) + PMB d local atmospheric pressure (mB; std=1013.25D0) + RH d local relative humidity (in the range 0D0-1D0) + WL d effective wavelength (micron, e.g. 0.55D0) + TLR d tropospheric lapse rate (DegK/metre, e.g. 0.0065D0) + + Returned: + AOPRMS d(14) star-independent apparent-to-observed parameters: + + (1) geodetic latitude (radians) + (2,3) sine and cosine of geodetic latitude + (4) magnitude of diurnal aberration vector + (5) height (HM) + (6) ambient temperature (TDK) + (7) pressure (PMB) + (8) relative humidity (RH) + (9) wavelength (WL) + (10) lapse rate (TLR) + (11,12) refraction constants A and B (radians) + (13) longitude + eqn of equinoxes + sidereal DUT (radians) + (14) local apparent sidereal time (radians) + + Notes: + + 1) It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + + 2) The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, improper, because of leap seconds. However, + as long as the delta UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap delta UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the delta UTC changes by one second to its post-leap new value. + + 3) The delta UT (UT1-UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep delta UT + within +/- 0.9 seconds. + + 4) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. + The longitude required by the present routine is east-positive, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + slOBS routine are west-positive, following astronomical + usage, and must be reversed in sign before use in the present + routine. + + 5) The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The maximum amplitude + is about 0.3 arcseconds. If XP,YP values are unavailable, + use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac + for a definition of the two angles. + + 6) The height above sea level of the observing station, HM, + can be obtained from the Astronomical Almanac (Section J + in the 1988 edition), or via the routine slOBS. If P, + the pressure in millibars, is available, an adequate + estimate of HM can be obtained from the expression + + HM ~ -29.3D0*TSL*LOG(P/1013.25D0). + + where TSL is the approximate sea-level air temperature in + deg K (see Astrophysical Quantities, C.W.Allen, 3rd edition, + section 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + + P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). + + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + + 7) Repeated, computationally-expensive, calls to slAOPA for + times that are very close together can be avoided by calling + slAOPA just once and then using slAOPT for the subsequent + times. Fresh calls to slAOPA will be needed only when changes + in the precession have grown to unacceptable levels or when + anything affecting the refraction has changed. + + Called: slGEOC, slRFCO, slEQEX, slAOPT + + P.T.Wallace Starlink 9 June 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/aoppat.hlp b/math/slalib/doc/aoppat.hlp new file mode 100644 index 00000000..c5d6f9c8 --- /dev/null +++ b/math/slalib/doc/aoppat.hlp @@ -0,0 +1,39 @@ +.help aoppat Jun99 "Slalib Package" +.nf + + SUBROUTINE slAOPT (DATE, AOPRMS) + + - - - - - - - + A O P T + - - - - - - - + + Recompute the sidereal time in the apparent to observed place + star-independent parameter block. + + Given: + DATE d UTC date/time (modified Julian Date, JD-2400000.5) + (see AOPPA source for comments on leap seconds) + + AOPRMS d(14) star-independent apparent-to-observed parameters + + (1-12) not required + (13) longitude + eqn of equinoxes + sidereal DUT + (14) not required + + Returned: + AOPRMS d(14) star-independent apparent-to-observed parameters: + + (1-13) not changed + (14) local apparent sidereal time (radians) + + For more information, see slAOPA. + + Called: slGMST + + P.T.Wallace Starlink 1 July 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/aopqk.hlp b/math/slalib/doc/aopqk.hlp new file mode 100644 index 00000000..aa916a5d --- /dev/null +++ b/math/slalib/doc/aopqk.hlp @@ -0,0 +1,131 @@ +.help aopqk Jun99 "Slalib Package" +.nf + + SUBROUTINE slAOPQ (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB) + + - - - - - - + A O P Q + - - - - - - + + Quick apparent to observed place (but see note 8, below, for + remarks about speed). + + Given: + RAP d geocentric apparent right ascension + DAP d geocentric apparent declination + AOPRMS d(14) star-independent apparent-to-observed parameters: + + (1) geodetic latitude (radians) + (2,3) sine and cosine of geodetic latitude + (4) magnitude of diurnal aberration vector + (5) height (HM) + (6) ambient temperature (T) + (7) pressure (P) + (8) relative humidity (RH) + (9) wavelength (WL) + (10) lapse rate (TLR) + (11,12) refraction constants A and B (radians) + (13) longitude + eqn of equinoxes + sidereal DUT (radians) + (14) local apparent sidereal time (radians) + + Returned: + AOB d observed azimuth (radians: N=0,E=90) + ZOB d observed zenith distance (radians) + HOB d observed Hour Angle (radians) + DOB d observed Declination (radians) + ROB d observed Right Ascension (radians) + + Notes: + + 1) This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + + 2) The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + observed RA,Dec predicted by this routine should be within + about 0.1 arcsec for a zenith distance of less than 70 degrees. + Even at a topocentric zenith distance of 90 degrees, the + accuracy in elevation should be better than 1 arcmin; useful + results are available for a further 3 degrees, beyond which + the slaRefro routine returns a fixed value of the refraction. + The complementary routines slaAop (or slaAopqk) and slaOap + (or slaOapqk) are self-consistent to better than 1 micro- + arcsecond all over the celestial sphere. + + 3) It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + + 4) "Apparent" place means the geocentric apparent right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, precession, nutation, + annual aberration, and the Sun's gravitational lens effect. For + star positions in the FK5 system (i.e. J2000), these effects can + be applied by means of the slMAP etc routines. Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 (i.e. B1950) mean places would first + have to be converted to FK5, which can be done with the + slFK45 etc routines. + + 5) "Observed" Az,El means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent RA,Dec by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The HA,Dec is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation (n.b. not to the + refracted pole). Finally, the RA is obtained by subtracting + the HA from the local apparent ST. + + 6) To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + + 7) The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the slAOPA routine. + If nothing has changed significantly except the time, the + slAOPT routine may be used to perform the requisite + partial recomputation of AOPRMS. + + 8) At zenith distances beyond about 76 degrees, the need for + special care with the corrections for refraction causes a + marked increase in execution time. Moreover, the effect + gets worse with increasing zenith distance. Adroit + programming in the calling application may allow the + problem to be reduced. Prepare an alternative AOPRMS array, + computed for zero air-pressure; this will disable the + refraction corrections and cause rapid execution. Using + this AOPRMS array, a preliminary call to the present routine + will, depending on the application, produce a rough position + which may be enough to establish whether the full, slow + calculation (using the real AOPRMS array) is worthwhile. + For example, there would be no need for the full calculation + if the preliminary call had already established that the + source was well below the elevation limits for a particular + telescope. + + 9) The azimuths etc produced by the present routine are with + respect to the celestial pole. Corrections to the terrestrial + pole can be computed using slPLMO. + + Called: slDS2C, slREFZ, slRFRO, slDC2S, slDA2P + + P.T.Wallace Starlink 22 February 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/atmdsp.hlp b/math/slalib/doc/atmdsp.hlp new file mode 100644 index 00000000..eaa2b411 --- /dev/null +++ b/math/slalib/doc/atmdsp.hlp @@ -0,0 +1,75 @@ +.help atmdsp Jun99 "Slalib Package" +.nf + + SUBROUTINE slATMD (TDK, PMB, RH, WL1, A1, B1, WL2, A2, B2) + + - - - - - - - + A T M D + - - - - - - - + + Apply atmospheric-dispersion adjustments to refraction coefficients. + + Given: + TDK d ambient temperature, degrees K + PMB d ambient pressure, millibars + RH d ambient relative humidity, 0-1 + WL1 d reference wavelength, micrometre (0.4D0 recommended) + A1 d refraction coefficient A for wavelength WL1 (radians) + B1 d refraction coefficient B for wavelength WL1 (radians) + WL2 d wavelength for which adjusted A,B required + + Returned: + A2 d refraction coefficient A for wavelength WL2 (radians) + B2 d refraction coefficient B for wavelength WL2 (radians) + + Notes: + + 1 To use this routine, first call slRFCO specifying WL1 as the + wavelength. This yields refraction coefficients A1,B1, correct + for that wavelength. Subsequently, calls to slATMD specifying + different wavelengths will produce new, slightly adjusted + refraction coefficients which apply to the specified wavelength. + + 2 Most of the atmospheric dispersion happens between 0.7 micrometre + and the UV atmospheric cutoff, and the effect increases strongly + towards the UV end. For this reason a blue reference wavelength + is recommended, for example 0.4 micrometres. + + 3 The accuracy, for this set of conditions: + + height above sea level 2000 m + latitude 29 deg + pressure 793 mB + temperature 17 degC + humidity 50% + lapse rate 0.0065 degC/m + reference wavelength 0.4 micrometre + star elevation 15 deg + + is about 2.5 mas RMS between 0.3 and 1.0 micrometres, and stays + within 4 mas for the whole range longward of 0.3 micrometres + (compared with a total dispersion from 0.3 to 20.0 micrometres + of about 11 arcsec). These errors are typical for ordinary + conditions and the given elevation; in extreme conditions values + a few times this size may occur, while at higher elevations the + errors become much smaller. + + 4 If either wavelength exceeds 100 micrometres, the radio case + is assumed and the returned refraction coefficients are the + same as the given ones. + + 5 The algorithm consists of calculation of the refractivity of the + air at the observer for the two wavelengths, using the methods + of the slRFRO routine, and then scaling of the two refraction + coefficients according to classical refraction theory. This + amounts to scaling the A coefficient in proportion to (n-1) and + the B coefficient almost in the same ratio (see R.M.Green, + "Spherical Astronomy", Cambridge University Press, 1985). + + P.T.Wallace Starlink 6 October 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/av2m.hlp b/math/slalib/doc/av2m.hlp new file mode 100644 index 00000000..0a98df84 --- /dev/null +++ b/math/slalib/doc/av2m.hlp @@ -0,0 +1,37 @@ +.help av2m Jun99 "Slalib Package" +.nf + + SUBROUTINE slAV2M (AXVEC, RMAT) + + - - - - - + A V 2 M + - - - - - + + Form the rotation matrix corresponding to a given axial vector. + + (single precision) + + A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the Euler axis, and the angle through which the + reference frame rotates is called the Euler angle. The axial + vector supplied to this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. + + Given: + AXVEC r(3) axial vector (radians) + + Returned: + RMAT r(3,3) rotation matrix + + If AXVEC is null, the unit matrix is returned. + + The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + + P.T.Wallace Starlink June 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/bear.hlp b/math/slalib/doc/bear.hlp new file mode 100644 index 00000000..97e4f13d --- /dev/null +++ b/math/slalib/doc/bear.hlp @@ -0,0 +1,30 @@ +.help bear Jun99 "Slalib Package" +.nf + + REAL FUNCTION slBEAR (A1, B1, A2, B2) + + - - - - - + B E A R + - - - - - + + Bearing (position angle) of one point on a sphere relative to another + (single precision) + + Given: + A1,B1 r spherical coordinates of one point + A2,B2 r spherical coordinates of the other point + + (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) + + The result is the bearing (position angle), in radians, of point + A2,B2 as seen from point A1,B1. It is in the range +/- pi. If + A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned + if the two points are coincident. + + P.T.Wallace Starlink 23 March 1991 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/caf2r.hlp b/math/slalib/doc/caf2r.hlp new file mode 100644 index 00000000..7533ff94 --- /dev/null +++ b/math/slalib/doc/caf2r.hlp @@ -0,0 +1,38 @@ +.help caf2r Jun99 "Slalib Package" +.nf + + SUBROUTINE slCAFR (IDEG, IAMIN, ASEC, RAD, J) + + - - - - - - + C A F R + - - - - - - + + Convert degrees, arcminutes, arcseconds to radians + (single precision) + + Given: + IDEG int degrees + IAMIN int arcminutes + ASEC real arcseconds + + Returned: + RAD real angle in radians + J int status: 0 = OK + 1 = IDEG outside range 0-359 + 2 = IAMIN outside range 0-59 + 3 = ASEC outside range 0-59.999... + + Notes: + + 1) The result is computed even if any of the range checks + fail. + + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/caldj.hlp b/math/slalib/doc/caldj.hlp new file mode 100644 index 00000000..1504c667 --- /dev/null +++ b/math/slalib/doc/caldj.hlp @@ -0,0 +1,38 @@ +.help caldj Jun99 "Slalib Package" +.nf + + SUBROUTINE slCADJ (IY, IM, ID, DJM, J) + + - - - - - - + C A D J + - - - - - - + + Gregorian Calendar to Modified Julian Date + + (Includes century default feature: use slCLDJ for years + before 100AD.) + + Given: + IY,IM,ID int year, month, day in Gregorian calendar + + Returned: + DJM dp modified Julian Date (JD-2400000.5) for 0 hrs + J int status: + 0 = OK + 1 = bad year (MJD not computed) + 2 = bad month (MJD not computed) + 3 = bad day (MJD computed) + + Acceptable years are 00-49, interpreted as 2000-2049, + 50-99, " " 1950-1999, + 100 upwards, interpreted literally. + + Called: slCLDJ + + P.T.Wallace Starlink November 1985 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/calyd.hlp b/math/slalib/doc/calyd.hlp new file mode 100644 index 00000000..7011cc41 --- /dev/null +++ b/math/slalib/doc/calyd.hlp @@ -0,0 +1,49 @@ +.help calyd Jun99 "Slalib Package" +.nf + + SUBROUTINE slCAYD (IY, IM, ID, NY, ND, J) + + - - - - - - + C A Y D + - - - - - - + + Gregorian calendar date to year and day in year (in a Julian + calendar aligned to the 20th/21st century Gregorian calendar). + + (Includes century default feature: use slCLYD for years + before 100AD.) + + Given: + IY,IM,ID int year, month, day in Gregorian calendar + (year may optionally omit the century) + Returned: + NY int year (re-aligned Julian calendar) + ND int day in year (1 = January 1st) + J int status: + 0 = OK + 1 = bad year (before -4711) + 2 = bad month + 3 = bad day (but conversion performed) + + Notes: + + 1 This routine exists to support the low-precision routines + slERTH, slMOON and slECOR. + + 2 Between 1900 March 1 and 2100 February 28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + + 3 Years in the range 50-99 are interpreted as 1950-1999, and + years in the range 00-49 are interpreted as 2000-2049. + + Called: slCLYD + + P.T.Wallace Starlink 23 November 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cc2s.hlp b/math/slalib/doc/cc2s.hlp new file mode 100644 index 00000000..8a16e76e --- /dev/null +++ b/math/slalib/doc/cc2s.hlp @@ -0,0 +1,33 @@ +.help cc2s Jun99 "Slalib Package" +.nf + + SUBROUTINE slCC2S (V, A, B) + + - - - - - + C C 2 S + - - - - - + + Direction cosines to spherical coordinates (single precision) + + Given: + V r(3) x,y,z vector + + Returned: + A,B r spherical coordinates in radians + + The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the x axis + at zero longitude and latitude, and the z axis at the + +ve latitude pole. + + If V is null, zero A and B are returned. + At either pole, zero A is returned. + + P.T.Wallace Starlink July 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cc62s.hlp b/math/slalib/doc/cc62s.hlp new file mode 100644 index 00000000..ffd20cb8 --- /dev/null +++ b/math/slalib/doc/cc62s.hlp @@ -0,0 +1,30 @@ +.help cc62s Jun99 "Slalib Package" +.nf + + SUBROUTINE slC62S (V, A, B, R, AD, BD, RD) + + - - - - - - + C 6 2 S + - - - - - - + + Conversion of position & velocity in Cartesian coordinates + to spherical coordinates (single precision) + + Given: + V r(6) Cartesian position & velocity vector + + Returned: + A r longitude (radians) + B r latitude (radians) + R r radial coordinate + AD r longitude derivative (radians per unit time) + BD r latitude derivative (radians per unit time) + RD r radial derivative + + P.T.Wallace Starlink 28 April 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cd2tf.hlp b/math/slalib/doc/cd2tf.hlp new file mode 100644 index 00000000..52e66f62 --- /dev/null +++ b/math/slalib/doc/cd2tf.hlp @@ -0,0 +1,47 @@ +.help cd2tf Jun99 "Slalib Package" +.nf + + SUBROUTINE slCDTF (NDP, DAYS, SIGN, IHMSF) + + - - - - - - + C D T F + - - - - - - + + Convert an interval in days into hours, minutes, seconds + + (single precision) + + Given: + NDP int number of decimal places of seconds + DAYS real interval in days + + Returned: + SIGN char '+' or '-' + IHMSF int(4) hours, minutes, seconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size of + DAYS, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). For example, + on the VAX, for DAYS up to 1.0, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + + 3) The absolute value of DAYS may exceed 1.0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1.0 and rounds up to 24 hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + + Called: slDDTF + + P.T.Wallace Starlink 12 December 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cldj.hlp b/math/slalib/doc/cldj.hlp new file mode 100644 index 00000000..3f65adb1 --- /dev/null +++ b/math/slalib/doc/cldj.hlp @@ -0,0 +1,34 @@ +.help cldj Jun99 "Slalib Package" +.nf + + SUBROUTINE slCLDJ (IY, IM, ID, DJM, J) + + - - - - - + C L D J + - - - - - + + Gregorian Calendar to Modified Julian Date + + Given: + IY,IM,ID int year, month, day in Gregorian calendar + + Returned: + DJM dp modified Julian Date (JD-2400000.5) for 0 hrs + J int status: + 0 = OK + 1 = bad year (MJD not computed) + 2 = bad month (MJD not computed) + 3 = bad day (MJD computed) + + The year must be -4699 (i.e. 4700BC) or later. + + The algorithm is derived from that of Hatcher 1984 + (QJRAS 25, 53-55). + + P.T.Wallace Starlink 11 March 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/clyd.hlp b/math/slalib/doc/clyd.hlp new file mode 100644 index 00000000..7afbe1aa --- /dev/null +++ b/math/slalib/doc/clyd.hlp @@ -0,0 +1,50 @@ +.help clyd Jun99 "Slalib Package" +.nf + + SUBROUTINE slCLYD (IY, IM, ID, NY, ND, JSTAT) + + - - - - - + C L Y D + - - - - - + + Gregorian calendar to year and day in year (in a Julian calendar + aligned to the 20th/21st century Gregorian calendar). + + Given: + IY,IM,ID i year, month, day in Gregorian calendar + + Returned: + NY i year (re-aligned Julian calendar) + ND i day in year (1 = January 1st) + JSTAT i status: + 0 = OK + 1 = bad year (before -4711) + 2 = bad month + 3 = bad day (but conversion performed) + + Notes: + + 1 This routine exists to support the low-precision routines + slERTH, slMOON and slECOR. + + 2 Between 1900 March 1 and 2100 February 28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + + 3 The essence of the algorithm is first to express the Gregorian + date as a Julian Day Number and then to convert this back to + a Julian calendar date, with day-in-year instead of month and + day. See 12.92-1 and 12.95-1 in the reference. + + Reference: Explanatory Supplement to the Astronomical Almanac, + ed P.K.Seidelmann, University Science Books (1992), + p604-606. + + P.T.Wallace Starlink 26 November 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cr2af.hlp b/math/slalib/doc/cr2af.hlp new file mode 100644 index 00000000..2a1863ca --- /dev/null +++ b/math/slalib/doc/cr2af.hlp @@ -0,0 +1,46 @@ +.help cr2af Jun99 "Slalib Package" +.nf + + SUBROUTINE slCRAF (NDP, ANGLE, SIGN, IDMSF) + + - - - - - - + C R A F + - - - - - - + + Convert an angle in radians into degrees, arcminutes, arcseconds + (single precision) + + Given: + NDP int number of decimal places of arcseconds + ANGLE real angle in radians + + Returned: + SIGN char '+' or '-' + IDMSF int(4) degrees, arcminutes, arcseconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IDMSF(4). For example, + on the VAX, for ANGLE up to 2pi, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + + 3) The absolute value of ANGLE may exceed 2pi. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly 2pi and rounds up to 360 deg, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + + Called: slCDTF + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cr2tf.hlp b/math/slalib/doc/cr2tf.hlp new file mode 100644 index 00000000..719db50e --- /dev/null +++ b/math/slalib/doc/cr2tf.hlp @@ -0,0 +1,46 @@ +.help cr2tf Jun99 "Slalib Package" +.nf + + SUBROUTINE slCRTF (NDP, ANGLE, SIGN, IHMSF) + + - - - - - - + C R T F + - - - - - - + + Convert an angle in radians into hours, minutes, seconds + (single precision) + + Given: + NDP int number of decimal places of seconds + ANGLE real angle in radians + + Returned: + SIGN char '+' or '-' + IHMSF int(4) hours, minutes, seconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). For example, + on the VAX, for ANGLE up to 2pi, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + + 3) The absolute value of ANGLE may exceed 2pi. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly 2pi and rounds up to 24 hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + + Called: slCDTF + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cs2c.hlp b/math/slalib/doc/cs2c.hlp new file mode 100644 index 00000000..df71c82c --- /dev/null +++ b/math/slalib/doc/cs2c.hlp @@ -0,0 +1,31 @@ +.help cs2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slCS2C (A, B, V) + + - - - - - + C S 2 C + - - - - - + + Spherical coordinates to direction cosines (single precision) + + Given: + A,B real spherical coordinates in radians + (RA,Dec), (Long,Lat) etc + + Returned: + V real(3) x,y,z unit vector + + The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the x axis + at zero longitude and latitude, and the z axis at the + +ve latitude pole. + + P.T.Wallace Starlink October 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/cs2c6.hlp b/math/slalib/doc/cs2c6.hlp new file mode 100644 index 00000000..0b69377d --- /dev/null +++ b/math/slalib/doc/cs2c6.hlp @@ -0,0 +1,30 @@ +.help cs2c6 Jun99 "Slalib Package" +.nf + + SUBROUTINE slS2C6 (A, B, R, AD, BD, RD, V) + + - - - - - - + S 2 C 6 + - - - - - - + + Conversion of position & velocity in spherical coordinates + to Cartesian coordinates (single precision) + + Given: + A r longitude (radians) + B r latitude (radians) + R r radial coordinate + AD r longitude derivative (radians per unit time) + BD r latitude derivative (radians per unit time) + RD r radial derivative + + Returned: + V r(6) Cartesian position & velocity vector + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ctf2d.hlp b/math/slalib/doc/ctf2d.hlp new file mode 100644 index 00000000..e8c985c3 --- /dev/null +++ b/math/slalib/doc/ctf2d.hlp @@ -0,0 +1,37 @@ +.help ctf2d Jun99 "Slalib Package" +.nf + + SUBROUTINE slCTFD (IHOUR, IMIN, SEC, DAYS, J) + + - - - - - - + C T F D + - - - - - - + + Convert hours, minutes, seconds to days (single precision) + + Given: + IHOUR int hours + IMIN int minutes + SEC real seconds + + Returned: + DAYS real interval in days + J int status: 0 = OK + 1 = IHOUR outside range 0-23 + 2 = IMIN outside range 0-59 + 3 = SEC outside range 0-59.999... + + Notes: + + 1) The result is computed even if any of the range checks + fail. + + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ctf2r.hlp b/math/slalib/doc/ctf2r.hlp new file mode 100644 index 00000000..72a1fb56 --- /dev/null +++ b/math/slalib/doc/ctf2r.hlp @@ -0,0 +1,40 @@ +.help ctf2r Jun99 "Slalib Package" +.nf + + SUBROUTINE slCTFR (IHOUR, IMIN, SEC, RAD, J) + + - - - - - - + C T F R + - - - - - - + + Convert hours, minutes, seconds to radians (single precision) + + Given: + IHOUR int hours + IMIN int minutes + SEC real seconds + + Returned: + RAD real angle in radians + J int status: 0 = OK + 1 = IHOUR outside range 0-23 + 2 = IMIN outside range 0-59 + 3 = SEC outside range 0-59.999... + + Called: + slCTFD + + Notes: + + 1) The result is computed even if any of the range checks + fail. + + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/daf2r.hlp b/math/slalib/doc/daf2r.hlp new file mode 100644 index 00000000..f0cf7434 --- /dev/null +++ b/math/slalib/doc/daf2r.hlp @@ -0,0 +1,36 @@ +.help daf2r Jun99 "Slalib Package" +.nf + + SUBROUTINE slDAFR (IDEG, IAMIN, ASEC, RAD, J) + + - - - - - - + D A F R + - - - - - - + + Convert degrees, arcminutes, arcseconds to radians + (double precision) + + Given: + IDEG int degrees + IAMIN int arcminutes + ASEC dp arcseconds + + Returned: + RAD dp angle in radians + J int status: 0 = OK + 1 = IDEG outside range 0-359 + 2 = IAMIN outside range 0-59 + 3 = ASEC outside range 0-59.999... + + Notes: + 1) The result is computed even if any of the range checks + fail. + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dafin.hlp b/math/slalib/doc/dafin.hlp new file mode 100644 index 00000000..2fa24d5c --- /dev/null +++ b/math/slalib/doc/dafin.hlp @@ -0,0 +1,90 @@ +.help dafin Jun99 "Slalib Package" +.nf + + SUBROUTINE slDAFN (STRING, IPTR, A, J) + + - - - - - - + D A F N + - - - - - - + + Sexagesimal character string to angle (double precision) + + Given: + STRING c*(*) string containing deg, arcmin, arcsec fields + IPTR i pointer to start of decode (1st = 1) + + Returned: + IPTR i advanced past the decoded angle + A d angle in radians + J i status: 0 = OK + +1 = default, A unchanged + -1 = bad degrees ) + -2 = bad arcminutes ) (note 3) + -3 = bad arcseconds ) + + Example: + + argument before after + + STRING '-57 17 44.806 12 34 56.7' unchanged + IPTR 1 16 (points to 12...) + A ? -1.00000D0 + J ? 0 + + A further call to slDAFN, without adjustment of IPTR, will + decode the second angle, 12deg 34min 56.7sec. + + Notes: + + 1) The first three "fields" in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the DFLTIN routine and is free-format. + + 2) Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and A is + unchanged. In all other cases A is changed. + + 3) Range checking: + + The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are absent. + + The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + + The arcseconds field is expected to be 0-59.9999... + + 4) Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting + to zero, and the result A is computed and returned. + + 5) Further fields after the three expected ones are not treated + as an error. The pointer IPTR is left in the correct state + for further decoding with the present routine or with DFLTIN + etc. See the example, above. + + 6) If STRING contains hours, minutes, seconds instead of degrees + etc, or if the required units are turns (or days) instead of + radians, the result A should be multiplied as follows: + + for to obtain multiply + STRING A in A by + + d ' " radians 1 = 1D0 + d ' " turns 1/2pi = 0.1591549430918953358D0 + h m s radians 15 = 15D0 + h m s days 15/2pi = 2.3873241463784300365D0 + + Called: slDFLI + + P.T.Wallace Starlink 1 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dat.hlp b/math/slalib/doc/dat.hlp new file mode 100644 index 00000000..20777dc5 --- /dev/null +++ b/math/slalib/doc/dat.hlp @@ -0,0 +1,55 @@ +.help dat Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDAT (UTC) + + - - - - + D A T + - - - - + + Increment to be applied to Coordinated Universal Time UTC to give + International Atomic Time TAI (double precision) + + Given: + UTC d UTC date as a modified JD (JD-2400000.5) + + Result: TAI-UTC in seconds + + Notes: + + 1 The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can only be guaranteed up to the end of the second 23:59:59. + + 2 For epochs from 1961 January 1 onwards, the expressions from the + file ftp://maia.usno.navy.mil/ser7/tai-utc.dat are used. + + 3 The 5ms timestep at 1961 January 1 is taken from 2.58.1 (p87) of + the 1992 Explanatory Supplement. + + 4 UTC began at 1960 January 1.0 (JD 2436934.5) and it is improper + to call the routine with an earlier epoch. However, if this + is attempted, the TAI-UTC expression for the year 1960 is used. + + + :-----------------------------------------: + : : + : IMPORTANT : + : : + : This routine must be updated on each : + : occasion that a leap second is : + : announced : + : : + : Latest leap second: 1999 January 1 : + : : + :-----------------------------------------: + + P.T.Wallace Starlink 31 May 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dav2m.hlp b/math/slalib/doc/dav2m.hlp new file mode 100644 index 00000000..26d5fae6 --- /dev/null +++ b/math/slalib/doc/dav2m.hlp @@ -0,0 +1,36 @@ +.help dav2m Jun99 "Slalib Package" +.nf + + SUBROUTINE slDAVM (AXVEC, RMAT) + + - - - - - - + D A V M + - - - - - - + + Form the rotation matrix corresponding to a given axial vector. + (double precision) + + A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the Euler axis, and the angle through which the + reference frame rotates is called the Euler angle. The axial + vector supplied to this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. + + Given: + AXVEC d(3) axial vector (radians) + + Returned: + RMAT d(3,3) rotation matrix + + If AXVEC is null, the unit matrix is returned. + + The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + + P.T.Wallace Starlink June 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dbear.hlp b/math/slalib/doc/dbear.hlp new file mode 100644 index 00000000..8d796e61 --- /dev/null +++ b/math/slalib/doc/dbear.hlp @@ -0,0 +1,30 @@ +.help dbear Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDBER (A1, B1, A2, B2) + + - - - - - - + D B E R + - - - - - - + + Bearing (position angle) of one point on a sphere relative to another + (double precision) + + Given: + A1,B1 d spherical coordinates of one point + A2,B2 d spherical coordinates of the other point + + (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) + + The result is the bearing (position angle), in radians, of point + A2,B2 as seen from point A1,B1. It is in the range +/- pi. If + A2,B2 is due east of A1,B1 the bearing is +pi/2. Zero is returned + if the two points are coincident. + + P.T.Wallace Starlink 23 March 1991 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dbjin.hlp b/math/slalib/doc/dbjin.hlp new file mode 100644 index 00000000..017333dd --- /dev/null +++ b/math/slalib/doc/dbjin.hlp @@ -0,0 +1,52 @@ +.help dbjin Jun99 "Slalib Package" +.nf + + SUBROUTINE slDBJI (STRING, NSTRT, DRESLT, J1, J2) + + - - - - - - + D B J I + - - - - - - + + Convert free-format input into double precision floating point, + using DFLTIN but with special syntax extensions. + + The purpose of the syntax extensions is to help cope with mixed + FK4 and FK5 data. In addition to the syntax accepted by DFLTIN, + the following two extensions are recognized by DBJIN: + + 1) A valid non-null field preceded by the character 'B' + (or 'b') is accepted. + + 2) A valid non-null field preceded by the character 'J' + (or 'j') is accepted. + + The calling program is notified of the incidence of either of these + extensions through an supplementary status argument. The rest of + the arguments are as for DFLTIN. + + Given: + STRING char string containing field to be decoded + NSTRT int pointer to 1st character of field in string + + Returned: + NSTRT int incremented + DRESLT double result + J1 int DFLTIN status: -1 = -OK + 0 = +OK + +1 = null field + +2 = error + J2 int syntax flag: 0 = normal DFLTIN syntax + +1 = 'B' or 'b' + +2 = 'J' or 'j' + + Called: slDFLI + + For details of the basic syntax, see slDFLI. + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dc62s.hlp b/math/slalib/doc/dc62s.hlp new file mode 100644 index 00000000..0294205b --- /dev/null +++ b/math/slalib/doc/dc62s.hlp @@ -0,0 +1,30 @@ +.help dc62s Jun99 "Slalib Package" +.nf + + SUBROUTINE slDC6S (V, A, B, R, AD, BD, RD) + + - - - - - - + D C 6 S + - - - - - - + + Conversion of position & velocity in Cartesian coordinates + to spherical coordinates (double precision) + + Given: + V d(6) Cartesian position & velocity vector + + Returned: + A d longitude (radians) + B d latitude (radians) + R d radial coordinate + AD d longitude derivative (radians per unit time) + BD d latitude derivative (radians per unit time) + RD d radial derivative + + P.T.Wallace Starlink 28 April 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dcc2s.hlp b/math/slalib/doc/dcc2s.hlp new file mode 100644 index 00000000..ace02cf7 --- /dev/null +++ b/math/slalib/doc/dcc2s.hlp @@ -0,0 +1,33 @@ +.help dcc2s Jun99 "Slalib Package" +.nf + + SUBROUTINE slDC2S (V, A, B) + + - - - - - - + D C 2 S + - - - - - - + + Direction cosines to spherical coordinates (double precision) + + Given: + V d(3) x,y,z vector + + Returned: + A,B d spherical coordinates in radians + + The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the x axis + at zero longitude and latitude, and the z axis at the + +ve latitude pole. + + If V is null, zero A and B are returned. + At either pole, zero A is returned. + + P.T.Wallace Starlink July 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dcmpf.hlp b/math/slalib/doc/dcmpf.hlp new file mode 100644 index 00000000..914addfd --- /dev/null +++ b/math/slalib/doc/dcmpf.hlp @@ -0,0 +1,70 @@ +.help dcmpf Jun99 "Slalib Package" +.nf + + SUBROUTINE slDCMF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT) + + - - - - - - + D C M F + - - - - - - + + Decompose an [X,Y] linear fit into its constituent parameters: + zero points, scales, nonperpendicularity and orientation. + + Given: + COEFFS d(6) transformation coefficients (see note) + + Returned: + XZ d x zero point + YZ d y zero point + XS d x scale + YS d y scale + PERP d nonperpendicularity (radians) + ORIENT d orientation (radians) + + The model relates two sets of [X,Y] coordinates as follows. + Naming the elements of COEFFS: + + COEFFS(1) = A + COEFFS(2) = B + COEFFS(3) = C + COEFFS(4) = D + COEFFS(5) = E + COEFFS(6) = F + + the model transforms coordinates [X1,Y1] into coordinates + [X2,Y2] as follows: + + X2 = A + B*X1 + C*Y1 + Y2 = D + E*X1 + F*Y1 + + The transformation can be decomposed into four steps: + + 1) Zero points: + + x' = XZ + X1 + y' = YZ + Y1 + + 2) Scales: + + x'' = XS*x' + y'' = YS*y' + + 3) Nonperpendicularity: + + x''' = cos(PERP/2)*x'' + sin(PERP/2)*y'' + y''' = sin(PERP/2)*x'' + cos(PERP/2)*y'' + + 4) Orientation: + + X2 = cos(ORIENT)*x''' + sin(ORIENT)*y''' + Y2 =-sin(ORIENT)*y''' + cos(ORIENT)*y''' + + See also slFTXY, slPXY, slINVF, slXYXY + + P.T.Wallace Starlink 14 August 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dcs2c.hlp b/math/slalib/doc/dcs2c.hlp new file mode 100644 index 00000000..50010ea4 --- /dev/null +++ b/math/slalib/doc/dcs2c.hlp @@ -0,0 +1,31 @@ +.help dcs2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slDS2C (A, B, V) + + - - - - - - + D S 2 C + - - - - - - + + Spherical coordinates to direction cosines (double precision) + + Given: + A,B dp spherical coordinates in radians + (RA,Dec), (Long,Lat) etc + + Returned: + V dp(3) x,y,z unit vector + + The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the x axis + at zero longitude and latitude, and the z axis at the + +ve latitude pole. + + P.T.Wallace Starlink October 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dd2tf.hlp b/math/slalib/doc/dd2tf.hlp new file mode 100644 index 00000000..124a7fcc --- /dev/null +++ b/math/slalib/doc/dd2tf.hlp @@ -0,0 +1,44 @@ +.help dd2tf Jun99 "Slalib Package" +.nf + + SUBROUTINE slDDTF (NDP, DAYS, SIGN, IHMSF) + + - - - - - - + D D T F + - - - - - - + + Convert an interval in days into hours, minutes, seconds + (double precision) + + Given: + NDP i number of decimal places of seconds + DAYS d interval in days + + Returned: + SIGN c '+' or '-' + IHMSF i(4) hours, minutes, seconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size + of DAYS, the format of DOUBLE PRECISION floating-point numbers + on the target machine, and the risk of overflowing IHMSF(4). + For example, on the VAX, for DAYS up to 1D0, the available + floating-point precision corresponds roughly to NDP=12. + However, the practical limit is NDP=9, set by the capacity of + the 32-bit integer IHMSF(4). + + 3) The absolute value of DAYS may exceed 1D0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1D0 and rounds up to 24 hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + + P.T.Wallace Starlink 19 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/de2h.hlp b/math/slalib/doc/de2h.hlp new file mode 100644 index 00000000..7e5bcb06 --- /dev/null +++ b/math/slalib/doc/de2h.hlp @@ -0,0 +1,59 @@ +.help de2h Jun99 "Slalib Package" +.nf + + SUBROUTINE slDE2H (HA, DEC, PHI, AZ, EL) + + - - - - - + D E 2 H + - - - - - + + Equatorial to horizon coordinates: HA,Dec to Az,El + + (double precision) + + Given: + HA d hour angle + DEC d declination + PHI d observatory latitude + + Returned: + AZ d azimuth + EL d elevation + + Notes: + + 1) All the arguments are angles in radians. + + 2) Azimuth is returned in the range 0-2pi; north is zero, + and east is +pi/2. Elevation is returned in the range + +/-pi/2. + + 3) The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + + 4) In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the "observed" HA,Dec, and the elevation + in vacuo, which would require the "topocentric" HA,Dec. + If the effects of diurnal aberration can be neglected, the + "apparent" HA,Dec may be used instead of the topocentric + HA,Dec. + + 5) No range checking of arguments is carried out. + + 6) In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + + P.T.Wallace Starlink 9 July 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/deuler.hlp b/math/slalib/doc/deuler.hlp new file mode 100644 index 00000000..1dc55844 --- /dev/null +++ b/math/slalib/doc/deuler.hlp @@ -0,0 +1,50 @@ +.help deuler Jun99 "Slalib Package" +.nf + + SUBROUTINE slDEUL (ORDER, PHI, THETA, PSI, RMAT) + + - - - - - - - + D E U L + - - - - - - - + + Form a rotation matrix from the Euler angles - three successive + rotations about specified Cartesian axes (double precision) + + Given: + ORDER c*(*) specifies about which axes the rotations occur + PHI d 1st rotation (radians) + THETA d 2nd rotation ( " ) + PSI d 3rd rotation ( " ) + + Returned: + RMAT d(3,3) rotation matrix + + A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + + The characters of ORDER define which axes the three successive + rotations are about. A typical value is 'ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old Z-axis, followed by THETA radians about the resulting X-axis, + then PSI radians about the resulting Z-axis. + + The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labeling/numbering conventions apply; the xyz (=123) + triad is right-handed. Thus, the 'ZXZ' example given above + could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ'). ORDER + is terminated by length or by the first unrecognized character. + + Fewer than three rotations are acceptable, in which case the later + angle arguments are ignored. If all rotations are zero, the + identity matrix is produced. + + P.T.Wallace Starlink 23 May 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dfltin.hlp b/math/slalib/doc/dfltin.hlp new file mode 100644 index 00000000..be42311f --- /dev/null +++ b/math/slalib/doc/dfltin.hlp @@ -0,0 +1,118 @@ +.help dfltin Jun99 "Slalib Package" +.nf + + SUBROUTINE slDFLI (STRING, NSTRT, DRESLT, JFLAG) + + - - - - - - - + D F L I + - - - - - - - + + Convert free-format input into double precision floating point + + Given: + STRING c string containing number to be decoded + NSTRT i pointer to where decoding is to start + DRESLT d current value of result + + Returned: + NSTRT i advanced to next number + DRESLT d result + JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error + + Notes: + + 1 The reason DFLTIN has separate OK status values for + + and - is to enable minus zero to be detected. This is + of crucial importance when decoding mixed-radix numbers. + For example, an angle expressed as deg, arcmin, arcsec + may have a leading minus sign but a zero degrees field. + + 2 A TAB is interpreted as a space, and lowercase characters + are interpreted as uppercase. + + 3 The basic format is the sequence of fields #^.^@#^, where + # is a sign character + or -, ^ means a string of decimal + digits, and @, which indicates an exponent, means D or E. + Various combinations of these fields can be omitted, and + embedded blanks are permissible in certain places. + + 4 Spaces: + + . Leading spaces are ignored. + + . Embedded spaces are allowed only after +, -, D or E, + and after the decomal point if the first sequence of + digits is absent. + + . Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + + 5 Delimiters: + + . Any character other than +,-,0-9,.,D,E or space may be + used to signal the end of the number and terminate + decoding. + + . Comma is recognized by DFLTIN as a special case; it + is skipped, leaving the pointer on the next character. + See 13, below. + + 6 Both signs are optional. The default is +. + + 7 The mantissa ^.^ defaults to 1. + + 8 The exponent @#^ defaults to D0. + + 9 The strings of decimal digits may be of any length. + + 10 The decimal point is optional for whole numbers. + + 11 A "null result" occurs when the string of characters being + decoded does not begin with +,-,0-9,.,D or E, or consists + entirely of spaces. When this condition is detected, JFLAG + is set to 1 and DRESLT is left untouched. + + 12 NSTRT = 1 for the first character in the string. + + 13 On return from DFLTIN, NSTRT is set ready for the next + decode - following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to DFLTIN, otherwise + all subsequent calls will return a null result. + + 14 Errors (JFLAG=2) occur when: + + . a +, -, D or E is left unsatisfied; or + + . the decimal point is present without at least + one decimal digit before or after it; or + + . an exponent more than 100 has been presented. + + 15 When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + DFLTIN does not detect that '1D999' is unacceptable + (on a computer where this is so) until the entire number + has been decoded. + + 16 Certain highly unlikely combinations of mantissa & + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + + 17 Decoding is left to right, one pass. + + 18 See also FLOTIN and INTIN + + Called: slICHF + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dh2e.hlp b/math/slalib/doc/dh2e.hlp new file mode 100644 index 00000000..965653c8 --- /dev/null +++ b/math/slalib/doc/dh2e.hlp @@ -0,0 +1,58 @@ +.help dh2e Jun99 "Slalib Package" +.nf + + SUBROUTINE slDH2E (AZ, EL, PHI, HA, DEC) + + - - - - - + D E 2 H + - - - - - + + Horizon to equatorial coordinates: Az,El to HA,Dec + + (double precision) + + Given: + AZ d azimuth + EL d elevation + PHI d observatory latitude + + Returned: + HA d hour angle + DEC d declination + + Notes: + + 1) All the arguments are angles in radians. + + 2) The sign convention for azimuth is north zero, east +pi/2. + + 3) HA is returned in the range +/-pi. Declination is returned + in the range +/-pi/2. + + 4) The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied. + + 5) In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of HA,Dec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the "observed" HA,Dec, and the elevation + in vacuo, which will yield the "topocentric" HA,Dec. If the + effects of diurnal aberration can be neglected, the + topocentric HA,Dec may be used as an approximation to the + "apparent" HA,Dec. + + 6) No range checking of arguments is done. + + 7) In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + + P.T.Wallace Starlink 21 February 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dimxv.hlp b/math/slalib/doc/dimxv.hlp new file mode 100644 index 00000000..805f124a --- /dev/null +++ b/math/slalib/doc/dimxv.hlp @@ -0,0 +1,32 @@ +.help dimxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slDIMV (DM, VA, VB) + + - - - - - - + D I M V + - - - - - - + + Performs the 3-D backward unitary transformation: + + vector VB = (inverse of matrix DM) * vector VA + + (double precision) + + (n.b. the matrix must be unitary, as this routine assumes that + the inverse and transpose are identical) + + Given: + DM dp(3,3) matrix + VA dp(3) vector + + Returned: + VB dp(3) result vector + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/djcal.hlp b/math/slalib/doc/djcal.hlp new file mode 100644 index 00000000..d65c81bd --- /dev/null +++ b/math/slalib/doc/djcal.hlp @@ -0,0 +1,38 @@ +.help djcal Jun99 "Slalib Package" +.nf + + SUBROUTINE slDJCA (NDP, DJM, IYMDF, J) + + - - - - - - + D J C A + - - - - - - + + Modified Julian Date to Gregorian Calendar, expressed + in a form convenient for formatting messages (namely + rounded to a specified precision, and with the fields + stored in a single array) + + Given: + NDP i number of decimal places of days in fraction + DJM d modified Julian Date (JD-2400000.5) + + Returned: + IYMDF i(4) year, month, day, fraction in Gregorian + calendar + J i status: nonzero = out of range + + Any date after 4701BC March 1 is accepted. + + NDP should be 4 or less if internal overflows are to be avoided + on machines which use 32-bit integers. + + The algorithm is derived from that of Hatcher 1984 + (QJRAS 25, 53-55). + + P.T.Wallace Starlink 27 April 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/djcl.hlp b/math/slalib/doc/djcl.hlp new file mode 100644 index 00000000..a6327c1d --- /dev/null +++ b/math/slalib/doc/djcl.hlp @@ -0,0 +1,34 @@ +.help djcl Jun99 "Slalib Package" +.nf + + SUBROUTINE slDJCL (DJM, IY, IM, ID, FD, J) + + - - - - - + D J C L + - - - - - + + Modified Julian Date to Gregorian year, month, day, + and fraction of a day. + + Given: + DJM dp modified Julian Date (JD-2400000.5) + + Returned: + IY int year + IM int month + ID int day + FD dp fraction of day + J int status: + 0 = OK + -1 = unacceptable date (before 4701BC March 1) + + The algorithm is derived from that of Hatcher 1984 + (QJRAS 25, 53-55). + + P.T.Wallace Starlink 27 April 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dm2av.hlp b/math/slalib/doc/dm2av.hlp new file mode 100644 index 00000000..6448b842 --- /dev/null +++ b/math/slalib/doc/dm2av.hlp @@ -0,0 +1,38 @@ +.help dm2av Jun99 "Slalib Package" +.nf + + SUBROUTINE slDMAV (RMAT, AXVEC) + + - - - - - - + D M A V + - - - - - - + + From a rotation matrix, determine the corresponding axial vector. + (double precision) + + A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the Euler axis, and the angle through which the + reference frame rotates is called the Euler angle. The axial + vector returned by this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. (The + magnitude and direction can be separated by means of the routine + slDVN.) + + Given: + RMAT d(3,3) rotation matrix + + Returned: + AXVEC d(3) axial vector (radians) + + The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + + If RMAT is null, so is the result. + + P.T.Wallace Starlink 24 December 1992 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dmat.hlp b/math/slalib/doc/dmat.hlp new file mode 100644 index 00000000..7d496345 --- /dev/null +++ b/math/slalib/doc/dmat.hlp @@ -0,0 +1,58 @@ +.help dmat Jun99 "Slalib Package" +.nf + + SUBROUTINE slDMAT (N, A, Y, D, JF, IW) + + - - - - - + D M A T + - - - - - + + Matrix inversion & solution of simultaneous equations + (double precision) + + For the set of n simultaneous equations in n unknowns: + A.Y = X + + where: + A is a non-singular N x N matrix + Y is the vector of N unknowns + X is the known vector + + DMATRX computes: + the inverse of matrix A + the determinant of matrix A + the vector of N unknowns + + Arguments: + + symbol type dimension before after + + N i no. of unknowns unchanged + A d (N,N) matrix inverse + Y d (N) vector solution + D d - determinant + * JF i - singularity flag + IW i (N) - workspace + + * JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=-1 & D=0D0 are + returned. In the latter case, the contents of array A on return + are undefined. + + Algorithm: + Gaussian elimination with partial pivoting. + + Speed: + Very fast. + + Accuracy: + Fairly accurate - errors 1 to 4 times those of routines optimized + for accuracy. + + P.T.Wallace Starlink 7 February 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dmoon.hlp b/math/slalib/doc/dmoon.hlp new file mode 100644 index 00000000..5afe24ce --- /dev/null +++ b/math/slalib/doc/dmoon.hlp @@ -0,0 +1,58 @@ +.help dmoon Jun99 "Slalib Package" +.nf + + SUBROUTINE slDMON (DATE, PV) + + - - - - - - + D M O N + - - - - - - + + Approximate geocentric position and velocity of the Moon + (double precision) + + Given: + DATE D TDB (loosely ET) as a Modified Julian Date + (JD-2400000.5) + + Returned: + PV D(6) Moon x,y,z,xdot,ydot,zdot, mean equator and + equinox of date (AU, AU/s) + + Notes: + + 1 This routine is a full implementation of the algorithm + published by Meeus (see reference). + + 2 Meeus quotes accuracies of 10 arcsec in longitude, 3 arcsec in + latitude and 0.2 arcsec in HP (equivalent to about 20 km in + distance). Comparison with JPL DE200 over the interval + 1960-2025 gives RMS errors of 3.7 arcsec and 83 mas/hour in + longitude, 2.3 arcsec and 48 mas/hour in latitude, 11 km + and 81 mm/s in distance. The maximum errors over the same + interval are 18 arcsec and 0.50 arcsec/hour in longitude, + 11 arcsec and 0.24 arcsec/hour in latitude, 40 km and 0.29 m/s + in distance. + + 3 The original algorithm is expressed in terms of the obsolete + timescale Ephemeris Time. Either TDB or TT can be used, but + not UT without incurring significant errors (30 arcsec at + the present time) due to the Moon's 0.5 arcsec/sec movement. + + 4 The algorithm is based on pre IAU 1976 standards. However, + the result has been moved onto the new (FK5) equinox, an + adjustment which is in any case much smaller than the + intrinsic accuracy of the procedure. + + 5 Velocity is obtained by a complete analytical differentiation + of the Meeus model. + + Reference: + Meeus, l'Astronomie, June 1984, p348. + + P.T.Wallace Starlink 22 January 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dmxm.hlp b/math/slalib/doc/dmxm.hlp new file mode 100644 index 00000000..6eeea162 --- /dev/null +++ b/math/slalib/doc/dmxm.hlp @@ -0,0 +1,34 @@ +.help dmxm Jun99 "Slalib Package" +.nf + + SUBROUTINE slDMXM (A, B, C) + + - - - - - + D M X M + - - - - - + + Product of two 3x3 matrices: + + matrix C = matrix A x matrix B + + (double precision) + + Given: + A dp(3,3) matrix + B dp(3,3) matrix + + Returned: + C dp(3,3) matrix result + + To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. However, the routine is coded so as to + work properly on the VAX and many other systems even if this + rule is violated. + + P.T.Wallace Starlink 5 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dmxv.hlp b/math/slalib/doc/dmxv.hlp new file mode 100644 index 00000000..025fd396 --- /dev/null +++ b/math/slalib/doc/dmxv.hlp @@ -0,0 +1,29 @@ +.help dmxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slDMXV (DM, VA, VB) + + - - - - - + D M X V + - - - - - + + Performs the 3-D forward unitary transformation: + + vector VB = matrix DM * vector VA + + (double precision) + + Given: + DM dp(3,3) matrix + VA dp(3) vector + + Returned: + VB dp(3) result vector + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dpav.hlp b/math/slalib/doc/dpav.hlp new file mode 100644 index 00000000..d0111a2d --- /dev/null +++ b/math/slalib/doc/dpav.hlp @@ -0,0 +1,38 @@ +.help dpav Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDPAV ( V1, V2 ) + + - - - - - + D P A V + - - - - - + + Position angle of one celestial direction with respect to another. + + (double precision) + + Given: + V1 d(3) direction cosines of one point + V2 d(3) direction cosines of the other point + + (The coordinate frames correspond to RA,Dec, Long,Lat etc.) + + The result is the bearing (position angle), in radians, of point + V2 with respect to point V1. It is in the range +/- pi. The + sense is such that if V2 is a small distance east of V1, the + bearing is about +pi/2. Zero is returned if the two points + are coincident. + + V1 and V2 need not be unit vectors. + + The routine slDBER performs an equivalent function except + that the points are specified in the form of spherical + coordinates. + + Patrick Wallace Starlink 13 July 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dr2af.hlp b/math/slalib/doc/dr2af.hlp new file mode 100644 index 00000000..b12d75c0 --- /dev/null +++ b/math/slalib/doc/dr2af.hlp @@ -0,0 +1,46 @@ +.help dr2af Jun99 "Slalib Package" +.nf + + SUBROUTINE slDRAF (NDP, ANGLE, SIGN, IDMSF) + + - - - - - - + D R A F + - - - - - - + + Convert an angle in radians to degrees, arcminutes, arcseconds + (double precision) + + Given: + NDP i number of decimal places of arcseconds + ANGLE d angle in radians + + Returned: + SIGN c '+' or '-' + IDMSF i(4) degrees, arcminutes, arcseconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE PRECISION floating-point + numbers on the target machine, and the risk of overflowing + IDMSF(4). For example, on the VAX, for ANGLE up to 2pi, the + available floating-point precision corresponds roughly to + NDP=12. However, the practical limit is NDP=9, set by the + capacity of the 32-bit integer IDMSF(4). + + 3) The absolute value of ANGLE may exceed 2pi. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly 2pi and rounds up to 360 deg, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + + Called: slDDTF + + P.T.Wallace Starlink 19 March 1999 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dr2tf.hlp b/math/slalib/doc/dr2tf.hlp new file mode 100644 index 00000000..49decabc --- /dev/null +++ b/math/slalib/doc/dr2tf.hlp @@ -0,0 +1,46 @@ +.help dr2tf Jun99 "Slalib Package" +.nf + + SUBROUTINE slDRTF (NDP, ANGLE, SIGN, IHMSF) + + - - - - - - + D R T F + - - - - - - + + Convert an angle in radians to hours, minutes, seconds + (double precision) + + Given: + NDP i number of decimal places of seconds + ANGLE d angle in radians + + Returned: + SIGN c '+' or '-' + IHMSF i(4) hours, minutes, seconds, fraction + + Notes: + + 1) NDP less than zero is interpreted as zero. + + 2) The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE PRECISION floating-point + numbers on the target machine, and the risk of overflowing + IHMSF(4). For example, on the VAX, for ANGLE up to 2pi, the + available floating-point precision corresponds roughly to + NDP=12. However, the practical limit is NDP=9, set by the + capacity of the 32-bit integer IHMSF(4). + + 3) The absolute value of ANGLE may exceed 2pi. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly 2pi and rounds up to 24 hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + + Called: slDDTF + + P.T.Wallace Starlink 19 March 1999 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/drange.hlp b/math/slalib/doc/drange.hlp new file mode 100644 index 00000000..025b6c08 --- /dev/null +++ b/math/slalib/doc/drange.hlp @@ -0,0 +1,23 @@ +.help drange Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDA1P (ANGLE) + + - - - - - - - + D A 1 P + - - - - - - - + + Normalize angle into range +/- pi (double precision) + + Given: + ANGLE dp the angle in radians + + The result (double precision) is ANGLE expressed in the range +/- pi. + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dranrm.hlp b/math/slalib/doc/dranrm.hlp new file mode 100644 index 00000000..a479127e --- /dev/null +++ b/math/slalib/doc/dranrm.hlp @@ -0,0 +1,24 @@ +.help dranrm Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDA2P (ANGLE) + + - - - - - - - + D A 2 P + - - - - - - - + + Normalize angle into range 0-2 pi (double precision) + + Given: + ANGLE dp the angle in radians + + The result is ANGLE expressed in the range 0-2 pi (double + precision). + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ds2c6.hlp b/math/slalib/doc/ds2c6.hlp new file mode 100644 index 00000000..23d3442e --- /dev/null +++ b/math/slalib/doc/ds2c6.hlp @@ -0,0 +1,32 @@ +.help ds2c6 Jun99 "Slalib Package" +.nf + + SUBROUTINE slDSC6 (A, B, R, AD, BD, RD, V) + + - - - - - - + D S C 6 + - - - - - - + + Conversion of position & velocity in spherical coordinates + to Cartesian coordinates + + (double precision) + + Given: + A dp longitude (radians) + B dp latitude (radians) + R dp radial coordinate + AD dp longitude derivative (radians per unit time) + BD dp latitude derivative (radians per unit time) + RD dp radial derivative + + Returned: + V dp(6) Cartesian position & velocity vector + + P.T.Wallace Starlink 10 July 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ds2tp.hlp b/math/slalib/doc/ds2tp.hlp new file mode 100644 index 00000000..ff772145 --- /dev/null +++ b/math/slalib/doc/ds2tp.hlp @@ -0,0 +1,30 @@ +.help ds2tp Jun99 "Slalib Package" +.nf + + SUBROUTINE slDSTP (RA, DEC, RAZ, DECZ, XI, ETA, J) + + - - - - - - + D S T P + - - - - - - + + Projection of spherical coordinates onto tangent plane: + "gnomonic" projection - "standard coordinates" (double precision) + + Given: + RA,DEC dp spherical coordinates of point to be projected + RAZ,DECZ dp spherical coordinates of tangent point + + Returned: + XI,ETA dp rectangular coordinates on tangent plane + J int status: 0 = OK, star on tangent plane + 1 = error, star too far from axis + 2 = error, antistar on tangent plane + 3 = error, antistar too far from axis + + P.T.Wallace Starlink 18 July 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dsep.hlp b/math/slalib/doc/dsep.hlp new file mode 100644 index 00000000..9b0f1117 --- /dev/null +++ b/math/slalib/doc/dsep.hlp @@ -0,0 +1,29 @@ +.help dsep Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDSEP (A1, B1, A2, B2) + + - - - - - + D S E P + - - - - - + + Angle between two points on a sphere (double precision) + + Given: + A1,B1 dp spherical coordinates of one point + A2,B2 dp spherical coordinates of the other point + + (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) + + The result is the angle, in radians, between the two points. It + is always positive. + + Called: slDS2C + + P.T.Wallace Starlink April 1985 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dt.hlp b/math/slalib/doc/dt.hlp new file mode 100644 index 00000000..65ddca29 --- /dev/null +++ b/math/slalib/doc/dt.hlp @@ -0,0 +1,55 @@ +.help dt Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDT (EPOCH) + + - - - + D T + - - - + + Estimate the offset between dynamical time and Universal Time + for a given historical epoch. + + Given: + EPOCH d (Julian) epoch (e.g. 1850D0) + + The result is a rough estimate of ET-UT (after 1984, TT-UT) at + the given epoch, in seconds. + + Notes: + + 1 Depending on the epoch, one of three parabolic approximations + is used: + + before 979 Stephenson & Morrison's 390 BC to AD 948 model + 979 to 1708 Stephenson & Morrison's 948 to 1600 model + after 1708 McCarthy & Babcock's post-1650 model + + The breakpoints are chosen to ensure continuity: they occur + at places where the adjacent models give the same answer as + each other. + + 2 The accuracy is modest, with errors of up to 20 sec during + the interval since 1650, rising to perhaps 30 min by 1000 BC. + Comparatively accurate values from AD 1600 are tabulated in + the Astronomical Almanac (see section K8 of the 1995 AA). + + 3 The use of double-precision for both argument and result is + purely for compatibility with other SLALIB time routines. + + 4 The models used are based on a lunar tidal acceleration value + of -26.00 arcsec per century. + + Reference: Explanatory Supplement to the Astronomical Almanac, + ed P.K.Seidelmann, University Science Books (1992), + section 2.553, p83. This contains references to + the Stephenson & Morrison and McCarthy & Babcock + papers. + + P.T.Wallace Starlink 1 March 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtf2d.hlp b/math/slalib/doc/dtf2d.hlp new file mode 100644 index 00000000..eef108f4 --- /dev/null +++ b/math/slalib/doc/dtf2d.hlp @@ -0,0 +1,36 @@ +.help dtf2d Jun99 "Slalib Package" +.nf + + SUBROUTINE slDTFD (IHOUR, IMIN, SEC, DAYS, J) + + - - - - - - + D T F D + - - - - - - + + Convert hours, minutes, seconds to days (double precision) + + Given: + IHOUR int hours + IMIN int minutes + SEC dp seconds + + Returned: + DAYS dp interval in days + J int status: 0 = OK + 1 = IHOUR outside range 0-23 + 2 = IMIN outside range 0-59 + 3 = SEC outside range 0-59.999... + + Notes: + + 1) The result is computed even if any of the range checks fail. + + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink July 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtf2r.hlp b/math/slalib/doc/dtf2r.hlp new file mode 100644 index 00000000..ff3fcfbe --- /dev/null +++ b/math/slalib/doc/dtf2r.hlp @@ -0,0 +1,39 @@ +.help dtf2r Jun99 "Slalib Package" +.nf + + SUBROUTINE slDTFR (IHOUR, IMIN, SEC, RAD, J) + + - - - - - - + D T F R + - - - - - - + + Convert hours, minutes, seconds to radians (double precision) + + Given: + IHOUR int hours + IMIN int minutes + SEC dp seconds + + Returned: + RAD dp angle in radians + J int status: 0 = OK + 1 = IHOUR outside range 0-23 + 2 = IMIN outside range 0-59 + 3 = SEC outside range 0-59.999... + + Called: + slDTFD + + Notes: + + 1) The result is computed even if any of the range checks fail. + + 2) The sign must be dealt with outside this routine. + + P.T.Wallace Starlink July 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtp2s.hlp b/math/slalib/doc/dtp2s.hlp new file mode 100644 index 00000000..73010651 --- /dev/null +++ b/math/slalib/doc/dtp2s.hlp @@ -0,0 +1,28 @@ +.help dtp2s Jun99 "Slalib Package" +.nf + + SUBROUTINE slDTPS (XI, ETA, RAZ, DECZ, RA, DEC) + + - - - - - - + D T P S + - - - - - - + + Transform tangent plane coordinates into spherical + (double precision) + + Given: + XI,ETA dp tangent plane rectangular coordinates + RAZ,DECZ dp spherical coordinates of tangent point + + Returned: + RA,DEC dp spherical coordinates (0-2pi,+/-pi/2) + + Called: slDA2P + + P.T.Wallace Starlink 24 July 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtp2v.hlp b/math/slalib/doc/dtp2v.hlp new file mode 100644 index 00000000..efd928ab --- /dev/null +++ b/math/slalib/doc/dtp2v.hlp @@ -0,0 +1,40 @@ +.help dtp2v Jun99 "Slalib Package" +.nf + + SUBROUTINE slDTPV (XI, ETA, V0, V) + + - - - - - - + D T P V + - - - - - - + + Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star. + + (double precision) + + Given: + XI,ETA d tangent plane coordinates of star + V0 d(3) direction cosines of tangent point + + Returned: + V d(3) direction cosines of star + + Notes: + + 1 If vector V0 is not of unit length, the returned vector V will + be wrong. + + 2 If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that the RA of the tangent + point is zero. + + 3 This routine is the Cartesian equivalent of the routine slDTPS. + + P.T.Wallace Starlink 11 February 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtps2c.hlp b/math/slalib/doc/dtps2c.hlp new file mode 100644 index 00000000..f0207d86 --- /dev/null +++ b/math/slalib/doc/dtps2c.hlp @@ -0,0 +1,58 @@ +.help dtps2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slDPSC (XI, ETA, RA, DEC, RAZ1, DECZ1, + : RAZ2, DECZ2, N) + + - - - - - - - + D P S C + - - - - - - - + + From the tangent plane coordinates of a star of known RA,Dec, + determine the RA,Dec of the tangent point. + + (double precision) + + Given: + XI,ETA d tangent plane rectangular coordinates + RA,DEC d spherical coordinates + + Returned: + RAZ1,DECZ1 d spherical coordinates of tangent point, solution 1 + RAZ2,DECZ2 d spherical coordinates of tangent point, solution 2 + N i number of solutions: + 0 = no solutions returned (note 2) + 1 = only the first solution is useful (note 3) + 2 = both solutions are useful (note 3) + + Notes: + + 1 The RAZ1 and RAZ2 values are returned in the range 0-2pi. + + 2 Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of XI and DEC. + + 3 Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N=1 indicates only one useful + solution, the usual case; under these circumstances, the second + solution corresponds to the "over-the-pole" case, and this is + reflected in the values of RAZ2 and DECZ2 which are returned. + + 4 The DECZ1 and DECZ2 values are returned in the range +/-pi, but + in the usual, non-pole-crossing, case, the range is +/-pi/2. + + 5 This routine is the spherical equivalent of the routine slDPVC. + + Called: slDA2P + + P.T.Wallace Starlink 5 June 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtpv2c.hlp b/math/slalib/doc/dtpv2c.hlp new file mode 100644 index 00000000..acc94985 --- /dev/null +++ b/math/slalib/doc/dtpv2c.hlp @@ -0,0 +1,51 @@ +.help dtpv2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slDPVC (XI, ETA, V, V01, V02, N) + + - - - - - - - + D P V C + - - - - - - - + + Given the tangent-plane coordinates of a star and its direction + cosines, determine the direction cosines of the tangent-point. + + (double precision) + + Given: + XI,ETA d tangent plane coordinates of star + V d(3) direction cosines of star + + Returned: + V01 d(3) direction cosines of tangent point, solution 1 + V02 d(3) direction cosines of tangent point, solution 2 + N i number of solutions: + 0 = no solutions returned (note 2) + 1 = only the first solution is useful (note 3) + 2 = both solutions are useful (note 3) + + Notes: + + 1 The vector V must be of unit length or the result will be wrong. + + 2 Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value, and hence it is meaningless + to ask where the tangent point would have to be. + + 3 Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N=1 indicates only one useful + solution, the usual case; under these circumstances, the second + solution can be regarded as valid if the vector V02 is interpreted + as the "over-the-pole" case. + + 4 This routine is the Cartesian equivalent of the routine slDPSC. + + P.T.Wallace Starlink 5 June 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dtt.hlp b/math/slalib/doc/dtt.hlp new file mode 100644 index 00000000..67c2b1ae --- /dev/null +++ b/math/slalib/doc/dtt.hlp @@ -0,0 +1,41 @@ +.help dtt Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDTT (UTC) + + - - - - + D T T + - - - - + + Increment to be applied to Coordinated Universal Time UTC to give + Terrestrial Time TT (formerly Ephemeris Time ET) + + (double precision) + + Given: + UTC d UTC date as a modified JD (JD-2400000.5) + + Result: TT-UTC in seconds + + Notes: + + 1 The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can only be guaranteed up to the end of the second 23:59:59. + + 2 Pre 1972 January 1 a fixed value of 10 + ET-TAI is returned. + + 3 See also the routine slDT, which roughly estimates ET-UT for + historical epochs. + + Called: slDAT + + P.T.Wallace Starlink 6 December 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dv2tp.hlp b/math/slalib/doc/dv2tp.hlp new file mode 100644 index 00000000..6b927741 --- /dev/null +++ b/math/slalib/doc/dv2tp.hlp @@ -0,0 +1,42 @@ +.help dv2tp Jun99 "Slalib Package" +.nf + + SUBROUTINE slDVTP (V, V0, XI, ETA, J) + + - - - - - - + D V T P + - - - - - - + + Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates. + + (double precision) + + Given: + V d(3) direction cosines of star + V0 d(3) direction cosines of tangent point + + Returned: + XI,ETA d tangent plane coordinates of star + J i status: 0 = OK + 1 = error, star too far from axis + 2 = error, antistar on tangent plane + 3 = error, antistar too far from axis + + Notes: + + 1 If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + + 2 If V0 points at a pole, the returned XI,ETA will be based on the + arbitrary assumption that the RA of the tangent point is zero. + + 3 This routine is the Cartesian equivalent of the routine slDSTP. + + P.T.Wallace Starlink 27 November 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dvdv.hlp b/math/slalib/doc/dvdv.hlp new file mode 100644 index 00000000..d3c566dd --- /dev/null +++ b/math/slalib/doc/dvdv.hlp @@ -0,0 +1,24 @@ +.help dvdv Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slDVDV (VA, VB) + + - - - - - + D V D V + - - - - - + + Scalar product of two 3-vectors (double precision) + + Given: + VA dp(3) first vector + VB dp(3) second vector + + The result is the scalar product VA.VB (double precision) + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dvn.hlp b/math/slalib/doc/dvn.hlp new file mode 100644 index 00000000..295937e6 --- /dev/null +++ b/math/slalib/doc/dvn.hlp @@ -0,0 +1,27 @@ +.help dvn Jun99 "Slalib Package" +.nf + + SUBROUTINE slDVN (V, UV, VM) + + - - - - + D V N + - - - - + + Normalizes a 3-vector also giving the modulus (double precision) + + Given: + V dp(3) vector + + Returned: + UV dp(3) unit vector in direction of V + VM dp modulus of V + + If the modulus of V is zero, UV is set to zero as well + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/dvxv.hlp b/math/slalib/doc/dvxv.hlp new file mode 100644 index 00000000..a7db5344 --- /dev/null +++ b/math/slalib/doc/dvxv.hlp @@ -0,0 +1,25 @@ +.help dvxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slDVXV (VA, VB, VC) + + - - - - - + D V X V + - - - - - + + Vector product of two 3-vectors (double precision) + + Given: + VA dp(3) first vector + VB dp(3) second vector + + Returned: + VC dp(3) vector result + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/e2h.hlp b/math/slalib/doc/e2h.hlp new file mode 100644 index 00000000..f962d80a --- /dev/null +++ b/math/slalib/doc/e2h.hlp @@ -0,0 +1,59 @@ +.help e2h Jun99 "Slalib Package" +.nf + + SUBROUTINE slE2H (HA, DEC, PHI, AZ, EL) + + - - - - + E 2 H + - - - - + + Equatorial to horizon coordinates: HA,Dec to Az,El + + (single precision) + + Given: + HA r hour angle + DEC r declination + PHI r observatory latitude + + Returned: + AZ r azimuth + EL r elevation + + Notes: + + 1) All the arguments are angles in radians. + + 2) Azimuth is returned in the range 0-2pi; north is zero, + and east is +pi/2. Elevation is returned in the range + +/-pi/2. + + 3) The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + + 4) In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the "observed" HA,Dec, and the elevation + in vacuo, which would require the "topocentric" HA,Dec. + If the effects of diurnal aberration can be neglected, the + "apparent" HA,Dec may be used instead of the topocentric + HA,Dec. + + 5) No range checking of arguments is carried out. + + 6) In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + + P.T.Wallace Starlink 9 July 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/earth.hlp b/math/slalib/doc/earth.hlp new file mode 100644 index 00000000..ea0eccd6 --- /dev/null +++ b/math/slalib/doc/earth.hlp @@ -0,0 +1,44 @@ +.help earth Jun99 "Slalib Package" +.nf + + SUBROUTINE slERTH (IY, ID, FD, PV) + + - - - - - - + E R T H + - - - - - - + + Approximate heliocentric position and velocity of the Earth + + Given: + IY I year + ID I day in year (1 = Jan 1st) + FD R fraction of day + + Returned: + PV R(6) Earth position & velocity vector + + Notes: + + 1 The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling slCAYD or + slCLYD. + + 2 The Earth heliocentric 6-vector is mean equator and equinox + of date. Position part, PV(1-3), is in AU; velocity part, + PV(4-6), is in AU/sec. + + 3 Max/RMS errors 1950-2050: + 13/5 E-5 AU = 19200/7600 km in position + 47/26 E-10 AU/s = 0.0070/0.0039 km/s in speed + + 4 More precise results are obtainable with the routine slEVP. + + P.T.Wallace Starlink 23 November 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ecleq.hlp b/math/slalib/doc/ecleq.hlp new file mode 100644 index 00000000..02fc6c50 --- /dev/null +++ b/math/slalib/doc/ecleq.hlp @@ -0,0 +1,31 @@ +.help ecleq Jun99 "Slalib Package" +.nf + + SUBROUTINE slECEQ (DL, DB, DATE, DR, DD) + + - - - - - - + E C E Q + - - - - - - + + Transformation from ecliptic coordinates to + J2000.0 equatorial coordinates (double precision) + + Given: + DL,DB dp ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians) + DATE dp TDB (loosely ET) as Modified Julian Date + (JD-2400000.5) + Returned: + DR,DD dp J2000.0 mean RA,Dec (radians) + + Called: + slDS2C, slECMA, slDIMV, slPREC, slEPJ, slDC2S, + slDA2P, slDA1P + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ecmat.hlp b/math/slalib/doc/ecmat.hlp new file mode 100644 index 00000000..a9be4579 --- /dev/null +++ b/math/slalib/doc/ecmat.hlp @@ -0,0 +1,34 @@ +.help ecmat Jun99 "Slalib Package" +.nf + + SUBROUTINE slECMA (DATE, RMAT) + + - - - - - - + E C M A + - - - - - - + + Form the equatorial to ecliptic rotation matrix - IAU 1980 theory + (double precision) + + Given: + DATE dp TDB (loosely ET) as Modified Julian Date + (JD-2400000.5) + Returned: + RMAT dp(3,3) matrix + + Reference: + Murray,C.A., Vectorial Astrometry, section 4.3. + + Note: + The matrix is in the sense V(ecl) = RMAT * V(equ); the + equator, equinox and ecliptic are mean of date. + + Called: slDEUL + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ecor.hlp b/math/slalib/doc/ecor.hlp new file mode 100644 index 00000000..07cf410f --- /dev/null +++ b/math/slalib/doc/ecor.hlp @@ -0,0 +1,54 @@ +.help ecor Jun99 "Slalib Package" +.nf + + SUBROUTINE slECOR (RM, DM, IY, ID, FD, RV, TL) + + - - - - - + E C O R + - - - - - + + Component of Earth orbit velocity and heliocentric + light time in a given direction (single precision) + + Given: + RM,DM real mean RA, Dec of date (radians) + IY int year + ID int day in year (1 = Jan 1st) + FD real fraction of day + + Returned: + RV real component of Earth orbital velocity (km/sec) + TL real component of heliocentric light time (sec) + + Notes: + + 1 The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling slCAYD or + slCLYD. + + 2 Sign convention: + + The velocity component is +ve when the Earth is receding from + the given point on the sky. The light time component is +ve + when the Earth lies between the Sun and the given point on + the sky. + + 3 Accuracy: + + The velocity component is usually within 0.004 km/s of the + correct value and is never in error by more than 0.007 km/s. + The error in light time correction is about 0.03s at worst, + but is usually better than 0.01s. For applications requiring + higher accuracy, see the slEVP routine. + + Called: slERTH, slCS2C, slVDV + + P.T.Wallace Starlink 24 November 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/eg50.hlp b/math/slalib/doc/eg50.hlp new file mode 100644 index 00000000..da2c0fa3 --- /dev/null +++ b/math/slalib/doc/eg50.hlp @@ -0,0 +1,38 @@ +.help eg50 Jun99 "Slalib Package" +.nf + + SUBROUTINE slEG50 (DR, DD, DL, DB) + + - - - - - + E G 5 0 + - - - - - + + Transformation from B1950.0 'FK4' equatorial coordinates to + IAU 1958 galactic coordinates (double precision) + + Given: + DR,DD dp B1950.0 'FK4' RA,Dec + + Returned: + DL,DB dp galactic longitude and latitude L2,B2 + + (all arguments are radians) + + Called: + slDS2C, slDMXV, slDC2S, slSUET, slDA2P, slDA1P + + Note: + The equatorial coordinates are B1950.0 'FK4'. Use the + routine slEQGA if conversion from J2000.0 coordinates + is required. + + Reference: + Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) + + P.T.Wallace Starlink 5 September 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/el2ue.hlp b/math/slalib/doc/el2ue.hlp new file mode 100644 index 00000000..9271fff6 --- /dev/null +++ b/math/slalib/doc/el2ue.hlp @@ -0,0 +1,133 @@ +.help el2ue Jun99 "Slalib Package" +.nf + + SUBROUTINE slELUE (DATE, JFORM, EPOCH, ORBINC, ANODE, + : PERIH, AORQ, E, AORL, DM, + : U, JSTAT) + + - - - - - - + E L U E + - - - - - - + + Transform conventional osculating orbital elements into "universal" form. + + Given: + DATE d epoch (TT MJD) of osculation (Note 3) + JFORM i choice of element set (1-3, Note 6) + EPOCH d epoch (TT MJD) of the elements + ORBINC d inclination (radians) + ANODE d longitude of the ascending node (radians) + PERIH d longitude or argument of perihelion (radians) + AORQ d mean distance or perihelion distance (AU) + E d eccentricity + AORL d mean anomaly or longitude (radians, JFORM=1,2 only) + DM d daily motion (radians, JFORM=1 only) + + Returned: + U d(13) universal orbital elements (Note 1) + + (1) combined mass (M+m) + (2) total energy of the orbit (alpha) + (3) reference (osculating) epoch (t0) + (4-6) position at reference epoch (r0) + (7-9) velocity at reference epoch (v0) + (10) heliocentric distance at reference epoch + (11) r0.v0 + (12) date (t) + (13) universal eccentric anomaly (psi) of date, approx + + JSTAT i status: 0 = OK + -1 = illegal JFORM + -2 = illegal E + -3 = illegal AORQ + -4 = illegal DM + -5 = numerical error + + Called: slUEPV, slPVUE + + Notes + + 1 The "universal" elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i) alpha, which is proportional to the total energy of the + orbit, (ii) the heliocentric distance at epoch, (iii) the + outwards component of the velocity at the given epoch, (iv) an + estimate of psi, the "universal eccentric anomaly" at a given + date and (v) that date. + + 2 The companion routine is slUEPV. This takes the set of numbers + that the present routine outputs and uses them to derive the + object's position and velocity. A single prediction requires one + call to the present routine followed by one call to slUEPV; + for convenience, the two calls are packaged as the routine + slPLNE. Multiple predictions may be made by again calling the + present routine once, but then calling slUEPV multiple times, + which is faster than multiple calls to slPLNE. + + 3 DATE is the epoch of osculation. It is in the TT timescale + (formerly Ephemeris Time, ET) and is a Modified Julian Date + (JD-2400000.5). + + 4 The supplied orbital elements are with respect to the J2000 + ecliptic and equinox. The position and velocity parameters + returned in the array U are with respect to the mean equator and + equinox of epoch J2000, and are for the perihelion prior to the + specified epoch. + + 5 The universal elements returned in the array U are in canonical + units (solar masses, AU and canonical days). + + 6 Three different element-format options are available: + + Option JFORM=1, suitable for the major planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = longitude of perihelion, curly pi (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e (range 0 to <1) + AORL = mean longitude L (radians) + DM = daily motion (radians) + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e (range 0 to <1) + AORL = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e (range 0 to 10) + + 7 Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + + 8 The algorithm was originally adapted from the EPHSLA program of + D.H.P.Jones (private communication, 1996). The method is based + on Stumpff's Universal Variables. + + Reference: Everhart & Pitkin, Am.J.Phys. 51, 712 (1983). + + P.T.Wallace Starlink 18 February 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/epb.hlp b/math/slalib/doc/epb.hlp new file mode 100644 index 00000000..6c7ed368 --- /dev/null +++ b/math/slalib/doc/epb.hlp @@ -0,0 +1,27 @@ +.help epb Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEPB (DATE) + + - - - - + E P B + - - - - + + Conversion of Modified Julian Date to Besselian Epoch + (double precision) + + Given: + DATE dp Modified Julian Date (JD - 2400000.5) + + The result is the Besselian Epoch. + + Reference: + Lieske,J.H., 1979. Astron.Astrophys.,73,282. + + P.T.Wallace Starlink February 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/epb2d.hlp b/math/slalib/doc/epb2d.hlp new file mode 100644 index 00000000..b0ded162 --- /dev/null +++ b/math/slalib/doc/epb2d.hlp @@ -0,0 +1,27 @@ +.help epb2d Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEB2D (EPB) + + - - - - - - + E B 2 D + - - - - - - + + Conversion of Besselian Epoch to Modified Julian Date + (double precision) + + Given: + EPB dp Besselian Epoch + + The result is the Modified Julian Date (JD - 2400000.5). + + Reference: + Lieske,J.H., 1979. Astron.Astrophys.,73,282. + + P.T.Wallace Starlink February 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/epco.hlp b/math/slalib/doc/epco.hlp new file mode 100644 index 00000000..d92bfde2 --- /dev/null +++ b/math/slalib/doc/epco.hlp @@ -0,0 +1,40 @@ +.help epco Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEPCO (K0, K, E) + + - - - - - + E P C O + - - - - - + + Convert an epoch into the appropriate form - 'B' or 'J' + + Given: + K0 char form of result: 'B'=Besselian, 'J'=Julian + K char form of given epoch: 'B' or 'J' + E dp epoch + + Called: slEPB, slEJ2D, slEPJ, slEB2D + + Notes: + + 1) The result is always either equal to or very close to + the given epoch E. The routine is required only in + applications where punctilious treatment of heterogeneous + mixtures of star positions is necessary. + + 2) K0 and K are not validated. They are interpreted as follows: + + o If K0 and K are the same the result is E. + o If K0 is 'B' or 'b' and K isn't, the conversion is J to B. + o In all other cases, the conversion is B to J. + + Note that K0 and K won't match if their cases differ. + + P.T.Wallace Starlink 5 September 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/epj.hlp b/math/slalib/doc/epj.hlp new file mode 100644 index 00000000..34d47ec7 --- /dev/null +++ b/math/slalib/doc/epj.hlp @@ -0,0 +1,26 @@ +.help epj Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEPJ (DATE) + + - - - - + E P J + - - - - + + Conversion of Modified Julian Date to Julian Epoch (double precision) + + Given: + DATE dp Modified Julian Date (JD - 2400000.5) + + The result is the Julian Epoch. + + Reference: + Lieske,J.H., 1979. Astron.Astrophys.,73,282. + + P.T.Wallace Starlink February 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/epj2d.hlp b/math/slalib/doc/epj2d.hlp new file mode 100644 index 00000000..ceadf7ab --- /dev/null +++ b/math/slalib/doc/epj2d.hlp @@ -0,0 +1,26 @@ +.help epj2d Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEJ2D (EPJ) + + - - - - - - + E J 2 D + - - - - - - + + Conversion of Julian Epoch to Modified Julian Date (double precision) + + Given: + EPJ dp Julian Epoch + + The result is the Modified Julian Date (JD - 2400000.5). + + Reference: + Lieske,J.H., 1979. Astron.Astrophys.,73,282. + + P.T.Wallace Starlink February 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/eqecl.hlp b/math/slalib/doc/eqecl.hlp new file mode 100644 index 00000000..a8266afe --- /dev/null +++ b/math/slalib/doc/eqecl.hlp @@ -0,0 +1,31 @@ +.help eqecl Jun99 "Slalib Package" +.nf + + SUBROUTINE slEQEC (DR, DD, DATE, DL, DB) + + - - - - - - + E Q E C + - - - - - - + + Transformation from J2000.0 equatorial coordinates to + ecliptic coordinates (double precision) + + Given: + DR,DD dp J2000.0 mean RA,Dec (radians) + DATE dp TDB (loosely ET) as Modified Julian Date + (JD-2400000.5) + Returned: + DL,DB dp ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians) + + Called: + slDS2C, slPREC, slEPJ, slDMXV, slECMA, slDC2S, + slDA2P, slDA1P + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/eqeqx.hlp b/math/slalib/doc/eqeqx.hlp new file mode 100644 index 00000000..35da9ab4 --- /dev/null +++ b/math/slalib/doc/eqeqx.hlp @@ -0,0 +1,33 @@ +.help eqeqx Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slEQEX (DATE) + + - - - - - - + E Q E X + - - - - - - + + Equation of the equinoxes (IAU 1994, double precision) + + Given: + DATE dp TDB (loosely ET) as Modified Julian Date + (JD-2400000.5) + + The result is the equation of the equinoxes (double precision) + in radians: + + Greenwich apparent ST = GMST + slEQEX + + References: IAU Resolution C7, Recommendation 3 (1994) + Capitaine, N. & Gontier, A.-M., Astron. Astrophys., + 275, 645-650 (1993) + + Called: slNUTC + + Patrick Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/eqgal.hlp b/math/slalib/doc/eqgal.hlp new file mode 100644 index 00000000..1f37716f --- /dev/null +++ b/math/slalib/doc/eqgal.hlp @@ -0,0 +1,38 @@ +.help eqgal Jun99 "Slalib Package" +.nf + + SUBROUTINE slEQGA (DR, DD, DL, DB) + + - - - - - - + E Q G A + - - - - - - + + Transformation from J2000.0 equatorial coordinates to + IAU 1958 galactic coordinates (double precision) + + Given: + DR,DD dp J2000.0 RA,Dec + + Returned: + DL,DB dp galactic longitude and latitude L2,B2 + + (all arguments are radians) + + Called: + slDS2C, slDMXV, slDC2S, slDA2P, slDA1P + + Note: + The equatorial coordinates are J2000.0. Use the routine + slEG50 if conversion from B1950.0 'FK4' coordinates is + required. + + Reference: + Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) + + P.T.Wallace Starlink 21 September 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/etrms.hlp b/math/slalib/doc/etrms.hlp new file mode 100644 index 00000000..bc14b655 --- /dev/null +++ b/math/slalib/doc/etrms.hlp @@ -0,0 +1,35 @@ +.help etrms Jun99 "Slalib Package" +.nf + + SUBROUTINE slETRM (EP, EV) + + - - - - - - + E T R M + - - - - - - + + Compute the E-terms (elliptic component of annual aberration) + vector (double precision) + + Given: + EP dp Besselian epoch + + Returned: + EV dp(3) E-terms as (dx,dy,dz) + + Note the use of the J2000 aberration constant (20.49552 arcsec). + This is a reflection of the fact that the E-terms embodied in + existing star catalogues were computed from a variety of + aberration constants. Rather than adopting one of the old + constants the latest value is used here. + + References: + 1 Smith, C.A. et al., 1989. Astr.J. 97, 265. + 2 Yallop, B.D. et al., 1989. Astr.J. 97, 274. + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/euler.hlp b/math/slalib/doc/euler.hlp new file mode 100644 index 00000000..7ae2fedc --- /dev/null +++ b/math/slalib/doc/euler.hlp @@ -0,0 +1,52 @@ +.help euler Jun99 "Slalib Package" +.nf + + SUBROUTINE slEULR (ORDER, PHI, THETA, PSI, RMAT) + + - - - - - - + E U L R + - - - - - - + + Form a rotation matrix from the Euler angles - three successive + rotations about specified Cartesian axes (single precision) + + Given: + ORDER c*(*) specifies about which axes the rotations occur + PHI r 1st rotation (radians) + THETA r 2nd rotation ( " ) + PSI r 3rd rotation ( " ) + + Returned: + RMAT r(3,3) rotation matrix + + A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + + The characters of ORDER define which axes the three successive + rotations are about. A typical value is 'ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old Z-axis, followed by THETA radians about the resulting X-axis, + then PSI radians about the resulting Z-axis. + + The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labeling/numbering conventions apply; the xyz (=123) + triad is right-handed. Thus, the 'ZXZ' example given above + could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ'). ORDER + is terminated by length or by the first unrecognized character. + + Fewer than three rotations are acceptable, in which case the later + angle arguments are ignored. If all rotations are zero, the + identity matrix is produced. + + Called: slDEUL + + P.T.Wallace Starlink 23 May 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/evp.hlp b/math/slalib/doc/evp.hlp new file mode 100644 index 00000000..e7fa04cf --- /dev/null +++ b/math/slalib/doc/evp.hlp @@ -0,0 +1,66 @@ +.help evp Jun99 "Slalib Package" +.nf + + SUBROUTINE slEVP (DATE, DEQX, DVB, DPB, DVH, DPH) + + - - - - + E V P + - - - - + + Barycentric and heliocentric velocity and position of the Earth + + All arguments are double precision + + Given: + + DATE TDB (loosely ET) as a Modified Julian Date + (JD-2400000.5) + + DEQX Julian Epoch (e.g. 2000.0D0) of mean equator and + equinox of the vectors returned. If DEQX .LE. 0D0, + all vectors are referred to the mean equator and + equinox (FK5) of epoch DATE. + + Returned (all 3D Cartesian vectors): + + DVB,DPB barycentric velocity, position + + DVH,DPH heliocentric velocity, position + + (Units are AU/s for velocity and AU for position) + + Called: slEPJ, slPREC + + Accuracy: + + The maximum deviations from the JPL DE96 ephemeris are as + follows: + + barycentric velocity 0.42 m/s + barycentric position 6900 km + + heliocentric velocity 0.42 m/s + heliocentric position 1600 km + + This routine is adapted from the BARVEL and BARCOR + subroutines of P.Stumpff, which are described in + Astron. Astrophys. Suppl. Ser. 41, 1-8 (1980). Most of the + changes are merely cosmetic and do not affect the results at + all. However, some adjustments have been made so as to give + results that refer to the new (IAU 1976 'FK5') equinox + and precession, although the differences these changes make + relative to the results from Stumpff's original 'FK4' version + are smaller than the inherent accuracy of the algorithm. One + minor shortcoming in the original routines that has NOT been + corrected is that better numerical accuracy could be achieved + if the various polynomial evaluations were nested. Note also + that one of Stumpff's precession constants differs by 0.001 arcsec + from the value given in the Explanatory Supplement to the A.E. + + P.T.Wallace Starlink 21 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fitxy.hlp b/math/slalib/doc/fitxy.hlp new file mode 100644 index 00000000..814deb9f --- /dev/null +++ b/math/slalib/doc/fitxy.hlp @@ -0,0 +1,76 @@ +.help fitxy Jun99 "Slalib Package" +.nf + + SUBROUTINE slFTXY (ITYPE,NP,XYE,XYM,COEFFS,J) + + - - - - - - + F T X Y + - - - - - - + + Fit a linear model to relate two sets of [X,Y] coordinates. + + Given: + ITYPE i type of model: 4 or 6 (note 1) + NP i number of samples (note 2) + XYE d(2,np) expected [X,Y] for each sample + XYM d(2,np) measured [X,Y] for each sample + + Returned: + COEFFS d(6) coefficients of model (note 3) + J i status: 0 = OK + -1 = illegal ITYPE + -2 = insufficient data + -3 = singular solution + + Notes: + + 1) ITYPE, which must be either 4 or 6, selects the type of model + fitted. Both allowed ITYPE values produce a model COEFFS which + consists of six coefficients, namely the zero points and, for + each of XE and YE, the coefficient of XM and YM. For ITYPE=6, + all six coefficients are independent, modelling squash and shear + as well as origin, scale, and orientation. However, ITYPE=4 + selects the "solid body rotation" option; the model COEFFS + still consists of the same six coefficients, but now two of + them are used twice (appropriately signed). Origin, scale + and orientation are still modelled, but not squash or shear - + the units of X and Y have to be the same. + + 2) For NC=4, NP must be at least 2. For NC=6, NP must be at + least 3. + + 3) The model is returned in the array COEFFS. Naming the + elements of COEFFS as follows: + + COEFFS(1) = A + COEFFS(2) = B + COEFFS(3) = C + COEFFS(4) = D + COEFFS(5) = E + COEFFS(6) = F + + the model is: + + XE = A + B*XM + C*YM + YE = D + E*XM + F*YM + + For the "solid body rotation" option (ITYPE=4), the + magnitudes of B and F, and of C and E, are equal. The + signs of these coefficients depend on whether there is a + sign reversal between XE,YE and XM,YM; fits are performed + with and without a sign reversal and the best one chosen. + + 4) Error status values J=-1 and -2 leave COEFFS unchanged; + if J=-3 COEFFS may have been changed. + + See also slPXY, slINVF, slXYXY, slDCMF + + Called: slDMAT, slDMXV + + P.T.Wallace Starlink 11 February 1991 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk425.hlp b/math/slalib/doc/fk425.hlp new file mode 100644 index 00000000..808dcb7b --- /dev/null +++ b/math/slalib/doc/fk425.hlp @@ -0,0 +1,81 @@ +.help fk425 Jun99 "Slalib Package" +.nf + + SUBROUTINE slFK45 (R1950,D1950,DR1950,DD1950,P1950,V1950, + : R2000,D2000,DR2000,DD2000,P2000,V2000) + + - - - - - - + F K 4 5 + - - - - - - + + Convert B1950.0 FK4 star data to J2000.0 FK5 (double precision) + + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU 1976, FK5, Fricke system. The precepts + of Smith et al (Ref 1) are followed, using the implementation + by Yallop et al (Ref 2) of a matrix method due to Standish. + Kinoshita's development of Andoyer's post-Newcomb precession is + used. The numerical constants from Seidelmann et al (Ref 3) are + used canonically. + + Given: (all B1950.0,FK4) + R1950,D1950 dp B1950.0 RA,Dec (rad) + DR1950,DD1950 dp B1950.0 proper motions (rad/trop.yr) + P1950 dp parallax (arcsec) + V1950 dp radial velocity (km/s, +ve = moving away) + + Returned: (all J2000.0,FK5) + R2000,D2000 dp J2000.0 RA,Dec (rad) + DR2000,DD2000 dp J2000.0 proper motions (rad/Jul.yr) + P2000 dp parallax (arcsec) + V2000 dp radial velocity (km/s, +ve = moving away) + + Notes: + + 1) The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt, and are per year rather than per century. + + 2) Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or + after FK425 is called. + + 3) In the FK4 catalogue the proper motions of stars within + 10 degrees of the poles do not embody the differential + E-term effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of dRA, the + errors resulting from this simplification are less than + 1 milliarcsecond in position and 1 milliarcsecond per + century in proper motion. + + References: + + 1 Smith, C.A. et al, 1989. "The transformation of astrometric + catalog systems to the equinox J2000.0". Astron.J. 97, 265. + + 2 Yallop, B.D. et al, 1989. "Transformation of mean star places + from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". + Astron.J. 97, 274. + + 3 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to + the Astronomical Almanac", ISBN 0-935702-68-7. + + P.T.Wallace Starlink 19 December 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk45z.hlp b/math/slalib/doc/fk45z.hlp new file mode 100644 index 00000000..6994302f --- /dev/null +++ b/math/slalib/doc/fk45z.hlp @@ -0,0 +1,83 @@ +.help fk45z Jun99 "Slalib Package" +.nf + + SUBROUTINE slF45Z (R1950,D1950,BEPOCH,R2000,D2000) + + - - - - - - + F 4 5 Z + - - - - - - + + Convert B1950.0 FK4 star data to J2000.0 FK5 assuming zero + proper motion in the FK5 frame (double precision) + + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU 1976, FK5, Fricke system, in such a + way that the FK5 proper motion is zero. Because such a star + has, in general, a non-zero proper motion in the FK4 system, + the routine requires the epoch at which the position in the + FK4 system was determined. + + The method is from Appendix 2 of Ref 1, but using the constants + of Ref 4. + + Given: + R1950,D1950 dp B1950.0 FK4 RA,Dec at epoch (rad) + BEPOCH dp Besselian epoch (e.g. 1979.3D0) + + Returned: + R2000,D2000 dp J2000.0 FK5 RA,Dec (rad) + + Notes: + + 1) The epoch BEPOCH is strictly speaking Besselian, but + if a Julian epoch is supplied the result will be + affected only to a negligible extent. + + 2) Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or + after FK45Z is called. + + 3) In the FK4 catalogue the proper motions of stars within + 10 degrees of the poles do not embody the differential + E-term effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of dRA, the + errors resulting from this simplification are less than + 1 milliarcsecond in position and 1 milliarcsecond per + century in proper motion. + + References: + + 1 Aoki,S., et al, 1983. Astron.Astrophys., 128, 263. + + 2 Smith, C.A. et al, 1989. "The transformation of astrometric + catalog systems to the equinox J2000.0". Astron.J. 97, 265. + + 3 Yallop, B.D. et al, 1989. "Transformation of mean star places + from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". + Astron.J. 97, 274. + + 4 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to + the Astronomical Almanac", ISBN 0-935702-68-7. + + Called: slDS2C, slEPJ, slEB2D, slDC2S, slDA2P + + P.T.Wallace Starlink 21 September 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk524.hlp b/math/slalib/doc/fk524.hlp new file mode 100644 index 00000000..ed86273b --- /dev/null +++ b/math/slalib/doc/fk524.hlp @@ -0,0 +1,81 @@ +.help fk524 Jun99 "Slalib Package" +.nf + + SUBROUTINE slFK54 (R2000,D2000,DR2000,DD2000,P2000,V2000, + : R1950,D1950,DR1950,DD1950,P1950,V1950) + + - - - - - - + F K 5 4 + - - - - - - + + Convert J2000.0 FK5 star data to B1950.0 FK4 (double precision) + + This routine converts stars from the new, IAU 1976, FK5, Fricke + system, to the old, Bessel-Newcomb, FK4 system. The precepts + of Smith et al (Ref 1) are followed, using the implementation + by Yallop et al (Ref 2) of a matrix method due to Standish. + Kinoshita's development of Andoyer's post-Newcomb precession is + used. The numerical constants from Seidelmann et al (Ref 3) are + used canonically. + + Given: (all J2000.0,FK5) + R2000,D2000 dp J2000.0 RA,Dec (rad) + DR2000,DD2000 dp J2000.0 proper motions (rad/Jul.yr) + P2000 dp parallax (arcsec) + V2000 dp radial velocity (km/s, +ve = moving away) + + Returned: (all B1950.0,FK4) + R1950,D1950 dp B1950.0 RA,Dec (rad) + DR1950,DD1950 dp B1950.0 proper motions (rad/trop.yr) + P1950 dp parallax (arcsec) + V1950 dp radial velocity (km/s, +ve = moving away) + + Notes: + + 1) The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt, and are per year rather than per century. + + 2) Note that conversion from Julian epoch 2000.0 to Besselian + epoch 1950.0 only is provided for. Conversions involving + other epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or after + FK524 is called. + + 3) In the FK4 catalogue the proper motions of stars within + 10 degrees of the poles do not embody the differential + E-term effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of dRA, the + errors resulting from this simplification are less than + 1 milliarcsecond in position and 1 milliarcsecond per + century in proper motion. + + References: + + 1 Smith, C.A. et al, 1989. "The transformation of astrometric + catalog systems to the equinox J2000.0". Astron.J. 97, 265. + + 2 Yallop, B.D. et al, 1989. "Transformation of mean star places + from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". + Astron.J. 97, 274. + + 3 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to + the Astronomical Almanac", ISBN 0-935702-68-7. + + P.T.Wallace Starlink 19 December 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk52h.hlp b/math/slalib/doc/fk52h.hlp new file mode 100644 index 00000000..ad7cb724 --- /dev/null +++ b/math/slalib/doc/fk52h.hlp @@ -0,0 +1,56 @@ +.help fk52h Jun99 "Slalib Package" +.nf + + SUBROUTINE slFK5H (R5,D5,DR5,DD5,RH,DH,DRH,DDH) + + - - - - - - + F K 5 H + - - - - - - + + Transform FK5 (J2000) star data into the Hipparcos frame. + + (double precision) + + This routine transforms FK5 star positions and proper motions + into the frame of the Hipparcos catalogue. + + Given (all FK5, equinox J2000, epoch J2000): + R5 d RA (radians) + D5 d Dec (radians) + DR5 d proper motion in RA (dRA/dt, rad/Jyear) + DD5 d proper motion in Dec (dDec/dt, rad/Jyear) + + Returned (all Hipparcos, epoch J2000): + RH d RA (radians) + DH d Dec (radians) + DRH d proper motion in RA (dRA/dt, rad/Jyear) + DDH d proper motion in Dec (dDec/dt, rad/Jyear) + + Called: slDSC6, slDAVM, slDMXV, slDVXV, slDC6S + + Notes: + + 1) The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt, and are per year rather than per century. + + 2) The FK5 to Hipparcos transformation consists of a pure + rotation and spin; zonal errors in the FK5 catalogue are + not taken into account. + + 3) The published orientation and spin components are interpreted + as "axial vectors". An axial vector points at the pole of the + rotation and its length is the amount of rotation in radians. + + 4) See also slHFK5, slF5HZ, slHF5Z. + + Reference: + + M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). + + P.T.Wallace Starlink 7 October 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk54z.hlp b/math/slalib/doc/fk54z.hlp new file mode 100644 index 00000000..b453bad9 --- /dev/null +++ b/math/slalib/doc/fk54z.hlp @@ -0,0 +1,56 @@ +.help fk54z Jun99 "Slalib Package" +.nf + + SUBROUTINE slF54Z (R2000,D2000,BEPOCH, + : R1950,D1950,DR1950,DD1950) + + - - - - - - + F 5 4 Z + - - - - - - + + Convert a J2000.0 FK5 star position to B1950.0 FK4 assuming + zero proper motion and parallax (double precision) + + This routine converts star positions from the new, IAU 1976, + FK5, Fricke system to the old, Bessel-Newcomb, FK4 system. + + Given: + R2000,D2000 dp J2000.0 FK5 RA,Dec (rad) + BEPOCH dp Besselian epoch (e.g. 1950D0) + + Returned: + R1950,D1950 dp B1950.0 FK4 RA,Dec (rad) at epoch BEPOCH + DR1950,DD1950 dp B1950.0 FK4 proper motions (rad/trop.yr) + + Notes: + + 1) The proper motion in RA is dRA/dt rather than cos(Dec)*dRA/dt. + + 2) Conversion from Julian epoch 2000.0 to Besselian epoch 1950.0 + only is provided for. Conversions involving other epochs will + require use of the appropriate precession routines before and + after this routine is called. + + 3) Unlike in the slFK54 routine, the FK5 proper motions, the + parallax and the radial velocity are presumed zero. + + 4) It is the intention that FK5 should be a close approximation + to an inertial frame, so that distant objects have zero proper + motion; such objects have (in general) non-zero proper motion + in FK4, and this routine returns those fictitious proper + motions. + + 5) The position returned by this routine is in the B1950 + reference frame but at Besselian epoch BEPOCH. For + comparison with catalogues the BEPOCH argument will + frequently be 1950D0. + + Called: slFK54, slPM + + P.T.Wallace Starlink 10 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/fk5hz.hlp b/math/slalib/doc/fk5hz.hlp new file mode 100644 index 00000000..4d5e5ab0 --- /dev/null +++ b/math/slalib/doc/fk5hz.hlp @@ -0,0 +1,54 @@ +.help fk5hz Jun99 "Slalib Package" +.nf + + SUBROUTINE slF5HZ (R5,D5,EPOCH,RH,DH) + + - - - - - - + F 5 H Z + - - - - - - + + Transform an FK5 (J2000) star position into the frame of the + Hipparcos catalogue, assuming zero Hipparcos proper motion. + + (double precision) + + This routine converts a star position from the FK5 system to + the Hipparcos system, in such a way that the Hipparcos proper + motion is zero. Because such a star has, in general, a non-zero + proper motion in the FK5 system, the routine requires the epoch + at which the position in the FK5 system was determined. + + Given: + R5 d FK5 RA (radians), equinox J2000, epoch EPOCH + D5 d FK5 Dec (radians), equinox J2000, epoch EPOCH + EPOCH d Julian epoch (TDB) + + Returned (all Hipparcos): + RH d RA (radians) + DH d Dec (radians) + + Called: slDS2C, slDAVM, slDIMV, slDMXV, slDC2S + + Notes: + + 1) The FK5 to Hipparcos transformation consists of a pure + rotation and spin; zonal errors in the FK5 catalogue are + not taken into account. + + 2) The published orientation and spin components are interpreted + as "axial vectors". An axial vector points at the pole of the + rotation and its length is the amount of rotation in radians. + + 3) See also slFK5H, slHFK5, slHF5Z. + + Reference: + + M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). + + P.T.Wallace Starlink 7 October 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/flotin.hlp b/math/slalib/doc/flotin.hlp new file mode 100644 index 00000000..5e3d8bd6 --- /dev/null +++ b/math/slalib/doc/flotin.hlp @@ -0,0 +1,118 @@ +.help flotin Jun99 "Slalib Package" +.nf + + SUBROUTINE slRFLI (STRING, NSTRT, RESLT, JFLAG) + + - - - - - - - + R F L I + - - - - - - - + + Convert free-format input into single precision floating point + + Given: + STRING c string containing number to be decoded + NSTRT i pointer to where decoding is to start + RESLT r current value of result + + Returned: + NSTRT i advanced to next number + RESLT r result + JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error + + Called: slDFLI + + Notes: + + 1 The reason FLOTIN has separate OK status values for + + and - is to enable minus zero to be detected. This is + of crucial importance when decoding mixed-radix numbers. + For example, an angle expressed as deg, arcmin, arcsec + may have a leading minus sign but a zero degrees field. + + 2 A TAB is interpreted as a space, and lowercase characters + are interpreted as uppercase. + + 3 The basic format is the sequence of fields #^.^@#^, where + # is a sign character + or -, ^ means a string of decimal + digits, and @, which indicates an exponent, means D or E. + Various combinations of these fields can be omitted, and + embedded blanks are permissible in certain places. + + 4 Spaces: + + . Leading spaces are ignored. + + . Embedded spaces are allowed only after +, -, D or E, + and after the decomal point if the first sequence of + digits is absent. + + . Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + + 5 Delimiters: + + . Any character other than +,-,0-9,.,D,E or space may be + used to signal the end of the number and terminate + decoding. + + . Comma is recognized by FLOTIN as a special case; it + is skipped, leaving the pointer on the next character. + See 13, below. + + 6 Both signs are optional. The default is +. + + 7 The mantissa ^.^ defaults to 1. + + 8 The exponent @#^ defaults to E0. + + 9 The strings of decimal digits may be of any length. + + 10 The decimal point is optional for whole numbers. + + 11 A "null result" occurs when the string of characters being + decoded does not begin with +,-,0-9,.,D or E, or consists + entirely of spaces. When this condition is detected, JFLAG + is set to 1 and RESLT is left untouched. + + 12 NSTRT = 1 for the first character in the string. + + 13 On return from FLOTIN, NSTRT is set ready for the next + decode - following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to FLOTIN, otherwise + all subsequent calls will return a null result. + + 14 Errors (JFLAG=2) occur when: + + . a +, -, D or E is left unsatisfied; or + + . the decimal point is present without at least + one decimal digit before or after it; or + + . an exponent more than 100 has been presented. + + 15 When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + FLOTIN does not detect that '1E999' is unacceptable + (on a computer where this is so) until the entire number + has been decoded. + + 16 Certain highly unlikely combinations of mantissa & + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + + 17 Decoding is left to right, one pass. + + 18 See also DFLTIN and INTIN + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/galeq.hlp b/math/slalib/doc/galeq.hlp new file mode 100644 index 00000000..6bda60d1 --- /dev/null +++ b/math/slalib/doc/galeq.hlp @@ -0,0 +1,38 @@ +.help galeq Jun99 "Slalib Package" +.nf + + SUBROUTINE slGAEQ (DL, DB, DR, DD) + + - - - - - - + G A E Q + - - - - - - + + Transformation from IAU 1958 galactic coordinates to + J2000.0 equatorial coordinates (double precision) + + Given: + DL,DB dp galactic longitude and latitude L2,B2 + + Returned: + DR,DD dp J2000.0 RA,Dec + + (all arguments are radians) + + Called: + slDS2C, slDIMV, slDC2S, slDA2P, slDA1P + + Note: + The equatorial coordinates are J2000.0. Use the routine + slGE50 if conversion to B1950.0 'FK4' coordinates is + required. + + Reference: + Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) + + P.T.Wallace Starlink 21 September 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/galsup.hlp b/math/slalib/doc/galsup.hlp new file mode 100644 index 00000000..497211ac --- /dev/null +++ b/math/slalib/doc/galsup.hlp @@ -0,0 +1,43 @@ +.help galsup Jun99 "Slalib Package" +.nf + + SUBROUTINE slGASU (DL, DB, DSL, DSB) + + - - - - - - - + G A S U + - - - - - - - + + Transformation from IAU 1958 galactic coordinates to + de Vaucouleurs supergalactic coordinates (double precision) + + Given: + DL,DB dp galactic longitude and latitude L2,B2 + + Returned: + DSL,DSB dp supergalactic longitude and latitude + + (all arguments are radians) + + Called: + slDS2C, slDMXV, slDC2S, slDA2P, slDA1P + + References: + + de Vaucouleurs, de Vaucouleurs, & Corwin, Second Reference + Catalogue of Bright Galaxies, U. Texas, page 8. + + Systems & Applied Sciences Corp., Documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is L2=137.37.) + + P.T.Wallace Starlink 25 January 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ge50.hlp b/math/slalib/doc/ge50.hlp new file mode 100644 index 00000000..b064e834 --- /dev/null +++ b/math/slalib/doc/ge50.hlp @@ -0,0 +1,38 @@ +.help ge50 Jun99 "Slalib Package" +.nf + + SUBROUTINE slGE50 (DL, DB, DR, DD) + + - - - - - + G E 5 0 + - - - - - + + Transformation from IAU 1958 galactic coordinates to + B1950.0 'FK4' equatorial coordinates (double precision) + + Given: + DL,DB dp galactic longitude and latitude L2,B2 + + Returned: + DR,DD dp B1950.0 'FK4' RA,Dec + + (all arguments are radians) + + Called: + slDS2C, slDIMV, slDC2S, slADET, slDA2P, slDA1P + + Note: + The equatorial coordinates are B1950.0 'FK4'. Use the + routine slGAEQ if conversion to J2000.0 coordinates + is required. + + Reference: + Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) + + P.T.Wallace Starlink 5 September 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/geoc.hlp b/math/slalib/doc/geoc.hlp new file mode 100644 index 00000000..538474d1 --- /dev/null +++ b/math/slalib/doc/geoc.hlp @@ -0,0 +1,33 @@ +.help geoc Jun99 "Slalib Package" +.nf + + SUBROUTINE slGEOC (P, H, R, Z) + + - - - - - + G E O C + - - - - - + + Convert geodetic position to geocentric (double precision) + + Given: + P dp latitude (geodetic, radians) + H dp height above reference spheroid (geodetic, metres) + + Returned: + R dp distance from Earth axis (AU) + Z dp distance from plane of Earth equator (AU) + + Notes: + 1) Geocentric latitude can be obtained by evaluating ATAN2(Z,R). + 2) IAU 1976 constants are used. + + Reference: + Green,R.M., Spherical Astronomy, CUP 1985, p98. + + P.T.Wallace Starlink 4th October 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/gmst.hlp b/math/slalib/doc/gmst.hlp new file mode 100644 index 00000000..7e58aec9 --- /dev/null +++ b/math/slalib/doc/gmst.hlp @@ -0,0 +1,41 @@ +.help gmst Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slGMST (UT1) + + - - - - - + G M S T + - - - - - + + Conversion from universal time to sidereal time (double precision) + + Given: + UT1 dp universal time (strictly UT1) expressed as + modified Julian Date (JD-2400000.5) + + The result is the Greenwich mean sidereal time (double + precision, radians). + + The IAU 1982 expression (see page S15 of 1984 Astronomical + Almanac) is used, but rearranged to reduce rounding errors. + This expression is always described as giving the GMST at + 0 hours UT. In fact, it gives the difference between the + GMST and the UT, which happens to equal the GMST (modulo + 24 hours) at 0 hours UT each day. In this routine, the + entire UT is used directly as the argument for the + standard formula, and the fractional part of the UT is + added separately; note that the factor 1.0027379... does + not appear. + + See also the routine slGMSA, which delivers better numerical + precision by accepting the UT date and time as separate arguments. + + Called: slDA2P + + P.T.Wallace Starlink 14 September 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/gmsta.hlp b/math/slalib/doc/gmsta.hlp new file mode 100644 index 00000000..e959d6cc --- /dev/null +++ b/math/slalib/doc/gmsta.hlp @@ -0,0 +1,55 @@ +.help gmsta Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slGMSA (DATE, UT) + + - - - - - - + G M S A + - - - - - - + + Conversion from Universal Time to Greenwich mean sidereal time, + with rounding errors minimized. + + double precision + + Given: + DATE d UT1 date (MJD: integer part of JD-2400000.5)) + UT d UT1 time (fraction of a day) + + The result is the Greenwich mean sidereal time (double precision, + radians, in the range 0 to 2pi). + + There is no restriction on how the UT is apportioned between the + DATE and UT arguments. Either of the two arguments could, for + example, be zero and the entire date+time supplied in the other. + However, the routine is designed to deliver maximum accuracy when + the DATE argument is a whole number and the UT lies in the range + 0 to 1 (or vice versa). + + The algorithm is based on the IAU 1982 expression (see page S15 of + the 1984 Astronomical Almanac). This is always described as giving + the GMST at 0 hours UT1. In fact, it gives the difference between + the GMST and the UT, the steady 4-minutes-per-day drawing-ahead of + ST with respect to UT. When whole days are ignored, the expression + happens to equal the GMST at 0 hours UT1 each day. + + In this routine, the entire UT1 (the sum of the two arguments DATE + and UT) is used directly as the argument for the standard formula. + The UT1 is then added, but omitting whole days to conserve accuracy. + + See also the routine slGMST, which accepts the UT as a single + argument. Compared with slGMST, the extra numerical precision + delivered by the present routine is unlikely to be important in + an absolute sense, but may be useful when critically comparing + algorithms and in applications where two sidereal times close + together are differenced. + + Called: slDA2P + + P.T.Wallace Starlink 13 April 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/h2e.hlp b/math/slalib/doc/h2e.hlp new file mode 100644 index 00000000..06fd4282 --- /dev/null +++ b/math/slalib/doc/h2e.hlp @@ -0,0 +1,58 @@ +.help h2e Jun99 "Slalib Package" +.nf + + SUBROUTINE slH2E (AZ, EL, PHI, HA, DEC) + + - - - - - + D E 2 H + - - - - - + + Horizon to equatorial coordinates: Az,El to HA,Dec + + (single precision) + + Given: + AZ r azimuth + EL r elevation + PHI r observatory latitude + + Returned: + HA r hour angle + DEC r declination + + Notes: + + 1) All the arguments are angles in radians. + + 2) The sign convention for azimuth is north zero, east +pi/2. + + 3) HA is returned in the range +/-pi. Declination is returned + in the range +/-pi/2. + + 4) The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied. + + 5) In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of HA,Dec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the "observed" HA,Dec, and the elevation + in vacuo, which will yield the "topocentric" HA,Dec. If the + effects of diurnal aberration can be neglected, the + topocentric HA,Dec may be used as an approximation to the + "apparent" HA,Dec. + + 6) No range checking of arguments is done. + + 7) In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + + P.T.Wallace Starlink 21 February 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/h2fk5.hlp b/math/slalib/doc/h2fk5.hlp new file mode 100644 index 00000000..158d9cfb --- /dev/null +++ b/math/slalib/doc/h2fk5.hlp @@ -0,0 +1,57 @@ +.help h2fk5 Jun99 "Slalib Package" +.nf + + SUBROUTINE slHFK5 (RH,DH,DRH,DDH,R5,D5,DR5,DD5) + + - - - - - - + H F K 5 + - - - - - - + + Transform Hipparcos star data into the FK5 (J2000) system. + + (double precision) + + This routine transforms Hipparcos star positions and proper + motions into FK5 J2000. + + Given (all Hipparcos, epoch J2000): + RH d RA (radians) + DH d Dec (radians) + DRH d proper motion in RA (dRA/dt, rad/Jyear) + DDH d proper motion in Dec (dDec/dt, rad/Jyear) + + Returned (all FK5, equinox J2000, epoch J2000): + R5 d RA (radians) + D5 d Dec (radians) + DR5 d proper motion in RA (dRA/dt, rad/Jyear) + DD5 d proper motion in Dec (dDec/dt, rad/Jyear) + + Called: slDSC6, slDAVM, slDMXV, slDIMV, slDVXV, + slDC6S + + Notes: + + 1) The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt, and are per year rather than per century. + + 2) The FK5 to Hipparcos transformation consists of a pure + rotation and spin; zonal errors in the FK5 catalogue are + not taken into account. + + 3) The published orientation and spin components are interpreted + as "axial vectors". An axial vector points at the pole of the + rotation and its length is the amount of rotation in radians. + + 4) See also slFK5H, slF5HZ, slHF5Z. + + Reference: + + M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). + + P.T.Wallace Starlink 7 October 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/hfk5z.hlp b/math/slalib/doc/hfk5z.hlp new file mode 100644 index 00000000..a2bea786 --- /dev/null +++ b/math/slalib/doc/hfk5z.hlp @@ -0,0 +1,60 @@ +.help hfk5z Jun99 "Slalib Package" +.nf + + SUBROUTINE slHF5Z (RH,DH,EPOCH,R5,D5,DR5,DD5) + + - - - - - - + H F 5 Z + - - - - - - + + Transform a Hipparcos star position into FK5 J2000, assuming + zero Hipparcos proper motion. + + (double precision) + + Given: + RH d Hipparcos RA (radians) + DH d Hipparcos Dec (radians) + EPOCH d Julian epoch (TDB) + + Returned (all FK5, equinox J2000, epoch EPOCH): + R5 d RA (radians) + D5 d Dec (radians) + + Called: slDS2C, slDAVM, slDMXV, slDAVM, slDMXM, + slDIMV, slDVXV, slDC6S + + Notes: + + 1) The proper motion in RA is dRA/dt rather than cos(Dec)*dRA/dt. + + 2) The FK5 to Hipparcos transformation consists of a pure + rotation and spin; zonal errors in the FK5 catalogue are + not taken into account. + + 3) The published orientation and spin components are interpreted + as "axial vectors". An axial vector points at the pole of the + rotation and its length is the amount of rotation in radians. + + 4) It was the intention that Hipparcos should be a close + approximation to an inertial frame, so that distant objects + have zero proper motion; such objects have (in general) + non-zero proper motion in FK5, and this routine returns those + fictitious proper motions. + + 5) The position returned by this routine is in the FK5 J2000 + reference frame but at Julian epoch EPOCH. + + 6) See also slFK5H, slHFK5, slF5HZ. + + Reference: + + M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). + + P.T.Wallace Starlink 7 October 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/imxv.hlp b/math/slalib/doc/imxv.hlp new file mode 100644 index 00000000..025c7122 --- /dev/null +++ b/math/slalib/doc/imxv.hlp @@ -0,0 +1,32 @@ +.help imxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slIMXV (RM, VA, VB) + + - - - - - + I M X V + - - - - - + + Performs the 3-D backward unitary transformation: + + vector VB = (inverse of matrix RM) * vector VA + + (single precision) + + (n.b. the matrix must be unitary, as this routine assumes that + the inverse and transpose are identical) + + Given: + RM real(3,3) matrix + VA real(3) vector + + Returned: + VB real(3) result vector + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/intin.hlp b/math/slalib/doc/intin.hlp new file mode 100644 index 00000000..f0b0c8ee --- /dev/null +++ b/math/slalib/doc/intin.hlp @@ -0,0 +1,90 @@ +.help intin Jun99 "Slalib Package" +.nf + + SUBROUTINE slINTI (STRING, NSTRT, IRESLT, JFLAG) + + - - - - - - + I N T I + - - - - - - + + Convert free-format input into an integer + + Given: + STRING c string containing number to be decoded + NSTRT i pointer to where decoding is to start + IRESLT i current value of result + + Returned: + NSTRT i advanced to next number + IRESLT i result + JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error + + Called: slICHI + + Notes: + + 1 The reason INTIN has separate OK status values for + + and - is to enable minus zero to be detected. This is + of crucial importance when decoding mixed-radix numbers. + For example, an angle expressed as deg, arcmin, arcsec + may have a leading minus sign but a zero degrees field. + + 2 A TAB is interpreted as a space. + + 3 The basic format is the sequence of fields #^, where + # is a sign character + or -, and ^ means a string of + decimal digits. + + 4 Spaces: + + . Leading spaces are ignored. + + . Spaces between the sign and the number are allowed. + + . Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + + 5 Delimiters: + + . Any character other than +,-,0-9 or space may be + used to signal the end of the number and terminate + decoding. + + . Comma is recognized by INTIN as a special case; it + is skipped, leaving the pointer on the next character. + See 9, below. + + 6 The sign is optional. The default is +. + + 7 A "null result" occurs when the string of characters being + decoded does not begin with +,- or 0-9, or consists + entirely of spaces. When this condition is detected, JFLAG + is set to 1 and IRESLT is left untouched. + + 8 NSTRT = 1 for the first character in the string. + + 9 On return from INTIN, NSTRT is set ready for the next + decode - following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to INTIN, otherwise + all subsequent calls will return a null result. + + 10 Errors (JFLAG=2) occur when: + + . there is a + or - but no number; or + + . the number is greater than BIG (defined below). + + 11 When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. + + 12 See also FLOTIN and DFLTIN. + + P.T.Wallace Starlink 27 April 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/invf.hlp b/math/slalib/doc/invf.hlp new file mode 100644 index 00000000..e1d8588e --- /dev/null +++ b/math/slalib/doc/invf.hlp @@ -0,0 +1,66 @@ +.help invf Jun99 "Slalib Package" +.nf + + SUBROUTINE slINVF (FWDS,BKWDS,J) + + - - - - - + I N V F + - - - - - + + Invert a linear model of the type produced by the + slFTXY routine. + + Given: + FWDS d(6) model coefficients + + Returned: + BKWDS d(6) inverse model + J i status: 0 = OK, -1 = no inverse + + The models relate two sets of [X,Y] coordinates as follows. + Naming the elements of FWDS: + + FWDS(1) = A + FWDS(2) = B + FWDS(3) = C + FWDS(4) = D + FWDS(5) = E + FWDS(6) = F + + where two sets of coordinates [X1,Y1] and [X2,Y1] are related + thus: + + X2 = A + B*X1 + C*Y1 + Y2 = D + E*X1 + F*Y1 + + the present routine generates a new set of coefficients: + + BKWDS(1) = P + BKWDS(2) = Q + BKWDS(3) = R + BKWDS(4) = S + BKWDS(5) = T + BKWDS(6) = U + + such that: + + X1 = P + Q*X2 + R*Y2 + Y1 = S + T*X2 + U*Y2 + + Two successive calls to slINVF will thus deliver a set + of coefficients equal to the starting values. + + To comply with the ANSI Fortran standard, FWDS and BKWDS must + not be the same array, even though the routine is coded to + work on the VAX and most other computers even if this rule + is violated. + + See also slFTXY, slPXY, slXYXY, slDCMF + + P.T.Wallace Starlink 11 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/kbj.hlp b/math/slalib/doc/kbj.hlp new file mode 100644 index 00000000..519868a7 --- /dev/null +++ b/math/slalib/doc/kbj.hlp @@ -0,0 +1,28 @@ +.help kbj Jun99 "Slalib Package" +.nf + + SUBROUTINE slKBJ (JB, E, K, J) + + - - - - + K B J + - - - - + + Select epoch prefix 'B' or 'J' + + Given: + JB int slDBJI prefix status: 0=none, 1='B', 2='J' + E dp epoch - Besselian or Julian + + Returned: + K char 'B' or 'J' + J int status: 0=OK + + If JB=0, B is assumed for E < 1984D0, otherwise J. + + P.T.Wallace Starlink 31 July 1989 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/m2av.hlp b/math/slalib/doc/m2av.hlp new file mode 100644 index 00000000..51d04343 --- /dev/null +++ b/math/slalib/doc/m2av.hlp @@ -0,0 +1,38 @@ +.help m2av Jun99 "Slalib Package" +.nf + + SUBROUTINE slM2AV (RMAT, AXVEC) + + - - - - - + M 2 A V + - - - - - + + From a rotation matrix, determine the corresponding axial vector + (single precision) + + A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the Euler axis, and the angle through which the + reference frame rotates is called the Euler angle. The axial + vector returned by this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. (The + magnitude and direction can be separated by means of the routine + slVN.) + + Given: + RMAT r(3,3) rotation matrix + + Returned: + AXVEC r(3) axial vector (radians) + + The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + + If RMAT is null, so is the result. + + P.T.Wallace Starlink 11 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/map.hlp b/math/slalib/doc/map.hlp new file mode 100644 index 00000000..4a66189b --- /dev/null +++ b/math/slalib/doc/map.hlp @@ -0,0 +1,65 @@ +.help map Jun99 "Slalib Package" +.nf + + SUBROUTINE slMAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA) + + - - - - + M A P + - - - - + + Transform star RA,Dec from mean place to geocentric apparent + + The reference frames and timescales used are post IAU 1976. + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Given: + RM,DM dp mean RA,Dec (rad) + PR,PD dp proper motions: RA,Dec changes per Julian year + PX dp parallax (arcsec) + RV dp radial velocity (km/sec, +ve if receding) + EQ dp epoch and equinox of star data (Julian) + DATE dp TDB for apparent place (JD-2400000.5) + + Returned: + RA,DA dp apparent RA,Dec (rad) + + Called: + slMAPA star-independent parameters + slMAPQ quick mean to apparent + + Notes: + + 1) EQ is the Julian epoch specifying both the reference + frame and the epoch of the position - usually 2000. + For positions where the epoch and equinox are + different, use the routine slPM to apply proper + motion corrections before using this routine. + + 2) The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + + 3) The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt. + + 4) This routine may be wasteful for some applications + because it recomputes the Earth position/velocity and + the precession/nutation matrix each time, and because + it allows for parallax and proper motion. Where + multiple transformations are to be carried out for one + epoch, a faster method is to call the slMAPA routine + once and then either the slMAPQ routine (which includes + parallax and proper motion) or slMAPZ (which assumes + zero parallax and proper motion). + + P.T.Wallace Starlink 19 January 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/mappa.hlp b/math/slalib/doc/mappa.hlp new file mode 100644 index 00000000..7a2bf727 --- /dev/null +++ b/math/slalib/doc/mappa.hlp @@ -0,0 +1,69 @@ +.help mappa Jun99 "Slalib Package" +.nf + + SUBROUTINE slMAPA (EQ, DATE, AMPRMS) + + - - - - - - + M A P A + - - - - - - + + Compute star-independent parameters in preparation for + conversions between mean place and geocentric apparent place. + + The parameters produced by this routine are required in the + parallax, light deflection, aberration, and precession/nutation + parts of the mean/apparent transformations. + + The reference frames and timescales used are post IAU 1976. + + Given: + EQ d epoch of mean equinox to be used (Julian) + DATE d TDB (JD-2400000.5) + + Returned: + AMPRMS d(21) star-independent mean-to-apparent parameters: + + (1) time interval for proper motion (Julian years) + (2-4) barycentric position of the Earth (AU) + (5-7) heliocentric direction of the Earth (unit vector) + (8) (grav rad Sun)*2/(Sun-Earth distance) + (9-11) ABV: barycentric Earth velocity in units of c + (12) sqrt(1-v**2) where v=modulus(ABV) + (13-21) precession/nutation (3,3) matrix + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Notes: + + 1) For DATE, the distinction between the required TDB and TT + is always negligible. Moreover, for all but the most + critical applications UTC is adequate. + + 2) The accuracy of the routines using the parameters AMPRMS is + limited by the routine slEVP, used here to compute the + Earth position and velocity by the methods of Stumpff. + The maximum error in the resulting aberration corrections is + about 0.3 milliarcsecond. + + 3) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to + the mean equinox and equator of epoch EQ. + + 4) The parameters AMPRMS produced by this routine are used by + slMAPQ and slMAPZ. + + Called: + slEPJ MDJ to Julian epoch + slEVP earth position & velocity + slDVN normalize vector + slPRNU precession/nutation matrix + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/mapqk.hlp b/math/slalib/doc/mapqk.hlp new file mode 100644 index 00000000..adfa1f3d --- /dev/null +++ b/math/slalib/doc/mapqk.hlp @@ -0,0 +1,76 @@ +.help mapqk Jun99 "Slalib Package" +.nf + + SUBROUTINE slMAPQ (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA) + + - - - - - - + M A P Q + - - - - - - + + Quick mean to apparent place: transform a star RA,Dec from + mean place to geocentric apparent place, given the + star-independent parameters. + + Use of this routine is appropriate when efficiency is important + and where many star positions, all referred to the same equator + and equinox, are to be transformed for one epoch. The + star-independent parameters can be obtained by calling the + slMAPA routine. + + If the parallax and proper motions are zero the slMAPZ + routine can be used instead. + + The reference frames and timescales used are post IAU 1976. + + Given: + RM,DM d mean RA,Dec (rad) + PR,PD d proper motions: RA,Dec changes per Julian year + PX d parallax (arcsec) + RV d radial velocity (km/sec, +ve if receding) + + AMPRMS d(21) star-independent mean-to-apparent parameters: + + (1) time interval for proper motion (Julian years) + (2-4) barycentric position of the Earth (AU) + (5-7) heliocentric direction of the Earth (unit vector) + (8) (grav rad Sun)*2/(Sun-Earth distance) + (9-11) barycentric Earth velocity in units of c + (12) sqrt(1-v**2) where v=modulus(ABV) + (13-21) precession/nutation (3,3) matrix + + Returned: + RA,DA d apparent RA,Dec (rad) + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Notes: + + 1) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to + the mean equinox and equator of epoch EQ. + + 2) Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about 920 arcsec of the + centre of the Sun's disc. The term has a maximum value of + about 1.85 arcsec at this radius, and decreases to zero as + the centre of the disc is approached. + + Called: + slDS2C spherical to Cartesian + slDVDV dot product + slDMXV matrix x vector + slDC2S Cartesian to spherical + slDA2P normalize angle 0-2Pi + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/mapqkz.hlp b/math/slalib/doc/mapqkz.hlp new file mode 100644 index 00000000..2ca9b493 --- /dev/null +++ b/math/slalib/doc/mapqkz.hlp @@ -0,0 +1,68 @@ +.help mapqkz Jun99 "Slalib Package" +.nf + + SUBROUTINE slMAPZ (RM, DM, AMPRMS, RA, DA) + + - - - - - - - + M A P Z + - - - - - - - + + Quick mean to apparent place: transform a star RA,Dec from + mean place to geocentric apparent place, given the + star-independent parameters, and assuming zero parallax + and proper motion. + + Use of this routine is appropriate when efficiency is important + and where many star positions, all with parallax and proper + motion either zero or already allowed for, and all referred to + the same equator and equinox, are to be transformed for one + epoch. The star-independent parameters can be obtained by + calling the slMAPA routine. + + The corresponding routine for the case of non-zero parallax + and proper motion is slMAPQ. + + The reference frames and timescales used are post IAU 1976. + + Given: + RM,DM d mean RA,Dec (rad) + AMPRMS d(21) star-independent mean-to-apparent parameters: + + (1-4) not used + (5-7) heliocentric direction of the Earth (unit vector) + (8) (grav rad Sun)*2/(Sun-Earth distance) + (9-11) ABV: barycentric Earth velocity in units of c + (12) sqrt(1-v**2) where v=modulus(ABV) + (13-21) precession/nutation (3,3) matrix + + Returned: + RA,DA d apparent RA,Dec (rad) + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Notes: + + 1) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to the + mean equinox and equator of epoch EQ. + + 2) Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about 920 arcsec of the + centre of the Sun's disc. The term has a maximum value of + about 1.85 arcsec at this radius, and decreases to zero as + the centre of the disc is approached. + + Called: slDS2C, slDVDV, slDMXV, slDC2S, slDA2P + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/moon.hlp b/math/slalib/doc/moon.hlp new file mode 100644 index 00000000..403984eb --- /dev/null +++ b/math/slalib/doc/moon.hlp @@ -0,0 +1,59 @@ +.help moon Jun99 "Slalib Package" +.nf + + SUBROUTINE slMOON (IY, ID, FD, PV) + + - - - - - + M O O N + - - - - - + + Approximate geocentric position and velocity of the Moon + (single precision). + + Given: + IY i year + ID i day in year (1 = Jan 1st) + FD r fraction of day + + Returned: + PV r(6) Moon position & velocity vector + + Notes: + + 1 The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling slCAYD or + slCLYD. + + 2 The Moon 6-vector is Moon centre relative to Earth centre, + mean equator and equinox of date. Position part, PV(1-3), + is in AU; velocity part, PV(4-6), is in AU/sec. + + 3 The position is accurate to better than 0.5 arcminute + in direction and 1000 km in distance. The velocity + is accurate to better than 0.5"/hour in direction and + 4 m/s in distance. (RMS figures with respect to JPL DE200 + for the interval 1960-2025 are 14 arcsec and 0.2 arcsec/hour in + longitude, 9 arcsec and 0.2 arcsec/hour in latitude, 350 km and + 2 m/s in distance.) Note that the distance accuracy is + comparatively poor because this routine is principally intended + for computing topocentric direction. + + 4 This routine is only a partial implementation of the original + Meeus algorithm (reference below), which offers 4 times the + accuracy in direction and 30 times the accuracy in distance + when fully implemented (as it is in slDMON). + + Reference: + Meeus, l'Astronomie, June 1984, p348. + + Called: slS2C6 + + P.T.Wallace Starlink 8 December 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/mxm.hlp b/math/slalib/doc/mxm.hlp new file mode 100644 index 00000000..7ee561e4 --- /dev/null +++ b/math/slalib/doc/mxm.hlp @@ -0,0 +1,33 @@ +.help mxm Jun99 "Slalib Package" +.nf + + SUBROUTINE slMXM (A, B, C) + + - - - - + M X M + - - - - + + Product of two 3x3 matrices: + matrix C = matrix A x matrix B + + (single precision) + + Given: + A real(3,3) matrix + B real(3,3) matrix + + Returned: + C real(3,3) matrix result + + To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. However, the routine is coded so as to + work properly on the VAX and many other systems even if this + rule is violated. + + P.T.Wallace Starlink 5 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/mxv.hlp b/math/slalib/doc/mxv.hlp new file mode 100644 index 00000000..bacba504 --- /dev/null +++ b/math/slalib/doc/mxv.hlp @@ -0,0 +1,29 @@ +.help mxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slMXV (RM, VA, VB) + + - - - - + M X V + - - - - + + Performs the 3-D forward unitary transformation: + + vector VB = matrix RM * vector VA + + (single precision) + + Given: + RM real(3,3) matrix + VA real(3) vector + + Returned: + VB real(3) result vector + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/nut.hlp b/math/slalib/doc/nut.hlp new file mode 100644 index 00000000..95ea2ff0 --- /dev/null +++ b/math/slalib/doc/nut.hlp @@ -0,0 +1,34 @@ +.help nut Jun99 "Slalib Package" +.nf + + SUBROUTINE slNUT (DATE, RMATN) + + - - - - + N U T + - - - - + + Form the matrix of nutation for a given date - IAU 1980 theory + (double precision) + + References: + Final report of the IAU Working Group on Nutation, + chairman P.K.Seidelmann, 1980. + Kaplan,G.H., 1981, USNO circular no. 163, pA3-6. + + Given: + DATE dp TDB (loosely ET) as Modified Julian Date + (=JD-2400000.5) + Returned: + RMATN dp(3,3) nutation matrix + + The matrix is in the sense V(true) = RMATN * V(mean) + + Called: slNUTC, slDEUL + + P.T.Wallace Starlink 1 January 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/nutc.hlp b/math/slalib/doc/nutc.hlp new file mode 100644 index 00000000..b028219d --- /dev/null +++ b/math/slalib/doc/nutc.hlp @@ -0,0 +1,33 @@ +.help nutc Jun99 "Slalib Package" +.nf + + SUBROUTINE slNUTC (DATE, DPSI, DEPS, EPS0) + + - - - - - + N U T C + - - - - - + + Nutation: longitude & obliquity components and mean + obliquity - IAU 1980 theory (double precision) + + Given: + + DATE dp TDB (loosely ET) as Modified Julian Date + (JD-2400000.5) + Returned: + + DPSI,DEPS dp nutation in longitude,obliquity + EPS0 dp mean obliquity + + References: + Final report of the IAU Working Group on Nutation, + chairman P.K.Seidelmann, 1980. + Kaplan,G.H., 1981, USNO circular no. 163, pA3-6. + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/oap.hlp b/math/slalib/doc/oap.hlp new file mode 100644 index 00000000..7322c0ee --- /dev/null +++ b/math/slalib/doc/oap.hlp @@ -0,0 +1,163 @@ +.help oap Jun99 "Slalib Package" +.nf + + SUBROUTINE slOAP (TYPE, OB1, OB2, DATE, DUT, ELONGM, PHIM, + : HM, XP, YP, TDK, PMB, RH, WL, TLR, + : RAP, DAP) + + - - - - + O A P + - - - - + + Observed to apparent place + + Given: + TYPE c*(*) type of coordinates - 'R', 'H' or 'A' (see below) + OB1 d observed Az, HA or RA (radians; Az is N=0,E=90) + OB2 d observed ZD or Dec (radians) + DATE d UTC date/time (modified Julian Date, JD-2400000.5) + DUT d delta UT: UT1-UTC (UTC seconds) + ELONGM d mean longitude of the observer (radians, east +ve) + PHIM d mean geodetic latitude of the observer (radians) + HM d observer's height above sea level (metres) + XP d polar motion x-coordinate (radians) + YP d polar motion y-coordinate (radians) + TDK d local ambient temperature (DegK; std=273.155D0) + PMB d local atmospheric pressure (mB; std=1013.25D0) + RH d local relative humidity (in the range 0D0-1D0) + WL d effective wavelength (micron, e.g. 0.55D0) + TLR d tropospheric lapse rate (DegK/metre, e.g. 0.0065D0) + + Returned: + RAP d geocentric apparent right ascension + DAP d geocentric apparent declination + + Notes: + + 1) Only the first character of the TYPE argument is significant. + 'R' or 'r' indicates that OBS1 and OBS2 are the observed Right + Ascension and Declination; 'H' or 'h' indicates that they are + Hour Angle (West +ve) and Declination; anything else ('A' or + 'a' is recommended) indicates that OBS1 and OBS2 are Azimuth + (North zero, East is 90 deg) and zenith distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + + 2) The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted apparent RA,Dec should be within about 0.1 arcsec + for a zenith distance of less than 70 degrees. Even at a + topocentric zenith distance of 90 degrees, the accuracy in + elevation should be better than 1 arcmin; useful results + are available for a further 3 degrees, beyond which the + slRFRO routine returns a fixed value of the refraction. + The complementary routines slAOP (or slAOPQ) and slOAP + (or slOAPQ) are self-consistent to better than 1 micro- + arcsecond all over the celestial sphere. + + 3) It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + + 4) "Observed" Az,El means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed HA,Dec via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. "Observed" RA,Dec or HA,Dec thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation (n.b. not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent RA,Dec is obtained. + + 5) Frequently, mean rather than apparent RA,Dec will be required, + in which case further transformations will be necessary. The + slAMP etc routines will convert the apparent RA,Dec produced + by the present routine into an "FK5" (J2000) mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should "FK4" (1950) + coordinates be needed, the routines slFK54 etc will also + need to be applied. + + 6) To convert to apparent RA,Dec the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + + 7) The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the slAOPA routine. + If nothing has changed significantly except the time, the + slAOPT routine may be used to perform the requisite + partial recomputation of AOPRMS. + + 8) The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the delta UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap delta UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the delta UTC changes by one second to its post-leap new value. + + 9) The delta UT (UT1-UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep delta UT + within +/- 0.9 seconds. + + 10) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. + The longitude required by the present routine is east-positive, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + slOBS routine are west-positive, following astronomical + usage, and must be reversed in sign before use in the present + routine. + + 11) The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The maximum amplitude + is about 0.3 arcseconds. If XP,YP values are unavailable, + use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac + for a definition of the two angles. + + 12) The height above sea level of the observing station, HM, + can be obtained from the Astronomical Almanac (Section J + in the 1988 edition), or via the routine slOBS. If P, + the pressure in millibars, is available, an adequate + estimate of HM can be obtained from the expression + + HM ~ -29.3D0*TSL*LOG(P/1013.25D0). + + where TSL is the approximate sea-level air temperature in + deg K (see Astrophysical Quantities, C.W.Allen, 3rd edition, + section 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + + P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). + + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + + 13) The azimuths etc used by the present routine are with respect + to the celestial pole. Corrections from the terrestrial pole + can be computed using slPLMO. + + Called: slAOPA, slOAPQ + + P.T.Wallace Starlink 9 June 1998 + + Copyright (C) 1998 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/oapqk.hlp b/math/slalib/doc/oapqk.hlp new file mode 100644 index 00000000..70a37f86 --- /dev/null +++ b/math/slalib/doc/oapqk.hlp @@ -0,0 +1,114 @@ +.help oapqk Jun99 "Slalib Package" +.nf + + SUBROUTINE slOAPQ (TYPE, OB1, OB2, AOPRMS, RAP, DAP) + + - - - - - - + O A P Q + - - - - - - + + Quick observed to apparent place + + Given: + TYPE c*(*) type of coordinates - 'R', 'H' or 'A' (see below) + OB1 d observed Az, HA or RA (radians; Az is N=0,E=90) + OB2 d observed ZD or Dec (radians) + AOPRMS d(14) star-independent apparent-to-observed parameters: + + (1) geodetic latitude (radians) + (2,3) sine and cosine of geodetic latitude + (4) magnitude of diurnal aberration vector + (5) height (HM) + (6) ambient temperature (T) + (7) pressure (P) + (8) relative humidity (RH) + (9) wavelength (WL) + (10) lapse rate (TLR) + (11,12) refraction constants A and B (radians) + (13) longitude + eqn of equinoxes + sidereal DUT (radians) + (14) local apparent sidereal time (radians) + + Returned: + RAP d geocentric apparent right ascension + DAP d geocentric apparent declination + + Notes: + + 1) Only the first character of the TYPE argument is significant. + 'R' or 'r' indicates that OBS1 and OBS2 are the observed Right + Ascension and Declination; 'H' or 'h' indicates that they are + Hour Angle (West +ve) and Declination; anything else ('A' or + 'a' is recommended) indicates that OBS1 and OBS2 are Azimuth + (North zero, East is 90 deg) and zenith distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + + 2) The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted apparent RA,Dec should be within about 0.1 arcsec + for a zenith distance of less than 70 degrees. Even at a + topocentric zenith distance of 90 degrees, the accuracy in + elevation should be better than 1 arcmin; useful results + are available for a further 3 degrees, beyond which the + slRFRO routine returns a fixed value of the refraction. + The complementary routines slAOP (or slAOPQ) and slOAP + (or slOAPQ) are self-consistent to better than 1 micro- + arcsecond all over the celestial sphere. + + 3) It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + + 5) "Observed" Az,El means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed HA,Dec via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. "Observed" RA,Dec or HA,Dec thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation (n.b. not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent RA,Dec is obtained. + + 5) Frequently, mean rather than apparent RA,Dec will be required, + in which case further transformations will be necessary. The + slAMP etc routines will convert the apparent RA,Dec produced + by the present routine into an "FK5" (J2000) mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should "FK4" (1950) + coordinates be needed, the routines slFK54 etc will also + need to be applied. + + 6) To convert to apparent RA,Dec the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + + 7) The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the slAOPA routine. + If nothing has changed significantly except the time, the + slAOPT routine may be used to perform the requisite + partial recomputation of AOPRMS. + + 8) The azimuths etc used by the present routine are with respect + to the celestial pole. Corrections from the terrestrial pole + can be computed using slPLMO. + + Called: slDS2C, slDC2S, slRFRO, slDA2P + + P.T.Wallace Starlink 23 June 1997 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/obs.hlp b/math/slalib/doc/obs.hlp new file mode 100644 index 00000000..bce6404e --- /dev/null +++ b/math/slalib/doc/obs.hlp @@ -0,0 +1,83 @@ +.help obs Jun99 "Slalib Package" +.nf + + SUBROUTINE slOBS (N, C, NAME, W, P, H) + + - - - - + O B S + - - - - + + Parameters of selected groundbased observing stations + + Given: + N int number specifying observing station + + Either given or returned + C c*(*) identifier specifying observing station + + Returned: + NAME c*(*) name of specified observing station + W dp longitude (radians, West +ve) + P dp geodetic latitude (radians, North +ve) + H dp height above sea level (metres) + + Notes: + + Station identifiers C may be up to 10 characters long, + and station names NAME may be up to 40 characters long. + + C and N are alternative ways of specifying the observing + station. The C option, which is the most generally useful, + may be selected by specifying an N value of zero or less. + If N is 1 or more, the parameters of the Nth station + in the currently supported list are interrogated, and + the station identifier C is returned as well as NAME, W, + P and H. + + If the station parameters are not available, either because + the station identifier C is not recognized, or because an + N value greater than the number of stations supported is + given, a name of '?' is returned and C, W, P and H are left + in their current states. + + Programs can obtain a list of all currently supported + stations by calling the routine repeatedly, with N=1,2,3... + When NAME='?' is seen, the list of stations has been + exhausted. + + Station numbers, identifiers, names and other details are + subject to change and should not be hardwired into + application programs. + + All station identifiers C are uppercase only; lowercase + characters must be converted to uppercase by the calling + program. The station names returned may contain both upper- + and lowercase. All characters up to the first space are + checked; thus an abbreviated ID will return the parameters + for the first station in the list which matches the + abbreviation supplied, and no station in the list will ever + contain embedded spaces. C must not have leading spaces. + + IMPORTANT -- BEWARE OF THE LONGITUDE SIGN CONVENTION. The + longitude returned by slOBS is west-positive in accordance + with astronomical usage. However, this sign convention is + left-handed and is the opposite of the one used by geographers; + elsewhere in SLALIB the preferable east-positive convention is + used. In particular, note that for use in slAOP, slAOPA + and slOAP the sign of the longitude must be reversed. + + Users are urged to inform the author of any improvements + they would like to see made. For example: + + typographical corrections + more accurate parameters + better station identifiers or names + additional stations + + P.T.Wallace Starlink 21 April 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pa.hlp b/math/slalib/doc/pa.hlp new file mode 100644 index 00000000..a7ee7357 --- /dev/null +++ b/math/slalib/doc/pa.hlp @@ -0,0 +1,36 @@ +.help pa Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slPA (HA, DEC, PHI) + + - - - + P A + - - - + + HA, Dec to Parallactic Angle (double precision) + + Given: + HA d hour angle in radians (geocentric apparent) + DEC d declination in radians (geocentric apparent) + PHI d observatory latitude in radians (geodetic) + + The result is in the range -pi to +pi + + Notes: + + 1) The parallactic angle at a point in the sky is the position + angle of the vertical, i.e. the angle between the direction to + the pole and to the zenith. In precise applications care must + be taken only to use geocentric apparent HA,Dec and to consider + separately the effects of atmospheric refraction and telescope + mount errors. + + 2) At the pole a zero result is returned. + + P.T.Wallace Starlink 16 August 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pav.hlp b/math/slalib/doc/pav.hlp new file mode 100644 index 00000000..a74d3ca3 --- /dev/null +++ b/math/slalib/doc/pav.hlp @@ -0,0 +1,40 @@ +.help pav Jun99 "Slalib Package" +.nf + + REAL FUNCTION slPAV ( V1, V2 ) + + - - - - + P A V + - - - - + + Position angle of one celestial direction with respect to another. + + (single precision) + + Given: + V1 r(3) direction cosines of one point + V2 r(3) direction cosines of the other point + + (The coordinate frames correspond to RA,Dec, Long,Lat etc.) + + The result is the bearing (position angle), in radians, of point + V2 with respect to point V1. It is in the range +/- pi. The + sense is such that if V2 is a small distance east of V1, the + bearing is about +pi/2. Zero is returned if the two points + are coincident. + + V1 and V2 do not have to be unit vectors. + + The routine slBEAR performs an equivalent function except + that the points are specified in the form of spherical + coordinates. + + Called: slDPAV + + Patrick Wallace Starlink 23 May 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pcd.hlp b/math/slalib/doc/pcd.hlp new file mode 100644 index 00000000..dd6263a4 --- /dev/null +++ b/math/slalib/doc/pcd.hlp @@ -0,0 +1,51 @@ +.help pcd Jun99 "Slalib Package" +.nf + + SUBROUTINE slPCD (DISCO,X,Y) + + - - - - + P C D + - - - - + + Apply pincushion/barrel distortion to a tangent-plane [x,y]. + + Given: + DISCO d pincushion/barrel distortion coefficient + X,Y d tangent-plane coordinates + + Returned: + X,Y d distorted coordinates + + Notes: + + 1) The distortion is of the form RP = R*(1 + C*R**2), where R is + the radial distance from the tangent point, C is the DISCO + argument, and RP is the radial distance in the presence of + the distortion. + + 2) For pincushion distortion, C is +ve; for barrel distortion, + C is -ve. + + 3) For X,Y in units of one projection radius (in the case of + a photographic plate, the focal length), the following + DISCO values apply: + + Geometry DISCO + + astrograph 0.0 + Schmidt -0.3333 + AAT PF doublet +147.069 + AAT PF triplet +178.585 + AAT f/8 +21.20 + JKT f/8 +13.32 + + 4) There is a companion routine, slUPCD, which performs + an approximately inverse operation. + + P.T.Wallace Starlink 31 December 1992 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pda2h.hlp b/math/slalib/doc/pda2h.hlp new file mode 100644 index 00000000..6a5a7dc4 --- /dev/null +++ b/math/slalib/doc/pda2h.hlp @@ -0,0 +1,33 @@ +.help pda2h Jun99 "Slalib Package" +.nf + + SUBROUTINE slPDAH (P, D, A, H1, J1, H2, J2) + + - - - - - - + P D A H + - - - - - - + + Hour Angle corresponding to a given azimuth + + (double precision) + + Given: + P d latitude + D d declination + A d azimuth + + Returned: + H1 d hour angle: first solution if any + J1 i flag: 0 = solution 1 is valid + H2 d hour angle: second solution if any + J2 i flag: 0 = solution 2 is valid + + Called: slDA1P + + P.T.Wallace Starlink 6 October 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pdq2h.hlp b/math/slalib/doc/pdq2h.hlp new file mode 100644 index 00000000..cdb0702f --- /dev/null +++ b/math/slalib/doc/pdq2h.hlp @@ -0,0 +1,33 @@ +.help pdq2h Jun99 "Slalib Package" +.nf + + SUBROUTINE slPDQH (P, D, Q, H1, J1, H2, J2) + + - - - - - - + P D Q H + - - - - - - + + Hour Angle corresponding to a given parallactic angle + + (double precision) + + Given: + P d latitude + D d declination + Q d parallactic angle + + Returned: + H1 d hour angle: first solution if any + J1 i flag: 0 = solution 1 is valid + H2 d hour angle: second solution if any + J2 i flag: 0 = solution 2 is valid + + Called: slDA1P + + P.T.Wallace Starlink 6 October 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pertel.hlp b/math/slalib/doc/pertel.hlp new file mode 100644 index 00000000..c1685eca --- /dev/null +++ b/math/slalib/doc/pertel.hlp @@ -0,0 +1,121 @@ +.help pertel Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRTL (JFORM, DATE0, DATE1, + : EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0, + : EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1, + : JSTAT) + + - - - - - - - + P R T L + - - - - - - - + + Update the osculating orbital elements of an asteroid or comet by + applying planetary perturbations. + + Given (format and dates): + JFORM i choice of element set (2 or 3; Note 1) + DATE0 d date of osculation (TT MJD) for the given elements + DATE1 d date of osculation (TT MJD) for the updated elements + + Given (the unperturbed elements): + EPOCH0 d epoch (TT MJD) of the given element set (Note 2) + ORBI0 d inclination (radians) + ANODE0 d longitude of the ascending node (radians) + PERIH0 d argument of perihelion (radians) + AORQ0 d mean distance or perihelion distance (AU) + E0 d eccentricity + AM0 d mean anomaly (radians, JFORM=2 only) + + Returned (the updated elements): + EPOCH1 d epoch (TT MJD) of the updated element set (Note 2) + ORBI1 d inclination (radians) + ANODE1 d longitude of the ascending node (radians) + PERIH1 d argument of perihelion (radians) + AORQ1 d mean distance or perihelion distance (AU) + E1 d eccentricity + AM1 d mean anomaly (radians, JFORM=2 only) + + Returned (status flag): + JSTAT i status: +102 = warning, distant epoch + +101 = warning, large timespan ( > 100 years) + +1 to +8 = coincident with major planet (Note 6) + 0 = OK + -1 = illegal JFORM + -2 = illegal E0 + -3 = illegal AORQ0 + -4 = internal error + -5 = numerical error + + Notes: + + 1 Two different element-format options are available: + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBI = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AM = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBI = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e + + 2 DATE0, DATE1, EPOCH0 and EPOCH1 are all instants of time in + the TT timescale (formerly Ephemeris Time, ET), expressed + as Modified Julian Dates (JD-2400000.5). + + DATE0 is the instant at which the given (i.e. unperturbed) + osculating elements are correct. + + DATE1 is the specified instant at which the updated osculating + elements are correct. + + EPOCH0 and EPOCH1 will be the same as DATE0 and DATE1 + (respectively) for the JFORM=2 case, normally used for minor + planets. For the JFORM=3 case, the two epochs will refer to + perihelion passage and so will not, in general, be the same as + DATE0 and/or DATE1 though they may be similar to one another. + + 3 The elements are with respect to the J2000 ecliptic and equinox. + + 4 Unused elements (AM0 and AM1 for JFORM=3) are not accessed. + + 5 See the slPRTE routine for details of the algorithm used. + + 6 This routine is not intended to be used for major planets, which + is why JFORM=1 is not available and why there is no opportunity + to specify either the longitude of perihelion or the daily + motion. However, if JFORM=2 elements are somehow obtained for a + major planet and supplied to the routine, sensible results will, + in fact, be produced. This happens because the slPRTE routine + that is called to perform the calculations checks the separation + between the body and each of the planets and interprets a + suspiciously small value (0.001 AU) as an attempt to apply it to + the planet concerned. If this condition is detected, the + contribution from that planet is ignored, and the status is set to + the planet number (Mercury=1,...,Neptune=8) as a warning. + + Reference: + + Sterne, Theodore E., "An Introduction to Celestial Mechanics", + Interscience Publishers Inc., 1960. Section 6.7, p199. + + Called: slELUE, slPRTE, slUEEL + + P.T.Wallace Starlink 14 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pertue.hlp b/math/slalib/doc/pertue.hlp new file mode 100644 index 00000000..4f5cf166 --- /dev/null +++ b/math/slalib/doc/pertue.hlp @@ -0,0 +1,152 @@ +.help pertue Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRTE (DATE, U, JSTAT) + + - - - - - - - + P R T E + - - - - - - - + + Update the universal elements of an asteroid or comet by applying + planetary perturbations. + + Given: + DATE d final epoch (TT MJD) for the updated elements + + Given and returned: + U d(13) universal elements (updated in place) + + (1) combined mass (M+m) + (2) total energy of the orbit (alpha) + (3) reference (osculating) epoch (t0) + (4-6) position at reference epoch (r0) + (7-9) velocity at reference epoch (v0) + (10) heliocentric distance at reference epoch + (11) r0.v0 + (12) date (t) + (13) universal eccentric anomaly (psi) of date, approx + + Returned: + JSTAT i status: + +102 = warning, distant epoch + +101 = warning, large timespan ( > 100 years) + +1 to +8 = coincident with major planet (Note 5) + 0 = OK + -1 = numerical error + + Called: slPLNT, slUEPV, slPVUE + + Notes: + + 1 The "universal" elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i) alpha, which is proportional to the total energy of the + orbit, (ii) the heliocentric distance at epoch, (iii) the + outwards component of the velocity at the given epoch, (iv) an + estimate of psi, the "universal eccentric anomaly" at a given + date and (v) that date. + + 2 The universal elements are with respect to the J2000 equator and + equinox. + + 3 The epochs DATE, U(3) and U(12) are all Modified Julian Dates + (JD-2400000.5). + + 4 The algorithm is a simplified form of Encke's method. It takes as + a basis the unperturbed motion of the body, and numerically + integrates the perturbing accelerations from the major planets. + The expression used is essentially Sterne's 6.7-2 (reference 1). + Everhart and Pitkin (reference 2) suggest rectifying the orbit at + each integration step by propagating the new perturbed position + and velocity as the new universal variables. In the present + routine the orbit is rectified less frequently than this, in order + to gain a slight speed advantage. However, the rectification is + done directly in terms of position and velocity, as suggested by + Everhart and Pitkin, bypassing the use of conventional orbital + elements. + + The f(q) part of the full Encke method is not used. The purpose + of this part is to avoid subtracting two nearly equal quantities + when calculating the "indirect member", which takes account of the + small change in the Sun's attraction due to the slightly displaced + position of the perturbed body. A simpler, direct calculation in + double precision proves to be faster and not significantly less + accurate. + + Apart from employing a variable timestep, and occasionally + "rectifying the orbit" to keep the indirect member small, the + integration is done in a fairly straightforward way. The + acceleration estimated for the middle of the timestep is assumed + to apply throughout that timestep; it is also used in the + extrapolation of the perturbations to the middle of the next + timestep, to predict the new disturbed position. There is no + iteration within a timestep. + + Measures are taken to reach a compromise between execution time + and accuracy. The starting-point is the goal of achieving + arcsecond accuracy for ordinary minor planets over a ten-year + timespan. This goal dictates how large the timesteps can be, + which in turn dictates how frequently the unperturbed motion has + to be recalculated from the osculating elements. + + Within predetermined limits, the timestep for the numerical + integration is varied in length in inverse proportion to the + magnitude of the net acceleration on the body from the major + planets. + + The numerical integration requires estimates of the major-planet + motions. Approximate positions for the major planets (Pluto + alone is omitted) are obtained from the routine slPLNT. Two + levels of interpolation are used, to enhance speed without + significantly degrading accuracy. At a low frequency, the routine + slPLNT is called to generate updated position+velocity "state + vectors". The only task remaining to be carried out at the full + frequency (i.e. at each integration step) is to use the state + vectors to extrapolate the planetary positions. In place of a + strictly linear extrapolation, some allowance is made for the + curvature of the orbit by scaling back the radius vector as the + linear extrapolation goes off at a tangent. + + Various other approximations are made. For example, perturbations + by Pluto and the minor planets are neglected, relativistic effects + are not taken into account and the Earth-Moon system is treated as + a single body. + + In the interests of simplicity, the background calculations for + the major planets are carried out en masse. The mean elements and + state vectors for all the planets are refreshed at the same time, + without regard for orbit curvature, mass or proximity. + + 5 This routine is not intended to be used for major planets. + However, if major-planet elements are supplied, sensible results + will, in fact, be produced. This happens because the routine + checks the separation between the body and each of the planets and + interprets a suspiciously small value (0.001 AU) as an attempt to + apply the routine to the planet concerned. If this condition is + detected, the contribution from that planet is ignored, and the + status is set to the planet number (Mercury=1,...,Neptune=8) as a + warning. + + References: + + 1 Sterne, Theodore E., "An Introduction to Celestial Mechanics", + Interscience Publishers Inc., 1960. Section 6.7, p199. + + 2 Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp + +.fi +.endhelp diff --git a/math/slalib/doc/planel.hlp b/math/slalib/doc/planel.hlp new file mode 100644 index 00000000..c5a0f02f --- /dev/null +++ b/math/slalib/doc/planel.hlp @@ -0,0 +1,96 @@ +.help planel Jun99 "Slalib Package" +.nf + + SUBROUTINE slPLNE (DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, PV, JSTAT) + + - - - - - - - + P L N L + - - - - - - - + + Heliocentric position and velocity of a planet, asteroid or comet, + starting from orbital elements. + + Given: + DATE d date, Modified Julian Date (JD - 2400000.5) + JFORM i choice of element set (1-3; Note 3) + EPOCH d epoch of elements (TT MJD) + ORBINC d inclination (radians) + ANODE d longitude of the ascending node (radians) + PERIH d longitude or argument of perihelion (radians) + AORQ d mean distance or perihelion distance (AU) + E d eccentricity + AORL d mean anomaly or longitude (radians, JFORM=1,2 only) + DM d daily motion (radians, JFORM=1 only) + + Returned: + PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, + J2000 equatorial triad (AU,AU/s) + JSTAT i status: 0 = OK + -1 = illegal JFORM + -2 = illegal E + -3 = illegal AORQ + -4 = illegal DM + -5 = numerical error + + Called: slELUE, slUEPV + + Notes + + 1 DATE is the instant for which the prediction is required. It is + in the TT timescale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD-2400000.5). + + 2 The elements are with respect to the J2000 ecliptic and equinox. + + 3 Three different element-format options are available: + + Option JFORM=1, suitable for the major planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = longitude of perihelion, curly pi (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e (range 0 to <1) + AORL = mean longitude L (radians) + DM = daily motion (radians) + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e (range 0 to <1) + AORL = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e (range 0 to 10) + + 4 Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + + 5 The reference frame for the result is with respect to the mean + equator and equinox of epoch J2000. + + 6 The algorithm was originally adapted from the EPHSLA program of + D.H.P.Jones (private communication, 1996). The method is based + on Stumpff's Universal Variables. + + Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/planet.hlp b/math/slalib/doc/planet.hlp new file mode 100644 index 00000000..3bdb7b9f --- /dev/null +++ b/math/slalib/doc/planet.hlp @@ -0,0 +1,130 @@ +.help planet Jun99 "Slalib Package" +.nf + + SUBROUTINE slPLNT (DATE, NP, PV, JSTAT) + + - - - - - - - + P L N T + - - - - - - - + + Approximate heliocentric position and velocity of a specified + major planet. + + Given: + DATE d Modified Julian Date (JD - 2400000.5) + NP i planet (1=Mercury, 2=Venus, 3=EMB ... 9=Pluto) + + Returned: + PV d(6) heliocentric x,y,z,xdot,ydot,zdot, J2000 + equatorial triad (AU,AU/s) + JSTAT i status: +1 = warning: date out of range + 0 = OK + -1 = illegal NP (outside 1-9) + -2 = solution didn't converge + + Called: slPLNE + + Notes + + 1 The epoch, DATE, is in the TDB timescale and is a Modified + Julian Date (JD-2400000.5). + + 2 The reference frame is equatorial and is with respect to the + mean equinox and ecliptic of epoch J2000. + + 3 If an NP value outside the range 1-9 is supplied, an error + status (JSTAT = -1) is returned and the PV vector set to zeroes. + + 4 The algorithm for obtaining the mean elements of the planets + from Mercury to Neptune is due to J.L. Simon, P. Bretagnon, + J. Chapront, M. Chapront-Touze, G. Francou and J. Laskar + (Bureau des Longitudes, Paris). The (completely different) + algorithm for calculating the ecliptic coordinates of Pluto + is by Meeus. + + 5 Comparisons of the present routine with the JPL DE200 ephemeris + give the following RMS errors over the interval 1960-2025: + + position (km) speed (metre/sec) + + Mercury 334 0.437 + Venus 1060 0.855 + EMB 2010 0.815 + Mars 7690 1.98 + Jupiter 71700 7.70 + Saturn 199000 19.4 + Uranus 564000 16.4 + Neptune 158000 14.4 + Pluto 36400 0.137 + + From comparisons with DE102, Simon et al quote the following + longitude accuracies over the interval 1800-2200: + + Mercury 4" + Venus 5" + EMB 6" + Mars 17" + Jupiter 71" + Saturn 81" + Uranus 86" + Neptune 11" + + In the case of Pluto, Meeus quotes an accuracy of 0.6 arcsec + in longitude and 0.2 arcsec in latitude for the period + 1885-2099. + + For all except Pluto, over the period 1000-3000 the accuracy + is better than 1.5 times that over 1800-2200. Outside the + period 1000-3000 the accuracy declines. For Pluto the + accuracy declines rapidly outside the period 1885-2099. + Outside these ranges (1885-2099 for Pluto, 1000-3000 for + the rest) a "date out of range" warning status (JSTAT=+1) + is returned. + + 6 The algorithms for (i) Mercury through Neptune and (ii) Pluto + are completely independent. In the Mercury through Neptune + case, the present SLALIB implementation differs from the + original Simon et al Fortran code in the following respects. + + * The date is supplied as a Modified Julian Date rather + than a Julian Date (MJD = JD - 2400000.5). + + * The result is returned only in equatorial Cartesian form; + the ecliptic longitude, latitude and radius vector are not + returned. + + * The velocity is in AU per second, not AU per day. + + * Different error/warning status values are used. + + * Kepler's equation is not solved inline. + + * Polynomials in T are nested to minimize rounding errors. + + * Explicit double-precision constants are used to avoid + mixed-mode expressions. + + * There are other, cosmetic, changes to comply with + Starlink/SLALIB style guidelines. + + None of the above changes affects the result significantly. + + 7 For NP=3 the result is for the Earth-Moon Barycentre. To + obtain the heliocentric position and velocity of the Earth, + either use the SLALIB routine slEVP or call slDMON and + subtract 0.012150581 times the geocentric Moon vector from + the EMB vector produced by the present routine. (The Moon + vector should be precessed to J2000 first, but this can + be omitted for modern epochs without introducing significant + inaccuracy.) + + References: Simon et al., Astron. Astrophys. 282, 663 (1994). + Meeus, Astronomical Algorithms, Willmann-Bell (1991). + + P.T.Wallace Starlink 27 May 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/plante.hlp b/math/slalib/doc/plante.hlp new file mode 100644 index 00000000..a801ca51 --- /dev/null +++ b/math/slalib/doc/plante.hlp @@ -0,0 +1,97 @@ +.help plante Jun99 "Slalib Package" +.nf + + SUBROUTINE slPLTE (DATE, ELONG, PHI, JFORM, EPOCH, + : ORBINC, ANODE, PERIH, AORQ, E, + : AORL, DM, RA, DEC, R, JSTAT) + + - - - - - - - + P L T E + - - - - - - - + + Topocentric apparent RA,Dec of a Solar-System object whose + heliocentric orbital elements are known. + + Given: + DATE d MJD of observation (JD - 2400000.5) + ELONG d observer's east longitude (radians) + PHI d observer's geodetic latitude (radians) + JFORM i choice of element set (1-3; Note 4) + EPOCH d epoch of elements (TT MJD) + ORBINC d inclination (radians) + ANODE d longitude of the ascending node (radians) + PERIH d longitude or argument of perihelion (radians) + AORQ d mean distance or perihelion distance (AU) + E d eccentricity + AORL d mean anomaly or longitude (radians, JFORM=1,2 only) + DM d daily motion (radians, JFORM=1 only ) + + Returned: + RA,DEC d RA, Dec (topocentric apparent, radians) + R d distance from observer (AU) + JSTAT i status: 0 = OK + -1 = illegal JFORM + -2 = illegal E + -3 = illegal AORQ + -4 = illegal DM + -5 = numerical error + + Notes: + + 1 DATE is the instant for which the prediction is required. It is + in the TT timescale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD-2400000.5). + + 2 The longitude and latitude allow correction for geocentric + parallax. This is usually a small effect, but can become + important for Earth-crossing asteroids. Geocentric positions + can be generated by appropriate use of routines slEVP and + slPLNE. + + 3 The elements are with respect to the J2000 ecliptic and equinox. + + 4 Three different element-format options are available: + + Option JFORM=1, suitable for the major planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = longitude of perihelion, curly pi (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean longitude L (radians) + DM = daily motion (radians) + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e + + 5 Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + + Called: slGMST, slDT, slEPJ, slPVOB, slPRNU, + slPLNE, slDMXV, slDC2S, slDA2P + + P.T.Wallace Starlink 17 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pm.hlp b/math/slalib/doc/pm.hlp new file mode 100644 index 00000000..a6d755ff --- /dev/null +++ b/math/slalib/doc/pm.hlp @@ -0,0 +1,45 @@ +.help pm Jun99 "Slalib Package" +.nf + + SUBROUTINE slPM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1) + + - - - + P M + - - - + + Apply corrections for proper motion to a star RA,Dec + (double precision) + + References: + 1984 Astronomical Almanac, pp B39-B41. + (also Lederle & Schwan, Astron. Astrophys. 134, + 1-6, 1984) + + Given: + R0,D0 dp RA,Dec at epoch EP0 (rad) + PR,PD dp proper motions: RA,Dec changes per year of epoch + PX dp parallax (arcsec) + RV dp radial velocity (km/sec, +ve if receding) + EP0 dp start epoch in years (e.g. Julian epoch) + EP1 dp end epoch in years (same system as EP0) + + Returned: + R1,D1 dp RA,Dec at epoch EP1 (rad) + + Called: + slDS2C spherical to Cartesian + slDC2S Cartesian to spherical + slDA2P normalize angle 0-2Pi + + Note: + The proper motions in RA are dRA/dt rather than + cos(Dec)*dRA/dt, and are in the same coordinate + system as R0,D0. + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/polmo.hlp b/math/slalib/doc/polmo.hlp new file mode 100644 index 00000000..b3f68383 --- /dev/null +++ b/math/slalib/doc/polmo.hlp @@ -0,0 +1,87 @@ +.help polmo Jun99 "Slalib Package" +.nf + + SUBROUTINE slPLMO ( ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ ) + + - - - - - - + P L M O + - - - - - - + + Polar motion: correct site longitude and latitude for polar + motion and calculate azimuth difference between celestial and + terrestrial poles. + + Given: + ELONGM d mean longitude of the observer (radians, east +ve) + PHIM d mean geodetic latitude of the observer (radians) + XP d polar motion x-coordinate (radians) + YP d polar motion y-coordinate (radians) + + Returned: + ELONG d true longitude of the observer (radians, east +ve) + PHI d true geodetic latitude of the observer (radians) + DAZ d azimuth correction (terrestrial-celestial, radians) + + Notes: + + 1) "Mean" longitude and latitude are the (fixed) values for the + site's location with respect to the IERS terrestrial reference + frame; the latitude is geodetic. TAKE CARE WITH THE LONGITUDE + SIGN CONVENTION. The longitudes used by the present routine + are east-positive, in accordance with geographical convention + (and right-handed). In particular, note that the longitudes + returned by the slOBS routine are west-positive, following + astronomical usage, and must be reversed in sign before use in + the present routine. + + 2) XP and YP are the (changing) coordinates of the Celestial + Ephemeris Pole with respect to the IERS Reference Pole. + XP is positive along the meridian at longitude 0 degrees, + and YP is positive along the meridian at longitude + 270 degrees (i.e. 90 degrees west). Values for XP,YP can + be obtained from IERS circulars and equivalent publications; + the maximum amplitude observed so far is about 0.3 arcseconds. + + 3) "True" longitude and latitude are the (moving) values for + the site's location with respect to the celestial ephemeris + pole and the meridian which corresponds to the Greenwich + apparent sidereal time. The true longitude and latitude + link the terrestrial coordinates with the standard celestial + models (for precession, nutation, sidereal time etc). + + 4) The azimuths produced by slAOP and slAOPQ are with + respect to due north as defined by the Celestial Ephemeris + Pole, and can therefore be called "celestial azimuths". + However, a telescope fixed to the Earth measures azimuth + essentially with respect to due north as defined by the + IERS Reference Pole, and can therefore be called "terrestrial + azimuth". Uncorrected, this would manifest itself as a + changing "azimuth zero-point error". The value DAZ is the + correction to be added to a celestial azimuth to produce + a terrestrial azimuth. + + 5) The present routine is rigorous. For most practical + purposes, the following simplified formulae provide an + adequate approximation: + + ELONG = ELONGM+XP*COS(ELONGM)-YP*SIN(ELONGM) + PHI = PHIM+(XP*SIN(ELONGM)+YP*COS(ELONGM))*TAN(PHIM) + DAZ = -SQRT(XP*XP+YP*YP)*COS(ELONGM-ATAN2(XP,YP))/COS(PHIM) + + An alternative formulation for DAZ is: + + X = COS(ELONGM)*COS(PHIM) + Y = SIN(ELONGM)*COS(PHIM) + DAZ = ATAN2(-X*YP-Y*XP,X*X+Y*Y) + + Reference: Seidelmann, P.K. (ed), 1992. "Explanatory Supplement + to the Astronomical Almanac", ISBN 0-935702-68-7, + sections 3.27, 4.25, 4.52. + + P.T.Wallace Starlink 22 February 1996 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/prebn.hlp b/math/slalib/doc/prebn.hlp new file mode 100644 index 00000000..e2c1991b --- /dev/null +++ b/math/slalib/doc/prebn.hlp @@ -0,0 +1,36 @@ +.help prebn Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRBN (BEP0, BEP1, RMATP) + + - - - - - - + P R B N + - - - - - - + + Generate the matrix of precession between two epochs, + using the old, pre-IAU1976, Bessel-Newcomb model, using + Kinoshita's formulation (double precision) + + Given: + BEP0 dp beginning Besselian epoch + BEP1 dp ending Besselian epoch + + Returned: + RMATP dp(3,3) precession matrix + + The matrix is in the sense V(BEP1) = RMATP * V(BEP0) + + Reference: + Kinoshita, H. (1975) 'Formulas for precession', SAO Special + Report No. 364, Smithsonian Institution Astrophysical + Observatory, Cambridge, Massachusetts. + + Called: slDEUL + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/prec.hlp b/math/slalib/doc/prec.hlp new file mode 100644 index 00000000..4b12d918 --- /dev/null +++ b/math/slalib/doc/prec.hlp @@ -0,0 +1,53 @@ +.help prec Jun99 "Slalib Package" +.nf + + SUBROUTINE slPREC (EP0, EP1, RMATP) + + - - - - - + P R E C + - - - - - + + Form the matrix of precession between two epochs (IAU 1976, FK5) + (double precision) + + Given: + EP0 dp beginning epoch + EP1 dp ending epoch + + Returned: + RMATP dp(3,3) precession matrix + + Notes: + + 1) The epochs are TDB (loosely ET) Julian epochs. + + 2) The matrix is in the sense V(EP1) = RMATP * V(EP0) + + 3) Though the matrix method itself is rigorous, the precession + angles are expressed through canonical polynomials which are + valid only for a limited time span. There are also known + errors in the IAU precession rate. The absolute accuracy + of the present formulation is better than 0.1 arcsec from + 1960AD to 2040AD, better than 1 arcsec from 1640AD to 2360AD, + and remains below 3 arcsec for the whole of the period + 500BC to 3000AD. The errors exceed 10 arcsec outside the + range 1200BC to 3900AD, exceed 100 arcsec outside 4200BC to + 5600AD and exceed 1000 arcsec outside 6800BC to 8200AD. + The SLALIB routine slPREL implements a more elaborate + model which is suitable for problems spanning several + thousand years. + + References: + Lieske,J.H., 1979. Astron.Astrophys.,73,282. + equations (6) & (7), p283. + Kaplan,G.H., 1981. USNO circular no. 163, pA2. + + Called: slDEUL + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/preces.hlp b/math/slalib/doc/preces.hlp new file mode 100644 index 00000000..7652ea8a --- /dev/null +++ b/math/slalib/doc/preces.hlp @@ -0,0 +1,47 @@ +.help preces Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRCE (SYSTEM, EP0, EP1, RA, DC) + + - - - - - - - + P R C E + - - - - - - - + + Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or + FK5 (Fricke, post IAU 1976) as required. + + Given: + SYSTEM char precession to be applied: 'FK4' or 'FK5' + EP0,EP1 dp starting and ending epoch + RA,DC dp RA,Dec, mean equator & equinox of epoch EP0 + + Returned: + RA,DC dp RA,Dec, mean equator & equinox of epoch EP1 + + Called: slDA2P, slPRBN, slPREC, slDS2C, + slDMXV, slDC2S + + Notes: + + 1) Lowercase characters in SYSTEM are acceptable. + + 2) The epochs are Besselian if SYSTEM='FK4' and Julian if 'FK5'. + For example, to precess coordinates in the old system from + equinox 1900.0 to 1950.0 the call would be: + CALL slPRCE ('FK4', 1900D0, 1950D0, RA, DC) + + 3) This routine will NOT correctly convert between the old and + the new systems - for example conversion from B1950 to J2000. + For these purposes see slFK45, slFK54, slF45Z and + slF54Z. + + 4) If an invalid SYSTEM is supplied, values of -99D0,-99D0 will + be returned for both RA and DC. + + P.T.Wallace Starlink 20 April 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/precl.hlp b/math/slalib/doc/precl.hlp new file mode 100644 index 00000000..b715172a --- /dev/null +++ b/math/slalib/doc/precl.hlp @@ -0,0 +1,47 @@ +.help precl Jun99 "Slalib Package" +.nf + + SUBROUTINE slPREL (EP0, EP1, RMATP) + + - - - - - - + P R E L + - - - - - - + + Form the matrix of precession between two epochs, using the + model of Simon et al (1994), which is suitable for long + periods of time. + + (double precision) + + Given: + EP0 dp beginning epoch + EP1 dp ending epoch + + Returned: + RMATP dp(3,3) precession matrix + + Notes: + + 1) The epochs are TDB Julian epochs. + + 2) The matrix is in the sense V(EP1) = RMATP * V(EP0) + + 3) The absolute accuracy of the model is limited by the + uncertainty in the general precession, about 0.3 arcsec per + 1000 years. The remainder of the formulation provides a + precision of 1 mas over the interval from 1000AD to 3000AD, + 0.1 arcsec from 1000BC to 5000AD and 1 arcsec from + 4000BC to 8000AD. + + Reference: + Simon, J.L. et al., 1994. Astron.Astrophys., 282, 663-683. + + Called: slDEUL + + P.T.Wallace Starlink 23 August 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/precss.hlp b/math/slalib/doc/precss.hlp new file mode 100644 index 00000000..ab244cf5 --- /dev/null +++ b/math/slalib/doc/precss.hlp @@ -0,0 +1,44 @@ +.help precss Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRCS (SYSTEM, EP0, EP1, RA, DC) + + - - - - - - - + P R C E + - - - - - - - + + Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or + FK5 (Fricke, post IAU 1976) as required. + + Given: + SYSTEM int precession to be applied: 1 = FK4 or 2 = FK5 + EP0,EP1 dp starting and ending epoch + RA,DC dp RA,Dec, mean equator & equinox of epoch EP0 + + Returned: + RA,DC dp RA,Dec, mean equator & equinox of epoch EP1 + + Called: slDA2P, slPRBN, slPREC, slDS2C, + slDMXV, slDC2S + + Notes: + + 1) Lowercase characters in SYSTEM are acceptable. + + 2) The epochs are Besselian if SYSTEM=FK4 and Julian if FK5. + For example, to precess coordinates in the old system from + equinox 1900.0 to 1950.0 the call would be: + CALL slPRCS (1, 1900D0, 1950D0, RA, DC) + + 3) This routine will NOT correctly convert between the old and + the new systems - for example conversion from B1950 to J2000. + For these purposes see slFK45, slFK54, slF45Z and + slF54Z. + + 4) If an invalid SYSTEM is supplied, values of -99D0,-99D0 will + be returned for both RA and DC. + + P.T.Wallace Starlink 20 April 1990 + +.fi +.endhelp diff --git a/math/slalib/doc/prenut.hlp b/math/slalib/doc/prenut.hlp new file mode 100644 index 00000000..bbe3ceff --- /dev/null +++ b/math/slalib/doc/prenut.hlp @@ -0,0 +1,35 @@ +.help prenut Jun99 "Slalib Package" +.nf + + SUBROUTINE slPRNU (EPOCH, DATE, RMATPN) + + - - - - - - - + P R N U + - - - - - - - + + Form the matrix of precession and nutation (IAU1976/FK5) + (double precision) + + Given: + EPOCH dp Julian Epoch for mean coordinates + DATE dp Modified Julian Date (JD-2400000.5) + for true coordinates + + Returned: + RMATPN dp(3,3) combined precession/nutation matrix + + Called: slPREC, slEPJ, slNUT, slDMXM + + Notes: + + 1) The epoch and date are TDB (loosely ET). + + 2) The matrix is in the sense V(true) = RMATPN * V(mean) + + P.T.Wallace Starlink April 1987 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pv2el.hlp b/math/slalib/doc/pv2el.hlp new file mode 100644 index 00000000..ef027a38 --- /dev/null +++ b/math/slalib/doc/pv2el.hlp @@ -0,0 +1,145 @@ +.help pv2el Jun99 "Slalib Package" +.nf + + SUBROUTINE slPVEL (PV, DATE, PMASS, JFORMR, + : JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, JSTAT) + + - - - - - - + P V E L + - - - - - - + + Heliocentric osculating elements obtained from instantaneous position + and velocity. + + Given: + PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, + J2000 equatorial triad (AU,AU/s; Note 1) + DATE d date (TT Modified Julian Date = JD-2400000.5) + PMASS d mass of the planet (Sun=1; Note 2) + JFORMR i requested element set (1-3; Note 3) + + Returned: + JFORM d element set actually returned (1-3; Note 4) + EPOCH d epoch of elements (TT MJD) + ORBINC d inclination (radians) + ANODE d longitude of the ascending node (radians) + PERIH d longitude or argument of perihelion (radians) + AORQ d mean distance or perihelion distance (AU) + E d eccentricity + AORL d mean anomaly or longitude (radians, JFORM=1,2 only) + DM d daily motion (radians, JFORM=1 only) + JSTAT i status: 0 = OK + -1 = illegal PMASS + -2 = illegal JFORMR + -3 = position/velocity out of range + + Notes + + 1 The PV 6-vector is with respect to the mean equator and equinox of + epoch J2000. The orbital elements produced are with respect to + the J2000 ecliptic and mean equinox. + + 2 The mass, PMASS, is important only for the larger planets. For + most purposes (e.g. asteroids) use 0D0. Values less than zero + are illegal. + + 3 Three different element-format options are supported: + + Option JFORM=1, suitable for the major planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = longitude of perihelion, curly pi (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean longitude L (radians) + DM = daily motion (radians) + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e + + 4 It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + JFORMR JFORM meaning + + 1 1 OK - elements are in the requested format + 1 2 never happens + 1 3 orbit not elliptical + + 2 1 never happens + 2 2 OK - elements are in the requested format + 2 3 orbit not elliptical + + 3 1 never happens + 3 2 never happens + 3 3 OK - elements are in the requested format + + 5 The arguments returned for each value of JFORM (cf Note 5: JFORM + may not be the same as JFORMR) are as follows: + + JFORM 1 2 3 + EPOCH t0 t0 T + ORBINC i i i + ANODE Omega Omega Omega + PERIH curly pi omega omega + AORQ a a q + E e e e + AORL L M - + DM n - - + + where: + + t0 is the epoch of the elements (MJD, TT) + T " epoch of perihelion (MJD, TT) + i " inclination (radians) + Omega " longitude of the ascending node (radians) + curly pi " longitude of perihelion (radians) + omega " argument of perihelion (radians) + a " mean distance (AU) + q " perihelion distance (AU) + e " eccentricity + L " longitude (radians, 0-2pi) + M " mean anomaly (radians, 0-2pi) + n " daily motion (radians) + - means no value is set + + 6 At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + + Reference: Sterne, Theodore E., "An Introduction to Celestial + Mechanics", Interscience Publishers, 1960 + + Called: slDA2P + + P.T.Wallace Starlink 13 February 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pv2ue.hlp b/math/slalib/doc/pv2ue.hlp new file mode 100644 index 00000000..776f877a --- /dev/null +++ b/math/slalib/doc/pv2ue.hlp @@ -0,0 +1,70 @@ +.help pv2ue Jun99 "Slalib Package" +.nf + + SUBROUTINE slPVUE (PV, DATE, PMASS, U, JSTAT) + + - - - - - - + P V U E + - - - - - - + + Construct a universal element set based on an instantaneous position + and velocity. + + Given: + PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, + (AU,AU/s; Note 1) + DATE d date (TT Modified Julian Date = JD-2400000.5) + PMASS d mass of the planet (Sun=1; Note 2) + + Returned: + U d(13) universal orbital elements (Note 3) + + (1) combined mass (M+m) + (2) total energy of the orbit (alpha) + (3) reference (osculating) epoch (t0) + (4-6) position at reference epoch (r0) + (7-9) velocity at reference epoch (v0) + (10) heliocentric distance at reference epoch + (11) r0.v0 + (12) date (t) + (13) universal eccentric anomaly (psi) of date, approx + + JSTAT i status: 0 = OK + -1 = illegal PMASS + -2 = too close to Sun + -3 = too slow + + Notes + + 1 The PV 6-vector can be with respect to any chosen inertial frame, + and the resulting universal-element set will be with respect to + the same frame. A common choice will be mean equator and ecliptic + of epoch J2000. + + 2 The mass, PMASS, is important only for the larger planets. For + most purposes (e.g. asteroids) use 0D0. Values less than zero + are illegal. + + 3 The "universal" elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i) alpha, which is proportional to the total energy of the + orbit, (ii) the heliocentric distance at epoch, (iii) the + outwards component of the velocity at the given epoch, (iv) an + estimate of psi, the "universal eccentric anomaly" at a given + date and (v) that date. + + Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pvobs.hlp b/math/slalib/doc/pvobs.hlp new file mode 100644 index 00000000..607d73a5 --- /dev/null +++ b/math/slalib/doc/pvobs.hlp @@ -0,0 +1,31 @@ +.help pvobs Jun99 "Slalib Package" +.nf + + SUBROUTINE slPVOB (P, H, STL, PV) + + - - - - - - + P V O B + - - - - - - + + Position and velocity of an observing station (double precision) + + Given: + P dp latitude (geodetic, radians) + H dp height above reference spheroid (geodetic, metres) + STL dp local apparent sidereal time (radians) + + Returned: + PV dp(6) position/velocity 6-vector (AU, AU/s, true equator + and equinox of date) + + Called: slGEOC + + IAU 1976 constants are used. + + P.T.Wallace Starlink 14 November 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/pxy.hlp b/math/slalib/doc/pxy.hlp new file mode 100644 index 00000000..e2764150 --- /dev/null +++ b/math/slalib/doc/pxy.hlp @@ -0,0 +1,56 @@ +.help pxy Jun99 "Slalib Package" +.nf + + SUBROUTINE slPXY (NP,XYE,XYM,COEFFS,XYP,XRMS,YRMS,RRMS) + + - - - - + P X Y + - - - - + + Given arrays of "expected" and "measured" [X,Y] coordinates, and a + linear model relating them (as produced by slFTXY), compute + the array of "predicted" coordinates and the RMS residuals. + + Given: + NP i number of samples + XYE d(2,np) expected [X,Y] for each sample + XYM d(2,np) measured [X,Y] for each sample + COEFFS d(6) coefficients of model (see below) + + Returned: + XYP d(2,np) predicted [X,Y] for each sample + XRMS d RMS in X + YRMS d RMS in Y + RRMS d total RMS (vector sum of XRMS and YRMS) + + The model is supplied in the array COEFFS. Naming the + elements of COEFF as follows: + + COEFFS(1) = A + COEFFS(2) = B + COEFFS(3) = C + COEFFS(4) = D + COEFFS(5) = E + COEFFS(6) = F + + the model is applied thus: + + XP = A + B*XM + C*YM + YP = D + E*XM + F*YM + + The residuals are (XP-XE) and (YP-YE). + + If NP is less than or equal to zero, no coordinates are + transformed, and the RMS residuals are all zero. + + See also slFTXY, slINVF, slXYXY, slDCMF + + Called: slXYXY + + P.T.Wallace Starlink 22 May 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/range.hlp b/math/slalib/doc/range.hlp new file mode 100644 index 00000000..b65a1a92 --- /dev/null +++ b/math/slalib/doc/range.hlp @@ -0,0 +1,24 @@ +.help range Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRA1P (ANGLE) + + - - - - - - + R A 1 P + - - - - - - + + Normalize angle into range +/- pi (single precision) + + Given: + ANGLE dp the angle in radians + + The result is ANGLE expressed in the +/- pi (single + precision). + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ranorm.hlp b/math/slalib/doc/ranorm.hlp new file mode 100644 index 00000000..5ee46937 --- /dev/null +++ b/math/slalib/doc/ranorm.hlp @@ -0,0 +1,24 @@ +.help ranorm Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRA2P (ANGLE) + + - - - - - - - + R A 2 P + - - - - - - - + + Normalize angle into range 0-2 pi (single precision) + + Given: + ANGLE dp the angle in radians + + The result is ANGLE expressed in the range 0-2 pi (single + precision). + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rcc.hlp b/math/slalib/doc/rcc.hlp new file mode 100644 index 00000000..fef7f578 --- /dev/null +++ b/math/slalib/doc/rcc.hlp @@ -0,0 +1,83 @@ +.help rcc Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slRCC (TDB, UT1, WL, U, V) + + - - - - + R C C + - - - - + + Relativistic clock correction: the difference between proper time at + a point on the surface of the Earth and coordinate time in the Solar + System barycentric space-time frame of reference. + + The proper time is Terrestrial Time TT; the coordinate + time is an implementation of the Barycentric Dynamical Time TDB. + + Given: + TDB dp coordinate time (MJD: JD-2400000.5) + UT1 dp universal time (fraction of one day) + WL dp clock longitude (radians west) + U dp clock distance from Earth spin axis (km) + V dp clock distance north of Earth equatorial plane (km) + + Returned: + The clock correction, TDB-TT, in seconds. TDB may be considered + to be the coordinate time in the Solar System barycentre frame of + reference, and TT is the proper time given by clocks at mean sea + level on the Earth. + + The result has a main (annual) sinusoidal term of amplitude + approximately 0.00166 seconds, plus planetary terms up to about + 20 microseconds, and lunar and diurnal terms up to 2 microseconds. + The variation arises from the transverse Doppler effect and the + gravitational red-shift as the observer varies in speed and moves + through different gravitational potentials. + + The argument TDB is, strictly, the barycentric coordinate time; + however, the terrestrial proper time (TT) can in practice be used. + + The geocentric model is that of Fairhead & Bretagnon (1990), in its + full form. It was supplied by Fairhead (private communication) as a + FORTRAN subroutine. The original Fairhead routine used explicit + formulae, in such large numbers that problems were experienced with + certain compilers (Microsoft Fortran on PC aborted with stack + overflow, Convex compiled successfully but extremely slowly). The + present implementation is a complete recoding, with the original + Fairhead coefficients held in a table. To optimize arithmetic + precision, the terms are accumulated in reverse order, smallest + first. A number of other coding changes were made, in order to match + the calling sequence of previous versions of the present routine, and + to comply with Starlink programming standards. Under VAX/VMS, the + numerical results compared with those from the Fairhead form are + essentially unaffected by the changes, the differences being at the + 10^-20 sec level. + + The topocentric part of the model is from Moyer (1981) and + Murray (1983). + + During the interval 1950-2050, the absolute accuracy is better + than +/- 3 nanoseconds relative to direct numerical integrations + using the JPL DE200/LE200 solar system ephemeris. + + The IAU definition of TDB is that it must differ from TT only by + periodic terms. Though practical, this is an imprecise definition + which ignores the existence of very long-period and secular effects + in the dynamics of the solar system. As a consequence, different + implementations of TDB will, in general, differ in zero-point and + will drift linearly relative to one other. + + References: + Bretagnon P, 1982 Astron. Astrophys., 114, 278-288. + Fairhead L & Bretagnon P, 1990, Astron. Astrophys., 229, 240-247. + Meeus J, 1984, l'Astronomie, 348-354. + Moyer T D, 1981, Cel. Mech., 23, 33. + Murray C A, 1983, Vectorial Astrometry, Adam Hilger. + + P.T.Wallace Starlink 10 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rdplan.hlp b/math/slalib/doc/rdplan.hlp new file mode 100644 index 00000000..5b9d560a --- /dev/null +++ b/math/slalib/doc/rdplan.hlp @@ -0,0 +1,73 @@ +.help rdplan Jun99 "Slalib Package" +.nf + + SUBROUTINE slRDPL (DATE, NP, ELONG, PHI, RA, DEC, DIAM) + + - - - - - - - + R D P L + - - - - - - - + + Approximate topocentric apparent RA,Dec of a planet, and its + angular diameter. + + Given: + DATE d MJD of observation (JD - 2400000.5) + NP i planet: 1 = Mercury + 2 = Venus + 3 = Moon + 4 = Mars + 5 = Jupiter + 6 = Saturn + 7 = Uranus + 8 = Neptune + 9 = Pluto + else = Sun + ELONG,PHI d observer's east longitude and geodetic + latitude (radians) + + Returned: + RA,DEC d RA, Dec (topocentric apparent, radians) + DIAM d angular diameter (equatorial, radians) + + Notes: + + 1 The date is in a dynamical timescale (TDB, formerly ET) and is + in the form of a Modified Julian Date (JD-2400000.5). For all + practical purposes, TT can be used instead of TDB, and for many + applications UT will do (except for the Moon). + + 2 The longitude and latitude allow correction for geocentric + parallax. This is a major effect for the Moon, but in the + context of the limited accuracy of the present routine its + effect on planetary positions is small (negligible for the + outer planets). Geocentric positions can be generated by + appropriate use of the routines slDMON and slPLNT. + + 3 The direction accuracy (arcsec, 1000-3000AD) is of order: + + Sun 5 + Mercury 2 + Venus 10 + Moon 30 + Mars 50 + Jupiter 90 + Saturn 90 + Uranus 90 + Neptune 10 + Pluto 1 (1885-2099AD only) + + The angular diameter accuracy is about 0.4% for the Moon, + and 0.01% or better for the Sun and planets. + + See the slPLNT routine for references. + + Called: slGMST, slDT, slEPJ, slDMON, slPVOB, slPRNU, + slPLNT, slDMXV, slDC2S, slDA2P + + P.T.Wallace Starlink 26 May 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/read.me b/math/slalib/doc/read.me new file mode 100644 index 00000000..e7f5f358 --- /dev/null +++ b/math/slalib/doc/read.me @@ -0,0 +1,437 @@ +READ.ME + +Revision date 31 May 1999 SLALIB Version 2.3-0 + +----------------------------------------------------------------------- + +FILES IN THE ORIGINAL SOURCE DIRECTORY (VAX) + + READ.ME this file + *.FOR Fortran source (separate modules) + *.OBS ditto, but obsolete routines + *.NEW ditto, but new and not yet ready for release + *.VAX Fortran source for VAX/VMS + *.CNVX Fortran source for Convex + *.MIPS Fortran source for DECstation + *.SUN4 Fortran source for Sun SPARCstation + *.LNX Fortran source for Linux + *.PCM Microsoft Fortran source for PC + *.C C functions needed for Linux version + PC.BAT rebuilds PC version + REP.BAT on PC, compiles one module and updates library + CREATE.COM complete rebuild of VAX and Unix releases + PUT.COM compile one module and update libraries + VAX_TO_UNIX.USH script to complete transfer to Unix platforms + SLA.NEWS NEWS item for latest release + MAKEFILE Unix make file + MK C-shell script to run make + SUN67.TEX document + +FILES IN [.RELEASE] DIRECTORY ON VAX + + SLALIB.OLB object library + SLALIB.TLB source library + SUN67.TEX document + +FILES IN [.UNIX] DIRECTORY ON VAX + + MAKEFILE make file for DECstation and Sun SPARC + MK C-shell script to run make + SLA.A archive file containing everything else + VAX_TO_UNIX script to complete transfer to Unix platforms + SLA.NEWS NEWS item for latest release + SUN67.TEX document + +FILES IN (INFORMAL) FTP DIRECTORIES + + The files distributed informally through anonymous FTP may differ + slightly in both content and name from the ones listed above. For + example the PC Fortran modules may be stored in archive files and + called xxx.f_pcm rather than XXX.PCM etc. + +----------------------------------------------------------------------- + +DISTRIBUTION - THIS DIRECTORY + + Nothing from this directory needs to be distributed. + +DISTRIBUTION - [.RELEASE] DIRECTORY + + SLALIB.* SLALIB_DIR + SLA.NEWS SLALIB_DIR + SUN67.TEX DOCSDIR + +INSTRUCTIONS FOR SAVING SPACE + + Extract from the SLALIB_DIR BACKUP save set only the file SLALIB.OLB. + +----------------------------------------------------------------------- + +PORTING FORTRAN SLALIB TO OTHER SYSTEMS + +FORTRAN SLALIB runs on VAX (VMS), PC (Linux+f2c), PC (Microsoft FORTRAN), +Convex (ConvexOS), DECstation (Ultrix), DEC Alpha (OSF-1) and Sun +SPARCstation (SunOS and Solaris). + +For most platforms, the required changes are confined to these routines: + + sla_GRESID + sla_RANDOM + sla_WAIT + +VAX, CONVEX, DECSTATION/ALPHA, SUN & PC + +Versions suitable for the above platforms are supplied in the +development directory as *.VAX, *,CNVX, *.MIPS, *.SUN4, *.PCM and +*.LNX respectively. + + +----------------------------------------------------------------------- + +LATEST RELEASE INFORMATION + +The latest release of SLALIB includes the following changes (most recent +at the end): + +* In sla_RCC, the topocentric term of coefficient 1.3184D-10 sec + had the wrong sign. Minus is correct. + +* The IAU decided in 1991 to rename the Terrestrial Dynamical + Time, TDT, which is now called "Terrestrial Time" or TT. + Appropriate changes have been made in the SLALIB documentation. + The same IAU resolutions introduced the timescales TCG and TCB; + there are at present no SLALIB routines to handle these new + timescales. + +* The Keck 1 Telescope has been added to sla_OBS. + +* The handling of the random-number seed in the PC versions of + sla_RANDOM and sla_GRESID was flawed and has been improved. + +* The UTC leap second at the end of June 1993 has been added to the + routine sla_DAT. Existing applications which call sla_DAT or + sla_DTT require relinking. + +* Some unnecessary code in sla_AMPQK has been removed. + +* Minor reorganization of the sla_REFRO code has led to an improvement + in speed of about 20%, and precautions have been taken against + potential arithmetic errors. + +* There have been small revisions to sla_FK425 and sla_FK524. The + results are not significantly affected, except in the pathological + case of large proper motion combined with immense distance, where + sla_FK524 could produce erroneous radial velocity values. The + latest versions are close to the algorithms published in the 1992 + Explanatory Supplement to the Astronomical Almanac. + +* The leap second at the end of June 1994 has been added to sla_DAT. + +* THE SLA_RVLSR ROUTINE HAS BEEN RETIRED. Its place has been taken + by two new routines: sla_RVLSRK and sla_RVLSRD. The original + sla_RVLSR had used a "kinematical" LSR. When this was later changed + to a "dynamical" LSR for (what seemed liked good reasons at the time), + the small differences were noticed by spectral-line radio observers, + who had to fall back on old copies of the routine to remain consistent + with existing practice. The new routines provide both sorts of LSR: + sla_RVLSRK uses a kinematical LSR and sla_RVLSRD uses the dynamical LSR. + +* The sla_PA routine (computation of parallactic angle) used an + unnecessarily complicated formulation, which has been simplified. + The results are unaffected. + +* The sla_ZD routine (computation of zenith distance) used a + straightforward cosine-formula-based method, which suffered from + decreased accuracy near the zenith. A better, vector-derived, + formulation has been substituted, without materially affecting + the results. Because sla_ZD is double precision, the old + formulation was always adequate; however, had anyone transcribed + the code in single precision errors approaching 1 arcmin could + have resulted. The new formulation delivers good results all + over the sky even in a single precision version. + +* Routines have been added to transform equatorial coordinates + (HA,Dec) to horizon coordinates (Az,El) and back. Single and + double precision are both supported. The routines are called + sla_E2H, sla_DE2H, sla_H2E, sla_DH2E. + +* A new routine has been added to the tangent-plane projection set. + The single and double precision versions are called sla_TPRD and + sla_DTPRD respectively. Given the RA,Dec of a star and its + xi,eta coordinates, the routine determines the "plate centre". + +* The existing routine sla_PREC for obtaining the precession matrix + uses the official IAU model and should continue to be used for + canonical purposes. A new version, called sla_PRECL, uses a + more up-to-date model which delivers better accuracy, especially + over intervals of millennia. + +* The routine sla_PVOBS was returning velocities in AU per sidereal + second rather than per UT second. This has been corrected. The + maximum error was equivalent to about 0.001 km/s. + +* In sla_MAPQK and sla_MAPQKZ, the area within which the gravitional + light-deflection term is restrained has been extended from its + original 300 arcsec radius to about 920 arcsec, just inside the + Sun's disc. + +* A chapter of explanation, with examples, has been added to SUN/67, + which has also undergone various cosmetic revisions. + +* There were two discrepancies between the documentation of sla_DCMPF + (program comments and SUN/67) and the code. The first was that the + formulae for the nonperpendicularity used PERP instead of PERP/2; + the documentation has been corrected. The other was that the + documentation showed the zero point corrections being applied first, + whereas the code returned zero point corrections corresponding to + being applied last. The code has been corrected to match the + documentation. + +* The C module slaCldj gave incorrect answers for dates during + January and February. The error, which did not affect the Fortran + version, has been corrected. + +* THE CALL FOR TPRD AND DTPRD HAS BEEN CHANGED. An integer status + argument has been added; non-zero means the supplied RA,Dec + and Xi,Eta describe an impossible case. (This can only happen + near the pole and with non-zero Xi.) Also, a slightly neater + formulation has been introduced. + +* Three new routines have been added. ALTAZ takes a star's HA,Dec + and produces position, velocity and acceleration for azimuth, + elevation and parallactic angle. PDA2H predicts the HA at which + a given azimuth will be reached. PDQ2H does the same for + position angle. + +* In the OBS routine, the wrong sign was returned for the Perkins + 72 inch telescope at Lowell - fixed. + +* A revised model for the equation of the equinoxes has been + installed in EQEQX, in line with recent IAU resolutions. The + change amounts to less than 3 mas. + +* A bug in DFLTIN has been corrected. A negative number following + an E- or D-format number without intervening spaces lost its + sign. + +* Four stations have been added to OBS: + + TAUTENBERG Tautenberg 1.34 metre Schmidt + PALOMAR48 Palomar 48-inch Schmidt + UKST UK 1.2 metre Schmidt, Siding Spring + KISO Kiso 1.05 metre Schmidt, Japan + ESOSCHMIDT ESO 1 metre Schmidt, La Silla + +* The EARTH and MOON routines could give an integer divide by zero + for years before 1 BC. This has been corrected. + +* CALYD (provided to support the EARTH and MOON routines) has been + upgraded to work outside the interval 1900 March 1 to + 2100 February 28. The status value indicating dates outside that + range has been dropped; a new error value for year before -4711 + has been introduced. + +* A new routine, CLYD, has been added. It is a version of CALYD + without the century-default feature and is to enable 1st-century + dates to be supplied to EARTH and MOON. + +* Two new routines, PLANETS and RDPLAN, have been added, which + compute approximate planetary ephemerides. + +* A new routine, DMOON, implements the same (Meeus) model as the + MOON routine, but in full and in double precision. The time + argument is a straightforward MJD rather than MOON's year and + day-in-year. + +* The REFRO code has been speeded up by a factor of two (and is + also clearer). + +* REFV and REFZ have, in different ways, been made more accurate for + cases close to the horizon. The improvement to REFV is relatively + modest, but REFZ is now capable of delivering useful results for + rise/set phenomena. + +* AOPQK has been speeded up for low-elevation cases. + +* Versions of the tangent-plane routines working directly in x,y,z + instead of spherical coordinates have been added. They may be + faster in some applications. The routines are DV2TP, V2TP, DTP2V, + TP2V, DTPXYZ, TPXYZ. + +* The coordinates of the Australia Telescope Compact Array have been + added to OBS. The name is 'ATCA'. + +* Despite their recent introduction THE ROUTINES DTPRD, DTPXYZ, TPRD + AND TPXYZ HAVE BEEN WITHDRAWN. They have been replaced by the new + routines DTPS2C, DTPV2C, TPS2C and TPV2C. These are functionally + equivalent to the earlier routines but return two solutions instead + of one: the second solution can arise near a pole. + +* The UTC leap second at the end of 1995 has been added to sla_DAT. + +* The refraction routine REFRO has been extensively revised. The + principal motivation was to improve the radio predictions by + introducing better humidity models. The models previously in + use had been entirely adequate for the optical case, for which + they had been devised, but improved models were required for + the radio case. None of the changes significantly affects the + optical results with respect to the earlier version of the REFRO + routine. For example, at 70 deg zenith distance the new version + agrees with the old version to better than 0.05 arcsec for any + reasonable combination of parameters. However, the improved + water-vapour expressions do make a significant difference in the + radio band, at 70 deg zenith distance reaching almost 4 arcsec + for a hot, humid, low-altitude site during a period of low pressure. + +* There was a bug in the (private) C version of RDPLAN. The + answers were unaffected but there could be floating-point + problems on some platforms. + +* A new routine has been added, GMSTA. This gives greater numerical + precision than the existing GMST function by allowing the date and + time to be specified separately rather than as a single MJD. + +* Measures taken in MAPQK to avoid trouble when processing Solar + positions had not been carried through into MAPQKZ. The two + routines now use the same strategy. + +* In REFRO, at zenith distances well beyond 90 deg and under some + conditions, it was possible to encounter arithmetic errors due to + failure of the tropospheric model-atmosphere to deliver sensible + temperatures. This is inherent in the published algorithm. To + avoid the problem, the temperature delivered by the model has been + constrained to the range 200 to 320 deg K. + +* A new routine has been added, ATMDSP, for rapidly recalculating + the A,B refraction coefficients for different wavelengths. + +* The first UTC leap-second date in the DAT routine was one day early. + This will have had no effect on the results for more recent epochs. + +* The C version of OBS had some problems related to character string + handling. A call using the "number" option retured an invalid + station ID, and station ID and name strings of the stipulated 10 + and 40 character lengths were improperly terminated. + +* A new routine, POLMO has been added. This is a specialist tool + to do with Earth polar motion. + +* DC62S and CC62S could give floating point errors if vectors in + unlikely units were supplied. The handling of difficult cases + has been improved. + +* Support for Linux has been added. + +* The C version of REFRO was not re-entrant. It is now; there has + been a small (4%) speed penalty. + +* RANDOM, GRESID and WAIT have been dropped from the C version. They + could not easily be made re-entrant and posed perennial platform- + dependency problems. + +* The value for the arcsec to radians factor in several routines + had an incorrect (and superfluous) 19th digit, which has been + removed. + +* There was a minor bug in DV2TP and V2TP, to do with protection + against the special case where the tangent point is the pole. + +* In OBS, the position of the Parkes radiotelescope has been revised, + and the ATNF Mopra observatory has been added. + +* Two new routines have been added. PAV (single precision) and DPAV + (double precision) are like BEAR and DBEAR but start with direction + cosines rather than spherical coordinates - they return the position + angle of one point with respect to the other. + +* The C version of REFRO still wasn't re-entrant, but is now. + +* The C version of DTF2D used to accept 60.0 in the seconds field; + this has been corrected. + +* The PLANET and RDPLAN routines now include Pluto. The ephemeris + is accurate (sub-arcsecond) but covers the 20th and 21st centuries + only. + + !!! IMPORTANT NOTE !!! + + RDPLAN used to interpret any planet number outside the range 1-8 + as meaning the Sun. The new version uses planet number 9. Existing + programs using 9 for the Sun should be changed to use 0. The rule + has not been changed, except that the range is now 1-9 instead of + 1-8, as it is unlikely that the equivalent problem will arise in the + future. + +* Two new routines have been added, PLANEL and PLANTE. They are + analogues of PLANET and RDPLAN but for the case where orbital + elements are available. They can be used for predicting the + positions of asteroids and comets, and, if up-to-date osculating + elements are supplied, more accurate positions for the major + planets than can be provided through the PLANET and RDPLAN + routines. + +* The REFRO routine could give inaccurate results for low temperatures + (subzero C). This was caused by over-cautious defensive programming, + which prevented the tropospheric temperature falling below 200 K. + +* A new routine has been added, REFCOQ. This calculates the coefficients + of a two-term refraction model. It complements the existing REFCO + routine, being much faster at the expense of some accuracy. + +* The 1997 July 1 UTC leap second has been added to the DAT routine. + +* A bug in the C version of SVD (slaSvd) caused occasional false + indications of ill-conditioning. The results of least-squares + fits do not seem to have been affected. The Fortran version + (sla_SVD) did not have the bug. + +* The Subaru telescope (Japanese National 8-metre telescope, Mauna Kea) + has been added to the OBS routine. + +* The DAT routine has been extended back to the inception of UTC in + 1960. + +* The "earliest date possible" in DJCL was two days out (disagreeing + with DJCAL, which had the correct value). + +* The GMSTA code has been improved. + +* A new routine, PV2EL, takes a heliocentric J2000 equatorial position + and velocity and produces the equivalent set of osculating elements. + +* The 1999 January 1 UTC leap second has been added to the DAT routine. + +* Four new routines have been introduced which transform between the + FK5 system and the ICRS (Hipparcos) system. FK52H and H2FK5 transform + star positions and proper motions from FK5 coordinates to Hipparcos + coordinates and vice versa. FK5HZ and HFK5Z do the same but for the + case where the Hipparcos proper motions are zero. + +* Six new routines have been introduced for dealing with orbital elements. + Four of them (sla_EL2UE, sla_PV2UE, sla_UE2EL and sla_UE2PV) provide + applications with direct access to the "universal variables" method + that was already being used internally. Compared with using conventional + (angular) elements and solving Kepler's equation, the universal variables + approach has a number of advantages, including better handling of near- + parabolic orbits and greater efficiency. The remaining two routines + (sla_PERTEL and sla_PERTUE) generate updated elements by applying + major-planet perturbations. The new elements can then be used to + predict positions that are much more accurate. For minor planets, + sub-arcsecond accuracy over a decade is achievable. + +* Several observatory sites have been added to the OBS routine: CFHT, + Keck 2, Gemini North, FCRAO, IRTF and CSO. The coordinates for all + the Mauna Kea sites have been updated in accordance with recent aerial + photography results made available by the Institute for Astronomy, + University of Hawaii. + +* A coding error in DAT produced incorrect results for dates in the + first 54 days of 1972. + +----------------------------------------------------------------------- + + + P.T.Wallace + + ptw@star.rl.ac.uk + +44-1235-44-5372 diff --git a/math/slalib/doc/refco.hlp b/math/slalib/doc/refco.hlp new file mode 100644 index 00000000..98be6d4c --- /dev/null +++ b/math/slalib/doc/refco.hlp @@ -0,0 +1,54 @@ +.help refco Jun99 "Slalib Package" +.nf + + SUBROUTINE slRFCO (HM, TDK, PMB, RH, WL, PHI, TLR, EPS, + : REFA, REFB) + + - - - - - - + R F C O + - - - - - - + + Determine the constants A and B in the atmospheric refraction + model dZ = A tan Z + B tan**3 Z. + + Z is the "observed" zenith distance (i.e. affected by refraction) + and dZ is what to add to Z to give the "topocentric" (i.e. in vacuo) + zenith distance. + + Given: + HM d height of the observer above sea level (metre) + TDK d ambient temperature at the observer (deg K) + PMB d pressure at the observer (millibar) + RH d relative humidity at the observer (range 0-1) + WL d effective wavelength of the source (micrometre) + PHI d latitude of the observer (radian, astronomical) + TLR d temperature lapse rate in the troposphere (degK/metre) + EPS d precision required to terminate iteration (radian) + + Returned: + REFA d tan Z coefficient (radian) + REFB d tan**3 Z coefficient (radian) + + Called: slRFRO + + Notes: + + 1 Typical values for the TLR and EPS arguments might be 0.0065D0 and + 1D-10 respectively. + + 2 The radio refraction is chosen by specifying WL > 100 micrometres. + + 3 The routine is a slower but more accurate alternative to the + slRFCQ routine. The constants it produces give perfect + agreement with slRFRO at zenith distances arctan(1) (45 deg) + and arctan(4) (about 76 deg). It achieves 0.5 arcsec accuracy + for ZD < 80 deg, 0.01 arcsec accuracy for ZD < 60 deg, and + 0.001 arcsec accuracy for ZD < 45 deg. + + P.T.Wallace Starlink 3 June 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/refcoq.hlp b/math/slalib/doc/refcoq.hlp new file mode 100644 index 00000000..153ed66e --- /dev/null +++ b/math/slalib/doc/refcoq.hlp @@ -0,0 +1,167 @@ +.help refcoq Jun99 "Slalib Package" +.nf + + SUBROUTINE slRFCQ (TDK, PMB, RH, WL, REFA, REFB) + + - - - - - - - + R F C Q + - - - - - - - + + Determine the constants A and B in the atmospheric refraction + model dZ = A tan Z + B tan**3 Z. This is a fast alternative + to the slRFCO routine - see notes. + + Z is the "observed" zenith distance (i.e. affected by refraction) + and dZ is what to add to Z to give the "topocentric" (i.e. in vacuo) + zenith distance. + + Given: + TDK d ambient temperature at the observer (deg K) + PMB d pressure at the observer (millibar) + RH d relative humidity at the observer (range 0-1) + WL d effective wavelength of the source (micrometre) + + Returned: + REFA d tan Z coefficient (radian) + REFB d tan**3 Z coefficient (radian) + + The radio refraction is chosen by specifying WL > 100 micrometres. + + Notes: + + 1 The model is an approximation, for moderate zenith distances, + to the predictions of the slRFRO routine. The approximation + is maintained across a range of conditions, and applies to + both optical/IR and radio. + + 2 The algorithm is a fast alternative to the slRFCO routine. + The latter calls the slRFRO routine itself: this involves + integrations through a model atmosphere, and is costly in + processor time. However, the model which is produced is precisely + correct for two zenith distance (45 degrees and about 76 degrees) + and at other zenith distances is limited in accuracy only by the + A tan Z + B tan**3 Z formulation itself. The present routine + is not as accurate, though it satisfies most practical + requirements. + + 3 The model omits the effects of (i) height above sea level (apart + from the reduced pressure itself), (ii) latitude (i.e. the + flattening of the Earth) and (iii) variations in tropospheric + lapse rate. + + The model was tested using the following range of conditions: + + lapse rates 0.0055, 0.0065, 0.0075 deg/metre + latitudes 0, 25, 50, 75 degrees + heights 0, 2500, 5000 metres ASL + pressures mean for height -10% to +5% in steps of 5% + temperatures -10 deg to +20 deg with respect to 280 deg at SL + relative humidity 0, 0.5, 1 + wavelengths 0.4, 0.6, ... 2 micron, + radio + zenith distances 15, 45, 75 degrees + + The accuracy with respect to direct use of the slRFRO routine + was as follows: + + worst RMS + + optical/IR 62 mas 8 mas + radio 319 mas 49 mas + + For this particular set of conditions: + + lapse rate 0.0065 degK/metre + latitude 50 degrees + sea level + pressure 1005 mB + temperature 280.15 degK + humidity 80% + wavelength 5740 Angstroms + + the results were as follows: + + ZD slRFRO slRFCQ Saastamoinen + + 10 10.27 10.27 10.27 + 20 21.19 21.20 21.19 + 30 33.61 33.61 33.60 + 40 48.82 48.83 48.81 + 45 58.16 58.18 58.16 + 50 69.28 69.30 69.27 + 55 82.97 82.99 82.95 + 60 100.51 100.54 100.50 + 65 124.23 124.26 124.20 + 70 158.63 158.68 158.61 + 72 177.32 177.37 177.31 + 74 200.35 200.38 200.32 + 76 229.45 229.43 229.42 + 78 267.44 267.29 267.41 + 80 319.13 318.55 319.10 + + deg arcsec arcsec arcsec + + The values for Saastamoinen's formula (which includes terms + up to tan^5) are taken from Hohenkerk and Sinclair (1985). + + The results from the much slower but more accurate slRFCO + routine have not been included in the tabulation as they are + identical to those in the slRFRO column to the 0.01 arcsec + resolution used. + + 4 Outlandish input parameters are silently limited to mathematically + safe values. Zero pressure is permissible, and causes zeroes to + be returned. + + 5 The algorithm draws on several sources, as follows: + + a) The formula for the saturation vapour pressure of water as + a function of temperature and temperature is taken from + expressions A4.5-A4.7 of Gill (1982). + + b) The formula for the water vapour pressure, given the + saturation pressure and the relative humidity, is from + Crane (1976), expression 2.5.5. + + c) The refractivity of air is a function of temperature, + total pressure, water-vapour pressure and, in the case + of optical/IR but not radio, wavelength. The formulae + for the two cases are developed from the Essen and Froome + expressions adopted in Resolution 1 of the 12th International + Geodesy Association General Assembly (1963). + + The above three items are as used in the slRFRO routine. + + d) The formula for beta, the ratio of the scale height of the + atmosphere to the geocentric distance of the observer, is + an adaption of expression 9 from Stone (1996). The + adaptations, arrived at empirically, consist of (i) a + small adjustment to the coefficient and (ii) a humidity + term for the radio case only. + + e) The formulae for the refraction constants as a function of + n-1 and beta are from Green (1987), expression 4.31. + + References: + + Crane, R.K., Meeks, M.L. (ed), "Refraction Effects in the Neutral + Atmosphere", Methods of Experimental Physics: Astrophysics 12B, + Academic Press, 1976. + + Gill, Adrian E., "Atmosphere-Ocean Dynamics", Academic Press, 1982. + + Hohenkerk, C.Y., & Sinclair, A.T., NAO Technical Note No. 63, 1985. + + International Geodesy Association General Assembly, Bulletin + Geodesique 70 p390, 1963. + + Stone, Ronald C., P.A.S.P. 108 1051-1058, 1996. + + Green, R.M., "Spherical Astronomy", Cambridge University Press, 1987. + + P.T.Wallace Starlink 4 June 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/refro.hlp b/math/slalib/doc/refro.hlp new file mode 100644 index 00000000..8b66c95d --- /dev/null +++ b/math/slalib/doc/refro.hlp @@ -0,0 +1,123 @@ +.help refro Jun99 "Slalib Package" +.nf + + SUBROUTINE slRFRO (ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, + : EPS, REF) + + - - - - - - + R F R O + - - - - - - + + Atmospheric refraction for radio and optical/IR wavelengths. + + Given: + ZOBS d observed zenith distance of the source (radian) + HM d height of the observer above sea level (metre) + TDK d ambient temperature at the observer (deg K) + PMB d pressure at the observer (millibar) + RH d relative humidity at the observer (range 0-1) + WL d effective wavelength of the source (micrometre) + PHI d latitude of the observer (radian, astronomical) + TLR d temperature lapse rate in the troposphere (degK/metre) + EPS d precision required to terminate iteration (radian) + + Returned: + REF d refraction: in vacuo ZD minus observed ZD (radian) + + Notes: + + 1 A suggested value for the TLR argument is 0.0065D0. The + refraction is significantly affected by TLR, and if studies + of the local atmosphere have been carried out a better TLR + value may be available. + + 2 A suggested value for the EPS argument is 1D-8. The result is + usually at least two orders of magnitude more computationally + precise than the supplied EPS value. + + 3 The routine computes the refraction for zenith distances up + to and a little beyond 90 deg using the method of Hohenkerk + and Sinclair (NAO Technical Notes 59 and 63, subsequently adopted + in the Explanatory Supplement, 1992 edition - see section 3.281). + + 4 The code is a development of the optical/IR refraction subroutine + AREF of C.Hohenkerk (HMNAO, September 1984), with extensions to + support the radio case. Apart from merely cosmetic changes, the + following modifications to the original HMNAO optical/IR refraction + code have been made: + + . The angle arguments have been changed to radians. + + . Any value of ZOBS is allowed (see note 6, below). + + . Other argument values have been limited to safe values. + + . Murray's values for the gas constants have been used + (Vectorial Astrometry, Adam Hilger, 1983). + + . The numerical integration phase has been rearranged for + extra clarity. + + . A better model for Ps(T) has been adopted (taken from + Gill, Atmosphere-Ocean Dynamics, Academic Press, 1982). + + . More accurate expressions for Pwo have been adopted + (again from Gill 1982). + + . Provision for radio wavelengths has been added using + expressions devised by A.T.Sinclair, RGO (private + communication 1989), based on the Essen & Froome + refractivity formula adopted in Resolution 1 of the + 13th International Geodesy Association General Assembly + (Bulletin Geodesique 70 p390, 1963). + + . Various small changes have been made to gain speed. + + None of the changes significantly affects the optical/IR results + with respect to the algorithm given in the 1992 Explanatory + Supplement. For example, at 70 deg zenith distance the present + routine agrees with the ES algorithm to better than 0.05 arcsec + for any reasonable combination of parameters. However, the + improved water-vapour expressions do make a significant difference + in the radio band, at 70 deg zenith distance reaching almost + 4 arcsec for a hot, humid, low-altitude site during a period of + low pressure. + + 5 The radio refraction is chosen by specifying WL > 100 micrometres. + Because the algorithm takes no account of the ionosphere, the + accuracy deteriorates at low frequencies, below about 30 MHz. + + 6 Before use, the value of ZOBS is expressed in the range +/- pi. + If this ranged ZOBS is -ve, the result REF is computed from its + absolute value before being made -ve to match. In addition, if + it has an absolute value greater than 93 deg, a fixed REF value + equal to the result for ZOBS = 93 deg is returned, appropriately + signed. + + 7 As in the original Hohenkerk and Sinclair algorithm, fixed values + of the water vapour polytrope exponent, the height of the + tropopause, and the height at which refraction is negligible are + used. + + 8 The radio refraction has been tested against work done by + Iain Coulson, JACH, (private communication 1995) for the + James Clerk Maxwell Telescope, Mauna Kea. For typical conditions, + agreement at the 0.1 arcsec level is achieved for moderate ZD, + worsening to perhaps 0.5-1.0 arcsec at ZD 80 deg. At hot and + humid sea-level sites the accuracy will not be as good. + + 9 It should be noted that the relative humidity RH is formally + defined in terms of "mixing ratio" rather than pressures or + densities as is often stated. It is the mass of water per unit + mass of dry air divided by that for saturated air at the same + temperature and pressure (see Gill 1982). + + Called: slDA1P, slATMT, slATMS + + P.T.Wallace Starlink 3 June 1997 + + Copyright (C) 1997 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/refv.hlp b/math/slalib/doc/refv.hlp new file mode 100644 index 00000000..104736a5 --- /dev/null +++ b/math/slalib/doc/refv.hlp @@ -0,0 +1,79 @@ +.help refv Jun99 "Slalib Package" +.nf + + SUBROUTINE slREFV (VU, REFA, REFB, VR) + + - - - - - + R E F V + - - - - - + + Adjust an unrefracted Cartesian vector to include the effect of + atmospheric refraction, using the simple A tan Z + B tan**3 Z + model. + + Given: + VU dp unrefracted position of the source (Az/El 3-vector) + REFA dp tan Z coefficient (radian) + REFB dp tan**3 Z coefficient (radian) + + Returned: + VR dp refracted position of the source (Az/El 3-vector) + + Notes: + + 1 This routine applies the adjustment for refraction in the + opposite sense to the usual one - it takes an unrefracted + (in vacuo) position and produces an observed (refracted) + position, whereas the A tan Z + B tan**3 Z model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the algorithm used here is equivalent to + one iteration of the Newton-Raphson method applied to the above + formula. + + 2 Though optimized for speed rather than precision, the present + routine achieves consistency with the refracted-to-unrefracted + A tan Z + B tan**3 Z model at better than 1 micro-arcsecond within + 30 degrees of the zenith and remains within 1 milliarcsecond to + beyond ZD 70 degrees. The inherent accuracy of the model is, of + course, far worse than this - see the documentation for slRFCO + for more information. + + 3 At low elevations (below about 3 degrees) the refraction + correction is held back to prevent arithmetic problems and + wildly wrong results. Over a wide range of observer heights + and corresponding temperatures and pressures, the following + levels of accuracy (arcsec) are achieved, relative to numerical + integration through a model atmosphere: + + ZD error + + 80 0.4 + 81 0.8 + 82 1.6 + 83 3 + 84 7 + 85 17 + 86 45 + 87 150 + 88 340 + 89 620 + 90 1100 + 91 1900 } relevant only to + 92 3200 } high-elevation sites + + 4 See also the routine slREFZ, which performs the adjustment to + the zenith distance rather than in Cartesian Az/El coordinates. + The present routine is faster than slREFZ and, except very low down, + is equally accurate for all practical purposes. However, beyond + about ZD 84 degrees slREFZ should be used, and for the utmost + accuracy iterative use of slRFRO should be considered. + + P.T.Wallace Starlink 26 December 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/refz.hlp b/math/slalib/doc/refz.hlp new file mode 100644 index 00000000..5c91ab03 --- /dev/null +++ b/math/slalib/doc/refz.hlp @@ -0,0 +1,78 @@ +.help refz Jun99 "Slalib Package" +.nf + + SUBROUTINE slREFZ (ZU, REFA, REFB, ZR) + + - - - - - + R E F Z + - - - - - + + Adjust an unrefracted zenith distance to include the effect of + atmospheric refraction, using the simple A tan Z + B tan**3 Z + model (plus special handling for large ZDs). + + Given: + ZU dp unrefracted zenith distance of the source (radian) + REFA dp tan Z coefficient (radian) + REFB dp tan**3 Z coefficient (radian) + + Returned: + ZR dp refracted zenith distance (radian) + + Notes: + + 1 This routine applies the adjustment for refraction in the + opposite sense to the usual one - it takes an unrefracted + (in vacuo) position and produces an observed (refracted) + position, whereas the A tan Z + B tan**3 Z model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the formula used here is based on the + Newton-Raphson method. For the utmost numerical consistency + with the refracted to unrefracted model, two iterations are + carried out, achieving agreement at the 1D-11 arcseconds level + for a ZD of 80 degrees. The inherent accuracy of the model + is, of course, far worse than this - see the documentation for + slRFCO for more information. + + 2 At ZD 83 degrees, the rapidly-worsening A tan Z + B tan**3 Z + model is abandoned and an empirical formula takes over. Over a + wide range of observer heights and corresponding temperatures and + pressures, the following levels of accuracy (arcsec) are + typically achieved, relative to numerical integration through a + model atmosphere: + + ZR error + + 80 0.4 + 81 0.8 + 82 1.5 + 83 3.2 + 84 4.9 + 85 5.8 + 86 6.1 + 87 7.1 + 88 10 + 89 20 + 90 40 + 91 100 } relevant only to + 92 200 } high-elevation sites + + The high-ZD model is scaled to match the normal model at the + transition point; there is no glitch. + + 3 Beyond 93 deg zenith distance, the refraction is held at its + 93 deg value. + + 4 See also the routine slREFV, which performs the adjustment in + Cartesian Az/El coordinates, and with the emphasis on speed + rather than numerical accuracy. + + P.T.Wallace Starlink 19 September 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rverot.hlp b/math/slalib/doc/rverot.hlp new file mode 100644 index 00000000..5f61abd7 --- /dev/null +++ b/math/slalib/doc/rverot.hlp @@ -0,0 +1,40 @@ +.help rverot Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRVER (PHI, RA, DA, ST) + + - - - - - - - + R V E R + - - - - - - - + + Velocity component in a given direction due to Earth rotation + (single precision) + + Given: + PHI real latitude of observing station (geodetic) + RA,DA real apparent RA,DEC + ST real local apparent sidereal time + + PHI, RA, DEC and ST are all in radians. + + Result: + Component of Earth rotation in direction RA,DA (km/s) + + Sign convention: + The result is +ve when the observatory is receding from the + given point on the sky. + + Accuracy: + The simple algorithm used assumes a spherical Earth, of + a radius chosen to give results accurate to about 0.0005 km/s + for observing stations at typical latitudes and heights. For + applications requiring greater precision, use the routine + slPVOB. + + P.T.Wallace Starlink 20 July 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rvgalc.hlp b/math/slalib/doc/rvgalc.hlp new file mode 100644 index 00000000..b0e2773e --- /dev/null +++ b/math/slalib/doc/rvgalc.hlp @@ -0,0 +1,42 @@ +.help rvgalc Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRVGA (R2000, D2000) + + - - - - - - - + R V G A + - - - - - - - + + Velocity component in a given direction due to the rotation + of the Galaxy (single precision) + + Given: + R2000,D2000 real J2000.0 mean RA,Dec (radians) + + Result: + Component of dynamical LSR motion in direction R2000,D2000 (km/s) + + Sign convention: + The result is +ve when the dynamical LSR is receding from the + given point on the sky. + + Note: The Local Standard of Rest used here is a point in the + vicinity of the Sun which is in a circular orbit around + the Galactic centre. Sometimes called the "dynamical" LSR, + it is not to be confused with a "kinematical" LSR, which + is the mean standard of rest of star catalogues or stellar + populations. + + Reference: The orbital speed of 220 km/s used here comes from + Kerr & Lynden-Bell (1986), MNRAS, 221, p1023. + + Called: + slCS2C, slVDV + + P.T.Wallace Starlink 23 March 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rvlg.hlp b/math/slalib/doc/rvlg.hlp new file mode 100644 index 00000000..e333c1e4 --- /dev/null +++ b/math/slalib/doc/rvlg.hlp @@ -0,0 +1,36 @@ +.help rvlg Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRVLG (R2000, D2000) + + - - - - - + R V L G + - - - - - + + Velocity component in a given direction due to the combination + of the rotation of the Galaxy and the motion of the Galaxy + relative to the mean motion of the local group (single precision) + + Given: + R2000,D2000 real J2000.0 mean RA,Dec (radians) + + Result: + Component of SOLAR motion in direction R2000,D2000 (km/s) + + Sign convention: + The result is +ve when the Sun is receding from the + given point on the sky. + + Reference: + IAU Trans 1976, 168, p201. + + Called: + slCS2C, slVDV + + P.T.Wallace Starlink June 1985 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rvlsrd.hlp b/math/slalib/doc/rvlsrd.hlp new file mode 100644 index 00000000..f7539867 --- /dev/null +++ b/math/slalib/doc/rvlsrd.hlp @@ -0,0 +1,51 @@ +.help rvlsrd Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRVLD (R2000, D2000) + + - - - - - - - + R V L D + - - - - - - - + + Velocity component in a given direction due to the Sun's motion + with respect to the dynamical Local Standard of Rest. + + (single precision) + + Given: + R2000,D2000 r J2000.0 mean RA,Dec (radians) + + Result: + Component of "peculiar" solar motion in direction R2000,D2000 (km/s) + + Sign convention: + The result is +ve when the Sun is receding from the given point on + the sky. + + Note: The Local Standard of Rest used here is the "dynamical" LSR, + a point in the vicinity of the Sun which is in a circular + orbit around the Galactic centre. The Sun's motion with + respect to the dynamical LSR is called the "peculiar" solar + motion. + + There is another type of LSR, called a "kinematical" LSR. A + kinematical LSR is the mean standard of rest of specified star + catalogues or stellar populations, and several slightly + different kinematical LSRs are in use. The Sun's motion with + respect to an agreed kinematical LSR is known as the "standard" + solar motion. To obtain a radial velocity correction with + respect to an adopted kinematical LSR use the routine slRVLK. + + Reference: Delhaye (1965), in "Stars and Stellar Systems", vol 5, + p73. + + Called: + slCS2C, slVDV + + P.T.Wallace Starlink 9 March 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/rvlsrk.hlp b/math/slalib/doc/rvlsrk.hlp new file mode 100644 index 00000000..04cbca89 --- /dev/null +++ b/math/slalib/doc/rvlsrk.hlp @@ -0,0 +1,50 @@ +.help rvlsrk Jun99 "Slalib Package" +.nf + + REAL FUNCTION slRVLK (R2000, D2000) + + - - - - - - - + R V L K + - - - - - - - + + Velocity component in a given direction due to the Sun's motion + with respect to an adopted kinematic Local Standard of Rest. + + (single precision) + + Given: + R2000,D2000 r J2000.0 mean RA,Dec (radians) + + Result: + Component of "standard" solar motion in direction R2000,D2000 (km/s) + + Sign convention: + The result is +ve when the Sun is receding from the given point on + the sky. + + Note: The Local Standard of Rest used here is one of several + "kinematical" LSRs in common use. A kinematical LSR is the + mean standard of rest of specified star catalogues or stellar + populations. The Sun's motion with respect to a kinematical + LSR is known as the "standard" solar motion. + + There is another sort of LSR, the "dynamical" LSR, which is a + point in the vicinity of the Sun which is in a circular orbit + around the Galactic centre. The Sun's motion with respect to + the dynamical LSR is called the "peculiar" solar motion. To + obtain a radial velocity correction with respect to the + dynamical LSR use the routine slRVLD. + + Reference: Delhaye (1965), in "Stars and Stellar Systems", vol 5, + p73. + + Called: + slCS2C, slVDV + + P.T.Wallace Starlink 11 March 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/s2tp.hlp b/math/slalib/doc/s2tp.hlp new file mode 100644 index 00000000..fb92a6f9 --- /dev/null +++ b/math/slalib/doc/s2tp.hlp @@ -0,0 +1,31 @@ +.help s2tp Jun99 "Slalib Package" +.nf + + SUBROUTINE slS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J) + + - - - - - + S 2 T P + - - - - - + + Projection of spherical coordinates onto tangent plane: + "gnomonic" projection - "standard coordinates" + (single precision) + + Given: + RA,DEC real spherical coordinates of point to be projected + RAZ,DECZ real spherical coordinates of tangent point + + Returned: + XI,ETA real rectangular coordinates on tangent plane + J int status: 0 = OK, star on tangent plane + 1 = error, star too far from axis + 2 = error, antistar on tangent plane + 3 = error, antistar too far from axis + + P.T.Wallace Starlink 18 July 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/sedscript b/math/slalib/doc/sedscript new file mode 100755 index 00000000..3797f980 --- /dev/null +++ b/math/slalib/doc/sedscript @@ -0,0 +1,35 @@ +#!/bin/csh + +# EZSEDSCRIPT -- Script for automatically creating simple help for the +# SLALIB FORTRAN routines. +# +# First argument $1 is the month and year combined, e.g. Jun84 + +foreach file (../*.f) + set rootfile = `basename $file .f` + set package = '"Slalib Package"' + set outfile = $rootfile.hlp + set d = `echo \$d` + set s = `echo \$s` + echo $outfile + echo "1i\\ +.help $rootfile $1 $package\\ +.nf\\ +\ +/^\*-/a\\ +\\ +.fi\\ +.endhelp\ +/^\*-/,$d\ +1,$s/^*+//\ +1,$s/^*//" > tmpfile + sed -f tmpfile $file > $outfile + rm tmpfile +end + +rm atms.hlp +rm atmt.hlp +rm idchf.hlp +rm idchi.hlp +rm sla_test.hlp +cp slalib.hlp.sav slalib.hlp diff --git a/math/slalib/doc/sep.hlp b/math/slalib/doc/sep.hlp new file mode 100644 index 00000000..71808737 --- /dev/null +++ b/math/slalib/doc/sep.hlp @@ -0,0 +1,29 @@ +.help sep Jun99 "Slalib Package" +.nf + + REAL FUNCTION slSEP (A1, B1, A2, B2) + + - - - - + S E P + - - - - + + Angle between two points on a sphere (single precision) + + Given: + A1,B1 real spherical coordinates of one point + A2,B2 real spherical coordinates of the other point + + (The spherical coordinates are RA,Dec, Long,Lat etc, in radians.) + + The result is the angle, in radians, between the two points. It + is always positive. + + Called: slCS2C + + P.T.Wallace Starlink April 1985 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/sla.news b/math/slalib/doc/sla.news new file mode 100644 index 00000000..541b6c8a --- /dev/null +++ b/math/slalib/doc/sla.news @@ -0,0 +1,36 @@ +SLALIB_Version_2.3-0 Expiry 30 September 1999 + +The latest releases of SLALIB include the following changes: + +* The 1999 January 1 UTC leap second has been added to the DAT routine. + +* Four new routines have been introduced which transform between the + FK5 system and the ICRS (Hipparcos) system. FK52H and H2FK5 transform + star positions and proper motions from FK5 coordinates to Hipparcos + coordinates and vice versa. FK5HZ and HFK5Z do the same but for the + case where the Hipparcos proper motions are zero. + +* Six new routines have been introduced for dealing with orbital elements. + Four of them (sla_EL2UE, sla_PV2UE, sla_UE2EL and sla_UE2PV) provide + applications with direct access to the "universal variables" method + that was already being used internally. Compared with using conventional + (angular) elements and solving Kepler's equation, the universal variables + approach has a number of advantages, including better handling of near- + parabolic orbits and greater efficiency. The remaining two routines + (sla_PERTEL and sla_PERTUE) generate updated elements by applying + major-planet perturbations. The new elements can then be used to + predict positions that are much more accurate. For minor planets, + sub-arcsecond accuracy over a decade is achievable. + +* Several observatory sites have been added to the OBS routine: CFHT, + Keck 2, Gemini North, FCRAO, IRTF and CSO. The coordinates for all + the Mauna Kea sites have been updated in accordance with recent aerial + photography results made available by the Institute for Astronomy, + University of Hawaii. + + P.T.Wallace + 21 April 1999 + + ptw@star.rl.ac.uk + +44-1235-44-5372 +-------------------------------------------------------------------------- diff --git a/math/slalib/doc/slalib.hd b/math/slalib/doc/slalib.hd new file mode 100644 index 00000000..35fe8ea0 --- /dev/null +++ b/math/slalib/doc/slalib.hd @@ -0,0 +1,183 @@ +# Help directory the SLALIB library + +$slalib = "math$slalib/" + +addet hlp=addet.hlp, src=slalib$addet.f +afin hlp=afin.hlp, src=slalib$afin.f +airmas hlp=airmas.hlp, src=slalib$airmas.f +altaz hlp=altaz.hlp, src=slalib$altaz.f +amp hlp=amp.hlp, src=slalib$amp.f +ampqk hlp=ampqk.hlp, src=slalib$ampqk.f +aop hlp=aop.hlp, src=slalib$aop.f +aoppa hlp=aoppa.hlp, src=slalib$aoppa.f +aoppat hlp=aoppat.hlp, src=slalib$aoppat.f +aopqk hlp=aopqk.hlp, src=slalib$aopqk.f +atmdsp hlp=atmdsp.hlp, src=slalib$atmdsp.f +av2m hlp=av2m.hlp, src=slalib$av2m.f +bear hlp=bear.hlp, src=slalib$bear.f +caf2r hlp=caf2r.hlp, src=slalib$caf2r.f +caldj hlp=caldj.hlp, src=slalib$caldj.f +calyd hlp=calyd.hlp, src=slalib$calyd.f +cc2s hlp=cc2s.hlp, src=slalib$cc2s.f +cc62s hlp=cc62s.hlp, src=slalib$cc62s.f +cd2tf hlp=cd2tf.hlp, src=slalib$cd2tf.f +cldj hlp=cldj.hlp, src=slalib$cldj.f +clyd hlp=clyd.hlp, src=slalib$clyd.f +cr2af hlp=cr2af.hlp, src=slalib$cr2af.f +cr2tf hlp=cr2tf.hlp, src=slalib$cr2tf.f +cs2c hlp=cs2c.hlp, src=slalib$cs2c.f +cs2c6 hlp=cs2c6.hlp, src=slalib$cs2c6.f +ctf2d hlp=ctf2d.hlp, src=slalib$ctf2d.f +ctf2r hlp=ctf2r.hlp, src=slalib$ctf2r.f +daf2r hlp=daf2r.hlp, src=slalib$daf2r.f +dafin hlp=dafin.hlp, src=slalib$dafin.f +dat hlp=dat.hlp, src=slalib$dat.f +dav2m hlp=dav2m.hlp, src=slalib$dav2m.f +dbear hlp=dbear.hlp, src=slalib$dbear.f +dbjin hlp=dbjin.hlp, src=slalib$dbjin.f +dc62s hlp=dc62s.hlp, src=slalib$dc62s.f +dcc2s hlp=dcc2s.hlp, src=slalib$dcc2s.f +dcmpf hlp=dcmpf.hlp, src=slalib$dcmpf.f +dcs2c hlp=dcs2c.hlp, src=slalib$dcs2c.f +dd2tf hlp=dd2tf.hlp, src=slalib$dd2tf.f +de2h hlp=de2h.hlp, src=slalib$de2h.f +deuler hlp=deuler.hlp, src=slalib$deuler.f +dfltin hlp=dfltin.hlp, src=slalib$dfltin.f +dh2e hlp=dh2e.hlp, src=slalib$dh2e.f +dimxv hlp=dimxv.hlp, src=slalib$dimxv.f +djcal hlp=djcal.hlp, src=slalib$djcal.f +djcl hlp=djcl.hlp, src=slalib$djcl.f +dm2av hlp=dm2av.hlp, src=slalib$dm2av.f +dmat hlp=dmat.hlp, src=slalib$dmat.f +dmoon hlp=dmoon.hlp, src=slalib$dmoon.f +dmxm hlp=dmxm.hlp, src=slalib$dmxm.f +dmxv hlp=dmxv.hlp, src=slalib$dmxv.f +dpav hlp=dpav.hlp, src=slalib$dpav.f +dr2af hlp=dr2af.hlp, src=slalib$dr2af.f +dr2tf hlp=dr2tf.hlp, src=slalib$dr2tf.f +drange hlp=drange.hlp, src=slalib$drange.f +dranrm hlp=dranrm.hlp, src=slalib$dranrm.f +ds2c6 hlp=ds2c6.hlp, src=slalib$ds2c6.f +ds2tp hlp=ds2tp.hlp, src=slalib$ds2tp.f +dsep hlp=dsep.hlp, src=slalib$dsep.f +dt hlp=dt.hlp, src=slalib$dt.f +dtf2d hlp=dtf2d.hlp, src=slalib$dtf2d.f +dtf2r hlp=dtf2r.hlp, src=slalib$dtf2r.f +dtp2s hlp=dtp2s.hlp, src=slalib$dtp2s.f +dtp2v hlp=dtp2v.hlp, src=slalib$dtp2v.f +dtps2c hlp=dtps2c.hlp, src=slalib$dtps2c.f +dtpv2c hlp=dtpv2c.hlp, src=slalib$dtpv2c.f +dtt hlp=dtt.hlp, src=slalib$dtt.f +dv2tp hlp=dv2tp.hlp, src=slalib$dv2tp.f +dvdv hlp=dvdv.hlp, src=slalib$dvdv.f +dvn hlp=dvn.hlp, src=slalib$dvn.f +dvxv hlp=dvxv.hlp, src=slalib$dvxv.f +e2h hlp=e2h.hlp, src=slalib$e2h.f +earth hlp=earth.hlp, src=slalib$earth.f +ecleq hlp=ecleq.hlp, src=slalib$ecleq.f +ecmat hlp=ecmat.hlp, src=slalib$ecmat.f +ecor hlp=ecor.hlp, src=slalib$ecor.f +eg50 hlp=eg50.hlp, src=slalib$eg50.f +el2ue hlp=el2ue.hlp, src=slalib$el2ue.f +epb hlp=epb.hlp, src=slalib$epb.f +epb2d hlp=epb2d.hlp, src=slalib$epb2d.f +epco hlp=epco.hlp, src=slalib$epco.f +epj hlp=epj.hlp, src=slalib$epj.f +epj2d hlp=epj2d.hlp, src=slalib$epj2d.f +eqecl hlp=eqecl.hlp, src=slalib$eqecl.f +eqeqx hlp=eqeqx.hlp, src=slalib$eqeqx.f +eqgal hlp=eqgal.hlp, src=slalib$eqgal.f +etrms hlp=etrms.hlp, src=slalib$etrms.f +euler hlp=euler.hlp, src=slalib$euler.f +evp hlp=evp.hlp, src=slalib$evp.f +fitxy hlp=fitxy.hlp, src=slalib$fitxy.f +fk425 hlp=fk425.hlp, src=slalib$fk425.f +fk45z hlp=fk45z.hlp, src=slalib$fk45z.f +fk524 hlp=fk524.hlp, src=slalib$fk524.f +fk54z hlp=fk54z.hlp, src=slalib$fk54z.f +fk52h hlp=fk52h.hlp, src=slalib$fk52h.f +fk5hz hlp=fk5hz.hlp, src=slalib$fk5hz.f +flotin hlp=flotin.hlp, src=slalib$flotin.f +galeq hlp=galeq.hlp, src=slalib$galeq.f +galsup hlp=galsup.hlp, src=slalib$galsup.f +ge50 hlp=ge50.hlp, src=slalib$ge50.f +geoc hlp=geoc.hlp, src=slalib$geoc.f +gmst hlp=gmst.hlp, src=slalib$gmst.f +gmsta hlp=gmsta.hlp, src=slalib$gmsta.f +h2e hlp=h2e.hlp, src=slalib$h2e.f +h2fk5 hlp=h2fk5.hlp, src=slalib$h2fk5.f +hfk5z hlp=hfk5z.hlp, src=slalib$hfk5z.f +imxv hlp=imxv.hlp, src=slalib$imxv.f +intin hlp=intin.hlp, src=slalib$intin.f +invf hlp=invf.hlp, src=slalib$invf.f +kbj hlp=kbj.hlp, src=slalib$kbj.f +m2av hlp=m2av.hlp, src=slalib$m2av.f +map hlp=map.hlp, src=slalib$map.f +mappa hlp=mappa.hlp, src=slalib$mappa.f +mapqk hlp=mapqk.hlp, src=slalib$mapqk.f +mapqkz hlp=mapqkz.hlp, src=slalib$mapqkz.f +moon hlp=moon.hlp, src=slalib$moon.f +mxm hlp=mxm.hlp, src=slalib$mxm.f +mxv hlp=mxv.hlp, src=slalib$mxv.f +nut hlp=nut.hlp, src=slalib$nut.f +nutc hlp=nutc.hlp, src=slalib$nutc.f +oap hlp=oap.hlp, src=slalib$oap.f +oapqk hlp=oapqk.hlp, src=slalib$oapqk.f +obs hlp=obs.hlp, src=slalib$obs.f +pa hlp=pa.hlp, src=slalib$pa.f +pav hlp=pav.hlp, src=slalib$pav.f +pcd hlp=pcd.hlp, src=slalib$pcd.f +pda2h hlp=pda2h.hlp, src=slalib$pda2h.f +pdq2h hlp=pdq2h.hlp, src=slalib$pdq2h.f +pertel hlp=pertel.hlp, src=slalib$pertel.f +pertue hlp=pertue.hlp, src=slalib$pertue.f +planel hlp=planel.hlp, src=slalib$planel.f +planet hlp=planet.hlp, src=slalib$planet.f +plante hlp=plante.hlp, src=slalib$plante.f +pm hlp=pm.hlp, src=slalib$pm.f +polmo hlp=polmo.hlp, src=slalib$polmo.f +prebn hlp=prebn.hlp, src=slalib$prebn.f +prec hlp=prec.hlp, src=slalib$prec.f +preces hlp=preces.hlp, src=slalib$preces.f +precl hlp=precl.hlp, src=slalib$precl.f +precss hlp=precss.hlp, src=slalib$precss.f +prenut hlp=prenut.hlp, src=slalib$prenut.f +pv2ue hlp=pv2ue.hlp, src=slalib$pv2ue.f +pv2el hlp=pv2el.hlp, src=slalib$pv2el.f +pvobs hlp=pvobs.hlp, src=slalib$pvobs.f +pxy hlp=pxy.hlp, src=slalib$pxy.f +range hlp=range.hlp, src=slalib$range.f +ranorm hlp=ranorm.hlp, src=slalib$ranorm.f +rcc hlp=rcc.hlp, src=slalib$rcc.f +rdplan hlp=rdplan.hlp, src=slalib$rdplan.f +refco hlp=refco.hlp, src=slalib$refco.f +refcoq hlp=refcoq.hlp, src=slalib$refcoq.f +refro hlp=refro.hlp, src=slalib$refro.f +refv hlp=refv.hlp, src=slalib$refv.f +refz hlp=refz.hlp, src=slalib$refz.f +rverot hlp=rverot.hlp, src=slalib$rverot.f +rvgalc hlp=rvgalc.hlp, src=slalib$rvgalc.f +rvlg hlp=rvlg.hlp, src=slalib$rvlg.f +rvlsrd hlp=rvlsrd.hlp, src=slalib$rvlsrd.f +rvlsrk hlp=rvlsrk.hlp, src=slalib$rvlsrk.f +s2tp hlp=s2tp.hlp, src=slalib$s2tp.f +sep hlp=sep.hlp, src=slalib$sep.f +smat hlp=smat.hlp, src=slalib$smat.f +subet hlp=subet.hlp, src=slalib$subet.f +supgal hlp=supgal.hlp, src=slalib$supgal.f +svd hlp=svd.hlp, src=slalib$svd.f +svdcov hlp=svdcov.hlp, src=slalib$svdcov.f +svdsol hlp=svdsol.hlp, src=slalib$svdsol.f +tp2s hlp=tp2s.hlp, src=slalib$tp2s.f +tp2v hlp=tp2v.hlp, src=slalib$tp2v.f +tps2c hlp=tps2c.hlp, src=slalib$tps2c.f +tpv2c hlp=tpv2c.hlp, src=slalib$tpv2c.f +ue2el hlp=ue2el.hlp, src=slalib$ue2el.f +ue2pv hlp=ue2pv.hlp, src=slalib$ue2pv.f +unpcd hlp=unpcd.hlp, src=slalib$unpcd.f +v2tp hlp=v2tp.hlp, src=slalib$v2tp.f +vdv hlp=vdv.hlp, src=slalib$vdv.f +vn hlp=vn.hlp, src=slalib$vn.f +vxv hlp=vxv.hlp, src=slalib$vxv.f +xy2xy hlp=xy2xy.hlp, src=slalib$xy2xy.f +zd hlp=zd.hlp, src=slalib$zd.f diff --git a/math/slalib/doc/slalib.hlp b/math/slalib/doc/slalib.hlp new file mode 100644 index 00000000..8da465cf --- /dev/null +++ b/math/slalib/doc/slalib.hlp @@ -0,0 +1,591 @@ +.help slalib Nov95 "Immatch Package" +.ih +NAME +slalib -- Starlink library of positional astronomy routines + +.ih +DESCRIPTION +SLALIB is a library of Fortran 77 routines intended to make accurate +and reliable positional-astronomy applications easier to write. Most +SLALIB library routines are concerned with astronomical position and time, +but a number have wider trigonometrical, numerical or general applications. +SLALIB contains routines covering the following topics: 1) string +decoding and sexagesimal conversions, 2) angles, vectors and rotation +matrices, 3) calendars and timescales, 4) precession and nutation, 5) +proper motion, 6) FK4/5 and elliptic aberration, 7) geocentric coordinates, +8) apparent and observed place, 9) azimuth and elevation, 10) refraction +and air mass, 11) ecliptic, galactic, and supergalactic coordinates, +12) ephemerides, 13) astrometry, and 14) numerical methods. + +The labels and calling sequences of the SLALIB are listed below grouped +by function. To get more detailed help on any individual routine type +the help command followed by the label, e.g the command "help flotin" +will give detailed help on the subroutine slrfli. + +.ih +STRING DECODING +.nf + intin -- call subroutine slinti (string, nstrt, ireslt, jflag) + Convert free-format string into integer + +flotin -- call subroutine slrfli (string, nstrt, reslt, jflag) +dfltin -- call subroutine sldfli (string, nstrt, dreslt, jflag) + Convert free-format string into floating point number + + afin -- call subroutine slafin (string, iptr, a, j) + dafin -- call subroutine sldafn (string, iptr, a, j) + Convert free-format string from deg, armin, arcsec to radians +.fi +.ih +SEXAGESIMAL CONVERSIONS +.nf + ctf2d -- call subroutine slctfd (ihour, imin, sec, days, j) + dtf2d -- call subroutine sldtfd (ihour, imin, sec, days, j) + Hours, minutes, seconds to days + + cd2tf -- call subroutine slcdtf (ndp, days, sign, ihmsf) + dd2tf -- call subroutine slddtf (ndp, days, sign, ihmsf) + Days to hours, minutes, and seconds + + ctf2r -- call subroutine slctfr (ihour, imin, sec, rad, j) + dtf2r -- call subroutine sldtfr (ihour, imin, sec, rad, j) + Hours, minutes, seconds to radians + + cr2tf -- call subroutine slcrtf (ndp, angle, sign, ihmsf) + dr2tf -- call subroutine sldrtf (ndp, angle, sign, ihmsf) + Radians to hours, minutes, seconds + + caf2r -- call subroutine slcafr (ideg, iamin, asec, rad, j) + daf2r -- call subroutine sldafr (ideg, iamin, asec, rad, j) + Degrees, arcminutes, arcseconds to radians + + cr2af -- call subroutine slcraf (ndp, angle, sign, idmsf) + dr2af -- call subroutine sldraf (ndp, angle, sign, idmsf) + Radians to degrees, arcminutes, arcseconds +.fi +.ih +ANGLES, VECTORS AND ROTATION MATRICES +.nf + range -- r = slra1p (angle) +drange -- d = slda1p (angle) + Normalize angle into range [-pi,pi] + +ranorm -- r = slra2p (angle) +dranrm -- d = slda2p (angle) + Normalize angle into range [0,2pi] + + cs2c -- call subroutine slcs2c (a, b, v) + dcs2c -- call subroutine slds2c (a, b, v) + Spherical coordinates to [x,y,z] + + cc2s -- call subroutine slcc2s (v, a, b) + dcc2s -- call subroutine sldc2s (v, a, b) + [x,y,z] to spherical coordinates + + vdv -- r = slvdv (va, vb) + dvdv -- d = sldvdv (va, vb) + Scalar product of two 3-vectors + + vxv -- call subroutine slvxv (va, vb, vc) + dvxv -- call subroutine sldvxv (va, vb, vc) + Vector product of two 3-vectors + + vn -- call subroutine slvn (v, uv, vm) + dvn -- call subroutine sldvn (v, uv, vm) + Normalize a 3-vector also giving the modulus + + sep -- s = slsep (a1, b1, a2, b2) + dsep -- d = sldsep (a1, b1, a2, b2) + Angle between two points on a sphere + + bear -- s = slbear (a1, b1, a2, b2) + dbear -- d = sldber (a1, b1, a2, b2) + pav -- s = slpav (v1, v2) + dpav -- d = sldpav (v1, v2) + Direction of one point on a sphere seen from another + + euler -- call subroutine sleulr (order, phi, theta, psi, rmat) +deuler -- call subroutine sldeul (order, phi, theta, psi, rmat) + Form form rotation matrix from three Euler angles + + + av2m -- call subroutine slav2m (axvec, rmat) + dav2m -- call subroutine sldavm (axvec, rmat) + Form rotation matrix from axial vector + + m2av -- call subroutine slm2av (rmat, axvec) + dm2av -- call subroutine sldmav (rmat, axvec) + Determine axial vector from rotation matrix + + dmxv -- call subroutine sldmxv (dm, va, vb) + mxv -- call subroutine slmxv (rm, va, vb) + Rotate vector forwards + + imxv -- call subroutine slimxv (rm, va, vb) + dimxv -- call subroutine sldimv (dm, va, vb) + Rotate vector backwards + + dmxm -- call subroutine sldmxm (a, b, c) + mxm -- call subroutine slmxm (a, b, c) + Product of two 3X3 matrices + + cs2c6 -- call subroutine sls2c6 (a, b, r, ad, bd, rd, v) + ds2c6 -- call subroutine sldsc6 (a, b, r, ad, bd, rd, v) + Conversion of position/velocity from spherical to Cartesian + coordinates + + cc62s -- call subroutine slc62s (v, a, b, r, ad, bd, rd) + dc62s -- call subroutine sldc6s (v, a, b, r, ad, bd, rd) + Conversion of position/velocity from Cartesian to spherical + coordinates +.fi +.ih +CALENDARS +.nf + cldj -- call subroutine slcadj (iy, im, id, djm, j) + Gregorian calendar to Modified Julian Date + + caldj -- call subroutine slcadj (iy, im, id, djm, j) + Gregorian calendar to Modified Julian Date, permitting century by + default + + djcal -- call subroutine sldjca (ndp, djm, iymdf, j) + Modified Julian Date to Gregorian calendar, in a from convenient + for formatted output + + djcl -- call subroutine sldjcl (djm, iy, im, id, fd, j) + Modified Julian Date to Gregorian Year, Month, Day, Fraction + + calyd -- call subroutine slcayd (iy, im, id, ny, nd, j) + Calendar to year and day in year, permitting century default + + clyd -- call subroutine slclyd (iy, im, id, ny, nd, jstat) + Calendar to year and day in year + + epb -- d = slepb (date) + Modified Julian Date to Besselian Epoch + + epb2d -- d = sleb2d (epb) + Besselian epoch to Modified Julian Date + + epj -- d = slepj (date) + Modified Julian Date to Julian Epoch + + epj2d -- d = slej2d (epj) + Julian epoch to Modified Julian Date +.fi +.fi +.ih +TIMESCALES +.nf + gmst -- d = slgmst (ut1) + Conversion from Universal Time to siderial time + + gmsta -- d = slgmsa (date, ut) + Conversion from Universal Time to siderial time, rounding errors + minimized + + eqeqx -- d = sleqex (date) + Equation of the equinoxes + + dat -- d = sldat (utc) + Offset of Atomic Time from Coordinated Universal Time: + TAI - UTC + + dt -- d = sldt (epoch) + Approximate offset between dynamical time and universal time + + dtt -- d = sldtt (utc) + Offset of Terrestrial Time from Coordinated Universal Time: + TT - UTC + + rcc -- d = slrcc (tdb, ut1, wl, u, v) + Relativistic clock correction: TDB - TT +.fi +.ih +PRECESSION AND NUTATION +.nf + nut -- call subroutine slnut (date, rmatn) + Nutation matrix + + nutc -- call subroutine slnutc (date, dpsi, deps, eps0) + Longitude and obliquity components of nutation, mean obliquity + + prec -- call subroutine slprec (ep0, ep1, rmatp) + Precession matrix (IAU) + + precl -- call subroutine slprel (ep0, ep1, rmatp) + Precession matrix (suitable for long periods) + +prenut -- call subroutine slprnu (epoch, date, rmatpn) + Combined precession/nutation matrix + + prebn -- call subroutine slprbn (bep0, bep1, rmatp) + Precession matrix (old system) + +preces -- call subroutine slprce (system, ep0, ep1, ra, dc) + Precession in either the old or new system, character string + ep0 and ep1 + +precss -- call subroutine slprcs (system, ep0, ep1, ra, dc) + Precession in either the old or new system, integer ep0 and ep1 +.fi +.fi +.ih +PROPER MOTION +.nf + pm -- call subroutine slpm (r0, d0, pr, pd, px, rv, ep0, ep1, r1, d1) + Adjust for proper motion +.fi +.ih +FK4/5/ICRS CONVERSIONS +.nf + fk425 -- call subroutine slfk45 (r1950, d1950, dr1950, dd1950, + p1950, v1950, r2000, d2000, dr2000, dd2000, p2000, v2000) + Convert B1950.0 FK4 star data to J2000.0 FK5 + + fk45z -- call subroutine slf45z (r1950, d1950, bepoch, r2000, d2000) + Convert B1950.0 FK4 position to J2000.0 FK5 assuming zero proper + motion in an inertial frame and no parallax + + fk524 -- call subroutine slfk54 (r2000, d2000, dr2000, dd2000, + p2000, v2000, r1950, d1950, dr1950, dd1950, p1950, v1950) + Convert J2000.0 FK5 star data to B1950.0 FK4 + + fk54z -- call subroutine slf54z (r2000, d2000, bepoch, r1950, d1950, + dr1950, dd1950) + Convert J2000.0 FK5 star data to B1950.0 FK4 assuming zero proper + motion in an inertial frame and no parallax + + fk52h -- call subroutine slfk5h (r5, d5, dr5, dd5, rh, dh, drh, ddh) + Convert J2000.0 FK5 star data to ICRS J2000.0 data + + fk5hz -- call subroutine slf5hz (r5, d5, epoch, rh, dh) + Convert J2000.0 FK5 star data to ICRS J2000.0 data assuming + no Hipparcos proper motion. + + h2fk5 -- call subroutine slhfk5 (rh, dh, drh, ddh, r5, d5, dr5, dd5) + Convert ICRS J2000.0 data to J2000.0 Fk5 star data. + + hfk5z -- call subroutine slhf5z (rh, dh, epoch, r5, d5) + Convert ICRS J2000.0 data to J2000.0 Fk5 star data assuming no + Hipparchos proper motion. + + dbjin -- call subroutine sldbji (string, nstrt, dreslt, j1, j2) + Like dfltin but with extensions to accept leading 'B' and 'J' + + kbj -- call subroutine slkbj (jb, e, k, j) + Select epoch prefix 'B' or 'J' + + epco -- d = slepco (k0, k, e) + Convert an epoch into the appropriate form 'B' or 'J' +.fi +.ih +ELLIPTIC ABERRATIONS +.nf + etrms -- call subroutine sletrm (ep, ev) + E-terms + + subet -- call subroutine slsuet (rc, dc, eq, rm, dm) + Remove the E-terms + + addet -- call subroutine sladet (rm, dm, eq, rc, dc) + Add the E-terms +.fi +.ih +GEOCENTRIC COORDINATES +.nf + obs -- call subroutine slobs (n, c, name, w, p, h) + Interrogate list of observatory parameters + + geoc -- call subroutine slgeoc (p, h, r, z) + Convert geodetic position to geocentric + + pvobs -- call subroutine slpvob (p, h, stl, pv) + Position and velocity of observatory +.fi +.ih +APPARENT AND OBSERVED PLACE +.nf + map -- call subroutine slmap (rm, dm, pr, pd, px, rv, eq, date, ra, da) + Mean place to geocentric apparent place + + mappa -- call subroutine slmapa (eq, date, amprms) + Precompute mean to apparent parameters + + mapqk -- call subroutine slmapq (rm, dm, pr, pd, px, rv, amprms, ra, da) + Mean to apparent place using precomputed parameters + +mapqkz -- call subroutine slmapz (rm, dm, amprms, ra, da) + Mean to apparent place using precomputed parameters, for zero + proper motion, parallax, and radial velocity + + amp -- call subroutine slamp (ra, da, date, eq, rm, dm) + Geocentric apparent place to mean place + + ampqk -- call subroutine slampq (ra, da, amprms, rm, dm) + Apparent to mean place using precomputed parameters + + aop -- call subroutine slaop (rap, dap, date, dut, elongm, phim, hm, + xp, yp, tdk, pmb, rh, wl, tlr, aob, zob, hob, dob, rob) + Apparent place to observed place + + aoppa -- call subroutine slaopa (date, dut, elongm, phim, hm, xy, yp, + tdk, pmb, rh, wl, tlr, aoprms) + Precompute apparent to observed parameters + +aoppat -- call subroutine slaopt (date, aoprms) + Update siderial time in apparent to observed parameters + + aopqk -- call subroutine slaopq (rap, dap, aoprms, aob, zob, hob, dob, rob) + Apparent to observed using precomputed parameters + + oap -- call subroutine sloap (type, ob1, ob2, date, dut, elongm, phim, + xp, yp, tdk, pmb, rh, wl, tlr, rap, dap) + Observed to apparent + + oapqk -- call subroutine sloapq (type, ob1, ob2, aoprms, rap, dap) + Observed to apparent using precomputed parameters + + polmo -- call subroutine slplmo (elongim, phim, xp, yp, elong, phi, daz) + Correct site longitude and latitude for polar motion +.fi +.ih +AZIMUTH AND ELEVATION +.nf + altaz -- call subroutine slalaz (ha, dec, phi, + Positions, velocities, etc. for an altazimuth mount + + e2h -- call subroutine sle2h (ha, dec, phi, az, el) + de2h -- call subroutine slde2h (ha, dec, phi, az, el) + Hour angle and declination to azimuth and elevation + + h2e -- call subroutine slh2e (az, el, phi, ha, dec) + dh2e -- call subroutine sldh2e (az, el, phi, ha, dec) + Azimuth and elevation to hour angle and declination + + pda2h -- call subroutine slpdah (p, d, a, h1, j1, h2, j2) + Hour angle corresponding to a given azimuth + + pdq2h -- call subroutine slpdqh (p, d, q, h1, j1, h2, j2) + Hour angle corresponding to a given parallactic angle + + pa -- d = slpa (ha, dec, phi) + Hour angle and declination to parallactic angle + + zd -- d = slzd (ha, dec, phi) + Hour angle and declination to zenith distance +.fi +.ih +REFRACTION AND AIR MASS +.nf + refro -- call subroutine slrfro (zobs, hm, tdk, pmb, rh, wl, phi, tlr, + eps, ref) + Change in zenith distance due to refraction + + refco -- call subroutine slrfco (hm, tdk, pmb, rh, wl, phi, tlr, eps, + refa, refb) + Constants for simple refraction model + +refcoq -- call subroutine slrfcq (tdk, pmb, rl, wl, refa, refb) + Constants for simple refraction model (quick version) + +atmdsp -- call subroutine slatmd (tdk, pmb, rh, wl1, a1, b1, wl2, a2, b2) + Adjust refraction constants for color + + refz -- call subroutine slrefz (zu, refa, refb, zr) + Unrefracted to refracted zenith distance, simple model + + refv -- call subroutine slrefv (vu, refa, refb, vr) + Unrefracted to refracted azimuth and elevation, simple model + +airmas -- d = slarms (zd) + Air mass +.fi +.ih +ECLIPTIC COORDINATES +.nf + ecmat -- call subroutine slecma (date, rmat) + Equatorial to ecliptic rotation matrix + + eqecl -- call subroutine sleqec (dr, dd, date, dl, db) + J2000.0 FK5 to ecliptic coordinates + + ecleq -- call subroutine sleceq (dl, db, date, dr, dd) + Ecliptic to J2000.0 FK5 coordinates +.fi +.ih +GALACTIC COORDINATES +.nf + eg50 -- call subroutine sleg50 (dr, dd, dl, db) + B1950.0 FK4 to galactic coordinates + + ge50 -- call subroutine slge50 (dl, db, dr, dd) + Galactic to B1950.0 FK4 coordinates + + eqgal -- call subroutine sleqga (dr, dd, dl, db) + J2000.0 FK5 to galactic coordinates + + galeq -- call subroutine slgaeq (dl, db, dr, dd) + Galactic to J2000.0 FK5 coordinates +.fi +.ih +SUPERGALACTIC COORDINATES +.nf +galsup -- call subroutine slgasu (dl, db, dsl, dsb) + Galactic to supergalactic coordinates + +supgal -- call subroutine slsuga (dsl, dsb, dl, db) + Supergalactic to galactic coordinates +.fi +.ih +EPHEMERIDES +.nf + dmoon -- call subroutine sldmon (date, pv) + Approximate geocentric position and velocity of moon + + earth -- call subroutine slerth (iy, id, fd, pv) + Approximate heliocentric position and velocity of earth + + evp -- call subroutine slevp (date, deqx, dvb, dpb, dvh, dph) + Barycentric and heliocentric velocity and position of earth + + moon -- call subroutine slmoon (iy, id, fd, pv) + Approximate geocentric position and velocity of moon + +planet -- call subroutine slplnt (date, np, pv, jstat) + Approximate heliocentric position and velocity of planet + +rdplan -- call subroutine slrdpl (date, np, elong, phi, ra, dec, diam) + Approximate topocentric apparent place of a planet + +planel -- call subroutine slplnl (date, jform, epoch, orbinc, anode, + perih, aorg, e, aorl, dm, pv, jstat) + Approximate heliocentric position and velocity of planet + +plante -- call subroutine slplte (date, elong, phi, jform, epoch, orbinc, + anode, perih, aorq, e, aorl, dm, ra, dec, r, jstat) + Approximate topocentric apparent place of a planet + + pv2el -- call subroutine slpvel (pv, date, pmass, jformr, jform, epoch, + orbinc, anode, perih, aorg, e, aorl, dm, jstat) + Convert J2000 position and velocity to equivalent osculating elements + + el2ue -- call subroutine slelue (date, jform, epoch, orbinc, anode, perih, + aorq, e, aorl, dm, u, jstat) + Convert conventional osculating orbital elements into universal + form. + + ue2el -- call subroutine slueel (u, jformr, jform, epoch, orbinc, anode, + perih, aorq, e, aorl, dm, jstat) + Convert universal elements into conventional heliocentric osculating + form. + + pv2ue -- call subroutine slpvue (pv, date, pmass, u, jstat) + Construct a universal element set based on instantaneous position + and velocity. + + ue2pv -- call subroutine sluepv (date, u, pv, jstat) + Compute heliocentric position and velocity of a planet, asteroid, or + comet, starting from orbital elements in the "universal variables" + form. + +pertel -- call subroutine slprtl (jform, date0, date1, epoch0, epoch1, + orbi0, anode0, perih0, aorq0, e0, am0, epoch1, orbi1, anode1, + perih1, aorq1m e1, am1, jstat) + Update the osculating elements of a comet or asteroid by applying + planetary perturbations. + +pertue -- call subroutine slprue (date, u, jstat) + Update universal elements of a comet or asteroid by applying planetary + perturbations. +.fi +.ih +RADIAL VELOCITIES +rverot -- s = slrver (phi, ra, da, st) + Velocity component due to rotation of the earth + + ecor -- call subroutine slecor (rm, dm, iy, id, fd, rv, tl) + Components of velocity and light time due to earth orbital motion + +rvlsrd -- r = slrvld (r2000, d2000) + Velocity component due to solar motion wrt dynamical LSR + +rvlsrk -- r = slrvlk (r2000, d2000) + Velocity component due to solar motion wrt kinematical LSR + +rvgalc -- r = slrvga (r2000, d2000) + Velocity component due to rotation of the Galaxy + + rvlg -- r = slrvlg (r2000, d2000) + Velocity component due to rotation and translation of the Galaxy, + relative to the mean motion of the local group +.fi +.ih +ASTROMETRY +.nf + s2tp -- call subroutine sls2tp (ra, dec, raz, decz, xi, eta, j) + ds2tp -- call subroutine sldstp (ra, dec, raz, decz, xi, eta, j) + Transform spherical into tangent plane coordinates + + v2tp -- call subroutine slv2tp (v, v0, xi, eta, j) + dv2tp -- call subroutine sldvtp (v, v0, xi, eta, j) + Transform [x,y,z] into tangent plane coordinates + + tp2s -- call subroutine sltp2s (xi, eta, raz, decz, ra, dec) + dtp2s -- call subroutine sldtps (xi, eta, raz, decz, ra, dec) + Transform tangent plane into spherical coordinates + + tp2v -- call subroutine sltp2v (xi, eta, v0, v) + dtp2v -- call subroutine sldtpv (xi, eta, v0, v) + Transform tangent plane coordinates into [x,y,z] + + tps2c -- call subroutine sltpsc (xi, eta, ra, dec, raz1, decz1, + raz2, decz2, n) +dtps2c -- call subroutine sldpsc (xi, eta, ra, dec, raz1, decz1, + raz2, decz2, n) + Get plate center from tangent plane and spherical coordinates + + tpv2c -- call subroutine sltpvc (xi, eta, v, v01, v02, n) +dtpv2c -- call subroutine sldpvc (xi, eta, v, v01, v02, n) + Get plate center from [x,y,x] and tangent plane coordinates + + pcd -- call subroutine slpcd (disco, x, y) + Apply pincushion/barrel distortion + + unpcd -- call subroutine slupcd (disco, x, y) + Remove pincushion/barrel distortion + + fitxy -- call subroutine slftxy (itype, np, xye, xym, coeffs, j) + Fit a linear model to relate two sets of [x,y] coordinates + + pxy -- call subroutine slpxy (np, xye, xym, coeffs, xyp, + xrms, yrms, rrms) + Compute predicted coordinates and residuals + + invf -- call subroutine slinvf (fwds, bkwds, j) + Invert a linear model + + xy2xy -- call subroutine slxyxy (x1, y1, coeffs, x2, y2) + Transform one set of [x,y] coordinates + + dcmpf -- call subroutine sldcmf (coeffs, xz, yz, xs, ys, perp, orient) + Decompose a linear fit into geometric parameters +.fi +.ih +NUMERICAL METHODS +.nf + smat -- call subroutine slsmat (n, a, y, d, jf, iw) + dmat -- call subroutine sldmat (n, a, y, d, jf, iw) + Matrix inversion and solution of simultaneous equations + + svd -- call subroutine slsvd (m, n, mp, np, a, w, v, work, jstat) + Singular value decomposition of a matrix + +svdsol -- call subroutine slsvds (m, n, mp, np, b, u, w, v, work, x) + Solution from a given vector plus SVD + +svdcov -- call subroutine slsvdc (n, np, nc, w, v, work, cvm) + Covariance matrix from SVD +.fi +.endhelp diff --git a/math/slalib/doc/slalib.hlp.sav b/math/slalib/doc/slalib.hlp.sav new file mode 100644 index 00000000..8da465cf --- /dev/null +++ b/math/slalib/doc/slalib.hlp.sav @@ -0,0 +1,591 @@ +.help slalib Nov95 "Immatch Package" +.ih +NAME +slalib -- Starlink library of positional astronomy routines + +.ih +DESCRIPTION +SLALIB is a library of Fortran 77 routines intended to make accurate +and reliable positional-astronomy applications easier to write. Most +SLALIB library routines are concerned with astronomical position and time, +but a number have wider trigonometrical, numerical or general applications. +SLALIB contains routines covering the following topics: 1) string +decoding and sexagesimal conversions, 2) angles, vectors and rotation +matrices, 3) calendars and timescales, 4) precession and nutation, 5) +proper motion, 6) FK4/5 and elliptic aberration, 7) geocentric coordinates, +8) apparent and observed place, 9) azimuth and elevation, 10) refraction +and air mass, 11) ecliptic, galactic, and supergalactic coordinates, +12) ephemerides, 13) astrometry, and 14) numerical methods. + +The labels and calling sequences of the SLALIB are listed below grouped +by function. To get more detailed help on any individual routine type +the help command followed by the label, e.g the command "help flotin" +will give detailed help on the subroutine slrfli. + +.ih +STRING DECODING +.nf + intin -- call subroutine slinti (string, nstrt, ireslt, jflag) + Convert free-format string into integer + +flotin -- call subroutine slrfli (string, nstrt, reslt, jflag) +dfltin -- call subroutine sldfli (string, nstrt, dreslt, jflag) + Convert free-format string into floating point number + + afin -- call subroutine slafin (string, iptr, a, j) + dafin -- call subroutine sldafn (string, iptr, a, j) + Convert free-format string from deg, armin, arcsec to radians +.fi +.ih +SEXAGESIMAL CONVERSIONS +.nf + ctf2d -- call subroutine slctfd (ihour, imin, sec, days, j) + dtf2d -- call subroutine sldtfd (ihour, imin, sec, days, j) + Hours, minutes, seconds to days + + cd2tf -- call subroutine slcdtf (ndp, days, sign, ihmsf) + dd2tf -- call subroutine slddtf (ndp, days, sign, ihmsf) + Days to hours, minutes, and seconds + + ctf2r -- call subroutine slctfr (ihour, imin, sec, rad, j) + dtf2r -- call subroutine sldtfr (ihour, imin, sec, rad, j) + Hours, minutes, seconds to radians + + cr2tf -- call subroutine slcrtf (ndp, angle, sign, ihmsf) + dr2tf -- call subroutine sldrtf (ndp, angle, sign, ihmsf) + Radians to hours, minutes, seconds + + caf2r -- call subroutine slcafr (ideg, iamin, asec, rad, j) + daf2r -- call subroutine sldafr (ideg, iamin, asec, rad, j) + Degrees, arcminutes, arcseconds to radians + + cr2af -- call subroutine slcraf (ndp, angle, sign, idmsf) + dr2af -- call subroutine sldraf (ndp, angle, sign, idmsf) + Radians to degrees, arcminutes, arcseconds +.fi +.ih +ANGLES, VECTORS AND ROTATION MATRICES +.nf + range -- r = slra1p (angle) +drange -- d = slda1p (angle) + Normalize angle into range [-pi,pi] + +ranorm -- r = slra2p (angle) +dranrm -- d = slda2p (angle) + Normalize angle into range [0,2pi] + + cs2c -- call subroutine slcs2c (a, b, v) + dcs2c -- call subroutine slds2c (a, b, v) + Spherical coordinates to [x,y,z] + + cc2s -- call subroutine slcc2s (v, a, b) + dcc2s -- call subroutine sldc2s (v, a, b) + [x,y,z] to spherical coordinates + + vdv -- r = slvdv (va, vb) + dvdv -- d = sldvdv (va, vb) + Scalar product of two 3-vectors + + vxv -- call subroutine slvxv (va, vb, vc) + dvxv -- call subroutine sldvxv (va, vb, vc) + Vector product of two 3-vectors + + vn -- call subroutine slvn (v, uv, vm) + dvn -- call subroutine sldvn (v, uv, vm) + Normalize a 3-vector also giving the modulus + + sep -- s = slsep (a1, b1, a2, b2) + dsep -- d = sldsep (a1, b1, a2, b2) + Angle between two points on a sphere + + bear -- s = slbear (a1, b1, a2, b2) + dbear -- d = sldber (a1, b1, a2, b2) + pav -- s = slpav (v1, v2) + dpav -- d = sldpav (v1, v2) + Direction of one point on a sphere seen from another + + euler -- call subroutine sleulr (order, phi, theta, psi, rmat) +deuler -- call subroutine sldeul (order, phi, theta, psi, rmat) + Form form rotation matrix from three Euler angles + + + av2m -- call subroutine slav2m (axvec, rmat) + dav2m -- call subroutine sldavm (axvec, rmat) + Form rotation matrix from axial vector + + m2av -- call subroutine slm2av (rmat, axvec) + dm2av -- call subroutine sldmav (rmat, axvec) + Determine axial vector from rotation matrix + + dmxv -- call subroutine sldmxv (dm, va, vb) + mxv -- call subroutine slmxv (rm, va, vb) + Rotate vector forwards + + imxv -- call subroutine slimxv (rm, va, vb) + dimxv -- call subroutine sldimv (dm, va, vb) + Rotate vector backwards + + dmxm -- call subroutine sldmxm (a, b, c) + mxm -- call subroutine slmxm (a, b, c) + Product of two 3X3 matrices + + cs2c6 -- call subroutine sls2c6 (a, b, r, ad, bd, rd, v) + ds2c6 -- call subroutine sldsc6 (a, b, r, ad, bd, rd, v) + Conversion of position/velocity from spherical to Cartesian + coordinates + + cc62s -- call subroutine slc62s (v, a, b, r, ad, bd, rd) + dc62s -- call subroutine sldc6s (v, a, b, r, ad, bd, rd) + Conversion of position/velocity from Cartesian to spherical + coordinates +.fi +.ih +CALENDARS +.nf + cldj -- call subroutine slcadj (iy, im, id, djm, j) + Gregorian calendar to Modified Julian Date + + caldj -- call subroutine slcadj (iy, im, id, djm, j) + Gregorian calendar to Modified Julian Date, permitting century by + default + + djcal -- call subroutine sldjca (ndp, djm, iymdf, j) + Modified Julian Date to Gregorian calendar, in a from convenient + for formatted output + + djcl -- call subroutine sldjcl (djm, iy, im, id, fd, j) + Modified Julian Date to Gregorian Year, Month, Day, Fraction + + calyd -- call subroutine slcayd (iy, im, id, ny, nd, j) + Calendar to year and day in year, permitting century default + + clyd -- call subroutine slclyd (iy, im, id, ny, nd, jstat) + Calendar to year and day in year + + epb -- d = slepb (date) + Modified Julian Date to Besselian Epoch + + epb2d -- d = sleb2d (epb) + Besselian epoch to Modified Julian Date + + epj -- d = slepj (date) + Modified Julian Date to Julian Epoch + + epj2d -- d = slej2d (epj) + Julian epoch to Modified Julian Date +.fi +.fi +.ih +TIMESCALES +.nf + gmst -- d = slgmst (ut1) + Conversion from Universal Time to siderial time + + gmsta -- d = slgmsa (date, ut) + Conversion from Universal Time to siderial time, rounding errors + minimized + + eqeqx -- d = sleqex (date) + Equation of the equinoxes + + dat -- d = sldat (utc) + Offset of Atomic Time from Coordinated Universal Time: + TAI - UTC + + dt -- d = sldt (epoch) + Approximate offset between dynamical time and universal time + + dtt -- d = sldtt (utc) + Offset of Terrestrial Time from Coordinated Universal Time: + TT - UTC + + rcc -- d = slrcc (tdb, ut1, wl, u, v) + Relativistic clock correction: TDB - TT +.fi +.ih +PRECESSION AND NUTATION +.nf + nut -- call subroutine slnut (date, rmatn) + Nutation matrix + + nutc -- call subroutine slnutc (date, dpsi, deps, eps0) + Longitude and obliquity components of nutation, mean obliquity + + prec -- call subroutine slprec (ep0, ep1, rmatp) + Precession matrix (IAU) + + precl -- call subroutine slprel (ep0, ep1, rmatp) + Precession matrix (suitable for long periods) + +prenut -- call subroutine slprnu (epoch, date, rmatpn) + Combined precession/nutation matrix + + prebn -- call subroutine slprbn (bep0, bep1, rmatp) + Precession matrix (old system) + +preces -- call subroutine slprce (system, ep0, ep1, ra, dc) + Precession in either the old or new system, character string + ep0 and ep1 + +precss -- call subroutine slprcs (system, ep0, ep1, ra, dc) + Precession in either the old or new system, integer ep0 and ep1 +.fi +.fi +.ih +PROPER MOTION +.nf + pm -- call subroutine slpm (r0, d0, pr, pd, px, rv, ep0, ep1, r1, d1) + Adjust for proper motion +.fi +.ih +FK4/5/ICRS CONVERSIONS +.nf + fk425 -- call subroutine slfk45 (r1950, d1950, dr1950, dd1950, + p1950, v1950, r2000, d2000, dr2000, dd2000, p2000, v2000) + Convert B1950.0 FK4 star data to J2000.0 FK5 + + fk45z -- call subroutine slf45z (r1950, d1950, bepoch, r2000, d2000) + Convert B1950.0 FK4 position to J2000.0 FK5 assuming zero proper + motion in an inertial frame and no parallax + + fk524 -- call subroutine slfk54 (r2000, d2000, dr2000, dd2000, + p2000, v2000, r1950, d1950, dr1950, dd1950, p1950, v1950) + Convert J2000.0 FK5 star data to B1950.0 FK4 + + fk54z -- call subroutine slf54z (r2000, d2000, bepoch, r1950, d1950, + dr1950, dd1950) + Convert J2000.0 FK5 star data to B1950.0 FK4 assuming zero proper + motion in an inertial frame and no parallax + + fk52h -- call subroutine slfk5h (r5, d5, dr5, dd5, rh, dh, drh, ddh) + Convert J2000.0 FK5 star data to ICRS J2000.0 data + + fk5hz -- call subroutine slf5hz (r5, d5, epoch, rh, dh) + Convert J2000.0 FK5 star data to ICRS J2000.0 data assuming + no Hipparcos proper motion. + + h2fk5 -- call subroutine slhfk5 (rh, dh, drh, ddh, r5, d5, dr5, dd5) + Convert ICRS J2000.0 data to J2000.0 Fk5 star data. + + hfk5z -- call subroutine slhf5z (rh, dh, epoch, r5, d5) + Convert ICRS J2000.0 data to J2000.0 Fk5 star data assuming no + Hipparchos proper motion. + + dbjin -- call subroutine sldbji (string, nstrt, dreslt, j1, j2) + Like dfltin but with extensions to accept leading 'B' and 'J' + + kbj -- call subroutine slkbj (jb, e, k, j) + Select epoch prefix 'B' or 'J' + + epco -- d = slepco (k0, k, e) + Convert an epoch into the appropriate form 'B' or 'J' +.fi +.ih +ELLIPTIC ABERRATIONS +.nf + etrms -- call subroutine sletrm (ep, ev) + E-terms + + subet -- call subroutine slsuet (rc, dc, eq, rm, dm) + Remove the E-terms + + addet -- call subroutine sladet (rm, dm, eq, rc, dc) + Add the E-terms +.fi +.ih +GEOCENTRIC COORDINATES +.nf + obs -- call subroutine slobs (n, c, name, w, p, h) + Interrogate list of observatory parameters + + geoc -- call subroutine slgeoc (p, h, r, z) + Convert geodetic position to geocentric + + pvobs -- call subroutine slpvob (p, h, stl, pv) + Position and velocity of observatory +.fi +.ih +APPARENT AND OBSERVED PLACE +.nf + map -- call subroutine slmap (rm, dm, pr, pd, px, rv, eq, date, ra, da) + Mean place to geocentric apparent place + + mappa -- call subroutine slmapa (eq, date, amprms) + Precompute mean to apparent parameters + + mapqk -- call subroutine slmapq (rm, dm, pr, pd, px, rv, amprms, ra, da) + Mean to apparent place using precomputed parameters + +mapqkz -- call subroutine slmapz (rm, dm, amprms, ra, da) + Mean to apparent place using precomputed parameters, for zero + proper motion, parallax, and radial velocity + + amp -- call subroutine slamp (ra, da, date, eq, rm, dm) + Geocentric apparent place to mean place + + ampqk -- call subroutine slampq (ra, da, amprms, rm, dm) + Apparent to mean place using precomputed parameters + + aop -- call subroutine slaop (rap, dap, date, dut, elongm, phim, hm, + xp, yp, tdk, pmb, rh, wl, tlr, aob, zob, hob, dob, rob) + Apparent place to observed place + + aoppa -- call subroutine slaopa (date, dut, elongm, phim, hm, xy, yp, + tdk, pmb, rh, wl, tlr, aoprms) + Precompute apparent to observed parameters + +aoppat -- call subroutine slaopt (date, aoprms) + Update siderial time in apparent to observed parameters + + aopqk -- call subroutine slaopq (rap, dap, aoprms, aob, zob, hob, dob, rob) + Apparent to observed using precomputed parameters + + oap -- call subroutine sloap (type, ob1, ob2, date, dut, elongm, phim, + xp, yp, tdk, pmb, rh, wl, tlr, rap, dap) + Observed to apparent + + oapqk -- call subroutine sloapq (type, ob1, ob2, aoprms, rap, dap) + Observed to apparent using precomputed parameters + + polmo -- call subroutine slplmo (elongim, phim, xp, yp, elong, phi, daz) + Correct site longitude and latitude for polar motion +.fi +.ih +AZIMUTH AND ELEVATION +.nf + altaz -- call subroutine slalaz (ha, dec, phi, + Positions, velocities, etc. for an altazimuth mount + + e2h -- call subroutine sle2h (ha, dec, phi, az, el) + de2h -- call subroutine slde2h (ha, dec, phi, az, el) + Hour angle and declination to azimuth and elevation + + h2e -- call subroutine slh2e (az, el, phi, ha, dec) + dh2e -- call subroutine sldh2e (az, el, phi, ha, dec) + Azimuth and elevation to hour angle and declination + + pda2h -- call subroutine slpdah (p, d, a, h1, j1, h2, j2) + Hour angle corresponding to a given azimuth + + pdq2h -- call subroutine slpdqh (p, d, q, h1, j1, h2, j2) + Hour angle corresponding to a given parallactic angle + + pa -- d = slpa (ha, dec, phi) + Hour angle and declination to parallactic angle + + zd -- d = slzd (ha, dec, phi) + Hour angle and declination to zenith distance +.fi +.ih +REFRACTION AND AIR MASS +.nf + refro -- call subroutine slrfro (zobs, hm, tdk, pmb, rh, wl, phi, tlr, + eps, ref) + Change in zenith distance due to refraction + + refco -- call subroutine slrfco (hm, tdk, pmb, rh, wl, phi, tlr, eps, + refa, refb) + Constants for simple refraction model + +refcoq -- call subroutine slrfcq (tdk, pmb, rl, wl, refa, refb) + Constants for simple refraction model (quick version) + +atmdsp -- call subroutine slatmd (tdk, pmb, rh, wl1, a1, b1, wl2, a2, b2) + Adjust refraction constants for color + + refz -- call subroutine slrefz (zu, refa, refb, zr) + Unrefracted to refracted zenith distance, simple model + + refv -- call subroutine slrefv (vu, refa, refb, vr) + Unrefracted to refracted azimuth and elevation, simple model + +airmas -- d = slarms (zd) + Air mass +.fi +.ih +ECLIPTIC COORDINATES +.nf + ecmat -- call subroutine slecma (date, rmat) + Equatorial to ecliptic rotation matrix + + eqecl -- call subroutine sleqec (dr, dd, date, dl, db) + J2000.0 FK5 to ecliptic coordinates + + ecleq -- call subroutine sleceq (dl, db, date, dr, dd) + Ecliptic to J2000.0 FK5 coordinates +.fi +.ih +GALACTIC COORDINATES +.nf + eg50 -- call subroutine sleg50 (dr, dd, dl, db) + B1950.0 FK4 to galactic coordinates + + ge50 -- call subroutine slge50 (dl, db, dr, dd) + Galactic to B1950.0 FK4 coordinates + + eqgal -- call subroutine sleqga (dr, dd, dl, db) + J2000.0 FK5 to galactic coordinates + + galeq -- call subroutine slgaeq (dl, db, dr, dd) + Galactic to J2000.0 FK5 coordinates +.fi +.ih +SUPERGALACTIC COORDINATES +.nf +galsup -- call subroutine slgasu (dl, db, dsl, dsb) + Galactic to supergalactic coordinates + +supgal -- call subroutine slsuga (dsl, dsb, dl, db) + Supergalactic to galactic coordinates +.fi +.ih +EPHEMERIDES +.nf + dmoon -- call subroutine sldmon (date, pv) + Approximate geocentric position and velocity of moon + + earth -- call subroutine slerth (iy, id, fd, pv) + Approximate heliocentric position and velocity of earth + + evp -- call subroutine slevp (date, deqx, dvb, dpb, dvh, dph) + Barycentric and heliocentric velocity and position of earth + + moon -- call subroutine slmoon (iy, id, fd, pv) + Approximate geocentric position and velocity of moon + +planet -- call subroutine slplnt (date, np, pv, jstat) + Approximate heliocentric position and velocity of planet + +rdplan -- call subroutine slrdpl (date, np, elong, phi, ra, dec, diam) + Approximate topocentric apparent place of a planet + +planel -- call subroutine slplnl (date, jform, epoch, orbinc, anode, + perih, aorg, e, aorl, dm, pv, jstat) + Approximate heliocentric position and velocity of planet + +plante -- call subroutine slplte (date, elong, phi, jform, epoch, orbinc, + anode, perih, aorq, e, aorl, dm, ra, dec, r, jstat) + Approximate topocentric apparent place of a planet + + pv2el -- call subroutine slpvel (pv, date, pmass, jformr, jform, epoch, + orbinc, anode, perih, aorg, e, aorl, dm, jstat) + Convert J2000 position and velocity to equivalent osculating elements + + el2ue -- call subroutine slelue (date, jform, epoch, orbinc, anode, perih, + aorq, e, aorl, dm, u, jstat) + Convert conventional osculating orbital elements into universal + form. + + ue2el -- call subroutine slueel (u, jformr, jform, epoch, orbinc, anode, + perih, aorq, e, aorl, dm, jstat) + Convert universal elements into conventional heliocentric osculating + form. + + pv2ue -- call subroutine slpvue (pv, date, pmass, u, jstat) + Construct a universal element set based on instantaneous position + and velocity. + + ue2pv -- call subroutine sluepv (date, u, pv, jstat) + Compute heliocentric position and velocity of a planet, asteroid, or + comet, starting from orbital elements in the "universal variables" + form. + +pertel -- call subroutine slprtl (jform, date0, date1, epoch0, epoch1, + orbi0, anode0, perih0, aorq0, e0, am0, epoch1, orbi1, anode1, + perih1, aorq1m e1, am1, jstat) + Update the osculating elements of a comet or asteroid by applying + planetary perturbations. + +pertue -- call subroutine slprue (date, u, jstat) + Update universal elements of a comet or asteroid by applying planetary + perturbations. +.fi +.ih +RADIAL VELOCITIES +rverot -- s = slrver (phi, ra, da, st) + Velocity component due to rotation of the earth + + ecor -- call subroutine slecor (rm, dm, iy, id, fd, rv, tl) + Components of velocity and light time due to earth orbital motion + +rvlsrd -- r = slrvld (r2000, d2000) + Velocity component due to solar motion wrt dynamical LSR + +rvlsrk -- r = slrvlk (r2000, d2000) + Velocity component due to solar motion wrt kinematical LSR + +rvgalc -- r = slrvga (r2000, d2000) + Velocity component due to rotation of the Galaxy + + rvlg -- r = slrvlg (r2000, d2000) + Velocity component due to rotation and translation of the Galaxy, + relative to the mean motion of the local group +.fi +.ih +ASTROMETRY +.nf + s2tp -- call subroutine sls2tp (ra, dec, raz, decz, xi, eta, j) + ds2tp -- call subroutine sldstp (ra, dec, raz, decz, xi, eta, j) + Transform spherical into tangent plane coordinates + + v2tp -- call subroutine slv2tp (v, v0, xi, eta, j) + dv2tp -- call subroutine sldvtp (v, v0, xi, eta, j) + Transform [x,y,z] into tangent plane coordinates + + tp2s -- call subroutine sltp2s (xi, eta, raz, decz, ra, dec) + dtp2s -- call subroutine sldtps (xi, eta, raz, decz, ra, dec) + Transform tangent plane into spherical coordinates + + tp2v -- call subroutine sltp2v (xi, eta, v0, v) + dtp2v -- call subroutine sldtpv (xi, eta, v0, v) + Transform tangent plane coordinates into [x,y,z] + + tps2c -- call subroutine sltpsc (xi, eta, ra, dec, raz1, decz1, + raz2, decz2, n) +dtps2c -- call subroutine sldpsc (xi, eta, ra, dec, raz1, decz1, + raz2, decz2, n) + Get plate center from tangent plane and spherical coordinates + + tpv2c -- call subroutine sltpvc (xi, eta, v, v01, v02, n) +dtpv2c -- call subroutine sldpvc (xi, eta, v, v01, v02, n) + Get plate center from [x,y,x] and tangent plane coordinates + + pcd -- call subroutine slpcd (disco, x, y) + Apply pincushion/barrel distortion + + unpcd -- call subroutine slupcd (disco, x, y) + Remove pincushion/barrel distortion + + fitxy -- call subroutine slftxy (itype, np, xye, xym, coeffs, j) + Fit a linear model to relate two sets of [x,y] coordinates + + pxy -- call subroutine slpxy (np, xye, xym, coeffs, xyp, + xrms, yrms, rrms) + Compute predicted coordinates and residuals + + invf -- call subroutine slinvf (fwds, bkwds, j) + Invert a linear model + + xy2xy -- call subroutine slxyxy (x1, y1, coeffs, x2, y2) + Transform one set of [x,y] coordinates + + dcmpf -- call subroutine sldcmf (coeffs, xz, yz, xs, ys, perp, orient) + Decompose a linear fit into geometric parameters +.fi +.ih +NUMERICAL METHODS +.nf + smat -- call subroutine slsmat (n, a, y, d, jf, iw) + dmat -- call subroutine sldmat (n, a, y, d, jf, iw) + Matrix inversion and solution of simultaneous equations + + svd -- call subroutine slsvd (m, n, mp, np, a, w, v, work, jstat) + Singular value decomposition of a matrix + +svdsol -- call subroutine slsvds (m, n, mp, np, b, u, w, v, work, x) + Solution from a given vector plus SVD + +svdcov -- call subroutine slsvdc (n, np, nc, w, v, work, cvm) + Covariance matrix from SVD +.fi +.endhelp diff --git a/math/slalib/doc/slalib.men b/math/slalib/doc/slalib.men new file mode 100644 index 00000000..2288c0aa --- /dev/null +++ b/math/slalib/doc/slalib.men @@ -0,0 +1,179 @@ + addet - add the E-terms to a pre IAU 1976 mean place + afin - convert a sexagesimal character string to radians (s.p.) + airmas - compute the airmass at a given zenith distance + altaz - compute altazimuth positions, velocities, accelerations + amp - convert a geocentric apparent to post IAU 1976 mean place + ampqk - convert a geocentric apparent to post IAU 1976 mean place + aop - convert an apparent to observed place + aoppa - pre-compute the set of apparent to observed place parameters + aoppat - recompute the apparent to observed place sidereal time parameter + aopqk - convert an apparent to observed place + atmdsp - apply atmospheric dispersion terms to refraction coefficients + av2m - compute a rotation matrix from an axial vector (s.p.) + bear - compute the bearing of a point on a sphere w.r.t. another + caf2r - convert degrees, arcminutes, and arcseconds to radians + caldj - convert a Gregorian calendar date to a modified Julian date + calyd - convert a Gregorian calendar date to a Julian calendar year, day + cc2s - convert Cartesian to spherical coordinates (s.p.) + cc62s - convert a 6-vector from Cartesian to spherical coordinates + cd2tf - convert an interval in days to hours, minutes, and seconds + cldj - convert a Gregorian calendar date to a modified Julian date + clyd - convert a Gregorian calendar date a Julian calendar year, day + cr2af - convert radians to degrees, arcminutes, and arcseconds + cr2tf - convert radians to hours, minutes, and seconds + cs2c - convert spherical to Cartesian coordinates (s.p.) + cs2c6 - convert spherical position/velocity to Cartesian coordinates + ctf2d - convert hours, minutes, and seconds to days + ctf2r - convert hours, minutes, and seconds to radians + daf2r - convert degrees, arcminutes, and arcseconds to radians (d.p) + dafin - convert a sexagesimal character string to radians (d.p.) + dat - compute difference between TAI and UTC in seconds + dav2m - compute a rotation matrix from an axial vector (d.p) + dbear - compute the bearing of a point on a sphere w.r.t. another (d.p.) + dbjin - convert a character string to a Besselian/Julian epoch + dc62s - convert Cartesian position/velocity to spherical coordinates (d.p.) + dcc2s - convert Cartesian to spherical coordinates (d.p) + dcmpf - convert linear fit coefficients to geometric parameters + dcs2c - convert spherical to Cartesian coordinates (d.p) + dd2tf - convert interval in days to hours, minutes, and seconds (d.p.) + de2h - convert hour angle and declination to azimuth and elevation (d.p.) + deuler - convert Euler angles to a rotation matrix (d.p.) + dfltin - convert a character string to a floating point number (d.p.) + dh2e - convert azimuth and elevation to hour angle and declination (d.p.) + dimxv - apply a 3D reverse rotation to a 3-vector (d.p.) + djcal - convert an MJD to a Gregorian calendar date + djcl - convert an MJD to a Gregorian year, month, and day + dm2av - convert a rotation matrix to an axial vector (d.p) + dmat - solve a set of simultaneous equations (d.p.) + dmoon - compute approximate geocentric position/velocity of moon (d.p.) + dmxm - compute the product of two 3X3 matrices (d.p.) + dmxv - multiple a 3-vector by a rotation matrix (d.p.) + dpav - compute the bearing of a point on a sphere w.r.t. another (d.p.) + dr2af - convert radians to degrees, arcminutes, and arcseconds (d.p) + dr2tf - convert radians to hours, minutes, and seconds (d.p.) + drange - normalize an angle to the range -pi <= angle <= pi (d.p.) + dranrm - normalize an angle to the range 0 <= angle <= 2pi (d.p.) + ds2c6 - convert spherical position/velocity to Cartesian coordinates (d.p.) + ds2tp - project spherical coordinates onto the tangent plane (d.p) + dsep - compute the angle between two points on a sphere (d.p.) + dt - estimate the approximate difference between ET and UT in seconds + dtf2d - convert hours, minutes, and seconds to days (d.p) + dtf2r - convert hours, minutes, and seconds to radians (d.p.) + dtp2s - convert tangent plane to spherical coordinates (d.p.) + dtp2v - convert tangent plane coordinates to direction cosines (d.p.) + dtps2c - compute the spherical coordinates of the tangent point (d.p.) + dtpv2c - compute the direction cosines of the tangent point (d.p.) + dtt - compute the difference between TT and UTC in seconds + dv2tp - convert direction cosines to tangent plane coordinates (d.p) + dvdv - compute the scalar product of 2 3-vectors (d.p.) + dvn - normalize a 3-vector and compute the modulus (d.p.) + dvxv - compute the vector product of 2 3-vectors (d.p.) + e2h - convert hour angle and declination to azimuth and elevation (d.p.) + earth - compute approximate heliocentric position/velocity of earth + ecleq - convert from ecliptic to equatorial FK5 coordinates + ecmat - compute the equatorial FK5 to ecliptic coordinates rotation matrix + ecor - compute rv of earth and time correction to sun in given direction + eg50 - convert equatorial FK4 to IAU 1958 galactic coordinates + el2ue - convert osculating orbital elements into universal form + epb - convert an MJD to a Besselian epoch + epb2d - convert a Besselian epoch to an MJD + epco - convert a Besselian/Julian epoch to match a given epoch + epj - convert an MJD to a Julian epoch + epj2d - convert a Julian epoch to an MJD + eqecl - convert equatorial FK5 to ecliptic coordinates + eqeqx - compute the equation of the equinoxes + eqgal - convert equatorial FK5 to IAU 1958 galactic coordinates + etrms - compute the E-terms vector + euler - convert Euler angles to a rotation matrix (s.p.) + evp - compute the barycentric/heliocentric velocity/position of earth + fitxy - fit a linear model to 2 sets of [x,y] coordinates + fk425 - convert equatorial FK4 to FK5 coordinates + fk45z - convert equatorial FK4 to FK5 coordinates excluding proper motion + fk524 - convert equatorial FK5 to FK4 coordinates + fk54z - convert equatorial FK5 to FK4 coordinates excluding proper motion + fk52h - convert equatorial FK5 to ICRS coordinates + fk5hz - Convert equatorial FK5 to ICRS coordinates (0 ICRS proper motions) + flotin - convert a character string to a floating point number + galeq - convert IAU 1958 galactic to equatorial FK5 coordinates + galsup - convert IAU 1958 galactic to deVaucouleurs supergalactic coordinates + ge50 - convert IAU 1958 galactic to equatorial FK4 coordinates + geoc - convert geodetic to geocentric position + gmst - convert from UT1 to GMST + gmsta - convert from UT1 to GMST while minimizing rounding errors + h2e - convert azimuth and elevation to hour angle and declination (s.p.) + h2fk5 - Convert equatorial ICRS to FK5 coordinates + hfk5z - Convert equatorial ICRS to FK5 coordinates (0 ICRS proper motions) + imxv - apply a 3D reverse rotation to a 3-vector (s.p.) + intin - convert a character string into an integer + invf - invert the linear model computed from 2 sets of [x,y] coordinates + kbj - select the epoch prefix B or J + m2av - convert a rotation matrix to an axial vector (s.p.) + map - convert a post IAU 1976 mean to geocentric apparent place + mappa - precompute the set of mean to geocentric apparent place parameters + mapqk - convert a post IAU 1976 mean to geocentric apparent place + mapqkz - convert a post IAU 1976 mean to geocentric apparent place + moon - compute approximate geocentric position/velocity of moon + mxm - compute the product of two 3X3 matrices (s.p.) + mxv - multiply a 3-vector by a rotation matrix (s.p.) + nut - compute the nutation matrix for a given date + nutc - compute the nutation components for a given date + oap - convert from observed to apparent place + oapqk - convert from observed to apparent place + obs - look up an entry in a list of groundbased observing stations + pa - compute the parallactic angle from the hour angle and declination + pav - compute the bearing of a point on a sphere w.r.t. another + pcd - apply pincushion/barrel distortion to tangent plane coordinates + pda2h - compute the hour angle corresponding to a given azimuth + pdq2h - compute the hour angle corresponding to a given parallactic angle + pertel - update osculating orbital elements by applying perturbations + pertue - update universal elements by applying perturbations + planel - compute the approximate heliocentric position/velocity of a planet + planet - compute the approximate heliocentric position/velocity of a planet + plante - compute approximate topocentric apparent position of a planet + pm - apply the correction for proper motion to a star + polmo - correct site longitude and latitude for polar motion + prebn - compute the FK4 matrix of precession between two epochs + prec - compute the FK5 matrix of precession between two epochs + preces - precess coordinates in either the FK4 or FK5 systems + precl - compute the longterm matrix of precession between two epochs + precss - precess coordinates in either the FK4 or FK5 systems + prenut - compute the FK5 matrix of precession and nutation + pv2el - convert J2000 position and velocity to osculating elements + pv2ue - convert instantaneous position and velocity to universal element set + pvobs - compute the geocentric position / velocity of an observing station + pxy - apply a linear model to a set of expected and measured [x,y] + range - normalize an angle to the range -pi <= angle <= pi (s.p.) + ranorm - normalize an angle to the range 0 <= angle <= 2pi (s.p.) + rcc - compute the difference between TDB and TT in seconds + rdplan - compute approximate topocentric apparent position of a planet + refco - compute the refraction coefficients + refcoq - compute the refraction coefficients (fast version) + refro - compute the atmospheric refraction for optical and radio wavelengths + refv - apply the refraction correction to a Cartesian 3-vector + refz - apply the refraction correction to a zenith distance + rverot - compute the earth rotation velocity component in a given direction + rvgalc - compute the dynamical LSR velocity component in a given direction + rvlg - compute the solar velocity component in a given direction + rvlsrd - compute the peculiar solar velocity component in a given direction + rvlsrk - compute the standard solar velocity component in a given direction + s2tp - project spherical coordinates onto the tangent plane (s.p.) + sep - compute the angle between two points on a sphere (s.p.) + smat - solve a set of simultaneous equations (s.p.) + subet - remove the E-terms from a pre IAU 1976 catalog position + supgal - convert deVaucouleurs supergalactic to IAU 1958 galactic coordinates + svd - compute the SVD factorization of a matrix + svdcov - compute the covariance matrix from the SVD factorization + svdsol - solve a set of simultaneous equations using SVD factorization + tp2s - convert tangent plane to spherical coordinates (s.p.) + tp2v - convert tangent plane coordinates to direction cosines (s.p.) + tps2c - compute the spherical coordinates of the tangent point (s.p.) + tpv2c - compute the direction cosines of the tangent point (s.p.) + ue2el - convert universal elements into heliocentric osculating elements + ue2pv - compute heliocentric position and velocity from universal form + unpcd - remove pincushion/barrel distortion from distorted coordinates + v2tp - convert direction cosines to tangent plane coordinates (s.p.) + vdv - convert the scale production of two 3-vectors (s.p.) + vn - normalize a 3-vector and compute the modulus (s.p.) + vxv - compute the vector product of two 3-vectors (s.p.) + xy2xy - apply a computed linear model to a set of [x,y] + zd - convert hour angle and declination to zenith distance diff --git a/math/slalib/doc/smat.hlp b/math/slalib/doc/smat.hlp new file mode 100644 index 00000000..ad2b1f2d --- /dev/null +++ b/math/slalib/doc/smat.hlp @@ -0,0 +1,60 @@ +.help smat Jun99 "Slalib Package" +.nf + + SUBROUTINE slSMAT (N, A, Y, D, JF, IW) + + - - - - - + S M A T + - - - - - + + Matrix inversion & solution of simultaneous equations + (single precision) + + For the set of n simultaneous equations in n unknowns: + A.Y = X + + where: + A is a non-singular N x N matrix + Y is the vector of N unknowns + X is the known vector + + SMATRX computes: + the inverse of matrix A + the determinant of matrix A + the vector of N unknowns + + Arguments: + + symbol type dimension before after + + N int no. of unknowns unchanged + A real (N,N) matrix inverse + Y real (N) vector solution + D real - determinant + * JF int - singularity flag + IW int (N) - workspace + + * JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=-1 & D=0.0 are + returned. In the latter case, the contents of array A on return + are undefined. + + Algorithm: + Gaussian elimination with partial pivoting. + + Speed: + Very fast. + + Accuracy: + Fairly accurate - errors 1 to 4 times those of routines optimized + for accuracy. + + Note: replaces the obsolete slSMATRX routine. + + P.T.Wallace Starlink 10 September 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/subet.hlp b/math/slalib/doc/subet.hlp new file mode 100644 index 00000000..42d74ccf --- /dev/null +++ b/math/slalib/doc/subet.hlp @@ -0,0 +1,41 @@ +.help subet Jun99 "Slalib Package" +.nf + + SUBROUTINE slSUET (RC, DC, EQ, RM, DM) + + - - - - - - + S U E T + - - - - - - + + Remove the E-terms (elliptic component of annual aberration) + from a pre IAU 1976 catalogue RA,Dec to give a mean place + (double precision) + + Given: + RC,DC dp RA,Dec (radians) with E-terms included + EQ dp Besselian epoch of mean equator and equinox + + Returned: + RM,DM dp RA,Dec (radians) without E-terms + + Called: + slETRM, slDS2C, sla_,DVDV, slDC2S, slDA2P + + Explanation: + Most star positions from pre-1984 optical catalogues (or + derived from astrometry using such stars) embody the + E-terms. This routine converts such a position to a + formal mean place (allowing, for example, comparison with a + pulsar timing position). + + Reference: + Explanatory Supplement to the Astronomical Ephemeris, + section 2D, page 48. + + P.T.Wallace Starlink 10 May 1990 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/sun67.tex b/math/slalib/doc/sun67.tex new file mode 100644 index 00000000..3e586f5e --- /dev/null +++ b/math/slalib/doc/sun67.tex @@ -0,0 +1,12311 @@ +\documentclass[11pt,twoside]{article} +\setcounter{tocdepth}{2} +\pagestyle{myheadings} + +% ----------------------------------------------------------------------------- +% ? Document identification +\newcommand{\stardoccategory} {Starlink User Note} +\newcommand{\stardocinitials} {SUN} +\newcommand{\stardocsource} {sun67.44} +\newcommand{\stardocnumber} {67.44} +\newcommand{\stardocauthors} {P.\,T.\,Wallace} +\newcommand{\stardocdate} {29 April 1999} +\newcommand{\stardoctitle} {SLALIB --- Positional Astronomy Library} +\newcommand{\stardocversion} {2.3-0} +\newcommand{\stardocmanual} {Programmer's Manual} +% ? End of document identification + +%%% Also see \nroutines definition later %%% + +% ----------------------------------------------------------------------------- + +\newcommand{\stardocname}{\stardocinitials /\stardocnumber} +\markright{\stardocname} +\setlength{\textwidth}{160mm} +\setlength{\textheight}{230mm} +\setlength{\topmargin}{-2mm} +\setlength{\oddsidemargin}{0mm} +\setlength{\evensidemargin}{0mm} +\setlength{\parindent}{0mm} +\setlength{\parskip}{\medskipamount} +\setlength{\unitlength}{1mm} + +% ----------------------------------------------------------------------------- +% Hypertext definitions. +% ====================== +% These are used by the LaTeX2HTML translator in conjunction with star2html. + +% Comment.sty: version 2.0, 19 June 1992 +% Selectively in/exclude pieces of text. +% +% Author +% Victor Eijkhout +% Department of Computer Science +% University Tennessee at Knoxville +% 104 Ayres Hall +% Knoxville, TN 37996 +% USA + +% Do not remove the %\begin{rawtex} and %\end{rawtex} lines (used by +% star2html to signify raw TeX that latex2html cannot process). +%\begin{rawtex} +\makeatletter +\def\makeinnocent#1{\catcode`#1=12 } +\def\csarg#1#2{\expandafter#1\csname#2\endcsname} + +\def\ThrowAwayComment#1{\begingroup + \def\CurrentComment{#1}% + \let\do\makeinnocent \dospecials + \makeinnocent\^^L% and whatever other special cases + \endlinechar`\^^M \catcode`\^^M=12 \xComment} +{\catcode`\^^M=12 \endlinechar=-1 % + \gdef\xComment#1^^M{\def\test{#1} + \csarg\ifx{PlainEnd\CurrentComment Test}\test + \let\html@next\endgroup + \else \csarg\ifx{LaLaEnd\CurrentComment Test}\test + \edef\html@next{\endgroup\noexpand\end{\CurrentComment}} + \else \let\html@next\xComment + \fi \fi \html@next} +} +\makeatother + +\def\includecomment + #1{\expandafter\def\csname#1\endcsname{}% + \expandafter\def\csname end#1\endcsname{}} +\def\excludecomment + #1{\expandafter\def\csname#1\endcsname{\ThrowAwayComment{#1}}% + {\escapechar=-1\relax + \csarg\xdef{PlainEnd#1Test}{\string\\end#1}% + \csarg\xdef{LaLaEnd#1Test}{\string\\end\string\{#1\string\}}% + }} + +% Define environments that ignore their contents. +\excludecomment{comment} +\excludecomment{rawhtml} +\excludecomment{htmlonly} +%\end{rawtex} + +% Hypertext commands etc. This is a condensed version of the html.sty +% file supplied with LaTeX2HTML by: Nikos Drakos & +% Jelle van Zeijl . The LaTeX2HTML documentation +% should be consulted about all commands (and the environments defined above) +% except \xref and \xlabel which are Starlink specific. + +\newcommand{\htmladdnormallinkfoot}[2]{#1\footnote{#2}} +\newcommand{\htmladdnormallink}[2]{#1} +\newcommand{\htmladdimg}[1]{} +\newenvironment{latexonly}{}{} +\newcommand{\hyperref}[4]{#2\ref{#4}#3} +\newcommand{\htmlref}[2]{#1} +\newcommand{\htmlimage}[1]{} +\newcommand{\htmladdtonavigation}[1]{} + +% Starlink cross-references and labels. +\newcommand{\xref}[3]{#1} +\newcommand{\xlabel}[1]{} + +% LaTeX2HTML symbol. +\newcommand{\latextohtml}{{\bf LaTeX}{2}{\tt{HTML}}} + +% Define command to re-centre underscore for Latex and leave as normal +% for HTML (severe problems with \_ in tabbing environments and \_\_ +% generally otherwise). +\newcommand{\latex}[1]{#1} +\newcommand{\setunderscore}{\renewcommand{\_}{{\tt\symbol{95}}}} +\latex{\setunderscore} + +% Redefine the \tableofcontents command. This procrastination is necessary +% to stop the automatic creation of a second table of contents page +% by latex2html. +\newcommand{\latexonlytoc}[0]{\tableofcontents} + +% ----------------------------------------------------------------------------- +% Debugging. +% ========= +% Remove % on the following to debug links in the HTML version using Latex. + +% \newcommand{\hotlink}[2]{\fbox{\begin{tabular}[t]{@{}c@{}}#1\\\hline{\footnotesize #2}\end{tabular}}} +% \renewcommand{\htmladdnormallinkfoot}[2]{\hotlink{#1}{#2}} +% \renewcommand{\htmladdnormallink}[2]{\hotlink{#1}{#2}} +% \renewcommand{\hyperref}[4]{\hotlink{#1}{\S\ref{#4}}} +% \renewcommand{\htmlref}[2]{\hotlink{#1}{\S\ref{#2}}} +% \renewcommand{\xref}[3]{\hotlink{#1}{#2 -- #3}} +% ----------------------------------------------------------------------------- +% ? Document specific \newcommand or \newenvironment commands. +%------------------------------------------------------------------------------ + +\newcommand{\nroutines} {181} +\newcommand{\radec} {$[\,\alpha,\delta\,]$} +\newcommand{\hadec} {$[\,h,\delta\,]$} +\newcommand{\xieta} {$[\,\xi,\eta\,]$} +\newcommand{\azel} {$[\,Az,El~]$} +\newcommand{\ecl} {$[\,\lambda,\beta~]$} +\newcommand{\gal} {$[\,l^{I\!I},b^{I\!I}\,]$} +\newcommand{\xy} {$[\,x,y\,]$} +\newcommand{\xyz} {$[\,x,y,z\,]$} +\newcommand{\xyzd} {$[\,\dot{x},\dot{y},\dot{z}\,]$} +\newcommand{\xyzxyzd} {$[\,x,y,z,\dot{x},\dot{y},\dot{z}\,]$} +\newcommand{\degree}[2] {$#1^{\circ} + \hspace{-0.37em}.\hspace{0.02em}#2$} + +\newcommand{\arcsec}[2] {\arcseci{#1}$\hspace{-0.4em}.#2$} +\begin{htmlonly} + \newcommand{\arcsec}[2] { + {$#1\hspace{-0.05em}^{'\hspace{-0.1em}'}\hspace{-0.4em}.#2$} + } +\end{htmlonly} + +\newcommand{\arcseci}[1] {$#1\hspace{-0.05em}$\raisebox{-0.5ex} + {$^{'\hspace{-0.1em}'}$}} +\begin{htmlonly} + \renewcommand{\arcseci}[1] {$#1\hspace{-0.05em}^{'\hspace{-0.1em}'}$} +\end{htmlonly} + +\newcommand{\dms}[4] {$#1^{\circ}\,#2\raisebox{-0.5ex} + {$^{'}$}\,$\arcsec{#3}{#4}} +\begin{htmlonly} + \renewcommand{\dms}[4]{$#1^{\circ}\,#2^{'}\,#3^{''}.#4$} +\end{htmlonly} + +\newcommand{\tseci}[1] {$#1$\mbox{$^{\rm s}$}} +\newcommand{\tsec}[2] {\tseci{#1}$\hspace{-0.3em}.#2$} +\begin{htmlonly} + \renewcommand{\tsec}[2] {$#1^{\rm s}\hspace{-0.3em}.#2$} +\end{htmlonly} + +\newcommand{\hms}[4] {$#1^{\rm h}\,#2^{\rm m}\,$\tsec{#3}{#4}} +\begin{htmlonly} + \renewcommand{\hms}[4] {$#1^{h}\,#2^{m}\,#3^{s}.#4$} +\end{htmlonly} + +\newcommand{\callhead}[1]{\goodbreak\vspace{\bigskipamount}{\large\bf{#1}}} +\newenvironment{callset}{\begin{list}{}{\setlength{\leftmargin}{2cm} + \setlength{\parsep}{\smallskipamount}}}{\end{list}} +\newcommand{\subp}[1]{\item\hspace{-1cm}#1\\} +\newcommand{\subq}[2]{\item\hspace{-1cm}#1\\\hspace*{-1cm}#2\\} +\newcommand{\name}[1]{\mbox{#1}} +\newcommand{\fortvar}[1]{\mbox{\em #1}} + +\newcommand{\routine}[3] +{\hbadness=10000 + \vbox + { + \rule{\textwidth}{0.3mm}\\ + {\Large {\bf #1} \hfill #2 \hfill {\bf #1}}\\ + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + #3 + \end{description} + \setlength{\topsep}{\oldspacing} + } +} + +% Replacement for HTML version (each routine in own subsection). +\begin{htmlonly} + \renewcommand{\routine}[3] + { + \subsection{#1\xlabel{#1} - #2\label{#1}} + \begin{description} + #3 + \end{description} + } +\end{htmlonly} + +\newcommand{\action}[1] +{\item[ACTION]: #1} + +\begin{htmlonly} + \newcommand{\action}[1] + {\item[ACTION:] #1} +\end{htmlonly} + +\newcommand{\call}[1] +{\item[CALL]: \hspace{0.4em}{\tt #1}} +\newlength{\oldspacing} + +\begin{htmlonly} + \renewcommand{\call}[1] + { + \item[CALL:] {\tt #1} + } +\end{htmlonly} + +\newcommand{\args}[2] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[#1]:\\[1.5ex] + \begin{tabular}{p{7em}p{6em}p{22em}} + #2 + \end{tabular} + \end{description} + \setlength{\topsep}{\oldspacing} +} +\begin{htmlonly} + \renewcommand{\args}[2] + { + \begin{description} + \item[#1:]\\ + \begin{tabular}{p{7em}p{6em}l} + #2 + \end{tabular} + \end{description} + } +\end{htmlonly} + +\newcommand{\spec}[3] +{ + {\em {#1}} & {\bf \mbox{#2}} & {#3} +} + +\newcommand{\specel}[2] +{ + \multicolumn{1}{c}{#1} & {} & {#2} +} + +\newcommand{\anote}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[NOTE]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \renewcommand{\anote}[1] + { + \begin{description} + \item[NOTE:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\notes}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[NOTES]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \renewcommand{\notes}[1] + { + \begin{description} + \item[NOTES:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\aref}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[REFERENCE]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \newcommand{\aref}[1] + { + \begin{description} + \item[REFERENCE:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\refs}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[REFERENCES]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} +\begin{htmlonly} + \newcommand{\refs}[1] + { + \begin{description} + \item[REFERENCES:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\exampleitem}{\item [EXAMPLE]:} +\begin{htmlonly} + \renewcommand{\exampleitem}{\item [EXAMPLE:]} +\end{htmlonly} + +%------------------------------------------------------------------------------ +% ? End of document specific commands +% ----------------------------------------------------------------------------- +% Title Page. +% =========== +\renewcommand{\thepage}{\roman{page}} +\begin{document} +\thispagestyle{empty} + +% Latex document header. +% ====================== +\begin{latexonly} + CCLRC / {\sc Rutherford Appleton Laboratory} \hfill {\bf \stardocname}\\ + {\large Particle Physics \& Astronomy Research Council}\\ + {\large Starlink Project\\} + {\large \stardoccategory\ \stardocnumber} + \begin{flushright} + \stardocauthors\\ + \stardocdate + \end{flushright} + \vspace{-4mm} + \rule{\textwidth}{0.5mm} + \vspace{5mm} + \begin{center} + {\Huge\bf \stardoctitle \\ [2.5ex]} + {\LARGE\bf \stardocversion \\ [4ex]} + {\Huge\bf \stardocmanual} + \end{center} + \vspace{5mm} + +% ? Heading for abstract if used. + \vspace{10mm} + \begin{center} + {\Large\bf Abstract} + \end{center} +% ? End of heading for abstract. +\end{latexonly} + +% HTML documentation header. +% ========================== +\begin{htmlonly} + \xlabel{} + \begin{rawhtml}

\end{rawhtml} + \stardoctitle\\ + \stardocversion\\ + \stardocmanual + \begin{rawhtml}

\end{rawhtml} + +% ? Add picture here if required. +% ? End of picture + + \begin{rawhtml}

\end{rawhtml} + \stardoccategory \stardocnumber \\ + \stardocauthors \\ + \stardocdate + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{CCLRC}{http://www.cclrc.ac.uk} / + \htmladdnormallink{Rutherford Appleton Laboratory} + {http://www.cclrc.ac.uk/ral} \\ + \htmladdnormallink{Particle Physics \& Astronomy Research Council} + {http://www.pparc.ac.uk} \\ + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{Starlink Project}{http://star-www.rl.ac.uk/} + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{\htmladdimg{source.gif} Retrieve hardcopy} + {http://star-www.rl.ac.uk/cgi-bin/hcserver?\stardocsource}\\ + +% HTML document table of contents. +% ================================ +% Add table of contents header and a navigation button to return to this +% point in the document (this should always go before the abstract \section). + \label{stardoccontents} + \begin{rawhtml} +
+

Contents

+ \end{rawhtml} + \renewcommand{\latexonlytoc}[0]{} + \htmladdtonavigation{\htmlref{\htmladdimg{contents_motif.gif}} + {stardoccontents}} + +% ? New section for abstract if used. + \section{\xlabel{abstract}Abstract} +% ? End of new section for abstract +\end{htmlonly} + +% ----------------------------------------------------------------------------- +% ? Document Abstract. (if used) +% ================== +SLALIB is a library used by writers of positional-astronomy applications. +Most of the \nroutines\ routines are concerned with astronomical position and time, +but a number have wider trigonometrical, numerical or general applications. +% ? End of document abstract +% ----------------------------------------------------------------------------- +% ? Latex document Table of Contents (if used). +% =========================================== + \newpage + \begin{latexonly} + \setlength{\parskip}{0mm} + \latexonlytoc + \setlength{\parskip}{\medskipamount} + \markright{\stardocname} + \end{latexonly} +% ? End of Latex document table of contents +% ----------------------------------------------------------------------------- +\newpage +\renewcommand{\thepage}{\arabic{page}} +\setcounter{page}{1} + +\section{INTRODUCTION} +\subsection{Purpose} +SLALIB\footnote{The name isn't an acronym; +it just stands for ``Subprogram Library~A''.} +is a library of routines +intended to make accurate and reliable positional-astronomy +applications easier to write. +Most SLALIB routines are concerned with astronomical position and time, but a +number have wider trigonometrical, numerical or general applications. +The applications ASTROM, COCO, RV and TPOINT +all make extensive use of the SLALIB +routines, as do a number of telescope control systems around the world. +The SLALIB versions currently in service are written in +Fortran~77 and run on VAX/VMS, several Unix platforms and PC. +A generic ANSI~C version is also available from the author; it is +functionally similar to the Fortran version upon which the present +document concentrates. + +\subsection{Example Application} +Here is a simple example of an application program written +using SLALIB calls: + +\begin{verbatim} + PROGRAM FK4FK5 + * + * Read a B1950 position from I/O unit 5 and reply on I/O unit 6 + * with the J2000 equivalent. Enter a period to quit. + * + IMPLICIT NONE + CHARACTER C*80,S + INTEGER I,J,IHMSF(4),IDMSF(4) + DOUBLE PRECISION R4,D4,R5,D5 + LOGICAL BAD + + * Loop until a period is entered + C = ' ' + DO WHILE (C(:1).NE.'.') + + * Read h m s d ' " + READ (5,'(A)') C + IF (C(:1).NE.'.') THEN + BAD = .TRUE. + + * Decode the RA + I = 1 + CALL sla_DAFIN(C,I,R4,J) + IF (J.EQ.0) THEN + R4 = 15D0*R4 + + * Decode the Dec + CALL sla_DAFIN(C,I,D4,J) + IF (J.EQ.0) THEN + + * FK4 to FK5 + CALL sla_FK45Z(R4,D4,1950D0,R5,D5) + + * Format and output the result + CALL sla_DR2TF(2,R5,S,IHMSF) + CALL sla_DR2AF(1,D5,S,IDMSF) + WRITE (6, + : '(1X,I2.2,2I3.2,''.'',I2.2,2X,A,I2.2,2I3.2,''.'',I1)') + : IHMSF,S,IDMSF + BAD = .FALSE. + END IF + END IF + IF (BAD) WRITE (6,'(1X,''?'')') + END IF + END DO + + END +\end{verbatim} +In this example, SLALIB not only provides the complicated FK4 to +FK5 transformation but also +simplifies the tedious and error-prone tasks +of decoding and formatting angles +expressed as hours, minutes {\it etc}. The +example incorporates range checking, and avoids the +notorious ``minus zero'' problem (an often-perpetrated bug where +declinations between $0^{\circ}$ and $-1^{\circ}$ lose their minus +sign). +With a little extra elaboration and a few more calls to SLALIB, +defaulting can be provided (enabling unused fields to +be replaced with commas to avoid retyping), proper motions +can be handled, different epochs can be specified, and +so on. See the program COCO (SUN/56) for further ideas. + +\subsection{Scope} +SLALIB contains \nroutines\ routines covering the following topics: +\begin{itemize} +\item String Decoding, + Sexagesimal Conversions +\item Angles, Vectors \& Rotation Matrices +\item Calendars, + Timescales +\item Precession \& Nutation +\item Proper Motion +\item FK4/FK5/Hipparcos, + Elliptic Aberration +\item Geocentric Coordinates +\item Apparent \& Observed Place +\item Azimuth \& Elevation +\item Refraction \& Air Mass +\item Ecliptic, + Galactic, + Supergalactic Coordinates +\item Ephemerides +\item Astrometry +\item Numerical Methods +\end{itemize} + +\subsection{Objectives} +SLALIB was designed to give application programmers +a basic set of positional-astronomy tools which were +accurate and easy to use. To this end, the library is: +\begin{itemize} +\item Readily available, including source code and documentation. +\item Supported and maintained. +\item Portable -- coded in standard languages and available for +multiple computers and operating systems. +\item Thoroughly commented, both for maintainability and to +assist those wishing to cannibalize the code. +\item Stable. +\item Trustworthy -- some care has gone into +testing SLALIB, both by comparison with published data and +by checks for internal consistency. +\item Rigorous -- corners are not cut, +even where the practical consequences would, as a rule, be +negligible. +\item Comprehensive, without including too many esoteric features +required only by specialists. +\item Practical -- almost all the routines have been written to +satisfy real needs encountered during the development of +real-life applications. +\item Environment-independent -- the package is +completely free of pauses, stops, I/O {\it etc}. +\item Self-contained -- SLALIB calls no other libraries. +\end{itemize} +A few {\it caveats}: +\begin{itemize} +\item SLALIB does not pretend to be canonical. It is in essence +an anthology, and the adopted algorithms are liable +to change as more up-to-date ones become available. +\item The functions aren't orthogonal -- there are several +cases of different +routines doing similar things, and many examples where +sequences of SLALIB calls have simply been packaged, all to +make applications less trouble to write. +\item There are omissions -- for example there are no +routines for calculating physical ephemerides of +Solar-System bodies. +\item SLALIB is not homogeneous, though important subsets +(for example the FK4/FK5 routines) are. +\item The library is not foolproof. You have to know what +you are trying to do ({\it e.g.}\ by reading textbooks on positional +astronomy), and it is the caller's responsibility to supply +sensible arguments (although enough internal validation is done to +avoid arithmetic errors). +\item Without being written in a wasteful +manner, SLALIB is nonetheless optimized for maintainability +rather than speed. In addition, there are many places +where considerable simplification would be possible if some +specified amount of accuracy could be sacrificed; such +compromises are left to the individual programmer and +are not allowed to limit SLALIB's value as a source +of comparison results. +\end{itemize} + +\subsection{Fortran Version} +The Fortran versions of SLALIB use ANSI Fortran~77 with a few +commonplace extensions. Just three out of the \nroutines\ routines require +platform-specific techniques and accordingly are supplied +in different forms. +SLALIB has been implemented on the following platforms: +VAX/VMS, +PC (Microsoft Fortran, Linux), +DECstation (Ultrix), +DEC Alpha (DEC Unix), +Sun (SunOS, Solaris), +Hewlett Packard (HP-UX), +CONVEX, +Perkin-Elmer and +Fujitsu. + +\subsection{C Version} +An ANSI C version of SLALIB is available from the author +but is not part of the Starlink release. +The functionality of this (proprietary) C version closely matches +that of the Starlink Fortran SLALIB, partly for the convenience of +existing users of the Fortran version, some of whom have in the past +implemented C ``wrappers''. The function names +cannot be the same as the Fortran versions because of potential +linking problems when +both forms of the library are present; the C routine which +is the equivalent of (for example) {\tt SLA\_REFRO} is {\tt slaRefro}. +The types of arguments follow the Fortran version, except +that integers are {\tt int} rather than {\tt long}. +Argument passing is by value +(except for arrays and strings of course) +for given arguments and by pointer for returned arguments. +All the C functions are re-entrant. + +The Fortran routines {\tt sla\_GRESID}, {\tt sla\_RANDOM} and +{\tt sla\_WAIT} have no C counterparts. + +Further details of the C version of SLALIB are available +from the author. The definitive guide to +the calling sequences is the file {\tt slalib.h}. + +\subsection{Future Versions} +The homogeneity and ease of use of SLALIB could perhaps be improved +in the future +by turning to C++ and object-oriented techniques. For example ``celestial +position'' could be a class and many of the transformations +could happen automatically. This requires further study and +would almost certainly result in a complete redesign. +Similarly, +the impact of Fortran~90 has yet to be assessed. Once compilers +become widely available, some internal recoding may be worthwhile +in order to simplify parts of the code. However, as with C++, +a redesign of the +application interfaces will be needed if the capabilities of the +new language are to be exploited to the full. + +\subsection{New Functions} +In a package like SLALIB it is difficult to know how far to go. Is it +enough to provide the primitive operations, or should more +complicated functions be packaged? Is it worth encroaching on +specialist areas, where individual experts have all written their +own software already? To what extent should CPU efficiency be +an issue? How much support of different numerical precisions is +required? And so on. + +In practice, almost all the routines in SLALIB are there because they were +needed for some specific application, and this is likely to remain the +pattern for any enhancements in the future. +Suggestions for additional SLALIB routines should be addressed to the +author. + +\subsection{Acknowledgements} +SLALIB is descended from a package of routines written +for the AAO 16-bit minicomputers +in the mid-1970s. The coming of the VAX +allowed a much more comprehensive and thorough package +to be designed for Starlink, especially important +at a time when the adoption +of the IAU 1976 resolutions meant that astronomers +would have to cope with a mixture of reference frames, +timescales and nomenclature. + +Much of the preparatory work on SLALIB was done by +Althea~Wilkinson of Manchester University. +During its development, +Andrew~Murray, +Catherine~Hohenkerk, +Andrew~Sinclair, +Bernard~Yallop +and +Brian~Emerson of Her Majesty's Nautical Almanac Office were consulted +on many occasions; their advice was indispensable. +I am especially grateful to +Catherine~Hohenkerk +for supplying preprints of papers, and test data. A number of +enhancements to SLALIB were at the suggestion of +Russell~Owen, University of Washington, +Phil~Hill, St~Andrews University, +Bill~Vacca, JILA, Boulder and +Ron~Maddalena, NRAO. +Mark~Calabretta, CSIRO Radiophysics, Sydney supplied changes to suit Convex. +I am indebted to Derek~Jones (RGO) for providing algorithms for +calculating 2-body orbital motion. + +The first C version of SLALIB was a hand-coded transcription +of the Starlink Fortran version carried out by +Steve~Eaton (University of Leeds) in the course of +MSc work. This was later +enhanced by John~Straede (AAO) and Martin~Shepherd (Caltech). +The current C SLALIB is a complete rewrite by the present author and +includes a comprehensive validation suite. +Additional comments on the C version came from Bob~Payne (NRAO) and +Jeremy~Bailey (AAO). + +\section{LINKING} + +On Unix systems (Sun, DEC Alpha {\it etc.}): +\begin{verse} +{\tt \%~~f77 progname.o -L/star/lib `sla\_link` -o progname} +\end{verse} +(The above assumes that all Starlink directories have been added to +the {\tt LD\_LIBRARY\_PATH} and {\tt PATH} environment variables +as described in SUN/202.) + +On VAX/VMS: +\begin{verse} +{\tt \$~~LINK progname,SLALIB\_DIR:SLALIB/LIB} +\end{verse} + +\pagebreak + +\section{SUBPROGRAM SPECIFICATIONS} +%----------------------------------------------------------------------- +\routine{SLA\_ADDET}{Add E-terms of Aberration} +{ + \action{Add the E-terms (elliptic component of annual aberration) to a + pre IAU 1976 mean place to conform to the old catalogue convention.} + \call{CALL sla\_ADDET (RM, DM, EQ, RC, DC)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{\radec\ without E-terms (radians)} \\ + \spec{EQ}{D}{Besselian epoch of mean equator and equinox} +} +\args{RETURNED} +{ + \spec{RC,DC}{D}{\radec\ with E-terms included (radians)} +} +\anote{Most star positions from pre-1984 optical catalogues (or + obtained by astrometry with respect to such stars) have the + E-terms built-in. If it is necessary to convert a formal mean + place (for example a pulsar timing position) to one + consistent with such a star catalogue, then the + \radec\ should be adjusted using this routine.} +\aref{{\it Explanatory Supplement to the Astronomical Ephemeris}, + section 2D, page 48.} +%----------------------------------------------------------------------- +\routine{SLA\_AFIN}{Sexagesimal character string to angle} +{ + \action{Decode a free-format sexagesimal string (degrees, arcminutes, + arcseconds) into a single precision floating point + number (radians).} + \call{CALL sla\_AFIN (STRING, NSTRT, RESLT, JF)} +} +\args{GIVEN} +{ + \spec{STRING}{C*(*)}{string containing deg, arcmin, arcsec fields} \\ + \spec{NSTRT}{I}{pointer to start of decode (beginning of STRING = 1)} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced past the decoded angle} \\ + \spec{RESLT}{R}{angle in radians} \\ + \spec{JF}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $+1$ = default, RESLT unchanged (note 2)} \\ + \spec{}{}{\hspace{0.7em} $-1$ = bad degrees (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-2$ = bad arcminutes (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-3$ = bad arcseconds (note 3)} \\ +} +\goodbreak +\setlength{\oldspacing}{\topsep} +\setlength{\topsep}{0.3ex} +\begin{description} + \exampleitem \\ [1.5ex] + \begin{tabular}{p{7em}p{15em}p{12em}} + {\it argument} & {\it before} & {\it after} \\ \\ + STRING & $'$\verb*}-57 17 44.806 12 34 56.7}$'$ & unchanged \\ + NSTRT & 1 & 16 ({\it i.e.}\ pointing to 12...) \\ + RESLT & - & $-1.00000$ \\ + JF & - & 0 + \end{tabular} + \item A further call to sla\_AFIN, without adjustment of NSTRT, will + decode the second angle, \dms{12}{34}{56}{7}. +\end{description} +\setlength{\topsep}{\oldspacing} +\notes +{ + \begin{enumerate} + \item The first three ``fields'' in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the sla\_DFLTIN routine and is free-format. + \item Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and RESLT is + unchanged. In all other cases RESLT is changed. + \item Range checking: + \begin{itemize} + \item The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are absent. + \item The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + \item The arcseconds field is expected to be 0-59.9999... + \item Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting to + zero, and the result RESLT is computed and returned. + \end{itemize} + \item Further fields after the three expected ones are not treated as + an error. The pointer NSTRT is left in the correct state for + further decoding with the present routine or with sla\_DFLTIN + {\it etc}. See the example, above. + \item If STRING contains hours, minutes, seconds instead of + degrees {\it etc}, + or if the required units are turns (or days) instead of radians, + the result RESLT should be multiplied as follows: \\ [1.5ex] + \begin{tabular}{p{6em}p{5em}p{15em}} + {\it for STRING} & {\it to obtain} & {\it multiply RESLT by} \\ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & radians & $1.0$ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & turns & $1/{2 \pi} = 0.1591549430918953358$ \\ + h m s & radians & $15.0$ \\ + h m s & days & $15/{2\pi} = 2.3873241463784300365$ \\ + \end{tabular} + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AIRMAS}{Air Mass} +{ + \action{Air mass at given zenith distance (double precision).} + \call{D~=~sla\_AIRMAS (ZD)} +} +\args{GIVEN} +{ + \spec{ZD}{D}{observed zenith distance (radians)} +} +\args{RETURNED} +{ + \spec{sla\_AIRMAS}{D}{air mass (1 at zenith)} +} +\notes +{ + \begin{enumerate} + \item The {\it observed}\/ zenith distance referred to above means + ``as affected by refraction''. + \item The routine uses Hardie's (1962) polynomial fit to Bemporad's + data for the relative air mass, $X$, in units of thickness at the + zenith as tabulated by Schoenberg (1929). This is adequate for all + normal needs as it is accurate to better than + 0.1\% up to $X = 6.8$ and better than 1\% up to $X = 10$. + Bemporad's tabulated values are unlikely to be trustworthy + to such accuracy + because of variations in density, pressure and other + conditions in the atmosphere from those assumed in his work. + \item The sign of the ZD is ignored. + \item At zenith distances greater than about $\zeta = 87^{\circ}$ the + air mass is held constant to avoid arithmetic overflows. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Hardie, R.H., 1962, in {\it Astronomical Techniques}\, + ed. W.A.\ Hiltner, University of Chicago Press, p180. + \item Schoenberg, E., 1929, Hdb.\ d.\ Ap., + Berlin, Julius Springer, 2, 268. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ALTAZ}{Velocities {\it etc.}\ for Altazimuth Mount} +{ + \action{Positions, velocities and accelerations for an altazimuth + telescope mount tracking a star (double precision).} + \call{CALL sla\_ALTAZ (\vtop{ + \hbox{HA, DEC, PHI,} + \hbox{AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)}}} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle} \\ + \spec{DEC}{D}{declination} \\ + \spec{PHI}{D}{observatory latitude} +} +\args{RETURNED} +{ + \spec{AZ}{D}{azimuth} \\ + \spec{AZD}{D}{azimuth velocity} \\ + \spec{AZDD}{D}{azimuth acceleration} \\ + \spec{EL}{D}{elevation} \\ + \spec{ELD}{D}{elevation velocity} \\ + \spec{ELDD}{D}{elevation acceleration} \\ + \spec{PA}{D}{parallactic angle} \\ + \spec{PAD}{D}{parallactic angle velocity} \\ + \spec{PADD}{D}{parallactic angle acceleration} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item Natural units are used throughout. HA, DEC, PHI, AZ, EL + and ZD are in radians. The velocities and accelerations + assume constant declination and constant rate of change of + hour angle (as for tracking a star); the units of AZD, ELD + and PAD are radians per radian of HA, while the units of AZDD, + ELDD and PADD are radians per radian of HA squared. To + convert into practical degree- and second-based units: + + \begin{center} + \begin{tabular}{rlcl} + angles & $\times 360/2\pi$ & $\rightarrow$ & degrees \\ + velocities & $\times (2\pi/86400) \times (360/2\pi)$ + & $\rightarrow$ & degree/sec \\ + accelerations & $\times (2\pi/86400)^2 \times (360/2\pi)$ + & $\rightarrow$ & degree/sec/sec \\ + \end{tabular} + \end{center} + + Note that the seconds here are sidereal rather than SI. One + sidereal second is about 0.99727 SI seconds. + + The velocity and acceleration factors assume the sidereal + tracking case. Their respective numerical values are (exactly) + 1/240 and (approximately) 1/3300236.9. + \item Azimuth is returned in the range $[\,0,2\pi\,]$; north is zero, + and east is $+\pi/2$. Elevation and parallactic angle are + returned in the range $\pm\pi/2$. Position angle is +ve + for a star west of the meridian and is the angle NP--star--zenith. + \item The latitude is geodetic as opposed to geocentric. The + hour angle and declination are topocentric. Refraction and + deficiencies in the telescope mounting are ignored. The + purpose of the routine is to give the general form of the + quantities. The details of a real telescope could profoundly + change the results, especially close to the zenith. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AMP}{Apparent to Mean} +{ + \action{Convert star \radec\ from geocentric apparent to + mean place (post IAU 1976).} + \call{CALL sla\_AMP (RA, DA, DATE, EQ, RM, DM)} +} +\args{GIVEN} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} \\ + \spec{DATE}{D}{TDB for apparent place (JD$-$2400000.5)} \\ + \spec{EQ}{D}{equinox: Julian epoch of mean place} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item The accuracy is limited by the routine sla\_EVP, called + by sla\_MAPPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3~milliarcsecond. + \item Iterative techniques are used for the aberration and + light deflection corrections so that the routines + sla\_AMP (or sla\_AMPQK) and sla\_MAP (or sla\_MAPQK) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1~nanoarcsecond. + \item Where multiple apparent places are to be converted to + mean places, for a fixed date and equinox, it is more + efficient to use the sla\_MAPPA routine to compute the + required parameters once, followed by one call to + sla\_AMPQK per star. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AMPQK}{Quick Apparent to Mean} +{ + \action{Convert star \radec\ from geocentric apparent to mean place + (post IAU 1976). Use of this routine is appropriate when + efficiency is important and where many star positions are + all to be transformed for one epoch and equinox. The + star-independent parameters can be obtained by calling + the sla\_MAPPA routine.} + \call{CALL sla\_AMPQK (RA, DA, AMPRMS, RM, DM)} +} +\args{GIVEN} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession/nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item The accuracy is limited by the routine sla\_EVP, called + by sla\_MAPPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3~milliarcsecond. + \item Iterative techniques are used for the aberration and + light deflection corrections so that the routines + sla\_AMP (or sla\_AMPQK) and sla\_MAP (or sla\_MAPQK) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1~nanoarcsecond. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOP}{Apparent to Observed} +{ + \action{Apparent to observed place, for optical sources distant from + the solar system.} + \call{CALL sla\_AOP (\vtop{ + \hbox{RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB)}}} +} +\args{GIVEN} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec\ (radians)} \\ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (degrees K; std=273.155D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mB; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (degrees K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{AOB}{D}{observed azimuth (radians: N=0, E=$90^{\circ}$)} \\ + \spec{ZOB}{D}{observed zenith distance (radians)} \\ + \spec{HOB}{D}{observed Hour Angle (radians)} \\ + \spec{DOB}{D}{observed $\delta$ (radians)} \\ + \spec{ROB}{D}{observed $\alpha$ (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Apparent}\/ \radec\ means the geocentric apparent right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, precession, nutation, + annual aberration, and the Sun's gravitational lens effect. For + star positions in the FK5 system ({\it i.e.}\ J2000), these effects can + be applied by means of the sla\_MAP {\it etc.}\ routines. Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 ({\it i.e.}\ B1950) mean places would first + have to be converted to FK5, which can be done with the + sla\_FK425 {\it etc.}\ routines. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent \radec\ by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The \hadec\ is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation ({\it n.b.}\ not to the + refracted pole). Finally, the $\alpha$ is obtained by subtracting + the {\it h}\/ from the local apparent ST. + \item To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + \item This routine takes time to execute, due mainly to the + rigorous integration used to evaluate the refraction. + For processing multiple stars for one location and time, + call sla\_AOPPA once followed by one call per star to sla\_AOPQK. + Where a range of times within a limited period of a few hours + is involved, and the highest precision is not required, call + sla\_AOPPA once, followed by a call to sla\_AOPPAT each time the + time changes, followed by one call per star to sla\_AOPQK. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use + in the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in mB, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in degrees K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections to the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOPPA}{Appt-to-Obs Parameters} +{ + \action{Pre-compute the set of apparent to observed place parameters + required by the ``quick'' routines sla\_AOPQK and sla\_OAPQK.} + \call{CALL sla\_AOPPA (\vtop{ + \hbox{DATE, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOPRMS)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (degrees K; std=273.155D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mB; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (degrees K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel {(1)} {geodetic latitude (radians)} \\ + \specel {(2,3)} {sine and cosine of geodetic latitude} \\ + \specel {(4)} {magnitude of diurnal aberration vector} \\ + \specel {(5)} {height (HM)} \\ + \specel {(6)} {ambient temperature (TDK)} \\ + \specel {(7)} {pressure (PMB)} \\ + \specel {(8)} {relative humidity (RH)} \\ + \specel {(9)} {wavelength (WL)} \\ + \specel {(10)} {lapse rate (TLR)} \\ + \specel {(11,12)} {refraction constants A and B (radians)} \\ + \specel {(13)} {longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel {(14)} {local apparent sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. The ``sidereal $\Delta$UT'' which forms + part of AOPRMS(13) is the same quantity, but converted from solar + to sidereal seconds and expressed in radians. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use in + the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in mB, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in degrees K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOPPAT}{Update Appt-to-Obs Parameters} +{ + \action{Recompute the sidereal time in the apparent to observed place + star-independent parameter block.} + \call{CALL sla\_AOPPAT (DATE, AOPRMS)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1-12)}{not required} \\ + \specel{(13)}{longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel{(14)}{not required} +} +\args{RETURNED} +{ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1-13)}{not changed} \\ + \specel{(14)}{local apparent sidereal time (radians)} +} +\anote{For more information, see sla\_AOPPA.} +%----------------------------------------------------------------------- +\routine{SLA\_AOPQK}{Quick Appt-to-Observed} +{ + \action{Quick apparent to observed place (but see Note~8, below).} + \call{CALL sla\_AOPQK (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB)} +} +\args{GIVEN} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec\ (radians)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1)}{geodetic latitude (radians)} \\ + \specel{(2,3)}{sine and cosine of geodetic latitude} \\ + \specel{(4)}{magnitude of diurnal aberration vector} \\ + \specel{(5)}{height (metres)} \\ + \specel{(6)}{ambient temperature (degrees K)} \\ + \specel{(7)}{pressure (mB)} \\ + \specel{(8)}{relative humidity (0\,--\,1)} \\ + \specel{(9)}{wavelength ($\mu{\rm m}$)} \\ + \specel{(10)}{lapse rate (degrees K per metre)} \\ + \specel{(11,12)}{refraction constants A and B (radians)} \\ + \specel{(13)}{longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel{(14)}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{AOB}{D}{observed azimuth (radians: N=0, E=$90^{\circ}$)} \\ + \spec{ZOB}{D}{observed zenith distance (radians)} \\ + \spec{HOB}{D}{observed Hour Angle (radians)} \\ + \spec{DOB}{D}{observed Declination (radians)} \\ + \spec{ROB}{D}{observed Right Ascension (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Apparent}\/ \radec\ means the geocentric apparent right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, precession, nutation, + annual aberration, and the Sun's gravitational lens effect. For + star positions in the FK5 system ({\it i.e.}\ J2000), these effects can + be applied by means of the sla\_MAP {\it etc.}\ routines. Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 ({\it i.e.}\ B1950) mean places would first + have to be converted to FK5, which can be done with the + sla\_FK425 {\it etc.}\ routines. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent \radec\ by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The \hadec\ is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation ({\it n.b.}\ not to the + refracted pole). Finally, the $\alpha$ is obtained by subtracting + the {\it h}\/ from the local apparent ST. + \item To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + \item The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the sla\_AOPPA routine. + If nothing has changed significantly except the time, the + sla\_AOPPAT routine may be used to perform the requisite + partial recomputation of AOPRMS. + \item The ``sidereal $\Delta$UT'' which forms part of AOPRMS(13) + is UT1$-$UTC converted from solar to + sidereal seconds and expressed in radians. + \item At zenith distances beyond about $76^\circ$, the need for + special care with the corrections for refraction causes a + marked increase in execution time. Moreover, the effect + gets worse with increasing zenith distance. Adroit + programming in the calling application may allow the + problem to be reduced. Prepare an alternative AOPRMS array, + computed for zero air-pressure; this will disable the + refraction corrections and cause rapid execution. Using + this AOPRMS array, a preliminary call to the present routine + will, depending on the application, produce a rough position + which may be enough to establish whether the full, slow + calculation (using the real AOPRMS array) is worthwhile. + For example, there would be no need for the full calculation + if the preliminary call had already established that the + source was well below the elevation limits for a particular + telescope. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections to the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ATMDSP}{Atmospheric Dispersion} +{ + \action{Apply atmospheric-dispersion adjustments to refraction coefficients.} + \call{CALL sla\_ATMDSP (TDK, PMB, RH, WL1, A1, B1, WL2, A2, B2)} +} +\args{GIVEN} +{ + \spec{TDK}{D}{ambient temperature at the observer (degrees K)} \\ + \spec{PMB}{D}{pressure at the observer (mB)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL1}{D}{base wavelength ($\mu{\rm m}$)} \\ + \spec{A1}{D}{refraction coefficient A for wavelength WL1 (radians)} \\ + \spec{B1}{D}{refraction coefficient B for wavelength WL1 (radians)} \\ + \spec{WL2}{D}{wavelength for which adjusted A,B required ($\mu{\rm m}$)} +} +\args{RETURNED} +{ + \spec{A2}{D}{refraction coefficient A for wavelength WL2 (radians)} \\ + \spec{B2}{D}{refraction coefficient B for wavelength WL2 (radians)} +} +\notes +{ + \begin{enumerate} + \item To use this routine, first call sla\_REFCO specifying WL1 as the + wavelength. This yields refraction coefficients A1, B1, correct + for that wavelength. Subsequently, calls to sla\_ATMDSP specifying + different wavelengths will produce new, slightly adjusted + refraction coefficients A2, B2, which apply to the specified wavelength. + \item Most of the atmospheric dispersion happens between $0.7\,\mu{\rm m}$ + and the UV atmospheric cutoff, and the effect increases strongly + towards the UV end. For this reason a blue reference wavelength + is recommended, for example $0.4\,\mu{\rm m}$. + \item The accuracy, for this set of conditions: \\[1pc] + \hspace*{5ex} \begin{tabular}{rcl} + height above sea level & ~ & 2000\,m \\ + latitude & ~ & $29^\circ$ \\ + pressure & ~ & 793\,mB \\ + temperature & ~ & $290^\circ$\,K \\ + humidity & ~ & 0.5 (50\%) \\ + lapse rate & ~ & $0.0065^\circ m^{-1}$ \\ + reference wavelength & ~ & $0.4\,\mu{\rm m}$ \\ + star elevation & ~ & $15^\circ$ \\ + \end{tabular}\\[1pc] + is about 2.5\,mas RMS between 0.3 and $1.0\,\mu{\rm m}$, and stays + within 4\,mas for the whole range longward of $0.3\,\mu{\rm m}$ + (compared with a total dispersion from 0.3 to $20\,\mu{\rm m}$ + of about \arcseci{11}). These errors are typical for ordinary + conditions; in extreme conditions values a few times this size + may occur. + \item If either wavelength exceeds $100\,\mu{\rm m}$, the radio case + is assumed and the returned refraction coefficients are the + same as the given ones. + \item The algorithm consists of calculation of the refractivity of the + air at the observer for the two wavelengths, using the methods + of the sla\_REFRO routine, and then scaling of the two refraction + coefficients according to classical refraction theory. This + amounts to scaling the A coefficient in proportion to $(\mu-1)$ and + the B coefficient almost in the same ratio (see R.M.Green, + {\it Spherical Astronomy,}\/ Cambridge University Press, 1985). + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AV2M}{Rotation Matrix from Axial Vector} +{ + \action{Form the rotation matrix corresponding to a given axial vector + (single precision).} + \call{CALL sla\_AV2M (AXVEC, RMAT)} +} +\args{GIVEN} +{ + \spec{AXVEC}{R(3)}{axial vector (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the {\it Euler axis}, and the angle through which the + reference frame rotates is called the Euler angle. The axial + vector supplied to this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. + \item If AXVEC is null, the unit matrix is returned. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_BEAR}{Direction Between Points on a Sphere} +{ + \action{Returns the bearing (position angle) of one point on a + sphere seen from another (single precision).} + \call{R~=~sla\_BEAR (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{R}{spherical coordinates of one point} \\ + \spec{A2,B2}{R}{spherical coordinates of the other point} +} +\args{RETURNED} +{ + \spec{sla\_BEAR}{R}{bearing from first point to second} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are \radec, + $[\lambda,\phi]$ {\it etc.}, in radians. + \item The result is the bearing (position angle), in radians, + of point [A2,B2] as seen + from point [A1,B1]. It is in the range $\pm \pi$. The sense + is such that if [A2,B2] + is a small distance due east of [A1,B1] the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item If either B-coordinate is outside the range $\pm\pi/2$, the + result may correspond to ``the long way round''. + \item The routine sla\_PAV performs an equivalent function except + that the points are specified in the form of Cartesian unit + vectors. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CAF2R}{Deg,Arcmin,Arcsec to Radians} +{ + \action{Convert degrees, arcminutes, arcseconds to radians + (single precision).} + \call{CALL sla\_CAF2R (IDEG, IAMIN, ASEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IDEG}{I}{degrees} \\ + \spec{IAMIN}{I}{arcminutes} \\ + \spec{ASEC}{R}{arcseconds} +} +\args{RETURNED} +{ + \spec{RAD}{R}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 1 = IDEG outside range 0$-$359} \\ + \spec{}{}{\hspace{1.5em} 2 = IAMIN outside range 0$-$59} \\ + \spec{}{}{\hspace{1.5em} 3 = ASEC outside range 0$-$59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CALDJ}{Calendar Date to MJD} +{ + \action{Gregorian Calendar to Modified Julian Date, with century default.} + \call{CALL sla\_CALDJ (IY, IM, ID, DJM, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5) for $0^{\rm h}$} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (MJD not computed)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month (MJD not computed)} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day (MJD computed)} \\ +} +\notes +{ + \begin{enumerate} + \item This routine supports the {\it century default}\/ feature. + Acceptable years are: + \begin{itemize} + \item 00-49, interpreted as 2000\,--\,2049, + \item 50-99, interpreted as 1950\,--\,1999, and + \item 100 upwards, interpreted literally. + \end{itemize} + For 1-100AD use the routine sla\_CLDJ instead. + \item For year $n$BC use IY = $-(n-1)$. + \item When an invalid year or month is supplied (status J~=~1~or~2) + the MJD is {\bf not} computed. When an invalid day is supplied + (status J~=~3) the MJD {\bf is} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CALYD}{Calendar to Year, Day} +{ + \action{Gregorian calendar date to year and day in year, in a Julian + calendar aligned to the 20th/21st century Gregorian calendar, + with century default.} + \call{CALL sla\_CALYD (IY, IM, ID, NY, ND, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar: + year may optionally omit the century} +} +\args{RETURNED} +{ + \spec{NY}{I}{year (re-aligned Julian calendar)} \\ + \spec{ND}{I}{day in year (1 = January 1st)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (before $-4711$)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item This routine supports the {\it century default}\/ feature. + Acceptable years are: + \begin{itemize} + \item 00-49, interpreted as 2000\,--\,2049, + \item 50-99, interpreted as 1950\,--\,1999, and + \item other years after -4712 , interpreted literally. + \end{itemize} + Use sla\_CLYD for years before 100AD. + \item The purpose of sla\_CALDJ is to support + sla\_EARTH, sla\_MOON and sla\_ECOR. + \item Between 1900~March~1 and 2100~February~28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + \item When an invalid year or month is supplied (status J~=~1 or J~=~2) + the results are {\bf not} computed. When a day is + supplied which is outside the conventional range (status J~=~3) + the results {\bf are} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CC2S}{Cartesian to Spherical} +{ + \action{Cartesian coordinates to spherical coordinates (single precision).} + \call{CALL sla\_CC2S (V, A, B)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{\xyz\ vector} +} +\args{RETURNED} +{ + \spec{A,B}{R}{spherical coordinates in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole. + \item If V is null, zero A and B are returned. + \item At either pole, zero A is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CC62S}{Cartesian 6-Vector to Spherical} +{ + \action{Conversion of position \& velocity in Cartesian coordinates + to spherical coordinates (single precision).} + \call{CALL sla\_CC62S (V, A, B, R, AD, BD, RD)} +} +\args{GIVEN} +{ + \spec{V}{R(6)}{\xyzxyzd} +} +\args{RETURNED} +{ + \spec{A}{R}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{R}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{R}{radial coordinate} \\ + \spec{AD}{R}{longitude derivative (radians per unit time)} \\ + \spec{BD}{R}{latitude derivative (radians per unit time)} \\ + \spec{RD}{R}{radial derivative} +} +%----------------------------------------------------------------------- +\routine{SLA\_CD2TF}{Days to Hour,Min,Sec} +{ + \action{Convert an interval in days to hours, minutes, seconds + (single precision).} + \call{CALL sla\_CD2TF (NDP, DAYS, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{DAYS}{R}{interval in days} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + DAYS, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). For example, + on a VAX computer, for DAYS up to 1.0, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + \item The absolute value of DAYS may exceed 1.0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1.0 and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CLDJ}{Calendar to MJD} +{ + \action{Gregorian Calendar to Modified Julian Date.} + \call{CALL sla\_CLDJ (IY, IM, ID, DJM, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5) for $0^{\rm h}$} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item When an invalid year or month is supplied (status J~=~1~or~2) + the MJD is {\bf not} computed. When an invalid day is supplied + (status J~=~3) the MJD {\bf is} computed. + \item The year must be $-$4699 ({\it i.e.}\ 4700BC) or later. + For year $n$BC use IY = $-(n-1)$. + \item An alternative to the present routine is sla\_CALDJ, which + accepts a year with the century missing. + \end{enumerate} +} +\aref{The algorithm is derived from that of Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_CLYD}{Calendar to Year, Day} +{ + \action{Gregorian calendar date to year and day in year, in a Julian + calendar aligned to the 20th/21st century Gregorian calendar.} + \call{CALL sla\_CLYD (IY, IM, ID, NY, ND, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{NY}{I}{year (re-aligned Julian calendar)} \\ + \spec{ND}{I}{day in year (1 = January 1st)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (before $-4711$)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item The purpose of sla\_CLYD is to support sla\_EARTH, + sla\_MOON and sla\_ECOR. + \item Between 1900~March~1 and 2100~February~28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + \item When an invalid year or month is supplied (status J~=~1 or J~=~2) + the results are {\bf not} computed. When a day is + supplied which is outside the conventional range (status J~=~3) + the results {\bf are} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CR2AF}{Radians to Deg,Arcmin,Arcsec} +{ + \action{Convert an angle in radians to degrees, arcminutes, + arcseconds (single precision).} + \call{CALL sla\_CR2AF (NDP, ANGLE, SIGN, IDMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of arcseconds} \\ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IDMSF}{I(4)}{degrees, arcminutes, arcseconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IDMSF(4). For example, + on a VAX computer, for ANGLE up to $2\pi$, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to $360^{\circ}$, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CR2TF}{Radians to Hour,Min,Sec} +{ + \action{Convert an angle in radians to hours, minutes, seconds + (single precision).} + \call{CALL sla\_CR2TF (NDP, ANGLE, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). For example, + on a VAX computer, for ANGLE up to $2\pi$, the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of the 32-bit + integer IHMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CS2C}{Spherical to Cartesian} +{ + \action{Spherical coordinates to Cartesian coordinates (single precision).} + \call{CALL sla\_CS2C (A, B, V)} +} +\args{GIVEN} +{ + \spec{A,B}{R}{spherical coordinates in radians: \radec\ {\it etc.}} +} +\args{RETURNED} +{ + \spec{V}{R(3)}{\xyz\ unit vector} +} +\anote{The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole.} +%----------------------------------------------------------------------- +\routine{SLA\_CS2C6}{Spherical Pos/Vel to Cartesian} +{ + \action{Conversion of position \& velocity in spherical coordinates + to Cartesian coordinates (single precision).} + \call{CALL sla\_CS2C6 (A, B, R, AD, BD, RD, V)} +} +\args{GIVEN} +{ + \spec{A}{R}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{R}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{R}{radial coordinate} \\ + \spec{AD}{R}{longitude derivative (radians per unit time)} \\ + \spec{BD}{R}{latitude derivative (radians per unit time)} \\ + \spec{RD}{R}{radial derivative} +} +\args{RETURNED} +{ + \spec{V}{R(6)}{\xyzxyzd} +} +%----------------------------------------------------------------------- +\routine{SLA\_CTF2D}{Hour,Min,Sec to Days} +{ + \action{Convert hours, minutes, seconds to days (single precision).} + \call{CALL sla\_CTF2D (IHOUR, IMIN, SEC, DAYS, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{R}{seconds} +} +\args{RETURNED} +{ + \spec{DAYS}{R}{interval in days} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CTF2R}{Hour,Min,Sec to Radians} +{ + \action{Convert hours, minutes, seconds to radians (single precision).} + \call{CALL sla\_CTF2R (IHOUR, IMIN, SEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{R}{seconds} +} +\args{RETURNED} +{ + \spec{RAD}{R}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAF2R}{Deg,Arcmin,Arcsec to Radians} +{ + \action{Convert degrees, arcminutes, arcseconds to radians + (double precision).} + \call{CALL sla\_DAF2R (IDEG, IAMIN, ASEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IDEG}{I}{degrees} \\ + \spec{IAMIN}{I}{arcminutes} \\ + \spec{ASEC}{D}{arcseconds} +} +\args{RETURNED} +{ + \spec{RAD}{D}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 1 = IDEG outside range 0$-$359} \\ + \spec{}{}{\hspace{1.5em} 2 = IAMIN outside range 0$-$59} \\ + \spec{}{}{\hspace{1.5em} 3 = ASEC outside range 0$-$59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAFIN}{Sexagesimal character string to angle} +{ + \action{Decode a free-format sexagesimal string (degrees, arcminutes, + arcseconds) into a double precision floating point + number (radians).} + \call{CALL sla\_DAFIN (STRING, NSTRT, DRESLT, JF)} +} +\args{GIVEN} +{ + \spec{STRING}{C*(*)}{string containing deg, arcmin, arcsec fields} \\ + \spec{NSTRT}{I}{pointer to start of decode (beginning of STRING = 1)} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced past the decoded angle} \\ + \spec{DRESLT}{D}{angle in radians} \\ + \spec{JF}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $+1$ = default, DRESLT unchanged (note 2)} \\ + \spec{}{}{\hspace{0.7em} $-1$ = bad degrees (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-2$ = bad arcminutes (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-3$ = bad arcseconds (note 3)} \\ +} +\goodbreak +\setlength{\oldspacing}{\topsep} +\setlength{\topsep}{0.3ex} +\begin{description} + \item [EXAMPLE]: \\ [1.5ex] + \begin{tabular}{p{7em}p{15em}p{12em}} + {\it argument} & {\it before} & {\it after} \\ \\ + STRING & $'$\verb*}-57 17 44.806 12 34 56.7}$'$ & unchanged \\ + NSTRT & 1 & 16 ({\it i.e.}\ pointing to 12...) \\ + RESLT & - & $-1.00000${\tt D0} \\ + JF & - & 0 + \end{tabular} + \item A further call to sla\_DAFIN, without adjustment of NSTRT, will + decode the second angle, \dms{12}{34}{56}{7}. +\end{description} +\setlength{\topsep}{\oldspacing} +\notes +{ + \begin{enumerate} + \item The first three ``fields'' in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the sla\_DFLTIN routine and is free-format. + \item Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and DRESLT is + unchanged. In all other cases DRESLT is changed. + \item Range checking: + \begin{itemize} + \item The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are absent. + \item The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + \item The arcseconds field is expected to be 0-59.9999... + \item Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting to + zero, and the result DRESLT is computed and returned. + \end{itemize} + \item Further fields after the three expected ones are not treated as + an error. The pointer NSTRT is left in the correct state for + further decoding with the present routine or with sla\_DFLTIN + {\it etc}. See the example, above. + \item If STRING contains hours, minutes, seconds instead of + degrees {\it etc}, + or if the required units are turns (or days) instead of radians, + the result DRESLT should be multiplied as follows: \\ [1.5ex] + \begin{tabular}{p{6em}p{5em}p{18em}} + {\it for STRING} & {\it to obtain} & {\it multiply DRESLT by} \\ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & radians & $1.0${\tt D0} \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & turns & $1/{2 \pi} = 0.1591549430918953358${\tt D0} \\ + h m s & radians & $15.0${\tt D0} \\ + h m s & days & $15/{2\pi} = 2.3873241463784300365${\tt D0} + \end{tabular} + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_DAT}{TAI$-$UTC} +{ + \action{Increment to be applied to Coordinated Universal Time UTC to give + International Atomic Time TAI.} + \call{D~=~sla\_DAT (UTC)} +} +\args{GIVEN} +{ + \spec{UTC}{D}{UTC date as a modified JD (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_DAT}{D}{TAI$-$UTC in seconds} +} +\notes +{ + \begin{enumerate} + \item The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can be guaranteed only up to the end of the second + $23^{\rm h}\,59^{\rm m}\,59^{\rm s}$. + \item UTC began at 1960 January 1. To specify a UTC prior to this + date would be meaningless; in such cases the parameters + for the year 1960 are used by default. + \item This routine has to be updated on each occasion that a + leap second is announced, and programs using it relinked. + Refer to the program source code for information on when the + most recent leap second was added. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAV2M}{Rotation Matrix from Axial Vector} +{ + \action{Form the rotation matrix corresponding to a given axial vector + (double precision).} + \call{CALL sla\_DAV2M (AXVEC, RMAT)} +} +\args{GIVEN} +{ + \spec{AXVEC}{D(3)}{axial vector (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the {\it Euler axis}, and the angle through which the + reference frame rotates is called the {\it Euler angle}. The axial + vector supplied to this routine has the same direction as the + Euler axis, and its magnitude is the Euler angle in radians. + \item If AXVEC is null, the unit matrix is returned. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DBEAR}{Direction Between Points on a Sphere} +{ + \action{Returns the bearing (position angle) of one point on a + sphere relative to another (double precision).} + \call{D~=~sla\_DBEAR (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{D}{spherical coordinates of one point} \\ + \spec{A2,B2}{D}{spherical coordinates of the other point} +} +\args{RETURNED} +{ + \spec{sla\_DBEAR}{D}{bearing from first point to second} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are \radec, + $[\lambda,\phi]$ {\it etc.}, in radians. + \item The result is the bearing (position angle), in radians, + of point [A2,B2] as seen + from point [A1,B1]. It is in the range $\pm \pi$. The sense + is such that if [A2,B2] + is a small distance due east of [A1,B1] the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item If either B-coordinate is outside the range $\pm\pi/2$, the + result may correspond to ``the long way round''. + \item The routine sla\_DPAV performs an equivalent function except + that the points are specified in the form of Cartesian unit + vectors. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DBJIN}{Decode String to B/J Epoch (DP)} +{ + \action{Decode a character string into a DOUBLE PRECISION number, + with special provision for Besselian and Julian epochs. + The string syntax is as for sla\_DFLTIN, prefixed by + an optional `B' or `J'.} + \call{CALL sla\_DBJIN (STRING, NSTRT, DRESLT, J1, J2)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing field to be decoded} \\ + \spec{NSTRT}{I}{pointer to first character of field in string} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{incremented past the decoded field} \\ + \spec{DRESLT}{D}{result} \\ + \spec{J1}{I}{DFLTIN status:} \\ + \spec{}{}{\hspace{0.7em} $-$1 = $-$OK} \\ + \spec{}{}{\hspace{1.5em} 0 = +OK} \\ + \spec{}{}{\hspace{1.5em} 1 = null field} \\ + \spec{}{}{\hspace{1.5em} 2 = error} \\ + \spec{J2}{I}{syntax flag:} \\ + \spec{}{}{\hspace{1.5em} 0 = normal DFLTIN syntax} \\ + \spec{}{}{\hspace{1.5em} 1 = `B' or `b'} \\ + \spec{}{}{\hspace{1.5em} 2 = `J' or `j'} +} +\notes +{ + \begin{enumerate} + \item The purpose of the syntax extensions is to help cope with mixed + FK4 and FK5 data, allowing fields such as `B1950' or `J2000' + to be decoded. + \item In addition to the syntax accepted by sla\_DFLTIN, + the following two extensions are recognized by sla\_DBJIN: + \begin{enumerate} + \item A valid non-null field preceded by the character `B' + (or `b') is accepted. + \item A valid non-null field preceded by the character `J' + (or `j') is accepted. + \end{enumerate} + \item The calling program is told of the `B' or `J' through an + supplementary status argument. The rest of + the arguments are as for sla\_DFLTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DC62S}{Cartesian 6-Vector to Spherical} +{ + \action{Conversion of position \& velocity in Cartesian coordinates + to spherical coordinates (double precision).} + \call{CALL sla\_DC62S (V, A, B, R, AD, BD, RD)} +} +\args{GIVEN} +{ + \spec{V}{D(6)}{\xyzxyzd} +} +\args{RETURNED} +{ + \spec{A}{D}{longitude (radians)} \\ + \spec{B}{D}{latitude (radians)} \\ + \spec{R}{D}{radial coordinate} \\ + \spec{AD}{D}{longitude derivative (radians per unit time)} \\ + \spec{BD}{D}{latitude derivative (radians per unit time)} \\ + \spec{RD}{D}{radial derivative} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCC2S}{Cartesian to Spherical} +{ + \action{Cartesian coordinates to spherical coordinates (double precision).} + \call{CALL sla\_DCC2S (V, A, B)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{\xyz\ vector} +} +\args{RETURNED} +{ + \spec{A,B}{D}{spherical coordinates in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole. + \item If V is null, zero A and B are returned. + \item At either pole, zero A is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCMPF}{Interpret Linear Fit} +{ + \action{Decompose an \xy\ linear fit into its constituent parameters: + zero points, scales, nonperpendicularity and orientation.} + \call{CALL sla\_DCMPF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT)} +} +\args{GIVEN} +{ + \spec{COEFFS}{D(6)}{transformation coefficients (see note)} +} +\args{RETURNED} +{ + \spec{XZ}{D}{{\it x} zero point} \\ + \spec{YZ}{D}{{\it y} zero point} \\ + \spec{XS}{D}{{\it x} scale} \\ + \spec{YS}{D}{{\it y} scale} \\ + \spec{PERP}{D}{nonperpendicularity (radians)} \\ + \spec{ORIENT}{D}{orientation (radians)} +} +\notes +{ + \begin{enumerate} + \item The model relates two sets of \xy\ coordinates as follows. + Naming the six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms coordinates $[x_{1},y_{1}\,]$ into coordinates + $[x_{2},y_{2}\,]$ as follows: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + The sla\_DCMPF routine decomposes this transformation + into four steps: + \begin{enumerate} + \item Zero points: + \begin{verse} + $x' = x_{1} + {\rm XZ}$ \\ + $y' = y_{1} + {\rm YZ}$ + \end{verse} + \item Scales: + \begin{verse} + $x'' = x' {\rm XS}$ \\ + $y'' = y' {\rm YS}$ + \end{verse} + \item Nonperpendicularity: + \begin{verse} + $x''' = + x'' \cos {\rm PERP}/2 + y'' \sin {\rm PERP}/2$ \\ + $y''' = + x'' \sin {\rm PERP}/2 + y'' \cos {\rm PERP}/2$ + \end{verse} + \item Orientation: + \begin{verse} + $x_{2} = + x''' \cos {\rm ORIENT} + + y''' \sin {\rm ORIENT}$ \\ + $y_{2} = - x''' \sin {\rm ORIENT} + + y''' \cos {\rm ORIENT}$ + \end{verse} + \end{enumerate} + \item See also sla\_FITXY, sla\_PXY, sla\_INVF, sla\_XY2XY. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCS2C}{Spherical to Cartesian} +{ + \action{Spherical coordinates to Cartesian coordinates (double precision).} + \call{CALL sla\_DCS2C (A, B, V)} +} +\args{GIVEN} +{ + \spec{A,B}{D}{spherical coordinates in radians: \radec\ {\it etc.}} +} +\args{RETURNED} +{ + \spec{V}{D(3)}{\xyz\ unit vector} +} +\anote{The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole.} +%----------------------------------------------------------------------- +\routine{SLA\_DD2TF}{Days to Hour,Min,Sec} +{ + \action{Convert an interval in days into hours, minutes, seconds + (double precision).} + \call{CALL sla\_DD2TF (NDP, DAYS, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{DAYS}{D}{interval in days} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of DAYS, the format of DOUBLE PRECISION floating-point numbers + on the target machine, and the risk of overflowing IHMSF(4). + For example, on a VAX computer, for DAYS up to 1D0, the available + floating-point precision corresponds roughly to NDP=12. However, + the practical limit is NDP=9, set by the capacity of the 32-bit + integer IHMSF(4). + \item The absolute value of DAYS may exceed 1D0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1D0 and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DE2H}{$h,\delta$ to Az,El} +{ + \action{Equatorial to horizon coordinates + (double precision).} + \call{CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle (radians)} \\ + \spec{DEC}{D}{declination (radians)} \\ + \spec{PHI}{D}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{AZ}{D}{azimuth (radians)} \\ + \spec{EL}{D}{elevation (radians)} +} +\notes +{ + \begin{enumerate} + \item Azimuth is returned in the range $0\!-\!2\pi$; north is zero, + and east is $+\pi/2$. Elevation is returned in the range + $\pm\pi$. + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the {\it observed} \hadec, and the elevation + {\it in vacuo}, which would require the {\it topocentric} + \hadec. + If the effects of diurnal aberration can be neglected, the + {\it apparent} \hadec\ may be used instead of the topocentric + \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DEULER}{Euler Angles to Rotation Matrix} +{ + \action{Form a rotation matrix from the Euler angles -- three + successive rotations about specified Cartesian axes + (double precision).} + \call{CALL sla\_DEULER (ORDER, PHI, THETA, PSI, RMAT)} +} +\args{GIVEN} +{ + \spec{ORDER}{C}{specifies about which axes the rotations occur} \\ + \spec{PHI}{D}{1st rotation (radians)} \\ + \spec{THETA}{D}{2nd rotation (radians)} \\ + \spec{PSI}{D}{3rd rotation (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + \item The characters of ORDER define which axes the three successive + rotations are about. A typical value is `ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old {\it z}-axis, followed by THETA radians about the resulting + {\it x}-axis, + then PSI radians about the resulting {\it z}-axis. + \item The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labelling/numbering conventions apply; the {\it xyz} ($\equiv123$) + triad is right-handed. Thus, the `ZXZ' example given above + could be written `zxz' or `313' (or even `ZxZ' or `3xZ'). ORDER + is terminated by length or by the first unrecognized character. + Fewer than three rotations are acceptable, in which case the later + angle arguments are ignored. Zero rotations produces a unit RMAT. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DFLTIN}{Decode a Double Precision Number} +{ + \action{Convert free-format input into double precision floating point.} + \call{CALL sla\_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{DRESLT}{D}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{DRESLT}{D}{result} \\ + \spec{JFLAG}{I}{status: $-$1~=~$-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_DFLTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space, and lowercase characters are + interpreted as uppercase. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n.n x \pm n$, + where $\pm$ is a sign + character `+' or `$-$', $n$ means a string of decimal digits, + `.' is a decimal point, and $x$, which indicates an exponent, + means `D' or `E'. Various combinations of these fields can be + omitted, and embedded blanks are permissible in certain places. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Embedded spaces are allowed only after +, $-$, D or E, + and after the decimal point if the first sequence of + digits is absent. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9,.,D,E or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_DFLTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 13, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item Both signs are optional. The default is +. + \item The mantissa $n.n$ defaults to unity. + \item The exponent $x\!\pm\!n$ defaults to `D0'. + \item The strings of decimal digits may be of any length. + \item The decimal point is optional for whole numbers. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$,0-9,.,D or E, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and DRESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_DFLTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_DFLTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item a +, $-$, D or E is left unsatisfied; or + \item the decimal point is present without at least + one decimal digit before or after it; or + \item an exponent more than 100 has been presented. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + sla\_DFLTIN does not detect that `1D999' is unacceptable + (on a computer where this is so) until the entire number + has been decoded. + \item Certain highly unlikely combinations of mantissa and + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + \item Decoding is left to right, one pass. + \item See also sla\_FLOTIN and sla\_INTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DH2E}{Az,El to $h,\delta$} +{ + \action{Horizon to equatorial coordinates + (double precision).} + \call{CALL sla\_DH2E (AZ, EL, PHI, HA, DEC)} +} +\args{GIVEN} +{ + \spec{AZ}{D}{azimuth (radians)} \\ + \spec{EL}{D}{elevation (radians)} \\ + \spec{PHI}{D}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{HA}{D}{hour angle (radians)} \\ + \spec{DEC}{D}{declination (radians)} +} +\notes +{ + \begin{enumerate} + \item The sign convention for azimuth is north zero, east $+\pi/2$. + \item HA is returned in the range $\pm\pi$. Declination is returned + in the range $\pm\pi$. + \item The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied + (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of \hadec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the {\it observed} \hadec, and the elevation + {\it in vacuo}, which will yield the {\it topocentric} + \hadec. If the + effects of diurnal aberration can be neglected, the + topocentric \hadec\ may be used as an approximation to the + {\it apparent} \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DIMXV}{Apply 3D Reverse Rotation} +{ + \action{Multiply a 3-vector by the inverse of a rotation + matrix (double precision).} + \call{CALL sla\_DIMXV (DM, VA, VB)} +} +\args{GIVEN} +{ + \spec{DM}{D(3,3)}{rotation matrix} \\ + \spec{VA}{D(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{D(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$^{T}\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix DM. + \item The main function of this routine is apply an inverse + rotation; under these circumstances, ${\bf \rm M}$ is + {\it orthogonal}, with its inverse the same as its transpose. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DJCAL}{MJD to Gregorian for Output} +{ + \action{Modified Julian Date to Gregorian Calendar Date, expressed + in a form convenient for formatting messages (namely + rounded to a specified precision, and with the fields + stored in a single array).} + \call{CALL sla\_DJCAL (NDP, DJM, IYMDF, J)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of days in fraction} \\ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{IYMDF}{I(4)}{year, month, day, fraction in Gregorian calendar} \\ + \spec{J}{I}{status: nonzero = out of range} +} +\notes +{ + \begin{enumerate} + \item Any date after 4701BC March 1 is accepted. + \item NDP should be 4 or less to avoid overflow on machines which + use 32-bit integers. + \end{enumerate} +} +\aref{The algorithm is derived from that of Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_DJCL}{MJD to Year,Month,Day,Frac} +{ + \action{Modified Julian Date to Gregorian year, month, day, + and fraction of a day.} + \call{CALL sla\_DJCL (DJM, IY, IM, ID, FD, J)} +} +\args{GIVEN} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{IY}{I}{year} \\ + \spec{IM}{I}{month} \\ + \spec{ID}{I}{day} \\ + \spec{FD}{D}{fraction of day} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $-$1 = unacceptable date (before 4701BC March 1)} +} +\aref{The algorithm is derived from that of Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_DM2AV}{Rotation Matrix to Axial Vector} +{ + \action{From a rotation matrix, determine the corresponding axial vector + (double precision).} + \call{CALL sla\_DM2AV (RMAT, AXVEC)} +} +\args{GIVEN} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\args{RETURNED} +{ + \spec{AXVEC}{D(3)}{axial vector (radians)} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the {\it Euler axis}, and the angle through + which the reference frame rotates is called the {\it Euler angle}. + The {\it axial vector}\/ returned by this routine has the same + direction as the Euler axis, and its magnitude is the Euler angle + in radians. + \item The magnitude and direction of the axial vector can be separated + by means of the routine sla\_DVN. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \item If RMAT is null, so is the result. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DMAT}{Solve Simultaneous Equations} +{ + \action{Matrix inversion and solution of simultaneous equations + (double precision).} + \call{CALL sla\_DMAT (N, A, Y, D, JF, IW)} +} +\args{GIVEN} +{ + \spec{N}{I}{number of unknowns} \\ + \spec{A}{D(N,N)}{matrix} \\ + \spec{Y}{D(N)}{vector} +} +\args{RETURNED} +{ + \spec{A}{D(N,N)}{matrix inverse} \\ + \spec{Y}{D(N)}{solution} \\ + \spec{D}{D}{determinant} \\ + \spec{JF}{I}{singularity flag: 0=OK} \\ + \spec{IW}{I(N)}{workspace} +} +\notes +{ + \begin{enumerate} + \item For the set of $n$ simultaneous linear equations in $n$ unknowns: + \begin{verse} + {\bf A}$\cdot${\bf y} = {\bf x} + \end{verse} + where: + \begin{itemize} + \item {\bf A} is a non-singular $n \times n$ matrix, + \item {\bf y} is the vector of $n$ unknowns, and + \item {\bf x} is the known vector, + \end{itemize} + sla\_DMAT computes: + \begin{itemize} + \item the inverse of matrix {\bf A}, + \item the determinant of matrix {\bf A}, and + \item the vector of $n$ unknowns {\bf y}. + \end{itemize} + Argument N is the order $n$, A (given) is the matrix {\bf A}, + Y (given) is the vector {\bf x} and Y (returned) + is the vector {\bf y}. + The argument A (returned) is the inverse matrix {\bf A}$^{-1}$, + and D is {\it det}\/({\bf A}). + \item JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=$-$1 + and D=0D0 are returned. In the latter case, the contents + of array A on return are undefined. + \item The algorithm is Gaussian elimination with partial pivoting. + This method is very fast; some much slower algorithms can give + better accuracy, but only by a small factor. + \item This routine replaces the obsolete sla\_DMATRX. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DMOON}{Approx Moon Pos/Vel} +{ + \action{Approximate geocentric position and velocity of the Moon + (double precision).} + \call{CALL sla\_DMOON (DATE, PV)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (loosely ET) as a Modified Julian Date (JD$-$2400000.5) +} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{Moon \xyzxyzd, mean equator and equinox + of date (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item This routine is a full implementation of the algorithm + published by Meeus (see reference). + \item Meeus quotes accuracies of \arcseci{10} in longitude, + \arcseci{3} in latitude and \arcsec{0}{2} arcsec in HP + (equivalent to about 20~km in distance). Comparison with + JPL~DE200 over the interval 1960-2025 gives RMS errors of + \arcsec{3}{7} and 83~mas/hour in longitude, + \arcsec{2}{3} arcsec and 48~mas/hour in latitude, + 11~km and 81~mm/s in distance. + The maximum errors over the same interval are + \arcseci{18} and \arcsec{0}{50}/hour in longitude, + \arcseci{11} and \arcsec{0}{24}/hour in latitude, + 40~km and 0.29~m/s in distance. + \item The original algorithm is expressed in terms of the obsolete + timescale {\it Ephemeris Time}. Either TDB or TT can be used, + but not UT without incurring significant errors (\arcseci{30} at + the present time) due to the Moon's \arcsec{0}{5}/s movement. + \item The algorithm is based on pre IAU 1976 standards. However, + the result has been moved onto the new (FK5) equinox, an + adjustment which is in any case much smaller than the + intrinsic accuracy of the procedure. + \item Velocity is obtained by a complete analytical differentiation + of the Meeus model. + \end{enumerate} +} +\aref{Meeus, {\it l'Astronomie}, June 1984, p348.} +%----------------------------------------------------------------------- +\routine{SLA\_DMXM}{Multiply $3\times3$ Matrices} +{ + \action{Product of two $3\times3$ matrices (double precision).} + \call{CALL sla\_DMXM (A, B, C)} +} +\args{GIVEN} +{ + \spec{A}{D(3,3)}{matrix {\bf A}} \\ + \spec{B}{D(3,3)}{matrix {\bf B}} +} +\args{RETURNED} +{ + \spec{C}{D(3,3)}{matrix result: {\bf A}$\times${\bf B}} +} +\anote{To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended.} +%----------------------------------------------------------------------- +\routine{SLA\_DMXV}{Apply 3D Rotation} +{ + \action{Multiply a 3-vector by a rotation matrix (double precision).} + \call{CALL sla\_DMXV (DM, VA, VB)} +} +\args{GIVEN} +{ + \spec{DM}{D(3,3)}{rotation matrix} \\ + \spec{VA}{D(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{D(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix DM. + \item The main function of this routine is apply a + rotation; under these circumstances, {\bf M} is a + {\it proper real orthogonal}\/ matrix. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DPAV}{Position-Angle Between Two Directions} +{ + \action{Returns the bearing (position angle) of one celestial + direction with respect to another (double precision).} + \call{D~=~sla\_DPAV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{D(3)}{direction cosines of one point} \\ + \spec{V2}{D(3)}{directions cosines of the other point} +} +\args{RETURNED} +{ + \spec{sla\_DPAV}{D}{position-angle of 2nd point with respect to 1st} +} +\notes +{ + \begin{enumerate} + \item The coordinate frames correspond to \radec, + $[\lambda,\phi]$ {\it etc.}. + \item The result is the bearing (position angle), in radians, + of point V2 as seen + from point V1. It is in the range $\pm \pi$. The sense + is such that if V2 + is a small distance due east of V1 the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item The routine sla\_DBEAR performs an equivalent function except + that the points are specified in the form of spherical coordinates. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_DR2AF}{Radians to Deg,Min,Sec,Frac} +{ + \action{Convert an angle in radians to degrees, arcminutes, arcseconds, + fraction (double precision).} + \call{CALL sla\_DR2AF (NDP, ANGLE, SIGN, IDMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of arcseconds} \\ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IDMSF}{I(4)}{degrees, arcminutes, arcseconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE~PRECISION floating-point numbers + on the target machine, and the risk of overflowing IDMSF(4). + For example, on a VAX computer, for ANGLE up to $2\pi$, the available + floating-point precision corresponds roughly to NDP=12. However, + the practical limit is NDP=9, set by the capacity of the 32-bit + integer IDMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to $360^{\circ}$, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DR2TF}{Radians to Hour,Min,Sec,Frac} +{ + \action{Convert an angle in radians to hours, minutes, seconds, + fraction (double precision).} + \call{CALL sla\_DR2TF (NDP, ANGLE, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE PRECISION floating-point numbers + on the target machine, and the risk of overflowing IHMSF(4). + For example, on a VAX computer, for ANGLE up to $2\pi$, the available + floating-point precision corresponds roughly to NDP=12. However, + the practical limit is NDP=9, set by the capacity of the 32-bit + integer IHMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DRANGE}{Put Angle into Range $\pm\pi$} +{ + \action{Normalize an angle into the range $\pm\pi$ (double precision).} + \call{D~=~sla\_DRANGE (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_DRANGE}{D}{ANGLE expressed in the range $\pm\pi$.} +} +%----------------------------------------------------------------------- +\routine{SLA\_DRANRM}{Put Angle into Range $0\!-\!2\pi$} +{ + \action{Normalize an angle into the range $0\!-\!2\pi$ + (double precision).} + \call{D~=~sla\_DRANRM (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_DRANRM}{D}{ANGLE expressed in the range $0\!-\!2\pi$} +} +%----------------------------------------------------------------------- +\routine{SLA\_DS2C6}{Spherical Pos/Vel to Cartesian} +{ + \action{Conversion of position \& velocity in spherical coordinates + to Cartesian coordinates (double precision).} + \call{CALL sla\_DS2C6 (A, B, R, AD, BD, RD, V)} +} +\args{GIVEN} +{ + \spec{A}{D}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{D}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{D}{radial coordinate} \\ + \spec{AD}{D}{longitude derivative (radians per unit time)} \\ + \spec{BD}{D}{latitude derivative (radians per unit time)} \\ + \spec{RD}{D}{radial derivative} +} +\args{RETURNED} +{ + \spec{V}{D(6)}{\xyzxyzd} +} +%----------------------------------------------------------------------- +\routine{SLA\_DS2TP}{Spherical to Tangent Plane} +{ + \action{Projection of spherical coordinates onto the tangent plane + (double precision).} + \call{CALL sla\_DS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{RA,DEC}{D}{spherical coordinates of star (radians)} \\ + \spec{RAZ,DECZ}{D}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{XI,ETA}{D}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DV2TP is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DSEP}{Angle Between 2 Points on Sphere} +{ + \action{Angle between two points on a sphere (double precision).} + \call{D~=~sla\_DSEP (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{D}{spherical coordinates of one point (radians)} \\ + \spec{A2,B2}{D}{spherical coordinates of the other point (radians)} +} +\args{RETURNED} +{ + \spec{sla\_DSEP}{D}{angle between [A1,B1] and [A2,B2] in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are right ascension and declination, + longitude and latitude, {\it etc.}, in radians. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DT}{Approximate ET minus UT} +{ + \action{Estimate $\Delta$T, the offset between dynamical time + and Universal Time, for a given historical epoch.} + \call{D~=~sla\_DT (EPOCH)} +} +\args{GIVEN} +{ + \spec{EPOCH}{D}{(Julian) epoch ({\it e.g.}\ 1850D0)} +} +\args{RETURNED} +{ + \spec{sla\_DT}{D}{approximate ET$-$UT (after 1984, TT$-$UT1) in seconds} +} +\notes +{ + \begin{enumerate} + \item Depending on the epoch, one of three parabolic approximations + is used: +\begin{tabbing} +xx \= xxxxxxxxxxxxxxxxxx \= \kill +\> before AD 979 \> Stephenson \& Morrison's 390 BC to AD 948 model \\ +\> AD 979 to AD 1708 \> Stephenson \& Morrison's AD 948 to AD 1600 model \\ +\> after AD 1708 \> McCarthy \& Babcock's post-1650 model +\end{tabbing} + The breakpoints are chosen to ensure continuity: they occur + at places where the adjacent models give the same answer as + each other. + \item The accuracy is modest, with errors of up to $20^{\rm s}$ during + the interval since 1650, rising to perhaps $30^{\rm m}$ + by 1000~BC. Comparatively accurate values from AD~1600 + are tabulated in + the {\it Astronomical Almanac}\/ (see section K8 of the 1995 + edition). + \item The use of {\tt DOUBLE PRECISION} for both argument and result is + simply for compatibility with other SLALIB time routines. + \item The models used are based on a lunar tidal acceleration value + of \arcsec{-26}{00} per century. + \end{enumerate} +} +\aref{Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + This contains references to the papers by Stephenson \& Morrison + and by McCarthy \& Babcock which describe the models used here.} +%----------------------------------------------------------------------- +\routine{SLA\_DTF2D}{Hour,Min,Sec to Days} +{ + \action{Convert hours, minutes, seconds to days (double precision).} + \call{CALL sla\_DTF2D (IHOUR, IMIN, SEC, DAYS, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{D}{seconds} +} +\args{RETURNED} +{ + \spec{DAYS}{D}{interval in days} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTF2R}{Hour,Min,Sec to Radians} +{ + \action{Convert hours, minutes, seconds to radians (double precision).} + \call{CALL sla\_DTF2R (IHOUR, IMIN, SEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{D}{seconds} +} +\args{RETURNED} +{ + \spec{RAD}{D}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTP2S}{Tangent Plane to Spherical} +{ + \action{Transform tangent plane coordinates into spherical + coordinates (double precision)} + \call{CALL sla\_DTP2S (XI, ETA, RAZ, DECZ, RA, DEC)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane rectangular coordinates (radians)} \\ + \spec{RAZ,DECZ}{D}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{spherical coordinates (radians)} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DTP2V is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTP2V}{Tangent Plane to Direction Cosines} +{ + \action{Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star + (double precision).} + \call{CALL sla\_DTP2V (XI, ETA, V0, V)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane coordinates of star (radians)} \\ + \spec{V0}{D(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{V}{D(3)}{direction cosines of star} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, the returned vector V will + be wrong. + \item If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that $\alpha=0$ at + the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DTP2S. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTPS2C}{Plate centre from $\xi,\eta$ and $\alpha,\delta$} +{ + \action{From the tangent plane coordinates of a star of known \radec, + determine the \radec\ of the tangent point (double precision)} + \call{CALL sla\_DTPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane rectangular coordinates (radians)} \\ + \spec{RA,DEC}{D}{spherical coordinates (radians)} +} +\args{RETURNED} +{ + \spec{RAZ1,DECZ1}{D}{spherical coordinates of tangent point, + solution 1} \\ + \spec{RAZ2,DECZ2}{D}{spherical coordinates of tangent point, + solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The RAZ1 and RAZ2 values returned are in the range $0\!-\!2\pi$. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero $\xi$ value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of $\xi$ and $\delta$. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N\,=\,1 + indicates only one useful solution, the usual case; under + these circumstances, the second solution corresponds to the + ``over-the-pole'' case, and this is reflected in the values + of RAZ2 and DECZ2 which are returned. + \item The DECZ1 and DECZ2 values returned are in the range $\pm\pi$, + but in the ordinary, non-pole-crossing, case, the range is + $\pm\pi/2$. + \item RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2 are all in radians. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DTPV2C is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTPV2C}{Plate centre from $\xi,\eta$ and $x,y,z$} +{ + \action{From the tangent plane coordinates of a star of known + direction cosines, determine the direction cosines + of the tangent point (double precision)} + \call{CALL sla\_DTPV2C (XI, ETA, V, V01, V02, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane coordinates of star (radians)} \\ + \spec{V}{D(3)}{direction cosines of star} +} +\args{RETURNED} +{ + \spec{V01}{D(3)}{direction cosines of tangent point, solution 1} \\ + \spec{V01}{D(3)}{direction cosines of tangent point, solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The vector V must be of unit length or the result will be wrong. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. + N\,=\,1 + indicates only one useful solution, the usual case; under these + circumstances, the second solution can be regarded as valid if + the vector V02 is interpreted as the ``over-the-pole'' case. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DTPS2C. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTT}{TT minus UTC} +{ + \action{Compute $\Delta$TT, the increment to be applied to + Coordinated Universal Time UTC to give + Terrestrial Time TT.} + \call{D~=~sla\_DTT (DJU)} +} +\args{GIVEN} +{ + \spec{DJU}{D}{UTC date as a modified JD (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_DTT}{D}{TT$-$UTC in seconds} +} +\notes +{ + \begin{enumerate} + \item The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can be guaranteed only up to the end of the second + $23^{\rm h}\,59^{\rm m}\,59^{\rm s}$. + \item Pre 1972 January 1 a fixed value of 10 + ET$-$TAI is returned. + \item TT is one interpretation of the defunct timescale + {\it Ephemeris Time}, ET. + \item See also the routine sla\_DT, which roughly estimates ET$-$UT for + historical epochs. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DV2TP}{Direction Cosines to Tangent Plane} +{ + \action{Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates + (double precision).} + \call{CALL sla\_DV2TP (V, V0, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{direction cosines of star} \\ + \spec{V0}{D(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{XI,ETA}{D}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + \item If V0 points at a pole, the returned $\xi,\eta$ + will be based on the + arbitrary assumption that $\alpha=0$ at the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DS2TP. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DVDV}{Scalar Product} +{ + \action{Scalar product of two 3-vectors (double precision).} + \call{D~=~sla\_DVDV (VA, VB)} +} +\args{GIVEN} +{ + \spec{VA}{D(3)}{first vector} \\ + \spec{VB}{D(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_DVDV}{D}{scalar product VA.VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_DVN}{Normalize Vector} +{ + \action{Normalize a 3-vector, also giving the modulus (double precision).} + \call{CALL sla\_DVN (V, UV, VM)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{vector} +} +\args{RETURNED} +{ + \spec{UV}{D(3)}{unit vector in direction of V} \\ + \spec{VM}{D}{modulus of V} +} +\anote{If the modulus of V is zero, UV is set to zero as well.} +%----------------------------------------------------------------------- +\routine{SLA\_DVXV}{Vector Product} +{ + \action{Vector product of two 3-vectors (double precision).} + \call{CALL sla\_DVXV (VA, VB, VC)} +} +\args{GIVEN} +{ + \spec{VA}{D(3)}{first vector} \\ + \spec{VB}{D(3)}{second vector} +} +\args{RETURNED} +{ + \spec{VC}{D(3)}{vector product VA$\times$VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_E2H}{$h,\delta$ to Az,El} +{ + \action{Equatorial to horizon coordinates + (single precision).} + \call{CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} +} +\args{GIVEN} +{ + \spec{HA}{R}{hour angle (radians)} \\ + \spec{DEC}{R}{declination (radians)} \\ + \spec{PHI}{R}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{AZ}{R}{azimuth (radians)} \\ + \spec{EL}{R}{elevation (radians)} +} +\notes +{ + \begin{enumerate} + \item Azimuth is returned in the range $0\!-\!2\pi$; north is zero, + and east is $+\pi/2$. Elevation is returned in the range + $\pm\pi$. + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the {\it observed} \hadec, and the elevation + {\it in vacuo}, which would require the {\it topocentric} + \hadec. + If the effects of diurnal aberration can be neglected, the + {\it apparent} \hadec\ may be used instead of the topocentric + \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EARTH}{Approx Earth Pos/Vel} +{ + \action{Approximate heliocentric position and velocity of the Earth + (single precision).} + \call{CALL sla\_EARTH (IY, ID, FD, PV)} +} +\args{GIVEN} +{ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R}{fraction of day} +} +\args{RETURNED} +{ + \spec{PV}{R(6)}{Earth \xyzxyzd\ (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900~March~1 to 2100~February~28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item The Earth heliocentric 6-vector is referred to the + FK4 mean equator and equinox of date. + \item Maximum/RMS errors 1950-2050: + \begin{itemize} + \item 13/5~$\times10^{-5}$~AU = 19200/7600~km in position + \item 47/26~$\times10^{-10}$~AU~s$^{-1}$ = + 0.0070/0.0039~km~s$^{-1}$ in speed + \end{itemize} + \item More accurate results are obtainable with the routine sla\_EVP. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ECLEQ}{Ecliptic to Equatorial} +{ + \action{Transformation from ecliptic longitude and latitude to + J2000.0 \radec.} + \call{CALL sla\_ECLEQ (DL, DB, DATE, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians)} \\ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{J2000.0 mean \radec\ (radians)} +} +%----------------------------------------------------------------------- +\routine{SLA\_ECMAT}{Form $\alpha,\delta\rightarrow\lambda,\beta$ Matrix} +{ + \action{Form the equatorial to ecliptic rotation matrix (IAU 1980 theory).} + \call{CALL sla\_ECMAT (DATE, RMAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item RMAT is matrix {\bf M} in the expression + {\bf v}$_{ecl}$~=~{\bf M}$\cdot${\bf v}$_{equ}$. + \item The equator, equinox and ecliptic are mean of date. + \end{enumerate} +} +\aref{Murray, C.A., {\it Vectorial Astrometry}, section 4.3.} +%----------------------------------------------------------------------- +\routine{SLA\_ECOR}{RV \& Time Corrns to Sun} +{ + \action{Component of Earth orbit velocity and heliocentric + light time in a given direction.} + \call{CALL sla\_ECOR (RM, DM, IY, ID, FD, RV, TL)} +} +\args{GIVEN} +{ + \spec{RM,DM}{R}{mean \radec\ of date (radians)} \\ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R}{fraction of day} +} +\args{RETURNED} +{ + \spec{RV}{R}{component of Earth orbital velocity (km~s$^{-1}$)} \\ + \spec{TL}{R}{component of heliocentric light time (s)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item Sign convention: + \begin{itemize} + \item The velocity component is +ve when the + Earth is receding from + the given point on the sky. + \item The light time component is +ve + when the Earth lies between the Sun and + the given point on the sky. + \end{itemize} + \item Accuracy: + \begin{itemize} + \item The velocity component is usually within 0.004~km~s$^{-1}$ + of the correct value and is never in error by more than + 0.007~km~s$^{-1}$. + \item The error in light time correction is about + \tsec{0}{03} at worst, + but is usually better than \tsec{0}{01}. + \end{itemize} + For applications requiring higher accuracy, see the sla\_EVP routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EG50}{B1950 $\alpha,\delta$ to Galactic} +{ + \action{Transformation from B1950.0 FK4 equatorial coordinates to + IAU 1958 galactic coordinates.} + \call{CALL sla\_EG50 (DR, DD, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{B1950.0 \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\anote{The equatorial coordinates are B1950.0 FK4. Use the + routine sla\_EQGAL if conversion from J2000.0 FK5 coordinates + is required.} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_EL2UE}{Conventional to Universal Elements} +{ + \action{Transform conventional osculating orbital elements + into ``universal'' form.} + \call{CALL sla\_EL2UE (\vtop{ + \hbox{DATE, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM,} + \hbox{U, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{epoch (TT MJD) of osculation (Note~3)} \\ + \spec{JFORM}{I}{choice of element set (1-3; Note~6)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, + approx} \\ \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.2em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.2em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.2em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.2em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item The ``universal'' elements are those which define the orbit for + the purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The companion routine is sla\_UE2PV. This takes the set of numbers + that the present routine outputs and uses them to derive the + object's position and velocity. A single prediction requires one + call to the present routine followed by one call to sla\_UE2PV; + for convenience, the two calls are packaged as the routine + sla\_PLANEL. Multiple predictions may be made by again calling the + present routine once, but then calling sla\_UE2PV multiple times, + which is faster than multiple calls to sla\_PLANEL. + \item DATE is the epoch of osculation. It is in the TT timescale + (formerly Ephemeris Time, ET) and is a Modified Julian Date + (JD$-$2400000.5). + \item The supplied orbital elements are with respect to the J2000 + ecliptic and equinox. The position and velocity parameters + returned in the array U are with respect to the mean equator and + equinox of epoch J2000, and are for the perihelion prior to the + specified epoch. + \item The universal elements returned in the array U are in canonical + units (solar masses, AU and canonical days). + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> longitude of perihelion $\varpi$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean longitude $L$ (radians) \\ + \> DM \> = \> daily motion $n$ (radians) + \end{tabbing} + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabbing} + \item Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%------------------------------------------------------------------------------ +\routine{SLA\_EPB}{MJD to Besselian Epoch} +{ + \action{Conversion of Modified Julian Date to Besselian Epoch.} + \call{D~=~sla\_EPB (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EPB}{D}{Besselian Epoch} +} +\aref{Lieske, J.H., 1979, {\it Astr.Astrophys.}\ {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPB2D}{Besselian Epoch to MJD} +{ + \action{Conversion of Besselian Epoch to Modified Julian Date.} + \call{D~=~sla\_EPB2D (EPB)} +} +\args{GIVEN} +{ + \spec{EPB}{D}{Besselian Epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPB2D}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\aref{Lieske, J.H., 1979. {\it Astr.Astrophys.}\ {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPCO}{Convert Epoch to B or J} +{ + \action{Convert an epoch to Besselian or Julian to match another one.} + \call{D~=~sla\_EPCO (K0, K, E)} + +} +\args{GIVEN} +{ + \spec{K0}{C}{form of result: `B'=Besselian, `J'=Julian} \\ + \spec{K}{C}{form of given epoch: `B' or `J'} \\ + \spec{E}{D}{epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPCO}{D}{the given epoch converted as necessary} +} +\notes +{ + \begin{enumerate} + \item The result is always either equal to or very close to + the given epoch E. The routine is required only in + applications where punctilious treatment of heterogeneous + mixtures of star positions is necessary. + \item K0 and K are not validated. They are interpreted as follows: + \begin{itemize} + \item If K0 and K are the same, the result is E. + \item If K0 is `B' and K isn't, the conversion is J to B. + \item In all other cases, the conversion is B to J. + \end{itemize} + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EPJ}{MJD to Julian Epoch} +{ + \action{Convert Modified Julian Date to Julian Epoch.} + \call{D~=~sla\_EPJ (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EPJ}{D}{Julian Epoch} +} +\aref{Lieske, J.H., 1979.\ {\it Astr.Astrophys.}, {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPJ2D}{Julian Epoch to MJD} +{ + \action{Convert Julian Epoch to Modified Julian Date.} + \call{D~=~sla\_EPJ2D (EPJ)} +} +\args{GIVEN} +{ + \spec{EPJ}{D}{Julian Epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPJ2D}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\aref{Lieske, J.H., 1979.\ {\it Astr.Astrophys.}, {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EQECL}{J2000 $\alpha,\delta$ to Ecliptic} +{ + \action{Transformation from J2000.0 equatorial coordinates to + ecliptic longitude and latitude.} + \call{CALL sla\_EQECL (DR, DD, DATE, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{J2000.0 mean \radec\ (radians)} \\ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians)} +} +%----------------------------------------------------------------------- +\routine{SLA\_EQEQX}{Equation of the Equinoxes} +{ + \action{Equation of the equinoxes (IAU 1994).} + \call{D~=~sla\_EQEQX (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EQEQX}{D}{The equation of the equinoxes (radians)} +} +\notes{ + \begin{enumerate} + \item The equation of the equinoxes is defined here as GAST~$-$~GMST: + it is added to a {\it mean}\/ sidereal time to give the + {\it apparent}\/ sidereal time. + \item The change from the classic ``textbook'' expression + $\Delta\psi\,cos\,\epsilon$ occurred with IAU Resolution C7, + Recommendation~3 (1994). The new formulation takes into + account cross-terms between the various precession and + nutation quantities, amounting to about 3~milliarcsec. + The transition from the old to the new model officially + takes place on 1997 February~27. + \end{enumerate} +} +\aref{Capitaine, N.\ \& Gontier, A.-M.\ (1993), + {\it Astron. Astrophys.}, + {\bf 275}, 645-650.} +%----------------------------------------------------------------------- +\routine{SLA\_EQGAL}{J2000 $\alpha,\delta$ to Galactic} +{ + \action{Transformation from J2000.0 FK5 equatorial coordinates to + IAU 1958 galactic coordinates.} + \call{CALL sla\_EQGAL (DR, DD, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{J2000.0 \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\anote{The equatorial coordinates are J2000.0 FK5. Use the routine + sla\_EG50 if conversion from B1950.0 FK4 coordinates is required.} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_ETRMS}{E-terms of Aberration} +{ + \action{Compute the E-terms vector -- the part of the annual + aberration which arises from the eccentricity of the + Earth's orbit.} + \call{CALL sla\_ETRMS (EP, EV)} +} +\args{GIVEN} +{ + \spec{EP}{D}{Besselian epoch} +} +\args{RETURNED} +{ + \spec{EV}{D(3)}{E-terms as $[\Delta x, \Delta y, \Delta z\,]$} +} +\anote{Note the use of the J2000 aberration constant (\arcsec{20}{49552}). + This is a reflection of the fact that the E-terms embodied in + existing star catalogues were computed from a variety of + aberration constants. Rather than adopting one of the old + constants the latest value is used here.} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989. {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989. {\it Astr.J.}\ {\bf 97}, 274. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EULER}{Rotation Matrix from Euler Angles} +{ + \action{Form a rotation matrix from the Euler angles -- three + successive rotations about specified Cartesian axes + (single precision).} + \call{CALL sla\_EULER (ORDER, PHI, THETA, PSI, RMAT)} +} +\args{GIVEN} +{ + \spec{ORDER}{C*(*)}{specifies about which axes the rotations occur} \\ + \spec{PHI}{R}{1st rotation (radians)} \\ + \spec{THETA}{R}{2nd rotation (radians)} \\ + \spec{PSI}{R}{3rd rotation (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + \item The characters of ORDER define which axes the three successive + rotations are about. A typical value is `ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old {\it z}-axis, followed by THETA radians about the resulting + {\it x}-axis, + then PSI radians about the resulting {\it z}-axis. In detail: + \begin{itemize} + \item The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labelling/numbering conventions apply; + the {\it xyz} ($\equiv123$) + triad is right-handed. Thus, the `ZXZ' example given above + could be written `zxz' or `313' (or even `ZxZ' or `3xZ'). + \item ORDER is terminated by length or by the first unrecognized + character. + \item Fewer than three rotations are acceptable, in which case + the later angle arguments are ignored. + \end{itemize} + \item Zero rotations produces a unit RMAT. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EVP}{Earth Position \& Velocity} +{ + \action{Barycentric and heliocentric velocity and position of the Earth.} + \call{CALL sla\_EVP (DATE, DEQX, DVB, DPB, DVH, DPH)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as a Modified Julian Date + (JD$-$2400000.5)} \\ + \spec{DEQX}{D}{Julian Epoch ({\it e.g.}\ 2000D0) of mean equator and + equinox of the vectors returned. If DEQX~$<0$, + all vectors are referred to the mean equator and + equinox (FK5) of date DATE.} +} +\args{RETURNED} +{ + \spec{DVB}{D(3)}{barycentric \xyzd, AU~s$^{-1}$} \\ + \spec{DPB}{D(3)}{barycentric \xyz, AU} \\ + \spec{DVH}{D(3)}{heliocentric \xyzd, AU~s$^{-1}$} \\ + \spec{DPH}{D(3)}{heliocentric \xyz, AU} +} +\notes +{ + \begin{enumerate} + \item This routine is used when accuracy is more important + than CPU time, yet the extra complication of reading a + pre-computed ephemeris is not justified. The maximum + deviations from the JPL~DE96 ephemeris are as follows: + \begin{itemize} + \item velocity (barycentric or heliocentric): 420~mm~s$^{-1}$ + \item position (barycentric): 6900~km + \item position (heliocentric): 1600~km + \end{itemize} + \item The routine is an adaption of the BARVEL and BARCOR + subroutines of P.Stumpff, which are described in + {\it Astr.Astrophys.Suppl.Ser.}\ {\bf 41}, 1-8 (1980). + Most of the changes are merely cosmetic and do not affect + the results at all. However, some adjustments have been + made so as to give results that refer to the new (IAU 1976 + `FK5') equinox and precession, although the differences these + changes make relative to the results from Stumpff's original + `FK4' version are smaller than the inherent accuracy of the + algorithm. One minor shortcoming in the original routines + that has {\bf not} been corrected is that slightly better + numerical accuracy could be achieved if the various polynomial + evaluations were to be so arranged that the smallest terms were + computed first. Note also that one of Stumpff's precession + constants differs by \arcsec{0}{001} from the value given in the + {\it Explanatory Supplement}. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FITXY}{Fit Linear Model to Two \xy\ Sets} +{ + \action{Fit a linear model to relate two sets of \xy\ coordinates.} + \call{CALL sla\_FITXY (ITYPE,NP,XYE,XYM,COEFFS,J)} +} +\args{GIVEN} +{ + \spec{ITYPE}{I}{type of model: 4 or 6 (note 1)} \\ + \spec{NP}{I}{number of samples (note 2)} \\ + \spec{XYE}{D(2,NP)}{expected \xy\ for each sample} \\ + \spec{XYM}{D(2,NP)}{measured \xy\ for each sample} +} +\args{RETURNED} +{ + \spec{COEFFS}{D(6)}{coefficients of model (note 3)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $-$1 = illegal ITYPE} \\ + \spec{}{}{\hspace{0.7em} $-$2 = insufficient data} \\ + \spec{}{}{\hspace{0.7em} $-$3 = singular solution} +} +\notes +{ + \begin{enumerate} + \item ITYPE, which must be either 4 or 6, selects the type of model + fitted. Both allowed ITYPE values produce a model COEFFS which + consists of six coefficients, namely the zero points and, for + each of XE and YE, the coefficient of XM and YM. For ITYPE=6, + all six coefficients are independent, modelling squash and shear + as well as origin, scale, and orientation. However, ITYPE=4 + selects the {\it solid body rotation}\/ option; the model COEFFS + still consists of the same six coefficients, but now two of + them are used twice (appropriately signed). Origin, scale + and orientation are still modelled, but not squash or shear -- + the units of X and Y have to be the same. + \item For NC=4, NP must be at least 2. For NC=6, NP must be at + least 3. + \item The model is returned in the array COEFFS. Naming the + six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms {\it measured}\/ coordinates + $[x_{m},y_{m}\,]$ into {\it expected}\/ coordinates + $[x_{e},y_{e}\,]$ as follows: + \begin{verse} + $x_{e} = a + bx_{m} + cy_{m}$ \\ + $y_{e} = d + ex_{m} + fy_{m}$ + \end{verse} + For the {\it solid body rotation}\/ option (ITYPE=4), the + magnitudes of $b$ and $f$, and of $c$ and $e$, are equal. The + signs of these coefficients depend on whether there is a + sign reversal between $[x_{e},y_{e}]$ and $[x_{m},y_{m}]$; + fits are performed + with and without a sign reversal and the best one chosen. + \item Error status values J=$-$1 and $-$2 leave COEFFS unchanged; + if J=$-$3 COEFFS may have been changed. + \item See also sla\_PXY, sla\_INVF, sla\_XY2XY, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK425}{FK4 to FK5} +{ + \action{Convert B1950.0 FK4 star data to J2000.0 FK5. + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU~1976, FK5, Fricke system. The precepts + of Smith~{\it et~al.}\ (see reference~1) are followed, + using the implementation + by Yallop~{\it et~al.}\ (reference~2) of a matrix method + due to Standish. + Kinoshita's development of Andoyer's post-Newcomb precession is + used. The numerical constants from + Seidelmann~{\it et~al.}\ (reference~3) are used canonically.} + \call{CALL sla\_FK425 (\vtop{ + \hbox{R1950,D1950,DR1950,DD1950,P1950,V1950,} + \hbox{R2000,D2000,DR2000,DD2000,P2000,V2000)}}} +} +\args{GIVEN} +{ + \spec{R1950}{D}{B1950.0 $\alpha$ (radians)} \\ + \spec{D1950}{D}{B1950.0 $\delta$ (radians)} \\ + \spec{DR1950}{D}{B1950.0 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 proper motion in $\delta$ + (radians per tropical year)} \\ + \spec{P1950}{D}{B1950.0 parallax (arcsec)} \\ + \spec{V1950}{D}{B1950.0 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\args{RETURNED} +{ + \spec{R2000}{D}{J2000.0 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 $\delta$ (radians)} \\ + \spec{DR2000}{D}{J2000.0 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD2000}{D}{J2000.0 proper motion in $\delta$ + (radians per Julian year)} \\ + \spec{P2000}{D}{J2000.0 parallax (arcsec)} \\ + \spec{V2000}{D}{J2000.0 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or after FK425 + is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch J2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK45Z, sla\_FK524, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK45Z}{FK4 to FK5, no P.M. or Parallax} +{ + \action{Convert B1950.0 FK4 star data to J2000.0 FK5 assuming zero + proper motion in the FK5 frame. + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU~1976, FK5, Fricke system, in such a + way that the FK5 proper motion is zero. Because such a star + has, in general, a non-zero proper motion in the FK4 system, + the routine requires the epoch at which the position in the + FK4 system was determined. The method is from appendix~2 of + reference~1, but using the constants of reference~4.} + \call{CALL sla\_FK45Z (R1950,D1950,BEPOCH,R2000,D2000)} +} +\args{GIVEN} +{ + \spec{R1950}{D}{B1950.0 FK4 $\alpha$ at epoch BEPOCH (radians)} \\ + \spec{D1950}{D}{B1950.0 FK4 $\delta$ at epoch BEPOCH (radians)} \\ + \spec{BEPOCH}{D}{Besselian epoch ({\it e.g.}\ 1979.3D0)} +} +\args{RETURNED} +{ + \spec{R2000}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 FK5 $\delta$ (radians)} +} +\notes +{ + \begin{enumerate} + \item The epoch BEPOCH is strictly speaking Besselian, but + if a Julian epoch is supplied the result will be + affected only to a negligible extent. + \item Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or + after FK45Z is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK425, sla\_FK524, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Aoki, S., {\it et al.}, 1983.\ {\it Astr.Astrophys.}, {\bf 128}, 263. + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK524}{FK5 to FK4} +{ + \action{Convert J2000.0 FK5 star data to B1950.0 FK4. + This routine converts stars from the new, IAU~1976, FK5, Fricke + system, to the old, Bessel-Newcomb, FK4 system. + The precepts of Smith~{\it et~al.}\ (reference~1) are followed, + using the implementation by Yallop~{\it et~al.}\ (reference~2) + of a matrix method due to Standish. Kinoshita's development of + Andoyer's post-Newcomb precession is used. The numerical + constants from Seidelmann~{\it et~al.}\ (reference~3) are + used canonically.} + \call{CALL sla\_FK524 (\vtop{ + \hbox{R2000,D2000,DR2000,DD2000,P2000,V2000,} + \hbox{R1950,D1950,DR1950,DD1950,P1950,V1950)}}} +} +\args{GIVEN} +{ + \spec{R2000}{D}{J2000.0 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 $\delta$ (radians)} \\ + \spec{DR2000}{D}{J2000.0 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD2000}{D}{J2000.0 proper motion in $\delta$ + (radians per Julian year)} \\ + \spec{P2000}{D}{J2000.0 parallax (arcsec)} \\ + \spec{V2000}{D}{J2000 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\args{RETURNED} +{ + \spec{R1950}{D}{B1950.0 $\alpha$ (radians)} \\ + \spec{D1950}{D}{B1950.0 $\delta$ (radians)} \\ + \spec{DR1950}{D}{B1950.0 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 proper motion in $\delta$ + (radians per tropical year)} \\ + \spec{P1950}{D}{B1950.0 parallax (arcsec)} \\ + \spec{V1950}{D}{radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Note that conversion from Julian epoch 2000.0 to Besselian + epoch 1950.0 only is provided for. Conversions involving + other epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or after + FK524 is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK425, sla\_FK45Z, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK52H}{FK5 to Hipparcos} +{ + \action{Transform an FK5 (J2000) position and proper motion + into the frame of the Hipparcos catalogue.} + \call{CALL sla\_FK52H (R5,D5,DR5,DD5,RH,DH,DRH,DDH)} +} +\args{GIVEN} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{J2000.0 FK5 proper motion in $\delta$ + (radians per Julian year)} +} +\args{RETURNED} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{DRH}{D}{Hipparcos proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DDH}{D}{Hipparcos proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK5HZ, sla\_H2FK5, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_FK54Z}{FK5 to FK4, no P.M. or Parallax} +{ + \action{Convert a J2000.0 FK5 star position to B1950.0 FK4 assuming + FK5 zero proper motion and parallax. + This routine converts star positions from the new, IAU~1976, + FK5, Fricke system to the old, Bessel-Newcomb, FK4 system.} + \call{CALL sla\_FK54Z (R2000,D2000,BEPOCH,R1950,D1950,DR1950,DD1950)} +} +\args{GIVEN} +{ + \spec{R2000}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{BEPOCH}{D}{Besselian epoch ({\it e.g.}\ 1950D0)} +} +\args{RETURNED} +{ + \spec{R1950}{D}{B1950.0 FK4 $\alpha$ at epoch BEPOCH (radians)} \\ + \spec{D1950}{D}{B1950.0 FK4 $\delta$ at epoch BEPOCH (radians)} \\ + \spec{DR1950}{D}{B1950.0 FK4 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 FK4 proper motion in $\delta$ + (radians per tropical year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Conversion from Julian epoch 2000.0 to Besselian epoch 1950.0 + only is provided for. Conversions involving other epochs will + require use of the appropriate precession routines before and + after this routine is called. + \item Unlike in the sla\_FK524 routine, the FK5 proper motions, the + parallax and the radial velocity are presumed zero. + \item It was the intention that FK5 should be a close approximation + to an inertial frame, so that distant objects have zero proper + motion; such objects have (in general) non-zero proper motion + in FK4, and this routine returns those {\it fictitious proper + motions}. + \item The position returned by this routine is in the B1950 + reference frame but at Besselian epoch BEPOCH. For + comparison with catalogues the BEPOCH argument will + frequently be 1950D0. + \item See also sla\_FK425, sla\_FK45Z, sla\_FK524. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK5HZ}{FK5 to Hipparcos, no P.M.} +{ + \action{Transform an FK5 (J2000) star position into the frame of the + Hipparcos catalogue, assuming zero Hipparcos proper motion.} + \call{CALL sla\_FK52H (R5,D5,EPOCH,RH,DH)} +} +\args{GIVEN} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{EPOCH}{D}{Julian epoch (TDB)} +} +\args{RETURNED} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK52H, sla\_H2FK5, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_FLOTIN}{Decode a Real Number} +{ + \action{Convert free-format input into single precision floating point.} + \call{CALL sla\_FLOTIN (STRING, NSTRT, RESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{RESLT}{R}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{RESLT}{R}{result} \\ + \spec{JFLAG}{I}{status: $-$1~=~$-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_FLOTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space, and lowercase characters are + interpreted as uppercase. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n.n x \pm n$, + where $\pm$ is a sign + character `+' or `$-$', $n$ means a string of decimal digits, + `.' is a decimal point, and $x$, which indicates an exponent, + means `D' or `E'. Various combinations of these fields can be + omitted, and embedded blanks are permissible in certain places. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Embedded spaces are allowed only after +, $-$, D or E, + and after the decimal point if the first sequence of + digits is absent. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9,.,D,E or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_FLOTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 13, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item Both signs are optional. The default is +. + \item The mantissa $n.n$ defaults to unity. + \item The exponent $x\!\pm\!n$ defaults to `E0'. + \item The strings of decimal digits may be of any length. + \item The decimal point is optional for whole numbers. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$,0-9,.,D or E, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and RESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_FLOTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_FLOTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item a +, $-$, D or E is left unsatisfied; or + \item the decimal point is present without at least + one decimal digit before or after it; or + \item an exponent more than 100 has been presented. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + sla\_FLOTIN does not detect that `1E999' is unacceptable + (on a computer where this is so) + until the entire number has been decoded. + \item Certain highly unlikely combinations of mantissa and + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + \item Decoding is left to right, one pass. + \item See also sla\_DFLTIN and sla\_INTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GALEQ}{Galactic to J2000 $\alpha,\delta$} +{ + \action{Transformation from IAU 1958 galactic coordinates + to J2000.0 FK5 equatorial coordinates.} + \call{CALL sla\_GALEQ (DL, DB, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{J2000.0 \radec} +} +\notes +{ + \begin{enumerate} + \item All arguments are in radians. + \item The equatorial coordinates are J2000.0 FK5. Use the routine + sla\_GE50 if conversion to B1950.0 FK4 coordinates is + required. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GALSUP}{Galactic to Supergalactic} +{ + \action{Transformation from IAU 1958 galactic coordinates to + de Vaucouleurs supergalactic coordinates.} + \call{CALL sla\_GALSUP (DL, DB, DSL, DSB)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\args{RETURNED} +{ + \spec{DSL,DSB}{D}{supergalactic longitude and latitude (radians)} +} +\refs +{ + \begin{enumerate} + \item de Vaucouleurs, de Vaucouleurs, \& Corwin, {\it Second Reference + Catalogue of Bright Galaxies}, U.Texas, p8. + \item Systems \& Applied Sciences Corp., documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + \end{enumerate} + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is $l^{I\!I}=137.37$.) +} +%----------------------------------------------------------------------- +\routine{SLA\_GE50}{B1950 $\alpha,\delta$ to Galactic} +{ + \action{Transformation from IAU 1958 galactic coordinates to + B1950.0 FK4 equatorial coordinates.} + \call{CALL sla\_GE50 (DL, DB, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{B1950.0 \radec} +} +\notes +{ + \begin{enumerate} + \item All arguments are in radians. + \item The equatorial coordinates are B1950.0 FK4. Use the + routine sla\_GALEQ if conversion to J2000.0 FK5 coordinates + is required. + \end{enumerate} +} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_GEOC}{Geodetic to Geocentric} +{ + \action{Convert geodetic position to geocentric.} + \call{CALL sla\_GEOC (P, H, R, Z)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude (geodetic, radians)} \\ + \spec{H}{D}{height above reference spheroid (geodetic, metres)} +} +\args{RETURNED} +{ + \spec{R}{D}{distance from Earth axis (AU)} \\ + \spec{Z}{D}{distance from plane of Earth equator (AU)} +} +\notes +{ + \begin{enumerate} + \item Geocentric latitude can be obtained by evaluating {\tt ATAN2(Z,R)}. + \item IAU 1976 constants are used. + \end{enumerate} +} +\aref{Green, R.M., 1985.\ {\it Spherical Astronomy}, Cambridge U.P., p98.} +%----------------------------------------------------------------------- +\routine{SLA\_GMST}{UT to GMST} +{ + \action{Conversion from universal time UT1 to Greenwich mean + sidereal time.} + \call{D~=~sla\_GMST (UT1)} +} +\args{GIVEN} +{ + \spec{UT1}{D}{universal time (strictly UT1) expressed as + modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_GMST}{D}{Greenwich mean sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item The IAU~1982 expression + (see page~S15 of the 1984 {\it Astronomical + Almanac})\/ is used, but rearranged to reduce rounding errors. This + expression is always described as giving the GMST at $0^{\rm h}$UT; + in fact, it gives the difference between the + GMST and the UT, which happens to equal the GMST (modulo + 24~hours) at $0^{\rm h}$UT each day. In sla\_GMST, the + entire UT is used directly as the argument for the + canonical formula, and the fractional part of the UT is + added separately; note that the factor $1.0027379\cdots$ does + not appear. + \item See also the routine sla\_GMSTA, which + delivers better numerical + precision by accepting the UT date and time as separate arguments. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GMSTA}{UT to GMST (extra precision)} +{ + \action{Conversion from universal time UT1 to Greenwich Mean + sidereal time, with rounding errors minimized.} + \call{D~=~sla\_GMSTA (DATE, UT1)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UT1 date as Modified Julian Date (integer part + of JD$-$2400000.5)} \\ + \spec{UT1}{D}{UT1 time (fraction of a day)} +} +\args{RETURNED} +{ + \spec{sla\_GMST}{D}{Greenwich mean sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item The algorithm is derived from the IAU 1982 expression + (see page~S15 of the 1984 Astronomical Almanac). + \item There is no restriction on how the UT is apportioned between the + DATE and UT1 arguments. Either of the two arguments could, for + example, be zero and the entire date\,+\,time supplied in the other. + However, the routine is designed to deliver maximum accuracy when + the DATE argument is a whole number and the UT1 argument + lies in the range $[\,0,\,1\,]$, or {\it vice versa}. + \item See also the routine sla\_GMST, which accepts the UT1 as a single + argument. Compared with sla\_GMST, the extra numerical precision + delivered by the present routine is unlikely to be important in + an absolute sense, but may be useful when critically comparing + algorithms and in applications where two sidereal times close + together are differenced. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GRESID}{Gaussian Residual} +{ + \action{Generate pseudo-random normal deviate or {\it Gaussian residual}.} + \call{R~=~sla\_GRESID (S)} +} +\args{GIVEN} +{ + \spec{S}{R}{standard deviation} +} +\notes +{ + \begin{enumerate} + \item The results of many calls to this routine will be + normally distributed with mean zero and standard deviation S. + \item The Box-Muller algorithm is used. + \item The implementation is machine-dependent. + \end{enumerate} +} +\aref{Ahrens \& Dieter, 1972.\ {\it Comm.A.C.M.}\ {\bf 15}, 873.} +%----------------------------------------------------------------------- +\routine{SLA\_H2E}{Az,El to $h,\delta$} +{ + \action{Horizon to equatorial coordinates + (single precision).} + \call{CALL sla\_H2E (AZ, EL, PHI, HA, DEC)} +} +\args{GIVEN} +{ + \spec{AZ}{R}{azimuth (radians)} \\ + \spec{EL}{R}{elevation (radians)} \\ + \spec{PHI}{R}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{HA}{R}{hour angle (radians)} \\ + \spec{DEC}{R}{declination (radians)} +} +\notes +{ + \begin{enumerate} + \item The sign convention for azimuth is north zero, east $+\pi/2$. + \item HA is returned in the range $\pm\pi$. Declination is returned + in the range $\pm\pi$. + \item The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied + (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of \hadec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the {\it observed} \hadec, and the elevation + {\it in vacuo}, which will yield the {\it topocentric} + \hadec. If the + effects of diurnal aberration can be neglected, the + topocentric \hadec\ may be used as an approximation to the + {\it apparent} \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_H2FK5}{Hipparcos to FK5} +{ + \action{Transform a Hipparcos star position and proper motion + into the FK5 (J2000) frame.} + \call{CALL sla\_H2FK5 (RH,DH,DRH,DDH,R5,D5,DR5,DD5)} +} +\args{GIVEN} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{DRH}{D}{Hipparcos proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DDH}{D}{Hipparcos proper motion in $\delta$ + (radians per Julian year)} +} +\args{RETURNED} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{FK5 J2000.0 proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK52H, sla\_FK5HZ, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_HFK5Z}{Hipparcos to FK5, no P.M.} +{ + \action{Transform a Hipparcos star position + into the FK5 (J2000) frame assuming zero Hipparcos proper motion.} + \call{CALL sla\_HFK5Z (RH,DH,EPOCH,R5,D5,DR5,DD5)} +} +\args{GIVEN} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{EPOCH}{D}{Julian epoch (TDB)} +} +\args{RETURNED} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{FK5 J2000.0 proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + The order of the rotations, which are very small, + \item It was the intention that Hipparcos should be a close + approximation to an inertial frame, so that distant objects + have zero proper motion; such objects have (in general) + non-zero proper motion in FK5, and this routine returns those + {\it fictitious proper motions.} + \item The position returned by this routine is in the FK5 J2000 + reference frame but at Julian epoch EPOCH. + \item See also sla\_FK52H, sla\_FK5HZ, sla\_H2FK5. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_IMXV}{Apply 3D Reverse Rotation} +{ + \action{Multiply a 3-vector by the inverse of a rotation + matrix (single precision).} + \call{CALL sla\_IMXV (RM, VA, VB)} +} +\args{GIVEN} +{ + \spec{RM}{R(3,3)}{rotation matrix} \\ + \spec{VA}{R(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{R(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$^{T}\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix RM. + \item The main function of this routine is apply an inverse + rotation; under these circumstances, ${\bf M}$ is + {\it orthogonal}, with its inverse the same as its transpose. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_INTIN}{Decode an Integer Number} +{ + \action{Convert free-format input into an integer.} + \call{CALL sla\_INTIN (STRING, NSTRT, IRESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{IRESLT}{I}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{IRESLT}{I}{result} \\ + \spec{JFLAG}{I}{status: $-$1 = $-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_INTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n$, + where $\pm$ is a sign + character `+' or `$-$', and $n$ means a string of decimal digits. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Spaces between the sign and the number are allowed. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9 or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_INTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 9, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item The sign is optional. The default is +. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$ or 0-9, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and IRESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_INTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_INTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item there is a + or $-$ but no number; or + \item the number is greater than $2^{31}-1$. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. + \item See also sla\_FLOTIN and sla\_DFLTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_INVF}{Invert Linear Model} +{ + \action{Invert a linear model of the type produced by the + sla\_FITXY routine.} + \call{CALL sla\_INVF (FWDS,BKWDS,J)} +} +\args{GIVEN} +{ + \spec{FWDS}{D(6)}{model coefficients} +} +\args{RETURNED} +{ + \spec{BKWDS}{D(6)}{inverse model} \\ + \spec{J}{I}{status: 0 = OK, $-$1 = no inverse} +} +\notes +{ + \begin{enumerate} + \item The models relate two sets of \xy\ coordinates as follows. + Naming the six elements of FWDS $a,b,c,d,e$ \& $f$, + where two sets of coordinates $[x_{1},y_{1}]$ and + $[x_{2},y_{2}\,]$ are related thus: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + The present routine generates a new set of coefficients + $p,q,r,s,t$ \& $u$ (the array BKWDS) such that: + \begin{verse} + $x_{1} = p + qx_{2} + ry_{2}$ \\ + $y_{1} = s + tx_{2} + uy_{2}$ + \end{verse} + \item Two successive calls to this routine will deliver a set + of coefficients equal to the starting values. + \item To comply with the ANSI Fortran 77 standard, FWDS and BKWDS must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \item See also sla\_FITXY, sla\_PXY, sla\_XY2XY, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_KBJ}{Select Epoch Prefix} +{ + \action{Select epoch prefix `B' or `J'.} + \call{CALL sla\_KBJ (JB, E, K, J)} +} +\args{GIVEN} +{ + \spec{JB}{I}{sla\_DBJIN prefix status: 0=none, 1=`B', 2=`J'} \\ + \spec{E}{D}{epoch -- Besselian or Julian} +} +\args{RETURNED} +{ + \spec{K}{C}{`B' or `J'} \\ + \spec{J}{I}{status: 0=OK} +} +\anote{The routine is mainly intended for use in conjunction with the + sla\_DBJIN routine. If the value of JB indicates that an explicit + B or J prefix was detected by sla\_DBJIN, a `B' or `J' + is returned to match. If JB indicates that no explicit B or J + was supplied, the choice is made on the basis of the epoch + itself; B is assumed for E $<1984$, otherwise J.} +%----------------------------------------------------------------------- +\routine{SLA\_M2AV}{Rotation Matrix to Axial Vector} +{ + \action{From a rotation matrix, determine the corresponding axial vector + (single precision).} + \call{CALL sla\_M2AV (RMAT, AXVEC)} +} +\args{GIVEN} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\args{RETURNED} +{ + \spec{AXVEC}{R(3)}{axial vector (radians)} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis. + The axis is called the {\it Euler axis}, and the angle through + which the reference frame rotates is called the {\it Euler angle}. + The {\it axial vector}\/ returned by this routine has the same + direction as the Euler axis, and its magnitude is the Euler angle + in radians. + \item The magnitude and direction of the axial vector can be separated + by means of the routine sla\_VN. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \item If RMAT is null, so is the result. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAP}{Mean to Apparent} +{ + \action{Transform star \radec\ from mean place to geocentric apparent. + The reference frames and timescales used are post IAU~1976.} + \call{CALL sla\_MAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{PR,PD}{D}{proper motions: \radec\ changes per Julian year} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{EQ}{D}{epoch and equinox of star data (Julian)} \\ + \spec{DATE}{D}{TDB for apparent place (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item EQ is the Julian epoch specifying both the reference + frame and the epoch of the position -- usually 2000. + For positions where the epoch and equinox are + different, use the routine sla\_PM to apply proper + motion corrections before using this routine. + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item This routine may be wasteful for some applications + because it recomputes the Earth position/velocity and + the precession/nutation matrix each time, and because + it allows for parallax and proper motion. Where + multiple transformations are to be carried out for one + epoch, a faster method is to call the sla\_MAPPA routine + once and then either the sla\_MAPQK routine (which includes + parallax and proper motion) or sla\_MAPQKZ (which assumes + zero parallax and FK5 proper motion). + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPPA}{Mean to Apparent Parameters} +{ + \action{Compute star-independent parameters in preparation for + conversions between mean place and geocentric apparent place. + The parameters produced by this routine are required in the + parallax, light deflection, aberration, and precession/nutation + parts of the mean/apparent transformations. + The reference frames and timescales used are post IAU~1976.} + \call{CALL sla\_MAPPA (EQ, DATE, AMPRMS)} +} +\args{GIVEN} +{ + \spec{EQ}{D}{epoch of mean equinox to be used (Julian)} \\ + \spec{DATE}{D}{TDB (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession/nutation $3\times3$ matrix} +} +\notes +{ + \begin{enumerate} + \item For DATE, the distinction between the required TDB and TT + is always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item The accuracy of the routines using the parameters AMPRMS is + limited by the routine sla\_EVP, used here to compute the + Earth position and velocity by the methods of Stumpff. + The maximum error in the resulting aberration corrections is + about 0.3 milliarcsecond. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to + the mean equinox and equator of epoch EQ. + \item The parameters produced by this routine are used by + sla\_MAPQK and sla\_MAPQKZ. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPQK}{Quick Mean to Apparent} +{ + \action{Quick mean to apparent place: transform a star \radec\ from + mean place to geocentric apparent place, given the + star-independent parameters. The reference frames and + timescales used are post IAU 1976.} + \call{CALL sla\_MAPQK (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{PR,PD}{D}{proper motions: \radec\ changes per Julian year} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession/nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RA,DA}{D }{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item Use of this routine is appropriate when efficiency is important + and where many star positions, all referred to the same equator + and equinox, are to be transformed for one epoch. The + star-independent parameters can be obtained by calling the + sla\_MAPPA routine. + \item If the parallax and proper motions are zero the sla\_MAPQKZ + routine can be used instead. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to + the mean equinox and equator of epoch EQ. + \item Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about \arcseci{920} of the + centre of the Sun's disc. The term has a maximum value of + about \arcsec{1}{85} at this radius, and decreases to zero as + the centre of the disc is approached. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPQKZ}{Quick Mean-Appt, no PM {\it etc.}} +{ + \action{Quick mean to apparent place: transform a star \radec\ from + mean place to geocentric apparent place, given the + star-independent parameters, and assuming zero parallax + and FK5 proper motion. + The reference frames and timescales used are post IAU~1976.} + \call{CALL sla\_MAPQKZ (RM, DM, AMPRMS, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession/nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item Use of this routine is appropriate when efficiency is important + and where many star positions, all with parallax and proper + motion either zero or already allowed for, and all referred to + the same equator and equinox, are to be transformed for one + epoch. The star-independent parameters can be obtained by + calling the sla\_MAPPA routine. + \item The corresponding routine for the case of non-zero parallax + and FK5 proper motion is sla\_MAPQK. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to the + mean equinox and equator of epoch EQ. + \item Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about \arcseci{920} of the + centre of the Sun's disc. The term has a maximum value of + about \arcsec{1}{85} at this radius, and decreases to zero as + the centre of the disc is approached. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MOON}{Approx Moon Pos/Vel} +{ + \action{Approximate geocentric position and velocity of the Moon + (single precision).} + \call{CALL sla\_MOON (IY, ID, FD, PV)} +} +\args{GIVEN} +{ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R }{fraction of day} +} +\args{RETURNED} +{ + \spec{PV}{R(6)}{Moon \xyzxyzd, mean equator and equinox of + date (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item The position is accurate to better than 0.5~arcminute + in direction and 1000~km in distance. The velocity + is accurate to better than \arcsec{0}{5} per hour in direction + and 4~metres per socond in distance. (RMS figures with respect + to JPL DE200 for the interval 1960-2025 are \arcseci{14} and + \arcsec{0}{2} per hour in longitude, \arcseci{9} and \arcsec{0}{2} + per hour in latitude, 350~km and 2~metres per second in distance.) + Note that the distance accuracy is comparatively poor because this + routine is principally intended for computing topocentric direction. + \item This routine is only a partial implementation of the original + Meeus algorithm (reference below), which offers 4 times the + accuracy in direction and 20 times the accuracy in distance + when fully implemented (as it is in sla\_DMOON). + \end{enumerate} +} +\aref{Meeus, {\it l'Astronomie}, June 1984, p348.} +%----------------------------------------------------------------------- +\routine{SLA\_MXM}{Multiply $3\times3$ Matrices} +{ + \action{Product of two $3\times3$ matrices (single precision).} + \call{CALL sla\_MXM (A, B, C)} +} +\args{GIVEN} +{ + \spec{A}{R(3,3)}{matrix {\bf A}} \\ + \spec{B}{R(3,3)}{matrix {\bf B}} +} +\args{RETURNED} +{ + \spec{C}{R(3,3)}{matrix result: {\bf A}$\times${\bf B}} +} +\anote{To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended.} +%----------------------------------------------------------------------- +\routine{SLA\_MXV}{Apply 3D Rotation} +{ + \action{Multiply a 3-vector by a rotation matrix (single precision).} + \call{CALL sla\_MXV (RM, VA, VB)} +} +\args{GIVEN} +{ + \spec{RM}{R(3,3)}{rotation matrix} \\ + \spec{VA}{R(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{R(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix RM. + \item The main function of this routine is apply a + rotation; under these circumstances, ${\bf M}$ is a + {\it proper real orthogonal}\/ matrix. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_NUT}{Nutation Matrix} +{ + \action{Form the matrix of nutation (IAU 1980 theory) for a given date.} + \call{CALL sla\_NUT (DATE, RMATN)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RMATN}{D(3,3)}{nutation matrix} +} +\anote{The matrix is in the sense: + \begin{verse} + {\bf v}$_{true}$ = {\bf M}$\cdot${\bf v}$_{mean}$ + \end{verse} + where {\bf v}$_{true}$ is the star vector relative to the + true equator and equinox of date, {\bf M} is the + $3\times3$ matrix RMATN and + {\bf v}$_{mean}$ is the star vector relative to the + mean equator and equinox of date.} +\refs +{ + \begin{enumerate} + \item Final report of the IAU Working Group on Nutation, + chairman P.K.Seidelmann, 1980. + \item Kaplan, G.H., 1981.\ {\it USNO circular No.\ 163}, pA3-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_NUTC}{Nutation Components} +{ + \action{Nutation (IAU 1980 theory): longitude \& obliquity + components, and mean obliquity.} + \call{CALL sla\_NUTC (DATE, DPSI, DEPS, EPS0)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DPSI,DEPS}{D}{nutation in longitude and obliquity (radians)} \\ + \spec{EPS0}{D}{mean obliquity (radians)} +} +\refs +{ + \begin{enumerate} + \item Final report of the IAU Working Group on Nutation, + chairman P.K.Seidelmann, 1980. + \item Kaplan, G.H., 1981.\ {\it USNO circular no.\ 163}, pA3-6. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_OAP}{Observed to Apparent} +{ + \action{Observed to apparent place.} + \call{CALL sla\_OAP (\vtop{ + \hbox{TYPE, OB1, OB2, DATE, DUT, ELONGM, PHIM,} + \hbox{HM, XP, YP, TDK, PMB, RH, WL, TLR, RAP, DAP)}}} +} +\args{GIVEN} +{ + \spec{TYPE}{C*(*)}{type of coordinates -- `R', `H' or `A' (see below)} \\ + \spec{OB1}{D}{observed Az, HA or RA (radians; Az is N=0, E=$90^{\circ}$)} \\ + \spec{OB2}{D}{observed zenith distance or $\delta$ (radians)} \\ + \spec{DATE}{D }{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (degrees K; std=273.155D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mB; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (degrees K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec} +} +\notes +{ + \begin{enumerate} + \item Only the first character of the TYPE argument is significant. + `R' or `r' indicates that OBS1 and OBS2 are the observed Right + Ascension and Declination; `H' or `h' indicates that they are + Hour Angle (west +ve) and Declination; anything else (`A' or + `a' is recommended) indicates that OBS1 and OBS2 are Azimuth + (north zero, east is $90^{\circ}$) and Zenith Distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed \hadec\ via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. {\it Observed}\/ \radec\ or \hadec\ thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation ({\it n.b.}\ not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent \radec\ is obtained. + \item Frequently, {\it mean}\/ rather than {\it apparent}\, + \radec\ will be required, + in which case further transformations will be necessary. The + sla\_AMP {\it etc.}\ routines will convert + the apparent \radec\ produced + by the present routine into an FK5 J2000 mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should FK4 B1950 + coordinates be needed, the routines sla\_FK524 {\it etc.}\ will also + need to be applied. + \item To convert to apparent \radec\ the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + \item The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the sla\_AOPPA routine. + If nothing has changed significantly except the time, the + sla\_AOPPAT routine may be used to perform the requisite + partial recomputation of AOPRMS. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use + in the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in mB, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in degrees K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52.) Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is proportional to the + pressure and that an accurate P value is important for + precise work. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections from the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_OAPQK}{Quick Observed to Apparent} +{ + \action{Quick observed to apparent place.} + \call{CALL sla\_OAPQK (TYPE, OB1, OB2, AOPRMS, RAP, DAP)} +} +\args{GIVEN} +{ + \spec{TYPE}{C*(*)}{type of coordinates -- `R', `H' or `A' (see below)} \\ + \spec{OB1}{D}{observed Az, HA or RA (radians; Az is N=0, E=$90^{\circ}$)} \\ + \spec{OB2}{D}{observed zenith distance or $\delta$ (radians)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel {(1)} {geodetic latitude (radians)} \\ + \specel {(2,3)} {sine and cosine of geodetic latitude} \\ + \specel {(4)} {magnitude of diurnal aberration vector} \\ + \specel {(5)} {height (HM)} \\ + \specel {(6)} {ambient temperature (TDK)} \\ + \specel {(7)} {pressure (PMB)} \\ + \specel {(8)} {relative humidity (RH)} \\ + \specel {(9)} {wavelength (WL)} \\ + \specel {(10)} {lapse rate (TLR)} \\ + \specel {(11,12)} {refraction constants A and B (radians)} \\ + \specel {(13)} {longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel {(14)} {local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec} +} +\notes +{ + \begin{enumerate} + \item Only the first character of the TYPE argument is significant. + `R' or `r' indicates that OBS1 and OBS2 are the observed Right + Ascension and Declination; `H' or `h' indicates that they are + Hour Angle (west +ve) and Declination; anything else (`A' or + `a' is recommended) indicates that OBS1 and OBS2 are Azimuth + (north zero, east is $90^{\circ}$) and Zenith Distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed \hadec\ via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. {\it Observed}\/ \radec\ or \hadec\ thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation ({\it n.b.}\ not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent \radec\ is obtained. + \item Frequently, {\it mean}\/ rather than {\it apparent}\, + \radec\ will be required, + in which case further transformations will be necessary. The + sla\_AMP {\it etc.}\ routines will convert + the apparent \radec\ produced + by the present routine into an FK5 J2000 mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should FK4 B1950 + coordinates be needed, the routines sla\_FK524 {\it etc.}\ will also + need to be applied. + \item To convert to apparent \radec\ the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + \item The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the sla\_AOPPA routine. + If nothing has changed significantly except the time, the + sla\_AOPPAT routine may be used to perform the requisite + partial recomputation of AOPRMS. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections from the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_OBS}{Observatory Parameters} +{ + \action{Look up an entry in a standard list of + groundbased observing stations parameters.} + \call{CALL sla\_OBS (N, C, NAME, W, P, H)} +} +\args{GIVEN} +{ + \spec{N}{I}{number specifying observing station} +} +\args{GIVEN or RETURNED} +{ + \spec{C}{C*(*)}{identifier specifying observing station} +} +\args{RETURNED} +{ + \spec{NAME}{C*(*)}{name of specified observing station} \\ + \spec{W}{D}{longitude (radians, west +ve)} \\ + \spec{P}{D}{geodetic latitude (radians, north +ve)} \\ + \spec{H}{D}{height above sea level (metres)} +} +\notes +{ + \begin{enumerate} + \item Station identifiers C may be up to 10 characters long, + and station names NAME may be up to 40 characters long. + \item C and N are {\it alternative}\/ ways of specifying the observing + station. The C option, which is the most generally useful, + may be selected by specifying an N value of zero or less. + If N is 1 or more, the parameters of the Nth station + in the currently supported list are interrogated, and + the station identifier C is returned as well as NAME, W, + P and H. + \item If the station parameters are not available, either because + the station identifier C is not recognized, or because an + N value greater than the number of stations supported is + given, a name of `?' is returned and W, P and H are left in + their current states. + \item Programs can obtain a list of all currently supported + stations by calling the routine repeatedly, with N=1,2,3... + When NAME=`?' is seen, the list of stations has been + exhausted. The stations at the time of writing are listed + below. + \item Station numbers, identifiers, names and other details are + subject to change and should not be hardwired into + application programs. + \item All station identifiers C are uppercase only; lower case + characters must be converted to uppercase by the calling + program. The station names returned may contain both upper- + and lowercase. All characters up to the first space are + checked; thus an abbreviated ID will return the parameters + for the first station in the list which matches the + abbreviation supplied, and no station in the list will ever + contain embedded spaces. C must not have leading spaces. + \item IMPORTANT -- BEWARE OF THE LONGITUDE SIGN CONVENTION. The + longitude returned by sla\_OBS is + {\bf west-positive}, following the pre-1984 {\it Astronomical + Almanac}. However, this sign convention is left-handed and is + the opposite of the one now used; elsewhere in + SLALIB the preferable east-positive convention is used. In + particular, note that for use in sla\_AOP, sla\_AOPPA and + sla\_OAP the sign of the longitude must be reversed. + \item Users are urged to inform the author of any improvements + they would like to see made. For example: + \begin{itemize} + \item typographical corrections + \item more accurate parameters + \item better station identifiers or names + \item additional stations + \end{itemize} + \end{enumerate} +Stations supported by sla\_OBS at the time of writing: +\begin{tabbing} +xxxxxxxxxxxxxxxxx \= \kill +{\it ID} \> {\it NAME} \\ \\ +AAT \> Anglo-Australian 3.9m Telescope \\ +ANU2.3 \> Siding Spring 2.3 metre \\ +APO3.5 \> Apache Point 3.5m \\ +ARECIBO \> Arecibo 1000 foot \\ +ATCA \> Australia Telescope Compact Array \\ +BLOEMF \> Bloemfontein 1.52 metre \\ +BOSQALEGRE \> Bosque Alegre 1.54 metre \\ +CAMB1MILE \> Cambridge 1 mile \\ +CAMB5KM \> Cambridge 5km \\ +CATALINA61 \> Catalina 61 inch \\ +CFHT \> Canada-France-Hawaii 3.6m Telescope \\ +CSO \> Caltech Sub-mm Observatory, Mauna Kea \\ +DAO72 \> DAO Victoria BC 1.85 metre \\ +DUNLAP74 \> David Dunlap 74 inch \\ +DUPONT \> Du Pont 2.5m Telescope, Las Campanas \\ +EFFELSBERG \> Effelsberg 100 metre \\ +ESO3.6 \> ESO 3.6 metre \\ +ESONTT \> ESO 3.5 metre NTT \\ +ESOSCHM \> ESO 1 metre Schmidt, La Silla \\ +FCRAO \> Five College Radio Astronomy Obs \\ +FLAGSTF61 \> USNO 61 inch astrograph, Flagstaff \\ +GBVA140 \> Greenbank 140 foot \\ +GBVA300 \> Greenbank 300 foot \\ +GEMININ \> Gemini North 8-m telescope \\ +HARVARD \> Harvard College Observatory 1.55m \\ +HPROV1.52 \> Haute Provence 1.52 metre \\ +HPROV1.93 \> Haute Provence 1.93 metre \\ +IRTF \> NASA IR Telescope Facility, Mauna Kea \\ +JCMT \> JCMT 15 metre \\ +JODRELL1 \> Jodrell Bank 250 foot \\ +KECK1 \> Keck 10m Telescope 1 \\ +KECK2 \> Keck 10m Telescope 2 \\ +KISO \> Kiso 1.05 metre Schmidt, Japan \\ +KOTTAMIA \> Kottamia 74 inch \\ +KPNO158 \> Kitt Peak 158 inch \\ +KPNO36FT \> Kitt Peak 36 foot \\ +KPNO84 \> Kitt Peak 84 inch \\ +KPNO90 \> Kitt Peak 90 inch \\ +LICK120 \> Lick 120 inch \\ +LOWELL72 \> Perkins 72 inch, Lowell \\ +LPO1 \> Jacobus Kapteyn 1m Telescope \\ +LPO2.5 \> Isaac Newton 2.5m Telescope \\ +LPO4.2 \> William Herschel 4.2m Telescope \\ +MAUNAK88 \> Mauna Kea 88 inch \\ +MCDONLD2.1 \> McDonald 2.1 metre \\ +MCDONLD2.7 \> McDonald 2.7 metre \\ +MMT \> MMT, Mt Hopkins \\ +MOPRA \> ATNF Mopra Observatory \\ +MTEKAR \> Mt Ekar 1.82 metre \\ +MTHOP1.5 \> Mt Hopkins 1.5 metre \\ +MTLEMMON60 \> Mt Lemmon 60 inch \\ +NOBEYAMA \> Nobeyama 45 metre \\ +OKAYAMA \> Okayama 1.88 metre \\ +PALOMAR200 \> Palomar 200 inch \\ +PALOMAR48 \> Palomar 48-inch Schmidt \\ +PALOMAR60 \> Palomar 60 inch \\ +PARKES \> Parkes 64 metre \\ +QUEBEC1.6 \> Quebec 1.6 metre \\ +SAAO74 \> Sutherland 74 inch \\ +SANPM83 \> San Pedro Martir 83 inch \\ +ST.ANDREWS \> St Andrews University Observatory \\ +STEWARD90 \> Steward 90 inch \\ +STROMLO74 \> Mount Stromlo 74 inch \\ +SUBARU \> Subaru 8 metre \\ +SUGARGROVE \> Sugar Grove 150 foot \\ +TAUTNBG \> Tautenburg 2 metre \\ +TAUTSCHM \> Tautenberg 1.34 metre Schmidt \\ +TIDBINBLA \> Tidbinbilla 64 metre \\ +TOLOLO1.5M \> Cerro Tololo 1.5 metre \\ +TOLOLO4M \> Cerro Tololo 4 metre \\ +UKIRT \> UK Infra Red Telescope \\ +UKST \> UK 1.2 metre Schmidt, Siding Spring \\ +USSR6 \> USSR 6 metre \\ +USSR600 \> USSR 600 foot \\ +VLA \> Very Large Array +\end{tabbing} +} +%----------------------------------------------------------------------- +\routine{SLA\_PA}{$h,\delta$ to Parallactic Angle} +{ + \action{Hour angle and declination to parallactic angle + (double precision).} + \call{D~=~sla\_PA (HA, DEC, PHI)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle in radians (geocentric apparent)} \\ + \spec{DEC}{D}{declination in radians (geocentric apparent)} \\ + \spec{PHI}{D}{latitude in radians (geodetic)} +} +\args{RETURNED} +{ + \spec{sla\_PA}{D}{parallactic angle (radians, in the range $\pm \pi$)} +} +\notes +{ + \begin{enumerate} + \item The parallactic angle at a point in the sky is the position + angle of the vertical, {\it i.e.}\ the angle between the direction to + the pole and to the zenith. In precise applications care must + be taken only to use geocentric apparent \hadec\ and to consider + separately the effects of atmospheric refraction and telescope + mount errors. + \item At the pole a zero result is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PAV}{Position-Angle Between Two Directions} +{ + \action{Returns the bearing (position angle) of one celestial + direction with respect to another (single precision).} + \call{R~=~sla\_PAV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{R(3)}{direction cosines of one point} \\ + \spec{V2}{R(3)}{directions cosines of the other point} +} +\args{RETURNED} +{ + \spec{sla\_PAV}{R}{position-angle of 2nd point with respect to 1st} +} +\notes +{ + \begin{enumerate} + \item The coordinate frames correspond to \radec, + $[\lambda,\phi]$ {\it etc.}. + \item The result is the bearing (position angle), in radians, + of point V2 as seen + from point V1. It is in the range $\pm \pi$. The sense + is such that if V2 + is a small distance due east of V1 the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item The routine sla\_BEAR performs an equivalent function except + that the points are specified in the form of spherical coordinates. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PCD}{Apply Radial Distortion} +{ + \action{Apply pincushion/barrel distortion to a tangent-plane \xy.} + \call{CALL sla\_PCD (DISCO,X,Y)} +} +\args{GIVEN} +{ + \spec{DISCO}{D}{pincushion/barrel distortion coefficient} \\ + \spec{X,Y}{D}{tangent-plane \xy} +} +\args{RETURNED} +{ + \spec{X,Y}{D}{distorted \xy} +} +\notes +{ + \begin{enumerate} + \item The distortion is of the form $\rho = r (1 + c r^{2})$, where $r$ is + the radial distance from the tangent point, $c$ is the DISCO + argument, and $\rho$ is the radial distance in the presence of + the distortion. + \item For {\it pincushion}\/ distortion, C is +ve; for + {\it barrel}\/ distortion, C is $-$ve. + \item For X,Y in units of one projection radius (in the case of + a photographic plate, the focal length), the following + DISCO values apply: + + \vspace{2ex} + + \hspace{5em} + \begin{tabular}{|l|c|} \hline + Geometry & DISCO \\ \hline \hline + astrograph & 0.0 \\ \hline + Schmidt & $-$0.3333 \\ \hline + AAT PF doublet & +147.069 \\ \hline + AAT PF triplet & +178.585 \\ \hline + AAT f/8 & +21.20 \\ \hline + JKT f/8 & +14.6 \\ \hline + \end{tabular} + + \vspace{2ex} + + \item There is a companion routine, sla\_UNPCD, which performs + an approximately inverse operation. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PDA2H}{H.A.\ for a Given Azimuth} +{ + \action{Hour Angle corresponding to a given azimuth (double precision).} + \call{CALL sla\_PDA2H (P, D, A, H1, J1, H2, J2)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude} \\ + \spec{D}{D}{declination} \\ + \spec{A}{D}{azimuth} +} +\args{RETURNED} +{ + \spec{H1}{D}{hour angle: first solution if any} \\ + \spec{J1}{I}{flag: 0 = solution 1 is valid} \\ + \spec{H2}{D}{hour angle: second solution if any} \\ + \spec{J2}{I}{flag: 0 = solution 2 is valid} +} +%----------------------------------------------------------------------- +\routine{SLA\_PDQ2H}{H.A.\ for a Given P.A.} +{ + \action{Hour Angle corresponding to a given parallactic angle + (double precision).} + \call{CALL sla\_PDQ2H (P, D, Q, H1, J1, H2, J2)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude} \\ + \spec{D}{D}{declination} \\ + \spec{Q}{D}{azimuth} +} +\args{RETURNED} +{ + \spec{H1}{D}{hour angle: first solution if any} \\ + \spec{J1}{I}{flag: 0 = solution 1 is valid} \\ + \spec{H2}{D}{hour angle: second solution if any} \\ + \spec{J2}{I}{flag: 0 = solution 2 is valid} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PERTEL}{Perturbed Orbital Elements} +{ + \action{Update the osculating elements of an asteroid or comet by + applying planetary perturbations.} + \call{CALL sla\_PERTEL (\vtop{ + \hbox{JFORM, DATE0, DATE1,} + \hbox{EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0,} + \hbox{EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1,} + \hbox{JSTAT)}}} +} +\args{GIVEN (format and dates)} +{ + \spec{JFORM}{I}{choice of element set (2 or 3; Note~1)} \\ + \spec{DATE0}{D}{date of osculation (TT MJD) for the given} \\ + \spec{}{}{\hspace{1.5em} elements} \\ + \spec{DATE1}{D}{date of osculation (TT MJD) for the updated} \\ + \spec{}{}{\hspace{1.5em} elements} +} +\args{GIVEN (the unperturbed elements)} +{ + \spec{EPOCH0}{D}{epoch of the given element set + ($t_0$ or $T$, TT MJD;} \\ + \spec{}{}{\hspace{1.5em} Note~2)} \\ + \spec{ORBI0}{D}{inclination ($i$, radians)} \\ + \spec{ANODE0}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH0}{D}{argument of perihelion + ($\omega$, radians)} \\ + \spec{AORQ0}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E0}{D}{eccentricity ($e$)} \\ + \spec{AM0}{D}{mean anomaly ($M$, radians, JFORM=2 only)} +} +\args{RETURNED (the updated elements)} +{ + \spec{EPOCH1}{D}{epoch of the updated element set + ($t_0$ or $T$,} \\ + \spec{}{}{\hspace{1.5em} TT MJD; Note~2)} \\ + \spec{ORBI1}{D}{inclination ($i$, radians)} \\ + \spec{ANODE1}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH1}{D}{argument of perihelion + ($\omega$, radians)} \\ + \spec{AORQ1}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E1}{D}{eccentricity ($e$)} \\ + \spec{AM1}{D}{mean anomaly ($M$, radians, JFORM=2 only)} +} +\args{RETURNED (status flag)} +{ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{0.5em}+102 = warning, distant epoch} \\ + \spec{}{}{\hspace{0.5em}+101 = warning, large timespan + ($>100$ years)} \\ + \spec{}{}{\hspace{-1.3em}+1 to +8 = coincident with major planet + (Note~6)} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.2em} $-$2 = illegal E0} \\ + \spec{}{}{\hspace{1.2em} $-$3 = illegal AORQ0} \\ + \spec{}{}{\hspace{1.2em} $-$4 = internal error} \\ + \spec{}{}{\hspace{1.2em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item Two different element-format options are supported, as follows. \\ + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabbing} + \item DATE0, DATE1, EPOCH0 and EPOCH1 are all instants of time in + the TT timescale (formerly Ephemeris Time, ET), expressed + as Modified Julian Dates (JD$-$2400000.5). + \begin{itemize} + \item DATE0 is the instant at which the given + ({\it i.e.}\ unperturbed) osculating elements are correct. + \item DATE1 is the specified instant at which the updated osculating + elements are correct. + \item EPOCH0 and EPOCH1 will be the same as DATE0 and DATE1 + (respectively) for the JFORM=2 case, normally used for minor + planets. For the JFORM=3 case, the two epochs will refer to + perihelion passage and so will not, in general, be the same as + DATE0 and/or DATE1 though they may be similar to one another. + \end{itemize} + \item The elements are with respect to the J2000 ecliptic and mean equinox. + \item Unused elements (AM0 and AM1 for JFORM=3) are not accessed. + \item See the sla\_PERTUE routine for details of the algorithm used. + \item This routine is not intended to be used for major planets, which + is why JFORM=1 is not available and why there is no opportunity + to specify either the longitude of perihelion or the daily + motion. However, if JFORM=2 elements are somehow obtained for a + major planet and supplied to the routine, sensible results will, + in fact, be produced. This happens because the sla\_PERTUE routine + that is called to perform the calculations checks the separation + between the body and each of the planets and interprets a + suspiciously small value (0.001~AU) as an attempt to apply it to + the planet concerned. If this condition is detected, the + contribution from that planet is ignored, and the status is set to + the planet number (Mercury=1,\ldots,Neptune=8) as a warning. + \end{enumerate} +} +\aref{Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199.} +%------------------------------------------------------------------------------ +\routine{SLA\_PERTUE}{Perturbed Universal Elements} +{ + \action{Update the universal elements of an asteroid or comet by + applying planetary perturbations.} + \call{CALL sla\_PERTUE (DATE, U, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE1}{D}{final epoch (TT MJD) for the updated elements} +} +\args{GIVEN and RETURNED} +{ + \spec{U}{D(13)}{universal elements (updated in place)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v_0}$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} +} +\args{RETURNED} +{ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{0.5em}+102 = warning, distant epoch} \\ + \spec{}{}{\hspace{0.5em}+101 = warning, large timespan + ($>100$ years)} \\ + \spec{}{}{\hspace{-1.3em}+1 to +8 = coincident with major planet + (Note~5)} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = numerical error} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The universal elements are with respect to the J2000 equator and + equinox. + \item The epochs DATE, U(3) and U(12) are all Modified Julian Dates + (JD$-$2400000.5). + \item The algorithm is a simplified form of Encke's method. It takes as + a basis the unperturbed motion of the body, and numerically + integrates the perturbing accelerations from the major planets. + The expression used is essentially Sterne's 6.7-2 (reference 1). + Everhart and Pitkin (reference 2) suggest rectifying the orbit at + each integration step by propagating the new perturbed position + and velocity as the new universal variables. In the present + routine the orbit is rectified less frequently than this, in order + to gain a slight speed advantage. However, the rectification is + done directly in terms of position and velocity, as suggested by + Everhart and Pitkin, bypassing the use of conventional orbital + elements. + + The $f(q)$ part of the full Encke method is not used. The purpose + of this part is to avoid subtracting two nearly equal quantities + when calculating the ``indirect member'', which takes account of the + small change in the Sun's attraction due to the slightly displaced + position of the perturbed body. A simpler, direct calculation in + double precision proves to be faster and not significantly less + accurate. + + Apart from employing a variable timestep, and occasionally + ``rectifying the orbit'' to keep the indirect member small, the + integration is done in a fairly straightforward way. The + acceleration estimated for the middle of the timestep is assumed + to apply throughout that timestep; it is also used in the + extrapolation of the perturbations to the middle of the next + timestep, to predict the new disturbed position. There is no + iteration within a timestep. + + Measures are taken to reach a compromise between execution time + and accuracy. The starting-point is the goal of achieving + arcsecond accuracy for ordinary minor planets over a ten-year + timespan. This goal dictates how large the timesteps can be, + which in turn dictates how frequently the unperturbed motion has + to be recalculated from the osculating elements. + + Within predetermined limits, the timestep for the numerical + integration is varied in length in inverse proportion to the + magnitude of the net acceleration on the body from the major + planets. + + The numerical integration requires estimates of the major-planet + motions. Approximate positions for the major planets (Pluto + alone is omitted) are obtained from the routine sla\_PLANET. Two + levels of interpolation are used, to enhance speed without + significantly degrading accuracy. At a low frequency, the routine + sla\_PLANET is called to generate updated position+velocity ``state + vectors''. The only task remaining to be carried out at the full + frequency ({\it i.e.}\ at each integration step) is to use the state + vectors to extrapolate the planetary positions. In place of a + strictly linear extrapolation, some allowance is made for the + curvature of the orbit by scaling back the radius vector as the + linear extrapolation goes off at a tangent. + + Various other approximations are made. For example, perturbations + by Pluto and the minor planets are neglected, relativistic effects + are not taken into account and the Earth-Moon system is treated as + a single body. + + In the interests of simplicity, the background calculations for + the major planets are carried out {\it en masse.} + The mean elements and + state vectors for all the planets are refreshed at the same time, + without regard for orbit curvature, mass or proximity. + + \item This routine is not intended to be used for major planets. + However, if major-planet elements are supplied, sensible results + will, in fact, be produced. This happens because the routine + checks the separation between the body and each of the planets and + interprets a suspiciously small value (0.001~AU) as an attempt to + apply the routine to the planet concerned. If this condition + is detected, the + contribution from that planet is ignored, and the status is set to + the planet number (Mercury=1,\ldots,Neptune=8) as a warning. + \end{enumerate} +} +\refs{ + \begin{enumerate} + \item Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199. + \item Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PLANEL}{Planet Position from Elements} +{ + \action{Heliocentric position and velocity of a planet, + asteroid or comet, starting from orbital elements.} + \call{CALL sla\_PLANEL (\vtop{ + \hbox{DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, PV, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} \\ + \spec{JFORM}{I}{choice of element set (1-3, see Note~3, below)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.5em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.5em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.5em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item DATE is the instant for which the prediction is + required. It is in the TT timescale (formerly + Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The elements are with respect to + the J2000 ecliptic and equinox. + \item Three different element-format options are available, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> longitude of perihelion $\varpi$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean longitude $L$ (radians) \\ + \> DM \> = \> daily motion $n$ (radians) + \end{tabbing} + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabbing} + \item Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + \item The reference frame for the result is equatorial and is with + respect to the mean equinox and ecliptic of epoch J2000. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%------------------------------------------------------------------------------ +\routine{SLA\_PLANET}{Planetary Ephemerides} +{ + \action{Approximate heliocentric position and velocity of a planet.} + \call{CALL sla\_PLANET (DATE, NP, PV, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} \\ + \spec{NP}{I}{planet:} \\ + \spec{}{}{\hspace{1.5em} 1\,=\,Mercury} \\ + \spec{}{}{\hspace{1.5em} 2\,=\,Venus} \\ + \spec{}{}{\hspace{1.5em} 3\,=\,Earth-Moon Barycentre} \\ + \spec{}{}{\hspace{1.5em} 4\,=\,Mars} \\ + \spec{}{}{\hspace{1.5em} 5\,=\,Jupiter} \\ + \spec{}{}{\hspace{1.5em} 6\,=\,Saturn} \\ + \spec{}{}{\hspace{1.5em} 7\,=\,Uranus} \\ + \spec{}{}{\hspace{1.5em} 8\,=\,Neptune} \\ + \spec{}{}{\hspace{1.5em} 9\,=\,Pluto} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} $+$1 = warning: date outside of range} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal NP (outside 1-9)} \\ + \spec{}{}{\hspace{1.5em} $-$2 = solution didn't converge} +} +\notes +{ + \begin{enumerate} + \item The epoch, DATE, is in the TDB timescale and is in the form + of a Modified Julian Date (JD$-$2400000.5). + \item The reference frame is equatorial and is with respect to + the mean equinox and ecliptic of epoch J2000. + \item If a planet number, NP, outside the range 1-9 is supplied, an error + status is returned (JSTAT~=~$-1$) and the PV vector + is set to zeroes. + \item The algorithm for obtaining the mean elements of the + planets from Mercury to Neptune is due to + J.\,L.\,Simon, P.\,Bretagnon, J.\,Chapront, + M.\,Chapront-Touze, G.\,Francou and J.\,Laskar (Bureau des + Longitudes, Paris, France). The (completely different) + algorithm for calculating the ecliptic coordinates of + Pluto is by Meeus. + \item Comparisons of the present routine with the JPL DE200 ephemeris + give the following RMS errors over the interval 1960-2025: + \begin{tabbing} + xxxxx \= xxxxxxxxxxxxxxxxx \= xxxxxxxxxxxxxx \= \kill + \> \> {\it position (km)} \> {\it speed (metre/sec)} \\ \\ + \> Mercury \> \hspace{2em}334 \> \hspace{2.5em}0.437 \\ + \> Venus \> \hspace{1.5em}1060 \> \hspace{2.5em}0.855 \\ + \> EMB \> \hspace{1.5em}2010 \> \hspace{2.5em}0.815 \\ + \> Mars \> \hspace{1.5em}7690 \> \hspace{2.5em}1.98 \\ + \> Jupiter \> \hspace{1em}71700 \> \hspace{2.5em}7.70 \\ + \> Saturn \> \hspace{0.5em}199000 \> \hspace{2em}19.4 \\ + \> Uranus \> \hspace{0.5em}564000 \> \hspace{2em}16.4 \\ + \> Neptune \> \hspace{0.5em}158000 \> \hspace{2em}14.4 \\ + \> Pluto \> \hspace{1em}36400 \> \hspace{2.5em}0.137 + \end{tabbing} + From comparisons with DE102, Simon {\it et al.}\/ quote the following + longitude accuracies over the interval 1800-2200: + \begin{tabbing} + xxxxx \= xxxxxxxxxxxxxxxxxxxx \= \kill + \> Mercury \> \hspace{0.5em}\arcseci{4} \\ + \> Venus \> \hspace{0.5em}\arcseci{5} \\ + \> EMB \> \hspace{0.5em}\arcseci{6} \\ + \> Mars \> \arcseci{17} \\ + \> Jupiter \> \arcseci{71} \\ + \> Saturn \> \arcseci{81} \\ + \> Uranus \> \arcseci{86} \\ + \> Neptune \> \arcseci{11} + \end{tabbing} + In the case of Pluto, Meeus quotes an accuracy of \arcsec{0}{6} + in longitude and \arcsec{0}{2} in latitude for the period + 1885-2099. + + For all except Pluto, over the period 1000-3000, + the accuracy is better than 1.5 + times that over 1800-2200. Outside the interval 1000-3000 the + accuracy declines. For Pluto the accuracy declines rapidly + outside the period 1885-2099. Outside these ranges + (1885-2099 for Pluto, 1000-3000 for the rest) a ``date out + of range'' warning status ({\tt JSTAT=+1}) is returned. + \item The algorithms for (i)~Mercury through Neptune and + (ii)~Pluto are completely independent. In the Mercury + through Neptune case, the present SLALIB + implementation differs from the original + Simon {\it et al.}\/ Fortran code in the following respects: + \begin{itemize} + \item The date is supplied as a Modified Julian Date rather + a Julian Date (${\rm MJD} = ({\rm JD} - 2400000.5$). + \item The result is returned only in equatorial + Cartesian form; the ecliptic + longitude, latitude and radius vector are not returned. + \item The velocity is in AU per second, not AU per day. + \item Different error/warning status values are used. + \item Kepler's Equation is not solved inline. + \item Polynomials in T are nested to minimize rounding errors. + \item Explicit double-precision constants are used to avoid + mixed-mode expressions. + \item There are other, cosmetic, changes to comply with + Starlink/SLALIB style guidelines. + \end{itemize} + None of the above changes affects the result significantly. + \item NP\,=\,3 the result is for the Earth-Moon Barycentre. To + obtain the heliocentric position and velocity of the Earth, + either use the SLALIB routine sla\_EVP or call sla\_DMOON and + subtract 0.012150581 times the geocentric Moon vector from + the EMB vector produced by the present routine. (The Moon + vector should be precessed to J2000 first, but this can + be omitted for modern epochs without introducing significant + inaccuracy.) + \end{enumerate} +\refs +{ + \begin{enumerate} + \item Simon {\it et al.,}\/ + Astron.\ Astrophys.\ {\bf 282}, 663 (1994). + \item Meeus, J., + {\it Astronomical Algorithms,}\/ Willmann-Bell (1991). + \end{enumerate} +} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PLANTE}{\radec\ of Planet from Elements} +{ + \action{Topocentric apparent \radec\ of a Solar-System object whose + heliocentric orbital elements are known.} + \call{CALL sla\_PLANTE (\vtop{ + \hbox{DATE, ELONG, PHI, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, RA, DEC, R, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{MJD of observation (JD$-$2400000.5)} \\ + \spec{ELONG,PHI}{D}{observer's longitude (east +ve) and latitude} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{JFORM}{I}{choice of element set (1-3, see Note~4, below)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude ($M$ or $L$,} \\ + \spec{}{}{\hspace{1.5em} radians, JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{topocentric apparent \radec\ (radians)} \\ + \spec{R}{D}{distance from observer (AU)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.5em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.5em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.5em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item DATE is the instant for which the prediction is + required. It is in the TT timescale (formerly + Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The longitude and latitude allow correction for geocentric + parallax. This is usually a small effect, but can become + important for Earth-crossing asteroids. Geocentric positions + can be generated by appropriate use of the routines + sla\_EVP and sla\_PLANEL. + \item The elements are with respect to the J2000 ecliptic and equinox. + \item Three different element-format options are available, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabbing} + xxx \= xxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> longitude of perihelion $\varpi$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ \\ + \> AORL \> = \> mean longitude $L$ (radians) \\ + \> DM \> = \> daily motion $n$ (radians) + \end{tabbing} + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ + \end{tabbing} + \item Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PM}{Proper Motion} +{ + \action{Apply corrections for proper motion to a star \radec.} + \call{CALL sla\_PM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1)} +} +\args{GIVEN} +{ + \spec{R0,D0}{D}{\radec\ at epoch EP0 (radians)} \\ + \spec{PR,PD}{D}{proper motions: rate of change of + \radec\ (radians per year)} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{EP0}{D}{start epoch in years ({\it e.g.}\ Julian epoch)} \\ + \spec{EP1}{D}{end epoch in years (same system as EP0)} +} +\args{RETURNED} +{ + \spec{R1,D1}{D}{\radec\ at epoch EP1 (radians)} +} +\anote{The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are in the same coordinate + system as R0,D0.} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr. Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_POLMO}{Polar Motion} +{ + \action{Polar motion: correct site longitude and latitude for polar + motion and calculate azimuth difference between celestial and + terrestrial poles.} + \call{CALL sla\_POLMO (ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ)} +} +\args{GIVEN} +{ + \spec{ELONGM}{D}{mean longitude of the site (radians, east +ve)} \\ + \spec{PHIM}{D}{mean geodetic latitude of the site (radians)} \\ + \spec{XP}{D}{polar motion $x$-coordinate (radians)} \\ + \spec{YP}{D}{polar motion $y$-coordinate (radians)} +} +\args{RETURNED} +{ + \spec{ELONG}{D}{true longitude of the site (radians, east +ve)} \\ + \spec{PHI}{D}{true geodetic latitude of the site (radians)} \\ + \spec{DAZ}{D}{azimuth correction (terrestrial$-$celestial, radians)} +} +\notes +{ +\begin{enumerate} +\item ``Mean'' longitude and latitude are the (fixed) values for the + site's location with respect to the IERS terrestrial reference + frame; the latitude is geodetic. TAKE CARE WITH THE LONGITUDE + SIGN CONVENTION. The longitudes used by the present routine + are east-positive, in accordance with geographical convention + (and right-handed). In particular, note that the longitudes + returned by the sla\_OBS routine are west-positive, following + astronomical usage, and must be reversed in sign before use in + the present routine. +\item XP and YP are the (changing) coordinates of the Celestial + Ephemeris Pole with respect to the IERS Reference Pole. + XP is positive along the meridian at longitude $0^\circ$, + and YP is positive along the meridian at longitude + $270^\circ$ ({\it i.e.}\ $90^\circ$ west). Values for XP,YP can + be obtained from IERS circulars and equivalent publications; + the maximum amplitude observed so far is about \arcsec{0}{3}. +\item ``True'' longitude and latitude are the (moving) values for + the site's location with respect to the celestial ephemeris + pole and the meridian which corresponds to the Greenwich + apparent sidereal time. The true longitude and latitude + link the terrestrial coordinates with the standard celestial + models (for precession, nutation, sidereal time {\it etc}). +\item The azimuths produced by sla\_AOP and sla\_AOPQK are with + respect to due north as defined by the Celestial Ephemeris + Pole, and can therefore be called ``celestial azimuths''. + However, a telescope fixed to the Earth measures azimuth + essentially with respect to due north as defined by the + IERS Reference Pole, and can therefore be called ``terrestrial + azimuth''. Uncorrected, this would manifest itself as a + changing ``azimuth zero-point error''. The value DAZ is the + correction to be added to a celestial azimuth to produce + a terrestrial azimuth. +\item The present routine is rigorous. For most practical + purposes, the following simplified formulae provide an + adequate approximation: \\[2ex] + \hspace*{1em}\begin{tabular}{lll} + {\tt ELONG} & {\tt =} & + {\tt ELONGM+XP*COS(ELONGM)-YP*SIN(ELONGM)} \\ + {\tt PHI } & {\tt =} & + {\tt PHIM+(XP*SIN(ELONGM)+YP*COS(ELONGM))*TAN(PHIM)} \\ + {\tt DAZ } & {\tt =} & + {\tt -SQRT(XP*XP+YP*YP)*COS(ELONGM-ATAN2(XP,YP))/COS(PHIM)} \\ + \end{tabular} \\[2ex] + An alternative formulation for DAZ is:\\[2ex] + \hspace*{1em}\begin{tabular}{lll} + {\tt X } & {\tt =} & {\tt COS(ELONGM)*COS(PHIM)} \\ + {\tt Y } & {\tt =} & {\tt SIN(ELONGM)*COS(PHIM)} \\ + {\tt DAZ} & {\tt =} & {\tt ATAN2(-X*YP-Y*XP,X*X+Y*Y)} \\ + \end{tabular} +\end{enumerate} +} +\aref{Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7, + sections 3.27, 4.25, 4.52.} +%----------------------------------------------------------------------- +\routine{SLA\_PREBN}{Precession Matrix (FK4)} +{ + \action{Generate the matrix of precession between two epochs, + using the old, pre IAU~1976, Bessel-Newcomb model, in + Andoyer's formulation.} + \call{CALL sla\_PREBN (BEP0, BEP1, RMATP)} +} +\args{GIVEN} +{ + \spec{BEP0}{D}{beginning Besselian epoch} \\ + \spec{BEP1}{D}{ending Besselian epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\anote{The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch BEP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch BEP0.} +\aref{Smith {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 269.} +%----------------------------------------------------------------------- +\routine{SLA\_PREC}{Precession Matrix (FK5)} +{ + \action{Form the matrix of precession between two epochs (IAU 1976, FK5).} + \call{CALL sla\_PREC (EP0, EP1, RMATP)} +} +\args{GIVEN} +{ + \spec{EP0}{D}{beginning epoch} \\ + \spec{EP1}{D}{ending epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\notes +{ + \begin{enumerate} + \item The epochs are TDB Julian epochs. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch EP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch EP0. + \item Though the matrix method itself is rigorous, the precession + angles are expressed through canonical polynomials which are + valid only for a limited time span. There are also known + errors in the IAU precession rate. The absolute accuracy + of the present formulation is better than \arcsec{0}{1} from + 1960\,AD to 2040\,AD, better than \arcseci{1} from 1640\,AD to 2360\,AD, + and remains below \arcseci{3} for the whole of the period + 500\,BC to 3000\,AD. The errors exceed \arcseci{10} outside the + range 1200\,BC to 3900\,AD, exceed \arcseci{100} outside 4200\,BC to + 5600\,AD and exceed \arcseci{1000} outside 6800\,BC to 8200\,AD. + The SLALIB routine sla\_PRECL implements a more elaborate + model which is suitable for problems spanning several + thousand years. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Lieske, J.H., 1979.\ {\it Astr.Astrophys.}\ {\bf 73}, 282; + equations 6 \& 7, p283. + \item Kaplan, G.H., 1981.\ {\it USNO circular no.\ 163}, pA2. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PRECES}{Precession} +{ + \action{Precession -- either the old ``FK4'' (Bessel-Newcomb, pre~IAU~1976) + or new ``FK5'' (Fricke, post~IAU~1976) as required.} + \call{CALL sla\_PRECES (SYSTEM, EP0, EP1, RA, DC)} +} +\args{GIVEN} +{ + \spec{SYSTEM}{C}{precession to be applied: `FK4' or `FK5'} \\ + \spec{EP0,EP1}{D}{starting and ending epoch} \\ + \spec{RA,DC}{D}{\radec, mean equator \& equinox of epoch EP0} +} +\args{RETURNED} +{ + \spec{RA,DC}{D}{\radec, mean equator \& equinox of epoch EP1} +} +\notes +{ + \begin{enumerate} + \item Lowercase characters in SYSTEM are acceptable. + \item The epochs are Besselian if SYSTEM=`FK4' and Julian if `FK5'. + For example, to precess coordinates in the old system from + equinox 1900.0 to 1950.0 the call would be: + \begin{quote} + {\tt CALL sla\_PRECES ('FK4', 1900D0, 1950D0, RA, DC)} + \end{quote} + \item This routine will {\bf NOT} correctly convert between the old and + the new systems -- for example conversion from B1950 to J2000. + For these purposes see sla\_FK425, sla\_FK524, sla\_FK45Z and + sla\_FK54Z. + \item If an invalid SYSTEM is supplied, values of $-$99D0,$-$99D0 are + returned for both RA and DC. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PRECL}{Precession Matrix (latest)} +{ + \action{Form the matrix of precession between two epochs, using the + model of Simon {\it et al}.\ (1994), which is suitable for long + periods of time.} + \call{CALL sla\_PRECL (EP0, EP1, RMATP)} +} +\args{GIVEN} +{ + \spec{EP0}{D}{beginning epoch} \\ + \spec{EP1}{D}{ending epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\notes +{ + \begin{enumerate} + \item The epochs are TDB Julian epochs. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch EP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch EP0. + \item The absolute accuracy of the model is limited by the + uncertainty in the general precession, about \arcsec{0}{3} per + 1000~years. The remainder of the formulation provides a + precision of 1~milliarcsecond over the interval from 1000\,AD + to 3000\,AD, \arcsec{0}{1} from 1000\,BC to 5000\,AD and + \arcseci{1} from 4000\,BC to 8000\,AD. + \end{enumerate} +} +\aref{Simon, J.L.\ {\it et al}., 1994.\ {\it Astr.Astrophys.}\ {\bf 282}, + 663.} +%----------------------------------------------------------------------- +\routine{SLA\_PRENUT}{Precession/Nutation Matrix} +{ + \action{Form the matrix of precession and nutation (IAU~1976, FK5).} + \call{CALL sla\_PRENUT (EPOCH, DATE, RMATPN)} +} +\args{GIVEN} +{ + \spec{EPOCH}{D}{Julian Epoch for mean coordinates} \\ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5) + for true coordinates} +} +\args{RETURNED} +{ + \spec{RMATPN}{D(3,3)}{combined precession/nutation matrix} +} +\notes +{ + \begin{enumerate} + \item The epoch and date are TDB. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{true}$ = {\bf M}$\cdot${\bf v}$_{mean}$ + \end{verse} + where {\bf v}$_{true}$ is the star vector relative to the + true equator and equinox of epoch DATE, {\bf M} is the + $3\times3$ matrix RMATPN and + {\bf v}$_{mean}$ is the star vector relative to the + mean equator and equinox of epoch EPOCH. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PV2EL}{Orbital Elements from Position/Velocity} +{ + \action{Heliocentric osculating elements obtained from instantaneous + position and velocity.} + \call{CALL sla\_PV2EL (\vtop{ + \hbox{PV, DATE, PMASS, JFORMR, JFORM, EPOCH, ORBINC,} + \hbox{ANODE, PERIH, AORQ, E, AORL, DM, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} \\ + \spec{PMASS}{D}{mass of the planet (Sun = 1; Note~2)} \\ + \spec{JFORMR}{I}{requested element set (1-3; Note~3)} +} +\args{RETURNED} +{ + \spec{JFORM}{I}{element set actually returned (1-3; Note~4)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal JFORMR} \\ + \spec{}{}{\hspace{1.5em} $-$3 = position/velocity out of allowed range} +} +\notes +{ + \begin{enumerate} + \item The PV 6-vector is with respect to the mean equator and equinox of + epoch J2000. The orbital elements produced are with respect to + the J2000 ecliptic and mean equinox. + \item The mass, PMASS, is important only for the larger planets. For + most purposes ({\it e.g.}~asteroids) use 0D0. Values less than zero + are illegal. + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> longitude of perihelion $\varpi$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean longitude $L$ (radians) \\ + \> DM \> = \> daily motion $n$ (radians) + \end{tabbing} + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabbing} + \item It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + \begin{tabbing} + xx \= xxxxxxxxxx \= xxxxxxxxxxx \= \kill + \> JFORMR \> JFORM \> meaning \\ \\ + \> ~~~~~1 \> ~~~~~1 \> OK: elements are in the requested format \\ + \> ~~~~~1 \> ~~~~~2 \> never happens \\ + \> ~~~~~1 \> ~~~~~3 \> orbit not elliptical \\ + \> ~~~~~2 \> ~~~~~1 \> never happens \\ + \> ~~~~~2 \> ~~~~~2 \> OK: elements are in the requested format \\ + \> ~~~~~2 \> ~~~~~3 \> orbit not elliptical \\ + \> ~~~~~3 \> ~~~~~1 \> never happens \\ + \> ~~~~~3 \> ~~~~~2 \> never happens \\ + \> ~~~~~3 \> ~~~~~3 \> OK: elements are in the requested format + \end{tabbing} + \item The arguments returned for each value of JFORM ({\it cf}\/ Note~5: + JFORM may not be the same as JFORMR) are as follows: + + \begin{tabbing} + xxx \= xxxxxxxxxxxx \= xxxxxx \= xxxxxx \= \kill + \> JFORM \> 1 \> 2 \> 3 \\ \\ + \> EPOCH \> $t_0$ \> $t_0$ \> $T$ \\ + \> ORBINC \> $i$ \> $i$ \> $i$ \\ + \> ANODE \> $\Omega$ \> $\Omega$ \> $\Omega$ \\ + \> PERIH \> $\varpi$ \> $\omega$ \> $\omega$ \\ + \> AORQ \> $a$ \> $a$ \> $q$ \\ + \> E \> $e$ \> $e$ \> $e$ \\ + \> AORL \> $L$ \> $M$ \> - \\ + \> DM \> $n$ \> - \> - + \end{tabbing} + + where: + \begin{tabbing} + xxx \= xxxxxxxx \= xxx \= \kill + \> $t_0$ \> is the epoch of the elements (MJD, TT) \\ + \> $T$ \> is the epoch of perihelion (MJD, TT) \\ + \> $i$ \> is the inclination (radians) \\ + \> $\Omega$ \> is the longitude of the ascending node (radians) \\ + \> $\varpi$ \> is the longitude of perihelion (radians) \\ + \> $\omega$ \> is the argument of perihelion (radians) \\ + \> $a$ \> is the mean distance (AU) \\ + \> $q$ \> is the perihelion distance (AU) \\ + \> $e$ \> is the eccentricity \\ + \> $L$ \> is the longitude (radians, $0-2\pi$) \\ + \> $M$ \> is the mean anomaly (radians, $0-2\pi$) \\ + \> $n$ \> is the daily motion (radians) \\ + \> - \> means no value is set + \end{tabbing} + \item At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + \end{enumerate} +} +\aref{Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960.} +%----------------------------------------------------------------------- +\routine{SLA\_PV2UE}{Position/Velocity to Universal Elements} +{ + \action{Construct a universal element set based on an instantaneous + position and velocity.} + \call{CALL sla\_PV2UE (PV, DATE, PMASS, U, JSTAT)} +} +\args{GIVEN} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} \\ + \spec{PMASS}{D}{mass of the planet (Sun = 1; Note~2)} +} +\args{RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (Note~3)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.2em} $-$2 = too close to Sun} \\ + \spec{}{}{\hspace{1.2em} $-$3 = too slow} +} +\notes +{ + \begin{enumerate} + \item The PV 6-vector can be with respect to any chosen inertial frame, + and the resulting universal-element set will be with respect to + the same frame. A common choice will be mean equator and ecliptic + of epoch J2000. + \item The mass, PMASS, is important only for the larger planets. For + most purposes ({\it e.g.}~asteroids) use 0D0. Values less than zero + are illegal. + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%----------------------------------------------------------------------- +\routine{SLA\_PVOBS}{Observatory Position \& Velocity} +{ + \action{Position and velocity of an observing station.} + \call{CALL sla\_PVOBS (P, H, STL, PV)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude (geodetic, radians)} \\ + \spec{H}{D}{height above reference spheroid (geodetic, metres)} \\ + \spec{STL}{D}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{\xyzxyzd\ (AU, AU~s$^{-1}$, true equator and equinox + of date)} +} +\anote{IAU 1976 constants are used.} +%----------------------------------------------------------------------- +\routine{SLA\_PXY}{Apply Linear Model} +{ + \action{Given arrays of {\it expected}\/ and {\it measured}\, + \xy\ coordinates, and a + linear model relating them (as produced by sla\_FITXY), compute + the array of {\it predicted}\/ coordinates and the RMS residuals.} + \call{CALL sla\_PXY (NP,XYE,XYM,COEFFS,XYP,XRMS,YRMS,RRMS)} +} +\args{GIVEN} +{ + \spec{NP}{I}{number of samples} \\ + \spec{XYE}{D(2,NP)}{expected \xy\ for each sample} \\ + \spec{XYM}{D(2,NP)}{measured \xy\ for each sample} \\ + \spec{COEFFS}{D(6)}{coefficients of model (see below)} +} +\args{RETURNED} +{ + \spec{XYP}{D(2,NP)}{predicted \xy\ for each sample} \\ + \spec{XRMS}{D}{RMS in X} \\ + \spec{YRMS}{D}{RMS in Y} \\ + \spec{RRMS}{D }{total RMS (vector sum of XRMS and YRMS)} +} +\notes +{ + \begin{enumerate} + \item The model is supplied in the array COEFFS. Naming the + six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms {\it measured}\/ coordinates + $[x_{m},y_{m}\,]$ into {\it predicted}\/ coordinates + $[x_{p},y_{p}\,]$ as follows: + \begin{verse} + $x_{p} = a + bx_{m} + cy_{m}$ \\ + $y_{p} = d + ex_{m} + fy_{m}$ + \end{verse} + \item The residuals are $(x_{p}-x_{e})$ and $(y_{p}-y_{e})$. + \item If NP is less than or equal to zero, no coordinates are + transformed, and the RMS residuals are all zero. + \item See also sla\_FITXY, sla\_INVF, sla\_XY2XY, sla\_DCMPF + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RANDOM}{Random Number} +{ + \action{Generate pseudo-random real number in the range $0 \leq x < 1$.} + \call{R~=~sla\_RANDOM (SEED)} +} +\args{GIVEN} +{ + \spec{SEED}{R}{an arbitrary real number} +} +\args{RETURNED} +{ + \spec{SEED}{R}{a new arbitrary value} \\ + \spec{sla\_RANDOM}{R}{Pseudo-random real number $0 \leq x < 1$.} +} +\anote{The implementation is machine-dependent.} +%----------------------------------------------------------------------- +\routine{SLA\_RANGE}{Put Angle into Range $\pm\pi$} +{ + \action{Normalize an angle into the range $\pm\pi$ (single precision).} + \call{R~=~sla\_RANGE (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_RANGE}{R}{ANGLE expressed in the range $\pm\pi$.} +} +%----------------------------------------------------------------------- +\routine{SLA\_RANORM}{Put Angle into Range $0\!-\!2\pi$} +{ + \action{Normalize an angle into the range $0\!-\!2\pi$ (single precision).} + \call{R~=~sla\_RANORM (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_RANORM}{R}{ANGLE expressed in the range $0\!-\!2\pi$} +} +%----------------------------------------------------------------------- +\routine{SLA\_RCC}{Barycentric Coordinate Time} +{ + \call{D~=~sla\_RCC (TDB, UT1, WL, U, V)} + \action{The relativistic clock correction TDB$-$TT, the + difference between {\it proper time}\, + on Earth and {\it coordinate time}\/ in the solar system barycentric + space-time frame of reference. The proper time is TT; the + coordinate time is {\it an implementation}\/ of TDB.} +} +\args{GIVEN} +{ + \spec{TDB}{D}{coordinate time (MJD: JD$-$2400000.5)} \\ + \spec{UT1}{D}{universal time (fraction of one day)} \\ + \spec{WL}{D}{clock longitude (radians west)} \\ + \spec{U}{D}{clock distance from Earth spin axis (km)} \\ + \spec{V}{D}{clock distance north of Earth equatorial plane (km)} +} +\args{RETURNED} +{ + \spec{sla\_RCC}{D}{TDB$-$TT (sec)} +} +\notes +{ + \begin{enumerate} + \item TDB may be considered to + be the coordinate time in the solar system barycentre frame of + reference, and TT is the proper time given by clocks at mean sea + level on the Earth. + \item The result has a main (annual) sinusoidal term of amplitude + approximately 1.66ms, plus planetary terms up to about + 20$\mu$s, and lunar and diurnal terms up to 2$\mu$s. The + variation arises from the transverse Doppler effect and the + gravitational red-shift as the observer varies in speed and + moves through different gravitational potentials. + \item The argument TDB is, strictly, the barycentric coordinate time; + however, the terrestrial proper time (TT) can in practice be used. + \item The geocentric model is that of Fairhead \& Bretagnon (1990), + in its full + form. It was supplied by Fairhead (private communication) + as a Fortran subroutine. A number of coding changes were made to + this subroutine in order + match the calling sequence of previous versions of the present + routine, to comply with Starlink programming standards and to + avoid compilation problems on certain machines. On the supported + computer types, + the numerical results are essentially unaffected by the + changes. The topocentric model is from Moyer (1981) and Murray (1983). + During the interval 1950-2050, the absolute accuracy of the + geocentric model is better than $\pm3$~nanoseconds + relative to direct numerical integrations using the JPL DE200/LE200 + solar system ephemeris. + \item The IAU definition of TDB is that it must differ from TT only by + periodic terms. Though practical, this is an imprecise definition + which ignores the existence of very long-period and secular effects + in the dynamics of the solar system. As a consequence, different + implementations of TDB will, in general, differ in zero-point and + will drift linearly relative to one other. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Fairhead, L.\ \& + Bretagnon, P., 1990.\ {\it Astr.Astrophys.}\ {\bf 229}, 240-247. + \item Moyer, T.D., 1981.\ {\it Cel.Mech.}\ {\bf 23}, 33. + \item Murray, C.A., 1983,\ {\it Vectorial Astrometry}, Adam Hilger. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_RDPLAN}{Apparent \radec\ of Planet} +{ + \action{Approximate topocentric apparent \radec\ and angular + size of a planet.} + \call{CALL sla\_RDPLAN (DATE, NP, ELONG, PHI, RA, DEC, DIAM)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{MJD of observation (JD$-$2400000.5)} \\ + \spec{NP}{I}{planet:} \\ + \spec{}{}{\hspace{1.5em} 1\,=\,Mercury} \\ + \spec{}{}{\hspace{1.5em} 2\,=\,Venus} \\ + \spec{}{}{\hspace{1.5em} 3\,=\,Moon} \\ + \spec{}{}{\hspace{1.5em} 4\,=\,Mars} \\ + \spec{}{}{\hspace{1.5em} 5\,=\,Jupiter} \\ + \spec{}{}{\hspace{1.5em} 6\,=\,Saturn} \\ + \spec{}{}{\hspace{1.5em} 7\,=\,Uranus} \\ + \spec{}{}{\hspace{1.5em} 8\,=\,Neptune} \\ + \spec{}{}{\hspace{1.5em} 9\,=\,Pluto} \\ + \spec{}{}{\hspace{0.44em} else\,=\,Sun} \\ + \spec{ELONG,PHI}{D}{observer's longitude (east +ve) and latitude + (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{topocentric apparent \radec\ (radians)} \\ + \spec{DIAM}{D}{angular diameter (equatorial, radians)} +} +\notes +{ + \begin{enumerate} + \item The date is in a dynamical timescale (TDB, formerly ET) + and is in the form of a Modified + Julian Date (JD$-$2400000.5). For all practical purposes, TT can + be used instead of TDB, and for many applications UT will do + (except for the Moon). + \item The longitude and latitude allow correction for geocentric + parallax. This is a major effect for the Moon, but in the + context of the limited accuracy of the present routine its + effect on planetary positions is small (negligible for the + outer planets). Geocentric positions can be generated by + appropriate use of the routines sla\_DMOON and sla\_PLANET. + \item The direction accuracy (arcsec, 1000-3000\,AD) is of order: + \begin{tabbing} + xxxxxxx \= xxxxxxxxxxxxxxxxxx \= \kill + \> Sun \> \hspace{0.5em}5 \\ + \> Mercury \> \hspace{0.5em}2 \\ + \> Venus \> 10 \\ + \> Moon \> 30 \\ + \> Mars \> 50 \\ + \> Jupiter \> 90 \\ + \> Saturn \> 90 \\ + \> Uranus \> 90 \\ + \> Neptune \> 10 \\ + \> Pluto \> \hspace{0.5em}1~~~(1885-2099\,AD only) + \end{tabbing} + The angular diameter accuracy is about 0.4\% for the Moon, + and 0.01\% or better for the Sun and planets. + For more information on accuracy, + refer to the routines sla\_PLANET and sla\_DMOON, + which the present routine uses. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFCO}{Refraction Constants} +{ + \action{Determine the constants $a$ and $b$ in the + atmospheric refraction model + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$, + where $\zeta$ is the {\it observed}\/ zenith distance + ({\it i.e.}\ affected by refraction) and $\Delta \zeta$ is + what to add to $\zeta$ to give the {\it topocentric}\, + ({\it i.e.\ in vacuo}) zenith distance.} + \call{CALL sla\_REFCO (HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REFA, REFB)} +} +\args{GIVEN} +{ + \spec{HM}{D}{height of the observer above sea level (metre)} \\ + \spec{TDK}{D}{ambient temperature at the observer (degrees K)} \\ + \spec{PMB}{D}{pressure at the observer (mB)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} \\ + \spec{PHI}{D}{latitude of the observer (radian, astronomical)} \\ + \spec{TLR}{D}{temperature lapse rate in the troposphere + (degrees K per metre)} \\ + \spec{EPS}{D}{precision required to terminate iteration (radian)} +} +\args{RETURNED} +{ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\notes +{ + \begin{enumerate} + \item Suggested values for the TLR and EPS arguments are 0.0065D0 and + 1D$-$8 respectively. + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + \item The routine is a slower but more accurate alternative to the + sla\_REFCOQ routine. The constants it produces give perfect + agreement with sla\_REFRO at zenith distances + $\tan^{-1} 1$ ($45^\circ$) and $\tan^{-1} 4$ ($\sim 76^\circ$). + At other zenith distances, the model achieves: + \arcsec{0}{5} accuracy for $\zeta<80^{\circ}$, + \arcsec{0}{01} accuracy for $\zeta<60^{\circ}$, and + \arcsec{0}{001} accuracy for $\zeta<45^{\circ}$. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFCOQ}{Refraction Constants (fast)} +{ + \action{Determine the constants $a$ and $b$ in the + atmospheric refraction model + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$, + where $\zeta$ is the {\it observed}\/ zenith distance + ({\it i.e.}\ affected by refraction) and $\Delta \zeta$ is + what to add to $\zeta$ to give the {\it topocentric}\, + ({\it i.e.\ in vacuo}) zenith distance. (This is a fast + alternative to the sla\_REFCO routine -- see notes.)} + \call{CALL sla\_REFCOQ (TDK, PMB, RH, WL, REFA, REFB)} +} +\args{GIVEN} +{ + \spec{TDK}{D}{ambient temperature at the observer (degrees K)} \\ + \spec{PMB}{D}{pressure at the observer (mB)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} +} +\args{RETURNED} +{ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\notes +{ + \begin{enumerate} + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + \item The model is an approximation, for moderate zenith distances, + to the predictions of the sla\_REFRO routine. The approximation + is maintained across a range of conditions, and applies to + both optical/IR and radio. + \item The algorithm is a fast alternative to the sla\_REFCO routine. + The latter calls the sla\_REFRO routine itself: this involves + integrations through a model atmosphere, and is costly in + processor time. However, the model which is produced is precisely + correct for two zenith distances ($45^\circ$ and $\sim\!76^\circ$) + and at other zenith distances is limited in accuracy only by the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ formulation + itself. The present routine is not as accurate, though it + satisfies most practical requirements. + \item The model omits the effects of (i)~height above sea level (apart + from the reduced pressure itself), (ii)~latitude ({\it i.e.}\ the + flattening of the Earth) and (iii)~variations in tropospheric + lapse rate. + \item The model has been tested using the following range of conditions: + \begin{itemize} + \item [$\cdot$] lapse rates 0.0055, 0.0065, 0.0075~degrees K per metre + \item [$\cdot$] latitudes $0^\circ$, $25^\circ$, $50^\circ$, $75^\circ$ + \item [$\cdot$] heights 0, 2500, 5000 metres above sea level + \item [$\cdot$] pressures mean for height $-10$\% to $+5$\% in steps of $5$\% + \item [$\cdot$] temperatures $-10^\circ$ to $+20^\circ$ with respect to + $280^\circ$K at sea level + \item [$\cdot$] relative humidity 0, 0.5, 1 + \item [$\cdot$] wavelength 0.4, 0.6, \ldots\ $2\mu{\rm m}$, + radio + \item [$\cdot$] zenith distances $15^\circ$, $45^\circ$, $75^\circ$ + \end{itemize} + For the above conditions, the comparison with sla\_REFRO + was as follows: + + \vspace{2ex} + + ~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & {\it worst} & {\it RMS} \\ \hline + optical/IR & 62 & 8 \\ + radio & 319 & 49 \\ \hline + & mas & mas \\ \hline + \end{tabular} + + \vspace{3ex} + + For this particular set of conditions: + \begin{itemize} + \item [$\cdot$] lapse rate $6.5^\circ K km^{-1}$ + \item [$\cdot$] latitude $50^\circ$ + \item [$\cdot$] sea level + \item [$\cdot$] pressure 1005\,mB + \item [$\cdot$] temperature $7^\circ$C + \item [$\cdot$] humidity 80\% + \item [$\cdot$] wavelength 5740\,\.{A} + \end{itemize} + the results were as follows: + + \vspace{2ex} + + ~~~~~~~~~~ + \begin{tabular}{|r|r|r|r|} \hline + \multicolumn{1}{|c}{$\zeta$} & + \multicolumn{1}{|c}{sla\_REFRO} & + \multicolumn{1}{|c}{sla\_REFCOQ} & + \multicolumn{1}{|c|}{Saastamoinen} \\ \hline + 10 & 10.27 & 10.27 & 10.27 \\ + 20 & 21.19 & 21.20 & 21.19 \\ + 30 & 33.61 & 33.61 & 33.60 \\ + 40 & 48.82 & 48.83 & 48.81 \\ + 45 & 58.16 & 58.18 & 58.16 \\ + 50 & 69.28 & 69.30 & 69.27 \\ + 55 & 82.97 & 82.99 & 82.95 \\ + 60 & 100.51 & 100.54 & 100.50 \\ + 65 & 124.23 & 124.26 & 124.20 \\ + 70 & 158.63 & 158.68 & 158.61 \\ + 72 & 177.32 & 177.37 & 177.31 \\ + 74 & 200.35 & 200.38 & 200.32 \\ + 76 & 229.45 & 229.43 & 229.42 \\ + 78 & 267.44 & 267.29 & 267.41 \\ + 80 & 319.13 & 318.55 & 319.10 \\ \hline + deg & arcsec & arcsec & arcsec \\ \hline + \end{tabular} + + \vspace{3ex} + + The values for Saastamoinen's formula (which includes terms + up to $\tan^5$) are taken from Hohenkerk and Sinclair (1985). + + The results from the much slower but more accurate sla\_REFCO + routine have not been included in the tabulation as they are + identical to those in the sla\_REFRO column to the \arcsec{0}{01} + resolution used. + \item Outlandish input parameters are silently limited + to mathematically safe values. Zero pressure is permissible, + and causes zeroes to be returned. + \item The algorithm draws on several sources, as follows: + \begin{itemize} + \item The formula for the saturation vapour pressure of water as + a function of temperature and temperature is taken from + expressions A4.5-A4.7 of Gill (1982). + \item The formula for the water vapour pressure, given the + saturation pressure and the relative humidity is from + Crane (1976), expression 2.5.5. + \item The refractivity of air is a function of temperature, + total pressure, water-vapour pressure and, in the case + of optical/IR but not radio, wavelength. The formulae + for the two cases are developed from the Essen and Froome + expressions adopted in Resolution 1 of the 12th International + Geodesy Association General Assembly (1963). + \end{itemize} + The above three items are as used in the sla\_REFRO routine. + \begin{itemize} + \item The formula for $\beta~(=H_0/r_0)$ is + an adaption of expression 9 from Stone (1996). The + adaptations, arrived at empirically, consist of (i)~a + small adjustment to the coefficient and (ii)~a humidity + term for the radio case only. + \item The formulae for the refraction constants as a function of + $n-1$ and $\beta$ are from Green (1987), expression 4.31. + \end{itemize} + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Crane, R.K., Meeks, M.L.\ (ed), ``Refraction Effects in + the Neutral Atmosphere'', + {\it Methods of Experimental Physics: Astrophysics 12B,}\/ + Academic Press, 1976. + \item Gill, Adrian E., {\it Atmosphere-Ocean Dynamics,}\/ + Academic Press, 1982. + \item Hohenkerk, C.Y., \& Sinclair, A.T., NAO Technical Note + No.~63, 1985. + \item International Geodesy Association General Assembly, Bulletin + G\'{e}od\'{e}sique {\bf 70} p390, 1963. + \item Stone, Ronald C., P.A.S.P.~{\bf 108} 1051-1058, 1996. + \item Green, R.M., {\it Spherical Astronomy,}\/ Cambridge + University Press, 1987. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFRO}{Refraction} +{ + \action{Atmospheric refraction, for radio or optical/IR wavelengths.} + \call{CALL sla\_REFRO (ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REF)} +} +\args{GIVEN} +{ + \spec{ZOBS}{D}{observed zenith distance of the source (radians)} \\ + \spec{HM}{D}{height of the observer above sea level (metre)} \\ + \spec{TDK}{D}{ambient temperature at the observer (degrees K)} \\ + \spec{PMB}{D}{pressure at the observer (mB)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} \\ + \spec{PHI}{D}{latitude of the observer (radian, astronomical)} \\ + \spec{TLR}{D}{temperature lapse rate in the troposphere + (degrees K per metre)} \\ + \spec{EPS}{D}{precision required to terminate iteration (radian)} +} +\args{RETURNED} +{ + \spec{REF}{D}{refraction: {\it in vacuo}\/ ZD minus observed ZD (radians)} +} +\notes +{ + \begin{enumerate} + \item A suggested value for the TLR argument is 0.0065D0. The + refraction is significantly affected by TLR, and if studies + of the local atmosphere have been carried out a better TLR + value may be available. + \item A suggested value for the EPS argument is 1D$-$8. The result is + usually at least two orders of magnitude more computationally + precise than the supplied EPS value. + \item The routine computes the refraction for zenith distances up + to and a little beyond $90^\circ$ using the method of Hohenkerk + \& Sinclair (NAO Technical Notes 59 and 63, subsequently adopted + in the {\it Explanatory Supplement to the Astronomical Almanac,}\/ + 1992 -- see section 3.281). + \item The code is based on the AREF optical/IR refraction subroutine + of C.\,Hohenkerk (HMNAO, September 1984), with extensions to + support the radio case. The modifications to the original HMNAO + optical/IR refraction code which affect the results are: + \begin{itemize} + \item Murray's values for the gas constants have been used + ({\it Vectorial Astrometry,}\/ Adam Hilger, 1983). + \item A better model for $P_s(T)$ has been adopted (taken from + Gill, {\it Atmosphere-Ocean Dynamics,}\/ Academic Press, 1982). + \item More accurate expressions for $Pw_o$ have been adopted + (again from Gill 1982). + \item Provision for radio wavelengths has been added using + expressions devised by A.\,T.\,Sinclair, RGO (private + communication 1989), based on the Essen \& Froome + refractivity formula adopted in Resolution~1 of the + 12th International Geodesy Association General Assembly + (Bulletin G\'{e}od\'{e}sique {\bf 70} p390, 1963). + \end{itemize} + None of the changes significantly affects the optical/IR results + with respect to the algorithm given in the 1992 {\it Explanatory + Supplement.}\/ For example, at $70^\circ$ zenith distance the present + routine agrees with the ES algorithm to better than \arcsec{0}{05} + for any reasonable combination of parameters. However, the + improved water-vapour expressions do make a significant difference + in the radio band, at $70^\circ$ zenith distance reaching almost + \arcseci{4} for a hot, humid, low-altitude site during a period of + low pressure. + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + Because the algorithm takes no account of the ionosphere, the + accuracy deteriorates at low frequencies, below about 30\,MHz. + \item Before use, the value of ZOBS is expressed in the range $\pm\pi$. + If this ranged ZOBS is negative, the result REF is computed from its + absolute value before being made negative to match. In addition, if + it has an absolute value greater than $93^\circ$, a fixed REF value + equal to the result for ZOBS~$=93^\circ$ is returned, appropriately + signed. + \item As in the original Hohenkerk and Sinclair algorithm, fixed values + of the water vapour polytrope exponent, the height of the + tropopause, and the height at which refraction is negligible are + used. + \item The radio refraction has been tested against work done by + Iain~Coulson, JACH, (private communication 1995) for the + James Clerk Maxwell Telescope, Mauna Kea. For typical conditions, + agreement at the \arcsec{0}{1} level is achieved for moderate ZD, + worsening to perhaps \arcsec{0}{5}\,--\,\arcsec{1}{0} at ZD $80^\circ$. + At hot and humid sea-level sites the accuracy will not be as good. + \item It should be noted that the relative humidity RH is formally + defined in terms of ``mixing ratio'' rather than pressures or + densities as is often stated. It is the mass of water per unit + mass of dry air divided by that for saturated air at the same + temperature and pressure (see Gill 1982). The familiar + $\nu=p_w/p_s$ or $\nu=\rho_w/\rho_s$ expressions can differ from + the formal definition by several percent, significant in the + radio case. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFV}{Apply Refraction to Vector} +{ + \action{Adjust an unrefracted Cartesian vector to include the effect of + atmospheric refraction, using the simple + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ model.} + \call{CALL sla\_REFV (VU, REFA, REFB, VR)} +} +\args{GIVEN} +{ + \spec{VU}{D}{unrefracted position of the source (\azel\ 3-vector)} \\ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\args{RETURNED} +{ + \spec{VR}{D}{refracted position of the source (\azel\ 3-vector)} +} +\notes +{ + \begin{enumerate} + \item This routine applies the adjustment for refraction in the + opposite sense to the usual one -- it takes an unrefracted + ({\it in vacuo}\/) position and produces an observed (refracted) + position, whereas the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the algorithm used here is equivalent to + one iteration of the Newton-Raphson method applied to the + above formula. + \item Though optimized for speed rather than precision, the present + routine achieves consistency with the refracted-to-unrefracted + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model at better than 1~microarcsecond within + $30^\circ$ of the zenith and remains within 1~milliarcsecond to + $\zeta=70^\circ$. The inherent accuracy of the model is, of + course, far worse than this -- see the documentation for sla\_REFCO + for more information. + \item At low elevations (below about $3^\circ$) the refraction + correction is held back to prevent arithmetic problems and + wildly wrong results. Over a wide range of observer heights + and corresponding temperatures and pressures, the following + levels of accuracy are achieved, relative to numerical + integration through a model atmosphere: + + \begin{center} + \begin{tabular}{ccl} + $\zeta_{obs}$ & {\it error} \\ \\ + $80^\circ$ & \arcsec{0}{4} \\ + $81^\circ$ & \arcsec{0}{8} \\ + $82^\circ$ & \arcsec{1}{6} \\ + $83^\circ$ & \arcseci{3} \\ + $84^\circ$ & \arcseci{7} \\ + $85^\circ$ & \arcseci{17} \\ + $86^\circ$ & \arcseci{45} \\ + $87^\circ$ & \arcseci{150} \\ + $88^\circ$ & \arcseci{340} \\ + $89^\circ$ & \arcseci{620} \\ + $90^\circ$ & \arcseci{1100} \\ + $91^\circ$ & \arcseci{1900} & $<$ high-altitude \\ + $92^\circ$ & \arcseci{3200} & $<$ sites only \\ + \end{tabular} + \end{center} + \item See also the routine sla\_REFZ, which performs the adjustment to + the zenith distance rather than in \xyz . + The present routine is faster than sla\_REFZ and, + except very low down, + is equally accurate for all practical purposes. However, beyond + about $\zeta=84^\circ$ sla\_REFZ should be used, and for the utmost + accuracy iterative use of sla\_REFRO should be considered. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFZ}{Apply Refraction to ZD} +{ + \action{Adjust an unrefracted zenith distance to include the effect of + atmospheric refraction, using the simple + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ model.} + \call{CALL sla\_REFZ (ZU, REFA, REFB, ZR)} +} +\args{GIVEN} +{ + \spec{ZU}{D}{unrefracted zenith distance of the source (radians)} \\ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\args{RETURNED} +{ + \spec{ZR}{D}{refracted zenith distance (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine applies the adjustment for refraction in the + opposite sense to the usual one -- it takes an unrefracted + ({\it in vacuo}\/) position and produces an observed (refracted) + position, whereas the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the formula used here is based on the + Newton-Raphson method. For the utmost numerical consistency + with the refracted to unrefracted model, two iterations are + carried out, achieving agreement at the $10^{-11}$~arcsecond level + for $\zeta=80^\circ$. The inherent accuracy of the model + is, of course, far worse than this -- see the documentation for + sla\_REFCO for more information. + \item At $\zeta=83^\circ$, the rapidly-worsening + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model is abandoned and an empirical formula takes over: + + \[\Delta \zeta = F \left( + \frac{0^\circ\hspace{-0.37em}.\hspace{0.02em}55445 + - 0^\circ\hspace{-0.37em}.\hspace{0.02em}01133 E + + 0^\circ\hspace{-0.37em}.\hspace{0.02em}00202 E^2} + {1 + 0.28385 E +0.02390 E^2} \right) \] + where $E=90^\circ-\zeta_{true}$ + and $F$ is a factor chosen to meet the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + formula at $\zeta=83^\circ$. Over a + wide range of observer heights and corresponding temperatures and + pressures, the following levels of accuracy are achieved, + relative to numerical integration through a model atmosphere: + + \begin{center} + \begin{tabular}{ccl} + $\zeta_{obs}$ & {\it error} \\ \\ + $80^\circ$ & \arcsec{0}{4} \\ + $81^\circ$ & \arcsec{0}{8} \\ + $82^\circ$ & \arcsec{1}{5} \\ + $83^\circ$ & \arcsec{3}{2} \\ + $84^\circ$ & \arcsec{4}{9} \\ + $85^\circ$ & \arcsec{5}{8} \\ + $86^\circ$ & \arcsec{6}{1} \\ + $87^\circ$ & \arcsec{7}{1} \\ + $88^\circ$ & \arcseci{11} \\ + $89^\circ$ & \arcseci{21} \\ + $90^\circ$ & \arcseci{43} \\ + $91^\circ$ & \arcseci{92} & $<$ high-altitude \\ + $92^\circ$ & \arcseci{220} & $<$ sites only \\ + \end{tabular} + \end{center} + \item See also the routine sla\_REFV, which performs the adjustment in + \xyz , and with the emphasis on speed rather than numerical accuracy. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RVEROT}{RV Corrn to Earth Centre} +{ + \action{Velocity component in a given direction due to Earth rotation.} + \call{R~=~sla\_RVEROT (PHI, RA, DA, ST)} +} +\args{GIVEN} +{ + \spec{PHI}{R}{geodetic latitude of observing station (radians)} \\ + \spec{RA,DA}{R}{apparent \radec\ (radians)} \\ + \spec{ST}{R}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVEROT}{R}{Component of Earth rotation in + direction RA,DA (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when the observatory + is receding from the given point on the sky. + \item Accuracy: the simple algorithm used assumes a spherical Earth and + an observing station at sea level; for actual observing + sites, the error is unlikely to be greater than 0.0005~km~s$^{-1}$. + For applications requiring greater precision, use the routine + sla\_PVOBS. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RVGALC}{RV Corrn to Galactic Centre} +{ + \action{Velocity component in a given direction due to the rotation + of the Galaxy.} + \call{R~=~sla\_RVGALC (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVGALC}{R}{Component of dynamical LSR motion in direction + R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when the LSR + is receding from the given point on the sky. + \item The Local Standard of Rest used here is a point in the + vicinity of the Sun which is in a circular orbit around + the Galactic centre. Sometimes called the {\it dynamical}\/ LSR, + it is not to be confused with a {\it kinematical}\/ LSR, which + is the mean standard of rest of star catalogues or stellar + populations. + \item The dynamical LSR velocity due to Galactic rotation is assumed to + be 220~km~s$^{-1}$ towards $l^{I\!I}=90^{\circ}$, + $b^{I\!I}=0$. + \end{enumerate} +} +\aref{Kerr \& Lynden-Bell (1986), MNRAS, 221, p1023.} +%----------------------------------------------------------------------- +\routine{SLA\_RVLG}{RV Corrn to Local Group} +{ + \action{Velocity component in a given direction due to the combination + of the rotation of the Galaxy and the motion of the Galaxy + relative to the mean motion of the local group.} + \call{R~=~sla\_RVLG (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLG}{R}{Component of {\bf solar} ({\it n.b.}) + motion in direction R2000,D2000 (km~s$^{-1}$)} +} +\anote{Sign convention: the result is positive when + the Sun is receding from the given point on the sky.} +\aref{{\it IAU Trans.}\ 1976.\ {\bf 16B}, p201.} +%----------------------------------------------------------------------- +\routine{SLA\_RVLSRD}{RV Corrn to Dynamical LSR} +{ + \action{Velocity component in a given direction due to the Sun's + motion with respect to the ``dynamical'' Local Standard of Rest.} + \call{R~=~sla\_RVLSRD (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLSRD}{R}{Component of {\it peculiar}\/ solar motion + in direction R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when + the Sun is receding from the given point on the sky. + \item The Local Standard of Rest used here is the {\it dynamical}\/ LSR, + a point in the vicinity of the Sun which is in a circular + orbit around the Galactic centre. The Sun's motion with + respect to the dynamical LSR is called the {\it peculiar}\/ solar + motion. + \item There is another type of LSR, called a {\it kinematical}\/ LSR. A + kinematical LSR is the mean standard of rest of specified star + catalogues or stellar populations, and several slightly + different kinematical LSRs are in use. The Sun's motion with + respect to an agreed kinematical LSR is known as the + {\it standard}\/ solar motion. + The dynamical LSR is seldom used by observational astronomers, + who conventionally use a kinematical LSR such as the one implemented + in the routine sla\_RVLSRK. + \item The peculiar solar motion is from Delhaye (1965), in {\it Stars + and Stellar Systems}, vol~5, p73: in Galactic Cartesian + coordinates (+9,+12,+7)~km~s$^{-1}$. + This corresponds to about 16.6~km~s$^{-1}$ + towards Galactic coordinates $l^{I\!I}=53^{\circ},b^{I\!I}=+25^{\circ}$. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RVLSRK}{RV Corrn to Kinematical LSR} +{ + \action{Velocity component in a given direction due to the Sun's + motion with respect to a kinematical Local Standard of Rest.} + \call{R~=~sla\_RVLSRK (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLSRK}{R}{Component of {\it standard}\/ solar motion + in direction R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when + the Sun is receding from the given point on the sky. + \item The Local Standard of Rest used here is one of several + {\it kinematical}\/ LSRs in common use. A kinematical LSR is the + mean standard of rest of specified star catalogues or stellar + populations. The Sun's motion with respect to a kinematical + LSR is known as the {\it standard}\/ solar motion. + \item There is another sort of LSR, seldom used by observational + astronomers, called the {\it dynamical}\/ LSR. This is a + point in the vicinity of the Sun which is in a circular orbit + around the Galactic centre. The Sun's motion with respect to + the dynamical LSR is called the {\it peculiar}\/ solar motion. To + obtain a radial velocity correction with respect to the + dynamical LSR use the routine sla\_RVLSRD. + \item The adopted standard solar motion is 20~km~s$^{-1}$ + towards $\alpha=18^{\rm h},\delta=+30^{\circ}$ (1900). + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Delhaye (1965), in {\it Stars and Stellar Systems}, vol~5, p73. + \item {\it Methods of Experimental Physics}\/ (ed Meeks), vol~12, + part~C, sec~6.1.5.2, p281. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_S2TP}{Spherical to Tangent Plane} +{ + \action{Projection of spherical coordinates onto the tangent plane + (single precision).} + \call{CALL sla\_S2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{RA,DEC}{R}{spherical coordinates of star (radians)} \\ + \spec{RAZ,DECZ}{R}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{XI,ETA}{R}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_V2TP is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SEP}{Angle Between 2 Points on Sphere} +{ + \action{Angle between two points on a sphere (single precision).} + \call{R~=~sla\_SEP (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{R}{spherical coordinates of one point (radians)} \\ + \spec{A2,B2}{R}{spherical coordinates of the other point (radians)} +} +\args{RETURNED} +{ + \spec{sla\_SEP}{R}{angle between [A1,B1] and [A2,B2] in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are right ascension and declination, + longitude and latitude, {\it etc.}\ in radians. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SMAT}{Solve Simultaneous Equations} +{ + \action{Matrix inversion and solution of simultaneous equations + (single precision).} + \call{CALL sla\_SMAT (N, A, Y, D, JF, IW)} +} +\args{GIVEN} +{ + \spec{N}{I}{number of unknowns} \\ + \spec{A}{R(N,N)}{matrix} \\ + \spec{Y}{R(N)}{vector} +} +\args{RETURNED} +{ + \spec{A}{R(N,N)}{matrix inverse} \\ + \spec{Y}{R(N)}{solution} \\ + \spec{D}{R}{determinant} \\ + \spec{JF}{I}{singularity flag: 0=OK} \\ + \spec{IW}{I(N)}{workspace} +} +\notes +{ + \begin{enumerate} + \item For the set of $n$ simultaneous linear equations in $n$ unknowns: + \begin{verse} + {\bf A}$\cdot${\bf y} = {\bf x} + \end{verse} + where: + \begin{itemize} + \item {\bf A} is a non-singular $n \times n$ matrix, + \item {\bf y} is the vector of $n$ unknowns, and + \item {\bf x} is the known vector, + \end{itemize} + sla\_SMAT computes: + \begin{itemize} + \item the inverse of matrix {\bf A}, + \item the determinant of matrix {\bf A}, and + \item the vector of $n$ unknowns {\bf y}. + \end{itemize} + Argument N is the order $n$, A (given) is the matrix {\bf A}, + Y (given) is the vector {\bf x} and Y (returned) + is the vector {\bf y}. + The argument A (returned) is the inverse matrix {\bf A}$^{-1}$, + and D is {\it det}\/({\bf A}). + \item JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=$-$1 + and D=0.0 are returned. In the latter case, the contents + of array A on return are undefined. + \item The algorithm is Gaussian elimination with partial pivoting. + This method is very fast; some much slower algorithms can give + better accuracy, but only by a small factor. + \item This routine replaces the obsolete sla\_SMATRX. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SUBET}{Remove E-terms} +{ + \action{Remove the E-terms (elliptic component of annual aberration) + from a pre IAU~1976 catalogue \radec\ to give a mean place.} + \call{CALL sla\_SUBET (RC, DC, EQ, RM, DM)} +} +\args{GIVEN} +{ + \spec{RC,DC}{D}{\radec\ with E-terms included (radians)} \\ + \spec{EQ}{D}{Besselian epoch of mean equator and equinox} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{\radec\ without E-terms (radians)} +} +\anote{Most star positions from pre-1984 optical catalogues (or + obtained by astrometry with respect to such stars) have the + E-terms built-in. This routine converts such a position to a + formal mean place (allowing, for example, comparison with a + pulsar timing position).} +\aref{{\it Explanatory Supplement to the Astronomical Ephemeris}, + section 2D, page 48.} +%----------------------------------------------------------------------- +\routine{SLA\_SUPGAL}{Supergalactic to Galactic} +{ + \action{Transformation from de Vaucouleurs supergalactic coordinates + to IAU 1958 galactic coordinates.} + \call{CALL sla\_GALSUP (DL, DB, DSL, DSB)} +} +\args{GIVEN} +{ + \spec{DSL,DSB}{D}{supergalactic longitude and latitude (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\refs +{ + \begin{enumerate} + \item de Vaucouleurs, de Vaucouleurs, \& Corwin, {\it Second Reference + Catalogue of Bright Galaxies}, U.Texas, p8. + \item Systems \& Applied Sciences Corp., documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + \end{enumerate} + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is $l^{I\!I}=137.37$.) +} +%------------------------------------------------------------------------------ +\routine{SLA\_SVD}{Singular Value Decomposition} +{ + \action{Singular value decomposition. + This routine expresses a given matrix {\bf A} as the product of + three matrices {\bf U}, {\bf W}, {\bf V}$^{T}$: + \begin{tabbing} + XXXXXX \= \kill + \> {\bf A} = {\bf U} $\cdot$ {\bf W} $\cdot$ {\bf V}$^{T}$ + \end{tabbing} + where: + \begin{tabbing} + XXXXXX \= XXXX \= \kill + \> {\bf A} \> is any $m$ (rows) $\times n$ (columns) matrix, + where $m \geq n$ \\ + \> {\bf U} \> is an $m \times n$ column-orthogonal matrix \\ + \> {\bf W} \> is an $n \times n$ diagonal matrix with + $w_{ii} \geq 0$ \\ + \> {\bf V}$^{T}$ \> is the transpose of an $n \times n$ + orthogonal matrix +\end{tabbing} +} + \call{CALL sla\_SVD (M, N, MP, NP, A, W, V, WORK, JSTAT)} +} +\args{GIVEN} +{ + \spec{M,N}{I}{$m$, $n$, the numbers of rows and columns in matrix {\bf A}} \\ + \spec{MP,NP}{I}{physical dimensions of array containing matrix {\bf A}} \\ + \spec{A}{D(MP,NP)}{array containing $m \times n$ matrix {\bf A}} +} +\args{RETURNED} +{ + \spec{A}{D(MP,NP)}{array containing $m \times n$ column-orthogonal + matrix {\bf U}} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal + matrix {\bf V} ({\it n.b.}\ not {\bf V}$^{T}$)} \\ + \spec{WORK}{D(N)}{workspace} \\ + \spec{JSTAT}{I}{0~=~OK, $-$1~=~array A wrong shape, $>$0~=~index of W + for which convergence failed (see note~3, below)} +} +\notes +{ + \begin{enumerate} + \item M and N are the {\it logical}\/ dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger {\it physical}\/ dimensions, given by MP and NP. + \item V contains matrix V, not the transpose of matrix V. + \item If the status JSTAT is greater than zero, this need not + necessarily be treated as a failure. It means that, due to + chance properties of the matrix A, the QR transformation + phase of the routine did not fully converge in a predefined + number of iterations, something that very seldom occurs. + When this condition does arise, it is possible that the + elements of the diagonal matrix W have not been correctly + found. However, in practice the results are likely to + be trustworthy. Applications should report the condition + as a warning, but then proceed normally. + \end{enumerate} +} +\refs{The algorithm is an adaptation of the routine SVD in the {\it EISPACK}\, + library (Garbow~{\it et~al.}\ 1977, {\it EISPACK Guide Extension}, + Springer Verlag), which is a FORTRAN~66 implementation of the Algol + routine SVD of Wilkinson \& Reinsch 1971 ({\it Handbook for Automatic + Computation}, vol~2, ed Bauer~{\it et~al.}, Springer Verlag). These + references give full details of the algorithm used here. + A good account of the use of SVD in least squares problems is given + in {\it Numerical Recipes}\/ (Press~{\it et~al.}\ 1987, Cambridge + University Press), which includes another variant of the EISPACK code.} +%----------------------------------------------------------------------- +\routine{SLA\_SVDCOV}{Covariance Matrix from SVD} +{ + \action{From the {\bf W} and {\bf V} matrices from the SVD + factorization of a matrix + (as obtained from the sla\_SVD routine), obtain + the covariance matrix.} + \call{CALL sla\_SVDCOV (N, NP, NC, W, V, WORK, CVM)} +} +\args{GIVEN} +{ + \spec{N}{I}{$n$, the number of rows and columns in + matrices {\bf W} and {\bf V}} \\ + \spec{NP}{I}{first dimension of array containing $n \times n$ + matrix {\bf V}} \\ + \spec{NC}{I}{first dimension of array CVM} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal matrix {\bf V}} +} +\args{RETURNED} +{ + \spec{WORK}{D(N)}{workspace} \\ + \spec{CVM}{D(NC,NC)}{array to receive covariance matrix} +} +\aref{{\it Numerical Recipes}, section 14.3.} +%----------------------------------------------------------------------- +\routine{SLA\_SVDSOL}{Solution Vector from SVD} +{ + \action{From a given vector and the SVD of a matrix (as obtained from + the sla\_SVD routine), obtain the solution vector. + This routine solves the equation: + \begin{tabbing} + XXXXXX \= \kill + \> {\bf A} $\cdot$ {\bf x} = {\bf b} + \end{tabbing} + where: + \begin{tabbing} + XXXXXX \= XXXX \= \kill + \> {\bf A} \> is a given $m$ (rows) $\times n$ (columns) + matrix, where $m \geq n$ \\ + \> {\bf x} \> is the $n$-vector we wish to find, and \\ + \> {\bf b} \> is a given $m$-vector + \end{tabbing} + by means of the {\it Singular Value Decomposition}\/ method (SVD).} + \call{CALL sla\_SVDSOL (M, N, MP, NP, B, U, W, V, WORK, X)} +} +\args{GIVEN} +{ + \spec{M,N}{I}{$m$, $n$, the numbers of rows and columns in matrix {\bf A}} \\ + \spec{MP,NP}{I}{physical dimensions of array containing matrix {\bf A}} \\ + \spec{B}{D(M)}{known vector {\bf b}} \\ + \spec{U}{D(MP,NP)}{array containing $m \times n$ matrix {\bf U}} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal matrix {\bf V}} +} +\args{RETURNED} +{ + \spec{WORK}{D(N)}{workspace} \\ + \spec{X}{D(N)}{unknown vector {\bf x}} +} +\notes +{ + \begin{enumerate} + \item In the Singular Value Decomposition method (SVD), + the matrix {\bf A} is first factorized (for example by + the routine sla\_SVD) into the following components: + \begin{tabbing} + XXXXXX \= \kill + \> {\bf A} = {\bf U} $\cdot$ {\bf W} $\cdot$ {\bf V}$^{T}$ + \end{tabbing} + where: + \begin{tabbing} + XXXXXX \= XXXX \= \kill + \> {\bf A} \> is any $m$ (rows) $\times n$ (columns) matrix, + where $m > n$ \\ + \> {\bf U} \> is an $m \times n$ column-orthogonal matrix \\ + \> {\bf W} \> is an $n \times n$ diagonal matrix with + $w_{ii} \geq 0$ \\ + \> {\bf V}$^{T}$ \> is the transpose of an $n \times n$ + orthogonal matrix + \end{tabbing} + Note that $m$ and $n$ are the {\it logical}\/ dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger {\it physical}\/ dimensions MP and NP. + The solution is then found from the expression: + \begin{tabbing} + XXXXXX \= \kill + \> {\bf x} = {\bf V} $\cdot~[diag(1/${\bf W}$_{j})] + \cdot (${\bf U}$^{T} \cdot${\bf b}) + \end{tabbing} + \item If matrix {\bf A} is square, and if the diagonal matrix {\bf W} is not + altered, the method is equivalent to conventional solution + of simultaneous equations. + \item If $m > n$, the result is a least-squares fit. + \item If the solution is poorly determined, this shows up in the + SVD factorization as very small or zero {\bf W}$_{j}$ values. Where + a {\bf W}$_{j}$ value is small but non-zero it can be set to zero to + avoid ill effects. The present routine detects such zero + {\bf W}$_{j}$ values and produces a sensible solution, with highly + correlated terms kept under control rather than being allowed + to elope to infinity, and with meaningful values for the + other terms. + \end{enumerate} +} +\aref{{\it Numerical Recipes}, section 2.9.} +%----------------------------------------------------------------------- +\routine{SLA\_TP2S}{Tangent Plane to Spherical} +{ + \action{Transform tangent plane coordinates into spherical + coordinates (single precision)} + \call{CALL sla\_TP2S (XI, ETA, RAZ, DECZ, RA, DEC)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane rectangular coordinates (radians)} \\ + \spec{RAZ,DECZ}{R}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{R}{spherical coordinates (radians)} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_TP2V is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TP2V}{Tangent Plane to Direction Cosines} +{ + \action{Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star + (single precision).} + \call{CALL sla\_TP2V (XI, ETA, V0, V)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane coordinates of star (radians)} \\ + \spec{V0}{R(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{V}{R(3)}{direction cosines of star} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, the returned vector V will + be wrong. + \item If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that $\alpha=0$ at + the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_TP2S. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TPS2C}{Plate centre from $\xi,\eta$ and $\alpha,\delta$} +{ + \action{From the tangent plane coordinates of a star of known \radec, + determine the \radec\ of the tangent point (single precision)} + \call{CALL sla\_TPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane rectangular coordinates (radians)} \\ + \spec{RA,DEC}{R}{spherical coordinates (radians)} +} +\args{RETURNED} +{ + \spec{RAZ1,DECZ1}{R}{spherical coordinates of tangent point, + solution 1} \\ + \spec{RAZ2,DECZ2}{R}{spherical coordinates of tangent point, + solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The RAZ1 and RAZ2 values returned are in the range $0\!-\!2\pi$. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero $\xi$ value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of $\xi$ and $\delta$. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N\,=\,1 + indicates only one useful solution, the usual case; under + these circumstances, the second solution corresponds to the + ``over-the-pole'' case, and this is reflected in the values + of RAZ2 and DECZ2 which are returned. + \item The DECZ1 and DECZ2 values returned are in the range $\pm\pi$, + but in the ordinary, non-pole-crossing, case, the range is + $\pm\pi/2$. + \item RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2 are all in radians. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_TPV2C is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TPV2C}{Plate centre from $\xi,\eta$ and $x,y,z$} +{ + \action{From the tangent plane coordinates of a star of known + direction cosines, determine the direction cosines + of the tangent point (single precision)} + \call{CALL sla\_TPV2C (XI, ETA, V, V01, V02, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane coordinates of star (radians)} \\ + \spec{V}{R(3)}{direction cosines of star} +} +\args{RETURNED} +{ + \spec{V01}{R(3)}{direction cosines of tangent point, solution 1} \\ + \spec{V01}{R(3)}{direction cosines of tangent point, solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The vector V must be of unit length or the result will be wrong. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. + N\,=\,1 + indicates only one useful solution, the usual case; under these + circumstances, the second solution can be regarded as valid if + the vector V02 is interpreted as the ``over-the-pole'' case. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_TPS2C. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_UE2EL}{Universal to Conventional Elements} +{ + \action{Transform universal elements into conventional heliocentric + osculating elements.} + \call{CALL sla\_UE2EL (\vtop{ + \hbox{U, JFORMR,} + \hbox{JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{U}{D(13)}{universal orbital elements (updated; Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} \\ \\ + \spec{JFORMR}{I}{requested element set (1-3; Note~3)} +} +\args{RETURNED} +{ + \spec{JFORM}{I}{element set actually returned (1-3; Note~4)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal JFORMR} \\ + \spec{}{}{\hspace{1.5em} $-$3 = position/velocity out of allowed range} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The universal elements are with respect to the mean equator and + equinox of epoch J2000. The orbital elements produced are with + respect to the J2000 ecliptic and mean equinox. + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> longitude of perihelion $\varpi$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean longitude $L$ (radians) \\ + \> DM \> = \> daily motion $n$ (radians) + \end{tabbing} + + JFORM=2, suitable for minor planets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of elements $t_0$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> mean distance $a$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e < 1 )$ \\ + \> AORL \> = \> mean anomaly $M$ (radians) + \end{tabbing} + + JFORM=3, suitable for comets: + + \begin{tabbing} + xxx \= xxxxxxxx \= xx \= \kill + \> EPOCH \> = \> epoch of perihelion $T$ (TT MJD) \\ + \> ORBINC \> = \> inclination $i$ (radians) \\ + \> ANODE \> = \> longitude of the ascending node $\Omega$ (radians) \\ + \> PERIH \> = \> argument of perihelion $\omega$ (radians) \\ + \> AORQ \> = \> perihelion distance $q$ (AU) \\ + \> E \> = \> eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabbing} + \item It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + \begin{tabbing} + xx \= xxxxxxxxxx \= xxxxxxxxxxx \= \kill + \> JFORMR \> JFORM \> meaning \\ \\ + \> ~~~~~1 \> ~~~~~1 \> OK: elements are in the requested format \\ + \> ~~~~~1 \> ~~~~~2 \> never happens \\ + \> ~~~~~1 \> ~~~~~3 \> orbit not elliptical \\ + \> ~~~~~2 \> ~~~~~1 \> never happens \\ + \> ~~~~~2 \> ~~~~~2 \> OK: elements are in the requested format \\ + \> ~~~~~2 \> ~~~~~3 \> orbit not elliptical \\ + \> ~~~~~3 \> ~~~~~1 \> never happens \\ + \> ~~~~~3 \> ~~~~~2 \> never happens \\ + \> ~~~~~3 \> ~~~~~3 \> OK: elements are in the requested format + \end{tabbing} + \item The arguments returned for each value of JFORM ({\it cf}\/ Note~5: + JFORM may not be the same as JFORMR) are as follows: + + \begin{tabbing} + xxx \= xxxxxxxxxxxx \= xxxxxx \= xxxxxx \= \kill + \> JFORM \> 1 \> 2 \> 3 \\ \\ + \> EPOCH \> $t_0$ \> $t_0$ \> $T$ \\ + \> ORBINC \> $i$ \> $i$ \> $i$ \\ + \> ANODE \> $\Omega$ \> $\Omega$ \> $\Omega$ \\ + \> PERIH \> $\varpi$ \> $\omega$ \> $\omega$ \\ + \> AORQ \> $a$ \> $a$ \> $q$ \\ + \> E \> $e$ \> $e$ \> $e$ \\ + \> AORL \> $L$ \> $M$ \> - \\ + \> DM \> $n$ \> - \> - + \end{tabbing} + + where: + \begin{tabbing} + xxx \= xxxxxxxx \= xxx \= \kill + \> $t_0$ \> is the epoch of the elements (MJD, TT) \\ + \> $T$ \> is the epoch of perihelion (MJD, TT) \\ + \> $i$ \> is the inclination (radians) \\ + \> $\Omega$ \> is the longitude of the ascending node (radians) \\ + \> $\varpi$ \> is the longitude of perihelion (radians) \\ + \> $\omega$ \> is the argument of perihelion (radians) \\ + \> $a$ \> is the mean distance (AU) \\ + \> $q$ \> is the perihelion distance (AU) \\ + \> $e$ \> is the eccentricity \\ + \> $L$ \> is the longitude (radians, $0-2\pi$) \\ + \> $M$ \> is the mean anomaly (radians, $0-2\pi$) \\ + \> $n$ \> is the daily motion (radians) \\ + \> - \> means no value is set + \end{tabbing} + \item At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + \end{enumerate} +} +\refs{ + \begin{enumerate} + \item Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199. + \item Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_UE2PV}{Pos/Vel from Universal Elements} +{ + \action{Heliocentric position and velocity of a planet, asteroid or comet, + starting from orbital elements in the ``universal variables'' form.} + \call{CALL sla\_UE2PV (DATE, U, PV, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} +} +\args{GIVEN and RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (updated; Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = radius vector zero} \\ + \spec{}{}{\hspace{1.2em} $-2$ = failed to converge} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The companion routine is sla\_EL2UE. This takes the conventional + orbital elements and transforms them into the set of numbers + needed by the present routine. A single prediction requires one + one call to sla\_EL2UE followed by one call to the present routine; + for convenience, the two calls are packaged as the routine + sla\_PLANEL. Multiple predictions may be made by again + calling sla\_EL2UE once, but then calling the present routine + multiple times, which is faster than multiple calls to sla\_PLANEL. + + It is not obligatory to use sla\_EL2UE to obtain the parameters. + However, it should be noted that because sla\_EL2UE performs its + own validation, no checks on the contents of the array U are made + by the present routine. + \item DATE is the instant for which the prediction is required. It is + in the TT timescale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The universal elements supplied in the array U are in canonical + units (solar masses, AU and canonical days). The position and + velocity are not sensitive to the choice of reference frame. The + sla\_EL2UE routine in fact produces coordinates with respect to the + J2000 equator and equinox. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%----------------------------------------------------------------------- +\routine{SLA\_UNPCD}{Remove Radial Distortion} +{ + \action{Remove pincushion/barrel distortion from a distorted + \xy\ to give tangent-plane \xy.} + \call{CALL sla\_UNPCD (DISCO,X,Y)} +} +\args{GIVEN} +{ + \spec{DISCO}{D}{pincushion/barrel distortion coefficient} \\ + \spec{X,Y}{D}{distorted \xy} +} +\args{RETURNED} +{ + \spec{X,Y}{D}{tangent-plane \xy} +} +\notes +{ + \begin{enumerate} + \item The distortion is of the form $\rho = r (1 + c r^{2})$, where $r$ is + the radial distance from the tangent point, $c$ is the DISCO + argument, and $\rho$ is the radial distance in the presence of + the distortion. + \item For {\it pincushion}\/ distortion, C is +ve; for + {\it barrel}\/ distortion, C is $-$ve. + \item For X,Y in units of one projection radius (in the case of + a photographic plate, the focal length), the following + DISCO values apply: + + \vspace{2ex} + + \hspace{5em} + \begin{tabular}{|l|c|} \hline + Geometry & DISCO \\ \hline \hline + astrograph & 0.0 \\ \hline + Schmidt & $-$0.3333 \\ \hline + AAT PF doublet & +147.069 \\ \hline + AAT PF triplet & +178.585 \\ \hline + AAT f/8 & +21.20 \\ \hline + JKT f/8 & +14.6 \\ \hline + \end{tabular} + + \vspace{2ex} + + \item The present routine is an approximate inverse to the + companion routine sla\_PCD, obtained from two iterations + of Newton's method. The mismatch between the sla\_PCD + and sla\_UNPCD is negligible for astrometric applications; + to reach 1~milliarcsec at the edge of the AAT triplet or + Schmidt field would require field diameters of \degree{2}{4} + and $42^{\circ}$ respectively. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_V2TP}{Direction Cosines to Tangent Plane} +{ + \action{Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates + (single precision).} + \call{CALL sla\_V2TP (V, V0, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{direction cosines of star} \\ + \spec{V0}{R(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{XI,ETA}{R}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + \item If V0 points at a pole, the returned $\xi,\eta$ + will be based on the + arbitrary assumption that $\alpha=0$ at the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_S2TP. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_VDV}{Scalar Product} +{ + \action{Scalar product of two 3-vectors (single precision).} + \call{R~=~sla\_VDV (VA, VB)} +} +\args{GIVEN} +{ + \spec{VA}{R(3)}{first vector} \\ + \spec{VB}{R(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_VDV}{R}{scalar product VA.VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_VN}{Normalize Vector} +{ + \action{Normalize a 3-vector, also giving the modulus (single precision).} + \call{CALL sla\_VN (V, UV, VM)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{vector} +} +\args{RETURNED} +{ + \spec{UV}{R(3)}{unit vector in direction of V} \\ + \spec{VM}{R}{modulus of V} +} +\anote{If the modulus of V is zero, UV is set to zero as well.} +%----------------------------------------------------------------------- +\routine{SLA\_VXV}{Vector Product} +{ + \action{Vector product of two 3-vectors (single precision).} + \call{CALL sla\_VXV (VA, VB, VC)} +} +\args{GIVEN} +{ + \spec{VA}{R(3)}{first vector} \\ + \spec{VB}{R(3)}{second vector} +} +\args{RETURNED} +{ + \spec{VC}{R(3)}{vector product VA$\times$VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_WAIT}{Time Delay} +{ + \action{Wait for a specified interval.} + \call{CALL sla\_WAIT (DELAY)} +} +\args{GIVEN} +{ + \spec{DELAY}{R}{delay in seconds} +} +\notes +{ + \begin{enumerate} + \item The implementation is machine-specific. + \item The delay actually requested is restricted to the range + 100ns-200s in the present implementation. + \item There is no guarantee of accuracy, though on almost all + types of computer the program will certainly not + resume execution {\it before}\/ the stated interval has + elapsed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_XY2XY}{Apply Linear Model to an \xy} +{ + \action{Transform one \xy\ into another using a linear model of the type + produced by the sla\_FITXY routine.} + \call{CALL sla\_XY2XY (X1,Y1,COEFFS,X2,Y2)} +} +\args{GIVEN} +{ + \spec{X1,Y1}{D}{\xy\ before transformation} \\ + \spec{COEFFS}{D(6)}{transformation coefficients (see note)} +} +\args{RETURNED} +{ + \spec{X2,Y2}{D}{\xy\ after transformation} +} +\notes +{ + \begin{enumerate} + \item The model relates two sets of \xy\ coordinates as follows. + Naming the six elements of COEFFS $a,b,c,d,e$ \& $f$, + the present routine performs the transformation: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + \item See also sla\_FITXY, sla\_PXY, sla\_INVF, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ZD}{$h,\delta$ to Zenith Distance} +{ + \action{Hour angle and declination to zenith distance + (double precision).} + \call{D~=~sla\_ZD (HA, DEC, PHI)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle in radians} \\ + \spec{DEC}{D}{declination in radians} \\ + \spec{PHI}{D}{latitude in radians} +} +\args{RETURNED} +{ + \spec{sla\_ZD}{D}{zenith distance (radians, $0\!-\!\pi$)} +} +\notes +{ + \begin{enumerate} + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type + of zenith distance. In particular, it may be + important to distinguish between the zenith distance + as affected by refraction, which would require the + {\it observed}\/ \hadec, and the zenith distance {\it in vacuo}, + which would require the {\it topocentric}\/ \hadec. If + the effects of diurnal aberration can be neglected, the + {\it apparent}\/ \hadec\ may be used instead of the + {\it topocentric}\/ \hadec. + \item No range checking of arguments is done. + \item In applications which involve many zenith distance calculations, + rather than calling the present routine it will be more + efficient to use inline code, having previously computed fixed + terms such as sine and cosine of latitude, and perhaps sine and + cosine of declination. + \end{enumerate} +} + +\pagebreak + +\section{EXPLANATION AND EXAMPLES} +To guide the writer of positional-astronomy applications software, +this final chapter puts the SLALIB routines into the context of +astronomical phenomena and techniques, and presents a few +``cookbook'' examples +of the SLALIB calls in action. The astronomical content of the chapter +is not, of course, intended to be a substitute for specialist text-books on +positional astronomy, but may help bridge the gap between +such books and the SLALIB routines. For further reading, the following +cover a wide range of material and styles: +\begin{itemize} +\item {\it Explanatory Supplement to the Astronomical Almanac}, + ed.\ P.\,Kenneth~Seidelmann (1992), University Science Books. +\item {\it Vectorial Astrometry}, C.\,A.\,Murray (1983), Adam Hilger. +\item {\it Spherical Astronomy}, Robin~M.\,Green (1985), Cambridge + University Press. +\item {\it Spacecraft Attitude Determination and Control}, + ed.\ James~R.\,Wertz (1986), Reidel. +\item {\it Practical Astronomy with your Calculator}, + Peter~Duffett-Smith (1981), Cambridge University Press. +\end{itemize} +Also of considerable value, though out of date in places, are: +\begin{itemize} +\item {\it Explanatory Supplement to the Astronomical Ephemeris + and the American Ephemeris and Nautical Almanac}, RGO/USNO (1974), + HMSO. +\item {\it Textbook on Spherical Astronomy}, W.\,M.\,Smart (1977), + Cambridge University Press. +\end{itemize} +Only brief details of individual SLALIB routines are given here, and +readers will find it useful to refer to the subprogram specifications +elsewhere in this document. The source code for the SLALIB routines +(available in both Fortran and C) is also intended to be used as +documentation. + +\subsection {Spherical Trigonometry} +Celestial phenomena occur at such vast distances from the +observer that for most practical purposes there is no need to +work in 3D; only the direction +of a source matters, not how far away it is. Things can +therefore be viewed as if they were happening +on the inside of sphere with the observer at the centre -- +the {\it celestial sphere}. Problems involving +positions and orientations in the sky can then be solved by +using the formulae of {\it spherical trigonometry}, which +apply to {\it spherical triangles}, the sides of which are +{\it great circles}. + +Positions on the celestial sphere may be specified by using +a spherical polar coordinate system, defined in terms of +some fundamental plane and a line in that plane chosen to +represent zero longitude. Mathematicians usually work with the +co-latitude, with zero at the principal pole, whereas most +astronomical coordinate systems use latitude, reckoned plus and +minus from the equator. +Astronomical coordinate systems may be either right-handed +({\it e.g.}\ right ascension and declination \radec, +Galactic longitude and latitude \gal) +or left-handed ({\it e.g.}\ hour angle and +declination \hadec). In some cases +different conventions have been used in the past, a fruitful source of +mistakes. Azimuth and geographical longitude are examples; azimuth +is now generally reckoned north through east +(making a left-handed system); geographical longitude is now usually +taken to increase eastwards (a right-handed system) but astronomers +used to employ a west-positive convention. In reports +and program comments it is wise to spell out what convention +is being used, if there is any possibility of confusion. + +When applying spherical trigonometry formulae, attention must be +paid to +rounding errors (for example it is a bad idea to find a +small angle through its cosine) and to the possibility of +problems close to poles. +Also, if a formulation relies on inspection to establish +the quadrant of the result, it is an indication that a vector-related +method might be preferable. + +As well as providing many routines which work in terms of specific +spherical coordinates such as \radec, SLALIB provides +two routines which operate directly on generic spherical +coordinates: +sla\_SEP +computes the separation between +two points (the distance along a great circle) and +sla\_BEAR +computes the bearing (or {\it position angle}) +of one point seen from the other. The routines +sla\_DSEP +and +sla\_DBEAR +are double precision equivalents. As a simple demonstration +of SLALIB, we will use these facilities to estimate the distance from +London to Sydney and the initial compass heading: +\goodbreak +\begin{verbatim} + IMPLICIT NONE + + * Degrees to radians + REAL D2R + PARAMETER (D2R=0.01745329252) + + * Longitudes and latitudes (radians) for London and Sydney + REAL AL,BL,AS,BS + PARAMETER (AL=-0.2*D2R,BL=51.5*D2R,AS=151.2*D2R,BS=-33.9*D2R) + + * Earth radius in km (spherical approximation) + REAL RKM + PARAMETER (RKM=6375.0) + + REAL sla_SEP,sla_BEAR + + + * Distance and initial heading (N=0, E=90) + WRITE (*,'(1X,I5,'' km,'',I4,'' deg'')') + : NINT(sla_SEP(AL,BL,AS,BS)*RKM),NINT(sla_BEAR(AL,BL,AS,BS)/D2R) + + END +\end{verbatim} +\goodbreak +(The result is 17011~km, $61^\circ$.) + +The routines +sla\_PAV and +sla\_DPAV +are equivalents of sla\_BEAR and sla\_DBEAR but starting from +direction-cosines instead of spherical coordinates. + +\subsubsection{Formatting angles} +SLALIB has routines for decoding decimal numbers +from character form and for converting angles to and from +sexagesimal form (hours, minutes, seconds or degrees, +arcminutes, arcseconds). These apparently straightforward +operations contain hidden traps which the SLALIB routines +avoid. + +There are five routines for decoding numbers from a character +string, such as might be entered using a keyboard. +They all work in the same style, and successive calls +can work their way along a single string decoding +a sequence of numbers of assorted types. Number +fields can be separated by spaces or commas, and can be defaulted +to previous values or to preset defaults. + +Three of the routines decode single numbers: +sla\_INTIN +(integer), +sla\_FLOTIN +(single precision floating point) and +sla\_DFLTIN +(double precision). A minus sign can be +detected even when the number is zero; this avoids +the frequently-encountered ``minus zero'' bug, where +declinations {\it etc.}\ in +the range $0^{\circ}$ to $-1^{\circ}$ mysteriously migrate to +the range $0^{\circ}$ to $+1^{\circ}$. +Here is an example (in Fortran) where we wish to +read two numbers, and integer {\tt IX} and a real, {\tt Y}, +with {\tt X} defaulting to zero and {\tt Y} defaulting to +{\tt X}: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION Y + CHARACTER*80 A + INTEGER IX,I,J + + * Input the string to be decoded + READ (*,'(A)') A + + * Preset IX to its default value + IX = 0 + + * Point to the start of the string + I = 1 + + * Decode an integer + CALL sla_INTIN(A,I,IX,J) + IF (J.GT.1) GO TO ... (bad IX) + + * Preset Y to its default value + Y = DBLE(IX) + + * Decode a double precision number + CALL sla_DFLTIN(A,I,Y,J) + IF (J.GT.1) GO TO ... (bad Y) +\end{verbatim} +\goodbreak +Two additional routines decode a 3-field sexagesimal number: +sla\_AFIN +(degrees, arcminutes, arcseconds to single +precision radians) and +sla\_DAFIN +(the same but double precision). They also +work using other units such as hours {\it etc}.\ if +you multiply the result by the appropriate factor. An example +Fortran program which uses +sla\_DAFIN +was given earlier, in section 1.2. + +SLALIB provides four routines for expressing an angle in radians +in a preferred range. The function +sla\_RANGE +expresses an angle +in the range $\pm\pi$; +sla\_RANORM +expresses an angle in the range +$0-2\pi$. The functions +sla\_DRANGE +and +sla\_DRANRM +are double precision versions. + +Several routines +(sla\_CTF2D, +sla\_CR2AF +{\it etc.}) are provided to convert +angles to and from +sexagesimal form (hours, minute, seconds or degrees, +arcminutes and arcseconds). +They avoid the common +``converting from integer to real at the wrong time'' +bug, which produces angles like \hms{24}{59}{59}{999}. +Here is a program which displays an hour angle +stored in radians: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION HA + CHARACTER SIGN + INTEGER IHMSF(4) + : + CALL sla_DR2TF(3,HA,SIGN,IHMSF) + WRITE (*,'(1X,A,3I3.2,''.'',I3.3)') SIGN,IHMSF +\end{verbatim} +\goodbreak + +\subsection {Vectors and Matrices} +As an alternative to employing a spherical polar coordinate system, +the direction of an object can be defined in terms of the sum of any +three vectors as long as they are different and +not coplanar. In practice, three vectors at right angles are +usually chosen, forming a system +of {\it Cartesian coordinates}. The {\it x}- and {\it y}-axes +lie in the fundamental plane ({\it e.g.}\ the equator in the +case of \radec), with the {\it x}-axis pointing to zero longitude. +The {\it z}-axis is normal to the fundamental plane and points +towards positive latitudes. The {\it y}-axis can lie in either +of the two possible directions, depending on whether the +coordinate system is right-handed or left-handed. +The three axes are sometimes called +a {\it triad}. For most applications involving arbitrarily +distant objects such as stars, the vector which defines +the direction concerned is constrained to have unit length. +The {\it x}-, {\it y-} and {\it z-}components +can be regarded as the scalar (dot) product of this vector +onto the three axes of the triad in turn. Because the vector +is a unit vector, +each of the three dot-products is simply the cosine of the angle +between the unit vector and the axis concerned, and the +{\it x}-, {\it y-} and {\it z-}components are sometimes +called {\it direction cosines}. + +For some applications involving objects +with the Solar System, unit vectors are inappropriate, and +it is necessary to use vectors scaled in length-units such as +AU, km {\it etc.} +In these cases the origin of the coordinate system may not be +the observer, but instead might be the Sun, the Solar-System +barycentre, the centre of the Earth {\it etc.} But whatever the application, +the final direction in which the observer sees the object can be +expressed as direction cosines. + +But where has this got us? Instead of two numbers -- a longitude and +a latitude -- we now have three numbers to look after +-- the {\it x}-, {\it y-} and +{\it z-}components -- whose quadratic sum we have somehow to contrive to +be unity. And, in addition to this apparent redundancy, +most people find it harder to visualize +problems in terms of \xyz\ than in $[\,\theta,\phi~]$. +Despite these objections, the vector approach turns out to have +significant advantages over the spherical trigonometry approach: +\begin{itemize} +\item Vector formulae tend to be much more succinct; one vector + operation is the equivalent of strings of sines and cosines. +\item The formulae are as a rule rigorous, even at the poles. +\item Accuracy is maintained all over the celestial sphere. + When one Cartesian component is nearly unity and + therefore insensitive to direction, the others become small + and therefore more precise. +\item Formulations usually deliver the quadrant of the result + without the need for any inspection (except within the + library function ATAN2). +\end{itemize} +A number of important transformations in positional +astronomy turn out to be nothing more than changes of coordinate +system, something which is especially convenient if +the vector approach is used. A direction with respect +to one triad can be expressed relative to another triad simply +by multiplying the \xyz\ column vector by the appropriate +$3\times3$ orthogonal matrix +(a tensor of Rank~2, or {\it dyadic}). The three rows of this +{\it rotation matrix}\/ +are the vectors in the old coordinate system of the three +new axes, and the transformation amounts to obtaining the +dot-product of the direction-vector with each of the three +new axes. Precession, nutation, \hadec\ to \azel, +\radec\ to \gal\ and so on are typical examples of the +technique. A useful property of the rotation matrices +is that they can be inverted simply by taking the transpose. + +The elements of these vectors and matrices are assorted combinations of +the sines and cosines of the various angles involved (hour angle, +declination and so on, depending on which transformation is +being applied). If you write out the matrix multiplications +in full you get expressions which are essentially the same as the +equivalent spherical trigonometry formulae. Indeed, many of the +standard formulae of spherical trigonometry are most easily +derived by expressing the problem initially in +terms of vectors. + +\subsubsection{Using vectors} +SLALIB provides conversions between spherical and vector +form +(sla\_CS2C, +sla\_CC2S +{\it etc.}), plus an assortment +of standard vector and matrix operations +(sla\_VDV, +sla\_MXV +{\it etc.}). +There are also routines +(sla\_EULER +{\it etc.}) for creating a rotation matrix +from three {\it Euler angles}\/ (successive rotations about +specified Cartesian axes). Instead of Euler angles, a rotation +matrix can be expressed as an {\it axial vector}\/ (the pole of the rotation, +and the amount of rotation), and routines are provided for this +(sla\_AV2M, +sla\_M2AV +{\it etc.}). + +Here is an example where spherical coordinates {\tt P1} and {\tt Q1} +undergo a coordinate transformation and become {\tt P2} and {\tt Q2}; +the transformation consists of a rotation of the coordinate system +through angles {\tt A}, {\tt B} and {\tt C} about the +{\it z}, new {\it y}\/ and new {\it z}\/ axes respectively: +\goodbreak +\begin{verbatim} + REAL A,B,C,R(3,3),P1,Q1,V1(3),V2(3),P2,Q2 + : + * Create rotation matrix + CALL sla_EULER('ZYZ',A,B,C,R) + + * Transform position (P,Q) from spherical to Cartesian + CALL sla_CS2C(P1,Q1,V1) + + * Multiply by rotation matrix + CALL sla_MXV(R,V1,V2) + + * Back to spherical + CALL sla_CC2S(V2,P2,Q2) +\end{verbatim} +\goodbreak +Small adjustments to the direction of a position +vector are often most conveniently described in terms of +$[\,\Delta x,\Delta y, \Delta z\,]$. Adding the correction +vector needs careful handling if the position +vector is to remain of length unity, an advisable precaution which +ensures that +the \xyz\ components are always available to mean the cosines of +the angles between the vector and the axis concerned. Two types +of shifts are commonly used, +the first where a small vector of arbitrary direction is +added to the unit vector, and the second where there is a displacement +in the latitude coordinate (declination, elevation {\it etc.}) alone. + +For a shift produced by adding a small \xyz\ vector ${\bf D}$ to a +unit vector ${\bf V1}$, the resulting vector ${\bf V2}$ has direction +$<{\bf V1}+{\bf D}>$ but is no longer of unit length. A better approximation +is available if the result is multiplied by a scaling factor of +$(1-{\bf D}\cdot{\bf V1})$, where the dot +means scalar product. In Fortran: +\goodbreak +\begin{verbatim} + F = (1D0-(DX*V1X+DY*V1Y+DZ*V1Z)) + V2X = F*(V1X+DX) + V2Y = F*(V1Y+DY) + V2Z = F*(V1Z+DZ) +\end{verbatim} +\goodbreak +\noindent +The correction for diurnal aberration (discussed later) is +an example of this form of shift. + +As an example of the second kind of displacement +we will apply a small change in elevation $\delta E$ to an +\azel\ direction vector. The direction of the +result can be obtained by making the allowable approximation +${\tan \delta E\approx\delta E}$ and adding a adjustment +vector of length $\delta E$ normal +to the direction vector in the vertical plane containing the direction +vector. The $z$-component of the adjustment vector is +$\delta E \cos E$, +and the horizontal component is +$\delta E \sin E$ which has then to be +resolved into $x$ and $y$ in proportion to their current sizes. To +approximate a unit vector more closely, a correction factor of +$\cos \delta E$ can then be applied, which is nearly +$(1-\delta E^2 /2)$ for +small $\delta E$. Expressed in Fortran, for initial vector +{\tt V1X,V1Y,V1Z}, change in elevation {\tt DEL} +(+ve $\equiv$ upwards), and result +vector {\tt V2X,V2Y,V2Z}: +\goodbreak +\begin{verbatim} + COSDEL = 1DO-DEL*DEL/2D0 + R1 = SQRT(V1X*V1X+V1Y*V1Y) + F = COSDEL*(R1-DEL*V1Z)/R1 + V2X = F*V1X + V2Y = F*V1Y + V2Z = COSDEL*(V1Z+DEL*R1) +\end{verbatim} +\goodbreak +An example of this type of shift is the correction for atmospheric +refraction (see later). +Depending on the relationship between $\delta E$ and $E$, special +handling at the pole (the zenith for our example) may be required. + +SLALIB includes routines for the case where both a position +and a velocity are involved. The routines +sla\_CS2C6 +and +sla\_CC62S +convert from $[\theta,\phi,\dot{\theta},\dot{\phi}]$ +to \xyzxyzd\ and back; +sla\_DCS26 +and +sla\_DC62S +are double precision equivalents. + +\subsection {Celestial Coordinate Systems} +SLALIB has routines to perform transformations +of celestial positions between different spherical +coordinate systems, including those shown in the following table: + +\begin{center} +\begin{tabular}{|l|c|c|c|c|c|c|} \hline +{\it system} & {\it symbols} & {\it longitude} & {\it latitude} & + {\it x-y plane} & {\it long.\ zero} & {\it RH/LH} +\\ \hline \hline +horizon & -- & azimuth & elevation & horizontal & north & L +\\ \hline +equatorial & $\alpha,\delta$ & R.A.\ & Dec.\ & equator & equinox & R +\\ \hline +local equ.\ & $h,\delta$ & H.A.\ & Dec.\ & equator & meridian & L +\\ \hline +ecliptic & $\lambda,\beta$ & ecl.\ long.\ & ecl.\ lat.\ & + ecliptic & equinox & R +\\ \hline +galactic & $l^{I\!I},b^{I\!I}$ & gal.\ long.\ & gal.\ lat.\ & + gal.\ equator & gal.\ centre & R +\\ \hline +supergalactic & SGL,SGB & SG long.\ & SG lat.\ & + SG equator & node w.\ gal.\ equ.\ & R +\\ \hline +\end{tabular} +\end{center} +Transformations between \hadec\ and \azel\ can be performed by +calling +sla\_E2H +and +sla\_H2E, +or, in double precision, +sla\_DE2H +and +sla\_DH2E. +There is also a routine for obtaining +zenith distance alone for a given \hadec, +sla\_ZD, +and one for determining the parallactic angle, +sla\_PA. +Three routines are included which relate to altazimuth telescope +mountings. For a given \hadec\ and latitude, +sla\_ALTAZ +returns the azimuth, elevation and parallactic angle, plus +velocities and accelerations for sidereal tracking. +The routines +sla\_PDA2H +and +sla\_PDQ2H +predict at what hour angle a given azimuth or +parallactic angle will be reached. + +The routines +sla\_EQECL +and +sla\_ECLEQ +transform between ecliptic +coordinates and \radec\/; there is also a routine for generating the +equatorial to ecliptic rotation matrix for a given date: +sla\_ECMAT. + +For conversion between Galactic coordinates and \radec\ there are +two sets of routines, depending on whether the \radec\ is +old-style, B1950, or new-style, J2000; +sla\_EG50 +and +sla\_GE50 +are \radec\ to \gal\ and {\it vice versa}\/ for the B1950 case, while +sla\_EQGAL +and +sla\_GALEQ +are the J2000 equivalents. + +Finally, the routines +sla\_GALSUP +and +sla\_SUPGAL +transform \gal\ to de~Vaucouleurs supergalactic longitude and latitude +and {\it vice versa.} + +It should be appreciated that the table, above, constitutes +a gross oversimplification. Apparently +simple concepts such as equator, equinox {\it etc.}\ are apt to be very hard to +pin down precisely (polar motion, orbital perturbations \ldots) and +some have several interpretations, all subtly different. The various +frames move in complicated ways with respect to one another or to +the stars (themselves in motion). And in some instances the +coordinate system is slightly distorted, so that the +ordinary rules of spherical trigonometry no longer strictly apply. + +These {\it caveats}\/ +apply particularly to the bewildering variety of different +\radec\ systems that are in use. Figure~1 shows how +some of these systems are related, to one another and +to the direction in which a celestial source actually +appears in the sky. At the top of the diagram are +the various sorts of {\it mean place}\/ +found in star catalogues and papers;\footnote{One frame not included in +Figure~1 is that of the Hipparcos catalogue. This is currently the +best available implementation in the optical of the {\it International +Celestial Reference System}\/ (ICRS), which is based on extragalactic +radio sources observed by VLBI. The distinction between FK5 J2000 +and Hipparcos coordinates only becomes important when accuracies of +50~mas or better are required. More details are given in +Section~4.14.} at the bottom is the +{\it observed}\/ \azel, where a perfect theodolite would +be pointed to see the source; and in the body of +the diagram are +the intermediate processing steps and coordinate +systems. To help +understand this diagram, and the SLALIB routines that can +be used to carry out the various calculations, we will look at the coordinate +systems involved, and the astronomical phenomena that +affect them. + +\begin{figure} +\begin{center} +\begin{tabular}{|cccccc|} \hline +& & & & & \\ +\hspace{5em} & \hspace{5em} & \hspace{5em} & + \hspace{5em} & \hspace{5em} & \hspace{5em} \\ +\multicolumn{2}{|c}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK4, \\ + any equinox + \vspace{0.5ex}}}} & + \multicolumn{2}{c}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK4, + no $\mu$, any equinox + \vspace{0.5ex}}}} & +\multicolumn{2}{c|}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK5, \\ + any equinox + \vspace{0.5ex}}}} \\ +& \multicolumn{2}{|c|}{} & \multicolumn{2}{c|}{} & \\ +\multicolumn{2}{|c}{space motion} & \multicolumn{1}{c|}{} & & + \multicolumn{2}{c|}{space motion} \\ +\multicolumn{2}{|c}{-- E-terms} & + \multicolumn{2}{c}{-- E-terms} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{precess to B1950} & \multicolumn{2}{c}{precess to B1950} & + \multicolumn{2}{c|}{precess to J2000} \\ +\multicolumn{2}{|c}{+ E-terms} & + \multicolumn{2}{c}{+ E-terms} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{FK4 to FK5, no $\mu$} & + \multicolumn{2}{c}{FK4 to FK5, no $\mu$} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{parallax} & \multicolumn{1}{c|}{} & & + \multicolumn{2}{c|}{parallax} \\ +& \multicolumn{2}{|c|}{} & \multicolumn{2}{c|}{} & \\ \cline{2-5} +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{\parbox{18em}{\center \vspace{-2ex} + FK5, J2000, current epoch, geocentric + \vspace{0.5ex}}}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{light deflection} & \\ +& \multicolumn{4}{c}{annual aberration} & \\ +& \multicolumn{4}{c}{precession/nutation} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Apparent \radec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{Earth rotation} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Apparent \hadec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{diurnal aberration} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Topocentric \hadec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\hadec\ to \azel} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Topocentric \azel}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{refraction} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Observed \azel}} & \\ +& & & & & \\ +& & & & & \\ \hline +\end{tabular} +\end{center} +\vspace{-0.5ex} +\caption{Relationship Between Celestial Coordinates} + +Star positions are published or catalogued using +one of the mean \radec\ systems shown at +the top. The ``FK4'' systems +were used before about 1980 and are usually +equinox B1950. The ``FK5'' system, equinox J2000, is now preferred, +or rather its modern equivalent, the International Celestial Reference +Frame (in the optical, the Hipparcos catalogue). +The figure relates a star's mean \radec\ to the actual +line-of-sight to the star. +Note that for the conventional choices of equinox, namely +B1950 or J2000, all of the precession and E-terms corrections +are superfluous. +\end{figure} + +\subsection{Precession and Nutation} +{\it Right ascension and declination}, (\radec), are the names +of the longitude and latitude in a spherical +polar coordinate system based on the Earth's axis of rotation. +The zero point of $\alpha$ is the point of intersection of +the {\it celestial +equator}\/ and the {\it ecliptic}\/ (the apparent path of the Sun +through the year) where the Sun moves into the northern +hemisphere. This point is called the +{\it first point of Aries}, +the {\it vernal equinox}\/ (with apologies to +southern-hemisphere readers) or simply the {\it equinox}.\footnote{With +the introduction of the International Celestial Reference System (ICRS), the +connection between (i)~star coordinates and (ii)~the Earth's orientation +and orbit has been broken. However, the orientation of the +International Celestial Reference Frame (ICRF) axes was, for convenience, +chosen to match J2000 FK5, and for most practical purposes ICRF coordinates +(for example entries in the Hipparcos catalogue) can be regarded as +synonymous with J2000 FK5. See Section 4.14 for further details.} + +This simple picture is unfortunately +complicated by the difficulty of defining +a suitable equator and equinox. One problem is that the +Sun's apparent motion is not completely regular, due to the +ellipticity of the Earth's orbit and its continuous disturbance +by the Moon and planets. This is dealt with by +separating the motion into (i)~a smooth and steady {\it mean Sun}\/ +and (ii)~a set of periodic corrections and perturbations; only the former +is involved in establishing reference frames and timescales. +A second, far larger problem, is that +the celestial equator and the ecliptic +are both moving with respect to the stars. +These motions arise because of the gravitational +interactions between the Earth and the other solar-system bodies. + +By far the largest effect is the +so-called ``precession of the equinoxes'', where the Earth's +rotation axis sweeps out a cone centred on the ecliptic +pole, completing one revolution in about 26,000 years. The +cause of the motion is the torque exerted on the distorted and +spinning Earth by the Sun and the Moon. Consider the effect of the +Sun alone, at or near the northern summer solstice. The Sun +`sees' the top (north pole) of the Earth tilted towards it +(by about \degree{23}{5}, the {\it obliquity of the +ecliptic}\/), +and sees the nearer part of the Earth's equatorial bulge +below centre and the further part above centre. +Although the Earth is in free fall, +the gravitational force on the nearer part of the +equatorial bulge is greater than that on the further part, and +so there is a net torque acting +as if to eliminate the tilt. Six months later the same thing +is happening in reverse, except that the torque is still +trying to eliminate the tilt. In between (at the equinoxes) the +torque shrinks to zero. A torque acting on a spinning body +is gyroscopically translated +into a precessional motion of the spin axis at right-angles to the torque, +and this happens to the Earth. +The motion varies during the +year, going through two maxima, but always acts in the +same direction. The Moon produces the same effect, +adding a contribution to the precession which peaks twice +per month. The Moon's proximity to the Earth more than compensates +for its smaller mass and gravitational attraction, so that it +in fact contributes most of the precessional effect. + +The complex interactions between the three bodies produce a +precessional motion that is wobbly rather than completely smooth. +However, the main 26,000-year component is on such a grand scale that +it dwarfs the remaining terms, the biggest of +which has an amplitude of only \arcseci{17} and a period of +about 18.6~years. This difference of scale makes it convenient to treat +these two components of the motion separately. The main 26,000-year +effect is called {\it luni-solar precession}; the smaller, +faster, periodic terms are called the {\it nutation}. + +Note that precession and nutation are simply +different frequency components of the same physical effect. It is +a common misconception that precession is caused +by the Sun and nutation is caused by the Moon. In fact +the Moon is responsible for two-thirds of the precession, and, +while it is true that much of the complex detail of the nutation is +a reflection of the intricacies of the lunar orbit, there are +nonetheless important solar terms in the nutation. + +In addition to and quite separate +from the precession/nutation effect, the orbit of the Earth-Moon system +is not fixed in orientation, a result of the attractions of the +planets. This slow (about \arcsec{0}{5}~per~year) +secular rotation of the ecliptic about a slowly-moving diameter is called, +confusingly, {\it planetary +precession}\/ and, along with the luni-solar precession is +included in the {\it general precession}. The equator and +ecliptic as affected by general precession +are what define the various ``mean'' \radec\ reference frames. + +The models for precession and nutation come from a combination +of observation and theory, and are subject to continuous +refinement. Nutation models in particular have reached a high +degree of sophistication, taking into account such things as +the non-rigidity of the Earth and the effects of +the planets; SLALIB's nutation +model (IAU~1980) involves 106 terms in each of $\psi$ (longitude) +and $\epsilon$ (obliquity), some as small as \arcsec{0}{0001}. + +\subsubsection{SLALIB support for precession and nutation} +SLALIB offers a choice of three precession models: +\begin{itemize} +\item The old Bessel-Newcomb, pre IAU~1976, ``FK4'' model, used for B1950 + star positions and other pre-1984.0 purposes +(sla\_PREBN). +\item The new Fricke, IAU~1976, ``FK5'' model, used for J2000 star + positions and other post-1984.0 purposes +(sla\_PREC). +\item A model published by Simon {\it et al.}\ which is more accurate than + the IAU~1976 model and which is suitable for long + periods of time +(sla\_PRECL). +\end{itemize} +In each case, the named SLALIB routine generates the $(3\times3)$ +{\it precession +matrix}\/ for a given start and finish time. For example, +here is the Fortran code for generating the rotation +matrix which describes the precession between the epochs +J2000 and J1985.372 (IAU 1976 model): +\goodbreak +\begin{verbatim} + DOUBLE PRECISION PMAT(3,3) + : + CALL sla_PREC(2000D0,1985.372D0,PMAT) +\end{verbatim} +\goodbreak +It is instructive to examine the resulting matrix: +\goodbreak +\begin{verbatim} + +0.9999936402 +0.0032709208 +0.0014214694 + -0.0032709208 +0.9999946505 -0.0000023247 + -0.0014214694 -0.0000023248 +0.9999989897 +\end{verbatim} +\goodbreak +Note that the diagonal elements are close to unity, and the +other elements are small. This shows that over an interval as +short as 15~years the precession isn't going to move a +position vector very far (in this case about \degree{0}{2}). + +For convenience, a direct \radec\ to \radec\ precession routine is +also provided +(sla\_PRECES), +suitable for either the old or the new system (but not a +mixture of the two). + +SLALIB provides only one nutation model, the new, IAU~1980 model, +implemented in the routine +sla\_NUTC. +This returns the components of nutation +in longitude and latitude (and also provides the obliquity) from +which a nutation matrix can be generated by calling +sla\_DEULER +(and from which the {\it equation of the equinoxes}, described +later, can be found). Alternatively, +the nutation matrix can be generated in a single call by using +sla\_NUT. + +A rotation matrix for applying the entire precession/nutation +transformation in one go can be generated by calling +sla\_PRENUT. + +\subsection{Mean Places} +The main effect of the precession/nutation is a steady increase of about +\arcseci{50}/year in the ecliptic longitudes of the stars. It is therefore +essential, when reporting the position of an astronomical target, to +qualify the coordinates with a date, or {\it epoch}. +Specifying the epoch ties down the equator and +equinox which define the \radec\ coordinate system that is +being used. +\footnote{An equinox is, however, not required for coordinates +in the International Celestial Reference System. Such coordinates must +be labelled simply ``ICRS'', or the specific catalogue can be mentioned, +such as ``Hipparcos''; constructions such as ``Hipparcos, J2000'' are +redundant and misleading.} For simplicity, only +the smooth and steady ``general +precession'' part of the complete precession/nutation effect is +included, thereby defining what is called the {\it mean}\/ +equator and equinox for the epoch concerned. We say a star +has a mean place of (for example) +\hms{12}{07}{58}{09}~\dms{-19}{44}{37}{1} ``with respect to the mean equator +and equinox of epoch J2000''. The short way of saying +this is ``\radec\ equinox J2000'' ({\bf not} ``\radec\ epoch J2000'', +which means something different to do with +proper motion). + +\subsection{Epoch} +The word ``epoch'' just means a moment in time, and can be supplied +in a variety of forms, using different calendar systems and timescales. + +For the purpose of specifying the epochs associated with the +mean place of a star, two conventions exist. Both sorts of epoch +superficially resemble years AD but are not tied to the civil +(Gregorian) calendar; to distinguish them from ordinary calendar-years +there is often +a ``.0'' suffix (as in ``1950.0''), although any other fractional +part is perfectly legal ({\it e.g.}\ 1987.5). + +The older system, +{\it Besselian epoch}, is defined in such a way that its units are +tropical years of about 365.2422~days and its timescale is the +obsolete {\it Ephemeris Time}. +The start of the Besselian year is the moment +when the ecliptic longitude of the mean Sun is +$280^{\circ}$; this happens near the start of the +calendar year (which is why $280^{\circ}$ was chosen). + +The new system, {\it Julian epoch}, was adopted as +part of the IAU~1976 revisions (about which more will be said +in due course) and came formally into use at the +beginning of 1984. It uses the Julian year of exactly +365.25~days; Julian epoch 2000 is defined to be 2000~January~1.5 in the +TT timescale. + +For specifying mean places, various standard epochs are in use, the +most common ones being Besselian epoch 1950.0 and Julian epoch 2000.0. +To distinguish the two systems, Besselian epochs +are now prefixed ``B'' and Julian epochs are prefixed ``J''. +Epochs without an initial letter can be assumed to be Besselian +if before 1984.0, otherwise Julian. These details are supported by +the SLALIB routines +sla\_DBJIN +(decodes numbers from a +character string, accepting an optional leading B or J), +sla\_KBJ +(decides whether B or J depending on prefix or range) and +sla\_EPCO +(converts one epoch to match another). + +SLALIB has four routines for converting +Besselian and Julian epochs into other forms. +The functions +sla\_EPB2D +and +sla\_EPJ2D +convert Besselian and Julian epochs into MJD; the functions +sla\_EPB +and +sla\_EPJ +do the reverse. For example, to express B1950 as a Julian epoch: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION sla_EPJ,sla_EPB2D + : + WRITE (*,'(1X,''J'',F10.5)') sla_EPJ(sla_EPB2D(1950D0)) +\end{verbatim} +\goodbreak +(The answer is J1949.99979.) + +\subsection{Proper Motion} +Stars in catalogues usually have, in addition to the +\radec\ coordinates, a {\it proper motion} $[\mu_\alpha,\mu_\delta]$. +This is an intrinsic motion +of the star across the background. Very few stars have a +proper motion which exceeds \arcseci{1}/year, and most are +far below this level. A star observed as part of normal +astronomy research will, as a rule, have a proper motion +which is unknown. + +Mean \radec\ and rate of change are not sufficient to pin +down a star; the epoch at which the \radec\ was or will +be correct is also needed. Note the distinction +between the epoch which specifies the +coordinate system and the epoch at which the star passed +through the given \radec. The full specification for a star +is \radec, proper motions, equinox and epoch (plus something to +identify which set of models for the precession {\it etc.}\ is +being used -- see the next section). +For convenience, coordinates given in star catalogues are almost +always adjusted to make the equinox and epoch the same -- for +example B1950 in the case of the SAO~catalogue. + +SLALIB provides one routine to handle proper motion on its own, +sla\_PM. +Proper motion is also allowed for in various other +routines as appropriate, for example +sla\_MAP +and +sla\_FK425. +Note that in all SLALIB routines which involve proper motion +the units are radians per year and the +$\alpha$ component is in the form $\dot{\alpha}$ ({\it i.e.}\ big +numbers near the poles). +Some star catalogues have proper motion per century, and +in some catalogues the $\alpha$ component is in the form +$\dot{\alpha}\cos\delta$ ({\it i.e.}\ angle on the sky). + +\subsection{Parallax and Radial Velocity} +For the utmost accuracy and the nearest stars, allowance can +be made for {\it annual parallax}\/ and for the effects of perspective +on the proper motion. + +Parallax is appreciable only for nearby stars; even +the nearest, Proxima Centauri, is displaced from its average +position by less than +an arcsecond as the Earth revolves in its orbit. + +For stars with a known parallax, knowledge of the radial velocity +allows the proper motion to be expressed as an actual space +motion in 3~dimensions. The proper motion is, +in fact, a snapshot of the transverse component of the +space motion, and in the case of nearby stars will +change with time due to perspective. + +SLALIB does not provide facilities for handling parallax +and radial-velocity on their own, but their contribution is +allowed for in such routines as +sla\_PM, +sla\_MAP +and +sla\_FK425. +Catalogue mean +places do not include the effects of parallax and are therefore +{\it barycentric}; when pointing telescopes {\it etc.}\ it is +usually most efficient to apply the slowly-changing +parallax correction to the mean place of the target early on +and to work with the {\it geocentric}\/ mean place. This latter +approach is implied in Figure~1. + +\subsection{Aberration} +The finite speed of light combined with the motion of the observer +around the Sun during the year causes apparent displacements of +the positions of the stars. The effect is called +the {\it annual aberration} (or ``stellar'' +aberration). Its maximum size, about \arcsec{20}{5}, +occurs for stars $90^{\circ}$ from the point towards which +the Earth is headed as it orbits the Sun; a star exactly in line with +the Earth's motion is not displaced. To receive the light of +a star, the telescope has to be offset slightly in the direction of +the Earth's motion. A familiar analogy is the need to tilt your +umbrella forward when on the move, to avoid getting wet. This +Newtonian model is, +in fact, highly misleading in the context of light as opposed +to rain, but happens to give the same answer as a relativistic +treatment to first order (better than 1~milliarcsecond). + +Before the IAU 1976 resolutions, different +values for the approximately +\arcsec{20}{5} {\it aberration constant}\/ were employed +at different times, and this can complicate comparisons +between different catalogues. Another complication comes from +the so-called {\it E-terms of aberration}, +that small part of the annual aberration correction that is a +function of the eccentricity of the Earth's orbit. The E-terms, +maximum amplitude about \arcsec{0}{3}, +happen to be approximately constant for a given star, and so they +used to be incorporated in the catalogue \radec\/ +to reduce the labour of converting to and from apparent place. +The E-terms can be removed from a catalogue \radec\/ by +calling +sla\_SUBET +or applied (for example to allow a pulsar +timing-position to be plotted on a B1950 finding chart) +by calling +sla\_ADDET; +the E-terms vector itself can be obtained by calling +sla\_ETRMS. +Star positions post IAU 1976 are free of these distortions, and to +apply corrections for annual aberration involves the actual +barycentric velocity of the Earth rather than the use of +canonical circular-orbit models. + +The annual aberration is the aberration correction for +an imaginary observer at the Earth's centre. +The motion of a real observer around the Earth's rotation axis in +the course of the day makes a small extra contribution to the total +aberration effect called the {\it diurnal aberration}. Its +maximum amplitude is about \arcsec{0}{2}. + +No SLALIB routine is provided for calculating the aberration on +its own, though the required velocity vectors can be +generated using +sla\_EVP +and +sla\_GEOC. +Annual and diurnal aberration are allowed for where required, for example in +sla\_MAP +{\it etc}.\ and +sla\_AOP +{\it etc}. Note that this sort +of aberration is different from the {\it planetary +aberration}, which is the apparent displacement of a solar-system +body, with respect to the ephemeris position, as a consequence +of the motion of {\it both}\/ the Earth and the source. The +planetary aberration can be computed either by correcting the +position of the solar-system body for light-time, followed by +the ordinary stellar aberration correction, or more +directly by expressing the position and velocity of the source +in the observer's frame and correcting for light-time alone. + +\subsection{Different Sorts of Mean Place} +A particularly confusing aspect of published mean places is that they +are sensitive to the precise way they were determined. A mean +place is not directly observable, even with fundamental +instruments such as transit circles, and to produce a mean +place will involve relying on some existing star catalogue, +for example the fundamental catalogues FK4 and FK5, +and applying given mathematical models of precession, nutation, +aberration and so on. +Note in particular that no star catalogue, +even a fundamental catalogue such as FK4 or +FK5, defines a coordinate system, strictly speaking; +it is merely a list of star positions and proper motions. +However, once the stars from a given catalogue +are used as position calibrators, {\it e.g.}\ for +transit-circle observations or for plate reductions, then a +broader sense of there being a coordinate grid naturally +arises, and such phrases as ``in the system of +the FK4'' can legitimately be employed. However, +there is no formal link between the +two concepts -- no ``standard least squares fit'' between +reality and the inevitably flawed catalogues.\footnote{This was +true until the inception of the International Celestial Reference +System, which is based on the idea of axes locked into the +distant background. The coordinates +of the extragalactic sources which realize these +axes have no individual significance; there is a ``no net rotation'' +condition which has to be satisfied each time any revisions take +place.} All such +catalogues suffer at some level from systematic, zonal distortions +of both the star positions and of the proper motions, +and include measurement errors peculiar to individual +stars. + +Many of these complications are of little significance except to +specialists. However, observational astronomers cannot +escape exposure to at least the two main varieties of +mean place, loosely called +FK4 and FK5, and should be aware of +certain pitfalls. For most practical purposes the more recent +system, FK5, is free of surprises and tolerates naive +use well. FK4, in contrast, contains two important traps: +\begin{itemize} +\item The FK4 system rotates at about + \arcsec{0}{5} per century relative to distant galaxies. + This is manifested as a systematic distortion in the + proper motions of all FK4-derived catalogues, which will + in turn pollute any astrometry done using those catalogues. + For example, FK4-based astrometry of a QSO using plates + taken decades apart will reveal a non-zero {\it fictitious proper + motion}, and any FK4 star which happens to have zero proper + motion is, in fact, slowly moving against the distant + background. The FK4 frame rotates because it was + established before the nature of the Milky Way, and hence the + existence of systematic motions of nearby stars, had been + recognized. +\item Star positions in the FK4 system are part-corrected for + annual aberration (see above) and embody the so-called + E-terms of aberration. +\end{itemize} +The change from the old FK4-based system to FK5 +occurred at the beginning +of 1984 as part of a package of resolutions made by the IAU in 1976, +along with the adoption of J2000 as the reference epoch. Star +positions in the newer, FK5, system are free from the E-terms, and +the system is a much better approximation to an +inertial frame (about five times better). + +It may occasionally be convenient to specify the FK4 fictitious proper +motion directly. In FK4, the centennial proper motion of (for example) +a QSO is: + +$\mu_\alpha=-$\tsec{0}{015869}$ + +(($\tsec{0}{029032}$~\sin \alpha + +$\tsec{0}{000340}$~\cos \alpha ) \sin \delta + -$\tsec{0}{000105}$~\cos \alpha + -$\tsec{0}{000083}$~\sin \alpha ) \sec \delta $ \\ +$\mu_\delta\,=+$\arcsec{0}{43549}$~\cos \alpha + -$\arcsec{0}{00510}$~\sin \alpha + + ($\arcsec{0}{00158}$~\sin \alpha + -$\arcsec{0}{00125}$~\cos \alpha ) \sin \delta + -$\arcsec{0}{00066}$~\cos \delta $ + +\subsection{Mean Place Transformations} +Figure~1 is based upon three varieties of mean \radec\ all of which are +of practical significance to observing astronomers in the present era: +\begin{itemize} + \item Old style (FK4) with known proper motion in the FK4 + system, and with parallax and radial velocity either + known or assumed zero. + \item Old style (FK4) with zero proper motion in FK5, + and with parallax and radial velocity assumed zero. + \item New style (FK5) with proper motion, parallax and + radial velocity either known or assumed zero. +\end{itemize} +The figure outlines the steps required to convert positions in +any of these systems to a J2000 \radec\ for the current +epoch, as might be required in a telescope-control +program for example. +Most of the steps can be carried out by calling a single +SLALIB routines; there are other SLALIB routines which +offer set-piece end-to-end transformation routines for common cases. +Note, however, that SLALIB does not set out to provide the capability +for arbitrary transformations of star-catalogue data +between all possible systems of mean \radec. +Only in the (common) cases of FK4, equinox and epoch B1950, +to FK5, equinox and epoch J2000, and {\it vice versa}\/ are +proper motion, parallax and radial velocity transformed +along with the star position itself, the +focus of SLALIB support. + +As an example of using SLALIB to transform mean places, here is +a program which implements the top-left path of Figure~1. +An FK4 \radec\ of arbitrary equinox and epoch and with +known proper motion and +parallax is transformed into an FK5 J2000 \radec\ for the current +epoch. As a test star we will use $\alpha=$\hms{16}{09}{55}{13}, +$\delta=$\dms{-75}{59}{27}{2}, equinox 1900, epoch 1963.087, +$\mu_\alpha=$\tsec{-0}{0312}$/y$, $\mu_\delta=$\arcsec{+0}{103}$/y$, +parallax = \arcsec{0}{062}, radial velocity = $-34.22$~km/s. The +epoch of observation is 1994.35. +\goodbreak +\begin{verbatim} + IMPLICIT NONE + DOUBLE PRECISION AS2R,S2R + PARAMETER (AS2R=4.8481368110953599D-6,S2R=7.2722052166430399D-5) + INTEGER J,I + DOUBLE PRECISION R0,D0,EQ0,EP0,PR,PD,PX,RV,EP1,R1,D1,R2,D2,R3,D3, + : R4,D4,R5,D5,R6,D6,EP1D,EP1B,W(3),EB(3),PXR,V(3) + DOUBLE PRECISION sla_EPB,sla_EPJ2D + + * RA, Dec etc of example star + CALL sla_DTF2R(16,09,55.13D0,R0,J) + CALL sla_DAF2R(75,59,27.2D0,D0,J) + D0=-D0 + EQ0=1900D0 + EP0=1963.087D0 + PR=-0.0312D0*S2R + PD=+0.103D0*AS2R + PX=0.062D0 + RV=-34.22D0 + EP1=1994.35D0 + + * Epoch of observation as MJD and Besselian epoch + EP1D=sla_EPJ2D(EP1) + EP1B=sla_EPB(EP1D) + + * Space motion to the current epoch + CALL sla_PM(R0,D0,PR,PD,PX,RV,EP0,EP1B,R1,D1) + + * Remove E-terms of aberration for the original equinox + CALL sla_SUBET(R1,D1,EQ0,R2,D2) + + * Precess to B1950 + R3=R2 + D3=D2 + CALL sla_PRECES('FK4',EQ0,1950D0,R3,D3) + + * Add E-terms for the standard equinox B1950 + CALL sla_ADDET(R3,D3,1950D0,R4,D4) + + * Transform to J2000, no proper motion + CALL sla_FK45Z(R4,D4,EP1B,R5,D5) + + * Parallax + CALL sla_EVP(sla_EPJ2D(EP1),2000D0,W,EB,W,W) + PXR=PX*AS2R + CALL sla_DCS2C(R5,D5,V) + DO I=1,3 + V(I)=V(I)-PXR*EB(I) + END DO + CALL sla_DCC2S(V,R6,D6) + : +\end{verbatim} +\goodbreak +It is interesting to look at how the \radec\ changes during the +course of the calculation: +\begin{tabbing} +xxxxxxxxxxxxxx \= xxxxxxxxxxxxxxxxxxxxxxxxx \= x \= \kill +\> {\tt 16 09 55.130 -75 59 27.20} \> \> {\it original equinox and epoch} \\ +\> {\tt 16 09 54.155 -75 59 23.98} \> \> {\it with space motion} \\ +\> {\tt 16 09 54.229 -75 59 24.18} \> \> {\it with old E-terms removed} \\ +\> {\tt 16 16 28.213 -76 06 54.57} \> \> {\it precessed to 1950.0} \\ +\> {\tt 16 16 28.138 -76 06 54.37} \> \> {\it with new E-terms} \\ +\> {\tt 16 23 07.901 -76 13 58.87} \> \> {\it J2000, current epoch} \\ +\> {\tt 16 23 07.907 -76 13 58.92} \> \> {\it including parallax} +\end{tabbing} + +Other remarks about the above (unusually complicated) example: +\begin{itemize} +\item If the original equinox and epoch were B1950, as is quite + likely, then it would be unnecessary to treat space motions + and E-terms explicitly. Transformation to FK5 J2000 could + be accomplished simply by calling +sla\_FK425, after which + a call to +sla\_PM and the parallax code would complete the + work. +\item The rigorous treatment of the E-terms + has only a small effect on the result. Such refinements + are, nevertheless, worthwhile in order to facilitate comparisons and + to increase the chances that star positions from different + suppliers are compatible. +\item The FK4 to FK5 transformations, +sla\_FK425 + and +sla\_FK45Z, + are not as is sometimes assumed simply 50 years of precession, + though this indeed accounts for most of the change. The + transformations also include adjustments + to the equinox, a revised precession model, elimination of the + E-terms, a change to the proper-motion time unit and so on. + The reason there are two routines rather than just one + is that the FK4 frame rotates relative to the background, whereas + the FK5 frame is a much better approximation to an + inertial frame, and zero proper + motion in FK4 does not, therefore, mean zero proper motion in FK5. + SLALIB also provides two routines, +sla\_FK524 + and +sla\_FK54Z, + to perform the inverse transformations. +\item Some star catalogues (FK4 itself is one) were constructed using slightly + different procedures for the polar regions compared with + elsewhere. SLALIB ignores this inhomogeneity and always + applies the standard + transformations irrespective of location on the celestial sphere. +\end{itemize} + +\subsection {Mean Place to Apparent Place} +The {\it geocentric apparent place}\/ of a source, or {\it apparent place}\/ +for short, +is the \radec\ if viewed from the centre of the Earth, +with respect to the true equator and equinox of date. +Transformation of an FK5 mean \radec, equinox J2000, +current epoch, to apparent place involves the following effects: +\goodbreak +\begin{itemize} + \item Light deflection -- the gravitational lens effect of + the sun. + \item Annual aberration. + \item Precession/nutation. +\end{itemize} +The {\it light deflection}\/ is seldom significant. Its value +at the limb of the Sun is about +\arcsec{1}{74}; it falls off rapidly with distance from the +Sun and has shrunk to about +\arcsec{0}{02} at an elongation of $20^\circ$. + +As already described, the {\it annual aberration}\/ +is a function of the Earth's velocity +relative to the solar system barycentre (available through the +SLALIB routine +sla\_EVP) +and produces shifts of up to about \arcsec{20}{5}. + +The {\it precession/nutation}, from J2000 to the current epoch, is +expressed by a rotation matrix which is available through the +SLALIB routine +sla\_PRENUT. + +The whole mean-to-apparent transformation can be done using the SLALIB +routine +sla\_MAP. As a demonstration, here is a program which lists the +{\it North Polar Distance}\/ ($90^\circ-\delta$) of Polaris for +the decade of closest approach to the Pole: +\goodbreak +\begin{verbatim} + IMPLICIT NONE + DOUBLE PRECISION PI,PIBY2,D2R,S2R,AS2R + PARAMETER (PI=3.141592653589793238462643D0) + PARAMETER (D2R=PI/180D0, + : PIBY2=PI/2D0, + : S2R=PI/(12D0*3600D0), + : AS2R=PI/(180D0*3600D0)) + DOUBLE PRECISION RM,DM,PR,PD,DATE,RA,DA + INTEGER J,IDS,IDE,ID,IYMDF(4),I + DOUBLE PRECISION sla_EPJ2D + + CALL sla_DTF2R(02,31,49.8131D0,RM,J) + CALL sla_DAF2R(89,15,50.661D0,DM,J) + PR=+21.7272D0*S2R/100D0 + PD=-1.571D0*AS2R/100D0 + WRITE (*,'(1X,'// + : '''Polaris north polar distance (deg) 2096-2105''/)') + WRITE (*,'(4X,''Date'',7X''NPD''/)') + CALL sla_CLDJ(2096,1,1,DATE,J) + IDS=NINT(DATE) + CALL sla_CLDJ(2105,12,31,DATE,J) + IDE=NINT(DATE) + DO ID=IDS,IDE,10 + DATE=DBLE(ID) + CALL sla_DJCAL(0,DATE,IYMDF,J) + CALL sla_MAP(RM,DM,PR,PD,0D0,0D0,2000D0,DATE,RA,DA) + WRITE (*,'(1X,I4,2I3.2,F9.5)') (IYMDF(I),I=1,3),(PIBY2-DA)/D2R + END DO + + END +\end{verbatim} +\goodbreak +For cases where the transformation has to be repeated for different +times or for more than one star, the straightforward +sla\_MAP +approach is apt to be +wasteful as both the Earth velocity and the +precession/nutation matrix can be re-calculated relatively +infrequently without ill effect. A more efficient method is to +perform the target-independent calculations only when necessary, +by calling +sla\_MAPPA, +and then to use either +sla\_MAPQKZ, +when only the \radec\/ is known, or +sla\_MAPQK, +when full catalogue positions, including proper motion, parallax and +radial velocity, are available. How frequently to call +sla\_MAPPA +depends on the accuracy objectives; once per +night will deliver sub-arcsecond accuracy for example. + +The routines +sla\_AMP +and +sla\_AMPQK +allow the reverse transformation, from apparent to mean place. + +\subsection{Apparent Place to Observed Place} +The {\it observed place}\/ of a source is its position as +seen by a perfect theodolite at the location of the +observer. Transformation of an apparent \radec\ to observed +place involves the following effects: +\goodbreak +\begin{itemize} + \item \radec\ to \hadec. + \item Diurnal aberration. + \item \hadec\ to \azel. + \item Refraction. +\end{itemize} +The transformation from apparent \radec\ to +apparent \hadec\ is made by allowing for +{\it Earth rotation}\/ through the {\it sidereal time}, $\theta$: +\[ h = \theta - \alpha \] +For this equation to work, $\alpha$ must be the apparent right +ascension for the time of observation, and $\theta$ must be +the {\it local apparent sidereal time}. The latter is obtained +as follows: +\begin{enumerate} +\item from civil time obtain the coordinated universal time, UTC + (more later on this); +\item add the UT1$-$UTC (typically a few tenths of a second) to + give the UT; +\item from the UT compute the Greenwich mean sidereal time (using +sla\_GMST); +\item add the observer's (east) longitude, giving the local mean + sidereal time; +\item add the equation of the equinoxes (using +sla\_EQEQX). +\end{enumerate} +The {\it equation of the equinoxes}\/~($=\Delta\psi\cos\epsilon$ plus +small terms) +is the effect of nutation on the sidereal time. +Its value is typically a second or less. It is +interesting to note that if the object of the exercise is to +transform a mean place all the way into an observed place (very +often the case), +then the equation of the +equinoxes and the longitude component of nutation can both be +omitted, removing a great deal of computation. However, SLALIB +follows the normal convention and works {\it via}\/ the apparent place. + +Note that for very precise work the observer's longitude should +be corrected for {\it polar motion}. This can be done with +sla\_POLMO. +The corrections are always less than about \arcsec{0}{3}, and +are futile unless the position of the observer's telescope is known +to better than a few metres. + +Tables of observed and +predicted UT1$-$UTC corrections and polar motion data +are published every few weeks by the International Earth Rotation Service. + +The transformation from apparent \hadec\ to {\it topocentric}\/ +\hadec\ consists of allowing for +{\it diurnal aberration}. This effect, maximum amplitude \arcsec{0}{2}, +was described earlier. There is no specific SLALIB routine +for computing the diurnal aberration, +though the routines +sla\_AOP {\it etc.}\ +include it, and the required velocity vector can be +determined by calling +sla\_GEOC. + +The next stage is the major coordinate rotation from local equatorial +coordinates \hadec\ into horizon coordinates. The SLALIB routines +sla\_E2H +{\it etc.}\ can be used for this. For high-precision +applications the mean geodetic latitude should be corrected for polar +motion. + +\subsubsection{Refraction} +The final correction is for atmospheric refraction. +This effect, which depends on local meteorological conditions and +the effective colour of the source/detector combination, +increases the observed elevation of the source by a +significant effect even at moderate zenith distances, and near the +horizon by over \degree{0}{5}. The amount of refraction can by +computed by calling the SLALIB routine +sla\_REFRO; +however, +this requires as input the observed zenith distance, which is what +we are trying to predict. For high precision it is +therefore necessary to iterate, using the topocentric +zenith distance as the initial estimate of the +observed zenith distance. + +The full +sla\_REFRO refraction calculation is onerous, and for +zenith distances of less than, say, $75^{\circ}$ the following +model can be used instead: + +\[ \zeta _{vac} \approx \zeta _{obs} + + A \tan \zeta _{obs} + + B \tan ^{3}\zeta _{obs} \] +where $\zeta _{vac}$ is the topocentric +zenith distance (i.e.\ {\it in vacuo}), +$\zeta _{obs}$ is the observed +zenith distance (i.e.\ affected by refraction), and $A$ and $B$ are +constants, about \arcseci{60} +and \arcsec{-0}{06} respectively for a sea-level site. +The two constants can be calculated for a given set of conditions +by calling either +sla\_REFCO or +sla\_REFCOQ. + +sla\_REFCO works by calling +sla\_REFRO for two zenith distances and fitting $A$ and $B$ +to match. The calculation is onerous, but delivers accurate +results whatever the conditions. +sla\_REFCOQ uses a direct formulation of $A$ and $B$ and +is much faster; it is slightly less accurate than +sla\_REFCO but more than adequate for most practical purposes. + +Like the full refraction model, the two-term formulation works in the wrong +direction for our purposes, predicting +the {\it in vacuo}\/ (topocentric) zenith distance +given the refracted (observed) zenith distance, +rather than {\it vice versa}. The obvious approach of +interchanging $\zeta _{vac}$ and $\zeta _{obs}$ and +reversing the signs, though approximately +correct, gives avoidable errors which are just significant in +some applications; for +example about \arcsec{0}{2} at $70^\circ$ zenith distance. A +much better result can easily be obtained, by using one Newton-Raphson +iteration as follows: + +\[ \zeta _{obs} \approx \zeta _{vac} + - \frac{A \tan \zeta _{vac} + B \tan ^{3}\zeta _{vac}} + {1 + ( A + 3 B \tan ^{2}\zeta _{vac} ) \sec ^{2}\zeta _{vac}}\] + +The effect of refraction can be applied to an unrefracted +zenith distance by calling +sla\_REFZ or to an unrefracted +\xyz\ by calling +sla\_REFV. +Over most of the sky these two routines deliver almost identical +results, but beyond $\zeta=83^\circ$ +sla\_REFV +becomes unacceptably inaccurate while +sla\_REFZ +remains usable. (However +sla\_REFV +is significantly faster, which may be important in some applications.) +SLALIB also provides a routine for computing the airmass, the function +sla\_AIRMAS. + +The refraction ``constants'' returned by +sla\_REFCO and +sla\_REFCOQ +are slightly affected by colour, especially at the blue end +of the spectrum. Where values for more than one +wavelength are needed, rather than calling +sla\_REFCO +several times it is more efficient to call +sla\_REFCO +just once, for a selected ``base'' wavelength, and then to call +sla\_ATMDSP +once for each wavelength of interest. + +All the SLALIB refraction routines work for radio wavelengths as well +as the optical/IR band. The radio refraction is very dependent on +humidity, and an accurate value must be supplied. There is no +wavelength dependence, however. The choice of optical/IR or +radio is made by specifying a wavelength greater than $100\mu m$ +for the radio case. + +\subsubsection{Efficiency considerations} +The complete apparent place to observed place transformation +can be carried out by calling +sla\_AOP. +For improved efficiency +in cases of more than one star or a sequence of times, the +target-independent calculations can be done once by +calling +sla\_AOPPA, +the time can be updated by calling +sla\_AOPPAT, +and +sla\_AOPQK +can then be used to perform the +apparent-to-observed transformation. The reverse transformation +is available through +sla\_OAP +and +sla\_OAPQK. +({\it n.b.}\ These routines use accurate but computationally-expensive +refraction algorithms for zenith distances beyond about $76^\circ$. +For many purposes, in-line code tailored to the accuracy requirements +of the application will be preferable, for example ignoring UT1$-$UTC, +omitting diurnal aberration and using +sla\_REFZ +to apply the refraction.) + +\subsection{The Hipparcos Catalogue and the ICRS} +With effect from the beginning of 1998, the IAU adopted a new +reference system to replace FK5 J2000. The new system, called the +International Celestial Reference System (ICRS), differs profoundly +from all predecessors in that the link with solar-system dynamics +was broken; the ICRS axes are defined in terms of the directions +of a set of extragalactic sources, not in terms of the mean equator and +equinox at a given reference epoch. Although the ICRS and FK5 coordinates +of any given object are almost the same, the orientation of the new frame +was essentially arbitrary, and the close match to FK5 J2000 was contrived +purely for reasons of continuity and convenience. + +A distinction is made between the reference {\it system}\/ (the ICRS) +and {\it frame}\/ (ICRF). The ICRS is the set of prescriptions and +conventions together with the modelling required to define, at any +time, a triad of axes. The ICRF is a practical realization, and +currently consists of a catalogue of equatorial coordinates for 608 +extragalactic radio sources observed by VLBI. + +The best optical realization of the ICRF currently available is the +Hipparcos catalogue. The extragalactic sources were not directly +observable by the Hipparcos satellite and so the link from Hipparcos +to ICRF was established through a variety of indirect techniques: VLBI and +conventional interferometry of radio stars, photographic astrometry +and so on. The Hipparcos frame is aligned to the ICRF to within about +0.5~mas and 0.5~mas/year (at epoch 1991.25). + +The Hipparcos catalogue includes all of the FK5 stars, which has enabled +the orientation and spin of the latter to be studied. At epoch J2000, +the misalignment of the FK5 frame with respect to Hipparcos +(and hence ICRS) are about 32~mas and 1~mas/year respectively. +Consequently, for many practical purposes, including pointing +telescopes, the IAU 1976-1982 conventions on reference frames and +Earth orientation remain adequate and there is no need to change to +Hipparcos coordinates, new precession/nutation models and so on. +However, for the most exacting astrometric applications, SLALIB +provides some support for Hipparcos coordinates in the form of +four new routines: +sla\_FK52H and +sla\_H2FK5, +which transform FK5 positions and proper motions to the Hipparcos frame +and {\it vice versa,}\/ and +sla\_FK5HZ and +sla\_HFK5Z, +where the transformations are for stars whose Hipparcos proper motion is +zero. + +Further information on the ICRS can be found in the paper by M.\,Feissel +and F.\,Mignard, Astron.\,Astrophys. 331, L33-L36 (1988). + +\subsection{Timescales} +SLALIB provides for conversion between several timescales, and involves +use of one or two others. The full list is as follows: +\begin{itemize} +\item TAI: International Atomic Time +\item UTC: Coordinated Universal Time +\item UT: Universal Time +\item GMST: Greenwich Mean Sidereal Time +\item LAST: Local Apparent Sidereal Time +\item TT: Terrestrial Time +\item TDB: Barycentric Dynamical Time. +\end{itemize} +Three obsolete timescales should be mentioned here to avoid confusion. +\begin{itemize} +\item GMT: Greenwich Mean Time -- can mean either UTC or UT. +\item ET: Ephemeris Time -- more or less the same as either TT or TDB. +\item TDT: Terrestrial Dynamical Time -- former name of TT. +\end{itemize} + +\subsubsection{Atomic Time: TAI} +{\it International Atomic Time}\/ TAI is a laboratory timescale. Its +unit is the SI second, which is defined in terms of a +defined number +of wavelengths of the radiation produced by a certain electronic +transition in the caesium 133 atom. It +is realized through a changing +population of high-precision atomic clocks held +at standards institutes in various countries. There is an +elaborate process of continuous intercomparison, leading to +a weighted average of all the clocks involved. + +Though TAI shares the same second as the more familiar UTC, the +two timescales are noticeably separated in epoch because of the +build-up of leap seconds. At the time of writing, UTC +lags about half a minute behind TAI. + +For any given date, the difference TAI$-$UTC +can be obtained by calling the SLALIB routine +sla\_DAT. +Note, however, that an up-to-date copy of the routine must be used if +the most recent leap seconds are required. For applications +where this is critical, mechanisms independent of SLALIB +and under local control must +be set up; in such cases +sla\_DAT +can be useful as an +independent check, for test dates within the range of the +available version. Up-to-date information on TAI$-$UTC is available +from {\tt ftp://maia.usno.navy.mil/ser7/tai-utc.dat}. + +\subsubsection{Universal Time: UTC, UT1} +{\it Coordinated Universal Time}\/ UTC is the basis of civil timekeeping. +Most time zones differ from UTC by an integer number +of hours, though a few ({\it e.g.}\ parts of Canada and Australia) differ +by $n+0.5$~hours. The UTC second is the same as the SI second, +as for TAI. In the long term, UTC keeps in step with the +Sun. It does so even though the Earth's rotation is slightly +variable (due to large scale movements of water and atmosphere +among other things) by occasionally introducing a {\it leap +second}. + +{\it Universal Time}\/ UT, or more specifically UT1, +is in effect the mean solar time. It is continuous +({\it i.e.}\ there are no leap seconds) but has a variable +rate because of the Earth's non-uniform rotation period. It is +needed for computing the sidereal time, an essential part of +pointing a telescope at a celestial source. To obtain UT1, you +have to look up the value of UT1$-$UTC for the date concerned +in tables published by the International Earth Rotation +Service; this quantity, kept in the range +$\pm$\tsec{0}{9} by means of UTC leap +seconds, is then added to the UTC. The quantity UT1$-$UTC, +which typically changes by 1 or 2~ms per day, +can only be obtained by observation, though seasonal trends +are known and the IERS listings are able to predict some way into +the future with adequate accuracy for pointing telescopes. + +UTC leap seconds are introduced as necessary, +usually at the end of December or June. +On the average the solar day is slightly longer +than the nominal 86,400~SI~seconds and so leap seconds are always positive; +however, provision exists for negative leap seconds if needed. +The form of a leap second can be seen from the +following description of the end of June~1994: + +\hspace{3em} +\begin{tabular}{clrccc} \\ + & & & UTC & UT1$-$UTC & UT1 \\ \\ +1994 & June & 30 & 23 59 58 & $-0.218$ & 23 59 57.782 \\ + & & & 23 59 59 & $-0.218$ & 23 59 58.782 \\ + & & & 23 59 60 & $-0.218$ & 23 59 59.782 \\ + & July & 1 & 00 00 00 & $+0.782$ & 00 00 00.782 \\ + & & & 00 00 01 & $+0.782$ & 00 00 01.782 \\ +\end{tabular} + +Note that UTC has to be expressed as hours, minutes and +seconds (or at least in seconds for a given date) if leap seconds +are to be taken into account. It is improper to express a UTC as a +Julian Date, for example, because there will be an ambiguity +during a leap second (in the above example, +1994~June~30 \hms{23}{59}{60}{0} and +1994~July~1 \hms{00}{00}{00}{0} would {\it both}\/ come out as +MJD~49534.00000). Although in the vast majority of +cases this won't matter, there are potential problems in +on-line data acquisition systems and in applications involving +taking the difference between two times. Note that although the routines +sla\_DAT +and +sla\_DTT +expect UTC in the form of an MJD, the meaning here is really a +whole-number {\it date}\/ rather than a time. Though the routines will accept +a fractional part and will almost always function correctly, on a day +which ends with a leap +second incorrect results would be obtained during the leap second +itself because by then the MJD would have moved into the next day. + +\subsubsection{Sidereal Time: GMST, LAST} +Sidereal Time is the ``time of day'' relative to the +stars rather than to the Sun. After +one sidereal day the stars come back to the same place in the +sky, apart from sub-arcsecond precession effects. Because the Earth +rotates faster relative to the stars than to the Sun by one day +per year, the sidereal second is shorter than the solar +second; the ratio is about 0.9973. + +The {\it Greenwich Mean Sidereal Time}\/ GMST is +linked to UT1 by a numerical formula which +is implemented in the SLALIB routines +sla\_GMST +and +sla\_GMSTA. +There are, of course, no leap seconds in GMST, but the second +changes in length along with the UT1 second, and also varies +over long periods of time because of slow changes in the Earth's +orbit. This makes the timescale unsuitable for everything except +predicting the apparent directions of celestial sources. + +The {\it Local Apparent Sidereal Time}\/ LAST is the apparent right +ascension of the local meridian, from which the hour angle of any +star can be determined knowing its $\alpha$. It can be obtained from the +GMST by adding the east longitude (corrected for polar motion +in precise work) and the {\it equation of the equinoxes}. The +latter, already described, is an aspect of the nutation effect +and can be predicted by calling the SLALIB routine +sla\_EQEQX +or, neglecting certain very small terms, by calling +sla\_NUTC +and using the expression $\Delta\psi\cos\epsilon$. + +\subsubsection{Dynamical Time: TT, TDB} +Dynamical time is the independent variable in the theories +which describe the motions of bodies in the solar system. When +you use published formulae which model the position of the +Earth in its orbit, for example, or look up +the Moon's position in a precomputed ephemeris, the date and time +you use must be in terms of one of the dynamical timescales. It +is a common but understandable mistake to use UT directly, in which +case the results will be about 1~minute out (in the present +era). + +It is not hard to see why such timescales are necessary. +UTC would clearly be unsuitable as the argument of an +ephemeris because of leap seconds. +A solar-system ephemeris based on UT1 or sidereal time would somehow +have to include the unpredictable variations of the Earth's rotation. +TAI would work, but eventually +the ephemeris and the ensemble of atomic clocks would drift apart. +In effect, the ephemeris {\it is}\/ a clock, with the bodies of +the solar system the hands. + +Only two of the dynamical timescales are of any great importance to +observational astronomers, TT and TDB. (The obsolete +timescale ET, ephemeris time, was more or less the same as TT.) + +{\it Terrestrial Time}\/ TT is +the theoretical timescale of apparent geocentric ephemerides of solar +system bodies. It applies, in principle, +to an Earthbound clock, at sea-level, and for practical purposes +it is tied to +Atomic Time TAI through the formula TT~$=$~TAI~$+$~\tsec{32}{184}. +In practice, therefore, the units of TT are ordinary SI seconds, and +the offset of \tsec{32}{184} with respect to TAI is fixed. +The SLALIB routine +sla\_DTT +returns TT$-$UTC for a given UTC +({\it n.b.}\ sla\_DTT +calls +sla\_DAT, +and the latter must be an up-to-date version if recent leap seconds are +to be taken into account). + +{\it Barycentric Dynamical Time}\/ TDB differs from TT by an amount which +cycles back and forth by a millisecond or two due to +relativistic effects. The variation is +negligible for most purposes, but unless taken into +account would swamp +long-term analysis of pulse arrival times from the +millisecond pulsars. It is a consequence of +the TT clock being on the Earth rather than in empty +space: the ellipticity of +the Earth's orbit means that the TT clock's speed and +gravitational potential vary slightly +during the course of the year, and as a consequence +its rate as seen from an outside observer +varies due to transverse Doppler effect and gravitational +redshift. By definition, TDB and TT differ only +by periodic terms, and the main effect +is a sinusoidal variation of amplitude \tsec{0}{0016}; the +largest planetary terms are nearly two orders of magnitude +smaller. The SLALIB routine +sla\_RCC +provides a model of +TDB-TT accurate to a few nanoseconds. +There are other dynamical timescales, not supported by +SLALIB routines, which include allowance also for the secular terms. +These timescales gain on TT and TDB by about \tsec{0}{0013}/day. + +For most purposes the more accessible TT is the timescale to use, +for example when calling +sla\_PRENUT +to generate a precession/nutation matrix or when calling +sla\_EVP +to predict the +Earth's position and velocity. For some purposes TDB is the +correct timescale, for example when interrogating the JPL planetary +ephemeris (see {\it Starlink User Note~87}\/), though in most cases +TT will be near enough and will involve less computation. + +Investigations of topocentric solar-system phenomena such as +occultations and eclipses require solar time as well as dynamical +time. TT/TDB/ET is all that is required in order to compute the geocentric +circumstances, but if horizon coordinates or geocentric parallax +are to be tackled UT is also needed. A rough estimate +of $\Delta {\rm T} = {\rm ET} - {\rm UT}$ is +available via the routine +sla\_DT. +For a given epoch ({\it e.g.}\ 1650) this returns an approximation +to $\Delta {\rm T}$ in seconds. + +\subsection{Calendars} +The ordinary {\it Gregorian Calendar Date}, +together with a time of day, can be +used to express an epoch in any desired timescale. For many purposes, +however, a continuous count of days is more convenient, and for +this purpose the system of {\it Julian Day Number}\/ can be used. +JD zero is located about 7000~years ago, well before the +historical era, and is formally defined in terms of Greenwich noon; +Julian Day Number 2449444 began at noon on 1994 April~1. {\it Julian Date}\/ +is the same system but with a fractional part appended; +Julian Date 2449443.5 was the midnight on which 1994 April~1 +commenced. Because of the unwieldy size of Julian Dates +and the awkwardness of the half-day offset, it is +accepted practice to remove the leading `24' and the trailing `.5', +producing what is called the {\it Modified Julian Date}: +MJD~=~JD$-2400000.5$. SLALIB routines use MJD, as opposed to +JD, throughout, largely to avoid loss of precision. +1994 April~1 commenced at MJD~49443.0. + +Despite JD (and hence MJD) being defined in terms of (in effect) +UT, the system can be used in conjunction with other timescales +such as TAI, TT and TDB (and even sidereal time through the +concept of {\it Greenwich Sidereal Date}). However, it is improper +to express a UTC as a JD or MJD because of leap seconds. + +SLALIB has six routines for converting to and from dates in +the Gregorian calendar. The routines +sla\_CLDJ +and +sla\_CALDJ +both convert a calendar date into an MJD, the former interpreting +years between 0 and 99 as 1st century and the latter as late 20th or +early 21st century. The routines sla\_DJCL +and +sla\_DJCAL +both convert an MJD into calendar year, month, day and fraction of a day; +the latter performs rounding to a specified precision, important +to avoid dates like `{\tt 94 04 01.***}' appearing in messages. +Some of SLALIB's low-precision ephemeris routines +(sla\_EARTH, +sla\_MOON +and +sla\_ECOR) +work in terms of year plus day-in-year (where +day~1~=~January~1st, at least for the modern era). +This form of date can be generated by +calling +sla\_CALYD +(which defaults years 0-99 into 1950-2049) +or +sla\_CLYD +(which covers the full range from prehistoric times). + +\subsection{Geocentric Coordinates} +The location of the observer on the Earth is significant in a +number of ways. The most obvious, of course, is the effect of latitude +on the observed \azel\ of a star. Less obvious is the need to +allow for geocentric parallax when finding the Moon with a +telescope (and when doing high-precision work involving the +Sun or planets), and the need to correct observed radial +velocities and apparent pulsar periods for the effects +of the Earth's rotation. + +The SLALIB routine +sla\_OBS +supplies details of groundbased observatories from an internal +list. This is useful when writing applications that apply to +more than one observatory; the user can enter a brief name, +or browse through a list, and be spared the trouble of typing +in the full latitude, longitude {\it etc}. The following +Fortran code returns the full name, longitude and latitude +of a specified observatory: +\goodbreak +\begin{verbatim} + CHARACTER IDENT*10,NAME*40 + DOUBLE PRECISION W,P,H + : + CALL sla_OBS(0,IDENT,NAME,W,P,H) + IF (NAME.EQ.'?') ... (not recognized) +\end{verbatim} +\goodbreak +(Beware of the longitude sign convention, which is west +ve +for historical reasons.) The following lists all +the supported observatories: +\goodbreak +\begin{verbatim} + : + INTEGER N + : + N=1 + NAME=' ' + DO WHILE (NAME.NE.'?') + CALL sla_OBS(N,IDENT,NAME,W,P,H) + IF (NAME.NE.'?') THEN + WRITE (*,'(1X,I3,4X,A,4X,A)') N,IDENT,NAME + N=N+1 + END IF + END DO +\end{verbatim} +\goodbreak +The routine +sla\_GEOC +converts a {\it geodetic latitude}\/ +(one referred to the local horizon) to a geocentric position, +taking into account the Earth's oblateness and also the height +above sea level of the observer. The results are expressed in +vector form, namely as the distance of the observer from +the spin axis and equator respectively. The {\it geocentric +latitude}\/ can be found be evaluating ATAN2 of the +two numbers. A full 3-D vector description of the position +and velocity of the observer is available through the routine +sla\_PVOBS. +For a specified geodetic latitude, height above +sea level, and local sidereal time, +sla\_PVOBS +generates a 6-element vector containing the position and +velocity with respect to the true equator and equinox of +date ({\it i.e.}\ compatible with apparent \radec). For +some applications it will be necessary to convert to a +mean \radec\ frame (notably FK5, J2000) by multiplying +elements 1-3 and 4-6 respectively with the appropriate +precession matrix. (In theory an additional correction to the +velocity vector is needed to allow for differential precession, +but this correction is always negligible.) + +See also the discussion of the routine +sla\_RVEROT, +later. + +\subsection{Ephemerides} +SLALIB includes routines for generating positions and +velocities of Solar-System bodies. The accuracy objectives are +modest, and the SLALIB facilities do not attempt +to compete with precomputed ephemerides such as +those provided by JPL, or with models containing +thousands of terms. It is also worth noting +that SLALIB's very accurate star coordinate conversion +routines are not strictly applicable to solar-system cases, +though they are adequate for most practical purposes. + +Earth/Sun ephemerides can be generated using the routine +sla\_EVP, +which predicts Earth position and velocity with respect to both the +solar-system barycentre and the +Sun. Maximum velocity error is 0.42~metres per second; maximum +heliocentric position error is 1600~km (about \arcseci{2}), with +barycentric position errors about 4 times worse. +(The Sun's position as +seen from the Earth can, of course, be obtained simply by +reversing the signs of the Cartesian components of the +Earth\,:\,Sun vector.) + +Geocentric Moon ephemerides are available from +sla\_DMOON, +which predicts the Moon's position and velocity with respect to +the Earth's centre. Direction accuracy is usually better than +10~km (\arcseci{5}) and distance accuracy a little worse. + +Lower-precision but faster predictions for the Sun and Moon +can be made by calling +sla\_EARTH +and +sla\_MOON. +Both are single precision and accept dates in the form of +year, day-in-year and fraction of day +(starting from a calendar date you need to call +sla\_CLYD +or +sla\_CALYD +to get the required year and day). +The +sla\_EARTH +routine returns the heliocentric position and velocity +of the Earth's centre for the mean equator and +equinox of date. The accuracy is better than 20,000~km in position +and 10~metres per second in speed. +The +position and velocity of the Moon with respect to the +Earth's centre for the mean equator and ecliptic of date +can be obtained by calling +sla\_MOON. +The positional accuracy is better than \arcseci{30} in direction +and 1000~km in distance. + +Approximate ephemerides for all the major planets +can be generated by calling +sla\_PLANET +or +sla\_RDPLAN. These routines offer arcminute accuracy (much +better for the inner planets and for Pluto) over a span of several +millennia (but only $\pm100$ years for Pluto). +The routine +sla\_PLANET produces heliocentric position and +velocity in the form of equatorial \xyzxyzd\ for the +mean equator and equinox of J2000. The vectors +produced by +sla\_PLANET +can be used in a variety of ways according to the +requirements of the application concerned. The routine +sla\_RDPLAN +uses +sla\_PLANET +and +sla\_DMOON +to deal with the common case of predicting +a planet's apparent \radec\ and angular size as seen by a +terrestrial observer. + +Note that in predicting the position in the sky of a solar-system body +it is necessary to allow for geocentric parallax. This correction +is {\it essential}\/ in the case of the Moon, where the observer's +position on the Earth can affect the Moon's \radec\ by up to +$1^\circ$. The calculation can most conveniently be done by calling +sla\_PVOBS and subtracting the resulting 6-vector from the +one produced by +sla\_DMOON, as is demonstrated by the following example: +\goodbreak +\begin{verbatim} + * Demonstrate the size of the geocentric parallax correction + * in the case of the Moon. The test example is for the AAT, + * before midnight, in summer, near first quarter. + + IMPLICIT NONE + CHARACTER NAME*40,SH,SD + INTEGER J,I,IHMSF(4),IDMSF(4) + DOUBLE PRECISION SLONGW,SLAT,H,DJUTC,FDUTC,DJUT1,DJTT,STL, + : RMATN(3,3),PMM(6),PMT(6),RM,DM,PVO(6),TL + DOUBLE PRECISION sla_DTT,sla_GMST,sla_EQEQX,sla_DRANRM + + * Get AAT longitude and latitude in radians and height in metres + CALL sla_OBS(0,'AAT',NAME,SLONGW,SLAT,H) + + * UTC (1992 January 13, 11 13 59) to MJD + CALL sla_CLDJ(1992,1,13,DJUTC,J) + CALL sla_DTF2D(11,13,59.0D0,FDUTC,J) + DJUTC=DJUTC+FDUTC + + * UT1 (UT1-UTC value of -0.152 sec is from IERS Bulletin B) + DJUT1=DJUTC+(-0.152D0)/86400D0 + + * TT + DJTT=DJUTC+sla_DTT(DJUTC)/86400D0 + + * Local apparent sidereal time + STL=sla_GMST(DJUT1)-SLONGW+sla_EQEQX(DJTT) + + * Geocentric position/velocity of Moon (mean of date) + CALL sla_DMOON(DJTT,PMM) + + * Nutation to true equinox of date + CALL sla_NUT(DJTT,RMATN) + CALL sla_DMXV(RMATN,PMM,PMT) + CALL sla_DMXV(RMATN,PMM(4),PMT(4)) + + * Report geocentric HA,Dec + CALL sla_DCC2S(PMT,RM,DM) + CALL sla_DR2TF(2,sla_DRANRM(STL-RM),SH,IHMSF) + CALL sla_DR2AF(1,DM,SD,IDMSF) + WRITE (*,'(1X,'' geocentric:'',2X,A,I2.2,2I3.2,''.'',I2.2,'// + : '1X,A,I2.2,2I3.2,''.'',I1)') + : SH,IHMSF,SD,IDMSF + + * Geocentric position of observer (true equator and equinox of date) + CALL sla_PVOBS(SLAT,H,STL,PVO) + + * Place origin at observer + DO I=1,6 + PMT(I)=PMT(I)-PVO(I) + END DO + + * Allow for planetary aberration + TL=499.004782D0*SQRT(PMT(1)**2+PMT(2)**2+PMT(3)**2) + DO I=1,3 + PMT(I)=PMT(I)-TL*PMT(I+3) + END DO + + * Report topocentric HA,Dec + CALL sla_DCC2S(PMT,RM,DM) + CALL sla_DR2TF(2,sla_DRANRM(STL-RM),SH,IHMSF) + CALL sla_DR2AF(1,DM,SD,IDMSF) + WRITE (*,'(1X,''topocentric:'',2X,A,I2.2,2I3.2,''.'',I2.2,'// + : '1X,A,I2.2,2I3.2,''.'',I1)') + : SH,IHMSF,SD,IDMSF + END +\end{verbatim} +\goodbreak +The output produced is as follows: +\goodbreak +\begin{verbatim} + geocentric: +03 06 55.59 +15 03 39.0 + topocentric: +03 09 23.79 +15 40 51.5 +\end{verbatim} +\goodbreak +(An easier but +less instructive method of estimating the topocentric apparent place of the +Moon is to call the routine +sla\_RDPLAN.) + +As an example of using +sla\_PLANET, +the following program estimates the geocentric separation +between Venus and Jupiter during a close conjunction +in 2\,BC, which is a star-of-Bethlehem candidate: +\goodbreak +\begin{verbatim} + * Compute time and minimum geocentric apparent separation + * between Venus and Jupiter during the close conjunction of 2 BC. + + IMPLICIT NONE + + DOUBLE PRECISION SEPMIN,DJD0,FD,DJD,DJDM,DF,PV(6),RMATP(3,3), + : PVM(6),PVE(6),TL,RV,DV,RJ,DJ,SEP + INTEGER IHOUR,IMIN,J,I,IHMIN,IMMIN + DOUBLE PRECISION sla_EPJ,sla_DSEP + + + * Search for closest approach on the given day + DJD0=1720859.5D0 + SEPMIN=1D10 + DO IHOUR=20,22 + DO IMIN=0,59 + CALL sla_DTF2D(IHOUR,IMIN,0D0,FD,J) + + * Julian date and MJD + DJD=DJD0+FD + DJDM=DJD-2400000.5D0 + + * Earth to Moon (mean of date) + CALL sla_DMOON(DJDM,PV) + + * Precess Moon position to J2000 + CALL sla_PRECL(sla_EPJ(DJDM),2000D0,RMATP) + CALL sla_DMXV(RMATP,PV,PVM) + + * Sun to Earth-Moon Barycentre (mean J2000) + CALL sla_PLANET(DJDM,3,PVE,J) + + * Correct from EMB to Earth + DO I=1,3 + PV(I)=PVE(I)-0.012150581D0*PVM(I) + END DO + + * Sun to Venus + CALL sla_PLANET(DJDM,2,PV,J) + + * Earth to Venus + DO I=1,6 + PV(I)=PV(I)-PVE(I) + END DO + + * Light time to Venus (sec) + TL=499.004782D0*SQRT((PV(1)-PVE(1))**2+ + : (PV(2)-PVE(2))**2+ + : (PV(3)-PVE(3))**2) + + * Extrapolate backwards in time by that much + DO I=1,3 + PV(I)=PV(I)-TL*PV(I+3) + END DO + + * To RA,Dec + CALL sla_DCC2S(PV,RV,DV) + + * Same for Jupiter + CALL sla_PLANET(DJDM,5,PV,J) + DO I=1,6 + PV(I)=PV(I)-PVE(I) + END DO + TL=499.004782D0*SQRT((PV(1)-PVE(1))**2+ + : (PV(2)-PVE(2))**2+ + : (PV(3)-PVE(3))**2) + DO I=1,3 + PV(I)=PV(I)-TL*PV(I+3) + END DO + CALL sla_DCC2S(PV,RJ,DJ) + + * Separation (arcsec) + SEP=sla_DSEP(RV,DV,RJ,DJ) + + * Keep if smallest so far + IF (SEP.LT.SEPMIN) THEN + IHMIN=IHOUR + IMMIN=IMIN + SEPMIN=SEP + END IF + END DO + END DO + + * Report + WRITE (*,'(1X,I2.2,'':'',I2.2,F6.1)') IHMIN,IMMIN, + : 206264.8062D0*SEPMIN + + END +\end{verbatim} +\goodbreak +The output produced (the Ephemeris Time on the day in question, and +the closest approach in arcseconds) is as follows: +\goodbreak +\begin{verbatim} + 21:19 33.7 +\end{verbatim} +\goodbreak +For comparison, accurate predictions based on the JPL DE\,102 ephemeris +give a separation about \arcseci{8} less than +the above estimate, occurring about half an hour earlier +(see {\it Sky and Telescope,}\/ April~1987, p\,357). + +The following program demonstrates +sla\_RDPLAN. +\begin{verbatim} + * For a given date, time and geographical location, output + * a table of planetary positions and diameters. + + IMPLICIT NONE + CHARACTER PNAMES(0:9)*7,B*80,S + INTEGER I,NP,IY,J,IM,ID,IHMSF(4),IDMSF(4) + DOUBLE PRECISION R2AS,FD,DJM,ELONG,PHI,RA,DEC,DIAM + PARAMETER (R2AS=206264.80625D0) + DATA PNAMES / 'Sun','Mercury','Venus','Moon','Mars','Jupiter', + : 'Saturn','Uranus','Neptune', 'Pluto' / + + + * Loop until 'end' typed + B=' ' + DO WHILE (B.NE.'END'.AND.B.NE.'end') + + * Get date, time and observer's location + PRINT *,'Date? (Y,M,D, Gregorian)' + READ (*,'(A)') B + IF (B.NE.'END'.AND.B.NE.'end') THEN + I=1 + CALL sla_INTIN(B,I,IY,J) + CALL sla_INTIN(B,I,IM,J) + CALL sla_INTIN(B,I,ID,J) + PRINT *,'Time? (H,M,S, dynamical)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,FD,J) + FD=FD*2.3873241463784300365D0 + CALL sla_CLDJ(IY,IM,ID,DJM,J) + DJM=DJM+FD + PRINT *,'Longitude? (D,M,S, east +ve)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,ELONG,J) + PRINT *,'Latitude? (D,M,S, (geodetic)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,PHI,J) + + * Loop planet by planet + DO NP=0,8 + + * Get RA,Dec and diameter + CALL sla_RDPLAN(DJM,NP,ELONG,PHI,RA,DEC,DIAM) + + * One line of report + CALL sla_DR2TF(2,RA,S,IHMSF) + CALL sla_DR2AF(1,DEC,S,IDMSF) + WRITE (*, + : '(1X,A,2X,3I3.2,''.'',I2.2,2X,A,I2.2,2I3.2,''.'',I1,F8.1)') + : PNAMES(NP),IHMSF,S,IDMSF,R2AS*DIAM + + * Next planet + END DO + PRINT *,' ' + END IF + + * Next case + END DO + + END +\end{verbatim} +Entering the following data (for 1927~June~29 at $5^{\rm h}\,25^{\rm m}$~ET +and the position of Preston, UK.): +\begin{verbatim} + 1927 6 29 + 5 25 + -2 42 + 53 46 +\end{verbatim} +produces the following report: +\begin{verbatim} + Sun 06 28 14.03 +23 17 17.5 1887.8 + Mercury 08 08 58.62 +19 20 57.3 9.3 + Venus 09 38 53.64 +15 35 32.9 22.8 + Moon 06 28 18.30 +23 18 37.3 1903.9 + Mars 09 06 49.34 +17 52 26.7 4.0 + Jupiter 00 11 12.06 -00 10 57.5 41.1 + Saturn 16 01 43.34 -18 36 55.9 18.2 + Uranus 00 13 33.53 +00 39 36.0 3.5 + Neptune 09 49 35.75 +13 38 40.8 2.2 + Pluto 07 05 29.50 +21 25 04.2 .1 +\end{verbatim} +Inspection of the Sun and Moon data reveals that +a total solar eclipse is in progress. + +SLALIB also provides for the case where orbital elements (with respect +to the J2000 equinox and ecliptic) +are available. This allows predictions to be made for minor-planets and +(if you ignore non-gravitational effects) +comets. Furthermore, if major-planet elements for an epoch close to the date +in question are available, more accurate predictions can be made than +are offered by +sla\_RDPLAN and +sla\_PLANET. + +The SLALIB planetary-prediction +routines that work with orbital elements are +sla\_PLANTE (the orbital-elements equivalent of +sla\_RDPLAN), which predicts the topocentric \radec, and +sla\_PLANEL (the orbital-elements equivalent of +sla\_PLANET), which predicts the heliocentric \xyzxyzd\ with respect to the +J2000 equinox and equator. In addition, the routine +sla\_PV2EL does the inverse of +sla\_PLANEL, transforming \xyzxyzd\ into {\it osculating elements.} + +Osculating elements describe the unperturbed 2-body orbit. This is +a good approximation to the actual orbit for a few weeks either +side of the specified epoch, outside which perturbations due to +the other bodies of the Solar System lead to +increasing errors. Given a minor planet's osculating elements for +a particular date, predictions for a date even just +100 days earlier or later +are likely to be in error by several arcseconds. +These errors can +be reduced if new elements are generated which take account of +the perturbations of the major planets, and this is what the routine +sla\_PERTEL does. Once +sla\_PERTEL has been called, to provide osculating elements +close to the required date, the elements can be passed to +sla\_PLANEL or +sla\_PLANTE in the normal way. Predictions of arcsecond accuracy +over a span of a decade or more are available using this +technique. + +Three different combinations of orbital elements are +provided for, matching the usual conventions +for major planets, minor planets and +comets respectively. The choice is made through the +argument {\tt JFORM}:\\ + +\hspace{4em} +\begin{tabular}{|c|c|c|} \hline +{\tt JFORM=1} & {\tt JFORM=2} & {\tt JFORM=3} \\ +\hline \hline +$t_0$ & $t_0$ & $T$ \\ +\hline +$i$ & $i$ & $i$ \\ +\hline +$\Omega$ & $\Omega$ & $\Omega$ \\ +\hline +$\varpi$ & $\omega$ & $\omega$ \\ +\hline +$a$ & $a$ & $q$ \\ +\hline +$e$ & $e$ & $e$ \\ +\hline +$L$ & $M$ & \\ +\hline +$n$ & & \\ +\hline +\end{tabular}\\[5ex] +The symbols have the following meanings: +\begin{tabbing} +xxxxxxx \= xxxx \= \kill +\> $t_0$ \> epoch at which the elements were correct \\ +\> $T$ \> epoch of perihelion passage \\ +\> $i$ \> inclination of the orbit \\ +\> $\Omega$ \> longitude of the ascending node \\ +\> $\varpi$ \> longitude of perihelion ($\varpi = \Omega + \omega$) \\ +\> $\omega$ \> argument of perihelion \\ +\> $a$ \> semi-major axis of the orbital ellipse \\ +\> $q$ \> perihelion distance \\ +\> $e$ \> orbital eccentricity \\ +\> $L$ \> mean longitude ($L = \varpi + M$) \\ +\> $M$ \> mean anomaly \\ +\> $n$ \> mean motion \\ +\end{tabbing} + +The mean motion, $n$, tells sla\_PLANEL the mass of the planet. +If it is not available, it should be claculated +from $n^2 a^3 = k^2 (1+m)$, where $k = 0.01720209895$ and +m is the mass of the planet ($M_\odot = 1$); $a$ is in AU. + +Conventional elements are not the only way of specifying an orbit. +The \xyzxyzd\ state vector is an equally valid specification, +and the so-called {\it method of universal variables}\/ allows +orbital calculations to be made directly, bypassing angular +quantities and avoiding Kepler's Equation. The universal-variables +approach has various advantages, including better handling of +near-parabolic cases and greater efficiency. +SLALIB uses universal variables for its internal +calculations and also offers a number of routines which +applications can call. + +The universal elements are the \xyzxyzd\ and its epoch, plus the mass +of the body. The SLALIB routines supplement these elements with +certain redundant values in order to +avoid unnecessary recomputation when the elements are next used. + +The routines +sla\_EL2UE and +sla\_UE2EL transform conventional elements into the +universal form and {\it vice versa.} +The routine +sla\_PV2UE takes an \xyzxyzd\ and forms the set of universal +elements; +sla\_UE2PV takes a set of universal elements and predicts the \xyzxyzd\ +for a specified epoch. +The routine +sla\_PERTUE provides updated universal elements, +taking into account perturbations from the major planets. + +\subsection{Radial Velocity and Light-Time Corrections} +When publishing high-resolution spectral observations +it is necessary to refer them to a specified standard of rest. +This involves knowing the component in the direction of the +source of the velocity of the observer. SLALIB provides a number +of routines for this purpose, allowing observations to be +referred to the Earth's centre, the Sun, a Local Standard of Rest +(either dynamical or kinematical), the centre of the Galaxy, and +the mean motion of the Local Group. + +The routine +sla\_RVEROT +corrects for the diurnal rotation of +the observer around the Earth's axis. This is always less than 0.5~km/s. + +No specific routine is provided to correct a radial velocity +from geocentric to heliocentric, but this can easily be done by calling +sla\_EVP +as follows (array declarations {\it etc}.\ omitted): +\goodbreak +\begin{verbatim} + : + * Star vector, J2000 + CALL sla_DCS2C(RM,DM,V) + + * Earth/Sun velocity and position, J2000 + CALL sla_EVP(TDB,2000D0,DVB,DPB,DVH,DPH) + + * Radial velocity correction due to Earth orbit (km/s) + VCORB = -sla_DVDV(V,DVH)*149.597870D6 + : +\end{verbatim} +\goodbreak +The maximum value of this correction is the Earth's orbital speed +of about 30~km/s. A related routine, +sla\_ECOR, +computes the light-time correction with respect to the Sun. It +would be used when reducing observations of a rapid variable-star +for instance. +Note, however, that the accuracy objectives for pulsar work are +beyond the scope of these SLALIB routines, and even the superior +sla\_EVP +routine is unsuitable for arrival-time calculations of better +than 25~millisecond accuracy. + +To remove the intrinsic $\sim20$~km/s motion of the Sun relative +to other stars in the solar neighbourhood, +a velocity correction to a +{\it local standard of rest}\/ (LSR) is required. There are +opportunities for mistakes here. There are two sorts of LSR, +{\it dynamical}\/ and {\it kinematical}, and +multiple definitions exist for the latter. The +dynamical LSR is a point near the Sun which is in a circular +orbit around the Galactic centre; the Sun has a ``peculiar'' +motion relative to the dynamical LSR. A kinematical LSR is +the mean standard of rest of specified star catalogues or stellar +populations, and its precise definition depends on which +catalogues or populations were used and how the analysis was +carried out. The Sun's motion with respect to a kinematical +LSR is called the ``standard'' solar motion. Radial +velocity corrections to the dynamical LSR are produced by the routine +sla\_RVLSRD +and to the adopted kinematical LSR by +sla\_RVLSRK. +See the individual specifications for these routines for the +precise definition of the LSR in each case. + +For extragalactic sources, the centre of the Galaxy can be used as +a standard of rest. The radial velocity correction from the +dynamical LSR to the Galactic centre can be obtained by calling +sla\_RVGALC. +Its maximum value is 220~km/s. + +For very distant sources it is appropriate to work relative +to the mean motion of the Local Group. The routine for +computing the radial velocity correction in this case is +sla\_RVLG. +Note that in this case the correction is with respect to the +dynamical LSR, not the Galactic centre as might be expected. +This conforms to the IAU definition, and confers immunity from +revisions of the Galactic rotation speed. + +\subsection{Focal-Plane Astrometry} +The relationship between the position of a star image in +the focal plane of a telescope and the star's celestial +coordinates is usually described in terms of the {\it tangent plane}\/ +or {\it gnomonic}\/ projection. This is the projection produced +by a pin-hole camera and is a good approximation to the projection +geometry of a traditional large {\it f}\/-ratio astrographic refractor. +SLALIB includes a group of routines which transform +star positions between their observed places on the celestial +sphere and their \xy\ coordinates in the tangent plane. The +spherical coordinate system does not have to be \radec\ but +usually is. The so-called {\it standard coordinates}\/ of a star +are the tangent plane \xy, in radians, with respect to an origin +at the tangent point, with the $y$-axis pointing north and +the $x$-axis pointing east (in the direction of increasing $\alpha$). +The factor relating the standard coordinates to +the actual \xy\ coordinates in, say, millimetres is simply +the focal length of the telescope. + +Given the \radec\ of the {\it plate centre}\/ (the tangent point) +and the \radec\ of a star within the field, the standard +coordinates can be determined by calling +sla\_S2TP +(single precision) or +sla\_DS2TP +(double precision). The reverse transformation, where the +\xy\ is known and we wish to find the \radec, is carried out by calling +sla\_TP2S +or +sla\_DTP2S. +Occasionally we know the both the \xy\ and the \radec\ of a +star and need to deduce the \radec\ of the tangent point; +this can be done by calling +sla\_TPS2C +or +sla\_DTPS2C. +(All of these transformations apply not just to \radec\ but to +other spherical coordinate systems, of course.) +Equivalent (and faster) +routines are provided which work directly in \xyz\ instead of +spherical coordinates: +sla\_V2TP and +sla\_DV2TP, +sla\_TP2V and +sla\_DTP2V, +sla\_TPV2C and +sla\_DTPV2C. + +Even at the best of times, the tangent plane projection is merely an +approximation. Some telescopes and cameras exhibit considerable pincushion +or barrel distortion and some have a curved focal surface. +For example, neither Schmidt cameras nor (especially) +large reflecting telescopes with wide-field corrector lenses +are adequately modelled by tangent-plane geometry. In such +cases, however, it is still possible to do most of the work +using the (mathematically convenient) tangent-plane +projection by inserting an extra step which applies or +removes the distortion peculiar to the system concerned. +A simple $r_1=r_0(1+Kr_0^2)$ law works well in the +majority of cases; $r_0$ is the radial distance in the +tangent plane, $r_1$ is the radial distance after adding +the distortion, and $K$ is a constant which depends on the +telescope ($\theta$ is unaffected). The routine +sla\_PCD +applies the distortion to an \xy\ and +sla\_UNPCD +removes it. For \xy\ in radians, $K$ values range from $-1/3$ for the +tiny amount of barrel distortion in Schmidt geometry to several +hundred for the serious pincushion distortion +produced by wide-field correctors in big reflecting telescopes +(the AAT prime focus triplet corrector is about $K=+178.6$). + +SLALIB includes a group of routines which can be put together +to build a simple plate-reduction program. The heart of the group is +sla\_FITXY, +which fits a linear model to relate two sets of \xy\ coordinates, +in the case of a plate reduction the measured positions of the +images of a set of +reference stars and the standard +coordinates derived from their catalogue positions. The +model is of the form: +\[x_{p} = a + bx_{m} + cy_{m}\] +\[y_{p} = d + ex_{m} + fy_{m}\] + +where the {\it p}\/ subscript indicates ``predicted'' coordinates +(the model's approximation to the ideal ``expected'' coordinates) and the +{\it m}\/ subscript indicates ``measured coordinates''. The +six coefficients {\it a--f}\/ can optionally be +constrained to represent a ``solid body rotation'' free of +any squash or shear distortions. Without this constraint +the model can, to some extent, accommodate effects like refraction, +allowing mean places to be used directly and +avoiding the extra complications of a +full mean-apparent-observed transformation for each star. +Having obtained the linear model, +sla\_PXY +can be used to process the set of measured and expected +coordinates, giving the predicted coordinates and determining +the RMS residuals in {\it x}\/ and {\it y}. +The routine +sla\_XY2XY +transforms one \xy\ into another using the linear model. A model +can be inverted by calling +sla\_INVF, +and decomposed into zero points, scales, $x/y$ nonperpendicularity +and orientation by calling +sla\_DCMPF. + +\subsection{Numerical Methods} +SLALIB contains a small number of simple, general-purpose +numerical-methods routines. They have no specific +connection with positional astronomy but have proved useful in +applications to do with simulation and fitting. + +At the heart of many simulation programs is the generation of +pseudo-random numbers, evenly distributed in a given range: +sla\_RANDOM +does this. Pseudo-random normal deviates, or ``Gaussian +residuals'', are often required to simulate noise and +can be generated by means of the function +sla\_GRESID. +Neither routine will pass super-sophisticated +statistical tests, but they work adequately for most +practical purposes and avoid the need to call non-standard +library routines peculiar to one sort of computer. + +Applications which perform a least-squares fit using a traditional +normal-equations methods can accomplish the required matrix-inversion +by calling either +sla\_SMAT +(single precision) or +sla\_DMAT +(double). A generally better way to perform such fits is +to use singular value decomposition. SLALIB provides a routine +to do the decomposition itself, +sla\_SVD, +and two routines to use the results: +sla\_SVDSOL +generates the solution, and +sla\_SVDCOV +produces the covariance matrix. +A simple demonstration of the use of the SLALIB SVD +routines is given below. It generates 500 simulated data +points and fits them to a model which has 4 unknown coefficients. +(The arrays in the example are sized to accept up to 1000 +points and 20 unknowns.) The model is: +\[ y = C_{1} +C_{2}x +C_{3}sin{x} +C_{4}cos{x} \] +The test values for the four coefficients are +$C_1\!=\!+50.0$, +$C_2\!=\!-2.0$, +$C_3\!=\!-10.0$ and +$C_4\!=\!+25.0$. +Gaussian noise, $\sigma=5.0$, is added to each ``observation''. +\goodbreak +\begin{verbatim} + IMPLICIT NONE + + * Sizes of arrays, physical and logical + INTEGER MP,NP,NC,M,N + PARAMETER (MP=1000,NP=10,NC=20,M=500,N=4) + + * The unknowns we are going to solve for + DOUBLE PRECISION C1,C2,C3,C4 + PARAMETER (C1=50D0,C2=-2D0,C3=-10D0,C4=25D0) + + * Arrays + DOUBLE PRECISION A(MP,NP),W(NP),V(NP,NP), + : WORK(NP),B(MP),X(NP),CVM(NC,NC) + + DOUBLE PRECISION VAL,BF1,BF2,BF3,BF4,SD2,D,VAR + REAL sla_GRESID + INTEGER I,J + + * Fill the design matrix + DO I=1,M + + * Dummy independent variable + VAL=DBLE(I)/10D0 + + * The basis functions + BF1=1D0 + BF2=VAL + BF3=SIN(VAL) + BF4=COS(VAL) + + * The observed value, including deliberate Gaussian noise + B(I)=C1*BF1+C2*BF2+C3*BF3+C4*BF4+DBLE(sla_GRESID(5.0)) + + * Fill one row of the design matrix + A(I,1)=BF1 + A(I,2)=BF2 + A(I,3)=BF3 + A(I,4)=BF4 + END DO + + * Factorize the design matrix, solve and generate covariance matrix + CALL sla_SVD(M,N,MP,NP,A,W,V,WORK,J) + CALL sla_SVDSOL(M,N,MP,NP,B,A,W,V,WORK,X) + CALL sla_SVDCOV(N,NP,NC,W,V,WORK,CVM) + + * Compute the variance + SD2=0D0 + DO I=1,M + VAL=DBLE(I)/10D0 + BF1=1D0 + BF2=VAL + BF3=SIN(VAL) + BF4=COS(VAL) + D=B(I)-(X(1)*BF1+X(2)*BF2+X(3)*BF3+X(4)*BF4) + SD2=SD2+D*D + END DO + VAR=SD2/DBLE(M) + + * Report the RMS and the solution + WRITE (*,'(1X,''RMS ='',F5.2/)') SQRT(VAR) + DO I=1,N + WRITE (*,'(1X,''C'',I1,'' ='',F7.3,'' +/-'',F6.3)') + : I,X(I),SQRT(VAR*CVM(I,I)) + END DO + END +\end{verbatim} +\goodbreak +The program produces the following output: +\goodbreak +\begin{verbatim} + RMS = 4.88 + + C1 = 50.192 +/- 0.439 + C2 = -2.002 +/- 0.015 + C3 = -9.771 +/- 0.310 + C4 = 25.275 +/- 0.310 +\end{verbatim} +\goodbreak +In this above example, essentially +identical results would be obtained if the more +commonplace normal-equations method had been used, and the large +$1000\times20$ array would have been avoided. However, the SVD method +comes into its own when the opportunity is taken to edit the W-matrix +(the so-called ``singular values'') in order to control +possible ill-conditioning. The procedure involves replacing with +zeroes any W-elements smaller than a nominated value, for example +0.001 times the largest W-element. Small W-elements indicate +ill-conditioning, which in the case of the normal-equations +method would produce spurious large coefficient values and +possible arithmetic overflows. Using SVD, the effect on the solution +of setting suspiciously small W-elements to zero is to restrain +the offending coefficients from moving very far. The +fact that action was taken can be reported to show the program user that +something is amiss. Furthermore, if element W(J) was set to zero, +the row numbers of the two biggest elements in the Jth column of the +V-matrix identify the pair of solution coefficients that are +dependent. + +A more detailed description of SVD and its use in least-squares +problems would be out of place here, and the reader is urged +to refer to the relevant sections of the book {\it Numerical Recipes} +(Press {\it et al.}, Cambridge University Press, 1987). + +\pagebreak + +\section{SUMMARY OF CALLS} +The basic trigonometrical and numerical facilities are supplied in both single +and double precision versions. +Most of the more esoteric position and time routines use double precision +arguments only, even in cases where single precision would normally be adequate +in practice. +Certain routines with modest accuracy objectives are supplied in +single precision versions only. +In the calling sequences which follow, no attempt has been made +to distinguish between single and double precision argument names, +and frequently the same name is used on different occasions to +mean different things. +However, none of the routines uses a mixture of single and +double precision arguments; each routine is either wholly +single precision or wholly double precision. + +In the classified list, below, +{\it subroutine}\/ subprograms are those whose names and argument lists +are preceded by `CALL', whereas {\it function}\/ subprograms are +those beginning `R=' (when the result is REAL) or `D=' (when +the result is DOUBLE~PRECISION). + +The list is, of course, merely for quick reference; inexperienced +users {\bf must} refer to the detailed specifications given later. +In particular, {\bf don't guess} whether arguments are single or +double precision; the result could be a program that happens to +works on one sort of machine but not on another. + +\callhead{String Decoding} +\begin{callset} +\subp{CALL sla\_INTIN (STRING, NSTRT, IRESLT, JFLAG)} + Convert free-format string into integer +\subq{CALL sla\_FLOTIN (STRING, NSTRT, RESLT, JFLAG)} + {CALL sla\_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)} + Convert free-format string into floating-point number +\subq{CALL sla\_AFIN (STRING, NSTRT, RESLT, JFLAG)} + {CALL sla\_DAFIN (STRING, NSTRT, DRESLT, JFLAG)} + Convert free-format string from deg,arcmin,arcsec to radians +\end{callset} + +\callhead{Sexagesimal Conversions} +\begin{callset} +\subq{CALL sla\_CTF2D (IHOUR, IMIN, SEC, DAYS, J)} + {CALL sla\_DTF2D (IHOUR, IMIN, SEC, DAYS, J)} + Hours, minutes, seconds to days +\subq{CALL sla\_CD2TF (NDP, DAYS, SIGN, IHMSF)} + {CALL sla\_DD2TF (NDP, DAYS, SIGN, IHMSF)} + Days to hours, minutes, seconds +\subq{CALL sla\_CTF2R (IHOUR, IMIN, SEC, RAD, J)} + {CALL sla\_DTF2R (IHOUR, IMIN, SEC, RAD, J)} + Hours, minutes, seconds to radians +\subq{CALL sla\_CR2TF (NDP, ANGLE, SIGN, IHMSF)} + {CALL sla\_DR2TF (NDP, ANGLE, SIGN, IHMSF)} + Radians to hours, minutes, seconds +\subq{CALL sla\_CAF2R (IDEG, IAMIN, ASEC, RAD, J)} + {CALL sla\_DAF2R (IDEG, IAMIN, ASEC, RAD, J)} + Degrees, arcminutes, arcseconds to radians +\subq{CALL sla\_CR2AF (NDP, ANGLE, SIGN, IDMSF)} + {CALL sla\_DR2AF (NDP, ANGLE, SIGN, IDMSF)} + Radians to degrees, arcminutes, arcseconds +\end{callset} + +\callhead{Angles, Vectors and Rotation Matrices} +\begin{callset} +\subq{R~=~sla\_RANGE (ANGLE)} + {D~=~sla\_DRANGE (ANGLE)} + Normalize angle into range $\pm\pi$ +\subq{R~=~sla\_RANORM (ANGLE)} + {D~=~sla\_DRANRM (ANGLE)} + Normalize angle into range $0\!-\!2\pi$ +\subq{CALL sla\_CS2C (A, B, V)} + {CALL sla\_DCS2C (A, B, V)} + Spherical coordinates to \xyz +\subq{CALL sla\_CC2S (V, A, B)} + {CALL sla\_DCC2S (V, A, B)} + \xyz\ to spherical coordinates +\subq{R~=~sla\_VDV (VA, VB)} + {D~=~sla\_DVDV (VA, VB)} + Scalar product of two 3-vectors +\subq{CALL sla\_VXV (VA, VB, VC)} + {CALL sla\_DVXV (VA, VB, VC)} + Vector product of two 3-vectors +\subq{CALL sla\_VN (V, UV, VM)} + {CALL sla\_DVN (V, UV, VM)} + Normalize a 3-vector also giving the modulus +\subq{R~=~sla\_SEP (A1, B1, A2, B2)} + {D~=~sla\_DSEP (A1, B1, A2, B2)} + Angle between two points on a sphere +\subq{R~=~sla\_BEAR (A1, B1, A2, B2)} + {D~=~sla\_DBEAR (A1, B1, A2, B2)} + Direction of one point on a sphere seen from another +\subq{R~=~sla\_PAV (V1, V2)} + {D~=~sla\_DPAV (V1, V2)} + Position-angle of one \xyz\ with respect to another +\subq{CALL sla\_EULER (ORDER, PHI, THETA, PSI, RMAT)} + {CALL sla\_DEULER (ORDER, PHI, THETA, PSI, RMAT)} + Form rotation matrix from three Euler angles +\subq{CALL sla\_AV2M (AXVEC, RMAT)} + {CALL sla\_DAV2M (AXVEC, RMAT)} + Form rotation matrix from axial vector +\subq{CALL sla\_M2AV (RMAT, AXVEC)} + {CALL sla\_DM2AV (RMAT, AXVEC)} + Determine axial vector from rotation matrix +\subq{CALL sla\_MXV (RM, VA, VB)} + {CALL sla\_DMXV (DM, VA, VB)} + Rotate vector forwards +\subq{CALL sla\_IMXV (RM, VA, VB)} + {CALL sla\_DIMXV (DM, VA, VB)} + Rotate vector backwards +\subq{CALL sla\_MXM (A, B, C)} + {CALL sla\_DMXM (A, B, C)} + Product of two 3x3 matrices +\subq{CALL sla\_CS2C6 (A, B, R, AD, BD, RD, V)} + {CALL sla\_DS2C6 (A, B, R, AD, BD, RD, V)} + Conversion of position and velocity in spherical + coordinates to Cartesian coordinates +\subq{CALL sla\_CC62S (V, A, B, R, AD, BD, RD)} + {CALL sla\_DC62S (V, A, B, R, AD, BD, RD)} + Conversion of position and velocity in Cartesian + coordinates to spherical coordinates +\end{callset} + +\callhead{Calendars} +\begin{callset} +\subp{CALL sla\_CLDJ (IY, IM, ID, DJM, J)} + Gregorian Calendar to Modified Julian Date +\subp{CALL sla\_CALDJ (IY, IM, ID, DJM, J)} + Gregorian Calendar to Modified Julian Date, + permitting century default +\subp{CALL sla\_DJCAL (NDP, DJM, IYMDF, J)} + Modified Julian Date to Gregorian Calendar, + in a form convenient for formatted output +\subp{CALL sla\_DJCL (DJM, IY, IM, ID, FD, J)} + Modified Julian Date to Gregorian Year, Month, Day, Fraction +\subp{CALL sla\_CALYD (IY, IM, ID, NY, ND, J)} + Calendar to year and day in year, permitting century default +\subp{CALL sla\_CLYD (IY, IM, ID, NY, ND, J)} + Calendar to year and day in year +\subp{D~=~sla\_EPB (DATE)} + Modified Julian Date to Besselian Epoch +\subp{D~=~sla\_EPB2D (EPB)} + Besselian Epoch to Modified Julian Date +\subp{D~=~sla\_EPJ (DATE)} + Modified Julian Date to Julian Epoch +\subp{D~=~sla\_EPJ2D (EPJ)} + Julian Epoch to Modified Julian Date +\end{callset} + +\callhead{Timescales} +\begin{callset} +\subp{D~=~sla\_GMST (UT1)} + Conversion from Universal Time to sidereal time +\subp{D~=~sla\_GMSTA (DATE, UT1)} + Conversion from Universal Time to sidereal time, rounding errors minimized +\subp{D~=~sla\_EQEQX (DATE)} + Equation of the equinoxes +\subp{D~=~sla\_DAT (DJU)} + Offset of Atomic Time from Coordinated Universal Time: TAI$-$UTC +\subp{D~=~sla\_DT (EPOCH)} + Approximate offset between dynamical time and universal time +\subp{D~=~sla\_DTT (DJU)} + Offset of Terrestrial Time from Coordinated Universal Time: TT$-$UTC +\subp{D~=~sla\_RCC (TDB, UT1, WL, U, V)} + Relativistic clock correction: TDB$-$TT +\end{callset} + +\callhead{Precession and Nutation} +\begin{callset} +\subp{CALL sla\_NUT (DATE, RMATN)} + Nutation matrix +\subp{CALL sla\_NUTC (DATE, DPSI, DEPS, EPS0)} + Longitude and obliquity components of nutation, and + mean obliquity +\subp{CALL sla\_PREC (EP0, EP1, RMATP)} + Precession matrix (IAU) +\subp{CALL sla\_PRECL (EP0, EP1, RMATP)} + Precession matrix (suitable for long periods) +\subp{CALL sla\_PRENUT (EPOCH, DATE, RMATPN)} + Combined precession/nutation matrix +\subp{CALL sla\_PREBN (BEP0, BEP1, RMATP)} + Precession matrix, old system +\subp{CALL sla\_PRECES (SYSTEM, EP0, EP1, RA, DC)} + Precession, in either the old or the new system +\end{callset} + +\callhead{Proper Motion} +\begin{callset} +\subp{CALL sla\_PM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1)} + Adjust for proper motion +\end{callset} + +\callhead{FK4/FK5/Hipparcos Conversions} +\begin{callset} +\subp{CALL sla\_FK425 (\vtop + {\hbox{R1950, D1950, DR1950, DD1950, P1950, V1950,} + \hbox{R2000, D2000, DR2000, DD2000, P2000, V2000)}}} + Convert B1950.0 FK4 star data to J2000.0 FK5 +\subp{CALL sla\_FK45Z (R1950, D1950, EPOCH, R2000, D2000)} + Convert B1950.0 FK4 position to J2000.0 FK5 assuming zero + FK5 proper motion and no parallax +\subp{CALL sla\_FK524 (\vtop + {\hbox{R2000, D2000, DR2000, DD2000, P2000, V2000,} + \hbox{R1950, D1950, DR1950, DD1950, P1950, V1950)}}} + Convert J2000.0 FK5 star data to B1950.0 FK4 +\subp{CALL sla\_FK54Z (R2000, D2000, BEPOCH, + R1950, D1950, DR1950, DD1950)} + Convert J2000.0 FK5 position to B1950.0 FK4 assuming zero + FK5 proper motion and no parallax +\subp{CALL sla\_FK52H (R5, D5, DR5, DD5, RH, DH, DRH, DDH)} + Convert J2000.0 FK5 star data to Hipparcos +\subp{CALL sla\_FK5HZ (R5, D5, EPOCH, RH, DH )} + Convert J2000.0 FK5 position to Hipparcos assuming zero Hipparcos + proper motion +\subp{CALL sla\_H2FK5 (RH, DH, DRH, DDH, R5, D5, DR5, DD5)} + Convert Hipparcos star data to J2000.0 FK5 +\subp{CALL sla\_HFK5Z (RH, DH, EPOCH, R5, D5, DR5, DD5)} + Convert Hipparcos position to J2000.0 FK5 assuming zero Hipparcos + proper motion +\subp{CALL sla\_DBJIN (STRING, NSTRT, DRESLT, J1, J2)} + Like sla\_DFLTIN but with extensions to accept leading `B' and `J' +\subp{CALL sla\_KBJ (JB, E, K, J)} + Select epoch prefix `B' or `J' +\subp{D~=~sla\_EPCO (K0, K, E)} + Convert an epoch into the appropriate form -- `B' or `J' +\end{callset} + +\callhead{Elliptic Aberration} +\begin{callset} +\subp{CALL sla\_ETRMS (EP, EV)} + E-terms +\subp{CALL sla\_SUBET (RC, DC, EQ, RM, DM)} + Remove the E-terms +\subp{CALL sla\_ADDET (RM, DM, EQ, RC, DC)} + Add the E-terms +\end{callset} + +\callhead{Geographical and Geocentric Coordinates} +\begin{callset} +\subp{CALL sla\_OBS (NUMBER, ID, NAME, WLONG, PHI, HEIGHT)} + Interrogate list of observatory parameters +\subp{CALL sla\_GEOC (P, H, R, Z)} + Convert geodetic position to geocentric +\subp{CALL sla\_POLMO (ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ)} + Polar motion +\subp{CALL sla\_PVOBS (P, H, STL, PV)} + Position and velocity of observatory +\end{callset} + +\callhead{Apparent and Observed Place} +\begin{callset} +\subp{CALL sla\_MAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA)} + Mean place to geocentric apparent place +\subp{CALL sla\_MAPPA (EQ, DATE, AMPRMS)} + Precompute mean to apparent parameters +\subp{CALL sla\_MAPQK (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA)} + Mean to apparent using precomputed parameters +\subp{CALL sla\_MAPQKZ (RM, DM, AMPRMS, RA, DA)} + Mean to apparent using precomputed parameters, for zero proper + motion, parallax and radial velocity +\subp{CALL sla\_AMP (RA, DA, DATE, EQ, RM, DM)} + Geocentric apparent place to mean place +\subp{CALL sla\_AMPQK (RA, DA, AOPRMS, RM, DM)} + Apparent to mean using precomputed parameters +\subp{CALL sla\_AOP (\vtop + {\hbox{RAP, DAP, UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB)}}} + Apparent place to observed place +\subp{CALL sla\_AOPPA (\vtop + {\hbox{UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOPRMS)}}} + Precompute apparent to observed parameters +\subp{CALL sla\_AOPPAT (UTC, AOPRMS)} + Update sidereal time in apparent to observed parameters +\subp{CALL sla\_AOPQK (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB)} + Apparent to observed using precomputed parameters +\subp{CALL sla\_OAP (\vtop + {\hbox{TYPE, OB1, OB2, UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, RAP, DAP)}}} + Observed to apparent +\subp{CALL sla\_OAPQK (TYPE, OB1, OB2, AOPRMS, RA, DA)} + Observed to apparent using precomputed parameters +\end{callset} + +\callhead{Azimuth and Elevation} +\begin{callset} +\subp{CALL sla\_ALTAZ (\vtop + {\hbox{HA, DEC, PHI,} + \hbox{AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)}}} + Positions, velocities {\it etc.}\ for an altazimuth mount +\subq{CALL sla\_E2H (HA, DEC, PHI, AZ, EL)} + {CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} + \hadec\ to \azel +\subq{CALL sla\_H2E (AZ, EL, PHI, HA, DEC)} + {CALL sla\_DH2E (AZ, EL, PHI, HA, DEC)} + \azel\ to \hadec +\subp{CALL sla\_PDA2H (P, D, A, H1, J1, H2, J2)} + Hour Angle corresponding to a given azimuth +\subp{CALL sla\_PDQ2H (P, D, Q, H1, J1, H2, J2)} + Hour Angle corresponding to a given parallactic angle +\subp{D~=~sla\_PA (HA, DEC, PHI)} + \hadec\ to parallactic angle +\subp{D~=~sla\_ZD (HA, DEC, PHI)} + \hadec\ to zenith distance +\end{callset} + +\callhead{Refraction and Air Mass} +\begin{callset} +\subp{CALL sla\_REFRO (ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REF)} + Change in zenith distance due to refraction +\subp{CALL sla\_REFCO (HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REFA, REFB)} + Constants for simple refraction model (accurate) +\subp{CALL sla\_REFCOQ (TDK, PMB, RH, WL, REFA, REFB)} + Constants for simple refraction model (fast) +\subp{CALL sla\_ATMDSP ( TDK, PMB, RH, WL1, REFA1, REFB1, WL2, REFA2, REFB2 )} + Adjust refraction constants for colour +\subp{CALL sla\_REFZ (ZU, REFA, REFB, ZR)} + Unrefracted to refracted ZD, simple model +\subp{CALL sla\_REFV (VU, REFA, REFB, VR)} + Unrefracted to refracted \azel\ vector, simple model +\subp{D~=~sla\_AIRMAS (ZD)} + Air mass +\end{callset} + +\callhead{Ecliptic Coordinates} +\begin{callset} +\subp{CALL sla\_ECMAT (DATE, RMAT)} + Equatorial to ecliptic rotation matrix +\subp{CALL sla\_EQECL (DR, DD, DATE, DL, DB)} + J2000.0 `FK5' to ecliptic coordinates +\subp{CALL sla\_ECLEQ (DL, DB, DATE, DR, DD)} + Ecliptic coordinates to J2000.0 `FK5' +\end{callset} + +\callhead{Galactic Coordinates} +\begin{callset} +\subp{CALL sla\_EG50 (DR, DD, DL, DB)} + B1950.0 `FK4' to galactic +\subp{CALL sla\_GE50 (DL, DB, DR, DD)} + Galactic to B1950.0 `FK4' +\subp{CALL sla\_EQGAL (DR, DD, DL, DB)} + J2000.0 `FK5' to galactic +\subp{CALL sla\_GALEQ (DL, DB, DR, DD)} + Galactic to J2000.0 `FK5' +\end{callset} + +\callhead{Supergalactic Coordinates} +\begin{callset} +\subp{CALL sla\_GALSUP (DL, DB, DSL, DSB)} + Galactic to supergalactic +\subp{CALL sla\_SUPGAL (DSL, DSB, DL, DB)} + Supergalactic to galactic +\end{callset} + +\callhead{Ephemerides} +\begin{callset} +\subp{CALL sla\_DMOON (DATE, PV)} + Approximate geocentric position and velocity of the Moon +\subp{CALL sla\_EARTH (IY, ID, FD, PV)} + Approximate heliocentric position and velocity of the Earth +\subp{CALL sla\_EVP (DATE, DEQX, DVB, DPB, DVH, DPH)} + Barycentric and heliocentric velocity and position of the Earth +\subp{CALL sla\_MOON (IY, ID, FD, PV)} + Approximate geocentric position and velocity of the Moon +\subp{CALL sla\_PLANET (DATE, NP, PV, JSTAT)} + Approximate heliocentric position and velocity of a planet +\subp{CALL sla\_RDPLAN (DATE, NP, ELONG, PHI, RA, DEC, DIAM)} + Approximate topocentric apparent place of a planet +\subp{CALL sla\_PLANEL (\vtop + {\hbox{DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, PV, JSTAT)}}} + Heliocentric position and velocity of a planet, asteroid or + comet, starting from orbital elements +\subp{CALL sla\_PLANTE (\vtop + {\hbox{DATE, ELONG, PHI, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM, RA, DEC, R, JSTAT)}}} + Topocentric apparent place of a Solar-System object whose + heliocentric orbital elements are known +\subp{CALL sla\_PV2EL (\vtop + {\hbox{PV, DATE, PMASS, JFORMR, JFORM, EPOCH, ORBINC,} + \hbox{ANODE, PERIH, AORQ, E, AORL, DM, JSTAT)}}} + Orbital elements of a planet from instantaneous position and velocity +\subp{CALL sla\_PERTEL (\vtop + {\hbox{JFORM, DATE0, DATE1,} + \hbox{EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0,} + \hbox{EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1,} + \hbox{JSTAT)}}} + Update elements by applying perturbations +\subp{CALL sla\_EL2UE (\vtop + {\hbox{DATE, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM,} + \hbox{U, JSTAT)}}} + Transform conventional elements to universal elements +\subp{CALL sla\_UE2EL (\vtop + {\hbox{U, JFORMR,} + \hbox{JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, JSTAT)}}} + Transform universal elements to conventional elements +\subp{CALL sla\_PV2UE (PV, DATE, PMASS, U, JSTAT)} + Package a position and velocity for use as universal elements +\subp{CALL sla\_UE2PV (DATE, U, PV, JSTAT)} + Extract the position and velocity from universal elements +\subp{CALL sla\_PERTUE (DATE, U, JSTAT)} + Update universal elements by applying perturbations +\subp{R~=~sla\_RVEROT (PHI, RA, DA, ST)} + Velocity component due to rotation of the Earth +\subp{CALL sla\_ECOR (RM, DM, IY, ID, FD, RV, TL)} + Components of velocity and light time due to Earth orbital motion +\subp{R~=~sla\_RVLSRD (R2000, D2000)} + Velocity component due to solar motion wrt dynamical LSR +\subp{R~=~sla\_RVLSRK (R2000, D2000)} + Velocity component due to solar motion wrt kinematical LSR +\subp{R~=~sla\_RVGALC (R2000, D2000)} + Velocity component due to rotation of the Galaxy +\subp{R~=~sla\_RVLG (R2000, D2000)} + Velocity component due to rotation and translation of the + Galaxy, relative to the mean motion of the local group +\end{callset} + +\callhead{Astrometry} +\begin{callset} +\subq{CALL sla\_S2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} + {CALL sla\_DS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} + Transform spherical coordinates into tangent plane +\subq{CALL sla\_V2TP (V, V0, XI, ETA, J)} + {CALL sla\_DV2TP (V, V0, XI, ETA, J)} + Transform \xyz\ into tangent plane coordinates +\subq{CALL sla\_DTP2S (XI, ETA, RAZ, DECZ, RA, DEC)} + {CALL sla\_TP2S (XI, ETA, RAZ, DECZ, RA, DEC)} + Transform tangent plane coordinates into spherical coordinates +\subq{CALL sla\_DTP2V (XI, ETA, V0, V)} + {CALL sla\_TP2V (XI, ETA, V0, V)} + Transform tangent plane coordinates into \xyz +\subq{CALL sla\_DTPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} + {CALL sla\_TPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} + Get plate centre from star \radec\ and tangent plane coordinates +\subq{CALL sla\_DTPV2C (XI, ETA, V, V01, V02, N)} + {CALL sla\_TPV2C (XI, ETA, V, V01, V02, N)} + Get plate centre from star \xyz\ and tangent plane coordinates +\subp{CALL sla\_PCD (DISCO, X, Y)} + Apply pincushion/barrel distortion +\subp{CALL sla\_UNPCD (DISCO, X, Y)} + Remove pincushion/barrel distortion +\subp{CALL sla\_FITXY (ITYPE, NP, XYE, XYM, COEFFS, J)} + Fit a linear model to relate two sets of \xy\ coordinates +\subp{CALL sla\_PXY (NP, XYE, XYM, COEFFS, XYP, XRMS, YRMS, RRMS)} + Compute predicted coordinates and residuals +\subp{CALL sla\_INVF (FWDS, BKWDS, J)} + Invert a linear model +\subp{CALL sla\_XY2XY (X1, Y1, COEFFS, X2, Y2)} + Transform one \xy +\subp{CALL sla\_DCMPF (COEFFS, XZ, YZ, XS, YS, PERP, ORIENT)} + Decompose a linear fit into scales {\it etc.} +\end{callset} + +\callhead{Numerical Methods} +\begin{callset} +\subq{CALL sla\_SMAT (N, A, Y, D, JF, IW)} + {CALL sla\_DMAT (N, A, Y, D, JF, IW)} + Matrix inversion and solution of simultaneous equations +\subp{CALL sla\_SVD (M, N, MP, NP, A, W, V, WORK, JSTAT)} + Singular value decomposition of a matrix +\subp{CALL sla\_SVDSOL (M, N, MP, NP, B, U, W, V, WORK, X)} + Solution from given vector plus SVD +\subp{CALL sla\_SVDCOV (N, NP, NC, W, V, WORK, CVM)} + Covariance matrix from SVD +\subp{R~=~sla\_RANDOM (SEED)} + Generate pseudo-random real number in the range {$0 \leq x < 1$} +\subp{R~=~sla\_GRESID (S)} + Generate pseudo-random normal deviate ($\equiv$ `Gaussian residual') +\end{callset} + +\callhead{Real-time} +\begin{callset} +\subp{CALL sla\_WAIT (DELAY)} + Interval wait +\end{callset} + +\end{document} diff --git a/math/slalib/doc/supgal.hlp b/math/slalib/doc/supgal.hlp new file mode 100644 index 00000000..aa260719 --- /dev/null +++ b/math/slalib/doc/supgal.hlp @@ -0,0 +1,43 @@ +.help supgal Jun99 "Slalib Package" +.nf + + SUBROUTINE slSUGA (DSL, DSB, DL, DB) + + - - - - - - - + S U G A + - - - - - - - + + Transformation from de Vaucouleurs supergalactic coordinates + to IAU 1958 galactic coordinates (double precision) + + Given: + DSL,DSB dp supergalactic longitude and latitude + + Returned: + DL,DB dp galactic longitude and latitude L2,B2 + + (all arguments are radians) + + Called: + slDS2C, slDIMV, slDC2S, slDA2P, slDA1P + + References: + + de Vaucouleurs, de Vaucouleurs, & Corwin, Second Reference + Catalogue of Bright Galaxies, U. Texas, page 8. + + Systems & Applied Sciences Corp., Documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is L2=137.37.) + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/svd.hlp b/math/slalib/doc/svd.hlp new file mode 100644 index 00000000..14b87c43 --- /dev/null +++ b/math/slalib/doc/svd.hlp @@ -0,0 +1,73 @@ +.help svd Jun99 "Slalib Package" +.nf + + SUBROUTINE slSVD (M, N, MP, NP, A, W, V, WORK, JSTAT) + + - - - - + S V D + - - - - + + Singular value decomposition (double precision) + + This routine expresses a given matrix A as the product of + three matrices U, W, V: + + A = U x W x VT + + Where: + + A is any M (rows) x N (columns) matrix, where M.GE.N + U is an M x N column-orthogonal matrix + W is an N x N diagonal matrix with W(I,I).GE.0 + VT is the transpose of an N x N orthogonal matrix + + Note that M and N, above, are the LOGICAL dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger PHYSICAL dimensions, given by MP and NP. + + Given: + M,N i numbers of rows and columns in matrix A + MP,NP i physical dimensions of array containing matrix A + A d(MP,NP) array containing MxN matrix A + + Returned: + A d(MP,NP) array containing MxN column-orthogonal matrix U + W d(N) NxN diagonal matrix W (diagonal elements only) + V d(NP,NP) array containing NxN orthogonal matrix V + WORK d(N) workspace + JSTAT i 0 = OK, -1 = A wrong shape, >0 = index of W + for which convergence failed. See note 2, below. + + Notes: + + 1) V contains matrix V, not the transpose of matrix V. + + 2) If the status JSTAT is greater than zero, this need not + necessarily be treated as a failure. It means that, due to + chance properties of the matrix A, the QR transformation + phase of the routine did not fully converge in a predefined + number of iterations, something that very seldom occurs. + When this condition does arise, it is possible that the + elements of the diagonal matrix W have not been correctly + found. However, in practice the results are likely to + be trustworthy. Applications should report the condition + as a warning, but then proceed normally. + + References: + The algorithm is an adaptation of the routine SVD in the EISPACK + library (Garbow et al 1977, EISPACK Guide Extension, Springer + Verlag), which is a FORTRAN 66 implementation of the Algol + routine SVD of Wilkinson & Reinsch 1971 (Handbook for Automatic + Computation, vol 2, ed Bauer et al, Springer Verlag). These + references give full details of the algorithm used here. A good + account of the use of SVD in least squares problems is given in + Numerical Recipes (Press et al 1986, Cambridge University Press), + which includes another variant of the EISPACK code. + + P.T.Wallace Starlink 22 December 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/svdcov.hlp b/math/slalib/doc/svdcov.hlp new file mode 100644 index 00000000..48ce38df --- /dev/null +++ b/math/slalib/doc/svdcov.hlp @@ -0,0 +1,35 @@ +.help svdcov Jun99 "Slalib Package" +.nf + + SUBROUTINE slSVDC (N, NP, NC, W, V, WORK, CVM) + + - - - - - - - + S V D C + - - - - - - - + + From the W and V matrices from the SVD factorisation of a matrix + (as obtained from the slSVD routine), obtain the covariance matrix. + + (double precision) + + Given: + N i number of rows and columns in matrices W and V + NP i first dimension of array containing matrix V + NC i first dimension of array to receive CVM + W d(N) NxN diagonal matrix W (diagonal elements only) + V d(NP,NP) array containing NxN orthogonal matrix V + + Returned: + WORK d(N) workspace + CVM d(NC,NC) array to receive covariance matrix + + Reference: + Numerical Recipes, section 14.3. + + P.T.Wallace Starlink December 1988 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/svdsol.hlp b/math/slalib/doc/svdsol.hlp new file mode 100644 index 00000000..42513cfa --- /dev/null +++ b/math/slalib/doc/svdsol.hlp @@ -0,0 +1,82 @@ +.help svdsol Jun99 "Slalib Package" +.nf + + SUBROUTINE slSVDS (M, N, MP, NP, B, U, W, V, WORK, X) + + - - - - - - - + S V D S + - - - - - - - + + From a given vector and the SVD of a matrix (as obtained from + the SVD routine), obtain the solution vector (double precision) + + This routine solves the equation: + + A . x = b + + where: + + A is a given M (rows) x N (columns) matrix, where M.GE.N + x is the N-vector we wish to find + b is a given M-vector + + by means of the Singular Value Decomposition method (SVD). In + this method, the matrix A is first factorised (for example by + the routine slSVD) into the following components: + + A = U x W x VT + + where: + + A is the M (rows) x N (columns) matrix + U is an M x N column-orthogonal matrix + W is an N x N diagonal matrix with W(I,I).GE.0 + VT is the transpose of an NxN orthogonal matrix + + Note that M and N, above, are the LOGICAL dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger PHYSICAL dimensions MP and NP. + + The solution is found from the expression: + + x = V . [diag(1/Wj)] . (transpose(U) . b) + + Notes: + + 1) If matrix A is square, and if the diagonal matrix W is not + adjusted, the method is equivalent to conventional solution + of simultaneous equations. + + 2) If M>N, the result is a least-squares fit. + + 3) If the solution is poorly determined, this shows up in the + SVD factorisation as very small or zero Wj values. Where + a Wj value is small but non-zero it can be set to zero to + avoid ill effects. The present routine detects such zero + Wj values and produces a sensible solution, with highly + correlated terms kept under control rather than being allowed + to elope to infinity, and with meaningful values for the + other terms. + + Given: + M,N i numbers of rows and columns in matrix A + MP,NP i physical dimensions of array containing matrix A + B d(M) known vector b + U d(MP,NP) array containing MxN matrix U + W d(N) NxN diagonal matrix W (diagonal elements only) + V d(NP,NP) array containing NxN orthogonal matrix V + + Returned: + WORK d(N) workspace + X d(N) unknown vector x + + Reference: + Numerical Recipes, section 2.9. + + P.T.Wallace Starlink 29 October 1993 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/tp2s.hlp b/math/slalib/doc/tp2s.hlp new file mode 100644 index 00000000..3cbf1c8e --- /dev/null +++ b/math/slalib/doc/tp2s.hlp @@ -0,0 +1,28 @@ +.help tp2s Jun99 "Slalib Package" +.nf + + SUBROUTINE slTP2S (XI, ETA, RAZ, DECZ, RA, DEC) + + - - - - - + T P 2 S + - - - - - + + Transform tangent plane coordinates into spherical + (single precision) + + Given: + XI,ETA real tangent plane rectangular coordinates + RAZ,DECZ real spherical coordinates of tangent point + + Returned: + RA,DEC real spherical coordinates (0-2pi,+/-pi/2) + + Called: slRA2P + + P.T.Wallace Starlink 24 July 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/tp2v.hlp b/math/slalib/doc/tp2v.hlp new file mode 100644 index 00000000..e81c60d1 --- /dev/null +++ b/math/slalib/doc/tp2v.hlp @@ -0,0 +1,40 @@ +.help tp2v Jun99 "Slalib Package" +.nf + + SUBROUTINE slTP2V (XI, ETA, V0, V) + + - - - - - + T P 2 V + - - - - - + + Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star. + + (single precision) + + Given: + XI,ETA r tangent plane coordinates of star + V0 r(3) direction cosines of tangent point + + Returned: + V r(3) direction cosines of star + + Notes: + + 1 If vector V0 is not of unit length, the returned vector V will + be wrong. + + 2 If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that the RA of the tangent + point is zero. + + 3 This routine is the Cartesian equivalent of the routine slTP2S. + + P.T.Wallace Starlink 11 February 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/tps2c.hlp b/math/slalib/doc/tps2c.hlp new file mode 100644 index 00000000..d1914ef2 --- /dev/null +++ b/math/slalib/doc/tps2c.hlp @@ -0,0 +1,58 @@ +.help tps2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slTPSC (XI, ETA, RA, DEC, RAZ1, DECZ1, + : RAZ2, DECZ2, N) + + - - - - - - + T P S C + - - - - - - + + From the tangent plane coordinates of a star of known RA,Dec, + determine the RA,Dec of the tangent point. + + (single precision) + + Given: + XI,ETA r tangent plane rectangular coordinates + RA,DEC r spherical coordinates + + Returned: + RAZ1,DECZ1 r spherical coordinates of tangent point, solution 1 + RAZ2,DECZ2 r spherical coordinates of tangent point, solution 2 + N i number of solutions: + 0 = no solutions returned (note 2) + 1 = only the first solution is useful (note 3) + 2 = both solutions are useful (note 3) + + Notes: + + 1 The RAZ1 and RAZ2 values are returned in the range 0-2pi. + + 2 Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of XI and DEC. + + 3 Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N=1 indicates only one useful + solution, the usual case; under these circumstances, the second + solution corresponds to the "over-the-pole" case, and this is + reflected in the values of RAZ2 and DECZ2 which are returned. + + 4 The DECZ1 and DECZ2 values are returned in the range +/-pi, but + in the usual, non-pole-crossing, case, the range is +/-pi/2. + + 5 This routine is the spherical equivalent of the routine slDPVC. + + Called: slRA2P + + P.T.Wallace Starlink 5 June 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/tpv2c.hlp b/math/slalib/doc/tpv2c.hlp new file mode 100644 index 00000000..7a1b688d --- /dev/null +++ b/math/slalib/doc/tpv2c.hlp @@ -0,0 +1,51 @@ +.help tpv2c Jun99 "Slalib Package" +.nf + + SUBROUTINE slTPVC (XI, ETA, V, V01, V02, N) + + - - - - - - + T P V C + - - - - - - + + Given the tangent-plane coordinates of a star and its direction + cosines, determine the direction cosines of the tangent-point. + + (single precision) + + Given: + XI,ETA r tangent plane coordinates of star + V r(3) direction cosines of star + + Returned: + V01 r(3) direction cosines of tangent point, solution 1 + V02 r(3) direction cosines of tangent point, solution 2 + N i number of solutions: + 0 = no solutions returned (note 2) + 1 = only the first solution is useful (note 3) + 2 = both solutions are useful (note 3) + + Notes: + + 1 The vector V must be of unit length or the result will be wrong. + + 2 Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value, and hence it is meaningless + to ask where the tangent point would have to be. + + 3 Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N=1 indicates only one useful + solution, the usual case; under these circumstances, the second + solution can be regarded as valid if the vector V02 is interpreted + as the "over-the-pole" case. + + 4 This routine is the Cartesian equivalent of the routine slTPSC. + + P.T.Wallace Starlink 5 June 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ue2el.hlp b/math/slalib/doc/ue2el.hlp new file mode 100644 index 00000000..6eb0996a --- /dev/null +++ b/math/slalib/doc/ue2el.hlp @@ -0,0 +1,167 @@ +.help ue2el Jun99 "Slalib Package" +.nf + + SUBROUTINE slUEEL (U, JFORMR, + : JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, JSTAT) + + - - - - - - + U E E L + - - - - - - + + Transform universal elements into conventional heliocentric + osculating elements. + + Given: + U d(13) universal orbital elements (Note 1) + + (1) combined mass (M+m) + (2) total energy of the orbit (alpha) + (3) reference (osculating) epoch (t0) + (4-6) position at reference epoch (r0) + (7-9) velocity at reference epoch (v0) + (10) heliocentric distance at reference epoch + (11) r0.v0 + (12) date (t) + (13) universal eccentric anomaly (psi) of date, approx + + JFORMR i requested element set (1-3; Note 3) + + Returned: + JFORM d element set actually returned (1-3; Note 4) + EPOCH d epoch of elements (TT MJD) + ORBINC d inclination (radians) + ANODE d longitude of the ascending node (radians) + PERIH d longitude or argument of perihelion (radians) + AORQ d mean distance or perihelion distance (AU) + E d eccentricity + AORL d mean anomaly or longitude (radians, JFORM=1,2 only) + DM d daily motion (radians, JFORM=1 only) + JSTAT i status: 0 = OK + -1 = illegal combined mass + -2 = illegal JFORMR + -3 = position/velocity out of range + + Notes + + 1 The "universal" elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i) alpha, which is proportional to the total energy of the + orbit, (ii) the heliocentric distance at epoch, (iii) the + outwards component of the velocity at the given epoch, (iv) an + estimate of psi, the "universal eccentric anomaly" at a given + date and (v) that date. + + 2 The universal elements are with respect to the mean equator and + equinox of epoch J2000. The orbital elements produced are with + respect to the J2000 ecliptic and mean equinox. + + 3 Three different element-format options are supported: + + Option JFORM=1, suitable for the major planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = longitude of perihelion, curly pi (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean longitude L (radians) + DM = daily motion (radians) + + Option JFORM=2, suitable for minor planets: + + EPOCH = epoch of elements (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = mean distance, a (AU) + E = eccentricity, e + AORL = mean anomaly M (radians) + + Option JFORM=3, suitable for comets: + + EPOCH = epoch of perihelion (TT MJD) + ORBINC = inclination i (radians) + ANODE = longitude of the ascending node, big omega (radians) + PERIH = argument of perihelion, little omega (radians) + AORQ = perihelion distance, q (AU) + E = eccentricity, e + + 4 It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + JFORMR JFORM meaning + + 1 1 OK - elements are in the requested format + 1 2 never happens + 1 3 orbit not elliptical + + 2 1 never happens + 2 2 OK - elements are in the requested format + 2 3 orbit not elliptical + + 3 1 never happens + 3 2 never happens + 3 3 OK - elements are in the requested format + + 5 The arguments returned for each value of JFORM (cf Note 6: JFORM + may not be the same as JFORMR) are as follows: + + JFORM 1 2 3 + EPOCH t0 t0 T + ORBINC i i i + ANODE Omega Omega Omega + PERIH curly pi omega omega + AORQ a a q + E e e e + AORL L M - + DM n - - + + where: + + t0 is the epoch of the elements (MJD, TT) + T " epoch of perihelion (MJD, TT) + i " inclination (radians) + Omega " longitude of the ascending node (radians) + curly pi " longitude of perihelion (radians) + omega " argument of perihelion (radians) + a " mean distance (AU) + q " perihelion distance (AU) + e " eccentricity + L " longitude (radians, 0-2pi) + M " mean anomaly (radians, 0-2pi) + n " daily motion (radians) + - means no value is set + + 6 At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + + References: + + 1 Sterne, Theodore E., "An Introduction to Celestial Mechanics", + Interscience Publishers Inc., 1960. Section 6.7, p199. + + 2 Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. + + Called: slPVEL + + P.T.Wallace Starlink 18 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/ue2pv.hlp b/math/slalib/doc/ue2pv.hlp new file mode 100644 index 00000000..ed5c9609 --- /dev/null +++ b/math/slalib/doc/ue2pv.hlp @@ -0,0 +1,87 @@ +.help ue2pv Jun99 "Slalib Package" +.nf + + SUBROUTINE slUEPV (DATE, U, PV, JSTAT) + + - - - - - - + U E P V + - - - - - - + + Heliocentric position and velocity of a planet, asteroid or comet, + starting from orbital elements in the "universal variables" form. + + Given: + DATE d date, Modified Julian Date (JD-2400000.5) + + Given and returned: + U d(13) universal orbital elements (updated; Note 1) + + given (1) combined mass (M+m) + " (2) total energy of the orbit (alpha) + " (3) reference (osculating) epoch (t0) + " (4-6) position at reference epoch (r0) + " (7-9) velocity at reference epoch (v0) + " (10) heliocentric distance at reference epoch + " (11) r0.v0 + returned (12) date (t) + " (13) universal eccentric anomaly (psi) of date + + Returned: + PV d(6) position (AU) and velocity (AU/s) + JSTAT i status: 0 = OK + -1 = radius vector zero + -2 = failed to converge + + Notes + + 1 The "universal" elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i) alpha, which is proportional to the total energy of the + orbit, (ii) the heliocentric distance at epoch, (iii) the + outwards component of the velocity at the given epoch, (iv) an + estimate of psi, the "universal eccentric anomaly" at a given + date and (v) that date. + + 2 The companion routine is slELUE. This takes the conventional + orbital elements and transforms them into the set of numbers + needed by the present routine. A single prediction requires one + one call to slELUE followed by one call to the present routine; + for convenience, the two calls are packaged as the routine + slPLNE. Multiple predictions may be made by again + calling slELUE once, but then calling the present routine + multiple times, which is faster than multiple calls to slPLNE. + + It is not obligatory to use slELUE to obtain the parameters. + However, it should be noted that because slELUE performs its + own validation, no checks on the contents of the array U are made + by the present routine. + + 3 DATE is the instant for which the prediction is required. It is + in the TT timescale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD-2400000.5). + + 4 The universal elements supplied in the array U are in canonical + units (solar masses, AU and canonical days). The position and + velocity are not sensitive to the choice of reference frame. The + slELUE routine in fact produces coordinates with respect to the + J2000 equator and equinox. + + 5 The algorithm was originally adapted from the EPHSLA program of + D.H.P.Jones (private communication, 1996). The method is based + on Stumpff's Universal Variables. + + Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. + + P.T.Wallace Starlink 19 March 1999 + + Copyright (C) 1999 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/unpcd.hlp b/math/slalib/doc/unpcd.hlp new file mode 100644 index 00000000..26654492 --- /dev/null +++ b/math/slalib/doc/unpcd.hlp @@ -0,0 +1,57 @@ +.help unpcd Jun99 "Slalib Package" +.nf + + SUBROUTINE slUPCD (DISCO,X,Y) + + - - - - - - + U P C D + - - - - - - + + Remove pincushion/barrel distortion from a distorted [x,y] + to give tangent-plane [x,y]. + + Given: + DISCO d pincushion/barrel distortion coefficient + X,Y d distorted coordinates + + Returned: + X,Y d tangent-plane coordinates + + Notes: + + 1) The distortion is of the form RP = R*(1 + C*R**2), where R is + the radial distance from the tangent point, C is the DISCO + argument, and RP is the radial distance in the presence of + the distortion. + + 2) For pincushion distortion, C is +ve; for barrel distortion, + C is -ve. + + 3) For X,Y in "radians" - units of one projection radius, + which in the case of a photograph is the focal length of + the camera - the following DISCO values apply: + + Geometry DISCO + + astrograph 0.0 + Schmidt -0.3333 + AAT PF doublet +147.069 + AAT PF triplet +178.585 + AAT f/8 +21.20 + JKT f/8 +13.32 + + 4) The present routine is an approximate inverse to the + companion routine slPCD, obtained from two iterations + of Newton's method. The mismatch between the slPCD and + slUPCD routines is negligible for astrometric applications; + to reach 1 milliarcsec at the edge of the AAT triplet or + Schmidt field would require field diameters of 2.4 degrees + and 42 degrees respectively. + + P.T.Wallace Starlink 1 August 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/v2tp.hlp b/math/slalib/doc/v2tp.hlp new file mode 100644 index 00000000..6522e398 --- /dev/null +++ b/math/slalib/doc/v2tp.hlp @@ -0,0 +1,42 @@ +.help v2tp Jun99 "Slalib Package" +.nf + + SUBROUTINE slV2TP (V, V0, XI, ETA, J) + + - - - - - + V 2 T P + - - - - - + + Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates. + + (single precision) + + Given: + V r(3) direction cosines of star + V0 r(3) direction cosines of tangent point + + Returned: + XI,ETA r tangent plane coordinates of star + J i status: 0 = OK + 1 = error, star too far from axis + 2 = error, antistar on tangent plane + 3 = error, antistar too far from axis + + Notes: + + 1 If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + + 2 If V0 points at a pole, the returned XI,ETA will be based on the + arbitrary assumption that the RA of the tangent point is zero. + + 3 This routine is the Cartesian equivalent of the routine slS2TP. + + P.T.Wallace Starlink 27 November 1996 + + Copyright (C) 1996 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/vdv.hlp b/math/slalib/doc/vdv.hlp new file mode 100644 index 00000000..526ce406 --- /dev/null +++ b/math/slalib/doc/vdv.hlp @@ -0,0 +1,24 @@ +.help vdv Jun99 "Slalib Package" +.nf + + REAL FUNCTION slVDV (VA, VB) + + - - - - + V D V + - - - - + + Scalar product of two 3-vectors (single precision) + + Given: + VA real(3) first vector + VB real(3) second vector + + The result is the scalar product VA.VB (single precision) + + P.T.Wallace Starlink November 1984 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/vn.hlp b/math/slalib/doc/vn.hlp new file mode 100644 index 00000000..17b7b3ba --- /dev/null +++ b/math/slalib/doc/vn.hlp @@ -0,0 +1,27 @@ +.help vn Jun99 "Slalib Package" +.nf + + SUBROUTINE slVN (V, UV, VM) + + - - - + V N + - - - + + Normalizes a 3-vector also giving the modulus (single precision) + + Given: + V real(3) vector + + Returned: + UV real(3) unit vector in direction of V + VM real modulus of V + + If the modulus of V is zero, UV is set to zero as well + + P.T.Wallace Starlink 23 November 1995 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/vxv.hlp b/math/slalib/doc/vxv.hlp new file mode 100644 index 00000000..64272c33 --- /dev/null +++ b/math/slalib/doc/vxv.hlp @@ -0,0 +1,25 @@ +.help vxv Jun99 "Slalib Package" +.nf + + SUBROUTINE slVXV (VA, VB, VC) + + - - - - + V X V + - - - - + + Vector product of two 3-vectors (single precision) + + Given: + VA real(3) first vector + VB real(3) second vector + + Returned: + VC real(3) vector result + + P.T.Wallace Starlink March 1986 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/xy2xy.hlp b/math/slalib/doc/xy2xy.hlp new file mode 100644 index 00000000..64ab43e2 --- /dev/null +++ b/math/slalib/doc/xy2xy.hlp @@ -0,0 +1,45 @@ +.help xy2xy Jun99 "Slalib Package" +.nf + + SUBROUTINE slXYXY (X1,Y1,COEFFS,X2,Y2) + + - - - - - - + X Y X Y + - - - - - - + + Transform one [X,Y] into another using a linear model of the type + produced by the slFTXY routine. + + Given: + X1 d x-coordinate + Y1 d y-coordinate + COEFFS d(6) transformation coefficients (see note) + + Returned: + X2 d x-coordinate + Y2 d y-coordinate + + The model relates two sets of [X,Y] coordinates as follows. + Naming the elements of COEFFS: + + COEFFS(1) = A + COEFFS(2) = B + COEFFS(3) = C + COEFFS(4) = D + COEFFS(5) = E + COEFFS(6) = F + + the present routine performs the transformation: + + X2 = A + B*X1 + C*Y1 + Y2 = D + E*X1 + F*Y1 + + See also slFTXY, slPXY, slINVF, slDCMF + + P.T.Wallace Starlink 5 December 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/doc/zd.hlp b/math/slalib/doc/zd.hlp new file mode 100644 index 00000000..109b4d10 --- /dev/null +++ b/math/slalib/doc/zd.hlp @@ -0,0 +1,48 @@ +.help zd Jun99 "Slalib Package" +.nf + + DOUBLE PRECISION FUNCTION slZD (HA, DEC, PHI) + + - - - + Z D + - - - + + HA, Dec to Zenith Distance (double precision) + + Given: + HA d Hour Angle in radians + DEC d declination in radians + PHI d observatory latitude in radians + + The result is in the range 0 to pi. + + Notes: + + 1) The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + + 2) In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of zenith distance. In particular, + it may be important to distinguish between the zenith distance + as affected by refraction, which would require the "observed" + HA,Dec, and the zenith distance in vacuo, which would require + the "topocentric" HA,Dec. If the effects of diurnal aberration + can be neglected, the "apparent" HA,Dec may be used instead of + the topocentric HA,Dec. + + 3) No range checking of arguments is done. + + 4) In applications which involve many zenith distance calculations, + rather than calling the present routine it will be more efficient + to use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and perhaps sine and cosine of + declination. + + P.T.Wallace Starlink 3 April 1994 + + Copyright (C) 1995 Rutherford Appleton Laboratory + Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. + +.fi +.endhelp diff --git a/math/slalib/dpav.f b/math/slalib/dpav.f new file mode 100644 index 00000000..20de2742 --- /dev/null +++ b/math/slalib/dpav.f @@ -0,0 +1,82 @@ + DOUBLE PRECISION FUNCTION slDPAV ( V1, V2 ) +*+ +* - - - - - +* D P A V +* - - - - - +* +* Position angle of one celestial direction with respect to another. +* +* (double precision) +* +* Given: +* V1 d(3) direction cosines of one point +* V2 d(3) direction cosines of the other point +* +* (The coordinate frames correspond to RA,Dec, Long,Lat etc.) +* +* The result is the bearing (position angle), in radians, of point +* V2 with respect to point V1. It is in the range +/- pi. The +* sense is such that if V2 is a small distance east of V1, the +* bearing is about +pi/2. Zero is returned if the two points +* are coincident. +* +* V1 and V2 need not be unit vectors. +* +* The routine slDBER performs an equivalent function except +* that the points are specified in the form of spherical +* coordinates. +* +* Last revision: 16 March 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V1(3),V2(3) + + DOUBLE PRECISION X1,Y1,Z1,W,X2,Y2,Z2,SQ,CQ + + + +* The unit vector to point 1. + X1 = V1(1) + Y1 = V1(2) + Z1 = V1(3) + W = SQRT(X1*X1+Y1*Y1+Z1*Z1) + IF (W.NE.0D0) THEN + X1 = X1/W + Y1 = Y1/W + Z1 = Z1/W + END IF + +* The vector to point 2. + X2 = V2(1) + Y2 = V2(2) + Z2 = V2(3) + +* Position angle. + SQ = Y2*X1-X2*Y1 + CQ = Z2*(X1*X1+Y1*Y1)-Z1*(X2*X1+Y2*Y1) + IF (SQ.EQ.0D0.AND.CQ.EQ.0D0) CQ=1D0 + slDPAV = ATAN2(SQ,CQ) + + END diff --git a/math/slalib/dr2af.f b/math/slalib/dr2af.f new file mode 100644 index 00000000..155f1f6b --- /dev/null +++ b/math/slalib/dr2af.f @@ -0,0 +1,76 @@ + SUBROUTINE slDRAF (NDP, ANGLE, SIGN, IDMSF) +*+ +* - - - - - - +* D R A F +* - - - - - - +* +* Convert an angle in radians to degrees, arcminutes, arcseconds +* (double precision) +* +* Given: +* NDP i number of decimal places of arcseconds +* ANGLE d angle in radians +* +* Returned: +* SIGN c '+' or '-' +* IDMSF i(4) degrees, arcminutes, arcseconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size +* of ANGLE, the format of DOUBLE PRECISION floating-point +* numbers on the target machine, and the risk of overflowing +* IDMSF(4). On some architectures, for ANGLE up to 2pi, the +* available floating-point precision corresponds roughly to +* NDP=12. However, the practical limit is NDP=9, set by the +* capacity of a typical 32-bit IDMSF(4). +* +* 3) The absolute value of ANGLE may exceed 2pi. In cases where it +* does not, it is up to the caller to test for and handle the +* case where ANGLE is very nearly 2pi and rounds up to 360 deg, +* by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. +* +* Called: slDDTF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + DOUBLE PRECISION ANGLE + CHARACTER SIGN*(*) + INTEGER IDMSF(4) + +* Hours to degrees * radians to turns + DOUBLE PRECISION F + PARAMETER (F=15D0/6.283185307179586476925287D0) + + + +* Scale then use days to h,m,s routine + CALL slDDTF(NDP,ANGLE*F,SIGN,IDMSF) + + END diff --git a/math/slalib/dr2tf.f b/math/slalib/dr2tf.f new file mode 100644 index 00000000..3f5edfbb --- /dev/null +++ b/math/slalib/dr2tf.f @@ -0,0 +1,76 @@ + SUBROUTINE slDRTF (NDP, ANGLE, SIGN, IHMSF) +*+ +* - - - - - - +* D R T F +* - - - - - - +* +* Convert an angle in radians to hours, minutes, seconds +* (double precision) +* +* Given: +* NDP i number of decimal places of seconds +* ANGLE d angle in radians +* +* Returned: +* SIGN c '+' or '-' +* IHMSF i(4) hours, minutes, seconds, fraction +* +* Notes: +* +* 1) NDP less than zero is interpreted as zero. +* +* 2) The largest useful value for NDP is determined by the size +* of ANGLE, the format of DOUBLE PRECISION floating-point +* numbers on the target machine, and the risk of overflowing +* IHMSF(4). On some architectures, for ANGLE up to 2pi, the +* available floating-point precision corresponds roughly to +* NDP=12. However, the practical limit is NDP=9, set by the +* capacity of a typical 32-bit IHMSF(4). +* +* 3) The absolute value of ANGLE may exceed 2pi. In cases where it +* does not, it is up to the caller to test for and handle the +* case where ANGLE is very nearly 2pi and rounds up to 24 hours, +* by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +* +* Called: slDDTF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NDP + DOUBLE PRECISION ANGLE + CHARACTER SIGN*(*) + INTEGER IHMSF(4) + +* Turns to radians + DOUBLE PRECISION T2R + PARAMETER (T2R=6.283185307179586476925287D0) + + + +* Scale then use days to h,m,s routine + CALL slDDTF(NDP,ANGLE/T2R,SIGN,IHMSF) + + END diff --git a/math/slalib/drange.f b/math/slalib/drange.f new file mode 100644 index 00000000..9f82c57e --- /dev/null +++ b/math/slalib/drange.f @@ -0,0 +1,50 @@ + DOUBLE PRECISION FUNCTION slDA1P (ANGLE) +*+ +* - - - - - - - +* D A 1 P +* - - - - - - - +* +* Normalize angle into range +/- pi (double precision) +* +* Given: +* ANGLE dp the angle in radians +* +* The result (double precision) is ANGLE expressed in the range +/- pi. +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ANGLE + + DOUBLE PRECISION DPI,D2PI + PARAMETER (DPI=3.141592653589793238462643D0) + PARAMETER (D2PI=6.283185307179586476925287D0) + + + slDA1P=MOD(ANGLE,D2PI) + IF (ABS(slDA1P).GE.DPI) + : slDA1P=slDA1P-SIGN(D2PI,ANGLE) + + END diff --git a/math/slalib/dranrm.f b/math/slalib/dranrm.f new file mode 100644 index 00000000..9325840c --- /dev/null +++ b/math/slalib/dranrm.f @@ -0,0 +1,48 @@ + DOUBLE PRECISION FUNCTION slDA2P (ANGLE) +*+ +* - - - - - - - +* D A 2 P +* - - - - - - - +* +* Normalize angle into range 0-2 pi (double precision) +* +* Given: +* ANGLE dp the angle in radians +* +* The result is ANGLE expressed in the range 0-2 pi. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ANGLE + + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925286766559D0) + + + slDA2P = MOD(ANGLE,D2PI) + IF (slDA2P.LT.0D0) slDA2P = slDA2P+D2PI + + END diff --git a/math/slalib/ds2c6.f b/math/slalib/ds2c6.f new file mode 100644 index 00000000..7c7de506 --- /dev/null +++ b/math/slalib/ds2c6.f @@ -0,0 +1,75 @@ + SUBROUTINE slDSC6 (A, B, R, AD, BD, RD, V) +*+ +* - - - - - - +* D S C 6 +* - - - - - - +* +* Conversion of position & velocity in spherical coordinates +* to Cartesian coordinates +* +* (double precision) +* +* Given: +* A dp longitude (radians) +* B dp latitude (radians) +* R dp radial coordinate +* AD dp longitude derivative (radians per unit time) +* BD dp latitude derivative (radians per unit time) +* RD dp radial derivative +* +* Returned: +* V dp(6) Cartesian position & velocity vector +* +* P.T.Wallace Starlink 10 July 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION A,B,R,AD,BD,RD,V(6) + + DOUBLE PRECISION SA,CA,SB,CB,RCB,X,Y,RBD,W + + + +* Useful functions + SA=SIN(A) + CA=COS(A) + SB=SIN(B) + CB=COS(B) + RCB=R*CB + X=RCB*CA + Y=RCB*SA + RBD=R*BD + W=RBD*SB-CB*RD + +* Position + V(1)=X + V(2)=Y + V(3)=R*SB + +* Velocity + V(4)=-Y*AD-W*CA + V(5)=X*AD-W*SA + V(6)=RBD*CB+SB*RD + + END diff --git a/math/slalib/ds2tp.f b/math/slalib/ds2tp.f new file mode 100644 index 00000000..ee8104d7 --- /dev/null +++ b/math/slalib/ds2tp.f @@ -0,0 +1,85 @@ + SUBROUTINE slDSTP (RA, DEC, RAZ, DECZ, XI, ETA, J) +*+ +* - - - - - - +* D S T P +* - - - - - - +* +* Projection of spherical coordinates onto tangent plane: +* "gnomonic" projection - "standard coordinates" (double precision) +* +* Given: +* RA,DEC dp spherical coordinates of point to be projected +* RAZ,DECZ dp spherical coordinates of tangent point +* +* Returned: +* XI,ETA dp rectangular coordinates on tangent plane +* J int status: 0 = OK, star on tangent plane +* 1 = error, star too far from axis +* 2 = error, antistar on tangent plane +* 3 = error, antistar too far from axis +* +* P.T.Wallace Starlink 18 July 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RA,DEC,RAZ,DECZ,XI,ETA + INTEGER J + + DOUBLE PRECISION SDECZ,SDEC,CDECZ,CDEC, + : RADIF,SRADIF,CRADIF,DENOM + + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-6) + + +* Trig functions + SDECZ=SIN(DECZ) + SDEC=SIN(DEC) + CDECZ=COS(DECZ) + CDEC=COS(DEC) + RADIF=RA-RAZ + SRADIF=SIN(RADIF) + CRADIF=COS(RADIF) + +* Reciprocal of star vector length to tangent plane + DENOM=SDEC*SDECZ+CDEC*CDECZ*CRADIF + +* Handle vectors too far from axis + IF (DENOM.GT.TINY) THEN + J=0 + ELSE IF (DENOM.GE.0D0) THEN + J=1 + DENOM=TINY + ELSE IF (DENOM.GT.-TINY) THEN + J=2 + DENOM=-TINY + ELSE + J=3 + END IF + +* Compute tangent plane coordinates (even in dubious cases) + XI=CDEC*SRADIF/DENOM + ETA=(SDEC*CDECZ-CDEC*SDECZ*CRADIF)/DENOM + + END diff --git a/math/slalib/dsep.f b/math/slalib/dsep.f new file mode 100644 index 00000000..6e7e9fff --- /dev/null +++ b/math/slalib/dsep.f @@ -0,0 +1,61 @@ + DOUBLE PRECISION FUNCTION slDSEP (A1, B1, A2, B2) +*+ +* - - - - - +* D S E P +* - - - - - +* +* Angle between two points on a sphere. +* +* (double precision) +* +* Given: +* A1,B1 d spherical coordinates of one point +* A2,B2 d spherical coordinates of the other point +* +* (The spherical coordinates are [RA,Dec], [Long,Lat] etc, in radians.) +* +* The result is the angle, in radians, between the two points. It +* is always positive. +* +* Called: slDS2C, slDSEPV +* +* Last revision: 7 May 2000 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION A1,B1,A2,B2 + + DOUBLE PRECISION V1(3),V2(3) + DOUBLE PRECISION slDSEPV + + + +* Convert coordinates from spherical to Cartesian. + CALL slDS2C(A1,B1,V1) + CALL slDS2C(A2,B2,V2) + +* Angle between the vectors. + slDSEP = slDSEPV(V1,V2) + + END diff --git a/math/slalib/dsepv.f b/math/slalib/dsepv.f new file mode 100644 index 00000000..6ff5d9d8 --- /dev/null +++ b/math/slalib/dsepv.f @@ -0,0 +1,77 @@ + DOUBLE PRECISION FUNCTION slDSEPV (V1, V2) +*+ +* - - - - - - +* D S E P V +* - - - - - - +* +* Angle between two vectors. +* +* (double precision) +* +* Given: +* V1 d(3) first vector +* V2 d(3) second vector +* +* The result is the angle, in radians, between the two vectors. It +* is always positive. +* +* Notes: +* +* 1 There is no requirement for the vectors to be unit length. +* +* 2 If either vector is null, zero is returned. +* +* 3 The simplest formulation would use dot product alone. However, +* this would reduce the accuracy for angles near zero and pi. The +* algorithm uses both cross product and dot product, which maintains +* accuracy for all sizes of angle. +* +* Called: slDVXV, slDVN, slDVDV +* +* Last revision: 14 June 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V1(3),V2(3) + + DOUBLE PRECISION V1XV2(3),WV(3),S,C + DOUBLE PRECISION slDVDV + + + +* Modulus of cross product = sine multiplied by the two moduli. + CALL slDVXV(V1,V2,V1XV2) + CALL slDVN(V1XV2,WV,S) + +* Dot product = cosine multiplied by the two moduli. + C = slDVDV(V1,V2) + +* Angle between the vectors. + IF ( S.NE.0D0 .OR. C.NE.0D0 ) THEN + slDSEPV = ATAN2(S,C) + ELSE + slDSEPV = 0D0 + END IF + + END diff --git a/math/slalib/dt.f b/math/slalib/dt.f new file mode 100644 index 00000000..a012c677 --- /dev/null +++ b/math/slalib/dt.f @@ -0,0 +1,97 @@ + DOUBLE PRECISION FUNCTION slDT (EPOCH) +*+ +* - - - +* D T +* - - - +* +* Estimate the offset between dynamical time and Universal Time +* for a given historical epoch. +* +* Given: +* EPOCH d (Julian) epoch (e.g. 1850D0) +* +* The result is a rough estimate of ET-UT (after 1984, TT-UT) at +* the given epoch, in seconds. +* +* Notes: +* +* 1 Depending on the epoch, one of three parabolic approximations +* is used: +* +* before 979 Stephenson & Morrison's 390 BC to AD 948 model +* 979 to 1708 Stephenson & Morrison's 948 to 1600 model +* after 1708 McCarthy & Babcock's post-1650 model +* +* The breakpoints are chosen to ensure continuity: they occur +* at places where the adjacent models give the same answer as +* each other. +* +* 2 The accuracy is modest, with errors of up to 20 sec during +* the interval since 1650, rising to perhaps 30 min by 1000 BC. +* Comparatively accurate values from AD 1600 are tabulated in +* the Astronomical Almanac (see section K8 of the 1995 AA). +* +* 3 The use of double-precision for both argument and result is +* purely for compatibility with other SLALIB time routines. +* +* 4 The models used are based on a lunar tidal acceleration value +* of -26.00 arcsec per century. +* +* Reference: Explanatory Supplement to the Astronomical Almanac, +* ed P.K.Seidelmann, University Science Books (1992), +* section 2.553, p83. This contains references to +* the Stephenson & Morrison and McCarthy & Babcock +* papers. +* +* P.T.Wallace Starlink 1 March 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EPOCH + DOUBLE PRECISION T,W,S + + +* Centuries since 1800 + T=(EPOCH-1800D0)/100D0 + +* Select model + IF (EPOCH.GE.1708.185161980887D0) THEN + +* Post-1708: use McCarthy & Babcock + W=T-0.19D0 + S=5.156D0+13.3066D0*W*W + ELSE IF (EPOCH.GE.979.0258204760233D0) THEN + +* 979-1708: use Stephenson & Morrison's 948-1600 model + S=25.5D0*T*T + ELSE + +* Pre-979: use Stephenson & Morrison's 390 BC to AD 948 model + S=1360.0D0+(320D0+44.3D0*T)*T + END IF + +* Result + slDT=S + + END diff --git a/math/slalib/dtf2d.f b/math/slalib/dtf2d.f new file mode 100644 index 00000000..757ed11e --- /dev/null +++ b/math/slalib/dtf2d.f @@ -0,0 +1,73 @@ + SUBROUTINE slDTFD (IHOUR, IMIN, SEC, DAYS, J) +*+ +* - - - - - - +* D T F D +* - - - - - - +* +* Convert hours, minutes, seconds to days (double precision) +* +* Given: +* IHOUR int hours +* IMIN int minutes +* SEC dp seconds +* +* Returned: +* DAYS dp interval in days +* J int status: 0 = OK +* 1 = IHOUR outside range 0-23 +* 2 = IMIN outside range 0-59 +* 3 = SEC outside range 0-59.999... +* +* Notes: +* +* 1) The result is computed even if any of the range checks fail. +* +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink July 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IHOUR,IMIN + DOUBLE PRECISION SEC,DAYS + INTEGER J + +* Seconds per day + DOUBLE PRECISION D2S + PARAMETER (D2S=86400D0) + + + +* Preset status + J=0 + +* Validate sec, min, hour + IF (SEC.LT.0D0.OR.SEC.GE.60D0) J=3 + IF (IMIN.LT.0.OR.IMIN.GT.59) J=2 + IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1 + +* Compute interval + DAYS=(60D0*(60D0*DBLE(IHOUR)+DBLE(IMIN))+SEC)/D2S + + END diff --git a/math/slalib/dtf2r.f b/math/slalib/dtf2r.f new file mode 100644 index 00000000..f260e3e1 --- /dev/null +++ b/math/slalib/dtf2r.f @@ -0,0 +1,71 @@ + SUBROUTINE slDTFR (IHOUR, IMIN, SEC, RAD, J) +*+ +* - - - - - - +* D T F R +* - - - - - - +* +* Convert hours, minutes, seconds to radians (double precision) +* +* Given: +* IHOUR int hours +* IMIN int minutes +* SEC dp seconds +* +* Returned: +* RAD dp angle in radians +* J int status: 0 = OK +* 1 = IHOUR outside range 0-23 +* 2 = IMIN outside range 0-59 +* 3 = SEC outside range 0-59.999... +* +* Called: +* slDTFD +* +* Notes: +* +* 1) The result is computed even if any of the range checks fail. +* +* 2) The sign must be dealt with outside this routine. +* +* P.T.Wallace Starlink July 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IHOUR,IMIN + DOUBLE PRECISION SEC,RAD + INTEGER J + + DOUBLE PRECISION TURNS + +* Turns to radians + DOUBLE PRECISION T2R + PARAMETER (T2R=6.283185307179586476925287D0) + + + +* Convert to turns then radians + CALL slDTFD(IHOUR,IMIN,SEC,TURNS,J) + RAD=T2R*TURNS + + END diff --git a/math/slalib/dtp2s.f b/math/slalib/dtp2s.f new file mode 100644 index 00000000..436057ea --- /dev/null +++ b/math/slalib/dtp2s.f @@ -0,0 +1,60 @@ + SUBROUTINE slDTPS (XI, ETA, RAZ, DECZ, RA, DEC) +*+ +* - - - - - - +* D T P S +* - - - - - - +* +* Transform tangent plane coordinates into spherical +* (double precision) +* +* Given: +* XI,ETA dp tangent plane rectangular coordinates +* RAZ,DECZ dp spherical coordinates of tangent point +* +* Returned: +* RA,DEC dp spherical coordinates (0-2pi,+/-pi/2) +* +* Called: slDA2P +* +* P.T.Wallace Starlink 24 July 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION XI,ETA,RAZ,DECZ,RA,DEC + + DOUBLE PRECISION slDA2P + + DOUBLE PRECISION SDECZ,CDECZ,DENOM + + + + SDECZ=SIN(DECZ) + CDECZ=COS(DECZ) + + DENOM=CDECZ-ETA*SDECZ + + RA=slDA2P(ATAN2(XI,DENOM)+RAZ) + DEC=ATAN2(SDECZ+ETA*CDECZ,SQRT(XI*XI+DENOM*DENOM)) + + END diff --git a/math/slalib/dtp2v.f b/math/slalib/dtp2v.f new file mode 100644 index 00000000..077df7a8 --- /dev/null +++ b/math/slalib/dtp2v.f @@ -0,0 +1,74 @@ + SUBROUTINE slDTPV (XI, ETA, V0, V) +*+ +* - - - - - - +* D T P V +* - - - - - - +* +* Given the tangent-plane coordinates of a star and the direction +* cosines of the tangent point, determine the direction cosines +* of the star. +* +* (double precision) +* +* Given: +* XI,ETA d tangent plane coordinates of star +* V0 d(3) direction cosines of tangent point +* +* Returned: +* V d(3) direction cosines of star +* +* Notes: +* +* 1 If vector V0 is not of unit length, the returned vector V will +* be wrong. +* +* 2 If vector V0 points at a pole, the returned vector V will be +* based on the arbitrary assumption that the RA of the tangent +* point is zero. +* +* 3 This routine is the Cartesian equivalent of the routine slDTPS. +* +* P.T.Wallace Starlink 11 February 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION XI,ETA,V0(3),V(3) + + DOUBLE PRECISION X,Y,Z,F,R + + + X=V0(1) + Y=V0(2) + Z=V0(3) + F=SQRT(1D0+XI*XI+ETA*ETA) + R=SQRT(X*X+Y*Y) + IF (R.EQ.0D0) THEN + R=1D-20 + X=R + END IF + V(1)=(X-(XI*Y+ETA*X*Z)/R)/F + V(2)=(Y+(XI*X-ETA*Y*Z)/R)/F + V(3)=(Z+ETA*R)/F + + END diff --git a/math/slalib/dtps2c.f b/math/slalib/dtps2c.f new file mode 100644 index 00000000..ce103804 --- /dev/null +++ b/math/slalib/dtps2c.f @@ -0,0 +1,109 @@ + SUBROUTINE slDPSC (XI, ETA, RA, DEC, RAZ1, DECZ1, + : RAZ2, DECZ2, N) +*+ +* - - - - - - - +* D P S C +* - - - - - - - +* +* From the tangent plane coordinates of a star of known RA,Dec, +* determine the RA,Dec of the tangent point. +* +* (double precision) +* +* Given: +* XI,ETA d tangent plane rectangular coordinates +* RA,DEC d spherical coordinates +* +* Returned: +* RAZ1,DECZ1 d spherical coordinates of tangent point, solution 1 +* RAZ2,DECZ2 d spherical coordinates of tangent point, solution 2 +* N i number of solutions: +* 0 = no solutions returned (note 2) +* 1 = only the first solution is useful (note 3) +* 2 = both solutions are useful (note 3) +* +* Notes: +* +* 1 The RAZ1 and RAZ2 values are returned in the range 0-2pi. +* +* 2 Cases where there is no solution can only arise near the poles. +* For example, it is clearly impossible for a star at the pole +* itself to have a non-zero XI value, and hence it is +* meaningless to ask where the tangent point would have to be +* to bring about this combination of XI and DEC. +* +* 3 Also near the poles, cases can arise where there are two useful +* solutions. The argument N indicates whether the second of the +* two solutions returned is useful. N=1 indicates only one useful +* solution, the usual case; under these circumstances, the second +* solution corresponds to the "over-the-pole" case, and this is +* reflected in the values of RAZ2 and DECZ2 which are returned. +* +* 4 The DECZ1 and DECZ2 values are returned in the range +/-pi, but +* in the usual, non-pole-crossing, case, the range is +/-pi/2. +* +* 5 This routine is the spherical equivalent of the routine slDPVC. +* +* Called: slDA2P +* +* P.T.Wallace Starlink 5 June 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION XI,ETA,RA,DEC,RAZ1,DECZ1,RAZ2,DECZ2 + INTEGER N + + DOUBLE PRECISION X2,Y2,SD,CD,SDF,R2,R,S,C + + DOUBLE PRECISION slDA2P + + + X2=XI*XI + Y2=ETA*ETA + SD=SIN(DEC) + CD=COS(DEC) + SDF=SD*SQRT(1D0+X2+Y2) + R2=CD*CD*(1D0+Y2)-SD*SD*X2 + IF (R2.GE.0D0) THEN + R=SQRT(R2) + S=SDF-ETA*R + C=SDF*ETA+R + IF (XI.EQ.0D0.AND.R.EQ.0D0) R=1D0 + RAZ1=slDA2P(RA-ATAN2(XI,R)) + DECZ1=ATAN2(S,C) + R=-R + S=SDF-ETA*R + C=SDF*ETA+R + RAZ2=slDA2P(RA-ATAN2(XI,R)) + DECZ2=ATAN2(S,C) + IF (ABS(SDF).LT.1D0) THEN + N=1 + ELSE + N=2 + END IF + ELSE + N=0 + END IF + + END diff --git a/math/slalib/dtpv2c.f b/math/slalib/dtpv2c.f new file mode 100644 index 00000000..930ca9ff --- /dev/null +++ b/math/slalib/dtpv2c.f @@ -0,0 +1,101 @@ + SUBROUTINE slDPVC (XI, ETA, V, V01, V02, N) +*+ +* - - - - - - - +* D P V C +* - - - - - - - +* +* Given the tangent-plane coordinates of a star and its direction +* cosines, determine the direction cosines of the tangent-point. +* +* (double precision) +* +* Given: +* XI,ETA d tangent plane coordinates of star +* V d(3) direction cosines of star +* +* Returned: +* V01 d(3) direction cosines of tangent point, solution 1 +* V02 d(3) direction cosines of tangent point, solution 2 +* N i number of solutions: +* 0 = no solutions returned (note 2) +* 1 = only the first solution is useful (note 3) +* 2 = both solutions are useful (note 3) +* +* Notes: +* +* 1 The vector V must be of unit length or the result will be wrong. +* +* 2 Cases where there is no solution can only arise near the poles. +* For example, it is clearly impossible for a star at the pole +* itself to have a non-zero XI value, and hence it is meaningless +* to ask where the tangent point would have to be. +* +* 3 Also near the poles, cases can arise where there are two useful +* solutions. The argument N indicates whether the second of the +* two solutions returned is useful. N=1 indicates only one useful +* solution, the usual case; under these circumstances, the second +* solution can be regarded as valid if the vector V02 is interpreted +* as the "over-the-pole" case. +* +* 4 This routine is the Cartesian equivalent of the routine slDPSC. +* +* P.T.Wallace Starlink 5 June 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION XI,ETA,V(3),V01(3),V02(3) + INTEGER N + + DOUBLE PRECISION X,Y,Z,RXY2,XI2,ETA2P1,SDF,R2,R,C + + + X=V(1) + Y=V(2) + Z=V(3) + RXY2=X*X+Y*Y + XI2=XI*XI + ETA2P1=ETA*ETA+1D0 + SDF=Z*SQRT(XI2+ETA2P1) + R2=RXY2*ETA2P1-Z*Z*XI2 + IF (R2.GT.0D0) THEN + R=SQRT(R2) + C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2))) + V01(1)=C*(X*R+Y*XI) + V01(2)=C*(Y*R-X*XI) + V01(3)=(SDF-ETA*R)/ETA2P1 + R=-R + C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2))) + V02(1)=C*(X*R+Y*XI) + V02(2)=C*(Y*R-X*XI) + V02(3)=(SDF-ETA*R)/ETA2P1 + IF (ABS(SDF).LT.1D0) THEN + N=1 + ELSE + N=2 + END IF + ELSE + N=0 + END IF + + END diff --git a/math/slalib/dtt.f b/math/slalib/dtt.f new file mode 100644 index 00000000..38e10ec8 --- /dev/null +++ b/math/slalib/dtt.f @@ -0,0 +1,64 @@ + DOUBLE PRECISION FUNCTION slDTT (UTC) +*+ +* - - - - +* D T T +* - - - - +* +* Increment to be applied to Coordinated Universal Time UTC to give +* Terrestrial Time TT (formerly Ephemeris Time ET) +* +* (double precision) +* +* Given: +* UTC d UTC date as a modified JD (JD-2400000.5) +* +* Result: TT-UTC in seconds +* +* Notes: +* +* 1 The UTC is specified to be a date rather than a time to indicate +* that care needs to be taken not to specify an instant which lies +* within a leap second. Though in most cases UTC can include the +* fractional part, correct behaviour on the day of a leap second +* can only be guaranteed up to the end of the second 23:59:59. +* +* 2 Pre 1972 January 1 a fixed value of 10 + ET-TAI is returned. +* +* 3 See also the routine slDT, which roughly estimates ET-UT for +* historical epochs. +* +* Called: slDAT +* +* P.T.Wallace Starlink 6 December 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION UTC + + DOUBLE PRECISION slDAT + + + slDTT=32.184D0+slDAT(UTC) + + END diff --git a/math/slalib/dv2tp.f b/math/slalib/dv2tp.f new file mode 100644 index 00000000..5d55f7f6 --- /dev/null +++ b/math/slalib/dv2tp.f @@ -0,0 +1,96 @@ + SUBROUTINE slDVTP (V, V0, XI, ETA, J) +*+ +* - - - - - - +* D V T P +* - - - - - - +* +* Given the direction cosines of a star and of the tangent point, +* determine the star's tangent-plane coordinates. +* +* (double precision) +* +* Given: +* V d(3) direction cosines of star +* V0 d(3) direction cosines of tangent point +* +* Returned: +* XI,ETA d tangent plane coordinates of star +* J i status: 0 = OK +* 1 = error, star too far from axis +* 2 = error, antistar on tangent plane +* 3 = error, antistar too far from axis +* +* Notes: +* +* 1 If vector V0 is not of unit length, or if vector V is of zero +* length, the results will be wrong. +* +* 2 If V0 points at a pole, the returned XI,ETA will be based on the +* arbitrary assumption that the RA of the tangent point is zero. +* +* 3 This routine is the Cartesian equivalent of the routine slDSTP. +* +* P.T.Wallace Starlink 27 November 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V(3),V0(3),XI,ETA + INTEGER J + + DOUBLE PRECISION X,Y,Z,X0,Y0,Z0,R2,R,W,D + + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-6) + + + X=V(1) + Y=V(2) + Z=V(3) + X0=V0(1) + Y0=V0(2) + Z0=V0(3) + R2=X0*X0+Y0*Y0 + R=SQRT(R2) + IF (R.EQ.0D0) THEN + R=1D-20 + X0=R + END IF + W=X*X0+Y*Y0 + D=W+Z*Z0 + IF (D.GT.TINY) THEN + J=0 + ELSE IF (D.GE.0D0) THEN + J=1 + D=TINY + ELSE IF (D.GT.-TINY) THEN + J=2 + D=-TINY + ELSE + J=3 + END IF + D=D*R + XI=(Y*X0-X*Y0)/D + ETA=(Z*R2-Z0*W)/D + + END diff --git a/math/slalib/dvdv.f b/math/slalib/dvdv.f new file mode 100644 index 00000000..b80d5877 --- /dev/null +++ b/math/slalib/dvdv.f @@ -0,0 +1,45 @@ + DOUBLE PRECISION FUNCTION slDVDV (VA, VB) +*+ +* - - - - - +* D V D V +* - - - - - +* +* Scalar product of two 3-vectors (double precision) +* +* Given: +* VA dp(3) first vector +* VB dp(3) second vector +* +* The result is the scalar product VA.VB (double precision) +* +* P.T.Wallace Starlink November 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION VA(3),VB(3) + + + slDVDV=VA(1)*VB(1)+VA(2)*VB(2)+VA(3)*VB(3) + + END diff --git a/math/slalib/dvn.f b/math/slalib/dvn.f new file mode 100644 index 00000000..68774c77 --- /dev/null +++ b/math/slalib/dvn.f @@ -0,0 +1,70 @@ + SUBROUTINE slDVN (V, UV, VM) +*+ +* - - - - +* D V N +* - - - - +* +* Normalizes a 3-vector also giving the modulus (double precision) +* +* Given: +* V d(3) vector +* +* Returned: +* UV d(3) unit vector in direction of V +* VM d modulus of V +* +* Notes: +* +* 1 If the modulus of V is zero, UV is set to zero as well. +* +* 2 To comply with the ANSI Fortran 77 standard, V and UV must be +* different arrays. However, the routine is coded so as to work +* properly on most platforms even if this rule is violated. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION V(3),UV(3),VM + + INTEGER I + DOUBLE PRECISION W1,W2 + + +* Modulus. + W1 = 0D0 + DO I=1,3 + W2 = V(I) + W1 = W1+W2*W2 + END DO + W1 = SQRT(W1) + VM = W1 + +* Normalize the vector. + IF (W1.LE.0D0) W1 = 1D0 + DO I=1,3 + UV(I) = V(I)/W1 + END DO + + END diff --git a/math/slalib/dvxv.f b/math/slalib/dvxv.f new file mode 100644 index 00000000..1c422fb7 --- /dev/null +++ b/math/slalib/dvxv.f @@ -0,0 +1,57 @@ + SUBROUTINE slDVXV (VA, VB, VC) +*+ +* - - - - - +* D V X V +* - - - - - +* +* Vector product of two 3-vectors (double precision) +* +* Given: +* VA dp(3) first vector +* VB dp(3) second vector +* +* Returned: +* VC dp(3) vector result +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION VA(3),VB(3),VC(3) + + DOUBLE PRECISION VW(3) + INTEGER I + + +* Form the vector product VA cross VB + VW(1)=VA(2)*VB(3)-VA(3)*VB(2) + VW(2)=VA(3)*VB(1)-VA(1)*VB(3) + VW(3)=VA(1)*VB(2)-VA(2)*VB(1) + +* Return the result + DO I=1,3 + VC(I)=VW(I) + END DO + + END diff --git a/math/slalib/e2h.f b/math/slalib/e2h.f new file mode 100644 index 00000000..3905bbb7 --- /dev/null +++ b/math/slalib/e2h.f @@ -0,0 +1,107 @@ + SUBROUTINE slE2H (HA, DEC, PHI, AZ, EL) +*+ +* - - - - +* E 2 H +* - - - - +* +* Equatorial to horizon coordinates: HA,Dec to Az,El +* +* (single precision) +* +* Given: +* HA r hour angle +* DEC r declination +* PHI r observatory latitude +* +* Returned: +* AZ r azimuth +* EL r elevation +* +* Notes: +* +* 1) All the arguments are angles in radians. +* +* 2) Azimuth is returned in the range 0-2pi; north is zero, +* and east is +pi/2. Elevation is returned in the range +* +/-pi/2. +* +* 3) The latitude must be geodetic. In critical applications, +* corrections for polar motion should be applied. +* +* 4) In some applications it will be important to specify the +* correct type of hour angle and declination in order to +* produce the required type of azimuth and elevation. In +* particular, it may be important to distinguish between +* elevation as affected by refraction, which would +* require the "observed" HA,Dec, and the elevation +* in vacuo, which would require the "topocentric" HA,Dec. +* If the effects of diurnal aberration can be neglected, the +* "apparent" HA,Dec may be used instead of the topocentric +* HA,Dec. +* +* 5) No range checking of arguments is carried out. +* +* 6) In applications which involve many such calculations, rather +* than calling the present routine it will be more efficient to +* use inline code, having previously computed fixed terms such +* as sine and cosine of latitude, and (for tracking a star) +* sine and cosine of declination. +* +* P.T.Wallace Starlink 9 July 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL HA,DEC,PHI,AZ,EL + + REAL R2PI + PARAMETER (R2PI=6.283185307179586476925286766559) + + REAL SH,CH,SD,CD,SP,CP,X,Y,Z,R,A + + +* Useful trig functions + SH=SIN(HA) + CH=COS(HA) + SD=SIN(DEC) + CD=COS(DEC) + SP=SIN(PHI) + CP=COS(PHI) + +* Az,El as x,y,z + X=-CH*CD*SP+SD*CP + Y=-SH*CD + Z=CH*CD*CP+SD*SP + +* To spherical + R=SQRT(X*X+Y*Y) + IF (R.EQ.0.0) THEN + A=0.0 + ELSE + A=ATAN2(Y,X) + END IF + IF (A.LT.0.0) A=A+R2PI + AZ=A + EL=ATAN2(Z,R) + + END diff --git a/math/slalib/earth.f b/math/slalib/earth.f new file mode 100644 index 00000000..5d2204af --- /dev/null +++ b/math/slalib/earth.f @@ -0,0 +1,130 @@ + SUBROUTINE slERTH (IY, ID, FD, PV) +*+ +* - - - - - - +* E R T H +* - - - - - - +* +* Approximate heliocentric position and velocity of the Earth +* +* Given: +* IY I year +* ID I day in year (1 = Jan 1st) +* FD R fraction of day +* +* Returned: +* PV R(6) Earth position & velocity vector +* +* Notes: +* +* 1 The date and time is TDB (loosely ET) in a Julian calendar +* which has been aligned to the ordinary Gregorian +* calendar for the interval 1900 March 1 to 2100 February 28. +* The year and day can be obtained by calling slCAYD or +* slCLYD. +* +* 2 The Earth heliocentric 6-vector is mean equator and equinox +* of date. Position part, PV(1-3), is in AU; velocity part, +* PV(4-6), is in AU/sec. +* +* 3 Max/RMS errors 1950-2050: +* 13/5 E-5 AU = 19200/7600 km in position +* 47/26 E-10 AU/s = 0.0070/0.0039 km/s in speed +* +* 4 More accurate results are obtainable with the routines slEVP +* and slEPV. +* +* Last revision: 5 April 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,ID + REAL FD,PV(6) + + INTEGER IY4 + REAL TWOPI,SPEED,REMB,SEMB,YI,YF,T,ELM,GAMMA,EM,ELT,EPS0, + : E,ESQ,V,R,ELMM,COSELT,SINEPS,COSEPS,W1,W2,SELMM,CELMM + + PARAMETER (TWOPI=6.28318530718) + +* Mean orbital speed of Earth, AU/s + PARAMETER (SPEED=1.9913E-7) + +* Mean Earth:EMB distance and speed, AU and AU/s + PARAMETER (REMB=3.12E-5,SEMB=8.31E-11) + + + +* Whole years & fraction of year, and years since J1900.0 + YI=FLOAT(IY-1900) + IY4=MOD(MOD(IY,4)+4,4) + YF=(FLOAT(4*(ID-1/(IY4+1))-IY4-2)+4.0*FD)/1461.0 + T=YI+YF + +* Geometric mean longitude of Sun +* (cf 4.881627938+6.283319509911*T MOD 2PI) + ELM=MOD(4.881628+TWOPI*YF+0.00013420*T,TWOPI) + +* Mean longitude of perihelion + GAMMA=4.908230+3.0005E-4*T + +* Mean anomaly + EM=ELM-GAMMA + +* Mean obliquity + EPS0=0.40931975-2.27E-6*T + +* Eccentricity + E=0.016751-4.2E-7*T + ESQ=E*E + +* True anomaly + V=EM+2.0*E*SIN(EM)+1.25*ESQ*SIN(2.0*EM) + +* True ecliptic longitude + ELT=V+GAMMA + +* True distance + R=(1.0-ESQ)/(1.0+E*COS(V)) + +* Moon's mean longitude + ELMM=MOD(4.72+83.9971*T,TWOPI) + +* Useful functions + COSELT=COS(ELT) + SINEPS=SIN(EPS0) + COSEPS=COS(EPS0) + W1=-R*SIN(ELT) + W2=-SPEED*(COSELT+E*COS(GAMMA)) + SELMM=SIN(ELMM) + CELMM=COS(ELMM) + +* Earth position and velocity + PV(1)=-R*COSELT-REMB*CELMM + PV(2)=(W1-REMB*SELMM)*COSEPS + PV(3)=W1*SINEPS + PV(4)=SPEED*(SIN(ELT)+E*SIN(GAMMA))+SEMB*SELMM + PV(5)=(W2-SEMB*CELMM)*COSEPS + PV(6)=W2*SINEPS + + END diff --git a/math/slalib/ecleq.f b/math/slalib/ecleq.f new file mode 100644 index 00000000..9c7d8ed3 --- /dev/null +++ b/math/slalib/ecleq.f @@ -0,0 +1,73 @@ + SUBROUTINE slECEQ (DL, DB, DATE, DR, DD) +*+ +* - - - - - - +* E C E Q +* - - - - - - +* +* Transformation from ecliptic coordinates to +* J2000.0 equatorial coordinates (double precision) +* +* Given: +* DL,DB dp ecliptic longitude and latitude +* (mean of date, IAU 1980 theory, radians) +* DATE dp TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* Returned: +* DR,DD dp J2000.0 mean RA,Dec (radians) +* +* Called: +* slDS2C, slECMA, slDIMV, slPREC, slEPJ, slDC2S, +* slDA2P, slDA1P +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DL,DB,DATE,DR,DD + + DOUBLE PRECISION slEPJ,slDA2P,slDA1P + + DOUBLE PRECISION RMAT(3,3),V1(3),V2(3) + + + +* Spherical to Cartesian + CALL slDS2C(DL,DB,V1) + +* Ecliptic to equatorial + CALL slECMA(DATE,RMAT) + CALL slDIMV(RMAT,V1,V2) + +* Mean of date to J2000 + CALL slPREC(2000D0,slEPJ(DATE),RMAT) + CALL slDIMV(RMAT,V2,V1) + +* Cartesian to spherical + CALL slDC2S(V1,DR,DD) + +* Express in conventional ranges + DR=slDA2P(DR) + DD=slDA1P(DD) + + END diff --git a/math/slalib/ecmat.f b/math/slalib/ecmat.f new file mode 100644 index 00000000..8213dd8f --- /dev/null +++ b/math/slalib/ecmat.f @@ -0,0 +1,70 @@ + SUBROUTINE slECMA (DATE, RMAT) +*+ +* - - - - - - +* E C M A +* - - - - - - +* +* Form the equatorial to ecliptic rotation matrix - IAU 1980 theory +* (double precision) +* +* Given: +* DATE dp TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* Returned: +* RMAT dp(3,3) matrix +* +* Reference: +* Murray,C.A., Vectorial Astrometry, section 4.3. +* +* Note: +* The matrix is in the sense V(ecl) = RMAT * V(equ); the +* equator, equinox and ecliptic are mean of date. +* +* Called: slDEUL +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,RMAT(3,3) + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION T,EPS0 + + + +* Interval between basic epoch J2000.0 and current epoch (JC) + T = (DATE-51544.5D0)/36525D0 + +* Mean obliquity + EPS0 = AS2R* + : (84381.448D0+(-46.8150D0+(-0.00059D0+0.001813D0*T)*T)*T) + +* Matrix + CALL slDEUL('X',EPS0,0D0,0D0,RMAT) + + END diff --git a/math/slalib/ecor.f b/math/slalib/ecor.f new file mode 100644 index 00000000..5405bc7d --- /dev/null +++ b/math/slalib/ecor.f @@ -0,0 +1,96 @@ + SUBROUTINE slECOR (RM, DM, IY, ID, FD, RV, TL) +*+ +* - - - - - +* E C O R +* - - - - - +* +* Component of Earth orbit velocity and heliocentric +* light time in a given direction (single precision) +* +* Given: +* RM,DM real mean RA, Dec of date (radians) +* IY int year +* ID int day in year (1 = Jan 1st) +* FD real fraction of day +* +* Returned: +* RV real component of Earth orbital velocity (km/sec) +* TL real component of heliocentric light time (sec) +* +* Notes: +* +* 1 The date and time is TDB (loosely ET) in a Julian calendar +* which has been aligned to the ordinary Gregorian +* calendar for the interval 1900 March 1 to 2100 February 28. +* The year and day can be obtained by calling slCAYD or +* slCLYD. +* +* 2 Sign convention: +* +* The velocity component is +ve when the Earth is receding from +* the given point on the sky. The light time component is +ve +* when the Earth lies between the Sun and the given point on +* the sky. +* +* 3 Accuracy: +* +* The velocity component is usually within 0.004 km/s of the +* correct value and is never in error by more than 0.007 km/s. +* The error in light time correction is about 0.03s at worst, +* but is usually better than 0.01s. For applications requiring +* higher accuracy, see the slEVP and slEPV routines. +* +* Called: slERTH, slCS2C, slVDV +* +* Last revision: 5 April 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL RM,DM + INTEGER IY,ID + REAL FD,RV,TL + + REAL slVDV + + REAL PV(6),V(3),AUKM,AUSEC + +* AU to km and light sec (1985 Almanac) + PARAMETER (AUKM=1.4959787066E8, + : AUSEC=499.0047837) + + + +* Sun:Earth position & velocity vector + CALL slERTH(IY,ID,FD,PV) + +* Star position vector + CALL slCS2C(RM,DM,V) + +* Velocity component + RV=-AUKM*slVDV(PV(4),V) + +* Light time component + TL=AUSEC*slVDV(PV(1),V) + + END diff --git a/math/slalib/eg50.f b/math/slalib/eg50.f new file mode 100644 index 00000000..85b65811 --- /dev/null +++ b/math/slalib/eg50.f @@ -0,0 +1,108 @@ + SUBROUTINE slEG50 (DR, DD, DL, DB) +*+ +* - - - - - +* E G 5 0 +* - - - - - +* +* Transformation from B1950.0 'FK4' equatorial coordinates to +* IAU 1958 galactic coordinates (double precision) +* +* Given: +* DR,DD dp B1950.0 'FK4' RA,Dec +* +* Returned: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDMXV, slDC2S, slSUET, slDA2P, slDA1P +* +* Note: +* The equatorial coordinates are B1950.0 'FK4'. Use the +* routine slEQGA if conversion from J2000.0 coordinates +* is required. +* +* Reference: +* Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) +* +* P.T.Wallace Starlink 5 September 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DR,DD,DL,DB + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3),R,D + +* +* L2,B2 system of galactic coordinates +* +* P = 192.25 RA of galactic north pole (mean B1950.0) +* Q = 62.6 inclination of galactic to mean B1950.0 equator +* R = 33 longitude of ascending node +* +* P,Q,R are degrees +* +* +* Equatorial to galactic rotation matrix +* +* The Euler angles are P, Q, 90-R, about the z then y then +* z axes. +* +* +CP.CQ.SR-SP.CR +SP.CQ.SR+CP.CR -SQ.SR +* +* -CP.CQ.CR-SP.SR -SP.CQ.CR+CP.SR +SQ.CR +* +* +CP.SQ +SP.SQ +CQ +* + + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3) / + : -0.066988739415D0,-0.872755765852D0,-0.483538914632D0, + : +0.492728466075D0,-0.450346958020D0,+0.744584633283D0, + : -0.867600811151D0,-0.188374601723D0,+0.460199784784D0 / + + + +* Remove E-terms + CALL slSUET(DR,DD,1950D0,R,D) + +* Spherical to Cartesian + CALL slDS2C(R,D,V1) + +* Rotate to galactic + CALL slDMXV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,DL,DB) + +* Express angles in conventional ranges + DL=slDA2P(DL) + DB=slDA1P(DB) + + END diff --git a/math/slalib/el2ue.f b/math/slalib/el2ue.f new file mode 100644 index 00000000..4edb620a --- /dev/null +++ b/math/slalib/el2ue.f @@ -0,0 +1,329 @@ + SUBROUTINE slELUE (DATE, JFORM, EPOCH, ORBINC, ANODE, + : PERIH, AORQ, E, AORL, DM, + : U, JSTAT) +*+ +* - - - - - - +* E L U E +* - - - - - - +* +* Transform conventional osculating orbital elements into "universal" +* form. +* +* Given: +* DATE d epoch (TT MJD) of osculation (Note 3) +* JFORM i choice of element set (1-3, Note 6) +* EPOCH d epoch (TT MJD) of the elements +* ORBINC d inclination (radians) +* ANODE d longitude of the ascending node (radians) +* PERIH d longitude or argument of perihelion (radians) +* AORQ d mean distance or perihelion distance (AU) +* E d eccentricity +* AORL d mean anomaly or longitude (radians, JFORM=1,2 only) +* DM d daily motion (radians, JFORM=1 only) +* +* Returned: +* U d(13) universal orbital elements (Note 1) +* +* (1) combined mass (M+m) +* (2) total energy of the orbit (alpha) +* (3) reference (osculating) epoch (t0) +* (4-6) position at reference epoch (r0) +* (7-9) velocity at reference epoch (v0) +* (10) heliocentric distance at reference epoch +* (11) r0.v0 +* (12) date (t) +* (13) universal eccentric anomaly (psi) of date, approx +* +* JSTAT i status: 0 = OK +* -1 = illegal JFORM +* -2 = illegal E +* -3 = illegal AORQ +* -4 = illegal DM +* -5 = numerical error +* +* Called: slUEPV, slPVUE +* +* Notes +* +* 1 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* 2 The companion routine is slUEPV. This takes the set of numbers +* that the present routine outputs and uses them to derive the +* object's position and velocity. A single prediction requires one +* call to the present routine followed by one call to slUEPV; +* for convenience, the two calls are packaged as the routine +* slPLNE. Multiple predictions may be made by again calling the +* present routine once, but then calling slUEPV multiple times, +* which is faster than multiple calls to slPLNE. +* +* 3 DATE is the epoch of osculation. It is in the TT timescale +* (formerly Ephemeris Time, ET) and is a Modified Julian Date +* (JD-2400000.5). +* +* 4 The supplied orbital elements are with respect to the J2000 +* ecliptic and equinox. The position and velocity parameters +* returned in the array U are with respect to the mean equator and +* equinox of epoch J2000, and are for the perihelion prior to the +* specified epoch. +* +* 5 The universal elements returned in the array U are in canonical +* units (solar masses, AU and canonical days). +* +* 6 Three different element-format options are available: +* +* Option JFORM=1, suitable for the major planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = longitude of perihelion, curly pi (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean longitude L (radians) +* DM = daily motion (radians) +* +* Option JFORM=2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean anomaly M (radians) +* +* Option JFORM=3, suitable for comets: +* +* EPOCH = epoch of perihelion (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e (range 0 to 10) +* +* 7 Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are +* not accessed. +* +* 8 The algorithm was originally adapted from the EPHSLA program of +* D.H.P.Jones (private communication, 1996). The method is based +* on Stumpff's Universal Variables. +* +* Reference: Everhart & Pitkin, Am.J.Phys. 51, 712 (1983). +* +* Last revision: 8 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + INTEGER JFORM + DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,U(13) + INTEGER JSTAT + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Sin and cos of J2000 mean obliquity (IAU 1976) + DOUBLE PRECISION SE,CE + PARAMETER (SE=0.3977771559319137D0, + : CE=0.9174820620691818D0) + + INTEGER J + + DOUBLE PRECISION PHT,ARGPH,Q,W,CM,ALPHA,PHS,SW,CW,SI,CI,SO,CO, + : X,Y,Z,PX,PY,PZ,VX,VY,VZ,DT,FC,FP,PSI, + : UL(13),PV(6) + + + +* Validate arguments. + IF (JFORM.LT.1.OR.JFORM.GT.3) THEN + JSTAT = -1 + GO TO 9999 + END IF + IF (E.LT.0D0.OR.E.GT.10D0.OR.(E.GE.1D0.AND.JFORM.NE.3)) THEN + JSTAT = -2 + GO TO 9999 + END IF + IF (AORQ.LE.0D0) THEN + JSTAT = -3 + GO TO 9999 + END IF + IF (JFORM.EQ.1.AND.DM.LE.0D0) THEN + JSTAT = -4 + GO TO 9999 + END IF + +* +* Transform elements into standard form: +* +* PHT = epoch of perihelion passage +* ARGPH = argument of perihelion (little omega) +* Q = perihelion distance (q) +* CM = combined mass, M+m (mu) + + IF (JFORM.EQ.1) THEN + +* Major planet. + PHT = EPOCH-(AORL-PERIH)/DM + ARGPH = PERIH-ANODE + Q = AORQ*(1D0-E) + W = DM/GCON + CM = W*W*AORQ*AORQ*AORQ + + ELSE IF (JFORM.EQ.2) THEN + +* Minor planet. + PHT = EPOCH-AORL*SQRT(AORQ*AORQ*AORQ)/GCON + ARGPH = PERIH + Q = AORQ*(1D0-E) + CM = 1D0 + + ELSE + +* Comet. + PHT = EPOCH + ARGPH = PERIH + Q = AORQ + CM = 1D0 + + END IF + +* The universal variable alpha. This is proportional to the total +* energy of the orbit: -ve for an ellipse, zero for a parabola, +* +ve for a hyperbola. + + ALPHA = CM*(E-1D0)/Q + +* Speed at perihelion. + + PHS = SQRT(ALPHA+2D0*CM/Q) + +* In a Cartesian coordinate system which has the x-axis pointing +* to perihelion and the z-axis normal to the orbit (such that the +* object orbits counter-clockwise as seen from +ve z), the +* perihelion position and velocity vectors are: +* +* position [Q,0,0] +* velocity [0,PHS,0] +* +* To express the results in J2000 equatorial coordinates we make a +* series of four rotations of the Cartesian axes: +* +* axis Euler angle +* +* 1 z argument of perihelion (little omega) +* 2 x inclination (i) +* 3 z longitude of the ascending node (big omega) +* 4 x J2000 obliquity (epsilon) +* +* In each case the rotation is clockwise as seen from the +ve end of +* the axis concerned. + +* Functions of the Euler angles. + SW = SIN(ARGPH) + CW = COS(ARGPH) + SI = SIN(ORBINC) + CI = COS(ORBINC) + SO = SIN(ANODE) + CO = COS(ANODE) + +* Position at perihelion (AU). + X = Q*CW + Y = Q*SW + Z = Y*SI + Y = Y*CI + PX = X*CO-Y*SO + Y = X*SO+Y*CO + PY = Y*CE-Z*SE + PZ = Y*SE+Z*CE + +* Velocity at perihelion (AU per canonical day). + X = -PHS*SW + Y = PHS*CW + Z = Y*SI + Y = Y*CI + VX = X*CO-Y*SO + Y = X*SO+Y*CO + VY = Y*CE-Z*SE + VZ = Y*SE+Z*CE + +* Time from perihelion to date (in Canonical Days: a canonical day +* is 58.1324409... days, defined as 1/GCON). + + DT = (DATE-PHT)*GCON + +* First approximation to the Universal Eccentric Anomaly, PSI, +* based on the circle (FC) and parabola (FP) values. + + FC = DT/Q + W = (3D0*DT+SQRT(9D0*DT*DT+8D0*Q*Q*Q))**(1D0/3D0) + FP = W-2D0*Q/W + PSI = (1D0-E)*FC+E*FP + +* Assemble local copy of element set. + UL(1) = CM + UL(2) = ALPHA + UL(3) = PHT + UL(4) = PX + UL(5) = PY + UL(6) = PZ + UL(7) = VX + UL(8) = VY + UL(9) = VZ + UL(10) = Q + UL(11) = 0D0 + UL(12) = DATE + UL(13) = PSI + +* Predict position+velocity at epoch of osculation. + CALL slUEPV(DATE,UL,PV,J) + IF (J.NE.0) GO TO 9010 + +* Convert back to universal elements. + CALL slPVUE(PV,DATE,CM-1D0,U,J) + IF (J.NE.0) GO TO 9010 + +* OK exit. + JSTAT = 0 + GO TO 9999 + +* Quasi-impossible numerical errors. + 9010 CONTINUE + JSTAT = -5 + + 9999 CONTINUE + END diff --git a/math/slalib/epb.f b/math/slalib/epb.f new file mode 100644 index 00000000..8b492e27 --- /dev/null +++ b/math/slalib/epb.f @@ -0,0 +1,48 @@ + DOUBLE PRECISION FUNCTION slEPB (DATE) +*+ +* - - - - +* E P B +* - - - - +* +* Conversion of Modified Julian Date to Besselian Epoch +* (double precision) +* +* Given: +* DATE dp Modified Julian Date (JD - 2400000.5) +* +* The result is the Besselian Epoch. +* +* Reference: +* Lieske,J.H., 1979. Astron.Astrophys.,73,282. +* +* P.T.Wallace Starlink February 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + + + slEPB = 1900D0 + (DATE-15019.81352D0)/365.242198781D0 + + END diff --git a/math/slalib/epb2d.f b/math/slalib/epb2d.f new file mode 100644 index 00000000..e430c7fc --- /dev/null +++ b/math/slalib/epb2d.f @@ -0,0 +1,48 @@ + DOUBLE PRECISION FUNCTION slEB2D (EPB) +*+ +* - - - - - - +* E B 2 D +* - - - - - - +* +* Conversion of Besselian Epoch to Modified Julian Date +* (double precision) +* +* Given: +* EPB dp Besselian Epoch +* +* The result is the Modified Julian Date (JD - 2400000.5). +* +* Reference: +* Lieske,J.H., 1979. Astron.Astrophys.,73,282. +* +* P.T.Wallace Starlink February 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EPB + + + slEB2D = 15019.81352D0 + (EPB-1900D0)*365.242198781D0 + + END diff --git a/math/slalib/epco.f b/math/slalib/epco.f new file mode 100644 index 00000000..fd6862bf --- /dev/null +++ b/math/slalib/epco.f @@ -0,0 +1,69 @@ + DOUBLE PRECISION FUNCTION slEPCO (K0, K, E) +*+ +* - - - - - +* E P C O +* - - - - - +* +* Convert an epoch into the appropriate form - 'B' or 'J' +* +* Given: +* K0 char form of result: 'B'=Besselian, 'J'=Julian +* K char form of given epoch: 'B' or 'J' +* E dp epoch +* +* Called: slEPB, slEJ2D, slEPJ, slEB2D +* +* Notes: +* +* 1) The result is always either equal to or very close to +* the given epoch E. The routine is required only in +* applications where punctilious treatment of heterogeneous +* mixtures of star positions is necessary. +* +* 2) K0 and K are not validated. They are interpreted as follows: +* +* o If K0 and K are the same the result is E. +* o If K0 is 'B' or 'b' and K isn't, the conversion is J to B. +* o In all other cases, the conversion is B to J. +* +* Note that K0 and K won't match if their cases differ. +* +* P.T.Wallace Starlink 5 September 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) K0,K + DOUBLE PRECISION E + DOUBLE PRECISION slEPB,slEJ2D,slEPJ,slEB2D + + + IF (K.EQ.K0) THEN + slEPCO=E + ELSE IF (K0.EQ.'B'.OR.K0.EQ.'b') THEN + slEPCO=slEPB(slEJ2D(E)) + ELSE + slEPCO=slEPJ(slEB2D(E)) + END IF + + END diff --git a/math/slalib/epj.f b/math/slalib/epj.f new file mode 100644 index 00000000..cc8943db --- /dev/null +++ b/math/slalib/epj.f @@ -0,0 +1,47 @@ + DOUBLE PRECISION FUNCTION slEPJ (DATE) +*+ +* - - - - +* E P J +* - - - - +* +* Conversion of Modified Julian Date to Julian Epoch (double precision) +* +* Given: +* DATE dp Modified Julian Date (JD - 2400000.5) +* +* The result is the Julian Epoch. +* +* Reference: +* Lieske,J.H., 1979. Astron.Astrophys.,73,282. +* +* P.T.Wallace Starlink February 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + + + slEPJ = 2000D0 + (DATE-51544.5D0)/365.25D0 + + END diff --git a/math/slalib/epj2d.f b/math/slalib/epj2d.f new file mode 100644 index 00000000..9754194b --- /dev/null +++ b/math/slalib/epj2d.f @@ -0,0 +1,47 @@ + DOUBLE PRECISION FUNCTION slEJ2D (EPJ) +*+ +* - - - - - - +* E J 2 D +* - - - - - - +* +* Conversion of Julian Epoch to Modified Julian Date (double precision) +* +* Given: +* EPJ dp Julian Epoch +* +* The result is the Modified Julian Date (JD - 2400000.5). +* +* Reference: +* Lieske,J.H., 1979. Astron.Astrophys.,73,282. +* +* P.T.Wallace Starlink February 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EPJ + + + slEJ2D = 51544.5D0 + (EPJ-2000D0)*365.25D0 + + END diff --git a/math/slalib/epv.f b/math/slalib/epv.f new file mode 100644 index 00000000..dbea31b0 --- /dev/null +++ b/math/slalib/epv.f @@ -0,0 +1,2509 @@ + SUBROUTINE slEPV ( DATE, PH, VH, PB, VB ) +*+ +* - - - - +* E P V +* - - - - +* +* Earth position and velocity, heliocentric and barycentric, with +* respect to the Barycentric Celestial Reference System. +* +* Given: +* DATE d date, TDB Modified Julian Date (Note 1) +* +* Returned: +* PH d(3) heliocentric Earth position (AU) +* VH d(3) heliocentric Earth velocity (AU,AU/day) +* PB d(3) barycentric Earth position (AU) +* VB d(3) barycentric Earth velocity (AU/day) +* +* Notes: +* +* 1) The date is TDB as an MJD (=JD-2400000.5). TT can be used instead +* of TDB in most applications. +* +* 2) On return, the arrays PH, VH, PV, PB contain the following: +* +* PH(1) x } +* PH(2) y } heliocentric position, AU +* PH(3) z } +* +* VH(1) xdot } +* VH(2) ydot } heliocentric velocity, AU/d +* VH(3) zdot } +* +* PB(1) x } +* PB(2) y } barycentric position, AU +* PB(3) z } +* +* VB(1) xdot } +* VB(2) ydot } barycentric velocity, AU/d +* VB(3) zdot } +* +* The vectors are with respect to the Barycentric Celestial +* Reference System (BCRS); velocities are in AU per TDB day. +* +* 3) The routine is a SIMPLIFIED SOLUTION from the planetary theory +* VSOP2000 (X. Moisson, P. Bretagnon, 2001, Celes. Mechanics & +* Dyn. Astron., 80, 3/4, 205-213) and is an adaptation of original +* Fortran code supplied by P. Bretagnon (private comm., 2000). +* +* 4) Comparisons over the time span 1900-2100 with this simplified +* solution and the JPL DE405 ephemeris give the following results: +* +* RMS max +* Heliocentric: +* position error 3.7 11.2 km +* velocity error 1.4 5.0 mm/s +* +* Barycentric: +* position error 4.6 13.4 km +* velocity error 1.4 4.9 mm/s +* +* The results deteriorate outside this time span. +* +* 5) The routine slEVP is faster but less accurate. The present +* routine targets the case where high accuracy is more important +* than CPU time, yet the extra complication of reading a pre- +* computed ephemeris is not justified. +* +* Last revision: 7 April 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*----------------------------------------------------------------------- + + IMPLICIT NONE + + DOUBLE PRECISION DATE, PH(3), VH(3), PB(3), VB(3) + + DOUBLE PRECISION T, T2, XYZ, XYZD, A, B, C, CT, P, CP, + : HP(3), HV(3), BP(3), BV(3), X, Y, Z + + INTEGER I, J, K + +* Days per Julian year + DOUBLE PRECISION DJY + PARAMETER ( DJY = 365.25D0 ) + +* Reference epoch (J2000), MJD + DOUBLE PRECISION DJM0 + PARAMETER ( DJM0 = 51544.5D0 ) +* +* Matrix elements for orienting the analytical model to DE405/ICRF. +* +* The corresponding Euler angles are: +* +* d ' " +* 1st rotation - 23 26 21.4091 about the x-axis (obliquity) +* 2nd rotation + 0.0475 about the z-axis (RA offset) +* +* These were obtained empirically, by comparisons with DE405 over +* 1900-2100. +* + DOUBLE PRECISION AM12, AM13, AM21, AM22, AM23, AM32, AM33 + PARAMETER ( AM12 = +0.000000211284D0, + : AM13 = -0.000000091603D0, + : AM21 = -0.000000230286D0, + : AM22 = +0.917482137087D0, + : AM23 = -0.397776982902D0, + : AM32 = +0.397776982902D0, + : AM33 = +0.917482137087D0 ) + +* ---------------------- +* Ephemeris Coefficients +* ---------------------- +* +* The coefficients are stored in arrays of dimension (3,n,3). There +* are separate sets of arrays for (i) the Sun to Earth vector and +* (ii) the Solar-System barycenter to Sun vector. Each of these two +* sets contains separate arrays for the terms (n in number) in each +* power of time (in Julian years since J2000): T^0, T^1 and T^2. +* Within each array, all the Cartesian x-components, elements (i,j,1), +* appear first, followed by all the y-components, elements (i,j,2) and +* finally all the z-components, elements (i,j,3). At the lowest level +* are groups of three coefficients. The first coefficient in each +* group, element (1,j,k), is the amplitude of the term, the second, +* element (2,j,k), is the phase and the third, element (3,j,k), is the +* frequency. +* +* The naming scheme is such that a block +* +* DOUBLE PRECISION bn(3,Mbn,3) +* +* applies to body b and time exponent n: +* +* . b can be either E (Earth with respect to Sun) or S (Sun with +* respect to Solar-System Barycenter) +* +* . n can be 0, 1 or 2, for T^0, T^1 or T^2 +* +* For example, array E2(3,ME2,3) contains the coefficients for +* the T^2 terms for the Sun-to-Earth vector. +* +* There is no requirement for the X, Y and Z models for a particular +* block to use the same number of coefficients. The number actually +* used is parameterized, the number of terms being used called NbnX, +* NbnY, and NbnZ respectively. The parameter Mbn is the biggest of +* the three, and defines the array size. Unused elements are not +* initialized and are never accessed. +* + + INTEGER NE0(3), NE0X, NE0Y, NE0Z, ME0, + : NE1(3), NE1X, NE1Y, NE1Z, ME1, + : NE2(3), NE2X, NE2Y, NE2Z, ME2, + : NS0(3), NS0X, NS0Y, NS0Z, MS0, + : NS1(3), NS1X, NS1Y, NS1Z, MS1, + : NS2(3), NS2X, NS2Y, NS2Z, MS2 + + PARAMETER ( NE0X = 501, NE0Y = 501, NE0Z = 137, ME0 = NE0X, + : NE1X = 79, NE1Y = 80, NE1Z = 12, ME1 = NE1Y, + : NE2X = 5, NE2Y = 5, NE2Z = 3, ME2 = NE2X, + : NS0X = 212, NS0Y = 213, NS0Z = 69, MS0 = NS0Y, + : NS1X = 50, NS1Y = 50, NS1Z = 14, MS1 = NS1X, + : NS2X = 9, NS2Y = 9, NS2Z = 2, MS2 = NS2X ) + + DOUBLE PRECISION E0(3,ME0,3), E1(3,ME1,3), E2(3,ME2,3), + : S0(3,MS0,3), S1(3,MS1,3), S2(3,MS2,3) + + DATA NE0 / NE0X, NE0Y, NE0Z / + DATA NE1 / NE1X, NE1Y, NE1Z / + DATA NE2 / NE2X, NE2Y, NE2Z / + DATA NS0 / NS0X, NS0Y, NS0Z / + DATA NS1 / NS1X, NS1Y, NS1Z / + DATA NS2 / NS2X, NS2Y, NS2Z / + +* Sun-to-Earth, T^0, X + DATA ((E0(I,J,1),I=1,3),J= 1, 10) / + : 0.9998292878132D+00, 0.1753485171504D+01, 0.6283075850446D+01, + : 0.8352579567414D-02, 0.1710344404582D+01, 0.1256615170089D+02, + : 0.5611445335148D-02, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.1046664295572D-03, 0.1667225416770D+01, 0.1884922755134D+02, + : 0.3110842534677D-04, 0.6687513390251D+00, 0.8399684731857D+02, + : 0.2552413503550D-04, 0.5830637358413D+00, 0.5296909721118D+00, + : 0.2137207845781D-04, 0.1092330954011D+01, 0.1577343543434D+01, + : 0.1680240182951D-04, 0.4955366134987D+00, 0.6279552690824D+01, + : 0.1679012370795D-04, 0.6153014091901D+01, 0.6286599010068D+01, + : 0.1445526946777D-04, 0.3472744100492D+01, 0.2352866153506D+01 / + DATA ((E0(I,J,1),I=1,3),J= 11, 20) / + : 0.1091038246184D-04, 0.3689845786119D+01, 0.5223693906222D+01, + : 0.9344399733932D-05, 0.6073934645672D+01, 0.1203646072878D+02, + : 0.8993182910652D-05, 0.3175705249069D+01, 0.1021328554739D+02, + : 0.5665546034116D-05, 0.2152484672246D+01, 0.1059381944224D+01, + : 0.6844146703035D-05, 0.1306964099750D+01, 0.5753384878334D+01, + : 0.7346610905565D-05, 0.4354980070466D+01, 0.3981490189893D+00, + : 0.6815396474414D-05, 0.2218229211267D+01, 0.4705732307012D+01, + : 0.6112787253053D-05, 0.5384788425458D+01, 0.6812766822558D+01, + : 0.4518120711239D-05, 0.6087604012291D+01, 0.5884926831456D+01, + : 0.4521963430706D-05, 0.1279424524906D+01, 0.6256777527156D+01 / + DATA ((E0(I,J,1),I=1,3),J= 21, 30) / + : 0.4497426764085D-05, 0.5369129144266D+01, 0.6309374173736D+01, + : 0.4062190566959D-05, 0.5436473303367D+00, 0.6681224869435D+01, + : 0.5412193480192D-05, 0.7867838528395D+00, 0.7755226100720D+00, + : 0.5469839049386D-05, 0.1461440311134D+01, 0.1414349524433D+02, + : 0.5205264083477D-05, 0.4432944696116D+01, 0.7860419393880D+01, + : 0.2149759935455D-05, 0.4502237496846D+01, 0.1150676975667D+02, + : 0.2279109618501D-05, 0.1239441308815D+01, 0.7058598460518D+01, + : 0.2259282939683D-05, 0.3272430985331D+01, 0.4694002934110D+01, + : 0.2558950271319D-05, 0.2265471086404D+01, 0.1216800268190D+02, + : 0.2561581447555D-05, 0.1454740653245D+01, 0.7099330490126D+00 / + DATA ((E0(I,J,1),I=1,3),J= 31, 40) / + : 0.1781441115440D-05, 0.2962068630206D+01, 0.7962980379786D+00, + : 0.1612005874644D-05, 0.1473255041006D+01, 0.5486777812467D+01, + : 0.1818630667105D-05, 0.3743903293447D+00, 0.6283008715021D+01, + : 0.1818601377529D-05, 0.6274174354554D+01, 0.6283142985870D+01, + : 0.1554475925257D-05, 0.1624110906816D+01, 0.2513230340178D+02, + : 0.2090948029241D-05, 0.5852052276256D+01, 0.1179062909082D+02, + : 0.2000176345460D-05, 0.4072093298513D+01, 0.1778984560711D+02, + : 0.1289535917759D-05, 0.5217019331069D+01, 0.7079373888424D+01, + : 0.1281135307881D-05, 0.4802054538934D+01, 0.3738761453707D+01, + : 0.1518229005692D-05, 0.8691914742502D+00, 0.2132990797783D+00 / + DATA ((E0(I,J,1),I=1,3),J= 41, 50) / + : 0.9450128579027D-06, 0.4601859529950D+01, 0.1097707878456D+02, + : 0.7781119494996D-06, 0.1844352816694D+01, 0.8827390247185D+01, + : 0.7733407759912D-06, 0.3582790154750D+01, 0.5507553240374D+01, + : 0.7350644318120D-06, 0.2695277788230D+01, 0.1589072916335D+01, + : 0.6535928827023D-06, 0.3651327986142D+01, 0.1176985366291D+02, + : 0.6324624183656D-06, 0.2241302375862D+01, 0.6262300422539D+01, + : 0.6298565300557D-06, 0.4407122406081D+01, 0.6303851278352D+01, + : 0.8587037089179D-06, 0.3024307223119D+01, 0.1672837615881D+03, + : 0.8299954491035D-06, 0.6192539428237D+01, 0.3340612434717D+01, + : 0.6311263503401D-06, 0.2014758795416D+01, 0.7113454667900D-02 / + DATA ((E0(I,J,1),I=1,3),J= 51, 60) / + : 0.6005646745452D-06, 0.3399500503397D+01, 0.4136910472696D+01, + : 0.7917715109929D-06, 0.2493386877837D+01, 0.6069776770667D+01, + : 0.7556958099685D-06, 0.4159491740143D+01, 0.6496374930224D+01, + : 0.6773228244949D-06, 0.4034162934230D+01, 0.9437762937313D+01, + : 0.5370708577847D-06, 0.1562219163734D+01, 0.1194447056968D+01, + : 0.5710804266203D-06, 0.2662730803386D+01, 0.6282095334605D+01, + : 0.5709824583726D-06, 0.3985828430833D+01, 0.6284056366286D+01, + : 0.5143950896447D-06, 0.1308144688689D+01, 0.6290189305114D+01, + : 0.5088010604546D-06, 0.5352817214804D+01, 0.6275962395778D+01, + : 0.4960369085172D-06, 0.2644267922349D+01, 0.6127655567643D+01 / + DATA ((E0(I,J,1),I=1,3),J= 61, 70) / + : 0.4803137891183D-06, 0.4008844192080D+01, 0.6438496133249D+01, + : 0.5731747768225D-06, 0.3794550174597D+01, 0.3154687086868D+01, + : 0.4735947960579D-06, 0.6107118308982D+01, 0.3128388763578D+01, + : 0.4808348796625D-06, 0.4771458618163D+01, 0.8018209333619D+00, + : 0.4115073743137D-06, 0.3327111335159D+01, 0.8429241228195D+01, + : 0.5230575889287D-06, 0.5305708551694D+01, 0.1336797263425D+02, + : 0.5133977889215D-06, 0.5784230738814D+01, 0.1235285262111D+02, + : 0.5065815825327D-06, 0.2052064793679D+01, 0.1185621865188D+02, + : 0.4339831593868D-06, 0.3644994195830D+01, 0.1726015463500D+02, + : 0.3952928638953D-06, 0.4930376436758D+01, 0.5481254917084D+01 / + DATA ((E0(I,J,1),I=1,3),J= 71, 80) / + : 0.4898498111942D-06, 0.4542084219731D+00, 0.9225539266174D+01, + : 0.4757490209328D-06, 0.3161126388878D+01, 0.5856477690889D+01, + : 0.4727701669749D-06, 0.6214993845446D+00, 0.2544314396739D+01, + : 0.3800966681863D-06, 0.3040132339297D+01, 0.4265981595566D+00, + : 0.3257301077939D-06, 0.8064977360087D+00, 0.3930209696940D+01, + : 0.3255810528674D-06, 0.1974147981034D+01, 0.2146165377750D+01, + : 0.3252029748187D-06, 0.2845924913135D+01, 0.4164311961999D+01, + : 0.3255505635308D-06, 0.3017900824120D+01, 0.5088628793478D+01, + : 0.2801345211990D-06, 0.6109717793179D+01, 0.1256967486051D+02, + : 0.3688987740970D-06, 0.2911550235289D+01, 0.1807370494127D+02 / + DATA ((E0(I,J,1),I=1,3),J= 81, 90) / + : 0.2475153429458D-06, 0.2179146025856D+01, 0.2629832328990D-01, + : 0.3033457749150D-06, 0.1994161050744D+01, 0.4535059491685D+01, + : 0.2186743763110D-06, 0.5125687237936D+01, 0.1137170464392D+02, + : 0.2764777032774D-06, 0.4822646860252D+00, 0.1256262854127D+02, + : 0.2199028768592D-06, 0.4637633293831D+01, 0.1255903824622D+02, + : 0.2046482824760D-06, 0.1467038733093D+01, 0.7084896783808D+01, + : 0.2611209147507D-06, 0.3044718783485D+00, 0.7143069561767D+02, + : 0.2286079656818D-06, 0.4764220356805D+01, 0.8031092209206D+01, + : 0.1855071202587D-06, 0.3383637774428D+01, 0.1748016358760D+01, + : 0.2324669506784D-06, 0.6189088449251D+01, 0.1831953657923D+02 / + DATA ((E0(I,J,1),I=1,3),J= 91,100) / + : 0.1709528015688D-06, 0.5874966729774D+00, 0.4933208510675D+01, + : 0.2168156875828D-06, 0.4302994009132D+01, 0.1044738781244D+02, + : 0.2106675556535D-06, 0.3800475419891D+01, 0.7477522907414D+01, + : 0.1430213830465D-06, 0.1294660846502D+01, 0.2942463415728D+01, + : 0.1388396901944D-06, 0.4594797202114D+01, 0.8635942003952D+01, + : 0.1922258844190D-06, 0.4943044543591D+00, 0.1729818233119D+02, + : 0.1888460058292D-06, 0.2426943912028D+01, 0.1561374759853D+03, + : 0.1789449386107D-06, 0.1582973303499D+00, 0.1592596075957D+01, + : 0.1360803685374D-06, 0.5197240440504D+01, 0.1309584267300D+02, + : 0.1504038014709D-06, 0.3120360916217D+01, 0.1649636139783D+02 / + DATA ((E0(I,J,1),I=1,3),J=101,110) / + : 0.1382769533389D-06, 0.6164702888205D+01, 0.7632943190217D+01, + : 0.1438059769079D-06, 0.1437423770979D+01, 0.2042657109477D+02, + : 0.1326303260037D-06, 0.3609688799679D+01, 0.1213955354133D+02, + : 0.1159244950540D-06, 0.5463018167225D+01, 0.5331357529664D+01, + : 0.1433118149136D-06, 0.6028909912097D+01, 0.7342457794669D+01, + : 0.1234623148594D-06, 0.3109645574997D+01, 0.6279485555400D+01, + : 0.1233949875344D-06, 0.3539359332866D+01, 0.6286666145492D+01, + : 0.9927196061299D-07, 0.1259321569772D+01, 0.7234794171227D+01, + : 0.1242302191316D-06, 0.1065949392609D+01, 0.1511046609763D+02, + : 0.1098402195201D-06, 0.2192508743837D+01, 0.1098880815746D+02 / + DATA ((E0(I,J,1),I=1,3),J=111,120) / + : 0.1158191395315D-06, 0.4054411278650D+01, 0.5729506548653D+01, + : 0.9048475596241D-07, 0.5429764748518D+01, 0.9623688285163D+01, + : 0.8889853269023D-07, 0.5046586206575D+01, 0.6148010737701D+01, + : 0.1048694242164D-06, 0.2628858030806D+01, 0.6836645152238D+01, + : 0.1112308378646D-06, 0.4177292719907D+01, 0.1572083878776D+02, + : 0.8631729709901D-07, 0.1601345232557D+01, 0.6418140963190D+01, + : 0.8527816951664D-07, 0.2463888997513D+01, 0.1471231707864D+02, + : 0.7892139456991D-07, 0.3154022088718D+01, 0.2118763888447D+01, + : 0.1051782905236D-06, 0.4795035816088D+01, 0.1349867339771D+01, + : 0.1048219943164D-06, 0.2952983395230D+01, 0.5999216516294D+01 / + DATA ((E0(I,J,1),I=1,3),J=121,130) / + : 0.7435760775143D-07, 0.5420547991464D+01, 0.6040347114260D+01, + : 0.9869574106949D-07, 0.3695646753667D+01, 0.6566935184597D+01, + : 0.9156886364226D-07, 0.3922675306609D+01, 0.5643178611111D+01, + : 0.7006834356188D-07, 0.1233968624861D+01, 0.6525804586632D+01, + : 0.9806170182601D-07, 0.1919542280684D+01, 0.2122839202813D+02, + : 0.9052289673607D-07, 0.4615902724369D+01, 0.4690479774488D+01, + : 0.7554200867893D-07, 0.1236863719072D+01, 0.1253985337760D+02, + : 0.8215741286498D-07, 0.3286800101559D+00, 0.1097355562493D+02, + : 0.7185178575397D-07, 0.5880942158367D+01, 0.6245048154254D+01, + : 0.7130726476180D-07, 0.7674871987661D+00, 0.6321103546637D+01 / + DATA ((E0(I,J,1),I=1,3),J=131,140) / + : 0.6650894461162D-07, 0.6987129150116D+00, 0.5327476111629D+01, + : 0.7396888823688D-07, 0.3576824794443D+01, 0.5368044267797D+00, + : 0.7420588884775D-07, 0.5033615245369D+01, 0.2354323048545D+02, + : 0.6141181642908D-07, 0.9449927045673D+00, 0.1296430071988D+02, + : 0.6373557924058D-07, 0.6206342280341D+01, 0.9517183207817D+00, + : 0.6359474329261D-07, 0.5036079095757D+01, 0.1990745094947D+01, + : 0.5740173582646D-07, 0.6105106371350D+01, 0.9555997388169D+00, + : 0.7019864084602D-07, 0.7237747359018D+00, 0.5225775174439D+00, + : 0.6398054487042D-07, 0.3976367969666D+01, 0.2407292145756D+02, + : 0.7797092650498D-07, 0.4305423910623D+01, 0.2200391463820D+02 / + DATA ((E0(I,J,1),I=1,3),J=141,150) / + : 0.6466760000900D-07, 0.3500136825200D+01, 0.5230807360890D+01, + : 0.7529417043890D-07, 0.3514779246100D+01, 0.1842262939178D+02, + : 0.6924571140892D-07, 0.2743457928679D+01, 0.1554202828031D+00, + : 0.6220798650222D-07, 0.2242598118209D+01, 0.1845107853235D+02, + : 0.5870209391853D-07, 0.2332832707527D+01, 0.6398972393349D+00, + : 0.6263953473888D-07, 0.2191105358956D+01, 0.6277552955062D+01, + : 0.6257781390012D-07, 0.4457559396698D+01, 0.6288598745829D+01, + : 0.5697304945123D-07, 0.3499234761404D+01, 0.1551045220144D+01, + : 0.6335438746791D-07, 0.6441691079251D+00, 0.5216580451554D+01, + : 0.6377258441152D-07, 0.2252599151092D+01, 0.5650292065779D+01 / + DATA ((E0(I,J,1),I=1,3),J=151,160) / + : 0.6484841818165D-07, 0.1992812417646D+01, 0.1030928125552D+00, + : 0.4735551485250D-07, 0.3744672082942D+01, 0.1431416805965D+02, + : 0.4628595996170D-07, 0.1334226211745D+01, 0.5535693017924D+00, + : 0.6258152336933D-07, 0.4395836159154D+01, 0.2608790314060D+02, + : 0.6196171366594D-07, 0.2587043007997D+01, 0.8467247584405D+02, + : 0.6159556952126D-07, 0.4782499769128D+01, 0.2394243902548D+03, + : 0.4987741172394D-07, 0.7312257619924D+00, 0.7771377146812D+02, + : 0.5459280703142D-07, 0.3001376372532D+01, 0.6179983037890D+01, + : 0.4863461189999D-07, 0.3767222128541D+01, 0.9027992316901D+02, + : 0.5349912093158D-07, 0.3663594450273D+01, 0.6386168663001D+01 / + DATA ((E0(I,J,1),I=1,3),J=161,170) / + : 0.5673725607806D-07, 0.4331187919049D+01, 0.6915859635113D+01, + : 0.4745485060512D-07, 0.5816195745518D+01, 0.6282970628506D+01, + : 0.4745379005326D-07, 0.8323672435672D+00, 0.6283181072386D+01, + : 0.4049002796321D-07, 0.3785023976293D+01, 0.6254626709878D+01, + : 0.4247084014515D-07, 0.2378220728783D+01, 0.7875671926403D+01, + : 0.4026912363055D-07, 0.2864103423269D+01, 0.6311524991013D+01, + : 0.4062935011774D-07, 0.2415408595975D+01, 0.3634620989887D+01, + : 0.5347771048509D-07, 0.3343479309801D+01, 0.2515860172507D+02, + : 0.4829494136505D-07, 0.2821742398262D+01, 0.5760498333002D+01, + : 0.4342554404599D-07, 0.5624662458712D+01, 0.7238675589263D+01 / + DATA ((E0(I,J,1),I=1,3),J=171,180) / + : 0.4021599184361D-07, 0.5557250275009D+00, 0.1101510648075D+02, + : 0.4104900474558D-07, 0.3296691780005D+01, 0.6709674010002D+01, + : 0.4376532905131D-07, 0.3814443999443D+01, 0.6805653367890D+01, + : 0.3314590480650D-07, 0.3560229189250D+01, 0.1259245002418D+02, + : 0.3232421839643D-07, 0.5185389180568D+01, 0.1066495398892D+01, + : 0.3541176318876D-07, 0.3921381909679D+01, 0.9917696840332D+01, + : 0.3689831242681D-07, 0.4190658955386D+01, 0.1192625446156D+02, + : 0.3890605376774D-07, 0.5546023371097D+01, 0.7478166569050D-01, + : 0.3038559339780D-07, 0.6231032794494D+01, 0.1256621883632D+02, + : 0.3137083969782D-07, 0.6207063419190D+01, 0.4292330755499D+01 / + DATA ((E0(I,J,1),I=1,3),J=181,190) / + : 0.4024004081854D-07, 0.1195257375713D+01, 0.1334167431096D+02, + : 0.3300234879283D-07, 0.1804694240998D+01, 0.1057540660594D+02, + : 0.3635399155575D-07, 0.5597811343500D+01, 0.6208294184755D+01, + : 0.3032668691356D-07, 0.3191059366530D+01, 0.1805292951336D+02, + : 0.2809652069058D-07, 0.4094348032570D+01, 0.3523159621801D-02, + : 0.3696955383823D-07, 0.5219282738794D+01, 0.5966683958112D+01, + : 0.3562894142503D-07, 0.1037247544554D+01, 0.6357857516136D+01, + : 0.3510598524148D-07, 0.1430020816116D+01, 0.6599467742779D+01, + : 0.3617736142953D-07, 0.3002911403677D+01, 0.6019991944201D+01, + : 0.2624524910730D-07, 0.2437046757292D+01, 0.6702560555334D+01 / + DATA ((E0(I,J,1),I=1,3),J=191,200) / + : 0.2535824204490D-07, 0.1581594689647D+01, 0.3141537925223D+02, + : 0.3519787226257D-07, 0.5379863121521D+01, 0.2505706758577D+03, + : 0.2578406709982D-07, 0.4904222639329D+01, 0.1673046366289D+02, + : 0.3423887981473D-07, 0.3646448997315D+01, 0.6546159756691D+01, + : 0.2776083886467D-07, 0.3307829300144D+01, 0.1272157198369D+02, + : 0.3379592818379D-07, 0.1747541251125D+01, 0.1494531617769D+02, + : 0.3050255426284D-07, 0.1784689432607D-01, 0.4732030630302D+01, + : 0.2652378350236D-07, 0.4420055276260D+01, 0.5863591145557D+01, + : 0.2374498173768D-07, 0.3629773929208D+01, 0.2388894113936D+01, + : 0.2716451255140D-07, 0.3079623706780D+01, 0.1202934727411D+02 / + DATA ((E0(I,J,1),I=1,3),J=201,210) / + : 0.3038583699229D-07, 0.3312487903507D+00, 0.1256608456547D+02, + : 0.2220681228760D-07, 0.5265520401774D+01, 0.1336244973887D+02, + : 0.3044156540912D-07, 0.4766664081250D+01, 0.2908881142201D+02, + : 0.2731859923561D-07, 0.5069146530691D+01, 0.1391601904066D+02, + : 0.2285603018171D-07, 0.5954935112271D+01, 0.6076890225335D+01, + : 0.2025006454555D-07, 0.4061789589267D+01, 0.4701116388778D+01, + : 0.2012597519804D-07, 0.2485047705241D+01, 0.6262720680387D+01, + : 0.2003406962258D-07, 0.4163779209320D+01, 0.6303431020504D+01, + : 0.2207863441371D-07, 0.6923839133828D+00, 0.6489261475556D+01, + : 0.2481374305624D-07, 0.5944173595676D+01, 0.1204357418345D+02 / + DATA ((E0(I,J,1),I=1,3),J=211,220) / + : 0.2130923288870D-07, 0.4641013671967D+01, 0.5746271423666D+01, + : 0.2446370543391D-07, 0.6125796518757D+01, 0.1495633313810D+00, + : 0.1932492759052D-07, 0.2234572324504D+00, 0.1352175143971D+02, + : 0.2600122568049D-07, 0.4281012405440D+01, 0.4590910121555D+01, + : 0.2431754047488D-07, 0.1429943874870D+00, 0.1162474756779D+01, + : 0.1875902869209D-07, 0.9781803816948D+00, 0.6279194432410D+01, + : 0.1874381139426D-07, 0.5670368130173D+01, 0.6286957268481D+01, + : 0.2156696047173D-07, 0.2008985006833D+01, 0.1813929450232D+02, + : 0.1965076182484D-07, 0.2566186202453D+00, 0.4686889479442D+01, + : 0.2334816372359D-07, 0.4408121891493D+01, 0.1002183730415D+02 / + DATA ((E0(I,J,1),I=1,3),J=221,230) / + : 0.1869937408802D-07, 0.5272745038656D+01, 0.2427287361862D+00, + : 0.2436236460883D-07, 0.4407720479029D+01, 0.9514313292143D+02, + : 0.1761365216611D-07, 0.1943892315074D+00, 0.1351787002167D+02, + : 0.2156289480503D-07, 0.1418570924545D+01, 0.6037244212485D+01, + : 0.2164748979255D-07, 0.4724603439430D+01, 0.2301353951334D+02, + : 0.2222286670853D-07, 0.2400266874598D+01, 0.1266924451345D+02, + : 0.2070901414929D-07, 0.5230348028732D+01, 0.6528907488406D+01, + : 0.1792745177020D-07, 0.2099190328945D+01, 0.6819880277225D+01, + : 0.1841802068445D-07, 0.3467527844848D+00, 0.6514761976723D+02, + : 0.1578401631718D-07, 0.7098642356340D+00, 0.2077542790660D-01 / + DATA ((E0(I,J,1),I=1,3),J=231,240) / + : 0.1561690152531D-07, 0.5943349620372D+01, 0.6272439236156D+01, + : 0.1558591045463D-07, 0.7040653478980D+00, 0.6293712464735D+01, + : 0.1737356469576D-07, 0.4487064760345D+01, 0.1765478049437D+02, + : 0.1434755619991D-07, 0.2993391570995D+01, 0.1102062672231D+00, + : 0.1482187806654D-07, 0.2278049198251D+01, 0.1052268489556D+01, + : 0.1424812827089D-07, 0.1682114725827D+01, 0.1311972100268D+02, + : 0.1380282448623D-07, 0.3262668602579D+01, 0.1017725758696D+02, + : 0.1811481244566D-07, 0.3187771221777D+01, 0.1887552587463D+02, + : 0.1504446185696D-07, 0.5650162308647D+01, 0.7626583626240D-01, + : 0.1740776154137D-07, 0.5487068607507D+01, 0.1965104848470D+02 / + DATA ((E0(I,J,1),I=1,3),J=241,250) / + : 0.1374339536251D-07, 0.5745688172201D+01, 0.6016468784579D+01, + : 0.1761377477704D-07, 0.5748060203659D+01, 0.2593412433514D+02, + : 0.1535138225795D-07, 0.6226848505790D+01, 0.9411464614024D+01, + : 0.1788140543676D-07, 0.6189318878563D+01, 0.3301902111895D+02, + : 0.1375002807996D-07, 0.5371812884394D+01, 0.6327837846670D+00, + : 0.1242115758632D-07, 0.1471687569712D+01, 0.3894181736510D+01, + : 0.1450977333938D-07, 0.4143836662127D+01, 0.1277945078067D+02, + : 0.1297579575023D-07, 0.9003477661957D+00, 0.6549682916313D+01, + : 0.1462667934821D-07, 0.5760505536428D+01, 0.1863592847156D+02, + : 0.1381774374799D-07, 0.1085471729463D+01, 0.2379164476796D+01 / + DATA ((E0(I,J,1),I=1,3),J=251,260) / + : 0.1682333169307D-07, 0.5409870870133D+01, 0.1620077269078D+02, + : 0.1190812918837D-07, 0.1397205174601D+01, 0.1149965630200D+02, + : 0.1221434762106D-07, 0.9001804809095D+00, 0.1257326515556D+02, + : 0.1549934644860D-07, 0.4262528275544D+01, 0.1820933031200D+02, + : 0.1252138953050D-07, 0.1411642012027D+01, 0.6993008899458D+01, + : 0.1237078905387D-07, 0.2844472403615D+01, 0.2435678079171D+02, + : 0.1446953389615D-07, 0.5295835522223D+01, 0.3813291813120D-01, + : 0.1388446457170D-07, 0.4969428135497D+01, 0.2458316379602D+00, + : 0.1019339179228D-07, 0.2491369561806D+01, 0.6112403035119D+01, + : 0.1258880815343D-07, 0.4679426248976D+01, 0.5429879531333D+01 / + DATA ((E0(I,J,1),I=1,3),J=261,270) / + : 0.1297768238261D-07, 0.1074509953328D+01, 0.1249137003520D+02, + : 0.9913505718094D-08, 0.4735097918224D+01, 0.6247047890016D+01, + : 0.9830453155969D-08, 0.4158649187338D+01, 0.6453748665772D+01, + : 0.1192615865309D-07, 0.3438208613699D+01, 0.6290122169689D+01, + : 0.9835874798277D-08, 0.1913300781229D+01, 0.6319103810876D+01, + : 0.9639087569277D-08, 0.9487683644125D+00, 0.8273820945392D+01, + : 0.1175716107001D-07, 0.3228141664287D+01, 0.6276029531202D+01, + : 0.1018926508678D-07, 0.2216607854300D+01, 0.1254537627298D+02, + : 0.9500087869225D-08, 0.2625116459733D+01, 0.1256517118505D+02, + : 0.9664192916575D-08, 0.5860562449214D+01, 0.6259197520765D+01 / + DATA ((E0(I,J,1),I=1,3),J=271,280) / + : 0.9612858712203D-08, 0.7885682917381D+00, 0.6306954180126D+01, + : 0.1117645675413D-07, 0.3932148831189D+01, 0.1779695906178D+02, + : 0.1158864052160D-07, 0.9995605521691D+00, 0.1778273215245D+02, + : 0.9021043467028D-08, 0.5263769742673D+01, 0.6172869583223D+01, + : 0.8836134773563D-08, 0.1496843220365D+01, 0.1692165728891D+01, + : 0.1045872200691D-07, 0.7009039517214D+00, 0.2204125344462D+00, + : 0.1211463487798D-07, 0.4041544938511D+01, 0.8257698122054D+02, + : 0.8541990804094D-08, 0.1447586692316D+01, 0.6393282117669D+01, + : 0.1038720703636D-07, 0.4594249718112D+00, 0.1550861511662D+02, + : 0.1126722351445D-07, 0.3925550579036D+01, 0.2061856251104D+00 / + DATA ((E0(I,J,1),I=1,3),J=281,290) / + : 0.8697373859631D-08, 0.4411341856037D+01, 0.9491756770005D+00, + : 0.8869380028441D-08, 0.2402659724813D+01, 0.3903911373650D+01, + : 0.9247014693258D-08, 0.1401579743423D+01, 0.6267823317922D+01, + : 0.9205062930950D-08, 0.5245978000814D+01, 0.6298328382969D+01, + : 0.8000745038049D-08, 0.3590803356945D+01, 0.2648454860559D+01, + : 0.9168973650819D-08, 0.2470150501679D+01, 0.1498544001348D+03, + : 0.1075444949238D-07, 0.1328606161230D+01, 0.3694923081589D+02, + : 0.7817298525817D-08, 0.6162256225998D+01, 0.4804209201333D+01, + : 0.9541469226356D-08, 0.3942568967039D+01, 0.1256713221673D+02, + : 0.9821910122027D-08, 0.2360246287233D+00, 0.1140367694411D+02 / + DATA ((E0(I,J,1),I=1,3),J=291,300) / + : 0.9897822023777D-08, 0.4619805634280D+01, 0.2280573557157D+02, + : 0.7737289283765D-08, 0.3784727847451D+01, 0.7834121070590D+01, + : 0.9260204034710D-08, 0.2223352487601D+01, 0.2787043132925D+01, + : 0.7320252888486D-08, 0.1288694636874D+01, 0.6282655592598D+01, + : 0.7319785780946D-08, 0.5359869567774D+01, 0.6283496108294D+01, + : 0.7147219933778D-08, 0.5516616675856D+01, 0.1725663147538D+02, + : 0.7946502829878D-08, 0.2630459984567D+01, 0.1241073141809D+02, + : 0.9001711808932D-08, 0.2849815827227D+01, 0.6281591679874D+01, + : 0.8994041507257D-08, 0.3795244450750D+01, 0.6284560021018D+01, + : 0.8298582787358D-08, 0.5236413127363D+00, 0.1241658836951D+02 / + DATA ((E0(I,J,1),I=1,3),J=301,310) / + : 0.8526596520710D-08, 0.4794605424426D+01, 0.1098419223922D+02, + : 0.8209822103197D-08, 0.1578752370328D+01, 0.1096996532989D+02, + : 0.6357049861094D-08, 0.5708926113761D+01, 0.1596186371003D+01, + : 0.7370473179049D-08, 0.3842402530241D+01, 0.4061219149443D+01, + : 0.7232154664726D-08, 0.3067548981535D+01, 0.1610006857377D+03, + : 0.6328765494903D-08, 0.1313930030069D+01, 0.1193336791622D+02, + : 0.8030064908595D-08, 0.3488500408886D+01, 0.8460828644453D+00, + : 0.6275464259232D-08, 0.1532061626198D+01, 0.8531963191132D+00, + : 0.7051897446325D-08, 0.3285859929993D+01, 0.5849364236221D+01, + : 0.6161593705428D-08, 0.1477341999464D+01, 0.5573142801433D+01 / + DATA ((E0(I,J,1),I=1,3),J=311,320) / + : 0.7754683957278D-08, 0.1586118663096D+01, 0.8662240327241D+01, + : 0.5889928990701D-08, 0.1304887868803D+01, 0.1232342296471D+02, + : 0.5705756047075D-08, 0.4555333589350D+01, 0.1258692712880D+02, + : 0.5964178808332D-08, 0.3001762842062D+01, 0.5333900173445D+01, + : 0.6712446027467D-08, 0.4886780007595D+01, 0.1171295538178D+02, + : 0.5941809275464D-08, 0.4701509603824D+01, 0.9779108567966D+01, + : 0.5466993627395D-08, 0.4588357817278D+01, 0.1884211409667D+02, + : 0.6340512090980D-08, 0.1164543038893D+01, 0.5217580628120D+02, + : 0.6325505710045D-08, 0.3919171259645D+01, 0.1041998632314D+02, + : 0.6164789509685D-08, 0.2143828253542D+01, 0.6151533897323D+01 / + DATA ((E0(I,J,1),I=1,3),J=321,330) / + : 0.5263330812430D-08, 0.6066564434241D+01, 0.1885275071096D+02, + : 0.5597087780221D-08, 0.2926316429472D+01, 0.4337116142245D+00, + : 0.5396556236817D-08, 0.3244303591505D+01, 0.6286362197481D+01, + : 0.5396615148223D-08, 0.3404304703662D+01, 0.6279789503410D+01, + : 0.7091832443341D-08, 0.8532377803192D+00, 0.4907302013889D+01, + : 0.6572352589782D-08, 0.4901966774419D+01, 0.1176433076753D+02, + : 0.5960236060795D-08, 0.1874672315797D+01, 0.1422690933580D-01, + : 0.5125480043511D-08, 0.3735726064334D+01, 0.1245594543367D+02, + : 0.5928241866410D-08, 0.4502033899935D+01, 0.6414617803568D+01, + : 0.5249600357424D-08, 0.4372334799878D+01, 0.1151388321134D+02 / + DATA ((E0(I,J,1),I=1,3),J=331,340) / + : 0.6059171276087D-08, 0.2581617302908D+01, 0.6062663316000D+01, + : 0.5295235081662D-08, 0.2974811513158D+01, 0.3496032717521D+01, + : 0.5820561875933D-08, 0.1796073748244D+00, 0.2838593341516D+00, + : 0.4754696606440D-08, 0.1981998136973D+01, 0.3104930017775D+01, + : 0.6385053548955D-08, 0.2559174171605D+00, 0.6133512519065D+01, + : 0.6589828273941D-08, 0.2750967106776D+01, 0.4087944051283D+02, + : 0.5383376567189D-08, 0.6325947523578D+00, 0.2248384854122D+02, + : 0.5928941683538D-08, 0.1672304519067D+01, 0.1581959461667D+01, + : 0.4816060709794D-08, 0.3512566172575D+01, 0.9388005868221D+01, + : 0.6003381586512D-08, 0.5610932219189D+01, 0.5326786718777D+01 / + DATA ((E0(I,J,1),I=1,3),J=341,350) / + : 0.5504225393105D-08, 0.4037501131256D+01, 0.6503488384892D+01, + : 0.5353772620129D-08, 0.6122774968240D+01, 0.1735668374386D+03, + : 0.5786253768544D-08, 0.5527984999515D+01, 0.1350651127443D+00, + : 0.5065706702002D-08, 0.9980765573624D+00, 0.1248988586463D+02, + : 0.5972838885276D-08, 0.6044489493203D+01, 0.2673594526851D+02, + : 0.5323585877961D-08, 0.3924265998147D+01, 0.4171425416666D+01, + : 0.5210772682858D-08, 0.6220111376901D+01, 0.2460261242967D+02, + : 0.4726549040535D-08, 0.3716043206862D+01, 0.7232251527446D+01, + : 0.6029425105059D-08, 0.8548704071116D+00, 0.3227113045244D+03, + : 0.4481542826513D-08, 0.1426925072829D+01, 0.5547199253223D+01 / + DATA ((E0(I,J,1),I=1,3),J=351,360) / + : 0.5836024505068D-08, 0.7135651752625D-01, 0.7285056171570D+02, + : 0.4137046613272D-08, 0.5330767643283D+01, 0.1087398597200D+02, + : 0.5171977473924D-08, 0.4494262335353D+00, 0.1884570439172D+02, + : 0.5694429833732D-08, 0.2952369582215D+01, 0.9723862754494D+02, + : 0.4009158925298D-08, 0.3500003416535D+01, 0.6244942932314D+01, + : 0.4784939596873D-08, 0.6196709413181D+01, 0.2929661536378D+02, + : 0.3983725022610D-08, 0.5103690031897D+01, 0.4274518229222D+01, + : 0.3870535232462D-08, 0.3187569587401D+01, 0.6321208768577D+01, + : 0.5140501213951D-08, 0.1668924357457D+01, 0.1232032006293D+02, + : 0.3849034819355D-08, 0.4445722510309D+01, 0.1726726808967D+02 / + DATA ((E0(I,J,1),I=1,3),J=361,370) / + : 0.4002383075060D-08, 0.5226224152423D+01, 0.7018952447668D+01, + : 0.3890719543549D-08, 0.4371166550274D+01, 0.1491901785440D+02, + : 0.4887084607881D-08, 0.5973556689693D+01, 0.1478866649112D+01, + : 0.3739939287592D-08, 0.2089084714600D+01, 0.6922973089781D+01, + : 0.5031925918209D-08, 0.4658371936827D+01, 0.1715706182245D+02, + : 0.4387748764954D-08, 0.4825580552819D+01, 0.2331413144044D+03, + : 0.4147398098865D-08, 0.3739003524998D+01, 0.1376059875786D+02, + : 0.3719089993586D-08, 0.1148941386536D+01, 0.6297302759782D+01, + : 0.3934238461056D-08, 0.1559893008343D+01, 0.7872148766781D+01, + : 0.3672471375622D-08, 0.5516145383612D+01, 0.6268848941110D+01 / + DATA ((E0(I,J,1),I=1,3),J=371,380) / + : 0.3768911277583D-08, 0.6116053700563D+01, 0.4157198507331D+01, + : 0.4033388417295D-08, 0.5076821746017D+01, 0.1567108171867D+02, + : 0.3764194617832D-08, 0.8164676232075D+00, 0.3185192151914D+01, + : 0.4840628226284D-08, 0.1360479453671D+01, 0.1252801878276D+02, + : 0.4949443923785D-08, 0.2725622229926D+01, 0.1617106187867D+03, + : 0.4117393089971D-08, 0.6054459628492D+00, 0.5642198095270D+01, + : 0.3925754020428D-08, 0.8570462135210D+00, 0.2139354194808D+02, + : 0.3630551757923D-08, 0.3552067338279D+01, 0.6294805223347D+01, + : 0.3627274802357D-08, 0.3096565085313D+01, 0.6271346477544D+01, + : 0.3806143885093D-08, 0.6367751709777D+00, 0.1725304118033D+02 / + DATA ((E0(I,J,1),I=1,3),J=381,390) / + : 0.4433254641565D-08, 0.4848461503937D+01, 0.7445550607224D+01, + : 0.3712319846576D-08, 0.1331950643655D+01, 0.4194847048887D+00, + : 0.3849847534783D-08, 0.4958368297746D+00, 0.9562891316684D+00, + : 0.3483955430165D-08, 0.2237215515707D+01, 0.1161697602389D+02, + : 0.3961912730982D-08, 0.3332402188575D+01, 0.2277943724828D+02, + : 0.3419978244481D-08, 0.5785600576016D+01, 0.1362553364512D+02, + : 0.3329417758177D-08, 0.9812676559709D-01, 0.1685848245639D+02, + : 0.4207206893193D-08, 0.9494780468236D+00, 0.2986433403208D+02, + : 0.3268548976410D-08, 0.1739332095686D+00, 0.5749861718712D+01, + : 0.3321880082685D-08, 0.1423354800666D+01, 0.6279143387820D+01 / + DATA ((E0(I,J,1),I=1,3),J=391,400) / + : 0.4503173010852D-08, 0.2314972675293D+00, 0.1385561574497D+01, + : 0.4316599090954D-08, 0.1012646782616D+00, 0.4176041334900D+01, + : 0.3283493323850D-08, 0.5233306881265D+01, 0.6287008313071D+01, + : 0.3164033542343D-08, 0.4005597257511D+01, 0.2099539292909D+02, + : 0.4159720956725D-08, 0.5365676242020D+01, 0.5905702259363D+01, + : 0.3565176892217D-08, 0.4284440620612D+01, 0.3932462625300D-02, + : 0.3514440950221D-08, 0.4270562636575D+01, 0.7335344340001D+01, + : 0.3540596871909D-08, 0.5953553201060D+01, 0.1234573916645D+02, + : 0.2960769905118D-08, 0.1115180417718D+01, 0.2670964694522D+02, + : 0.2962213739684D-08, 0.3863811918186D+01, 0.6408777551755D+00 / + DATA ((E0(I,J,1),I=1,3),J=401,410) / + : 0.3883556700251D-08, 0.1268617928302D+01, 0.6660449441528D+01, + : 0.2919225516346D-08, 0.4908605223265D+01, 0.1375773836557D+01, + : 0.3115158863370D-08, 0.3744519976885D+01, 0.3802769619140D-01, + : 0.4099438144212D-08, 0.4173244670532D+01, 0.4480965020977D+02, + : 0.2899531858964D-08, 0.5910601428850D+01, 0.2059724391010D+02, + : 0.3289733429855D-08, 0.2488050078239D+01, 0.1081813534213D+02, + : 0.3933075612875D-08, 0.1122363652883D+01, 0.3773735910827D+00, + : 0.3021403764467D-08, 0.4951973724904D+01, 0.2982630633589D+02, + : 0.2798598949757D-08, 0.5117057845513D+01, 0.1937891852345D+02, + : 0.3397421302707D-08, 0.6104159180476D+01, 0.6923953605621D+01 / + DATA ((E0(I,J,1),I=1,3),J=411,420) / + : 0.3720398002179D-08, 0.1184933429829D+01, 0.3066615496545D+02, + : 0.3598484186267D-08, 0.3505282086105D+01, 0.6147450479709D+01, + : 0.3694594027310D-08, 0.2286651088141D+01, 0.2636725487657D+01, + : 0.2680444152969D-08, 0.1871816775482D+00, 0.6816289982179D+01, + : 0.3497574865641D-08, 0.3143251755431D+01, 0.6418701221183D+01, + : 0.3130274129494D-08, 0.2462167316018D+01, 0.1235996607578D+02, + : 0.3241119069551D-08, 0.4256374004686D+01, 0.1652265972112D+02, + : 0.2601960842061D-08, 0.4970362941425D+01, 0.1045450126711D+02, + : 0.2690601527504D-08, 0.2372657824898D+01, 0.3163918923335D+00, + : 0.2908688152664D-08, 0.4232652627721D+01, 0.2828699048865D+02 / + DATA ((E0(I,J,1),I=1,3),J=421,430) / + : 0.3120456131875D-08, 0.3925747001137D+00, 0.2195415756911D+02, + : 0.3148855423384D-08, 0.3093478330445D+01, 0.1172006883645D+02, + : 0.3051044261017D-08, 0.5560948248212D+01, 0.6055599646783D+01, + : 0.2826006876660D-08, 0.5072790310072D+01, 0.5120601093667D+01, + : 0.3100034191711D-08, 0.4998530231096D+01, 0.1799603123222D+02, + : 0.2398771640101D-08, 0.2561739802176D+01, 0.6255674361143D+01, + : 0.2384002842728D-08, 0.4087420284111D+01, 0.6310477339748D+01, + : 0.2842146517568D-08, 0.2515048217955D+01, 0.5469525544182D+01, + : 0.2847674371340D-08, 0.5235326497443D+01, 0.1034429499989D+02, + : 0.2903722140764D-08, 0.1088200795797D+01, 0.6510552054109D+01 / + DATA ((E0(I,J,1),I=1,3),J=431,440) / + : 0.3187610710605D-08, 0.4710624424816D+01, 0.1693792562116D+03, + : 0.3048869992813D-08, 0.2857975896445D+00, 0.8390110365991D+01, + : 0.2860216950984D-08, 0.2241619020815D+01, 0.2243449970715D+00, + : 0.2701117683113D-08, 0.6651573305272D-01, 0.6129297044991D+01, + : 0.2509891590152D-08, 0.1285135324585D+01, 0.1044027435778D+02, + : 0.2623200252223D-08, 0.2981229834530D+00, 0.6436854655901D+01, + : 0.2622541669202D-08, 0.6122470726189D+01, 0.9380959548977D+01, + : 0.2818435667099D-08, 0.4251087148947D+01, 0.5934151399930D+01, + : 0.2365196797465D-08, 0.3465070460790D+01, 0.2470570524223D+02, + : 0.2358704646143D-08, 0.5791603815350D+01, 0.8671969964381D+01 / + DATA ((E0(I,J,1),I=1,3),J=441,450) / + : 0.2388299481390D-08, 0.4142483772941D+01, 0.7096626156709D+01, + : 0.1996041217224D-08, 0.2101901889496D+01, 0.1727188400790D+02, + : 0.2687593060336D-08, 0.1526689456959D+01, 0.7075506709219D+02, + : 0.2618913670810D-08, 0.2397684236095D+01, 0.6632000300961D+01, + : 0.2571523050364D-08, 0.5751929456787D+00, 0.6206810014183D+01, + : 0.2582135006946D-08, 0.5595464352926D+01, 0.4873985990671D+02, + : 0.2372530190361D-08, 0.5092689490655D+01, 0.1590676413561D+02, + : 0.2357178484712D-08, 0.4444363527851D+01, 0.3097883698531D+01, + : 0.2451590394723D-08, 0.3108251687661D+01, 0.6612329252343D+00, + : 0.2370045949608D-08, 0.2608133861079D+01, 0.3459636466239D+02 / + DATA ((E0(I,J,1),I=1,3),J=451,460) / + : 0.2268997267358D-08, 0.3639717753384D+01, 0.2844914056730D-01, + : 0.1731432137906D-08, 0.1741898445707D+00, 0.2019909489111D+02, + : 0.1629869741622D-08, 0.3902225646724D+01, 0.3035599730800D+02, + : 0.2206215801974D-08, 0.4971131250731D+01, 0.6281667977667D+01, + : 0.2205469554680D-08, 0.1677462357110D+01, 0.6284483723224D+01, + : 0.2148792362509D-08, 0.4236259604006D+01, 0.1980482729015D+02, + : 0.1873733657847D-08, 0.5926814998687D+01, 0.2876692439167D+02, + : 0.2026573758959D-08, 0.4349643351962D+01, 0.2449240616245D+02, + : 0.1807770325110D-08, 0.5700940482701D+01, 0.2045286941806D+02, + : 0.1881174408581D-08, 0.6601286363430D+00, 0.2358125818164D+02 / + DATA ((E0(I,J,1),I=1,3),J=461,470) / + : 0.1368023671690D-08, 0.2211098592752D+01, 0.2473415438279D+02, + : 0.1720017916280D-08, 0.4942488551129D+01, 0.1679593901136D+03, + : 0.1702427665131D-08, 0.1452233856386D+01, 0.3338575901272D+03, + : 0.1414032510054D-08, 0.5525357721439D+01, 0.1624205518357D+03, + : 0.1652626045364D-08, 0.4108794283624D+01, 0.8956999012000D+02, + : 0.1642957769686D-08, 0.7344335209984D+00, 0.5267006960365D+02, + : 0.1614952403624D-08, 0.3541213951363D+01, 0.3332657872986D+02, + : 0.1535988291188D-08, 0.4031094072151D+01, 0.3852657435933D+02, + : 0.1593193738177D-08, 0.4185136203609D+01, 0.2282781046519D+03, + : 0.1074569126382D-08, 0.1720485636868D+01, 0.8397383534231D+02 / + DATA ((E0(I,J,1),I=1,3),J=471,480) / + : 0.1074408214509D-08, 0.2758613420318D+01, 0.8401985929482D+02, + : 0.9700199670465D-09, 0.4216686842097D+01, 0.7826370942180D+02, + : 0.1258433517061D-08, 0.2575068876639D+00, 0.3115650189215D+03, + : 0.1240303229539D-08, 0.4800844956756D+00, 0.1784300471910D+03, + : 0.9018345948127D-09, 0.3896756361552D+00, 0.5886454391678D+02, + : 0.1135301432805D-08, 0.3700805023550D+00, 0.7842370451713D+02, + : 0.9215887951370D-09, 0.4364579276638D+01, 0.1014262087719D+03, + : 0.1055401054147D-08, 0.2156564222111D+01, 0.5660027930059D+02, + : 0.1008725979831D-08, 0.5454015785234D+01, 0.4245678405627D+02, + : 0.7217398104321D-09, 0.1597772562175D+01, 0.2457074661053D+03 / + DATA ((E0(I,J,1),I=1,3),J=481,490) / + : 0.6912033134447D-09, 0.5824090621461D+01, 0.1679936946371D+03, + : 0.6833881523549D-09, 0.3578778482835D+01, 0.6053048899753D+02, + : 0.4887304205142D-09, 0.3724362812423D+01, 0.9656299901946D+02, + : 0.5173709754788D-09, 0.5422427507933D+01, 0.2442876000072D+03, + : 0.4671353097145D-09, 0.2396106924439D+01, 0.1435713242844D+03, + : 0.5652608439480D-09, 0.2804028838685D+01, 0.8365903305582D+02, + : 0.5604061331253D-09, 0.1638816006247D+01, 0.8433466158131D+02, + : 0.4712723365400D-09, 0.8979003224474D+00, 0.3164282286739D+03, + : 0.4909967465112D-09, 0.3210426725516D+01, 0.4059982187939D+03, + : 0.4771358267658D-09, 0.5308027211629D+01, 0.1805255418145D+03 / + DATA ((E0(I,J,1),I=1,3),J=491,500) / + : 0.3943451445989D-09, 0.2195145341074D+01, 0.2568537517081D+03, + : 0.3952109120244D-09, 0.5081189491586D+01, 0.2449975330562D+03, + : 0.3788134594789D-09, 0.4345171264441D+01, 0.1568131045107D+03, + : 0.3738330190479D-09, 0.2613062847997D+01, 0.3948519331910D+03, + : 0.3099866678136D-09, 0.2846760817689D+01, 0.1547176098872D+03, + : 0.2002962716768D-09, 0.4921360989412D+01, 0.2268582385539D+03, + : 0.2198291338754D-09, 0.1130360117454D+00, 0.1658638954901D+03, + : 0.1491958330784D-09, 0.4228195232278D+01, 0.2219950288015D+03, + : 0.1475384076173D-09, 0.3005721811604D+00, 0.3052819430710D+03, + : 0.1661626624624D-09, 0.7830125621203D+00, 0.2526661704812D+03 / + DATA ((E0(I,J,1),I=1,3),J=501,NE0X) / + : 0.9015823460025D-10, 0.3807792942715D+01, 0.4171445043968D+03 / + +* Sun-to-Earth, T^1, X + DATA ((E1(I,J,1),I=1,3),J= 1, 10) / + : 0.1234046326004D-05, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.5150068824701D-06, 0.6002664557501D+01, 0.1256615170089D+02, + : 0.1290743923245D-07, 0.5959437664199D+01, 0.1884922755134D+02, + : 0.1068615564952D-07, 0.2015529654209D+01, 0.6283075850446D+01, + : 0.2079619142538D-08, 0.1732960531432D+01, 0.6279552690824D+01, + : 0.2078009243969D-08, 0.4915604476996D+01, 0.6286599010068D+01, + : 0.6206330058856D-09, 0.3616457953824D+00, 0.4705732307012D+01, + : 0.5989335313746D-09, 0.3802607304474D+01, 0.6256777527156D+01, + : 0.5958495663840D-09, 0.2845866560031D+01, 0.6309374173736D+01, + : 0.4866923261539D-09, 0.5213203771824D+01, 0.7755226100720D+00 / + DATA ((E1(I,J,1),I=1,3),J= 11, 20) / + : 0.4267785823142D-09, 0.4368189727818D+00, 0.1059381944224D+01, + : 0.4610675141648D-09, 0.1837249181372D-01, 0.7860419393880D+01, + : 0.3626989993973D-09, 0.2161590545326D+01, 0.5753384878334D+01, + : 0.3563071194389D-09, 0.1452631954746D+01, 0.5884926831456D+01, + : 0.3557015642807D-09, 0.4470593393054D+01, 0.6812766822558D+01, + : 0.3210412089122D-09, 0.5195926078314D+01, 0.6681224869435D+01, + : 0.2875473577986D-09, 0.5916256610193D+01, 0.2513230340178D+02, + : 0.2842913681629D-09, 0.1149902426047D+01, 0.6127655567643D+01, + : 0.2751248215916D-09, 0.5502088574662D+01, 0.6438496133249D+01, + : 0.2481432881127D-09, 0.2921989846637D+01, 0.5486777812467D+01 / + DATA ((E1(I,J,1),I=1,3),J= 21, 30) / + : 0.2059885976560D-09, 0.3718070376585D+01, 0.7079373888424D+01, + : 0.2015522342591D-09, 0.5979395259740D+01, 0.6290189305114D+01, + : 0.1995364084253D-09, 0.6772087985494D+00, 0.6275962395778D+01, + : 0.1957436436943D-09, 0.2899210654665D+01, 0.5507553240374D+01, + : 0.1651609818948D-09, 0.6228206482192D+01, 0.1150676975667D+02, + : 0.1822980550699D-09, 0.1469348746179D+01, 0.1179062909082D+02, + : 0.1675223159760D-09, 0.3813910555688D+01, 0.7058598460518D+01, + : 0.1706491764745D-09, 0.3004380506684D+00, 0.7113454667900D-02, + : 0.1392952362615D-09, 0.1440393973406D+01, 0.7962980379786D+00, + : 0.1209868266342D-09, 0.4150425791727D+01, 0.4694002934110D+01 / + DATA ((E1(I,J,1),I=1,3),J= 31, 40) / + : 0.1009827202611D-09, 0.3290040429843D+01, 0.3738761453707D+01, + : 0.1047261388602D-09, 0.4229590090227D+01, 0.6282095334605D+01, + : 0.1047006652004D-09, 0.2418967680575D+01, 0.6284056366286D+01, + : 0.9609993143095D-10, 0.4627943659201D+01, 0.6069776770667D+01, + : 0.9590900593873D-10, 0.1894393939924D+01, 0.4136910472696D+01, + : 0.9146249188071D-10, 0.2010647519562D+01, 0.6496374930224D+01, + : 0.8545274480290D-10, 0.5529846956226D-01, 0.1194447056968D+01, + : 0.8224377881194D-10, 0.1254304102174D+01, 0.1589072916335D+01, + : 0.6183529510410D-10, 0.3360862168815D+01, 0.8827390247185D+01, + : 0.6259255147141D-10, 0.4755628243179D+01, 0.8429241228195D+01 / + DATA ((E1(I,J,1),I=1,3),J= 41, 50) / + : 0.5539291694151D-10, 0.5371746955142D+01, 0.4933208510675D+01, + : 0.7328259466314D-10, 0.4927699613906D+00, 0.4535059491685D+01, + : 0.6017835843560D-10, 0.5776682001734D-01, 0.1255903824622D+02, + : 0.7079827775243D-10, 0.4395059432251D+01, 0.5088628793478D+01, + : 0.5170358878213D-10, 0.5154062619954D+01, 0.1176985366291D+02, + : 0.4872301838682D-10, 0.6289611648973D+00, 0.6040347114260D+01, + : 0.5249869411058D-10, 0.5617272046949D+01, 0.3154687086868D+01, + : 0.4716172354411D-10, 0.3965901800877D+01, 0.5331357529664D+01, + : 0.4871214940964D-10, 0.4627507050093D+01, 0.1256967486051D+02, + : 0.4598076850751D-10, 0.6023631226459D+01, 0.6525804586632D+01 / + DATA ((E1(I,J,1),I=1,3),J= 51, 60) / + : 0.4562196089485D-10, 0.4138562084068D+01, 0.3930209696940D+01, + : 0.4325493872224D-10, 0.1330845906564D+01, 0.7632943190217D+01, + : 0.5673781176748D-10, 0.2558752615657D+01, 0.5729506548653D+01, + : 0.3961436642503D-10, 0.2728071734630D+01, 0.7234794171227D+01, + : 0.5101868209058D-10, 0.4113444965144D+01, 0.6836645152238D+01, + : 0.5257043167676D-10, 0.6195089830590D+01, 0.8031092209206D+01, + : 0.5076613989393D-10, 0.2305124132918D+01, 0.7477522907414D+01, + : 0.3342169352778D-10, 0.5415998155071D+01, 0.1097707878456D+02, + : 0.3545881983591D-10, 0.3727160564574D+01, 0.4164311961999D+01, + : 0.3364063738599D-10, 0.2901121049204D+00, 0.1137170464392D+02 / + DATA ((E1(I,J,1),I=1,3),J= 61, 70) / + : 0.3357039670776D-10, 0.1652229354331D+01, 0.5223693906222D+01, + : 0.4307412268687D-10, 0.4938909587445D+01, 0.1592596075957D+01, + : 0.3405769115435D-10, 0.2408890766511D+01, 0.3128388763578D+01, + : 0.3001926198480D-10, 0.4862239006386D+01, 0.1748016358760D+01, + : 0.2778264787325D-10, 0.5241168661353D+01, 0.7342457794669D+01, + : 0.2676159480666D-10, 0.3423593942199D+01, 0.2146165377750D+01, + : 0.2954273399939D-10, 0.1881721265406D+01, 0.5368044267797D+00, + : 0.3309362888795D-10, 0.1931525677349D+01, 0.8018209333619D+00, + : 0.2810283608438D-10, 0.2414659495050D+01, 0.5225775174439D+00, + : 0.3378045637764D-10, 0.4238019163430D+01, 0.1554202828031D+00 / + DATA ((E1(I,J,1),I=1,3),J= 71,NE1X) / + : 0.2558134979840D-10, 0.1828225235805D+01, 0.5230807360890D+01, + : 0.2273755578447D-10, 0.5858184283998D+01, 0.7084896783808D+01, + : 0.2294176037690D-10, 0.4514589779057D+01, 0.1726015463500D+02, + : 0.2533506099435D-10, 0.2355717851551D+01, 0.5216580451554D+01, + : 0.2716685375812D-10, 0.2221003625100D+01, 0.8635942003952D+01, + : 0.2419043435198D-10, 0.5955704951635D+01, 0.4690479774488D+01, + : 0.2521232544812D-10, 0.1395676848521D+01, 0.5481254917084D+01, + : 0.2630195021491D-10, 0.5727468918743D+01, 0.2629832328990D-01, + : 0.2548395840944D-10, 0.2628351859400D-03, 0.1349867339771D+01 / + +* Sun-to-Earth, T^2, X + DATA ((E2(I,J,1),I=1,3),J= 1,NE2X) / + : -0.4143818297913D-10, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.2171497694435D-10, 0.4398225628264D+01, 0.1256615170089D+02, + : 0.9845398442516D-11, 0.2079720838384D+00, 0.6283075850446D+01, + : 0.9256833552682D-12, 0.4191264694361D+01, 0.1884922755134D+02, + : 0.1022049384115D-12, 0.5381133195658D+01, 0.8399684731857D+02 / + +* Sun-to-Earth, T^0, Y + DATA ((E0(I,J,2),I=1,3),J= 1, 10) / + : 0.9998921098898D+00, 0.1826583913846D+00, 0.6283075850446D+01, + : -0.2442700893735D-01, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.8352929742915D-02, 0.1395277998680D+00, 0.1256615170089D+02, + : 0.1046697300177D-03, 0.9641423109763D-01, 0.1884922755134D+02, + : 0.3110841876663D-04, 0.5381140401712D+01, 0.8399684731857D+02, + : 0.2570269094593D-04, 0.5301016407128D+01, 0.5296909721118D+00, + : 0.2147389623610D-04, 0.2662510869850D+01, 0.1577343543434D+01, + : 0.1680344384050D-04, 0.5207904119704D+01, 0.6279552690824D+01, + : 0.1679117312193D-04, 0.4582187486968D+01, 0.6286599010068D+01, + : 0.1440512068440D-04, 0.1900688517726D+01, 0.2352866153506D+01 / + DATA ((E0(I,J,2),I=1,3),J= 11, 20) / + : 0.1135139664999D-04, 0.5273108538556D+01, 0.5223693906222D+01, + : 0.9345482571018D-05, 0.4503047687738D+01, 0.1203646072878D+02, + : 0.9007418719568D-05, 0.1605621059637D+01, 0.1021328554739D+02, + : 0.5671536712314D-05, 0.5812849070861D+00, 0.1059381944224D+01, + : 0.7451401861666D-05, 0.2807346794836D+01, 0.3981490189893D+00, + : 0.6393470057114D-05, 0.6029224133855D+01, 0.5753384878334D+01, + : 0.6814275881697D-05, 0.6472990145974D+00, 0.4705732307012D+01, + : 0.6113705628887D-05, 0.3813843419700D+01, 0.6812766822558D+01, + : 0.4503851367273D-05, 0.4527804370996D+01, 0.5884926831456D+01, + : 0.4522249141926D-05, 0.5991783029224D+01, 0.6256777527156D+01 / + DATA ((E0(I,J,2),I=1,3),J= 21, 30) / + : 0.4501794307018D-05, 0.3798703844397D+01, 0.6309374173736D+01, + : 0.5514927480180D-05, 0.3961257833388D+01, 0.5507553240374D+01, + : 0.4062862799995D-05, 0.5256247296369D+01, 0.6681224869435D+01, + : 0.5414900429712D-05, 0.5499032014097D+01, 0.7755226100720D+00, + : 0.5463153987424D-05, 0.6173092454097D+01, 0.1414349524433D+02, + : 0.5071611859329D-05, 0.2870244247651D+01, 0.7860419393880D+01, + : 0.2195112094455D-05, 0.2952338617201D+01, 0.1150676975667D+02, + : 0.2279139233919D-05, 0.5951775132933D+01, 0.7058598460518D+01, + : 0.2278386100876D-05, 0.4845456398785D+01, 0.4694002934110D+01, + : 0.2559088003308D-05, 0.6945321117311D+00, 0.1216800268190D+02 / + DATA ((E0(I,J,2),I=1,3),J= 31, 40) / + : 0.2561079286856D-05, 0.6167224608301D+01, 0.7099330490126D+00, + : 0.1792755796387D-05, 0.1400122509632D+01, 0.7962980379786D+00, + : 0.1818715656502D-05, 0.4703347611830D+01, 0.6283142985870D+01, + : 0.1818744924791D-05, 0.5086748900237D+01, 0.6283008715021D+01, + : 0.1554518791390D-05, 0.5331008042713D-01, 0.2513230340178D+02, + : 0.2063265737239D-05, 0.4283680484178D+01, 0.1179062909082D+02, + : 0.1497613520041D-05, 0.6074207826073D+01, 0.5486777812467D+01, + : 0.2000617940427D-05, 0.2501426281450D+01, 0.1778984560711D+02, + : 0.1289731195580D-05, 0.3646340599536D+01, 0.7079373888424D+01, + : 0.1282657998934D-05, 0.3232864804902D+01, 0.3738761453707D+01 / + DATA ((E0(I,J,2),I=1,3),J= 41, 50) / + : 0.1528915968658D-05, 0.5581433416669D+01, 0.2132990797783D+00, + : 0.1187304098432D-05, 0.5453576453694D+01, 0.9437762937313D+01, + : 0.7842782928118D-06, 0.2823953922273D+00, 0.8827390247185D+01, + : 0.7352892280868D-06, 0.1124369580175D+01, 0.1589072916335D+01, + : 0.6570189360797D-06, 0.2089154042840D+01, 0.1176985366291D+02, + : 0.6324967590410D-06, 0.6704855581230D+00, 0.6262300422539D+01, + : 0.6298289872283D-06, 0.2836414855840D+01, 0.6303851278352D+01, + : 0.6476686465855D-06, 0.4852433866467D+00, 0.7113454667900D-02, + : 0.8587034651234D-06, 0.1453511005668D+01, 0.1672837615881D+03, + : 0.8068948788113D-06, 0.9224087798609D+00, 0.6069776770667D+01 / + DATA ((E0(I,J,2),I=1,3),J= 51, 60) / + : 0.8353786011661D-06, 0.4631707184895D+01, 0.3340612434717D+01, + : 0.6009324532132D-06, 0.1829498827726D+01, 0.4136910472696D+01, + : 0.7558158559566D-06, 0.2588596800317D+01, 0.6496374930224D+01, + : 0.5809279504503D-06, 0.5516818853476D+00, 0.1097707878456D+02, + : 0.5374131950254D-06, 0.6275674734960D+01, 0.1194447056968D+01, + : 0.5711160507326D-06, 0.1091905956872D+01, 0.6282095334605D+01, + : 0.5710183170746D-06, 0.2415001635090D+01, 0.6284056366286D+01, + : 0.5144373590610D-06, 0.6020336443438D+01, 0.6290189305114D+01, + : 0.5103108927267D-06, 0.3775634564605D+01, 0.6275962395778D+01, + : 0.4960654697891D-06, 0.1073450946756D+01, 0.6127655567643D+01 / + DATA ((E0(I,J,2),I=1,3),J= 61, 70) / + : 0.4786385689280D-06, 0.2431178012310D+01, 0.6438496133249D+01, + : 0.6109911263665D-06, 0.5343356157914D+01, 0.3154687086868D+01, + : 0.4839898944024D-06, 0.5830833594047D-01, 0.8018209333619D+00, + : 0.4734822623919D-06, 0.4536080134821D+01, 0.3128388763578D+01, + : 0.4834741473290D-06, 0.2585090489754D+00, 0.7084896783808D+01, + : 0.5134858581156D-06, 0.4213317172603D+01, 0.1235285262111D+02, + : 0.5064004264978D-06, 0.4814418806478D+00, 0.1185621865188D+02, + : 0.3753476772761D-06, 0.1599953399788D+01, 0.8429241228195D+01, + : 0.4935264014283D-06, 0.2157417556873D+01, 0.2544314396739D+01, + : 0.3950929600897D-06, 0.3359394184254D+01, 0.5481254917084D+01 / + DATA ((E0(I,J,2),I=1,3),J= 71, 80) / + : 0.4895849789777D-06, 0.5165704376558D+01, 0.9225539266174D+01, + : 0.4215241688886D-06, 0.2065368800993D+01, 0.1726015463500D+02, + : 0.3796773731132D-06, 0.1468606346612D+01, 0.4265981595566D+00, + : 0.3114178142515D-06, 0.3615638079474D+01, 0.2146165377750D+01, + : 0.3260664220838D-06, 0.4417134922435D+01, 0.4164311961999D+01, + : 0.3976996123008D-06, 0.4700866883004D+01, 0.5856477690889D+01, + : 0.2801459672924D-06, 0.4538902060922D+01, 0.1256967486051D+02, + : 0.3638931868861D-06, 0.1334197991475D+01, 0.1807370494127D+02, + : 0.2487013269476D-06, 0.3749275558275D+01, 0.2629832328990D-01, + : 0.3034165481994D-06, 0.4236622030873D+00, 0.4535059491685D+01 / + DATA ((E0(I,J,2),I=1,3),J= 81, 90) / + : 0.2676278825586D-06, 0.5970848007811D+01, 0.3930209696940D+01, + : 0.2764903818918D-06, 0.5194636754501D+01, 0.1256262854127D+02, + : 0.2485149930507D-06, 0.1002434207846D+01, 0.5088628793478D+01, + : 0.2199305540941D-06, 0.3066773098403D+01, 0.1255903824622D+02, + : 0.2571106500435D-06, 0.7588312459063D+00, 0.1336797263425D+02, + : 0.2049751817158D-06, 0.3444977434856D+01, 0.1137170464392D+02, + : 0.2599707296297D-06, 0.1873128542205D+01, 0.7143069561767D+02, + : 0.1785018072217D-06, 0.5015891306615D+01, 0.1748016358760D+01, + : 0.2324833891115D-06, 0.4618271239730D+01, 0.1831953657923D+02, + : 0.1709711119545D-06, 0.5300003455669D+01, 0.4933208510675D+01 / + DATA ((E0(I,J,2),I=1,3),J= 91,100) / + : 0.2107159351716D-06, 0.2229819815115D+01, 0.7477522907414D+01, + : 0.1750333080295D-06, 0.6161485880008D+01, 0.1044738781244D+02, + : 0.2000598210339D-06, 0.2967357299999D+01, 0.8031092209206D+01, + : 0.1380920248681D-06, 0.3027007923917D+01, 0.8635942003952D+01, + : 0.1412460470299D-06, 0.6037597163798D+01, 0.2942463415728D+01, + : 0.1888459803001D-06, 0.8561476243374D+00, 0.1561374759853D+03, + : 0.1788370542585D-06, 0.4869736290209D+01, 0.1592596075957D+01, + : 0.1360893296167D-06, 0.3626411886436D+01, 0.1309584267300D+02, + : 0.1506846530160D-06, 0.1550975377427D+01, 0.1649636139783D+02, + : 0.1800913376176D-06, 0.2075826033190D+01, 0.1729818233119D+02 / + DATA ((E0(I,J,2),I=1,3),J=101,110) / + : 0.1436261390649D-06, 0.6148876420255D+01, 0.2042657109477D+02, + : 0.1220227114151D-06, 0.4382583879906D+01, 0.7632943190217D+01, + : 0.1337883603592D-06, 0.2036644327361D+01, 0.1213955354133D+02, + : 0.1159326650738D-06, 0.3892276994687D+01, 0.5331357529664D+01, + : 0.1352853128569D-06, 0.1447950649744D+01, 0.1673046366289D+02, + : 0.1433408296083D-06, 0.4457854692961D+01, 0.7342457794669D+01, + : 0.1234701666518D-06, 0.1538818147151D+01, 0.6279485555400D+01, + : 0.1234027192007D-06, 0.1968523220760D+01, 0.6286666145492D+01, + : 0.1244024091797D-06, 0.5779803499985D+01, 0.1511046609763D+02, + : 0.1097934945516D-06, 0.6210975221388D+00, 0.1098880815746D+02 / + DATA ((E0(I,J,2),I=1,3),J=111,120) / + : 0.1254611329856D-06, 0.2591963807998D+01, 0.1572083878776D+02, + : 0.1158247286784D-06, 0.2483612812670D+01, 0.5729506548653D+01, + : 0.9039078252960D-07, 0.3857554579796D+01, 0.9623688285163D+01, + : 0.9108024978836D-07, 0.5826368512984D+01, 0.7234794171227D+01, + : 0.8887068108436D-07, 0.3475694573987D+01, 0.6148010737701D+01, + : 0.8632374035438D-07, 0.3059070488983D-01, 0.6418140963190D+01, + : 0.7893186992967D-07, 0.1583194837728D+01, 0.2118763888447D+01, + : 0.8297650201172D-07, 0.8519770534637D+00, 0.1471231707864D+02, + : 0.1019759578988D-06, 0.1319598738732D+00, 0.1349867339771D+01, + : 0.1010037696236D-06, 0.9937860115618D+00, 0.6836645152238D+01 / + DATA ((E0(I,J,2),I=1,3),J=121,130) / + : 0.1047727548266D-06, 0.1382138405399D+01, 0.5999216516294D+01, + : 0.7351993881086D-07, 0.3833397851735D+01, 0.6040347114260D+01, + : 0.9868771092341D-07, 0.2124913814390D+01, 0.6566935184597D+01, + : 0.7007321959390D-07, 0.5946305343763D+01, 0.6525804586632D+01, + : 0.6861411679709D-07, 0.4574654977089D+01, 0.7238675589263D+01, + : 0.7554519809614D-07, 0.5949232686844D+01, 0.1253985337760D+02, + : 0.9541880448335D-07, 0.3495242990564D+01, 0.2122839202813D+02, + : 0.7185606722155D-07, 0.4310113471661D+01, 0.6245048154254D+01, + : 0.7131360871710D-07, 0.5480309323650D+01, 0.6321103546637D+01, + : 0.6651142021039D-07, 0.5411097713654D+01, 0.5327476111629D+01 / + DATA ((E0(I,J,2),I=1,3),J=131,140) / + : 0.8538618213667D-07, 0.1827849973951D+01, 0.1101510648075D+02, + : 0.8634954288044D-07, 0.5443584943349D+01, 0.5643178611111D+01, + : 0.7449415051484D-07, 0.2011535459060D+01, 0.5368044267797D+00, + : 0.7421047599169D-07, 0.3464562529249D+01, 0.2354323048545D+02, + : 0.6140694354424D-07, 0.5657556228815D+01, 0.1296430071988D+02, + : 0.6353525143033D-07, 0.3463816593821D+01, 0.1990745094947D+01, + : 0.6221964013447D-07, 0.1532259498697D+01, 0.9517183207817D+00, + : 0.5852480257244D-07, 0.1375396598875D+01, 0.9555997388169D+00, + : 0.6398637498911D-07, 0.2405645801972D+01, 0.2407292145756D+02, + : 0.7039744069878D-07, 0.5397541799027D+01, 0.5225775174439D+00 / + DATA ((E0(I,J,2),I=1,3),J=141,150) / + : 0.6977997694382D-07, 0.4762347105419D+01, 0.1097355562493D+02, + : 0.7460629558396D-07, 0.2711944692164D+01, 0.2200391463820D+02, + : 0.5376577536101D-07, 0.2352980430239D+01, 0.1431416805965D+02, + : 0.7530607893556D-07, 0.1943940180699D+01, 0.1842262939178D+02, + : 0.6822928971605D-07, 0.4337651846959D+01, 0.1554202828031D+00, + : 0.6220772380094D-07, 0.6716871369278D+00, 0.1845107853235D+02, + : 0.6586950799043D-07, 0.2229714460505D+01, 0.5216580451554D+01, + : 0.5873800565771D-07, 0.7627013920580D+00, 0.6398972393349D+00, + : 0.6264346929745D-07, 0.6202785478961D+00, 0.6277552955062D+01, + : 0.6257929115669D-07, 0.2886775596668D+01, 0.6288598745829D+01 / + DATA ((E0(I,J,2),I=1,3),J=151,160) / + : 0.5343536033409D-07, 0.1977241012051D+01, 0.4690479774488D+01, + : 0.5587849781714D-07, 0.1922923484825D+01, 0.1551045220144D+01, + : 0.6905100845603D-07, 0.3570757164631D+01, 0.1030928125552D+00, + : 0.6178957066649D-07, 0.5197558947765D+01, 0.5230807360890D+01, + : 0.6187270224331D-07, 0.8193497368922D+00, 0.5650292065779D+01, + : 0.5385664291426D-07, 0.5406336665586D+01, 0.7771377146812D+02, + : 0.6329363917926D-07, 0.2837760654536D+01, 0.2608790314060D+02, + : 0.4546018761604D-07, 0.2933580297050D+01, 0.5535693017924D+00, + : 0.6196091049375D-07, 0.4157871494377D+01, 0.8467247584405D+02, + : 0.6159555108218D-07, 0.3211703561703D+01, 0.2394243902548D+03 / + DATA ((E0(I,J,2),I=1,3),J=161,170) / + : 0.4995340539317D-07, 0.1459098102922D+01, 0.4732030630302D+01, + : 0.5457031243572D-07, 0.1430457676136D+01, 0.6179983037890D+01, + : 0.4863461418397D-07, 0.2196425916730D+01, 0.9027992316901D+02, + : 0.5342947626870D-07, 0.2086612890268D+01, 0.6386168663001D+01, + : 0.5674296648439D-07, 0.2760204966535D+01, 0.6915859635113D+01, + : 0.4745783120161D-07, 0.4245368971862D+01, 0.6282970628506D+01, + : 0.4745676961198D-07, 0.5544725787016D+01, 0.6283181072386D+01, + : 0.4049796869973D-07, 0.2213984363586D+01, 0.6254626709878D+01, + : 0.4248333596940D-07, 0.8075781952896D+00, 0.7875671926403D+01, + : 0.4027178070205D-07, 0.1293268540378D+01, 0.6311524991013D+01 / + DATA ((E0(I,J,2),I=1,3),J=171,180) / + : 0.4066543943476D-07, 0.3986141175804D+01, 0.3634620989887D+01, + : 0.4858863787880D-07, 0.1276112738231D+01, 0.5760498333002D+01, + : 0.5277398263530D-07, 0.4916111741527D+01, 0.2515860172507D+02, + : 0.4105635656559D-07, 0.1725805864426D+01, 0.6709674010002D+01, + : 0.4376781925772D-07, 0.2243642442106D+01, 0.6805653367890D+01, + : 0.3235827894693D-07, 0.3614135118271D+01, 0.1066495398892D+01, + : 0.3073244740308D-07, 0.2460873393460D+01, 0.5863591145557D+01, + : 0.3088609271373D-07, 0.5678431771790D+01, 0.9917696840332D+01, + : 0.3393022279836D-07, 0.3814017477291D+01, 0.1391601904066D+02, + : 0.3038686508802D-07, 0.4660216229171D+01, 0.1256621883632D+02 / + DATA ((E0(I,J,2),I=1,3),J=181,190) / + : 0.4019677752497D-07, 0.5906906243735D+01, 0.1334167431096D+02, + : 0.3288834998232D-07, 0.9536146445882D+00, 0.1620077269078D+02, + : 0.3889973794631D-07, 0.3942205097644D+01, 0.7478166569050D-01, + : 0.3050438987141D-07, 0.1624810271286D+01, 0.1805292951336D+02, + : 0.3601142564638D-07, 0.4030467142575D+01, 0.6208294184755D+01, + : 0.3689015557141D-07, 0.3648878818694D+01, 0.5966683958112D+01, + : 0.3563471893565D-07, 0.5749584017096D+01, 0.6357857516136D+01, + : 0.2776183170667D-07, 0.2630124187070D+01, 0.3523159621801D-02, + : 0.2922350530341D-07, 0.1790346403629D+01, 0.1272157198369D+02, + : 0.3511076917302D-07, 0.6142198301611D+01, 0.6599467742779D+01 / + DATA ((E0(I,J,2),I=1,3),J=191,200) / + : 0.3619351007632D-07, 0.1432421386492D+01, 0.6019991944201D+01, + : 0.2561254711098D-07, 0.2302822475792D+01, 0.1259245002418D+02, + : 0.2626903942920D-07, 0.8660470994571D+00, 0.6702560555334D+01, + : 0.2550187397083D-07, 0.6069721995383D+01, 0.1057540660594D+02, + : 0.2535873526138D-07, 0.1079020331795D-01, 0.3141537925223D+02, + : 0.3519786153847D-07, 0.3809066902283D+01, 0.2505706758577D+03, + : 0.3424651492873D-07, 0.2075435114417D+01, 0.6546159756691D+01, + : 0.2372676630861D-07, 0.2057803120154D+01, 0.2388894113936D+01, + : 0.2710980779541D-07, 0.1510068488010D+01, 0.1202934727411D+02, + : 0.3038710889704D-07, 0.5043617528901D+01, 0.1256608456547D+02 / + DATA ((E0(I,J,2),I=1,3),J=201,210) / + : 0.2220364130585D-07, 0.3694793218205D+01, 0.1336244973887D+02, + : 0.3025880825460D-07, 0.5450618999049D-01, 0.2908881142201D+02, + : 0.2784493486864D-07, 0.3381164084502D+01, 0.1494531617769D+02, + : 0.2294414142438D-07, 0.4382309025210D+01, 0.6076890225335D+01, + : 0.2012723294724D-07, 0.9142212256518D+00, 0.6262720680387D+01, + : 0.2036357831958D-07, 0.5676172293154D+01, 0.4701116388778D+01, + : 0.2003474823288D-07, 0.2592767977625D+01, 0.6303431020504D+01, + : 0.2207144900109D-07, 0.5404976271180D+01, 0.6489261475556D+01, + : 0.2481664905135D-07, 0.4373284587027D+01, 0.1204357418345D+02, + : 0.2674949182295D-07, 0.5859182188482D+01, 0.4590910121555D+01 / + DATA ((E0(I,J,2),I=1,3),J=211,220) / + : 0.2450554720322D-07, 0.4555381557451D+01, 0.1495633313810D+00, + : 0.2601975986457D-07, 0.3933165584959D+01, 0.1965104848470D+02, + : 0.2199860022848D-07, 0.5227977189087D+01, 0.1351787002167D+02, + : 0.2448121172316D-07, 0.4858060353949D+01, 0.1162474756779D+01, + : 0.1876014864049D-07, 0.5690546553605D+01, 0.6279194432410D+01, + : 0.1874513219396D-07, 0.4099539297446D+01, 0.6286957268481D+01, + : 0.2156380842559D-07, 0.4382594769913D+00, 0.1813929450232D+02, + : 0.1981691240061D-07, 0.1829784152444D+01, 0.4686889479442D+01, + : 0.2329992648539D-07, 0.2836254278973D+01, 0.1002183730415D+02, + : 0.1765184135302D-07, 0.2803494925833D+01, 0.4292330755499D+01 / + DATA ((E0(I,J,2),I=1,3),J=221,230) / + : 0.2436368366085D-07, 0.2836897959677D+01, 0.9514313292143D+02, + : 0.2164089203889D-07, 0.6127522446024D+01, 0.6037244212485D+01, + : 0.1847755034221D-07, 0.3683163635008D+01, 0.2427287361862D+00, + : 0.1674798769966D-07, 0.3316993867246D+00, 0.1311972100268D+02, + : 0.2222542124356D-07, 0.8294097805480D+00, 0.1266924451345D+02, + : 0.2071074505925D-07, 0.3659492220261D+01, 0.6528907488406D+01, + : 0.1608224471835D-07, 0.4774492067182D+01, 0.1352175143971D+02, + : 0.1857583439071D-07, 0.2873120597682D+01, 0.8662240327241D+01, + : 0.1793018836159D-07, 0.5282441177929D+00, 0.6819880277225D+01, + : 0.1575391221692D-07, 0.1320789654258D+01, 0.1102062672231D+00 / + DATA ((E0(I,J,2),I=1,3),J=231,240) / + : 0.1840132009557D-07, 0.1917110916256D+01, 0.6514761976723D+02, + : 0.1760917288281D-07, 0.2972635937132D+01, 0.5746271423666D+01, + : 0.1561779518516D-07, 0.4372569261981D+01, 0.6272439236156D+01, + : 0.1558687885205D-07, 0.5416424926425D+01, 0.6293712464735D+01, + : 0.1951359382579D-07, 0.3094448898752D+01, 0.2301353951334D+02, + : 0.1569144275614D-07, 0.2802103689808D+01, 0.1765478049437D+02, + : 0.1479130389462D-07, 0.2136435020467D+01, 0.2077542790660D-01, + : 0.1467828510764D-07, 0.7072627435674D+00, 0.1052268489556D+01, + : 0.1627627337440D-07, 0.3947607143237D+01, 0.6327837846670D+00, + : 0.1503498479758D-07, 0.4079248909190D+01, 0.7626583626240D-01 / + DATA ((E0(I,J,2),I=1,3),J=241,250) / + : 0.1297967708237D-07, 0.6269637122840D+01, 0.1149965630200D+02, + : 0.1374416896634D-07, 0.4175657970702D+01, 0.6016468784579D+01, + : 0.1783812325219D-07, 0.1476540547560D+01, 0.3301902111895D+02, + : 0.1525884228756D-07, 0.4653477715241D+01, 0.9411464614024D+01, + : 0.1451067396763D-07, 0.2573001128225D+01, 0.1277945078067D+02, + : 0.1297713111950D-07, 0.5612799618771D+01, 0.6549682916313D+01, + : 0.1462784012820D-07, 0.4189661623870D+01, 0.1863592847156D+02, + : 0.1384185980007D-07, 0.2656915472196D+01, 0.2379164476796D+01, + : 0.1221497599801D-07, 0.5612515760138D+01, 0.1257326515556D+02, + : 0.1560574525896D-07, 0.4783414317919D+01, 0.1887552587463D+02 / + DATA ((E0(I,J,2),I=1,3),J=251,260) / + : 0.1544598372036D-07, 0.2694431138063D+01, 0.1820933031200D+02, + : 0.1531678928696D-07, 0.4105103489666D+01, 0.2593412433514D+02, + : 0.1349321503795D-07, 0.3082437194015D+00, 0.5120601093667D+01, + : 0.1252030290917D-07, 0.6124072334087D+01, 0.6993008899458D+01, + : 0.1459243816687D-07, 0.3733103981697D+01, 0.3813291813120D-01, + : 0.1226103625262D-07, 0.1267127706817D+01, 0.2435678079171D+02, + : 0.1019449641504D-07, 0.4367790112269D+01, 0.1725663147538D+02, + : 0.1380789433607D-07, 0.3387201768700D+01, 0.2458316379602D+00, + : 0.1019453421658D-07, 0.9204143073737D+00, 0.6112403035119D+01, + : 0.1297929434405D-07, 0.5786874896426D+01, 0.1249137003520D+02 / + DATA ((E0(I,J,2),I=1,3),J=261,270) / + : 0.9912677786097D-08, 0.3164232870746D+01, 0.6247047890016D+01, + : 0.9829386098599D-08, 0.2586762413351D+01, 0.6453748665772D+01, + : 0.1226807746104D-07, 0.6239068436607D+01, 0.5429879531333D+01, + : 0.1192691755997D-07, 0.1867380051424D+01, 0.6290122169689D+01, + : 0.9836499227081D-08, 0.3424716293727D+00, 0.6319103810876D+01, + : 0.9642862564285D-08, 0.5661372990657D+01, 0.8273820945392D+01, + : 0.1165184404862D-07, 0.5768367239093D+01, 0.1778273215245D+02, + : 0.1175794418818D-07, 0.1657351222943D+01, 0.6276029531202D+01, + : 0.1018948635601D-07, 0.6458292350865D+00, 0.1254537627298D+02, + : 0.9500383606676D-08, 0.1054306140741D+01, 0.1256517118505D+02 / + DATA ((E0(I,J,2),I=1,3),J=271,280) / + : 0.1227512202906D-07, 0.2505278379114D+01, 0.2248384854122D+02, + : 0.9664792009993D-08, 0.4289737277000D+01, 0.6259197520765D+01, + : 0.9613285666331D-08, 0.5500597673141D+01, 0.6306954180126D+01, + : 0.1117906736211D-07, 0.2361405953468D+01, 0.1779695906178D+02, + : 0.9611378640782D-08, 0.2851310576269D+01, 0.2061856251104D+00, + : 0.8845354852370D-08, 0.6208777705343D+01, 0.1692165728891D+01, + : 0.1054046966600D-07, 0.5413091423934D+01, 0.2204125344462D+00, + : 0.1215539124483D-07, 0.5613969479755D+01, 0.8257698122054D+02, + : 0.9932460955209D-08, 0.1106124877015D+01, 0.1017725758696D+02, + : 0.8785804715043D-08, 0.2869224476477D+01, 0.9491756770005D+00 / + DATA ((E0(I,J,2),I=1,3),J=281,290) / + : 0.8538084097562D-08, 0.6159640899344D+01, 0.6393282117669D+01, + : 0.8648994369529D-08, 0.1374901198784D+01, 0.4804209201333D+01, + : 0.1039063219067D-07, 0.5171080641327D+01, 0.1550861511662D+02, + : 0.8867983926439D-08, 0.8317320304902D+00, 0.3903911373650D+01, + : 0.8327495955244D-08, 0.3605591969180D+01, 0.6172869583223D+01, + : 0.9243088356133D-08, 0.6114299196843D+01, 0.6267823317922D+01, + : 0.9205657357835D-08, 0.3675153683737D+01, 0.6298328382969D+01, + : 0.1033269714606D-07, 0.3313328813024D+01, 0.5573142801433D+01, + : 0.8001706275552D-08, 0.2019980960053D+01, 0.2648454860559D+01, + : 0.9171858254191D-08, 0.8992015524177D+00, 0.1498544001348D+03 / + DATA ((E0(I,J,2),I=1,3),J=291,300) / + : 0.1075327150242D-07, 0.2898669963648D+01, 0.3694923081589D+02, + : 0.9884866689828D-08, 0.4946715904478D+01, 0.1140367694411D+02, + : 0.9541835576677D-08, 0.2371787888469D+01, 0.1256713221673D+02, + : 0.7739903376237D-08, 0.2213775190612D+01, 0.7834121070590D+01, + : 0.7311962684106D-08, 0.3429378787739D+01, 0.1192625446156D+02, + : 0.9724904869624D-08, 0.6195878564404D+01, 0.2280573557157D+02, + : 0.9251628983612D-08, 0.6511509527390D+00, 0.2787043132925D+01, + : 0.7320763787842D-08, 0.6001083639421D+01, 0.6282655592598D+01, + : 0.7320296650962D-08, 0.3789073265087D+01, 0.6283496108294D+01, + : 0.7947032271039D-08, 0.1059659582204D+01, 0.1241073141809D+02 / + DATA ((E0(I,J,2),I=1,3),J=301,310) / + : 0.9005277053115D-08, 0.1280315624361D+01, 0.6281591679874D+01, + : 0.8995601652048D-08, 0.2224439106766D+01, 0.6284560021018D+01, + : 0.8288040568796D-08, 0.5234914433867D+01, 0.1241658836951D+02, + : 0.6359381347255D-08, 0.4137989441490D+01, 0.1596186371003D+01, + : 0.8699572228626D-08, 0.1758411009497D+01, 0.6133512519065D+01, + : 0.6456797542736D-08, 0.5919285089994D+01, 0.1685848245639D+02, + : 0.7424573475452D-08, 0.5414616938827D+01, 0.4061219149443D+01, + : 0.7235671196168D-08, 0.1496516557134D+01, 0.1610006857377D+03, + : 0.8104015182733D-08, 0.1919918242764D+01, 0.8460828644453D+00, + : 0.8098576535937D-08, 0.3819615855458D+01, 0.3894181736510D+01 / + DATA ((E0(I,J,2),I=1,3),J=311,320) / + : 0.6275292346625D-08, 0.6244264115141D+01, 0.8531963191132D+00, + : 0.6052432989112D-08, 0.5037731872610D+00, 0.1567108171867D+02, + : 0.5705651535817D-08, 0.2984557271995D+01, 0.1258692712880D+02, + : 0.5789650115138D-08, 0.6087038140697D+01, 0.1193336791622D+02, + : 0.5512132153377D-08, 0.5855668994076D+01, 0.1232342296471D+02, + : 0.7388890819102D-08, 0.2443128574740D+01, 0.4907302013889D+01, + : 0.5467593991798D-08, 0.3017561234194D+01, 0.1884211409667D+02, + : 0.6388519802999D-08, 0.5887386712935D+01, 0.5217580628120D+02, + : 0.6106777149944D-08, 0.3483461059895D+00, 0.1422690933580D-01, + : 0.7383420275489D-08, 0.5417387056707D+01, 0.2358125818164D+02 / + DATA ((E0(I,J,2),I=1,3),J=321,330) / + : 0.5505208141738D-08, 0.2848193644783D+01, 0.1151388321134D+02, + : 0.6310757462877D-08, 0.2349882520828D+01, 0.1041998632314D+02, + : 0.6166904929691D-08, 0.5728575944077D+00, 0.6151533897323D+01, + : 0.5263442042754D-08, 0.4495796125937D+01, 0.1885275071096D+02, + : 0.5591828082629D-08, 0.1355441967677D+01, 0.4337116142245D+00, + : 0.5397051680497D-08, 0.1673422864307D+01, 0.6286362197481D+01, + : 0.5396992745159D-08, 0.1833502206373D+01, 0.6279789503410D+01, + : 0.6572913000726D-08, 0.3331122065824D+01, 0.1176433076753D+02, + : 0.5123421866413D-08, 0.2165327142679D+01, 0.1245594543367D+02, + : 0.5930495725999D-08, 0.2931146089284D+01, 0.6414617803568D+01 / + DATA ((E0(I,J,2),I=1,3),J=331,340) / + : 0.6431797403933D-08, 0.4134407994088D+01, 0.1350651127443D+00, + : 0.5003182207604D-08, 0.3805420303749D+01, 0.1096996532989D+02, + : 0.5587731032504D-08, 0.1082469260599D+01, 0.6062663316000D+01, + : 0.5935263407816D-08, 0.8384333678401D+00, 0.5326786718777D+01, + : 0.4756019827760D-08, 0.3552588749309D+01, 0.3104930017775D+01, + : 0.6599951172637D-08, 0.4320826409528D+01, 0.4087944051283D+02, + : 0.5902606868464D-08, 0.4811879454445D+01, 0.5849364236221D+01, + : 0.5921147809031D-08, 0.9942628922396D-01, 0.1581959461667D+01, + : 0.5505382581266D-08, 0.2466557607764D+01, 0.6503488384892D+01, + : 0.5353771071862D-08, 0.4551978748683D+01, 0.1735668374386D+03 / + DATA ((E0(I,J,2),I=1,3),J=341,350) / + : 0.5063282210946D-08, 0.5710812312425D+01, 0.1248988586463D+02, + : 0.5926120403383D-08, 0.1333998428358D+01, 0.2673594526851D+02, + : 0.5211016176149D-08, 0.4649315360760D+01, 0.2460261242967D+02, + : 0.5347075084894D-08, 0.5512754081205D+01, 0.4171425416666D+01, + : 0.4872609773574D-08, 0.1308025299938D+01, 0.5333900173445D+01, + : 0.4727711321420D-08, 0.2144908368062D+01, 0.7232251527446D+01, + : 0.6029426018652D-08, 0.5567259412084D+01, 0.3227113045244D+03, + : 0.4321485284369D-08, 0.5230667156451D+01, 0.9388005868221D+01, + : 0.4476406760553D-08, 0.6134081115303D+01, 0.5547199253223D+01, + : 0.5835268277420D-08, 0.4783808492071D+01, 0.7285056171570D+02 / + DATA ((E0(I,J,2),I=1,3),J=351,360) / + : 0.5172183602748D-08, 0.5161817911099D+01, 0.1884570439172D+02, + : 0.5693571465184D-08, 0.1381646203111D+01, 0.9723862754494D+02, + : 0.4060634965349D-08, 0.3876705259495D+00, 0.4274518229222D+01, + : 0.3967398770473D-08, 0.5029491776223D+01, 0.3496032717521D+01, + : 0.3943754005255D-08, 0.1923162955490D+01, 0.6244942932314D+01, + : 0.4781323427824D-08, 0.4633332586423D+01, 0.2929661536378D+02, + : 0.3871483781204D-08, 0.1616650009743D+01, 0.6321208768577D+01, + : 0.5141741733997D-08, 0.9817316704659D-01, 0.1232032006293D+02, + : 0.4002385978497D-08, 0.3656161212139D+01, 0.7018952447668D+01, + : 0.4901092604097D-08, 0.4404098713092D+01, 0.1478866649112D+01 / + DATA ((E0(I,J,2),I=1,3),J=361,370) / + : 0.3740932630345D-08, 0.5181188732639D+00, 0.6922973089781D+01, + : 0.4387283718538D-08, 0.3254859566869D+01, 0.2331413144044D+03, + : 0.5019197802033D-08, 0.3086773224677D+01, 0.1715706182245D+02, + : 0.3834931695175D-08, 0.2797882673542D+01, 0.1491901785440D+02, + : 0.3760413942497D-08, 0.2892676280217D+01, 0.1726726808967D+02, + : 0.3719717204628D-08, 0.5861046025739D+01, 0.6297302759782D+01, + : 0.4145623530149D-08, 0.2168239627033D+01, 0.1376059875786D+02, + : 0.3932788425380D-08, 0.6271811124181D+01, 0.7872148766781D+01, + : 0.3686377476857D-08, 0.3936853151404D+01, 0.6268848941110D+01, + : 0.3779077950339D-08, 0.1404148734043D+01, 0.4157198507331D+01 / + DATA ((E0(I,J,2),I=1,3),J=371,380) / + : 0.4091334550598D-08, 0.2452436180854D+01, 0.9779108567966D+01, + : 0.3926694536146D-08, 0.6102292739040D+01, 0.1098419223922D+02, + : 0.4841000253289D-08, 0.6072760457276D+01, 0.1252801878276D+02, + : 0.4949340130240D-08, 0.1154832815171D+01, 0.1617106187867D+03, + : 0.3761557737360D-08, 0.5527545321897D+01, 0.3185192151914D+01, + : 0.3647396268188D-08, 0.1525035688629D+01, 0.6271346477544D+01, + : 0.3932405074189D-08, 0.5570681040569D+01, 0.2139354194808D+02, + : 0.3631322501141D-08, 0.1981240601160D+01, 0.6294805223347D+01, + : 0.4130007425139D-08, 0.2050060880201D+01, 0.2195415756911D+02, + : 0.4433905965176D-08, 0.3277477970321D+01, 0.7445550607224D+01 / + DATA ((E0(I,J,2),I=1,3),J=381,390) / + : 0.3851814176947D-08, 0.5210690074886D+01, 0.9562891316684D+00, + : 0.3485807052785D-08, 0.6653274904611D+00, 0.1161697602389D+02, + : 0.3979772816991D-08, 0.1767941436148D+01, 0.2277943724828D+02, + : 0.3402607460500D-08, 0.3421746306465D+01, 0.1087398597200D+02, + : 0.4049993000926D-08, 0.1127144787547D+01, 0.3163918923335D+00, + : 0.3420511182382D-08, 0.4214794779161D+01, 0.1362553364512D+02, + : 0.3640772365012D-08, 0.5324905497687D+01, 0.1725304118033D+02, + : 0.3323037987501D-08, 0.6135761838271D+01, 0.6279143387820D+01, + : 0.4503141663637D-08, 0.1802305450666D+01, 0.1385561574497D+01, + : 0.4314560055588D-08, 0.4812299731574D+01, 0.4176041334900D+01 / + DATA ((E0(I,J,2),I=1,3),J=391,400) / + : 0.3294226949110D-08, 0.3657547059723D+01, 0.6287008313071D+01, + : 0.3215657197281D-08, 0.4866676894425D+01, 0.5749861718712D+01, + : 0.4129362656266D-08, 0.3809342558906D+01, 0.5905702259363D+01, + : 0.3137762976388D-08, 0.2494635174443D+01, 0.2099539292909D+02, + : 0.3514010952384D-08, 0.2699961831678D+01, 0.7335344340001D+01, + : 0.3327607571530D-08, 0.3318457714816D+01, 0.5436992986000D+01, + : 0.3541066946675D-08, 0.4382703582466D+01, 0.1234573916645D+02, + : 0.3216179847052D-08, 0.5271066317054D+01, 0.3802769619140D-01, + : 0.2959045059570D-08, 0.5819591585302D+01, 0.2670964694522D+02, + : 0.3884040326665D-08, 0.5980934960428D+01, 0.6660449441528D+01 / + DATA ((E0(I,J,2),I=1,3),J=401,410) / + : 0.2922027539886D-08, 0.3337290282483D+01, 0.1375773836557D+01, + : 0.4110846382042D-08, 0.5742978187327D+01, 0.4480965020977D+02, + : 0.2934508411032D-08, 0.2278075804200D+01, 0.6408777551755D+00, + : 0.3966896193000D-08, 0.5835747858477D+01, 0.3773735910827D+00, + : 0.3286695827610D-08, 0.5838898193902D+01, 0.3932462625300D-02, + : 0.3720643094196D-08, 0.1122212337858D+01, 0.1646033343740D+02, + : 0.3285508906174D-08, 0.9182250996416D+00, 0.1081813534213D+02, + : 0.3753880575973D-08, 0.5174761973266D+01, 0.5642198095270D+01, + : 0.3022129385587D-08, 0.3381611020639D+01, 0.2982630633589D+02, + : 0.2798569205621D-08, 0.3546193723922D+01, 0.1937891852345D+02 / + DATA ((E0(I,J,2),I=1,3),J=411,420) / + : 0.3397872070505D-08, 0.4533203197934D+01, 0.6923953605621D+01, + : 0.3708099772977D-08, 0.2756168198616D+01, 0.3066615496545D+02, + : 0.3599283541510D-08, 0.1934395469918D+01, 0.6147450479709D+01, + : 0.3688702753059D-08, 0.7149920971109D+00, 0.2636725487657D+01, + : 0.2681084724003D-08, 0.4899819493154D+01, 0.6816289982179D+01, + : 0.3495993460759D-08, 0.1572418915115D+01, 0.6418701221183D+01, + : 0.3130770324995D-08, 0.8912190180489D+00, 0.1235996607578D+02, + : 0.2744353821941D-08, 0.3800821940055D+01, 0.2059724391010D+02, + : 0.2842732906341D-08, 0.2644717440029D+01, 0.2828699048865D+02, + : 0.3046882682154D-08, 0.3987793020179D+01, 0.6055599646783D+01 / + DATA ((E0(I,J,2),I=1,3),J=421,430) / + : 0.2399072455143D-08, 0.9908826440764D+00, 0.6255674361143D+01, + : 0.2384306274204D-08, 0.2516149752220D+01, 0.6310477339748D+01, + : 0.2977324500559D-08, 0.5849195642118D+01, 0.1652265972112D+02, + : 0.3062835258972D-08, 0.1681660100162D+01, 0.1172006883645D+02, + : 0.3109682589231D-08, 0.5804143987737D+00, 0.2751146787858D+02, + : 0.2903920355299D-08, 0.5800768280123D+01, 0.6510552054109D+01, + : 0.2823221989212D-08, 0.9241118370216D+00, 0.5469525544182D+01, + : 0.3187949696649D-08, 0.3139776445735D+01, 0.1693792562116D+03, + : 0.2922559771655D-08, 0.3549440782984D+01, 0.2630839062450D+00, + : 0.2436302066603D-08, 0.4735540696319D+01, 0.3946258593675D+00 / + DATA ((E0(I,J,2),I=1,3),J=431,440) / + : 0.3049473043606D-08, 0.4998289124561D+01, 0.8390110365991D+01, + : 0.2863682575784D-08, 0.6709515671102D+00, 0.2243449970715D+00, + : 0.2641750517966D-08, 0.5410978257284D+01, 0.2986433403208D+02, + : 0.2704093466243D-08, 0.4778317207821D+01, 0.6129297044991D+01, + : 0.2445522177011D-08, 0.6009020662222D+01, 0.1171295538178D+02, + : 0.2623608810230D-08, 0.5010449777147D+01, 0.6436854655901D+01, + : 0.2079259704053D-08, 0.5980943768809D+01, 0.2019909489111D+02, + : 0.2820225596771D-08, 0.2679965110468D+01, 0.5934151399930D+01, + : 0.2365221950927D-08, 0.1894231148810D+01, 0.2470570524223D+02, + : 0.2359682077149D-08, 0.4220752950780D+01, 0.8671969964381D+01 / + DATA ((E0(I,J,2),I=1,3),J=441,450) / + : 0.2387577137206D-08, 0.2571783940617D+01, 0.7096626156709D+01, + : 0.1982102089816D-08, 0.5169765997119D+00, 0.1727188400790D+02, + : 0.2687502389925D-08, 0.6239078264579D+01, 0.7075506709219D+02, + : 0.2207751669135D-08, 0.2031184412677D+01, 0.4377611041777D+01, + : 0.2618370214274D-08, 0.8266079985979D+00, 0.6632000300961D+01, + : 0.2591951887361D-08, 0.8819350522008D+00, 0.4873985990671D+02, + : 0.2375055656248D-08, 0.3520944177789D+01, 0.1590676413561D+02, + : 0.2472019978911D-08, 0.1551431908671D+01, 0.6612329252343D+00, + : 0.2368157127199D-08, 0.4178610147412D+01, 0.3459636466239D+02, + : 0.1764846605693D-08, 0.1506764000157D+01, 0.1980094587212D+02 / + DATA ((E0(I,J,2),I=1,3),J=451,460) / + : 0.2291769608798D-08, 0.2118250611782D+01, 0.2844914056730D-01, + : 0.2209997316943D-08, 0.3363255261678D+01, 0.2666070658668D+00, + : 0.2292699097923D-08, 0.4200423956460D+00, 0.1484170571900D-02, + : 0.1629683015329D-08, 0.2331362582487D+01, 0.3035599730800D+02, + : 0.2206492862426D-08, 0.3400274026992D+01, 0.6281667977667D+01, + : 0.2205746568257D-08, 0.1066051230724D+00, 0.6284483723224D+01, + : 0.2026310767991D-08, 0.2779066487979D+01, 0.2449240616245D+02, + : 0.1762977622163D-08, 0.9951450691840D+00, 0.2045286941806D+02, + : 0.1368535049606D-08, 0.6402447365817D+00, 0.2473415438279D+02, + : 0.1720598775450D-08, 0.2303524214705D+00, 0.1679593901136D+03 / + DATA ((E0(I,J,2),I=1,3),J=461,470) / + : 0.1702429015449D-08, 0.6164622655048D+01, 0.3338575901272D+03, + : 0.1414033197685D-08, 0.3954561185580D+01, 0.1624205518357D+03, + : 0.1573768958043D-08, 0.2028286308984D+01, 0.3144167757552D+02, + : 0.1650705184447D-08, 0.2304040666128D+01, 0.5267006960365D+02, + : 0.1651087618855D-08, 0.2538461057280D+01, 0.8956999012000D+02, + : 0.1616409518983D-08, 0.5111054348152D+01, 0.3332657872986D+02, + : 0.1537175173581D-08, 0.5601130666603D+01, 0.3852657435933D+02, + : 0.1593191980553D-08, 0.2614340453411D+01, 0.2282781046519D+03, + : 0.1499480170643D-08, 0.3624721577264D+01, 0.2823723341956D+02, + : 0.1493807843235D-08, 0.4214569879008D+01, 0.2876692439167D+02 / + DATA ((E0(I,J,2),I=1,3),J=471,480) / + : 0.1074571199328D-08, 0.1496911744704D+00, 0.8397383534231D+02, + : 0.1074406983417D-08, 0.1187817671922D+01, 0.8401985929482D+02, + : 0.9757576855851D-09, 0.2655703035858D+01, 0.7826370942180D+02, + : 0.1258432887565D-08, 0.4969896184844D+01, 0.3115650189215D+03, + : 0.1240336343282D-08, 0.5192460776926D+01, 0.1784300471910D+03, + : 0.9016107005164D-09, 0.1960356923057D+01, 0.5886454391678D+02, + : 0.1135392360918D-08, 0.5082427809068D+01, 0.7842370451713D+02, + : 0.9216046089565D-09, 0.2793775037273D+01, 0.1014262087719D+03, + : 0.1061276615030D-08, 0.3726144311409D+01, 0.5660027930059D+02, + : 0.1010110596263D-08, 0.7404080708937D+00, 0.4245678405627D+02 / + DATA ((E0(I,J,2),I=1,3),J=481,490) / + : 0.7217424756199D-09, 0.2697449980577D-01, 0.2457074661053D+03, + : 0.6912003846756D-09, 0.4253296276335D+01, 0.1679936946371D+03, + : 0.6871814664847D-09, 0.5148072412354D+01, 0.6053048899753D+02, + : 0.4887158016343D-09, 0.2153581148294D+01, 0.9656299901946D+02, + : 0.5161802866314D-09, 0.3852750634351D+01, 0.2442876000072D+03, + : 0.5652599559057D-09, 0.1233233356270D+01, 0.8365903305582D+02, + : 0.4710812608586D-09, 0.5610486976767D+01, 0.3164282286739D+03, + : 0.4909977500324D-09, 0.1639629524123D+01, 0.4059982187939D+03, + : 0.4772641839378D-09, 0.3737100368583D+01, 0.1805255418145D+03, + : 0.4487562567153D-09, 0.1158417054478D+00, 0.8433466158131D+02 / + DATA ((E0(I,J,2),I=1,3),J=491,500) / + : 0.3943441230497D-09, 0.6243502862796D+00, 0.2568537517081D+03, + : 0.3952236913598D-09, 0.3510377382385D+01, 0.2449975330562D+03, + : 0.3788898363417D-09, 0.5916128302299D+01, 0.1568131045107D+03, + : 0.3738329328831D-09, 0.1042266763456D+01, 0.3948519331910D+03, + : 0.2451199165151D-09, 0.1166788435700D+01, 0.1435713242844D+03, + : 0.2436734402904D-09, 0.3254726114901D+01, 0.2268582385539D+03, + : 0.2213605274325D-09, 0.1687210598530D+01, 0.1658638954901D+03, + : 0.1491521204829D-09, 0.2657541786794D+01, 0.2219950288015D+03, + : 0.1474995329744D-09, 0.5013089805819D+01, 0.3052819430710D+03, + : 0.1661939475656D-09, 0.5495315428418D+01, 0.2526661704812D+03 / + DATA ((E0(I,J,2),I=1,3),J=501,NE0Y) / + : 0.9015946748003D-10, 0.2236989966505D+01, 0.4171445043968D+03 / + +* Sun-to-Earth, T^1, Y + DATA ((E1(I,J,2),I=1,3),J= 1, 10) / + : 0.9304690546528D-06, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.5150715570663D-06, 0.4431807116294D+01, 0.1256615170089D+02, + : 0.1290825411056D-07, 0.4388610039678D+01, 0.1884922755134D+02, + : 0.4645466665386D-08, 0.5827263376034D+01, 0.6283075850446D+01, + : 0.2079625310718D-08, 0.1621698662282D+00, 0.6279552690824D+01, + : 0.2078189850907D-08, 0.3344713435140D+01, 0.6286599010068D+01, + : 0.6207190138027D-09, 0.5074049319576D+01, 0.4705732307012D+01, + : 0.5989826532569D-09, 0.2231842216620D+01, 0.6256777527156D+01, + : 0.5961360812618D-09, 0.1274975769045D+01, 0.6309374173736D+01, + : 0.4874165471016D-09, 0.3642277426779D+01, 0.7755226100720D+00 / + DATA ((E1(I,J,2),I=1,3),J= 11, 20) / + : 0.4283834034360D-09, 0.5148765510106D+01, 0.1059381944224D+01, + : 0.4652389287529D-09, 0.4715794792175D+01, 0.7860419393880D+01, + : 0.3751707476401D-09, 0.6617207370325D+00, 0.5753384878334D+01, + : 0.3559998806198D-09, 0.6155548875404D+01, 0.5884926831456D+01, + : 0.3558447558857D-09, 0.2898827297664D+01, 0.6812766822558D+01, + : 0.3211116927106D-09, 0.3625813502509D+01, 0.6681224869435D+01, + : 0.2875609914672D-09, 0.4345435813134D+01, 0.2513230340178D+02, + : 0.2843109704069D-09, 0.5862263940038D+01, 0.6127655567643D+01, + : 0.2744676468427D-09, 0.3926419475089D+01, 0.6438496133249D+01, + : 0.2481285237789D-09, 0.1351976572828D+01, 0.5486777812467D+01 / + DATA ((E1(I,J,2),I=1,3),J= 21, 30) / + : 0.2060338481033D-09, 0.2147556998591D+01, 0.7079373888424D+01, + : 0.2015822358331D-09, 0.4408358972216D+01, 0.6290189305114D+01, + : 0.2001195944195D-09, 0.5385829822531D+01, 0.6275962395778D+01, + : 0.1953667642377D-09, 0.1304933746120D+01, 0.5507553240374D+01, + : 0.1839744078713D-09, 0.6173567228835D+01, 0.1179062909082D+02, + : 0.1643334294845D-09, 0.4635942997523D+01, 0.1150676975667D+02, + : 0.1768051018652D-09, 0.5086283558874D+01, 0.7113454667900D-02, + : 0.1674874205489D-09, 0.2243332137241D+01, 0.7058598460518D+01, + : 0.1421445397609D-09, 0.6186899771515D+01, 0.7962980379786D+00, + : 0.1255163958267D-09, 0.5730238465658D+01, 0.4694002934110D+01 / + DATA ((E1(I,J,2),I=1,3),J= 31, 40) / + : 0.1013945281961D-09, 0.1726055228402D+01, 0.3738761453707D+01, + : 0.1047294335852D-09, 0.2658801228129D+01, 0.6282095334605D+01, + : 0.1047103879392D-09, 0.8481047835035D+00, 0.6284056366286D+01, + : 0.9530343962826D-10, 0.3079267149859D+01, 0.6069776770667D+01, + : 0.9604637611690D-10, 0.3258679792918D+00, 0.4136910472696D+01, + : 0.9153518537177D-10, 0.4398599886584D+00, 0.6496374930224D+01, + : 0.8562458214922D-10, 0.4772686794145D+01, 0.1194447056968D+01, + : 0.8232525360654D-10, 0.5966220721679D+01, 0.1589072916335D+01, + : 0.6150223411438D-10, 0.1780985591923D+01, 0.8827390247185D+01, + : 0.6272087858000D-10, 0.3184305429012D+01, 0.8429241228195D+01 / + DATA ((E1(I,J,2),I=1,3),J= 41, 50) / + : 0.5540476311040D-10, 0.3801260595433D+01, 0.4933208510675D+01, + : 0.7331901699361D-10, 0.5205948591865D+01, 0.4535059491685D+01, + : 0.6018528702791D-10, 0.4770139083623D+01, 0.1255903824622D+02, + : 0.5150530724804D-10, 0.3574796899585D+01, 0.1176985366291D+02, + : 0.6471933741811D-10, 0.2679787266521D+01, 0.5088628793478D+01, + : 0.5317460644174D-10, 0.9528763345494D+00, 0.3154687086868D+01, + : 0.4832187748783D-10, 0.5329322498232D+01, 0.6040347114260D+01, + : 0.4716763555110D-10, 0.2395235316466D+01, 0.5331357529664D+01, + : 0.4871509139861D-10, 0.3056663648823D+01, 0.1256967486051D+02, + : 0.4598417696768D-10, 0.4452762609019D+01, 0.6525804586632D+01 / + DATA ((E1(I,J,2),I=1,3),J= 51, 60) / + : 0.5674189533175D-10, 0.9879680872193D+00, 0.5729506548653D+01, + : 0.4073560328195D-10, 0.5939127696986D+01, 0.7632943190217D+01, + : 0.5040994945359D-10, 0.4549875824510D+01, 0.8031092209206D+01, + : 0.5078185134679D-10, 0.7346659893982D+00, 0.7477522907414D+01, + : 0.3769343537061D-10, 0.1071317188367D+01, 0.7234794171227D+01, + : 0.4980331365299D-10, 0.2500345341784D+01, 0.6836645152238D+01, + : 0.3458236594757D-10, 0.3825159450711D+01, 0.1097707878456D+02, + : 0.3578859493602D-10, 0.5299664791549D+01, 0.4164311961999D+01, + : 0.3370504646419D-10, 0.5002316301593D+01, 0.1137170464392D+02, + : 0.3299873338428D-10, 0.2526123275282D+01, 0.3930209696940D+01 / + DATA ((E1(I,J,2),I=1,3),J= 61, 70) / + : 0.4304917318409D-10, 0.3368078557132D+01, 0.1592596075957D+01, + : 0.3402418753455D-10, 0.8385495425800D+00, 0.3128388763578D+01, + : 0.2778460572146D-10, 0.3669905203240D+01, 0.7342457794669D+01, + : 0.2782710128902D-10, 0.2691664812170D+00, 0.1748016358760D+01, + : 0.2711725179646D-10, 0.4707487217718D+01, 0.5296909721118D+00, + : 0.2981760946340D-10, 0.3190260867816D+00, 0.5368044267797D+00, + : 0.2811672977772D-10, 0.3196532315372D+01, 0.7084896783808D+01, + : 0.2863454474467D-10, 0.2263240324780D+00, 0.5223693906222D+01, + : 0.3333464634051D-10, 0.3498451685065D+01, 0.8018209333619D+00, + : 0.3312991747609D-10, 0.5839154477412D+01, 0.1554202828031D+00 / + DATA ((E1(I,J,2),I=1,3),J= 71,NE1Y) / + : 0.2813255564006D-10, 0.8268044346621D+00, 0.5225775174439D+00, + : 0.2665098083966D-10, 0.3934021725360D+01, 0.5216580451554D+01, + : 0.2349795705216D-10, 0.5197620913779D+01, 0.2146165377750D+01, + : 0.2330352293961D-10, 0.2984999231807D+01, 0.1726015463500D+02, + : 0.2728001683419D-10, 0.6521679638544D+00, 0.8635942003952D+01, + : 0.2484061007669D-10, 0.3468955561097D+01, 0.5230807360890D+01, + : 0.2646328768427D-10, 0.1013724533516D+01, 0.2629832328990D-01, + : 0.2518630264831D-10, 0.6108081057122D+01, 0.5481254917084D+01, + : 0.2421901455384D-10, 0.1651097776260D+01, 0.1349867339771D+01, + : 0.6348533267831D-11, 0.3220226560321D+01, 0.8433466158131D+02 / + +* Sun-to-Earth, T^2, Y + DATA ((E2(I,J,2),I=1,3),J= 1,NE2Y) / + : 0.5063375872532D-10, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.2173815785980D-10, 0.2827805833053D+01, 0.1256615170089D+02, + : 0.1010231999920D-10, 0.4634612377133D+01, 0.6283075850446D+01, + : 0.9259745317636D-12, 0.2620612076189D+01, 0.1884922755134D+02, + : 0.1022202095812D-12, 0.3809562326066D+01, 0.8399684731857D+02 / + +* Sun-to-Earth, T^0, Z + DATA ((E0(I,J,3),I=1,3),J= 1, 10) / + : 0.2796207639075D-05, 0.3198701560209D+01, 0.8433466158131D+02, + : 0.1016042198142D-05, 0.5422360395913D+01, 0.5507553240374D+01, + : 0.8044305033647D-06, 0.3880222866652D+01, 0.5223693906222D+01, + : 0.4385347909274D-06, 0.3704369937468D+01, 0.2352866153506D+01, + : 0.3186156414906D-06, 0.3999639363235D+01, 0.1577343543434D+01, + : 0.2272412285792D-06, 0.3984738315952D+01, 0.1047747311755D+01, + : 0.1645620103007D-06, 0.3565412516841D+01, 0.5856477690889D+01, + : 0.1815836921166D-06, 0.4984507059020D+01, 0.6283075850446D+01, + : 0.1447461676364D-06, 0.3702753570108D+01, 0.9437762937313D+01, + : 0.1430760876382D-06, 0.3409658712357D+01, 0.1021328554739D+02 / + DATA ((E0(I,J,3),I=1,3),J= 11, 20) / + : 0.1120445753226D-06, 0.4829561570246D+01, 0.1414349524433D+02, + : 0.1090232840797D-06, 0.2080729178066D+01, 0.6812766822558D+01, + : 0.9715727346551D-07, 0.3476295881948D+01, 0.4694002934110D+01, + : 0.1036267136217D-06, 0.4056639536648D+01, 0.7109288135493D+02, + : 0.8752665271340D-07, 0.4448159519911D+01, 0.5753384878334D+01, + : 0.8331864956004D-07, 0.4991704044208D+01, 0.7084896783808D+01, + : 0.6901658670245D-07, 0.4325358994219D+01, 0.6275962395778D+01, + : 0.9144536848998D-07, 0.1141826375363D+01, 0.6620890113188D+01, + : 0.7205085037435D-07, 0.3624344170143D+01, 0.5296909721118D+00, + : 0.7697874654176D-07, 0.5554257458998D+01, 0.1676215758509D+03 / + DATA ((E0(I,J,3),I=1,3),J= 21, 30) / + : 0.5197545738384D-07, 0.6251760961735D+01, 0.1807370494127D+02, + : 0.5031345378608D-07, 0.2497341091913D+01, 0.4705732307012D+01, + : 0.4527110205840D-07, 0.2335079920992D+01, 0.6309374173736D+01, + : 0.4753355798089D-07, 0.7094148987474D+00, 0.5884926831456D+01, + : 0.4296951977516D-07, 0.1101916352091D+01, 0.6681224869435D+01, + : 0.3855341568387D-07, 0.1825495405486D+01, 0.5486777812467D+01, + : 0.5253930970990D-07, 0.4424740687208D+01, 0.7860419393880D+01, + : 0.4024630496471D-07, 0.5120498157053D+01, 0.1336797263425D+02, + : 0.4061069791453D-07, 0.6029771435451D+01, 0.3930209696940D+01, + : 0.3797883804205D-07, 0.4435193600836D+00, 0.3154687086868D+01 / + DATA ((E0(I,J,3),I=1,3),J= 31, 40) / + : 0.2933033225587D-07, 0.5124157356507D+01, 0.1059381944224D+01, + : 0.3503000930426D-07, 0.5421830162065D+01, 0.6069776770667D+01, + : 0.3670096214050D-07, 0.4582101667297D+01, 0.1219403291462D+02, + : 0.2905609437008D-07, 0.1926566420072D+01, 0.1097707878456D+02, + : 0.2466827821713D-07, 0.6090174539834D+00, 0.6496374930224D+01, + : 0.2691647295332D-07, 0.1393432595077D+01, 0.2200391463820D+02, + : 0.2150554667946D-07, 0.4308671715951D+01, 0.5643178611111D+01, + : 0.2237481922680D-07, 0.8133968269414D+00, 0.8635942003952D+01, + : 0.1817741038157D-07, 0.3755205127454D+01, 0.3340612434717D+01, + : 0.2227820762132D-07, 0.2759558596664D+01, 0.1203646072878D+02 / + DATA ((E0(I,J,3),I=1,3),J= 41, 50) / + : 0.1944713772307D-07, 0.5699645869121D+01, 0.1179062909082D+02, + : 0.1527340520662D-07, 0.1986749091746D+01, 0.3981490189893D+00, + : 0.1577282574914D-07, 0.3205017217983D+01, 0.5088628793478D+01, + : 0.1424738825424D-07, 0.6256747903666D+01, 0.2544314396739D+01, + : 0.1616563121701D-07, 0.2601671259394D+00, 0.1729818233119D+02, + : 0.1401210391692D-07, 0.4686939173506D+01, 0.7058598460518D+01, + : 0.1488726974214D-07, 0.2815862451372D+01, 0.2593412433514D+02, + : 0.1692626442388D-07, 0.4956894109797D+01, 0.1564752902480D+03, + : 0.1123571582910D-07, 0.2381192697696D+01, 0.3738761453707D+01, + : 0.9903308606317D-08, 0.4294851657684D+01, 0.9225539266174D+01 / + DATA ((E0(I,J,3),I=1,3),J= 51, 60) / + : 0.9174533187191D-08, 0.3075171510642D+01, 0.4164311961999D+01, + : 0.8645985631457D-08, 0.5477534821633D+00, 0.8429241228195D+01, + : -0.1085876492688D-07, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.9264309077815D-08, 0.5968571670097D+01, 0.7079373888424D+01, + : 0.8243116984954D-08, 0.1489098777643D+01, 0.1044738781244D+02, + : 0.8268102113708D-08, 0.3512977691983D+01, 0.1150676975667D+02, + : 0.9043613988227D-08, 0.1290704408221D+00, 0.1101510648075D+02, + : 0.7432912038789D-08, 0.1991086893337D+01, 0.2608790314060D+02, + : 0.8586233727285D-08, 0.4238357924414D+01, 0.2986433403208D+02, + : 0.7612230060131D-08, 0.2911090150166D+01, 0.4732030630302D+01 / + DATA ((E0(I,J,3),I=1,3),J= 61, 70) / + : 0.7097787751408D-08, 0.1908938392390D+01, 0.8031092209206D+01, + : 0.7640237040175D-08, 0.6129219000168D+00, 0.7962980379786D+00, + : 0.7070445688081D-08, 0.1380417036651D+01, 0.2146165377750D+01, + : 0.7690770957702D-08, 0.1680504249084D+01, 0.2122839202813D+02, + : 0.8051292542594D-08, 0.5127423484511D+01, 0.2942463415728D+01, + : 0.5902709104515D-08, 0.2020274190917D+01, 0.7755226100720D+00, + : 0.5134567496462D-08, 0.2606778676418D+01, 0.1256615170089D+02, + : 0.5525802046102D-08, 0.1613011769663D+01, 0.8018209333619D+00, + : 0.5880724784221D-08, 0.4604483417236D+01, 0.4690479774488D+01, + : 0.5211699081370D-08, 0.5718964114193D+01, 0.8827390247185D+01 / + DATA ((E0(I,J,3),I=1,3),J= 71, 80) / + : 0.4891849573562D-08, 0.3689658932196D+01, 0.2132990797783D+00, + : 0.5150246069997D-08, 0.4099769855122D+01, 0.6480980550449D+02, + : 0.5102434319633D-08, 0.5660834602509D+01, 0.3379454372902D+02, + : 0.5083405254252D-08, 0.9842221218974D+00, 0.4136910472696D+01, + : 0.4206562585682D-08, 0.1341363634163D+00, 0.3128388763578D+01, + : 0.4663249683579D-08, 0.8130132735866D+00, 0.5216580451554D+01, + : 0.4099474416530D-08, 0.5791497770644D+01, 0.4265981595566D+00, + : 0.4628251220767D-08, 0.1249802769331D+01, 0.1572083878776D+02, + : 0.5024068728142D-08, 0.4795684802743D+01, 0.6290189305114D+01, + : 0.5120234327758D-08, 0.3810420387208D+01, 0.5230807360890D+01 / + DATA ((E0(I,J,3),I=1,3),J= 81, 90) / + : 0.5524029815280D-08, 0.1029264714351D+01, 0.2397622045175D+03, + : 0.4757415718860D-08, 0.3528044781779D+01, 0.1649636139783D+02, + : 0.3915786131127D-08, 0.5593889282646D+01, 0.1589072916335D+01, + : 0.4869053149991D-08, 0.3299636454433D+01, 0.7632943190217D+01, + : 0.3649365703729D-08, 0.1286049002584D+01, 0.6206810014183D+01, + : 0.3992493949002D-08, 0.3100307589464D+01, 0.2515860172507D+02, + : 0.3320247477418D-08, 0.6212683940807D+01, 0.1216800268190D+02, + : 0.3287123739696D-08, 0.4699118445928D+01, 0.7234794171227D+01, + : 0.3472776811103D-08, 0.2630507142004D+01, 0.7342457794669D+01, + : 0.3423253294767D-08, 0.2946432844305D+01, 0.9623688285163D+01 / + DATA ((E0(I,J,3),I=1,3),J= 91,100) / + : 0.3896173898244D-08, 0.1224834179264D+01, 0.6438496133249D+01, + : 0.3388455337924D-08, 0.1543807616351D+01, 0.1494531617769D+02, + : 0.3062704716523D-08, 0.1191777572310D+01, 0.8662240327241D+01, + : 0.3270075600400D-08, 0.5483498767737D+01, 0.1194447056968D+01, + : 0.3101209215259D-08, 0.8000833804348D+00, 0.3772475342596D+02, + : 0.2780883347311D-08, 0.4077980721888D+00, 0.5863591145557D+01, + : 0.2903605931824D-08, 0.2617490302147D+01, 0.1965104848470D+02, + : 0.2682014743119D-08, 0.2634703158290D+01, 0.7238675589263D+01, + : 0.2534360108492D-08, 0.6102446114873D+01, 0.6836645152238D+01, + : 0.2392564882509D-08, 0.3681820208691D+01, 0.5849364236221D+01 / + DATA ((E0(I,J,3),I=1,3),J=101,110) / + : 0.2656667254856D-08, 0.6216045388886D+01, 0.6133512519065D+01, + : 0.2331242096773D-08, 0.5864949777744D+01, 0.4535059491685D+01, + : 0.2287898363668D-08, 0.4566628532802D+01, 0.7477522907414D+01, + : 0.2336944521306D-08, 0.2442722126930D+01, 0.1137170464392D+02, + : 0.3156632236269D-08, 0.1626628050682D+01, 0.2509084901204D+03, + : 0.2982612402766D-08, 0.2803604512609D+01, 0.1748016358760D+01, + : 0.2774031674807D-08, 0.4654002897158D+01, 0.8223916695780D+02, + : 0.2295236548638D-08, 0.4326518333253D+01, 0.3378142627421D+00, + : 0.2190714699873D-08, 0.4519614578328D+01, 0.2908881142201D+02, + : 0.2191495845045D-08, 0.3012626912549D+01, 0.1673046366289D+02 / + DATA ((E0(I,J,3),I=1,3),J=111,120) / + : 0.2492901628386D-08, 0.1290101424052D+00, 0.1543797956245D+03, + : 0.1993778064319D-08, 0.3864046799414D+01, 0.1778984560711D+02, + : 0.1898146479022D-08, 0.5053777235891D+01, 0.2042657109477D+02, + : 0.1918280127634D-08, 0.2222470192548D+01, 0.4165496312290D+02, + : 0.1916351061607D-08, 0.8719067257774D+00, 0.7737595720538D+02, + : 0.1834720181466D-08, 0.4031491098040D+01, 0.2358125818164D+02, + : 0.1249201523806D-08, 0.5938379466835D+01, 0.3301902111895D+02, + : 0.1477304050539D-08, 0.6544722606797D+00, 0.9548094718417D+02, + : 0.1264316431249D-08, 0.2059072853236D+01, 0.8399684731857D+02, + : 0.1203526495039D-08, 0.3644813532605D+01, 0.4558517281984D+02 / + DATA ((E0(I,J,3),I=1,3),J=121,130) / + : 0.9221681059831D-09, 0.3241815055602D+01, 0.7805158573086D+02, + : 0.7849278367646D-09, 0.5043812342457D+01, 0.5217580628120D+02, + : 0.7983392077387D-09, 0.5000024502753D+01, 0.1501922143975D+03, + : 0.7925395431654D-09, 0.1398734871821D-01, 0.9061773743175D+02, + : 0.7640473285886D-09, 0.5067111723130D+01, 0.4951538251678D+02, + : 0.5398937754482D-09, 0.5597382200075D+01, 0.1613385000004D+03, + : 0.5626247550193D-09, 0.2601338209422D+01, 0.7318837597844D+02, + : 0.5525197197855D-09, 0.5814832109256D+01, 0.1432335100216D+03, + : 0.5407629837898D-09, 0.3384820609076D+01, 0.3230491187871D+03, + : 0.3856739119801D-09, 0.1072391840473D+01, 0.2334791286671D+03 / + DATA ((E0(I,J,3),I=1,3),J=131,NE0Z) / + : 0.3856425239987D-09, 0.2369540393327D+01, 0.1739046517013D+03, + : 0.4350867755983D-09, 0.5255575751082D+01, 0.1620484330494D+03, + : 0.3844113924996D-09, 0.5482356246182D+01, 0.9757644180768D+02, + : 0.2854869155431D-09, 0.9573634763143D+00, 0.1697170704744D+03, + : 0.1719227671416D-09, 0.1887203025202D+01, 0.2265204242912D+03, + : 0.1527846879755D-09, 0.3982183931157D+01, 0.3341954043900D+03, + : 0.1128229264847D-09, 0.2787457156298D+01, 0.3119028331842D+03 / + +* Sun-to-Earth, T^1, Z + DATA ((E1(I,J,3),I=1,3),J= 1, 10) / + : 0.2278290449966D-05, 0.3413716033863D+01, 0.6283075850446D+01, + : 0.5429458209830D-07, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.1903240492525D-07, 0.3370592358297D+01, 0.1256615170089D+02, + : 0.2385409276743D-09, 0.3327914718416D+01, 0.1884922755134D+02, + : 0.8676928342573D-10, 0.1824006811264D+01, 0.5223693906222D+01, + : 0.7765442593544D-10, 0.3888564279247D+01, 0.5507553240374D+01, + : 0.7066158332715D-10, 0.5194267231944D+01, 0.2352866153506D+01, + : 0.7092175288657D-10, 0.2333246960021D+01, 0.8399684731857D+02, + : 0.5357582213535D-10, 0.2224031176619D+01, 0.5296909721118D+00, + : 0.3828035865021D-10, 0.2156710933584D+01, 0.6279552690824D+01 / + DATA ((E1(I,J,3),I=1,3),J= 11,NE1Z) / + : 0.3824857220427D-10, 0.1529755219915D+01, 0.6286599010068D+01, + : 0.3286995181628D-10, 0.4879512900483D+01, 0.1021328554739D+02 / + +* Sun-to-Earth, T^2, Z + DATA ((E2(I,J,3),I=1,3),J= 1,NE2Z) / + : 0.9722666114891D-10, 0.5152219582658D+01, 0.6283075850446D+01, + : -0.3494819171909D-11, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.6713034376076D-12, 0.6440188750495D+00, 0.1256615170089D+02 / + +* SSB-to-Sun, T^0, X + DATA ((S0(I,J,1),I=1,3),J= 1, 10) / + : 0.4956757536410D-02, 0.3741073751789D+01, 0.5296909721118D+00, + : 0.2718490072522D-02, 0.4016011511425D+01, 0.2132990797783D+00, + : 0.1546493974344D-02, 0.2170528330642D+01, 0.3813291813120D-01, + : 0.8366855276341D-03, 0.2339614075294D+01, 0.7478166569050D-01, + : 0.2936777942117D-03, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.1201317439469D-03, 0.4090736353305D+01, 0.1059381944224D+01, + : 0.7578550887230D-04, 0.3241518088140D+01, 0.4265981595566D+00, + : 0.1941787367773D-04, 0.1012202064330D+01, 0.2061856251104D+00, + : 0.1889227765991D-04, 0.3892520416440D+01, 0.2204125344462D+00, + : 0.1937896968613D-04, 0.4797779441161D+01, 0.1495633313810D+00 / + DATA ((S0(I,J,1),I=1,3),J= 11, 20) / + : 0.1434506110873D-04, 0.3868960697933D+01, 0.5225775174439D+00, + : 0.1406659911580D-04, 0.4759766557397D+00, 0.5368044267797D+00, + : 0.1179022300202D-04, 0.7774961520598D+00, 0.7626583626240D-01, + : 0.8085864460959D-05, 0.3254654471465D+01, 0.3664874755930D-01, + : 0.7622752967615D-05, 0.4227633103489D+01, 0.3961708870310D-01, + : 0.6209171139066D-05, 0.2791828325711D+00, 0.7329749511860D-01, + : 0.4366435633970D-05, 0.4440454875925D+01, 0.1589072916335D+01, + : 0.3792124889348D-05, 0.5156393842356D+01, 0.7113454667900D-02, + : 0.3154548963402D-05, 0.6157005730093D+01, 0.4194847048887D+00, + : 0.3088359882942D-05, 0.2494567553163D+01, 0.6398972393349D+00 / + DATA ((S0(I,J,1),I=1,3),J= 21, 30) / + : 0.2788440902136D-05, 0.4934318747989D+01, 0.1102062672231D+00, + : 0.3039928456376D-05, 0.4895077702640D+01, 0.6283075850446D+01, + : 0.2272258457679D-05, 0.5278394064764D+01, 0.1030928125552D+00, + : 0.2162007057957D-05, 0.5802978019099D+01, 0.3163918923335D+00, + : 0.1767632855737D-05, 0.3415346595193D-01, 0.1021328554739D+02, + : 0.1349413459362D-05, 0.2001643230755D+01, 0.1484170571900D-02, + : 0.1170141900476D-05, 0.2424750491620D+01, 0.6327837846670D+00, + : 0.1054355266820D-05, 0.3123311487576D+01, 0.4337116142245D+00, + : 0.9800822461610D-06, 0.3026258088130D+01, 0.1052268489556D+01, + : 0.1091203749931D-05, 0.3157811670347D+01, 0.1162474756779D+01 / + DATA ((S0(I,J,1),I=1,3),J= 31, 40) / + : 0.6960236715913D-06, 0.8219570542313D+00, 0.1066495398892D+01, + : 0.5689257296909D-06, 0.1323052375236D+01, 0.9491756770005D+00, + : 0.6613172135802D-06, 0.2765348881598D+00, 0.8460828644453D+00, + : 0.6277702517571D-06, 0.5794064466382D+01, 0.1480791608091D+00, + : 0.6304884066699D-06, 0.7323555380787D+00, 0.2243449970715D+00, + : 0.4897850467382D-06, 0.3062464235399D+01, 0.3340612434717D+01, + : 0.3759148598786D-06, 0.4588290469664D+01, 0.3516457698740D-01, + : 0.3110520548195D-06, 0.1374299536572D+01, 0.6373574839730D-01, + : 0.3064708359780D-06, 0.4222267485047D+01, 0.1104591729320D-01, + : 0.2856347168241D-06, 0.3714202944973D+01, 0.1510475019529D+00 / + DATA ((S0(I,J,1),I=1,3),J= 41, 50) / + : 0.2840945514288D-06, 0.2847972875882D+01, 0.4110125927500D-01, + : 0.2378951599405D-06, 0.3762072563388D+01, 0.2275259891141D+00, + : 0.2714229481417D-06, 0.1036049980031D+01, 0.2535050500000D-01, + : 0.2323551717307D-06, 0.4682388599076D+00, 0.8582758298370D-01, + : 0.1881790512219D-06, 0.4790565425418D+01, 0.2118763888447D+01, + : 0.2261353968371D-06, 0.1669144912212D+01, 0.7181332454670D-01, + : 0.2214546389848D-06, 0.3937717281614D+01, 0.2968341143800D-02, + : 0.2184915594933D-06, 0.1129169845099D+00, 0.7775000683430D-01, + : 0.2000164937936D-06, 0.4030009638488D+01, 0.2093666171530D+00, + : 0.1966105136719D-06, 0.8745955786834D+00, 0.2172315424036D+00 / + DATA ((S0(I,J,1),I=1,3),J= 51, 60) / + : 0.1904742332624D-06, 0.5919743598964D+01, 0.2022531624851D+00, + : 0.1657399705031D-06, 0.2549141484884D+01, 0.7358765972222D+00, + : 0.1574070533987D-06, 0.5277533020230D+01, 0.7429900518901D+00, + : 0.1832261651039D-06, 0.3064688127777D+01, 0.3235053470014D+00, + : 0.1733615346569D-06, 0.3011432799094D+01, 0.1385174140878D+00, + : 0.1549124014496D-06, 0.4005569132359D+01, 0.5154640627760D+00, + : 0.1637044713838D-06, 0.1831375966632D+01, 0.8531963191132D+00, + : 0.1123420082383D-06, 0.1180270407578D+01, 0.1990721704425D+00, + : 0.1083754165740D-06, 0.3414101320863D+00, 0.5439178814476D+00, + : 0.1156638012655D-06, 0.6130479452594D+00, 0.5257585094865D+00 / + DATA ((S0(I,J,1),I=1,3),J= 61, 70) / + : 0.1142548785134D-06, 0.3724761948846D+01, 0.5336234347371D+00, + : 0.7921463895965D-07, 0.2435425589361D+01, 0.1478866649112D+01, + : 0.7428600285231D-07, 0.3542144398753D+01, 0.2164800718209D+00, + : 0.8323211246747D-07, 0.3525058072354D+01, 0.1692165728891D+01, + : 0.7257595116312D-07, 0.1364299431982D+01, 0.2101180877357D+00, + : 0.7111185833236D-07, 0.2460478875808D+01, 0.4155522422634D+00, + : 0.6868090383716D-07, 0.4397327670704D+01, 0.1173197218910D+00, + : 0.7226419974175D-07, 0.4042647308905D+01, 0.1265567569334D+01, + : 0.6955642383177D-07, 0.2865047906085D+01, 0.9562891316684D+00, + : 0.7492139296331D-07, 0.5014278994215D+01, 0.1422690933580D-01 / + DATA ((S0(I,J,1),I=1,3),J= 71, 80) / + : 0.6598363128857D-07, 0.2376730020492D+01, 0.6470106940028D+00, + : 0.7381147293385D-07, 0.3272990384244D+01, 0.1581959461667D+01, + : 0.6402909624032D-07, 0.5302290955138D+01, 0.9597935788730D-01, + : 0.6237454263857D-07, 0.5444144425332D+01, 0.7084920306520D-01, + : 0.5241198544016D-07, 0.4215359579205D+01, 0.5265099800692D+00, + : 0.5144463853918D-07, 0.1218916689916D+00, 0.5328719641544D+00, + : 0.5868164772299D-07, 0.2369402002213D+01, 0.7871412831580D-01, + : 0.6233195669151D-07, 0.1254922242403D+01, 0.2608790314060D+02, + : 0.6068463791422D-07, 0.5679713760431D+01, 0.1114304132498D+00, + : 0.4359361135065D-07, 0.6097219641646D+00, 0.1375773836557D+01 / + DATA ((S0(I,J,1),I=1,3),J= 81, 90) / + : 0.4686510366826D-07, 0.4786231041431D+01, 0.1143987543936D+00, + : 0.3758977287225D-07, 0.1167368068139D+01, 0.1596186371003D+01, + : 0.4282051974778D-07, 0.1519471064319D+01, 0.2770348281756D+00, + : 0.5153765386113D-07, 0.1860532322984D+01, 0.2228608264996D+00, + : 0.4575129387188D-07, 0.7632857887158D+00, 0.1465949902372D+00, + : 0.3326844933286D-07, 0.1298219485285D+01, 0.5070101000000D-01, + : 0.3748617450984D-07, 0.1046510321062D+01, 0.4903339079539D+00, + : 0.2816756661499D-07, 0.3434522346190D+01, 0.2991266627620D+00, + : 0.3412750405039D-07, 0.2523766270318D+01, 0.3518164938661D+00, + : 0.2655796761776D-07, 0.2904422260194D+01, 0.6256703299991D+00 / + DATA ((S0(I,J,1),I=1,3),J= 91,100) / + : 0.2963597929458D-07, 0.5923900431149D+00, 0.1099462426779D+00, + : 0.2539523734781D-07, 0.4851947722567D+01, 0.1256615170089D+02, + : 0.2283087914139D-07, 0.3400498595496D+01, 0.6681224869435D+01, + : 0.2321309799331D-07, 0.5789099148673D+01, 0.3368040641550D-01, + : 0.2549657649750D-07, 0.3991856479792D-01, 0.1169588211447D+01, + : 0.2290462303977D-07, 0.2788567577052D+01, 0.1045155034888D+01, + : 0.1945398522914D-07, 0.3290896998176D+01, 0.1155361302111D+01, + : 0.1849171512638D-07, 0.2698060129367D+01, 0.4452511715700D-02, + : 0.1647199834254D-07, 0.3016735644085D+01, 0.4408250688924D+00, + : 0.1529530765273D-07, 0.5573043116178D+01, 0.6521991896920D-01 / + DATA ((S0(I,J,1),I=1,3),J=101,110) / + : 0.1433199339978D-07, 0.1481192356147D+01, 0.9420622223326D+00, + : 0.1729134193602D-07, 0.1422817538933D+01, 0.2108507877249D+00, + : 0.1716463931346D-07, 0.3469468901855D+01, 0.2157473718317D+00, + : 0.1391206061378D-07, 0.6122436220547D+01, 0.4123712502208D+00, + : 0.1404746661924D-07, 0.1647765641936D+01, 0.4258542984690D-01, + : 0.1410452399455D-07, 0.5989729161964D+01, 0.2258291676434D+00, + : 0.1089828772168D-07, 0.2833705509371D+01, 0.4226656969313D+00, + : 0.1047374564948D-07, 0.5090690007331D+00, 0.3092784376656D+00, + : 0.1358279126532D-07, 0.5128990262836D+01, 0.7923417740620D-01, + : 0.1020456476148D-07, 0.9632772880808D+00, 0.1456308687557D+00 / + DATA ((S0(I,J,1),I=1,3),J=111,120) / + : 0.1033428735328D-07, 0.3223779318418D+01, 0.1795258541446D+01, + : 0.1412435841540D-07, 0.2410271572721D+01, 0.1525316725248D+00, + : 0.9722759371574D-08, 0.2333531395690D+01, 0.8434341241180D-01, + : 0.9657334084704D-08, 0.6199270974168D+01, 0.1272681024002D+01, + : 0.1083641148690D-07, 0.2864222292929D+01, 0.7032915397480D-01, + : 0.1067318403838D-07, 0.5833458866568D+00, 0.2123349582968D+00, + : 0.1062366201976D-07, 0.4307753989494D+01, 0.2142632012598D+00, + : 0.1236364149266D-07, 0.2873917870593D+01, 0.1847279083684D+00, + : 0.1092759489593D-07, 0.2959887266733D+01, 0.1370332435159D+00, + : 0.8912069362899D-08, 0.5141213702562D+01, 0.2648454860559D+01 / + DATA ((S0(I,J,1),I=1,3),J=121,130) / + : 0.9656467707970D-08, 0.4532182462323D+01, 0.4376440768498D+00, + : 0.8098386150135D-08, 0.2268906338379D+01, 0.2880807454688D+00, + : 0.7857714675000D-08, 0.4055544260745D+01, 0.2037373330570D+00, + : 0.7288455940646D-08, 0.5357901655142D+01, 0.1129145838217D+00, + : 0.9450595950552D-08, 0.4264926963939D+01, 0.5272426800584D+00, + : 0.9381718247537D-08, 0.7489366976576D-01, 0.5321392641652D+00, + : 0.7079052646038D-08, 0.1923311052874D+01, 0.6288513220417D+00, + : 0.9259004415344D-08, 0.2970256853438D+01, 0.1606092486742D+00, + : 0.8259801499742D-08, 0.3327056314697D+01, 0.8389694097774D+00, + : 0.6476334355779D-08, 0.2954925505727D+01, 0.2008557621224D+01 / + DATA ((S0(I,J,1),I=1,3),J=131,140) / + : 0.5984021492007D-08, 0.9138753105829D+00, 0.2042657109477D+02, + : 0.5989546863181D-08, 0.3244464082031D+01, 0.2111650433779D+01, + : 0.6233108606023D-08, 0.4995232638403D+00, 0.4305306221819D+00, + : 0.6877299149965D-08, 0.2834987233449D+01, 0.9561746721300D-02, + : 0.8311234227190D-08, 0.2202951835758D+01, 0.3801276407308D+00, + : 0.6599472832414D-08, 0.4478581462618D+01, 0.1063314406849D+01, + : 0.6160491096549D-08, 0.5145858696411D+01, 0.1368660381889D+01, + : 0.6164772043891D-08, 0.3762976697911D+00, 0.4234171675140D+00, + : 0.6363248684450D-08, 0.3162246718685D+01, 0.1253008786510D-01, + : 0.6448587520999D-08, 0.3442693302119D+01, 0.5287268506303D+00 / + DATA ((S0(I,J,1),I=1,3),J=141,150) / + : 0.6431662283977D-08, 0.8977549136606D+00, 0.5306550935933D+00, + : 0.6351223158474D-08, 0.4306447410369D+01, 0.5217580628120D+02, + : 0.5476721393451D-08, 0.3888529177855D+01, 0.2221856701002D+01, + : 0.5341772572619D-08, 0.2655560662512D+01, 0.7466759693650D-01, + : 0.5337055758302D-08, 0.5164990735946D+01, 0.7489573444450D-01, + : 0.5373120816787D-08, 0.6041214553456D+01, 0.1274714967946D+00, + : 0.5392351705426D-08, 0.9177763485932D+00, 0.1055449481598D+01, + : 0.6688495850205D-08, 0.3089608126937D+01, 0.2213766559277D+00, + : 0.5072003660362D-08, 0.4311316541553D+01, 0.2132517061319D+00, + : 0.5070726650455D-08, 0.5790675464444D+00, 0.2133464534247D+00 / + DATA ((S0(I,J,1),I=1,3),J=151,160) / + : 0.5658012950032D-08, 0.2703945510675D+01, 0.7287631425543D+00, + : 0.4835509924854D-08, 0.2975422976065D+01, 0.7160067364790D-01, + : 0.6479821978012D-08, 0.1324168733114D+01, 0.2209183458640D-01, + : 0.6230636494980D-08, 0.2860103632836D+01, 0.3306188016693D+00, + : 0.4649239516213D-08, 0.4832259763403D+01, 0.7796265773310D-01, + : 0.6487325792700D-08, 0.2726165825042D+01, 0.3884652414254D+00, + : 0.4682823682770D-08, 0.6966602455408D+00, 0.1073608853559D+01, + : 0.5704230804976D-08, 0.5669634104606D+01, 0.8731175355560D-01, + : 0.6125413585489D-08, 0.1513386538915D+01, 0.7605151500000D-01, + : 0.6035825038187D-08, 0.1983509168227D+01, 0.9846002785331D+00 / + DATA ((S0(I,J,1),I=1,3),J=161,170) / + : 0.4331123462303D-08, 0.2782892992807D+01, 0.4297791515992D+00, + : 0.4681107685143D-08, 0.5337232886836D+01, 0.2127790306879D+00, + : 0.4669105829655D-08, 0.5837133792160D+01, 0.2138191288687D+00, + : 0.5138823602365D-08, 0.3080560200507D+01, 0.7233337363710D-01, + : 0.4615856664534D-08, 0.1661747897471D+01, 0.8603097737811D+00, + : 0.4496916702197D-08, 0.2112508027068D+01, 0.7381754420900D-01, + : 0.4278479042945D-08, 0.5716528462627D+01, 0.7574578717200D-01, + : 0.3840525503932D-08, 0.6424172726492D+00, 0.3407705765729D+00, + : 0.4866636509685D-08, 0.4919244697715D+01, 0.7722995774390D-01, + : 0.3526100639296D-08, 0.2550821052734D+01, 0.6225157782540D-01 / + DATA ((S0(I,J,1),I=1,3),J=171,180) / + : 0.3939558488075D-08, 0.3939331491710D+01, 0.5268983110410D-01, + : 0.4041268772576D-08, 0.2275337571218D+01, 0.3503323232942D+00, + : 0.3948761842853D-08, 0.1999324200790D+01, 0.1451108196653D+00, + : 0.3258394550029D-08, 0.9121001378200D+00, 0.5296435984654D+00, + : 0.3257897048761D-08, 0.3428428660869D+01, 0.5297383457582D+00, + : 0.3842559031298D-08, 0.6132927720035D+01, 0.9098186128426D+00, + : 0.3109920095448D-08, 0.7693650193003D+00, 0.3932462625300D-02, + : 0.3132237775119D-08, 0.3621293854908D+01, 0.2346394437820D+00, + : 0.3942189421510D-08, 0.4841863659733D+01, 0.3180992042600D-02, + : 0.3796972285340D-08, 0.1814174994268D+01, 0.1862120789403D+00 / + DATA ((S0(I,J,1),I=1,3),J=181,190) / + : 0.3995640233688D-08, 0.1386990406091D+01, 0.4549093064213D+00, + : 0.2875013727414D-08, 0.9178318587177D+00, 0.1905464808669D+01, + : 0.3073719932844D-08, 0.2688923811835D+01, 0.3628624111593D+00, + : 0.2731016580075D-08, 0.1188259127584D+01, 0.2131850110243D+00, + : 0.2729549896546D-08, 0.3702160634273D+01, 0.2134131485323D+00, + : 0.3339372892449D-08, 0.7199163960331D+00, 0.2007689919132D+00, + : 0.2898833764204D-08, 0.1916709364999D+01, 0.5291709230214D+00, + : 0.2894536549362D-08, 0.2424043195547D+01, 0.5302110212022D+00, + : 0.3096872473843D-08, 0.4445894977497D+01, 0.2976424921901D+00, + : 0.2635672326810D-08, 0.3814366984117D+01, 0.1485980103780D+01 / + DATA ((S0(I,J,1),I=1,3),J=191,200) / + : 0.3649302697001D-08, 0.2924200596084D+01, 0.6044726378023D+00, + : 0.3127954585895D-08, 0.1842251648327D+01, 0.1084620721060D+00, + : 0.2616040173947D-08, 0.4155841921984D+01, 0.1258454114666D+01, + : 0.2597395859860D-08, 0.1158045978874D+00, 0.2103781122809D+00, + : 0.2593286172210D-08, 0.4771850408691D+01, 0.2162200472757D+00, + : 0.2481823585747D-08, 0.4608842558889D+00, 0.1062562936266D+01, + : 0.2742219550725D-08, 0.1538781127028D+01, 0.5651155736444D+00, + : 0.3199558469610D-08, 0.3226647822878D+00, 0.7036329877322D+00, + : 0.2666088542957D-08, 0.1967991731219D+00, 0.1400015846597D+00, + : 0.2397067430580D-08, 0.3707036669873D+01, 0.2125476091956D+00 / + DATA ((S0(I,J,1),I=1,3),J=201,210) / + : 0.2376570772738D-08, 0.1182086628042D+01, 0.2140505503610D+00, + : 0.2547228007887D-08, 0.4906256820629D+01, 0.1534957940063D+00, + : 0.2265575594114D-08, 0.3414949866857D+01, 0.2235935264888D+00, + : 0.2464381430585D-08, 0.4599122275378D+01, 0.2091065926078D+00, + : 0.2433408527044D-08, 0.2830751145445D+00, 0.2174915669488D+00, + : 0.2443605509076D-08, 0.4212046432538D+01, 0.1739420156204D+00, + : 0.2319779262465D-08, 0.9881978408630D+00, 0.7530171478090D-01, + : 0.2284622835465D-08, 0.5565347331588D+00, 0.7426161660010D-01, + : 0.2467268750783D-08, 0.5655708150766D+00, 0.2526561439362D+00, + : 0.2808513492782D-08, 0.1418405053408D+01, 0.5636314030725D+00 / + DATA ((S0(I,J,1),I=1,3),J=211,NS0X) / + : 0.2329528932532D-08, 0.4069557545675D+01, 0.1056200952181D+01, + : 0.9698639532817D-09, 0.1074134313634D+01, 0.7826370942180D+02 / + +* SSB-to-Sun, T^1, X + DATA ((S1(I,J,1),I=1,3),J= 1, 10) / + : -0.1296310361520D-07, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.8975769009438D-08, 0.1128891609250D+01, 0.4265981595566D+00, + : 0.7771113441307D-08, 0.2706039877077D+01, 0.2061856251104D+00, + : 0.7538303866642D-08, 0.2191281289498D+01, 0.2204125344462D+00, + : 0.6061384579336D-08, 0.3248167319958D+01, 0.1059381944224D+01, + : 0.5726994235594D-08, 0.5569981398610D+01, 0.5225775174439D+00, + : 0.5616492836424D-08, 0.5057386614909D+01, 0.5368044267797D+00, + : 0.1010881584769D-08, 0.3473577116095D+01, 0.7113454667900D-02, + : 0.7259606157626D-09, 0.3651858593665D+00, 0.6398972393349D+00, + : 0.8755095026935D-09, 0.1662835408338D+01, 0.4194847048887D+00 / + DATA ((S1(I,J,1),I=1,3),J= 11, 20) / + : 0.5370491182812D-09, 0.1327673878077D+01, 0.4337116142245D+00, + : 0.5743773887665D-09, 0.4250200846687D+01, 0.2132990797783D+00, + : 0.4408103140300D-09, 0.3598752574277D+01, 0.1589072916335D+01, + : 0.3101892374445D-09, 0.4887822983319D+01, 0.1052268489556D+01, + : 0.3209453713578D-09, 0.9702272295114D+00, 0.5296909721118D+00, + : 0.3017228286064D-09, 0.5484462275949D+01, 0.1066495398892D+01, + : 0.3200700038601D-09, 0.2846613338643D+01, 0.1495633313810D+00, + : 0.2137637279911D-09, 0.5692163292729D+00, 0.3163918923335D+00, + : 0.1899686386727D-09, 0.2061077157189D+01, 0.2275259891141D+00, + : 0.1401994545308D-09, 0.4177771136967D+01, 0.1102062672231D+00 / + DATA ((S1(I,J,1),I=1,3),J= 21, 30) / + : 0.1578057810499D-09, 0.5782460597335D+01, 0.7626583626240D-01, + : 0.1237713253351D-09, 0.5705900866881D+01, 0.5154640627760D+00, + : 0.1313076837395D-09, 0.5163438179576D+01, 0.3664874755930D-01, + : 0.1184963304860D-09, 0.3054804427242D+01, 0.6327837846670D+00, + : 0.1238130878565D-09, 0.2317292575962D+01, 0.3961708870310D-01, + : 0.1015959527736D-09, 0.2194643645526D+01, 0.7329749511860D-01, + : 0.9017954423714D-10, 0.2868603545435D+01, 0.1990721704425D+00, + : 0.8668024955603D-10, 0.4923849675082D+01, 0.5439178814476D+00, + : 0.7756083930103D-10, 0.3014334135200D+01, 0.9491756770005D+00, + : 0.7536503401741D-10, 0.2704886279769D+01, 0.1030928125552D+00 / + DATA ((S1(I,J,1),I=1,3),J= 31, 40) / + : 0.5483308679332D-10, 0.6010983673799D+01, 0.8531963191132D+00, + : 0.5184339620428D-10, 0.1952704573291D+01, 0.2093666171530D+00, + : 0.5108658712030D-10, 0.2958575786649D+01, 0.2172315424036D+00, + : 0.5019424524650D-10, 0.1736317621318D+01, 0.2164800718209D+00, + : 0.4909312625978D-10, 0.3167216416257D+01, 0.2101180877357D+00, + : 0.4456638901107D-10, 0.7697579923471D+00, 0.3235053470014D+00, + : 0.4227030350925D-10, 0.3490910137928D+01, 0.6373574839730D-01, + : 0.4095456040093D-10, 0.5178888984491D+00, 0.6470106940028D+00, + : 0.4990537041422D-10, 0.3323887668974D+01, 0.1422690933580D-01, + : 0.4321170010845D-10, 0.4288484987118D+01, 0.7358765972222D+00 / + DATA ((S1(I,J,1),I=1,3),J= 41,NS1X) / + : 0.3544072091802D-10, 0.6021051579251D+01, 0.5265099800692D+00, + : 0.3480198638687D-10, 0.4600027054714D+01, 0.5328719641544D+00, + : 0.3440287244435D-10, 0.4349525970742D+01, 0.8582758298370D-01, + : 0.3330628322713D-10, 0.2347391505082D+01, 0.1104591729320D-01, + : 0.2973060707184D-10, 0.4789409286400D+01, 0.5257585094865D+00, + : 0.2932606766089D-10, 0.5831693799927D+01, 0.5336234347371D+00, + : 0.2876972310953D-10, 0.2692638514771D+01, 0.1173197218910D+00, + : 0.2827488278556D-10, 0.2056052487960D+01, 0.2022531624851D+00, + : 0.2515028239756D-10, 0.7411863262449D+00, 0.9597935788730D-01, + : 0.2853033744415D-10, 0.3948481024894D+01, 0.2118763888447D+01 / + +* SSB-to-Sun, T^2, X + DATA ((S2(I,J,1),I=1,3),J= 1,NS2X) / + : 0.1603551636587D-11, 0.4404109410481D+01, 0.2061856251104D+00, + : 0.1556935889384D-11, 0.4818040873603D+00, 0.2204125344462D+00, + : 0.1182594414915D-11, 0.9935762734472D+00, 0.5225775174439D+00, + : 0.1158794583180D-11, 0.3353180966450D+01, 0.5368044267797D+00, + : 0.9597358943932D-12, 0.5567045358298D+01, 0.2132990797783D+00, + : 0.6511516579605D-12, 0.5630872420788D+01, 0.4265981595566D+00, + : 0.7419792747688D-12, 0.2156188581957D+01, 0.5296909721118D+00, + : 0.3951972655848D-12, 0.1981022541805D+01, 0.1059381944224D+01, + : 0.4478223877045D-12, 0.0000000000000D+00, 0.0000000000000D+00 / + +* SSB-to-Sun, T^0, Y + DATA ((S0(I,J,2),I=1,3),J= 1, 10) / + : 0.4955392320126D-02, 0.2170467313679D+01, 0.5296909721118D+00, + : 0.2722325167392D-02, 0.2444433682196D+01, 0.2132990797783D+00, + : 0.1546579925346D-02, 0.5992779281546D+00, 0.3813291813120D-01, + : 0.8363140252966D-03, 0.7687356310801D+00, 0.7478166569050D-01, + : 0.3385792683603D-03, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.1201192221613D-03, 0.2520035601514D+01, 0.1059381944224D+01, + : 0.7587125720554D-04, 0.1669954006449D+01, 0.4265981595566D+00, + : 0.1964155361250D-04, 0.5707743963343D+01, 0.2061856251104D+00, + : 0.1891900364909D-04, 0.2320960679937D+01, 0.2204125344462D+00, + : 0.1937373433356D-04, 0.3226940689555D+01, 0.1495633313810D+00 / + DATA ((S0(I,J,2),I=1,3),J= 11, 20) / + : 0.1437139941351D-04, 0.2301626908096D+01, 0.5225775174439D+00, + : 0.1406267683099D-04, 0.5188579265542D+01, 0.5368044267797D+00, + : 0.1178703080346D-04, 0.5489483248476D+01, 0.7626583626240D-01, + : 0.8079835186041D-05, 0.1683751835264D+01, 0.3664874755930D-01, + : 0.7623253594652D-05, 0.2656400462961D+01, 0.3961708870310D-01, + : 0.6248667483971D-05, 0.4992775362055D+01, 0.7329749511860D-01, + : 0.4366353695038D-05, 0.2869706279678D+01, 0.1589072916335D+01, + : 0.3829101568895D-05, 0.3572131359950D+01, 0.7113454667900D-02, + : 0.3175733773908D-05, 0.4535372530045D+01, 0.4194847048887D+00, + : 0.3092437902159D-05, 0.9230153317909D+00, 0.6398972393349D+00 / + DATA ((S0(I,J,2),I=1,3),J= 21, 30) / + : 0.2874168812154D-05, 0.3363143761101D+01, 0.1102062672231D+00, + : 0.3040119321826D-05, 0.3324250895675D+01, 0.6283075850446D+01, + : 0.2699723308006D-05, 0.2917882441928D+00, 0.1030928125552D+00, + : 0.2134832683534D-05, 0.4220997202487D+01, 0.3163918923335D+00, + : 0.1770412139433D-05, 0.4747318496462D+01, 0.1021328554739D+02, + : 0.1377264209373D-05, 0.4305058462401D+00, 0.1484170571900D-02, + : 0.1127814538960D-05, 0.8538177240740D+00, 0.6327837846670D+00, + : 0.1055608090130D-05, 0.1551800742580D+01, 0.4337116142245D+00, + : 0.9802673861420D-06, 0.1459646735377D+01, 0.1052268489556D+01, + : 0.1090329461951D-05, 0.1587351228711D+01, 0.1162474756779D+01 / + DATA ((S0(I,J,2),I=1,3),J= 31, 40) / + : 0.6959590025090D-06, 0.5534442628766D+01, 0.1066495398892D+01, + : 0.5664914529542D-06, 0.6030673003297D+01, 0.9491756770005D+00, + : 0.6607787763599D-06, 0.4989507233927D+01, 0.8460828644453D+00, + : 0.6269725742838D-06, 0.4222951804572D+01, 0.1480791608091D+00, + : 0.6301889697863D-06, 0.5444316669126D+01, 0.2243449970715D+00, + : 0.4891042662861D-06, 0.1490552839784D+01, 0.3340612434717D+01, + : 0.3457083123290D-06, 0.3030475486049D+01, 0.3516457698740D-01, + : 0.3032559967314D-06, 0.2652038793632D+01, 0.1104591729320D-01, + : 0.2841133988903D-06, 0.1276744786829D+01, 0.4110125927500D-01, + : 0.2855564444432D-06, 0.2143368674733D+01, 0.1510475019529D+00 / + DATA ((S0(I,J,2),I=1,3),J= 41, 50) / + : 0.2765157135038D-06, 0.5444186109077D+01, 0.6373574839730D-01, + : 0.2382312465034D-06, 0.2190521137593D+01, 0.2275259891141D+00, + : 0.2808060365077D-06, 0.5735195064841D+01, 0.2535050500000D-01, + : 0.2332175234405D-06, 0.9481985524859D-01, 0.7181332454670D-01, + : 0.2322488199659D-06, 0.5180499361533D+01, 0.8582758298370D-01, + : 0.1881850258423D-06, 0.3219788273885D+01, 0.2118763888447D+01, + : 0.2196111392808D-06, 0.2366941159761D+01, 0.2968341143800D-02, + : 0.2183810335519D-06, 0.4825445110915D+01, 0.7775000683430D-01, + : 0.2002733093326D-06, 0.2457148995307D+01, 0.2093666171530D+00, + : 0.1967111767229D-06, 0.5586291545459D+01, 0.2172315424036D+00 / + DATA ((S0(I,J,2),I=1,3),J= 51, 60) / + : 0.1568473250543D-06, 0.3708003123320D+01, 0.7429900518901D+00, + : 0.1852528314300D-06, 0.4310638151560D+01, 0.2022531624851D+00, + : 0.1832111226447D-06, 0.1494665322656D+01, 0.3235053470014D+00, + : 0.1746805502310D-06, 0.1451378500784D+01, 0.1385174140878D+00, + : 0.1555730966650D-06, 0.1068040418198D+01, 0.7358765972222D+00, + : 0.1554883462559D-06, 0.2442579035461D+01, 0.5154640627760D+00, + : 0.1638380568746D-06, 0.2597913420625D+00, 0.8531963191132D+00, + : 0.1159938593640D-06, 0.5834512021280D+01, 0.1990721704425D+00, + : 0.1083427965695D-06, 0.5054033177950D+01, 0.5439178814476D+00, + : 0.1156480369431D-06, 0.5325677432457D+01, 0.5257585094865D+00 / + DATA ((S0(I,J,2),I=1,3),J= 61, 70) / + : 0.1141308860095D-06, 0.2153403923857D+01, 0.5336234347371D+00, + : 0.7913146470946D-07, 0.8642846847027D+00, 0.1478866649112D+01, + : 0.7439752463733D-07, 0.1970628496213D+01, 0.2164800718209D+00, + : 0.7280277104079D-07, 0.6073307250609D+01, 0.2101180877357D+00, + : 0.8319567719136D-07, 0.1954371928334D+01, 0.1692165728891D+01, + : 0.7137705549290D-07, 0.8904989440909D+00, 0.4155522422634D+00, + : 0.6900825396225D-07, 0.2825717714977D+01, 0.1173197218910D+00, + : 0.7245757216635D-07, 0.2481677513331D+01, 0.1265567569334D+01, + : 0.6961165696255D-07, 0.1292955312978D+01, 0.9562891316684D+00, + : 0.7571804456890D-07, 0.3427517575069D+01, 0.1422690933580D-01 / + DATA ((S0(I,J,2),I=1,3),J= 71, 80) / + : 0.6605425721904D-07, 0.8052192701492D+00, 0.6470106940028D+00, + : 0.7375477357248D-07, 0.1705076390088D+01, 0.1581959461667D+01, + : 0.7041664951470D-07, 0.4848356967891D+00, 0.9597935788730D-01, + : 0.6322199535763D-07, 0.3878069473909D+01, 0.7084920306520D-01, + : 0.5244380279191D-07, 0.2645560544125D+01, 0.5265099800692D+00, + : 0.5143125704988D-07, 0.4834486101370D+01, 0.5328719641544D+00, + : 0.5871866319373D-07, 0.7981472548900D+00, 0.7871412831580D-01, + : 0.6300822573871D-07, 0.5979398788281D+01, 0.2608790314060D+02, + : 0.6062154271548D-07, 0.4108655402756D+01, 0.1114304132498D+00, + : 0.4361912339976D-07, 0.5322624319280D+01, 0.1375773836557D+01 / + DATA ((S0(I,J,2),I=1,3),J= 81, 90) / + : 0.4417005920067D-07, 0.6240817359284D+01, 0.2770348281756D+00, + : 0.4686806749936D-07, 0.3214977301156D+01, 0.1143987543936D+00, + : 0.3758892132305D-07, 0.5879809634765D+01, 0.1596186371003D+01, + : 0.5151351332319D-07, 0.2893377688007D+00, 0.2228608264996D+00, + : 0.4554683578572D-07, 0.5475427144122D+01, 0.1465949902372D+00, + : 0.3442381385338D-07, 0.5992034796640D+01, 0.5070101000000D-01, + : 0.2831093954933D-07, 0.5367350273914D+01, 0.3092784376656D+00, + : 0.3756267090084D-07, 0.5758171285420D+01, 0.4903339079539D+00, + : 0.2816374679892D-07, 0.1863718700923D+01, 0.2991266627620D+00, + : 0.3419307025569D-07, 0.9524347534130D+00, 0.3518164938661D+00 / + DATA ((S0(I,J,2),I=1,3),J= 91,100) / + : 0.2904250494239D-07, 0.5304471615602D+01, 0.1099462426779D+00, + : 0.2471734511206D-07, 0.1297069793530D+01, 0.6256703299991D+00, + : 0.2539620831872D-07, 0.3281126083375D+01, 0.1256615170089D+02, + : 0.2281017868007D-07, 0.1829122133165D+01, 0.6681224869435D+01, + : 0.2275319473335D-07, 0.5797198160181D+01, 0.3932462625300D-02, + : 0.2547755368442D-07, 0.4752697708330D+01, 0.1169588211447D+01, + : 0.2285979669317D-07, 0.1223205292886D+01, 0.1045155034888D+01, + : 0.1913386560994D-07, 0.1757532993389D+01, 0.1155361302111D+01, + : 0.1809020525147D-07, 0.4246116108791D+01, 0.3368040641550D-01, + : 0.1649213300201D-07, 0.1445162890627D+01, 0.4408250688924D+00 / + DATA ((S0(I,J,2),I=1,3),J=101,110) / + : 0.1834972793932D-07, 0.1126917567225D+01, 0.4452511715700D-02, + : 0.1439550648138D-07, 0.6160756834764D+01, 0.9420622223326D+00, + : 0.1487645457041D-07, 0.4358761931792D+01, 0.4123712502208D+00, + : 0.1731729516660D-07, 0.6134456753344D+01, 0.2108507877249D+00, + : 0.1717747163567D-07, 0.1898186084455D+01, 0.2157473718317D+00, + : 0.1418190430374D-07, 0.4180286741266D+01, 0.6521991896920D-01, + : 0.1404844134873D-07, 0.7654053565412D-01, 0.4258542984690D-01, + : 0.1409842846538D-07, 0.4418612420312D+01, 0.2258291676434D+00, + : 0.1090948346291D-07, 0.1260615686131D+01, 0.4226656969313D+00, + : 0.1357577323612D-07, 0.3558248818690D+01, 0.7923417740620D-01 / + DATA ((S0(I,J,2),I=1,3),J=111,120) / + : 0.1018154061960D-07, 0.5676087241256D+01, 0.1456308687557D+00, + : 0.1412073972109D-07, 0.8394392632422D+00, 0.1525316725248D+00, + : 0.1030938326496D-07, 0.1653593274064D+01, 0.1795258541446D+01, + : 0.1180081567104D-07, 0.1285802592036D+01, 0.7032915397480D-01, + : 0.9708510575650D-08, 0.7631889488106D+00, 0.8434341241180D-01, + : 0.9637689663447D-08, 0.4630642649176D+01, 0.1272681024002D+01, + : 0.1068910429389D-07, 0.5294934032165D+01, 0.2123349582968D+00, + : 0.1063716179336D-07, 0.2736266800832D+01, 0.2142632012598D+00, + : 0.1234858713814D-07, 0.1302891146570D+01, 0.1847279083684D+00, + : 0.8912631189738D-08, 0.3570415993621D+01, 0.2648454860559D+01 / + DATA ((S0(I,J,2),I=1,3),J=121,130) / + : 0.1036378285534D-07, 0.4236693440949D+01, 0.1370332435159D+00, + : 0.9667798501561D-08, 0.2960768892398D+01, 0.4376440768498D+00, + : 0.8108314201902D-08, 0.6987781646841D+00, 0.2880807454688D+00, + : 0.7648364324628D-08, 0.2499017863863D+01, 0.2037373330570D+00, + : 0.7286136828406D-08, 0.3787426951665D+01, 0.1129145838217D+00, + : 0.9448237743913D-08, 0.2694354332983D+01, 0.5272426800584D+00, + : 0.9374276106428D-08, 0.4787121277064D+01, 0.5321392641652D+00, + : 0.7100226287462D-08, 0.3530238792101D+00, 0.6288513220417D+00, + : 0.9253056659571D-08, 0.1399478925664D+01, 0.1606092486742D+00, + : 0.6636432145504D-08, 0.3479575438447D+01, 0.1368660381889D+01 / + DATA ((S0(I,J,2),I=1,3),J=131,140) / + : 0.6469975312932D-08, 0.1383669964800D+01, 0.2008557621224D+01, + : 0.7335849729765D-08, 0.1243698166898D+01, 0.9561746721300D-02, + : 0.8743421205855D-08, 0.3776164289301D+01, 0.3801276407308D+00, + : 0.5993635744494D-08, 0.5627122113596D+01, 0.2042657109477D+02, + : 0.5981008479693D-08, 0.1674336636752D+01, 0.2111650433779D+01, + : 0.6188535145838D-08, 0.5214925208672D+01, 0.4305306221819D+00, + : 0.6596074017566D-08, 0.2907653268124D+01, 0.1063314406849D+01, + : 0.6630815126226D-08, 0.2127643669658D+01, 0.8389694097774D+00, + : 0.6156772830040D-08, 0.5082160803295D+01, 0.4234171675140D+00, + : 0.6446960563014D-08, 0.1872100916905D+01, 0.5287268506303D+00 / + DATA ((S0(I,J,2),I=1,3),J=141,150) / + : 0.6429324424668D-08, 0.5610276103577D+01, 0.5306550935933D+00, + : 0.6302232396465D-08, 0.1592152049607D+01, 0.1253008786510D-01, + : 0.6399244436159D-08, 0.2746214421532D+01, 0.5217580628120D+02, + : 0.5474965172558D-08, 0.2317666374383D+01, 0.2221856701002D+01, + : 0.5339293190692D-08, 0.1084724961156D+01, 0.7466759693650D-01, + : 0.5334733683389D-08, 0.3594106067745D+01, 0.7489573444450D-01, + : 0.5392665782110D-08, 0.5630254365606D+01, 0.1055449481598D+01, + : 0.6682075673789D-08, 0.1518480041732D+01, 0.2213766559277D+00, + : 0.5079130495960D-08, 0.2739765115711D+01, 0.2132517061319D+00, + : 0.5077759793261D-08, 0.5290711290094D+01, 0.2133464534247D+00 / + DATA ((S0(I,J,2),I=1,3),J=151,160) / + : 0.4832037368310D-08, 0.1404473217200D+01, 0.7160067364790D-01, + : 0.6463279674802D-08, 0.6038381695210D+01, 0.2209183458640D-01, + : 0.6240592771560D-08, 0.1290170653666D+01, 0.3306188016693D+00, + : 0.4672013521493D-08, 0.3261895939677D+01, 0.7796265773310D-01, + : 0.6500650750348D-08, 0.1154522312095D+01, 0.3884652414254D+00, + : 0.6344161389053D-08, 0.6206111545062D+01, 0.7605151500000D-01, + : 0.4682518370646D-08, 0.5409118796685D+01, 0.1073608853559D+01, + : 0.5329460015591D-08, 0.1202985784864D+01, 0.7287631425543D+00, + : 0.5701588675898D-08, 0.4098715257064D+01, 0.8731175355560D-01, + : 0.6030690867211D-08, 0.4132033218460D+00, 0.9846002785331D+00 / + DATA ((S0(I,J,2),I=1,3),J=161,170) / + : 0.4336256312655D-08, 0.1211415991827D+01, 0.4297791515992D+00, + : 0.4688498808975D-08, 0.3765479072409D+01, 0.2127790306879D+00, + : 0.4675578609335D-08, 0.4265540037226D+01, 0.2138191288687D+00, + : 0.4225578112158D-08, 0.5237566010676D+01, 0.3407705765729D+00, + : 0.5139422230028D-08, 0.1507173079513D+01, 0.7233337363710D-01, + : 0.4619995093571D-08, 0.9023957449848D-01, 0.8603097737811D+00, + : 0.4494776255461D-08, 0.5414930552139D+00, 0.7381754420900D-01, + : 0.4274026276788D-08, 0.4145735303659D+01, 0.7574578717200D-01, + : 0.5018141789353D-08, 0.3344408829055D+01, 0.3180992042600D-02, + : 0.4866163952181D-08, 0.3348534657607D+01, 0.7722995774390D-01 / + DATA ((S0(I,J,2),I=1,3),J=171,180) / + : 0.4111986020501D-08, 0.4198823597220D+00, 0.1451108196653D+00, + : 0.3356142784950D-08, 0.5609144747180D+01, 0.1274714967946D+00, + : 0.4070575554551D-08, 0.7028411059224D+00, 0.3503323232942D+00, + : 0.3257451857278D-08, 0.5624697983086D+01, 0.5296435984654D+00, + : 0.3256973703026D-08, 0.1857842076707D+01, 0.5297383457582D+00, + : 0.3830771508640D-08, 0.4562887279931D+01, 0.9098186128426D+00, + : 0.3725024005962D-08, 0.2358058692652D+00, 0.1084620721060D+00, + : 0.3136763921756D-08, 0.2049731526845D+01, 0.2346394437820D+00, + : 0.3795147256194D-08, 0.2432356296933D+00, 0.1862120789403D+00, + : 0.2877342229911D-08, 0.5631101279387D+01, 0.1905464808669D+01 / + DATA ((S0(I,J,2),I=1,3),J=181,190) / + : 0.3076931798805D-08, 0.1117615737392D+01, 0.3628624111593D+00, + : 0.2734765945273D-08, 0.5899826516955D+01, 0.2131850110243D+00, + : 0.2733405296885D-08, 0.2130562964070D+01, 0.2134131485323D+00, + : 0.2898552353410D-08, 0.3462387048225D+00, 0.5291709230214D+00, + : 0.2893736103681D-08, 0.8534352781543D+00, 0.5302110212022D+00, + : 0.3095717734137D-08, 0.2875061429041D+01, 0.2976424921901D+00, + : 0.2636190425832D-08, 0.2242512846659D+01, 0.1485980103780D+01, + : 0.3645512095537D-08, 0.1354016903958D+01, 0.6044726378023D+00, + : 0.2808173547723D-08, 0.6705114365631D-01, 0.6225157782540D-01, + : 0.2625012866888D-08, 0.4775705748482D+01, 0.5268983110410D-01 / + DATA ((S0(I,J,2),I=1,3),J=191,200) / + : 0.2572233995651D-08, 0.2638924216139D+01, 0.1258454114666D+01, + : 0.2604238824792D-08, 0.4826358927373D+01, 0.2103781122809D+00, + : 0.2596886385239D-08, 0.3200388483118D+01, 0.2162200472757D+00, + : 0.3228057304264D-08, 0.5384848409563D+01, 0.2007689919132D+00, + : 0.2481601798252D-08, 0.5173373487744D+01, 0.1062562936266D+01, + : 0.2745977498864D-08, 0.6250966149853D+01, 0.5651155736444D+00, + : 0.2669878833811D-08, 0.4906001352499D+01, 0.1400015846597D+00, + : 0.3203986611711D-08, 0.5034333010005D+01, 0.7036329877322D+00, + : 0.3354961227212D-08, 0.6108262423137D+01, 0.4549093064213D+00, + : 0.2400407324558D-08, 0.2135399294955D+01, 0.2125476091956D+00 / + DATA ((S0(I,J,2),I=1,3),J=201,210) / + : 0.2379905859802D-08, 0.5893721933961D+01, 0.2140505503610D+00, + : 0.2550844302187D-08, 0.3331940762063D+01, 0.1534957940063D+00, + : 0.2268824211001D-08, 0.1843418461035D+01, 0.2235935264888D+00, + : 0.2464700891204D-08, 0.3029548547230D+01, 0.2091065926078D+00, + : 0.2436814726024D-08, 0.4994717970364D+01, 0.2174915669488D+00, + : 0.2443623894745D-08, 0.2645102591375D+01, 0.1739420156204D+00, + : 0.2318701783838D-08, 0.5700547397897D+01, 0.7530171478090D-01, + : 0.2284448700256D-08, 0.5268898905872D+01, 0.7426161660010D-01, + : 0.2468848123510D-08, 0.5276280575078D+01, 0.2526561439362D+00, + : 0.2814052350303D-08, 0.6130168623475D+01, 0.5636314030725D+00 / + DATA ((S0(I,J,2),I=1,3),J=211,NS0Y) / + : 0.2243662755220D-08, 0.6631692457995D+00, 0.8886590321940D-01, + : 0.2330795855941D-08, 0.2499435487702D+01, 0.1056200952181D+01, + : 0.9757679038404D-09, 0.5796846023126D+01, 0.7826370942180D+02 / + +* SSB-to-Sun, T^1, Y + DATA ((S1(I,J,2),I=1,3),J= 1, 10) / + : 0.8989047573576D-08, 0.5840593672122D+01, 0.4265981595566D+00, + : 0.7815938401048D-08, 0.1129664707133D+01, 0.2061856251104D+00, + : 0.7550926713280D-08, 0.6196589104845D+00, 0.2204125344462D+00, + : 0.6056556925895D-08, 0.1677494667846D+01, 0.1059381944224D+01, + : 0.5734142698204D-08, 0.4000920852962D+01, 0.5225775174439D+00, + : 0.5614341822459D-08, 0.3486722577328D+01, 0.5368044267797D+00, + : 0.1028678147656D-08, 0.1877141024787D+01, 0.7113454667900D-02, + : 0.7270792075266D-09, 0.5077167301739D+01, 0.6398972393349D+00, + : 0.8734141726040D-09, 0.9069550282609D-01, 0.4194847048887D+00, + : 0.5377371402113D-09, 0.6039381844671D+01, 0.4337116142245D+00 / + DATA ((S1(I,J,2),I=1,3),J= 11, 20) / + : 0.4729719431571D-09, 0.2153086311760D+01, 0.2132990797783D+00, + : 0.4458052820973D-09, 0.5059830025565D+01, 0.5296909721118D+00, + : 0.4406855467908D-09, 0.2027971692630D+01, 0.1589072916335D+01, + : 0.3101659310977D-09, 0.3317677981860D+01, 0.1052268489556D+01, + : 0.3016749232545D-09, 0.3913703482532D+01, 0.1066495398892D+01, + : 0.3198541352656D-09, 0.1275513098525D+01, 0.1495633313810D+00, + : 0.2142065389871D-09, 0.5301351614597D+01, 0.3163918923335D+00, + : 0.1902615247592D-09, 0.4894943352736D+00, 0.2275259891141D+00, + : 0.1613410990871D-09, 0.2449891130437D+01, 0.1102062672231D+00, + : 0.1576992165097D-09, 0.4211421447633D+01, 0.7626583626240D-01 / + DATA ((S1(I,J,2),I=1,3),J= 21, 30) / + : 0.1241637259894D-09, 0.4140803368133D+01, 0.5154640627760D+00, + : 0.1313974830355D-09, 0.3591920305503D+01, 0.3664874755930D-01, + : 0.1181697118258D-09, 0.1506314382788D+01, 0.6327837846670D+00, + : 0.1238239742779D-09, 0.7461405378404D+00, 0.3961708870310D-01, + : 0.1010107068241D-09, 0.6271010795475D+00, 0.7329749511860D-01, + : 0.9226316616509D-10, 0.1259158839583D+01, 0.1990721704425D+00, + : 0.8664946419555D-10, 0.3353244696934D+01, 0.5439178814476D+00, + : 0.7757230468978D-10, 0.1447677295196D+01, 0.9491756770005D+00, + : 0.7693168628139D-10, 0.1120509896721D+01, 0.1030928125552D+00, + : 0.5487897454612D-10, 0.4439380426795D+01, 0.8531963191132D+00 / + DATA ((S1(I,J,2),I=1,3),J= 31, 40) / + : 0.5196118677218D-10, 0.3788856619137D+00, 0.2093666171530D+00, + : 0.5110853339935D-10, 0.1386879372016D+01, 0.2172315424036D+00, + : 0.5027804534813D-10, 0.1647881805466D+00, 0.2164800718209D+00, + : 0.4922485922674D-10, 0.1594315079862D+01, 0.2101180877357D+00, + : 0.6155599524400D-10, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.4447147832161D-10, 0.5480720918976D+01, 0.3235053470014D+00, + : 0.4144691276422D-10, 0.1931371033660D+01, 0.6373574839730D-01, + : 0.4099950625452D-10, 0.5229611294335D+01, 0.6470106940028D+00, + : 0.5060541682953D-10, 0.1731112486298D+01, 0.1422690933580D-01, + : 0.4293615946300D-10, 0.2714571038925D+01, 0.7358765972222D+00 / + DATA ((S1(I,J,2),I=1,3),J= 41,NS1Y) / + : 0.3545659845763D-10, 0.4451041444634D+01, 0.5265099800692D+00, + : 0.3479112041196D-10, 0.3029385448081D+01, 0.5328719641544D+00, + : 0.3438516493570D-10, 0.2778507143731D+01, 0.8582758298370D-01, + : 0.3297341285033D-10, 0.7898709807584D+00, 0.1104591729320D-01, + : 0.2972585818015D-10, 0.3218785316973D+01, 0.5257585094865D+00, + : 0.2931707295017D-10, 0.4260731012098D+01, 0.5336234347371D+00, + : 0.2897198149403D-10, 0.1120753978101D+01, 0.1173197218910D+00, + : 0.2832293240878D-10, 0.4597682717827D+00, 0.2022531624851D+00, + : 0.2864348326612D-10, 0.2169939928448D+01, 0.9597935788730D-01, + : 0.2852714675471D-10, 0.2377659870578D+01, 0.2118763888447D+01 / + +* SSB-to-Sun, T^2, Y + DATA ((S2(I,J,2),I=1,3),J= 1,NS2Y) / + : 0.1609114495091D-11, 0.2831096993481D+01, 0.2061856251104D+00, + : 0.1560330784946D-11, 0.5193058213906D+01, 0.2204125344462D+00, + : 0.1183535479202D-11, 0.5707003443890D+01, 0.5225775174439D+00, + : 0.1158183066182D-11, 0.1782400404928D+01, 0.5368044267797D+00, + : 0.1032868027407D-11, 0.4036925452011D+01, 0.2132990797783D+00, + : 0.6540142847741D-12, 0.4058241056717D+01, 0.4265981595566D+00, + : 0.7305236491596D-12, 0.6175401942957D+00, 0.5296909721118D+00, + : -0.5580725052968D-12, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.3946122651015D-12, 0.4108265279171D+00, 0.1059381944224D+01 / + +* SSB-to-Sun, T^0, Z + DATA ((S0(I,J,3),I=1,3),J= 1, 10) / + : 0.1181255122986D-03, 0.4607918989164D+00, 0.2132990797783D+00, + : 0.1127777651095D-03, 0.4169146331296D+00, 0.5296909721118D+00, + : 0.4777754401806D-04, 0.4582657007130D+01, 0.3813291813120D-01, + : 0.1129354285772D-04, 0.5758735142480D+01, 0.7478166569050D-01, + : -0.1149543637123D-04, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.3298730512306D-05, 0.5978801994625D+01, 0.4265981595566D+00, + : 0.2733376706079D-05, 0.7665413691040D+00, 0.1059381944224D+01, + : 0.9426389657270D-06, 0.3710201265838D+01, 0.2061856251104D+00, + : 0.8187517749552D-06, 0.3390675605802D+00, 0.2204125344462D+00, + : 0.4080447871819D-06, 0.4552296640088D+00, 0.5225775174439D+00 / + DATA ((S0(I,J,3),I=1,3),J= 11, 20) / + : 0.3169973017028D-06, 0.3445455899321D+01, 0.5368044267797D+00, + : 0.2438098615549D-06, 0.5664675150648D+01, 0.3664874755930D-01, + : 0.2601897517235D-06, 0.1931894095697D+01, 0.1495633313810D+00, + : 0.2314558080079D-06, 0.3666319115574D+00, 0.3961708870310D-01, + : 0.1962549548002D-06, 0.3167411699020D+01, 0.7626583626240D-01, + : 0.2180518287925D-06, 0.1544420746580D+01, 0.7113454667900D-02, + : 0.1451382442868D-06, 0.1583756740070D+01, 0.1102062672231D+00, + : 0.1358439007389D-06, 0.5239941758280D+01, 0.6398972393349D+00, + : 0.1050585898028D-06, 0.2266958352859D+01, 0.3163918923335D+00, + : 0.1050029870186D-06, 0.2711495250354D+01, 0.4194847048887D+00 / + DATA ((S0(I,J,3),I=1,3),J= 21, 30) / + : 0.9934920679800D-07, 0.1116208151396D+01, 0.1589072916335D+01, + : 0.1048395331560D-06, 0.3408619600206D+01, 0.1021328554739D+02, + : 0.8370147196668D-07, 0.3810459401087D+01, 0.2535050500000D-01, + : 0.7989856510998D-07, 0.3769910473647D+01, 0.7329749511860D-01, + : 0.5441221655233D-07, 0.2416994903374D+01, 0.1030928125552D+00, + : 0.4610812906784D-07, 0.5858503336994D+01, 0.4337116142245D+00, + : 0.3923022803444D-07, 0.3354170010125D+00, 0.1484170571900D-02, + : 0.2610725582128D-07, 0.5410600646324D+01, 0.6327837846670D+00, + : 0.2455279767721D-07, 0.6120216681403D+01, 0.1162474756779D+01, + : 0.2375530706525D-07, 0.6055443426143D+01, 0.1052268489556D+01 / + DATA ((S0(I,J,3),I=1,3),J= 31, 40) / + : 0.1782967577553D-07, 0.3146108708004D+01, 0.8460828644453D+00, + : 0.1581687095238D-07, 0.6255496089819D+00, 0.3340612434717D+01, + : 0.1594657672461D-07, 0.3782604300261D+01, 0.1066495398892D+01, + : 0.1563448615040D-07, 0.1997775733196D+01, 0.2022531624851D+00, + : 0.1463624258525D-07, 0.1736316792088D+00, 0.3516457698740D-01, + : 0.1331585056673D-07, 0.4331941830747D+01, 0.9491756770005D+00, + : 0.1130634557637D-07, 0.6152017751825D+01, 0.2968341143800D-02, + : 0.1028949607145D-07, 0.2101792614637D+00, 0.2275259891141D+00, + : 0.1024074971618D-07, 0.4071833211074D+01, 0.5070101000000D-01, + : 0.8826956060303D-08, 0.4861633688145D+00, 0.2093666171530D+00 / + DATA ((S0(I,J,3),I=1,3),J= 41, 50) / + : 0.8572230171541D-08, 0.5268190724302D+01, 0.4110125927500D-01, + : 0.7649332643544D-08, 0.5134543417106D+01, 0.2608790314060D+02, + : 0.8581673291033D-08, 0.2920218146681D+01, 0.1480791608091D+00, + : 0.8430589300938D-08, 0.3604576619108D+01, 0.2172315424036D+00, + : 0.7776165501012D-08, 0.3772942249792D+01, 0.6373574839730D-01, + : 0.8311070234408D-08, 0.6200412329888D+01, 0.3235053470014D+00, + : 0.6927365212582D-08, 0.4543353113437D+01, 0.8531963191132D+00, + : 0.6791574208598D-08, 0.2882188406238D+01, 0.7181332454670D-01, + : 0.5593100811839D-08, 0.1776646892780D+01, 0.7429900518901D+00, + : 0.4553381853021D-08, 0.3949617611240D+01, 0.7775000683430D-01 / + DATA ((S0(I,J,3),I=1,3),J= 51, 60) / + : 0.5758000450068D-08, 0.3859251775075D+01, 0.1990721704425D+00, + : 0.4281283457133D-08, 0.1466294631206D+01, 0.2118763888447D+01, + : 0.4206935661097D-08, 0.5421776011706D+01, 0.1104591729320D-01, + : 0.4213751641837D-08, 0.3412048993322D+01, 0.2243449970715D+00, + : 0.5310506239878D-08, 0.5421641370995D+00, 0.5154640627760D+00, + : 0.3827450341320D-08, 0.8887314524995D+00, 0.1510475019529D+00, + : 0.4292435241187D-08, 0.1405043757194D+01, 0.1422690933580D-01, + : 0.3189780702289D-08, 0.1060049293445D+01, 0.1173197218910D+00, + : 0.3226611928069D-08, 0.6270858897442D+01, 0.2164800718209D+00, + : 0.2893897608830D-08, 0.5117563223301D+01, 0.6470106940028D+00 / + DATA ((S0(I,J,3),I=1,3),J= 61,NS0Z) / + : 0.3239852024578D-08, 0.4079092237983D+01, 0.2101180877357D+00, + : 0.2956892222200D-08, 0.1594917021704D+01, 0.3092784376656D+00, + : 0.2980177912437D-08, 0.5258787667564D+01, 0.4155522422634D+00, + : 0.3163725690776D-08, 0.3854589225479D+01, 0.8582758298370D-01, + : 0.2662262399118D-08, 0.3561326430187D+01, 0.5257585094865D+00, + : 0.2766689135729D-08, 0.3180732086830D+00, 0.1385174140878D+00, + : 0.2411600278464D-08, 0.3324798335058D+01, 0.5439178814476D+00, + : 0.2483527695131D-08, 0.4169069291947D+00, 0.5336234347371D+00, + : 0.7788777276590D-09, 0.1900569908215D+01, 0.5217580628120D+02 / + +* SSB-to-Sun, T^1, Z + DATA ((S1(I,J,3),I=1,3),J= 1, 10) / + : 0.5444220475678D-08, 0.1803825509310D+01, 0.2132990797783D+00, + : 0.3883412695596D-08, 0.4668616389392D+01, 0.5296909721118D+00, + : 0.1334341434551D-08, 0.0000000000000D+00, 0.0000000000000D+00, + : 0.3730001266883D-09, 0.5401405918943D+01, 0.2061856251104D+00, + : 0.2894929197956D-09, 0.4932415609852D+01, 0.2204125344462D+00, + : 0.2857950357701D-09, 0.3154625362131D+01, 0.7478166569050D-01, + : 0.2499226432292D-09, 0.3657486128988D+01, 0.4265981595566D+00, + : 0.1937705443593D-09, 0.5740434679002D+01, 0.1059381944224D+01, + : 0.1374894396320D-09, 0.1712857366891D+01, 0.5368044267797D+00, + : 0.1217248678408D-09, 0.2312090870932D+01, 0.5225775174439D+00 / + DATA ((S1(I,J,3),I=1,3),J= 11,NS1Z) / + : 0.7961052740870D-10, 0.5283368554163D+01, 0.3813291813120D-01, + : 0.4979225949689D-10, 0.4298290471860D+01, 0.4194847048887D+00, + : 0.4388552286597D-10, 0.6145515047406D+01, 0.7113454667900D-02, + : 0.2586835212560D-10, 0.3019448001809D+01, 0.6398972393349D+00 / + +* SSB-to-Sun, T^2, Z + DATA ((S2(I,J,3),I=1,3),J= 1,NS2Z) / + : 0.3749920358054D-12, 0.3230285558668D+01, 0.2132990797783D+00, + : 0.2735037220939D-12, 0.6154322683046D+01, 0.5296909721118D+00 / + +* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +* Time since reference epoch, years. + T = ( DATE - DJM0 ) / DJY + T2 = T*T + +* X then Y then Z. + DO K=1,3 + +* Initialize position and velocity component. + XYZ = 0D0 + XYZD = 0D0 + +* ------------------------------------------------ +* Obtain component of Sun to Earth ecliptic vector +* ------------------------------------------------ + +* Sun to Earth, T^0 terms. + DO J=1,NE0(K) + A = E0(1,J,K) + B = E0(2,J,K) + C = E0(3,J,K) + P = B + C*T + XYZ = XYZ + A*COS(P) + XYZD = XYZD - A*C*SIN(P) + END DO + +* Sun to Earth, T^1 terms. + DO J=1,NE1(K) + A = E1(1,J,K) + B = E1(2,J,K) + C = E1(3,J,K) + CT = C*T + P = B + CT + CP = COS(P) + XYZ = XYZ + A*T*CP + XYZD = XYZD + A*(CP-CT*SIN(P)) + END DO + +* Sun to Earth, T^2 terms. + DO J=1,NE2(K) + A = E2(1,J,K) + B = E2(2,J,K) + C = E2(3,J,K) + CT = C*T + P = B + CT + CP = COS(P) + XYZ = XYZ + A*T2*CP + XYZD = XYZD + A*T*(2D0*CP-CT*SIN(P)) + END DO + +* Heliocentric Earth position and velocity component. + HP(K) = XYZ + HV(K) = XYZD / DJY + +* ------------------------------------------------ +* Obtain component of SSB to Earth ecliptic vector +* ------------------------------------------------ + +* SSB to Sun, T^0 terms. + DO J=1,NS0(K) + A = S0(1,J,K) + B = S0(2,J,K) + C = S0(3,J,K) + P = B + C*T + XYZ = XYZ + A*COS(P) + XYZD = XYZD - A*C*SIN(P) + END DO + +* SSB to Sun, T^1 terms. + DO J=1,NS1(K) + A = S1(1,J,K) + B = S1(2,J,K) + C = S1(3,J,K) + CT = C*T + P = B + CT + CP = COS(P) + XYZ = XYZ + A*T*CP + XYZD = XYZD + A*(CP-CT*SIN(P)) + END DO + +* SSB to Sun, T^2 terms. + DO J=1,NS2(K) + A = S2(1,J,K) + B = S2(2,J,K) + C = S2(3,J,K) + CT = C*T + P = B + CT + CP = COS(P) + XYZ = XYZ + A*T2*CP + XYZD = XYZD + A*T*(2D0*CP-CT*SIN(P)) + END DO + +* Barycentric Earth position and velocity component. + BP(K) = XYZ + BV(K) = XYZD / DJY + +* Next Cartesian component. + END DO + +* Rotate from ecliptic to ICRS coordinates and return the results. + X = HP(1) + Y = HP(2) + Z = HP(3) + PH(1) = X + AM12*Y + AM13*Z + PH(2) = AM21*X + AM22*Y + AM23*Z + PH(3) = AM32*Y + AM33*Z + X = HV(1) + Y = HV(2) + Z = HV(3) + VH(1) = X + AM12*Y + AM13*Z + VH(2) = AM21*X + AM22*Y + AM23*Z + VH(3) = AM32*Y + AM33*Z + X = BP(1) + Y = BP(2) + Z = BP(3) + PB(1) = X + AM12*Y + AM13*Z + PB(2) = AM21*X + AM22*Y + AM23*Z + PB(3) = AM32*Y + AM33*Z + X = BV(1) + Y = BV(2) + Z = BV(3) + VB(1) = X + AM12*Y + AM13*Z + VB(2) = AM21*X + AM22*Y + AM23*Z + VB(3) = AM32*Y + AM33*Z + + END diff --git a/math/slalib/eqecl.f b/math/slalib/eqecl.f new file mode 100644 index 00000000..d3e405a9 --- /dev/null +++ b/math/slalib/eqecl.f @@ -0,0 +1,73 @@ + SUBROUTINE slEQEC (DR, DD, DATE, DL, DB) +*+ +* - - - - - - +* E Q E C +* - - - - - - +* +* Transformation from J2000.0 equatorial coordinates to +* ecliptic coordinates (double precision) +* +* Given: +* DR,DD dp J2000.0 mean RA,Dec (radians) +* DATE dp TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* Returned: +* DL,DB dp ecliptic longitude and latitude +* (mean of date, IAU 1980 theory, radians) +* +* Called: +* slDS2C, slPREC, slEPJ, slDMXV, slECMA, slDC2S, +* slDA2P, slDA1P +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DR,DD,DATE,DL,DB + + DOUBLE PRECISION slEPJ,slDA2P,slDA1P + + DOUBLE PRECISION RMAT(3,3),V1(3),V2(3) + + + +* Spherical to Cartesian + CALL slDS2C(DR,DD,V1) + +* Mean J2000 to mean of date + CALL slPREC(2000D0,slEPJ(DATE),RMAT) + CALL slDMXV(RMAT,V1,V2) + +* Equatorial to ecliptic + CALL slECMA(DATE,RMAT) + CALL slDMXV(RMAT,V2,V1) + +* Cartesian to spherical + CALL slDC2S(V1,DL,DB) + +* Express in conventional ranges + DL=slDA2P(DL) + DB=slDA1P(DB) + + END diff --git a/math/slalib/eqeqx.f b/math/slalib/eqeqx.f new file mode 100644 index 00000000..915f40c3 --- /dev/null +++ b/math/slalib/eqeqx.f @@ -0,0 +1,75 @@ + DOUBLE PRECISION FUNCTION slEQEX (DATE) +*+ +* - - - - - - +* E Q E X +* - - - - - - +* +* Equation of the equinoxes (IAU 1994, double precision) +* +* Given: +* DATE dp TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* +* The result is the equation of the equinoxes (double precision) +* in radians: +* +* Greenwich apparent ST = GMST + slEQEX +* +* References: IAU Resolution C7, Recommendation 3 (1994) +* Capitaine, N. & Gontier, A.-M., Astron. Astrophys., +* 275, 645-650 (1993) +* +* Called: slNUTC +* +* Patrick Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + +* Turns to arc seconds and arc seconds to radians + DOUBLE PRECISION T2AS,AS2R + PARAMETER (T2AS=1296000D0, + : AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION T,OM,DPSI,DEPS,EPS0 + + + +* Interval between basic epoch J2000.0 and current epoch (JC) + T=(DATE-51544.5D0)/36525D0 + +* Longitude of the mean ascending node of the lunar orbit on the +* ecliptic, measured from the mean equinox of date + OM=AS2R*(450160.280D0+(-5D0*T2AS-482890.539D0 + : +(7.455D0+0.008D0*T)*T)*T) + +* Nutation + CALL slNUTC(DATE,DPSI,DEPS,EPS0) + +* Equation of the equinoxes + slEQEX=DPSI*COS(EPS0)+AS2R*(0.00264D0*SIN(OM)+ + : 0.000063D0*SIN(OM+OM)) + + END diff --git a/math/slalib/eqgal.f b/math/slalib/eqgal.f new file mode 100644 index 00000000..eeb19f5d --- /dev/null +++ b/math/slalib/eqgal.f @@ -0,0 +1,97 @@ + SUBROUTINE slEQGA (DR, DD, DL, DB) +*+ +* - - - - - - +* E Q G A +* - - - - - - +* +* Transformation from J2000.0 equatorial coordinates to +* IAU 1958 galactic coordinates (double precision) +* +* Given: +* DR,DD dp J2000.0 RA,Dec +* +* Returned: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDMXV, slDC2S, slDA2P, slDA1P +* +* Note: +* The equatorial coordinates are J2000.0. Use the routine +* slEG50 if conversion from B1950.0 'FK4' coordinates is +* required. +* +* Reference: +* Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) +* +* P.T.Wallace Starlink 21 September 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DR,DD,DL,DB + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3) + +* +* L2,B2 system of galactic coordinates +* +* P = 192.25 RA of galactic north pole (mean B1950.0) +* Q = 62.6 inclination of galactic to mean B1950.0 equator +* R = 33 longitude of ascending node +* +* P,Q,R are degrees +* +* Equatorial to galactic rotation matrix (J2000.0), obtained by +* applying the standard FK4 to FK5 transformation, for zero proper +* motion in FK5, to the columns of the B1950 equatorial to +* galactic rotation matrix: +* + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3)/ + : -0.054875539726D0,-0.873437108010D0,-0.483834985808D0, + : +0.494109453312D0,-0.444829589425D0,+0.746982251810D0, + : -0.867666135858D0,-0.198076386122D0,+0.455983795705D0/ + + + +* Spherical to Cartesian + CALL slDS2C(DR,DD,V1) + +* Equatorial to galactic + CALL slDMXV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,DL,DB) + +* Express in conventional ranges + DL=slDA2P(DL) + DB=slDA1P(DB) + + END diff --git a/math/slalib/etrms.f b/math/slalib/etrms.f new file mode 100644 index 00000000..f596bf2c --- /dev/null +++ b/math/slalib/etrms.f @@ -0,0 +1,80 @@ + SUBROUTINE slETRM (EP, EV) +*+ +* - - - - - - +* E T R M +* - - - - - - +* +* Compute the E-terms (elliptic component of annual aberration) +* vector (double precision) +* +* Given: +* EP dp Besselian epoch +* +* Returned: +* EV dp(3) E-terms as (dx,dy,dz) +* +* Note the use of the J2000 aberration constant (20.49552 arcsec). +* This is a reflection of the fact that the E-terms embodied in +* existing star catalogues were computed from a variety of +* aberration constants. Rather than adopting one of the old +* constants the latest value is used here. +* +* References: +* 1 Smith, C.A. et al., 1989. Astr.J. 97, 265. +* 2 Yallop, B.D. et al., 1989. Astr.J. 97, 274. +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EP,EV(3) + +* Arcseconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION T,E,E0,P,EK,CP + + + +* Julian centuries since B1950 + T=(EP-1950D0)*1.00002135903D-2 + +* Eccentricity + E=0.01673011D0-(0.00004193D0+0.000000126D0*T)*T + +* Mean obliquity + E0=(84404.836D0-(46.8495D0+(0.00319D0+0.00181D0*T)*T)*T)*AS2R + +* Mean longitude of perihelion + P=(1015489.951D0+(6190.67D0+(1.65D0+0.012D0*T)*T)*T)*AS2R + +* E-terms + EK=E*20.49552D0*AS2R + CP=COS(P) + EV(1)= EK*SIN(P) + EV(2)=-EK*CP*COS(E0) + EV(3)=-EK*CP*SIN(E0) + + END diff --git a/math/slalib/euler.f b/math/slalib/euler.f new file mode 100644 index 00000000..ff764cf6 --- /dev/null +++ b/math/slalib/euler.f @@ -0,0 +1,86 @@ + SUBROUTINE slEULR (ORDER, PHI, THETA, PSI, RMAT) +*+ +* - - - - - - +* E U L R +* - - - - - - +* +* Form a rotation matrix from the Euler angles - three successive +* rotations about specified Cartesian axes (single precision) +* +* Given: +* ORDER c*(*) specifies about which axes the rotations occur +* PHI r 1st rotation (radians) +* THETA r 2nd rotation ( " ) +* PSI r 3rd rotation ( " ) +* +* Returned: +* RMAT r(3,3) rotation matrix +* +* A rotation is positive when the reference frame rotates +* anticlockwise as seen looking towards the origin from the +* positive region of the specified axis. +* +* The characters of ORDER define which axes the three successive +* rotations are about. A typical value is 'ZXZ', indicating that +* RMAT is to become the direction cosine matrix corresponding to +* rotations of the reference frame through PHI radians about the +* old Z-axis, followed by THETA radians about the resulting X-axis, +* then PSI radians about the resulting Z-axis. +* +* The axis names can be any of the following, in any order or +* combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal +* axis labelling/numbering conventions apply; the xyz (=123) +* triad is right-handed. Thus, the 'ZXZ' example given above +* could be written 'zxz' or '313' (or even 'ZxZ' or '3xZ'). ORDER +* is terminated by length or by the first unrecognized character. +* +* Fewer than three rotations are acceptable, in which case the later +* angle arguments are ignored. If all rotations are zero, the +* identity matrix is produced. +* +* Called: slDEUL +* +* P.T.Wallace Starlink 23 May 1997 +* +* Copyright (C) 1997 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) ORDER + REAL PHI,THETA,PSI,RMAT(3,3) + + INTEGER J,I + DOUBLE PRECISION W(3,3) + + + +* Compute matrix in double precision + CALL slDEUL(ORDER,DBLE(PHI),DBLE(THETA),DBLE(PSI),W) + +* Copy the result + DO J=1,3 + DO I=1,3 + RMAT(I,J) = REAL(W(I,J)) + END DO + END DO + + END diff --git a/math/slalib/evp.f b/math/slalib/evp.f new file mode 100644 index 00000000..f1e6f555 --- /dev/null +++ b/math/slalib/evp.f @@ -0,0 +1,457 @@ + SUBROUTINE slEVP (DATE, DEQX, DVB, DPB, DVH, DPH) +*+ +* - - - - +* E V P +* - - - - +* +* Barycentric and heliocentric velocity and position of the Earth +* +* All arguments are double precision +* +* Given: +* +* DATE TDB (loosely ET) as a Modified Julian Date +* (JD-2400000.5) +* +* DEQX Julian Epoch (e.g. 2000.0D0) of mean equator and +* equinox of the vectors returned. If DEQX .LE. 0D0, +* all vectors are referred to the mean equator and +* equinox (FK5) of epoch DATE. +* +* Returned (all 3D Cartesian vectors): +* +* DVB,DPB barycentric velocity, position (AU/s, AU) +* DVH,DPH heliocentric velocity, position (AU/s, AU) +* +* Called: slEPJ, slPREC +* +* Notes: +* +* 1 This routine is accurate enough for many purposes but faster and +* more compact than the slEPV routine. The maximum deviations +* from the JPL DE96 ephemeris are as follows: +* +* barycentric velocity 0.42 m/s +* barycentric position 6900 km +* +* heliocentric velocity 0.42 m/s +* heliocentric position 1600 km +* +* 2 The routine is adapted from the BARVEL and BARCOR subroutines of +* Stumpff (1980). Most of the changes are merely cosmetic and do +* not affect the results at all. However, some adjustments have +* been made so as to give results that refer to the IAU 1976 'FK5' +* equinox and precession, although the differences these changes +* make relative to the results from Stumpff's original 'FK4' version +* are smaller than the inherent accuracy of the algorithm. One +* minor shortcoming in the original routines that has NOT been +* corrected is that better numerical accuracy could be achieved if +* the various polynomial evaluations were nested. +* +* Reference: +* +* Stumpff, P., Astron.Astrophys.Suppl.Ser. 41, 1-8 (1980). +* +* Last revision: 7 April 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,DEQX,DVB(3),DPB(3),DVH(3),DPH(3) + + INTEGER IDEQ,I,J,K + + REAL CC2PI,CCSEC3,CCSGD,CCKM,CCMLD,CCFDI,CCIM,T,TSQ,A,PERTL, + : PERTLD,PERTR,PERTRD,COSA,SINA,ESQ,E,PARAM,TWOE,TWOG,G, + : PHI,F,SINF,COSF,PHID,PSID,PERTP,PERTPD,TL,SINLM,COSLM, + : SIGMA,B,PLON,POMG,PECC,FLATM,FLAT + + DOUBLE PRECISION DC2PI,DS2R,DCSLD,DC1MME,DT,DTSQ,DLOCAL,DML, + : DEPS,DPARAM,DPSI,D1PDRO,DRD,DRLD,DTL,DSINLS, + : DCOSLS,DXHD,DYHD,DZHD,DXBD,DYBD,DZBD,DCOSEP, + : DSINEP,DYAHD,DZAHD,DYABD,DZABD,DR, + : DXH,DYH,DZH,DXB,DYB,DZB,DYAH,DZAH,DYAB, + : DZAB,DEPJ,DEQCOR,B1950 + + REAL SN(4),CCSEL(3,17),CCAMPS(5,15),CCSEC(3,4),CCAMPM(4,3), + : CCPAMV(4),CCPAM(4),FORBEL(7),SORBEL(17),SINLP(4),COSLP(4) + EQUIVALENCE (SORBEL(1),E),(FORBEL(1),G) + + DOUBLE PRECISION DCFEL(3,8),DCEPS(3),DCARGS(2,15),DCARGM(2,3), + : DPREMA(3,3),W,VW(3) + + DOUBLE PRECISION slEPJ + + PARAMETER (DC2PI=6.2831853071796D0,CC2PI=6.283185) + PARAMETER (DS2R=0.7272205216643D-4) + PARAMETER (B1950=1949.9997904423D0) + +* +* Constants DCFEL(I,K) of fast changing elements +* I=1 I=2 I=3 + DATA DCFEL/ 1.7400353D+00, 6.2833195099091D+02, 5.2796D-06, + : 6.2565836D+00, 6.2830194572674D+02,-2.6180D-06, + : 4.7199666D+00, 8.3997091449254D+03,-1.9780D-05, + : 1.9636505D-01, 8.4334662911720D+03,-5.6044D-05, + : 4.1547339D+00, 5.2993466764997D+01, 5.8845D-06, + : 4.6524223D+00, 2.1354275911213D+01, 5.6797D-06, + : 4.2620486D+00, 7.5025342197656D+00, 5.5317D-06, + : 1.4740694D+00, 3.8377331909193D+00, 5.6093D-06/ + +* +* Constants DCEPS and CCSEL(I,K) of slowly changing elements +* I=1 I=2 I=3 + DATA DCEPS/ 4.093198D-01,-2.271110D-04,-2.860401D-08 / + DATA CCSEL/ 1.675104E-02,-4.179579E-05,-1.260516E-07, + : 2.220221E-01, 2.809917E-02, 1.852532E-05, + : 1.589963E+00, 3.418075E-02, 1.430200E-05, + : 2.994089E+00, 2.590824E-02, 4.155840E-06, + : 8.155457E-01, 2.486352E-02, 6.836840E-06, + : 1.735614E+00, 1.763719E-02, 6.370440E-06, + : 1.968564E+00, 1.524020E-02,-2.517152E-06, + : 1.282417E+00, 8.703393E-03, 2.289292E-05, + : 2.280820E+00, 1.918010E-02, 4.484520E-06, + : 4.833473E-02, 1.641773E-04,-4.654200E-07, + : 5.589232E-02,-3.455092E-04,-7.388560E-07, + : 4.634443E-02,-2.658234E-05, 7.757000E-08, + : 8.997041E-03, 6.329728E-06,-1.939256E-09, + : 2.284178E-02,-9.941590E-05, 6.787400E-08, + : 4.350267E-02,-6.839749E-05,-2.714956E-07, + : 1.348204E-02, 1.091504E-05, 6.903760E-07, + : 3.106570E-02,-1.665665E-04,-1.590188E-07/ + +* +* Constants of the arguments of the short-period perturbations +* by the planets: DCARGS(I,K) +* I=1 I=2 + DATA DCARGS/ 5.0974222D+00,-7.8604195454652D+02, + : 3.9584962D+00,-5.7533848094674D+02, + : 1.6338070D+00,-1.1506769618935D+03, + : 2.5487111D+00,-3.9302097727326D+02, + : 4.9255514D+00,-5.8849265665348D+02, + : 1.3363463D+00,-5.5076098609303D+02, + : 1.6072053D+00,-5.2237501616674D+02, + : 1.3629480D+00,-1.1790629318198D+03, + : 5.5657014D+00,-1.0977134971135D+03, + : 5.0708205D+00,-1.5774000881978D+02, + : 3.9318944D+00, 5.2963464780000D+01, + : 4.8989497D+00, 3.9809289073258D+01, + : 1.3097446D+00, 7.7540959633708D+01, + : 3.5147141D+00, 7.9618578146517D+01, + : 3.5413158D+00,-5.4868336758022D+02/ + +* +* Amplitudes CCAMPS(N,K) of the short-period perturbations +* N=1 N=2 N=3 N=4 N=5 + DATA 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.0E0, + : -8.043059E-6,-2.991300E-6, 1.473654E-7,-3.154542E-7, 0.0E0, + : 3.699128E-6,-3.316126E-6, 2.901257E-7, 3.407826E-7, 0.0E0, + : 2.550120E-6,-1.241123E-6, 9.901116E-8, 2.210482E-7, 0.0E0, + : -6.351059E-7, 2.341650E-6, 1.061492E-6, 2.878231E-7, 0.0E0/ + +* +* Constants of the secular perturbations in longitude +* CCSEC3 and CCSEC(N,K) +* N=1 N=2 N=3 + DATA CCSEC3/-7.757020E-08/, + : CCSEC/ 1.289600E-06, 5.550147E-01, 2.076942E+00, + : 3.102810E-05, 4.035027E+00, 3.525565E-01, + : 9.124190E-06, 9.990265E-01, 2.622706E+00, + : 9.793240E-07, 5.508259E+00, 1.559103E+01/ + +* Sidereal rate DCSLD in longitude, rate CCSGD in mean anomaly + DATA DCSLD/1.990987D-07/, + : CCSGD/1.990969E-07/ + +* Some constants used in the calculation of the lunar contribution + DATA CCKM/3.122140E-05/, + : CCMLD/2.661699E-06/, + : CCFDI/2.399485E-07/ + +* +* Constants DCARGM(I,K) of the arguments of the perturbations +* of the motion of the Moon +* I=1 I=2 + DATA DCARGM/ 5.1679830D+00, 8.3286911095275D+03, + : 5.4913150D+00,-7.2140632838100D+03, + : 5.9598530D+00, 1.5542754389685D+04/ + +* +* Amplitudes CCAMPM(N,K) of the perturbations of the Moon +* N=1 N=2 N=3 N=4 + DATA CCAMPM/ + : 1.097594E-01, 2.896773E-07, 5.450474E-02, 1.438491E-07, + : -2.223581E-02, 5.083103E-08, 1.002548E-02,-2.291823E-08, + : 1.148966E-02, 5.658888E-08, 8.249439E-03, 4.063015E-08/ + +* +* CCPAMV(K)=A*M*DL/DT (planets), DC1MME=1-MASS(Earth+Moon) + DATA CCPAMV/8.326827E-11,1.843484E-11,1.988712E-12,1.881276E-12/ + DATA DC1MME/0.99999696D0/ + +* CCPAM(K)=A*M(planets), CCIM=INCLINATION(Moon) + DATA CCPAM/4.960906E-3,2.727436E-3,8.392311E-4,1.556861E-3/ + DATA CCIM/8.978749E-2/ + + + + +* +* EXECUTION +* --------- + +* Control parameter IDEQ, and time arguments + IDEQ = 0 + IF (DEQX.GT.0D0) IDEQ=1 + DT = (DATE-15019.5D0)/36525D0 + T = REAL(DT) + DTSQ = DT*DT + TSQ = REAL(DTSQ) + +* Values of all elements for the instant DATE + DO K=1,8 + DLOCAL = MOD(DCFEL(1,K)+DT*DCFEL(2,K)+DTSQ*DCFEL(3,K), DC2PI) + IF (K.EQ.1) THEN + DML = DLOCAL + ELSE + FORBEL(K-1) = REAL(DLOCAL) + END IF + END DO + DEPS = MOD(DCEPS(1)+DT*DCEPS(2)+DTSQ*DCEPS(3), DC2PI) + DO K=1,17 + SORBEL(K) = MOD(CCSEL(1,K)+T*CCSEL(2,K)+TSQ*CCSEL(3,K), + : CC2PI) + END DO + +* Secular perturbations in longitude + DO K=1,4 + A = MOD(CCSEC(2,K)+T*CCSEC(3,K), CC2PI) + SN(K) = SIN(A) + END DO + +* Periodic perturbations of the EMB (Earth-Moon barycentre) + PERTL = CCSEC(1,1) *SN(1) +CCSEC(1,2)*SN(2)+ + : (CCSEC(1,3)+T*CCSEC3)*SN(3) +CCSEC(1,4)*SN(4) + PERTLD = 0.0 + PERTR = 0.0 + PERTRD = 0.0 + DO K=1,15 + A = SNGL(MOD(DCARGS(1,K)+DT*DCARGS(2,K), DC2PI)) + COSA = COS(A) + SINA = SIN(A) + PERTL = PERTL + CCAMPS(1,K)*COSA+CCAMPS(2,K)*SINA + PERTR = PERTR + CCAMPS(3,K)*COSA+CCAMPS(4,K)*SINA + IF (K.LT.11) THEN + PERTLD = PERTLD+ + : (CCAMPS(2,K)*COSA-CCAMPS(1,K)*SINA)*CCAMPS(5,K) + PERTRD = PERTRD+ + : (CCAMPS(4,K)*COSA-CCAMPS(3,K)*SINA)*CCAMPS(5,K) + END IF + END DO + +* Elliptic part of the motion of the EMB + ESQ = E*E + DPARAM = 1D0-DBLE(ESQ) + PARAM = REAL(DPARAM) + TWOE = E+E + TWOG = G+G + PHI = TWOE*((1.0-ESQ*0.125)*SIN(G)+E*0.625*SIN(TWOG) + : +ESQ*0.54166667*SIN(G+TWOG) ) + F = G+PHI + SINF = SIN(F) + COSF = COS(F) + DPSI = DPARAM/(1D0+DBLE(E*COSF)) + PHID = TWOE*CCSGD*((1.0+ESQ*1.5)*COSF+E*(1.25-SINF*SINF*0.5)) + PSID = CCSGD*E*SINF/SQRT(PARAM) + +* Perturbed heliocentric motion of the EMB + D1PDRO = 1D0+DBLE(PERTR) + DRD = D1PDRO*(DBLE(PSID)+DPSI*DBLE(PERTRD)) + DRLD = D1PDRO*DPSI*(DCSLD+DBLE(PHID)+DBLE(PERTLD)) + DTL = MOD(DML+DBLE(PHI)+DBLE(PERTL), 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 + DO K=1,3 + A = SNGL(MOD(DCARGM(1,K)+DT*DCARGM(2,K), DC2PI)) + SINA = SIN(A) + COSA = COS(A) + PERTL = PERTL +CCAMPM(1,K)*SINA + PERTLD = PERTLD+CCAMPM(2,K)*COSA + PERTP = PERTP +CCAMPM(3,K)*COSA + PERTPD = PERTPD-CCAMPM(4,K)*SINA + END DO + +* Heliocentric motion of the Earth + TL = FORBEL(2)+PERTL + SINLM = SIN(TL) + COSLM = COS(TL) + SIGMA = CCKM/(1.0+PERTP) + A = SIGMA*(CCMLD+PERTLD) + B = SIGMA*PERTPD + DXHD = DXHD+DBLE(A*SINLM)+DBLE(B*COSLM) + DYHD = DYHD-DBLE(A*COSLM)+DBLE(B*SINLM) + DZHD = -DBLE(SIGMA*CCFDI*COS(FORBEL(3))) + +* Barycentric motion of the Earth + DXBD = DXHD*DC1MME + DYBD = DYHD*DC1MME + DZBD = DZHD*DC1MME + DO K=1,4 + PLON = FORBEL(K+3) + POMG = SORBEL(K+1) + PECC = SORBEL(K+9) + TL = MOD(PLON+2.0*PECC*SIN(PLON-POMG), CC2PI) + SINLP(K) = SIN(TL) + COSLP(K) = COS(TL) + DXBD = DXBD+DBLE(CCPAMV(K)*(SINLP(K)+PECC*SIN(POMG))) + DYBD = DYBD-DBLE(CCPAMV(K)*(COSLP(K)+PECC*COS(POMG))) + DZBD = DZBD-DBLE(CCPAMV(K)*SORBEL(K+13)*COS(PLON-SORBEL(K+5))) + END DO + +* 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 + +* Heliocentric coordinates of the Earth + DR = DPSI*D1PDRO + FLATM = CCIM*SIN(FORBEL(3)) + A = SIGMA*COS(FLATM) + DXH = DR*DCOSLS-DBLE(A*COSLM) + DYH = DR*DSINLS-DBLE(A*SINLM) + DZH = -DBLE(SIGMA*SIN(FLATM)) + +* Barycentric coordinates of the Earth + DXB = DXH*DC1MME + DYB = DYH*DC1MME + DZB = DZH*DC1MME + DO K=1,4 + FLAT = SORBEL(K+13)*SIN(FORBEL(K+3)-SORBEL(K+5)) + A = CCPAM(K)*(1.0-SORBEL(K+9)*COS(FORBEL(K+3)-SORBEL(K+1))) + B = A*COS(FLAT) + DXB = DXB-DBLE(B*COSLP(K)) + DYB = DYB-DBLE(B*SINLP(K)) + DZB = DZB-DBLE(A*SIN(FLAT)) + END DO + +* Transition to mean equator of date + DYAH = DCOSEP*DYH-DSINEP*DZH + DZAH = DSINEP*DYH+DCOSEP*DZH + DYAB = DCOSEP*DYB-DSINEP*DZB + DZAB = DSINEP*DYB+DCOSEP*DZB + +* Copy result components into vectors, correcting for FK4 equinox + DEPJ=slEPJ(DATE) + DEQCOR = DS2R*(0.035D0+0.00085D0*(DEPJ-B1950)) + DVH(1) = DXHD-DEQCOR*DYAHD + DVH(2) = DYAHD+DEQCOR*DXHD + DVH(3) = DZAHD + DVB(1) = DXBD-DEQCOR*DYABD + DVB(2) = DYABD+DEQCOR*DXBD + DVB(3) = DZABD + DPH(1) = DXH-DEQCOR*DYAH + DPH(2) = DYAH+DEQCOR*DXH + DPH(3) = DZAH + DPB(1) = DXB-DEQCOR*DYAB + DPB(2) = DYAB+DEQCOR*DXB + DPB(3) = DZAB + +* Was precession to another equinox requested? + IF (IDEQ.NE.0) THEN + +* Yes: compute precession matrix from MJD DATE to Julian epoch DEQX + CALL slPREC(DEPJ,DEQX,DPREMA) + +* Rotate DVH + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DPREMA(J,I)*DVH(I) + END DO + VW(J)=W + END DO + DO J=1,3 + DVH(J)=VW(J) + END DO + +* Rotate DVB + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DPREMA(J,I)*DVB(I) + END DO + VW(J)=W + END DO + DO J=1,3 + DVB(J)=VW(J) + END DO + +* Rotate DPH + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DPREMA(J,I)*DPH(I) + END DO + VW(J)=W + END DO + DO J=1,3 + DPH(J)=VW(J) + END DO + +* Rotate DPB + DO J=1,3 + W=0D0 + DO I=1,3 + W=W+DPREMA(J,I)*DPB(I) + END DO + VW(J)=W + END DO + DO J=1,3 + DPB(J)=VW(J) + END DO + END IF + + END diff --git a/math/slalib/f77.h.in b/math/slalib/f77.h.in new file mode 100644 index 00000000..43cab152 --- /dev/null +++ b/math/slalib/f77.h.in @@ -0,0 +1,956 @@ +/* +*+ +* Name: +* f77.h and cnf.h + +* Purpose: +* C - FORTRAN interace macros and prototypes + +* Language: +* C (part ANSI, part not) + +* Type of Module: +* C include file + +* Description: +* Including this file in SLALIB allows SLALIB to remain free of any +* dependencies on the rest of the Starlink Software Collection. +* +* For historical reasons two files, F77.h and cnf.h are required +* but the have now been combined and for new code, only one is +* necessary. +* +* This file defines the macros needed to write C functions that are +* designed to be called from FORTRAN programs, and to do so in a +* portable way. Arguments are normally passed by reference from a +* FORTRAN program, and so the F77 macros arrange for a pointer to +* all arguments to be available. This requires no work on most +* machines, but will actually generate the pointers on a machine +* that passes FORTRAN arguments by value. + +* Notes: +* - Macros are provided to handle the conversion of logical data +* values between the way that FORTRAN represents a value and the +* way that C represents it. +* - Macros are provided to convert variables between the FORTRAN and +* C method of representing them. In most cases there is no +* conversion required, the macros just arrange for a pointer to +* the FORTRAN variable to be set appropriately. The possibility that +* FORTRAN and C might use different ways of representing integer +* and floating point values is considered remote, the macros are +* really only there for completeness and to assist in the automatic +* generation of C interfaces. +* - For character variables the macros convert between +* the FORTRAN method of representing them (fixed length, blank +* filled strings) and the C method (variable length, null +* terminated strings) using calls to the CNF functions. + +* Implementation Deficiencies: +* - The macros support the K&R style of function definition, but +* this file may not work with all K&R compilers as it contains +* "#if defined" statements. These could be replaced with #ifdef's +* if necessary. This has not been done as is would make the code +* less clear and the need for support for K&R sytle definitions +* should disappear as ANSI compilers become the default. + +* Copyright: +* Copyright (C) 1991, 1993 Science & Engineering Research Council. +* Copyright (C) 2006 Particle Physics and Astronomy Research Council. +* Copyright (C) 2011 Science and Technology Facilities Council. +* All Rights Reserved. + +* Licence: +* This program is free software; you can redistribute it and/or +* modify it under the terms of the GNU General Public License as +* published by the Free Software Foundation; either version 2 of +* the License, or (at your option) any later version. +* +* This program is distributed in the hope that it will be +* useful,but WITHOUT ANY WARRANTY; without even the implied +* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +* PURPOSE. See the GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program; if not, write to the Free Software +* Foundation, Inc., 51 Franklin Street,Fifth Floor, Boston, MA +* 02110-1301, USA + +* Authors: +* PMA: Peter Allan (Starlink, RAL) +* AJC: Alan Chipperfield (Starlink, RAL) +* DSB: David S Berry (JAC) +* PWD: Peter W. Draper (JAC, Durham University) +* {enter_new_authors_here} + +* History: +* 13-JUN-2006 (DSB): +* Original version, copied from AST. +* 22-JUN-2006 (PWD): +* Updated to include changes that handle the return type of +* REAL functions (double, not float, on some platforms). +* 13-JUL-2007 (PWD): +* Parameterise the type used for Fortran string lengths. +* 11-MAY-2011 (DSB): +* Added F77_LOCK +* {enter_further_changes_here} +* + +* Bugs: +* {note_any_bugs_here} + +*- +------------------------------------------------------------------------------ +*/ +#if !defined(CNF_MACROS) +#define CNF_MACROS + +#include +/* This initial sections defines values for all macros. These are the */ +/* values that are generally appropriate to an ANSI C compiler on Unix. */ +/* For macros that have different values on other systems, the macros */ +/* should be undefined and then redefined in the system specific sections. */ +/* At the end of this section, some macros are redefined if the compiler */ +/* is non-ANSI. */ + + +#if defined(__STDC__) || defined(VMS) +#define CNF_CONST const +#else +#define CNF_CONST +#endif + +/* ----- Macros common to calling C from FORTRAN and FORTRAN from C ---- */ + + +/* --- External Names --- */ + +/* Macro to define the name of a Fortran routine or common block. This */ +/* ends in an underscore on many Unix systems. */ + +#define F77_EXTERNAL_NAME(X) X ## _ + + +/* --- Logical Values --- */ + +/* Define the values that are used to represent the logical values TRUE */ +/* and FALSE in Fortran. */ + +#define F77_TRUE 1 +#define F77_FALSE 0 + +/* Define macros that evaluate to C logical values, given a FORTRAN */ +/* logical value. */ + +#define F77_ISTRUE(X) ( X ) +#define F77_ISFALSE(X) ( !( X ) ) + + +/* --- Common Blocks --- */ + +/* Macros used in referring to FORTRAN common blocks. */ + +#define F77_BLANK_COMMON _BLNK__ +#define F77_NAMED_COMMON(B) F77_EXTERNAL_NAME(B) + + + +/* ------------------ Calling C from FORTRAN --------------------------- */ + + +/* --- Data Types --- */ + +/* Define macros for all the Fortran data types (except COMPLEX, which is */ +/* not handled by this package). */ + +#define F77_INTEGER_TYPE int +#define F77_REAL_TYPE float +#define F77_REAL_FUNCTION_TYPE @REAL_FUNCTION_TYPE@ +#define F77_DOUBLE_TYPE double +#define F77_LOGICAL_TYPE int +#define F77_CHARACTER_TYPE char +#define F77_BYTE_TYPE signed char +#define F77_WORD_TYPE short int +#define F77_UBYTE_TYPE unsigned char +#define F77_UWORD_TYPE unsigned short int + +/* Define macros for the type of a CHARACTER and CHARACTER_ARRAY argument */ +#define F77_CHARACTER_ARG_TYPE char +#define F77_CHARACTER_ARRAY_ARG_TYPE char + +/* Define a macro to use when passing arguments that STARLINK FORTRAN */ +/* treats as a pointer. From the point of view of C, this type should be */ +/* (void *), but it is declared as type unsigned int as we actually pass */ +/* an INTEGER from the FORTRAN routine. The distinction is important for */ +/* architectures where the size of an INTEGER is not the same as the size */ +/* of a pointer. */ + +#define F77_POINTER_TYPE unsigned int + + +/* --- Subroutine Names --- */ + +/* This declares that the C function returns a value of void. */ + +#define F77_SUBROUTINE(X) void F77_EXTERNAL_NAME(X) + + +/* --- Function Names --- */ + +/* Macros to define the types and names of functions that return values. */ +/* Due the the different ways that function return values could be */ +/* implemented, it is better not to use functions, but to stick to using */ +/* subroutines. */ + +/* Character functions are implemented, but in a way that cannot be */ +/* guaranteed to be portable although it will work on VMS, SunOS, Ultrix */ +/* and DEC OSF/1. It would be better to return the character value as a */ +/* subroutine argument where possible, rather than use a character */ +/* function. */ + +#define F77_INTEGER_FUNCTION(X) F77_INTEGER_TYPE F77_EXTERNAL_NAME(X) +#define F77_REAL_FUNCTION(X) F77_REAL_FUNCTION_TYPE F77_EXTERNAL_NAME(X) +#define F77_DOUBLE_FUNCTION(X) F77_DOUBLE_TYPE F77_EXTERNAL_NAME(X) +#define F77_LOGICAL_FUNCTION(X) F77_LOGICAL_TYPE F77_EXTERNAL_NAME(X) +#define F77_CHARACTER_FUNCTION(X) void F77_EXTERNAL_NAME(X) +#define F77_BYTE_FUNCTION(X) F77_BYTE_TYPE F77_EXTERNAL_NAME(X) +#define F77_WORD_FUNCTION(X) F77_WORD_TYPE F77_EXTERNAL_NAME(X) +#define F77_UBYTE_FUNCTION(X) F77_UBYTE_TYPE F77_EXTERNAL_NAME(X) +#define F77_UWORD_FUNCTION(X) F77_UWORD_TYPE F77_EXTERNAL_NAME(X) +#define F77_POINTER_FUNCTION(X) F77_POINTER_TYPE F77_EXTERNAL_NAME(X) + + +/* --- Character return value for a function --- */ + +#define CHARACTER_RETURN_VALUE(X) CHARACTER(X) TRAIL(X) +#define CHARACTER_RETURN_ARG(X) CHARACTER_ARG(X) TRAIL_ARG(X) + +/* --- Dummy Arguments --- */ + +/* Macros for defining subroutine arguments. All these macros take a */ +/* single argument; the name of the parameter. On most systems, a numeric */ +/* argument is passed as a pointer. */ + +#define INTEGER(X) F77_INTEGER_TYPE *CNF_CONST X +#define REAL(X) F77_REAL_TYPE *CNF_CONST X +#define DOUBLE(X) F77_DOUBLE_TYPE *CNF_CONST X +#define LOGICAL(X) F77_LOGICAL_TYPE *CNF_CONST X +#define BYTE(X) F77_BYTE_TYPE *CNF_CONST X +#define WORD(X) F77_WORD_TYPE *CNF_CONST X +#define UBYTE(X) F77_UBYTE_TYPE *CNF_CONST X +#define UWORD(X) F77_UWORD_TYPE *CNF_CONST X + +/* Pointer arguments. Define a pointer type for passing pointer values */ +/* between subroutines. */ + +#define POINTER(X) F77_POINTER_TYPE *CNF_CONST X + +/* EXTERNAL arguments. Define a passed subroutine or function name */ +#define SUBROUTINE(X) void (*X)() +#define INTEGER_FUNCTION(X) F77_INTEGER_TYPE (*X)() +#define REAL_FUNCTION(X) F77_REAL_TYPE (*X)() +#define DOUBLE_FUNCTION(X) F77_DOUBLE_TYPE (*X)() +#define LOGICAL_FUNCTION(X) F77_LOGICAL_TYPE (*X)() +#define CHARACTER_FUNCTION(X) F77_CHARACTER_TYPE (*X)() +#define BYTE_FUNCTION(X) F77_BYTE_TYPE (*X)() +#define WORD_FUNCTION(X) F77_WORD_TYPE (*X)() +#define UBYTE_FUNCTION(X) F77_UBYTE_TYPE (*X)() +#define UWORD_FUNCTION(X) F77_UWORD_TYPE (*X)() +#define POINTER_FUNCTION(X) F77_POINTER_TYPE (*X)() + +/* Array arguments. */ + +#define INTEGER_ARRAY(X) F77_INTEGER_TYPE *CNF_CONST X +#define REAL_ARRAY(X) F77_REAL_TYPE *CNF_CONST X +#define DOUBLE_ARRAY(X) F77_DOUBLE_TYPE *CNF_CONST X +#define LOGICAL_ARRAY(X) F77_LOGICAL_TYPE *CNF_CONST X +#define BYTE_ARRAY(X) F77_BYTE_TYPE *CNF_CONST X +#define WORD_ARRAY(X) F77_WORD_TYPE *CNF_CONST X +#define UBYTE_ARRAY(X) F77_UBYTE_TYPE *CNF_CONST X +#define UWORD_ARRAY(X) F77_UWORD_TYPE *CNF_CONST X + +#define POINTER_ARRAY(X) F77_POINTER_TYPE *CNF_CONST X + +/* Macros to handle character arguments. */ + +/* Character arguments can be passed in many ways. The purpose of these */ +/* macros and the GENPTR_CHARACTER macro (defined in the next section) is */ +/* to generate a pointer to a character variable called ARG and an integer */ +/* ARG_length containing the length of ARG. If these two variables are */ +/* available directly from the argument list of the routine, then the */ +/* GENPTR_CHARACTER macro is null, otherwise it works on intermediate */ +/* variables. */ + +#define CHARACTER(X) F77_CHARACTER_TYPE *CNF_CONST X +#define TRAIL(X) ,@TRAIL_TYPE@ X ## _length +#define CHARACTER_ARRAY(X) F77_CHARACTER_TYPE *CNF_CONST X + + +/* --- Getting Pointers to Arguments --- */ + +/* Macros that ensure that a pointer to each argument is available for the */ +/* programmer to use. Usually this means that these macros are null. On */ +/* VMS, a pointer to a character variable has to be generated. If a */ +/* particular machine were to pass arguments by reference, rather than by */ +/* value, then these macros would construct the appropriate pointers. */ + +#define GENPTR_INTEGER(X) +#define GENPTR_REAL(X) +#define GENPTR_DOUBLE(X) +#define GENPTR_CHARACTER(X) +#define GENPTR_LOGICAL(X) +#define GENPTR_BYTE(X) +#define GENPTR_WORD(X) +#define GENPTR_UBYTE(X) +#define GENPTR_UWORD(X) +#define GENPTR_POINTER(X) + +#define GENPTR_INTEGER_ARRAY(X) +#define GENPTR_REAL_ARRAY(X) +#define GENPTR_DOUBLE_ARRAY(X) +#define GENPTR_CHARACTER_ARRAY(X) +#define GENPTR_LOGICAL_ARRAY(X) +#define GENPTR_BYTE_ARRAY(X) +#define GENPTR_WORD_ARRAY(X) +#define GENPTR_UBYTE_ARRAY(X) +#define GENPTR_UWORD_ARRAY(X) +#define GENPTR_POINTER_ARRAY(X) + +#define GENPTR_SUBROUTINE(X) +#define GENPTR_INTEGER_FUNCTION(X) +#define GENPTR_REAL_FUNCTION(X) +#define GENPTR_DOUBLE_FUNCTION(X) +#define GENPTR_CHARACTER_FUNCTION(X) +#define GENPTR_LOGICAL_FUNCTION(X) +#define GENPTR_BYTE_FUNCTION(X) +#define GENPTR_WORD_FUNCTION(X) +#define GENPTR_UBYTE_FUNCTION(X) +#define GENPTR_UWORD_FUNCTION(X) +#define GENPTR_POINTER_FUNCTION(X) + + + +/* ------------------ Calling FORTRAN from C --------------------------- */ + + +/* --- Declare variables --- */ + +#define DECLARE_INTEGER(X) F77_INTEGER_TYPE X +#define DECLARE_REAL(X) F77_REAL_TYPE X +#define DECLARE_DOUBLE(X) F77_DOUBLE_TYPE X +#define DECLARE_LOGICAL(X) F77_LOGICAL_TYPE X +#define DECLARE_BYTE(X) F77_BYTE_TYPE X +#define DECLARE_WORD(X) F77_WORD_TYPE X +#define DECLARE_UBYTE(X) F77_UBYTE_TYPE X +#define DECLARE_UWORD(X) F77_UWORD_TYPE X + +#define DECLARE_POINTER(X) F77_POINTER_TYPE X + +#define DECLARE_CHARACTER(X,L) F77_CHARACTER_TYPE X[L]; \ + const int X##_length = L + + +/* --- Declare arrays --- */ + +#define DECLARE_INTEGER_ARRAY(X,D) F77_INTEGER_TYPE X[D] +#define DECLARE_REAL_ARRAY(X,D) F77_REAL_TYPE X[D] +#define DECLARE_DOUBLE_ARRAY(X,D) F77_DOUBLE_TYPE X[D] +#define DECLARE_LOGICAL_ARRAY(X,D) F77_LOGICAL_TYPE X[D] +#define DECLARE_BYTE_ARRAY(X,D) F77_BYTE_TYPE X[D] +#define DECLARE_WORD_ARRAY(X,D) F77_WORD_TYPE X[D] +#define DECLARE_UBYTE_ARRAY(X,D) F77_UBYTE_TYPE X[D] +#define DECLARE_UWORD_ARRAY(X,D) F77_UWORD_TYPE X[D] +#define DECLARE_POINTER_ARRAY(X,D) F77_POINTER_TYPE X[D] +#define DECLARE_CHARACTER_ARRAY(X,L,D) F77_CHARACTER_TYPE X[D][L]; \ + const int X##_length = L + +/* --- Declare and construct dynamic CHARACTER arguments --- */ +#define DECLARE_CHARACTER_DYN(X) F77_CHARACTER_TYPE *X;\ + int X##_length +#define F77_CREATE_CHARACTER(X,L) X=slaStringCreate(L);\ + X##_length = (L>0?L:1) + +/* Declare Dynamic Fortran arrays */ +#define DECLARE_INTEGER_ARRAY_DYN(X) F77_INTEGER_TYPE *X +#define DECLARE_REAL_ARRAY_DYN(X) F77_REAL_TYPE *X +#define DECLARE_DOUBLE_ARRAY_DYN(X) F77_DOUBLE_TYPE *X +#define DECLARE_LOGICAL_ARRAY_DYN(X) F77_LOGICAL_TYPE *X +#define DECLARE_BYTE_ARRAY_DYN(X) F77_BYTE_TYPE *X +#define DECLARE_WORD_ARRAY_DYN(X) F77_WORD_TYPE *X +#define DECLARE_UBYTE_ARRAY_DYN(X) F77_UBYTE_TYPE *X +#define DECLARE_UWORD_ARRAY_DYN(X) F77_UWORD_TYPE *X +#define DECLARE_POINTER_ARRAY_DYN(X) F77_POINTER_TYPE *X +#define DECLARE_CHARACTER_ARRAY_DYN(X) F77_CHARACTER_TYPE *X;\ + int X##_length + +/* Create arrays dynamic Fortran arrays for those types which require */ +/* Separate space for Fortran and C arrays */ +/* Character and logical are already defined */ +/* For most types there is nothing to do */ +#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ + {int f77dims[1];f77dims[0]=N;X=cnfCrefa(L,1,f77dims);X##_length=L;} +#define F77_CREATE_CHARACTER_ARRAY_M(X,L,N,D) X=cnfCrefa(L,N,D);\ + X##_length = L +#define F77_CREATE_LOGICAL_ARRAY(X,N) \ + {int f77dims[1];f77dims[0]=N;X=cnfCrela(1,f77dims);} +#define F77_CREATE_LOGICAL_ARRAY_M(X,N,D) X=cnfCrela(N,D) +#define F77_CREATE_INTEGER_ARRAY(X,N) +#define F77_CREATE_REAL_ARRAY(X,N) +#define F77_CREATE_DOUBLE_ARRAY(X,N) +#define F77_CREATE_BYTE_ARRAY(X,N) +#define F77_CREATE_UBYTE_ARRAY(X,N) +#define F77_CREATE_WORD_ARRAY(X,N) +#define F77_CREATE_UWORD_ARRAY(X,N) +#define F77_CREATE_POINTER_ARRAY(X,N)\ + X=(F77_POINTER_TYPE *) malloc(N*sizeof(F77_POINTER_TYPE)) + +/* Associate Fortran arrays with C arrays */ +/* These macros ensure that there is space somewhere for the Fortran */ +/* array. They are complemetary to the CREATE_type_ARRAY macros */ +#define F77_ASSOC_CHARACTER_ARRAY(F,C) +#define F77_ASSOC_LOGICAL_ARRAY(F,C) +#define F77_ASSOC_INTEGER_ARRAY(F,C) F=C +#define F77_ASSOC_REAL_ARRAY(F,C) F=C +#define F77_ASSOC_DOUBLE_ARRAY(F,C) F=C +#define F77_ASSOC_BYTE_ARRAY(F,C) F=C +#define F77_ASSOC_UBYTE_ARRAY(F,C) F=C +#define F77_ASSOC_WORD_ARRAY(F,C) F=C +#define F77_ASSOC_UWORD_ARRAY(F,C) F=C +#define F77_ASSOC_POINTER_ARRAY(F,C) + +/* Free created dynamic arrays */ +/* Character and logical are already defined */ +/* For most types there is nothing to do */ +#define F77_FREE_INTEGER(X) +#define F77_FREE_REAL(X) +#define F77_FREE_DOUBLE(X) +#define F77_FREE_BYTE(X) +#define F77_FREE_UBYTE(X) +#define F77_FREE_WORD(X) +#define F77_FREE_UWORD(X) +#define F77_FREE_POINTER(X) cnfFree((void *)X); +#define F77_FREE_CHARACTER(X) slaStringFree( X ) +#define F77_FREE_LOGICAL(X) cnfFree( (char *)X ) + +/* --- IMPORT and EXPORT of values --- */ +/* Export C variables to Fortran variables */ +#define F77_EXPORT_CHARACTER(C,F,L) slaStringExport(C,F,L) +#define F77_EXPORT_DOUBLE(C,F) F=C +#define F77_EXPORT_INTEGER(C,F) F=C +#define F77_EXPORT_LOGICAL(C,F) F=C?F77_TRUE:F77_FALSE +#define F77_EXPORT_REAL(C,F) F=C +#define F77_EXPORT_BYTE(C,F) F=C +#define F77_EXPORT_WORD(C,F) F=C +#define F77_EXPORT_UBYTE(C,F) F=C +#define F77_EXPORT_UWORD(C,F) F=C +#define F77_EXPORT_POINTER(C,F) F=cnfFptr(C) +#define F77_EXPORT_LOCATOR(C,F) cnfExpch(C,F,DAT__SZLOC) + +/* Allow for character strings to be NULL, protects strlen. Note this + * does not allow lengths to differ. */ +#define F77_CREATE_EXPORT_CHARACTER(C,F) \ + if (C) { \ + F77_CREATE_CHARACTER(F,strlen(C)); \ + F77_EXPORT_CHARACTER(C,F,F##_length); \ + } else { \ + F77_CREATE_CHARACTER(F,1); \ + F77_EXPORT_CHARACTER(" ",F,F##_length); \ + } + + +/* Export C arrays to Fortran */ +/* Arrays are assumed to be 1-d so just the number of elements is given */ +/* This may be OK for n-d arrays also */ +/* CHARACTER arrays may be represented in C as arrays of arrays of char or */ +/* as arrays of pointers to char (the _P variant) */ +#define F77_EXPORT_CHARACTER_ARRAY(C,LC,F,LF,N) \ + {int f77dims[1];f77dims[0]=N;cnfExprta(C,LC,F,LF,1,f77dims);} +#define F77_EXPORT_CHARACTER_ARRAY_P(C,F,LF,N) \ + {int f77dims[1];f77dims[0]=N;cnfExprtap(C,F,LF,1,f77dims);} +#define F77_EXPORT_DOUBLE_ARRAY(C,F,N) F=(F77_DOUBLE_TYPE *)C +#define F77_EXPORT_INTEGER_ARRAY(C,F,N) F=(F77_INTEGER_TYPE *)C +#define F77_EXPORT_LOGICAL_ARRAY(C,F,N) \ + {int f77dims[1];f77dims[0]=N;cnfExpla(C,F,1,f77dims);} +#define F77_EXPORT_REAL_ARRAY(C,F,N) F=(F77_REAL_TYPE *)C +#define F77_EXPORT_BYTE_ARRAY(C,F,N) F=(F77_BYTE_TYPE *)C +#define F77_EXPORT_WORD_ARRAY(C,F,N) F=(F77_WORD_TYPE *)C +#define F77_EXPORT_UBYTE_ARRAY(C,F,N) F=(F77_UBYTE_TYPE *)C +#define F77_EXPORT_UWORD_ARRAY(C,F,N) F=(F77_UWORD_TYPE * )C +#define F77_EXPORT_POINTER_ARRAY(C,F,N) \ + {int f77i;for (f77i=0;f77i + +#if USE_CNF +#define F77_LOCK(code) \ + cnfLock(); \ + code \ + cnfUnlock(); +#else +#define F77_LOCK(code) code +#endif + +/* --- Pass arguments to a FORTRAN routine --- */ + +#define INTEGER_ARG(X) X +#define REAL_ARG(X) X +#define DOUBLE_ARG(X) X +#define LOGICAL_ARG(X) X +#define BYTE_ARG(X) X +#define WORD_ARG(X) X +#define UBYTE_ARG(X) X +#define UWORD_ARG(X) X +#define POINTER_ARG(X) X +#define CHARACTER_ARG(X) X +#define TRAIL_ARG(X) ,X##_length + +#define SUBROUTINE_ARG(X) X +#define INTEGER_FUNCTION_ARG(X) X +#define REAL_FUNCTION_ARG(X) X +#define DOUBLE_FUNCTION_ARG(X) X +#define LOGICAL_FUNCTION_ARG(X) X +#define CHARACTER_FUNCTION_ARG(X) X +#define BYTE_FUNCTION_ARG(X) X +#define WORD_FUNCTION_ARG(X) X +#define UBYTE_FUNCTION_ARG(X) X +#define UWORD_FUNCTION_ARG(X) X +#define POINTER_FUNCTION_ARG(X) X + +#define INTEGER_ARRAY_ARG(X) (F77_INTEGER_TYPE *)X +#define REAL_ARRAY_ARG(X) (F77_REAL_TYPE *)X +#define DOUBLE_ARRAY_ARG(X) (F77_DOUBLE_TYPE *)X +#define LOGICAL_ARRAY_ARG(X) (F77_LOGICAL_TYPE *)X +#define BYTE_ARRAY_ARG(X) (F77_BYTE_TYPE *)X +#define WORD_ARRAY_ARG(X) (F77_WORD_TYPE *)X +#define UBYTE_ARRAY_ARG(X) (F77_UBYTE_TYPE *)X +#define UWORD_ARRAY_ARG(X) (F77_UWORD_TYPE *)X +#define POINTER_ARRAY_ARG(X) (F77_POINTER_TYPE *)X +#define CHARACTER_ARRAY_ARG(X) (F77_CHARACTER_ARRAY_ARG_TYPE *)X + + +/* ------------------------ Non-ansi section ------------------------------ */ + +/* The difference between ANSI and non-ANSI compilers, as far as macro */ +/* definition is concerned, is that non-ANSI compilers do not support the */ +/* token concatenation operator (##). To work around this, we use the fact */ +/* that the null comment is preprocessed to produce no characters at all */ +/* by our non-ANSI compilers. */ +/* This section does not deal with the fact that some non-ANSI compilers */ +/* cannot handle function prototypes. That is handled in the machine */ +/* specific sections. */ + +#if !defined(__STDC__) + +/* --- External Name --- */ + +/* Macro to define the name of a Fortran routine or common block. This */ +/* ends in an underscore on many Unix systems. */ + +#undef F77_EXTERNAL_NAME +#define F77_EXTERNAL_NAME(X) X/**/_ + + +/* --- Dummy Arguments --- */ + +/* Macros to handle character dummy arguments. */ + +#undef TRAIL +#define TRAIL(X) ,@TRAIL_TYPE@ X/**/_length + + +/* --- Declare variables --- */ + +#undef DECLARE_CHARACTER +#define DECLARE_CHARACTER(X,L) F77_CHARACTER_TYPE X[L]; \ + const int X/**/_length = L +#undef DECLARE_CHARACTER_ARRAY +#define DECLARE_CHARACTER_ARRAY(X,L,D) F77_CHARACTER_TYPE X[D][L]; \ + const int X/**/_length = L +#undef DECLARE_CHARACTER_DYN +#define DECLARE_CHARACTER_DYN(X) F77_CHARACTER_TYPE *X;\ + int X/**/_length +#undef DECLARE_CHARACTER_ARRAY_DYN +#define DECLARE_CHARACTER_ARRAY_DYN(X) F77_CHARACTER_TYPE *X;\ + int X/**/_length +#undef F77_CREATE_CHARACTER +#define F77_CREATE_CHARACTER(X,L) X=cnfCref(L);\ + X/**/_length = L +#undef F77_CREATE_CHARACTER_ARRAY +#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ + {int f77dims[1];f77dims[0]=N;X=cnfCrefa(L,1,f77dims);X/**/_length=L;} + +/* --- Pass arguments to a FORTRAN routine --- */ + +#undef TRAIL_ARG +#define TRAIL_ARG(X) ,X/**/_length + + +#endif /* of non ANSI redefinitions */ + + +/* ----------------------------------------------------------------------- */ + +/* The standard macros defined above are known to work with the following */ +/* systems: */ + +/*-------- +| Sun | +---------*/ + +/* On SunOS, the ANSI definitions work with the acc and gcc compilers. */ +/* The cc compiler uses the non ANSI definitions. It also needs the K&R */ +/* definitions in the file kr.h. */ +/* On Solaris, the standard definitions work with the cc compiler. */ + +#if defined(sun) + +#if !defined(__STDC__) +#if !defined(_F77_KR) +#define _F77_KR +#endif +#endif + +#endif /* Sun */ + +/* -------------------- System dependent sections ------------------------- */ + +/*------------ +| VAX/VMS | +-------------*/ + +/* Many macros need to be changed due to the way that VMS handles external */ +/* names, passes character arguments and handles logical values. */ + + +#if defined(VMS) + +/* --- Data Types --- */ + +/* Redefine the macro for the byte data type as signed is not valid syntax */ +/* as the VMS compiler is not ANSI compliant. */ + +#undef F77_BYTE_TYPE +#define F77_BYTE_TYPE char + + +/* --- External Names --- */ + +/* Macro to define the name of a Fortran routine or common block. */ +/* Fortran and C routines names are the same on VMS. */ + +#undef F77_EXTERNAL_NAME +#define F77_EXTERNAL_NAME(X) X + + +/* --- Dummy Arguments --- */ + +/* Macros to handle character arguments. */ +/* Character string arguments are pointers to character string descriptors */ +/* and there are no trailing arguments. */ + +#if( VMS != 0 ) +#include +#endif + + +#undef F77_CHARACTER_ARG_TYPE +#define F77_CHARACTER_ARG_TYPE struct dsc$descriptor_s +#undef F77_CHARACTER_ARRAY_ARG_TYPE +#define F77_CHARACTER_ARRAY_ARG_TYPE struct dsc$descriptor_a +#undef CHARACTER +#define CHARACTER(X) F77_CHARACTER_ARG_TYPE *CNF_CONST X/**/_arg +#undef TRAIL +#define TRAIL(X) +#undef CHARACTER_ARRAY +#define CHARACTER_ARRAY(X) F77_CHARACTER_ARRAY_ARG_TYPE *CNF_CONST X/**/_arg +#undef GENPTR_CHARACTER +#define GENPTR_CHARACTER(X) \ + F77_CHARACTER_TYPE *X = X/**/_arg->dsc$a_pointer; \ + int X/**/_length = X/**/_arg->dsc$w_length; +#undef GENPTR_CHARACTER_ARRAY +#define GENPTR_CHARACTER_ARRAY(X) GENPTR_CHARACTER(X) + + +/* --- Logical Values --- */ + +#undef F77_TRUE +#define F77_TRUE -1 +#undef F77_ISTRUE +#define F77_ISTRUE(X) ( (X)&1 ) +#undef F77_ISFALSE +#define F77_ISFALSE(X) ( ! ( (X)&1 ) ) + + +/* --- Common Blocks --- */ + +#undef F77_BLANK_COMMON +#define F77_BLANK_COMMON $BLANK + + +/* --- Declare Variables --- */ + +#undef DECLARE_CHARACTER +#define DECLARE_CHARACTER(X,L) \ + F77_CHARACTER_TYPE X[L]; const int X/**/_length = L; \ + F77_CHARACTER_ARG_TYPE X/**/_descr = \ + { L, DSC$K_DTYPE_T, DSC$K_CLASS_S, X }; \ + F77_CHARACTER_ARG_TYPE *X/**/_arg = &X/**/_descr +#undef DECLARE_CHARACTER_ARRAY +#define DECLARE_CHARACTER_ARRAY(X,L,D) \ + F77_CHARACTER_TYPE X[D][L]; const int X/**/_length = L; \ + F77_CHARACTER_ARRAY_ARG_TYPE X/**/_descr = \ + { L, DSC$K_DTYPE_T, DSC$K_CLASS_S, X }; \ + F77_CHARACTER_ARRAY_ARG_TYPE *X/**/_arg = &X/**/_descr + + +/* --- The dynamic allocation of character arguments --- */ +#undef DECLARE_CHARACTER_DYN +#define DECLARE_CHARACTER_DYN(X) int X/**/_length;\ + F77_CHARACTER_ARG_TYPE *X/**/_arg;\ + F77_CHARACTER_TYPE *X +#undef DECLARE_CHARACTER_ARRAY_DYN +#define DECLARE_CHARACTER_ARRAY_DYN(X) int X/**/_length;\ + F77_CHARACTER_ARRAY_ARG_TYPE *X/**/_arg;\ + F77_CHARACTER_TYPE *X +#undef F77_CREATE_CHARACTER +#define F77_CREATE_CHARACTER(X,L) X/**/_arg = cnfCref(L);\ + X = X/**/_arg->dsc$a_pointer; \ + X/**/_length = X/**/_arg->dsc$w_length +#undef F77_CREATE_CHARACTER_ARRAY +#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ + {int f77dims[1];f77dims[0]=N;X/**/_arg=cnfCrefa(L,1,f77dims);X/**/_length=L;} +#define F77_CREATE_CHARACTER_ARRAY_M(X,L,N,D) X/**/_arg = cnfCrefa(L,N,D);\ + X = X/**/_arg->dsc$a_pointer; \ + X/**/_length = X/**/_arg->dsc$w_length +#undef F77_FREE_CHARACTER +#define F77_FREE_CHARACTER(X) slaStringFree( X/**/_arg ) + +/* --- Pass arguments to a FORTRAN routine --- */ + +#undef CHARACTER_ARG +#define CHARACTER_ARG(X) X/**/_arg +#undef CHARACTER_ARRAY_ARG +#define CHARACTER_ARRAY_ARG(X) X/**/_arg +#undef TRAIL_ARG +#define TRAIL_ARG(X) + +#endif /* VMS */ + +/* ----------------------------------------------------------------------- */ + +/*-------------------------- +| DECstation Ultrix (cc) | +| DECstation Ultrix (c89) | +| DECstation OSF/1 | +| Alpha OSF/1 | + --------------------------*/ + +/* Do this complicated set of definitions as a single #if cannot be */ +/* continued across multiple lines. */ + +#if defined(mips) && defined(ultrix) +#define _dec_unix 1 +#endif +#if defined(__mips) && defined(__ultrix) +#define _dec_unix 1 +#endif +#if defined(__mips__) && defined(__osf__) +#define _dec_unix 1 +#endif +#if defined(__alpha) && defined(__osf__) +#define _dec_unix 1 +#endif + +#if _dec_unix + +/* The macros for Ultrix are the same as the standard ones except for ones */ +/* dealing with logical values. The ANSI definitions work with the c89 */ +/* compiler, and the non ANSI definitions work with the cc compiler. */ +/* The same applies to DEC OSF/1, except that its cc compiler is ANSI */ +/* compliant. */ + + +/* --- Logical Values --- */ + +/* Redefine macros that evaluate to a C logical value, given a FORTRAN */ +/* logical value. These definitions are only valid when used with the DEC */ +/* FORTRAN for RISC compiler. If you are using the earlier FORTRAN for */ +/* RISC compiler from MIPS, then these macros should be deleted. */ + +#undef F77_TRUE +#define F77_TRUE -1 +#undef F77_ISTRUE +#define F77_ISTRUE(X) ( (X)&1 ) +#undef F77_ISFALSE +#define F77_ISFALSE(X) ( ! ( (X)&1 ) ) + + +#endif /* DEC Unix */ + +/* +*+ +* Name: +* cnf.h + +* Purpose: +* Function prototypes for cnf routines + +* Language: +* ANSI C + +* Type of Module: +* C include file + +* Description: +* These are the prototype definitions for the functions in the CNF +* library. They are used used in mixing C and FORTRAN programs. + +* Copyright: +* Copyright (C) 1991 Science & Engineering Research Council + +* Authors: +* PMA: Peter Allan (Starlink, RAL) +* AJC: Alan Chipperfield (Starlink, RAL) +* {enter_new_authors_here} + +* History: +* 23-MAY-1991 (PMA): +* Original version. +* 12-JAN-1996 (AJC): +* Add cnf_cref and cnf_freef +* 14-JUN-1996 (AJC): +* Add cnf_crefa, imprta, exprta +* crela, impla, expla +* 18-JUL-1996 (AJC): +* Add impch and expch +* 17-MAR-1998 (AJC): +* Add imprtap and exprtap +* {enter_changes_here} + +* Bugs: +* {note_any_bugs_here} + +*- +------------------------------------------------------------------------------ +*/ +void *cnfCalloc( size_t, size_t ); +void cnfCopyf( const char *source_f, int source_len, char *dest_f, + int dest_len ); +void *cnfCptr( F77_POINTER_TYPE ); +char *cnfCreat( int length ); +F77_CHARACTER_ARG_TYPE *cnfCref( int length ); +F77_CHARACTER_ARG_TYPE *cnfCrefa( int length, int ndims, const int *dims ); +char *cnfCreib( const char *source_f, int source_len ); +char *cnfCreim( const char *source_f, int source_len ); +F77_LOGICAL_TYPE *cnfCrela( int ndims, const int *dims ); +void cnfExpch( const char *source_c, char *dest_f, int nchars ); +void cnfExpla( const int *source_c, F77_LOGICAL_TYPE *dest_f, int ndims, + const int *dims ); +void cnfExpn( const char *source_c, int max, char *dest_f, int dest_len ); +void cnfExprt( const char *source_c, char *dest_f, int dest_len ); +void cnfExprta( const char *source_c, int source_len, char *dest_f, + int dest_len, int ndims, const int *dims ); +void cnfExprtap( char *const *source_c, char *dest_f, int dest_len, + int ndims, const int *dims ); +F77_POINTER_TYPE cnfFptr( void *cpointer ); +void cnfFree( void * ); +void cnfFreef( F77_CHARACTER_ARG_TYPE *temp ); +void cnfImpb( const char *source_f, int source_len, char *dest_c ); +void cnfImpbn( const char *source_f, int source_len, int max, char *dest_c ); +void cnfImpch( const char *source_f, int nchars, char *dest_c ); +void cnfImpla( const F77_LOGICAL_TYPE *source_f, int *dest_c, + int ndims, const int *dims ); +void cnfImpn( const char *source_f, int source_len, int max, char *dest_c ); +void cnfImprt( const char *source_f, int source_len, char *dest_c ); +void cnfImprta( const char *source_f, int source_len, char *dest_c, + int dest_len, int ndims, const int *dims ); +void cnfImprtap( const char *source_f, int source_len, char *const *dest_c, + int dest_len, int ndims, const int *dims ); +int cnfLenc( const char *source_c ); +int cnfLenf( const char *source_f, int source_len ); +void *cnfMalloc( size_t ); +int cnfRegp( void * ); +void cnfUregp( void * ); +void cnfLock( void ); +void cnfUnlock( void ); +#endif + +#ifndef CNF_OLD_DEFINED +#define CNF_OLD_DEFINED +/* Define old names to be new names */ +#define cnf_calloc cnfCalloc +#define cnf_copyf cnfCopyf +#define cnf_cptr cnfCptr +#define cnf_creat cnfCreat +#define cnf_cref cnfCref +#define cnf_crefa cnfCrefa +#define cnf_creib cnfCreib +#define cnf_creim cnfCreim +#define cnf_crela cnfCrela +#define cnf_expch cnfExpch +#define cnf_expla cnfExpla +#define cnf_expn cnfExpn +#define cnf_exprt cnfExprt +#define cnf_exprta cnfExprta +#define cnf_exprtap cnfExprtap +#define cnf_fptr cnfFptr +#define cnf_free cnfFree +#define cnf_freef cnfFreef +#define cnf_impb cnfImpb +#define cnf_impbn cnfImpbn +#define cnf_impch cnfImpch +#define cnf_impla cnfImpla +#define cnf_impn cnfImpn +#define cnf_imprt cnfImprt +#define cnf_imprta cnfImprta +#define cnf_imprtap cnfImprtap +#define cnf_lenc cnfLenc +#define cnf_lenf cnfLenf +#define cnf_malloc cnfMalloc +#define cnf_regp cnfRegp +#define cnf_uregp cnfUregp + +#endif diff --git a/math/slalib/fitxy.f b/math/slalib/fitxy.f new file mode 100644 index 00000000..5060510e --- /dev/null +++ b/math/slalib/fitxy.f @@ -0,0 +1,329 @@ + SUBROUTINE slFTXY (ITYPE,NP,XYE,XYM,COEFFS,J) +*+ +* - - - - - - +* F T X Y +* - - - - - - +* +* Fit a linear model to relate two sets of [X,Y] coordinates. +* +* Given: +* ITYPE i type of model: 4 or 6 (note 1) +* NP i number of samples (note 2) +* XYE d(2,np) expected [X,Y] for each sample +* XYM d(2,np) measured [X,Y] for each sample +* +* Returned: +* COEFFS d(6) coefficients of model (note 3) +* J i status: 0 = OK +* -1 = illegal ITYPE +* -2 = insufficient data +* -3 = no solution +* +* Notes: +* +* 1) ITYPE, which must be either 4 or 6, selects the type of model +* fitted. Both allowed ITYPE values produce a model COEFFS which +* consists of six coefficients, namely the zero points and, for +* each of XE and YE, the coefficient of XM and YM. For ITYPE=6, +* all six coefficients are independent, modelling squash and shear +* as well as origin, scale, and orientation. However, ITYPE=4 +* selects the "solid body rotation" option; the model COEFFS +* still consists of the same six coefficients, but now two of +* them are used twice (appropriately signed). Origin, scale +* and orientation are still modelled, but not squash or shear - +* the units of X and Y have to be the same. +* +* 2) For NC=4, NP must be at least 2. For NC=6, NP must be at +* least 3. +* +* 3) The model is returned in the array COEFFS. Naming the +* elements of COEFFS as follows: +* +* COEFFS(1) = A +* COEFFS(2) = B +* COEFFS(3) = C +* COEFFS(4) = D +* COEFFS(5) = E +* COEFFS(6) = F +* +* the model is: +* +* XE = A + B*XM + C*YM +* YE = D + E*XM + F*YM +* +* For the "solid body rotation" option (ITYPE=4), the +* magnitudes of B and F, and of C and E, are equal. The +* signs of these coefficients depend on whether there is a +* sign reversal between XE,YE and XM,YM; fits are performed +* with and without a sign reversal and the best one chosen. +* +* 4) Error status values J=-1 and -2 leave COEFFS unchanged; +* if J=-3 COEFFS may have been changed. +* +* See also slPXY, slINVF, slXYXY, slDCMF +* +* Called: slDMAT, slDMXV +* +* Last revision: 8 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER ITYPE,NP + DOUBLE PRECISION XYE(2,NP),XYM(2,NP),COEFFS(6) + INTEGER J + + INTEGER I,JSTAT,IW(4),NSOL + DOUBLE PRECISION A,B,C,D,AOLD,BOLD,COLD,DOLD,SOLD, + : P,SXE,SXEXM,SXEYM,SYE,SYEYM,SYEXM,SXM, + : SYM,SXMXM,SXMYM,SYMYM,XE,YE, + : XM,YM,V(4),DM3(3,3),DM4(4,4),DET, + : SGN,SXXYY,SXYYX,SX2Y2,SDR2,XR,YR + + + +* Preset the status + J=0 + +* Variable initializations to avoid compiler warnings + A = 0D0 + B = 0D0 + C = 0D0 + D = 0D0 + AOLD = 0D0 + BOLD = 0D0 + COLD = 0D0 + DOLD = 0D0 + SOLD = 0D0 + +* Float the number of samples + P=DBLE(NP) + +* Check ITYPE + IF (ITYPE.EQ.6) THEN + +* +* Six-coefficient linear model +* ---------------------------- + +* Check enough samples + IF (NP.GE.3) THEN + +* Form summations + SXE=0D0 + SXEXM=0D0 + SXEYM=0D0 + SYE=0D0 + SYEYM=0D0 + SYEXM=0D0 + SXM=0D0 + SYM=0D0 + SXMXM=0D0 + SXMYM=0D0 + SYMYM=0D0 + DO I=1,NP + XE=XYE(1,I) + YE=XYE(2,I) + XM=XYM(1,I) + YM=XYM(2,I) + SXE=SXE+XE + SXEXM=SXEXM+XE*XM + SXEYM=SXEYM+XE*YM + SYE=SYE+YE + SYEYM=SYEYM+YE*YM + SYEXM=SYEXM+YE*XM + SXM=SXM+XM + SYM=SYM+YM + SXMXM=SXMXM+XM*XM + SXMYM=SXMYM+XM*YM + SYMYM=SYMYM+YM*YM + END DO + +* Solve for A,B,C in XE = A + B*XM + C*YM + V(1)=SXE + V(2)=SXEXM + V(3)=SXEYM + DM3(1,1)=P + DM3(1,2)=SXM + DM3(1,3)=SYM + DM3(2,1)=SXM + DM3(2,2)=SXMXM + DM3(2,3)=SXMYM + DM3(3,1)=SYM + DM3(3,2)=SXMYM + DM3(3,3)=SYMYM + CALL slDMAT(3,DM3,V,DET,JSTAT,IW) + IF (JSTAT.EQ.0) THEN + DO I=1,3 + COEFFS(I)=V(I) + END DO + +* Solve for D,E,F in YE = D + E*XM + F*YM + V(1)=SYE + V(2)=SYEXM + V(3)=SYEYM + CALL slDMXV(DM3,V,COEFFS(4)) + + ELSE + +* No 6-coefficient solution possible + J=-3 + + END IF + + ELSE + +* Insufficient data for 6-coefficient fit + J=-2 + + END IF + + ELSE IF (ITYPE.EQ.4) THEN + +* +* Four-coefficient solid body rotation model +* ------------------------------------------ + +* Check enough samples + IF (NP.GE.2) THEN + +* Try two solutions, first without then with flip in X + DO NSOL=1,2 + IF (NSOL.EQ.1) THEN + SGN=1D0 + ELSE + SGN=-1D0 + END IF + +* Form summations + SXE=0D0 + SXXYY=0D0 + SXYYX=0D0 + SYE=0D0 + SXM=0D0 + SYM=0D0 + SX2Y2=0D0 + DO I=1,NP + XE=XYE(1,I)*SGN + YE=XYE(2,I) + XM=XYM(1,I) + YM=XYM(2,I) + SXE=SXE+XE + SXXYY=SXXYY+XE*XM+YE*YM + SXYYX=SXYYX+XE*YM-YE*XM + SYE=SYE+YE + SXM=SXM+XM + SYM=SYM+YM + SX2Y2=SX2Y2+XM*XM+YM*YM + END DO + +* +* Solve for A,B,C,D in: +/- XE = A + B*XM - C*YM +* + YE = D + C*XM + B*YM + V(1)=SXE + V(2)=SXXYY + V(3)=SXYYX + V(4)=SYE + DM4(1,1)=P + DM4(1,2)=SXM + DM4(1,3)=-SYM + DM4(1,4)=0D0 + DM4(2,1)=SXM + DM4(2,2)=SX2Y2 + DM4(2,3)=0D0 + DM4(2,4)=SYM + DM4(3,1)=SYM + DM4(3,2)=0D0 + DM4(3,3)=-SX2Y2 + DM4(3,4)=-SXM + DM4(4,1)=0D0 + DM4(4,2)=SYM + DM4(4,3)=SXM + DM4(4,4)=P + CALL slDMAT(4,DM4,V,DET,JSTAT,IW) + IF (JSTAT.EQ.0) THEN + A=V(1) + B=V(2) + C=V(3) + D=V(4) + +* Determine sum of radial errors squared + SDR2=0D0 + DO I=1,NP + XM=XYM(1,I) + YM=XYM(2,I) + XR=A+B*XM-C*YM-XYE(1,I)*SGN + YR=D+C*XM+B*YM-XYE(2,I) + SDR2=SDR2+XR*XR+YR*YR + END DO + + ELSE + +* Singular: set flag + SDR2=-1D0 + + END IF + +* If first pass and non-singular, save variables + IF (NSOL.EQ.1.AND.JSTAT.EQ.0) THEN + AOLD=A + BOLD=B + COLD=C + DOLD=D + SOLD=SDR2 + END IF + + END DO + +* Pick the best of the two solutions + IF (SOLD.GE.0D0.AND.(SOLD.LE.SDR2.OR.NP.EQ.2)) THEN + COEFFS(1)=AOLD + COEFFS(2)=BOLD + COEFFS(3)=-COLD + COEFFS(4)=DOLD + COEFFS(5)=COLD + COEFFS(6)=BOLD + ELSE IF (JSTAT.EQ.0) THEN + COEFFS(1)=-A + COEFFS(2)=-B + COEFFS(3)=C + COEFFS(4)=D + COEFFS(5)=C + COEFFS(6)=B + ELSE + +* No 4-coefficient fit possible + J=-3 + END IF + ELSE + +* Insufficient data for 4-coefficient fit + J=-2 + END IF + ELSE + +* Illegal ITYPE - not 4 or 6 + J=-1 + END IF + + END diff --git a/math/slalib/fk425.f b/math/slalib/fk425.f new file mode 100644 index 00000000..40d5a615 --- /dev/null +++ b/math/slalib/fk425.f @@ -0,0 +1,267 @@ + SUBROUTINE slFK45 (R1950,D1950,DR1950,DD1950,P1950,V1950, + : R2000,D2000,DR2000,DD2000,P2000,V2000) +*+ +* - - - - - - +* F K 4 5 +* - - - - - - +* +* Convert B1950.0 FK4 star data to J2000.0 FK5 (double precision) +* +* This routine converts stars from the old, Bessel-Newcomb, FK4 +* system to the new, IAU 1976, FK5, Fricke system. The precepts +* of Smith et al (Ref 1) are followed, using the implementation +* by Yallop et al (Ref 2) of a matrix method due to Standish. +* Kinoshita's development of Andoyer's post-Newcomb precession is +* used. The numerical constants from Seidelmann et al (Ref 3) are +* used canonically. +* +* Given: (all B1950.0,FK4) +* R1950,D1950 dp B1950.0 RA,Dec (rad) +* DR1950,DD1950 dp B1950.0 proper motions (rad/trop.yr) +* P1950 dp parallax (arcsec) +* V1950 dp radial velocity (km/s, +ve = moving away) +* +* Returned: (all J2000.0,FK5) +* R2000,D2000 dp J2000.0 RA,Dec (rad) +* DR2000,DD2000 dp J2000.0 proper motions (rad/Jul.yr) +* P2000 dp parallax (arcsec) +* V2000 dp radial velocity (km/s, +ve = moving away) +* +* Notes: +* +* 1) The proper motions in RA are dRA/dt rather than +* cos(Dec)*dRA/dt, and are per year rather than per century. +* +* 2) Conversion from Besselian epoch 1950.0 to Julian epoch +* 2000.0 only is provided for. Conversions involving other +* epochs will require use of the appropriate precession, +* proper motion, and E-terms routines before and/or +* after FK425 is called. +* +* 3) In the FK4 catalogue the proper motions of stars within +* 10 degrees of the poles do not embody the differential +* E-term effect and should, strictly speaking, be handled +* in a different manner from stars outside these regions. +* However, given the general lack of homogeneity of the star +* data available for routine astrometry, the difficulties of +* handling positions that may have been determined from +* astrometric fields spanning the polar and non-polar regions, +* the likelihood that the differential E-terms effect was not +* taken into account when allowing for proper motion in past +* astrometry, and the undesirability of a discontinuity in +* the algorithm, the decision has been made in this routine to +* include the effect of differential E-terms on the proper +* motions for all stars, whether polar or not. At epoch 2000, +* and measuring on the sky rather than in terms of dRA, the +* errors resulting from this simplification are less than +* 1 milliarcsecond in position and 1 milliarcsecond per +* century in proper motion. +* +* References: +* +* 1 Smith, C.A. et al, 1989. "The transformation of astrometric +* catalog systems to the equinox J2000.0". Astron.J. 97, 265. +* +* 2 Yallop, B.D. et al, 1989. "Transformation of mean star places +* from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". +* Astron.J. 97, 274. +* +* 3 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to +* the Astronomical Almanac", ISBN 0-935702-68-7. +* +* P.T.Wallace Starlink 19 December 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R1950,D1950,DR1950,DD1950,P1950,V1950, + : R2000,D2000,DR2000,DD2000,P2000,V2000 + + +* Miscellaneous + DOUBLE PRECISION R,D,UR,UD,PX,RV,SR,CR,SD,CD,W,WD + DOUBLE PRECISION X,Y,Z,XD,YD,ZD + DOUBLE PRECISION RXYSQ,RXYZSQ,RXY,RXYZ,SPXY,SPXYZ + INTEGER I,J + +* Star position and velocity vectors + DOUBLE PRECISION R0(3),RD0(3) + +* Combined position and velocity vectors + DOUBLE PRECISION V1(6),V2(6) + +* 2Pi + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925287D0) + +* Radians per year to arcsec per century + DOUBLE PRECISION PMF + PARAMETER (PMF=100D0*60D0*60D0*360D0/D2PI) + +* Small number to avoid arithmetic problems + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-30) + + +* +* CANONICAL CONSTANTS (see references) +* + +* Km per sec to AU per tropical century +* = 86400 * 36524.2198782 / 149597870 + DOUBLE PRECISION VF + PARAMETER (VF=21.095D0) + +* Constant vector and matrix (by columns) + DOUBLE PRECISION A(3),AD(3),EM(6,6) + DATA A,AD/ -1.62557D-6, -0.31919D-6, -0.13843D-6, + : +1.245D-3, -1.580D-3, -0.659D-3/ + + DATA (EM(I,1),I=1,6) / +0.9999256782D0, + : +0.0111820610D0, + : +0.0048579479D0, + : -0.000551D0, + : +0.238514D0, + : -0.435623D0 / + + DATA (EM(I,2),I=1,6) / -0.0111820611D0, + : +0.9999374784D0, + : -0.0000271474D0, + : -0.238565D0, + : -0.002667D0, + : +0.012254D0 / + + DATA (EM(I,3),I=1,6) / -0.0048579477D0, + : -0.0000271765D0, + : +0.9999881997D0, + : +0.435739D0, + : -0.008541D0, + : +0.002117D0 / + + DATA (EM(I,4),I=1,6) / +0.00000242395018D0, + : +0.00000002710663D0, + : +0.00000001177656D0, + : +0.99994704D0, + : +0.01118251D0, + : +0.00485767D0 / + + DATA (EM(I,5),I=1,6) / -0.00000002710663D0, + : +0.00000242397878D0, + : -0.00000000006582D0, + : -0.01118251D0, + : +0.99995883D0, + : -0.00002714D0 / + + DATA (EM(I,6),I=1,6) / -0.00000001177656D0, + : -0.00000000006587D0, + : +0.00000242410173D0, + : -0.00485767D0, + : -0.00002718D0, + : +1.00000956D0 / + + + +* Pick up B1950 data (units radians and arcsec/TC) + R=R1950 + D=D1950 + UR=DR1950*PMF + UD=DD1950*PMF + PX=P1950 + RV=V1950 + +* Spherical to Cartesian + SR=SIN(R) + CR=COS(R) + SD=SIN(D) + CD=COS(D) + + R0(1)=CR*CD + R0(2)=SR*CD + R0(3)= SD + + W=VF*RV*PX + + RD0(1)=-SR*CD*UR-CR*SD*UD+W*R0(1) + RD0(2)= CR*CD*UR-SR*SD*UD+W*R0(2) + RD0(3)= CD*UD+W*R0(3) + +* Allow for e-terms and express as position+velocity 6-vector + W=R0(1)*A(1)+R0(2)*A(2)+R0(3)*A(3) + WD=R0(1)*AD(1)+R0(2)*AD(2)+R0(3)*AD(3) + DO I=1,3 + V1(I)=R0(I)-A(I)+W*R0(I) + V1(I+3)=RD0(I)-AD(I)+WD*R0(I) + END DO + +* Convert position+velocity vector to Fricke system + DO I=1,6 + W=0D0 + DO J=1,6 + W=W+EM(I,J)*V1(J) + END DO + V2(I)=W + END DO + +* Revert to spherical coordinates + X=V2(1) + Y=V2(2) + Z=V2(3) + XD=V2(4) + YD=V2(5) + ZD=V2(6) + + RXYSQ=X*X+Y*Y + RXYZSQ=RXYSQ+Z*Z + RXY=SQRT(RXYSQ) + RXYZ=SQRT(RXYZSQ) + + SPXY=X*XD+Y*YD + SPXYZ=SPXY+Z*ZD + + IF (X.EQ.0D0.AND.Y.EQ.0D0) THEN + R=0D0 + ELSE + R=ATAN2(Y,X) + IF (R.LT.0.0D0) R=R+D2PI + END IF + D=ATAN2(Z,RXY) + + IF (RXY.GT.TINY) THEN + UR=(X*YD-Y*XD)/RXYSQ + UD=(ZD*RXYSQ-Z*SPXY)/(RXYZSQ*RXY) + END IF + + IF (PX.GT.TINY) THEN + RV=SPXYZ/(PX*RXYZ*VF) + PX=PX/RXYZ + END IF + +* Return results + R2000=R + D2000=D + DR2000=UR/PMF + DD2000=UD/PMF + V2000=RV + P2000=PX + + END diff --git a/math/slalib/fk45z.f b/math/slalib/fk45z.f new file mode 100644 index 00000000..409d811b --- /dev/null +++ b/math/slalib/fk45z.f @@ -0,0 +1,183 @@ + SUBROUTINE slF45Z (R1950,D1950,BEPOCH,R2000,D2000) +*+ +* - - - - - - +* F 4 5 Z +* - - - - - - +* +* Convert B1950.0 FK4 star data to J2000.0 FK5 assuming zero +* proper motion in the FK5 frame (double precision) +* +* This routine converts stars from the old, Bessel-Newcomb, FK4 +* system to the new, IAU 1976, FK5, Fricke system, in such a +* way that the FK5 proper motion is zero. Because such a star +* has, in general, a non-zero proper motion in the FK4 system, +* the routine requires the epoch at which the position in the +* FK4 system was determined. +* +* The method is from Appendix 2 of Ref 1, but using the constants +* of Ref 4. +* +* Given: +* R1950,D1950 dp B1950.0 FK4 RA,Dec at epoch (rad) +* BEPOCH dp Besselian epoch (e.g. 1979.3D0) +* +* Returned: +* R2000,D2000 dp J2000.0 FK5 RA,Dec (rad) +* +* Notes: +* +* 1) The epoch BEPOCH is strictly speaking Besselian, but +* if a Julian epoch is supplied the result will be +* affected only to a negligible extent. +* +* 2) Conversion from Besselian epoch 1950.0 to Julian epoch +* 2000.0 only is provided for. Conversions involving other +* epochs will require use of the appropriate precession, +* proper motion, and E-terms routines before and/or +* after FK45Z is called. +* +* 3) In the FK4 catalogue the proper motions of stars within +* 10 degrees of the poles do not embody the differential +* E-term effect and should, strictly speaking, be handled +* in a different manner from stars outside these regions. +* However, given the general lack of homogeneity of the star +* data available for routine astrometry, the difficulties of +* handling positions that may have been determined from +* astrometric fields spanning the polar and non-polar regions, +* the likelihood that the differential E-terms effect was not +* taken into account when allowing for proper motion in past +* astrometry, and the undesirability of a discontinuity in +* the algorithm, the decision has been made in this routine to +* include the effect of differential E-terms on the proper +* motions for all stars, whether polar or not. At epoch 2000, +* and measuring on the sky rather than in terms of dRA, the +* errors resulting from this simplification are less than +* 1 milliarcsecond in position and 1 milliarcsecond per +* century in proper motion. +* +* References: +* +* 1 Aoki,S., et al, 1983. Astron.Astrophys., 128, 263. +* +* 2 Smith, C.A. et al, 1989. "The transformation of astrometric +* catalog systems to the equinox J2000.0". Astron.J. 97, 265. +* +* 3 Yallop, B.D. et al, 1989. "Transformation of mean star places +* from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". +* Astron.J. 97, 274. +* +* 4 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to +* the Astronomical Almanac", ISBN 0-935702-68-7. +* +* Called: slDS2C, slEPJ, slEB2D, slDC2S, slDA2P +* +* P.T.Wallace Starlink 21 September 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R1950,D1950,BEPOCH,R2000,D2000 + + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925287D0) + + DOUBLE PRECISION W + INTEGER I,J + +* Position and position+velocity vectors + DOUBLE PRECISION R0(3),A1(3),V1(3),V2(6) + +* Radians per year to arcsec per century + DOUBLE PRECISION PMF + PARAMETER (PMF=100D0*60D0*60D0*360D0/D2PI) + +* Functions + DOUBLE PRECISION slEPJ,slEB2D,slDA2P + +* +* CANONICAL CONSTANTS (see references) +* + +* Vectors A and Adot, and matrix M (only half of which is needed here) + DOUBLE PRECISION A(3),AD(3),EM(6,3) + DATA A,AD/ -1.62557D-6, -0.31919D-6, -0.13843D-6, + : +1.245D-3, -1.580D-3, -0.659D-3/ + + DATA (EM(I,1),I=1,6) / +0.9999256782D0, + : +0.0111820610D0, + : +0.0048579479D0, + : -0.000551D0, + : +0.238514D0, + : -0.435623D0 / + + DATA (EM(I,2),I=1,6) / -0.0111820611D0, + : +0.9999374784D0, + : -0.0000271474D0, + : -0.238565D0, + : -0.002667D0, + : +0.012254D0 / + + DATA (EM(I,3),I=1,6) / -0.0048579477D0, + : -0.0000271765D0, + : +0.9999881997D0, + : +0.435739D0, + : -0.008541D0, + : +0.002117D0 / + + + +* Spherical to Cartesian + CALL slDS2C(R1950,D1950,R0) + +* Adjust vector A to give zero proper motion in FK5 + W=(BEPOCH-1950D0)/PMF + DO I=1,3 + A1(I)=A(I)+W*AD(I) + END DO + +* Remove e-terms + W=R0(1)*A1(1)+R0(2)*A1(2)+R0(3)*A1(3) + DO I=1,3 + V1(I)=R0(I)-A1(I)+W*R0(I) + END DO + +* Convert position vector to Fricke system + DO I=1,6 + W=0D0 + DO J=1,3 + W=W+EM(I,J)*V1(J) + END DO + V2(I)=W + END DO + +* Allow for fictitious proper motion in FK4 + W=(slEPJ(slEB2D(BEPOCH))-2000D0)/PMF + DO I=1,3 + V2(I)=V2(I)+W*V2(I+3) + END DO + +* Revert to spherical coordinates + CALL slDC2S(V2,W,D2000) + R2000=slDA2P(W) + + END diff --git a/math/slalib/fk524.f b/math/slalib/fk524.f new file mode 100644 index 00000000..49118030 --- /dev/null +++ b/math/slalib/fk524.f @@ -0,0 +1,275 @@ + SUBROUTINE slFK54 (R2000,D2000,DR2000,DD2000,P2000,V2000, + : R1950,D1950,DR1950,DD1950,P1950,V1950) +*+ +* - - - - - - +* F K 5 4 +* - - - - - - +* +* Convert J2000.0 FK5 star data to B1950.0 FK4 (double precision) +* +* This routine converts stars from the new, IAU 1976, FK5, Fricke +* system, to the old, Bessel-Newcomb, FK4 system. The precepts +* of Smith et al (Ref 1) are followed, using the implementation +* by Yallop et al (Ref 2) of a matrix method due to Standish. +* Kinoshita's development of Andoyer's post-Newcomb precession is +* used. The numerical constants from Seidelmann et al (Ref 3) are +* used canonically. +* +* Given: (all J2000.0,FK5) +* R2000,D2000 dp J2000.0 RA,Dec (rad) +* DR2000,DD2000 dp J2000.0 proper motions (rad/Jul.yr) +* P2000 dp parallax (arcsec) +* V2000 dp radial velocity (km/s, +ve = moving away) +* +* Returned: (all B1950.0,FK4) +* R1950,D1950 dp B1950.0 RA,Dec (rad) +* DR1950,DD1950 dp B1950.0 proper motions (rad/trop.yr) +* P1950 dp parallax (arcsec) +* V1950 dp radial velocity (km/s, +ve = moving away) +* +* Notes: +* +* 1) The proper motions in RA are dRA/dt rather than +* cos(Dec)*dRA/dt, and are per year rather than per century. +* +* 2) Note that conversion from Julian epoch 2000.0 to Besselian +* epoch 1950.0 only is provided for. Conversions involving +* other epochs will require use of the appropriate precession, +* proper motion, and E-terms routines before and/or after +* FK524 is called. +* +* 3) In the FK4 catalogue the proper motions of stars within +* 10 degrees of the poles do not embody the differential +* E-term effect and should, strictly speaking, be handled +* in a different manner from stars outside these regions. +* However, given the general lack of homogeneity of the star +* data available for routine astrometry, the difficulties of +* handling positions that may have been determined from +* astrometric fields spanning the polar and non-polar regions, +* the likelihood that the differential E-terms effect was not +* taken into account when allowing for proper motion in past +* astrometry, and the undesirability of a discontinuity in +* the algorithm, the decision has been made in this routine to +* include the effect of differential E-terms on the proper +* motions for all stars, whether polar or not. At epoch 2000, +* and measuring on the sky rather than in terms of dRA, the +* errors resulting from this simplification are less than +* 1 milliarcsecond in position and 1 milliarcsecond per +* century in proper motion. +* +* References: +* +* 1 Smith, C.A. et al, 1989. "The transformation of astrometric +* catalog systems to the equinox J2000.0". Astron.J. 97, 265. +* +* 2 Yallop, B.D. et al, 1989. "Transformation of mean star places +* from FK4 B1950.0 to FK5 J2000.0 using matrices in 6-space". +* Astron.J. 97, 274. +* +* 3 Seidelmann, P.K. (ed), 1992. "Explanatory Supplement to +* the Astronomical Almanac", ISBN 0-935702-68-7. +* +* P.T.Wallace Starlink 19 December 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R2000,D2000,DR2000,DD2000,P2000,V2000, + : R1950,D1950,DR1950,DD1950,P1950,V1950 + + +* Miscellaneous + DOUBLE PRECISION R,D,UR,UD,PX,RV + DOUBLE PRECISION SR,CR,SD,CD,X,Y,Z,W + DOUBLE PRECISION V1(6),V2(6) + DOUBLE PRECISION XD,YD,ZD + DOUBLE PRECISION RXYZ,WD,RXYSQ,RXY + INTEGER I,J + +* 2Pi + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925287D0) + +* Radians per year to arcsec per century + DOUBLE PRECISION PMF + PARAMETER (PMF=100D0*60D0*60D0*360D0/D2PI) + +* Small number to avoid arithmetic problems + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-30) + +* +* CANONICAL CONSTANTS (see references) +* + +* Km per sec to AU per tropical century +* = 86400 * 36524.2198782 / 149597870 + DOUBLE PRECISION VF + PARAMETER (VF=21.095D0) + +* Constant vector and matrix (by columns) + DOUBLE PRECISION A(6),EMI(6,6) + DATA A/ -1.62557D-6, -0.31919D-6, -0.13843D-6, + : +1.245D-3, -1.580D-3, -0.659D-3/ + + DATA (EMI(I,1),I=1,6) / +0.9999256795D0, + : -0.0111814828D0, + : -0.0048590040D0, + : -0.000551D0, + : -0.238560D0, + : +0.435730D0 / + + DATA (EMI(I,2),I=1,6) / +0.0111814828D0, + : +0.9999374849D0, + : -0.0000271557D0, + : +0.238509D0, + : -0.002667D0, + : -0.008541D0 / + + DATA (EMI(I,3),I=1,6) / +0.0048590039D0, + : -0.0000271771D0, + : +0.9999881946D0, + : -0.435614D0, + : +0.012254D0, + : +0.002117D0 / + + DATA (EMI(I,4),I=1,6) / -0.00000242389840D0, + : +0.00000002710544D0, + : +0.00000001177742D0, + : +0.99990432D0, + : -0.01118145D0, + : -0.00485852D0 / + + DATA (EMI(I,5),I=1,6) / -0.00000002710544D0, + : -0.00000242392702D0, + : +0.00000000006585D0, + : +0.01118145D0, + : +0.99991613D0, + : -0.00002716D0 / + + DATA (EMI(I,6),I=1,6) / -0.00000001177742D0, + : +0.00000000006585D0, + : -0.00000242404995D0, + : +0.00485852D0, + : -0.00002717D0, + : +0.99996684D0 / + + + +* Pick up J2000 data (units radians and arcsec/JC) + R=R2000 + D=D2000 + UR=DR2000*PMF + UD=DD2000*PMF + PX=P2000 + RV=V2000 + +* Spherical to Cartesian + SR=SIN(R) + CR=COS(R) + SD=SIN(D) + CD=COS(D) + + X=CR*CD + Y=SR*CD + Z= SD + + W=VF*RV*PX + + V1(1)=X + V1(2)=Y + V1(3)=Z + + V1(4)=-UR*Y-CR*SD*UD+W*X + V1(5)= UR*X-SR*SD*UD+W*Y + V1(6)= CD*UD+W*Z + +* Convert position+velocity vector to BN system + DO I=1,6 + W=0D0 + DO J=1,6 + W=W+EMI(I,J)*V1(J) + END DO + V2(I)=W + END DO + +* Position vector components and magnitude + X=V2(1) + Y=V2(2) + Z=V2(3) + RXYZ=SQRT(X*X+Y*Y+Z*Z) + +* Apply E-terms to position + W=X*A(1)+Y*A(2)+Z*A(3) + X=X+A(1)*RXYZ-W*X + Y=Y+A(2)*RXYZ-W*Y + Z=Z+A(3)*RXYZ-W*Z + +* Recompute magnitude + RXYZ=SQRT(X*X+Y*Y+Z*Z) + +* Apply E-terms to both position and velocity + X=V2(1) + Y=V2(2) + Z=V2(3) + W=X*A(1)+Y*A(2)+Z*A(3) + WD=X*A(4)+Y*A(5)+Z*A(6) + X=X+A(1)*RXYZ-W*X + Y=Y+A(2)*RXYZ-W*Y + Z=Z+A(3)*RXYZ-W*Z + XD=V2(4)+A(4)*RXYZ-WD*X + YD=V2(5)+A(5)*RXYZ-WD*Y + ZD=V2(6)+A(6)*RXYZ-WD*Z + +* Convert to spherical + RXYSQ=X*X+Y*Y + RXY=SQRT(RXYSQ) + + IF (X.EQ.0D0.AND.Y.EQ.0D0) THEN + R=0D0 + ELSE + R=ATAN2(Y,X) + IF (R.LT.0.0D0) R=R+D2PI + END IF + D=ATAN2(Z,RXY) + + IF (RXY.GT.TINY) THEN + UR=(X*YD-Y*XD)/RXYSQ + UD=(ZD*RXYSQ-Z*(X*XD+Y*YD))/((RXYSQ+Z*Z)*RXY) + END IF + +* Radial velocity and parallax + IF (PX.GT.TINY) THEN + RV=(X*XD+Y*YD+Z*ZD)/(PX*VF*RXYZ) + PX=PX/RXYZ + END IF + +* Return results + R1950=R + D1950=D + DR1950=UR/PMF + DD1950=UD/PMF + P1950=PX + V1950=RV + + END diff --git a/math/slalib/fk52h.f b/math/slalib/fk52h.f new file mode 100644 index 00000000..4d9d42f8 --- /dev/null +++ b/math/slalib/fk52h.f @@ -0,0 +1,123 @@ + SUBROUTINE slFK5H (R5,D5,DR5,DD5,RH,DH,DRH,DDH) +*+ +* - - - - - - +* F K 5 H +* - - - - - - +* +* Transform FK5 (J2000) star data into the Hipparcos frame. +* +* (double precision) +* +* This routine transforms FK5 star positions and proper motions +* into the frame of the Hipparcos catalogue. +* +* Given (all FK5, equinox J2000, epoch J2000): +* R5 d RA (radians) +* D5 d Dec (radians) +* DR5 d proper motion in RA (dRA/dt, rad/Jyear) +* DD5 d proper motion in Dec (dDec/dt, rad/Jyear) +* +* Returned (all Hipparcos, epoch J2000): +* RH d RA (radians) +* DH d Dec (radians) +* DRH d proper motion in RA (dRA/dt, rad/Jyear) +* DDH d proper motion in Dec (dDec/dt, rad/Jyear) +* +* Called: slDSC6, slDAVM, slDMXV, slDVXV, slDC6S, +* slDA2P +* +* Notes: +* +* 1) The proper motions in RA are dRA/dt rather than +* cos(Dec)*dRA/dt, and are per year rather than per century. +* +* 2) The FK5 to Hipparcos transformation consists of a pure +* rotation and spin; zonal errors in the FK5 catalogue are +* not taken into account. +* +* 3) The published orientation and spin components are interpreted +* as "axial vectors". An axial vector points at the pole of the +* rotation and its length is the amount of rotation in radians. +* +* 4) See also slHFK5, slF5HZ, slHF5Z. +* +* Reference: +* +* M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). +* +* P.T.Wallace Starlink 22 June 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R5,D5,DR5,DD5,RH,DH,DRH,DDH + + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + +* FK5 to Hipparcos orientation and spin (radians, radians/year) + DOUBLE PRECISION EPX,EPY,EPZ + DOUBLE PRECISION OMX,OMY,OMZ + + PARAMETER ( EPX = -19.9D-3 * AS2R, + : EPY = -9.1D-3 * AS2R, + : EPZ = +22.9D-3 * AS2R ) + + PARAMETER ( OMX = -0.30D-3 * AS2R, + : OMY = +0.60D-3 * AS2R, + : OMZ = +0.70D-3 * AS2R ) + + DOUBLE PRECISION PV5(6),ORTN(3),R5H(3,3),S5(3),VV(3),PVH(6),W,R,V + INTEGER I + + DOUBLE PRECISION slDA2P + + + +* FK5 barycentric position/velocity 6-vector (normalized). + CALL slDSC6(R5,D5,1D0,DR5,DD5,0D0,PV5) + +* FK5 to Hipparcos orientation matrix. + ORTN(1) = EPX + ORTN(2) = EPY + ORTN(3) = EPZ + CALL slDAVM(ORTN,R5H) + +* Hipparcos wrt FK5 spin vector. + S5(1) = OMX + S5(2) = OMY + S5(3) = OMZ + +* Orient & spin the 6-vector into the Hipparcos frame. + CALL slDMXV(R5H,PV5,PVH) + CALL slDVXV(PV5,S5,VV) + DO I=1,3 + VV(I) = PV5(I+3)+VV(I) + END DO + CALL slDMXV(R5H,VV,PVH(4)) + +* Hipparcos 6-vector to spherical. + CALL slDC6S(PVH,W,DH,R,DRH,DDH,V) + RH = slDA2P(W) + + END diff --git a/math/slalib/fk54z.f b/math/slalib/fk54z.f new file mode 100644 index 00000000..69a93461 --- /dev/null +++ b/math/slalib/fk54z.f @@ -0,0 +1,87 @@ + SUBROUTINE slF54Z (R2000,D2000,BEPOCH, + : R1950,D1950,DR1950,DD1950) +*+ +* - - - - - - +* F 5 4 Z +* - - - - - - +* +* Convert a J2000.0 FK5 star position to B1950.0 FK4 assuming +* zero proper motion and parallax (double precision) +* +* This routine converts star positions from the new, IAU 1976, +* FK5, Fricke system to the old, Bessel-Newcomb, FK4 system. +* +* Given: +* R2000,D2000 dp J2000.0 FK5 RA,Dec (rad) +* BEPOCH dp Besselian epoch (e.g. 1950D0) +* +* Returned: +* R1950,D1950 dp B1950.0 FK4 RA,Dec (rad) at epoch BEPOCH +* DR1950,DD1950 dp B1950.0 FK4 proper motions (rad/trop.yr) +* +* Notes: +* +* 1) The proper motion in RA is dRA/dt rather than cos(Dec)*dRA/dt. +* +* 2) Conversion from Julian epoch 2000.0 to Besselian epoch 1950.0 +* only is provided for. Conversions involving other epochs will +* require use of the appropriate precession routines before and +* after this routine is called. +* +* 3) Unlike in the slFK54 routine, the FK5 proper motions, the +* parallax and the radial velocity are presumed zero. +* +* 4) It is the intention that FK5 should be a close approximation +* to an inertial frame, so that distant objects have zero proper +* motion; such objects have (in general) non-zero proper motion +* in FK4, and this routine returns those fictitious proper +* motions. +* +* 5) The position returned by this routine is in the B1950 +* reference frame but at Besselian epoch BEPOCH. For +* comparison with catalogues the BEPOCH argument will +* frequently be 1950D0. +* +* Called: slFK54, slPM +* +* P.T.Wallace Starlink 10 April 1990 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R2000,D2000,BEPOCH, + : R1950,D1950,DR1950,DD1950 + + DOUBLE PRECISION R,D,PX,RV + + + +* FK5 equinox J2000 (any epoch) to FK4 equinox B1950 epoch B1950 + CALL slFK54(R2000,D2000,0D0,0D0,0D0,0D0, + : R,D,DR1950,DD1950,PX,RV) + +* Fictitious proper motion to epoch BEPOCH + CALL slPM(R,D,DR1950,DD1950,0D0,0D0,1950D0,BEPOCH, + : R1950,D1950) + + END diff --git a/math/slalib/fk5hz.f b/math/slalib/fk5hz.f new file mode 100644 index 00000000..0905376d --- /dev/null +++ b/math/slalib/fk5hz.f @@ -0,0 +1,125 @@ + SUBROUTINE slF5HZ (R5,D5,EPOCH,RH,DH) +*+ +* - - - - - - +* F 5 H Z +* - - - - - - +* +* Transform an FK5 (J2000) star position into the frame of the +* Hipparcos catalogue, assuming zero Hipparcos proper motion. +* +* (double precision) +* +* This routine converts a star position from the FK5 system to +* the Hipparcos system, in such a way that the Hipparcos proper +* motion is zero. Because such a star has, in general, a non-zero +* proper motion in the FK5 system, the routine requires the epoch +* at which the position in the FK5 system was determined. +* +* Given: +* R5 d FK5 RA (radians), equinox J2000, epoch EPOCH +* D5 d FK5 Dec (radians), equinox J2000, epoch EPOCH +* EPOCH d Julian epoch (TDB) +* +* Returned (all Hipparcos): +* RH d RA (radians) +* DH d Dec (radians) +* +* Called: slDS2C, slDAVM, slDIMV, slDMXV, slDC2S, +* slDA2P +* +* Notes: +* +* 1) The FK5 to Hipparcos transformation consists of a pure +* rotation and spin; zonal errors in the FK5 catalogue are +* not taken into account. +* +* 2) The published orientation and spin components are interpreted +* as "axial vectors". An axial vector points at the pole of the +* rotation and its length is the amount of rotation in radians. +* +* 3) See also slFK5H, slHFK5, slHF5Z. +* +* Reference: +* +* M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). +* +* P.T.Wallace Starlink 22 June 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R5,D5,EPOCH,RH,DH + + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + +* FK5 to Hipparcos orientation and spin (radians, radians/year) + DOUBLE PRECISION EPX,EPY,EPZ + DOUBLE PRECISION OMX,OMY,OMZ + + PARAMETER ( EPX = -19.9D-3 * AS2R, + : EPY = -9.1D-3 * AS2R, + : EPZ = +22.9D-3 * AS2R ) + + PARAMETER ( OMX = -0.30D-3 * AS2R, + : OMY = +0.60D-3 * AS2R, + : OMZ = +0.70D-3 * AS2R ) + + DOUBLE PRECISION P5E(3),ORTN(3),R5H(3,3),T,VST(3),RST(3,3), + : P5(3),PH(3),W + + DOUBLE PRECISION slDA2P + + + +* FK5 barycentric position vector. + CALL slDS2C(R5,D5,P5E) + +* FK5 to Hipparcos orientation matrix. + ORTN(1) = EPX + ORTN(2) = EPY + ORTN(3) = EPZ + CALL slDAVM(ORTN,R5H) + +* Time interval from epoch to J2000. + T = 2000D0-EPOCH + +* Axial vector: accumulated Hipparcos wrt FK5 spin over that interval. + VST(1) = OMX*T + VST(2) = OMY*T + VST(3) = OMZ*T + +* Express the accumulated spin as a rotation matrix. + CALL slDAVM(VST,RST) + +* Derotate the vector's FK5 axes back to epoch. + CALL slDIMV(RST,P5E,P5) + +* Rotate the vector into the Hipparcos frame. + CALL slDMXV(R5H,P5,PH) + +* Hipparcos vector to spherical. + CALL slDC2S(PH,W,DH) + RH = slDA2P(W) + + END diff --git a/math/slalib/flotin.f b/math/slalib/flotin.f new file mode 100644 index 00000000..932580a3 --- /dev/null +++ b/math/slalib/flotin.f @@ -0,0 +1,146 @@ + SUBROUTINE slRFLI (STRING, NSTRT, RESLT, JFLAG) +*+ +* - - - - - - - +* R F L I +* - - - - - - - +* +* Convert free-format input into single precision floating point +* +* Given: +* STRING c string containing number to be decoded +* NSTRT i pointer to where decoding is to start +* RESLT r current value of result +* +* Returned: +* NSTRT i advanced to next number +* RESLT r result +* JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error +* +* Called: slDFLI +* +* Notes: +* +* 1 The reason FLOTIN has separate OK status values for + +* and - is to enable minus zero to be detected. This is +* of crucial importance when decoding mixed-radix numbers. +* For example, an angle expressed as deg, arcmin, arcsec +* may have a leading minus sign but a zero degrees field. +* +* 2 A TAB is interpreted as a space, and lowercase characters +* are interpreted as uppercase. +* +* 3 The basic format is the sequence of fields #^.^@#^, where +* # is a sign character + or -, ^ means a string of decimal +* digits, and @, which indicates an exponent, means D or E. +* Various combinations of these fields can be omitted, and +* embedded blanks are permissible in certain places. +* +* 4 Spaces: +* +* . Leading spaces are ignored. +* +* . Embedded spaces are allowed only after +, -, D or E, +* and after the decomal point if the first sequence of +* digits is absent. +* +* . Trailing spaces are ignored; the first signifies +* end of decoding and subsequent ones are skipped. +* +* 5 Delimiters: +* +* . Any character other than +,-,0-9,.,D,E or space may be +* used to signal the end of the number and terminate +* decoding. +* +* . Comma is recognized by FLOTIN as a special case; it +* is skipped, leaving the pointer on the next character. +* See 13, below. +* +* 6 Both signs are optional. The default is +. +* +* 7 The mantissa ^.^ defaults to 1. +* +* 8 The exponent @#^ defaults to E0. +* +* 9 The strings of decimal digits may be of any length. +* +* 10 The decimal point is optional for whole numbers. +* +* 11 A "null result" occurs when the string of characters being +* decoded does not begin with +,-,0-9,.,D or E, or consists +* entirely of spaces. When this condition is detected, JFLAG +* is set to 1 and RESLT is left untouched. +* +* 12 NSTRT = 1 for the first character in the string. +* +* 13 On return from FLOTIN, NSTRT is set ready for the next +* decode - following trailing blanks and any comma. If a +* delimiter other than comma is being used, NSTRT must be +* incremented before the next call to FLOTIN, otherwise +* all subsequent calls will return a null result. +* +* 14 Errors (JFLAG=2) occur when: +* +* . a +, -, D or E is left unsatisfied; or +* +* . the decimal point is present without at least +* one decimal digit before or after it; or +* +* . an exponent more than 100 has been presented. +* +* 15 When an error has been detected, NSTRT is left +* pointing to the character following the last +* one used before the error came to light. This +* may be after the point at which a more sophisticated +* program could have detected the error. For example, +* FLOTIN does not detect that '1E999' is unacceptable +* (on a computer where this is so) until the entire number +* has been decoded. +* +* 16 Certain highly unlikely combinations of mantissa & +* exponent can cause arithmetic faults during the +* decode, in some cases despite the fact that they +* together could be construed as a valid number. +* +* 17 Decoding is left to right, one pass. +* +* 18 See also DFLTIN and INTIN +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NSTRT + REAL RESLT + INTEGER JFLAG + + DOUBLE PRECISION DRESLT + + +* Call the double precision version + CALL slDFLI(STRING,NSTRT,DRESLT,JFLAG) + IF (JFLAG.LE.0) RESLT=REAL(DRESLT) + + END diff --git a/math/slalib/galeq.f b/math/slalib/galeq.f new file mode 100644 index 00000000..e0010c8b --- /dev/null +++ b/math/slalib/galeq.f @@ -0,0 +1,97 @@ + SUBROUTINE slGAEQ (DL, DB, DR, DD) +*+ +* - - - - - - +* G A E Q +* - - - - - - +* +* Transformation from IAU 1958 galactic coordinates to +* J2000.0 equatorial coordinates (double precision) +* +* Given: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* Returned: +* DR,DD dp J2000.0 RA,Dec +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDIMV, slDC2S, slDA2P, slDA1P +* +* Note: +* The equatorial coordinates are J2000.0. Use the routine +* slGE50 if conversion to B1950.0 'FK4' coordinates is +* required. +* +* Reference: +* Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) +* +* P.T.Wallace Starlink 21 September 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DL,DB,DR,DD + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3) + +* +* L2,B2 system of galactic coordinates +* +* P = 192.25 RA of galactic north pole (mean B1950.0) +* Q = 62.6 inclination of galactic to mean B1950.0 equator +* R = 33 longitude of ascending node +* +* P,Q,R are degrees +* +* Equatorial to galactic rotation matrix (J2000.0), obtained by +* applying the standard FK4 to FK5 transformation, for zero proper +* motion in FK5, to the columns of the B1950 equatorial to +* galactic rotation matrix: +* + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3)/ + : -0.054875539726D0,-0.873437108010D0,-0.483834985808D0, + : +0.494109453312D0,-0.444829589425D0,+0.746982251810D0, + : -0.867666135858D0,-0.198076386122D0,+0.455983795705D0/ + + + +* Spherical to Cartesian + CALL slDS2C(DL,DB,V1) + +* Galactic to equatorial + CALL slDIMV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,DR,DD) + +* Express in conventional ranges + DR=slDA2P(DR) + DD=slDA1P(DD) + + END diff --git a/math/slalib/galsup.f b/math/slalib/galsup.f new file mode 100644 index 00000000..afc9240c --- /dev/null +++ b/math/slalib/galsup.f @@ -0,0 +1,97 @@ + SUBROUTINE slGASU (DL, DB, DSL, DSB) +*+ +* - - - - - - - +* G A S U +* - - - - - - - +* +* Transformation from IAU 1958 galactic coordinates to +* de Vaucouleurs supergalactic coordinates (double precision) +* +* Given: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* Returned: +* DSL,DSB dp supergalactic longitude and latitude +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDMXV, slDC2S, slDA2P, slDA1P +* +* References: +* +* de Vaucouleurs, de Vaucouleurs, & Corwin, Second Reference +* Catalogue of Bright Galaxies, U. Texas, page 8. +* +* Systems & Applied Sciences Corp., Documentation for the +* machine-readable version of the above catalogue, +* Contract NAS 5-26490. +* +* (These two references give different values for the galactic +* longitude of the supergalactic origin. Both are wrong; the +* correct value is L2=137.37.) +* +* P.T.Wallace Starlink 25 January 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DL,DB,DSL,DSB + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3) + +* +* System of supergalactic coordinates: +* +* SGL SGB L2 B2 (deg) +* - +90 47.37 +6.32 +* 0 0 - 0 +* +* Galactic to supergalactic rotation matrix: +* + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3)/ + : -0.735742574804D0,+0.677261296414D0,+0.000000000000D0, + : -0.074553778365D0,-0.080991471307D0,+0.993922590400D0, + : +0.673145302109D0,+0.731271165817D0,+0.110081262225D0/ + + + +* Spherical to Cartesian + CALL slDS2C(DL,DB,V1) + +* Galactic to supergalactic + CALL slDMXV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,DSL,DSB) + +* Express in conventional ranges + DSL=slDA2P(DSL) + DSB=slDA1P(DSB) + + END diff --git a/math/slalib/ge50.f b/math/slalib/ge50.f new file mode 100644 index 00000000..a6a8afeb --- /dev/null +++ b/math/slalib/ge50.f @@ -0,0 +1,108 @@ + SUBROUTINE slGE50 (DL, DB, DR, DD) +*+ +* - - - - - +* G E 5 0 +* - - - - - +* +* Transformation from IAU 1958 galactic coordinates to +* B1950.0 'FK4' equatorial coordinates (double precision) +* +* Given: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* Returned: +* DR,DD dp B1950.0 'FK4' RA,Dec +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDIMV, slDC2S, slADET, slDA2P, slDA1P +* +* Note: +* The equatorial coordinates are B1950.0 'FK4'. Use the +* routine slGAEQ if conversion to J2000.0 coordinates +* is required. +* +* Reference: +* Blaauw et al, Mon.Not.R.Astron.Soc.,121,123 (1960) +* +* P.T.Wallace Starlink 5 September 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DL,DB,DR,DD + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3),R,D,RE,DE + +* +* L2,B2 system of galactic coordinates +* +* P = 192.25 RA of galactic north pole (mean B1950.0) +* Q = 62.6 inclination of galactic to mean B1950.0 equator +* R = 33 longitude of ascending node +* +* P,Q,R are degrees +* +* +* Equatorial to galactic rotation matrix +* +* The Euler angles are P, Q, 90-R, about the z then y then +* z axes. +* +* +CP.CQ.SR-SP.CR +SP.CQ.SR+CP.CR -SQ.SR +* +* -CP.CQ.CR-SP.SR -SP.CQ.CR+CP.SR +SQ.CR +* +* +CP.SQ +SP.SQ +CQ +* + + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3) / + : -0.066988739415D0,-0.872755765852D0,-0.483538914632D0, + : +0.492728466075D0,-0.450346958020D0,+0.744584633283D0, + : -0.867600811151D0,-0.188374601723D0,+0.460199784784D0 / + + + +* Spherical to Cartesian + CALL slDS2C(DL,DB,V1) + +* Rotate to mean B1950.0 + CALL slDIMV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,R,D) + +* Introduce E-terms + CALL slADET(R,D,1950D0,RE,DE) + +* Express in conventional ranges + DR=slDA2P(RE) + DD=slDA1P(DE) + + END diff --git a/math/slalib/geoc.f b/math/slalib/geoc.f new file mode 100644 index 00000000..470a1958 --- /dev/null +++ b/math/slalib/geoc.f @@ -0,0 +1,78 @@ + SUBROUTINE slGEOC (P, H, R, Z) +*+ +* - - - - - +* G E O C +* - - - - - +* +* Convert geodetic position to geocentric (double precision) +* +* Given: +* P dp latitude (geodetic, radians) +* H dp height above reference spheroid (geodetic, metres) +* +* Returned: +* R dp distance from Earth axis (AU) +* Z dp distance from plane of Earth equator (AU) +* +* Notes: +* +* 1 Geocentric latitude can be obtained by evaluating ATAN2(Z,R). +* +* 2 IAU 1976 constants are used. +* +* Reference: +* +* Green,R.M., Spherical Astronomy, CUP 1985, p98. +* +* Last revision: 22 July 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION P,H,R,Z + +* Earth equatorial radius (metres) + DOUBLE PRECISION A0 + PARAMETER (A0=6378140D0) + +* Reference spheroid flattening factor and useful function + DOUBLE PRECISION F,B + PARAMETER (F=1D0/298.257D0,B=(1D0-F)**2) + +* Astronomical unit in metres + DOUBLE PRECISION AU + PARAMETER (AU=1.49597870D11) + + DOUBLE PRECISION SP,CP,C,S + + + +* Geodetic to geocentric conversion + SP = SIN(P) + CP = COS(P) + C = 1D0/SQRT(CP*CP+B*SP*SP) + S = B*C + R = (A0*C+H)*CP/AU + Z = (A0*S+H)*SP/AU + + END diff --git a/math/slalib/gmst.f b/math/slalib/gmst.f new file mode 100644 index 00000000..808ea382 --- /dev/null +++ b/math/slalib/gmst.f @@ -0,0 +1,78 @@ + DOUBLE PRECISION FUNCTION slGMST (UT1) +*+ +* - - - - - +* G M S T +* - - - - - +* +* Conversion from universal time to sidereal time (double precision) +* +* Given: +* UT1 dp universal time (strictly UT1) expressed as +* modified Julian Date (JD-2400000.5) +* +* The result is the Greenwich mean sidereal time (double +* precision, radians). +* +* The IAU 1982 expression (see page S15 of 1984 Astronomical Almanac) +* is used, but rearranged to reduce rounding errors. This expression +* is always described as giving the GMST at 0 hours UT. In fact, it +* gives the difference between the GMST and the UT, which happens to +* equal the GMST (modulo 24 hours) at 0 hours UT each day. In this +* routine, the entire UT is used directly as the argument for the +* standard formula, and the fractional part of the UT is added +* separately. Note that the factor 1.0027379... does not appear in the +* IAU 1982 expression explicitly but in the form of the coefficient +* 8640184.812866, which is 86400x36525x0.0027379... +* +* See also the routine slGMSA, which delivers better numerical +* precision by accepting the UT date and time as separate arguments. +* +* Called: slDA2P +* +* P.T.Wallace Starlink 14 October 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION UT1 + + DOUBLE PRECISION slDA2P + + DOUBLE PRECISION D2PI,S2R + PARAMETER (D2PI=6.283185307179586476925286766559D0, + : S2R=7.272205216643039903848711535369D-5) + + DOUBLE PRECISION TU + + + +* Julian centuries from fundamental epoch J2000 to this UT + TU=(UT1-51544.5D0)/36525D0 + +* GMST at this UT + slGMST=slDA2P(MOD(UT1,1D0)*D2PI+ + : (24110.54841D0+ + : (8640184.812866D0+ + : (0.093104D0-6.2D-6*TU)*TU)*TU)*S2R) + + END diff --git a/math/slalib/gmsta.f b/math/slalib/gmsta.f new file mode 100644 index 00000000..31a92e99 --- /dev/null +++ b/math/slalib/gmsta.f @@ -0,0 +1,100 @@ + DOUBLE PRECISION FUNCTION slGMSA (DATE, UT) +*+ +* - - - - - - +* G M S A +* - - - - - - +* +* Conversion from Universal Time to Greenwich mean sidereal time, +* with rounding errors minimized. +* +* double precision +* +* Given: +* DATE d UT1 date (MJD: integer part of JD-2400000.5)) +* UT d UT1 time (fraction of a day) +* +* The result is the Greenwich mean sidereal time (double precision, +* radians, in the range 0 to 2pi). +* +* There is no restriction on how the UT is apportioned between the +* DATE and UT arguments. Either of the two arguments could, for +* example, be zero and the entire date+time supplied in the other. +* However, the routine is designed to deliver maximum accuracy when +* the DATE argument is a whole number and the UT lies in the range +* 0 to 1 (or vice versa). +* +* The algorithm is based on the IAU 1982 expression (see page S15 of +* the 1984 Astronomical Almanac). This is always described as giving +* the GMST at 0 hours UT1. In fact, it gives the difference between +* the GMST and the UT, the steady 4-minutes-per-day drawing-ahead of +* ST with respect to UT. When whole days are ignored, the expression +* happens to equal the GMST at 0 hours UT1 each day. Note that the +* factor 1.0027379... does not appear explicitly but in the form of +* the coefficient 8640184.812866, which is 86400x36525x0.0027379... +* +* In this routine, the entire UT1 (the sum of the two arguments DATE +* and UT) is used directly as the argument for the standard formula. +* The UT1 is then added, but omitting whole days to conserve accuracy. +* +* See also the routine slGMST, which accepts the UT as a single +* argument. Compared with slGMST, the extra numerical precision +* delivered by the present routine is unlikely to be important in +* an absolute sense, but may be useful when critically comparing +* algorithms and in applications where two sidereal times close +* together are differenced. +* +* Called: slDA2P +* +* P.T.Wallace Starlink 14 October 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,UT + +* Seconds of time to radians + DOUBLE PRECISION S2R + PARAMETER (S2R=7.272205216643039903848712D-5) + + DOUBLE PRECISION D1,D2,T + DOUBLE PRECISION slDA2P + + +* Julian centuries since J2000. + IF (DATE.LT.UT) THEN + D1=DATE + D2=UT + ELSE + D1=UT + D2=DATE + END IF + T=(D1+(D2-51544.5D0))/36525D0 + +* GMST at this UT1. + slGMSA=slDA2P(S2R*(24110.54841D0+ + : (8640184.812866D0+ + : (0.093104D0 + : -6.2D-6*T)*T)*T + : +86400D0*(MOD(D1,1D0)+MOD(D2,1D0)))) + + END diff --git a/math/slalib/gresid.F__vms b/math/slalib/gresid.F__vms new file mode 100644 index 00000000..7cb318fb --- /dev/null +++ b/math/slalib/gresid.F__vms @@ -0,0 +1,89 @@ + REAL FUNCTION sla_GRESID (S) +*+ +* - - - - - - - +* G R E S I D +* - - - - - - - +* +* Generate pseudo-random normal deviate ( = 'Gaussian residual') +* (single precision) +* +* !!! Version for VAX/VMS and DECstation !!! +* +* Given: +* S real standard deviation +* +* The results of many calls to this routine will be +* normally distributed with mean zero and standard deviation S. +* +* The Box-Muller algorithm is used. This is described in +* Numerical Recipes, section 7.2. +* +* P.T.Wallace Starlink 14 October 1991 +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL S + + REAL X,Y,R,W,GNEXT,G + INTEGER ISEED + LOGICAL FIRST + + REAL RAN + + SAVE GNEXT,ISEED,FIRST + DATA ISEED / 123456789 / + DATA FIRST / .TRUE. / + + + +* Second normal deviate of the pair available? + IF (FIRST) THEN + +* No - generate two random numbers inside unit circle + R = 2.0 + DO WHILE (R.GE.1.0) + +* Generate two random numbers in range +/- 1 + X = 2.0*RAN(ISEED)-1.0 + Y = 2.0*RAN(ISEED)-1.0 + +* Try again if not in unit circle + R = X*X+Y*Y + END DO + +* Box-Muller transformation, generating two deviates + W = SQRT(-2.0*LOG(R)/MAX(R,1E-20)) + GNEXT = X*W + G = Y*W + +* Set flag to indicate availability of next deviate + FIRST = .FALSE. + ELSE + +* Return second deviate of the pair & reset flag + G = GNEXT + FIRST = .TRUE. + END IF + +* Scale the deviate by the required standard deviation + sla_GRESID = G*S + + END diff --git a/math/slalib/gresid.F__win b/math/slalib/gresid.F__win new file mode 100644 index 00000000..af197dbd --- /dev/null +++ b/math/slalib/gresid.F__win @@ -0,0 +1,90 @@ + REAL FUNCTION sla_GRESID (S) +*+ +* - - - - - - - +* G R E S I D +* - - - - - - - +* +* Generate pseudo-random normal deviate ( = 'Gaussian residual') +* (single precision) +* +* Given: +* S real standard deviation +* +* The results of many calls to this routine will be +* normally distributed with mean zero and standard deviation S. +* +* The Box-Muller algorithm is used. This is described in +* Numerical Recipes, section 7.2. +* +* !!! Microsoft Fortran dependent - calls the RAN routine !!! +* !!! To seed the random-number generator, either call the !!! +* !!! Microsoft SEED routine specifying some INTEGER*2 !!! +* !!! seed or call the function sla_RANDOM specifying some !!! +* !!! REAL seed. !!! +* +* P.T.Wallace Starlink 1 April 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL S + + REAL X,Y,RV,R,W,GNEXT,G + LOGICAL FIRST + + SAVE GNEXT,RV,FIRST + DATA FIRST / .TRUE. / + + + +* Second normal deviate of the pair available? + IF (FIRST) THEN + +* No - generate two random numbers in range +/- 1 + 1 CONTINUE + CALL RANDOM(RV) !!! PC + X = 2.0*RV-1.0 + CALL RANDOM(RV) !!! PC + Y = 2.0*RV-1.0 + +* Try again if not in unit circle + R = X*X+Y*Y + IF (R.GE.1.0) GO TO 1 + +* Box-Muller transformation, generating two deviates + W = SQRT(-2.0*LOG(R)/MAX(R,1E-20)) + GNEXT = X*W + G = Y*W + +* Set flag to indicate availability of next deviate + FIRST = .FALSE. + ELSE + +* Return second deviate of the pair & reset flag + G = GNEXT + FIRST = .TRUE. + END IF + +* Scale the deviate by the required standard deviation + sla_GRESID = G*S + + END diff --git a/math/slalib/gresid.Fdefault b/math/slalib/gresid.Fdefault new file mode 100644 index 00000000..e3b595ef --- /dev/null +++ b/math/slalib/gresid.Fdefault @@ -0,0 +1,113 @@ +#include "config.h" + REAL FUNCTION sla_GRESID (S) +*+ +* - - - - - - - +* G R E S I D +* - - - - - - - +* +* Generate pseudo-random normal deviate ( = 'Gaussian residual') +* (single precision) +* +* Given: +* S real standard deviation +* +* The results of many calls to this routine will be +* normally distributed with mean zero and standard deviation S. +* +* The Box-Muller algorithm is used. This is described in +* Numerical Recipes, section 7.2. +* +* Called: RAN or RAND (a REAL function returning a random variate -- +* the precise function which is called depends on which functions +* are available when the library is built). If neither of these +* is available, we use the local substitute RANDOM defined +* in rtl_random.c +* +* P.T.Wallace Starlink 14 October 1991 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +*- + + IMPLICIT NONE + + REAL S + + REAL X,Y,R,W,GNEXT,G + LOGICAL FTF,FIRST + +#if HAVE_RAND + REAL RAND +#elif HAVE_RANDOM + REAL RANDOM +#else + error "Can't find random-number function" +#endif + + SAVE GNEXT,FTF,FIRST + DATA FTF,FIRST / .TRUE.,.TRUE. / + + X = 0.0 + Y = 0.0 + +* First time through, initialise the random-number generator +#if HAVE_RAND + IF (FTF) THEN + X = RAND(123456789) + FTF = .FALSE. + END IF +#endif + +* Second normal deviate of the pair available? + IF (FIRST) THEN + +* No - generate two random numbers inside unit circle + R = 2.0 + DO WHILE (R.GE.1.0) + +* Generate two random numbers in range +/- 1 +#if HAVE_RAND + X = 2.0*RAND(0)-1.0 + Y = 2.0*RAND(0)-1.0 +#elif HAVE_RANDOM + X = 2.0*RAN(ISEED)-1.0 + Y = 2.0*RAN(ISEED)-1.0 +#endif + +* Try again if not in unit circle + R = X*X+Y*Y + END DO + +* Box-Muller transformation, generating two deviates + W = SQRT(-2.0*LOG(R)/MAX(R,1E-20)) + GNEXT = X*W + G = Y*W + +* Set flag to indicate availability of next deviate + FIRST = .FALSE. + ELSE + +* Return second deviate of the pair & reset flag + G = GNEXT + FIRST = .TRUE. + END IF + +* Scale the deviate by the required standard deviation + sla_GRESID = G*S + + END diff --git a/math/slalib/h2e.f b/math/slalib/h2e.f new file mode 100644 index 00000000..06016ce3 --- /dev/null +++ b/math/slalib/h2e.f @@ -0,0 +1,101 @@ + SUBROUTINE slH2E ( AZ, EL, PHI, HA, DEC ) +*+ +* - - - - - +* D E 2 H +* - - - - - +* +* Horizon to equatorial coordinates: Az,El to HA,Dec +* +* (single precision) +* +* Given: +* AZ r azimuth +* EL r elevation +* PHI r observatory latitude +* +* Returned: +* HA r hour angle +* DEC r declination +* +* Notes: +* +* 1) All the arguments are angles in radians. +* +* 2) The sign convention for azimuth is north zero, east +pi/2. +* +* 3) HA is returned in the range +/-pi. Declination is returned +* in the range +/-pi/2. +* +* 4) The latitude is (in principle) geodetic. In critical +* applications, corrections for polar motion should be applied. +* +* 5) In some applications it will be important to specify the +* correct type of elevation in order to produce the required +* type of HA,Dec. In particular, it may be important to +* distinguish between the elevation as affected by refraction, +* which will yield the "observed" HA,Dec, and the elevation +* in vacuo, which will yield the "topocentric" HA,Dec. If the +* effects of diurnal aberration can be neglected, the +* topocentric HA,Dec may be used as an approximation to the +* "apparent" HA,Dec. +* +* 6) No range checking of arguments is done. +* +* 7) In applications which involve many such calculations, rather +* than calling the present routine it will be more efficient to +* use inline code, having previously computed fixed terms such +* as sine and cosine of latitude. +* +* Last revision: 11 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL AZ, EL, PHI, HA, DEC + + DOUBLE PRECISION SA, CA, SE, CE, SP, CP, X, Y, Z, R + + +* Useful trig functions. + SA = SIN(AZ) + CA = COS(AZ) + SE = SIN(EL) + CE = COS(EL) + SP = SIN(PHI) + CP = COS(PHI) + +* HA,Dec as x,y,z. + X = -CA*CE*SP+SE*CP + Y = -SA*CE + Z = CA*CE*CP+SE*SP + +* To HA,Dec. + R = SQRT(X*X+Y*Y) + IF (R.EQ.0.0) THEN + HA = 0.0 + ELSE + HA = REAL(ATAN2(Y,X)) + END IF + DEC = REAL(ATAN2(Z,R)) + + END diff --git a/math/slalib/h2fk5.f b/math/slalib/h2fk5.f new file mode 100644 index 00000000..74d71f39 --- /dev/null +++ b/math/slalib/h2fk5.f @@ -0,0 +1,127 @@ + SUBROUTINE slHFK5 (RH,DH,DRH,DDH,R5,D5,DR5,DD5) +*+ +* - - - - - - +* H F K 5 +* - - - - - - +* +* Transform Hipparcos star data into the FK5 (J2000) system. +* +* (double precision) +* +* This routine transforms Hipparcos star positions and proper +* motions into FK5 J2000. +* +* Given (all Hipparcos, epoch J2000): +* RH d RA (radians) +* DH d Dec (radians) +* DRH d proper motion in RA (dRA/dt, rad/Jyear) +* DDH d proper motion in Dec (dDec/dt, rad/Jyear) +* +* Returned (all FK5, equinox J2000, epoch J2000): +* R5 d RA (radians) +* D5 d Dec (radians) +* DR5 d proper motion in RA (dRA/dt, rad/Jyear) +* DD5 d proper motion in Dec (dDec/dt, rad/Jyear) +* +* Called: slDSC6, slDAVM, slDMXV, slDIMV, slDVXV, +* slDC6S, slDA2P +* +* Notes: +* +* 1) The proper motions in RA are dRA/dt rather than +* cos(Dec)*dRA/dt, and are per year rather than per century. +* +* 2) The FK5 to Hipparcos transformation consists of a pure +* rotation and spin; zonal errors in the FK5 catalogue are +* not taken into account. +* +* 3) The published orientation and spin components are interpreted +* as "axial vectors". An axial vector points at the pole of the +* rotation and its length is the amount of rotation in radians. +* +* 4) See also slFK5H, slF5HZ, slHF5Z. +* +* Reference: +* +* M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). +* +* P.T.Wallace Starlink 22 June 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RH,DH,DRH,DDH,R5,D5,DR5,DD5 + + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + +* FK5 to Hipparcos orientation and spin (radians, radians/year) + DOUBLE PRECISION EPX,EPY,EPZ + DOUBLE PRECISION OMX,OMY,OMZ + + PARAMETER ( EPX = -19.9D-3 * AS2R, + : EPY = -9.1D-3 * AS2R, + : EPZ = +22.9D-3 * AS2R ) + + PARAMETER ( OMX = -0.30D-3 * AS2R, + : OMY = +0.60D-3 * AS2R, + : OMZ = +0.70D-3 * AS2R ) + + DOUBLE PRECISION PVH(6),ORTN(3),R5H(3,3),S5(3),SH(3),VV(3), + : PV5(6),W,R,V + INTEGER I + + DOUBLE PRECISION slDA2P + + + +* Hipparcos barycentric position/velocity 6-vector (normalized). + CALL slDSC6(RH,DH,1D0,DRH,DDH,0D0,PVH) + +* FK5 to Hipparcos orientation matrix. + ORTN(1) = EPX + ORTN(2) = EPY + ORTN(3) = EPZ + CALL slDAVM(ORTN,R5H) + +* Hipparcos wrt FK5 spin vector. + S5(1) = OMX + S5(2) = OMY + S5(3) = OMZ + +* Rotate the spin vector into the Hipparcos frame. + CALL slDMXV(R5H,S5,SH) + +* De-orient & de-spin the 6-vector into FK5 J2000. + CALL slDIMV(R5H,PVH,PV5) + CALL slDVXV(PVH,SH,VV) + DO I=1,3 + VV(I) = PVH(I+3)-VV(I) + END DO + CALL slDIMV(R5H,VV,PV5(4)) + +* FK5 6-vector to spherical. + CALL slDC6S(PV5,W,D5,R,DR5,DD5,V) + R5 = slDA2P(W) + + END diff --git a/math/slalib/hfk5z.f b/math/slalib/hfk5z.f new file mode 100644 index 00000000..2f6d53b2 --- /dev/null +++ b/math/slalib/hfk5z.f @@ -0,0 +1,140 @@ + SUBROUTINE slHF5Z (RH,DH,EPOCH,R5,D5,DR5,DD5) +*+ +* - - - - - - +* H F 5 Z +* - - - - - - +* +* Transform a Hipparcos star position into FK5 J2000, assuming +* zero Hipparcos proper motion. +* +* (double precision) +* +* Given: +* RH d Hipparcos RA (radians) +* DH d Hipparcos Dec (radians) +* EPOCH d Julian epoch (TDB) +* +* Returned (all FK5, equinox J2000, epoch EPOCH): +* R5 d RA (radians) +* D5 d Dec (radians) +* +* Called: slDS2C, slDAVM, slDMXV, slDMXM, +* slDIMV, slDVXV, slDC6S, slDA2P +* +* Notes: +* +* 1) The proper motion in RA is dRA/dt rather than cos(Dec)*dRA/dt. +* +* 2) The FK5 to Hipparcos transformation consists of a pure +* rotation and spin; zonal errors in the FK5 catalogue are +* not taken into account. +* +* 3) The published orientation and spin components are interpreted +* as "axial vectors". An axial vector points at the pole of the +* rotation and its length is the amount of rotation in radians. +* +* 4) It was the intention that Hipparcos should be a close +* approximation to an inertial frame, so that distant objects +* have zero proper motion; such objects have (in general) +* non-zero proper motion in FK5, and this routine returns those +* fictitious proper motions. +* +* 5) The position returned by this routine is in the FK5 J2000 +* reference frame but at Julian epoch EPOCH. +* +* 6) See also slFK5H, slHFK5, sla_FK5ZHZ. +* +* Reference: +* +* M.Feissel & F.Mignard, Astron. Astrophys. 331, L33-L36 (1998). +* +* P.T.Wallace Starlink 30 December 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RH,DH,EPOCH,R5,D5,DR5,DD5 + + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + +* FK5 to Hipparcos orientation and spin (radians, radians/year) + DOUBLE PRECISION EPX,EPY,EPZ + DOUBLE PRECISION OMX,OMY,OMZ + + PARAMETER ( EPX = -19.9D-3 * AS2R, + : EPY = -9.1D-3 * AS2R, + : EPZ = +22.9D-3 * AS2R ) + + PARAMETER ( OMX = -0.30D-3 * AS2R, + : OMY = +0.60D-3 * AS2R, + : OMZ = +0.70D-3 * AS2R ) + + DOUBLE PRECISION PH(3),ORTN(3),R5H(3,3),S5(3),SH(3),T,VST(3), + : RST(3,3),R5HT(3,3),PV5E(6),VV(3),W,R,V + + DOUBLE PRECISION slDA2P + + + +* Hipparcos barycentric position vector (normalized). + CALL slDS2C(RH,DH,PH) + +* FK5 to Hipparcos orientation matrix. + ORTN(1) = EPX + ORTN(2) = EPY + ORTN(3) = EPZ + CALL slDAVM(ORTN,R5H) + +* Hipparcos wrt FK5 spin vector. + S5(1) = OMX + S5(2) = OMY + S5(3) = OMZ + +* Rotate the spin vector into the Hipparcos frame. + CALL slDMXV(R5H,S5,SH) + +* Time interval from J2000 to epoch. + T = EPOCH-2000D0 + +* Axial vector: accumulated Hipparcos wrt FK5 spin over that interval. + VST(1) = OMX*T + VST(2) = OMY*T + VST(3) = OMZ*T + +* Express the accumulated spin as a rotation matrix. + CALL slDAVM(VST,RST) + +* Rotation matrix: accumulated spin, then FK5 to Hipparcos. + CALL slDMXM(R5H,RST,R5HT) + +* De-orient & de-spin the vector into FK5 J2000 at epoch. + CALL slDIMV(R5HT,PH,PV5E) + CALL slDVXV(SH,PH,VV) + CALL slDIMV(R5HT,VV,PV5E(4)) + +* FK5 position/velocity 6-vector to spherical. + CALL slDC6S(PV5E,W,D5,R,DR5,DD5,V) + R5 = slDA2P(W) + + END diff --git a/math/slalib/idchf.f b/math/slalib/idchf.f new file mode 100644 index 00000000..fa6e597b --- /dev/null +++ b/math/slalib/idchf.f @@ -0,0 +1,112 @@ + SUBROUTINE slICHF (STRING, NPTR, NVEC, NDIGIT, DIGIT) +*+ +* - - - - - - +* I C H F +* - - - - - - +* +* Internal routine used by DFLTIN +* +* Identify next character in string +* +* Given: +* STRING char string +* NPTR int pointer to character to be identified +* +* Returned: +* NPTR int incremented unless end of field +* NVEC int vector for identified character +* NDIGIT int 0-9 if character was a numeral +* DIGIT double equivalent of NDIGIT +* +* NVEC takes the following values: +* +* 1 0-9 +* 2 space or TAB !!! n.b. ASCII TAB assumed !!! +* 3 D,d,E or e +* 4 . +* 5 + +* 6 - +* 7 , +* 8 else +* 9 outside field +* +* If the character is not 0-9, NDIGIT and DIGIT are either not +* altered or are set to arbitrary values. +* +* P.T.Wallace Starlink 22 December 1992 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NPTR,NVEC,NDIGIT + DOUBLE PRECISION DIGIT + + CHARACTER K + INTEGER NCHAR + +* Character/vector tables + INTEGER NCREC + PARAMETER (NCREC=19) + CHARACTER KCTAB(NCREC) + INTEGER KVTAB(NCREC) + DATA KCTAB/'0','1','2','3','4','5','6','7','8','9', + : ' ','D','d','E','e','.','+','-',','/ + DATA KVTAB/10*1,2,4*3,4,5,6,7/ + + +* Handle pointer outside field + IF (NPTR.LT.1.OR.NPTR.GT.LEN(STRING)) THEN + NVEC=9 + ELSE + +* Not end of field: identify the character + K=STRING(NPTR:NPTR) + DO NCHAR=1,NCREC + IF (K.EQ.KCTAB(NCHAR)) THEN + +* Recognized + NVEC=KVTAB(NCHAR) + NDIGIT=NCHAR-1 + DIGIT=DBLE(NDIGIT) + GO TO 2300 + END IF + END DO + +* Not recognized: check for TAB !!! n.b. ASCII assumed !!! + IF (K.EQ.CHAR(9)) THEN + +* TAB: treat as space + NVEC=2 + ELSE + +* Unrecognized + NVEC=8 + END IF + +* Increment pointer + 2300 CONTINUE + NPTR=NPTR+1 + END IF + + END diff --git a/math/slalib/idchi.f b/math/slalib/idchi.f new file mode 100644 index 00000000..99f8392d --- /dev/null +++ b/math/slalib/idchi.f @@ -0,0 +1,109 @@ + SUBROUTINE slICHI (STRING, NPTR, NVEC, DIGIT) +*+ +* - - - - - - +* I C H I +* - - - - - - +* +* Internal routine used by INTIN +* +* Identify next character in string +* +* Given: +* STRING char string +* NPTR int pointer to character to be identified +* +* Returned: +* NPTR int incremented unless end of field +* NVEC int vector for identified character +* DIGIT double double precision digit if 0-9 +* +* NVEC takes the following values: +* +* 1 0-9 +* 2 space or TAB !!! n.b. ASCII TAB assumed !!! +* 3 + +* 4 - +* 5 , +* 6 else +* 7 outside string +* +* If the character is not 0-9, DIGIT is either unaltered or +* is set to an arbitrary value. +* +* P.T.Wallace Starlink 22 December 1992 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NPTR,NVEC + DOUBLE PRECISION DIGIT + + CHARACTER K + INTEGER NCHAR + +* Character/vector tables + INTEGER NCREC + PARAMETER (NCREC=14) + CHARACTER KCTAB(NCREC) + INTEGER KVTAB(NCREC) + DATA KCTAB/'0','1','2','3','4','5','6','7','8','9', + : ' ', '+','-',','/ + DATA KVTAB/10*1,2,3,4,5/ + + + +* Handle pointer outside field + IF (NPTR.LT.1.OR.NPTR.GT.LEN(STRING)) THEN + NVEC=7 + ELSE + +* Not end of field: identify character + K=STRING(NPTR:NPTR) + DO NCHAR=1,NCREC + IF (K.EQ.KCTAB(NCHAR)) THEN + +* Recognized + NVEC=KVTAB(NCHAR) + DIGIT=DBLE(NCHAR-1) + GO TO 2300 + END IF + END DO + +* Not recognized: check for TAB !!! n.b. ASCII assumed !!! + IF (K.EQ.CHAR(9)) THEN + +* TAB: treat as space + NVEC=2 + ELSE + +* Unrecognized + NVEC=6 + END IF + +* Increment pointer + 2300 CONTINUE + NPTR=NPTR+1 + END IF + + END diff --git a/math/slalib/imxv.f b/math/slalib/imxv.f new file mode 100644 index 00000000..804adef7 --- /dev/null +++ b/math/slalib/imxv.f @@ -0,0 +1,69 @@ + SUBROUTINE slIMXV (RM, VA, VB) +*+ +* - - - - - +* I M X V +* - - - - - +* +* Performs the 3-D backward unitary transformation: +* +* vector VB = (inverse of matrix RM) * vector VA +* +* (single precision) +* +* (n.b. the matrix must be unitary, as this routine assumes that +* the inverse and transpose are identical) +* +* Given: +* RM real(3,3) matrix +* VA real(3) vector +* +* Returned: +* VB real(3) result vector +* +* P.T.Wallace Starlink November 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL RM(3,3),VA(3),VB(3) + + INTEGER I,J + REAL W,VW(3) + + + +* Inverse of matrix RM * vector VA -> vector VW + DO J=1,3 + W=0.0 + DO I=1,3 + W=W+RM(I,J)*VA(I) + END DO + VW(J)=W + END DO + +* Vector VW -> vector VB + DO J=1,3 + VB(J)=VW(J) + END DO + + END diff --git a/math/slalib/intin.f b/math/slalib/intin.f new file mode 100644 index 00000000..669cb18d --- /dev/null +++ b/math/slalib/intin.f @@ -0,0 +1,194 @@ + SUBROUTINE slINTI (STRING, NSTRT, IRESLT, JFLAG) +*+ +* - - - - - - +* I N T I +* - - - - - - +* +* Convert free-format input into an integer +* +* Given: +* STRING c string containing number to be decoded +* NSTRT i pointer to where decoding is to start +* IRESLT i current value of result +* +* Returned: +* NSTRT i advanced to next number +* IRESLT i result +* JFLAG i status: -1 = -OK, 0 = +OK, 1 = null, 2 = error +* +* Called: slICHI +* +* Notes: +* +* 1 The reason INTIN has separate OK status values for + +* and - is to enable minus zero to be detected. This is +* of crucial importance when decoding mixed-radix numbers. +* For example, an angle expressed as deg, arcmin, arcsec +* may have a leading minus sign but a zero degrees field. +* +* 2 A TAB is interpreted as a space. +* +* 3 The basic format is the sequence of fields #^, where +* # is a sign character + or -, and ^ means a string of +* decimal digits. +* +* 4 Spaces: +* +* . Leading spaces are ignored. +* +* . Spaces between the sign and the number are allowed. +* +* . Trailing spaces are ignored; the first signifies +* end of decoding and subsequent ones are skipped. +* +* 5 Delimiters: +* +* . Any character other than +,-,0-9 or space may be +* used to signal the end of the number and terminate +* decoding. +* +* . Comma is recognized by INTIN as a special case; it +* is skipped, leaving the pointer on the next character. +* See 9, below. +* +* 6 The sign is optional. The default is +. +* +* 7 A "null result" occurs when the string of characters being +* decoded does not begin with +,- or 0-9, or consists +* entirely of spaces. When this condition is detected, JFLAG +* is set to 1 and IRESLT is left untouched. +* +* 8 NSTRT = 1 for the first character in the string. +* +* 9 On return from INTIN, NSTRT is set ready for the next +* decode - following trailing blanks and any comma. If a +* delimiter other than comma is being used, NSTRT must be +* incremented before the next call to INTIN, otherwise +* all subsequent calls will return a null result. +* +* 10 Errors (JFLAG=2) occur when: +* +* . there is a + or - but no number; or +* +* . the number is greater than BIG (defined below). +* +* 11 When an error has been detected, NSTRT is left +* pointing to the character following the last +* one used before the error came to light. +* +* 12 See also FLOTIN and DFLTIN. +* +* P.T.Wallace Starlink 27 April 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) STRING + INTEGER NSTRT,IRESLT,JFLAG + +* Maximum allowed value + DOUBLE PRECISION BIG + PARAMETER (BIG=2147483647D0) + + INTEGER JPTR,MSIGN,NVEC,J + DOUBLE PRECISION DRES,DIGIT + + + +* Current character + JPTR=NSTRT + +* Set defaults + DRES=0D0 + MSIGN=1 + +* Look for sign + 100 CONTINUE + CALL slICHI(STRING,JPTR,NVEC,DIGIT) + GO TO ( 400, 100, 300, 200, 9110, 9100, 9110),NVEC +* 0-9 SP + - , ELSE END + +* Negative + 200 CONTINUE + MSIGN=-1 + +* Look for first decimal + 300 CONTINUE + CALL slICHI(STRING,JPTR,NVEC,DIGIT) + GO TO ( 400, 300, 9200, 9200, 9200, 9200, 9210),NVEC +* 0-9 SP + - , ELSE END + +* Accept decimals + 400 CONTINUE + DRES=DRES*1D1+DIGIT + +* Test for overflow + IF (DRES.GT.BIG) GO TO 9200 + +* Look for subsequent decimals + CALL slICHI(STRING,JPTR,NVEC,DIGIT) + GO TO ( 400, 1610, 1600, 1600, 1600, 1600, 1610),NVEC +* 0-9 SP + - , ELSE END + +* Get result & status + 1600 CONTINUE + JPTR=JPTR-1 + 1610 CONTINUE + J=0 + IF (MSIGN.EQ.1) GO TO 1620 + J=-1 + DRES=-DRES + 1620 CONTINUE + IRESLT=NINT(DRES) + +* Skip to end of field + 1630 CONTINUE + CALL slICHI(STRING,JPTR,NVEC,DIGIT) + GO TO (1720, 1630, 1720, 1720, 9900, 1720, 9900),NVEC +* 0-9 SP + - , ELSE END + + 1720 CONTINUE + JPTR=JPTR-1 + GO TO 9900 + +* Exits + +* Null field + 9100 CONTINUE + JPTR=JPTR-1 + 9110 CONTINUE + J=1 + GO TO 9900 + +* Errors + 9200 CONTINUE + JPTR=JPTR-1 + 9210 CONTINUE + J=2 + +* Return + 9900 CONTINUE + NSTRT=JPTR + JFLAG=J + + END diff --git a/math/slalib/invf.f b/math/slalib/invf.f new file mode 100644 index 00000000..90eb83b9 --- /dev/null +++ b/math/slalib/invf.f @@ -0,0 +1,106 @@ + SUBROUTINE slINVF (FWDS,BKWDS,J) +*+ +* - - - - - +* I N V F +* - - - - - +* +* Invert a linear model of the type produced by the slFTXY routine. +* +* Given: +* FWDS d(6) model coefficients +* +* Returned: +* BKWDS d(6) inverse model +* J i status: 0 = OK, -1 = no inverse +* +* The models relate two sets of [X,Y] coordinates as follows. +* Naming the elements of FWDS: +* +* FWDS(1) = A +* FWDS(2) = B +* FWDS(3) = C +* FWDS(4) = D +* FWDS(5) = E +* FWDS(6) = F +* +* where two sets of coordinates [X1,Y1] and [X2,Y1] are related +* thus: +* +* X2 = A + B*X1 + C*Y1 +* Y2 = D + E*X1 + F*Y1 +* +* the present routine generates a new set of coefficients: +* +* BKWDS(1) = P +* BKWDS(2) = Q +* BKWDS(3) = R +* BKWDS(4) = S +* BKWDS(5) = T +* BKWDS(6) = U +* +* such that: +* +* X1 = P + Q*X2 + R*Y2 +* Y1 = S + T*X2 + U*Y2 +* +* Two successive calls to slINVF will thus deliver a set +* of coefficients equal to the starting values. +* +* To comply with the ANSI Fortran standard, FWDS and BKWDS must +* not be the same array, even though the routine is coded to +* work on many platforms even if this rule is violated. +* +* See also slFTXY, slPXY, slXYXY, slDCMF +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION FWDS(6),BKWDS(6) + INTEGER J + + DOUBLE PRECISION A,B,C,D,E,F,DET + + + + A=FWDS(1) + B=FWDS(2) + C=FWDS(3) + D=FWDS(4) + E=FWDS(5) + F=FWDS(6) + DET=B*F-C*E + IF (DET.NE.0D0) THEN + BKWDS(1)=(C*D-A*F)/DET + BKWDS(2)=F/DET + BKWDS(3)=-C/DET + BKWDS(4)=(A*E-B*D)/DET + BKWDS(5)=-E/DET + BKWDS(6)=B/DET + J=0 + ELSE + J=-1 + END IF + + END diff --git a/math/slalib/kbj.f b/math/slalib/kbj.f new file mode 100644 index 00000000..6d68a069 --- /dev/null +++ b/math/slalib/kbj.f @@ -0,0 +1,74 @@ + SUBROUTINE slKBJ (JB, E, K, J) +*+ +* - - - - +* K B J +* - - - - +* +* Select epoch prefix 'B' or 'J' +* +* Given: +* JB int slDBJI prefix status: 0=none, 1='B', 2='J' +* E dp epoch - Besselian or Julian +* +* Returned: +* K char 'B' or 'J' +* J int status: 0=OK +* +* If JB=0, B is assumed for E < 1984D0, otherwise J. +* +* P.T.Wallace Starlink 31 July 1989 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER JB + DOUBLE PRECISION E + CHARACTER K*(*) + INTEGER J + +* Preset status + J=0 + +* If prefix given expressly, use it + IF (JB.EQ.1) THEN + K='B' + ELSE IF (JB.EQ.2) THEN + K='J' + +* If no prefix, examine the epoch + ELSE IF (JB.EQ.0) THEN + +* If epoch is pre-1984.0, assume Besselian; otherwise Julian + IF (E.LT.1984D0) THEN + K='B' + ELSE + K='J' + END IF + +* If illegal prefix, return error status + ELSE + K=' ' + J=1 + END IF + + END diff --git a/math/slalib/m2av.f b/math/slalib/m2av.f new file mode 100644 index 00000000..7e2e0cdb --- /dev/null +++ b/math/slalib/m2av.f @@ -0,0 +1,75 @@ + SUBROUTINE slM2AV (RMAT, AXVEC) +*+ +* - - - - - +* M 2 A V +* - - - - - +* +* From a rotation matrix, determine the corresponding axial vector +* (single precision) +* +* A rotation matrix describes a rotation about some arbitrary axis, +* called the Euler axis. The "axial vector" returned by this routine +* has the same direction as the Euler axis, and its magnitude is the +* amount of rotation in radians. (The magnitude and direction can be +* separated by means of the routine slVN.) +* +* Given: +* RMAT r(3,3) rotation matrix +* +* Returned: +* AXVEC r(3) axial vector (radians) +* +* The reference frame rotates clockwise as seen looking along +* the axial vector from the origin. +* +* If RMAT is null, so is the result. +* +* Last revision: 26 November 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL RMAT(3,3),AXVEC(3) + + REAL X,Y,Z,S2,C2,PHI,F + + + + X = RMAT(2,3)-RMAT(3,2) + Y = RMAT(3,1)-RMAT(1,3) + Z = RMAT(1,2)-RMAT(2,1) + S2 = SQRT(X*X+Y*Y+Z*Z) + IF (S2.NE.0.0) THEN + C2 = (RMAT(1,1)+RMAT(2,2)+RMAT(3,3)-1.0) + PHI = ATAN2(S2/2.0,C2/2.0) + F = PHI/S2 + AXVEC(1) = X*F + AXVEC(2) = Y*F + AXVEC(3) = Z*F + ELSE + AXVEC(1) = 0.0 + AXVEC(2) = 0.0 + AXVEC(3) = 0.0 + END IF + + END diff --git a/math/slalib/map.f b/math/slalib/map.f new file mode 100644 index 00000000..5c019fcd --- /dev/null +++ b/math/slalib/map.f @@ -0,0 +1,99 @@ + SUBROUTINE slMAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA) +*+ +* - - - - +* M A P +* - - - - +* +* Transform star RA,Dec from mean place to geocentric apparent +* +* The reference frames and timescales used are post IAU 1976. +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Given: +* RM,DM dp mean RA,Dec (rad) +* PR,PD dp proper motions: RA,Dec changes per Julian year +* PX dp parallax (arcsec) +* RV dp radial velocity (km/sec, +ve if receding) +* EQ dp epoch and equinox of star data (Julian) +* DATE dp TDB for apparent place (JD-2400000.5) +* +* Returned: +* RA,DA dp apparent RA,Dec (rad) +* +* Called: +* slMAPA star-independent parameters +* slMAPQ quick mean to apparent +* +* Notes: +* +* 1) EQ is the Julian epoch specifying both the reference frame and +* the epoch of the position - usually 2000. For positions where +* the epoch and equinox are different, use the routine slPM to +* apply proper motion corrections before using this routine. +* +* 2) The distinction between the required TDB and TT is always +* negligible. Moreover, for all but the most critical +* applications UTC is adequate. +* +* 3) The proper motions in RA are dRA/dt rather than cos(Dec)*dRA/dt. +* +* 4) This routine may be wasteful for some applications because it +* recomputes the Earth position/velocity and the precession- +* nutation matrix each time, and because it allows for parallax +* and proper motion. Where multiple transformations are to be +* carried out for one epoch, a faster method is to call the +* slMAPA routine once and then either the slMAPQ routine +* (which includes parallax and proper motion) or slMAPZ (which +* assumes zero parallax and proper motion). +* +* 5) The accuracy is sub-milliarcsecond, limited by the +* precession-nutation model (IAU 1976 precession, Shirai & +* Fukushima 2001 forced nutation and precession corrections). +* +* 6) The accuracy is further limited by the routine slEVP, called +* by slMAPA, which computes the Earth position and velocity +* using the methods of Stumpff. The maximum error is about +* 0.3 mas. +* +* P.T.Wallace Starlink 17 September 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RM,DM,PR,PD,PX,RV,EQ,DATE,RA,DA + + DOUBLE PRECISION AMPRMS(21) + + + +* Star-independent parameters + CALL slMAPA(EQ,DATE,AMPRMS) + +* Mean to apparent + CALL slMAPQ(RM,DM,PR,PD,PX,RV,AMPRMS,RA,DA) + + END diff --git a/math/slalib/mappa.f b/math/slalib/mappa.f new file mode 100644 index 00000000..d3d9c2ae --- /dev/null +++ b/math/slalib/mappa.f @@ -0,0 +1,129 @@ + SUBROUTINE slMAPA (EQ, DATE, AMPRMS) +*+ +* - - - - - - +* M A P A +* - - - - - - +* +* Compute star-independent parameters in preparation for +* conversions between mean place and geocentric apparent place. +* +* The parameters produced by this routine are required in the +* parallax, light deflection, aberration, and precession/nutation +* parts of the mean/apparent transformations. +* +* The reference frames and timescales used are post IAU 1976. +* +* Given: +* EQ d epoch of mean equinox to be used (Julian) +* DATE d TDB (JD-2400000.5) +* +* Returned: +* AMPRMS d(21) star-independent mean-to-apparent parameters: +* +* (1) time interval for proper motion (Julian years) +* (2-4) barycentric position of the Earth (AU) +* (5-7) heliocentric direction of the Earth (unit vector) +* (8) (grav rad Sun)*2/(Sun-Earth distance) +* (9-11) ABV: barycentric Earth velocity in units of c +* (12) sqrt(1-v**2) where v=modulus(ABV) +* (13-21) precession/nutation (3,3) matrix +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Notes: +* +* 1) For DATE, the distinction between the required TDB and TT +* is always negligible. Moreover, for all but the most +* critical applications UTC is adequate. +* +* 2) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to +* the mean equinox and equator of epoch EQ. +* +* 3) The parameters AMPRMS produced by this routine are used by +* slAMPQ, slMAPQ and slMAPZ. +* +* 4) The accuracy is sub-milliarcsecond, limited by the +* precession-nutation model (IAU 1976 precession, Shirai & +* Fukushima 2001 forced nutation and precession corrections). +* +* 5) A further limit to the accuracy of routines using the parameter +* array AMPRMS is imposed by the routine slEVP, used here to +* compute the Earth position and velocity by the methods of +* Stumpff. The maximum error in the resulting aberration +* corrections is about 0.3 milliarcsecond. +* +* Called: +* slEPJ MDJ to Julian epoch +* slEVP earth position & velocity +* slDVN normalize vector +* slPRNU precession/nutation matrix +* +* P.T.Wallace Starlink 24 October 2003 +* +* Copyright (C) 2003 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EQ,DATE,AMPRMS(21) + +* Light time for 1 AU (sec) + DOUBLE PRECISION CR + PARAMETER (CR=499.004782D0) + +* Gravitational radius of the Sun x 2 (2*mu/c**2, AU) + DOUBLE PRECISION GR2 + PARAMETER (GR2=2D0*9.87063D-9) + + INTEGER I + + DOUBLE PRECISION EBD(3),EHD(3),EH(3),E,VN(3),VM + + DOUBLE PRECISION slEPJ + + + +* Time interval for proper motion correction + AMPRMS(1) = slEPJ(DATE)-EQ + +* Get Earth barycentric and heliocentric position and velocity + CALL slEVP(DATE,EQ,EBD,AMPRMS(2),EHD,EH) + +* Heliocentric direction of earth (normalized) and modulus + CALL slDVN(EH,AMPRMS(5),E) + +* Light deflection parameter + AMPRMS(8) = GR2/E + +* Aberration parameters + DO I=1,3 + AMPRMS(I+8) = EBD(I)*CR + END DO + CALL slDVN(AMPRMS(9),VN,VM) + AMPRMS(12) = SQRT(1D0-VM*VM) + +* Precession/nutation matrix + CALL slPRNU(EQ,DATE,AMPRMS(13)) + + END diff --git a/math/slalib/mapqk.f b/math/slalib/mapqk.f new file mode 100644 index 00000000..0e1997ff --- /dev/null +++ b/math/slalib/mapqk.f @@ -0,0 +1,160 @@ + SUBROUTINE slMAPQ (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA) +*+ +* - - - - - - +* M A P Q +* - - - - - - +* +* Quick mean to apparent place: transform a star RA,Dec from +* mean place to geocentric apparent place, given the +* star-independent parameters. +* +* Use of this routine is appropriate when efficiency is important +* and where many star positions, all referred to the same equator +* and equinox, are to be transformed for one epoch. The +* star-independent parameters can be obtained by calling the +* slMAPA routine. +* +* If the parallax and proper motions are zero the slMAPZ +* routine can be used instead. +* +* The reference frames and timescales used are post IAU 1976. +* +* Given: +* RM,DM d mean RA,Dec (rad) +* PR,PD d proper motions: RA,Dec changes per Julian year +* PX d parallax (arcsec) +* RV d radial velocity (km/sec, +ve if receding) +* +* AMPRMS d(21) star-independent mean-to-apparent parameters: +* +* (1) time interval for proper motion (Julian years) +* (2-4) barycentric position of the Earth (AU) +* (5-7) heliocentric direction of the Earth (unit vector) +* (8) (grav rad Sun)*2/(Sun-Earth distance) +* (9-11) barycentric Earth velocity in units of c +* (12) sqrt(1-v**2) where v=modulus(ABV) +* (13-21) precession/nutation (3,3) matrix +* +* Returned: +* RA,DA d apparent RA,Dec (rad) +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Notes: +* +* 1) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to +* the mean equinox and equator of epoch EQ. +* +* 2) Strictly speaking, the routine is not valid for solar-system +* sources, though the error will usually be extremely small. +* However, to prevent gross errors in the case where the +* position of the Sun is specified, the gravitational +* deflection term is restrained within about 920 arcsec of the +* centre of the Sun's disc. The term has a maximum value of +* about 1.85 arcsec at this radius, and decreases to zero as +* the centre of the disc is approached. +* +* Called: +* slDS2C spherical to Cartesian +* slDVDV dot product +* slDMXV matrix x vector +* slDC2S Cartesian to spherical +* slDA2P normalize angle 0-2Pi +* +* P.T.Wallace Starlink 15 January 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RM,DM,PR,PD,PX,RV,AMPRMS(21),RA,DA + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + +* Km/s to AU/year + DOUBLE PRECISION VF + PARAMETER (VF=0.21094502D0) + + INTEGER I + + DOUBLE PRECISION PMT,GR2E,AB1,EB(3),EHN(3),ABV(3), + : Q(3),PXR,W,EM(3),P(3),PN(3),PDE,PDEP1, + : P1(3),P1DV,P2(3),P3(3) + + DOUBLE PRECISION slDVDV,slDA2P + + + +* Unpack scalar and vector parameters + PMT = AMPRMS(1) + GR2E = AMPRMS(8) + AB1 = AMPRMS(12) + DO I=1,3 + EB(I) = AMPRMS(I+1) + EHN(I) = AMPRMS(I+4) + ABV(I) = AMPRMS(I+8) + END DO + +* Spherical to x,y,z + CALL slDS2C(RM,DM,Q) + +* Space motion (radians per year) + PXR = PX*AS2R + W = VF*RV*PXR + EM(1) = -PR*Q(2)-PD*COS(RM)*SIN(DM)+W*Q(1) + EM(2) = PR*Q(1)-PD*SIN(RM)*SIN(DM)+W*Q(2) + EM(3) = PD*COS(DM) +W*Q(3) + +* Geocentric direction of star (normalized) + DO I=1,3 + P(I) = Q(I)+PMT*EM(I)-PXR*EB(I) + END DO + CALL slDVN(P,PN,W) + +* Light deflection (restrained within the Sun's disc) + PDE = slDVDV(PN,EHN) + PDEP1 = PDE+1D0 + W = GR2E/MAX(PDEP1,1D-5) + DO I=1,3 + P1(I) = PN(I)+W*(EHN(I)-PDE*PN(I)) + END DO + +* Aberration (normalization omitted) + P1DV = slDVDV(P1,ABV) + W = 1D0+P1DV/(AB1+1D0) + DO I=1,3 + P2(I) = AB1*P1(I)+W*ABV(I) + END DO + +* Precession and nutation + CALL slDMXV(AMPRMS(13),P2,P3) + +* Geocentric apparent RA,Dec + CALL slDC2S(P3,RA,DA) + RA = slDA2P(RA) + + END diff --git a/math/slalib/mapqkz.f b/math/slalib/mapqkz.f new file mode 100644 index 00000000..6409b22e --- /dev/null +++ b/math/slalib/mapqkz.f @@ -0,0 +1,131 @@ + SUBROUTINE slMAPZ (RM, DM, AMPRMS, RA, DA) +*+ +* - - - - - - - +* M A P Z +* - - - - - - - +* +* Quick mean to apparent place: transform a star RA,Dec from +* mean place to geocentric apparent place, given the +* star-independent parameters, and assuming zero parallax +* and proper motion. +* +* Use of this routine is appropriate when efficiency is important +* and where many star positions, all with parallax and proper +* motion either zero or already allowed for, and all referred to +* the same equator and equinox, are to be transformed for one +* epoch. The star-independent parameters can be obtained by +* calling the slMAPA routine. +* +* The corresponding routine for the case of non-zero parallax +* and proper motion is slMAPQ. +* +* The reference frames and timescales used are post IAU 1976. +* +* Given: +* RM,DM d mean RA,Dec (rad) +* AMPRMS d(21) star-independent mean-to-apparent parameters: +* +* (1-4) not used +* (5-7) heliocentric direction of the Earth (unit vector) +* (8) (grav rad Sun)*2/(Sun-Earth distance) +* (9-11) ABV: barycentric Earth velocity in units of c +* (12) sqrt(1-v**2) where v=modulus(ABV) +* (13-21) precession/nutation (3,3) matrix +* +* Returned: +* RA,DA d apparent RA,Dec (rad) +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Notes: +* +* 1) The vectors AMPRMS(2-4) and AMPRMS(5-7) are referred to the +* mean equinox and equator of epoch EQ. +* +* 2) Strictly speaking, the routine is not valid for solar-system +* sources, though the error will usually be extremely small. +* However, to prevent gross errors in the case where the +* position of the Sun is specified, the gravitational +* deflection term is restrained within about 920 arcsec of the +* centre of the Sun's disc. The term has a maximum value of +* about 1.85 arcsec at this radius, and decreases to zero as +* the centre of the disc is approached. +* +* Called: slDS2C, slDVDV, slDMXV, slDC2S, slDA2P +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RM,DM,AMPRMS(21),RA,DA + + INTEGER I + + DOUBLE PRECISION GR2E,AB1,EHN(3),ABV(3), + : P(3),PDE,PDEP1,W,P1(3),P1DV, + : P1DVP1,P2(3),P3(3) + + DOUBLE PRECISION slDVDV,slDA2P + + + + +* Unpack scalar and vector parameters + GR2E = AMPRMS(8) + AB1 = AMPRMS(12) + DO I=1,3 + EHN(I) = AMPRMS(I+4) + ABV(I) = AMPRMS(I+8) + END DO + +* Spherical to x,y,z + CALL slDS2C(RM,DM,P) + +* Light deflection + PDE = slDVDV(P,EHN) + PDEP1 = PDE+1D0 + W = GR2E/MAX(PDEP1,1D-5) + DO I=1,3 + P1(I) = P(I)+W*(EHN(I)-PDE*P(I)) + END DO + +* Aberration + P1DV = slDVDV(P1,ABV) + P1DVP1 = P1DV+1D0 + W = 1D0+P1DV/(AB1+1D0) + DO I=1,3 + P2(I) = (AB1*P1(I)+W*ABV(I))/P1DVP1 + END DO + +* Precession and nutation + CALL slDMXV(AMPRMS(13),P2,P3) + +* Geocentric apparent RA,Dec + CALL slDC2S(P3,RA,DA) + RA = slDA2P(RA) + + END diff --git a/math/slalib/mkpkg b/math/slalib/mkpkg new file mode 100644 index 00000000..d2f9203b --- /dev/null +++ b/math/slalib/mkpkg @@ -0,0 +1,193 @@ +# SLALIB library routines + +$checkout libslalib.a lib$ +$update libslalib.a +$checkin libslalib.a lib$ +$exit + +libslalib.a: + addet.f + afin.f + airmas.f + altaz.f + amp.f + ampqk.f + aop.f + aoppa.f + aoppat.f + aopqk.f + atmdsp.f + atms.f + atmt.f + av2m.f + bear.f + caf2r.f + caldj.f + calyd.f + cc2s.f + cc62s.f + cd2tf.f + cldj.f + clyd.f + cr2af.f + cr2tf.f + cs2c.f + cs2c6.f + ctf2d.f + ctf2r.f + daf2r.f + dafin.f + dat.f + dav2m.f + dbear.f + dbjin.f + dc62s.f + dcc2s.f + dcmpf.f + dcs2c.f + dd2tf.f + de2h.f + deuler.f + dfltin.f + dh2e.f + dimxv.f + djcal.f + djcl.f + dm2av.f + dmat.f + dmoon.f + dmxm.f + dmxv.f + dpav.f + dr2af.f + dr2tf.f + drange.f + dranrm.f + ds2c6.f + ds2tp.f + dsep.f + dsepv.f + dt.f + dtf2d.f + dtf2r.f + dtp2s.f + dtp2v.f + dtps2c.f + dtpv2c.f + dtt.f + dv2tp.f + dvdv.f + dvn.f + dvxv.f + e2h.f + earth.f + ecleq.f + ecmat.f + ecor.f + eg50.f + el2ue.f + epb.f + epb2d.f + epco.f + epj.f + epj2d.f + eqecl.f + eqeqx.f + eqgal.f + etrms.f + euler.f + evp.f + fitxy.f + fk425.f + fk45z.f + fk524.f + fk54z.f + fk52h.f + fk5hz.f + flotin.f + galeq.f + galsup.f + ge50.f + geoc.f + gmst.f + gmsta.f + h2e.f + h2fk5.f + hfk5z.f + idchf.f + idchi.f + imxv.f + intin.f + invf.f + kbj.f + m2av.f + map.f + mappa.f + mapqk.f + mapqkz.f + moon.f + mxm.f + mxv.f + nut.f + nutc.f + oap.f + oapqk.f + obs.f + pa.f + pav.f + pcd.f + pda2h.f + pdq2h.f + pertel.f + pertue.f + planel.f + planet.f + plante.f + pm.f + polmo.f + prebn.f + prec.f + preces.f + precl.f + precss.f # preces.f with an integer system argument + prenut.f + pv2ue.f + pv2el.f + pvobs.f + pxy.f + range.f + ranorm.f + rcc.f + rdplan.f + refco.f + refcoq.f + refro.f + refv.f + refz.f + rverot.f + rvgalc.f + rvlg.f + rvlsrd.f + rvlsrk.f + s2tp.f + sep.f + smat.f + subet.f + supgal.f + svd.f + svdcov.f + svdsol.f + tp2s.f + tp2v.f + tps2c.f + tpv2c.f + ue2el.f + ue2pv.f + unpcd.f + v2tp.f + vdv.f + vn.f + vxv.f + xy2xy.f + zd.f + ; diff --git a/math/slalib/moon.f b/math/slalib/moon.f new file mode 100644 index 00000000..c77395ee --- /dev/null +++ b/math/slalib/moon.f @@ -0,0 +1,380 @@ + SUBROUTINE slMOON (IY, ID, FD, PV) +*+ +* - - - - - +* M O O N +* - - - - - +* +* Approximate geocentric position and velocity of the Moon +* (single precision). +* +* Given: +* IY i year +* ID i day in year (1 = Jan 1st) +* FD r fraction of day +* +* Returned: +* PV r(6) Moon position & velocity vector +* +* Notes: +* +* 1 The date and time is TDB (loosely ET) in a Julian calendar +* which has been aligned to the ordinary Gregorian +* calendar for the interval 1900 March 1 to 2100 February 28. +* The year and day can be obtained by calling slCAYD or +* slCLYD. +* +* 2 The Moon 6-vector is Moon centre relative to Earth centre, +* mean equator and equinox of date. Position part, PV(1-3), +* is in AU; velocity part, PV(4-6), is in AU/sec. +* +* 3 The position is accurate to better than 0.5 arcminute +* in direction and 1000 km in distance. The velocity +* is accurate to better than 0.5"/hour in direction and +* 4 m/s in distance. (RMS figures with respect to JPL DE200 +* for the interval 1960-2025 are 14 arcsec and 0.2 arcsec/hour in +* longitude, 9 arcsec and 0.2 arcsec/hour in latitude, 350 km and +* 2 m/s in distance.) Note that the distance accuracy is +* comparatively poor because this routine is principally intended +* for computing topocentric direction. +* +* 4 This routine is only a partial implementation of the original +* Meeus algorithm (reference below), which offers 4 times the +* accuracy in direction and 30 times the accuracy in distance +* when fully implemented (as it is in slDMON). +* +* Reference: +* Meeus, l'Astronomie, June 1984, p348. +* +* Called: slS2C6 +* +* P.T.Wallace Starlink 8 December 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IY,ID + REAL FD,PV(6) + + INTEGER ITP(4,4),ITL(4,39),ITB(4,29),I,IY4,N + REAL D2R,RATCON,ERADAU + REAL ELP0,ELP1,ELP1I,ELP1F + REAL EM0,EM1,EM1F + REAL EMP0,EMP1,EMP1I,EMP1F + REAL D0,D1,D1I,D1F + REAL F0,F1,F1I,F1F + REAL TL(39) + REAL TB(29) + REAL TP(4) + REAL YI,YF,T,ELP,EM,EMP,D,F,EL,ELD,COEFF,CEM,CEMP + REAL CD,CF,THETA,THETAD,B,BD,P,PD,SP,R,RD + REAL V(6),EPS,SINEPS,COSEPS + +* Degrees to radians + PARAMETER (D2R=1.745329252E-2) + +* Rate conversion factor: D2R**2/(86400*365.25) + PARAMETER (RATCON=9.652743551E-12) + +* Earth radius in AU: 6378.137/149597870 + PARAMETER (ERADAU=4.2635212653763E-5) + +* +* Coefficients for fundamental arguments +* +* Fixed term (deg), term in T (deg & whole revs + fraction per year) +* +* Moon's mean longitude + DATA ELP0,ELP1,ELP1I,ELP1F / + : 270.434164, 4812.678831, 4680., 132.678831 / +* +* Sun's mean anomaly + DATA EM0,EM1,EM1F / + : 358.475833, 359.990498, 359.990498 / +* +* Moon's mean anomaly + DATA EMP0,EMP1,EMP1I,EMP1F / + : 296.104608, 4771.988491, 4680., 91.988491 / +* +* Moon's mean elongation + DATA D0,D1,D1I,D1F / + : 350.737486, 4452.671142, 4320., 132.671142 / +* +* Mean distance of the Moon from its ascending node + DATA F0,F1,F1I,F1F / + : 11.250889, 4832.020251, 4680., 152.020251 / + +* +* Coefficients for Moon position +* +* T(N) = coefficient of term (deg) +* IT(N,1-4) = coefficients of M, M', D, F in argument +* +* Longitude +* M M' D F + DATA TL( 1)/ +6.288750 /, + : (ITL(I, 1),I=1,4)/ 0, +1, 0, 0 / + DATA TL( 2)/ +1.274018 /, + : (ITL(I, 2),I=1,4)/ 0, -1, +2, 0 / + DATA TL( 3)/ +0.658309 /, + : (ITL(I, 3),I=1,4)/ 0, 0, +2, 0 / + DATA TL( 4)/ +0.213616 /, + : (ITL(I, 4),I=1,4)/ 0, +2, 0, 0 / + DATA TL( 5)/ -0.185596 /, + : (ITL(I, 5),I=1,4)/ +1, 0, 0, 0 / + DATA TL( 6)/ -0.114336 /, + : (ITL(I, 6),I=1,4)/ 0, 0, 0, +2 / + DATA TL( 7)/ +0.058793 /, + : (ITL(I, 7),I=1,4)/ 0, -2, +2, 0 / + DATA TL( 8)/ +0.057212 /, + : (ITL(I, 8),I=1,4)/ -1, -1, +2, 0 / + DATA TL( 9)/ +0.053320 /, + : (ITL(I, 9),I=1,4)/ 0, +1, +2, 0 / + DATA TL(10)/ +0.045874 /, + : (ITL(I,10),I=1,4)/ -1, 0, +2, 0 / + DATA TL(11)/ +0.041024 /, + : (ITL(I,11),I=1,4)/ -1, +1, 0, 0 / + DATA TL(12)/ -0.034718 /, + : (ITL(I,12),I=1,4)/ 0, 0, +1, 0 / + DATA TL(13)/ -0.030465 /, + : (ITL(I,13),I=1,4)/ +1, +1, 0, 0 / + DATA TL(14)/ +0.015326 /, + : (ITL(I,14),I=1,4)/ 0, 0, +2, -2 / + DATA TL(15)/ -0.012528 /, + : (ITL(I,15),I=1,4)/ 0, +1, 0, +2 / + DATA TL(16)/ -0.010980 /, + : (ITL(I,16),I=1,4)/ 0, -1, 0, +2 / + DATA TL(17)/ +0.010674 /, + : (ITL(I,17),I=1,4)/ 0, -1, +4, 0 / + DATA TL(18)/ +0.010034 /, + : (ITL(I,18),I=1,4)/ 0, +3, 0, 0 / + DATA TL(19)/ +0.008548 /, + : (ITL(I,19),I=1,4)/ 0, -2, +4, 0 / + DATA TL(20)/ -0.007910 /, + : (ITL(I,20),I=1,4)/ +1, -1, +2, 0 / + DATA TL(21)/ -0.006783 /, + : (ITL(I,21),I=1,4)/ +1, 0, +2, 0 / + DATA TL(22)/ +0.005162 /, + : (ITL(I,22),I=1,4)/ 0, +1, -1, 0 / + DATA TL(23)/ +0.005000 /, + : (ITL(I,23),I=1,4)/ +1, 0, +1, 0 / + DATA TL(24)/ +0.004049 /, + : (ITL(I,24),I=1,4)/ -1, +1, +2, 0 / + DATA TL(25)/ +0.003996 /, + : (ITL(I,25),I=1,4)/ 0, +2, +2, 0 / + DATA TL(26)/ +0.003862 /, + : (ITL(I,26),I=1,4)/ 0, 0, +4, 0 / + DATA TL(27)/ +0.003665 /, + : (ITL(I,27),I=1,4)/ 0, -3, +2, 0 / + DATA TL(28)/ +0.002695 /, + : (ITL(I,28),I=1,4)/ -1, +2, 0, 0 / + DATA TL(29)/ +0.002602 /, + : (ITL(I,29),I=1,4)/ 0, +1, -2, -2 / + DATA TL(30)/ +0.002396 /, + : (ITL(I,30),I=1,4)/ -1, -2, +2, 0 / + DATA TL(31)/ -0.002349 /, + : (ITL(I,31),I=1,4)/ 0, +1, +1, 0 / + DATA TL(32)/ +0.002249 /, + : (ITL(I,32),I=1,4)/ -2, 0, +2, 0 / + DATA TL(33)/ -0.002125 /, + : (ITL(I,33),I=1,4)/ +1, +2, 0, 0 / + DATA TL(34)/ -0.002079 /, + : (ITL(I,34),I=1,4)/ +2, 0, 0, 0 / + DATA TL(35)/ +0.002059 /, + : (ITL(I,35),I=1,4)/ -2, -1, +2, 0 / + DATA TL(36)/ -0.001773 /, + : (ITL(I,36),I=1,4)/ 0, +1, +2, -2 / + DATA TL(37)/ -0.001595 /, + : (ITL(I,37),I=1,4)/ 0, 0, +2, +2 / + DATA TL(38)/ +0.001220 /, + : (ITL(I,38),I=1,4)/ -1, -1, +4, 0 / + DATA TL(39)/ -0.001110 /, + : (ITL(I,39),I=1,4)/ 0, +2, 0, +2 / +* +* Latitude +* M M' D F + DATA TB( 1)/ +5.128189 /, + : (ITB(I, 1),I=1,4)/ 0, 0, 0, +1 / + DATA TB( 2)/ +0.280606 /, + : (ITB(I, 2),I=1,4)/ 0, +1, 0, +1 / + DATA TB( 3)/ +0.277693 /, + : (ITB(I, 3),I=1,4)/ 0, +1, 0, -1 / + DATA TB( 4)/ +0.173238 /, + : (ITB(I, 4),I=1,4)/ 0, 0, +2, -1 / + DATA TB( 5)/ +0.055413 /, + : (ITB(I, 5),I=1,4)/ 0, -1, +2, +1 / + DATA TB( 6)/ +0.046272 /, + : (ITB(I, 6),I=1,4)/ 0, -1, +2, -1 / + DATA TB( 7)/ +0.032573 /, + : (ITB(I, 7),I=1,4)/ 0, 0, +2, +1 / + DATA TB( 8)/ +0.017198 /, + : (ITB(I, 8),I=1,4)/ 0, +2, 0, +1 / + DATA TB( 9)/ +0.009267 /, + : (ITB(I, 9),I=1,4)/ 0, +1, +2, -1 / + DATA TB(10)/ +0.008823 /, + : (ITB(I,10),I=1,4)/ 0, +2, 0, -1 / + DATA TB(11)/ +0.008247 /, + : (ITB(I,11),I=1,4)/ -1, 0, +2, -1 / + DATA TB(12)/ +0.004323 /, + : (ITB(I,12),I=1,4)/ 0, -2, +2, -1 / + DATA TB(13)/ +0.004200 /, + : (ITB(I,13),I=1,4)/ 0, +1, +2, +1 / + DATA TB(14)/ +0.003372 /, + : (ITB(I,14),I=1,4)/ -1, 0, -2, +1 / + DATA TB(15)/ +0.002472 /, + : (ITB(I,15),I=1,4)/ -1, -1, +2, +1 / + DATA TB(16)/ +0.002222 /, + : (ITB(I,16),I=1,4)/ -1, 0, +2, +1 / + DATA TB(17)/ +0.002072 /, + : (ITB(I,17),I=1,4)/ -1, -1, +2, -1 / + DATA TB(18)/ +0.001877 /, + : (ITB(I,18),I=1,4)/ -1, +1, 0, +1 / + DATA TB(19)/ +0.001828 /, + : (ITB(I,19),I=1,4)/ 0, -1, +4, -1 / + DATA TB(20)/ -0.001803 /, + : (ITB(I,20),I=1,4)/ +1, 0, 0, +1 / + DATA TB(21)/ -0.001750 /, + : (ITB(I,21),I=1,4)/ 0, 0, 0, +3 / + DATA TB(22)/ +0.001570 /, + : (ITB(I,22),I=1,4)/ -1, +1, 0, -1 / + DATA TB(23)/ -0.001487 /, + : (ITB(I,23),I=1,4)/ 0, 0, +1, +1 / + DATA TB(24)/ -0.001481 /, + : (ITB(I,24),I=1,4)/ +1, +1, 0, +1 / + DATA TB(25)/ +0.001417 /, + : (ITB(I,25),I=1,4)/ -1, -1, 0, +1 / + DATA TB(26)/ +0.001350 /, + : (ITB(I,26),I=1,4)/ -1, 0, 0, +1 / + DATA TB(27)/ +0.001330 /, + : (ITB(I,27),I=1,4)/ 0, 0, -1, +1 / + DATA TB(28)/ +0.001106 /, + : (ITB(I,28),I=1,4)/ 0, +3, 0, +1 / + DATA TB(29)/ +0.001020 /, + : (ITB(I,29),I=1,4)/ 0, 0, +4, -1 / +* +* Parallax +* M M' D F + DATA TP( 1)/ +0.051818 /, + : (ITP(I, 1),I=1,4)/ 0, +1, 0, 0 / + DATA TP( 2)/ +0.009531 /, + : (ITP(I, 2),I=1,4)/ 0, -1, +2, 0 / + DATA TP( 3)/ +0.007843 /, + : (ITP(I, 3),I=1,4)/ 0, 0, +2, 0 / + DATA TP( 4)/ +0.002824 /, + : (ITP(I, 4),I=1,4)/ 0, +2, 0, 0 / + + + +* Whole years & fraction of year, and years since J1900.0 + YI=FLOAT(IY-1900) + IY4=MOD(MOD(IY,4)+4,4) + YF=(FLOAT(4*(ID-1/(IY4+1))-IY4-2)+4.0*FD)/1461.0 + T=YI+YF + +* Moon's mean longitude + ELP=D2R*MOD(ELP0+ELP1I*YF+ELP1F*T,360.0) + +* Sun's mean anomaly + EM=D2R*MOD(EM0+EM1F*T,360.0) + +* Moon's mean anomaly + EMP=D2R*MOD(EMP0+EMP1I*YF+EMP1F*T,360.0) + +* Moon's mean elongation + D=D2R*MOD(D0+D1I*YF+D1F*T,360.0) + +* Mean distance of the moon from its ascending node + F=D2R*MOD(F0+F1I*YF+F1F*T,360.0) + +* Longitude + EL=0.0 + ELD=0.0 + DO N=39,1,-1 + COEFF=TL(N) + CEM=FLOAT(ITL(1,N)) + CEMP=FLOAT(ITL(2,N)) + CD=FLOAT(ITL(3,N)) + CF=FLOAT(ITL(4,N)) + THETA=CEM*EM+CEMP*EMP+CD*D+CF*F + THETAD=CEM*EM1+CEMP*EMP1+CD*D1+CF*F1 + EL=EL+COEFF*SIN(THETA) + ELD=ELD+COEFF*COS(THETA)*THETAD + END DO + EL=EL*D2R+ELP + ELD=RATCON*(ELD+ELP1/D2R) + +* Latitude + B=0.0 + BD=0.0 + DO N=29,1,-1 + COEFF=TB(N) + CEM=FLOAT(ITB(1,N)) + CEMP=FLOAT(ITB(2,N)) + CD=FLOAT(ITB(3,N)) + CF=FLOAT(ITB(4,N)) + THETA=CEM*EM+CEMP*EMP+CD*D+CF*F + THETAD=CEM*EM1+CEMP*EMP1+CD*D1+CF*F1 + B=B+COEFF*SIN(THETA) + BD=BD+COEFF*COS(THETA)*THETAD + END DO + B=B*D2R + BD=RATCON*BD + +* Parallax + P=0.0 + PD=0.0 + DO N=4,1,-1 + COEFF=TP(N) + CEM=FLOAT(ITP(1,N)) + CEMP=FLOAT(ITP(2,N)) + CD=FLOAT(ITP(3,N)) + CF=FLOAT(ITP(4,N)) + THETA=CEM*EM+CEMP*EMP+CD*D+CF*F + THETAD=CEM*EM1+CEMP*EMP1+CD*D1+CF*F1 + P=P+COEFF*COS(THETA) + PD=PD-COEFF*SIN(THETA)*THETAD + END DO + P=(P+0.950724)*D2R + PD=RATCON*PD + +* Transform parallax to distance (AU, AU/sec) + SP=SIN(P) + R=ERADAU/SP + RD=-R*PD/SP + +* Longitude, latitude to x,y,z (AU) + CALL slS2C6(EL,B,R,ELD,BD,RD,V) + +* Mean obliquity + EPS=D2R*(23.45229-0.00013*T) + SINEPS=SIN(EPS) + COSEPS=COS(EPS) + +* Rotate Moon position and velocity into equatorial system + PV(1)=V(1) + PV(2)=V(2)*COSEPS-V(3)*SINEPS + PV(3)=V(2)*SINEPS+V(3)*COSEPS + PV(4)=V(4) + PV(5)=V(5)*COSEPS-V(6)*SINEPS + PV(6)=V(5)*SINEPS+V(6)*COSEPS + + END diff --git a/math/slalib/mxm.f b/math/slalib/mxm.f new file mode 100644 index 00000000..1c00c632 --- /dev/null +++ b/math/slalib/mxm.f @@ -0,0 +1,72 @@ + SUBROUTINE slMXM (A, B, C) +*+ +* - - - - +* M X M +* - - - - +* +* Product of two 3x3 matrices: +* matrix C = matrix A x matrix B +* +* (single precision) +* +* Given: +* A real(3,3) matrix +* B real(3,3) matrix +* +* Returned: +* C real(3,3) matrix result +* +* To comply with the ANSI Fortran 77 standard, A, B and C must +* be different arrays. However, the routine is coded so as to +* work properly on many platforms even if this rule is violated. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL A(3,3),B(3,3),C(3,3) + + INTEGER I,J,K + REAL W,WM(3,3) + + +* Multiply into scratch matrix + DO I=1,3 + DO J=1,3 + W=0.0 + DO K=1,3 + W=W+A(I,K)*B(K,J) + END DO + WM(I,J)=W + END DO + END DO + +* Return the result + DO J=1,3 + DO I=1,3 + C(I,J)=WM(I,J) + END DO + END DO + + END diff --git a/math/slalib/mxv.f b/math/slalib/mxv.f new file mode 100644 index 00000000..266c1f85 --- /dev/null +++ b/math/slalib/mxv.f @@ -0,0 +1,69 @@ + SUBROUTINE slMXV (RM, VA, VB) +*+ +* - - - - +* M X V +* - - - - +* +* Performs the 3-D forward unitary transformation: +* +* vector VB = matrix RM * vector VA +* +* (single precision) +* +* Given: +* RM real(3,3) matrix +* VA real(3) vector +* +* Returned: +* VB real(3) result vector +* +* To comply with the ANSI Fortran 77 standard, VA and VB must be +* different arrays. However, the routine is coded so as to work +* properly on many platforms even if this rule is violated. +* +* Last revision: 26 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL RM(3,3),VA(3),VB(3) + + INTEGER I,J + REAL W,VW(3) + + +* Matrix RM * vector VA -> vector VW + DO J=1,3 + W=0.0 + DO I=1,3 + W=W+RM(J,I)*VA(I) + END DO + VW(J)=W + END DO + +* Vector VW -> vector VB + DO J=1,3 + VB(J)=VW(J) + END DO + + END diff --git a/math/slalib/newnames b/math/slalib/newnames new file mode 100644 index 00000000..f91c9c86 --- /dev/null +++ b/math/slalib/newnames @@ -0,0 +1,205 @@ +sla_ADDET slADET +sla_AFIN slAFIN +sla_AIRMAS slARMS +sla_ALTAZ slALAZ +sla_AMP slAMP +sla_AMPQK slAMPQ +sla_AOP slAOP +sla_AOPPA slAOPA +sla_AOPPAT slAOPT +sla_AOPQK slAOPQ +sla__ATMS slATMS +sla__ATMT slATMT +sla_ATMDSP slATMD +sla_AV2M slAV2M + +sla_BEAR slBEAR + +sla_CAF2R slCAFR +sla_CALDJ slCADJ +sla_CALYD slCAYD +sla_CC2S slCC2S +sla_CC62S slC62S +sla_CD2TF slCDTF +sla_CLDJ slCLDJ +sla_CLYD slCLYD +sla_CR2AF slCRAF +sla_CR2TF slCRTF +sla_CS2C slCS2C +sla_CS2C6 slS2C6 +sla_CTF2D slCTFD +sla_CTF2R slCTFR + +sla_DAF2R slDAFR +sla_DAFIN slDAFN +sla_DAT slDAT +sla_DAV2M slDAVM +sla_DBEAR slDBER +sla_DBJIN slDBJI +sla_DC62S slDC6S +sla_DCC2S slDC2S +sla_DCMPF slDCMF +sla_DCS2C slDS2C +sla_DD2TF slDDTF +sla_DE2H slDE2H +sla_DEULER slDEUL +sla_DFLTIN slDFLI +sla_DH2E slDH2E +sla_DIMXV slDIMV +sla_DJCAL slDJCA +sla_DJCL slDJCL +sla_DM2AV slDMAV +sla_DMAT slDMAT +sla_DMOON slDMON +sla_DMXM slDMXM +sla_DMXV slDMXV +sla_DPAV slDPAV +sla_DR2AF slDRAF +sla_DR2TF slDRTF +sla_DRANGE slDA1P +sla_DRANRM slDA2P +sla_DS2C6 slDSC6 +sla_DS2TP slDSTP +sla_DSEP slDSEP +sla_DT slDT +sla_DTF2D slDTFD +sla_DTF2R slDTFR +sla_DTP2S slDTPS +sla_DTP2V slDTPV +sla_DTPS2C slDPSC +sla_DTPV2C slDPVC +sla_DTT slDTT +sla_DV2TP slDVTP +sla_DVDV slDVDV +sla_DVN slDVN +sla_DVXV slDVXV + +sla_E2H slE2H +sla_EARTH slERTH +sla_ECLEQ slECEQ +sla_ECMAT slECMA +sla_ECOR slECOR +sla_EG50 slEG50 +sla_EL2UE slELUE +sla_EPB slEPB +sla_EPB2D slEB2D +sla_EPCO slEPCO +sla_EPJ slEPJ +sla_EPJ2D slEJ2D +sla_EQECL slEQEC +sla_EQEQX slEQEX +sla_EQGAL slEQGA +sla_ETRMS slETRM +sla_EULER slEULR +sla_EVP slEVP + +sla_FITXY slFTXY +sla_FK425 slFK45 +sla_FK45Z slF45Z +sla_FK524 slFK54 +sla_FK52H slFK5H +sla_FK54Z slF54Z +sla_FK5HZ slF5HZ +sla_FLOTIN slRFLI + +sla_GALEQ slGAEQ +sla_GALSUP slGASU +sla_GE50 slGE50 +sla_GEOC slGEOC +sla_GMST slGMST +sla_GMSTA slGMSA +sla_GRESID slGRES + +sla_H2E slH2E +sla_H2FK5 slHFK5 +sla_HFK5Z slHF5Z + +sla__IDCHI slICHI +sla__IDCHF slICHF +sla_IMXV slIMXV +sla_INTIN slINTI +sla_INVF slINVF + +sla_KBJ slKBJ + +sla_M2AV slM2AV +sla_MAP slMAP +sla_MAPPA slMAPA +sla_MAPQK slMAPQ +sla_MAPQKZ slMAPZ +sla_MOON slMOON +sla_MXM slMXM +sla_MXV slMXV + +sla_NUT slNUT +sla_NUTC slNUTC + +sla_OBS slOBS +sla_OAP slOAP +sla_OAPQK slOAPQ + +sla_PA slPA +sla_PAV slPAV +sla_PCD slPCD +sla_PDA2H slPDAH +sla_PDQ2H slPDQH +sla_PERTEL slPRTL +sla_PERTUE slPRTE +sla_PLANEL slPLNE +sla_PLANET slPLNT +sla_PLANTE slPLTE +sla_PM slPM +sla_POLMO slPLMO +sla_PREBN slPRBN +sla_PREC slPREC +sla_PRECES slPRCE +sla_PRECL slPREL +sla_PRENUT slPRNU +sla_PV2EL slPVEL +sla_PV2UE slPVUE +sla_PVOBS slPVOB +sla_PXY slPXY + +sla_RANDOM slRNDM +sla_RANGE slRA1P +sla_RANORM slRA2P +sla_RCC slRCC +sla_RDPLAN slRDPL +sla_REFCO slRFCO +sla_REFCOQ slRFCQ +sla_REFRO slRFRO +sla_REFV slREFV +sla_REFZ slREFZ +sla_RVEROT slRVER +sla_RVGALC slRVGA +sla_RVLG slRVLG +sla_RVLSRD slRVLD +sla_RVLSRK slRVLK + +sla_S2TP slS2TP +sla_SEP slSEP +sla_SMAT slSMAT +sla_SUBET slSUET +sla_SUPGAL slSUGA +sla_SVD slSVD +sla_SVDCOV slSVDC +sla_SVDSOL slSVDS + +sla_TP2S slTP2S +sla_TP2V slTP2V +sla_TPS2C slTPSC +sla_TPV2C slTPVC + +sla_UE2EL slUEEL +sla_UE2PV slUEPV +sla_UNPCD slUPCD + +sla_V2TP slV2TP +sla_VDV slVDV +sla_VN slVN +sla_VXV slVXV + +sla_WAIT slWAIT + +sla_XY2XY slXYXY +sla_ZD slZD diff --git a/math/slalib/nut.f b/math/slalib/nut.f new file mode 100644 index 00000000..b3cbf192 --- /dev/null +++ b/math/slalib/nut.f @@ -0,0 +1,76 @@ + SUBROUTINE slNUT (DATE, RMATN) +*+ +* - - - - +* N U T +* - - - - +* +* Form the matrix of nutation for a given date - Shirai & Fukushima +* 2001 theory (double precision) +* +* Reference: +* Shirai, T. & Fukushima, T., Astron.J. 121, 3270-3283 (2001). +* +* Given: +* DATE d TDB (loosely ET) as Modified Julian Date +* (=JD-2400000.5) +* Returned: +* RMATN d(3,3) nutation matrix +* +* Notes: +* +* 1 The matrix is in the sense v(true) = rmatn * v(mean) . +* where v(true) is the star vector relative to the true equator and +* equinox of date and v(mean) is the star vector relative to the +* mean equator and equinox of date. +* +* 2 The matrix represents forced nutation (but not free core +* nutation) plus corrections to the IAU~1976 precession model. +* +* 3 Earth attitude predictions made by combining the present nutation +* matrix with IAU~1976 precession are accurate to 1~mas (with +* respect to the ICRS) for a few decades around 2000. +* +* 4 The distinction between the required TDB and TT is always +* negligible. Moreover, for all but the most critical applications +* UTC is adequate. +* +* Called: slNUTC, slDEUL +* +* Last revision: 1 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,RMATN(3,3) + + DOUBLE PRECISION DPSI,DEPS,EPS0 + + + +* Nutation components and mean obliquity + CALL slNUTC(DATE,DPSI,DEPS,EPS0) + +* Rotation matrix + CALL slDEUL('XZX',EPS0,-DPSI,-(EPS0+DEPS),RMATN) + + END diff --git a/math/slalib/nutc.f b/math/slalib/nutc.f new file mode 100644 index 00000000..95affe1b --- /dev/null +++ b/math/slalib/nutc.f @@ -0,0 +1,831 @@ + SUBROUTINE slNUTC (DATE, DPSI, DEPS, EPS0) +*+ +* - - - - - +* N U T C +* - - - - - +* +* Nutation: longitude & obliquity components and mean obliquity, +* using the Shirai & Fukushima (2001) theory. +* +* Given: +* DATE d TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* Returned: +* DPSI,DEPS d nutation in longitude,obliquity +* EPS0 d mean obliquity +* +* Notes: +* +* 1 The routine predicts forced nutation (but not free core nutation) +* plus corrections to the IAU 1976 precession model. +* +* 2 Earth attitude predictions made by combining the present nutation +* model with IAU 1976 precession are accurate to 1 mas (with respect +* to the ICRF) for a few decades around 2000. +* +* 3 The slNUTC80 routine is the equivalent of the present routine +* but using the IAU 1980 nutation theory. The older theory is less +* accurate, leading to errors as large as 350 mas over the interval +* 1900-2100, mainly because of the error in the IAU 1976 precession. +* +* References: +* +* Shirai, T. & Fukushima, T., Astron.J. 121, 3270-3283 (2001). +* +* Fukushima, T., Astron.Astrophys. 244, L11 (1991). +* +* Simon, J. L., Bretagnon, P., Chapront, J., Chapront-Touze, M., +* Francou, G. & Laskar, J., Astron.Astrophys. 282, 663 (1994). +* +* This revision: 24 November 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,DPSI,DEPS,EPS0 + +* Degrees to radians + DOUBLE PRECISION DD2R + PARAMETER (DD2R=1.745329251994329576923691D-2) + +* Arc seconds to radians + DOUBLE PRECISION DAS2R + PARAMETER (DAS2R=4.848136811095359935899141D-6) + +* Arc seconds in a full circle + DOUBLE PRECISION TURNAS + PARAMETER (TURNAS=1296000D0) + +* Reference epoch (J2000), MJD + DOUBLE PRECISION DJM0 + PARAMETER (DJM0=51544.5D0 ) + +* Days per Julian century + DOUBLE PRECISION DJC + PARAMETER (DJC=36525D0) + + INTEGER I,J + DOUBLE PRECISION T,EL,ELP,F,D,OM,VE,MA,JU,SA,THETA,C,S,DP,DE + +* Number of terms in the nutation model + INTEGER NTERMS + PARAMETER (NTERMS=194) + +* The SF2001 forced nutation model + INTEGER NA(9,NTERMS) + DOUBLE PRECISION PSI(4,NTERMS), EPS(4,NTERMS) + +* Coefficients of fundamental angles + DATA ( ( NA(I,J), I=1,9 ), J=1,10 ) / + : 0, 0, 0, 0, -1, 0, 0, 0, 0, + : 0, 0, 2, -2, 2, 0, 0, 0, 0, + : 0, 0, 2, 0, 2, 0, 0, 0, 0, + : 0, 0, 0, 0, -2, 0, 0, 0, 0, + : 0, 1, 0, 0, 0, 0, 0, 0, 0, + : 0, 1, 2, -2, 2, 0, 0, 0, 0, + : 1, 0, 0, 0, 0, 0, 0, 0, 0, + : 0, 0, 2, 0, 1, 0, 0, 0, 0, + : 1, 0, 2, 0, 2, 0, 0, 0, 0, + : 0, -1, 2, -2, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=11,20 ) / + : 0, 0, 2, -2, 1, 0, 0, 0, 0, + : -1, 0, 2, 0, 2, 0, 0, 0, 0, + : -1, 0, 0, 2, 0, 0, 0, 0, 0, + : 1, 0, 0, 0, 1, 0, 0, 0, 0, + : 1, 0, 0, 0, -1, 0, 0, 0, 0, + : -1, 0, 2, 2, 2, 0, 0, 0, 0, + : 1, 0, 2, 0, 1, 0, 0, 0, 0, + : -2, 0, 2, 0, 1, 0, 0, 0, 0, + : 0, 0, 0, 2, 0, 0, 0, 0, 0, + : 0, 0, 2, 2, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=21,30 ) / + : 2, 0, 0, -2, 0, 0, 0, 0, 0, + : 2, 0, 2, 0, 2, 0, 0, 0, 0, + : 1, 0, 2, -2, 2, 0, 0, 0, 0, + : -1, 0, 2, 0, 1, 0, 0, 0, 0, + : 2, 0, 0, 0, 0, 0, 0, 0, 0, + : 0, 0, 2, 0, 0, 0, 0, 0, 0, + : 0, 1, 0, 0, 1, 0, 0, 0, 0, + : -1, 0, 0, 2, 1, 0, 0, 0, 0, + : 0, 2, 2, -2, 2, 0, 0, 0, 0, + : 0, 0, 2, -2, 0, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=31,40 ) / + : -1, 0, 0, 2, -1, 0, 0, 0, 0, + : 0, 1, 0, 0, -1, 0, 0, 0, 0, + : 0, 2, 0, 0, 0, 0, 0, 0, 0, + : -1, 0, 2, 2, 1, 0, 0, 0, 0, + : 1, 0, 2, 2, 2, 0, 0, 0, 0, + : 0, 1, 2, 0, 2, 0, 0, 0, 0, + : -2, 0, 2, 0, 0, 0, 0, 0, 0, + : 0, 0, 2, 2, 1, 0, 0, 0, 0, + : 0, -1, 2, 0, 2, 0, 0, 0, 0, + : 0, 0, 0, 2, 1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=41,50 ) / + : 1, 0, 2, -2, 1, 0, 0, 0, 0, + : 2, 0, 0, -2, -1, 0, 0, 0, 0, + : 2, 0, 2, -2, 2, 0, 0, 0, 0, + : 2, 0, 2, 0, 1, 0, 0, 0, 0, + : 0, 0, 0, 2, -1, 0, 0, 0, 0, + : 0, -1, 2, -2, 1, 0, 0, 0, 0, + : -1, -1, 0, 2, 0, 0, 0, 0, 0, + : 2, 0, 0, -2, 1, 0, 0, 0, 0, + : 1, 0, 0, 2, 0, 0, 0, 0, 0, + : 0, 1, 2, -2, 1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=51,60 ) / + : 1, -1, 0, 0, 0, 0, 0, 0, 0, + : -2, 0, 2, 0, 2, 0, 0, 0, 0, + : 0, -1, 0, 2, 0, 0, 0, 0, 0, + : 3, 0, 2, 0, 2, 0, 0, 0, 0, + : 0, 0, 0, 1, 0, 0, 0, 0, 0, + : 1, -1, 2, 0, 2, 0, 0, 0, 0, + : 1, 0, 0, -1, 0, 0, 0, 0, 0, + : -1, -1, 2, 2, 2, 0, 0, 0, 0, + : -1, 0, 2, 0, 0, 0, 0, 0, 0, + : 2, 0, 0, 0, -1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=61,70 ) / + : 0, -1, 2, 2, 2, 0, 0, 0, 0, + : 1, 1, 2, 0, 2, 0, 0, 0, 0, + : 2, 0, 0, 0, 1, 0, 0, 0, 0, + : 1, 1, 0, 0, 0, 0, 0, 0, 0, + : 1, 0, -2, 2, -1, 0, 0, 0, 0, + : 1, 0, 2, 0, 0, 0, 0, 0, 0, + : -1, 1, 0, 1, 0, 0, 0, 0, 0, + : 1, 0, 0, 0, 2, 0, 0, 0, 0, + : -1, 0, 1, 0, 1, 0, 0, 0, 0, + : 0, 0, 2, 1, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=71,80 ) / + : -1, 1, 0, 1, 1, 0, 0, 0, 0, + : -1, 0, 2, 4, 2, 0, 0, 0, 0, + : 0, -2, 2, -2, 1, 0, 0, 0, 0, + : 1, 0, 2, 2, 1, 0, 0, 0, 0, + : 1, 0, 0, 0, -2, 0, 0, 0, 0, + : -2, 0, 2, 2, 2, 0, 0, 0, 0, + : 1, 1, 2, -2, 2, 0, 0, 0, 0, + : -2, 0, 2, 4, 2, 0, 0, 0, 0, + : -1, 0, 4, 0, 2, 0, 0, 0, 0, + : 2, 0, 2, -2, 1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=81,90 ) / + : 1, 0, 0, -1, -1, 0, 0, 0, 0, + : 2, 0, 2, 2, 2, 0, 0, 0, 0, + : 1, 0, 0, 2, 1, 0, 0, 0, 0, + : 3, 0, 0, 0, 0, 0, 0, 0, 0, + : 0, 0, 2, -2, -1, 0, 0, 0, 0, + : 3, 0, 2, -2, 2, 0, 0, 0, 0, + : 0, 0, 4, -2, 2, 0, 0, 0, 0, + : -1, 0, 0, 4, 0, 0, 0, 0, 0, + : 0, 1, 2, 0, 1, 0, 0, 0, 0, + : 0, 0, 2, -2, 3, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=91,100 ) / + : -2, 0, 0, 4, 0, 0, 0, 0, 0, + : -1, -1, 0, 2, 1, 0, 0, 0, 0, + : -2, 0, 2, 0, -1, 0, 0, 0, 0, + : 0, 0, 2, 0, -1, 0, 0, 0, 0, + : 0, -1, 2, 0, 1, 0, 0, 0, 0, + : 0, 1, 0, 0, 2, 0, 0, 0, 0, + : 0, 0, 2, -1, 2, 0, 0, 0, 0, + : 2, 1, 0, -2, 0, 0, 0, 0, 0, + : 0, 0, 2, 4, 2, 0, 0, 0, 0, + : -1, -1, 0, 2, -1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=101,110 ) / + : -1, 1, 0, 2, 0, 0, 0, 0, 0, + : 1, -1, 0, 0, 1, 0, 0, 0, 0, + : 0, -1, 2, -2, 0, 0, 0, 0, 0, + : 0, 1, 0, 0, -2, 0, 0, 0, 0, + : 1, -1, 2, 2, 2, 0, 0, 0, 0, + : 1, 0, 0, 2, -1, 0, 0, 0, 0, + : -1, 1, 2, 2, 2, 0, 0, 0, 0, + : 3, 0, 2, 0, 1, 0, 0, 0, 0, + : 0, 1, 2, 2, 2, 0, 0, 0, 0, + : 1, 0, 2, -2, 0, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=111,120 ) / + : -1, 0, -2, 4, -1, 0, 0, 0, 0, + : -1, -1, 2, 2, 1, 0, 0, 0, 0, + : 0, -1, 2, 2, 1, 0, 0, 0, 0, + : 2, -1, 2, 0, 2, 0, 0, 0, 0, + : 0, 0, 0, 2, 2, 0, 0, 0, 0, + : 1, -1, 2, 0, 1, 0, 0, 0, 0, + : -1, 1, 2, 0, 2, 0, 0, 0, 0, + : 0, 1, 0, 2, 0, 0, 0, 0, 0, + : 0, 1, 2, -2, 0, 0, 0, 0, 0, + : 0, 3, 2, -2, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=121,130 ) / + : 0, 0, 0, 1, 1, 0, 0, 0, 0, + : -1, 0, 2, 2, 0, 0, 0, 0, 0, + : 2, 1, 2, 0, 2, 0, 0, 0, 0, + : 1, 1, 0, 0, 1, 0, 0, 0, 0, + : 2, 0, 0, 2, 0, 0, 0, 0, 0, + : 1, 1, 2, 0, 1, 0, 0, 0, 0, + : -1, 0, 0, 2, 2, 0, 0, 0, 0, + : 1, 0, -2, 2, 0, 0, 0, 0, 0, + : 0, -1, 0, 2, -1, 0, 0, 0, 0, + : -1, 0, 1, 0, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=131,140 ) / + : 0, 1, 0, 1, 0, 0, 0, 0, 0, + : 1, 0, -2, 2, -2, 0, 0, 0, 0, + : 0, 0, 0, 1, -1, 0, 0, 0, 0, + : 1, -1, 0, 0, -1, 0, 0, 0, 0, + : 0, 0, 0, 4, 0, 0, 0, 0, 0, + : 1, -1, 0, 2, 0, 0, 0, 0, 0, + : 1, 0, 2, 1, 2, 0, 0, 0, 0, + : 1, 0, 2, -1, 2, 0, 0, 0, 0, + : -1, 0, 0, 2, -2, 0, 0, 0, 0, + : 0, 0, 2, 1, 1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=141,150 ) / + : -1, 0, 2, 0, -1, 0, 0, 0, 0, + : -1, 0, 2, 4, 1, 0, 0, 0, 0, + : 0, 0, 2, 2, 0, 0, 0, 0, 0, + : 1, 1, 2, -2, 1, 0, 0, 0, 0, + : 0, 0, 1, 0, 1, 0, 0, 0, 0, + : -1, 0, 2, -1, 1, 0, 0, 0, 0, + : -2, 0, 2, 2, 1, 0, 0, 0, 0, + : 2, -1, 0, 0, 0, 0, 0, 0, 0, + : 4, 0, 2, 0, 2, 0, 0, 0, 0, + : 2, 1, 2, -2, 2, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=151,160 ) / + : 0, 1, 2, 1, 2, 0, 0, 0, 0, + : 1, 0, 4, -2, 2, 0, 0, 0, 0, + : 1, 1, 0, 0, -1, 0, 0, 0, 0, + : -2, 0, 2, 4, 1, 0, 0, 0, 0, + : 2, 0, 2, 0, 0, 0, 0, 0, 0, + : -1, 0, 1, 0, 0, 0, 0, 0, 0, + : 1, 0, 0, 1, 0, 0, 0, 0, 0, + : 0, 1, 0, 2, 1, 0, 0, 0, 0, + : -1, 0, 4, 0, 1, 0, 0, 0, 0, + : -1, 0, 0, 4, 1, 0, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=161,170 ) / + : 2, 0, 2, 2, 1, 0, 0, 0, 0, + : 2, 1, 0, 0, 0, 0, 0, 0, 0, + : 0, 0, 5, -5, 5, -3, 0, 0, 0, + : 0, 0, 0, 0, 0, 0, 0, 2, 0, + : 0, 0, 1, -1, 1, 0, 0, -1, 0, + : 0, 0, -1, 1, -1, 1, 0, 0, 0, + : 0, 0, -1, 1, 0, 0, 2, 0, 0, + : 0, 0, 3, -3, 3, 0, 0, -1, 0, + : 0, 0, -8, 8, -7, 5, 0, 0, 0, + : 0, 0, -1, 1, -1, 0, 2, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=171,180 ) / + : 0, 0, -2, 2, -2, 2, 0, 0, 0, + : 0, 0, -6, 6, -6, 4, 0, 0, 0, + : 0, 0, -2, 2, -2, 0, 8, -3, 0, + : 0, 0, 6, -6, 6, 0, -8, 3, 0, + : 0, 0, 4, -4, 4, -2, 0, 0, 0, + : 0, 0, -3, 3, -3, 2, 0, 0, 0, + : 0, 0, 4, -4, 3, 0, -8, 3, 0, + : 0, 0, -4, 4, -5, 0, 8, -3, 0, + : 0, 0, 0, 0, 0, 2, 0, 0, 0, + : 0, 0, -4, 4, -4, 3, 0, 0, 0 / + DATA ( ( NA(I,J), I=1,9 ), J=181,190 ) / + : 0, 1, -1, 1, -1, 0, 0, 1, 0, + : 0, 0, 0, 0, 0, 0, 0, 1, 0, + : 0, 0, 1, -1, 1, 1, 0, 0, 0, + : 0, 0, 2, -2, 2, 0, -2, 0, 0, + : 0, -1, -7, 7, -7, 5, 0, 0, 0, + : -2, 0, 2, 0, 2, 0, 0, -2, 0, + : -2, 0, 2, 0, 1, 0, 0, -3, 0, + : 0, 0, 2, -2, 2, 0, 0, -2, 0, + : 0, 0, 1, -1, 1, 0, 0, 1, 0, + : 0, 0, 0, 0, 0, 0, 0, 0, 2 / + DATA ( ( NA(I,J), I=1,9 ), J=191,NTERMS ) / + : 0, 0, 0, 0, 0, 0, 0, 0, 1, + : 2, 0, -2, 0, -2, 0, 0, 3, 0, + : 0, 0, 1, -1, 1, 0, 0, -2, 0, + : 0, 0, -7, 7, -7, 5, 0, 0, 0 / + +* Nutation series: longitude + DATA ( ( PSI(I,J), I=1,4 ), J=1,10 ) / + : 3341.5D0, 17206241.8D0, 3.1D0, 17409.5D0, + : -1716.8D0, -1317185.3D0, 1.4D0, -156.8D0, + : 285.7D0, -227667.0D0, 0.3D0, -23.5D0, + : -68.6D0, -207448.0D0, 0.0D0, -21.4D0, + : 950.3D0, 147607.9D0, -2.3D0, -355.0D0, + : -66.7D0, -51689.1D0, 0.2D0, 122.6D0, + : -108.6D0, 71117.6D0, 0.0D0, 7.0D0, + : 35.6D0, -38740.2D0, 0.1D0, -36.2D0, + : 85.4D0, -30127.6D0, 0.0D0, -3.1D0, + : 9.0D0, 21583.0D0, 0.1D0, -50.3D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=11,20 ) / + : 22.1D0, 12822.8D0, 0.0D0, 13.3D0, + : 3.4D0, 12350.8D0, 0.0D0, 1.3D0, + : -21.1D0, 15699.4D0, 0.0D0, 1.6D0, + : 4.2D0, 6313.8D0, 0.0D0, 6.2D0, + : -22.8D0, 5796.9D0, 0.0D0, 6.1D0, + : 15.7D0, -5961.1D0, 0.0D0, -0.6D0, + : 13.1D0, -5159.1D0, 0.0D0, -4.6D0, + : 1.8D0, 4592.7D0, 0.0D0, 4.5D0, + : -17.5D0, 6336.0D0, 0.0D0, 0.7D0, + : 16.3D0, -3851.1D0, 0.0D0, -0.4D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=21,30 ) / + : -2.8D0, 4771.7D0, 0.0D0, 0.5D0, + : 13.8D0, -3099.3D0, 0.0D0, -0.3D0, + : 0.2D0, 2860.3D0, 0.0D0, 0.3D0, + : 1.4D0, 2045.3D0, 0.0D0, 2.0D0, + : -8.6D0, 2922.6D0, 0.0D0, 0.3D0, + : -7.7D0, 2587.9D0, 0.0D0, 0.2D0, + : 8.8D0, -1408.1D0, 0.0D0, 3.7D0, + : 1.4D0, 1517.5D0, 0.0D0, 1.5D0, + : -1.9D0, -1579.7D0, 0.0D0, 7.7D0, + : 1.3D0, -2178.6D0, 0.0D0, -0.2D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=31,40 ) / + : -4.8D0, 1286.8D0, 0.0D0, 1.3D0, + : 6.3D0, 1267.2D0, 0.0D0, -4.0D0, + : -1.0D0, 1669.3D0, 0.0D0, -8.3D0, + : 2.4D0, -1020.0D0, 0.0D0, -0.9D0, + : 4.5D0, -766.9D0, 0.0D0, 0.0D0, + : -1.1D0, 756.5D0, 0.0D0, -1.7D0, + : -1.4D0, -1097.3D0, 0.0D0, -0.5D0, + : 2.6D0, -663.0D0, 0.0D0, -0.6D0, + : 0.8D0, -714.1D0, 0.0D0, 1.6D0, + : 0.4D0, -629.9D0, 0.0D0, -0.6D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=41,50 ) / + : 0.3D0, 580.4D0, 0.0D0, 0.6D0, + : -1.6D0, 577.3D0, 0.0D0, 0.5D0, + : -0.9D0, 644.4D0, 0.0D0, 0.0D0, + : 2.2D0, -534.0D0, 0.0D0, -0.5D0, + : -2.5D0, 493.3D0, 0.0D0, 0.5D0, + : -0.1D0, -477.3D0, 0.0D0, -2.4D0, + : -0.9D0, 735.0D0, 0.0D0, -1.7D0, + : 0.7D0, 406.2D0, 0.0D0, 0.4D0, + : -2.8D0, 656.9D0, 0.0D0, 0.0D0, + : 0.6D0, 358.0D0, 0.0D0, 2.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=51,60 ) / + : -0.7D0, 472.5D0, 0.0D0, -1.1D0, + : -0.1D0, -300.5D0, 0.0D0, 0.0D0, + : -1.2D0, 435.1D0, 0.0D0, -1.0D0, + : 1.8D0, -289.4D0, 0.0D0, 0.0D0, + : 0.6D0, -422.6D0, 0.0D0, 0.0D0, + : 0.8D0, -287.6D0, 0.0D0, 0.6D0, + : -38.6D0, -392.3D0, 0.0D0, 0.0D0, + : 0.7D0, -281.8D0, 0.0D0, 0.6D0, + : 0.6D0, -405.7D0, 0.0D0, 0.0D0, + : -1.2D0, 229.0D0, 0.0D0, 0.2D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=61,70 ) / + : 1.1D0, -264.3D0, 0.0D0, 0.5D0, + : -0.7D0, 247.9D0, 0.0D0, -0.5D0, + : -0.2D0, 218.0D0, 0.0D0, 0.2D0, + : 0.6D0, -339.0D0, 0.0D0, 0.8D0, + : -0.7D0, 198.7D0, 0.0D0, 0.2D0, + : -1.5D0, 334.0D0, 0.0D0, 0.0D0, + : 0.1D0, 334.0D0, 0.0D0, 0.0D0, + : -0.1D0, -198.1D0, 0.0D0, 0.0D0, + : -106.6D0, 0.0D0, 0.0D0, 0.0D0, + : -0.5D0, 165.8D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=71,80 ) / + : 0.0D0, 134.8D0, 0.0D0, 0.0D0, + : 0.9D0, -151.6D0, 0.0D0, 0.0D0, + : 0.0D0, -129.7D0, 0.0D0, 0.0D0, + : 0.8D0, -132.8D0, 0.0D0, -0.1D0, + : 0.5D0, -140.7D0, 0.0D0, 0.0D0, + : -0.1D0, 138.4D0, 0.0D0, 0.0D0, + : 0.0D0, 129.0D0, 0.0D0, -0.3D0, + : 0.5D0, -121.2D0, 0.0D0, 0.0D0, + : -0.3D0, 114.5D0, 0.0D0, 0.0D0, + : -0.1D0, 101.8D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=81,90 ) / + : -3.6D0, -101.9D0, 0.0D0, 0.0D0, + : 0.8D0, -109.4D0, 0.0D0, 0.0D0, + : 0.2D0, -97.0D0, 0.0D0, 0.0D0, + : -0.7D0, 157.3D0, 0.0D0, 0.0D0, + : 0.2D0, -83.3D0, 0.0D0, 0.0D0, + : -0.3D0, 93.3D0, 0.0D0, 0.0D0, + : -0.1D0, 92.1D0, 0.0D0, 0.0D0, + : -0.5D0, 133.6D0, 0.0D0, 0.0D0, + : -0.1D0, 81.5D0, 0.0D0, 0.0D0, + : 0.0D0, 123.9D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=91,100 ) / + : -0.3D0, 128.1D0, 0.0D0, 0.0D0, + : 0.1D0, 74.1D0, 0.0D0, -0.3D0, + : -0.2D0, -70.3D0, 0.0D0, 0.0D0, + : -0.4D0, 66.6D0, 0.0D0, 0.0D0, + : 0.1D0, -66.7D0, 0.0D0, 0.0D0, + : -0.7D0, 69.3D0, 0.0D0, -0.3D0, + : 0.0D0, -70.4D0, 0.0D0, 0.0D0, + : -0.1D0, 101.5D0, 0.0D0, 0.0D0, + : 0.5D0, -69.1D0, 0.0D0, 0.0D0, + : -0.2D0, 58.5D0, 0.0D0, 0.2D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=101,110 ) / + : 0.1D0, -94.9D0, 0.0D0, 0.2D0, + : 0.0D0, 52.9D0, 0.0D0, -0.2D0, + : 0.1D0, 86.7D0, 0.0D0, -0.2D0, + : -0.1D0, -59.2D0, 0.0D0, 0.2D0, + : 0.3D0, -58.8D0, 0.0D0, 0.1D0, + : -0.3D0, 49.0D0, 0.0D0, 0.0D0, + : -0.2D0, 56.9D0, 0.0D0, -0.1D0, + : 0.3D0, -50.2D0, 0.0D0, 0.0D0, + : -0.2D0, 53.4D0, 0.0D0, -0.1D0, + : 0.1D0, -76.5D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=111,120 ) / + : -0.2D0, 45.3D0, 0.0D0, 0.0D0, + : 0.1D0, -46.8D0, 0.0D0, 0.0D0, + : 0.2D0, -44.6D0, 0.0D0, 0.0D0, + : 0.2D0, -48.7D0, 0.0D0, 0.0D0, + : 0.1D0, -46.8D0, 0.0D0, 0.0D0, + : 0.1D0, -42.0D0, 0.0D0, 0.0D0, + : 0.0D0, 46.4D0, 0.0D0, -0.1D0, + : 0.2D0, -67.3D0, 0.0D0, 0.1D0, + : 0.0D0, -65.8D0, 0.0D0, 0.2D0, + : -0.1D0, -43.9D0, 0.0D0, 0.3D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=121,130 ) / + : 0.0D0, -38.9D0, 0.0D0, 0.0D0, + : -0.3D0, 63.9D0, 0.0D0, 0.0D0, + : -0.2D0, 41.2D0, 0.0D0, 0.0D0, + : 0.0D0, -36.1D0, 0.0D0, 0.2D0, + : -0.3D0, 58.5D0, 0.0D0, 0.0D0, + : -0.1D0, 36.1D0, 0.0D0, 0.0D0, + : 0.0D0, -39.7D0, 0.0D0, 0.0D0, + : 0.1D0, -57.7D0, 0.0D0, 0.0D0, + : -0.2D0, 33.4D0, 0.0D0, 0.0D0, + : 36.4D0, 0.0D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=131,140 ) / + : -0.1D0, 55.7D0, 0.0D0, -0.1D0, + : 0.1D0, -35.4D0, 0.0D0, 0.0D0, + : 0.1D0, -31.0D0, 0.0D0, 0.0D0, + : -0.1D0, 30.1D0, 0.0D0, 0.0D0, + : -0.3D0, 49.2D0, 0.0D0, 0.0D0, + : -0.2D0, 49.1D0, 0.0D0, 0.0D0, + : -0.1D0, 33.6D0, 0.0D0, 0.0D0, + : 0.1D0, -33.5D0, 0.0D0, 0.0D0, + : 0.1D0, -31.0D0, 0.0D0, 0.0D0, + : -0.1D0, 28.0D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=141,150 ) / + : 0.1D0, -25.2D0, 0.0D0, 0.0D0, + : 0.1D0, -26.2D0, 0.0D0, 0.0D0, + : -0.2D0, 41.5D0, 0.0D0, 0.0D0, + : 0.0D0, 24.5D0, 0.0D0, 0.1D0, + : -16.2D0, 0.0D0, 0.0D0, 0.0D0, + : 0.0D0, -22.3D0, 0.0D0, 0.0D0, + : 0.0D0, 23.1D0, 0.0D0, 0.0D0, + : -0.1D0, 37.5D0, 0.0D0, 0.0D0, + : 0.2D0, -25.7D0, 0.0D0, 0.0D0, + : 0.0D0, 25.2D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=151,160 ) / + : 0.1D0, -24.5D0, 0.0D0, 0.0D0, + : -0.1D0, 24.3D0, 0.0D0, 0.0D0, + : 0.1D0, -20.7D0, 0.0D0, 0.0D0, + : 0.1D0, -20.8D0, 0.0D0, 0.0D0, + : -0.2D0, 33.4D0, 0.0D0, 0.0D0, + : 32.9D0, 0.0D0, 0.0D0, 0.0D0, + : 0.1D0, -32.6D0, 0.0D0, 0.0D0, + : 0.0D0, 19.9D0, 0.0D0, 0.0D0, + : -0.1D0, 19.6D0, 0.0D0, 0.0D0, + : 0.0D0, -18.7D0, 0.0D0, 0.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=161,170 ) / + : 0.1D0, -19.0D0, 0.0D0, 0.0D0, + : 0.1D0, -28.6D0, 0.0D0, 0.0D0, + : 4.0D0, 178.8D0,-11.8D0, 0.3D0, + : 39.8D0, -107.3D0, -5.6D0, -1.0D0, + : 9.9D0, 164.0D0, -4.1D0, 0.1D0, + : -4.8D0, -135.3D0, -3.4D0, -0.1D0, + : 50.5D0, 75.0D0, 1.4D0, -1.2D0, + : -1.1D0, -53.5D0, 1.3D0, 0.0D0, + : -45.0D0, -2.4D0, -0.4D0, 6.6D0, + : -11.5D0, -61.0D0, -0.9D0, 0.4D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=171,180 ) / + : 4.4D0, -68.4D0, -3.4D0, 0.0D0, + : 7.7D0, -47.1D0, -4.7D0, -1.0D0, + : -42.9D0, -12.6D0, -1.2D0, 4.2D0, + : -42.8D0, 12.7D0, -1.2D0, -4.2D0, + : -7.6D0, -44.1D0, 2.1D0, -0.5D0, + : -64.1D0, 1.7D0, 0.2D0, 4.5D0, + : 36.4D0, -10.4D0, 1.0D0, 3.5D0, + : 35.6D0, 10.2D0, 1.0D0, -3.5D0, + : -1.7D0, 39.5D0, 2.0D0, 0.0D0, + : 50.9D0, -8.2D0, -0.8D0, -5.0D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=181,190 ) / + : 0.0D0, 52.3D0, 1.2D0, 0.0D0, + : -42.9D0, -17.8D0, 0.4D0, 0.0D0, + : 2.6D0, 34.3D0, 0.8D0, 0.0D0, + : -0.8D0, -48.6D0, 2.4D0, -0.1D0, + : -4.9D0, 30.5D0, 3.7D0, 0.7D0, + : 0.0D0, -43.6D0, 2.1D0, 0.0D0, + : 0.0D0, -25.4D0, 1.2D0, 0.0D0, + : 2.0D0, 40.9D0, -2.0D0, 0.0D0, + : -2.1D0, 26.1D0, 0.6D0, 0.0D0, + : 22.6D0, -3.2D0, -0.5D0, -0.5D0 / + DATA ( ( PSI(I,J), I=1,4 ), J=191,NTERMS ) / + : -7.6D0, 24.9D0, -0.4D0, -0.2D0, + : -6.2D0, 34.9D0, 1.7D0, 0.3D0, + : 2.0D0, 17.4D0, -0.4D0, 0.1D0, + : -3.9D0, 20.5D0, 2.4D0, 0.6D0 / + +* Nutation series: obliquity + DATA ( ( EPS(I,J), I=1,4 ), J=1,10 ) / + : 9205365.8D0, -1506.2D0, 885.7D0, -0.2D0, + : 573095.9D0, -570.2D0, -305.0D0, -0.3D0, + : 97845.5D0, 147.8D0, -48.8D0, -0.2D0, + : -89753.6D0, 28.0D0, 46.9D0, 0.0D0, + : 7406.7D0, -327.1D0, -18.2D0, 0.8D0, + : 22442.3D0, -22.3D0, -67.6D0, 0.0D0, + : -683.6D0, 46.8D0, 0.0D0, 0.0D0, + : 20070.7D0, 36.0D0, 1.6D0, 0.0D0, + : 12893.8D0, 39.5D0, -6.2D0, 0.0D0, + : -9593.2D0, 14.4D0, 30.2D0, -0.1D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=11,20 ) / + : -6899.5D0, 4.8D0, -0.6D0, 0.0D0, + : -5332.5D0, -0.1D0, 2.7D0, 0.0D0, + : -125.2D0, 10.5D0, 0.0D0, 0.0D0, + : -3323.4D0, -0.9D0, -0.3D0, 0.0D0, + : 3142.3D0, 8.9D0, 0.3D0, 0.0D0, + : 2552.5D0, 7.3D0, -1.2D0, 0.0D0, + : 2634.4D0, 8.8D0, 0.2D0, 0.0D0, + : -2424.4D0, 1.6D0, -0.4D0, 0.0D0, + : -123.3D0, 3.9D0, 0.0D0, 0.0D0, + : 1642.4D0, 7.3D0, -0.8D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=21,30 ) / + : 47.9D0, 3.2D0, 0.0D0, 0.0D0, + : 1321.2D0, 6.2D0, -0.6D0, 0.0D0, + : -1234.1D0, -0.3D0, 0.6D0, 0.0D0, + : -1076.5D0, -0.3D0, 0.0D0, 0.0D0, + : -61.6D0, 1.8D0, 0.0D0, 0.0D0, + : -55.4D0, 1.6D0, 0.0D0, 0.0D0, + : 856.9D0, -4.9D0, -2.1D0, 0.0D0, + : -800.7D0, -0.1D0, 0.0D0, 0.0D0, + : 685.1D0, -0.6D0, -3.8D0, 0.0D0, + : -16.9D0, -1.5D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=31,40 ) / + : 695.7D0, 1.8D0, 0.0D0, 0.0D0, + : 642.2D0, -2.6D0, -1.6D0, 0.0D0, + : 13.3D0, 1.1D0, -0.1D0, 0.0D0, + : 521.9D0, 1.6D0, 0.0D0, 0.0D0, + : 325.8D0, 2.0D0, -0.1D0, 0.0D0, + : -325.1D0, -0.5D0, 0.9D0, 0.0D0, + : 10.1D0, 0.3D0, 0.0D0, 0.0D0, + : 334.5D0, 1.6D0, 0.0D0, 0.0D0, + : 307.1D0, 0.4D0, -0.9D0, 0.0D0, + : 327.2D0, 0.5D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=41,50 ) / + : -304.6D0, -0.1D0, 0.0D0, 0.0D0, + : 304.0D0, 0.6D0, 0.0D0, 0.0D0, + : -276.8D0, -0.5D0, 0.1D0, 0.0D0, + : 268.9D0, 1.3D0, 0.0D0, 0.0D0, + : 271.8D0, 1.1D0, 0.0D0, 0.0D0, + : 271.5D0, -0.4D0, -0.8D0, 0.0D0, + : -5.2D0, 0.5D0, 0.0D0, 0.0D0, + : -220.5D0, 0.1D0, 0.0D0, 0.0D0, + : -20.1D0, 0.3D0, 0.0D0, 0.0D0, + : -191.0D0, 0.1D0, 0.5D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=51,60 ) / + : -4.1D0, 0.3D0, 0.0D0, 0.0D0, + : 130.6D0, -0.1D0, 0.0D0, 0.0D0, + : 3.0D0, 0.3D0, 0.0D0, 0.0D0, + : 122.9D0, 0.8D0, 0.0D0, 0.0D0, + : 3.7D0, -0.3D0, 0.0D0, 0.0D0, + : 123.1D0, 0.4D0, -0.3D0, 0.0D0, + : -52.7D0, 15.3D0, 0.0D0, 0.0D0, + : 120.7D0, 0.3D0, -0.3D0, 0.0D0, + : 4.0D0, -0.3D0, 0.0D0, 0.0D0, + : 126.5D0, 0.5D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=61,70 ) / + : 112.7D0, 0.5D0, -0.3D0, 0.0D0, + : -106.1D0, -0.3D0, 0.3D0, 0.0D0, + : -112.9D0, -0.2D0, 0.0D0, 0.0D0, + : 3.6D0, -0.2D0, 0.0D0, 0.0D0, + : 107.4D0, 0.3D0, 0.0D0, 0.0D0, + : -10.9D0, 0.2D0, 0.0D0, 0.0D0, + : -0.9D0, 0.0D0, 0.0D0, 0.0D0, + : 85.4D0, 0.0D0, 0.0D0, 0.0D0, + : 0.0D0, -88.8D0, 0.0D0, 0.0D0, + : -71.0D0, -0.2D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=71,80 ) / + : -70.3D0, 0.0D0, 0.0D0, 0.0D0, + : 64.5D0, 0.4D0, 0.0D0, 0.0D0, + : 69.8D0, 0.0D0, 0.0D0, 0.0D0, + : 66.1D0, 0.4D0, 0.0D0, 0.0D0, + : -61.0D0, -0.2D0, 0.0D0, 0.0D0, + : -59.5D0, -0.1D0, 0.0D0, 0.0D0, + : -55.6D0, 0.0D0, 0.2D0, 0.0D0, + : 51.7D0, 0.2D0, 0.0D0, 0.0D0, + : -49.0D0, -0.1D0, 0.0D0, 0.0D0, + : -52.7D0, -0.1D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=81,90 ) / + : -49.6D0, 1.4D0, 0.0D0, 0.0D0, + : 46.3D0, 0.4D0, 0.0D0, 0.0D0, + : 49.6D0, 0.1D0, 0.0D0, 0.0D0, + : -5.1D0, 0.1D0, 0.0D0, 0.0D0, + : -44.0D0, -0.1D0, 0.0D0, 0.0D0, + : -39.9D0, -0.1D0, 0.0D0, 0.0D0, + : -39.5D0, -0.1D0, 0.0D0, 0.0D0, + : -3.9D0, 0.1D0, 0.0D0, 0.0D0, + : -42.1D0, -0.1D0, 0.0D0, 0.0D0, + : -17.2D0, 0.1D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=91,100 ) / + : -2.3D0, 0.1D0, 0.0D0, 0.0D0, + : -39.2D0, 0.0D0, 0.0D0, 0.0D0, + : -38.4D0, 0.1D0, 0.0D0, 0.0D0, + : 36.8D0, 0.2D0, 0.0D0, 0.0D0, + : 34.6D0, 0.1D0, 0.0D0, 0.0D0, + : -32.7D0, 0.3D0, 0.0D0, 0.0D0, + : 30.4D0, 0.0D0, 0.0D0, 0.0D0, + : 0.4D0, 0.1D0, 0.0D0, 0.0D0, + : 29.3D0, 0.2D0, 0.0D0, 0.0D0, + : 31.6D0, 0.1D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=101,110 ) / + : 0.8D0, -0.1D0, 0.0D0, 0.0D0, + : -27.9D0, 0.0D0, 0.0D0, 0.0D0, + : 2.9D0, 0.0D0, 0.0D0, 0.0D0, + : -25.3D0, 0.0D0, 0.0D0, 0.0D0, + : 25.0D0, 0.1D0, 0.0D0, 0.0D0, + : 27.5D0, 0.1D0, 0.0D0, 0.0D0, + : -24.4D0, -0.1D0, 0.0D0, 0.0D0, + : 24.9D0, 0.2D0, 0.0D0, 0.0D0, + : -22.8D0, -0.1D0, 0.0D0, 0.0D0, + : 0.9D0, -0.1D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=111,120 ) / + : 24.4D0, 0.1D0, 0.0D0, 0.0D0, + : 23.9D0, 0.1D0, 0.0D0, 0.0D0, + : 22.5D0, 0.1D0, 0.0D0, 0.0D0, + : 20.8D0, 0.1D0, 0.0D0, 0.0D0, + : 20.1D0, 0.0D0, 0.0D0, 0.0D0, + : 21.5D0, 0.1D0, 0.0D0, 0.0D0, + : -20.0D0, 0.0D0, 0.0D0, 0.0D0, + : 1.4D0, 0.0D0, 0.0D0, 0.0D0, + : -0.2D0, -0.1D0, 0.0D0, 0.0D0, + : 19.0D0, 0.0D0, -0.1D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=121,130 ) / + : 20.5D0, 0.0D0, 0.0D0, 0.0D0, + : -2.0D0, 0.0D0, 0.0D0, 0.0D0, + : -17.6D0, -0.1D0, 0.0D0, 0.0D0, + : 19.0D0, 0.0D0, 0.0D0, 0.0D0, + : -2.4D0, 0.0D0, 0.0D0, 0.0D0, + : -18.4D0, -0.1D0, 0.0D0, 0.0D0, + : 17.1D0, 0.0D0, 0.0D0, 0.0D0, + : 0.4D0, 0.0D0, 0.0D0, 0.0D0, + : 18.4D0, 0.1D0, 0.0D0, 0.0D0, + : 0.0D0, 17.4D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=131,140 ) / + : -0.6D0, 0.0D0, 0.0D0, 0.0D0, + : -15.4D0, 0.0D0, 0.0D0, 0.0D0, + : -16.8D0, -0.1D0, 0.0D0, 0.0D0, + : 16.3D0, 0.0D0, 0.0D0, 0.0D0, + : -2.0D0, 0.0D0, 0.0D0, 0.0D0, + : -1.5D0, 0.0D0, 0.0D0, 0.0D0, + : -14.3D0, -0.1D0, 0.0D0, 0.0D0, + : 14.4D0, 0.0D0, 0.0D0, 0.0D0, + : -13.4D0, 0.0D0, 0.0D0, 0.0D0, + : -14.3D0, -0.1D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=141,150 ) / + : -13.7D0, 0.0D0, 0.0D0, 0.0D0, + : 13.1D0, 0.1D0, 0.0D0, 0.0D0, + : -1.7D0, 0.0D0, 0.0D0, 0.0D0, + : -12.8D0, 0.0D0, 0.0D0, 0.0D0, + : 0.0D0, -14.4D0, 0.0D0, 0.0D0, + : 12.4D0, 0.0D0, 0.0D0, 0.0D0, + : -12.0D0, 0.0D0, 0.0D0, 0.0D0, + : -0.8D0, 0.0D0, 0.0D0, 0.0D0, + : 10.9D0, 0.1D0, 0.0D0, 0.0D0, + : -10.8D0, 0.0D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=151,160 ) / + : 10.5D0, 0.0D0, 0.0D0, 0.0D0, + : -10.4D0, 0.0D0, 0.0D0, 0.0D0, + : -11.2D0, 0.0D0, 0.0D0, 0.0D0, + : 10.5D0, 0.1D0, 0.0D0, 0.0D0, + : -1.4D0, 0.0D0, 0.0D0, 0.0D0, + : 0.0D0, 0.1D0, 0.0D0, 0.0D0, + : 0.7D0, 0.0D0, 0.0D0, 0.0D0, + : -10.3D0, 0.0D0, 0.0D0, 0.0D0, + : -10.0D0, 0.0D0, 0.0D0, 0.0D0, + : 9.6D0, 0.0D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=161,170 ) / + : 9.4D0, 0.1D0, 0.0D0, 0.0D0, + : 0.6D0, 0.0D0, 0.0D0, 0.0D0, + : -87.7D0, 4.4D0, -0.4D0, -6.3D0, + : 46.3D0, 22.4D0, 0.5D0, -2.4D0, + : 15.6D0, -3.4D0, 0.1D0, 0.4D0, + : 5.2D0, 5.8D0, 0.2D0, -0.1D0, + : -30.1D0, 26.9D0, 0.7D0, 0.0D0, + : 23.2D0, -0.5D0, 0.0D0, 0.6D0, + : 1.0D0, 23.2D0, 3.4D0, 0.0D0, + : -12.2D0, -4.3D0, 0.0D0, 0.0D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=171,180 ) / + : -2.1D0, -3.7D0, -0.2D0, 0.1D0, + : -18.6D0, -3.8D0, -0.4D0, 1.8D0, + : 5.5D0, -18.7D0, -1.8D0, -0.5D0, + : -5.5D0, -18.7D0, 1.8D0, -0.5D0, + : 18.4D0, -3.6D0, 0.3D0, 0.9D0, + : -0.6D0, 1.3D0, 0.0D0, 0.0D0, + : -5.6D0, -19.5D0, 1.9D0, 0.0D0, + : 5.5D0, -19.1D0, -1.9D0, 0.0D0, + : -17.3D0, -0.8D0, 0.0D0, 0.9D0, + : -3.2D0, -8.3D0, -0.8D0, 0.3D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=181,190 ) / + : -0.1D0, 0.0D0, 0.0D0, 0.0D0, + : -5.4D0, 7.8D0, -0.3D0, 0.0D0, + : -14.8D0, 1.4D0, 0.0D0, 0.3D0, + : -3.8D0, 0.4D0, 0.0D0, -0.2D0, + : 12.6D0, 3.2D0, 0.5D0, -1.5D0, + : 0.1D0, 0.0D0, 0.0D0, 0.0D0, + : -13.6D0, 2.4D0, -0.1D0, 0.0D0, + : 0.9D0, 1.2D0, 0.0D0, 0.0D0, + : -11.9D0, -0.5D0, 0.0D0, 0.3D0, + : 0.4D0, 12.0D0, 0.3D0, -0.2D0 / + DATA ( ( EPS(I,J), I=1,4 ), J=191,NTERMS ) / + : 8.3D0, 6.1D0, -0.1D0, 0.1D0, + : 0.0D0, 0.0D0, 0.0D0, 0.0D0, + : 0.4D0, -10.8D0, 0.3D0, 0.0D0, + : 9.6D0, 2.2D0, 0.3D0, -1.2D0 / + + + +* Interval between fundamental epoch J2000.0 and given epoch (JC). + T = (DATE-DJM0)/DJC + +* Mean anomaly of the Moon. + EL = 134.96340251D0*DD2R+ + : MOD(T*(1717915923.2178D0+ + : T*( 31.8792D0+ + : T*( 0.051635D0+ + : T*( - 0.00024470D0)))),TURNAS)*DAS2R + +* Mean anomaly of the Sun. + ELP = 357.52910918D0*DD2R+ + : MOD(T*( 129596581.0481D0+ + : T*( - 0.5532D0+ + : T*( 0.000136D0+ + : T*( - 0.00001149D0)))),TURNAS)*DAS2R + +* Mean argument of the latitude of the Moon. + F = 93.27209062D0*DD2R+ + : MOD(T*(1739527262.8478D0+ + : T*( - 12.7512D0+ + : T*( - 0.001037D0+ + : T*( 0.00000417D0)))),TURNAS)*DAS2R + +* Mean elongation of the Moon from the Sun. + D = 297.85019547D0*DD2R+ + : MOD(T*(1602961601.2090D0+ + : T*( - 6.3706D0+ + : T*( 0.006539D0+ + : T*( - 0.00003169D0)))),TURNAS)*DAS2R + +* Mean longitude of the ascending node of the Moon. + OM = 125.04455501D0*DD2R+ + : MOD(T*( - 6962890.5431D0+ + : T*( 7.4722D0+ + : T*( 0.007702D0+ + : T*( - 0.00005939D0)))),TURNAS)*DAS2R + +* Mean longitude of Venus. + VE = 181.97980085D0*DD2R+MOD(210664136.433548D0*T,TURNAS)*DAS2R + +* Mean longitude of Mars. + MA = 355.43299958D0*DD2R+MOD( 68905077.493988D0*T,TURNAS)*DAS2R + +* Mean longitude of Jupiter. + JU = 34.35151874D0*DD2R+MOD( 10925660.377991D0*T,TURNAS)*DAS2R + +* Mean longitude of Saturn. + SA = 50.07744430D0*DD2R+MOD( 4399609.855732D0*T,TURNAS)*DAS2R + +* Geodesic nutation (Fukushima 1991) in microarcsec. + DP = -153.1D0*SIN(ELP)-1.9D0*SIN(2D0*ELP) + DE = 0D0 + +* Shirai & Fukushima (2001) nutation series. + DO J=NTERMS,1,-1 + THETA = DBLE(NA(1,J))*EL+ + : DBLE(NA(2,J))*ELP+ + : DBLE(NA(3,J))*F+ + : DBLE(NA(4,J))*D+ + : DBLE(NA(5,J))*OM+ + : DBLE(NA(6,J))*VE+ + : DBLE(NA(7,J))*MA+ + : DBLE(NA(8,J))*JU+ + : DBLE(NA(9,J))*SA + C = COS(THETA) + S = SIN(THETA) + DP = DP+(PSI(1,J)+PSI(3,J)*T)*C+(PSI(2,J)+PSI(4,J)*T)*S + DE = DE+(EPS(1,J)+EPS(3,J)*T)*C+(EPS(2,J)+EPS(4,J)*T)*S + END DO + +* Change of units, and addition of the precession correction. + DPSI = (DP*1D-6-0.042888D0-0.29856D0*T)*DAS2R + DEPS = (DE*1D-6-0.005171D0-0.02408D0*T)*DAS2R + +* Mean obliquity of date (Simon et al. 1994). + EPS0 = (84381.412D0+ + : (-46.80927D0+ + : (-0.000152D0+ + : (0.0019989D0+ + : (-0.00000051D0+ + : (-0.000000025D0)*T)*T)*T)*T)*T)*DAS2R + + END diff --git a/math/slalib/nutc80.f b/math/slalib/nutc80.f new file mode 100644 index 00000000..4d27e331 --- /dev/null +++ b/math/slalib/nutc80.f @@ -0,0 +1,476 @@ + SUBROUTINE slNUTC80 (DATE, DPSI, DEPS, EPS0) +*+ +* - - - - - - - +* N U T C 8 0 +* - - - - - - - +* +* Nutation: longitude & obliquity components and mean obliquity, +* using the IAU 1980 theory (double precision) +* +* Given: +* DATE d TDB (loosely ET) as Modified Julian Date +* (JD-2400000.5) +* Returned: +* DPSI,DEPS d nutation in longitude,obliquity +* EPS0 d mean obliquity +* +* Called: slDA1P +* +* Notes: +* +* 1 Earth attitude predictions made by combining the present nutation +* model with IAU 1976 precession are accurate to 0.35 arcsec over +* the interval 1900-2100. (The accuracy is much better near the +* middle of the interval.) +* +* 2 The slNUTC routine is the equivalent of the present routine +* but using the Shirai & Fukushima 2001 forced nutation theory +* (SF2001). The newer theory is more accurate than IAU 1980, +* within 1 mas (with respect to the ICRF) for a few decades around +* 2000. The improvement is mainly because of the corrections to the +* IAU 1976 precession that the SF2001 theory includes. +* +* References: +* Final report of the IAU Working Group on Nutation, +* chairman P.K.Seidelmann, 1980. +* Kaplan,G.H., 1981, USNO circular no. 163, pA3-6. +* +* P.T.Wallace Starlink 7 October 2001 +* +* Copyright (C) 2001 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,DPSI,DEPS,EPS0 + + DOUBLE PRECISION T2AS,AS2R,U2R + DOUBLE PRECISION T,EL,EL2,EL3 + DOUBLE PRECISION ELP,ELP2 + DOUBLE PRECISION F,F2,F4 + DOUBLE PRECISION D,D2,D4 + DOUBLE PRECISION OM,OM2 + DOUBLE PRECISION DP,DE + DOUBLE PRECISION A + + DOUBLE PRECISION slDA1P + + +* Turns to arc seconds + PARAMETER (T2AS=1296000D0) +* Arc seconds to radians + PARAMETER (AS2R=0.484813681109535994D-5) +* Units of 0.0001 arcsec to radians + PARAMETER (U2R=AS2R/1D4) + + + + +* Interval between basic epoch J2000.0 and current epoch (JC) + T=(DATE-51544.5D0)/36525D0 + +* +* FUNDAMENTAL ARGUMENTS in the FK5 reference system +* + +* Mean longitude of the Moon minus mean longitude of the Moon's perigee + EL=slDA1P(AS2R*(485866.733D0+(1325D0*T2AS+715922.633D0 + : +(31.310D0+0.064D0*T)*T)*T)) + +* Mean longitude of the Sun minus mean longitude of the Sun's perigee + ELP=slDA1P(AS2R*(1287099.804D0+(99D0*T2AS+1292581.224D0 + : +(-0.577D0-0.012D0*T)*T)*T)) + +* Mean longitude of the Moon minus mean longitude of the Moon's node + F=slDA1P(AS2R*(335778.877D0+(1342D0*T2AS+295263.137D0 + : +(-13.257D0+0.011D0*T)*T)*T)) + +* Mean elongation of the Moon from the Sun + D=slDA1P(AS2R*(1072261.307D0+(1236D0*T2AS+1105601.328D0 + : +(-6.891D0+0.019D0*T)*T)*T)) + +* Longitude of the mean ascending node of the lunar orbit on the +* ecliptic, measured from the mean equinox of date + OM=slDA1P(AS2R*(450160.280D0+(-5D0*T2AS-482890.539D0 + : +(7.455D0+0.008D0*T)*T)*T)) + +* Multiples of arguments + EL2=EL+EL + EL3=EL2+EL + ELP2=ELP+ELP + F2=F+F + F4=F2+F2 + D2=D+D + D4=D2+D2 + OM2=OM+OM + + +* +* SERIES FOR THE NUTATION +* + DP=0D0 + DE=0D0 + +* 106 + DP=DP+SIN(ELP+D) +* 105 + DP=DP-SIN(F2+D4+OM2) +* 104 + DP=DP+SIN(EL2+D2) +* 103 + DP=DP-SIN(EL-F2+D2) +* 102 + DP=DP-SIN(EL+ELP-D2+OM) +* 101 + DP=DP-SIN(-ELP+F2+OM) +* 100 + DP=DP-SIN(EL-F2-D2) +* 99 + DP=DP-SIN(ELP+D2) +* 98 + DP=DP-SIN(F2-D+OM2) +* 97 + DP=DP-SIN(-F2+OM) +* 96 + DP=DP+SIN(-EL-ELP+D2+OM) +* 95 + DP=DP+SIN(ELP+F2+OM) +* 94 + DP=DP-SIN(EL+F2-D2) +* 93 + DP=DP+SIN(EL3+F2-D2+OM2) +* 92 + DP=DP+SIN(F4-D2+OM2) +* 91 + DP=DP-SIN(EL+D2+OM) +* 90 + DP=DP-SIN(EL2+F2+D2+OM2) +* 89 + A=EL2+F2-D2+OM + DP=DP+SIN(A) + DE=DE-COS(A) +* 88 + DP=DP+SIN(EL-ELP-D2) +* 87 + DP=DP+SIN(-EL+F4+OM2) +* 86 + A=-EL2+F2+D4+OM2 + DP=DP-SIN(A) + DE=DE+COS(A) +* 85 + A=EL+F2+D2+OM + DP=DP-SIN(A) + DE=DE+COS(A) +* 84 + A=EL+ELP+F2-D2+OM2 + DP=DP+SIN(A) + DE=DE-COS(A) +* 83 + DP=DP-SIN(EL2-D4) +* 82 + A=-EL+F2+D4+OM2 + DP=DP-2D0*SIN(A) + DE=DE+COS(A) +* 81 + A=-EL2+F2+D2+OM2 + DP=DP+SIN(A) + DE=DE-COS(A) +* 80 + DP=DP-SIN(EL-D4) +* 79 + A=-EL+OM2 + DP=DP+SIN(A) + DE=DE-COS(A) +* 78 + A=F2+D+OM2 + DP=DP+2D0*SIN(A) + DE=DE-COS(A) +* 77 + DP=DP+2D0*SIN(EL3) +* 76 + A=EL+OM2 + DP=DP-2D0*SIN(A) + DE=DE+COS(A) +* 75 + A=EL2+OM + DP=DP+2D0*SIN(A) + DE=DE-COS(A) +* 74 + A=-EL+F2-D2+OM + DP=DP-2D0*SIN(A) + DE=DE+COS(A) +* 73 + A=EL+ELP+F2+OM2 + DP=DP+2D0*SIN(A) + DE=DE-COS(A) +* 72 + A=-ELP+F2+D2+OM2 + DP=DP-3D0*SIN(A) + DE=DE+COS(A) +* 71 + A=EL3+F2+OM2 + DP=DP-3D0*SIN(A) + DE=DE+COS(A) +* 70 + A=-EL2+OM + DP=DP-2D0*SIN(A) + DE=DE+COS(A) +* 69 + A=-EL-ELP+F2+D2+OM2 + DP=DP-3D0*SIN(A) + DE=DE+COS(A) +* 68 + A=EL-ELP+F2+OM2 + DP=DP-3D0*SIN(A) + DE=DE+COS(A) +* 67 + DP=DP+3D0*SIN(EL+F2) +* 66 + DP=DP-3D0*SIN(EL+ELP) +* 65 + DP=DP-4D0*SIN(D) +* 64 + DP=DP+4D0*SIN(EL-F2) +* 63 + DP=DP-4D0*SIN(ELP-D2) +* 62 + A=EL2+F2+OM + DP=DP-5D0*SIN(A) + DE=DE+3D0*COS(A) +* 61 + DP=DP+5D0*SIN(EL-ELP) +* 60 + A=-D2+OM + DP=DP-5D0*SIN(A) + DE=DE+3D0*COS(A) +* 59 + A=EL+F2-D2+OM + DP=DP+6D0*SIN(A) + DE=DE-3D0*COS(A) +* 58 + A=F2+D2+OM + DP=DP-7D0*SIN(A) + DE=DE+3D0*COS(A) +* 57 + A=D2+OM + DP=DP-6D0*SIN(A) + DE=DE+3D0*COS(A) +* 56 + A=EL2+F2-D2+OM2 + DP=DP+6D0*SIN(A) + DE=DE-3D0*COS(A) +* 55 + DP=DP+6D0*SIN(EL+D2) +* 54 + A=EL+F2+D2+OM2 + DP=DP-8D0*SIN(A) + DE=DE+3D0*COS(A) +* 53 + A=-ELP+F2+OM2 + DP=DP-7D0*SIN(A) + DE=DE+3D0*COS(A) +* 52 + A=ELP+F2+OM2 + DP=DP+7D0*SIN(A) + DE=DE-3D0*COS(A) +* 51 + DP=DP-7D0*SIN(EL+ELP-D2) +* 50 + A=-EL+F2+D2+OM + DP=DP-10D0*SIN(A) + DE=DE+5D0*COS(A) +* 49 + A=EL-D2+OM + DP=DP-13D0*SIN(A) + DE=DE+7D0*COS(A) +* 48 + A=-EL+D2+OM + DP=DP+16D0*SIN(A) + DE=DE-8D0*COS(A) +* 47 + A=-EL+F2+OM + DP=DP+21D0*SIN(A) + DE=DE-10D0*COS(A) +* 46 + DP=DP+26D0*SIN(F2) + DE=DE-COS(F2) +* 45 + A=EL2+F2+OM2 + DP=DP-31D0*SIN(A) + DE=DE+13D0*COS(A) +* 44 + A=EL+F2-D2+OM2 + DP=DP+29D0*SIN(A) + DE=DE-12D0*COS(A) +* 43 + DP=DP+29D0*SIN(EL2) + DE=DE-COS(EL2) +* 42 + A=F2+D2+OM2 + DP=DP-38D0*SIN(A) + DE=DE+16D0*COS(A) +* 41 + A=EL+F2+OM + DP=DP-51D0*SIN(A) + DE=DE+27D0*COS(A) +* 40 + A=-EL+F2+D2+OM2 + DP=DP-59D0*SIN(A) + DE=DE+26D0*COS(A) +* 39 + A=-EL+OM + DP=DP+(-58D0-0.1D0*T)*SIN(A) + DE=DE+32D0*COS(A) +* 38 + A=EL+OM + DP=DP+(63D0+0.1D0*T)*SIN(A) + DE=DE-33D0*COS(A) +* 37 + DP=DP+63D0*SIN(D2) + DE=DE-2D0*COS(D2) +* 36 + A=-EL+F2+OM2 + DP=DP+123D0*SIN(A) + DE=DE-53D0*COS(A) +* 35 + A=EL-D2 + DP=DP-158D0*SIN(A) + DE=DE-COS(A) +* 34 + A=EL+F2+OM2 + DP=DP-301D0*SIN(A) + DE=DE+(129D0-0.1D0*T)*COS(A) +* 33 + A=F2+OM + DP=DP+(-386D0-0.4D0*T)*SIN(A) + DE=DE+200D0*COS(A) +* 32 + DP=DP+(712D0+0.1D0*T)*SIN(EL) + DE=DE-7D0*COS(EL) +* 31 + A=F2+OM2 + DP=DP+(-2274D0-0.2D0*T)*SIN(A) + DE=DE+(977D0-0.5D0*T)*COS(A) +* 30 + DP=DP-SIN(ELP+F2-D2) +* 29 + DP=DP+SIN(-EL+D+OM) +* 28 + DP=DP+SIN(ELP+OM2) +* 27 + DP=DP-SIN(ELP-F2+D2) +* 26 + DP=DP+SIN(-F2+D2+OM) +* 25 + DP=DP+SIN(EL2+ELP-D2) +* 24 + DP=DP-4D0*SIN(EL-D) +* 23 + A=ELP+F2-D2+OM + DP=DP+4D0*SIN(A) + DE=DE-2D0*COS(A) +* 22 + A=EL2-D2+OM + DP=DP+4D0*SIN(A) + DE=DE-2D0*COS(A) +* 21 + A=-ELP+F2-D2+OM + DP=DP-5D0*SIN(A) + DE=DE+3D0*COS(A) +* 20 + A=-EL2+D2+OM + DP=DP-6D0*SIN(A) + DE=DE+3D0*COS(A) +* 19 + A=-ELP+OM + DP=DP-12D0*SIN(A) + DE=DE+6D0*COS(A) +* 18 + A=ELP2+F2-D2+OM2 + DP=DP+(-16D0+0.1D0*T)*SIN(A) + DE=DE+7D0*COS(A) +* 17 + A=ELP+OM + DP=DP-15D0*SIN(A) + DE=DE+9D0*COS(A) +* 16 + DP=DP+(17D0-0.1D0*T)*SIN(ELP2) +* 15 + DP=DP-22D0*SIN(F2-D2) +* 14 + A=EL2-D2 + DP=DP+48D0*SIN(A) + DE=DE+COS(A) +* 13 + A=F2-D2+OM + DP=DP+(129D0+0.1D0*T)*SIN(A) + DE=DE-70D0*COS(A) +* 12 + A=-ELP+F2-D2+OM2 + DP=DP+(217D0-0.5D0*T)*SIN(A) + DE=DE+(-95D0+0.3D0*T)*COS(A) +* 11 + A=ELP+F2-D2+OM2 + DP=DP+(-517D0+1.2D0*T)*SIN(A) + DE=DE+(224D0-0.6D0*T)*COS(A) +* 10 + DP=DP+(1426D0-3.4D0*T)*SIN(ELP) + DE=DE+(54D0-0.1D0*T)*COS(ELP) +* 9 + A=F2-D2+OM2 + DP=DP+(-13187D0-1.6D0*T)*SIN(A) + DE=DE+(5736D0-3.1D0*T)*COS(A) +* 8 + DP=DP+SIN(EL2-F2+OM) +* 7 + A=-ELP2+F2-D2+OM + DP=DP-2D0*SIN(A) + DE=DE+1D0*COS(A) +* 6 + DP=DP-3D0*SIN(EL-ELP-D) +* 5 + A=-EL2+F2+OM2 + DP=DP-3D0*SIN(A) + DE=DE+1D0*COS(A) +* 4 + DP=DP+11D0*SIN(EL2-F2) +* 3 + A=-EL2+F2+OM + DP=DP+46D0*SIN(A) + DE=DE-24D0*COS(A) +* 2 + DP=DP+(2062D0+0.2D0*T)*SIN(OM2) + DE=DE+(-895D0+0.5D0*T)*COS(OM2) +* 1 + DP=DP+(-171996D0-174.2D0*T)*SIN(OM) + DE=DE+(92025D0+8.9D0*T)*COS(OM) + +* Convert results to radians + DPSI=DP*U2R + DEPS=DE*U2R + +* Mean obliquity + EPS0=AS2R*(84381.448D0+ + : (-46.8150D0+ + : (-0.00059D0+ + : 0.001813D0*T)*T)*T) + + END diff --git a/math/slalib/oap.f b/math/slalib/oap.f new file mode 100644 index 00000000..1e851d50 --- /dev/null +++ b/math/slalib/oap.f @@ -0,0 +1,193 @@ + SUBROUTINE slOAP ( TYPE, OB1, OB2, DATE, DUT, ELONGM, PHIM, + : HM, XP, YP, TDK, PMB, RH, WL, TLR, + : RAP, DAP ) +*+ +* - - - - +* O A P +* - - - - +* +* Observed to apparent place. +* +* Given: +* TYPE c*(*) type of coordinates - 'R', 'H' or 'A' (see below) +* OB1 d observed Az, HA or RA (radians; Az is N=0,E=90) +* OB2 d observed ZD or Dec (radians) +* DATE d UTC date/time (modified Julian Date, JD-2400000.5) +* DUT d delta UT: UT1-UTC (UTC seconds) +* ELONGM d mean longitude of the observer (radians, east +ve) +* PHIM d mean geodetic latitude of the observer (radians) +* HM d observer's height above sea level (metres) +* XP d polar motion x-coordinate (radians) +* YP d polar motion y-coordinate (radians) +* TDK d local ambient temperature (K; std=273.15D0) +* PMB d local atmospheric pressure (mb; std=1013.25D0) +* RH d local relative humidity (in the range 0D0-1D0) +* WL d effective wavelength (micron, e.g. 0.55D0) +* TLR d tropospheric lapse rate (K/metre, e.g. 0.0065D0) +* +* Returned: +* RAP d geocentric apparent right ascension +* DAP d geocentric apparent declination +* +* Notes: +* +* 1) Only the first character of the TYPE argument is significant. +* 'R' or 'r' indicates that OBS1 and OBS2 are the observed right +* ascension and declination; 'H' or 'h' indicates that they are +* hour angle (west +ve) and declination; anything else ('A' or +* 'a' is recommended) indicates that OBS1 and OBS2 are azimuth +* (north zero, east 90 deg) and zenith distance. (Zenith +* distance is used rather than elevation in order to reflect the +* fact that no allowance is made for depression of the horizon.) +* +* 2) The accuracy of the result is limited by the corrections for +* refraction. Providing the meteorological parameters are +* known accurately and there are no gross local effects, the +* predicted apparent RA,Dec should be within about 0.1 arcsec +* for a zenith distance of less than 70 degrees. Even at a +* topocentric zenith distance of 90 degrees, the accuracy in +* elevation should be better than 1 arcmin; useful results +* are available for a further 3 degrees, beyond which the +* slRFRO routine returns a fixed value of the refraction. +* The complementary routines slAOP (or slAOPQ) and slOAP +* (or slOAPQ) are self-consistent to better than 1 micro- +* arcsecond all over the celestial sphere. +* +* 3) It is advisable to take great care with units, as even +* unlikely values of the input parameters are accepted and +* processed in accordance with the models used. +* +* 4) "Observed" Az,El means the position that would be seen by a +* perfect theodolite located at the observer. This is +* related to the observed HA,Dec via the standard rotation, using +* the geodetic latitude (corrected for polar motion), while the +* observed HA and RA are related simply through the local +* apparent ST. "Observed" RA,Dec or HA,Dec thus means the +* position that would be seen by a perfect equatorial located +* at the observer and with its polar axis aligned to the +* Earth's axis of rotation (n.b. not to the refracted pole). +* By removing from the observed place the effects of +* atmospheric refraction and diurnal aberration, the +* geocentric apparent RA,Dec is obtained. +* +* 5) Frequently, mean rather than apparent RA,Dec will be required, +* in which case further transformations will be necessary. The +* slAMP etc routines will convert the apparent RA,Dec produced +* by the present routine into an "FK5" (J2000) mean place, by +* allowing for the Sun's gravitational lens effect, annual +* aberration, nutation and precession. Should "FK4" (1950) +* coordinates be needed, the routines slFK54 etc will also +* need to be applied. +* +* 6) To convert to apparent RA,Dec the coordinates read from a +* real telescope, corrections would have to be applied for +* encoder zero points, gear and encoder errors, tube flexure, +* the position of the rotator axis and the pointing axis +* relative to it, non-perpendicularity between the mounting +* axes, and finally for the tilt of the azimuth or polar axis +* of the mounting (with appropriate corrections for mount +* flexures). Some telescopes would, of course, exhibit other +* properties which would need to be accounted for at the +* appropriate point in the sequence. +* +* 7) This routine takes time to execute, due mainly to the rigorous +* integration used to evaluate the refraction. For processing +* multiple stars for one location and time, call slAOPA once +* followed by one call per star to slOAPQ. Where a range of +* times within a limited period of a few hours is involved, and the +* highest precision is not required, call slAOPA once, followed +* by a call to slAOPT each time the time changes, followed by +* one call per star to slOAPQ. +* +* 8) The DATE argument is UTC expressed as an MJD. This is, strictly +* speaking, wrong, because of leap seconds. However, as long as +* the delta UT and the UTC are consistent there are no +* difficulties, except during a leap second. In this case, the +* start of the 61st second of the final minute should begin a new +* MJD day and the old pre-leap delta UT should continue to be used. +* As the 61st second completes, the MJD should revert to the start +* of the day as, simultaneously, the delta UTC changes by one +* second to its post-leap new value. +* +* 9) The delta UT (UT1-UTC) is tabulated in IERS circulars and +* elsewhere. It increases by exactly one second at the end of +* each UTC leap second, introduced in order to keep delta UT +* within +/- 0.9 seconds. +* +* 10) IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. +* The longitude required by the present routine is east-positive, +* in accordance with geographical convention (and right-handed). +* In particular, note that the longitudes returned by the +* slOBS routine are west-positive, following astronomical +* usage, and must be reversed in sign before use in the present +* routine. +* +* 11) The polar coordinates XP,YP can be obtained from IERS +* circulars and equivalent publications. The maximum amplitude +* is about 0.3 arcseconds. If XP,YP values are unavailable, +* use XP=YP=0D0. See page B60 of the 1988 Astronomical Almanac +* for a definition of the two angles. +* +* 12) The height above sea level of the observing station, HM, +* can be obtained from the Astronomical Almanac (Section J +* in the 1988 edition), or via the routine slOBS. If P, +* the pressure in millibars, is available, an adequate +* estimate of HM can be obtained from the expression +* +* HM ~ -29.3D0*TSL*LOG(P/1013.25D0). +* +* where TSL is the approximate sea-level air temperature in K +* (see Astrophysical Quantities, C.W.Allen, 3rd edition, +* section 52). Similarly, if the pressure P is not known, +* it can be estimated from the height of the observing +* station, HM, as follows: +* +* P ~ 1013.25D0*EXP(-HM/(29.3D0*TSL)). +* +* Note, however, that the refraction is nearly proportional to the +* pressure and that an accurate P value is important for precise +* work. +* +* 13) The azimuths etc. used by the present routine are with respect +* to the celestial pole. Corrections from the terrestrial pole +* can be computed using slPLMO. +* +* Called: slAOPA, slOAPQ +* +* Last revision: 2 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) TYPE + DOUBLE PRECISION OB1,OB2,DATE,DUT,ELONGM,PHIM,HM, + : XP,YP,TDK,PMB,RH,WL,TLR,RAP,DAP + + DOUBLE PRECISION AOPRMS(14) + + + CALL slAOPA(DATE,DUT,ELONGM,PHIM,HM,XP,YP,TDK,PMB,RH,WL,TLR, + : AOPRMS) + CALL slOAPQ(TYPE,OB1,OB2,AOPRMS,RAP,DAP) + + END diff --git a/math/slalib/oapqk.f b/math/slalib/oapqk.f new file mode 100644 index 00000000..7e8a2bb5 --- /dev/null +++ b/math/slalib/oapqk.f @@ -0,0 +1,251 @@ + SUBROUTINE slOAPQ (TYPE, OB1, OB2, AOPRMS, RAP, DAP) +*+ +* - - - - - - +* O A P Q +* - - - - - - +* +* Quick observed to apparent place +* +* Given: +* TYPE c*(*) type of coordinates - 'R', 'H' or 'A' (see below) +* OB1 d observed Az, HA or RA (radians; Az is N=0,E=90) +* OB2 d observed ZD or Dec (radians) +* AOPRMS d(14) star-independent apparent-to-observed parameters: +* +* (1) geodetic latitude (radians) +* (2,3) sine and cosine of geodetic latitude +* (4) magnitude of diurnal aberration vector +* (5) height (HM) +* (6) ambient temperature (T) +* (7) pressure (P) +* (8) relative humidity (RH) +* (9) wavelength (WL) +* (10) lapse rate (TLR) +* (11,12) refraction constants A and B (radians) +* (13) longitude + eqn of equinoxes + sidereal DUT (radians) +* (14) local apparent sidereal time (radians) +* +* Returned: +* RAP d geocentric apparent right ascension +* DAP d geocentric apparent declination +* +* Notes: +* +* 1) Only the first character of the TYPE argument is significant. +* 'R' or 'r' indicates that OBS1 and OBS2 are the observed right +* ascension and declination; 'H' or 'h' indicates that they are +* hour angle (west +ve) and declination; anything else ('A' or +* 'a' is recommended) indicates that OBS1 and OBS2 are azimuth +* (north zero, east 90 deg) and zenith distance. (Zenith distance +* is used rather than elevation in order to reflect the fact that +* no allowance is made for depression of the horizon.) +* +* 2) The accuracy of the result is limited by the corrections for +* refraction. Providing the meteorological parameters are +* known accurately and there are no gross local effects, the +* predicted apparent RA,Dec should be within about 0.1 arcsec +* for a zenith distance of less than 70 degrees. Even at a +* topocentric zenith distance of 90 degrees, the accuracy in +* elevation should be better than 1 arcmin; useful results +* are available for a further 3 degrees, beyond which the +* slRFRO routine returns a fixed value of the refraction. +* The complementary routines slAOP (or slAOPQ) and slOAP +* (or slOAPQ) are self-consistent to better than 1 micro- +* arcsecond all over the celestial sphere. +* +* 3) It is advisable to take great care with units, as even +* unlikely values of the input parameters are accepted and +* processed in accordance with the models used. +* +* 5) "Observed" Az,El means the position that would be seen by a +* perfect theodolite located at the observer. This is +* related to the observed HA,Dec via the standard rotation, using +* the geodetic latitude (corrected for polar motion), while the +* observed HA and RA are related simply through the local +* apparent ST. "Observed" RA,Dec or HA,Dec thus means the +* position that would be seen by a perfect equatorial located +* at the observer and with its polar axis aligned to the +* Earth's axis of rotation (n.b. not to the refracted pole). +* By removing from the observed place the effects of +* atmospheric refraction and diurnal aberration, the +* geocentric apparent RA,Dec is obtained. +* +* 5) Frequently, mean rather than apparent RA,Dec will be required, +* in which case further transformations will be necessary. The +* slAMP etc routines will convert the apparent RA,Dec produced +* by the present routine into an "FK5" (J2000) mean place, by +* allowing for the Sun's gravitational lens effect, annual +* aberration, nutation and precession. Should "FK4" (1950) +* coordinates be needed, the routines slFK54 etc will also +* need to be applied. +* +* 6) To convert to apparent RA,Dec the coordinates read from a +* real telescope, corrections would have to be applied for +* encoder zero points, gear and encoder errors, tube flexure, +* the position of the rotator axis and the pointing axis +* relative to it, non-perpendicularity between the mounting +* axes, and finally for the tilt of the azimuth or polar axis +* of the mounting (with appropriate corrections for mount +* flexures). Some telescopes would, of course, exhibit other +* properties which would need to be accounted for at the +* appropriate point in the sequence. +* +* 7) The star-independent apparent-to-observed-place parameters +* in AOPRMS may be computed by means of the slAOPA routine. +* If nothing has changed significantly except the time, the +* slAOPT routine may be used to perform the requisite +* partial recomputation of AOPRMS. +* +* 8) The azimuths etc used by the present routine are with respect +* to the celestial pole. Corrections from the terrestrial pole +* can be computed using slPLMO. +* +* Called: slDS2C, slDC2S, slRFRO, slDA2P +* +* Last revision: 29 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) TYPE + DOUBLE PRECISION OB1,OB2,AOPRMS(14),RAP,DAP + +* Breakpoint for fast/slow refraction algorithm: +* ZD greater than arctan(4), (see slRFCO routine) +* or vector Z less than cosine(arctan(Z)) = 1/sqrt(17) + DOUBLE PRECISION ZBREAK + PARAMETER (ZBREAK=0.242535625D0) + + CHARACTER C + DOUBLE PRECISION C1,C2,SPHI,CPHI,ST,CE,XAEO,YAEO,ZAEO,V(3), + : XMHDO,YMHDO,ZMHDO,AZ,SZ,ZDO,TZ,DREF,ZDT, + : XAET,YAET,ZAET,XMHDA,YMHDA,ZMHDA,DIURAB,F,HMA + + DOUBLE PRECISION slDA2P + + + +* Coordinate type + C = TYPE(1:1) + +* Coordinates + C1 = OB1 + C2 = OB2 + +* Sin, cos of latitude + SPHI = AOPRMS(2) + CPHI = AOPRMS(3) + +* Local apparent sidereal time + ST = AOPRMS(14) + +* Standardise coordinate type + IF (C.EQ.'R'.OR.C.EQ.'r') THEN + C = 'R' + ELSE IF (C.EQ.'H'.OR.C.EQ.'h') THEN + C = 'H' + ELSE + C = 'A' + END IF + +* If Az,ZD convert to Cartesian (S=0,E=90) + IF (C.EQ.'A') THEN + CE = SIN(C2) + XAEO = -COS(C1)*CE + YAEO = SIN(C1)*CE + ZAEO = COS(C2) + ELSE + +* If RA,Dec convert to HA,Dec + IF (C.EQ.'R') THEN + C1 = ST-C1 + END IF + +* To Cartesian -HA,Dec + CALL slDS2C(-C1,C2,V) + XMHDO = V(1) + YMHDO = V(2) + ZMHDO = V(3) + +* To Cartesian Az,El (S=0,E=90) + XAEO = SPHI*XMHDO-CPHI*ZMHDO + YAEO = YMHDO + ZAEO = CPHI*XMHDO+SPHI*ZMHDO + END IF + +* Azimuth (S=0,E=90) + IF (XAEO.NE.0D0.OR.YAEO.NE.0D0) THEN + AZ = ATAN2(YAEO,XAEO) + ELSE + AZ = 0D0 + END IF + +* Sine of observed ZD, and observed ZD + SZ = SQRT(XAEO*XAEO+YAEO*YAEO) + ZDO = ATAN2(SZ,ZAEO) + +* +* Refraction +* ---------- + +* Large zenith distance? + IF (ZAEO.GE.ZBREAK) THEN + +* Fast algorithm using two constant model + TZ = SZ/ZAEO + DREF = (AOPRMS(11)+AOPRMS(12)*TZ*TZ)*TZ + + ELSE + +* Rigorous algorithm for large ZD + CALL slRFRO(ZDO,AOPRMS(5),AOPRMS(6),AOPRMS(7),AOPRMS(8), + : AOPRMS(9),AOPRMS(1),AOPRMS(10),1D-8,DREF) + END IF + + ZDT = ZDO+DREF + +* To Cartesian Az,ZD + CE = SIN(ZDT) + XAET = COS(AZ)*CE + YAET = SIN(AZ)*CE + ZAET = COS(ZDT) + +* Cartesian Az,ZD to Cartesian -HA,Dec + XMHDA = SPHI*XAET+CPHI*ZAET + YMHDA = YAET + ZMHDA = -CPHI*XAET+SPHI*ZAET + +* Diurnal aberration + DIURAB = -AOPRMS(4) + F = (1D0-DIURAB*YMHDA) + V(1) = F*XMHDA + V(2) = F*(YMHDA+DIURAB) + V(3) = F*ZMHDA + +* To spherical -HA,Dec + CALL slDC2S(V,HMA,DAP) + +* Right Ascension + RAP = slDA2P(ST+HMA) + + END diff --git a/math/slalib/obs.f b/math/slalib/obs.f new file mode 100644 index 00000000..5aad21d1 --- /dev/null +++ b/math/slalib/obs.f @@ -0,0 +1,943 @@ + SUBROUTINE slOBS (N, C, NAME, W, P, H) +*+ +* - - - - +* O B S +* - - - - +* +* Parameters of selected groundbased observing stations +* +* Given: +* N int number specifying observing station +* +* Either given or returned +* C c*(*) identifier specifying observing station +* +* Returned: +* NAME c*(*) name of specified observing station +* W dp longitude (radians, West +ve) +* P dp geodetic latitude (radians, North +ve) +* H dp height above sea level (metres) +* +* Notes: +* +* Station identifiers C may be up to 10 characters long, +* and station names NAME may be up to 40 characters long. +* +* C and N are alternative ways of specifying the observing +* station. The C option, which is the most generally useful, +* may be selected by specifying an N value of zero or less. +* If N is 1 or more, the parameters of the Nth station +* in the currently supported list are interrogated, and +* the station identifier C is returned as well as NAME, W, +* P and H. +* +* If the station parameters are not available, either because +* the station identifier C is not recognized, or because an +* N value greater than the number of stations supported is +* given, a name of '?' is returned and C, W, P and H are left +* in their current states. +* +* Programs can obtain a list of all currently supported +* stations by calling the routine repeatedly, with N=1,2,3... +* When NAME='?' is seen, the list of stations has been +* exhausted. +* +* Station numbers, identifiers, names and other details are +* subject to change and should not be hardwired into +* application programs. +* +* All station identifiers C are uppercase only; lowercase +* characters must be converted to uppercase by the calling +* program. The station names returned may contain both upper- +* and lowercase. All characters up to the first space are +* checked; thus an abbreviated ID will return the parameters +* for the first station in the list which matches the +* abbreviation supplied, and no station in the list will ever +* contain embedded spaces. C must not have leading spaces. +* +* IMPORTANT -- BEWARE OF THE LONGITUDE SIGN CONVENTION. The +* longitude returned by slOBS is west-positive in accordance +* with astronomical usage. However, this sign convention is +* left-handed and is the opposite of the one used by geographers; +* elsewhere in SLALIB the preferable east-positive convention is +* used. In particular, note that for use in slAOP, slAOPA +* and slOAP the sign of the longitude must be reversed. +* +* Users are urged to inform the author of any improvements +* they would like to see made. For example: +* +* typographical corrections +* more accurate parameters +* better station identifiers or names +* additional stations +* +* P.T.Wallace Starlink 15 March 2002 +* +* Copyright (C) 2002 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER N + CHARACTER C*(*),NAME*(*) + DOUBLE PRECISION W,P,H + + INTEGER NMAX,M,NS,I + CHARACTER*10 CC + + DOUBLE PRECISION AS2R,WEST,NORTH,EAST,SOUTH + INTEGER ID,IAM + REAL AS + PARAMETER (AS2R=0.484813681109535994D-5) + +* Table of station identifiers + PARAMETER (NMAX=83) + CHARACTER*10 CTAB(NMAX) + DATA CTAB (1) /'AAT '/ + DATA CTAB (2) /'LPO4.2 '/ + DATA CTAB (3) /'LPO2.5 '/ + DATA CTAB (4) /'LPO1 '/ + DATA CTAB (5) /'LICK120 '/ + DATA CTAB (6) /'MMT '/ + DATA CTAB (7) /'DAO72 '/ + DATA CTAB (8) /'DUPONT '/ + DATA CTAB (9) /'MTHOP1.5 '/ + DATA CTAB (10) /'STROMLO74 '/ + DATA CTAB (11) /'ANU2.3 '/ + DATA CTAB (12) /'GBVA140 '/ + DATA CTAB (13) /'TOLOLO4M '/ + DATA CTAB (14) /'TOLOLO1.5M'/ + DATA CTAB (15) /'TIDBINBLA '/ + DATA CTAB (16) /'BLOEMF '/ + DATA CTAB (17) /'BOSQALEGRE'/ + DATA CTAB (18) /'FLAGSTF61 '/ + DATA CTAB (19) /'LOWELL72 '/ + DATA CTAB (20) /'HARVARD '/ + DATA CTAB (21) /'OKAYAMA '/ + DATA CTAB (22) /'KPNO158 '/ + DATA CTAB (23) /'KPNO90 '/ + DATA CTAB (24) /'KPNO84 '/ + DATA CTAB (25) /'KPNO36FT '/ + DATA CTAB (26) /'KOTTAMIA '/ + DATA CTAB (27) /'ESO3.6 '/ + DATA CTAB (28) /'MAUNAK88 '/ + DATA CTAB (29) /'UKIRT '/ + DATA CTAB (30) /'QUEBEC1.6 '/ + DATA CTAB (31) /'MTEKAR '/ + DATA CTAB (32) /'MTLEMMON60'/ + DATA CTAB (33) /'MCDONLD2.7'/ + DATA CTAB (34) /'MCDONLD2.1'/ + DATA CTAB (35) /'PALOMAR200'/ + DATA CTAB (36) /'PALOMAR60 '/ + DATA CTAB (37) /'DUNLAP74 '/ + DATA CTAB (38) /'HPROV1.93 '/ + DATA CTAB (39) /'HPROV1.52 '/ + DATA CTAB (40) /'SANPM83 '/ + DATA CTAB (41) /'SAAO74 '/ + DATA CTAB (42) /'TAUTNBG '/ + DATA CTAB (43) /'CATALINA61'/ + DATA CTAB (44) /'STEWARD90 '/ + DATA CTAB (45) /'USSR6 '/ + DATA CTAB (46) /'ARECIBO '/ + DATA CTAB (47) /'CAMB5KM '/ + DATA CTAB (48) /'CAMB1MILE '/ + DATA CTAB (49) /'EFFELSBERG'/ + DATA CTAB (50) /'GBVA300 '/ + DATA CTAB (51) /'JODRELL1 '/ + DATA CTAB (52) /'PARKES '/ + DATA CTAB (53) /'VLA '/ + DATA CTAB (54) /'SUGARGROVE'/ + DATA CTAB (55) /'USSR600 '/ + DATA CTAB (56) /'NOBEYAMA '/ + DATA CTAB (57) /'JCMT '/ + DATA CTAB (58) /'ESONTT '/ + DATA CTAB (59) /'ST.ANDREWS'/ + DATA CTAB (60) /'APO3.5 '/ + DATA CTAB (61) /'KECK1 '/ + DATA CTAB (62) /'TAUTSCHM '/ + DATA CTAB (63) /'PALOMAR48 '/ + DATA CTAB (64) /'UKST '/ + DATA CTAB (65) /'KISO '/ + DATA CTAB (66) /'ESOSCHM '/ + DATA CTAB (67) /'ATCA '/ + DATA CTAB (68) /'MOPRA '/ + DATA CTAB (69) /'SUBARU '/ + DATA CTAB (70) /'CFHT '/ + DATA CTAB (71) /'KECK2 '/ + DATA CTAB (72) /'GEMININ '/ + DATA CTAB (73) /'FCRAO '/ + DATA CTAB (74) /'IRTF '/ + DATA CTAB (75) /'CSO '/ + DATA CTAB (76) /'VLT1 '/ + DATA CTAB (77) /'VLT2 '/ + DATA CTAB (78) /'VLT3 '/ + DATA CTAB (79) /'VLT4 '/ + DATA CTAB (80) /'GEMINIS '/ + DATA CTAB (81) /'KOSMA3M '/ + DATA CTAB (82) /'MAGELLAN1 '/ + DATA CTAB (83) /'MAGELLAN2 '/ + +* Degrees, arcminutes, arcseconds to radians + WEST(ID,IAM,AS)=AS2R*(DBLE(60*(60*ID+IAM))+DBLE(AS)) + NORTH(ID,IAM,AS)=WEST(ID,IAM,AS) + EAST(ID,IAM,AS)=-WEST(ID,IAM,AS) + SOUTH(ID,IAM,AS)=-WEST(ID,IAM,AS) + + + + +* Station specified by number or identifier? + IF (N.GT.0) THEN + +* Station specified by number + M=N + IF (M.LE.NMAX) C=CTAB(M) + + ELSE + +* Station specified by identifier: determine corresponding number + CC=C + DO NS=1,NMAX + DO I=1,10 + IF (CC(I:I).EQ.' ') GO TO 5 + IF (CC(I:I).NE.CTAB(NS)(I:I)) GO TO 1 + END DO + GO TO 5 + 1 CONTINUE + END DO + NS=NMAX+1 + 5 CONTINUE + IF (C(1:1).NE.' ') THEN + M=NS + ELSE + M=NMAX+1 + END IF + + END IF + +* +* Return parameters of Mth station +* -------------------------------- + + GO TO (10,20,30,40,50,60,70,80,90,100, + : 110,120,130,140,150,160,170,180,190,200, + : 210,220,230,240,250,260,270,280,290,300, + : 310,320,330,340,350,360,370,380,390,400, + : 410,420,430,440,450,460,470,480,490,500, + : 510,520,530,540,550,560,570,580,590,600, + : 610,620,630,640,650,660,670,680,690,700, + : 710,720,730,740,750,760,770,780,790,800, + : 810,820,830) M + GO TO 9000 + +* AAT (Observer's Guide) AAT + 10 CONTINUE + NAME='Anglo-Australian 3.9m Telescope' + W=EAST(149,03,57.91) + P=SOUTH(31,16,37.34) + H=1164D0 + GO TO 9999 + +* WHT (Gemini, April 1987) LPO4.2 + 20 CONTINUE + NAME='William Herschel 4.2m Telescope' + W=WEST(17,52,53.9) + P=NORTH(28,45,38.1) + H=2332D0 + GO TO 9999 + +* INT (Gemini, April 1987) LPO2.5 + 30 CONTINUE + NAME='Isaac Newton 2.5m Telescope' + W=WEST(17,52,39.5) + P=NORTH(28,45,43.2) + H=2336D0 + GO TO 9999 + +* JKT (Gemini, April 1987) LPO1 + 40 CONTINUE + NAME='Jacobus Kapteyn 1m Telescope' + W=WEST(17,52,41.2) + P=NORTH(28,45,39.9) + H=2364D0 + GO TO 9999 + +* Lick 120" (S.L.Allen, private communication, 2002) LICK120 + 50 CONTINUE + NAME='Lick 120 inch' + W=WEST(121,38,13.689) + P=NORTH(37,20,34.931) + H=1286D0 + GO TO 9999 + +* MMT 6.5m conversion (MMT Observatory website) MMT + 60 CONTINUE + NAME='MMT 6.5m, Mt Hopkins' + W=WEST(110,53,04.4) + P=NORTH(31,41,19.6) + H=2608D0 + GO TO 9999 + +* Victoria B.C. 1.85m (1984 Almanac) DAO72 + 70 CONTINUE + NAME='DAO Victoria BC 1.85 metre' + W=WEST(123,25,01.18) + P=NORTH(48,31,11.9) + H=238D0 + GO TO 9999 + +* Las Campanas (1983 Almanac) DUPONT + 80 CONTINUE + NAME='Du Pont 2.5m Telescope, Las Campanas' + W=WEST(70,42,9.) + P=SOUTH(29,00,11.) + H=2280D0 + GO TO 9999 + +* Mt Hopkins 1.5m (1983 Almanac) MTHOP1.5 + 90 CONTINUE + NAME='Mt Hopkins 1.5 metre' + W=WEST(110,52,39.00) + P=NORTH(31,40,51.4) + H=2344D0 + GO TO 9999 + +* Mt Stromlo 74" (1983 Almanac) STROMLO74 + 100 CONTINUE + NAME='Mount Stromlo 74 inch' + W=EAST(149,00,27.59) + P=SOUTH(35,19,14.3) + H=767D0 + GO TO 9999 + +* ANU 2.3m, SSO (Gary Hovey) ANU2.3 + 110 CONTINUE + NAME='Siding Spring 2.3 metre' + W=EAST(149,03,40.3) + P=SOUTH(31,16,24.1) + H=1149D0 + GO TO 9999 + +* Greenbank 140' (1983 Almanac) GBVA140 + 120 CONTINUE + NAME='Greenbank 140 foot' + W=WEST(79,50,09.61) + P=NORTH(38,26,15.4) + H=881D0 + GO TO 9999 + +* Cerro Tololo 4m (1982 Almanac) TOLOLO4M + 130 CONTINUE + NAME='Cerro Tololo 4 metre' + W=WEST(70,48,53.6) + P=SOUTH(30,09,57.8) + H=2235D0 + GO TO 9999 + +* Cerro Tololo 1.5m (1982 Almanac) TOLOLO1.5M + 140 CONTINUE + NAME='Cerro Tololo 1.5 metre' + W=WEST(70,48,54.5) + P=SOUTH(30,09,56.3) + H=2225D0 + GO TO 9999 + +* Tidbinbilla 64m (1982 Almanac) TIDBINBLA + 150 CONTINUE + NAME='Tidbinbilla 64 metre' + W=EAST(148,58,48.20) + P=SOUTH(35,24,14.3) + H=670D0 + GO TO 9999 + +* Bloemfontein 1.52m (1981 Almanac) BLOEMF + 160 CONTINUE + NAME='Bloemfontein 1.52 metre' + W=EAST(26,24,18.) + P=SOUTH(29,02,18.) + H=1387D0 + GO TO 9999 + +* Bosque Alegre 1.54m (1981 Almanac) BOSQALEGRE + 170 CONTINUE + NAME='Bosque Alegre 1.54 metre' + W=WEST(64,32,48.0) + P=SOUTH(31,35,53.) + H=1250D0 + GO TO 9999 + +* USNO 61" astrographic reflector, Flagstaff (1981 Almanac) FLAGSTF61 + 180 CONTINUE + NAME='USNO 61 inch astrograph, Flagstaff' + W=WEST(111,44,23.6) + P=NORTH(35,11,02.5) + H=2316D0 + GO TO 9999 + +* Lowell 72" (1981 Almanac) LOWELL72 + 190 CONTINUE + NAME='Perkins 72 inch, Lowell' + W=WEST(111,32,09.3) + P=NORTH(35,05,48.6) + H=2198D0 + GO TO 9999 + +* Harvard 1.55m (1981 Almanac) HARVARD + 200 CONTINUE + NAME='Harvard College Observatory 1.55m' + W=WEST(71,33,29.32) + P=NORTH(42,30,19.0) + H=185D0 + GO TO 9999 + +* Okayama 1.88m (1981 Almanac) OKAYAMA + 210 CONTINUE + NAME='Okayama 1.88 metre' + W=EAST(133,35,47.29) + P=NORTH(34,34,26.1) + H=372D0 + GO TO 9999 + +* Kitt Peak Mayall 4m (1981 Almanac) KPNO158 + 220 CONTINUE + NAME='Kitt Peak 158 inch' + W=WEST(111,35,57.61) + P=NORTH(31,57,50.3) + H=2120D0 + GO TO 9999 + +* Kitt Peak 90 inch (1981 Almanac) KPNO90 + 230 CONTINUE + NAME='Kitt Peak 90 inch' + W=WEST(111,35,58.24) + P=NORTH(31,57,46.9) + H=2071D0 + GO TO 9999 + +* Kitt Peak 84 inch (1981 Almanac) KPNO84 + 240 CONTINUE + NAME='Kitt Peak 84 inch' + W=WEST(111,35,51.56) + P=NORTH(31,57,29.2) + H=2096D0 + GO TO 9999 + +* Kitt Peak 36 foot (1981 Almanac) KPNO36FT + 250 CONTINUE + NAME='Kitt Peak 36 foot' + W=WEST(111,36,51.12) + P=NORTH(31,57,12.1) + H=1939D0 + GO TO 9999 + +* Kottamia 74" (1981 Almanac) KOTTAMIA + 260 CONTINUE + NAME='Kottamia 74 inch' + W=EAST(31,49,30.) + P=NORTH(29,55,54.) + H=476D0 + GO TO 9999 + +* La Silla 3.6m (1981 Almanac) ESO3.6 + 270 CONTINUE + NAME='ESO 3.6 metre' + W=WEST(70,43,36.) + P=SOUTH(29,15,36.) + H=2428D0 + GO TO 9999 + +* Mauna Kea 88 inch MAUNAK88 +* (IfA website, Richard Wainscoat) + 280 CONTINUE + NAME='Mauna Kea 88 inch' + W=WEST(155,28,09.96) + P=NORTH(19,49,22.77) + H=4213.6D0 + GO TO 9999 + +* UKIRT (IfA website, Richard Wainscoat) UKIRT + 290 CONTINUE + NAME='UK Infra Red Telescope' + W=WEST(155,28,13.18) + P=NORTH(19,49,20.75) + H=4198.5D0 + GO TO 9999 + +* Quebec 1.6m (1981 Almanac) QUEBEC1.6 + 300 CONTINUE + NAME='Quebec 1.6 metre' + W=WEST(71,09,09.7) + P=NORTH(45,27,20.6) + H=1114D0 + GO TO 9999 + +* Mt Ekar 1.82m (1981 Almanac) MTEKAR + 310 CONTINUE + NAME='Mt Ekar 1.82 metre' + W=EAST(11,34,15.) + P=NORTH(45,50,48.) + H=1365D0 + GO TO 9999 + +* Mt Lemmon 60" (1981 Almanac) MTLEMMON60 + 320 CONTINUE + NAME='Mt Lemmon 60 inch' + W=WEST(110,42,16.9) + P=NORTH(32,26,33.9) + H=2790D0 + GO TO 9999 + +* Mt Locke 2.7m (1981 Almanac) MCDONLD2.7 + 330 CONTINUE + NAME='McDonald 2.7 metre' + W=WEST(104,01,17.60) + P=NORTH(30,40,17.7) + H=2075D0 + GO TO 9999 + +* Mt Locke 2.1m (1981 Almanac) MCDONLD2.1 + 340 CONTINUE + NAME='McDonald 2.1 metre' + W=WEST(104,01,20.10) + P=NORTH(30,40,17.7) + H=2075D0 + GO TO 9999 + +* Palomar 200" (1981 Almanac) PALOMAR200 + 350 CONTINUE + NAME='Palomar 200 inch' + W=WEST(116,51,50.) + P=NORTH(33,21,22.) + H=1706D0 + GO TO 9999 + +* Palomar 60" (1981 Almanac) PALOMAR60 + 360 CONTINUE + NAME='Palomar 60 inch' + W=WEST(116,51,31.) + P=NORTH(33,20,56.) + H=1706D0 + GO TO 9999 + +* David Dunlap 74" (1981 Almanac) DUNLAP74 + 370 CONTINUE + NAME='David Dunlap 74 inch' + W=WEST(79,25,20.) + P=NORTH(43,51,46.) + H=244D0 + GO TO 9999 + +* Haute Provence 1.93m (1981 Almanac) HPROV1.93 + 380 CONTINUE + NAME='Haute Provence 1.93 metre' + W=EAST(5,42,46.75) + P=NORTH(43,55,53.3) + H=665D0 + GO TO 9999 + +* Haute Provence 1.52m (1981 Almanac) HPROV1.52 + 390 CONTINUE + NAME='Haute Provence 1.52 metre' + W=EAST(5,42,43.82) + P=NORTH(43,56,00.2) + H=667D0 + GO TO 9999 + +* San Pedro Martir 83" (1981 Almanac) SANPM83 + 400 CONTINUE + NAME='San Pedro Martir 83 inch' + W=WEST(115,27,47.) + P=NORTH(31,02,38.) + H=2830D0 + GO TO 9999 + +* Sutherland 74" (1981 Almanac) SAAO74 + 410 CONTINUE + NAME='Sutherland 74 inch' + W=EAST(20,48,44.3) + P=SOUTH(32,22,43.4) + H=1771D0 + GO TO 9999 + +* Tautenburg 2m (1981 Almanac) TAUTNBG + 420 CONTINUE + NAME='Tautenburg 2 metre' + W=EAST(11,42,45.) + P=NORTH(50,58,51.) + H=331D0 + GO TO 9999 + +* Catalina 61" (1981 Almanac) CATALINA61 + 430 CONTINUE + NAME='Catalina 61 inch' + W=WEST(110,43,55.1) + P=NORTH(32,25,00.7) + H=2510D0 + GO TO 9999 + +* Steward 90" (1981 Almanac) STEWARD90 + 440 CONTINUE + NAME='Steward 90 inch' + W=WEST(111,35,58.24) + P=NORTH(31,57,46.9) + H=2071D0 + GO TO 9999 + +* Russian 6m (1981 Almanac) USSR6 + 450 CONTINUE + NAME='USSR 6 metre' + W=EAST(41,26,30.0) + P=NORTH(43,39,12.) + H=2100D0 + GO TO 9999 + +* Arecibo 1000' (1981 Almanac) ARECIBO + 460 CONTINUE + NAME='Arecibo 1000 foot' + W=WEST(66,45,11.1) + P=NORTH(18,20,36.6) + H=496D0 + GO TO 9999 + +* Cambridge 5km (1981 Almanac) CAMB5KM + 470 CONTINUE + NAME='Cambridge 5km' + W=EAST(0,02,37.23) + P=NORTH(52,10,12.2) + H=17D0 + GO TO 9999 + +* Cambridge 1 mile (1981 Almanac) CAMB1MILE + 480 CONTINUE + NAME='Cambridge 1 mile' + W=EAST(0,02,21.64) + P=NORTH(52,09,47.3) + H=17D0 + GO TO 9999 + +* Bonn 100m (1981 Almanac) EFFELSBERG + 490 CONTINUE + NAME='Effelsberg 100 metre' + W=EAST(6,53,01.5) + P=NORTH(50,31,28.6) + H=366D0 + GO TO 9999 + +* Greenbank 300' (1981 Almanac) GBVA300 (R.I.P.) + 500 CONTINUE + NAME='Greenbank 300 foot' + W=WEST(79,50,56.36) + P=NORTH(38,25,46.3) + H=894D0 + GO TO 9999 + +* Jodrell Bank Mk 1 (1981 Almanac) JODRELL1 + 510 CONTINUE + NAME='Jodrell Bank 250 foot' + W=WEST(2,18,25.) + P=NORTH(53,14,10.5) + H=78D0 + GO TO 9999 + +* Australia Telescope Parkes Observatory PARKES +* (Peter te Lintel Hekkert) + 520 CONTINUE + NAME='Parkes 64 metre' + W=EAST(148,15,44.3591) + P=SOUTH(32,59,59.8657) + H=391.79D0 + GO TO 9999 + +* VLA (1981 Almanac) VLA + 530 CONTINUE + NAME='Very Large Array' + W=WEST(107,37,03.82) + P=NORTH(34,04,43.5) + H=2124D0 + GO TO 9999 + +* Sugar Grove 150' (1981 Almanac) SUGARGROVE + 540 CONTINUE + NAME='Sugar Grove 150 foot' + W=WEST(79,16,23.) + P=NORTH(38,31,14.) + H=705D0 + GO TO 9999 + +* Russian 600' (1981 Almanac) USSR600 + 550 CONTINUE + NAME='USSR 600 foot' + W=EAST(41,35,25.5) + P=NORTH(43,49,32.) + H=973D0 + GO TO 9999 + +* Nobeyama 45 metre mm dish (based on 1981 Almanac entry) NOBEYAMA + 560 CONTINUE + NAME='Nobeyama 45 metre' + W=EAST(138,29,12.) + P=NORTH(35,56,19.) + H=1350D0 + GO TO 9999 + +* James Clerk Maxwell 15 metre mm telescope, Mauna Kea JCMT +* From GPS measurements on 11Apr2007 for eSMA setup (R. Tilanus) + 570 CONTINUE + NAME='JCMT 15 metre' + W=WEST(155,28,37.30) + P=NORTH(19,49,22.22) + H=4124.75D0 + GO TO 9999 + +* ESO 3.5 metre NTT, La Silla (K.Wirenstrand) ESONTT + 580 CONTINUE + NAME='ESO 3.5 metre NTT' + W=WEST(70,43,07.) + P=SOUTH(29,15,30.) + H=2377D0 + GO TO 9999 + +* St Andrews University Observatory (1982 Almanac) ST.ANDREWS + 590 CONTINUE + NAME='St Andrews' + W=WEST(2,48,52.5) + P=NORTH(56,20,12.) + H=30D0 + GO TO 9999 + +* Apache Point 3.5 metre (R.Owen) APO3.5 + 600 CONTINUE + NAME='Apache Point 3.5m' + W=WEST(105,49,11.56) + P=NORTH(32,46,48.96) + H=2809D0 + GO TO 9999 + +* W.M.Keck Observatory, Telescope 1 KECK1 +* (William Lupton) + 610 CONTINUE + NAME='Keck 10m Telescope #1' + W=WEST(155,28,28.99) + P=NORTH(19,49,33.41) + H=4160D0 + GO TO 9999 + +* Tautenberg Schmidt (1983 Almanac) TAUTSCHM + 620 CONTINUE + NAME='Tautenberg 1.34 metre Schmidt' + W=EAST(11,42,45.0) + P=NORTH(50,58,51.0) + H=331D0 + GO TO 9999 + +* Palomar Schmidt (1981 Almanac) PALOMAR48 + 630 CONTINUE + NAME='Palomar 48-inch Schmidt' + W=WEST(116,51,32.0) + P=NORTH(33,21,26.0) + H=1706D0 + GO TO 9999 + +* UK Schmidt, Siding Spring (1983 Almanac) UKST + 640 CONTINUE + NAME='UK 1.2 metre Schmidt, Siding Spring' + W=EAST(149,04,12.8) + P=SOUTH(31,16,27.8) + H=1145D0 + GO TO 9999 + +* Kiso Schmidt, Japan (1981 Almanac) KISO + 650 CONTINUE + NAME='Kiso 1.05 metre Schmidt, Japan' + W=EAST(137,37,42.2) + P=NORTH(35,47,38.7) + H=1130D0 + GO TO 9999 + +* ESO Schmidt, La Silla (1981 Almanac) ESOSCHM + 660 CONTINUE + NAME='ESO 1 metre Schmidt, La Silla' + W=WEST(70,43,46.5) + P=SOUTH(29,15,25.8) + H=2347D0 + GO TO 9999 + +* Australia Telescope Compact Array ATCA +* (WGS84 coordinates of Station 35, Mark Calabretta) + 670 CONTINUE + NAME='Australia Telescope Compact Array' + W=EAST(149,33,00.500) + P=SOUTH(30,18,46.385) + H=236.9D0 + GO TO 9999 + +* Australia Telescope Mopra Observatory MOPRA +* (Peter te Lintel Hekkert) + 680 CONTINUE + NAME='ATNF Mopra Observatory' + W=EAST(149,05,58.732) + P=SOUTH(31,16,04.451) + H=850D0 + GO TO 9999 + +* Subaru telescope, Mauna Kea SUBARU +* (IfA website, Richard Wainscoat) + 690 CONTINUE + NAME='Subaru 8m telescope' + W=WEST(155,28,33.67) + P=NORTH(19,49,31.81) + H=4163D0 + GO TO 9999 + +* Canada-France-Hawaii Telescope, Mauna Kea CFHT +* (IfA website, Richard Wainscoat) + 700 CONTINUE + NAME='Canada-France-Hawaii 3.6m Telescope' + W=WEST(155,28,07.95) + P=NORTH(19,49,30.91) + H=4204.1D0 + GO TO 9999 + +* W.M.Keck Observatory, Telescope 2 KECK2 +* (William Lupton) + 710 CONTINUE + NAME='Keck 10m Telescope #2' + W=WEST(155,28,27.24) + P=NORTH(19,49,35.62) + H=4159.6D0 + GO TO 9999 + +* Gemini North, Mauna Kea GEMININ +* (IfA website, Richard Wainscoat) + 720 CONTINUE + NAME='Gemini North 8-m telescope' + W=WEST(155,28,08.57) + P=NORTH(19,49,25.69) + H=4213.4D0 + GO TO 9999 + +* Five College Radio Astronomy Observatory FCRAO +* (Tim Jenness) + 730 CONTINUE + NAME='Five College Radio Astronomy Obs' + W=WEST(72,20,42.0) + P=NORTH(42,23,30.0) + H=314D0 + GO TO 9999 + +* NASA Infra Red Telescope Facility IRTF +* (IfA website, Richard Wainscoat) + 740 CONTINUE + NAME='NASA IR Telescope Facility, Mauna Kea' + W=WEST(155,28,19.20) + P=NORTH(19,49,34.39) + H=4168.1D0 + GO TO 9999 + +* Caltech Submillimeter Observatory CSO +* (IfA website, Richard Wainscoat; height estimated) + 750 CONTINUE + NAME='Caltech Sub-mm Observatory, Mauna Kea' + W=WEST(155,28,31.79) + P=NORTH(19,49,20.78) + H=4080D0 + GO TO 9999 + +* ESO VLT, UT1 VLT1 +* (ESO website, VLT Whitebook Chapter 2) + 760 CONTINUE + NAME='ESO VLT, Paranal, Chile: UT1' + W=WEST(70,24,11.642) + P=SOUTH(24,37,33.117) + H=2635.43 + GO TO 9999 + +* ESO VLT, UT2 VLT2 +* (ESO website, VLT Whitebook Chapter 2) + 770 CONTINUE + NAME='ESO VLT, Paranal, Chile: UT2' + W=WEST(70,24,10.855) + P=SOUTH(24,37,31.465) + H=2635.43 + GO TO 9999 + +* ESO VLT, UT3 VLT3 +* (ESO website, VLT Whitebook Chapter 2) + 780 CONTINUE + NAME='ESO VLT, Paranal, Chile: UT3' + W=WEST(70,24,09.896) + P=SOUTH(24,37,30.300) + H=2635.43 + GO TO 9999 + +* ESO VLT, UT4 VLT4 +* (ESO website, VLT Whitebook Chapter 2) + 790 CONTINUE + NAME='ESO VLT, Paranal, Chile: UT4' + W=WEST(70,24,08.000) + P=SOUTH(24,37,31.000) + H=2635.43 + GO TO 9999 + +* Gemini South, Cerro Pachon GEMINIS +* (GPS readings by Patrick Wallace) + 800 CONTINUE + NAME='Gemini South 8-m telescope' + W=WEST(70,44,11.5) + P=SOUTH(30,14,26.7) + H=2738D0 + GO TO 9999 + +* Cologne Observatory for Submillimeter Astronomy (KOSMA) KOSMA3M +* (Holger Jakob) + 810 CONTINUE + NAME='KOSMA 3m telescope, Gornergrat' + W=EAST(7,47,3.48) + P=NORTH(45,58,59.772) + H=3141D0 + GO TO 9999 + +* Magellan 1, 6.5m telescope at Las Campanas, Chile MAGELLAN1 +* (Skip Schaller) + 820 CONTINUE + NAME='Magellan 1, 6.5m, Las Campanas' + W=WEST(70,41,31.9) + P=SOUTH(29,00,51.7) + H=2408D0 + GO TO 9999 + +* Magellan 2, 6.5m telescope at Las Campanas, Chile MAGELLAN2 +* (Skip Schaller) + 830 CONTINUE + NAME='Magellan 2, 6.5m, Las Campanas' + W=WEST(70,41,33.5) + P=SOUTH(29,00,50.3) + H=2408D0 + GO TO 9999 + +* Unrecognized station + 9000 CONTINUE + NAME='?' + +* Exit + 9999 CONTINUE + + END diff --git a/math/slalib/pa.f b/math/slalib/pa.f new file mode 100644 index 00000000..88d21105 --- /dev/null +++ b/math/slalib/pa.f @@ -0,0 +1,64 @@ + DOUBLE PRECISION FUNCTION slPA (HA, DEC, PHI) +*+ +* - - - +* P A +* - - - +* +* HA, Dec to Parallactic Angle (double precision) +* +* Given: +* HA d hour angle in radians (geocentric apparent) +* DEC d declination in radians (geocentric apparent) +* PHI d observatory latitude in radians (geodetic) +* +* The result is in the range -pi to +pi +* +* Notes: +* +* 1) The parallactic angle at a point in the sky is the position +* angle of the vertical, i.e. the angle between the direction to +* the pole and to the zenith. In precise applications care must +* be taken only to use geocentric apparent HA,Dec and to consider +* separately the effects of atmospheric refraction and telescope +* mount errors. +* +* 2) At the pole a zero result is returned. +* +* P.T.Wallace Starlink 16 August 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION HA,DEC,PHI + + DOUBLE PRECISION CP,SQSZ,CQSZ + + + + CP=COS(PHI) + SQSZ=CP*SIN(HA) + CQSZ=SIN(PHI)*COS(DEC)-CP*SIN(DEC)*COS(HA) + IF (SQSZ.EQ.0D0.AND.CQSZ.EQ.0D0) CQSZ=1D0 + slPA=ATAN2(SQSZ,CQSZ) + + END diff --git a/math/slalib/pav.f b/math/slalib/pav.f new file mode 100644 index 00000000..6e6af8a3 --- /dev/null +++ b/math/slalib/pav.f @@ -0,0 +1,71 @@ + REAL FUNCTION slPAV ( V1, V2 ) +*+ +* - - - - +* P A V +* - - - - +* +* Position angle of one celestial direction with respect to another. +* +* (single precision) +* +* Given: +* V1 r(3) direction cosines of one point +* V2 r(3) direction cosines of the other point +* +* (The coordinate frames correspond to RA,Dec, Long,Lat etc.) +* +* The result is the bearing (position angle), in radians, of point +* V2 with respect to point V1. It is in the range +/- pi. The +* sense is such that if V2 is a small distance east of V1, the +* bearing is about +pi/2. Zero is returned if the two points +* are coincident. +* +* V1 and V2 do not have to be unit vectors. +* +* The routine slBEAR performs an equivalent function except +* that the points are specified in the form of spherical +* coordinates. +* +* Called: slDPAV +* +* Last revision: 11 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V1(3), V2(3) + + INTEGER I + DOUBLE PRECISION D1(3), D2(3) + + DOUBLE PRECISION slDPAV + + +* Call the double precision version. + DO I=1,3 + D1(I) = V1(I) + D2(I) = V2(I) + END DO + slPAV = REAL(slDPAV(D1,D2)) + + END diff --git a/math/slalib/pcd.f b/math/slalib/pcd.f new file mode 100644 index 00000000..cef1dbf7 --- /dev/null +++ b/math/slalib/pcd.f @@ -0,0 +1,77 @@ + SUBROUTINE slPCD (DISCO,X,Y) +*+ +* - - - - +* P C D +* - - - - +* +* Apply pincushion/barrel distortion to a tangent-plane [x,y]. +* +* Given: +* DISCO d pincushion/barrel distortion coefficient +* X,Y d tangent-plane coordinates +* +* Returned: +* X,Y d distorted coordinates +* +* Notes: +* +* 1) The distortion is of the form RP = R*(1 + C*R**2), where R is +* the radial distance from the tangent point, C is the DISCO +* argument, and RP is the radial distance in the presence of +* the distortion. +* +* 2) For pincushion distortion, C is +ve; for barrel distortion, +* C is -ve. +* +* 3) For X,Y in units of one projection radius (in the case of +* a photographic plate, the focal length), the following +* DISCO values apply: +* +* Geometry DISCO +* +* astrograph 0.0 +* Schmidt -0.3333 +* AAT PF doublet +147.069 +* AAT PF triplet +178.585 +* AAT f/8 +21.20 +* JKT f/8 +13.32 +* +* 4) There is a companion routine, slUPCD, which performs the +* inverse operation. +* +* P.T.Wallace Starlink 3 September 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DISCO,X,Y + + DOUBLE PRECISION F + + + + F=1D0+DISCO*(X*X+Y*Y) + X=X*F + Y=Y*F + + END diff --git a/math/slalib/pda2h.f b/math/slalib/pda2h.f new file mode 100644 index 00000000..ea8a3425 --- /dev/null +++ b/math/slalib/pda2h.f @@ -0,0 +1,118 @@ + SUBROUTINE slPDAH (P, D, A, H1, J1, H2, J2) +*+ +* - - - - - - +* P D A H +* - - - - - - +* +* Hour Angle corresponding to a given azimuth +* +* (double precision) +* +* Given: +* P d latitude +* D d declination +* A d azimuth +* +* Returned: +* H1 d hour angle: first solution if any +* J1 i flag: 0 = solution 1 is valid +* H2 d hour angle: second solution if any +* J2 i flag: 0 = solution 2 is valid +* +* Called: slDA1P +* +* P.T.Wallace Starlink 6 October 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION P,D,A,H1 + INTEGER J1 + DOUBLE PRECISION H2 + INTEGER J2 + + DOUBLE PRECISION DPI + PARAMETER (DPI=3.141592653589793238462643D0) + DOUBLE PRECISION D90 + PARAMETER (D90=DPI/2D0) + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-12) + DOUBLE PRECISION PN,AN,DN,SA,CA,SASP,QT,QB,HPT,T + DOUBLE PRECISION slDA1P + + +* Preset status flags to OK + J1=0 + J2=0 + +* Adjust latitude, azimuth, declination to avoid critical values + PN=slDA1P(P) + IF (ABS(ABS(PN)-D90).LT.TINY) THEN + PN=PN-SIGN(TINY,PN) + ELSE IF (ABS(PN).LT.TINY) THEN + PN=TINY + END IF + AN=slDA1P(A) + IF (ABS(ABS(AN)-DPI).LT.TINY) THEN + AN=AN-SIGN(TINY,AN) + ELSE IF (ABS(AN).LT.TINY) THEN + AN=TINY + END IF + DN=slDA1P(D) + IF (ABS(ABS(DN)-ABS(P)).LT.TINY) THEN + DN=DN-SIGN(TINY,DN) + ELSE IF (ABS(ABS(DN)-D90).LT.TINY) THEN + DN=DN-SIGN(TINY,DN) + ELSE IF (ABS(DN).LT.TINY) THEN + DN=TINY + END IF + +* Useful functions + SA=SIN(AN) + CA=COS(AN) + SASP=SA*SIN(PN) + +* Quotient giving sin(h+t) + QT=SIN(DN)*SA*COS(PN) + QB=COS(DN)*SQRT(CA*CA+SASP*SASP) + +* Any solutions? + IF (ABS(QT).LE.QB) THEN + +* Yes: find h+t and t + HPT=ASIN(QT/QB) + T=ATAN2(SASP,-CA) + +* The two solutions + H1=slDA1P(HPT-T) + H2=slDA1P(-HPT-(T+DPI)) + +* Reject unless h and A different signs + IF (H1*AN.GT.0D0) J1=-1 + IF (H2*AN.GT.0D0) J2=-1 + ELSE + J1=-1 + J2=-1 + END IF + + END diff --git a/math/slalib/pdq2h.f b/math/slalib/pdq2h.f new file mode 100644 index 00000000..678bb3d7 --- /dev/null +++ b/math/slalib/pdq2h.f @@ -0,0 +1,116 @@ + SUBROUTINE slPDQH (P, D, Q, H1, J1, H2, J2) +*+ +* - - - - - - +* P D Q H +* - - - - - - +* +* Hour Angle corresponding to a given parallactic angle +* +* (double precision) +* +* Given: +* P d latitude +* D d declination +* Q d parallactic angle +* +* Returned: +* H1 d hour angle: first solution if any +* J1 i flag: 0 = solution 1 is valid +* H2 d hour angle: second solution if any +* J2 i flag: 0 = solution 2 is valid +* +* Called: slDA1P +* +* P.T.Wallace Starlink 6 October 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION P,D,Q,H1 + INTEGER J1 + DOUBLE PRECISION H2 + INTEGER J2 + + DOUBLE PRECISION DPI + PARAMETER (DPI=3.141592653589793238462643D0) + DOUBLE PRECISION D90 + PARAMETER (D90=DPI/2D0) + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-12) + DOUBLE PRECISION PN,QN,DN,SQ,CQ,SQSD,QT,QB,HPT,T + DOUBLE PRECISION slDA1P + + +* Preset status flags to OK + J1=0 + J2=0 + +* Adjust latitude, declination, parallactic angle to avoid critical values + PN=slDA1P(P) + IF (ABS(ABS(PN)-D90).LT.TINY) THEN + PN=PN-SIGN(TINY,PN) + ELSE IF (ABS(PN).LT.TINY) THEN + PN=TINY + END IF + QN=slDA1P(Q) + IF (ABS(ABS(QN)-DPI).LT.TINY) THEN + QN=QN-SIGN(TINY,QN) + ELSE IF (ABS(QN).LT.TINY) THEN + QN=TINY + END IF + DN=slDA1P(D) + IF (ABS(ABS(D)-ABS(P)).LT.TINY) THEN + DN=DN-SIGN(TINY,DN) + ELSE IF (ABS(ABS(D)-D90).LT.TINY) THEN + DN=DN-SIGN(TINY,DN) + END IF + +* Useful functions + SQ=SIN(QN) + CQ=COS(QN) + SQSD=SQ*SIN(DN) + +* Quotient giving sin(h+t) + QT=SIN(PN)*SQ*COS(DN) + QB=COS(PN)*SQRT(CQ*CQ+SQSD*SQSD) + +* Any solutions? + IF (ABS(QT).LE.QB) THEN + +* Yes: find h+t and t + HPT=ASIN(QT/QB) + T=ATAN2(SQSD,CQ) + +* The two solutions + H1=slDA1P(HPT-T) + H2=slDA1P(-HPT-(T+DPI)) + +* Reject if h and Q different signs + IF (H1*QN.LT.0D0) J1=-1 + IF (H2*QN.LT.0D0) J2=-1 + ELSE + J1=-1 + J2=-1 + END IF + + END diff --git a/math/slalib/permut.f b/math/slalib/permut.f new file mode 100644 index 00000000..b5aee8b7 --- /dev/null +++ b/math/slalib/permut.f @@ -0,0 +1,160 @@ + SUBROUTINE slPERM ( N, ISTATE, IORDER, J ) +*+ +* - - - - - - - +* P E R M U T +* - - - - - - - +* +* Generate the next permutation of a specified number of items. +* +* Given: +* N i number of items: there will be N! permutations +* +* Given and returned: +* ISTATE i(N) state, ISTATE(1)=-1 to initialize +* +* Returned: +* IORDER i(N) next permutation of numbers 1,2,...,N +* J i status: -1 = illegal N (zero or less is illegal) +* 0 = OK +* +1 = no more permutations available +* +* Notes: +* +* 1) This routine returns, in the IORDER array, the integers 1 to N +* inclusive, in an order that depends on the current contents of +* the ISTATE array. Before calling the routine for the first +* time, the caller must set the first element of the ISTATE array +* to -1 (any negative number will do) to cause the ISTATE array +* to be fully initialized. +* +* 2) The first permutation to be generated is: +* +* IORDER(1)=N, IORDER(2)=N-1, ..., IORDER(N)=1 +* +* This is also the permutation returned for the "finished" +* (J=1) case. +* +* The final permutation to be generated is: +* +* IORDER(1)=1, IORDER(2)=2, ..., IORDER(N)=N +* +* 3) If the "finished" (J=1) status is ignored, the routine continues +* to deliver permutations, the pattern repeating every N! calls. +* +* Last revision: 19 February 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER N,IORDER(N),ISTATE(N),J + + INTEGER I,IP1,ISLOT,ISKIP + + +* ------------- +* Preliminaries +* ------------- + +* Validate, and set status. + IF (N.LT.1) THEN + J = -1 + GO TO 9999 + ELSE + J = 0 + END IF + +* If just starting, initialize state array + IF (ISTATE(1).LT.0) THEN + ISTATE(1) = -1 + DO I=2,N + ISTATE(I) = 0 + END DO + END IF + +* -------------------------- +* Increment the state number +* -------------------------- + +* The state number, maintained in the ISTATE array, is a mixed-radix +* number with N! states. The least significant digit, with a radix of +* 1, is in ISTATE(1). The next digit, in ISTATE(2), has a radix of 2, +* and so on. + +* Increment the least-significant digit of the state number. + ISTATE(1) = ISTATE(1)+1 + +* Digit by digit starting with the least significant. + DO I=1,N + +* Carry? + IF (ISTATE(I).GE.I) THEN + +* Yes: reset the current digit. + ISTATE(I) = 0 + +* Overflow? + IF (I.GE.N) THEN + +* Yes: there are no more permutations. + J = 1 + ELSE + +* No: carry. + IP1 = I+1 + ISTATE(IP1) = ISTATE(IP1)+1 + END IF + END IF + END DO + +* ------------------------------------------------------------------- +* Translate the state number into the corresponding permutation order +* ------------------------------------------------------------------- + +* Initialize the order array. All but one element will be overwritten. + DO I=1,N + IORDER(I) = 1 + END DO + +* Look at each state number digit, starting with the most significant. + DO I=N,2,-1 + +* Initialize the position where the new number will go. + ISLOT = 0 + +* The state number digit says which unfilled slot is to be used. + DO ISKIP=0,ISTATE(I) + +* Increment the slot number until an unused slot is found. + ISLOT = ISLOT+1 + DO WHILE (IORDER(ISLOT).GT.1) + ISLOT = ISLOT+1 + END DO + END DO + +* Store the number in the permutation order array. + IORDER(ISLOT) = I + END DO + + 9999 CONTINUE + + END diff --git a/math/slalib/pertel.f b/math/slalib/pertel.f new file mode 100644 index 00000000..06bf3c42 --- /dev/null +++ b/math/slalib/pertel.f @@ -0,0 +1,182 @@ + SUBROUTINE slPRTL (JFORM, DATE0, DATE1, + : EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0, + : EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1, + : JSTAT) +*+ +* - - - - - - - +* P R T L +* - - - - - - - +* +* Update the osculating orbital elements of an asteroid or comet by +* applying planetary perturbations. +* +* Given (format and dates): +* JFORM i choice of element set (2 or 3; Note 1) +* DATE0 d date of osculation (TT MJD) for the given elements +* DATE1 d date of osculation (TT MJD) for the updated elements +* +* Given (the unperturbed elements): +* EPOCH0 d epoch (TT MJD) of the given element set (Note 2) +* ORBI0 d inclination (radians) +* ANODE0 d longitude of the ascending node (radians) +* PERIH0 d argument of perihelion (radians) +* AORQ0 d mean distance or perihelion distance (AU) +* E0 d eccentricity +* AM0 d mean anomaly (radians, JFORM=2 only) +* +* Returned (the updated elements): +* EPOCH1 d epoch (TT MJD) of the updated element set (Note 2) +* ORBI1 d inclination (radians) +* ANODE1 d longitude of the ascending node (radians) +* PERIH1 d argument of perihelion (radians) +* AORQ1 d mean distance or perihelion distance (AU) +* E1 d eccentricity +* AM1 d mean anomaly (radians, JFORM=2 only) +* +* Returned (status flag): +* JSTAT i status: +102 = warning, distant epoch +* +101 = warning, large timespan ( > 100 years) +* +1 to +10 = coincident with planet (Note 6) +* 0 = OK +* -1 = illegal JFORM +* -2 = illegal E0 +* -3 = illegal AORQ0 +* -4 = internal error +* -5 = numerical error +* +* Notes: +* +* 1 Two different element-format options are available: +* +* Option JFORM=2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBI = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e +* AM = mean anomaly M (radians) +* +* Option JFORM=3, suitable for comets: +* +* EPOCH = epoch of perihelion (TT MJD) +* ORBI = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e +* +* 2 DATE0, DATE1, EPOCH0 and EPOCH1 are all instants of time in +* the TT timescale (formerly Ephemeris Time, ET), expressed +* as Modified Julian Dates (JD-2400000.5). +* +* DATE0 is the instant at which the given (i.e. unperturbed) +* osculating elements are correct. +* +* DATE1 is the specified instant at which the updated osculating +* elements are correct. +* +* EPOCH0 and EPOCH1 will be the same as DATE0 and DATE1 +* (respectively) for the JFORM=2 case, normally used for minor +* planets. For the JFORM=3 case, the two epochs will refer to +* perihelion passage and so will not, in general, be the same as +* DATE0 and/or DATE1 though they may be similar to one another. +* +* 3 The elements are with respect to the J2000 ecliptic and equinox. +* +* 4 Unused elements (AM0 and AM1 for JFORM=3) are not accessed. +* +* 5 See the slPRTE routine for details of the algorithm used. +* +* 6 This routine is not intended to be used for major planets, which +* is why JFORM=1 is not available and why there is no opportunity +* to specify either the longitude of perihelion or the daily +* motion. However, if JFORM=2 elements are somehow obtained for a +* major planet and supplied to the routine, sensible results will, +* in fact, be produced. This happens because the slPRTE routine +* that is called to perform the calculations checks the separation +* between the body and each of the planets and interprets a +* suspiciously small value (0.001 AU) as an attempt to apply it to +* the planet concerned. If this condition is detected, the +* contribution from that planet is ignored, and the status is set to +* the planet number (1-10 = Mercury, Venus, EMB, Mars, Jupiter, +* Saturn, Uranus, Neptune, Earth, Moon) as a warning. +* +* Reference: +* +* Sterne, Theodore E., "An Introduction to Celestial Mechanics", +* Interscience Publishers Inc., 1960. Section 6.7, p199. +* +* Called: slELUE, slPRTE, slUEEL +* +* This revision: 19 June 2004 +* +* Copyright (C) 2004 P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + INTEGER JFORM + DOUBLE PRECISION DATE0,DATE1, + : EPOCH0,ORBI0,ANODE0,PERIH0,AORQ0,E0,AM0, + : EPOCH1,ORBI1,ANODE1,PERIH1,AORQ1,E1,AM1 + INTEGER JSTAT + + DOUBLE PRECISION U(13),DM + INTEGER J,JF + + + +* Check that the elements are either minor-planet or comet format. + IF (JFORM.LT.2.OR.JFORM.GT.3) THEN + JSTAT = -1 + GO TO 9999 + ELSE + +* Provisionally set the status to OK. + JSTAT = 0 + END IF + +* Transform the elements from conventional to universal form. + CALL slELUE(DATE0,JFORM,EPOCH0,ORBI0,ANODE0,PERIH0, + : AORQ0,E0,AM0,0D0,U,J) + IF (J.NE.0) THEN + JSTAT = J + GO TO 9999 + END IF + +* Update the universal elements. + CALL slPRTE(DATE1,U,J) + IF (J.GT.0) THEN + JSTAT = J + ELSE IF (J.LT.0) THEN + JSTAT = -5 + GO TO 9999 + END IF + +* Transform from universal to conventional elements. + CALL slUEEL(U,JFORM, + : JF, EPOCH1, ORBI1, ANODE1, PERIH1, + : AORQ1, E1, AM1, DM, J) + IF (JF.NE.JFORM.OR.J.NE.0) JSTAT=-5 + + 9999 CONTINUE + END diff --git a/math/slalib/pertue.f b/math/slalib/pertue.f new file mode 100644 index 00000000..fc9683c5 --- /dev/null +++ b/math/slalib/pertue.f @@ -0,0 +1,644 @@ + SUBROUTINE slPRTE (DATE, U, JSTAT) +*+ +* - - - - - - - +* P R T E +* - - - - - - - +* +* Update the universal elements of an asteroid or comet by applying +* planetary perturbations. +* +* Given: +* DATE d final epoch (TT MJD) for the updated elements +* +* Given and returned: +* U d(13) universal elements (updated in place) +* +* (1) combined mass (M+m) +* (2) total energy of the orbit (alpha) +* (3) reference (osculating) epoch (t0) +* (4-6) position at reference epoch (r0) +* (7-9) velocity at reference epoch (v0) +* (10) heliocentric distance at reference epoch +* (11) r0.v0 +* (12) date (t) +* (13) universal eccentric anomaly (psi) of date, approx +* +* Returned: +* JSTAT i status: +* +102 = warning, distant epoch +* +101 = warning, large timespan ( > 100 years) +* +1 to +10 = coincident with major planet (Note 5) +* 0 = OK +* -1 = numerical error +* +* Called: slEPJ, slPLNT, slPVUE, slUEPV, slEPV, +* slPREC, slDMON, slDMXV +* +* Notes: +* +* 1 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference 2). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* 2 The universal elements are with respect to the J2000 equator and +* equinox. +* +* 3 The epochs DATE, U(3) and U(12) are all Modified Julian Dates +* (JD-2400000.5). +* +* 4 The algorithm is a simplified form of Encke's method. It takes as +* a basis the unperturbed motion of the body, and numerically +* integrates the perturbing accelerations from the major planets. +* The expression used is essentially Sterne's 6.7-2 (reference 1). +* Everhart and Pitkin (reference 2) suggest rectifying the orbit at +* each integration step by propagating the new perturbed position +* and velocity as the new universal variables. In the present +* routine the orbit is rectified less frequently than this, in order +* to gain a slight speed advantage. However, the rectification is +* done directly in terms of position and velocity, as suggested by +* Everhart and Pitkin, bypassing the use of conventional orbital +* elements. +* +* The f(q) part of the full Encke method is not used. The purpose +* of this part is to avoid subtracting two nearly equal quantities +* when calculating the "indirect member", which takes account of the +* small change in the Sun's attraction due to the slightly displaced +* position of the perturbed body. A simpler, direct calculation in +* double precision proves to be faster and not significantly less +* accurate. +* +* Apart from employing a variable timestep, and occasionally +* "rectifying the orbit" to keep the indirect member small, the +* integration is done in a fairly straightforward way. The +* acceleration estimated for the middle of the timestep is assumed +* to apply throughout that timestep; it is also used in the +* extrapolation of the perturbations to the middle of the next +* timestep, to predict the new disturbed position. There is no +* iteration within a timestep. +* +* Measures are taken to reach a compromise between execution time +* and accuracy. The starting-point is the goal of achieving +* arcsecond accuracy for ordinary minor planets over a ten-year +* timespan. This goal dictates how large the timesteps can be, +* which in turn dictates how frequently the unperturbed motion has +* to be recalculated from the osculating elements. +* +* Within predetermined limits, the timestep for the numerical +* integration is varied in length in inverse proportion to the +* magnitude of the net acceleration on the body from the major +* planets. +* +* The numerical integration requires estimates of the major-planet +* motions. Approximate positions for the major planets (Pluto +* alone is omitted) are obtained from the routine slPLNT. Two +* levels of interpolation are used, to enhance speed without +* significantly degrading accuracy. At a low frequency, the routine +* slPLNT is called to generate updated position+velocity "state +* vectors". The only task remaining to be carried out at the full +* frequency (i.e. at each integration step) is to use the state +* vectors to extrapolate the planetary positions. In place of a +* strictly linear extrapolation, some allowance is made for the +* curvature of the orbit by scaling back the radius vector as the +* linear extrapolation goes off at a tangent. +* +* Various other approximations are made. For example, perturbations +* by Pluto and the minor planets are neglected and relativistic +* effects are not taken into account. +* +* In the interests of simplicity, the background calculations for +* the major planets are carried out en masse. The mean elements and +* state vectors for all the planets are refreshed at the same time, +* without regard for orbit curvature, mass or proximity. +* +* The Earth-Moon system is treated as a single body when the body is +* distant but as separate bodies when closer to the EMB than the +* parameter RNE, which incurs a time penalty but improves accuracy +* for near-Earth objects. +* +* 5 This routine is not intended to be used for major planets. +* However, if major-planet elements are supplied, sensible results +* will, in fact, be produced. This happens because the routine +* checks the separation between the body and each of the planets and +* interprets a suspiciously small value (0.001 AU) as an attempt to +* apply the routine to the planet concerned. If this condition is +* detected, the contribution from that planet is ignored, and the +* status is set to the planet number (1-10 = Mercury, Venus, EMB, +* Mars, Jupiter, Saturn, Uranus, Neptune, Earth, Moon) as a warning. +* +* References: +* +* 1 Sterne, Theodore E., "An Introduction to Celestial Mechanics", +* Interscience Publishers Inc., 1960. Section 6.7, p199. +* +* 2 Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* Last revision: 27 December 2004 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + DOUBLE PRECISION DATE,U(13) + INTEGER JSTAT + +* Distance from EMB at which Earth and Moon are treated separately + DOUBLE PRECISION RNE + PARAMETER (RNE=1D0) + +* Coincidence with major planet distance + DOUBLE PRECISION COINC + PARAMETER (COINC=0.0001D0) + +* Coefficient relating timestep to perturbing force + DOUBLE PRECISION TSC + PARAMETER (TSC=1D-4) + +* Minimum and maximum timestep (days) + DOUBLE PRECISION TSMIN,TSMAX + PARAMETER (TSMIN=0.01D0,TSMAX=10D0) + +* Age limit for major-planet state vector (days) + DOUBLE PRECISION AGEPMO + PARAMETER (AGEPMO=5D0) + +* Age limit for major-planet mean elements (days) + DOUBLE PRECISION AGEPEL + PARAMETER (AGEPEL=50D0) + +* Margin for error when deciding whether to renew the planetary data + DOUBLE PRECISION TINY + PARAMETER (TINY=1D-6) + +* Age limit for the body's osculating elements (before rectification) + DOUBLE PRECISION AGEBEL + PARAMETER (AGEBEL=100D0) + +* Gaussian gravitational constant (exact) and square + DOUBLE PRECISION GCON,GCON2 + PARAMETER (GCON=0.01720209895D0,GCON2=GCON*GCON) + +* The final epoch + DOUBLE PRECISION TFINAL + +* The body's current universal elements + DOUBLE PRECISION UL(13) + +* Current reference epoch + DOUBLE PRECISION T0 + +* Timespan from latest orbit rectification to final epoch (days) + DOUBLE PRECISION TSPAN + +* Time left to go before integration is complete + DOUBLE PRECISION TLEFT + +* Time direction flag: +1=forwards, -1=backwards + DOUBLE PRECISION FB + +* First-time flag + LOGICAL FIRST + +* +* The current perturbations +* +* Epoch (days relative to current reference epoch) + DOUBLE PRECISION RTN +* Position (AU) + DOUBLE PRECISION PERP(3) +* Velocity (AU/d) + DOUBLE PRECISION PERV(3) +* Acceleration (AU/d/d) + DOUBLE PRECISION PERA(3) +* + +* Length of current timestep (days), and half that + DOUBLE PRECISION TS,HTS + +* Epoch of middle of timestep + DOUBLE PRECISION T + +* Epoch of planetary mean elements + DOUBLE PRECISION TPEL + +* Planet number (1=Mercury, 2=Venus, 3=EMB...8=Neptune) + INTEGER NP + +* Planetary universal orbital elements + DOUBLE PRECISION UP(13,8) + +* Epoch of planetary state vectors + DOUBLE PRECISION TPMO + +* State vectors for the major planets (AU,AU/s) + DOUBLE PRECISION PVIN(6,8) + +* Earth velocity and position vectors (AU,AU/s) + DOUBLE PRECISION VB(3),PB(3),VH(3),PE(3) + +* Moon geocentric state vector (AU,AU/s) and position part + DOUBLE PRECISION PVM(6),PM(3) + +* Date to J2000 de-precession matrix + DOUBLE PRECISION PMAT(3,3) + +* +* Correction terms for extrapolated major planet vectors +* +* Sun-to-planet distances squared multiplied by 3 + DOUBLE PRECISION R2X3(8) +* Sunward acceleration terms, G/2R^3 + DOUBLE PRECISION GC(8) +* Tangential-to-circular correction factor + DOUBLE PRECISION FC +* Radial correction factor due to Sunwards acceleration + DOUBLE PRECISION FG +* + +* The body's unperturbed and perturbed state vectors (AU,AU/s) + DOUBLE PRECISION PV0(6),PV(6) + +* The body's perturbed and unperturbed heliocentric distances (AU) cubed + DOUBLE PRECISION R03,R3 + +* The perturbating accelerations, indirect and direct + DOUBLE PRECISION FI(3),FD(3) + +* Sun-to-planet vector, and distance cubed + DOUBLE PRECISION RHO(3),RHO3 + +* Body-to-planet vector, and distance cubed + DOUBLE PRECISION DELTA(3),DELTA3 + +* Miscellaneous + INTEGER I,J + DOUBLE PRECISION R2,W,DT,DT2,R,FT + LOGICAL NE + + DOUBLE PRECISION slEPJ + +* Planetary inverse masses, Mercury through Neptune then Earth and Moon + DOUBLE PRECISION AMAS(10) + DATA AMAS / 6023600D0, 408523.5D0, 328900.5D0, 3098710D0, + : 1047.355D0, 3498.5D0, 22869D0, 19314D0, + : 332946.038D0, 27068709D0 / + +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*----------------------------------------------------------------------* + + +* Preset the status to OK. + JSTAT = 0 + +* Copy the final epoch. + TFINAL = DATE + +* Copy the elements (which will be periodically updated). + DO I=1,13 + UL(I) = U(I) + END DO + +* Initialize the working reference epoch. + T0=UL(3) + +* Total timespan (days) and hence time left. + TSPAN = TFINAL-T0 + TLEFT = TSPAN + +* Warn if excessive. + IF (ABS(TSPAN).GT.36525D0) JSTAT=101 + +* Time direction: +1 for forwards, -1 for backwards. + FB = SIGN(1D0,TSPAN) + +* Initialize relative epoch for start of current timestep. + RTN = 0D0 + +* Reset the perturbations (position, velocity, acceleration). + DO I=1,3 + PERP(I) = 0D0 + PERV(I) = 0D0 + PERA(I) = 0D0 + END DO + +* Set "first iteration" flag. + FIRST = .TRUE. + +* Step through the time left. + DO WHILE (FB*TLEFT.GT.0D0) + +* Magnitude of current acceleration due to planetary attractions. + IF (FIRST) THEN + TS = TSMIN + ELSE + R2 = 0D0 + DO I=1,3 + W = FD(I) + R2 = R2+W*W + END DO + W = SQRT(R2) + +* Use the acceleration to decide how big a timestep can be tolerated. + IF (W.NE.0D0) THEN + TS = MIN(TSMAX,MAX(TSMIN,TSC/W)) + ELSE + TS = TSMAX + END IF + END IF + TS = TS*FB + +* Override if final epoch is imminent. + TLEFT = TSPAN-RTN + IF (ABS(TS).GT.ABS(TLEFT)) TS=TLEFT + +* Epoch of middle of timestep. + HTS = TS/2D0 + T = T0+RTN+HTS + +* Is it time to recompute the major-planet elements? + IF (FIRST.OR.ABS(T-TPEL)-AGEPEL.GE.TINY) THEN + +* Yes: go forward in time by just under the maximum allowed. + TPEL = T+FB*AGEPEL + +* Compute the state vector for the new epoch. + DO NP=1,8 + CALL slPLNT(TPEL,NP,PV,J) + +* Warning if remote epoch, abort if error. + IF (J.EQ.1) THEN + JSTAT = 102 + ELSE IF (J.NE.0) THEN + GO TO 9010 + END IF + +* Transform the vector into universal elements. + CALL slPVUE(PV,TPEL,0D0,UP(1,NP),J) + IF (J.NE.0) GO TO 9010 + END DO + END IF + +* Is it time to recompute the major-planet motions? + IF (FIRST.OR.ABS(T-TPMO)-AGEPMO.GE.TINY) THEN + +* Yes: look ahead. + TPMO = T+FB*AGEPMO + +* Compute the motions of each planet (AU,AU/d). + DO NP=1,8 + +* The planet's position and velocity (AU,AU/s). + CALL slUEPV(TPMO,UP(1,NP),PVIN(1,NP),J) + IF (J.NE.0) GO TO 9010 + +* Scale velocity to AU/d. + DO J=4,6 + PVIN(J,NP) = PVIN(J,NP)*86400D0 + END DO + +* Precompute also the extrapolation correction terms. + R2 = 0D0 + DO I=1,3 + W = PVIN(I,NP) + R2 = R2+W*W + END DO + R2X3(NP) = R2*3D0 + GC(NP) = GCON2/(2D0*R2*SQRT(R2)) + END DO + END IF + +* Reset the first-time flag. + FIRST = .FALSE. + +* Unperturbed motion of the body at middle of timestep (AU,AU/s). + CALL slUEPV(T,UL,PV0,J) + IF (J.NE.0) GO TO 9010 + +* Perturbed position of the body (AU) and heliocentric distance cubed. + R2 = 0D0 + DO I=1,3 + W = PV0(I)+PERP(I)+(PERV(I)+PERA(I)*HTS/2D0)*HTS + PV(I) = W + R2 = R2+W*W + END DO + R3 = R2*SQRT(R2) + +* The body's unperturbed heliocentric distance cubed. + R2 = 0D0 + DO I=1,3 + W = PV0(I) + R2 = R2+W*W + END DO + R03 = R2*SQRT(R2) + +* Compute indirect and initialize direct parts of the perturbation. + DO I=1,3 + FI(I) = PV0(I)/R03-PV(I)/R3 + FD(I) = 0D0 + END DO + +* Ready to compute the direct planetary effects. + +* Reset the "near-Earth" flag. + NE = .FALSE. + +* Interval from state-vector epoch to middle of current timestep. + DT = T-TPMO + DT2 = DT*DT + +* Planet by planet, including separate Earth and Moon. + DO NP=1,10 + +* Which perturbing body? + IF (NP.LE.8) THEN + +* Planet: compute the extrapolation in longitude (squared). + R2 = 0D0 + DO J=4,6 + W = PVIN(J,NP)*DT + R2 = R2+W*W + END DO + +* Hence the tangential-to-circular correction factor. + FC = 1D0+R2/R2X3(NP) + +* The radial correction factor due to the inwards acceleration. + FG = 1D0-GC(NP)*DT2 + +* Planet's position. + DO I=1,3 + RHO(I) = FG*(PVIN(I,NP)+FC*PVIN(I+3,NP)*DT) + END DO + + ELSE IF (NE) THEN + +* Near-Earth and either Earth or Moon. + + IF (NP.EQ.9) THEN + +* Earth: position. + CALL slEPV(T,PE,VH,PB,VB) + DO I=1,3 + RHO(I) = PE(I) + END DO + + ELSE + +* Moon: position. + CALL slPREC(slEPJ(T),2000D0,PMAT) + CALL slDMON(T,PVM) + CALL slDMXV(PMAT,PVM,PM) + DO I=1,3 + RHO(I) = PM(I)+PE(I) + END DO + END IF + END IF + +* Proceed unless Earth or Moon and not the near-Earth case. + IF (NP.LE.8.OR.NE) THEN + +* Heliocentric distance cubed. + R2 = 0D0 + DO I=1,3 + W = RHO(I) + R2 = R2+W*W + END DO + R = SQRT(R2) + RHO3 = R2*R + +* Body-to-planet vector, and distance. + R2 = 0D0 + DO I=1,3 + W = RHO(I)-PV(I) + DELTA(I) = W + R2 = R2+W*W + END DO + R = SQRT(R2) + +* If this is the EMB, set the near-Earth flag appropriately. + IF (NP.EQ.3.AND.R.LT.RNE) NE = .TRUE. + +* Proceed unless EMB and this is the near-Earth case. + IF (.NOT.(NE.AND.NP.EQ.3)) THEN + +* If too close, ignore this planet and set a warning. + IF (R.LT.COINC) THEN + JSTAT = NP + + ELSE + +* Accumulate "direct" part of perturbation acceleration. + DELTA3 = R2*R + W = AMAS(NP) + DO I=1,3 + FD(I) = FD(I)+(DELTA(I)/DELTA3-RHO(I)/RHO3)/W + END DO + END IF + END IF + END IF + END DO + +* Update the perturbations to the end of the timestep. + RTN = RTN+TS + DO I=1,3 + W = (FI(I)+FD(I))*GCON2 + FT = W*TS + PERP(I) = PERP(I)+(PERV(I)+FT/2D0)*TS + PERV(I) = PERV(I)+FT + PERA(I) = W + END DO + +* Time still to go. + TLEFT = TSPAN-RTN + +* Is it either time to rectify the orbit or the last time through? + IF (ABS(RTN).GE.AGEBEL.OR.FB*TLEFT.LE.0D0) THEN + +* Yes: update to the end of the current timestep. + T0 = T0+RTN + RTN = 0D0 + +* The body's unperturbed motion (AU,AU/s). + CALL slUEPV(T0,UL,PV0,J) + IF (J.NE.0) GO TO 9010 + +* Add and re-initialize the perturbations. + DO I=1,3 + J = I+3 + PV(I) = PV0(I)+PERP(I) + PV(J) = PV0(J)+PERV(I)/86400D0 + PERP(I) = 0D0 + PERV(I) = 0D0 + PERA(I) = FD(I)*GCON2 + END DO + +* Use the position and velocity to set up new universal elements. + CALL slPVUE(PV,T0,0D0,UL,J) + IF (J.NE.0) GO TO 9010 + +* Adjust the timespan and time left. + TSPAN = TFINAL-T0 + TLEFT = TSPAN + END IF + +* Next timestep. + END DO + +* Return the updated universal-element set. + DO I=1,13 + U(I) = UL(I) + END DO + +* Finished. + GO TO 9999 + +* Miscellaneous numerical error. + 9010 CONTINUE + JSTAT = -1 + + 9999 CONTINUE + END diff --git a/math/slalib/planel.f b/math/slalib/planel.f new file mode 100644 index 00000000..666a4036 --- /dev/null +++ b/math/slalib/planel.f @@ -0,0 +1,184 @@ + SUBROUTINE slPLNE (DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, PV, JSTAT) +*+ +* - - - - - - - +* P L N L +* - - - - - - - +* +* Heliocentric position and velocity of a planet, asteroid or comet, +* starting from orbital elements. +* +* Given: +* DATE d date, Modified Julian Date (JD - 2400000.5, Note 1) +* JFORM i choice of element set (1-3; Note 3) +* EPOCH d epoch of elements (TT MJD, Note 4) +* ORBINC d inclination (radians) +* ANODE d longitude of the ascending node (radians) +* PERIH d longitude or argument of perihelion (radians) +* AORQ d mean distance or perihelion distance (AU) +* E d eccentricity +* AORL d mean anomaly or longitude (radians, JFORM=1,2 only) +* DM d daily motion (radians, JFORM=1 only) +* +* Returned: +* PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, +* J2000 equatorial triad (AU,AU/s) +* JSTAT i status: 0 = OK +* -1 = illegal JFORM +* -2 = illegal E +* -3 = illegal AORQ +* -4 = illegal DM +* -5 = numerical error +* +* Called: slELUE, slUEPV +* +* Notes +* +* 1 DATE is the instant for which the prediction is required. It is +* in the TT timescale (formerly Ephemeris Time, ET) and is a +* Modified Julian Date (JD-2400000.5). +* +* 2 The elements are with respect to the J2000 ecliptic and equinox. +* +* 3 A choice of three different element-set options is available: +* +* Option JFORM = 1, suitable for the major planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = longitude of perihelion, curly pi (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean longitude L (radians) +* DM = daily motion (radians) +* +* Option JFORM = 2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean anomaly M (radians) +* +* Option JFORM = 3, suitable for comets: +* +* EPOCH = epoch of elements and perihelion (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e (range 0 to 10) +* +* Unused arguments (DM for JFORM=2, AORL and DM for JFORM=3) are not +* accessed. +* +* 4 Each of the three element sets defines an unperturbed heliocentric +* orbit. For a given epoch of observation, the position of the body +* in its orbit can be predicted from these elements, which are +* called "osculating elements", using standard two-body analytical +* solutions. However, due to planetary perturbations, a given set +* of osculating elements remains usable for only as long as the +* unperturbed orbit that it describes is an adequate approximation +* to reality. Attached to such a set of elements is a date called +* the "osculating epoch", at which the elements are, momentarily, +* a perfect representation of the instantaneous position and +* velocity of the body. +* +* Therefore, for any given problem there are up to three different +* epochs in play, and it is vital to distinguish clearly between +* them: +* +* . The epoch of observation: the moment in time for which the +* position of the body is to be predicted. +* +* . The epoch defining the position of the body: the moment in time +* at which, in the absence of purturbations, the specified +* position (mean longitude, mean anomaly, or perihelion) is +* reached. +* +* . The osculating epoch: the moment in time at which the given +* elements are correct. +* +* For the major-planet and minor-planet cases it is usual to make +* the epoch that defines the position of the body the same as the +* epoch of osculation. Thus, only two different epochs are +* involved: the epoch of the elements and the epoch of observation. +* +* For comets, the epoch of perihelion fixes the position in the +* orbit and in general a different epoch of osculation will be +* chosen. Thus, all three types of epoch are involved. +* +* For the present routine: +* +* . The epoch of observation is the argument DATE. +* +* . The epoch defining the position of the body is the argument +* EPOCH. +* +* . The osculating epoch is not used and is assumed to be close +* enough to the epoch of observation to deliver adequate accuracy. +* If not, a preliminary call to slPRTL may be used to update +* the element-set (and its associated osculating epoch) by +* applying planetary perturbations. +* +* 5 The reference frame for the result is with respect to the mean +* equator and equinox of epoch J2000. +* +* 6 The algorithm was originally adapted from the EPHSLA program of +* D.H.P.Jones (private communication, 1996). The method is based +* on Stumpff's Universal Variables. +* +* Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* P.T.Wallace Starlink 31 December 2002 +* +* Copyright (C) 2002 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + INTEGER JFORM + DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,PV(6) + INTEGER JSTAT + + DOUBLE PRECISION U(13) + INTEGER J + + + +* Validate elements and convert to "universal variables" parameters. + CALL slELUE(DATE,JFORM, + : EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,U,J) + +* Determine the position and velocity. + IF (J.EQ.0) THEN + CALL slUEPV(DATE,U,PV,J) + IF (J.NE.0) J=-5 + END IF + +* Wrap up. + JSTAT = J + + END diff --git a/math/slalib/planet.f b/math/slalib/planet.f new file mode 100644 index 00000000..02590c65 --- /dev/null +++ b/math/slalib/planet.f @@ -0,0 +1,725 @@ + SUBROUTINE slPLNT (DATE, NP, PV, JSTAT) +*+ +* - - - - - - - +* P L N T +* - - - - - - - +* +* Approximate heliocentric position and velocity of a specified +* major planet. +* +* Given: +* DATE d Modified Julian Date (JD - 2400000.5) +* NP i planet (1=Mercury, 2=Venus, 3=EMB ... 9=Pluto) +* +* Returned: +* PV d(6) heliocentric x,y,z,xdot,ydot,zdot, J2000 +* equatorial triad (AU,AU/s) +* JSTAT i status: +1 = warning: date out of range +* 0 = OK +* -1 = illegal NP (outside 1-9) +* -2 = solution didn't converge +* +* Called: slPLNE +* +* Notes +* +* 1 The epoch, DATE, is in the TDB timescale and is a Modified +* Julian Date (JD-2400000.5). +* +* 2 The reference frame is equatorial and is with respect to the +* mean equinox and ecliptic of epoch J2000. +* +* 3 If an NP value outside the range 1-9 is supplied, an error +* status (JSTAT = -1) is returned and the PV vector set to zeroes. +* +* 4 The algorithm for obtaining the mean elements of the planets +* from Mercury to Neptune is due to J.L. Simon, P. Bretagnon, +* J. Chapront, M. Chapront-Touze, G. Francou and J. Laskar +* (Bureau des Longitudes, Paris). The (completely different) +* algorithm for calculating the ecliptic coordinates of Pluto +* is by Meeus. +* +* 5 Comparisons of the present routine with the JPL DE200 ephemeris +* give the following RMS errors over the interval 1960-2025: +* +* position (km) speed (metre/sec) +* +* Mercury 334 0.437 +* Venus 1060 0.855 +* EMB 2010 0.815 +* Mars 7690 1.98 +* Jupiter 71700 7.70 +* Saturn 199000 19.4 +* Uranus 564000 16.4 +* Neptune 158000 14.4 +* Pluto 36400 0.137 +* +* From comparisons with DE102, Simon et al quote the following +* longitude accuracies over the interval 1800-2200: +* +* Mercury 4" +* Venus 5" +* EMB 6" +* Mars 17" +* Jupiter 71" +* Saturn 81" +* Uranus 86" +* Neptune 11" +* +* In the case of Pluto, Meeus quotes an accuracy of 0.6 arcsec +* in longitude and 0.2 arcsec in latitude for the period +* 1885-2099. +* +* For all except Pluto, over the period 1000-3000 the accuracy +* is better than 1.5 times that over 1800-2200. Outside the +* period 1000-3000 the accuracy declines. For Pluto the +* accuracy declines rapidly outside the period 1885-2099. +* Outside these ranges (1885-2099 for Pluto, 1000-3000 for +* the rest) a "date out of range" warning status (JSTAT=+1) +* is returned. +* +* 6 The algorithms for (i) Mercury through Neptune and (ii) Pluto +* are completely independent. In the Mercury through Neptune +* case, the present SLALIB implementation differs from the +* original Simon et al Fortran code in the following respects. +* +* * The date is supplied as a Modified Julian Date rather +* than a Julian Date (MJD = JD - 2400000.5). +* +* * The result is returned only in equatorial Cartesian form; +* the ecliptic longitude, latitude and radius vector are not +* returned. +* +* * The velocity is in AU per second, not AU per day. +* +* * Different error/warning status values are used. +* +* * Kepler's equation is not solved inline. +* +* * Polynomials in T are nested to minimize rounding errors. +* +* * Explicit double-precision constants are used to avoid +* mixed-mode expressions. +* +* * There are other, cosmetic, changes to comply with +* Starlink/SLALIB style guidelines. +* +* None of the above changes affects the result significantly. +* +* 7 For NP=3 the result is for the Earth-Moon Barycentre. To +* obtain the heliocentric position and velocity of the Earth, +* either use the SLALIB routine slEVP (or slEPV) or call +* slDMON and subtract 0.012150581 times the geocentric Moon +* vector from the EMB vector produced by the present routine. +* (The Moon vector should be precessed to J2000 first, but this +* can be omitted for modern epochs without introducing significant +* inaccuracy.) +* +* References: Simon et al., Astron. Astrophys. 282, 663 (1994). +* Meeus, Astronomical Algorithms, Willmann-Bell (1991). +* +* This revision: 19 June 2004 +* +* Copyright (C) 2004 P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + INTEGER NP + DOUBLE PRECISION PV(6) + INTEGER JSTAT + +* 2Pi, deg to radians, arcsec to radians + DOUBLE PRECISION D2PI,D2R,AS2R + PARAMETER (D2PI=6.283185307179586476925286766559D0, + : D2R=0.017453292519943295769236907684886D0, + : AS2R=4.848136811095359935899141023579D-6) + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Seconds per Julian century + DOUBLE PRECISION SPC + PARAMETER (SPC=36525D0*86400D0) + +* Sin and cos of J2000 mean obliquity (IAU 1976) + DOUBLE PRECISION SE,CE + PARAMETER (SE=0.3977771559319137D0, + : CE=0.9174820620691818D0) + + INTEGER I,J,IJSP(3,43) + DOUBLE PRECISION AMAS(8),A(3,8),DLM(3,8),E(3,8), + : PI(3,8),DINC(3,8),OMEGA(3,8), + : DKP(9,8),CA(9,8),SA(9,8), + : DKQ(10,8),CLO(10,8),SLO(10,8), + : T,DA,DE,DPE,DI,DO,DMU,ARGA,ARGL,DM, + : AB(2,3,43),DJ0,DS0,DP0,DL0,DLD0,DB0,DR0, + : DJ,DS,DP,DJD,DSD,DPD,WLBR(3),WLBRD(3), + : WJ,WS,WP,AL,ALD,SAL,CAL, + : AC,BC,DL,DLD,DB,DBD,DR,DRD, + : SL,CL,SB,CB,SLCB,CLCB,X,Y,Z,XD,YD,ZD + +* ----------------------- +* Mercury through Neptune +* ----------------------- + +* Planetary inverse masses + DATA AMAS / 6023600D0,408523.5D0,328900.5D0,3098710D0, + : 1047.355D0,3498.5D0,22869D0,19314D0 / + +* +* Tables giving the mean Keplerian elements, limited to T**2 terms: +* +* A semi-major axis (AU) +* DLM mean longitude (degree and arcsecond) +* E eccentricity +* PI longitude of the perihelion (degree and arcsecond) +* DINC inclination (degree and arcsecond) +* OMEGA longitude of the ascending node (degree and arcsecond) +* + DATA A / + : 0.3870983098D0, 0D0, 0D0, + : 0.7233298200D0, 0D0, 0D0, + : 1.0000010178D0, 0D0, 0D0, + : 1.5236793419D0, 3D-10, 0D0, + : 5.2026032092D0, 19132D-10, -39D-10, + : 9.5549091915D0, -0.0000213896D0, 444D-10, + : 19.2184460618D0, -3716D-10, 979D-10, + : 30.1103868694D0, -16635D-10, 686D-10 / +* + DATA DLM / + : 252.25090552D0, 5381016286.88982D0, -1.92789D0, + : 181.97980085D0, 2106641364.33548D0, 0.59381D0, + : 100.46645683D0, 1295977422.83429D0, -2.04411D0, + : 355.43299958D0, 689050774.93988D0, 0.94264D0, + : 34.35151874D0, 109256603.77991D0, -30.60378D0, + : 50.07744430D0, 43996098.55732D0, 75.61614D0, + : 314.05500511D0, 15424811.93933D0, -1.75083D0, + : 304.34866548D0, 7865503.20744D0, 0.21103D0/ +* + DATA E / + : 0.2056317526D0, 0.0002040653D0, -28349D-10, + : 0.0067719164D0, -0.0004776521D0, 98127D-10, + : 0.0167086342D0, -0.0004203654D0, -0.0000126734D0, + : 0.0934006477D0, 0.0009048438D0, -80641D-10, + : 0.0484979255D0, 0.0016322542D0, -0.0000471366D0, + : 0.0555481426D0, -0.0034664062D0, -0.0000643639D0, + : 0.0463812221D0, -0.0002729293D0, 0.0000078913D0, + : 0.0094557470D0, 0.0000603263D0, 0D0 / +* + DATA PI / + : 77.45611904D0, 5719.11590D0, -4.83016D0, + : 131.56370300D0, 175.48640D0, -498.48184D0, + : 102.93734808D0, 11612.35290D0, 53.27577D0, + : 336.06023395D0, 15980.45908D0, -62.32800D0, + : 14.33120687D0, 7758.75163D0, 259.95938D0, + : 93.05723748D0, 20395.49439D0, 190.25952D0, + : 173.00529106D0, 3215.56238D0, -34.09288D0, + : 48.12027554D0, 1050.71912D0, 27.39717D0 / +* + DATA DINC / + : 7.00498625D0, -214.25629D0, 0.28977D0, + : 3.39466189D0, -30.84437D0, -11.67836D0, + : 0D0, 469.97289D0, -3.35053D0, + : 1.84972648D0, -293.31722D0, -8.11830D0, + : 1.30326698D0, -71.55890D0, 11.95297D0, + : 2.48887878D0, 91.85195D0, -17.66225D0, + : 0.77319689D0, -60.72723D0, 1.25759D0, + : 1.76995259D0, 8.12333D0, 0.08135D0 / +* + DATA OMEGA / + : 48.33089304D0, -4515.21727D0, -31.79892D0, + : 76.67992019D0, -10008.48154D0, -51.32614D0, + : 174.87317577D0, -8679.27034D0, 15.34191D0, + : 49.55809321D0, -10620.90088D0, -230.57416D0, + : 100.46440702D0, 6362.03561D0, 326.52178D0, + : 113.66550252D0, -9240.19942D0, -66.23743D0, + : 74.00595701D0, 2669.15033D0, 145.93964D0, + : 131.78405702D0, -221.94322D0, -0.78728D0 / +* +* Tables for trigonometric terms to be added to the mean elements +* of the semi-major axes. +* + DATA DKP / + : 69613, 75645, 88306, 59899, 15746, 71087, 142173, 3086, 0, + : 21863, 32794, 26934, 10931, 26250, 43725, 53867, 28939, 0, + : 16002, 21863, 32004, 10931, 14529, 16368, 15318, 32794, 0, + : 6345, 7818, 15636, 7077, 8184, 14163, 1107, 4872, 0, + : 1760, 1454, 1167, 880, 287, 2640, 19, 2047, 1454, + : 574, 0, 880, 287, 19, 1760, 1167, 306, 574, + : 204, 0, 177, 1265, 4, 385, 200, 208, 204, + : 0, 102, 106, 4, 98, 1367, 487, 204, 0 / +* + DATA CA / + : 4, -13, 11, -9, -9, -3, -1, 4, 0, + : -156, 59, -42, 6, 19, -20, -10, -12, 0, + : 64, -152, 62, -8, 32, -41, 19, -11, 0, + : 124, 621, -145, 208, 54, -57, 30, 15, 0, + : -23437, -2634, 6601, 6259, -1507, -1821, 2620, -2115,-1489, + : 62911,-119919, 79336, 17814,-24241, 12068, 8306, -4893, 8902, + : 389061,-262125,-44088, 8387,-22976, -2093, -615, -9720, 6633, + :-412235,-157046,-31430, 37817, -9740, -13, -7449, 9644, 0 / +* + DATA SA / + : -29, -1, 9, 6, -6, 5, 4, 0, 0, + : -48, -125, -26, -37, 18, -13, -20, -2, 0, + : -150, -46, 68, 54, 14, 24, -28, 22, 0, + : -621, 532, -694, -20, 192, -94, 71, -73, 0, + : -14614,-19828, -5869, 1881, -4372, -2255, 782, 930, 913, + : 139737, 0, 24667, 51123, -5102, 7429, -4095, -1976,-9566, + : -138081, 0, 37205,-49039,-41901,-33872,-27037,-12474,18797, + : 0, 28492,133236, 69654, 52322,-49577,-26430, -3593, 0 / +* +* Tables giving the trigonometric terms to be added to the mean +* elements of the mean longitudes. +* + DATA DKQ / + : 3086, 15746, 69613, 59899, 75645, 88306, 12661, 2658, 0, 0, + : 21863, 32794, 10931, 73, 4387, 26934, 1473, 2157, 0, 0, + : 10, 16002, 21863, 10931, 1473, 32004, 4387, 73, 0, 0, + : 10, 6345, 7818, 1107, 15636, 7077, 8184, 532, 10, 0, + : 19, 1760, 1454, 287, 1167, 880, 574, 2640, 19,1454, + : 19, 574, 287, 306, 1760, 12, 31, 38, 19, 574, + : 4, 204, 177, 8, 31, 200, 1265, 102, 4, 204, + : 4, 102, 106, 8, 98, 1367, 487, 204, 4, 102 / +* + DATA CLO / + : 21, -95, -157, 41, -5, 42, 23, 30, 0, 0, + : -160, -313, -235, 60, -74, -76, -27, 34, 0, 0, + : -325, -322, -79, 232, -52, 97, 55, -41, 0, 0, + : 2268, -979, 802, 602, -668, -33, 345, 201, -55, 0, + : 7610, -4997,-7689,-5841,-2617, 1115, -748, -607, 6074, 354, + : -18549, 30125,20012, -730, 824, 23, 1289, -352,-14767,-2062, + :-135245,-14594, 4197,-4030,-5630,-2898, 2540, -306, 2939, 1986, + : 89948, 2103, 8963, 2695, 3682, 1648, 866, -154, -1963, -283 / +* + DATA SLO / + : -342, 136, -23, 62, 66, -52, -33, 17, 0, 0, + : 524, -149, -35, 117, 151, 122, -71, -62, 0, 0, + : -105, -137, 258, 35, -116, -88, -112, -80, 0, 0, + : 854, -205, -936, -240, 140, -341, -97, -232, 536, 0, + : -56980, 8016, 1012, 1448,-3024,-3710, 318, 503, 3767, 577, + : 138606,-13478,-4964, 1441,-1319,-1482, 427, 1236, -9167,-1918, + : 71234,-41116, 5334,-4935,-1848, 66, 434,-1748, 3780, -701, + : -47645, 11647, 2166, 3194, 679, 0, -244, -419, -2531, 48 / + +* ----- +* Pluto +* ----- + +* +* Coefficients for fundamental arguments: mean longitudes +* (degrees) and mean rate of change of longitude (degrees per +* Julian century) for Jupiter, Saturn and Pluto +* + DATA DJ0, DJD / 34.35D0, 3034.9057D0 / + DATA DS0, DSD / 50.08D0, 1222.1138D0 / + DATA DP0, DPD / 238.96D0, 144.9600D0 / + +* Coefficients for latitude, longitude, radius vector + DATA DL0,DLD0 / 238.956785D0, 144.96D0 / + DATA DB0 / -3.908202D0 / + DATA DR0 / 40.7247248D0 / + +* +* Coefficients for periodic terms (Meeus's Table 36.A) +* +* The coefficients for term n in the series are: +* +* IJSP(1,n) J +* IJSP(2,n) S +* IJSP(3,n) P +* AB(1,1,n) longitude sine (degrees) +* AB(2,1,n) longitude cosine (degrees) +* AB(1,2,n) latitude sine (degrees) +* AB(2,2,n) latitude cosine (degrees) +* AB(1,3,n) radius vector sine (AU) +* AB(2,3,n) radius vector cosine (AU) +* + DATA (IJSP(I, 1),I=1,3),((AB(J,I, 1),J=1,2),I=1,3) / + : 0, 0, 1, + : -19798886D-6, 19848454D-6, + : -5453098D-6, -14974876D-6, + : 66867334D-7, 68955876D-7 / + DATA (IJSP(I, 2),I=1,3),((AB(J,I, 2),J=1,2),I=1,3) / + : 0, 0, 2, + : 897499D-6, -4955707D-6, + : 3527363D-6, 1672673D-6, + : -11826086D-7, -333765D-7 / + DATA (IJSP(I, 3),I=1,3),((AB(J,I, 3),J=1,2),I=1,3) / + : 0, 0, 3, + : 610820D-6, 1210521D-6, + : -1050939D-6, 327763D-6, + : 1593657D-7, -1439953D-7 / + DATA (IJSP(I, 4),I=1,3),((AB(J,I, 4),J=1,2),I=1,3) / + : 0, 0, 4, + : -341639D-6, -189719D-6, + : 178691D-6, -291925D-6, + : -18948D-7, 482443D-7 / + DATA (IJSP(I, 5),I=1,3),((AB(J,I, 5),J=1,2),I=1,3) / + : 0, 0, 5, + : 129027D-6, -34863D-6, + : 18763D-6, 100448D-6, + : -66634D-7, -85576D-7 / + DATA (IJSP(I, 6),I=1,3),((AB(J,I, 6),J=1,2),I=1,3) / + : 0, 0, 6, + : -38215D-6, 31061D-6, + : -30594D-6, -25838D-6, + : 30841D-7, -5765D-7 / + DATA (IJSP(I, 7),I=1,3),((AB(J,I, 7),J=1,2),I=1,3) / + : 0, 1, -1, + : 20349D-6, -9886D-6, + : 4965D-6, 11263D-6, + : -6140D-7, 22254D-7 / + DATA (IJSP(I, 8),I=1,3),((AB(J,I, 8),J=1,2),I=1,3) / + : 0, 1, 0, + : -4045D-6, -4904D-6, + : 310D-6, -132D-6, + : 4434D-7, 4443D-7 / + DATA (IJSP(I, 9),I=1,3),((AB(J,I, 9),J=1,2),I=1,3) / + : 0, 1, 1, + : -5885D-6, -3238D-6, + : 2036D-6, -947D-6, + : -1518D-7, 641D-7 / + DATA (IJSP(I,10),I=1,3),((AB(J,I,10),J=1,2),I=1,3) / + : 0, 1, 2, + : -3812D-6, 3011D-6, + : -2D-6, -674D-6, + : -5D-7, 792D-7 / + DATA (IJSP(I,11),I=1,3),((AB(J,I,11),J=1,2),I=1,3) / + : 0, 1, 3, + : -601D-6, 3468D-6, + : -329D-6, -563D-6, + : 518D-7, 518D-7 / + DATA (IJSP(I,12),I=1,3),((AB(J,I,12),J=1,2),I=1,3) / + : 0, 2, -2, + : 1237D-6, 463D-6, + : -64D-6, 39D-6, + : -13D-7, -221D-7 / + DATA (IJSP(I,13),I=1,3),((AB(J,I,13),J=1,2),I=1,3) / + : 0, 2, -1, + : 1086D-6, -911D-6, + : -94D-6, 210D-6, + : 837D-7, -494D-7 / + DATA (IJSP(I,14),I=1,3),((AB(J,I,14),J=1,2),I=1,3) / + : 0, 2, 0, + : 595D-6, -1229D-6, + : -8D-6, -160D-6, + : -281D-7, 616D-7 / + DATA (IJSP(I,15),I=1,3),((AB(J,I,15),J=1,2),I=1,3) / + : 1, -1, 0, + : 2484D-6, -485D-6, + : -177D-6, 259D-6, + : 260D-7, -395D-7 / + DATA (IJSP(I,16),I=1,3),((AB(J,I,16),J=1,2),I=1,3) / + : 1, -1, 1, + : 839D-6, -1414D-6, + : 17D-6, 234D-6, + : -191D-7, -396D-7 / + DATA (IJSP(I,17),I=1,3),((AB(J,I,17),J=1,2),I=1,3) / + : 1, 0, -3, + : -964D-6, 1059D-6, + : 582D-6, -285D-6, + : -3218D-7, 370D-7 / + DATA (IJSP(I,18),I=1,3),((AB(J,I,18),J=1,2),I=1,3) / + : 1, 0, -2, + : -2303D-6, -1038D-6, + : -298D-6, 692D-6, + : 8019D-7, -7869D-7 / + DATA (IJSP(I,19),I=1,3),((AB(J,I,19),J=1,2),I=1,3) / + : 1, 0, -1, + : 7049D-6, 747D-6, + : 157D-6, 201D-6, + : 105D-7, 45637D-7 / + DATA (IJSP(I,20),I=1,3),((AB(J,I,20),J=1,2),I=1,3) / + : 1, 0, 0, + : 1179D-6, -358D-6, + : 304D-6, 825D-6, + : 8623D-7, 8444D-7 / + DATA (IJSP(I,21),I=1,3),((AB(J,I,21),J=1,2),I=1,3) / + : 1, 0, 1, + : 393D-6, -63D-6, + : -124D-6, -29D-6, + : -896D-7, -801D-7 / + DATA (IJSP(I,22),I=1,3),((AB(J,I,22),J=1,2),I=1,3) / + : 1, 0, 2, + : 111D-6, -268D-6, + : 15D-6, 8D-6, + : 208D-7, -122D-7 / + DATA (IJSP(I,23),I=1,3),((AB(J,I,23),J=1,2),I=1,3) / + : 1, 0, 3, + : -52D-6, -154D-6, + : 7D-6, 15D-6, + : -133D-7, 65D-7 / + DATA (IJSP(I,24),I=1,3),((AB(J,I,24),J=1,2),I=1,3) / + : 1, 0, 4, + : -78D-6, -30D-6, + : 2D-6, 2D-6, + : -16D-7, 1D-7 / + DATA (IJSP(I,25),I=1,3),((AB(J,I,25),J=1,2),I=1,3) / + : 1, 1, -3, + : -34D-6, -26D-6, + : 4D-6, 2D-6, + : -22D-7, 7D-7 / + DATA (IJSP(I,26),I=1,3),((AB(J,I,26),J=1,2),I=1,3) / + : 1, 1, -2, + : -43D-6, 1D-6, + : 3D-6, 0D-6, + : -8D-7, 16D-7 / + DATA (IJSP(I,27),I=1,3),((AB(J,I,27),J=1,2),I=1,3) / + : 1, 1, -1, + : -15D-6, 21D-6, + : 1D-6, -1D-6, + : 2D-7, 9D-7 / + DATA (IJSP(I,28),I=1,3),((AB(J,I,28),J=1,2),I=1,3) / + : 1, 1, 0, + : -1D-6, 15D-6, + : 0D-6, -2D-6, + : 12D-7, 5D-7 / + DATA (IJSP(I,29),I=1,3),((AB(J,I,29),J=1,2),I=1,3) / + : 1, 1, 1, + : 4D-6, 7D-6, + : 1D-6, 0D-6, + : 1D-7, -3D-7 / + DATA (IJSP(I,30),I=1,3),((AB(J,I,30),J=1,2),I=1,3) / + : 1, 1, 3, + : 1D-6, 5D-6, + : 1D-6, -1D-6, + : 1D-7, 0D-7 / + DATA (IJSP(I,31),I=1,3),((AB(J,I,31),J=1,2),I=1,3) / + : 2, 0, -6, + : 8D-6, 3D-6, + : -2D-6, -3D-6, + : 9D-7, 5D-7 / + DATA (IJSP(I,32),I=1,3),((AB(J,I,32),J=1,2),I=1,3) / + : 2, 0, -5, + : -3D-6, 6D-6, + : 1D-6, 2D-6, + : 2D-7, -1D-7 / + DATA (IJSP(I,33),I=1,3),((AB(J,I,33),J=1,2),I=1,3) / + : 2, 0, -4, + : 6D-6, -13D-6, + : -8D-6, 2D-6, + : 14D-7, 10D-7 / + DATA (IJSP(I,34),I=1,3),((AB(J,I,34),J=1,2),I=1,3) / + : 2, 0, -3, + : 10D-6, 22D-6, + : 10D-6, -7D-6, + : -65D-7, 12D-7 / + DATA (IJSP(I,35),I=1,3),((AB(J,I,35),J=1,2),I=1,3) / + : 2, 0, -2, + : -57D-6, -32D-6, + : 0D-6, 21D-6, + : 126D-7, -233D-7 / + DATA (IJSP(I,36),I=1,3),((AB(J,I,36),J=1,2),I=1,3) / + : 2, 0, -1, + : 157D-6, -46D-6, + : 8D-6, 5D-6, + : 270D-7, 1068D-7 / + DATA (IJSP(I,37),I=1,3),((AB(J,I,37),J=1,2),I=1,3) / + : 2, 0, 0, + : 12D-6, -18D-6, + : 13D-6, 16D-6, + : 254D-7, 155D-7 / + DATA (IJSP(I,38),I=1,3),((AB(J,I,38),J=1,2),I=1,3) / + : 2, 0, 1, + : -4D-6, 8D-6, + : -2D-6, -3D-6, + : -26D-7, -2D-7 / + DATA (IJSP(I,39),I=1,3),((AB(J,I,39),J=1,2),I=1,3) / + : 2, 0, 2, + : -5D-6, 0D-6, + : 0D-6, 0D-6, + : 7D-7, 0D-7 / + DATA (IJSP(I,40),I=1,3),((AB(J,I,40),J=1,2),I=1,3) / + : 2, 0, 3, + : 3D-6, 4D-6, + : 0D-6, 1D-6, + : -11D-7, 4D-7 / + DATA (IJSP(I,41),I=1,3),((AB(J,I,41),J=1,2),I=1,3) / + : 3, 0, -2, + : -1D-6, -1D-6, + : 0D-6, 1D-6, + : 4D-7, -14D-7 / + DATA (IJSP(I,42),I=1,3),((AB(J,I,42),J=1,2),I=1,3) / + : 3, 0, -1, + : 6D-6, -3D-6, + : 0D-6, 0D-6, + : 18D-7, 35D-7 / + DATA (IJSP(I,43),I=1,3),((AB(J,I,43),J=1,2),I=1,3) / + : 3, 0, 0, + : -1D-6, -2D-6, + : 0D-6, 1D-6, + : 13D-7, 3D-7 / + + +* Validate the planet number. + IF (NP.LT.1.OR.NP.GT.9) THEN + JSTAT=-1 + DO I=1,6 + PV(I)=0D0 + END DO + ELSE + +* Separate algorithms for Pluto and the rest. + IF (NP.NE.9) THEN + +* ----------------------- +* Mercury through Neptune +* ----------------------- + +* Time: Julian millennia since J2000. + T=(DATE-51544.5D0)/365250D0 + +* OK status unless remote epoch. + IF (ABS(T).LE.1D0) THEN + JSTAT=0 + ELSE + JSTAT=1 + END IF + +* Compute the mean elements. + DA=A(1,NP)+(A(2,NP)+A(3,NP)*T)*T + DL=(3600D0*DLM(1,NP)+(DLM(2,NP)+DLM(3,NP)*T)*T)*AS2R + DE=E(1,NP)+(E(2,NP)+E(3,NP)*T)*T + DPE=MOD((3600D0*PI(1,NP)+(PI(2,NP)+PI(3,NP)*T)*T)*AS2R,D2PI) + DI=(3600D0*DINC(1,NP)+(DINC(2,NP)+DINC(3,NP)*T)*T)*AS2R + DO=MOD((3600D0*OMEGA(1,NP) + : +(OMEGA(2,NP)+OMEGA(3,NP)*T)*T)*AS2R,D2PI) + +* Apply the trigonometric terms. + DMU=0.35953620D0*T + DO J=1,8 + ARGA=DKP(J,NP)*DMU + ARGL=DKQ(J,NP)*DMU + DA=DA+(CA(J,NP)*COS(ARGA)+SA(J,NP)*SIN(ARGA))*1D-7 + DL=DL+(CLO(J,NP)*COS(ARGL)+SLO(J,NP)*SIN(ARGL))*1D-7 + END DO + ARGA=DKP(9,NP)*DMU + DA=DA+T*(CA(9,NP)*COS(ARGA)+SA(9,NP)*SIN(ARGA))*1D-7 + DO J=9,10 + ARGL=DKQ(J,NP)*DMU + DL=DL+T*(CLO(J,NP)*COS(ARGL)+SLO(J,NP)*SIN(ARGL))*1D-7 + END DO + DL=MOD(DL,D2PI) + +* Daily motion. + DM=GCON*SQRT((1D0+1D0/AMAS(NP))/(DA*DA*DA)) + +* Make the prediction. + CALL slPLNE(DATE,1,DATE,DI,DO,DPE,DA,DE,DL,DM,PV,J) + IF (J.LT.0) JSTAT=-2 + + ELSE + +* ----- +* Pluto +* ----- + +* Time: Julian centuries since J2000. + T=(DATE-51544.5D0)/36525D0 + +* OK status unless remote epoch. + IF (T.GE.-1.15D0.AND.T.LE.1D0) THEN + JSTAT=0 + ELSE + JSTAT=1 + END IF + +* Fundamental arguments (radians). + DJ=(DJ0+DJD*T)*D2R + DS=(DS0+DSD*T)*D2R + DP=(DP0+DPD*T)*D2R + +* Initialize coefficients and derivatives. + DO I=1,3 + WLBR(I)=0D0 + WLBRD(I)=0D0 + END DO + +* Term by term through Meeus Table 36.A. + DO J=1,43 + +* Argument and derivative (radians, radians per century). + WJ=DBLE(IJSP(1,J)) + WS=DBLE(IJSP(2,J)) + WP=DBLE(IJSP(3,J)) + AL=WJ*DJ+WS*DS+WP*DP + ALD=(WJ*DJD+WS*DSD+WP*DPD)*D2R + +* Functions of argument. + SAL=SIN(AL) + CAL=COS(AL) + +* Periodic terms in longitude, latitude, radius vector. + DO I=1,3 + +* A and B coefficients (deg, AU). + AC=AB(1,I,J) + BC=AB(2,I,J) + +* Periodic terms (deg, AU, deg/Jc, AU/Jc). + WLBR(I)=WLBR(I)+AC*SAL+BC*CAL + WLBRD(I)=WLBRD(I)+(AC*CAL-BC*SAL)*ALD + END DO + END DO + +* Heliocentric longitude and derivative (radians, radians/sec). + DL=(DL0+DLD0*T+WLBR(1))*D2R + DLD=(DLD0+WLBRD(1))*D2R/SPC + +* Heliocentric latitude and derivative (radians, radians/sec). + DB=(DB0+WLBR(2))*D2R + DBD=WLBRD(2)*D2R/SPC + +* Heliocentric radius vector and derivative (AU, AU/sec). + DR=DR0+WLBR(3) + DRD=WLBRD(3)/SPC + +* Functions of latitude, longitude, radius vector. + SL=SIN(DL) + CL=COS(DL) + SB=SIN(DB) + CB=COS(DB) + SLCB=SL*CB + CLCB=CL*CB + +* Heliocentric vector and derivative, J2000 ecliptic and equinox. + X=DR*CLCB + Y=DR*SLCB + Z=DR*SB + XD=DRD*CLCB-DR*(CL*SB*DBD+SLCB*DLD) + YD=DRD*SLCB+DR*(-SL*SB*DBD+CLCB*DLD) + ZD=DRD*SB+DR*CB*DBD + +* Transform to J2000 equator and equinox. + PV(1)=X + PV(2)=Y*CE-Z*SE + PV(3)=Y*SE+Z*CE + PV(4)=XD + PV(5)=YD*CE-ZD*SE + PV(6)=YD*SE+ZD*CE + END IF + END IF + + END diff --git a/math/slalib/plante.f b/math/slalib/plante.f new file mode 100644 index 00000000..585e764d --- /dev/null +++ b/math/slalib/plante.f @@ -0,0 +1,251 @@ + SUBROUTINE slPLTE (DATE, ELONG, PHI, JFORM, EPOCH, + : ORBINC, ANODE, PERIH, AORQ, E, + : AORL, DM, RA, DEC, R, JSTAT) +*+ +* - - - - - - - +* P L T E +* - - - - - - - +* +* Topocentric apparent RA,Dec of a Solar-System object whose +* heliocentric orbital elements are known. +* +* Given: +* DATE d MJD of observation (JD - 2400000.5, Notes 1,5) +* ELONG d observer's east longitude (radians, Note 2) +* PHI d observer's geodetic latitude (radians, Note 2) +* JFORM i choice of element set (1-3; Notes 3-6) +* EPOCH d epoch of elements (TT MJD, Note 5) +* ORBINC d inclination (radians) +* ANODE d longitude of the ascending node (radians) +* PERIH d longitude or argument of perihelion (radians) +* AORQ d mean distance or perihelion distance (AU) +* E d eccentricity +* AORL d mean anomaly or longitude (radians, JFORM=1,2 only) +* DM d daily motion (radians, JFORM=1 only ) +* +* Returned: +* RA,DEC d RA, Dec (topocentric apparent, radians) +* R d distance from observer (AU) +* JSTAT i status: 0 = OK +* -1 = illegal JFORM +* -2 = illegal E +* -3 = illegal AORQ +* -4 = illegal DM +* -5 = numerical error +* +* Called: slELUE, slPLTU +* +* Notes: +* +* 1 DATE is the instant for which the prediction is required. It is +* in the TT timescale (formerly Ephemeris Time, ET) and is a +* Modified Julian Date (JD-2400000.5). +* +* 2 The longitude and latitude allow correction for geocentric +* parallax. This is usually a small effect, but can become +* important for near-Earth asteroids. Geocentric positions can be +* generated by appropriate use of routines slEVP (or slEPV) and +* slPLNE. +* +* 3 The elements are with respect to the J2000 ecliptic and equinox. +* +* 4 A choice of three different element-set options is available: +* +* Option JFORM = 1, suitable for the major planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = longitude of perihelion, curly pi (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean longitude L (radians) +* DM = daily motion (radians) +* +* Option JFORM = 2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e (range 0 to <1) +* AORL = mean anomaly M (radians) +* +* Option JFORM = 3, suitable for comets: +* +* EPOCH = epoch of elements and perihelion (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e (range 0 to 10) +* +* Unused arguments (DM for JFORM=2, AORL and DM for JFORM=3) are not +* accessed. +* +* 5 Each of the three element sets defines an unperturbed heliocentric +* orbit. For a given epoch of observation, the position of the body +* in its orbit can be predicted from these elements, which are +* called "osculating elements", using standard two-body analytical +* solutions. However, due to planetary perturbations, a given set +* of osculating elements remains usable for only as long as the +* unperturbed orbit that it describes is an adequate approximation +* to reality. Attached to such a set of elements is a date called +* the "osculating epoch", at which the elements are, momentarily, +* a perfect representation of the instantaneous position and +* velocity of the body. +* +* Therefore, for any given problem there are up to three different +* epochs in play, and it is vital to distinguish clearly between +* them: +* +* . The epoch of observation: the moment in time for which the +* position of the body is to be predicted. +* +* . The epoch defining the position of the body: the moment in time +* at which, in the absence of purturbations, the specified +* position (mean longitude, mean anomaly, or perihelion) is +* reached. +* +* . The osculating epoch: the moment in time at which the given +* elements are correct. +* +* For the major-planet and minor-planet cases it is usual to make +* the epoch that defines the position of the body the same as the +* epoch of osculation. Thus, only two different epochs are +* involved: the epoch of the elements and the epoch of observation. +* +* For comets, the epoch of perihelion fixes the position in the +* orbit and in general a different epoch of osculation will be +* chosen. Thus, all three types of epoch are involved. +* +* For the present routine: +* +* . The epoch of observation is the argument DATE. +* +* . The epoch defining the position of the body is the argument +* EPOCH. +* +* . The osculating epoch is not used and is assumed to be close +* enough to the epoch of observation to deliver adequate accuracy. +* If not, a preliminary call to slPRTL may be used to update +* the element-set (and its associated osculating epoch) by +* applying planetary perturbations. +* +* 6 Two important sources for orbital elements are Horizons, operated +* by the Jet Propulsion Laboratory, Pasadena, and the Minor Planet +* Center, operated by the Center for Astrophysics, Harvard. +* +* The JPL Horizons elements (heliocentric, J2000 ecliptic and +* equinox) correspond to SLALIB arguments as follows. +* +* Major planets: +* +* JFORM = 1 +* EPOCH = JDCT-2400000.5D0 +* ORBINC = IN (in radians) +* ANODE = OM (in radians) +* PERIH = OM+W (in radians) +* AORQ = A +* E = EC +* AORL = MA+OM+W (in radians) +* DM = N (in radians) +* +* Epoch of osculation = JDCT-2400000.5D0 +* +* Minor planets: +* +* JFORM = 2 +* EPOCH = JDCT-2400000.5D0 +* ORBINC = IN (in radians) +* ANODE = OM (in radians) +* PERIH = W (in radians) +* AORQ = A +* E = EC +* AORL = MA (in radians) +* +* Epoch of osculation = JDCT-2400000.5D0 +* +* Comets: +* +* JFORM = 3 +* EPOCH = Tp-2400000.5D0 +* ORBINC = IN (in radians) +* ANODE = OM (in radians) +* PERIH = W (in radians) +* AORQ = QR +* E = EC +* +* Epoch of osculation = JDCT-2400000.5D0 +* +* The MPC elements correspond to SLALIB arguments as follows. +* +* Minor planets: +* +* JFORM = 2 +* EPOCH = Epoch-2400000.5D0 +* ORBINC = Incl. (in radians) +* ANODE = Node (in radians) +* PERIH = Perih. (in radians) +* AORQ = a +* E = e +* AORL = M (in radians) +* +* Epoch of osculation = Epoch-2400000.5D0 +* +* Comets: +* +* JFORM = 3 +* EPOCH = T-2400000.5D0 +* ORBINC = Incl. (in radians) +* ANODE = Node. (in radians) +* PERIH = Perih. (in radians) +* AORQ = q +* E = e +* +* Epoch of osculation = Epoch-2400000.5D0 +* +* This revision: 19 June 2004 +* +* Copyright (C) 2004 P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,ELONG,PHI + INTEGER JFORM + DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E, + : AORL,DM,RA,DEC,R + INTEGER JSTAT + + DOUBLE PRECISION U(13) + + +* Transform conventional elements to universal elements. + CALL slELUE(DATE, + : JFORM,EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM, + : U,JSTAT) + +* If successful, make the prediction. + IF (JSTAT.EQ.0) CALL slPLTU(DATE,ELONG,PHI,U,RA,DEC,R,JSTAT) + + END diff --git a/math/slalib/plantu.f b/math/slalib/plantu.f new file mode 100644 index 00000000..81e65148 --- /dev/null +++ b/math/slalib/plantu.f @@ -0,0 +1,156 @@ + SUBROUTINE slPLTU (DATE, ELONG, PHI, U, RA, DEC, R, JSTAT) +*+ +* - - - - - - - +* P L A N T U +* - - - - - - - +* +* Topocentric apparent RA,Dec of a Solar-System object whose +* heliocentric universal elements are known. +* +* Given: +* DATE d TT MJD of observation (JD - 2400000.5) +* ELONG d observer's east longitude (radians) +* PHI d observer's geodetic latitude (radians) +* U d(13) universal elements +* +* (1) combined mass (M+m) +* (2) total energy of the orbit (alpha) +* (3) reference (osculating) epoch (t0) +* (4-6) position at reference epoch (r0) +* (7-9) velocity at reference epoch (v0) +* (10) heliocentric distance at reference epoch +* (11) r0.v0 +* (12) date (t) +* (13) universal eccentric anomaly (psi) of date, approx +* +* Returned: +* RA,DEC d RA, Dec (topocentric apparent, radians) +* R d distance from observer (AU) +* JSTAT i status: 0 = OK +* -1 = radius vector zero +* -2 = failed to converge +* +* Called: slGMST, slDT, slEPJ, slEPV, slUEPV, slPRNU, +* slDMXV, slPVOB, slDC2S, slDA2P +* +* Notes: +* +* 1 DATE is the instant for which the prediction is required. It is +* in the TT timescale (formerly Ephemeris Time, ET) and is a +* Modified Julian Date (JD-2400000.5). +* +* 2 The longitude and latitude allow correction for geocentric +* parallax. This is usually a small effect, but can become +* important for near-Earth asteroids. Geocentric positions can be +* generated by appropriate use of routines slEPV (or slEVP) and +* slUEPV. +* +* 3 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference 2). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* 4 The universal elements are with respect to the J2000 equator and +* equinox. +* +* 1 Sterne, Theodore E., "An Introduction to Celestial Mechanics", +* Interscience Publishers Inc., 1960. Section 6.7, p199. +* +* 2 Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* Last revision: 19 February 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,ELONG,PHI,U(13),RA,DEC,R + INTEGER JSTAT + +* Light time for unit distance (sec) + DOUBLE PRECISION TAU + PARAMETER (TAU=499.004782D0) + + INTEGER I + DOUBLE PRECISION DVB(3),DPB(3),VSG(6),VSP(6),V(6),RMAT(3,3), + : VGP(6),STL,VGO(6),DX,DY,DZ,D,TL + DOUBLE PRECISION slGMST,slDT,slEPJ,slDA2P + + + +* Sun to geocentre (J2000, velocity in AU/s). + CALL slEPV(DATE,VSG,VSG(4),DPB,DVB) + DO I=4,6 + VSG(I)=VSG(I)/86400D0 + END DO + +* Sun to planet (J2000). + CALL slUEPV(DATE,U,VSP,JSTAT) + +* Geocentre to planet (J2000). + DO I=1,6 + V(I)=VSP(I)-VSG(I) + END DO + +* Precession and nutation to date. + CALL slPRNU(2000D0,DATE,RMAT) + CALL slDMXV(RMAT,V,VGP) + CALL slDMXV(RMAT,V(4),VGP(4)) + +* Geocentre to observer (date). + STL=slGMST(DATE-slDT(slEPJ(DATE))/86400D0)+ELONG + CALL slPVOB(PHI,0D0,STL,VGO) + +* Observer to planet (date). + DO I=1,6 + V(I)=VGP(I)-VGO(I) + END DO + +* Geometric distance (AU). + DX=V(1) + DY=V(2) + DZ=V(3) + D=SQRT(DX*DX+DY*DY+DZ*DZ) + +* Light time (sec). + TL=TAU*D + +* Correct position for planetary aberration + DO I=1,3 + V(I)=V(I)-TL*V(I+3) + END DO + +* To RA,Dec. + CALL slDC2S(V,RA,DEC) + RA=slDA2P(RA) + R=D + + END diff --git a/math/slalib/pm.f b/math/slalib/pm.f new file mode 100644 index 00000000..903f92a8 --- /dev/null +++ b/math/slalib/pm.f @@ -0,0 +1,98 @@ + SUBROUTINE slPM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1) +*+ +* - - - +* P M +* - - - +* +* Apply corrections for proper motion to a star RA,Dec +* (double precision) +* +* References: +* 1984 Astronomical Almanac, pp B39-B41. +* (also Lederle & Schwan, Astron. Astrophys. 134, +* 1-6, 1984) +* +* Given: +* R0,D0 dp RA,Dec at epoch EP0 (rad) +* PR,PD dp proper motions: RA,Dec changes per year of epoch +* PX dp parallax (arcsec) +* RV dp radial velocity (km/sec, +ve if receding) +* EP0 dp start epoch in years (e.g. Julian epoch) +* EP1 dp end epoch in years (same system as EP0) +* +* Returned: +* R1,D1 dp RA,Dec at epoch EP1 (rad) +* +* Called: +* slDS2C spherical to Cartesian +* slDC2S Cartesian to spherical +* slDA2P normalize angle 0-2Pi +* +* Notes: +* +* 1 The proper motions in RA are dRA/dt rather than cos(Dec)*dRA/dt, +* and are in the same coordinate system as R0,D0. +* +* 2 If the available proper motions are pre-FK5 they will be per +* tropical year rather than per Julian year, and so the epochs +* must both be Besselian rather than Julian. In such cases, a +* scaling factor of 365.2422D0/365.25D0 should be applied to the +* radial velocity before use. +* +* P.T.Wallace Starlink 19 January 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION R0,D0,PR,PD,PX,RV,EP0,EP1,R1,D1 + +* Km/s to AU/year multiplied by arcseconds to radians + DOUBLE PRECISION VFR + PARAMETER (VFR=(365.25D0*86400D0/149597870D0)*4.8481368111D-6) + + INTEGER I + DOUBLE PRECISION slDA2P + DOUBLE PRECISION W,EM(3),T,P(3) + + + +* Spherical to Cartesian + CALL slDS2C(R0,D0,P) + +* Space motion (radians per year) + W=VFR*RV*PX + EM(1)=-PR*P(2)-PD*COS(R0)*SIN(D0)+W*P(1) + EM(2)= PR*P(1)-PD*SIN(R0)*SIN(D0)+W*P(2) + EM(3)= PD*COS(D0) +W*P(3) + +* Apply the motion + T=EP1-EP0 + DO I=1,3 + P(I)=P(I)+T*EM(I) + END DO + +* Cartesian to spherical + CALL slDC2S(P,R1,D1) + R1=slDA2P(R1) + + END diff --git a/math/slalib/polmo.f b/math/slalib/polmo.f new file mode 100644 index 00000000..c82f2132 --- /dev/null +++ b/math/slalib/polmo.f @@ -0,0 +1,159 @@ + SUBROUTINE slPLMO ( ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ ) +*+ +* - - - - - - +* P L M O +* - - - - - - +* +* Polar motion: correct site longitude and latitude for polar +* motion and calculate azimuth difference between celestial and +* terrestrial poles. +* +* Given: +* ELONGM d mean longitude of the observer (radians, east +ve) +* PHIM d mean geodetic latitude of the observer (radians) +* XP d polar motion x-coordinate (radians) +* YP d polar motion y-coordinate (radians) +* +* Returned: +* ELONG d true longitude of the observer (radians, east +ve) +* PHI d true geodetic latitude of the observer (radians) +* DAZ d azimuth correction (terrestrial-celestial, radians) +* +* Notes: +* +* 1) "Mean" longitude and latitude are the (fixed) values for the +* site's location with respect to the IERS terrestrial reference +* frame; the latitude is geodetic. TAKE CARE WITH THE LONGITUDE +* SIGN CONVENTION. The longitudes used by the present routine +* are east-positive, in accordance with geographical convention +* (and right-handed). In particular, note that the longitudes +* returned by the slOBS routine are west-positive, following +* astronomical usage, and must be reversed in sign before use in +* the present routine. +* +* 2) XP and YP are the (changing) coordinates of the Celestial +* Ephemeris Pole with respect to the IERS Reference Pole. +* XP is positive along the meridian at longitude 0 degrees, +* and YP is positive along the meridian at longitude +* 270 degrees (i.e. 90 degrees west). Values for XP,YP can +* be obtained from IERS circulars and equivalent publications; +* the maximum amplitude observed so far is about 0.3 arcseconds. +* +* 3) "True" longitude and latitude are the (moving) values for +* the site's location with respect to the celestial ephemeris +* pole and the meridian which corresponds to the Greenwich +* apparent sidereal time. The true longitude and latitude +* link the terrestrial coordinates with the standard celestial +* models (for precession, nutation, sidereal time etc). +* +* 4) The azimuths produced by slAOP and slAOPQ are with +* respect to due north as defined by the Celestial Ephemeris +* Pole, and can therefore be called "celestial azimuths". +* However, a telescope fixed to the Earth measures azimuth +* essentially with respect to due north as defined by the +* IERS Reference Pole, and can therefore be called "terrestrial +* azimuth". Uncorrected, this would manifest itself as a +* changing "azimuth zero-point error". The value DAZ is the +* correction to be added to a celestial azimuth to produce +* a terrestrial azimuth. +* +* 5) The present routine is rigorous. For most practical +* purposes, the following simplified formulae provide an +* adequate approximation: +* +* ELONG = ELONGM+XP*COS(ELONGM)-YP*SIN(ELONGM) +* PHI = PHIM+(XP*SIN(ELONGM)+YP*COS(ELONGM))*TAN(PHIM) +* DAZ = -SQRT(XP*XP+YP*YP)*COS(ELONGM-ATAN2(XP,YP))/COS(PHIM) +* +* An alternative formulation for DAZ is: +* +* X = COS(ELONGM)*COS(PHIM) +* Y = SIN(ELONGM)*COS(PHIM) +* DAZ = ATAN2(-X*YP-Y*XP,X*X+Y*Y) +* +* Reference: Seidelmann, P.K. (ed), 1992. "Explanatory Supplement +* to the Astronomical Almanac", ISBN 0-935702-68-7, +* sections 3.27, 4.25, 4.52. +* +* P.T.Wallace Starlink 30 November 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ELONGM,PHIM,XP,YP,ELONG,PHI,DAZ + + DOUBLE PRECISION SEL,CEL,SPH,CPH,XM,YM,ZM,XNM,YNM,ZNM, + : SXP,CXP,SYP,CYP,ZW,XT,YT,ZT,XNT,YNT + + + +* Site mean longitude and mean geodetic latitude as a Cartesian vector + SEL=SIN(ELONGM) + CEL=COS(ELONGM) + SPH=SIN(PHIM) + CPH=COS(PHIM) + + XM=CEL*CPH + YM=SEL*CPH + ZM=SPH + +* Rotate site vector by polar motion, Y-component then X-component + SXP=SIN(XP) + CXP=COS(XP) + SYP=SIN(YP) + CYP=COS(YP) + + ZW=(-YM*SYP+ZM*CYP) + + XT=XM*CXP-ZW*SXP + YT=YM*CYP+ZM*SYP + ZT=XM*SXP+ZW*CXP + +* Rotate also the geocentric direction of the terrestrial pole (0,0,1) + XNM=-SXP*CYP + YNM=SYP + ZNM=CXP*CYP + + CPH=SQRT(XT*XT+YT*YT) + IF (CPH.EQ.0D0) XT=1D0 + SEL=YT/CPH + CEL=XT/CPH + +* Return true longitude and true geodetic latitude of site + IF (XT.NE.0D0.OR.YT.NE.0D0) THEN + ELONG=ATAN2(YT,XT) + ELSE + ELONG=0D0 + END IF + PHI=ATAN2(ZT,CPH) + +* Return current azimuth of terrestrial pole seen from site position + XNT=(XNM*CEL+YNM*SEL)*ZT-ZNM*CPH + YNT=-XNM*SEL+YNM*CEL + IF (XNT.NE.0D0.OR.YNT.NE.0D0) THEN + DAZ=ATAN2(-YNT,-XNT) + ELSE + DAZ=0D0 + END IF + + END diff --git a/math/slalib/prebn.f b/math/slalib/prebn.f new file mode 100644 index 00000000..0c46f592 --- /dev/null +++ b/math/slalib/prebn.f @@ -0,0 +1,80 @@ + SUBROUTINE slPRBN (BEP0, BEP1, RMATP) +*+ +* - - - - - - +* P R B N +* - - - - - - +* +* Generate the matrix of precession between two epochs, +* using the old, pre-IAU1976, Bessel-Newcomb model, using +* Kinoshita's formulation (double precision) +* +* Given: +* BEP0 dp beginning Besselian epoch +* BEP1 dp ending Besselian epoch +* +* Returned: +* RMATP dp(3,3) precession matrix +* +* The matrix is in the sense V(BEP1) = RMATP * V(BEP0) +* +* Reference: +* Kinoshita, H. (1975) 'Formulas for precession', SAO Special +* Report No. 364, Smithsonian Institution Astrophysical +* Observatory, Cambridge, Massachusetts. +* +* Called: slDEUL +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION BEP0,BEP1,RMATP(3,3) + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION BIGT,T,TAS2R,W,ZETA,Z,THETA + + + +* Interval between basic epoch B1850.0 and beginning epoch in TC + BIGT = (BEP0-1850D0)/100D0 + +* Interval over which precession required, in tropical centuries + T = (BEP1-BEP0)/100D0 + +* Euler angles + TAS2R = T*AS2R + W = 2303.5548D0+(1.39720D0+0.000059D0*BIGT)*BIGT + + ZETA = (W+(0.30242D0-0.000269D0*BIGT+0.017996D0*T)*T)*TAS2R + Z = (W+(1.09478D0+0.000387D0*BIGT+0.018324D0*T)*T)*TAS2R + THETA = (2005.1125D0+(-0.85294D0-0.000365D0*BIGT)*BIGT+ + : (-0.42647D0-0.000365D0*BIGT-0.041802D0*T)*T)*TAS2R + +* Rotation matrix + CALL slDEUL('ZYZ',-ZETA,THETA,-Z,RMATP) + + END diff --git a/math/slalib/prec.f b/math/slalib/prec.f new file mode 100644 index 00000000..e8eadce7 --- /dev/null +++ b/math/slalib/prec.f @@ -0,0 +1,97 @@ + SUBROUTINE slPREC (EP0, EP1, RMATP) +*+ +* - - - - - +* P R E C +* - - - - - +* +* Form the matrix of precession between two epochs (IAU 1976, FK5) +* (double precision) +* +* Given: +* EP0 dp beginning epoch +* EP1 dp ending epoch +* +* Returned: +* RMATP dp(3,3) precession matrix +* +* Notes: +* +* 1) The epochs are TDB (loosely ET) Julian epochs. +* +* 2) The matrix is in the sense V(EP1) = RMATP * V(EP0) +* +* 3) Though the matrix method itself is rigorous, the precession +* angles are expressed through canonical polynomials which are +* valid only for a limited time span. There are also known +* errors in the IAU precession rate. The absolute accuracy +* of the present formulation is better than 0.1 arcsec from +* 1960AD to 2040AD, better than 1 arcsec from 1640AD to 2360AD, +* and remains below 3 arcsec for the whole of the period +* 500BC to 3000AD. The errors exceed 10 arcsec outside the +* range 1200BC to 3900AD, exceed 100 arcsec outside 4200BC to +* 5600AD and exceed 1000 arcsec outside 6800BC to 8200AD. +* The SLALIB routine slPREL implements a more elaborate +* model which is suitable for problems spanning several +* thousand years. +* +* References: +* Lieske,J.H., 1979. Astron.Astrophys.,73,282. +* equations (6) & (7), p283. +* Kaplan,G.H., 1981. USNO circular no. 163, pA2. +* +* Called: slDEUL +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EP0,EP1,RMATP(3,3) + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION T0,T,TAS2R,W,ZETA,Z,THETA + + + +* Interval between basic epoch J2000.0 and beginning epoch (JC) + T0 = (EP0-2000D0)/100D0 + +* Interval over which precession required (JC) + T = (EP1-EP0)/100D0 + +* Euler angles + TAS2R = T*AS2R + W = 2306.2181D0+(1.39656D0-0.000139D0*T0)*T0 + + ZETA = (W+((0.30188D0-0.000344D0*T0)+0.017998D0*T)*T)*TAS2R + Z = (W+((1.09468D0+0.000066D0*T0)+0.018203D0*T)*T)*TAS2R + THETA = ((2004.3109D0+(-0.85330D0-0.000217D0*T0)*T0) + : +((-0.42665D0-0.000217D0*T0)-0.041833D0*T)*T)*TAS2R + +* Rotation matrix + CALL slDEUL('ZYZ',-ZETA,THETA,-Z,RMATP) + + END diff --git a/math/slalib/preces.f b/math/slalib/preces.f new file mode 100644 index 00000000..9c2aec25 --- /dev/null +++ b/math/slalib/preces.f @@ -0,0 +1,102 @@ + SUBROUTINE slPRCE (SYSTEM, EP0, EP1, RA, DC) +*+ +* - - - - - - - +* P R C E +* - - - - - - - +* +* Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or +* FK5 (Fricke, post IAU 1976) as required. +* +* Given: +* SYSTEM char precession to be applied: 'FK4' or 'FK5' +* EP0,EP1 dp starting and ending epoch +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP0 +* +* Returned: +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP1 +* +* Called: slDA2P, slPRBN, slPREC, slDS2C, +* slDMXV, slDC2S +* +* Notes: +* +* 1) Lowercase characters in SYSTEM are acceptable. +* +* 2) The epochs are Besselian if SYSTEM='FK4' and Julian if 'FK5'. +* For example, to precess coordinates in the old system from +* equinox 1900.0 to 1950.0 the call would be: +* CALL slPRCE ('FK4', 1900D0, 1950D0, RA, DC) +* +* 3) This routine will NOT correctly convert between the old and +* the new systems - for example conversion from B1950 to J2000. +* For these purposes see slFK45, slFK54, slF45Z and +* slF54Z. +* +* 4) If an invalid SYSTEM is supplied, values of -99D0,-99D0 will +* be returned for both RA and DC. +* +* P.T.Wallace Starlink 20 April 1990 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER SYSTEM*(*) + DOUBLE PRECISION EP0,EP1,RA,DC + + DOUBLE PRECISION PM(3,3),V1(3),V2(3) + CHARACTER SYSUC*3 + + DOUBLE PRECISION slDA2P + + + + +* Convert to uppercase and validate SYSTEM + SYSUC=SYSTEM + IF (SYSUC(1:1).EQ.'f') SYSUC(1:1)='F' + IF (SYSUC(2:2).EQ.'k') SYSUC(2:2)='K' + IF (SYSUC.NE.'FK4'.AND.SYSUC.NE.'FK5') THEN + RA=-99D0 + DC=-99D0 + ELSE + +* Generate appropriate precession matrix + IF (SYSUC.EQ.'FK4') THEN + CALL slPRBN(EP0,EP1,PM) + ELSE + CALL slPREC(EP0,EP1,PM) + END IF + +* Convert RA,Dec to x,y,z + CALL slDS2C(RA,DC,V1) + +* Precess + CALL slDMXV(PM,V1,V2) + +* Back to RA,Dec + CALL slDC2S(V2,RA,DC) + RA=slDA2P(RA) + + END IF + + END diff --git a/math/slalib/precl.f b/math/slalib/precl.f new file mode 100644 index 00000000..55bb839e --- /dev/null +++ b/math/slalib/precl.f @@ -0,0 +1,143 @@ + SUBROUTINE slPREL (EP0, EP1, RMATP) +*+ +* - - - - - - +* P R E L +* - - - - - - +* +* Form the matrix of precession between two epochs, using the +* model of Simon et al (1994), which is suitable for long +* periods of time. +* +* (double precision) +* +* Given: +* EP0 dp beginning epoch +* EP1 dp ending epoch +* +* Returned: +* RMATP dp(3,3) precession matrix +* +* Notes: +* +* 1) The epochs are TDB Julian epochs. +* +* 2) The matrix is in the sense V(EP1) = RMATP * V(EP0) +* +* 3) The absolute accuracy of the model is limited by the +* uncertainty in the general precession, about 0.3 arcsec per +* 1000 years. The remainder of the formulation provides a +* precision of 1 mas over the interval from 1000AD to 3000AD, +* 0.1 arcsec from 1000BC to 5000AD and 1 arcsec from +* 4000BC to 8000AD. +* +* Reference: +* Simon, J.L. et al., 1994. Astron.Astrophys., 282, 663-683. +* +* Called: slDEUL +* +* P.T.Wallace Starlink 23 August 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EP0,EP1,RMATP(3,3) + +* Arc seconds to radians + DOUBLE PRECISION AS2R + PARAMETER (AS2R=0.484813681109535994D-5) + + DOUBLE PRECISION T0,T,TAS2R,W,ZETA,Z,THETA + + + +* Interval between basic epoch J2000.0 and beginning epoch (1000JY) + T0 = (EP0-2000D0)/1000D0 + +* Interval over which precession required (1000JY) + T = (EP1-EP0)/1000D0 + +* Euler angles + TAS2R = T*AS2R + W = 23060.9097D0+ + : (139.7459D0+ + : (-0.0038D0+ + : (-0.5918D0+ + : (-0.0037D0+ + : 0.0007D0*T0)*T0)*T0)*T0)*T0 + + ZETA = (W+(30.2226D0+ + : (-0.2523D0+ + : (-0.3840D0+ + : (-0.0014D0+ + : 0.0007D0*T0)*T0)*T0)*T0+ + : (18.0183D0+ + : (-0.1326D0+ + : (0.0006D0+ + : 0.0005D0*T0)*T0)*T0+ + : (-0.0583D0+ + : (-0.0001D0+ + : 0.0007D0*T0)*T0+ + : (-0.0285D0+ + : (-0.0002D0)*T)*T)*T)*T)*T)*TAS2R + + Z = (W+(109.5270D0+ + : (0.2446D0+ + : (-1.3913D0+ + : (-0.0134D0+ + : 0.0026D0*T0)*T0)*T0)*T0+ + : (18.2667D0+ + : (-1.1400D0+ + : (-0.0173D0+ + : 0.0044D0*T0)*T0)*T0+ + : (-0.2821D0+ + : (-0.0093D0+ + : 0.0032D0*T0)*T0+ + : (-0.0301D0+ + : 0.0006D0*T0 + : -0.0001D0*T)*T)*T)*T)*T)*TAS2R + + THETA = (20042.0207D0+ + : (-85.3131D0+ + : (-0.2111D0+ + : (0.3642D0+ + : (0.0008D0+ + : (-0.0005D0)*T0)*T0)*T0)*T0)*T0+ + : (-42.6566D0+ + : (-0.2111D0+ + : (0.5463D0+ + : (0.0017D0+ + : (-0.0012D0)*T0)*T0)*T0)*T0+ + : (-41.8238D0+ + : (0.0359D0+ + : (0.0027D0+ + : (-0.0001D0)*T0)*T0)*T0+ + : (-0.0731D0+ + : (0.0019D0+ + : 0.0009D0*T0)*T0+ + : (-0.0127D0+ + : 0.0011D0*T0+0.0004D0*T)*T)*T)*T)*T)*TAS2R + +* Rotation matrix + CALL slDEUL('ZYZ',-ZETA,THETA,-Z,RMATP) + + END diff --git a/math/slalib/precss.f b/math/slalib/precss.f new file mode 100644 index 00000000..c18707dc --- /dev/null +++ b/math/slalib/precss.f @@ -0,0 +1,76 @@ + SUBROUTINE slPRCS (SYSTEM, EP0, EP1, RA, DC) +*+ +* - - - - - - - +* P R C E +* - - - - - - - +* +* Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or +* FK5 (Fricke, post IAU 1976) as required. +* +* Given: +* SYSTEM int precession to be applied: 1 = FK4 or 2 = FK5 +* EP0,EP1 dp starting and ending epoch +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP0 +* +* Returned: +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP1 +* +* Called: slDA2P, slPRBN, slPREC, slDS2C, +* slDMXV, slDC2S +* +* Notes: +* +* 1) Lowercase characters in SYSTEM are acceptable. +* +* 2) The epochs are Besselian if SYSTEM=FK4 and Julian if FK5. +* For example, to precess coordinates in the old system from +* equinox 1900.0 to 1950.0 the call would be: +* CALL slPRCS (1, 1900D0, 1950D0, RA, DC) +* +* 3) This routine will NOT correctly convert between the old and +* the new systems - for example conversion from B1950 to J2000. +* For these purposes see slFK45, slFK54, slF45Z and +* slF54Z. +* +* 4) If an invalid SYSTEM is supplied, values of -99D0,-99D0 will +* be returned for both RA and DC. +* +* P.T.Wallace Starlink 20 April 1990 +*- + + IMPLICIT NONE + + INTEGER SYSTEM + DOUBLE PRECISION EP0,EP1,RA,DC + + DOUBLE PRECISION PM(3,3),V1(3),V2(3) + + DOUBLE PRECISION slDA2P + + +* Convert to uppercase and validate SYSTEM + IF (SYSTEM.NE.1.AND.SYSTEM.NE.2) THEN + RA=-99D0 + DC=-99D0 + ELSE + +* Generate appropriate precession matrix + IF (SYSTEM.EQ.1) THEN + CALL slPRBN(EP0,EP1,PM) + ELSE + CALL slPREC(EP0,EP1,PM) + END IF + +* Convert RA,Dec to x,y,z + CALL slDS2C(RA,DC,V1) + +* Precess + CALL slDMXV(PM,V1,V2) + +* Back to RA,Dec + CALL slDC2S(V2,RA,DC) + RA=slDA2P(RA) + + END IF + + END diff --git a/math/slalib/precss.f.sav b/math/slalib/precss.f.sav new file mode 100644 index 00000000..c18707dc --- /dev/null +++ b/math/slalib/precss.f.sav @@ -0,0 +1,76 @@ + SUBROUTINE slPRCS (SYSTEM, EP0, EP1, RA, DC) +*+ +* - - - - - - - +* P R C E +* - - - - - - - +* +* Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or +* FK5 (Fricke, post IAU 1976) as required. +* +* Given: +* SYSTEM int precession to be applied: 1 = FK4 or 2 = FK5 +* EP0,EP1 dp starting and ending epoch +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP0 +* +* Returned: +* RA,DC dp RA,Dec, mean equator & equinox of epoch EP1 +* +* Called: slDA2P, slPRBN, slPREC, slDS2C, +* slDMXV, slDC2S +* +* Notes: +* +* 1) Lowercase characters in SYSTEM are acceptable. +* +* 2) The epochs are Besselian if SYSTEM=FK4 and Julian if FK5. +* For example, to precess coordinates in the old system from +* equinox 1900.0 to 1950.0 the call would be: +* CALL slPRCS (1, 1900D0, 1950D0, RA, DC) +* +* 3) This routine will NOT correctly convert between the old and +* the new systems - for example conversion from B1950 to J2000. +* For these purposes see slFK45, slFK54, slF45Z and +* slF54Z. +* +* 4) If an invalid SYSTEM is supplied, values of -99D0,-99D0 will +* be returned for both RA and DC. +* +* P.T.Wallace Starlink 20 April 1990 +*- + + IMPLICIT NONE + + INTEGER SYSTEM + DOUBLE PRECISION EP0,EP1,RA,DC + + DOUBLE PRECISION PM(3,3),V1(3),V2(3) + + DOUBLE PRECISION slDA2P + + +* Convert to uppercase and validate SYSTEM + IF (SYSTEM.NE.1.AND.SYSTEM.NE.2) THEN + RA=-99D0 + DC=-99D0 + ELSE + +* Generate appropriate precession matrix + IF (SYSTEM.EQ.1) THEN + CALL slPRBN(EP0,EP1,PM) + ELSE + CALL slPREC(EP0,EP1,PM) + END IF + +* Convert RA,Dec to x,y,z + CALL slDS2C(RA,DC,V1) + +* Precess + CALL slDMXV(PM,V1,V2) + +* Back to RA,Dec + CALL slDC2S(V2,RA,DC) + RA=slDA2P(RA) + + END IF + + END diff --git a/math/slalib/prenut.f b/math/slalib/prenut.f new file mode 100644 index 00000000..4e2bb8cb --- /dev/null +++ b/math/slalib/prenut.f @@ -0,0 +1,67 @@ + SUBROUTINE slPRNU (EPOCH, DATE, RMATPN) +*+ +* - - - - - - - +* P R N U +* - - - - - - - +* +* Form the matrix of precession and nutation (SF2001) +* (double precision) +* +* Given: +* EPOCH dp Julian Epoch for mean coordinates +* DATE dp Modified Julian Date (JD-2400000.5) +* for true coordinates +* +* Returned: +* RMATPN dp(3,3) combined precession/nutation matrix +* +* Called: slPREC, slEPJ, slNUT, slDMXM +* +* Notes: +* +* 1) The epoch and date are TDB (loosely ET). TT will do, or even +* UTC. +* +* 2) The matrix is in the sense V(true) = RMATPN * V(mean) +* +* Last revision: 3 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION EPOCH,DATE,RMATPN(3,3) + + DOUBLE PRECISION RMATP(3,3),RMATN(3,3),slEPJ + + + +* Precession + CALL slPREC(EPOCH,slEPJ(DATE),RMATP) + +* Nutation + CALL slNUT(DATE,RMATN) + +* Combine the matrices: PN = N x P + CALL slDMXM(RMATN,RMATP,RMATPN) + + END diff --git a/math/slalib/pv2el.f b/math/slalib/pv2el.f new file mode 100644 index 00000000..b8db2d25 --- /dev/null +++ b/math/slalib/pv2el.f @@ -0,0 +1,380 @@ + SUBROUTINE slPVEL (PV, DATE, PMASS, JFORMR, + : JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, JSTAT) +*+ +* - - - - - - +* P V E L +* - - - - - - +* +* Heliocentric osculating elements obtained from instantaneous position +* and velocity. +* +* Given: +* PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, +* J2000 equatorial triad (AU,AU/s; Note 1) +* DATE d date (TT Modified Julian Date = JD-2400000.5) +* PMASS d mass of the planet (Sun=1; Note 2) +* JFORMR i requested element set (1-3; Note 3) +* +* Returned: +* JFORM d element set actually returned (1-3; Note 4) +* EPOCH d epoch of elements (TT MJD) +* ORBINC d inclination (radians) +* ANODE d longitude of the ascending node (radians) +* PERIH d longitude or argument of perihelion (radians) +* AORQ d mean distance or perihelion distance (AU) +* E d eccentricity +* AORL d mean anomaly or longitude (radians, JFORM=1,2 only) +* DM d daily motion (radians, JFORM=1 only) +* JSTAT i status: 0 = OK +* -1 = illegal PMASS +* -2 = illegal JFORMR +* -3 = position/velocity out of range +* +* Notes +* +* 1 The PV 6-vector is with respect to the mean equator and equinox of +* epoch J2000. The orbital elements produced are with respect to +* the J2000 ecliptic and mean equinox. +* +* 2 The mass, PMASS, is important only for the larger planets. For +* most purposes (e.g. asteroids) use 0D0. Values less than zero +* are illegal. +* +* 3 Three different element-format options are supported: +* +* Option JFORM=1, suitable for the major planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = longitude of perihelion, curly pi (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e +* AORL = mean longitude L (radians) +* DM = daily motion (radians) +* +* Option JFORM=2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e +* AORL = mean anomaly M (radians) +* +* Option JFORM=3, suitable for comets: +* +* EPOCH = epoch of perihelion (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e +* +* 4 It may not be possible to generate elements in the form +* requested through JFORMR. The caller is notified of the form +* of elements actually returned by means of the JFORM argument: +* +* JFORMR JFORM meaning +* +* 1 1 OK - elements are in the requested format +* 1 2 never happens +* 1 3 orbit not elliptical +* +* 2 1 never happens +* 2 2 OK - elements are in the requested format +* 2 3 orbit not elliptical +* +* 3 1 never happens +* 3 2 never happens +* 3 3 OK - elements are in the requested format +* +* 5 The arguments returned for each value of JFORM (cf Note 5: JFORM +* may not be the same as JFORMR) are as follows: +* +* JFORM 1 2 3 +* EPOCH t0 t0 T +* ORBINC i i i +* ANODE Omega Omega Omega +* PERIH curly pi omega omega +* AORQ a a q +* E e e e +* AORL L M - +* DM n - - +* +* where: +* +* t0 is the epoch of the elements (MJD, TT) +* T " epoch of perihelion (MJD, TT) +* i " inclination (radians) +* Omega " longitude of the ascending node (radians) +* curly pi " longitude of perihelion (radians) +* omega " argument of perihelion (radians) +* a " mean distance (AU) +* q " perihelion distance (AU) +* e " eccentricity +* L " longitude (radians, 0-2pi) +* M " mean anomaly (radians, 0-2pi) +* n " daily motion (radians) +* - means no value is set +* +* 6 At very small inclinations, the longitude of the ascending node +* ANODE becomes indeterminate and under some circumstances may be +* set arbitrarily to zero. Similarly, if the orbit is close to +* circular, the true anomaly becomes indeterminate and under some +* circumstances may be set arbitrarily to zero. In such cases, +* the other elements are automatically adjusted to compensate, +* and so the elements remain a valid description of the orbit. +* +* 7 The osculating epoch for the returned elements is the argument +* DATE. +* +* Reference: Sterne, Theodore E., "An Introduction to Celestial +* Mechanics", Interscience Publishers, 1960 +* +* Called: slDA2P +* +* Last revision: 8 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION PV(6),DATE,PMASS + INTEGER JFORMR,JFORM + DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM + INTEGER JSTAT + +* Seconds to days + DOUBLE PRECISION DAY + PARAMETER (DAY=86400D0) + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Sin and cos of J2000 mean obliquity (IAU 1976) + DOUBLE PRECISION SE,CE + PARAMETER (SE=0.3977771559319137D0, + : CE=0.9174820620691818D0) + +* Minimum allowed distance (AU) and speed (AU/day) + DOUBLE PRECISION RMIN,VMIN + PARAMETER (RMIN=1D-3,VMIN=1D-8) + +* How close to unity the eccentricity has to be to call it a parabola + DOUBLE PRECISION PARAB + PARAMETER (PARAB=1D-8) + + DOUBLE PRECISION X,Y,Z,XD,YD,ZD,R,V2,V,RDV,GMU,HX,HY,HZ, + : HX2PY2,H2,H,OI,BIGOM,AR,ECC,S,C,AT,U,OM, + : GAR3,EM1,EP1,HAT,SHAT,CHAT,AE,AM,DN,PL, + : EL,Q,TP,THAT,THHF,F + + INTEGER JF + + DOUBLE PRECISION slDA2P + + +* Validate arguments PMASS and JFORMR. + IF (PMASS.LT.0D0) THEN + JSTAT = -1 + GO TO 999 + END IF + IF (JFORMR.LT.1.OR.JFORMR.GT.3) THEN + JSTAT = -2 + GO TO 999 + END IF + +* Provisionally assume the elements will be in the chosen form. + JF = JFORMR + +* Rotate the position from equatorial to ecliptic coordinates. + X = PV(1) + Y = PV(2)*CE+PV(3)*SE + Z = -PV(2)*SE+PV(3)*CE + +* Rotate the velocity similarly, scaling to AU/day. + XD = DAY*PV(4) + YD = DAY*(PV(5)*CE+PV(6)*SE) + ZD = DAY*(-PV(5)*SE+PV(6)*CE) + +* Distance and speed. + R = SQRT(X*X+Y*Y+Z*Z) + V2 = XD*XD+YD*YD+ZD*ZD + V = SQRT(V2) + +* Reject unreasonably small values. + IF (R.LT.RMIN.OR.V.LT.VMIN) THEN + JSTAT = -3 + GO TO 999 + END IF + +* R dot V. + RDV = X*XD+Y*YD+Z*ZD + +* Mu. + GMU = (1D0+PMASS)*GCON*GCON + +* Vector angular momentum per unit reduced mass. + HX = Y*ZD-Z*YD + HY = Z*XD-X*ZD + HZ = X*YD-Y*XD + +* Areal constant. + HX2PY2 = HX*HX+HY*HY + H2 = HX2PY2+HZ*HZ + H = SQRT(H2) + +* Inclination. + OI = ATAN2(SQRT(HX2PY2),HZ) + +* Longitude of ascending node. + IF (HX.NE.0D0.OR.HY.NE.0D0) THEN + BIGOM = ATAN2(HX,-HY) + ELSE + BIGOM=0D0 + END IF + +* Reciprocal of mean distance etc. + AR = 2D0/R-V2/GMU + +* Eccentricity. + ECC = SQRT(MAX(1D0-AR*H2/GMU,0D0)) + +* True anomaly. + S = H*RDV + C = H2-R*GMU + IF (S.NE.0D0.OR.C.NE.0D0) THEN + AT = ATAN2(S,C) + ELSE + AT = 0D0 + END IF + +* Argument of the latitude. + S = SIN(BIGOM) + C = COS(BIGOM) + U = ATAN2((-X*S+Y*C)*COS(OI)+Z*SIN(OI),X*C+Y*S) + +* Argument of perihelion. + OM = U-AT + +* Capture near-parabolic cases. + IF (ABS(ECC-1D0).LT.PARAB) ECC=1D0 + +* Comply with JFORMR = 1 or 2 only if orbit is elliptical. + IF (ECC.GE.1D0) JF=3 + +* Functions. + GAR3 = GMU*AR*AR*AR + EM1 = ECC-1D0 + EP1 = ECC+1D0 + HAT = AT/2D0 + SHAT = SIN(HAT) + CHAT = COS(HAT) + +* Variable initializations to avoid compiler warnings. + AM = 0D0 + DN = 0D0 + PL = 0D0 + EL = 0D0 + Q = 0D0 + TP = 0D0 + +* Ellipse? + IF (ECC.LT.1D0 ) THEN + +* Eccentric anomaly. + AE = 2D0*ATAN2(SQRT(-EM1)*SHAT,SQRT(EP1)*CHAT) + +* Mean anomaly. + AM = AE-ECC*SIN(AE) + +* Daily motion. + DN = SQRT(GAR3) + END IF + +* "Major planet" element set? + IF (JF.EQ.1) THEN + +* Longitude of perihelion. + PL = BIGOM+OM + +* Longitude at epoch. + EL = PL+AM + END IF + +* "Comet" element set? + IF (JF.EQ.3) THEN + +* Perihelion distance. + Q = H2/(GMU*EP1) + +* Ellipse, parabola, hyperbola? + IF (ECC.LT.1D0) THEN + +* Ellipse: epoch of perihelion. + TP = DATE-AM/DN + ELSE + +* Parabola or hyperbola: evaluate tan ( ( true anomaly ) / 2 ) + THAT = SHAT/CHAT + IF (ECC.EQ.1D0) THEN + +* Parabola: epoch of perihelion. + TP = DATE-THAT*(1D0+THAT*THAT/3D0)*H*H2/(2D0*GMU*GMU) + ELSE + +* Hyperbola: epoch of perihelion. + THHF = SQRT(EM1/EP1)*THAT + F = LOG(1D0+THHF)-LOG(1D0-THHF) + TP = DATE-(ECC*SINH(F)-F)/SQRT(-GAR3) + END IF + END IF + END IF + +* Return the appropriate set of elements. + JFORM = JF + ORBINC = OI + ANODE = slDA2P(BIGOM) + E = ECC + IF (JF.EQ.1) THEN + PERIH = slDA2P(PL) + AORL = slDA2P(EL) + DM = DN + ELSE + PERIH = slDA2P(OM) + IF (JF.EQ.2) AORL = slDA2P(AM) + END IF + IF (JF.NE.3) THEN + EPOCH = DATE + AORQ = 1D0/AR + ELSE + EPOCH = TP + AORQ = Q + END IF + JSTAT = 0 + + 999 CONTINUE + END diff --git a/math/slalib/pv2ue.f b/math/slalib/pv2ue.f new file mode 100644 index 00000000..a2a686ab --- /dev/null +++ b/math/slalib/pv2ue.f @@ -0,0 +1,168 @@ + SUBROUTINE slPVUE (PV, DATE, PMASS, U, JSTAT) +*+ +* - - - - - - +* P V U E +* - - - - - - +* +* Construct a universal element set based on an instantaneous position +* and velocity. +* +* Given: +* PV d(6) heliocentric x,y,z,xdot,ydot,zdot of date, +* (AU,AU/s; Note 1) +* DATE d date (TT Modified Julian Date = JD-2400000.5) +* PMASS d mass of the planet (Sun=1; Note 2) +* +* Returned: +* U d(13) universal orbital elements (Note 3) +* +* (1) combined mass (M+m) +* (2) total energy of the orbit (alpha) +* (3) reference (osculating) epoch (t0) +* (4-6) position at reference epoch (r0) +* (7-9) velocity at reference epoch (v0) +* (10) heliocentric distance at reference epoch +* (11) r0.v0 +* (12) date (t) +* (13) universal eccentric anomaly (psi) of date, approx +* +* JSTAT i status: 0 = OK +* -1 = illegal PMASS +* -2 = too close to Sun +* -3 = too slow +* +* Notes +* +* 1 The PV 6-vector can be with respect to any chosen inertial frame, +* and the resulting universal-element set will be with respect to +* the same frame. A common choice will be mean equator and ecliptic +* of epoch J2000. +* +* 2 The mass, PMASS, is important only for the larger planets. For +* most purposes (e.g. asteroids) use 0D0. Values less than zero +* are illegal. +* +* 3 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION PV(6),DATE,PMASS,U(13) + INTEGER JSTAT + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Canonical days to seconds + DOUBLE PRECISION CD2S + PARAMETER (CD2S=GCON/86400D0) + +* Minimum allowed distance (AU) and speed (AU per canonical day) + DOUBLE PRECISION RMIN,VMIN + PARAMETER (RMIN=1D-3,VMIN=1D-3) + + DOUBLE PRECISION T0,CM,X,Y,Z,XD,YD,ZD,R,V2,V,ALPHA,RDV + + +* Reference epoch. + T0 = DATE + +* Combined mass (mu=M+m). + IF (PMASS.LT.0D0) GO TO 9010 + CM = 1D0+PMASS + +* Unpack the state vector, expressing velocity in AU per canonical day. + X = PV(1) + Y = PV(2) + Z = PV(3) + XD = PV(4)/CD2S + YD = PV(5)/CD2S + ZD = PV(6)/CD2S + +* Heliocentric distance, and speed. + R = SQRT(X*X+Y*Y+Z*Z) + V2 = XD*XD+YD*YD+ZD*ZD + V = SQRT(V2) + +* Reject unreasonably small values. + IF (R.LT.RMIN) GO TO 9020 + IF (V.LT.VMIN) GO TO 9030 + +* Total energy of the orbit. + ALPHA = V2-2D0*CM/R + +* Outward component of velocity. + RDV = X*XD+Y*YD+Z*ZD + +* Construct the universal-element set. + U(1) = CM + U(2) = ALPHA + U(3) = T0 + U(4) = X + U(5) = Y + U(6) = Z + U(7) = XD + U(8) = YD + U(9) = ZD + U(10) = R + U(11) = RDV + U(12) = T0 + U(13) = 0D0 + +* Exit. + JSTAT = 0 + GO TO 9999 + +* Negative PMASS. + 9010 CONTINUE + JSTAT = -1 + GO TO 9999 + +* Too close. + 9020 CONTINUE + JSTAT = -2 + GO TO 9999 + +* Too slow. + 9030 CONTINUE + JSTAT = -3 + + 9999 CONTINUE + END diff --git a/math/slalib/pvobs.f b/math/slalib/pvobs.f new file mode 100644 index 00000000..143704c3 --- /dev/null +++ b/math/slalib/pvobs.f @@ -0,0 +1,77 @@ + SUBROUTINE slPVOB (P, H, STL, PV) +*+ +* - - - - - - +* P V O B +* - - - - - - +* +* Position and velocity of an observing station (double precision) +* +* Given: +* P dp latitude (geodetic, radians) +* H dp height above reference spheroid (geodetic, metres) +* STL dp local apparent sidereal time (radians) +* +* Returned: +* PV dp(6) position/velocity 6-vector (AU, AU/s, true equator +* and equinox of date) +* +* Called: slGEOC +* +* IAU 1976 constants are used. +* +* P.T.Wallace Starlink 14 November 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION P,H,STL,PV(6) + + DOUBLE PRECISION R,Z,S,C,V + +* Mean sidereal rate (at J2000) in radians per (UT1) second + DOUBLE PRECISION SR + PARAMETER (SR=7.292115855306589D-5) + + + +* Geodetic to geocentric conversion + CALL slGEOC(P,H,R,Z) + +* Functions of ST + S=SIN(STL) + C=COS(STL) + +* Speed + V=SR*R + +* Position + PV(1)=R*C + PV(2)=R*S + PV(3)=Z + +* Velocity + PV(4)=-V*S + PV(5)=V*C + PV(6)=0D0 + + END diff --git a/math/slalib/pxy.f b/math/slalib/pxy.f new file mode 100644 index 00000000..6b67089b --- /dev/null +++ b/math/slalib/pxy.f @@ -0,0 +1,110 @@ + SUBROUTINE slPXY (NP,XYE,XYM,COEFFS,XYP,XRMS,YRMS,RRMS) +*+ +* - - - - +* P X Y +* - - - - +* +* Given arrays of "expected" and "measured" [X,Y] coordinates, and a +* linear model relating them (as produced by slFTXY), compute +* the array of "predicted" coordinates and the RMS residuals. +* +* Given: +* NP i number of samples +* XYE d(2,np) expected [X,Y] for each sample +* XYM d(2,np) measured [X,Y] for each sample +* COEFFS d(6) coefficients of model (see below) +* +* Returned: +* XYP d(2,np) predicted [X,Y] for each sample +* XRMS d RMS in X +* YRMS d RMS in Y +* RRMS d total RMS (vector sum of XRMS and YRMS) +* +* The model is supplied in the array COEFFS. Naming the +* elements of COEFF as follows: +* +* COEFFS(1) = A +* COEFFS(2) = B +* COEFFS(3) = C +* COEFFS(4) = D +* COEFFS(5) = E +* COEFFS(6) = F +* +* the model is applied thus: +* +* XP = A + B*XM + C*YM +* YP = D + E*XM + F*YM +* +* The residuals are (XP-XE) and (YP-YE). +* +* If NP is less than or equal to zero, no coordinates are +* transformed, and the RMS residuals are all zero. +* +* See also slFTXY, slINVF, slXYXY, slDCMF +* +* Called: slXYXY +* +* P.T.Wallace Starlink 22 May 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER NP + DOUBLE PRECISION XYE(2,NP),XYM(2,NP),COEFFS(6), + : XYP(2,NP),XRMS,YRMS,RRMS + + INTEGER I + DOUBLE PRECISION SDX2,SDY2,XP,YP,DX,DY,DX2,DY2,P + + + +* Initialize summations + SDX2=0D0 + SDY2=0D0 + +* Loop by sample + DO I=1,NP + +* Transform "measured" [X,Y] to "predicted" [X,Y] + CALL slXYXY(XYM(1,I),XYM(2,I),COEFFS,XP,YP) + XYP(1,I)=XP + XYP(2,I)=YP + +* Compute residuals in X and Y, and update summations + DX=XYE(1,I)-XP + DY=XYE(2,I)-YP + DX2=DX*DX + DY2=DY*DY + SDX2=SDX2+DX2 + SDY2=SDY2+DY2 + +* Next sample + END DO + +* Compute RMS values + P=MAX(1D0,DBLE(NP)) + XRMS=SQRT(SDX2/P) + YRMS=SQRT(SDY2/P) + RRMS=SQRT(XRMS*XRMS+YRMS*YRMS) + + END diff --git a/math/slalib/random.F__vms b/math/slalib/random.F__vms new file mode 100644 index 00000000..b57b5fc9 --- /dev/null +++ b/math/slalib/random.F__vms @@ -0,0 +1,69 @@ + REAL FUNCTION sla_RANDOM (SEED) +*+ +* - - - - - - - +* R A N D O M +* - - - - - - - +* +* Generate pseudo-random real number in the range 0 <= X < 1. +* (single precision) +* +* !!! Version for VAX/VMS and DECstation !!! +* +* Given: +* SEED real an arbitrary real number +* +* Notes: +* +* 1) The result is a pseudo-random REAL number in the range +* 0 <= sla_RANDOM < 1. +* +* 2) SEED is used first time through only. +* +* Called: RAN (a REAL function from the DEC Fortran Library) +* +* P.T.Wallace Starlink 14 October 1991 +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL SEED + + REAL RAN + + REAL AS + INTEGER ISEED + LOGICAL FIRST + SAVE FIRST + DATA FIRST /.TRUE./ + + + +* If first time, turn SEED into a large, odd integer + IF (FIRST) THEN + AS=ABS(SEED)+1.0 + ISEED=NINT(AS/10.0**(NINT(ALOG10(AS))-6)) + IF (MOD(ISEED,2).EQ.0) ISEED=ISEED+1 + FIRST=.FALSE. + END IF + +* Next pseudo-random number + sla_RANDOM=RAN(ISEED) + + END diff --git a/math/slalib/random.F__win b/math/slalib/random.F__win new file mode 100644 index 00000000..9cd77fac --- /dev/null +++ b/math/slalib/random.F__win @@ -0,0 +1,59 @@ + REAL FUNCTION sla_RANDOM (XSEED) +*+ +* - - - - - - - +* R A N D O M +* - - - - - - - +* +* Generate pseudo-random real number in the range 0 <= X < 1. +* +* (single precision) +* +* !!! Microsoft Fortran dependent !!! +* +* Given (but used first time only): +* XSEED real an arbitrary real number +* +* The value returned is a pseudo-random number such that +* 0 <= sla_RANDOM < 1. +* +* Called: RANDOM (Microsoft run-time library) +* +* P.T.Wallace Starlink 7 November 2003 +* +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL XSEED + + REAL X + LOGICAL FIRST + SAVE FIRST + DATA FIRST /.TRUE./ + + + IF (FIRST) THEN + CALL SEED(NINT(MOD(XSEED*1.234E7,32E3))) ! Microsoft Fortran + FIRST=.FALSE. + END IF + CALL RANDOM(X) ! Microsoft Fortran + sla_RANDOM=X + + END diff --git a/math/slalib/random.Fdefault b/math/slalib/random.Fdefault new file mode 100644 index 00000000..9a79cb6c --- /dev/null +++ b/math/slalib/random.Fdefault @@ -0,0 +1,87 @@ +#include "config.h" + REAL FUNCTION sla_RANDOM (SEED) +*+ +* - - - - - - - +* R A N D O M +* - - - - - - - +* +* Generate pseudo-random real number in the range 0 <= X < 1. +* (single precision) +* +* +* Given: +* SEED real an arbitrary real number +* +* Notes: +* +* 1) The result is a pseudo-random REAL number in the range +* 0 <= sla_RANDOM < 1. +* +* 2) SEED is used first time through only. +* +* Called: RAN or RAND (a REAL function returning a random variate -- +* the precise function which is called depends on which functions +* are available when the library is built). If neither of these +* is available, we use the local substitute RANDOM defined +* in rtl_random.c +* +* P.T.Wallace Starlink 14 October 1991 +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +*- + + IMPLICIT NONE + + REAL SEED + +#if HAVE_RAND + REAL RAND +#elif HAVE_RANDOM + REAL RANDOM +#else + error "Can't find random-number function" +#endif + + REAL AS + INTEGER ISEED + LOGICAL FIRST + SAVE FIRST + DATA FIRST /.TRUE./ + + + +* If first time, turn SEED into a large, odd integer + IF (FIRST) THEN + AS=ABS(SEED)+1.0 + ISEED=NINT(AS/10.0**(NINT(ALOG10(AS))-6)) + IF (MOD(ISEED,2).EQ.0) ISEED=ISEED+1 + FIRST=.FALSE. +#if HAVE_RAND + AS = RAND(ISEED) +#endif + ELSE + ISEED=0 + END IF + +* Next pseudo-random number +#if HAVE_RAND + sla_RANDOM=RAND(0) +#elif HAVE_RANDOM + sla_RANDOM=RANDOM(ISEED) +#endif + + END diff --git a/math/slalib/range.f b/math/slalib/range.f new file mode 100644 index 00000000..fa927043 --- /dev/null +++ b/math/slalib/range.f @@ -0,0 +1,51 @@ + REAL FUNCTION slRA1P (ANGLE) +*+ +* - - - - - - +* R A 1 P +* - - - - - - +* +* Normalize angle into range +/- pi (single precision) +* +* Given: +* ANGLE dp the angle in radians +* +* The result is ANGLE expressed in the +/- pi (single +* precision). +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL ANGLE + + REAL API,A2PI + PARAMETER (API=3.141592653589793238462643) + PARAMETER (A2PI=6.283185307179586476925287) + + + slRA1P=MOD(ANGLE,A2PI) + IF (ABS(slRA1P).GE.API) + : slRA1P=slRA1P-SIGN(A2PI,ANGLE) + + END diff --git a/math/slalib/ranorm.f b/math/slalib/ranorm.f new file mode 100644 index 00000000..77f4b781 --- /dev/null +++ b/math/slalib/ranorm.f @@ -0,0 +1,49 @@ + REAL FUNCTION slRA2P (ANGLE) +*+ +* - - - - - - - +* R A 2 P +* - - - - - - - +* +* Normalize angle into range 0-2 pi (single precision) +* +* Given: +* ANGLE dp the angle in radians +* +* The result is ANGLE expressed in the range 0-2 pi (single +* precision). +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL ANGLE + + REAL A2PI + PARAMETER (A2PI=6.283185307179586476925287) + + + slRA2P=MOD(ANGLE,A2PI) + IF (slRA2P.LT.0.0) slRA2P=slRA2P+A2PI + + END diff --git a/math/slalib/rcc.f b/math/slalib/rcc.f new file mode 100644 index 00000000..a07a6d82 --- /dev/null +++ b/math/slalib/rcc.f @@ -0,0 +1,1110 @@ + DOUBLE PRECISION FUNCTION slRCC (TDB, UT1, WL, U, V) +*+ +* - - - - +* R C C +* - - - - +* +* Relativistic clock correction: the difference between proper time at +* a point on the surface of the Earth and coordinate time in the Solar +* System barycentric space-time frame of reference. +* +* The proper time is terrestrial time, TT; the coordinate time is an +* implementation of barycentric dynamical time, TDB. +* +* Given: +* TDB d TDB (MJD: JD-2400000.5) +* UT1 d universal time (fraction of one day) +* WL d clock longitude (radians west) +* U d clock distance from Earth spin axis (km) +* V d clock distance north of Earth equatorial plane (km) +* +* Returned: +* The clock correction, TDB-TT, in seconds: +* +* . TDB is coordinate time in the solar system barycentre frame +* of reference, in units chosen to eliminate the scale difference +* with respect to terrestrial time. +* +* . TT is the proper time for clocks at mean sea level on the +* Earth. +* +* Notes: +* +* 1 The argument TDB is, strictly, the barycentric coordinate time; +* however, the terrestrial time TT can in practice be used without +* any significant loss of accuracy. +* +* 2 The result returned by slRCC comprises a main (annual) +* sinusoidal term of amplitude approximately 0.00166 seconds, plus +* planetary and lunar terms up to about 20 microseconds, and diurnal +* terms up to 2 microseconds. The variation arises from the +* transverse Doppler effect and the gravitational red-shift as the +* observer varies in speed and moves through different gravitational +* potentials. +* +* 3 The geocentric model is that of Fairhead & Bretagnon (1990), in +* its full form. It was supplied by Fairhead (private +* communication) as a FORTRAN subroutine. The original Fairhead +* routine used explicit formulae, in such large numbers that +* problems were experienced with certain compilers (Microsoft +* Fortran on PC aborted with stack overflow, Convex compiled +* successfully but extremely slowly). The present implementation is +* a complete recoding, with the original Fairhead coefficients held +* in a table. To optimise arithmetic precision, the terms are +* accumulated in reverse order, smallest first. A number of other +* coding changes were made, in order to match the calling sequence +* of previous versions of the present routine, and to comply with +* Starlink programming standards. The numerical results compared +* with those from the Fairhead form are essentially unaffected by +* the changes, the differences being at the 10^-20 sec level. +* +* 4 The topocentric part of the model is from Moyer (1981) and +* Murray (1983). It is an approximation to the expression +* ( v / c ) . ( r / c ), where v is the barycentric velocity of +* the Earth, r is the geocentric position of the observer and +* c is the speed of light. +* +* 5 During the interval 1950-2050, the absolute accuracy of is better +* than +/- 3 nanoseconds relative to direct numerical integrations +* using the JPL DE200/LE200 solar system ephemeris. +* +* 6 The IAU definition of TDB was that it must differ from TT only by +* periodic terms. Though practical, this is an imprecise definition +* which ignores the existence of very long-period and secular +* effects in the dynamics of the solar system. As a consequence, +* different implementations of TDB will, in general, differ in zero- +* point and will drift linearly relative to one other. +* +* 7 TDB was, in principle, superseded by new coordinate timescales +* which the IAU introduced in 1991: geocentric coordinate time, +* TCG, and barycentric coordinate time, TCB. However, slRCC +* can be used to implement the periodic part of TCB-TCG. +* +* References: +* +* 1 Fairhead, L., & Bretagnon, P., Astron.Astrophys., 229, 240-247 +* (1990). +* +* 2 Moyer, T.D., Cel.Mech., 23, 33 (1981). +* +* 3 Murray, C.A., Vectorial Astrometry, Adam Hilger (1983). +* +* 4 Seidelmann, P.K. et al, Explanatory Supplement to the +* Astronomical Almanac, Chapter 2, University Science Books +* (1992). +* +* 5 Simon J.L., Bretagnon P., Chapront J., Chapront-Touze M., +* Francou G. & Laskar J., Astron.Astrophys., 282, 663-683 (1994). +* +* P.T.Wallace Starlink 7 May 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION TDB,UT1,WL,U,V + + DOUBLE PRECISION D2PI,D2R + PARAMETER (D2PI=6.283185307179586476925287D0, + : D2R=0.0174532925199432957692369D0) + + DOUBLE PRECISION T,TSOL,W,ELSUN,EMSUN,D,ELJ,ELS, + : WT,W0,W1,W2,W3,W4,WF,WJ + +* ----------------------------------------------------------------------- +* +* Fairhead and Bretagnon canonical coefficients +* +* 787 sets of three coefficients. +* +* Each set is amplitude (microseconds) +* frequency (radians per Julian millennium since J2000), +* phase (radians). +* +* Sets 1-474 are the T**0 terms, +* " 475-679 " " T**1 " +* " 680-764 " " T**2 " +* " 765-784 " " T**3 " +* " 785-787 " " T**4 " . +* + DOUBLE PRECISION FAIRHD(3,787) + INTEGER I,J + DATA ((FAIRHD(I,J),I=1,3),J= 1, 10) / + : 1656.674564D-6, 6283.075849991D0, 6.240054195D0, + : 22.417471D-6, 5753.384884897D0, 4.296977442D0, + : 13.839792D-6, 12566.151699983D0, 6.196904410D0, + : 4.770086D-6, 529.690965095D0, 0.444401603D0, + : 4.676740D-6, 6069.776754553D0, 4.021195093D0, + : 2.256707D-6, 213.299095438D0, 5.543113262D0, + : 1.694205D-6, -3.523118349D0, 5.025132748D0, + : 1.554905D-6, 77713.771467920D0, 5.198467090D0, + : 1.276839D-6, 7860.419392439D0, 5.988822341D0, + : 1.193379D-6, 5223.693919802D0, 3.649823730D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 11, 20) / + : 1.115322D-6, 3930.209696220D0, 1.422745069D0, + : 0.794185D-6, 11506.769769794D0, 2.322313077D0, + : 0.447061D-6, 26.298319800D0, 3.615796498D0, + : 0.435206D-6, -398.149003408D0, 4.349338347D0, + : 0.600309D-6, 1577.343542448D0, 2.678271909D0, + : 0.496817D-6, 6208.294251424D0, 5.696701824D0, + : 0.486306D-6, 5884.926846583D0, 0.520007179D0, + : 0.432392D-6, 74.781598567D0, 2.435898309D0, + : 0.468597D-6, 6244.942814354D0, 5.866398759D0, + : 0.375510D-6, 5507.553238667D0, 4.103476804D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 21, 30) / + : 0.243085D-6, -775.522611324D0, 3.651837925D0, + : 0.173435D-6, 18849.227549974D0, 6.153743485D0, + : 0.230685D-6, 5856.477659115D0, 4.773852582D0, + : 0.203747D-6, 12036.460734888D0, 4.333987818D0, + : 0.143935D-6, -796.298006816D0, 5.957517795D0, + : 0.159080D-6, 10977.078804699D0, 1.890075226D0, + : 0.119979D-6, 38.133035638D0, 4.551585768D0, + : 0.118971D-6, 5486.777843175D0, 1.914547226D0, + : 0.116120D-6, 1059.381930189D0, 0.873504123D0, + : 0.137927D-6, 11790.629088659D0, 1.135934669D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 31, 40) / + : 0.098358D-6, 2544.314419883D0, 0.092793886D0, + : 0.101868D-6, -5573.142801634D0, 5.984503847D0, + : 0.080164D-6, 206.185548437D0, 2.095377709D0, + : 0.079645D-6, 4694.002954708D0, 2.949233637D0, + : 0.062617D-6, 20.775395492D0, 2.654394814D0, + : 0.075019D-6, 2942.463423292D0, 4.980931759D0, + : 0.064397D-6, 5746.271337896D0, 1.280308748D0, + : 0.063814D-6, 5760.498431898D0, 4.167901731D0, + : 0.048042D-6, 2146.165416475D0, 1.495846011D0, + : 0.048373D-6, 155.420399434D0, 2.251573730D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 41, 50) / + : 0.058844D-6, 426.598190876D0, 4.839650148D0, + : 0.046551D-6, -0.980321068D0, 0.921573539D0, + : 0.054139D-6, 17260.154654690D0, 3.411091093D0, + : 0.042411D-6, 6275.962302991D0, 2.869567043D0, + : 0.040184D-6, -7.113547001D0, 3.565975565D0, + : 0.036564D-6, 5088.628839767D0, 3.324679049D0, + : 0.040759D-6, 12352.852604545D0, 3.981496998D0, + : 0.036507D-6, 801.820931124D0, 6.248866009D0, + : 0.036955D-6, 3154.687084896D0, 5.071801441D0, + : 0.042732D-6, 632.783739313D0, 5.720622217D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 51, 60) / + : 0.042560D-6, 161000.685737473D0, 1.270837679D0, + : 0.040480D-6, 15720.838784878D0, 2.546610123D0, + : 0.028244D-6, -6286.598968340D0, 5.069663519D0, + : 0.033477D-6, 6062.663207553D0, 4.144987272D0, + : 0.034867D-6, 522.577418094D0, 5.210064075D0, + : 0.032438D-6, 6076.890301554D0, 0.749317412D0, + : 0.030215D-6, 7084.896781115D0, 3.389610345D0, + : 0.029247D-6, -71430.695617928D0, 4.183178762D0, + : 0.033529D-6, 9437.762934887D0, 2.404714239D0, + : 0.032423D-6, 8827.390269875D0, 5.541473556D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 61, 70) / + : 0.027567D-6, 6279.552731642D0, 5.040846034D0, + : 0.029862D-6, 12139.553509107D0, 1.770181024D0, + : 0.022509D-6, 10447.387839604D0, 1.460726241D0, + : 0.020937D-6, 8429.241266467D0, 0.652303414D0, + : 0.020322D-6, 419.484643875D0, 3.735430632D0, + : 0.024816D-6, -1194.447010225D0, 1.087136918D0, + : 0.025196D-6, 1748.016413067D0, 2.901883301D0, + : 0.021691D-6, 14143.495242431D0, 5.952658009D0, + : 0.017673D-6, 6812.766815086D0, 3.186129845D0, + : 0.022567D-6, 6133.512652857D0, 3.307984806D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 71, 80) / + : 0.016155D-6, 10213.285546211D0, 1.331103168D0, + : 0.014751D-6, 1349.867409659D0, 4.308933301D0, + : 0.015949D-6, -220.412642439D0, 4.005298270D0, + : 0.015974D-6, -2352.866153772D0, 6.145309371D0, + : 0.014223D-6, 17789.845619785D0, 2.104551349D0, + : 0.017806D-6, 73.297125859D0, 3.475975097D0, + : 0.013671D-6, -536.804512095D0, 5.971672571D0, + : 0.011942D-6, 8031.092263058D0, 2.053414715D0, + : 0.014318D-6, 16730.463689596D0, 3.016058075D0, + : 0.012462D-6, 103.092774219D0, 1.737438797D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 81, 90) / + : 0.010962D-6, 3.590428652D0, 2.196567739D0, + : 0.015078D-6, 19651.048481098D0, 3.969480770D0, + : 0.010396D-6, 951.718406251D0, 5.717799605D0, + : 0.011707D-6, -4705.732307544D0, 2.654125618D0, + : 0.010453D-6, 5863.591206116D0, 1.913704550D0, + : 0.012420D-6, 4690.479836359D0, 4.734090399D0, + : 0.011847D-6, 5643.178563677D0, 5.489005403D0, + : 0.008610D-6, 3340.612426700D0, 3.661698944D0, + : 0.011622D-6, 5120.601145584D0, 4.863931876D0, + : 0.010825D-6, 553.569402842D0, 0.842715011D0 / + DATA ((FAIRHD(I,J),I=1,3),J= 91,100) / + : 0.008666D-6, -135.065080035D0, 3.293406547D0, + : 0.009963D-6, 149.563197135D0, 4.870690598D0, + : 0.009858D-6, 6309.374169791D0, 1.061816410D0, + : 0.007959D-6, 316.391869657D0, 2.465042647D0, + : 0.010099D-6, 283.859318865D0, 1.942176992D0, + : 0.007147D-6, -242.728603974D0, 3.661486981D0, + : 0.007505D-6, 5230.807466803D0, 4.920937029D0, + : 0.008323D-6, 11769.853693166D0, 1.229392026D0, + : 0.007490D-6, -6256.777530192D0, 3.658444681D0, + : 0.009370D-6, 149854.400134205D0, 0.673880395D0 / + DATA ((FAIRHD(I,J),I=1,3),J=101,110) / + : 0.007117D-6, 38.027672636D0, 5.294249518D0, + : 0.007857D-6, 12168.002696575D0, 0.525733528D0, + : 0.007019D-6, 6206.809778716D0, 0.837688810D0, + : 0.006056D-6, 955.599741609D0, 4.194535082D0, + : 0.008107D-6, 13367.972631107D0, 3.793235253D0, + : 0.006731D-6, 5650.292110678D0, 5.639906583D0, + : 0.007332D-6, 36.648562930D0, 0.114858677D0, + : 0.006366D-6, 4164.311989613D0, 2.262081818D0, + : 0.006858D-6, 5216.580372801D0, 0.642063318D0, + : 0.006919D-6, 6681.224853400D0, 6.018501522D0 / + DATA ((FAIRHD(I,J),I=1,3),J=111,120) / + : 0.006826D-6, 7632.943259650D0, 3.458654112D0, + : 0.005308D-6, -1592.596013633D0, 2.500382359D0, + : 0.005096D-6, 11371.704689758D0, 2.547107806D0, + : 0.004841D-6, 5333.900241022D0, 0.437078094D0, + : 0.005582D-6, 5966.683980335D0, 2.246174308D0, + : 0.006304D-6, 11926.254413669D0, 2.512929171D0, + : 0.006603D-6, 23581.258177318D0, 5.393136889D0, + : 0.005123D-6, -1.484472708D0, 2.999641028D0, + : 0.004648D-6, 1589.072895284D0, 1.275847090D0, + : 0.005119D-6, 6438.496249426D0, 1.486539246D0 / + DATA ((FAIRHD(I,J),I=1,3),J=121,130) / + : 0.004521D-6, 4292.330832950D0, 6.140635794D0, + : 0.005680D-6, 23013.539539587D0, 4.557814849D0, + : 0.005488D-6, -3.455808046D0, 0.090675389D0, + : 0.004193D-6, 7234.794256242D0, 4.869091389D0, + : 0.003742D-6, 7238.675591600D0, 4.691976180D0, + : 0.004148D-6, -110.206321219D0, 3.016173439D0, + : 0.004553D-6, 11499.656222793D0, 5.554998314D0, + : 0.004892D-6, 5436.993015240D0, 1.475415597D0, + : 0.004044D-6, 4732.030627343D0, 1.398784824D0, + : 0.004164D-6, 12491.370101415D0, 5.650931916D0 / + DATA ((FAIRHD(I,J),I=1,3),J=131,140) / + : 0.004349D-6, 11513.883316794D0, 2.181745369D0, + : 0.003919D-6, 12528.018664345D0, 5.823319737D0, + : 0.003129D-6, 6836.645252834D0, 0.003844094D0, + : 0.004080D-6, -7058.598461315D0, 3.690360123D0, + : 0.003270D-6, 76.266071276D0, 1.517189902D0, + : 0.002954D-6, 6283.143160294D0, 4.447203799D0, + : 0.002872D-6, 28.449187468D0, 1.158692983D0, + : 0.002881D-6, 735.876513532D0, 0.349250250D0, + : 0.003279D-6, 5849.364112115D0, 4.893384368D0, + : 0.003625D-6, 6209.778724132D0, 1.473760578D0 / + DATA ((FAIRHD(I,J),I=1,3),J=141,150) / + : 0.003074D-6, 949.175608970D0, 5.185878737D0, + : 0.002775D-6, 9917.696874510D0, 1.030026325D0, + : 0.002646D-6, 10973.555686350D0, 3.918259169D0, + : 0.002575D-6, 25132.303399966D0, 6.109659023D0, + : 0.003500D-6, 263.083923373D0, 1.892100742D0, + : 0.002740D-6, 18319.536584880D0, 4.320519510D0, + : 0.002464D-6, 202.253395174D0, 4.698203059D0, + : 0.002409D-6, 2.542797281D0, 5.325009315D0, + : 0.003354D-6, -90955.551694697D0, 1.942656623D0, + : 0.002296D-6, 6496.374945429D0, 5.061810696D0 / + DATA ((FAIRHD(I,J),I=1,3),J=151,160) / + : 0.003002D-6, 6172.869528772D0, 2.797822767D0, + : 0.003202D-6, 27511.467873537D0, 0.531673101D0, + : 0.002954D-6, -6283.008539689D0, 4.533471191D0, + : 0.002353D-6, 639.897286314D0, 3.734548088D0, + : 0.002401D-6, 16200.772724501D0, 2.605547070D0, + : 0.003053D-6, 233141.314403759D0, 3.029030662D0, + : 0.003024D-6, 83286.914269554D0, 2.355556099D0, + : 0.002863D-6, 17298.182327326D0, 5.240963796D0, + : 0.002103D-6, -7079.373856808D0, 5.756641637D0, + : 0.002303D-6, 83996.847317911D0, 2.013686814D0 / + DATA ((FAIRHD(I,J),I=1,3),J=161,170) / + : 0.002303D-6, 18073.704938650D0, 1.089100410D0, + : 0.002381D-6, 63.735898303D0, 0.759188178D0, + : 0.002493D-6, 6386.168624210D0, 0.645026535D0, + : 0.002366D-6, 3.932153263D0, 6.215885448D0, + : 0.002169D-6, 11015.106477335D0, 4.845297676D0, + : 0.002397D-6, 6243.458341645D0, 3.809290043D0, + : 0.002183D-6, 1162.474704408D0, 6.179611691D0, + : 0.002353D-6, 6246.427287062D0, 4.781719760D0, + : 0.002199D-6, -245.831646229D0, 5.956152284D0, + : 0.001729D-6, 3894.181829542D0, 1.264976635D0 / + DATA ((FAIRHD(I,J),I=1,3),J=171,180) / + : 0.001896D-6, -3128.388765096D0, 4.914231596D0, + : 0.002085D-6, 35.164090221D0, 1.405158503D0, + : 0.002024D-6, 14712.317116458D0, 2.752035928D0, + : 0.001737D-6, 6290.189396992D0, 5.280820144D0, + : 0.002229D-6, 491.557929457D0, 1.571007057D0, + : 0.001602D-6, 14314.168113050D0, 4.203664806D0, + : 0.002186D-6, 454.909366527D0, 1.402101526D0, + : 0.001897D-6, 22483.848574493D0, 4.167932508D0, + : 0.001825D-6, -3738.761430108D0, 0.545828785D0, + : 0.001894D-6, 1052.268383188D0, 5.817167450D0 / + DATA ((FAIRHD(I,J),I=1,3),J=181,190) / + : 0.001421D-6, 20.355319399D0, 2.419886601D0, + : 0.001408D-6, 10984.192351700D0, 2.732084787D0, + : 0.001847D-6, 10873.986030480D0, 2.903477885D0, + : 0.001391D-6, -8635.942003763D0, 0.593891500D0, + : 0.001388D-6, -7.046236698D0, 1.166145902D0, + : 0.001810D-6, -88860.057071188D0, 0.487355242D0, + : 0.001288D-6, -1990.745017041D0, 3.913022880D0, + : 0.001297D-6, 23543.230504682D0, 3.063805171D0, + : 0.001335D-6, -266.607041722D0, 3.995764039D0, + : 0.001376D-6, 10969.965257698D0, 5.152914309D0 / + DATA ((FAIRHD(I,J),I=1,3),J=191,200) / + : 0.001745D-6, 244287.600007027D0, 3.626395673D0, + : 0.001649D-6, 31441.677569757D0, 1.952049260D0, + : 0.001416D-6, 9225.539273283D0, 4.996408389D0, + : 0.001238D-6, 4804.209275927D0, 5.503379738D0, + : 0.001472D-6, 4590.910180489D0, 4.164913291D0, + : 0.001169D-6, 6040.347246017D0, 5.841719038D0, + : 0.001039D-6, 5540.085789459D0, 2.769753519D0, + : 0.001004D-6, -170.672870619D0, 0.755008103D0, + : 0.001284D-6, 10575.406682942D0, 5.306538209D0, + : 0.001278D-6, 71.812653151D0, 4.713486491D0 / + DATA ((FAIRHD(I,J),I=1,3),J=201,210) / + : 0.001321D-6, 18209.330263660D0, 2.624866359D0, + : 0.001297D-6, 21228.392023546D0, 0.382603541D0, + : 0.000954D-6, 6282.095528923D0, 0.882213514D0, + : 0.001145D-6, 6058.731054289D0, 1.169483931D0, + : 0.000979D-6, 5547.199336460D0, 5.448375984D0, + : 0.000987D-6, -6262.300454499D0, 2.656486959D0, + : 0.001070D-6, -154717.609887482D0, 1.827624012D0, + : 0.000991D-6, 4701.116501708D0, 4.387001801D0, + : 0.001155D-6, -14.227094002D0, 3.042700750D0, + : 0.001176D-6, 277.034993741D0, 3.335519004D0 / + DATA ((FAIRHD(I,J),I=1,3),J=211,220) / + : 0.000890D-6, 13916.019109642D0, 5.601498297D0, + : 0.000884D-6, -1551.045222648D0, 1.088831705D0, + : 0.000876D-6, 5017.508371365D0, 3.969902609D0, + : 0.000806D-6, 15110.466119866D0, 5.142876744D0, + : 0.000773D-6, -4136.910433516D0, 0.022067765D0, + : 0.001077D-6, 175.166059800D0, 1.844913056D0, + : 0.000954D-6, -6284.056171060D0, 0.968480906D0, + : 0.000737D-6, 5326.786694021D0, 4.923831588D0, + : 0.000845D-6, -433.711737877D0, 4.749245231D0, + : 0.000819D-6, 8662.240323563D0, 5.991247817D0 / + DATA ((FAIRHD(I,J),I=1,3),J=221,230) / + : 0.000852D-6, 199.072001436D0, 2.189604979D0, + : 0.000723D-6, 17256.631536341D0, 6.068719637D0, + : 0.000940D-6, 6037.244203762D0, 6.197428148D0, + : 0.000885D-6, 11712.955318231D0, 3.280414875D0, + : 0.000706D-6, 12559.038152982D0, 2.824848947D0, + : 0.000732D-6, 2379.164473572D0, 2.501813417D0, + : 0.000764D-6, -6127.655450557D0, 2.236346329D0, + : 0.000908D-6, 131.541961686D0, 2.521257490D0, + : 0.000907D-6, 35371.887265976D0, 3.370195967D0, + : 0.000673D-6, 1066.495477190D0, 3.876512374D0 / + DATA ((FAIRHD(I,J),I=1,3),J=231,240) / + : 0.000814D-6, 17654.780539750D0, 4.627122566D0, + : 0.000630D-6, 36.027866677D0, 0.156368499D0, + : 0.000798D-6, 515.463871093D0, 5.151962502D0, + : 0.000798D-6, 148.078724426D0, 5.909225055D0, + : 0.000806D-6, 309.278322656D0, 6.054064447D0, + : 0.000607D-6, -39.617508346D0, 2.839021623D0, + : 0.000601D-6, 412.371096874D0, 3.984225404D0, + : 0.000646D-6, 11403.676995575D0, 3.852959484D0, + : 0.000704D-6, 13521.751441591D0, 2.300991267D0, + : 0.000603D-6, -65147.619767937D0, 4.140083146D0 / + DATA ((FAIRHD(I,J),I=1,3),J=241,250) / + : 0.000609D-6, 10177.257679534D0, 0.437122327D0, + : 0.000631D-6, 5767.611978898D0, 4.026532329D0, + : 0.000576D-6, 11087.285125918D0, 4.760293101D0, + : 0.000674D-6, 14945.316173554D0, 6.270510511D0, + : 0.000726D-6, 5429.879468239D0, 6.039606892D0, + : 0.000710D-6, 28766.924424484D0, 5.672617711D0, + : 0.000647D-6, 11856.218651625D0, 3.397132627D0, + : 0.000678D-6, -5481.254918868D0, 6.249666675D0, + : 0.000618D-6, 22003.914634870D0, 2.466427018D0, + : 0.000738D-6, 6134.997125565D0, 2.242668890D0 / + DATA ((FAIRHD(I,J),I=1,3),J=251,260) / + : 0.000660D-6, 625.670192312D0, 5.864091907D0, + : 0.000694D-6, 3496.032826134D0, 2.668309141D0, + : 0.000531D-6, 6489.261398429D0, 1.681888780D0, + : 0.000611D-6, -143571.324284214D0, 2.424978312D0, + : 0.000575D-6, 12043.574281889D0, 4.216492400D0, + : 0.000553D-6, 12416.588502848D0, 4.772158039D0, + : 0.000689D-6, 4686.889407707D0, 6.224271088D0, + : 0.000495D-6, 7342.457780181D0, 3.817285811D0, + : 0.000567D-6, 3634.621024518D0, 1.649264690D0, + : 0.000515D-6, 18635.928454536D0, 3.945345892D0 / + DATA ((FAIRHD(I,J),I=1,3),J=261,270) / + : 0.000486D-6, -323.505416657D0, 4.061673868D0, + : 0.000662D-6, 25158.601719765D0, 1.794058369D0, + : 0.000509D-6, 846.082834751D0, 3.053874588D0, + : 0.000472D-6, -12569.674818332D0, 5.112133338D0, + : 0.000461D-6, 6179.983075773D0, 0.513669325D0, + : 0.000641D-6, 83467.156352816D0, 3.210727723D0, + : 0.000520D-6, 10344.295065386D0, 2.445597761D0, + : 0.000493D-6, 18422.629359098D0, 1.676939306D0, + : 0.000478D-6, 1265.567478626D0, 5.487314569D0, + : 0.000472D-6, -18.159247265D0, 1.999707589D0 / + DATA ((FAIRHD(I,J),I=1,3),J=271,280) / + : 0.000559D-6, 11190.377900137D0, 5.783236356D0, + : 0.000494D-6, 9623.688276691D0, 3.022645053D0, + : 0.000463D-6, 5739.157790895D0, 1.411223013D0, + : 0.000432D-6, 16858.482532933D0, 1.179256434D0, + : 0.000574D-6, 72140.628666286D0, 1.758191830D0, + : 0.000484D-6, 17267.268201691D0, 3.290589143D0, + : 0.000550D-6, 4907.302050146D0, 0.864024298D0, + : 0.000399D-6, 14.977853527D0, 2.094441910D0, + : 0.000491D-6, 224.344795702D0, 0.878372791D0, + : 0.000432D-6, 20426.571092422D0, 6.003829241D0 / + DATA ((FAIRHD(I,J),I=1,3),J=281,290) / + : 0.000481D-6, 5749.452731634D0, 4.309591964D0, + : 0.000480D-6, 5757.317038160D0, 1.142348571D0, + : 0.000485D-6, 6702.560493867D0, 0.210580917D0, + : 0.000426D-6, 6055.549660552D0, 4.274476529D0, + : 0.000480D-6, 5959.570433334D0, 5.031351030D0, + : 0.000466D-6, 12562.628581634D0, 4.959581597D0, + : 0.000520D-6, 39302.096962196D0, 4.788002889D0, + : 0.000458D-6, 12132.439962106D0, 1.880103788D0, + : 0.000470D-6, 12029.347187887D0, 1.405611197D0, + : 0.000416D-6, -7477.522860216D0, 1.082356330D0 / + DATA ((FAIRHD(I,J),I=1,3),J=291,300) / + : 0.000449D-6, 11609.862544012D0, 4.179989585D0, + : 0.000465D-6, 17253.041107690D0, 0.353496295D0, + : 0.000362D-6, -4535.059436924D0, 1.583849576D0, + : 0.000383D-6, 21954.157609398D0, 3.747376371D0, + : 0.000389D-6, 17.252277143D0, 1.395753179D0, + : 0.000331D-6, 18052.929543158D0, 0.566790582D0, + : 0.000430D-6, 13517.870106233D0, 0.685827538D0, + : 0.000368D-6, -5756.908003246D0, 0.731374317D0, + : 0.000330D-6, 10557.594160824D0, 3.710043680D0, + : 0.000332D-6, 20199.094959633D0, 1.652901407D0 / + DATA ((FAIRHD(I,J),I=1,3),J=301,310) / + : 0.000384D-6, 11933.367960670D0, 5.827781531D0, + : 0.000387D-6, 10454.501386605D0, 2.541182564D0, + : 0.000325D-6, 15671.081759407D0, 2.178850542D0, + : 0.000318D-6, 138.517496871D0, 2.253253037D0, + : 0.000305D-6, 9388.005909415D0, 0.578340206D0, + : 0.000352D-6, 5749.861766548D0, 3.000297967D0, + : 0.000311D-6, 6915.859589305D0, 1.693574249D0, + : 0.000297D-6, 24072.921469776D0, 1.997249392D0, + : 0.000363D-6, -640.877607382D0, 5.071820966D0, + : 0.000323D-6, 12592.450019783D0, 1.072262823D0 / + DATA ((FAIRHD(I,J),I=1,3),J=311,320) / + : 0.000341D-6, 12146.667056108D0, 4.700657997D0, + : 0.000290D-6, 9779.108676125D0, 1.812320441D0, + : 0.000342D-6, 6132.028180148D0, 4.322238614D0, + : 0.000329D-6, 6268.848755990D0, 3.033827743D0, + : 0.000374D-6, 17996.031168222D0, 3.388716544D0, + : 0.000285D-6, -533.214083444D0, 4.687313233D0, + : 0.000338D-6, 6065.844601290D0, 0.877776108D0, + : 0.000276D-6, 24.298513841D0, 0.770299429D0, + : 0.000336D-6, -2388.894020449D0, 5.353796034D0, + : 0.000290D-6, 3097.883822726D0, 4.075291557D0 / + DATA ((FAIRHD(I,J),I=1,3),J=321,330) / + : 0.000318D-6, 709.933048357D0, 5.941207518D0, + : 0.000271D-6, 13095.842665077D0, 3.208912203D0, + : 0.000331D-6, 6073.708907816D0, 4.007881169D0, + : 0.000292D-6, 742.990060533D0, 2.714333592D0, + : 0.000362D-6, 29088.811415985D0, 3.215977013D0, + : 0.000280D-6, 12359.966151546D0, 0.710872502D0, + : 0.000267D-6, 10440.274292604D0, 4.730108488D0, + : 0.000262D-6, 838.969287750D0, 1.327720272D0, + : 0.000250D-6, 16496.361396202D0, 0.898769761D0, + : 0.000325D-6, 20597.243963041D0, 0.180044365D0 / + DATA ((FAIRHD(I,J),I=1,3),J=331,340) / + : 0.000268D-6, 6148.010769956D0, 5.152666276D0, + : 0.000284D-6, 5636.065016677D0, 5.655385808D0, + : 0.000301D-6, 6080.822454817D0, 2.135396205D0, + : 0.000294D-6, -377.373607916D0, 3.708784168D0, + : 0.000236D-6, 2118.763860378D0, 1.733578756D0, + : 0.000234D-6, 5867.523359379D0, 5.575209112D0, + : 0.000268D-6, -226858.238553767D0, 0.069432392D0, + : 0.000265D-6, 167283.761587465D0, 4.369302826D0, + : 0.000280D-6, 28237.233459389D0, 5.304829118D0, + : 0.000292D-6, 12345.739057544D0, 4.096094132D0 / + DATA ((FAIRHD(I,J),I=1,3),J=341,350) / + : 0.000223D-6, 19800.945956225D0, 3.069327406D0, + : 0.000301D-6, 43232.306658416D0, 6.205311188D0, + : 0.000264D-6, 18875.525869774D0, 1.417263408D0, + : 0.000304D-6, -1823.175188677D0, 3.409035232D0, + : 0.000301D-6, 109.945688789D0, 0.510922054D0, + : 0.000260D-6, 813.550283960D0, 2.389438934D0, + : 0.000299D-6, 316428.228673312D0, 5.384595078D0, + : 0.000211D-6, 5756.566278634D0, 3.789392838D0, + : 0.000209D-6, 5750.203491159D0, 1.661943545D0, + : 0.000240D-6, 12489.885628707D0, 5.684549045D0 / + DATA ((FAIRHD(I,J),I=1,3),J=351,360) / + : 0.000216D-6, 6303.851245484D0, 3.862942261D0, + : 0.000203D-6, 1581.959348283D0, 5.549853589D0, + : 0.000200D-6, 5642.198242609D0, 1.016115785D0, + : 0.000197D-6, -70.849445304D0, 4.690702525D0, + : 0.000227D-6, 6287.008003254D0, 2.911891613D0, + : 0.000197D-6, 533.623118358D0, 1.048982898D0, + : 0.000205D-6, -6279.485421340D0, 1.829362730D0, + : 0.000209D-6, -10988.808157535D0, 2.636140084D0, + : 0.000208D-6, -227.526189440D0, 4.127883842D0, + : 0.000191D-6, 415.552490612D0, 4.401165650D0 / + DATA ((FAIRHD(I,J),I=1,3),J=361,370) / + : 0.000190D-6, 29296.615389579D0, 4.175658539D0, + : 0.000264D-6, 66567.485864652D0, 4.601102551D0, + : 0.000256D-6, -3646.350377354D0, 0.506364778D0, + : 0.000188D-6, 13119.721102825D0, 2.032195842D0, + : 0.000185D-6, -209.366942175D0, 4.694756586D0, + : 0.000198D-6, 25934.124331089D0, 3.832703118D0, + : 0.000195D-6, 4061.219215394D0, 3.308463427D0, + : 0.000234D-6, 5113.487598583D0, 1.716090661D0, + : 0.000188D-6, 1478.866574064D0, 5.686865780D0, + : 0.000222D-6, 11823.161639450D0, 1.942386641D0 / + DATA ((FAIRHD(I,J),I=1,3),J=371,380) / + : 0.000181D-6, 10770.893256262D0, 1.999482059D0, + : 0.000171D-6, 6546.159773364D0, 1.182807992D0, + : 0.000206D-6, 70.328180442D0, 5.934076062D0, + : 0.000169D-6, 20995.392966449D0, 2.169080622D0, + : 0.000191D-6, 10660.686935042D0, 5.405515999D0, + : 0.000228D-6, 33019.021112205D0, 4.656985514D0, + : 0.000184D-6, -4933.208440333D0, 3.327476868D0, + : 0.000220D-6, -135.625325010D0, 1.765430262D0, + : 0.000166D-6, 23141.558382925D0, 3.454132746D0, + : 0.000191D-6, 6144.558353121D0, 5.020393445D0 / + DATA ((FAIRHD(I,J),I=1,3),J=381,390) / + : 0.000180D-6, 6084.003848555D0, 0.602182191D0, + : 0.000163D-6, 17782.732072784D0, 4.960593133D0, + : 0.000225D-6, 16460.333529525D0, 2.596451817D0, + : 0.000222D-6, 5905.702242076D0, 3.731990323D0, + : 0.000204D-6, 227.476132789D0, 5.636192701D0, + : 0.000159D-6, 16737.577236597D0, 3.600691544D0, + : 0.000200D-6, 6805.653268085D0, 0.868220961D0, + : 0.000187D-6, 11919.140866668D0, 2.629456641D0, + : 0.000161D-6, 127.471796607D0, 2.862574720D0, + : 0.000205D-6, 6286.666278643D0, 1.742882331D0 / + DATA ((FAIRHD(I,J),I=1,3),J=391,400) / + : 0.000189D-6, 153.778810485D0, 4.812372643D0, + : 0.000168D-6, 16723.350142595D0, 0.027860588D0, + : 0.000149D-6, 11720.068865232D0, 0.659721876D0, + : 0.000189D-6, 5237.921013804D0, 5.245313000D0, + : 0.000143D-6, 6709.674040867D0, 4.317625647D0, + : 0.000146D-6, 4487.817406270D0, 4.815297007D0, + : 0.000144D-6, -664.756045130D0, 5.381366880D0, + : 0.000175D-6, 5127.714692584D0, 4.728443327D0, + : 0.000162D-6, 6254.626662524D0, 1.435132069D0, + : 0.000187D-6, 47162.516354635D0, 1.354371923D0 / + DATA ((FAIRHD(I,J),I=1,3),J=401,410) / + : 0.000146D-6, 11080.171578918D0, 3.369695406D0, + : 0.000180D-6, -348.924420448D0, 2.490902145D0, + : 0.000148D-6, 151.047669843D0, 3.799109588D0, + : 0.000157D-6, 6197.248551160D0, 1.284375887D0, + : 0.000167D-6, 146.594251718D0, 0.759969109D0, + : 0.000133D-6, -5331.357443741D0, 5.409701889D0, + : 0.000154D-6, 95.979227218D0, 3.366890614D0, + : 0.000148D-6, -6418.140930027D0, 3.384104996D0, + : 0.000128D-6, -6525.804453965D0, 3.803419985D0, + : 0.000130D-6, 11293.470674356D0, 0.939039445D0 / + DATA ((FAIRHD(I,J),I=1,3),J=411,420) / + : 0.000152D-6, -5729.506447149D0, 0.734117523D0, + : 0.000138D-6, 210.117701700D0, 2.564216078D0, + : 0.000123D-6, 6066.595360816D0, 4.517099537D0, + : 0.000140D-6, 18451.078546566D0, 0.642049130D0, + : 0.000126D-6, 11300.584221356D0, 3.485280663D0, + : 0.000119D-6, 10027.903195729D0, 3.217431161D0, + : 0.000151D-6, 4274.518310832D0, 4.404359108D0, + : 0.000117D-6, 6072.958148291D0, 0.366324650D0, + : 0.000165D-6, -7668.637425143D0, 4.298212528D0, + : 0.000117D-6, -6245.048177356D0, 5.379518958D0 / + DATA ((FAIRHD(I,J),I=1,3),J=421,430) / + : 0.000130D-6, -5888.449964932D0, 4.527681115D0, + : 0.000121D-6, -543.918059096D0, 6.109429504D0, + : 0.000162D-6, 9683.594581116D0, 5.720092446D0, + : 0.000141D-6, 6219.339951688D0, 0.679068671D0, + : 0.000118D-6, 22743.409379516D0, 4.881123092D0, + : 0.000129D-6, 1692.165669502D0, 0.351407289D0, + : 0.000126D-6, 5657.405657679D0, 5.146592349D0, + : 0.000114D-6, 728.762966531D0, 0.520791814D0, + : 0.000120D-6, 52.596639600D0, 0.948516300D0, + : 0.000115D-6, 65.220371012D0, 3.504914846D0 / + DATA ((FAIRHD(I,J),I=1,3),J=431,440) / + : 0.000126D-6, 5881.403728234D0, 5.577502482D0, + : 0.000158D-6, 163096.180360983D0, 2.957128968D0, + : 0.000134D-6, 12341.806904281D0, 2.598576764D0, + : 0.000151D-6, 16627.370915377D0, 3.985702050D0, + : 0.000109D-6, 1368.660252845D0, 0.014730471D0, + : 0.000131D-6, 6211.263196841D0, 0.085077024D0, + : 0.000146D-6, 5792.741760812D0, 0.708426604D0, + : 0.000146D-6, -77.750543984D0, 3.121576600D0, + : 0.000107D-6, 5341.013788022D0, 0.288231904D0, + : 0.000138D-6, 6281.591377283D0, 2.797450317D0 / + DATA ((FAIRHD(I,J),I=1,3),J=441,450) / + : 0.000113D-6, -6277.552925684D0, 2.788904128D0, + : 0.000115D-6, -525.758811831D0, 5.895222200D0, + : 0.000138D-6, 6016.468808270D0, 6.096188999D0, + : 0.000139D-6, 23539.707386333D0, 2.028195445D0, + : 0.000146D-6, -4176.041342449D0, 4.660008502D0, + : 0.000107D-6, 16062.184526117D0, 4.066520001D0, + : 0.000142D-6, 83783.548222473D0, 2.936315115D0, + : 0.000128D-6, 9380.959672717D0, 3.223844306D0, + : 0.000135D-6, 6205.325306007D0, 1.638054048D0, + : 0.000101D-6, 2699.734819318D0, 5.481603249D0 / + DATA ((FAIRHD(I,J),I=1,3),J=451,460) / + : 0.000104D-6, -568.821874027D0, 2.205734493D0, + : 0.000103D-6, 6321.103522627D0, 2.440421099D0, + : 0.000119D-6, 6321.208885629D0, 2.547496264D0, + : 0.000138D-6, 1975.492545856D0, 2.314608466D0, + : 0.000121D-6, 137.033024162D0, 4.539108237D0, + : 0.000123D-6, 19402.796952817D0, 4.538074405D0, + : 0.000119D-6, 22805.735565994D0, 2.869040566D0, + : 0.000133D-6, 64471.991241142D0, 6.056405489D0, + : 0.000129D-6, -85.827298831D0, 2.540635083D0, + : 0.000131D-6, 13613.804277336D0, 4.005732868D0 / + DATA ((FAIRHD(I,J),I=1,3),J=461,470) / + : 0.000104D-6, 9814.604100291D0, 1.959967212D0, + : 0.000112D-6, 16097.679950283D0, 3.589026260D0, + : 0.000123D-6, 2107.034507542D0, 1.728627253D0, + : 0.000121D-6, 36949.230808424D0, 6.072332087D0, + : 0.000108D-6, -12539.853380183D0, 3.716133846D0, + : 0.000113D-6, -7875.671863624D0, 2.725771122D0, + : 0.000109D-6, 4171.425536614D0, 4.033338079D0, + : 0.000101D-6, 6247.911759770D0, 3.441347021D0, + : 0.000113D-6, 7330.728427345D0, 0.656372122D0, + : 0.000113D-6, 51092.726050855D0, 2.791483066D0 / + DATA ((FAIRHD(I,J),I=1,3),J=471,480) / + : 0.000106D-6, 5621.842923210D0, 1.815323326D0, + : 0.000101D-6, 111.430161497D0, 5.711033677D0, + : 0.000103D-6, 909.818733055D0, 2.812745443D0, + : 0.000101D-6, 1790.642637886D0, 1.965746028D0, + +* T + : 102.156724D-6, 6283.075849991D0, 4.249032005D0, + : 1.706807D-6, 12566.151699983D0, 4.205904248D0, + : 0.269668D-6, 213.299095438D0, 3.400290479D0, + : 0.265919D-6, 529.690965095D0, 5.836047367D0, + : 0.210568D-6, -3.523118349D0, 6.262738348D0, + : 0.077996D-6, 5223.693919802D0, 4.670344204D0 / + DATA ((FAIRHD(I,J),I=1,3),J=481,490) / + : 0.054764D-6, 1577.343542448D0, 4.534800170D0, + : 0.059146D-6, 26.298319800D0, 1.083044735D0, + : 0.034420D-6, -398.149003408D0, 5.980077351D0, + : 0.032088D-6, 18849.227549974D0, 4.162913471D0, + : 0.033595D-6, 5507.553238667D0, 5.980162321D0, + : 0.029198D-6, 5856.477659115D0, 0.623811863D0, + : 0.027764D-6, 155.420399434D0, 3.745318113D0, + : 0.025190D-6, 5746.271337896D0, 2.980330535D0, + : 0.022997D-6, -796.298006816D0, 1.174411803D0, + : 0.024976D-6, 5760.498431898D0, 2.467913690D0 / + DATA ((FAIRHD(I,J),I=1,3),J=491,500) / + : 0.021774D-6, 206.185548437D0, 3.854787540D0, + : 0.017925D-6, -775.522611324D0, 1.092065955D0, + : 0.013794D-6, 426.598190876D0, 2.699831988D0, + : 0.013276D-6, 6062.663207553D0, 5.845801920D0, + : 0.011774D-6, 12036.460734888D0, 2.292832062D0, + : 0.012869D-6, 6076.890301554D0, 5.333425680D0, + : 0.012152D-6, 1059.381930189D0, 6.222874454D0, + : 0.011081D-6, -7.113547001D0, 5.154724984D0, + : 0.010143D-6, 4694.002954708D0, 4.044013795D0, + : 0.009357D-6, 5486.777843175D0, 3.416081409D0 / + DATA ((FAIRHD(I,J),I=1,3),J=501,510) / + : 0.010084D-6, 522.577418094D0, 0.749320262D0, + : 0.008587D-6, 10977.078804699D0, 2.777152598D0, + : 0.008628D-6, 6275.962302991D0, 4.562060226D0, + : 0.008158D-6, -220.412642439D0, 5.806891533D0, + : 0.007746D-6, 2544.314419883D0, 1.603197066D0, + : 0.007670D-6, 2146.165416475D0, 3.000200440D0, + : 0.007098D-6, 74.781598567D0, 0.443725817D0, + : 0.006180D-6, -536.804512095D0, 1.302642751D0, + : 0.005818D-6, 5088.628839767D0, 4.827723531D0, + : 0.004945D-6, -6286.598968340D0, 0.268305170D0 / + DATA ((FAIRHD(I,J),I=1,3),J=511,520) / + : 0.004774D-6, 1349.867409659D0, 5.808636673D0, + : 0.004687D-6, -242.728603974D0, 5.154890570D0, + : 0.006089D-6, 1748.016413067D0, 4.403765209D0, + : 0.005975D-6, -1194.447010225D0, 2.583472591D0, + : 0.004229D-6, 951.718406251D0, 0.931172179D0, + : 0.005264D-6, 553.569402842D0, 2.336107252D0, + : 0.003049D-6, 5643.178563677D0, 1.362634430D0, + : 0.002974D-6, 6812.766815086D0, 1.583012668D0, + : 0.003403D-6, -2352.866153772D0, 2.552189886D0, + : 0.003030D-6, 419.484643875D0, 5.286473844D0 / + DATA ((FAIRHD(I,J),I=1,3),J=521,530) / + : 0.003210D-6, -7.046236698D0, 1.863796539D0, + : 0.003058D-6, 9437.762934887D0, 4.226420633D0, + : 0.002589D-6, 12352.852604545D0, 1.991935820D0, + : 0.002927D-6, 5216.580372801D0, 2.319951253D0, + : 0.002425D-6, 5230.807466803D0, 3.084752833D0, + : 0.002656D-6, 3154.687084896D0, 2.487447866D0, + : 0.002445D-6, 10447.387839604D0, 2.347139160D0, + : 0.002990D-6, 4690.479836359D0, 6.235872050D0, + : 0.002890D-6, 5863.591206116D0, 0.095197563D0, + : 0.002498D-6, 6438.496249426D0, 2.994779800D0 / + DATA ((FAIRHD(I,J),I=1,3),J=531,540) / + : 0.001889D-6, 8031.092263058D0, 3.569003717D0, + : 0.002567D-6, 801.820931124D0, 3.425611498D0, + : 0.001803D-6, -71430.695617928D0, 2.192295512D0, + : 0.001782D-6, 3.932153263D0, 5.180433689D0, + : 0.001694D-6, -4705.732307544D0, 4.641779174D0, + : 0.001704D-6, -1592.596013633D0, 3.997097652D0, + : 0.001735D-6, 5849.364112115D0, 0.417558428D0, + : 0.001643D-6, 8429.241266467D0, 2.180619584D0, + : 0.001680D-6, 38.133035638D0, 4.164529426D0, + : 0.002045D-6, 7084.896781115D0, 0.526323854D0 / + DATA ((FAIRHD(I,J),I=1,3),J=541,550) / + : 0.001458D-6, 4292.330832950D0, 1.356098141D0, + : 0.001437D-6, 20.355319399D0, 3.895439360D0, + : 0.001738D-6, 6279.552731642D0, 0.087484036D0, + : 0.001367D-6, 14143.495242431D0, 3.987576591D0, + : 0.001344D-6, 7234.794256242D0, 0.090454338D0, + : 0.001438D-6, 11499.656222793D0, 0.974387904D0, + : 0.001257D-6, 6836.645252834D0, 1.509069366D0, + : 0.001358D-6, 11513.883316794D0, 0.495572260D0, + : 0.001628D-6, 7632.943259650D0, 4.968445721D0, + : 0.001169D-6, 103.092774219D0, 2.838496795D0 / + DATA ((FAIRHD(I,J),I=1,3),J=551,560) / + : 0.001162D-6, 4164.311989613D0, 3.408387778D0, + : 0.001092D-6, 6069.776754553D0, 3.617942651D0, + : 0.001008D-6, 17789.845619785D0, 0.286350174D0, + : 0.001008D-6, 639.897286314D0, 1.610762073D0, + : 0.000918D-6, 10213.285546211D0, 5.532798067D0, + : 0.001011D-6, -6256.777530192D0, 0.661826484D0, + : 0.000753D-6, 16730.463689596D0, 3.905030235D0, + : 0.000737D-6, 11926.254413669D0, 4.641956361D0, + : 0.000694D-6, 3340.612426700D0, 2.111120332D0, + : 0.000701D-6, 3894.181829542D0, 2.760823491D0 / + DATA ((FAIRHD(I,J),I=1,3),J=561,570) / + : 0.000689D-6, -135.065080035D0, 4.768800780D0, + : 0.000700D-6, 13367.972631107D0, 5.760439898D0, + : 0.000664D-6, 6040.347246017D0, 1.051215840D0, + : 0.000654D-6, 5650.292110678D0, 4.911332503D0, + : 0.000788D-6, 6681.224853400D0, 4.699648011D0, + : 0.000628D-6, 5333.900241022D0, 5.024608847D0, + : 0.000755D-6, -110.206321219D0, 4.370971253D0, + : 0.000628D-6, 6290.189396992D0, 3.660478857D0, + : 0.000635D-6, 25132.303399966D0, 4.121051532D0, + : 0.000534D-6, 5966.683980335D0, 1.173284524D0 / + DATA ((FAIRHD(I,J),I=1,3),J=571,580) / + : 0.000543D-6, -433.711737877D0, 0.345585464D0, + : 0.000517D-6, -1990.745017041D0, 5.414571768D0, + : 0.000504D-6, 5767.611978898D0, 2.328281115D0, + : 0.000485D-6, 5753.384884897D0, 1.685874771D0, + : 0.000463D-6, 7860.419392439D0, 5.297703006D0, + : 0.000604D-6, 515.463871093D0, 0.591998446D0, + : 0.000443D-6, 12168.002696575D0, 4.830881244D0, + : 0.000570D-6, 199.072001436D0, 3.899190272D0, + : 0.000465D-6, 10969.965257698D0, 0.476681802D0, + : 0.000424D-6, -7079.373856808D0, 1.112242763D0 / + DATA ((FAIRHD(I,J),I=1,3),J=581,590) / + : 0.000427D-6, 735.876513532D0, 1.994214480D0, + : 0.000478D-6, -6127.655450557D0, 3.778025483D0, + : 0.000414D-6, 10973.555686350D0, 5.441088327D0, + : 0.000512D-6, 1589.072895284D0, 0.107123853D0, + : 0.000378D-6, 10984.192351700D0, 0.915087231D0, + : 0.000402D-6, 11371.704689758D0, 4.107281715D0, + : 0.000453D-6, 9917.696874510D0, 1.917490952D0, + : 0.000395D-6, 149.563197135D0, 2.763124165D0, + : 0.000371D-6, 5739.157790895D0, 3.112111866D0, + : 0.000350D-6, 11790.629088659D0, 0.440639857D0 / + DATA ((FAIRHD(I,J),I=1,3),J=591,600) / + : 0.000356D-6, 6133.512652857D0, 5.444568842D0, + : 0.000344D-6, 412.371096874D0, 5.676832684D0, + : 0.000383D-6, 955.599741609D0, 5.559734846D0, + : 0.000333D-6, 6496.374945429D0, 0.261537984D0, + : 0.000340D-6, 6055.549660552D0, 5.975534987D0, + : 0.000334D-6, 1066.495477190D0, 2.335063907D0, + : 0.000399D-6, 11506.769769794D0, 5.321230910D0, + : 0.000314D-6, 18319.536584880D0, 2.313312404D0, + : 0.000424D-6, 1052.268383188D0, 1.211961766D0, + : 0.000307D-6, 63.735898303D0, 3.169551388D0 / + DATA ((FAIRHD(I,J),I=1,3),J=601,610) / + : 0.000329D-6, 29.821438149D0, 6.106912080D0, + : 0.000357D-6, 6309.374169791D0, 4.223760346D0, + : 0.000312D-6, -3738.761430108D0, 2.180556645D0, + : 0.000301D-6, 309.278322656D0, 1.499984572D0, + : 0.000268D-6, 12043.574281889D0, 2.447520648D0, + : 0.000257D-6, 12491.370101415D0, 3.662331761D0, + : 0.000290D-6, 625.670192312D0, 1.272834584D0, + : 0.000256D-6, 5429.879468239D0, 1.913426912D0, + : 0.000339D-6, 3496.032826134D0, 4.165930011D0, + : 0.000283D-6, 3930.209696220D0, 4.325565754D0 / + DATA ((FAIRHD(I,J),I=1,3),J=611,620) / + : 0.000241D-6, 12528.018664345D0, 3.832324536D0, + : 0.000304D-6, 4686.889407707D0, 1.612348468D0, + : 0.000259D-6, 16200.772724501D0, 3.470173146D0, + : 0.000238D-6, 12139.553509107D0, 1.147977842D0, + : 0.000236D-6, 6172.869528772D0, 3.776271728D0, + : 0.000296D-6, -7058.598461315D0, 0.460368852D0, + : 0.000306D-6, 10575.406682942D0, 0.554749016D0, + : 0.000251D-6, 17298.182327326D0, 0.834332510D0, + : 0.000290D-6, 4732.030627343D0, 4.759564091D0, + : 0.000261D-6, 5884.926846583D0, 0.298259862D0 / + DATA ((FAIRHD(I,J),I=1,3),J=621,630) / + : 0.000249D-6, 5547.199336460D0, 3.749366406D0, + : 0.000213D-6, 11712.955318231D0, 5.415666119D0, + : 0.000223D-6, 4701.116501708D0, 2.703203558D0, + : 0.000268D-6, -640.877607382D0, 0.283670793D0, + : 0.000209D-6, 5636.065016677D0, 1.238477199D0, + : 0.000193D-6, 10177.257679534D0, 1.943251340D0, + : 0.000182D-6, 6283.143160294D0, 2.456157599D0, + : 0.000184D-6, -227.526189440D0, 5.888038582D0, + : 0.000182D-6, -6283.008539689D0, 0.241332086D0, + : 0.000228D-6, -6284.056171060D0, 2.657323816D0 / + DATA ((FAIRHD(I,J),I=1,3),J=631,640) / + : 0.000166D-6, 7238.675591600D0, 5.930629110D0, + : 0.000167D-6, 3097.883822726D0, 5.570955333D0, + : 0.000159D-6, -323.505416657D0, 5.786670700D0, + : 0.000154D-6, -4136.910433516D0, 1.517805532D0, + : 0.000176D-6, 12029.347187887D0, 3.139266834D0, + : 0.000167D-6, 12132.439962106D0, 3.556352289D0, + : 0.000153D-6, 202.253395174D0, 1.463313961D0, + : 0.000157D-6, 17267.268201691D0, 1.586837396D0, + : 0.000142D-6, 83996.847317911D0, 0.022670115D0, + : 0.000152D-6, 17260.154654690D0, 0.708528947D0 / + DATA ((FAIRHD(I,J),I=1,3),J=641,650) / + : 0.000144D-6, 6084.003848555D0, 5.187075177D0, + : 0.000135D-6, 5756.566278634D0, 1.993229262D0, + : 0.000134D-6, 5750.203491159D0, 3.457197134D0, + : 0.000144D-6, 5326.786694021D0, 6.066193291D0, + : 0.000160D-6, 11015.106477335D0, 1.710431974D0, + : 0.000133D-6, 3634.621024518D0, 2.836451652D0, + : 0.000134D-6, 18073.704938650D0, 5.453106665D0, + : 0.000134D-6, 1162.474704408D0, 5.326898811D0, + : 0.000128D-6, 5642.198242609D0, 2.511652591D0, + : 0.000160D-6, 632.783739313D0, 5.628785365D0 / + DATA ((FAIRHD(I,J),I=1,3),J=651,660) / + : 0.000132D-6, 13916.019109642D0, 0.819294053D0, + : 0.000122D-6, 14314.168113050D0, 5.677408071D0, + : 0.000125D-6, 12359.966151546D0, 5.251984735D0, + : 0.000121D-6, 5749.452731634D0, 2.210924603D0, + : 0.000136D-6, -245.831646229D0, 1.646502367D0, + : 0.000120D-6, 5757.317038160D0, 3.240883049D0, + : 0.000134D-6, 12146.667056108D0, 3.059480037D0, + : 0.000137D-6, 6206.809778716D0, 1.867105418D0, + : 0.000141D-6, 17253.041107690D0, 2.069217456D0, + : 0.000129D-6, -7477.522860216D0, 2.781469314D0 / + DATA ((FAIRHD(I,J),I=1,3),J=661,670) / + : 0.000116D-6, 5540.085789459D0, 4.281176991D0, + : 0.000116D-6, 9779.108676125D0, 3.320925381D0, + : 0.000129D-6, 5237.921013804D0, 3.497704076D0, + : 0.000113D-6, 5959.570433334D0, 0.983210840D0, + : 0.000122D-6, 6282.095528923D0, 2.674938860D0, + : 0.000140D-6, -11.045700264D0, 4.957936982D0, + : 0.000108D-6, 23543.230504682D0, 1.390113589D0, + : 0.000106D-6, -12569.674818332D0, 0.429631317D0, + : 0.000110D-6, -266.607041722D0, 5.501340197D0, + : 0.000115D-6, 12559.038152982D0, 4.691456618D0 / + DATA ((FAIRHD(I,J),I=1,3),J=671,680) / + : 0.000134D-6, -2388.894020449D0, 0.577313584D0, + : 0.000109D-6, 10440.274292604D0, 6.218148717D0, + : 0.000102D-6, -543.918059096D0, 1.477842615D0, + : 0.000108D-6, 21228.392023546D0, 2.237753948D0, + : 0.000101D-6, -4535.059436924D0, 3.100492232D0, + : 0.000103D-6, 76.266071276D0, 5.594294322D0, + : 0.000104D-6, 949.175608970D0, 5.674287810D0, + : 0.000101D-6, 13517.870106233D0, 2.196632348D0, + : 0.000100D-6, 11933.367960670D0, 4.056084160D0, + : 4.322990D-6, 6283.075849991D0, 2.642893748D0 / + DATA ((FAIRHD(I,J),I=1,3),J=681,690) / + : 0.406495D-6, 0.000000000D0, 4.712388980D0, + : 0.122605D-6, 12566.151699983D0, 2.438140634D0, + : 0.019476D-6, 213.299095438D0, 1.642186981D0, + : 0.016916D-6, 529.690965095D0, 4.510959344D0, + : 0.013374D-6, -3.523118349D0, 1.502210314D0, + : 0.008042D-6, 26.298319800D0, 0.478549024D0, + : 0.007824D-6, 155.420399434D0, 5.254710405D0, + : 0.004894D-6, 5746.271337896D0, 4.683210850D0, + : 0.004875D-6, 5760.498431898D0, 0.759507698D0, + : 0.004416D-6, 5223.693919802D0, 6.028853166D0 / + DATA ((FAIRHD(I,J),I=1,3),J=691,700) / + : 0.004088D-6, -7.113547001D0, 0.060926389D0, + : 0.004433D-6, 77713.771467920D0, 3.627734103D0, + : 0.003277D-6, 18849.227549974D0, 2.327912542D0, + : 0.002703D-6, 6062.663207553D0, 1.271941729D0, + : 0.003435D-6, -775.522611324D0, 0.747446224D0, + : 0.002618D-6, 6076.890301554D0, 3.633715689D0, + : 0.003146D-6, 206.185548437D0, 5.647874613D0, + : 0.002544D-6, 1577.343542448D0, 6.232904270D0, + : 0.002218D-6, -220.412642439D0, 1.309509946D0, + : 0.002197D-6, 5856.477659115D0, 2.407212349D0 / + DATA ((FAIRHD(I,J),I=1,3),J=701,710) / + : 0.002897D-6, 5753.384884897D0, 5.863842246D0, + : 0.001766D-6, 426.598190876D0, 0.754113147D0, + : 0.001738D-6, -796.298006816D0, 2.714942671D0, + : 0.001695D-6, 522.577418094D0, 2.629369842D0, + : 0.001584D-6, 5507.553238667D0, 1.341138229D0, + : 0.001503D-6, -242.728603974D0, 0.377699736D0, + : 0.001552D-6, -536.804512095D0, 2.904684667D0, + : 0.001370D-6, -398.149003408D0, 1.265599125D0, + : 0.001889D-6, -5573.142801634D0, 4.413514859D0, + : 0.001722D-6, 6069.776754553D0, 2.445966339D0 / + DATA ((FAIRHD(I,J),I=1,3),J=711,720) / + : 0.001124D-6, 1059.381930189D0, 5.041799657D0, + : 0.001258D-6, 553.569402842D0, 3.849557278D0, + : 0.000831D-6, 951.718406251D0, 2.471094709D0, + : 0.000767D-6, 4694.002954708D0, 5.363125422D0, + : 0.000756D-6, 1349.867409659D0, 1.046195744D0, + : 0.000775D-6, -11.045700264D0, 0.245548001D0, + : 0.000597D-6, 2146.165416475D0, 4.543268798D0, + : 0.000568D-6, 5216.580372801D0, 4.178853144D0, + : 0.000711D-6, 1748.016413067D0, 5.934271972D0, + : 0.000499D-6, 12036.460734888D0, 0.624434410D0 / + DATA ((FAIRHD(I,J),I=1,3),J=721,730) / + : 0.000671D-6, -1194.447010225D0, 4.136047594D0, + : 0.000488D-6, 5849.364112115D0, 2.209679987D0, + : 0.000621D-6, 6438.496249426D0, 4.518860804D0, + : 0.000495D-6, -6286.598968340D0, 1.868201275D0, + : 0.000456D-6, 5230.807466803D0, 1.271231591D0, + : 0.000451D-6, 5088.628839767D0, 0.084060889D0, + : 0.000435D-6, 5643.178563677D0, 3.324456609D0, + : 0.000387D-6, 10977.078804699D0, 4.052488477D0, + : 0.000547D-6, 161000.685737473D0, 2.841633844D0, + : 0.000522D-6, 3154.687084896D0, 2.171979966D0 / + DATA ((FAIRHD(I,J),I=1,3),J=731,740) / + : 0.000375D-6, 5486.777843175D0, 4.983027306D0, + : 0.000421D-6, 5863.591206116D0, 4.546432249D0, + : 0.000439D-6, 7084.896781115D0, 0.522967921D0, + : 0.000309D-6, 2544.314419883D0, 3.172606705D0, + : 0.000347D-6, 4690.479836359D0, 1.479586566D0, + : 0.000317D-6, 801.820931124D0, 3.553088096D0, + : 0.000262D-6, 419.484643875D0, 0.606635550D0, + : 0.000248D-6, 6836.645252834D0, 3.014082064D0, + : 0.000245D-6, -1592.596013633D0, 5.519526220D0, + : 0.000225D-6, 4292.330832950D0, 2.877956536D0 / + DATA ((FAIRHD(I,J),I=1,3),J=741,750) / + : 0.000214D-6, 7234.794256242D0, 1.605227587D0, + : 0.000205D-6, 5767.611978898D0, 0.625804796D0, + : 0.000180D-6, 10447.387839604D0, 3.499954526D0, + : 0.000229D-6, 199.072001436D0, 5.632304604D0, + : 0.000214D-6, 639.897286314D0, 5.960227667D0, + : 0.000175D-6, -433.711737877D0, 2.162417992D0, + : 0.000209D-6, 515.463871093D0, 2.322150893D0, + : 0.000173D-6, 6040.347246017D0, 2.556183691D0, + : 0.000184D-6, 6309.374169791D0, 4.732296790D0, + : 0.000227D-6, 149854.400134205D0, 5.385812217D0 / + DATA ((FAIRHD(I,J),I=1,3),J=751,760) / + : 0.000154D-6, 8031.092263058D0, 5.120720920D0, + : 0.000151D-6, 5739.157790895D0, 4.815000443D0, + : 0.000197D-6, 7632.943259650D0, 0.222827271D0, + : 0.000197D-6, 74.781598567D0, 3.910456770D0, + : 0.000138D-6, 6055.549660552D0, 1.397484253D0, + : 0.000149D-6, -6127.655450557D0, 5.333727496D0, + : 0.000137D-6, 3894.181829542D0, 4.281749907D0, + : 0.000135D-6, 9437.762934887D0, 5.979971885D0, + : 0.000139D-6, -2352.866153772D0, 4.715630782D0, + : 0.000142D-6, 6812.766815086D0, 0.513330157D0 / + DATA ((FAIRHD(I,J),I=1,3),J=761,770) / + : 0.000120D-6, -4705.732307544D0, 0.194160689D0, + : 0.000131D-6, -71430.695617928D0, 0.000379226D0, + : 0.000124D-6, 6279.552731642D0, 2.122264908D0, + : 0.000108D-6, -6256.777530192D0, 0.883445696D0, + : 0.143388D-6, 6283.075849991D0, 1.131453581D0, + : 0.006671D-6, 12566.151699983D0, 0.775148887D0, + : 0.001480D-6, 155.420399434D0, 0.480016880D0, + : 0.000934D-6, 213.299095438D0, 6.144453084D0, + : 0.000795D-6, 529.690965095D0, 2.941595619D0, + : 0.000673D-6, 5746.271337896D0, 0.120415406D0 / + DATA ((FAIRHD(I,J),I=1,3),J=771,780) / + : 0.000672D-6, 5760.498431898D0, 5.317009738D0, + : 0.000389D-6, -220.412642439D0, 3.090323467D0, + : 0.000373D-6, 6062.663207553D0, 3.003551964D0, + : 0.000360D-6, 6076.890301554D0, 1.918913041D0, + : 0.000316D-6, -21.340641002D0, 5.545798121D0, + : 0.000315D-6, -242.728603974D0, 1.884932563D0, + : 0.000278D-6, 206.185548437D0, 1.266254859D0, + : 0.000238D-6, -536.804512095D0, 4.532664830D0, + : 0.000185D-6, 522.577418094D0, 4.578313856D0, + : 0.000245D-6, 18849.227549974D0, 0.587467082D0 / + DATA ((FAIRHD(I,J),I=1,3),J=781,787) / + : 0.000180D-6, 426.598190876D0, 5.151178553D0, + : 0.000200D-6, 553.569402842D0, 5.355983739D0, + : 0.000141D-6, 5223.693919802D0, 1.336556009D0, + : 0.000104D-6, 5856.477659115D0, 4.239842759D0, + : 0.003826D-6, 6283.075849991D0, 5.705257275D0, + : 0.000303D-6, 12566.151699983D0, 5.407132842D0, + : 0.000209D-6, 155.420399434D0, 1.989815753D0 / +* ----------------------------------------------------------------------- + + + +* Time since J2000.0 in Julian millennia. + T=(TDB-51544.5D0)/365250D0 + +* -------------------- Topocentric terms ------------------------------- + +* Convert UT1 to local solar time in radians. + TSOL = MOD(UT1,1D0)*D2PI - WL + +* FUNDAMENTAL ARGUMENTS: Simon et al 1994 + +* Combine time argument (millennia) with deg/arcsec factor. + W = T / 3600D0 + +* Sun Mean Longitude. + ELSUN = MOD(280.46645683D0+1296027711.03429D0*W,360D0)*D2R + +* Sun Mean Anomaly. + EMSUN = MOD(357.52910918D0+1295965810.481D0*W,360D0)*D2R + +* Mean Elongation of Moon from Sun. + D = MOD(297.85019547D0+16029616012.090D0*W,360D0)*D2R + +* Mean Longitude of Jupiter. + ELJ = MOD(34.35151874D0+109306899.89453D0*W,360D0)*D2R + +* Mean Longitude of Saturn. + ELS = MOD(50.07744430D0+44046398.47038D0*W,360D0)*D2R + +* TOPOCENTRIC TERMS: Moyer 1981 and Murray 1983. + WT = +0.00029D-10*U*SIN(TSOL+ELSUN-ELS) + : +0.00100D-10*U*SIN(TSOL-2D0*EMSUN) + : +0.00133D-10*U*SIN(TSOL-D) + : +0.00133D-10*U*SIN(TSOL+ELSUN-ELJ) + : -0.00229D-10*U*SIN(TSOL+2D0*ELSUN+EMSUN) + : -0.0220 D-10*V*COS(ELSUN+EMSUN) + : +0.05312D-10*U*SIN(TSOL-EMSUN) + : -0.13677D-10*U*SIN(TSOL+2D0*ELSUN) + : -1.3184 D-10*V*COS(ELSUN) + : +3.17679D-10*U*SIN(TSOL) + +* --------------- Fairhead model --------------------------------------- + +* T**0 + W0=0D0 + DO I=474,1,-1 + W0=W0+FAIRHD(1,I)*SIN(FAIRHD(2,I)*T+FAIRHD(3,I)) + END DO + +* T**1 + W1=0D0 + DO I=679,475,-1 + W1=W1+FAIRHD(1,I)*SIN(FAIRHD(2,I)*T+FAIRHD(3,I)) + END DO + +* T**2 + W2=0D0 + DO I=764,680,-1 + W2=W2+FAIRHD(1,I)*SIN(FAIRHD(2,I)*T+FAIRHD(3,I)) + END DO + +* T**3 + W3=0D0 + DO I=784,765,-1 + W3=W3+FAIRHD(1,I)*SIN(FAIRHD(2,I)*T+FAIRHD(3,I)) + END DO + +* T**4 + W4=0D0 + DO I=787,785,-1 + W4=W4+FAIRHD(1,I)*SIN(FAIRHD(2,I)*T+FAIRHD(3,I)) + END DO + +* Multiply by powers of T and combine. + WF=T*(T*(T*(T*W4+W3)+W2)+W1)+W0 + +* Adjustments to use JPL planetary masses instead of IAU. + WJ= 0.00065D-6 * SIN( 6069.776754D0 *T + 4.021194D0 ) + + : 0.00033D-6 * SIN( 213.299095D0 *T + 5.543132D0 ) + + : (-0.00196D-6 * SIN( 6208.294251D0 *T + 5.696701D0 ))+ + : (-0.00173D-6 * SIN( 74.781599D0 *T + 2.435900D0 ))+ + : 0.03638D-6*T*T + +* ----------------------------------------------------------------------- + +* Final result: TDB-TT in seconds. + slRCC=WT+WF+WJ + + END diff --git a/math/slalib/rdplan.f b/math/slalib/rdplan.f new file mode 100644 index 00000000..95ba3ef8 --- /dev/null +++ b/math/slalib/rdplan.f @@ -0,0 +1,201 @@ + SUBROUTINE slRDPL (DATE, NP, ELONG, PHI, RA, DEC, DIAM) +*+ +* - - - - - - - +* R D P L +* - - - - - - - +* +* Approximate topocentric apparent RA,Dec of a planet, and its +* angular diameter. +* +* Given: +* DATE d MJD of observation (JD - 2400000.5) +* NP i planet: 1 = Mercury +* 2 = Venus +* 3 = Moon +* 4 = Mars +* 5 = Jupiter +* 6 = Saturn +* 7 = Uranus +* 8 = Neptune +* 9 = Pluto +* else = Sun +* ELONG,PHI d observer's east longitude and geodetic +* latitude (radians) +* +* Returned: +* RA,DEC d RA, Dec (topocentric apparent, radians) +* DIAM d angular diameter (equatorial, radians) +* +* Notes: +* +* 1 The date is in a dynamical timescale (TDB, formerly ET) and is +* in the form of a Modified Julian Date (JD-2400000.5). For all +* practical purposes, TT can be used instead of TDB, and for many +* applications UT will do (except for the Moon). +* +* 2 The longitude and latitude allow correction for geocentric +* parallax. This is a major effect for the Moon, but in the +* context of the limited accuracy of the present routine its +* effect on planetary positions is small (negligible for the +* outer planets). Geocentric positions can be generated by +* appropriate use of the routines slDMON and slPLNT. +* +* 3 The direction accuracy (arcsec, 1000-3000AD) is of order: +* +* Sun 5 +* Mercury 2 +* Venus 10 +* Moon 30 +* Mars 50 +* Jupiter 90 +* Saturn 90 +* Uranus 90 +* Neptune 10 +* Pluto 1 (1885-2099AD only) +* +* The angular diameter accuracy is about 0.4% for the Moon, +* and 0.01% or better for the Sun and planets. +* +* See the slPLNT routine for references. +* +* Called: slGMST, slDT, slEPJ, slDMON, slPVOB, slPRNU, +* slPLNT, slDMXV, slDC2S, slDA2P +* +* P.T.Wallace Starlink 26 May 1997 +* +* Copyright (C) 1997 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE + INTEGER NP + DOUBLE PRECISION ELONG,PHI,RA,DEC,DIAM + +* AU in km + DOUBLE PRECISION AUKM + PARAMETER (AUKM=1.49597870D8) + +* Light time for unit distance (sec) + DOUBLE PRECISION TAU + PARAMETER (TAU=499.004782D0) + + INTEGER IP,J,I + DOUBLE PRECISION EQRAU(0:9),STL,VGM(6),V(6),RMAT(3,3), + : VSE(6),VSG(6),VSP(6),VGO(6),DX,DY,DZ,R,TL + DOUBLE PRECISION slGMST,slDT,slEPJ,slDA2P + +* Equatorial radii (km) + DATA EQRAU / 696000D0,2439.7D0,6051.9D0,1738D0,3397D0,71492D0, + : 60268D0,25559D0,24764D0,1151D0 / + + + +* Classify NP + IP=NP + IF (IP.LT.0.OR.IP.GT.9) IP=0 + +* Approximate local ST + STL=slGMST(DATE-slDT(slEPJ(DATE))/86400D0)+ELONG + +* Geocentre to Moon (mean of date) + CALL slDMON(DATE,V) + +* Nutation to true of date + CALL slNUT(DATE,RMAT) + CALL slDMXV(RMAT,V,VGM) + CALL slDMXV(RMAT,V(4),VGM(4)) + +* Moon? + IF (IP.EQ.3) THEN + +* Yes: geocentre to Moon (true of date) + DO I=1,6 + V(I)=VGM(I) + END DO + ELSE + +* No: precession/nutation matrix, J2000 to date + CALL slPRNU(2000D0,DATE,RMAT) + +* Sun to Earth-Moon Barycentre (J2000) + CALL slPLNT(DATE,3,V,J) + +* Precession and nutation to date + CALL slDMXV(RMAT,V,VSE) + CALL slDMXV(RMAT,V(4),VSE(4)) + +* Sun to geocentre (true of date) + DO I=1,6 + VSG(I)=VSE(I)-0.012150581D0*VGM(I) + END DO + +* Sun? + IF (IP.EQ.0) THEN + +* Yes: geocentre to Sun + DO I=1,6 + V(I)=-VSG(I) + END DO + ELSE + +* No: Sun to Planet (J2000) + CALL slPLNT(DATE,IP,V,J) + +* Precession and nutation to date + CALL slDMXV(RMAT,V,VSP) + CALL slDMXV(RMAT,V(4),VSP(4)) + +* Geocentre to planet + DO I=1,6 + V(I)=VSP(I)-VSG(I) + END DO + END IF + END IF + +* Refer to origin at the observer + CALL slPVOB(PHI,0D0,STL,VGO) + DO I=1,6 + V(I)=V(I)-VGO(I) + END DO + +* Geometric distance (AU) + DX=V(1) + DY=V(2) + DZ=V(3) + R=SQRT(DX*DX+DY*DY+DZ*DZ) + +* Light time (sec) + TL=TAU*R + +* Correct position for planetary aberration + DO I=1,3 + V(I)=V(I)-TL*V(I+3) + END DO + +* To RA,Dec + CALL slDC2S(V,RA,DEC) + RA=slDA2P(RA) + +* Angular diameter (radians) + DIAM=2D0*ASIN(EQRAU(IP)/(R*AUKM)) + + END diff --git a/math/slalib/read.me b/math/slalib/read.me new file mode 100644 index 00000000..0b216cb6 --- /dev/null +++ b/math/slalib/read.me @@ -0,0 +1,443 @@ +READ.ME + +Revision date 14 June 2005 SLALIB Version 2.5-2 + +----------------------------------------------------------------------- + +FILES IN THE ORIGINAL SOURCE DIRECTORY (UNIX) + + read.me this file + *.f Fortran source (separate modules) + *.vax Fortran source for VAX/VMS + *.cnvx Fortran source for Convex + *.mips Fortran source for DECstation + *.sun4 Fortran source for Sun SPARCstation + *.lnx Fortran source for Linux + *.pcm Microsoft Fortran source for PC + *.c C functions needed for Linux version + sla.news NEWS item for latest release + make_file Unix make file + mk C-shell script to run make + sun67.tex document + +----------------------------------------------------------------------- + + Copyright (C) 1995-2005 Rutherford Appleton Laboratory + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +----------------------------------------------------------------------- + +PORTING FORTRAN SLALIB TO OTHER SYSTEMS + +FORTRAN SLALIB runs on VAX (VMS), PC (Linux+f2c), PC (Microsoft FORTRAN), +Convex (ConvexOS), DECstation (Ultrix), DEC Alpha (OSF-1) and Sun +SPARCstation (SunOS and Solaris). + +For most platforms, the required changes are confined to these routines: + + sla_GRESID + sla_RANDOM + sla_WAIT + +VAX, CONVEX, DECSTATION/ALPHA, SUN & PC + +Versions suitable for the above platforms are supplied in the +development directory as *.vax, *,cnvx, *.mips, *.sun4, *.pcm and +*.lnx respectively. + + +----------------------------------------------------------------------- + +LATEST RELEASE INFORMATION + +The latest release of SLALIB includes the following changes (most recent +at the end): + +* In sla_RCC, the topocentric term of coefficient 1.3184D-10 sec + had the wrong sign. Minus is correct. + +* The IAU decided in 1991 to rename the Terrestrial Dynamical + Time, TDT, which is now called "Terrestrial Time" or TT. + Appropriate changes have been made in the SLALIB documentation. + The same IAU resolutions introduced the timescales TCG and TCB; + there are at present no SLALIB routines to handle these new + timescales. + +* The Keck 1 Telescope has been added to sla_OBS. + +* The handling of the random-number seed in the PC versions of + sla_RANDOM and sla_GRESID was flawed and has been improved. + +* The UTC leap second at the end of June 1993 has been added to the + routine sla_DAT. Existing applications which call sla_DAT or + sla_DTT require relinking. + +* Some unnecessary code in sla_AMPQK has been removed. + +* Minor reorganization of the sla_REFRO code has led to an improvement + in speed of about 20%, and precautions have been taken against + potential arithmetic errors. + +* There have been small revisions to sla_FK425 and sla_FK524. The + results are not significantly affected, except in the pathological + case of large proper motion combined with immense distance, where + sla_FK524 could produce erroneous radial velocity values. The + latest versions are close to the algorithms published in the 1992 + Explanatory Supplement to the Astronomical Almanac. + +* The leap second at the end of June 1994 has been added to sla_DAT. + +* THE SLA_RVLSR ROUTINE HAS BEEN RETIRED. Its place has been taken + by two new routines: sla_RVLSRK and sla_RVLSRD. The original + sla_RVLSR had used a "kinematical" LSR. When this was later changed + to a "dynamical" LSR for (what seemed liked good reasons at the time), + the small differences were noticed by spectral-line radio observers, + who had to fall back on old copies of the routine to remain consistent + with existing practice. The new routines provide both sorts of LSR: + sla_RVLSRK uses a kinematical LSR and sla_RVLSRD uses the dynamical LSR. + +* The sla_PA routine (computation of parallactic angle) used an + unnecessarily complicated formulation, which has been simplified. + The results are unaffected. + +* The sla_ZD routine (computation of zenith distance) used a + straightforward cosine-formula-based method, which suffered from + decreased accuracy near the zenith. A better, vector-derived, + formulation has been substituted, without materially affecting + the results. Because sla_ZD is double precision, the old + formulation was always adequate; however, had anyone transcribed + the code in single precision errors approaching 1 arcmin could + have resulted. The new formulation delivers good results all + over the sky even in a single precision version. + +* Routines have been added to transform equatorial coordinates + (HA,Dec) to horizon coordinates (Az,El) and back. Single and + double precision are both supported. The routines are called + sla_E2H, sla_DE2H, sla_H2E, sla_DH2E. + +* A new routine has been added to the tangent-plane projection set. + The single and double precision versions are called sla_TPRD and + sla_DTPRD respectively. Given the RA,Dec of a star and its + xi,eta coordinates, the routine determines the "plate centre". + +* The existing routine sla_PREC for obtaining the precession matrix + uses the official IAU model and should continue to be used for + canonical purposes. A new version, called sla_PRECL, uses a + more up-to-date model which delivers better accuracy, especially + over intervals of millennia. + +* The routine sla_PVOBS was returning velocities in AU per sidereal + second rather than per UT second. This has been corrected. The + maximum error was equivalent to about 0.001 km/s. + +* In sla_MAPQK and sla_MAPQKZ, the area within which the gravitional + light-deflection term is restrained has been extended from its + original 300 arcsec radius to about 920 arcsec, just inside the + Sun's disc. + +* A chapter of explanation, with examples, has been added to SUN/67, + which has also undergone various cosmetic revisions. + +* There were two discrepancies between the documentation of sla_DCMPF + (program comments and SUN/67) and the code. The first was that the + formulae for the nonperpendicularity used PERP instead of PERP/2; + the documentation has been corrected. The other was that the + documentation showed the zero point corrections being applied first, + whereas the code returned zero point corrections corresponding to + being applied last. The code has been corrected to match the + documentation. + +* The C module slaCldj gave incorrect answers for dates during + January and February. The error, which did not affect the Fortran + version, has been corrected. + +* THE CALLS FOR sla_TPRD AND sla_DTPRD HAS BEEN CHANGED. An integer + status argument has been added; non-zero means the supplied RA,Dec + and Xi,Eta describe an impossible case. (This can only happen + near the pole and with non-zero Xi.) Also, a slightly neater + formulation has been introduced. + +* Three new routines have been added. sla_ALTAZ takes a star's HA,Dec + and produces position, velocity and acceleration for azimuth, + elevation and parallactic angle. sla_PDA2H predicts the HA at which + a given azimuth will be reached. sla_PDQ2H does the same for + position angle. + +* In the sla_OBS routine, the wrong sign was returned for the Perkins + 72 inch telescope at Lowell - fixed. + +* A revised model for the equation of the equinoxes has been + installed in sla_EQEQX, in line with recent IAU resolutions. The + change amounts to less than 3 mas. + +* A bug in sla_DFLTIN has been corrected. A negative number following + an E- or D-format number without intervening spaces lost its sign. + +* Four stations have been added to sla_OBS: + + TAUTENBERG Tautenberg 1.34 metre Schmidt + PALOMAR48 Palomar 48-inch Schmidt + UKST UK 1.2 metre Schmidt, Siding Spring + KISO Kiso 1.05 metre Schmidt, Japan + ESOSCHMIDT ESO 1 metre Schmidt, La Silla + +* The sla_EARTH and sla_MOON routines could give an integer divide by zero + for years before 1 BC. This has been corrected. + +* sla_CALYD (provided to support the sla_EARTH and sla_MOON routines) + has been upgraded to work outside the interval 1900 March 1 to + 2100 February 28. The status value indicating dates outside that + range has been dropped; a new error value for year before -4711 + has been introduced. + +* A new routine, sla_CLYD, has been added. It is a version of sla_CALYD + without the century-default feature and is to enable 1st-century + dates to be supplied to sla_EARTH and sla_MOON. + +* Two new routines, sla_PLANET and sla_RDPLAN, have been added, which + compute approximate planetary ephemerides. + +* A new routine, sla_DMOON, implements the same (Meeus) model as the + sla_MOON routine, but in full and in double precision. The time + argument is a straightforward MJD rather than sla_MOON's year and + day-in-year. + +* The sla_REFRO code has been speeded up by a factor of two (and is + also clearer). + +* sla_REFV and sla_REFZ have, in different ways, been made more accurate + for cases close to the horizon. The improvement to sla_REFV is + relatively modest, but sla_REFZ is now capable of delivering useful + results for rise/set phenomena. + +* sla_AOPQK has been speeded up for low-elevation cases. + +* Versions of the tangent-plane routines working directly in x,y,z + instead of spherical coordinates have been added. They may be + faster in some applications. The routines are sla_DV2TP, sla_V2TP, + sla_DTP2V, sla_TP2V, sla_DTPXYZ, sla_TPXYZ. + +* The coordinates of the Australia Telescope Compact Array have been + added to sla_OBS. The name is 'ATCA'. + +* Despite their recent introduction THE ROUTINES sla_DTPRD, sla_DTPXYZ, + sla_TPRD AND sla_TPXYZ HAVE BEEN WITHDRAWN. They have been replaced + by the new routines sla_DTPS2C, sla_DTPV2C, sla_TPS2C and sla_TPV2C. + These are functionally equivalent to the earlier routines but return + two solutions instead of one: the second solution can arise near a + pole. + +* The UTC leap second at the end of 1995 has been added to sla_DAT. + +* The refraction routine sla_REFRO has been extensively revised. The + principal motivation was to improve the radio predictions by + introducing better humidity models. The models previously in + use had been entirely adequate for the optical case, for which + they had been devised, but improved models were required for + the radio case. None of the changes significantly affects the + optical results with respect to the earlier version of the sla_REFRO + routine. For example, at 70 deg zenith distance the new version + agrees with the old version to better than 0.05 arcsec for any + reasonable combination of parameters. However, the improved + water-vapour expressions do make a significant difference in the + radio band, at 70 deg zenith distance reaching almost 4 arcsec + for a hot, humid, low-altitude site during a period of low pressure. + +* There was a bug in slaRdplan, the (private) C version of sla_RDPLAN. + The answers were unaffected but there could be floating-point + problems on some platforms. + +* A new routine has been added, sla_GMSTA. This gives greater numerical + precision than the existing GMST function by allowing the date and + time to be specified separately rather than as a single MJD. + +* Measures taken in sla_MAPQK to avoid trouble when processing Solar + positions had not been carried through into sla_MAPQKZ. The two + routines now use the same strategy. + +* In sla_REFRO, at zenith distances well beyond 90 deg and under some + conditions, it was possible to encounter arithmetic errors due to + failure of the tropospheric model-atmosphere to deliver sensible + temperatures. This is inherent in the published algorithm. To + avoid the problem, the temperature delivered by the model has been + constrained to the range 200 to 320 deg K. + +* A new routine has been added, sla_ATMDSP, for rapidly recalculating + the A,B refraction coefficients for different wavelengths. + +* The first UTC leap-second date in the sla_DAT routine was one day early. + This will have had no effect on the results for more recent epochs. + +* slaObs, the C version of sla_OBS, had some problems related to character + string handling. A call using the "number" option retured an invalid + station ID, and station ID and name strings of the stipulated 10 + and 40 character lengths were improperly terminated. + +* A new routine, sla_POLMO has been added. This is a specialist tool + to do with Earth polar motion. + +* sla_DC62S and sla_CC62S could give floating point errors if vectors in + unlikely units were supplied. The handling of difficult cases has + been improved. + +* Support for Linux has been added. + +* slaRefreo, the C version of sla_REFRO, was not re-entrant. It is now; + there has been a small (4%) speed penalty. + +* The C routines slaRandom, slaGresid and slaWait have been dropped. + They could not easily be made re-entrant and posed perennial platform- + dependency problems. + +* The value for the arcsec to radians factor in several routines + had an incorrect (and superfluous) 19th digit, which has been + removed. + +* There was a minor bug in sla_DV2TP and sla_V2TP, to do with protection + against the special case where the tangent point is the pole. + +* In sla_OBS, the position of the Parkes radiotelescope has been revised, + and the ATNF Mopra observatory has been added. + +* Two new routines have been added. sla_PAV (single precision) and + sla_DPAV (double precision) are like sla_BEAR and sla_DBEAR but start + with direction cosines rather than spherical coordinates - they return + the position angle of one point with respect to the other. + +* slaRefro, the C version of sla_REFRO, still wasn't re-entrant, but is + now. + +* slaDtf2d, the C version of sla_DTF2D, used to accept 60.0 in the seconds + field; this has been corrected. + +* The sla_PLANET and sla_RDPLAN routines now include Pluto. The ephemeris + is accurate (sub-arcsecond) but covers the 20th and 21st centuries + only. + + !!! IMPORTANT NOTE !!! + + sla_RDPLAN used to interpret any planet number outside the range 1-8 + as meaning the Sun. The new version uses planet number 9. Existing + programs using 9 for the Sun should be changed to use 0. The rule + has not been changed, except that the range is now 1-9 instead of + 1-8, as it is unlikely that the equivalent problem will arise in the + future. + +* Two new routines have been added, sla_PLANEL and sla_PLANTE. They are + analogues of sla_PLANET and sla_RDPLAN but for the case where orbital + elements are available. They can be used for predicting the + positions of asteroids and comets, and, if up-to-date osculating + elements are supplied, more accurate positions for the major + planets than can be provided through the sla_PLANET and sla_RDPLAN + routines. + +* The sla_REFRO routine could give inaccurate results for low temperatures + (subzero C). This was caused by over-cautious defensive programming, + which prevented the tropospheric temperature falling below 200 K. + +* A new routine has been added, sla_REFCOQ. This calculates the coefficients + of a two-term refraction model. It complements the existing sla_REFCO + routine, being much faster at the expense of some accuracy. + +* The 1997 July 1 UTC leap second has been added to the sla_DAT routine. + +* A bug in slaSvd, the C version of sla_SVD, caused occasional false + indications of ill-conditioning. The results of least-squares + fits do not seem to have been affected. The Fortran version did not + have the bug. + +* The Subaru telescope (Japanese National 8-metre telescope, Mauna Kea) + has been added to the sla_OBS routine. + +* The sla_DAT routine has been extended back to the inception of UTC in + 1960. + +* The "earliest date possible" in DJCL sla_was two days out (disagreeing + with sla_DJCAL, which had the correct value). + +* The sla_GMSTA code has been improved. + +* A new routine, sla_PV2EL, takes a heliocentric J2000 equatorial position + and velocity and produces the equivalent set of osculating elements. + +* The 1999 January 1 UTC leap second has been added to the sla_DAT routine. + +* Four new routines have been introduced which transform between the + FK5 system and the ICRS (Hipparcos) system. sla_FK52H and sla_H2FK5 + transform star positions and proper motions from FK5 coordinates to + Hipparcos coordinates and vice versa. sla_FK5HZ and sla_HFK5Z do the + same but for the case where the Hipparcos proper motions are zero. + +* Six new routines have been introduced for dealing with orbital elements. + Four of them (sla_EL2UE, sla_PV2UE, sla_UE2EL and sla_UE2PV) provide + applications with direct access to the "universal variables" method + that was already being used internally. Compared with using conventional + (angular) elements and solving Kepler's equation, the universal variables + approach has a number of advantages, including better handling of near- + parabolic orbits and greater efficiency. The remaining two routines + (sla_PERTEL and sla_PERTUE) generate updated elements by applying + major-planet perturbations. The new elements can then be used to + predict positions that are much more accurate. For minor planets, + sub-arcsecond accuracy over a decade is achievable. + +* Several observatory sites have been added to the OBS routine: CFHT, + Keck 2, Gemini North, FCRAO, IRTF and CSO. The coordinates for all + the Mauna Kea sites have been updated in accordance with recent aerial + photography results made available by the Institute for Astronomy, + University of Hawaii. + +* A bug in sla_DAT has been corrected. It used to give incorrect + results for dates in the first 54 days of 1972. + +* There are new routines for generating permutations (sla_PERMUT) and + combinations (sla_COMBN). + +* There was a bug in sla_PM for star data using Julian epochs (i.e. all + modern data). The treatment of radial velocity was correct for + Besselian epochs but wrong for Julian epochs. This had only a tiny + effect on a handful of nearby stars. The new version assumes Julian + epochs when interpreting the radial velocity. If the data are old- + style, using Besselian epochs, you have to scale the radial velocity + by 365.2422/365.25 first. + +* There was a bug in sla_RCC which meant the diurnal terms were being + calculated incorrectly, leading to errors of up to about 4 microsec. + +* Two new routines have been added, sla_DSEPV and sla_SEPV. These are + analogues of the existing routines sla_DSEP and sla_SEP, but accept + [x,y,z] vectors instead of spherical coordinates. + +* The sla_UNPCD routine used to be approximate but now is rigorous. + +* The four VLTs and Gemini South have been added to sla_OBS. + +* An additional Earth position/velocity routine, sla_EPV, has been + added. It is bigger and slower than sla_EVP but much more accurate. + Position accuracy is a few km; velocity accuracy is a few mm/s. + The sla_PERTUE and sla_PLANTU routines now call this routine in + order to deliver better predictions for near-Earth objects. + +* There was a bug in sla_DSEPV. For the unique case of two precisely + antipodal vectors zero was returned instead of pi. + +----------------------------------------------------------------------- + + + P.T.Wallace + + ptw@star.rl.ac.uk + +44-1235-44-5372 diff --git a/math/slalib/refco.f b/math/slalib/refco.f new file mode 100644 index 00000000..f03a30fa --- /dev/null +++ b/math/slalib/refco.f @@ -0,0 +1,88 @@ + SUBROUTINE slRFCO ( HM, TDK, PMB, RH, WL, PHI, TLR, EPS, + : REFA, REFB ) +*+ +* - - - - - - +* R F C O +* - - - - - - +* +* Determine the constants A and B in the atmospheric refraction +* model dZ = A tan Z + B tan**3 Z. +* +* Z is the "observed" zenith distance (i.e. affected by refraction) +* and dZ is what to add to Z to give the "topocentric" (i.e. in vacuo) +* zenith distance. +* +* Given: +* HM d height of the observer above sea level (metre) +* TDK d ambient temperature at the observer (K) +* PMB d pressure at the observer (millibar) +* RH d relative humidity at the observer (range 0-1) +* WL d effective wavelength of the source (micrometre) +* PHI d latitude of the observer (radian, astronomical) +* TLR d temperature lapse rate in the troposphere (K/metre) +* EPS d precision required to terminate iteration (radian) +* +* Returned: +* REFA d tan Z coefficient (radian) +* REFB d tan**3 Z coefficient (radian) +* +* Called: slRFRO +* +* Notes: +* +* 1 Typical values for the TLR and EPS arguments might be 0.0065D0 and +* 1D-10 respectively. +* +* 2 The radio refraction is chosen by specifying WL > 100 micrometres. +* +* 3 The routine is a slower but more accurate alternative to the +* slRFCQ routine. The constants it produces give perfect +* agreement with slRFRO at zenith distances arctan(1) (45 deg) +* and arctan(4) (about 76 deg). It achieves 0.5 arcsec accuracy +* for ZD < 80 deg, 0.01 arcsec accuracy for ZD < 60 deg, and +* 0.001 arcsec accuracy for ZD < 45 deg. +* +* P.T.Wallace Starlink 22 May 2004 +* +* Copyright (C) 2004 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION HM,TDK,PMB,RH,WL,PHI,TLR,EPS,REFA,REFB + + DOUBLE PRECISION ATN1,ATN4,R1,R2 + +* Sample zenith distances: arctan(1) and arctan(4) + PARAMETER (ATN1=0.7853981633974483D0, + : ATN4=1.325817663668033D0) + + + +* Determine refraction for the two sample zenith distances + CALL slRFRO(ATN1,HM,TDK,PMB,RH,WL,PHI,TLR,EPS,R1) + CALL slRFRO(ATN4,HM,TDK,PMB,RH,WL,PHI,TLR,EPS,R2) + +* Solve for refraction constants + REFA = (64D0*R1-R2)/60D0 + REFB = (R2-4D0*R1)/60D0 + + END diff --git a/math/slalib/refcoq.f b/math/slalib/refcoq.f new file mode 100644 index 00000000..76e40341 --- /dev/null +++ b/math/slalib/refcoq.f @@ -0,0 +1,227 @@ + SUBROUTINE slRFCQ ( TDK, PMB, RH, WL, REFA, REFB ) +*+ +* - - - - - - - +* R F C Q +* - - - - - - - +* +* Determine the constants A and B in the atmospheric refraction +* model dZ = A tan Z + B tan**3 Z. This is a fast alternative +* to the slRFCO routine - see notes. +* +* Z is the "observed" zenith distance (i.e. affected by refraction) +* and dZ is what to add to Z to give the "topocentric" (i.e. in vacuo) +* zenith distance. +* +* Given: +* TDK d ambient temperature at the observer (K) +* PMB d pressure at the observer (millibar) +* RH d relative humidity at the observer (range 0-1) +* WL d effective wavelength of the source (micrometre) +* +* Returned: +* REFA d tan Z coefficient (radian) +* REFB d tan**3 Z coefficient (radian) +* +* The radio refraction is chosen by specifying WL > 100 micrometres. +* +* Notes: +* +* 1 The model is an approximation, for moderate zenith distances, +* to the predictions of the slRFRO routine. The approximation +* is maintained across a range of conditions, and applies to +* both optical/IR and radio. +* +* 2 The algorithm is a fast alternative to the slRFCO routine. +* The latter calls the slRFRO routine itself: this involves +* integrations through a model atmosphere, and is costly in +* processor time. However, the model which is produced is precisely +* correct for two zenith distance (45 degrees and about 76 degrees) +* and at other zenith distances is limited in accuracy only by the +* A tan Z + B tan**3 Z formulation itself. The present routine +* is not as accurate, though it satisfies most practical +* requirements. +* +* 3 The model omits the effects of (i) height above sea level (apart +* from the reduced pressure itself), (ii) latitude (i.e. the +* flattening of the Earth) and (iii) variations in tropospheric +* lapse rate. +* +* The model was tested using the following range of conditions: +* +* lapse rates 0.0055, 0.0065, 0.0075 K/metre +* latitudes 0, 25, 50, 75 degrees +* heights 0, 2500, 5000 metres ASL +* pressures mean for height -10% to +5% in steps of 5% +* temperatures -10 deg to +20 deg with respect to 280 deg at SL +* relative humidity 0, 0.5, 1 +* wavelengths 0.4, 0.6, ... 2 micron, + radio +* zenith distances 15, 45, 75 degrees +* +* The accuracy with respect to direct use of the slRFRO routine +* was as follows: +* +* worst RMS +* +* optical/IR 62 mas 8 mas +* radio 319 mas 49 mas +* +* For this particular set of conditions: +* +* lapse rate 0.0065 K/metre +* latitude 50 degrees +* sea level +* pressure 1005 mb +* temperature 280.15 K +* humidity 80% +* wavelength 5740 Angstroms +* +* the results were as follows: +* +* ZD slRFRO slRFCQ Saastamoinen +* +* 10 10.27 10.27 10.27 +* 20 21.19 21.20 21.19 +* 30 33.61 33.61 33.60 +* 40 48.82 48.83 48.81 +* 45 58.16 58.18 58.16 +* 50 69.28 69.30 69.27 +* 55 82.97 82.99 82.95 +* 60 100.51 100.54 100.50 +* 65 124.23 124.26 124.20 +* 70 158.63 158.68 158.61 +* 72 177.32 177.37 177.31 +* 74 200.35 200.38 200.32 +* 76 229.45 229.43 229.42 +* 78 267.44 267.29 267.41 +* 80 319.13 318.55 319.10 +* +* deg arcsec arcsec arcsec +* +* The values for Saastamoinen's formula (which includes terms +* up to tan^5) are taken from Hohenkerk and Sinclair (1985). +* +* The results from the much slower but more accurate slRFCO +* routine have not been included in the tabulation as they are +* identical to those in the slRFRO column to the 0.01 arcsec +* resolution used. +* +* 4 Outlandish input parameters are silently limited to mathematically +* safe values. Zero pressure is permissible, and causes zeroes to +* be returned. +* +* 5 The algorithm draws on several sources, as follows: +* +* a) The formula for the saturation vapour pressure of water as +* a function of temperature and temperature is taken from +* expressions A4.5-A4.7 of Gill (1982). +* +* b) The formula for the water vapour pressure, given the +* saturation pressure and the relative humidity, is from +* Crane (1976), expression 2.5.5. +* +* c) The refractivity of air is a function of temperature, +* total pressure, water-vapour pressure and, in the case +* of optical/IR but not radio, wavelength. The formulae +* for the two cases are developed from Hohenkerk & Sinclair +* (1985) and Rueger (2002). +* +* The above three items are as used in the slRFRO routine. +* +* d) The formula for beta, the ratio of the scale height of the +* atmosphere to the geocentric distance of the observer, is +* an adaption of expression 9 from Stone (1996). The +* adaptations, arrived at empirically, consist of (i) a +* small adjustment to the coefficient and (ii) a humidity +* term for the radio case only. +* +* e) The formulae for the refraction constants as a function of +* n-1 and beta are from Green (1987), expression 4.31. +* +* References: +* +* Crane, R.K., Meeks, M.L. (ed), "Refraction Effects in the Neutral +* Atmosphere", Methods of Experimental Physics: Astrophysics 12B, +* Academic Press, 1976. +* +* Gill, Adrian E., "Atmosphere-Ocean Dynamics", Academic Press, 1982. +* +* Green, R.M., "Spherical Astronomy", Cambridge University Press, 1987. +* +* Hohenkerk, C.Y., & Sinclair, A.T., NAO Technical Note No. 63, 1985. +* +* Rueger, J.M., "Refractive Index Formulae for Electronic Distance +* Measurement with Radio and Millimetre Waves", in Unisurv Report +* S-68, School of Surveying and Spatial Information Systems, +* University of New South Wales, Sydney, Australia, 2002. +* +* Stone, Ronald C., P.A.S.P. 108 1051-1058, 1996. +* +* Last revision: 2 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION TDK,PMB,RH,WL,REFA,REFB + + LOGICAL OPTIC + DOUBLE PRECISION T,P,R,W,TDC,PS,PW,WLSQ,GAMMA,BETA + + + +* Decide whether optical/IR or radio case: switch at 100 microns. + OPTIC = WL.LE.100D0 + +* Restrict parameters to safe values. + T = MIN(MAX(TDK,100D0),500D0) + P = MIN(MAX(PMB,0D0),10000D0) + R = MIN(MAX(RH,0D0),1D0) + W = MIN(MAX(WL,0.1D0),1D6) + +* Water vapour pressure at the observer. + IF (P.GT.0D0) THEN + TDC = T-273.15D0 + PS = 10D0**((0.7859D0+0.03477D0*TDC)/(1D0+0.00412D0*TDC))* + : (1D0+P*(4.5D-6+6D-10*TDC*TDC)) + PW = R*PS/(1D0-(1D0-R)*PS/P) + ELSE + PW = 0D0 + END IF + +* Refractive index minus 1 at the observer. + IF (OPTIC) THEN + WLSQ = W*W + GAMMA = ((77.53484D-6+(4.39108D-7+3.666D-9/WLSQ)/WLSQ)*P + : -11.2684D-6*PW)/T + ELSE + GAMMA = (77.6890D-6*P-(6.3938D-6-0.375463D0/T)*PW)/T + END IF + +* Formula for beta adapted from Stone, with empirical adjustments. + BETA=4.4474D-6*T + IF (.NOT.OPTIC) BETA=BETA-0.0074D0*PW*BETA + +* Refraction constants from Green. + REFA = GAMMA*(1D0-BETA) + REFB = -GAMMA*(BETA-GAMMA/2D0) + + END diff --git a/math/slalib/refro.f b/math/slalib/refro.f new file mode 100644 index 00000000..3a93264e --- /dev/null +++ b/math/slalib/refro.f @@ -0,0 +1,402 @@ + SUBROUTINE slRFRO ( ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, + : EPS, REF ) +*+ +* - - - - - - +* R F R O +* - - - - - - +* +* Atmospheric refraction for radio and optical/IR wavelengths. +* +* Given: +* ZOBS d observed zenith distance of the source (radian) +* HM d height of the observer above sea level (metre) +* TDK d ambient temperature at the observer (K) +* PMB d pressure at the observer (millibar) +* RH d relative humidity at the observer (range 0-1) +* WL d effective wavelength of the source (micrometre) +* PHI d latitude of the observer (radian, astronomical) +* TLR d temperature lapse rate in the troposphere (K/metre) +* EPS d precision required to terminate iteration (radian) +* +* Returned: +* REF d refraction: in vacuo ZD minus observed ZD (radian) +* +* Notes: +* +* 1 A suggested value for the TLR argument is 0.0065D0. The +* refraction is significantly affected by TLR, and if studies +* of the local atmosphere have been carried out a better TLR +* value may be available. The sign of the supplied TLR value +* is ignored. +* +* 2 A suggested value for the EPS argument is 1D-8. The result is +* usually at least two orders of magnitude more computationally +* precise than the supplied EPS value. +* +* 3 The routine computes the refraction for zenith distances up +* to and a little beyond 90 deg using the method of Hohenkerk +* and Sinclair (NAO Technical Notes 59 and 63, subsequently adopted +* in the Explanatory Supplement, 1992 edition - see section 3.281). +* +* 4 The code is a development of the optical/IR refraction subroutine +* AREF of C.Hohenkerk (HMNAO, September 1984), with extensions to +* support the radio case. Apart from merely cosmetic changes, the +* following modifications to the original HMNAO optical/IR refraction +* code have been made: +* +* . The angle arguments have been changed to radians. +* +* . Any value of ZOBS is allowed (see note 6, below). +* +* . Other argument values have been limited to safe values. +* +* . Murray's values for the gas constants have been used +* (Vectorial Astrometry, Adam Hilger, 1983). +* +* . The numerical integration phase has been rearranged for +* extra clarity. +* +* . A better model for Ps(T) has been adopted (taken from +* Gill, Atmosphere-Ocean Dynamics, Academic Press, 1982). +* +* . More accurate expressions for Pwo have been adopted +* (again from Gill 1982). +* +* . The formula for the water vapour pressure, given the +* saturation pressure and the relative humidity, is from +* Crane (1976), expression 2.5.5. +* +* . Provision for radio wavelengths has been added using +* expressions devised by A.T.Sinclair, RGO (private +* communication 1989). The refractivity model currently +* used is from J.M.Rueger, "Refractive Index Formulae for +* Electronic Distance Measurement with Radio and Millimetre +* Waves", in Unisurv Report S-68 (2002), School of Surveying +* and Spatial Information Systems, University of New South +* Wales, Sydney, Australia. +* +* . The optical refractivity for dry air is from Resolution 3 of +* the International Association of Geodesy adopted at the XXIIth +* General Assembly in Birmingham, UK, 1999. +* +* . Various small changes have been made to gain speed. +* +* 5 The radio refraction is chosen by specifying WL > 100 micrometres. +* Because the algorithm takes no account of the ionosphere, the +* accuracy deteriorates at low frequencies, below about 30 MHz. +* +* 6 Before use, the value of ZOBS is expressed in the range +/- pi. +* If this ranged ZOBS is -ve, the result REF is computed from its +* absolute value before being made -ve to match. In addition, if +* it has an absolute value greater than 93 deg, a fixed REF value +* equal to the result for ZOBS = 93 deg is returned, appropriately +* signed. +* +* 7 As in the original Hohenkerk and Sinclair algorithm, fixed values +* of the water vapour polytrope exponent, the height of the +* tropopause, and the height at which refraction is negligible are +* used. +* +* 8 The radio refraction has been tested against work done by +* Iain Coulson, JACH, (private communication 1995) for the +* James Clerk Maxwell Telescope, Mauna Kea. For typical conditions, +* agreement at the 0.1 arcsec level is achieved for moderate ZD, +* worsening to perhaps 0.5-1.0 arcsec at ZD 80 deg. At hot and +* humid sea-level sites the accuracy will not be as good. +* +* 9 It should be noted that the relative humidity RH is formally +* defined in terms of "mixing ratio" rather than pressures or +* densities as is often stated. It is the mass of water per unit +* mass of dry air divided by that for saturated air at the same +* temperature and pressure (see Gill 1982). +* +* 10 The algorithm is designed for observers in the troposphere. The +* supplied temperature, pressure and lapse rate are assumed to be +* for a point in the troposphere and are used to define a model +* atmosphere with the tropopause at 11km altitude and a constant +* temperature above that. However, in practice, the refraction +* values returned for stratospheric observers, at altitudes up to +* 25km, are quite usable. +* +* Called: slDA1P, slATMT, slATMS +* +* Last revision: 5 December 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ZOBS,HM,TDK,PMB,RH,WL,PHI,TLR,EPS,REF + +* +* Fixed parameters +* + DOUBLE PRECISION D93,GCR,DMD,DMW,S,DELTA,HT,HS + INTEGER ISMAX +* 93 degrees in radians + PARAMETER (D93=1.623156204D0) +* Universal gas constant + PARAMETER (GCR=8314.32D0) +* Molecular weight of dry air + PARAMETER (DMD=28.9644D0) +* Molecular weight of water vapour + PARAMETER (DMW=18.0152D0) +* Mean Earth radius (metre) + PARAMETER (S=6378120D0) +* Exponent of temperature dependence of water vapour pressure + PARAMETER (DELTA=18.36D0) +* Height of tropopause (metre) + PARAMETER (HT=11000D0) +* Upper limit for refractive effects (metre) + PARAMETER (HS=80000D0) +* Numerical integration: maximum number of strips. + PARAMETER (ISMAX=16384) + + INTEGER IS,K,N,I,J + LOGICAL OPTIC,LOOP + DOUBLE PRECISION ZOBS1,ZOBS2,HMOK,TDKOK,PMBOK,RHOK,WLOK,ALPHA, + : TOL,WLSQ,GB,A,GAMAL,GAMMA,GAMM2,DELM2, + : TDC,PSAT,PWO,W, + : C1,C2,C3,C4,C5,C6,R0,TEMPO,DN0,RDNDR0,SK0,F0, + : RT,TT,DNT,RDNDRT,SINE,ZT,FT,DNTS,RDNDRP,ZTS,FTS, + : RS,DNS,RDNDRS,ZS,FS,REFOLD,Z0,ZRANGE,FB,FF,FO,FE, + : H,R,SZ,RG,DR,TG,DN,RDNDR,T,F,REFP,REFT + + DOUBLE PRECISION slDA1P + +* The refraction integrand + DOUBLE PRECISION REFI + REFI(DN,RDNDR) = RDNDR/(DN+RDNDR) + + + +* Transform ZOBS into the normal range. + ZOBS1 = slDA1P(ZOBS) + ZOBS2 = MIN(ABS(ZOBS1),D93) + +* Keep other arguments within safe bounds. + HMOK = MIN(MAX(HM,-1D3),HS) + TDKOK = MIN(MAX(TDK,100D0),500D0) + PMBOK = MIN(MAX(PMB,0D0),10000D0) + RHOK = MIN(MAX(RH,0D0),1D0) + WLOK = MAX(WL,0.1D0) + ALPHA = MIN(MAX(ABS(TLR),0.001D0),0.01D0) + +* Tolerance for iteration. + TOL = MIN(MAX(ABS(EPS),1D-12),0.1D0)/2D0 + +* Decide whether optical/IR or radio case - switch at 100 microns. + OPTIC = WLOK.LE.100D0 + +* Set up model atmosphere parameters defined at the observer. + WLSQ = WLOK*WLOK + GB = 9.784D0*(1D0-0.0026D0*COS(PHI+PHI)-0.00000028D0*HMOK) + IF (OPTIC) THEN + A = (287.6155D0+(1.62887D0+0.01360D0/WLSQ)/WLSQ) + : *273.15D-6/1013.25D0 + ELSE + A = 77.6890D-6 + END IF + GAMAL = (GB*DMD)/GCR + GAMMA = GAMAL/ALPHA + GAMM2 = GAMMA-2D0 + DELM2 = DELTA-2D0 + TDC = TDKOK-273.15D0 + PSAT = 10D0**((0.7859D0+0.03477D0*TDC)/(1D0+0.00412D0*TDC))* + : (1D0+PMBOK*(4.5D-6+6D-10*TDC*TDC)) + IF (PMBOK.GT.0D0) THEN + PWO = RHOK*PSAT/(1D0-(1D0-RHOK)*PSAT/PMBOK) + ELSE + PWO = 0D0 + END IF + W = PWO*(1D0-DMW/DMD)*GAMMA/(DELTA-GAMMA) + C1 = A*(PMBOK+W)/TDKOK + IF (OPTIC) THEN + C2 = (A*W+11.2684D-6*PWO)/TDKOK + ELSE + C2 = (A*W+6.3938D-6*PWO)/TDKOK + END IF + C3 = (GAMMA-1D0)*ALPHA*C1/TDKOK + C4 = (DELTA-1D0)*ALPHA*C2/TDKOK + IF (OPTIC) THEN + C5 = 0D0 + C6 = 0D0 + ELSE + C5 = 375463D-6*PWO/TDKOK + C6 = C5*DELM2*ALPHA/(TDKOK*TDKOK) + END IF + +* Conditions at the observer. + R0 = S+HMOK + CALL slATMT(R0,TDKOK,ALPHA,GAMM2,DELM2,C1,C2,C3,C4,C5,C6, + : R0,TEMPO,DN0,RDNDR0) + SK0 = DN0*R0*SIN(ZOBS2) + F0 = REFI(DN0,RDNDR0) + +* Conditions in the troposphere at the tropopause. + RT = S+MAX(HT,HMOK) + CALL slATMT(R0,TDKOK,ALPHA,GAMM2,DELM2,C1,C2,C3,C4,C5,C6, + : RT,TT,DNT,RDNDRT) + SINE = SK0/(RT*DNT) + ZT = ATAN2(SINE,SQRT(MAX(1D0-SINE*SINE,0D0))) + FT = REFI(DNT,RDNDRT) + +* Conditions in the stratosphere at the tropopause. + CALL slATMS(RT,TT,DNT,GAMAL,RT,DNTS,RDNDRP) + SINE = SK0/(RT*DNTS) + ZTS = ATAN2(SINE,SQRT(MAX(1D0-SINE*SINE,0D0))) + FTS = REFI(DNTS,RDNDRP) + +* Conditions at the stratosphere limit. + RS = S+HS + CALL slATMS(RT,TT,DNT,GAMAL,RS,DNS,RDNDRS) + SINE = SK0/(RS*DNS) + ZS = ATAN2(SINE,SQRT(MAX(1D0-SINE*SINE,0D0))) + FS = REFI(DNS,RDNDRS) + +* Variable initialization to avoid compiler warning. + REFT = 0D0 + +* Integrate the refraction integral in two parts; first in the +* troposphere (K=1), then in the stratosphere (K=2). + + DO K = 1,2 + +* Initialize previous refraction to ensure at least two iterations. + REFOLD = 1D0 + +* Start off with 8 strips. + IS = 8 + +* Start Z, Z range, and start and end values. + IF (K.EQ.1) THEN + Z0 = ZOBS2 + ZRANGE = ZT-Z0 + FB = F0 + FF = FT + ELSE + Z0 = ZTS + ZRANGE = ZS-Z0 + FB = FTS + FF = FS + END IF + +* Sums of odd and even values. + FO = 0D0 + FE = 0D0 + +* First time through the loop we have to do every point. + N = 1 + +* Start of iteration loop (terminates at specified precision). + LOOP = .TRUE. + DO WHILE (LOOP) + +* Strip width. + H = ZRANGE/DBLE(IS) + +* Initialize distance from Earth centre for quadrature pass. + IF (K.EQ.1) THEN + R = R0 + ELSE + R = RT + END IF + +* One pass (no need to compute evens after first time). + DO I=1,IS-1,N + +* Sine of observed zenith distance. + SZ = SIN(Z0+H*DBLE(I)) + +* Find R (to the nearest metre, maximum four iterations). + IF (SZ.GT.1D-20) THEN + W = SK0/SZ + RG = R + DR = 1D6 + J = 0 + DO WHILE (ABS(DR).GT.1D0.AND.J.LT.4) + J=J+1 + IF (K.EQ.1) THEN + CALL slATMT(R0,TDKOK,ALPHA,GAMM2,DELM2, + : C1,C2,C3,C4,C5,C6,RG,TG,DN,RDNDR) + ELSE + CALL slATMS(RT,TT,DNT,GAMAL,RG,DN,RDNDR) + END IF + DR = (RG*DN-W)/(DN+RDNDR) + RG = RG-DR + END DO + R = RG + END IF + +* Find the refractive index and integrand at R. + IF (K.EQ.1) THEN + CALL slATMT(R0,TDKOK,ALPHA,GAMM2,DELM2, + : C1,C2,C3,C4,C5,C6,R,T,DN,RDNDR) + ELSE + CALL slATMS(RT,TT,DNT,GAMAL,R,DN,RDNDR) + END IF + F = REFI(DN,RDNDR) + +* Accumulate odd and (first time only) even values. + IF (N.EQ.1.AND.MOD(I,2).EQ.0) THEN + FE = FE+F + ELSE + FO = FO+F + END IF + END DO + +* Evaluate the integrand using Simpson's Rule. + REFP = H*(FB+4D0*FO+2D0*FE+FF)/3D0 + +* Has the required precision been achieved (or can't be)? + IF (ABS(REFP-REFOLD).GT.TOL.AND.IS.LT.ISMAX) THEN + +* No: prepare for next iteration. + +* Save current value for convergence test. + REFOLD = REFP + +* Double the number of strips. + IS = IS+IS + +* Sum of all current values = sum of next pass's even values. + FE = FE+FO + +* Prepare for new odd values. + FO = 0D0 + +* Skip even values next time. + N = 2 + ELSE + +* Yes: save troposphere component and terminate the loop. + IF (K.EQ.1) REFT = REFP + LOOP = .FALSE. + END IF + END DO + END DO + +* Result. + REF = REFT+REFP + IF (ZOBS1.LT.0D0) REF = -REF + + END diff --git a/math/slalib/refv.f b/math/slalib/refv.f new file mode 100644 index 00000000..42a5f1f6 --- /dev/null +++ b/math/slalib/refv.f @@ -0,0 +1,129 @@ + SUBROUTINE slREFV (VU, REFA, REFB, VR) +*+ +* - - - - - +* R E F V +* - - - - - +* +* Adjust an unrefracted Cartesian vector to include the effect of +* atmospheric refraction, using the simple A tan Z + B tan**3 Z +* model. +* +* Given: +* VU dp unrefracted position of the source (Az/El 3-vector) +* REFA dp tan Z coefficient (radian) +* REFB dp tan**3 Z coefficient (radian) +* +* Returned: +* VR dp refracted position of the source (Az/El 3-vector) +* +* Notes: +* +* 1 This routine applies the adjustment for refraction in the +* opposite sense to the usual one - it takes an unrefracted +* (in vacuo) position and produces an observed (refracted) +* position, whereas the A tan Z + B tan**3 Z model strictly +* applies to the case where an observed position is to have the +* refraction removed. The unrefracted to refracted case is +* harder, and requires an inverted form of the text-book +* refraction models; the algorithm used here is equivalent to +* one iteration of the Newton-Raphson method applied to the above +* formula. +* +* 2 Though optimized for speed rather than precision, the present +* routine achieves consistency with the refracted-to-unrefracted +* A tan Z + B tan**3 Z model at better than 1 microarcsecond within +* 30 degrees of the zenith and remains within 1 milliarcsecond to +* beyond ZD 70 degrees. The inherent accuracy of the model is, of +* course, far worse than this - see the documentation for slRFCO +* for more information. +* +* 3 At low elevations (below about 3 degrees) the refraction +* correction is held back to prevent arithmetic problems and +* wildly wrong results. For optical/IR wavelengths, over a wide +* range of observer heights and corresponding temperatures and +* pressures, the following levels of accuracy (arcsec, worst case) +* are achieved, relative to numerical integration through a model +* atmosphere: +* +* ZD error +* +* 80 0.7 +* 81 1.3 +* 82 2.5 +* 83 5 +* 84 10 +* 85 20 +* 86 55 +* 87 160 +* 88 360 +* 89 640 +* 90 1100 +* 91 1700 } relevant only to +* 92 2600 } high-elevation sites +* +* The results for radio are slightly worse over most of the range, +* becoming significantly worse below ZD=88 and unusable beyond +* ZD=90. +* +* 4 See also the routine slREFZ, which performs the adjustment to +* the zenith distance rather than in Cartesian Az/El coordinates. +* The present routine is faster than slREFZ and, except very low down, +* is equally accurate for all practical purposes. However, beyond +* about ZD 84 degrees slREFZ should be used, and for the utmost +* accuracy iterative use of slRFRO should be considered. +* +* P.T.Wallace Starlink 10 April 2004 +* +* Copyright (C) 2004 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION VU(3),REFA,REFB,VR(3) + + DOUBLE PRECISION X,Y,Z1,Z,ZSQ,RSQ,R,WB,WT,D,CD,F + + + +* Initial estimate = unrefracted vector + X = VU(1) + Y = VU(2) + Z1 = VU(3) + +* Keep correction approximately constant below about 3 deg elevation + Z = MAX(Z1,0.05D0) + +* One Newton-Raphson iteration + ZSQ = Z*Z + RSQ = X*X+Y*Y + R = SQRT(RSQ) + WB = REFB*RSQ/ZSQ + WT = (REFA+WB)/(1D0+(REFA+3D0*WB)*(ZSQ+RSQ)/ZSQ) + D = WT*R/Z + CD = 1D0-D*D/2D0 + F = CD*(1D0-WT) + +* Post-refraction x,y,z + VR(1) = X*F + VR(2) = Y*F + VR(3) = CD*(Z+D*R)+(Z1-Z) + + END diff --git a/math/slalib/refz.f b/math/slalib/refz.f new file mode 100644 index 00000000..6bdae80f --- /dev/null +++ b/math/slalib/refz.f @@ -0,0 +1,170 @@ + SUBROUTINE slREFZ (ZU, REFA, REFB, ZR) +*+ +* - - - - - +* R E F Z +* - - - - - +* +* Adjust an unrefracted zenith distance to include the effect of +* atmospheric refraction, using the simple A tan Z + B tan**3 Z +* model (plus special handling for large ZDs). +* +* Given: +* ZU dp unrefracted zenith distance of the source (radian) +* REFA dp tan Z coefficient (radian) +* REFB dp tan**3 Z coefficient (radian) +* +* Returned: +* ZR dp refracted zenith distance (radian) +* +* Notes: +* +* 1 This routine applies the adjustment for refraction in the +* opposite sense to the usual one - it takes an unrefracted +* (in vacuo) position and produces an observed (refracted) +* position, whereas the A tan Z + B tan**3 Z model strictly +* applies to the case where an observed position is to have the +* refraction removed. The unrefracted to refracted case is +* harder, and requires an inverted form of the text-book +* refraction models; the formula used here is based on the +* Newton-Raphson method. For the utmost numerical consistency +* with the refracted to unrefracted model, two iterations are +* carried out, achieving agreement at the 1D-11 arcseconds level +* for a ZD of 80 degrees. The inherent accuracy of the model +* is, of course, far worse than this - see the documentation for +* slRFCO for more information. +* +* 2 At ZD 83 degrees, the rapidly-worsening A tan Z + B tan^3 Z +* model is abandoned and an empirical formula takes over. For +* optical/IR wavelengths, over a wide range of observer heights and +* corresponding temperatures and pressures, the following levels of +* accuracy (arcsec, worst case) are achieved, relative to numerical +* integration through a model atmosphere: +* +* ZR error +* +* 80 0.7 +* 81 1.3 +* 82 2.4 +* 83 4.7 +* 84 6.2 +* 85 6.4 +* 86 8 +* 87 10 +* 88 15 +* 89 30 +* 90 60 +* 91 150 } relevant only to +* 92 400 } high-elevation sites +* +* For radio wavelengths the errors are typically 50% larger than +* the optical figures and by ZD 85 deg are twice as bad, worsening +* rapidly below that. To maintain 1 arcsec accuracy down to ZD=85 +* at the Green Bank site, Condon (2004) has suggested amplifying +* the amount of refraction predicted by slREFZ below 10.8 deg +* elevation by the factor (1+0.00195*(10.8-E_t)), where E_t is the +* unrefracted elevation in degrees. +* +* The high-ZD model is scaled to match the normal model at the +* transition point; there is no glitch. +* +* 3 Beyond 93 deg zenith distance, the refraction is held at its +* 93 deg value. +* +* 4 See also the routine slREFV, which performs the adjustment in +* Cartesian Az/El coordinates, and with the emphasis on speed +* rather than numerical accuracy. +* +* Reference: +* +* Condon,J.J., Refraction Corrections for the GBT, PTCS/PN/35.2, +* NRAO Green Bank, 2004. +* +* P.T.Wallace Starlink 9 April 2004 +* +* Copyright (C) 2004 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION ZU,REFA,REFB,ZR + +* Radians to degrees + DOUBLE PRECISION R2D + PARAMETER (R2D=57.29577951308232D0) + +* Largest usable ZD (deg) + DOUBLE PRECISION D93 + PARAMETER (D93=93D0) + +* Coefficients for high ZD model (used beyond ZD 83 deg) + DOUBLE PRECISION C1,C2,C3,C4,C5 + PARAMETER (C1=+0.55445D0, + : C2=-0.01133D0, + : C3=+0.00202D0, + : C4=+0.28385D0, + : C5=+0.02390D0) + +* ZD at which one model hands over to the other (radians) + DOUBLE PRECISION Z83 + PARAMETER (Z83=83D0/R2D) + +* High-ZD-model prediction (deg) for that point + DOUBLE PRECISION REF83 + PARAMETER (REF83=(C1+C2*7D0+C3*49D0)/(1D0+C4*7D0+C5*49D0)) + + DOUBLE PRECISION ZU1,ZL,S,C,T,TSQ,TCU,REF,E,E2 + + + +* Perform calculations for ZU or 83 deg, whichever is smaller + ZU1 = MIN(ZU,Z83) + +* Functions of ZD + ZL = ZU1 + S = SIN(ZL) + C = COS(ZL) + T = S/C + TSQ = T*T + TCU = T*TSQ + +* Refracted ZD (mathematically to better than 1 mas at 70 deg) + ZL = ZL-(REFA*T+REFB*TCU)/(1D0+(REFA+3D0*REFB*TSQ)/(C*C)) + +* Further iteration + S = SIN(ZL) + C = COS(ZL) + T = S/C + TSQ = T*T + TCU = T*TSQ + REF = ZU1-ZL+ + : (ZL-ZU1+REFA*T+REFB*TCU)/(1D0+(REFA+3D0*REFB*TSQ)/(C*C)) + +* Special handling for large ZU + IF (ZU.GT.ZU1) THEN + E = 90D0-MIN(D93,ZU*R2D) + E2 = E*E + REF = (REF/REF83)*(C1+C2*E+C3*E2)/(1D0+C4*E+C5*E2) + END IF + +* Return refracted ZD + ZR = ZU-REF + + END diff --git a/math/slalib/rtl_random.c b/math/slalib/rtl_random.c new file mode 100644 index 00000000..a8730c0c --- /dev/null +++ b/math/slalib/rtl_random.c @@ -0,0 +1,33 @@ +#include + +float +random_ ( int *iseed ) +/* +** - - - - - - - +** r a n d o m +** - - - - - - - +** +** Generate pseudo-random real number in the range 0 <= x < 1. +** +** (single precision) +** +** This function is designed to replace the Fortran->C interface routine +** random(3f) on systems which do not have this library (for example Linux) +** +** Fortran call: X = RANDOM(ISEED) +** +** Given: +** iseed int seed value +** +** If iseed !=0 random-number generator is initialised and first number +** is returned. +** iseed == 0 next number in the sequence is returned +** +** B.K.McIlwrath Starlink 12 January 1996 +*/ +{ + if( *iseed != 0 ) + srand(*iseed); + + return (float) rand() / (float) RAND_MAX; +} diff --git a/math/slalib/rverot.f b/math/slalib/rverot.f new file mode 100644 index 00000000..3fc5ab50 --- /dev/null +++ b/math/slalib/rverot.f @@ -0,0 +1,66 @@ + REAL FUNCTION slRVER (PHI, RA, DA, ST) +*+ +* - - - - - - - +* R V E R +* - - - - - - - +* +* Velocity component in a given direction due to Earth rotation +* (single precision) +* +* Given: +* PHI real latitude of observing station (geodetic) +* RA,DA real apparent RA,DEC +* ST real local apparent sidereal time +* +* PHI, RA, DEC and ST are all in radians. +* +* Result: +* Component of Earth rotation in direction RA,DA (km/s) +* +* Sign convention: +* The result is +ve when the observatory is receding from the +* given point on the sky. +* +* Accuracy: +* The simple algorithm used assumes a spherical Earth, of +* a radius chosen to give results accurate to about 0.0005 km/s +* for observing stations at typical latitudes and heights. For +* applications requiring greater precision, use the routine +* slPVOB. +* +* P.T.Wallace Starlink 20 July 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL PHI,RA,DA,ST + +* Nominal mean sidereal speed of Earth equator in km/s (the actual +* value is about 0.4651) + REAL ESPEED + PARAMETER (ESPEED=0.4655) + + + slRVER=ESPEED*COS(PHI)*SIN(ST-RA)*COS(DA) + + END diff --git a/math/slalib/rvgalc.f b/math/slalib/rvgalc.f new file mode 100644 index 00000000..173c7d92 --- /dev/null +++ b/math/slalib/rvgalc.f @@ -0,0 +1,87 @@ + REAL FUNCTION slRVGA (R2000, D2000) +*+ +* - - - - - - - +* R V G A +* - - - - - - - +* +* Velocity component in a given direction due to the rotation +* of the Galaxy (single precision) +* +* Given: +* R2000,D2000 real J2000.0 mean RA,Dec (radians) +* +* Result: +* Component of dynamical LSR motion in direction R2000,D2000 (km/s) +* +* Sign convention: +* The result is +ve when the dynamical LSR is receding from the +* given point on the sky. +* +* Note: The Local Standard of Rest used here is a point in the +* vicinity of the Sun which is in a circular orbit around +* the Galactic centre. Sometimes called the "dynamical" LSR, +* it is not to be confused with a "kinematical" LSR, which +* is the mean standard of rest of star catalogues or stellar +* populations. +* +* Reference: The orbital speed of 220 km/s used here comes from +* Kerr & Lynden-Bell (1986), MNRAS, 221, p1023. +* +* Called: +* slCS2C, slVDV +* +* P.T.Wallace Starlink 23 March 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL R2000,D2000 + + REAL VA(3), VB(3) + + REAL slVDV + +* +* LSR velocity due to Galactic rotation +* +* Speed = 220 km/s +* Apex = L2,B2 90deg, 0deg +* = RA,Dec 21 12 01.1 +48 19 47 J2000.0 +* +* This is expressed in the form of a J2000.0 x,y,z vector: +* +* VA(1) = X = -SPEED*COS(RA)*COS(DEC) +* VA(2) = Y = -SPEED*SIN(RA)*COS(DEC) +* VA(3) = Z = -SPEED*SIN(DEC) + + DATA VA / -108.70408, +97.86251, -164.33610 / + + + +* Convert given J2000 RA,Dec to x,y,z + CALL slCS2C(R2000,D2000,VB) + +* Compute dot product with LSR motion vector + slRVGA=slVDV(VA,VB) + + END diff --git a/math/slalib/rvlg.f b/math/slalib/rvlg.f new file mode 100644 index 00000000..cc3076e6 --- /dev/null +++ b/math/slalib/rvlg.f @@ -0,0 +1,82 @@ + REAL FUNCTION slRVLG (R2000, D2000) +*+ +* - - - - - +* R V L G +* - - - - - +* +* Velocity component in a given direction due to the combination +* of the rotation of the Galaxy and the motion of the Galaxy +* relative to the mean motion of the local group (single precision) +* +* Given: +* R2000,D2000 real J2000.0 mean RA,Dec (radians) +* +* Result: +* Component of SOLAR motion in direction R2000,D2000 (km/s) +* +* Sign convention: +* The result is +ve when the Sun is receding from the +* given point on the sky. +* +* Reference: +* IAU Trans 1976, 168, p201. +* +* Called: +* slCS2C, slVDV +* +* P.T.Wallace Starlink June 1985 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL R2000,D2000 + + REAL VA(3), VB(3) + + REAL slVDV + +* +* Solar velocity due to Galactic rotation and translation +* +* Speed = 300 km/s +* +* Apex = L2,B2 90deg, 0deg +* = RA,Dec 21 12 01.1 +48 19 47 J2000.0 +* +* This is expressed in the form of a J2000.0 x,y,z vector: +* +* VA(1) = X = -SPEED*COS(RA)*COS(DEC) +* VA(2) = Y = -SPEED*SIN(RA)*COS(DEC) +* VA(3) = Z = -SPEED*SIN(DEC) + + DATA VA / -148.23284, +133.44888, -224.09467 / + + + +* Convert given J2000 RA,Dec to x,y,z + CALL slCS2C(R2000,D2000,VB) + +* Compute dot product with Solar motion vector + slRVLG=slVDV(VA,VB) + + END diff --git a/math/slalib/rvlsrd.f b/math/slalib/rvlsrd.f new file mode 100644 index 00000000..720d6c9c --- /dev/null +++ b/math/slalib/rvlsrd.f @@ -0,0 +1,96 @@ + REAL FUNCTION slRVLD (R2000, D2000) +*+ +* - - - - - - - +* R V L D +* - - - - - - - +* +* Velocity component in a given direction due to the Sun's motion +* with respect to the dynamical Local Standard of Rest. +* +* (single precision) +* +* Given: +* R2000,D2000 r J2000.0 mean RA,Dec (radians) +* +* Result: +* Component of "peculiar" solar motion in direction R2000,D2000 (km/s) +* +* Sign convention: +* The result is +ve when the Sun is receding from the given point on +* the sky. +* +* Note: The Local Standard of Rest used here is the "dynamical" LSR, +* a point in the vicinity of the Sun which is in a circular +* orbit around the Galactic centre. The Sun's motion with +* respect to the dynamical LSR is called the "peculiar" solar +* motion. +* +* There is another type of LSR, called a "kinematical" LSR. A +* kinematical LSR is the mean standard of rest of specified star +* catalogues or stellar populations, and several slightly +* different kinematical LSRs are in use. The Sun's motion with +* respect to an agreed kinematical LSR is known as the "standard" +* solar motion. To obtain a radial velocity correction with +* respect to an adopted kinematical LSR use the routine slRVLK. +* +* Reference: Delhaye (1965), in "Stars and Stellar Systems", vol 5, +* p73. +* +* Called: +* slCS2C, slVDV +* +* P.T.Wallace Starlink 9 March 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL R2000,D2000 + + REAL VA(3), VB(3) + + REAL slVDV + +* +* Peculiar solar motion from Delhaye 1965: in Galactic Cartesian +* coordinates (+9,+12,+7) km/s. This corresponds to about 16.6 km/s +* towards Galactic coordinates L2 = 53 deg, B2 = +25 deg, or RA,Dec +* 17 49 58.7 +28 07 04 J2000. +* +* The solar motion is expressed here in the form of a J2000.0 +* equatorial Cartesian vector: +* +* VA(1) = X = -SPEED*COS(RA)*COS(DEC) +* VA(2) = Y = -SPEED*SIN(RA)*COS(DEC) +* VA(3) = Z = -SPEED*SIN(DEC) + + DATA VA / +0.63823, +14.58542, -7.80116 / + + + +* Convert given J2000 RA,Dec to x,y,z + CALL slCS2C(R2000,D2000,VB) + +* Compute dot product with solar motion vector + slRVLD=slVDV(VA,VB) + + END diff --git a/math/slalib/rvlsrk.f b/math/slalib/rvlsrk.f new file mode 100644 index 00000000..52b3db95 --- /dev/null +++ b/math/slalib/rvlsrk.f @@ -0,0 +1,95 @@ + REAL FUNCTION slRVLK (R2000, D2000) +*+ +* - - - - - - - +* R V L K +* - - - - - - - +* +* Velocity component in a given direction due to the Sun's motion +* with respect to an adopted kinematic Local Standard of Rest. +* +* (single precision) +* +* Given: +* R2000,D2000 r J2000.0 mean RA,Dec (radians) +* +* Result: +* Component of "standard" solar motion in direction R2000,D2000 (km/s) +* +* Sign convention: +* The result is +ve when the Sun is receding from the given point on +* the sky. +* +* Note: The Local Standard of Rest used here is one of several +* "kinematical" LSRs in common use. A kinematical LSR is the +* mean standard of rest of specified star catalogues or stellar +* populations. The Sun's motion with respect to a kinematical +* LSR is known as the "standard" solar motion. +* +* There is another sort of LSR, the "dynamical" LSR, which is a +* point in the vicinity of the Sun which is in a circular orbit +* around the Galactic centre. The Sun's motion with respect to +* the dynamical LSR is called the "peculiar" solar motion. To +* obtain a radial velocity correction with respect to the +* dynamical LSR use the routine slRVLD. +* +* Reference: Delhaye (1965), in "Stars and Stellar Systems", vol 5, +* p73. +* +* Called: +* slCS2C, slVDV +* +* P.T.Wallace Starlink 11 March 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL R2000,D2000 + + REAL VA(3), VB(3) + + REAL slVDV + +* +* Standard solar motion (from Methods of Experimental Physics, ed Meeks, +* vol 12, part C, sec 6.1.5.2, p281): +* +* 20 km/s towards RA 18h Dec +30d (1900). +* +* The solar motion is expressed here in the form of a J2000.0 +* equatorial Cartesian vector: +* +* VA(1) = X = -SPEED*COS(RA)*COS(DEC) +* VA(2) = Y = -SPEED*SIN(RA)*COS(DEC) +* VA(3) = Z = -SPEED*SIN(DEC) + + DATA VA / -0.29000, +17.31726, -10.00141 / + + + +* Convert given J2000 RA,Dec to x,y,z + CALL slCS2C(R2000,D2000,VB) + +* Compute dot product with solar motion vector + slRVLK=slVDV(VA,VB) + + END diff --git a/math/slalib/s2tp.f b/math/slalib/s2tp.f new file mode 100644 index 00000000..ca187db2 --- /dev/null +++ b/math/slalib/s2tp.f @@ -0,0 +1,85 @@ + SUBROUTINE slS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J) +*+ +* - - - - - +* S 2 T P +* - - - - - +* +* Projection of spherical coordinates onto tangent plane: +* "gnomonic" projection - "standard coordinates" +* (single precision) +* +* Given: +* RA,DEC real spherical coordinates of point to be projected +* RAZ,DECZ real spherical coordinates of tangent point +* +* Returned: +* XI,ETA real rectangular coordinates on tangent plane +* J int status: 0 = OK, star on tangent plane +* 1 = error, star too far from axis +* 2 = error, antistar on tangent plane +* 3 = error, antistar too far from axis +* +* P.T.Wallace Starlink 18 July 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL RA,DEC,RAZ,DECZ,XI,ETA + INTEGER J + + REAL SDECZ,SDEC,CDECZ,CDEC,RADIF,SRADIF,CRADIF,DENOM + + REAL TINY + PARAMETER (TINY=1E-6) + + +* Trig functions + SDECZ=SIN(DECZ) + SDEC=SIN(DEC) + CDECZ=COS(DECZ) + CDEC=COS(DEC) + RADIF=RA-RAZ + SRADIF=SIN(RADIF) + CRADIF=COS(RADIF) + +* Reciprocal of star vector length to tangent plane + DENOM=SDEC*SDECZ+CDEC*CDECZ*CRADIF + +* Handle vectors too far from axis + IF (DENOM.GT.TINY) THEN + J=0 + ELSE IF (DENOM.GE.0.0) THEN + J=1 + DENOM=TINY + ELSE IF (DENOM.GT.-TINY) THEN + J=2 + DENOM=-TINY + ELSE + J=3 + END IF + +* Compute tangent plane coordinates (even in dubious cases) + XI=CDEC*SRADIF/DENOM + ETA=(SDEC*CDECZ-CDEC*SDECZ*CRADIF)/DENOM + + END diff --git a/math/slalib/sedscript b/math/slalib/sedscript new file mode 100755 index 00000000..046d7e1d --- /dev/null +++ b/math/slalib/sedscript @@ -0,0 +1,17 @@ +#!/bin/csh + +# SEDSCRIPT -- Script for editing/renaming the SLALIB FORTRAN routines + +# Make the appropriate name changes and add IRAF copyright +foreach file (*.f) + echo $file + sed -f SED1 $file > tempfile.f + rm $file + mv tempfile.f $file + sed -f SED2 $file > tempfile.f + rm $file + mv tempfile.f $file +end + +# Restore IRAF version of the preces.f file from a save version. +cp precss.f.sav precss.f diff --git a/math/slalib/sep.f b/math/slalib/sep.f new file mode 100644 index 00000000..100de493 --- /dev/null +++ b/math/slalib/sep.f @@ -0,0 +1,56 @@ + REAL FUNCTION slSEP (A1, B1, A2, B2) +*+ +* - - - - +* S E P +* - - - - +* +* Angle between two points on a sphere. +* +* (single precision) +* +* Given: +* A1,B1 r spherical coordinates of one point +* A2,B2 r spherical coordinates of the other point +* +* (The spherical coordinates are [RA,Dec], [Long,Lat] etc, in radians.) +* +* The result is the angle, in radians, between the two points. It +* is always positive. +* +* Called: slDSEP +* +* Last revision: 7 May 2000 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL A1,B1,A2,B2 + + DOUBLE PRECISION slDSEP + + + +* Use double precision version. + slSEP = REAL(slDSEP(DBLE(A1),DBLE(B1),DBLE(A2),DBLE(B2))) + + END diff --git a/math/slalib/sepv.f b/math/slalib/sepv.f new file mode 100644 index 00000000..c1c867ce --- /dev/null +++ b/math/slalib/sepv.f @@ -0,0 +1,71 @@ + REAL FUNCTION slSEPV (V1, V2) +*+ +* - - - - - +* S E P V +* - - - - - +* +* Angle between two vectors. +* +* (single precision) +* +* Given: +* V1 r(3) first vector +* V2 r(3) second vector +* +* The result is the angle, in radians, between the two vectors. It +* is always positive. +* +* Notes: +* +* 1 There is no requirement for the vectors to be unit length. +* +* 2 If either vector is null, zero is returned. +* +* 3 The simplest formulation would use dot product alone. However, +* this would reduce the accuracy for angles near zero and pi. The +* algorithm uses both cross product and dot product, which maintains +* accuracy for all sizes of angle. +* +* Called: slDSEPV +* +* Last revision: 7 May 2000 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V1(3),V2(3) + + INTEGER I + DOUBLE PRECISION DV1(3),DV2(3) + DOUBLE PRECISION slDSEPV + + + +* Use double precision version. + DO I=1,3 + DV1(I) = DBLE(V1(I)) + DV2(I) = DBLE(V2(I)) + END DO + slSEPV = REAL(slDSEPV(DV1,DV2)) + + END diff --git a/math/slalib/sla.c b/math/slalib/sla.c new file mode 100644 index 00000000..10bfde3c --- /dev/null +++ b/math/slalib/sla.c @@ -0,0 +1,2338 @@ +/* +* Name: +* sla.c + +* Purpose: +* Implement a C interface to the Fortran SLALIB library. + +* Description: +* This file implements a C interface to the Fortran version of the +* SLALIB library. + +* Notes: +* This interface only supports a subset of the functions provided by +* SLALIB. It should be extended as and when necessary. + +* Copyright: +* Copyright (C) 1996-2006 Council for the Central Laboratory of the +* Research Councils. Copyright (C) 2007-2008 Science and Technology +* Facilities Council. All Rights Reserved. + +* Licence: +* This program is free software; you can redistribute it and/or +* modify it under the terms of the GNU General Public Licence as +* published by the Free Software Foundation; either version 2 of +* the Licence, or (at your option) any later version. +* +* This program is distributed in the hope that it will be +* useful,but WITHOUT ANY WARRANTY; without even the implied +* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +* PURPOSE. See the GNU General Public Licence for more details. +* +* You should have received a copy of the GNU General Public Licence +* along with this program; if not, write to the Free Software +* Foundation, Inc., 51 Franklin Street,Fifth Floor, Boston, MA +* 02110-1301, USA + +* Authors: +* RFWS: R.F. Warren-Smith (STARLINK) +* DSB: David S. Berry (STARLINK) +* TIMJ: Tim Jenness (JAC, Hawaii) +* PWD: Peter W. Draper (Durham University) + +* History: +* 12-NOV-1996 (RFWS): +* Original version. +* 28-APR-1997 (RFWS): +* Added SLA_DJCAL. +* 26-SEP-1997 (DSB): +* Added SLA_DD2TF, SLA_DJCL. +* 21-JUN-2001 (DSB): +* Added SLA_DBEAR, SLA_DVDV. +* 23-AUG-2001 (DSB): +* Added SLA_SVD and SLA_SVDSOL +* 11-NOV-2002 (DSB): +* Added SLA_RVEROT, SLA_GMST, SLA_EQEQX, SLA_RVLSRK, SLA_RVLSRD, +* SLA_RVLG, SLA_RVGALC. +* 11-JUN-2003 (DSB): +* Added SLA_GEOC, SLA_HFK5Z and SLA_FK5HZ. +* 2-DEC-2004 (DSB): +* Added SLA_DEULER. +* 29-SEP-2005 (DSB): +* Added SLA_DE2H and SLA_DH2E +* 12-JUN-2006 (DSB): +* Moved from AST to SLALIB. +* 25-JUN-2006 (TIMJ): +* Add SLA_AIRMAS. +* 07-AUG-2006 (TIMJ): +* Import cnfImprt from CNF. +* Add SLA_OBS +* 08-AUG-2006 (TIMJ): +* Add SLA_PA +* 12-DEC-2006 (TIMJ): +* Add SLA_DTT and SLA_DAT +* 21-DEC-2006 (TIMJ): +* Add SLA_RDPLAN +* 03-APR-2007 (TIMJ): +* Add SLA_DR2TF +* 14-DEC-2007 (TIMJ): +* Add slaDafin, Add slaMap +* 12-MAR-2008 (TIMJ): +* Add slaOap, slaDr2af, slaAmp, slaPertel, slaPlanet, slaCldj +* to enable elements test. +* 14-JUL-2008 (TIMJ): +* Allowed to use const. +* 30-JUL-2008 (TIMJ): +* Add slaDs2tp +* 10-FEB-2012 (DSB): +* Added slaPvobs +*- +*/ + +/* Header files. */ +/* ============= */ +#include "f77.h" /* FORTRAN <-> C interface macros (SUN/209) */ +#include "slalib.h" /* Prototypes for C SLALIB functions */ +#include /* Malloc etc */ +#include /* string manipulation */ + + +/* Functions needed to avoid a dependence on CNF. */ +/* ============================================== */ + +static void slaStringExport( const char *source_c, char *dest_f, int dest_len ) { +/* +*+ +* Name: +* slaStringExport + +* Purpose: +* Export a C string to a FORTRAN string. + +* Type: +* Protected function. + +* Synopsis: +* void slaStringExport( const char *source_c, char *dest_f, int dest_len ) + +* Description: +* This function creates a FORTRAN string from a C string, storing +* it in the supplied memory. If the C string is shorter than the +* space allocated for the FORTRAN string, then it is padded with +* blanks. If the C string is longer than the space allocated for +* the FORTRAN string, then the string is truncated. + +* Parameters: +* source_c +* A pointer to the input C string. +* dest_f +* A pointer to the output FORTRAN string. +* dest_len +* The length of the output FORTRAN string. + +* Notes: +* - This function is potentially platform-specific. For example, +* if FORTRAN strings were passed by descriptor, then the +* descriptor address would be passed as "dest_f" and this must +* then be used to locate the actual FORTRAN character data. +* - This function is equivalent to cnfExprt but is included here to +* avoid SLALIB becoming dependent on CNF. +*- +*/ + +/* Local Variables:*/ + int i; /* Loop counter for characters */ + +/* Check the supplied pointers. */ + if ( !source_c || !dest_f ) return; + +/* Copy the characters of the input C string to the output FORTRAN + string, taking care not to go beyond the end of the FORTRAN + string.*/ + for ( i = 0; source_c[ i ] && ( i < dest_len ); i++ ) { + dest_f[ i ] = source_c[ i ]; + } + +/* Fill the rest of the output FORTRAN string with blanks. */ + for ( ; i < dest_len; i++ ) dest_f[ i ] = ' '; +} + +static void slaStringImport( const char *source_f, int source_len, char *dest_c ) + +/* +*+ +* Name: +* slaStringImportt + +* Purpose: +* Import a FORTRAN string into a C string + +* Type: +* Protected function. + +* Language: +* ANSI C + +* Invocation: +* slaStringImport( source_f, source_len, dest_c ) + +* Description: +* Import a FORTRAN string into a C string, discarding trailing +* blanks. The NUL character is appended to the C string after +* the last non-blank character. The input string and output string +* pointers can point to the same location if the string is to be +* modified in place (but care must be taken to allow for the additional +* C terminator when allocating memory). + +* Arguments: +* const char *source_f (Given) +* A pointer to the input FORTRAN string +* int source_len (Given) +* The length of the input FORTRAN string +* char *dest_c (Returned via pointer) +* A pointer to the output C string. Can be same as source. + +* Notes: +* - No check is made that there is sufficient space allocated to +* the C string to hold the FORTRAN string and a terminating null. +* It is responsibility of the programmer to check this. +* - This function is equivalent to cnfImprt but is included here to +* avoid SLALIB becoming dependent on CNF. + +* Authors: +* PMA: Peter Allan (Starlink, RAL) +* AJC: Alan Chipperfield (Starlink, RAL) +* TIMJ: Tim Jenness (JAC, Hawaii) +* {enter_new_authors_here} + +* History: +* 27-MAR-1991 (PMA): +* Original version. +* 22-MAY-1996 (AJC): +* Correct description re trailing blanks +* 24-SEP-1998 (AJC): +* Specify const char * for input strings +* 25-NOV-2005 (TIMJ): +* Allow the strings to be identical +* {enter_changes_here} + +*- + +*...........................................................................*/ + +{ +/* Local Variables: */ + + int i; /* Loop counter */ + + +/* Find the last non blank character in the input FORTRAN string. */ + + for( i = source_len - 1 ; ( i >= 0 ) && ( source_f[i] == ' ' ) ; i-- ) + ; + +/* Put a null character at the end of the output C string. */ + + dest_c[i+1] = '\0'; + +/* Copy the characters from the input FORTRAN string to the output C */ +/* string if the strings are different. */ + + if (dest_c != source_f ) { + memmove( dest_c, source_f, (size_t)i+1 ); + } +} + +/* Allocate string buffer dynamically. Taken from cnfCref. + See cnfCref for more details. +*/ + +static F77_CHARACTER_ARG_TYPE *slaStringCreate( int length ) { + /* Local Variables: */ + F77_CHARACTER_ARG_TYPE *ptr; /* A pointer to the string allocated */ + +/* Allocate the space. */ + ptr = (F77_CHARACTER_ARG_TYPE *) + malloc( (size_t)( ( length > 0 ) ? length : 1 ) ); + +/* Check for malloc returning a null value. If it does not, set the string */ +/* to the null character. */ + if ( ptr != 0 ) { + ptr[0] = '\0'; + } + + return( ptr ); +} + +/* Free space allocate by slaStringCreate. Take from cnfFreef */ + +static void slaStringFree ( F77_CHARACTER_ARG_TYPE * temp ) { + free( temp ); +} + + +/* SLALIB wrapper implementations. */ +/* =============================== */ +/* Fortran routine prototype. */ +F77_SUBROUTINE(sla_addet)( DOUBLE(RM), + DOUBLE(DM), + DOUBLE(EQ), + DOUBLE(RC), + DOUBLE(DC) ); + +/* C interface implementation. */ +void slaAddet ( double rm, double dm, double eq, double *rc, double *dc ) { + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + DECLARE_DOUBLE(EQ); + DECLARE_DOUBLE(RC); + DECLARE_DOUBLE(DC); + RM = rm; + DM = dm; + EQ = eq; + F77_LOCK( F77_CALL(sla_addet)( DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM), + DOUBLE_ARG(&EQ), + DOUBLE_ARG(&RC), + DOUBLE_ARG(&DC) ); ) + *rc = RC; + *dc = DC; +} + +/* etc... */ +F77_SUBROUTINE(sla_ampqk)( DOUBLE(RA), + DOUBLE(DA), + DOUBLE_ARRAY(AMPRMS), + DOUBLE(RM), + DOUBLE(DM) ); + +void slaAmpqk ( double ra, double da, double amprms[21], + double *rm, double *dm ) { + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DA); + DECLARE_DOUBLE_ARRAY(AMPRMS,21); + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + int i; + RA = ra; + DA = da; + for ( i = 0; i < 21; i++ ) AMPRMS[ i ] = amprms[ i ]; + F77_LOCK( F77_CALL(sla_ampqk)( DOUBLE_ARG(&RA), + DOUBLE_ARG(&DA), + DOUBLE_ARRAY_ARG(AMPRMS), + DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM) ); ) + *rm = RM; + *dm = DM; +} + +F77_DOUBLE_FUNCTION(sla_airmas)( DOUBLE(ZD) ); + +double slaAirmas( double zd ) { + DECLARE_DOUBLE(ZD); + double result; + ZD = zd; + F77_LOCK( result = F77_CALL(sla_airmas)( DOUBLE_ARG(&ZD) ); ) + return result; +} + +F77_SUBROUTINE(sla_caldj)( INTEGER(IY), + INTEGER(IM), + INTEGER(ID), + DOUBLE(DJM), + INTEGER(J) ); + +void slaCaldj ( int iy, int im, int id, double *djm, int *j ) { + DECLARE_INTEGER(IY); + DECLARE_INTEGER(IM); + DECLARE_INTEGER(ID); + DECLARE_DOUBLE(DJM); + DECLARE_INTEGER(J); + IY = iy; + IM = im; + ID = id; + F77_LOCK( F77_CALL(sla_caldj)( INTEGER_ARG(&IY), + INTEGER_ARG(&IM), + INTEGER_ARG(&ID), + DOUBLE_ARG(&DJM), + INTEGER_ARG(&J) ); ) + *djm = DJM; + *j = J; +} + +F77_SUBROUTINE(sla_daf2r)( INTEGER(IDEG), + INTEGER(IAMIN), + DOUBLE(ASEC), + DOUBLE(RAD), + INTEGER(J) ); + +void slaDaf2r ( int ideg, int iamin, double asec, double *rad, int *j ) { + DECLARE_INTEGER(IDEG); + DECLARE_INTEGER(IAMIN); + DECLARE_DOUBLE(ASEC); + DECLARE_DOUBLE(RAD); + DECLARE_INTEGER(J); + IDEG = ideg; + IAMIN = iamin; + ASEC = asec; + F77_LOCK( F77_CALL(sla_daf2r)( INTEGER_ARG(&IDEG), + INTEGER_ARG(&IAMIN), + DOUBLE_ARG(&ASEC), + DOUBLE_ARG(&RAD), + INTEGER_ARG(&J) ); ) + *rad = RAD; + *j = J; +} + +F77_SUBROUTINE(sla_dav2m)( DOUBLE_ARRAY(AXVEC), + DOUBLE_ARRAY(RMAT) ); + +void slaDav2m ( double axvec[3], double rmat[3][3] ) { + DECLARE_DOUBLE_ARRAY(AXVEC,3); + DECLARE_DOUBLE_ARRAY(RMAT,9); + int i; + int j; + for ( i = 0; i < 3; i++ ) AXVEC[ i ] = axvec[ i ]; + F77_LOCK( F77_CALL(sla_dav2m)( DOUBLE_ARRAY_ARG(AXVEC), + DOUBLE_ARRAY_ARG(RMAT) ); ) + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) rmat[ i ][ j ] = RMAT[ i + 3 * j ]; + } +} + +F77_SUBROUTINE(sla_dcc2s)( DOUBLE_ARRAY(V), + DOUBLE(A), + DOUBLE(B) ); + +void slaDcc2s ( double v[3], double *a, double *b ) { + DECLARE_DOUBLE_ARRAY(V,3); + DECLARE_DOUBLE(A); + DECLARE_DOUBLE(B); + int i; + for ( i = 0; i < 3; i++ ) V[ i ] = v[ i ]; + F77_LOCK( F77_CALL(sla_dcc2s)( DOUBLE_ARRAY_ARG(V), + DOUBLE_ARG(&A), + DOUBLE_ARG(&B) ); ) + *a = A; + *b = B; +} + +F77_SUBROUTINE(sla_dcs2c)( DOUBLE(A), + DOUBLE(B), + DOUBLE_ARRAY(V) ); + +void slaDcs2c ( double a, double b, double v[3] ) { + DECLARE_DOUBLE(A); + DECLARE_DOUBLE(B); + DECLARE_DOUBLE_ARRAY(V,3); + int i; + A = a; + B = b; + F77_LOCK( F77_CALL(sla_dcs2c)( DOUBLE_ARG(&A), + DOUBLE_ARG(&B), + DOUBLE_ARRAY_ARG(V) ); ) + for ( i = 0; i < 3; i++ ) v[ i ] = V[ i ]; +} + +F77_SUBROUTINE(sla_dd2tf)( INTEGER(NDP), + DOUBLE(DAYS), + CHARACTER(SIGN), + INTEGER_ARRAY(IHMSF) + TRAIL(SIGN) ); + +void slaDd2tf ( int ndp, double days, char *sign, int ihmsf[4] ) { + DECLARE_INTEGER(NDP); + DECLARE_DOUBLE(DAYS); + DECLARE_CHARACTER(SIGN,2); + DECLARE_INTEGER_ARRAY(IHMSF,4); + int i; + + NDP = ndp; + DAYS = days; + F77_LOCK( F77_CALL(sla_dd2tf)( INTEGER_ARG(&NDP), + DOUBLE_ARG(&DAYS), + CHARACTER_ARG(SIGN), + INTEGER_ARRAY_ARG(IHMSF) + TRAIL_ARG(SIGN) ); ) + sign[0] = SIGN[0]; + sign[1] = 0; + for ( i = 0; i < 4; i++ ) ihmsf[ i ] = IHMSF[ i ]; +} + +F77_SUBROUTINE(sla_dr2tf)( INTEGER(NDP), + DOUBLE(ANGLE), + CHARACTER(SIGN), + INTEGER_ARRAY(IHMSF) + TRAIL(SIGN) ); + +void +slaDr2tf( int ndp, double angle, char * sign, int ihmsf[4] ) { + DECLARE_INTEGER(NDP); + DECLARE_DOUBLE(ANGLE); + DECLARE_CHARACTER(SIGN,2); + DECLARE_INTEGER_ARRAY(IHMSF,4); + int i; + + NDP = ndp; + ANGLE = angle; + F77_LOCK( F77_CALL(sla_dr2tf)( INTEGER_ARG(&NDP), + DOUBLE_ARG(&ANGLE), + CHARACTER_ARG(SIGN), + INTEGER_ARRAY_ARG(IHMSF) + TRAIL_ARG(SIGN) ); ) + sign[0] = SIGN[0]; + sign[1] = 0; + for ( i = 0; i < 4; i++ ) ihmsf[ i ] = IHMSF[ i ]; +} + +F77_SUBROUTINE(sla_dr2af)( INTEGER(NDP), + DOUBLE(ANGLE), + CHARACTER(SIGN), + INTEGER_ARRAY(IDMSF) + TRAIL(SIGN) ); + +void +slaDr2af( int ndp, double angle, char * sign, int idmsf[4] ) { + DECLARE_INTEGER(NDP); + DECLARE_DOUBLE(ANGLE); + DECLARE_CHARACTER(SIGN,2); + DECLARE_INTEGER_ARRAY(IDMSF,4); + int i; + + NDP = ndp; + ANGLE = angle; + F77_LOCK( F77_CALL(sla_dr2af)( INTEGER_ARG(&NDP), + DOUBLE_ARG(&ANGLE), + CHARACTER_ARG(SIGN), + INTEGER_ARRAY_ARG(IDMSF) + TRAIL_ARG(SIGN) ); ) + sign[0] = SIGN[0]; + sign[1] = 0; + for ( i = 0; i < 4; i++ ) idmsf[ i ] = IDMSF[ i ]; +} + +F77_SUBROUTINE(sla_dimxv)( DOUBLE_ARRAY(DM), + DOUBLE_ARRAY(VA), + DOUBLE_ARRAY(VB) ); + +void slaDimxv ( double dm[3][3], double va[3], double vb[3] ) { + DECLARE_DOUBLE_ARRAY(DM,9); + DECLARE_DOUBLE_ARRAY(VA,3); + DECLARE_DOUBLE_ARRAY(VB,3); + int i; + int j; + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) DM[ i + j * 3 ] = dm[ i ][ j ]; + VA[ i ] = va[ i ]; + } + F77_LOCK( F77_CALL(sla_dimxv)( DOUBLE_ARRAY_ARG(DM), + DOUBLE_ARRAY_ARG(VA), + DOUBLE_ARRAY_ARG(VB) ); ) + for ( i = 0; i < 3; i++ ) vb[ i ] = VB[ i ]; +} + +F77_SUBROUTINE(sla_djcal)( INTEGER(NDP), + DOUBLE(DJM), + INTEGER_ARRAY(IYMDF), + INTEGER(J) ); + +void slaDjcal ( int ndp, double djm, int iymdf[ 4 ], int *j ) { + DECLARE_INTEGER(NDP); + DECLARE_DOUBLE(DJM); + DECLARE_INTEGER_ARRAY(IYMDF,4); + DECLARE_INTEGER(J); + int i; + + NDP = ndp; + DJM = djm; + F77_LOCK( F77_CALL(sla_djcal)( INTEGER_ARG(&NDP), + DOUBLE_ARG(&DJM), + INTEGER_ARRAY_ARG(IYMDF), + INTEGER_ARG(&J) ); ) + for ( i = 0; i < 4; i++ ) iymdf[ i ] = IYMDF[ i ]; + *j = J; +} + +F77_SUBROUTINE(sla_djcl)( DOUBLE(DJM), + INTEGER(IY), + INTEGER(IM), + INTEGER(ID), + DOUBLE(FD), + INTEGER(J) ); + +void slaDjcl ( double djm, int *iy, int *im, int *id, double *fd, int *j ) { + DECLARE_DOUBLE(DJM); + DECLARE_INTEGER(IY); + DECLARE_INTEGER(IM); + DECLARE_INTEGER(ID); + DECLARE_DOUBLE(FD); + DECLARE_INTEGER(J); + + DJM = djm; + F77_LOCK( F77_CALL(sla_djcl)( DOUBLE_ARG(&DJM), + INTEGER_ARG(&IY), + INTEGER_ARG(&IM), + INTEGER_ARG(&ID), + DOUBLE_ARG(&FD), + INTEGER_ARG(&J) ); ) + *iy = IY; + *im = IM; + *id = ID; + *fd = FD; + *j = J; +} + +F77_SUBROUTINE(sla_dmat)( INTEGER(N), + DOUBLE_ARRAY(A), + DOUBLE_ARRAY(Y), + DOUBLE(D), + INTEGER(JF), + INTEGER_ARRAY(IW) ); + +void slaDmat ( int n, double *a, double *y, double *d, int *jf, int *iw ) { + DECLARE_INTEGER(N); + F77_DOUBLE_TYPE *A; + F77_DOUBLE_TYPE *Y; + DECLARE_DOUBLE(D); + DECLARE_INTEGER(JF); + F77_INTEGER_TYPE *IW; + int i; + int j; + A = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( n * n ) ); + Y = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + if ( sizeof( F77_INTEGER_TYPE ) > sizeof( int ) ) { + IW = malloc( sizeof( F77_INTEGER_TYPE ) * (size_t) n ); + } else { + IW = (F77_INTEGER_TYPE *) iw; + } + if ( IW ) { + N = n; + for ( i = 0; i < n; i++ ) { + for ( j = 0; j < n; j++ ) A[ i + n * j ] = a[ n * i + j ]; + Y[ i ] = y[ i ]; + } + F77_LOCK( F77_CALL(sla_dmat)( INTEGER_ARG(&N), DOUBLE_ARRAY_ARG(A), + DOUBLE_ARRAY_ARG(Y), DOUBLE_ARG(&D), + INTEGER_ARG(&JF), INTEGER_ARG(IW) ); ) + for ( i = 0; i < n; i++ ) { + for ( j = 0; j < n; j++ ) a[ n * i + j ] = A[ i + n * j ]; + y[ i ] = Y[ i ]; + } + *d = D; + *jf = JF; + } + free( A ); + free( Y ); + if ( sizeof( F77_INTEGER_TYPE ) > sizeof( int ) ) free( IW ); +} + +F77_SUBROUTINE(sla_dmxm)( DOUBLE_ARRAY(A), + DOUBLE_ARRAY(B), + DOUBLE_ARRAY(C) ); + +void slaDmxm ( double a[3][3], double b[3][3], double c[3][3] ) { + DECLARE_DOUBLE_ARRAY(A,9); + DECLARE_DOUBLE_ARRAY(B,9); + DECLARE_DOUBLE_ARRAY(C,9); + int i; + int j; + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) { + A[ i + 3 * j ] = a[ i ][ j ]; + B[ i + 3 * j ] = b[ i ][ j ]; + } + } + F77_LOCK( F77_CALL(sla_dmxm)( DOUBLE_ARRAY_ARG(A), + DOUBLE_ARRAY_ARG(B), + DOUBLE_ARRAY_ARG(C) ); ) + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) c[ i ][ j ] = C[ i + 3 * j ]; + } +} + +F77_SUBROUTINE(sla_dmxv)( DOUBLE_ARRAY(DM), + DOUBLE_ARRAY(VA), + DOUBLE_ARRAY(VB) ); + +void slaDmxv ( double dm[3][3], double va[3], double vb[3] ) { + DECLARE_DOUBLE_ARRAY(DM,9); + DECLARE_DOUBLE_ARRAY(VA,3); + DECLARE_DOUBLE_ARRAY(VB,3); + int i; + int j; + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) DM[ i + 3 * j ] = dm[ i ][ j ]; + VA[ i ] = va[ i ]; + } + F77_LOCK( F77_CALL(sla_dmxv)( DOUBLE_ARRAY_ARG(DM), + DOUBLE_ARRAY_ARG(VA), + DOUBLE_ARRAY_ARG(VB) ); ) + for ( i = 0; i < 3; i++ ) vb[ i ] = VB[ i ]; +} + +F77_DOUBLE_FUNCTION(sla_dbear)( DOUBLE(A1), DOUBLE(B1), + DOUBLE(A2), DOUBLE(B2) ); + +double slaDbear ( double a1, double b1, double a2, double b2 ) { + DECLARE_DOUBLE(A1); + DECLARE_DOUBLE(B1); + DECLARE_DOUBLE(A2); + DECLARE_DOUBLE(B2); + double result; + A1 = a1; + B1 = b1; + A2 = a2; + B2 = b2; + F77_LOCK( result = F77_CALL(sla_dbear)( DOUBLE_ARG(&A1), DOUBLE_ARG(&B1), + DOUBLE_ARG(&A2), DOUBLE_ARG(&B2) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_drange)( DOUBLE(ANGLE) ); + +double slaDrange ( double angle ) { + DECLARE_DOUBLE(ANGLE); + double result; + ANGLE = angle; + F77_LOCK( result = F77_CALL(sla_drange)( DOUBLE_ARG(&ANGLE) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_dranrm)( DOUBLE(ANGLE) ); + +double slaDranrm ( double angle ) { + DECLARE_DOUBLE(ANGLE); + double result; + ANGLE = angle; + F77_LOCK( result = F77_CALL(sla_dranrm)( DOUBLE_ARG(&ANGLE) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_dsep)( DOUBLE(A1), + DOUBLE(B1), + DOUBLE(A2), + DOUBLE(B2) ); + +double slaDsep ( double a1, double b1, double a2, double b2 ) { + DECLARE_DOUBLE(A1); + DECLARE_DOUBLE(B1); + DECLARE_DOUBLE(A2); + DECLARE_DOUBLE(B2); + double result; + A1 = a1; + B1 = b1; + A2 = a2; + B2 = b2; + F77_LOCK( result = F77_CALL(sla_dsep)( DOUBLE_ARG(&A1), + DOUBLE_ARG(&B1), + DOUBLE_ARG(&A2), + DOUBLE_ARG(&B2) ); ) + return result; +} + +F77_SUBROUTINE(sla_ds2tp)( DOUBLE(RA), DOUBLE(DEC), + DOUBLE(RAZ), DOUBLE(DECZ), + DOUBLE(XI), DOUBLE(ETA), + INTEGER(J) ); + +void slaDs2tp ( double ra, double dec, double raz, double decz, double * xi, double * eta, int* j ) { + + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DEC); + DECLARE_DOUBLE(RAZ); + DECLARE_DOUBLE(DECZ); + DECLARE_DOUBLE(XI); + DECLARE_DOUBLE(ETA); + DECLARE_INTEGER(J); + + F77_EXPORT_DOUBLE(ra, RA); + F77_EXPORT_DOUBLE(dec, DEC); + F77_EXPORT_DOUBLE(raz, RAZ); + F77_EXPORT_DOUBLE(decz, DECZ); + + F77_LOCK( F77_CALL(sla_ds2tp)( DOUBLE_ARG(&RA), + DOUBLE_ARG(&DEC), + DOUBLE_ARG(&RAZ), + DOUBLE_ARG(&DECZ), + DOUBLE_ARG(&XI), + DOUBLE_ARG(&ETA), + INTEGER_ARG(&J) ); ) + + F77_IMPORT_DOUBLE(XI, *xi); + F77_IMPORT_DOUBLE(ETA, *eta); + F77_IMPORT_DOUBLE(J, *j); + +} + +F77_DOUBLE_FUNCTION(sla_dvdv)( DOUBLE_ARRAY(VA), + DOUBLE_ARRAY(VB) ); + +double slaDvdv( double va[3], double vb[3] ) { + DECLARE_DOUBLE_ARRAY(VA,3); + DECLARE_DOUBLE_ARRAY(VB,3); + double result; + int i; + for ( i = 0; i < 3; i++ ) { + VA[ i ] = va[ i ]; + VB[ i ] = vb[ i ]; + } + F77_LOCK( result = F77_CALL(sla_dvdv)( DOUBLE_ARRAY_ARG(VA), + DOUBLE_ARRAY_ARG(VB) ); ) + return result; +} + +F77_SUBROUTINE(sla_dtf2d)( INTEGER(IHOUR), + INTEGER(IMIN), + DOUBLE(SEC), + DOUBLE(DAYS), + INTEGER(J) ); + +void slaDtf2d ( int ihour, int imin, double sec, double *days, int *j ) { + DECLARE_INTEGER(IHOUR); + DECLARE_INTEGER(IMIN); + DECLARE_DOUBLE(SEC); + DECLARE_DOUBLE(DAYS); + DECLARE_INTEGER(J); + IHOUR = ihour; + IMIN = imin; + SEC = sec; + F77_LOCK( F77_CALL(sla_dtf2d)( INTEGER_ARG(&IHOUR), + INTEGER_ARG(&IMIN), + DOUBLE_ARG(&SEC), + DOUBLE_ARG(&DAYS), + INTEGER_ARG(&J) ); ) + *days = DAYS; + *j = J; +} + +F77_SUBROUTINE(sla_dtf2r)( INTEGER(IHOUR), + INTEGER(IMIN), + DOUBLE(SEC), + DOUBLE(RAD), + INTEGER(J) ); + +void slaDtf2r ( int ihour, int imin, double sec, double *rad, int *j ) { + DECLARE_INTEGER(IHOUR); + DECLARE_INTEGER(IMIN); + DECLARE_DOUBLE(SEC); + DECLARE_DOUBLE(RAD); + DECLARE_INTEGER(J); + IHOUR = ihour; + IMIN = imin; + SEC = sec; + F77_LOCK( F77_CALL(sla_dtf2r)( INTEGER_ARG(&IHOUR), + INTEGER_ARG(&IMIN), + DOUBLE_ARG(&SEC), + DOUBLE_ARG(&RAD), + INTEGER_ARG(&J) ); ) + *rad = RAD; + *j = J; +} + +F77_DOUBLE_FUNCTION(sla_dt)( DOUBLE(EPOCH) ); + +double slaDt ( double epoch ) +{ + DECLARE_DOUBLE(EPOCH); + double result; + EPOCH = epoch; + F77_LOCK( result = F77_CALL(sla_dt)( DOUBLE_ARG(&EPOCH) ); ) + return result; +} + +F77_SUBROUTINE(sla_dvn)( DOUBLE_ARRAY(V), + DOUBLE_ARRAY(UV), + DOUBLE(VM) ); + +void slaDvn ( double v[3], double uv[3], double *vm ) { + DECLARE_DOUBLE_ARRAY(V,3); + DECLARE_DOUBLE_ARRAY(UV,3); + DECLARE_DOUBLE(VM); + int i; + for ( i = 0; i < 3; i++ ) V[ i ] = v[ i ]; + F77_LOCK( F77_CALL(sla_dvn)( DOUBLE_ARRAY_ARG(V), + DOUBLE_ARRAY_ARG(UV), + DOUBLE_ARG(&VM) ); ) + for ( i = 0; i < 3; i++ ) uv[ i ] = UV[ i ]; + *vm = VM; +} + +F77_SUBROUTINE(sla_dvxv)( DOUBLE_ARRAY(VA), + DOUBLE_ARRAY(VB), + DOUBLE_ARRAY(VC) ); + +void slaDvxv ( double va[3], double vb[3], double vc[3] ) { + DECLARE_DOUBLE_ARRAY(VA,3); + DECLARE_DOUBLE_ARRAY(VB,3); + DECLARE_DOUBLE_ARRAY(VC,3); + int i; + for ( i = 0; i < 3; i++ ) { + VA[ i ] = va[ i ]; + VB[ i ] = vb[ i ]; + } + F77_LOCK( F77_CALL(sla_dvxv)( DOUBLE_ARRAY_ARG(VA), + DOUBLE_ARRAY_ARG(VB), + DOUBLE_ARRAY_ARG(VC) ); ) + for ( i = 0; i < 3; i++ ) vc[ i ] = VC[ i ]; +} + +F77_SUBROUTINE(sla_ecmat)( DOUBLE(DATE), + DOUBLE_ARRAY(RMAT) ); + +void slaEcmat ( double date, double rmat[3][3] ) { + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE_ARRAY(RMAT,9); + int i; + int j; + DATE = date; + F77_LOCK( F77_CALL(sla_ecmat)( DOUBLE_ARG(&DATE), + DOUBLE_ARRAY_ARG(RMAT) ); ) + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) rmat[ i ][ j ] = RMAT[ i + 3 * j ]; + } +} + +F77_DOUBLE_FUNCTION(sla_epb)( DOUBLE(DATE) ); + +double slaEpb ( double date ) { + DECLARE_DOUBLE(DATE); + double result; + DATE = date; + F77_LOCK( result = F77_CALL(sla_epb)( DOUBLE_ARG(&DATE) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_epb2d)( DOUBLE(EPB) ); + +double slaEpb2d ( double epb ) { + DECLARE_DOUBLE(EPB); + double result; + EPB = epb; + F77_LOCK( result = F77_CALL(sla_epb2d)( DOUBLE_ARG(&EPB) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_epj)( DOUBLE(DATE) ); + +double slaEpj ( double date ) { + DECLARE_DOUBLE(DATE); + double result; + DATE = date; + F77_LOCK( result = F77_CALL(sla_epj)( DOUBLE_ARG(&DATE) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_epj2d)( DOUBLE(EPJ) ); + +double slaEpj2d ( double epj ) { + DECLARE_DOUBLE(EPJ); + double result; + EPJ = epj; + F77_LOCK( result = F77_CALL(sla_epj2d)( DOUBLE_ARG(&EPJ) ); ) + return result; +} + +F77_DOUBLE_FUNCTION(sla_eqeqx)( DOUBLE(DATE) ); + +double slaEqeqx ( double date ) { + DECLARE_DOUBLE(DATE); + double result; + DATE = date; + F77_LOCK( result = F77_CALL(sla_eqeqx)( DOUBLE_ARG(&DATE) ); ) + return result; +} + +F77_SUBROUTINE(sla_eqgal)( DOUBLE(DR), + DOUBLE(DD), + DOUBLE(DL), + DOUBLE(DB) ); + +void slaEqgal ( double dr, double dd, double *dl, double *db ) { + DECLARE_DOUBLE(DR); + DECLARE_DOUBLE(DD); + DECLARE_DOUBLE(DL); + DECLARE_DOUBLE(DB); + DR = dr; + DD = dd; + F77_LOCK( F77_CALL(sla_eqgal)( DOUBLE_ARG(&DR), + DOUBLE_ARG(&DD), + DOUBLE_ARG(&DL), + DOUBLE_ARG(&DB) ); ) + *dl = DL; + *db = DB; +} + +F77_SUBROUTINE(sla_fk45z)( DOUBLE(R1950), + DOUBLE(D1950), + DOUBLE(BEPOCH), + DOUBLE(R2000), + DOUBLE(D2000) ); + +void slaFk45z ( double r1950, double d1950, double bepoch, + double *r2000, double *d2000 ) { + DECLARE_DOUBLE(R1950); + DECLARE_DOUBLE(D1950); + DECLARE_DOUBLE(BEPOCH); + DECLARE_DOUBLE(R2000); + DECLARE_DOUBLE(D2000); + R1950 = r1950; + D1950 = d1950; + BEPOCH = bepoch; + F77_LOCK( F77_CALL(sla_fk45z)( DOUBLE_ARG(&R1950), + DOUBLE_ARG(&D1950), + DOUBLE_ARG(&BEPOCH), + DOUBLE_ARG(&R2000), + DOUBLE_ARG(&D2000) ); ) + *r2000 = R2000; + *d2000 = D2000; +} + +F77_SUBROUTINE(sla_fk54z)( DOUBLE(R2000), + DOUBLE(D2000), + DOUBLE(BEPOCH), + DOUBLE(R1950), + DOUBLE(D1950), + DOUBLE(DR1950), + DOUBLE(DD1950) ); + +void slaFk54z ( double r2000, double d2000, double bepoch, + double *r1950, double *d1950, + double *dr1950, double *dd1950 ) { + DECLARE_DOUBLE(R2000); + DECLARE_DOUBLE(D2000); + DECLARE_DOUBLE(BEPOCH); + DECLARE_DOUBLE(R1950); + DECLARE_DOUBLE(D1950); + DECLARE_DOUBLE(DR1950); + DECLARE_DOUBLE(DD1950); + R2000 = r2000; + D2000 = d2000; + BEPOCH = bepoch; + F77_LOCK( F77_CALL(sla_fk54z)( DOUBLE_ARG(&R2000), + DOUBLE_ARG(&D2000), + DOUBLE_ARG(&BEPOCH), + DOUBLE_ARG(&R1950), + DOUBLE_ARG(&D1950), + DOUBLE_ARG(&DR1950), + DOUBLE_ARG(&DD1950) ); ) + *r1950 = R1950; + *d1950 = D1950; + *dr1950 = DR1950; + *dd1950 = DD1950; +} + +F77_SUBROUTINE(sla_galeq)( DOUBLE(DL), + DOUBLE(DB), + DOUBLE(DR), + DOUBLE(DD) ); + +void slaGaleq ( double dl, double db, double *dr, double *dd ) { + DECLARE_DOUBLE(DL); + DECLARE_DOUBLE(DB); + DECLARE_DOUBLE(DR); + DECLARE_DOUBLE(DD); + DL = dl; + DB = db; + F77_LOCK( F77_CALL(sla_galeq)( DOUBLE_ARG(&DL), + DOUBLE_ARG(&DB), + DOUBLE_ARG(&DR), + DOUBLE_ARG(&DD) ); ) + *dr = DR; + *dd = DD; +} + +F77_SUBROUTINE(sla_galsup)( DOUBLE(DL), + DOUBLE(DB), + DOUBLE(DSL), + DOUBLE(DSB) ); + +void slaGalsup ( double dl, double db, double *dsl, double *dsb ) { + DECLARE_DOUBLE(DL); + DECLARE_DOUBLE(DB); + DECLARE_DOUBLE(DSL); + DECLARE_DOUBLE(DSB); + DL = dl; + DB = db; + F77_LOCK( F77_CALL(sla_galsup)( DOUBLE_ARG(&DL), + DOUBLE_ARG(&DB), + DOUBLE_ARG(&DSL), + DOUBLE_ARG(&DSB) ); ) + *dsl = DSL; + *dsb = DSB; +} + +F77_DOUBLE_FUNCTION(sla_gmst)( DOUBLE(UT1) ); + +double slaGmst ( double ut1 ) { + DECLARE_DOUBLE(UT1); + double result; + UT1 = ut1; + F77_LOCK( result = F77_CALL(sla_gmst)( DOUBLE_ARG(&UT1) ); ) + return result; +} + +F77_SUBROUTINE(sla_mappa)( DOUBLE(EQ), + DOUBLE(DATE), + DOUBLE_ARRAY(AMPRMS) ); + +void slaMappa ( double eq, double date, double amprms[21] ) { + DECLARE_DOUBLE(EQ); + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE_ARRAY(AMPRMS,21); + int i; + EQ = eq; + DATE = date; + F77_LOCK( F77_CALL(sla_mappa)( DOUBLE_ARG(&EQ), + DOUBLE_ARG(&DATE), + DOUBLE_ARRAY_ARG(AMPRMS) ); ) + for ( i = 0; i < 21; i++ ) amprms[ i ] = AMPRMS[ i ]; +} + +F77_SUBROUTINE(sla_map)(DOUBLE(RM), DOUBLE(DM), + DOUBLE(PR), DOUBLE(PD), + DOUBLE(PX), + DOUBLE(RV), + DOUBLE(EQ), + DOUBLE(DATE), + DOUBLE(RA), DOUBLE(DA) ); + +void +slaMap( double rm, double dm, double pr, double pd, double px, + double rv, double eq, double date, double * ra, double * da ) { + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + DECLARE_DOUBLE(PR); + DECLARE_DOUBLE(PD); + DECLARE_DOUBLE(PX); + DECLARE_DOUBLE(RV); + DECLARE_DOUBLE(EQ); + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DA); + + F77_EXPORT_DOUBLE(rm,RM); + F77_EXPORT_DOUBLE(dm,DM); + F77_EXPORT_DOUBLE(pr,PR); + F77_EXPORT_DOUBLE(pd,PD); + F77_EXPORT_DOUBLE(px,PX); + F77_EXPORT_DOUBLE(rv,RV); + F77_EXPORT_DOUBLE(eq,EQ); + F77_EXPORT_DOUBLE(date,DATE); + + F77_LOCK( F77_CALL(sla_map)( DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM), + DOUBLE_ARG(&PR), + DOUBLE_ARG(&PD), + DOUBLE_ARG(&PX), + DOUBLE_ARG(&RV), + DOUBLE_ARG(&EQ), + DOUBLE_ARG(&DATE), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DA) + ); ) + + + F77_IMPORT_DOUBLE(RA, *ra); + F77_IMPORT_DOUBLE(DA, *da); +} + + +F77_SUBROUTINE(sla_mapqkz)( DOUBLE(RM), + DOUBLE(DM), + DOUBLE_ARRAY(AMPRMS), + DOUBLE(RA), + DOUBLE(DA) ); + +void slaMapqkz ( double rm, double dm, double amprms[21], + double *ra, double *da ) { + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + DECLARE_DOUBLE_ARRAY(AMPRMS,21); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DA); + int i; + RM = rm; + DM = dm; + for ( i = 0; i < 21; i++ ) AMPRMS[ i ] = amprms[ i ]; + F77_LOCK( F77_CALL(sla_mapqkz)( DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM), + DOUBLE_ARRAY_ARG(AMPRMS), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DA) ); ) + *ra = RA; + *da = DA; +} + +F77_SUBROUTINE(sla_mapqk)( DOUBLE(RM), + DOUBLE(DM), + DOUBLE(PR), + DOUBLE(PD), + DOUBLE(PX), + DOUBLE(RV), + DOUBLE_ARRAY(AMPRMS), + DOUBLE(RA), + DOUBLE(DA) ); + +void slaMapqk ( double rm, double dm, double pr, double pd, + double px, double rv, double amprms[21], + double *ra, double *da ) { + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + DECLARE_DOUBLE(PR); + DECLARE_DOUBLE(PD); + DECLARE_DOUBLE(PX); + DECLARE_DOUBLE(RV); + DECLARE_DOUBLE_ARRAY(AMPRMS,21); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DA); + int i; + RM = rm; + DM = dm; + PR = pr; + PD = pd; + PX = px; + RV = rv; + for ( i = 0; i < 21; i++ ) AMPRMS[ i ] = amprms[ i ]; + F77_LOCK( F77_CALL(sla_mapqk)( DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM), + DOUBLE_ARG(&PR), + DOUBLE_ARG(&PD), + DOUBLE_ARG(&PX), + DOUBLE_ARG(&RV), + DOUBLE_ARRAY_ARG(AMPRMS), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DA) ); ) + *ra = RA; + *da = DA; +} + +F77_SUBROUTINE(sla_prebn)( DOUBLE(BEP0), + DOUBLE(BEP1), + DOUBLE_ARRAY(RMATP) ); + +void slaPrebn ( double bep0, double bep1, double rmatp[3][3] ) { + DECLARE_DOUBLE(BEP0); + DECLARE_DOUBLE(BEP1); + DECLARE_DOUBLE_ARRAY(RMATP,9); + int i; + int j; + BEP0 = bep0; + BEP1 = bep1; + F77_LOCK( F77_CALL(sla_prebn)( DOUBLE_ARG(&BEP0), + DOUBLE_ARG(&BEP1), + DOUBLE_ARRAY_ARG(RMATP) ); ) + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) rmatp[ i ][ j ] = RMATP[ i + 3 * j ]; + } +} + +F77_SUBROUTINE(sla_prec)( DOUBLE(EP0), + DOUBLE(EP1), + DOUBLE_ARRAY(RMATP) ); + +void slaPrec ( double ep0, double ep1, double rmatp[3][3] ) { + DECLARE_DOUBLE(EP0); + DECLARE_DOUBLE(EP1); + DECLARE_DOUBLE_ARRAY(RMATP,9); + int i; + int j; + EP0 = ep0; + EP1 = ep1; + F77_LOCK( F77_CALL(sla_prec)( DOUBLE_ARG(&EP0), + DOUBLE_ARG(&EP1), + DOUBLE_ARRAY_ARG(RMATP) ); ) + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) rmatp[ i ][ j ] = RMATP[ i + 3 * j ]; + } +} + +F77_REAL_FUNCTION(sla_rverot)( REAL(PHI), + REAL(RA), + REAL(DEC), + REAL(ST) ); + +float slaRverot ( float phi, float ra, float dec, float st ) { + DECLARE_REAL(PHI); + DECLARE_REAL(RA); + DECLARE_REAL(DEC); + DECLARE_REAL(ST); + float result; + PHI = phi; + RA = ra; + DEC = dec; + ST = st; + F77_LOCK( result = F77_CALL(sla_rverot)( REAL_ARG(&PHI), + REAL_ARG(&RA), + REAL_ARG(&DEC), + REAL_ARG(&ST) ); ) + return result; +} + +F77_REAL_FUNCTION(sla_rvgalc)( REAL(RA), + REAL(DEC) ); + +float slaRvgalc ( float ra, float dec ) { + DECLARE_REAL(RA); + DECLARE_REAL(DEC); + float result; + RA = ra; + DEC = dec; + F77_LOCK( result = F77_CALL(sla_rvgalc)( REAL_ARG(&RA), + REAL_ARG(&DEC) ); ) + return result; +} + +F77_REAL_FUNCTION(sla_rvlg)( REAL(RA), + REAL(DEC) ); + +float slaRvlg ( float ra, float dec ) { + DECLARE_REAL(RA); + DECLARE_REAL(DEC); + float result; + RA = ra; + DEC = dec; + F77_LOCK( result = F77_CALL(sla_rvlg)( REAL_ARG(&RA), + REAL_ARG(&DEC) ); ) + return result; +} + +F77_REAL_FUNCTION(sla_rvlsrd)( REAL(RA), + REAL(DEC) ); + +float slaRvlsrd ( float ra, float dec ) { + DECLARE_REAL(RA); + DECLARE_REAL(DEC); + float result; + RA = ra; + DEC = dec; + F77_LOCK( result = F77_CALL(sla_rvlsrd)( REAL_ARG(&RA), + REAL_ARG(&DEC) ); ) + return result; +} + +F77_REAL_FUNCTION(sla_rvlsrk)( REAL(RA), + REAL(DEC) ); + +float slaRvlsrk ( float ra, float dec ) { + DECLARE_REAL(RA); + DECLARE_REAL(DEC); + float result; + RA = ra; + DEC = dec; + F77_LOCK( result = F77_CALL(sla_rvlsrk)( REAL_ARG(&RA), + REAL_ARG(&DEC) ); ) + return result; +} + + +F77_SUBROUTINE(sla_subet)( DOUBLE(RC), + DOUBLE(DC), + DOUBLE(EQ), + DOUBLE(RM), + DOUBLE(DM) ); + +void slaSubet ( double rc, double dc, double eq, double *rm, double *dm ) { + DECLARE_DOUBLE(RC); + DECLARE_DOUBLE(DC); + DECLARE_DOUBLE(EQ); + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + RC = rc; + DC = dc; + EQ = eq; + F77_LOCK( F77_CALL(sla_subet)( DOUBLE_ARG(&RC), + DOUBLE_ARG(&DC), + DOUBLE_ARG(&EQ), + DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM) ); ) + *rm = RM; + *dm = DM; +} + +F77_SUBROUTINE(sla_supgal)( DOUBLE(DSL), + DOUBLE(DSB), + DOUBLE(DL), + DOUBLE(DB) ); + +void slaSupgal ( double dsl, double dsb, double *dl, double *db ) { + DECLARE_DOUBLE(DSL); + DECLARE_DOUBLE(DSB); + DECLARE_DOUBLE(DL); + DECLARE_DOUBLE(DB); + DSL = dsl; + DSB = dsb; + F77_LOCK( F77_CALL(sla_supgal)( DOUBLE_ARG(&DSL), + DOUBLE_ARG(&DSB), + DOUBLE_ARG(&DL), + DOUBLE_ARG(&DB) ); ) + *dl = DL; + *db = DB; +} + + + +F77_SUBROUTINE(sla_svd)( INTEGER(M), + INTEGER(N), + INTEGER(MP), + INTEGER(NP), + DOUBLE_ARRAY(A), + DOUBLE_ARRAY(W), + DOUBLE_ARRAY(V), + DOUBLE_ARRAY(WORK), + INTEGER(JSTAT) ); + +void slaSvd ( int m, int n, int mp, int np, + double *a, double *w, double *v, double *work, + int *jstat ){ + DECLARE_INTEGER(M); + DECLARE_INTEGER(N); + DECLARE_INTEGER(MP); + DECLARE_INTEGER(NP); + F77_DOUBLE_TYPE *A; + F77_DOUBLE_TYPE *W; + F77_DOUBLE_TYPE *V; + F77_DOUBLE_TYPE *WORK; + DECLARE_INTEGER(JSTAT); + + + int i; + int j; + + A = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( mp * np ) ); + W = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + V = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( np * np ) ); + WORK = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + + if ( WORK ) { + M = m; + N = n; + MP = mp; + NP = np; + + for ( i = 0; i < m; i++ ) { + for ( j = 0; j < n; j++ ) A[ i + mp * j ] = a[ np * i + j ]; + } + + F77_LOCK( F77_CALL(sla_svd)( INTEGER_ARG(&M), + INTEGER_ARG(&N), + INTEGER_ARG(&MP), + INTEGER_ARG(&NP), + DOUBLE_ARRAY_ARG(A), + DOUBLE_ARRAY_ARG(W), + DOUBLE_ARRAY_ARG(V), + DOUBLE_ARRAY_ARG(WORK), + INTEGER_ARG(&JSTAT) ); ) + + + for ( i = 0; i < m; i++ ) { + for ( j = 0; j < n; j++ ) a[ np * i + j ] = A[ i + mp * j ]; + } + + for ( i = 0; i < n; i++ ) { + w[ i ] = W[ i ]; + work[ i ] = WORK[ i ]; + for ( j = 0; j < n; j++ ) v[ np * i + j ] = V[ i + np * j ]; + } + + *jstat = JSTAT; + } + + free( A ); + free( W ); + free( V ); + free( WORK ); +} + +F77_SUBROUTINE(sla_svdsol)( INTEGER(M), + INTEGER(N), + INTEGER(MP), + INTEGER(NP), + DOUBLE_ARRAY(B), + DOUBLE_ARRAY(U), + DOUBLE_ARRAY(W), + DOUBLE_ARRAY(V), + DOUBLE_ARRAY(WORK), + DOUBLE_ARRAY(X) ); + +void slaSvdsol ( int m, int n, int mp, int np, + double *b, double *u, double *w, double *v, + double *work, double *x ){ + + DECLARE_INTEGER(M); + DECLARE_INTEGER(N); + DECLARE_INTEGER(MP); + DECLARE_INTEGER(NP); + F77_DOUBLE_TYPE *B; + F77_DOUBLE_TYPE *U; + F77_DOUBLE_TYPE *W; + F77_DOUBLE_TYPE *V; + F77_DOUBLE_TYPE *WORK; + F77_DOUBLE_TYPE *X; + + int i; + int j; + + B = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( m ) ); + U = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( mp * np ) ); + W = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + V = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) ( np * np ) ); + WORK = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + X = malloc( sizeof( F77_DOUBLE_TYPE ) * (size_t) n ); + + if ( X ) { + M = m; + N = n; + MP = mp; + NP = np; + + for ( i = 0; i < m; i++ ) { + B[ i ] = b[ i ]; + for ( j = 0; j < n; j++ ) U[ i + mp * j ] = u[ np * i + j ]; + } + for ( i = 0; i < n; i++ ) { + W[ i ] = w[ i ]; + for ( j = 0; j < n; j++ ) V[ i + np * j ] = v[ np * i + j ]; + } + + F77_LOCK( F77_CALL(sla_svdsol)( INTEGER_ARG(&M), + INTEGER_ARG(&N), + INTEGER_ARG(&MP), + INTEGER_ARG(&NP), + DOUBLE_ARRAY_ARG(B), + DOUBLE_ARRAY_ARG(U), + DOUBLE_ARRAY_ARG(W), + DOUBLE_ARRAY_ARG(V), + DOUBLE_ARRAY_ARG(WORK), + DOUBLE_ARRAY_ARG(X) ); ) + + for ( i = 0; i < n; i++ ) { + x[ i ] = X[ i ]; + work[ i ] = WORK[ i ]; + } + } + + free( B ); + free( U ); + free( W ); + free( V ); + free( WORK ); + free( X ); +} + + + +F77_SUBROUTINE(sla_evp)( DOUBLE(DATE), + DOUBLE(DEQX), + DOUBLE_ARRAY(DVB), + DOUBLE_ARRAY(DPB), + DOUBLE_ARRAY(DVH), + DOUBLE_ARRAY(DPH) ); + +void slaEvp ( double date, double deqx, double dvb[3], double dpb[3], + double dvh[3], double dph[3] ) { + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(DEQX); + DECLARE_DOUBLE_ARRAY(DVB,3); + DECLARE_DOUBLE_ARRAY(DPB,3); + DECLARE_DOUBLE_ARRAY(DVH,3); + DECLARE_DOUBLE_ARRAY(DPH,3); + + int i; + DATE = date; + DEQX = deqx; + F77_LOCK( F77_CALL(sla_evp)( DOUBLE_ARG(&DATE), + DOUBLE_ARG(&DEQX), + DOUBLE_ARRAY_ARG(DVB), + DOUBLE_ARRAY_ARG(DPB), + DOUBLE_ARRAY_ARG(DVH), + DOUBLE_ARRAY_ARG(DPH) ); ) + for ( i = 0; i < 3; i++ ) { + dvb[ i ] = DVB[ i ]; + dpb[ i ] = DPB[ i ]; + dvh[ i ] = DVH[ i ]; + dph[ i ] = DPH[ i ]; + } + +} + +F77_SUBROUTINE(sla_fk5hz)( DOUBLE(R5), + DOUBLE(D5), + DOUBLE(JEPOCH), + DOUBLE(RH), + DOUBLE(DH) ); + +void slaFk5hz ( double r5, double d5, double jepoch, + double *rh, double *dh ) { + DECLARE_DOUBLE(R5); + DECLARE_DOUBLE(D5); + DECLARE_DOUBLE(JEPOCH); + DECLARE_DOUBLE(RH); + DECLARE_DOUBLE(DH); + R5 = r5; + D5 = d5; + JEPOCH = jepoch; + F77_LOCK( F77_CALL(sla_fk5hz)( DOUBLE_ARG(&R5), + DOUBLE_ARG(&D5), + DOUBLE_ARG(&JEPOCH), + DOUBLE_ARG(&RH), + DOUBLE_ARG(&DH) ); ) + *rh = RH; + *dh = DH; +} + +F77_SUBROUTINE(sla_hfk5z)( DOUBLE(RH), + DOUBLE(DH), + DOUBLE(JEPOCH), + DOUBLE(R5), + DOUBLE(D5), + DOUBLE(DR5), + DOUBLE(DD5) ); + +void slaHfk5z ( double rh, double dh, double jepoch, + double *r5, double *d5, + double *dr5, double *dd5 ) { + DECLARE_DOUBLE(RH); + DECLARE_DOUBLE(DH); + DECLARE_DOUBLE(JEPOCH); + DECLARE_DOUBLE(R5); + DECLARE_DOUBLE(D5); + DECLARE_DOUBLE(DR5); + DECLARE_DOUBLE(DD5); + RH = rh; + DH = dh; + JEPOCH = jepoch; + F77_LOCK( F77_CALL(sla_hfk5z)( DOUBLE_ARG(&RH), + DOUBLE_ARG(&DH), + DOUBLE_ARG(&JEPOCH), + DOUBLE_ARG(&R5), + DOUBLE_ARG(&D5), + DOUBLE_ARG(&DR5), + DOUBLE_ARG(&DD5) ); ) + *r5 = R5; + *d5 = D5; + *dr5 = DR5; + *dd5 = DD5; +} + +F77_SUBROUTINE(sla_geoc)( DOUBLE(P), + DOUBLE(H), + DOUBLE(R), + DOUBLE(Z) ); + +void slaGeoc ( double p, double h, double *r, double *z ) { + DECLARE_DOUBLE(P); + DECLARE_DOUBLE(H); + DECLARE_DOUBLE(R); + DECLARE_DOUBLE(Z); + P = p; + H = h; + F77_LOCK( F77_CALL(sla_geoc)( DOUBLE_ARG(&P), + DOUBLE_ARG(&H), + DOUBLE_ARG(&R), + DOUBLE_ARG(&Z) ); ) + *r = R; + *z = Z; +} + +F77_SUBROUTINE(sla_deuler)( CHARACTER(ORDER), + DOUBLE(PHI), + DOUBLE(THETA), + DOUBLE(PSI), + DOUBLE_ARRAY(RMAT) + TRAIL(ORDER) ); + +void slaDeuler ( const char *order, double phi, double theta, double psi, + double rmat[3][3] ) { + + DECLARE_CHARACTER(ORDER,4); + DECLARE_DOUBLE(PHI); + DECLARE_DOUBLE(THETA); + DECLARE_DOUBLE(PSI); + DECLARE_DOUBLE_ARRAY(RMAT,9); + int i,j; + + PHI = phi; + THETA = theta; + PSI = psi; + + slaStringExport( order, ORDER, 4 ); + + F77_LOCK( F77_CALL (sla_deuler) ( CHARACTER_ARG(ORDER), + DOUBLE_ARG(&PHI), + DOUBLE_ARG(&THETA), + DOUBLE_ARG(&PSI), + DOUBLE_ARRAY_ARG(RMAT) + TRAIL_ARG(ORDER) ); ) + + for ( i = 0; i < 3; i++ ) { + for ( j = 0; j < 3; j++ ) rmat[ i ][ j ] = RMAT[ i + 3 * j ]; + } + +} + +F77_SUBROUTINE(sla_de2h)( DOUBLE(HA), + DOUBLE(DEC), + DOUBLE(PHI), + DOUBLE(AZ), + DOUBLE(EL) ); + +void slaDe2h ( double ha, double dec, double phi, double *az, double *el ) { + DECLARE_DOUBLE(HA); + DECLARE_DOUBLE(DEC); + DECLARE_DOUBLE(PHI); + DECLARE_DOUBLE(AZ); + DECLARE_DOUBLE(EL); + HA = ha; + DEC = dec; + PHI = phi; + F77_LOCK( F77_CALL(sla_de2h)( DOUBLE_ARG(&HA), + DOUBLE_ARG(&DEC), + DOUBLE_ARG(&PHI), + DOUBLE_ARG(&AZ), + DOUBLE_ARG(&EL) ); ) + *az = AZ; + *el = EL; +} + +F77_SUBROUTINE(sla_dh2e)( DOUBLE(AZ), + DOUBLE(EL), + DOUBLE(PHI), + DOUBLE(HA), + DOUBLE(DEC) ); + +void slaDh2e ( double az, double el, double phi, double *ha, double *dec ) { + DECLARE_DOUBLE(AZ); + DECLARE_DOUBLE(EL); + DECLARE_DOUBLE(PHI); + DECLARE_DOUBLE(HA); + DECLARE_DOUBLE(DEC); + AZ = az; + EL = el; + PHI = phi; + F77_LOCK( F77_CALL(sla_dh2e)( DOUBLE_ARG(&AZ), + DOUBLE_ARG(&EL), + DOUBLE_ARG(&PHI), + DOUBLE_ARG(&HA), + DOUBLE_ARG(&DEC) ); ) + *ha = HA; + *dec = DEC; +} + + +F77_SUBROUTINE(sla_obs)( INTEGER(I), + CHARACTER(C), + CHARACTER(NAME), + DOUBLE(W), + DOUBLE(P), + DOUBLE(H) + TRAIL(C) + TRAIL(NAME) ); + +/* Note that SLA insists that "c" has space for 10 characters + nul + and "name" has space for 40 characters + nul */ + +void +slaObs( int n, char *c, char *name, double *w, double *p, double *h ) { + + DECLARE_INTEGER( N ); + DECLARE_CHARACTER( C, 10 ); + DECLARE_CHARACTER( NAME, 40 ); + DECLARE_DOUBLE( W ); + DECLARE_DOUBLE( P ); + DECLARE_DOUBLE( H ); + + if (n < 1) { + /* C needs to be imported */ + slaStringExport( c, C, 10 ); + } else { + /* initialise C */ + slaStringExport( "", C, 10 ); + } + F77_EXPORT_INTEGER( n, N ); + + /* w, p and h are not touched on error but for consistency this means + we copy the current values to Fortran so that we can correctly copy + back the result. */ + F77_EXPORT_DOUBLE( *w, W ); + F77_EXPORT_DOUBLE( *p, P ); + F77_EXPORT_DOUBLE( *h, H ); + + /* call the routine */ + F77_LOCK( F77_CALL(sla_obs)( INTEGER_ARG(&N), + CHARACTER_ARG(C), + CHARACTER_ARG(NAME), + DOUBLE_ARG(&W), + DOUBLE_ARG(&P), + DOUBLE_ARG(&H) + TRAIL_ARG(C) + TRAIL_ARG(NAME) ); ) + + /* extract results */ + slaStringImport( NAME, 40, name ); + if (n > 0 && name[0] != '?') { + /* only do this if we know we used a numeric input and if the result + for the NAME is not '?' (since we are not allowed to alter the string + in that case). This allows people + to call slaObs with a string constant */ + slaStringImport( C, 10, c ); + } + F77_IMPORT_DOUBLE( W, *w ); + F77_IMPORT_DOUBLE( P, *p ); + F77_IMPORT_DOUBLE( H, *h ); + +} + +F77_DOUBLE_FUNCTION(sla_pa)( DOUBLE(HA), DOUBLE(DEC), DOUBLE(PHI) ); + +double +slaPa ( double ha, double dec, double phi ) { + DECLARE_DOUBLE(HA); + DECLARE_DOUBLE(DEC); + DECLARE_DOUBLE(PHI); + DECLARE_DOUBLE(RETVAL); + double retval; + + F77_EXPORT_DOUBLE( ha, HA ); + F77_EXPORT_DOUBLE( dec, DEC ); + F77_EXPORT_DOUBLE( phi, PHI ); + + F77_LOCK( RETVAL = F77_CALL(sla_pa)( DOUBLE_ARG(&HA), DOUBLE_ARG(&DEC), DOUBLE_ARG(&PHI)); ) + + F77_IMPORT_DOUBLE( RETVAL, retval ); + return retval; +} + +F77_DOUBLE_FUNCTION(sla_dtt)( DOUBLE(UTC) ); + +double +slaDtt( double utc ) { + DECLARE_DOUBLE(UTC); + DECLARE_DOUBLE(RETVAL); + double retval; + + F77_EXPORT_DOUBLE( utc, UTC ); + F77_LOCK( RETVAL = F77_CALL(sla_dtt)( DOUBLE_ARG(&UTC) ); ) + + F77_IMPORT_DOUBLE( RETVAL, retval ); + return retval; +} + +F77_DOUBLE_FUNCTION(sla_dat)( DOUBLE(UTC) ); + +double +slaDat( double utc ) { + DECLARE_DOUBLE(UTC); + DECLARE_DOUBLE(RETVAL); + double retval; + + F77_EXPORT_DOUBLE( utc, UTC ); + F77_LOCK( RETVAL = F77_CALL(sla_dat)( DOUBLE_ARG(&UTC) ); ) + + F77_IMPORT_DOUBLE( RETVAL, retval ); + return retval; +} + +F77_SUBROUTINE(sla_rdplan)(DOUBLE(DATE), INTEGER(I), DOUBLE(ELONG), DOUBLE(PHI), + DOUBLE(RA), DOUBLE(DEC), DOUBLE(DIAM) ); + +void +slaRdplan( double date, int i, double elong, double phi, + double * ra, double * dec, double * diam ) { + DECLARE_DOUBLE(DATE); + DECLARE_INTEGER(I); + DECLARE_DOUBLE(ELONG); + DECLARE_DOUBLE(PHI); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DEC); + DECLARE_DOUBLE(DIAM); + + F77_EXPORT_DOUBLE( date, DATE ); + F77_EXPORT_INTEGER( i, I ); + F77_EXPORT_DOUBLE( elong, ELONG ); + F77_EXPORT_DOUBLE( phi, PHI ); + + F77_LOCK( F77_CALL(sla_rdplan)( DOUBLE_ARG(&DATE), + INTEGER_ARG(&I), + DOUBLE_ARG(&ELONG), + DOUBLE_ARG(&PHI), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DEC), + DOUBLE_ARG(&DIAM)); ) + + F77_IMPORT_DOUBLE( RA, *ra ); + F77_IMPORT_DOUBLE( DEC, *dec ); + F77_IMPORT_DOUBLE( DIAM, *diam ); +} + +F77_SUBROUTINE(sla_dafin)( CHARACTER(STRING), INTEGER(IPTR), DOUBLE(A), + INTEGER(J) TRAIL(STRING) ); + +void +slaDafin( const char * string, int * iptr, double *a, int *j ) { + + DECLARE_CHARACTER_DYN(STRING); + DECLARE_DOUBLE(A); + DECLARE_INTEGER(IPTR); + DECLARE_INTEGER(J); + + F77_EXPORT_INTEGER( *iptr, IPTR ); + F77_CREATE_EXPORT_CHARACTER( string, STRING ); + + F77_LOCK( F77_CALL(sla_dafin)( CHARACTER_ARG(STRING), INTEGER_ARG(&IPTR), + DOUBLE_ARG(&A), INTEGER_ARG(&J) TRAIL_ARG(STRING) ); ) + + F77_IMPORT_INTEGER(IPTR, *iptr ); + F77_IMPORT_INTEGER(J, *j ); + F77_IMPORT_DOUBLE(A, *a ); + F77_FREE_CHARACTER(STRING); + +} + +F77_SUBROUTINE(sla_oap)( CHARACTER(TYPE), + DOUBLE(OB1), + DOUBLE(OB2), + DOUBLE(DATE), + DOUBLE(DUT), + DOUBLE(ELONGM), + DOUBLE(PHIM), + DOUBLE(HM), + DOUBLE(XP), + DOUBLE(YP), + DOUBLE(TDK), + DOUBLE(PMB), + DOUBLE(RH), + DOUBLE(WL), + DOUBLE(TLR), + DOUBLE(RAP), + DOUBLE(DAP) + TRAIL(TYPE) ); + +void slaOap ( const char *type, double ob1, double ob2, double date, + double dut, double elongm, double phim, double hm, + double xp, double yp, double tdk, double pmb, + double rh, double wl, double tlr, + double *rap, double *dap ) { + DECLARE_CHARACTER(TYPE,1); + DECLARE_DOUBLE(OB1); + DECLARE_DOUBLE(OB2); + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(DUT); + DECLARE_DOUBLE(ELONGM); + DECLARE_DOUBLE(PHIM); + DECLARE_DOUBLE(HM); + DECLARE_DOUBLE(XP); + DECLARE_DOUBLE(YP); + DECLARE_DOUBLE(TDK); + DECLARE_DOUBLE(PMB); + DECLARE_DOUBLE(RH); + DECLARE_DOUBLE(WL); + DECLARE_DOUBLE(TLR); + DECLARE_DOUBLE(RAP); + DECLARE_DOUBLE(DAP); + + slaStringExport( type, TYPE, 1 ); + OB1 = ob1; + OB2 = ob2; + DATE = date; + DUT = dut; + ELONGM = elongm; + PHIM = phim; + HM = hm; + XP = xp; + YP = yp; + TDK = tdk; + PMB = pmb; + RH = rh; + WL = wl; + TLR = tlr; + + F77_LOCK( F77_CALL(sla_oap)( CHARACTER_ARG(TYPE), + DOUBLE_ARG(&OB1), DOUBLE_ARG(&OB2), + DOUBLE_ARG(&DATE), DOUBLE_ARG(&DUT), + DOUBLE_ARG(&ELONGM), DOUBLE_ARG(&PHIM), + DOUBLE_ARG(&HM), DOUBLE_ARG(&XP), + DOUBLE_ARG(&YP), DOUBLE_ARG(&TDK), + DOUBLE_ARG(&PMB), DOUBLE_ARG(&RH), + DOUBLE_ARG(&WL), DOUBLE_ARG(&TLR), + DOUBLE_ARG(&RAP), DOUBLE_ARG(&DAP) + TRAIL_ARG(TYPE) ); ) + + *rap = RAP; + *dap = DAP; + +} + +F77_SUBROUTINE(sla_amp)( DOUBLE(RA), + DOUBLE(DA), + DOUBLE(DATE), + DOUBLE(EQ), + DOUBLE(RM), + DOUBLE(DM) + ); + +void slaAmp( double ra, double da, double date, double eq, + double *rm, double *dm) { + + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DA); + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(EQ); + DECLARE_DOUBLE(RM); + DECLARE_DOUBLE(DM); + + RA = ra; + DA = da; + DATE = date; + EQ = eq; + + F77_LOCK( F77_CALL(sla_amp)( DOUBLE_ARG(&RA), + DOUBLE_ARG(&DA), + DOUBLE_ARG(&DATE), + DOUBLE_ARG(&EQ), + DOUBLE_ARG(&RM), + DOUBLE_ARG(&DM)); ) + + *rm = RM; + *dm = DM; + +} + +F77_SUBROUTINE(sla_aop)( + DOUBLE(RAP), + DOUBLE(DAP), + DOUBLE(DATE), + DOUBLE(DUT), + DOUBLE(ELONGM), + DOUBLE(PHIM), + DOUBLE(HM), + DOUBLE(XP), + DOUBLE(YP), + DOUBLE(TDK), + DOUBLE(PMB), + DOUBLE(RH), + DOUBLE(WL), + DOUBLE(TLR), + DOUBLE(AOB), + DOUBLE(ZOB), + DOUBLE(HOB), + DOUBLE(DOB), + DOUBLE(ROB) ); + +void slaAop ( double rap, double dap, double date, double dut, + double elongm, double phim, double hm, double xp, + double yp, double tdk, double pmb, double rh, + double wl, double tlr, + double *aob, double *zob, double *hob, + double *dob, double *rob ) { + + DECLARE_DOUBLE(RAP); + DECLARE_DOUBLE(DAP); + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(DUT); + DECLARE_DOUBLE(ELONGM); + DECLARE_DOUBLE(PHIM); + DECLARE_DOUBLE(HM); + DECLARE_DOUBLE(XP); + DECLARE_DOUBLE(YP); + DECLARE_DOUBLE(TDK); + DECLARE_DOUBLE(PMB); + DECLARE_DOUBLE(RH); + DECLARE_DOUBLE(WL); + DECLARE_DOUBLE(TLR); + DECLARE_DOUBLE(AOB); + DECLARE_DOUBLE(ZOB); + DECLARE_DOUBLE(HOB); + DECLARE_DOUBLE(DOB); + DECLARE_DOUBLE(ROB); + + RAP = rap; + DAP = dap; + DATE = date; + DUT = dut; + ELONGM = elongm; + PHIM = phim; + HM = hm; + XP = xp; + YP = yp; + TDK = tdk; + PMB = pmb; + RH = rh; + WL = wl; + TLR = tlr; + + F77_LOCK( F77_CALL(sla_aop)( + DOUBLE_ARG(&RAP), + DOUBLE_ARG(&DAP), + DOUBLE_ARG(&DATE), + DOUBLE_ARG(&DUT), + DOUBLE_ARG(&ELONGM), + DOUBLE_ARG(&PHIM), + DOUBLE_ARG(&HM), + DOUBLE_ARG(&XP), + DOUBLE_ARG(&YP), + DOUBLE_ARG(&TDK), + DOUBLE_ARG(&PMB), + DOUBLE_ARG(&RH), + DOUBLE_ARG(&WL), + DOUBLE_ARG(&TLR), + DOUBLE_ARG(&AOB), + DOUBLE_ARG(&ZOB), + DOUBLE_ARG(&HOB), + DOUBLE_ARG(&DOB), + DOUBLE_ARG(&ROB) ); ) + + *aob = AOB; + *zob = ZOB; + *hob = HOB; + *dob = DOB; + *rob = ROB; +} + +F77_SUBROUTINE(sla_cldj)( INTEGER(IY), + INTEGER(IM), + INTEGER(ID), + DOUBLE(DJM), + INTEGER(I) ); + +void +slaCldj( int iy, int im, int id, double * djm, int *i ) { + DECLARE_INTEGER(IY); + DECLARE_INTEGER(IM); + DECLARE_INTEGER(ID); + DECLARE_DOUBLE(DJM); + DECLARE_INTEGER(I); + + IY = iy; + IM = im; + ID = id; + + F77_LOCK( F77_CALL(sla_cldj)( INTEGER_ARG(&IY), + INTEGER_ARG(&IM), + INTEGER_ARG(&ID), + DOUBLE_ARG(&DJM), + INTEGER_ARG(&I) ); ) + + *djm = DJM; + *i = I; + +} + +F77_SUBROUTINE(sla_pertel)( INTEGER(JFORM), + DOUBLE(DATE0), + DOUBLE(DATE1), + DOUBLE(EPOCH0), + DOUBLE(ORBI0), + DOUBLE(ANODE0), + DOUBLE(PERIH0), + DOUBLE(AORQ0), + DOUBLE(E0), + DOUBLE(AM0), + DOUBLE(EPOCH1), + DOUBLE(ORBI1), + DOUBLE(ANODE1), + DOUBLE(PERIH1), + DOUBLE(AORQ1), + DOUBLE(E1), + DOUBLE(AM1), + INTEGER(JSTAT) ); + +void slaPertel (int jform, double date0, double date1, + double epoch0, double orbi0, double anode0, + double perih0, double aorq0, double e0, double am0, + double *epoch1, double *orbi1, double *anode1, + double *perih1, double *aorq1, double *e1, double *am1, + int *jstat ) { + + DECLARE_INTEGER(JFORM); + DECLARE_DOUBLE(DATE0); + DECLARE_DOUBLE(DATE1); + DECLARE_DOUBLE(EPOCH0); + DECLARE_DOUBLE(ORBI0); + DECLARE_DOUBLE(ANODE0); + DECLARE_DOUBLE(PERIH0); + DECLARE_DOUBLE(AORQ0); + DECLARE_DOUBLE(E0); + DECLARE_DOUBLE(AM0); + DECLARE_DOUBLE(EPOCH1); + DECLARE_DOUBLE(ORBI1); + DECLARE_DOUBLE(ANODE1); + DECLARE_DOUBLE(PERIH1); + DECLARE_DOUBLE(AORQ1); + DECLARE_DOUBLE(E1); + DECLARE_DOUBLE(AM1); + DECLARE_INTEGER(JSTAT); + + JFORM = jform; + DATE0 = date0; + DATE1 = date1; + EPOCH0 = epoch0; + ORBI0 = orbi0; + ANODE0 = anode0; + PERIH0 = perih0; + AORQ0 = aorq0; + E0 = e0; + AM0 = am0; + + F77_LOCK( F77_CALL(sla_pertel)( INTEGER_ARG(&JFORM), + DOUBLE_ARG(&DATE0), + DOUBLE_ARG(&DATE1), + DOUBLE_ARG(&EPOCH0), + DOUBLE_ARG(&ORBI0), + DOUBLE_ARG(&ANODE0), + DOUBLE_ARG(&PERIH0), + DOUBLE_ARG(&AORQ0), + DOUBLE_ARG(&E0), + DOUBLE_ARG(&AM0), + DOUBLE_ARG(&EPOCH1), + DOUBLE_ARG(&ORBI1), + DOUBLE_ARG(&ANODE1), + DOUBLE_ARG(&PERIH1), + DOUBLE_ARG(&AORQ1), + DOUBLE_ARG(&E1), + DOUBLE_ARG(&AM1), + INTEGER_ARG(&JSTAT) ); ) + + *epoch1 = EPOCH1; + *orbi1 = ORBI1; + *anode1 = ANODE1; + *perih1 = PERIH1; + *aorq1 = AORQ1; + *e1 = E1; + *am1 = AM1; + *jstat = JSTAT; + +} + +F77_SUBROUTINE(sla_plante)(DOUBLE(DATE), + DOUBLE(ELONG), + DOUBLE(PHI), + INTEGER(JFORM), + DOUBLE(EPOCH), + DOUBLE(ORBINC), + DOUBLE(ANODE), + DOUBLE(PERIH), + DOUBLE(AORQ), + DOUBLE(E), + DOUBLE(AORL), + DOUBLE(DM), + DOUBLE(RA), + DOUBLE(DEC), + DOUBLE(R), + INTEGER(JSTAT) ); + +void slaPlante ( double date, double elong, double phi, int jform, + double epoch, double orbinc, double anode, double perih, + double aorq, double e, double aorl, double dm, + double *ra, double *dec, double *r, int *jstat ) { + + DECLARE_DOUBLE(DATE); + DECLARE_DOUBLE(ELONG); + DECLARE_DOUBLE(PHI); + DECLARE_INTEGER(JFORM); + DECLARE_DOUBLE(EPOCH); + DECLARE_DOUBLE(ORBINC); + DECLARE_DOUBLE(ANODE); + DECLARE_DOUBLE(PERIH); + DECLARE_DOUBLE(AORQ); + DECLARE_DOUBLE(E); + DECLARE_DOUBLE(AORL); + DECLARE_DOUBLE(DM); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DEC); + DECLARE_DOUBLE(R); + DECLARE_INTEGER(JSTAT); + + DATE = date; + ELONG = elong; + PHI = phi; + JFORM = jform; + EPOCH = epoch; + ORBINC = orbinc; + ANODE = anode; + PERIH = perih; + AORQ = aorq; + E = e; + AORL = aorl; + DM = dm; + + F77_LOCK( F77_CALL(sla_plante)( DOUBLE_ARG(&EPOCH), + DOUBLE_ARG(&ELONG), + DOUBLE_ARG(&PHI), + INTEGER_ARG(&JFORM), + DOUBLE_ARG(&EPOCH), + DOUBLE_ARG(&ORBINC), + DOUBLE_ARG(&ANODE), + DOUBLE_ARG(&PERIH), + DOUBLE_ARG(&AORQ), + DOUBLE_ARG(&E), + DOUBLE_ARG(&AORL), + DOUBLE_ARG(&DM), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DEC), + DOUBLE_ARG(&R), + INTEGER_ARG(&JSTAT) ); ) + + *ra = RA; + *dec = DEC; + *r = R; + *jstat = JSTAT; + +} + +F77_SUBROUTINE(sla_preces)(CHARACTER(SYS), + DOUBLE(EP0), + DOUBLE(EP1), + DOUBLE(RA), + DOUBLE(DC) + TRAIL(SYS) ); + +void slaPreces ( const char sys[3], double ep0, double ep1, + double *ra, double *dc ) { + + DECLARE_CHARACTER(SYS,3); + DECLARE_DOUBLE(EP0); + DECLARE_DOUBLE(EP1); + DECLARE_DOUBLE(RA); + DECLARE_DOUBLE(DC); + + slaStringExport( sys, SYS, 3 ); + EP0 = ep0; + EP1 = ep1; + RA = *ra; + DC = *dc; + + F77_LOCK( F77_CALL(sla_preces)( CHARACTER_ARG(SYS), + DOUBLE_ARG(&EP0), + DOUBLE_ARG(&EP1), + DOUBLE_ARG(&RA), + DOUBLE_ARG(&DC) + TRAIL_ARG(SYS) ); ) + + *ra = RA; + *dc = DC; + +} + + +F77_SUBROUTINE(sla_pvobs)( DOUBLE(P), + DOUBLE(H), + DOUBLE(STL), + DOUBLE_ARRAY(PV) ); + +void slaPvobs( double p, double h, double stl, double pv[6] ){ + DECLARE_DOUBLE(P); + DECLARE_DOUBLE(H); + DECLARE_DOUBLE(STL); + DECLARE_DOUBLE_ARRAY(PV,6); + + int i; + P = p; + H = h; + STL = stl; + F77_LOCK( F77_CALL(sla_pvobs)( DOUBLE_ARG(&P), + DOUBLE_ARG(&H), + DOUBLE_ARG(&STL), + DOUBLE_ARRAY_ARG(PV) ); ) + for( i = 0; i < 6; i++ ) pv[ i ] = PV[ i ]; +} + diff --git a/math/slalib/sla.news b/math/slalib/sla.news new file mode 100644 index 00000000..e395c6e5 --- /dev/null +++ b/math/slalib/sla.news @@ -0,0 +1,88 @@ +# 23-SEP-2005 (PTW): +# Suppression of compiler warnings. +# Improved sla_UE2PV. +# Package version number changed to 2.5-4. + +SLALIB_Version_2.5.5 + +* The SLALIB C wrapper now optionally uses the CNF library to serialise +calls from C to Fortran, there-by ensuring that the C functions are +thread-safe. This dependency on CNF can be switched off by configuring +SLALIB with the "--without-cnf" option, in which case CNF will not be +used and the C wrappers will not be thread-safe. + +SLALIB_Version_2.5.4 + +* Changes to sla_EL2UE, sla_FITXY, sla_PV2EL, sla_REFRO, sla_UE2PV and + sla_SVD to avoid warnings if compiled with -Wall and -g -O. + +* Changes to sla_UE2PV to improve convergence in high-eccentricity + cases. + +SLALIB_Version_2.5.3 Expiry 30 June 2006 + +* 2006 January 1 leap second added to sla_DAT. + +SLALIB_Version_2.5.2 Expiry 31 March 2006 + +* Bug-fix to sla_DSEPV. Precisely antipodal vectors returned zero + instead of pi. + +SLALIB_Version_2.5.1 Expiry 31 March 2006 + +* An additional Earth position/velocity routine, sla_EPV, has been + added. It is bigger and slower than sla_EVP but much more accurate. + Position accuracy is a few km; velocity accuracy is a few mm/s. + The sla_PERTUE and sla_PLANTU routines now call this routine in + order to deliver better predictions for near-Earth objects. + +SLALIB_Version_2.4-14 Expiry 31 December 2005 + +* Cosmetic changes to about 20% of the routines. + +* Updated optical refraction model in REFCOQ and REFRO. + +SLALIB_Version_2.4-12 + +* SLALIB has been autoconfed and integrated into the new Starlink build + system. + +* It has been released under the Gnu General Public License + +SLALIB_Version_2.4-11 Expiry 31 March 2004 + +The latest releases of SLALIB include the following changes: + +* A new routine PLANTU has been added. It predicts the topocentric + apparent RA,Dec of a solar-system body given the Universal Elements. + It is a Universal-Elements counterpart to PLANTE, which uses + conventional spherical elements (and which now calls PLANTU). + +* The documentation for the suite of heliocentric orbital elements + routines has been improved to make it easier and more obvious how + to use of elements from JPL Horizons and from the Minor Planet + Center. + + Confusion over epochs has often arisen, because the epoch of osculation + (when the elements are momentarily correct) is completely separate from + the epochs that locate a body in its orbit, the former having a role + only when appying perturbations. Part of the reason for this confusion + is that for major and minor planets it is conventional to adopt the + same epoch for (i) osculation and (ii) computing the anomaly or longitude + that fixes the body, even though they could in principle be different. + For the comet case this convention is impossible because the choice of + perihelion dictates the epoch fixing the body, and hence the existence + of (and need for) two independent concepts of epoch is exposed. + + The SLALIB routines in question, especially slaPlante, now have extra + explanation dealing with the three distinct epochs (date of observation, + fixing the body, and osculation) and also some notes dealing with JPL + and MPC elements. Additionally, a table has been added to SUN/67 + showing how to use the JPL and MPC elements. + + P.T.Wallace + 8 April 2005 + + ptw@tpsoft.demon.co.uk + +44-1235-531198 +-------------------------------------------------------------------------- diff --git a/math/slalib/slaTest.c b/math/slalib/slaTest.c new file mode 100644 index 00000000..ab684558 --- /dev/null +++ b/math/slalib/slaTest.c @@ -0,0 +1,112 @@ +/* + *+ + * Name: + * slaTest + + * Purpose: + * Test C interface to SLA + + * Language: + * Starlink ANSI C + + * Description: + * Provides a simple test of the C interface. Test coverage is not + * complete because not all Fortran routines have wrappers. + + * Copyright: + * Copyright (C) 2006 Particle Physics and Engineering Research Council + + * Licence: + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License as + * published by the Free Software Foundation; either version 2 of + * the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be + * useful,but WITHOUT ANY WARRANTY; without even the implied + * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR + * PURPOSE. See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street,Fifth Floor, Boston, MA + * 02110-1301, USA + + * Authors: + * TIMJ: Tim Jenness (JAC, Hawaii) + * {enter_new_authors_here} + + * History: + * 07-AUG-2006 (TIMJ): + * Original version. + + *- + */ + +#if HAVE_CONFIG_H +# include +#endif + +#include +#include +#include +#include "slalib.h" + +#if HAVE_FC_MAIN +void FC_MAIN ( void ); +void FC_MAIN ( ) {} +#endif + + +int main ( void ) { + double w, p, h; + char telname[41]; + char telshort[11]; + int exstatus = EXIT_SUCCESS; + + + /* call slaObs - initialise to recognisable state */ + w = 0.0; p = 0.0; h = -1.0; + + /* first call by short name */ + slaObs( 0, "JCMT", telname, &w, &p, &h ); + if ( h == -1.0 ) { + printf( "Error obtaining information on JCMT\n"); + exstatus = EXIT_FAILURE; + } else { + printf( "Telescope JCMT is '%s' w = %f, p = %f, h = %f\n", + telname, w, p, h); + } + + /* call by index */ + h = -1.0; w = 0.0; p = 0.0; + slaObs( 1, telshort, telname, &w, &p, &h ); + if (h == -1.0 ) { + printf( "Error obtaining information on telescope 1\n"); + exstatus = EXIT_FAILURE; + } else { + printf( "Telescope 1 is '%s' aka '%s' w = %f, p = %f, h = %f\n", + telshort, telname, w, p, h); + } + + /* deliberately fail - with bad index */ + h = -1.0; w = 0.0; p = 0.0; strcpy( telshort, "unknown" ); + slaObs( 100000, telshort, telname, &w, &p, &h ); + if (h != -1.0 || telname[0] != '?') { + printf("Attempt to decode unfeasibly large telescope index should have failed\n"); + printf("Got this result: Tel: '%s' aka '%s', w=%f p=%f h=%f\n", telshort, + telname, w, p, h); + exstatus = EXIT_FAILURE; + } + + /* deliberately fail - with bad name */ + h = -1.0; w = 0.0; p = 0.0; + slaObs( 0, "AFakeTel", telname, &w, &p, &h ); + if (h != -1.0 || telname[0] != '?') { + printf("Attempt to decode unknown telescope should have failed\n"); + printf("Got this result: Tel: '%s', w=%f p=%f h=%f\n", telname, w, p, h); + exstatus = EXIT_FAILURE; + } + + return exstatus; +} diff --git a/math/slalib/sla_link b/math/slalib/sla_link new file mode 100755 index 00000000..941abfac --- /dev/null +++ b/math/slalib/sla_link @@ -0,0 +1 @@ +echo -lsla `cnf_link` diff --git a/math/slalib/sla_link_adam b/math/slalib/sla_link_adam new file mode 100755 index 00000000..a5e757b3 --- /dev/null +++ b/math/slalib/sla_link_adam @@ -0,0 +1 @@ +echo -lsla `cnf_link_adam` diff --git a/math/slalib/sla_test.f b/math/slalib/sla_test.f new file mode 100644 index 00000000..4edaf093 --- /dev/null +++ b/math/slalib/sla_test.f @@ -0,0 +1,6655 @@ + PROGRAM SLA_TEST +*+ +* - - - - - - - - - +* S L A _ T E S T +* - - - - - - - - - +* +* Validate the slalib library. +* +* Each slalib function is tested to some useful but in most cases +* not exhaustive level. Successful completion is signalled by an +* absence of output messages. Failure of a given function or +* group of functions results in error messages. +* +* Any messages go to standard output. +* +* Adapted from original C code by P.T.Wallace. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink and P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + INTEGER EXITSTATUS + + +* Preset the status to success. + STATUS = .TRUE. + +* Test all the slalib functions. + CALL T_ADDET ( STATUS ) + CALL T_AFIN ( STATUS ) + CALL T_AIRMAS ( STATUS ) + CALL T_ALTAZ ( STATUS ) + CALL T_AMP ( STATUS ) + CALL T_AOP ( STATUS ) + CALL T_BEAR ( STATUS ) + CALL T_CAF2R ( STATUS ) + CALL T_CALDJ ( STATUS ) + CALL T_CALYD ( STATUS ) + CALL T_CC2S ( STATUS ) + CALL T_CC62S ( STATUS ) + CALL T_CD2TF ( STATUS ) + CALL T_CLDJ ( STATUS ) + CALL T_CR2AF ( STATUS ) + CALL T_CR2TF ( STATUS ) + CALL T_CS2C6 ( STATUS ) + CALL T_CTF2D ( STATUS ) + CALL T_CTF2R ( STATUS ) + CALL T_DAT ( STATUS ) + CALL T_DBJIN ( STATUS ) + CALL T_DJCAL ( STATUS ) + CALL T_DMAT ( STATUS ) + CALL T_E2H ( STATUS ) + CALL T_EARTH ( STATUS ) + CALL T_ECLEQ ( STATUS ) + CALL T_ECMAT ( STATUS ) + CALL T_ECOR ( STATUS ) + CALL T_EG50 ( STATUS ) + CALL T_EPB ( STATUS ) + CALL T_EPB2D ( STATUS ) + CALL T_EPCO ( STATUS ) + CALL T_EPJ ( STATUS ) + CALL T_EPJ2D ( STATUS ) + CALL T_EQECL ( STATUS ) + CALL T_EQEQX ( STATUS ) + CALL T_EQGAL ( STATUS ) + CALL T_ETRMS ( STATUS ) + CALL T_EVP ( STATUS ) + CALL T_FITXY ( STATUS ) + CALL T_FK425 ( STATUS ) + CALL T_FK45Z ( STATUS ) + CALL T_FK524 ( STATUS ) + CALL T_FK52H ( STATUS ) + CALL T_FK54Z ( STATUS ) + CALL T_FLOTIN ( STATUS ) + CALL T_GALEQ ( STATUS ) + CALL T_GALSUP ( STATUS ) + CALL T_GE50 ( STATUS ) + CALL T_GMST ( STATUS ) + CALL T_INTIN ( STATUS ) + CALL T_KBJ ( STATUS ) + CALL T_MAP ( STATUS ) + CALL T_MOON ( STATUS ) + CALL T_NUT ( STATUS ) + CALL T_OBS ( STATUS ) + CALL T_PA ( STATUS ) + CALL T_PCD ( STATUS ) + CALL T_PDA2H ( STATUS ) + CALL T_PDQ2H ( STATUS ) + CALL T_PERCOM ( STATUS ) + CALL T_PLANET ( STATUS ) + CALL T_PM ( STATUS ) + CALL T_POLMO ( STATUS ) + CALL T_PREBN ( STATUS ) + CALL T_PREC ( STATUS ) + CALL T_PRECES ( STATUS ) + CALL T_PRENUT ( STATUS ) + CALL T_PVOBS ( STATUS ) + CALL T_RANGE ( STATUS ) + CALL T_RANORM ( STATUS ) + CALL T_RCC ( STATUS ) + CALL T_REF ( STATUS ) + CALL T_RV ( STATUS ) + CALL T_SEP ( STATUS ) + CALL T_SMAT ( STATUS ) + CALL T_SUPGAL ( STATUS ) + CALL T_SVD ( STATUS ) + CALL T_TP ( STATUS ) + CALL T_TPV ( STATUS ) + CALL T_VECMAT ( STATUS ) + CALL T_ZD ( STATUS ) + +* Report any errors and set up an appropriate exit status. Set the +* EXITSTATUS to 0 on success, 1 on any error -- Unix-style. The +* EXIT intrinsic is non-standard but common (which is portable enough +* for a regression test). + + IF ( STATUS ) THEN + WRITE (*,'(1X,''SLALIB validation OK!'')') + EXITSTATUS = 0 + ELSE + WRITE (*,'(1X,''SLALIB validation failed!'')') + EXITSTATUS = 1 + ENDIF + + CALL EXIT(EXITSTATUS) + + END + + SUBROUTINE VCS ( S, SOK, FUNC, TEST, STATUS ) +*+ +* - - - - +* V C S +* - - - - +* +* Validate a character string result. +* +* Internal routine used by sla_TEST program. +* +* Given: +* S CHARACTER string produced by routine under test +* SOK CHARACTER correct value +* FUNC CHARACTER name of routine under test +* TEST CHARACTER name of individual test (or ' ') +* +* Given and returned: +* STATUS LOGICAL set to .FALSE. if test fails +* +* Called: ERR +* +* Last revision: 25 May 2002 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) S, SOK, FUNC, TEST + LOGICAL STATUS + + + IF ( S .NE. SOK ) THEN + CALL ERR ( FUNC, TEST, STATUS ) + WRITE (*,'(1X,'' expected ='',6X,''"'',A,''"'')') SOK + WRITE (*,'(1X,'' actual = '',6X,''"'',A,''"'')') S + END IF + + END + + SUBROUTINE VIV ( IVAL, IVALOK, FUNC, TEST, STATUS ) +*+ +* - - - - +* V I V +* - - - - +* +* Validate an integer result. +* +* Internal routine used by sla_TEST program. +* +* Given: +* IVAL INTEGER value computed by routine under test +* IVALOK INTEGER correct value +* FUNC CHARACTER name of routine under test +* TEST CHARACTER name of individual test (or ' ') +* +* Given and returned: +* STATUS LOGICAL set to .FALSE. if test fails +* +* Called: ERR +* +* Last revision: 25 May 2002 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER IVAL, IVALOK + CHARACTER*(*) FUNC, TEST + LOGICAL STATUS + + + IF ( IVAL .NE. IVALOK ) THEN + CALL ERR ( FUNC, TEST, STATUS ) + WRITE (*,'(1X,'' expected ='',I10)') IVALOK + WRITE (*,'(1X,'' actual = '',I10)') IVAL + END IF + + END + + SUBROUTINE VLV ( IVAL, IVALOK, FUNC, TEST, STATUS ) +*+ +* - - - - +* V L V +* - - - - +* +* Validate a long result. +* +* Internal routine used by sla_TEST program. +* +* Given: +* IVAL INTEGER*4 value computed by routine under test +* IVALOK INTEGER*4 correct value +* FUNC CHARACTER name of routine under test +* TEST CHARACTER name of individual test (or ' ') +* +* Given and returned: +* STATUS LOGICAL set to .FALSE. if test fails +* +* Called: ERR +* +* Last revision: 25 May 2002 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER*4 IVAL, IVALOK + CHARACTER*(*) FUNC, TEST + LOGICAL STATUS + + + IF ( IVAL .NE. IVALOK ) THEN + CALL ERR ( FUNC, TEST, STATUS ) + WRITE (*,'(1X,'' expected ='',I10)') IVALOK + WRITE (*,'(1X,'' actual = '',I10)') IVAL + END IF + + END + + SUBROUTINE VVD ( VAL, VALOK, DVAL, FUNC, TEST, STATUS ) +*+ +* - - - - +* V V D +* - - - - +* +* Validate a double result. +* +* Internal routine used by sla_TEST program. +* +* Given: +* VAL DOUBLE value computed by routine under test +* VALOK DOUBLE correct value +* DVAL DOUBLE maximum allowable error +* FUNC CHARACTER name of routine under test +* TEST CHARACTER name of individual test (or ' ') +* +* Given and returned: +* STATUS LOGICAL set to .FALSE. if test fails +* +* Called: ERR +* +* Last revision: 25 May 2002 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION VAL, VALOK, DVAL + CHARACTER*(*) FUNC, TEST + LOGICAL STATUS + + + IF ( DABS ( VAL - VALOK ) .GT. DVAL ) THEN + CALL ERR ( FUNC, TEST, STATUS ) + WRITE (*,'(1X,'' expected ='',G30.19)') VALOK + WRITE (*,'(1X,'' actual = '',G30.19)') VAL + END IF + + END + + SUBROUTINE ERR ( FUNC, TEST, STATUS ) +*+ +* - - - - +* E R R +* - - - - +* +* Report a failed test. +* +* Internal routine used by sla_TEST program. +* +* Given: +* FUNC CHARACTER name of routine under test +* TEST CHARACTER name of individual test (or ' ') +* +* Given and returned: +* STATUS LOGICAL set to .FALSE. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + CHARACTER*(*) FUNC, TEST + LOGICAL STATUS + + + WRITE (*,'(1X,A,'' test '',A,'' fails:'')') FUNC, TEST + STATUS = .FALSE. + + END + + SUBROUTINE T_ADDET ( STATUS ) +*+ +* - - - - - - - - +* T _ A D E T +* - - - - - - - - +* +* Test slADET, slSUET routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slADET, VVD, slSUET. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RM, DM, EQ, R1, D1, R2, D2 + + RM = 2D0 + DM = -1D0 + EQ = 1975D0 + + CALL slADET ( RM, DM, EQ, R1, D1 ) + CALL VVD ( R1 - RM, 2.983864874295250D-6, 1D-12, 'slADET', + : 'R', STATUS ) + CALL VVD ( D1 - DM, 2.379650804185118D-7, 1D-12, 'slADET', + : 'D', STATUS ) + + CALL slSUET ( R1, D1, EQ, R2, D2 ) + CALL VVD ( R2 - RM, 0D0, 1D-12, 'slSUET', 'R', STATUS ) + CALL VVD ( D2 - DM, 0D0, 1D-12, 'slSUET', 'D', STATUS ) + + END + + SUBROUTINE T_AFIN ( STATUS ) +*+ +* - - - - - - - +* T _ A F I N +* - - - - - - - +* +* Test slAFIN and slDAFN routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slAFIN, VIV, VVD, slDAFN. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I, J + REAL F + DOUBLE PRECISION D + CHARACTER*12 S + DATA S /'12 34 56.7 |'/ + + + I = 1 + CALL slAFIN (S, I, F, J) + CALL VIV ( I, 12, 'slAFIN', 'I', STATUS ) + CALL VVD ( DBLE( F ), 0.2196045986911432D0, 1D-6, 'slAFIN', + : 'A', STATUS ) + CALL VIV ( J, 0, 'slAFIN', 'J', STATUS ) + + I = 1 + CALL slDAFN (S, I, D, J) + CALL VIV ( I, 12, 'slDAFN', 'I', STATUS ) + CALL VVD ( D, 0.2196045986911432D0, 1D-12, 'slDAFN', 'A', + : STATUS ) + CALL VIV ( J, 0, 'slDAFN', 'J', STATUS ) + + END + + SUBROUTINE T_AIRMAS ( STATUS ) +*+ +* - - - - - - - - - +* T _ A R M S +* - - - - - - - - - +* +* Test slARMS routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: VVD, slARMS. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slARMS + + + CALL VVD ( slARMS ( 1.2354D0 ), 3.015698990074724D0, + : 1D-12, 'slARMS', ' ', STATUS ) + + END + + SUBROUTINE T_ALTAZ ( STATUS ) +*+ +* - - - - - - - - +* T _ A L A Z +* - - - - - - - - +* +* Test slALAZ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slALAZ, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD + + CALL slALAZ ( 0.7D0, -0.7D0, -0.65D0, + : AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD ) + + CALL VVD ( AZ, 4.400560746660174D0, 1D-12, 'slALAZ', + : 'AZ', STATUS ) + CALL VVD ( AZD, -0.2015438937145421D0, 1D-13, 'slALAZ', + : 'AZD', STATUS ) + CALL VVD ( AZDD, -0.4381266949668748D0, 1D-13, 'slALAZ', + : 'AZDD', STATUS ) + CALL VVD ( EL, 1.026646506651396D0, 1D-12, 'slALAZ', + : 'EL', STATUS ) + CALL VVD ( ELD, -0.7576920683826450D0, 1D-13, 'slALAZ', + : 'ELD', STATUS ) + CALL VVD ( ELDD, 0.04922465406857453D0, 1D-14, 'slALAZ', + : 'ELDD', STATUS ) + CALL VVD ( PA, 1.707639969653937D0, 1D-12, 'slALAZ', + : 'PA', STATUS ) + CALL VVD ( PAD, 0.4717832355365627D0, 1D-13, 'slALAZ', + : 'PAD', STATUS ) + CALL VVD ( PADD, -0.2957914128185515D0, 1D-13, 'slALAZ', + : 'PADD', STATUS ) + + END + + SUBROUTINE T_AMP ( STATUS ) +*+ +* - - - - - - +* T _ A M P +* - - - - - - +* +* Test slAMP, slMAPA, slAMPQ routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slAMP, VVD. +* +* Last revision: 16 November 2001 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RM, DM + + CALL slAMP ( 2.345D0, -1.234D0, 50100D0, 1990D0, RM, DM ) + CALL VVD ( RM, 2.344472180027961D0, 1D-11, 'slAMP', 'R', + : STATUS ) + CALL VVD ( DM, -1.233573099847705D0, 1D-11, 'slAMP', 'D', + : STATUS ) + + END + + SUBROUTINE T_AOP ( STATUS ) +*+ +* - - - - - - +* T _ A O P +* - - - - - - +* +* Test slAOP, slAOPA, slAOPQ, slOAP, slOAPQ, +* slAOPT routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slAOP, VVD, slAOPA, slAOPQ, slOAP, slOAPQ, +* slAOPT. +* +* Defined in slamac.h: DS2R +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I + DOUBLE PRECISION DS2R + DOUBLE PRECISION RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, XP, YP, + : TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB, AOPRMS(14) + + PARAMETER (DS2R = + : 7.2722052166430399038487115353692196393452995355905D-5) + + DAP = -0.1234D0 + DATE = 51000.1D0 + DUT = 25D0 + ELONGM = 2.1D0 + PHIM = 0.5D0 + HM = 3000D0 + XP = -0.5D-6 + YP = 1D-6 + TDK = 280D0 + PMB = 550D0 + RH = 0.6D0 + TLR = 0.006D0 + + DO I = 1, 3 + + IF ( I .EQ. 1 ) THEN + RAP = 2.7D0 + WL = 0.45D0 + ELSE IF ( I .EQ. 2 ) THEN + RAP = 2.345D0 + ELSE + WL = 1D6 + END IF + + CALL slAOP ( RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, XP, YP, + : TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB ) + + IF ( I .EQ. 1 ) THEN + CALL VVD ( AOB, 1.812817787123283034D0, 1D-10, 'slAOP', + : 'lo aob', STATUS ) + CALL VVD ( ZOB, 1.393860816635714034D0, 1D-10, 'slAOP', + : 'lo zob', STATUS ) + CALL VVD ( HOB, -1.297808009092456683D0, 1D-10, 'slAOP', + : 'lo hob', STATUS ) + CALL VVD ( DOB, -0.122967060534561D0, 1D-10, 'slAOP', + : 'lo dob', STATUS ) + CALL VVD ( ROB, 2.699270287872084D0, 1D-10, 'slAOP', + : 'lo rob', STATUS ) + ELSE IF ( I .EQ. 2 ) THEN + CALL VVD ( AOB, 2.019928026670621442D0, 1D-10, 'slAOP', + : 'aob/o', STATUS ) + CALL VVD ( ZOB, 1.101316172427482466D0, 1D-10, 'slAOP', + : 'zob/o', STATUS ) + CALL VVD ( HOB, -0.9432923558497740862D0, 1D-10, 'slAOP', + : 'hob/o', STATUS ) + CALL VVD ( DOB, -0.1232144708194224D0, 1D-10, 'slAOP', + : 'dob/o', STATUS ) + CALL VVD ( ROB, 2.344754634629428D0, 1D-10, 'slAOP', + : 'rob/o', STATUS ) + ELSE + CALL VVD ( AOB, 2.019928026670621442D0, 1D-10, 'slAOP', + : 'aob/r', STATUS ) + CALL VVD ( ZOB, 1.101267532198003760D0, 1D-10, 'slAOP', + : 'zob/r', STATUS ) + CALL VVD ( HOB, -0.9432533138143315937D0, 1D-10, 'slAOP', + : 'hob/r', STATUS ) + CALL VVD ( DOB, -0.1231850665614878D0, 1D-10, 'slAOP', + : 'dob/r', STATUS ) + CALL VVD ( ROB, 2.344715592593984D0, 1D-10, 'slAOP', + : 'rob/r', STATUS ) + END IF + END DO + + DATE = 48000.3D0 + WL = 0.45D0 + + CALL slAOPA ( DATE, DUT, ELONGM, PHIM, HM, XP, YP, TDK, + : PMB, RH, WL, TLR, AOPRMS ) + CALL VVD ( AOPRMS(1), 0.4999993892136306D0, 1D-13, 'slAOPA', + : '1', STATUS ) + CALL VVD ( AOPRMS(2), 0.4794250025886467D0, 1D-13, 'slAOPA', + : '2', STATUS ) + CALL VVD ( AOPRMS(3), 0.8775828547167932D0, 1D-13, 'slAOPA', + : '3', STATUS ) + CALL VVD ( AOPRMS(4), 1.363180872136126D-6, 1D-13, 'slAOPA', + : '4', STATUS ) + CALL VVD ( AOPRMS(5), 3000D0, 1D-10, 'slAOPA', '5', + : STATUS ) + CALL VVD ( AOPRMS(6), 280D0, 1D-11, 'slAOPA', '6', + : STATUS ) + CALL VVD ( AOPRMS(7), 550D0, 1D-11, 'slAOPA', '7', + : STATUS ) + CALL VVD ( AOPRMS(8), 0.6D0, 1D-13, 'slAOPA', '8', + : STATUS ) + CALL VVD ( AOPRMS(9), 0.45D0, 1D-13, 'slAOPA', '9', + : STATUS ) + CALL VVD ( AOPRMS(10), 0.006D0, 1D-15, 'slAOPA', '10', + : STATUS ) + CALL VVD ( AOPRMS(11), 0.0001562803328459898D0, 1D-13, + : 'slAOPA', '11', STATUS ) + CALL VVD ( AOPRMS(12), -1.792293660141D-7, 1D-13, + : 'slAOPA', '12', STATUS ) + CALL VVD ( AOPRMS(13), 2.101874231495843D0, 1D-13, + : 'slAOPA', '13', STATUS ) + CALL VVD ( AOPRMS(14), 7.601916802079765D0, 1D-8, + : 'slAOPA', '14', STATUS ) + + CALL slOAP ( 'R', 1.6D0, -1.01D0, DATE, DUT, ELONGM, PHIM, + : HM, XP, YP, TDK, PMB, RH, WL, TLR, RAP, DAP ) + CALL VVD ( RAP, 1.601197569844787D0, 1D-10, 'slOAP', + : 'Rr', STATUS ) + CALL VVD ( DAP, -1.012528566544262D0, 1D-10, 'slOAP', + : 'Rd', STATUS ) + CALL slOAP ( 'H', -1.234D0, 2.34D0, DATE, DUT, ELONGM, PHIM, + : HM, XP, YP, TDK, PMB, RH, WL, TLR, RAP, DAP ) + CALL VVD ( RAP, 5.693087688154886463D0, 1D-10, 'slOAP', + : 'Hr', STATUS ) + CALL VVD ( DAP, 0.8010281167405444D0, 1D-10, 'slOAP', + : 'Hd', STATUS ) + CALL slOAP ( 'A', 6.1D0, 1.1D0, DATE, DUT, ELONGM, PHIM, + : HM, XP, YP, TDK, PMB, RH, WL, TLR, RAP, DAP ) + CALL VVD ( RAP, 5.894305175192448940D0, 1D-10, 'slOAP', + : 'Ar', STATUS ) + CALL VVD ( DAP, 1.406150707974922D0, 1D-10, 'slOAP', + : 'Ad', STATUS ) + + CALL slOAPQ ( 'R', 2.1D0, -0.345D0, AOPRMS, RAP, DAP ) + CALL VVD ( RAP, 2.10023962776202D0, 1D-10, 'slOAPQ', + : 'Rr', STATUS ) + CALL VVD ( DAP, -0.3452428692888919D0, 1D-10, 'slOAPQ', + : 'Rd', STATUS ) + CALL slOAPQ ( 'H', -0.01D0, 1.03D0, AOPRMS, RAP, DAP ) + CALL VVD ( RAP, 1.328731933634564995D0, 1D-10, 'slOAPQ', + : 'Hr', STATUS ) + CALL VVD ( DAP, 1.030091538647746D0, 1D-10, 'slOAPQ', + : 'Hd', STATUS ) + CALL slOAPQ ( 'A', 4.321D0, 0.987D0, AOPRMS, RAP, DAP ) + CALL VVD ( RAP, 0.4375507112075065923D0, 1D-10, 'slOAPQ', + : 'Ar', STATUS ) + CALL VVD ( DAP, -0.01520898480744436D0, 1D-10, 'slOAPQ', + : 'Ad', STATUS ) + + CALL slAOPT ( DATE + DS2R, AOPRMS ) + CALL VVD ( AOPRMS(14), 7.602374979243502D0, 1D-8, 'slAOPT', + : ' ', STATUS ) + + END + + SUBROUTINE T_BEAR ( STATUS ) +*+ +* - - - - - - - +* T _ B E A R +* - - - - - - - +* +* Test slBEAR, slDBER, slDPAV, slPAV routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: VVD, slBEAR, slDBER, +* slDS2C, slPAV, slDPAV. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I + REAL F1(3), F2(3) + REAL slBEAR, slPAV + DOUBLE PRECISION D1(3), D2(3) + DOUBLE PRECISION A1, B1, A2, B2 + DOUBLE PRECISION slDBER, slDPAV + + + A1 = 1.234D0 + B1 = -0.123D0 + A2 = 2.345D0 + B2 = 0.789D0 + + CALL VVD ( DBLE( slBEAR ( SNGL( A1 ), SNGL( B1 ), SNGL( A2 ), + : SNGL( B2 ) ) ), 0.7045970341781791D0, 1D-6, + : 'slBEAR', ' ', STATUS ) + CALL VVD ( slDBER ( A1, B1, A2, B2 ), 0.7045970341781791D0, + : 1D-12, 'slDBER', ' ', STATUS ) + CALL slDS2C ( A1, B1, D1 ) + CALL slDS2C ( A2, B2, D2 ) + + DO I = 1, 3 + F1(I) = SNGL( D1(I) ) + F2(I) = SNGL( D2(I) ) + END DO + + CALL VVD ( DBLE( slPAV ( F1, F2 ) ), 0.7045970341781791D0, + : 1D-6, 'slPAV', ' ', STATUS ) + CALL VVD ( slDPAV ( D1, D2 ), 0.7045970341781791D0, + : 1D-12, 'slDPAV', ' ', STATUS ) + + END + + SUBROUTINE T_CAF2R ( STATUS ) +*+ +* - - - - - - - - +* T _ C A F R +* - - - - - - - - +* +* Test slCAFR, slDAFR routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCAFR, VVD, VIV, slDAFR. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + REAL R + DOUBLE PRECISION DR + + CALL slCAFR ( 76, 54, 32.1E0, R, J ) + CALL VVD ( DBLE( R ), 1.342313819975276D0, 1D-6, 'slCAFR', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slCAFR', 'J', STATUS ) + CALL slDAFR ( 76, 54, 32.1D0, DR, J ) + CALL VVD ( DR, 1.342313819975276D0, 1D-12, 'slDAFR', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slCAFR', 'J', STATUS ) + + END + + SUBROUTINE T_CALDJ ( STATUS ) +*+ +* - - - - - - - - +* T _ C A D J +* - - - - - - - - +* +* Test slCADJ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCADJ, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + DOUBLE PRECISION DJM + + CALL slCADJ ( 1999, 12, 31, DJM, J ) + CALL VVD ( DJM, 51543D0, 0D0, 'slCADJ', ' ', STATUS ) + + END + + SUBROUTINE T_CALYD ( STATUS ) +*+ +* - - - - - - - - +* T _ C A Y D +* - - - - - - - - +* +* Test slCAYD and slCLYD routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCAYD, slCLYD, VIV. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER NY, ND, J + + CALL slCAYD ( 46, 4, 30, NY, ND, J ) + CALL VIV ( NY, 2046, 'slCAYD', 'Y', STATUS ) + CALL VIV ( ND, 120, 'slCAYD', 'D', STATUS ) + CALL VIV ( J, 0, 'slCAYD', 'J', STATUS ) + CALL slCLYD ( -5000, 1, 1, NY, ND, J ) + CALL VIV ( J, 1, 'slCLYD', 'illegal year', STATUS ) + CALL slCLYD ( 1900, 0, 1, NY, ND, J ) + CALL VIV ( J, 2, 'slCLYD', 'illegal month', STATUS ) + CALL slCLYD ( 1900, 2, 29, NY, ND, J) + CALL VIV ( NY, 1900, 'slCLYD', 'illegal day (Y)', STATUS ) + CALL VIV ( ND, 61, 'slCLYD', 'illegal day (D)', STATUS ) + CALL VIV ( J, 3, 'slCLYD', 'illegal day (J)', STATUS ) + CALL slCLYD ( 2000, 2, 29, NY, ND, J ) + CALL VIV ( NY, 2000, 'slCLYD', 'Y', STATUS ) + CALL VIV ( ND, 60, 'slCLYD', 'D', STATUS ) + CALL VIV ( J, 0, 'slCLYD', 'J', STATUS ) + + END + + SUBROUTINE T_CC2S ( STATUS ) +*+ +* - - - - - - - +* T _ C C 2 S +* - - - - - - - +* +* Test slCC2S, slDC2S routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCC2S, VVD, slDC2S. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL V(3), A, B + DOUBLE PRECISION DV(3), DA, DB + + DATA V/100.0, -50.0, 25.0/ + DATA DV/100D0, -50D0, 25D0/ + + CALL slCC2S ( V, A, B ) + CALL VVD ( DBLE( A), -0.4636476090008061D0, 1D-6, 'slCC2S', + : 'A', STATUS ) + CALL VVD ( DBLE( B ), 0.2199879773954594D0, 1D-6, 'slCC2S', + : 'B', STATUS ) + + CALL slDC2S ( DV, DA, DB ) + CALL VVD ( DA, -0.4636476090008061D0, 1D-12, 'slDC2S', + : 'A', STATUS ) + CALL VVD ( DB, 0.2199879773954594D0, 1D-12, 'slDC2S', + : 'B', STATUS ) + + END + + SUBROUTINE T_CC62S ( STATUS ) +*+ +* - - - - - - - - +* T _ C 6 2 S +* - - - - - - - - +* +* Test slC62S, slDC6S routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slC62S, VVD, slDC6S. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL V(6), A, B, R, AD, BD, RD + DOUBLE PRECISION DV(6), DA, DB, DR, DAD, DBD, DRD + + DATA V/100.0, -50.0, 25.0, -0.1, 0.2, 0.7/ + DATA DV/100D0, -50D0, 25D0, -0.1D0, 0.2D0, 0.7D0/ + + CALL slC62S ( V, A, B, R, AD, BD, RD ) + CALL VVD ( DBLE( A ), -0.4636476090008061D0, 1D-6, 'slC62S', + : 'A', STATUS ) + CALL VVD ( DBLE( B ), 0.2199879773954594D0, 1D-6, 'slC62S', + : 'B', STATUS ) + CALL VVD ( DBLE( R ), 114.564392373896D0, 1D-3, 'slC62S', + : 'R', STATUS ) + CALL VVD ( DBLE( AD ), 0.001200000000000000D0, 1D-9, 'slC62S', + : 'AD', STATUS ) + CALL VVD ( DBLE( BD ), 0.006303582107999407D0, 1D-8, 'slC62S', + : 'BD', STATUS ) + CALL VVD ( DBLE( RD ), -0.02182178902359925D0, 1D-7, 'slC62S', + : 'RD', STATUS ) + + CALL slDC6S ( DV, DA, DB, DR, DAD, DBD, DRD ) + CALL VVD ( DA, -0.4636476090008061D0, 1D-6, 'slDC6S', + : 'A', STATUS ) + CALL VVD ( DB, 0.2199879773954594D0, 1D-6, 'slDC6S', + : 'B', STATUS ) + CALL VVD ( DR, 114.564392373896D0, 1D-9, 'slDC6S', + : 'R', STATUS ) + CALL VVD ( DAD, 0.001200000000000000D0, 1D-15, 'slDC6S', + : 'AD', STATUS ) + CALL VVD ( DBD, 0.006303582107999407D0, 1D-14, 'slDC6S', + : 'BD', STATUS ) + CALL VVD ( DRD, -0.02182178902359925D0, 1D-13, 'slDC6S', + : 'RD', STATUS ) + + END + + SUBROUTINE T_CD2TF ( STATUS ) +*+ +* - - - - - - - - +* T _ C D T F +* - - - - - - - - +* +* Test slCDTF, slDDTF routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCDTF, VIV, VVD, slDDTF. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER IHMSF(4) + CHARACTER S + + CALL slCDTF ( 4, -0.987654321E0, S, IHMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '-' ), 'slCDTF', 'S', STATUS ) + CALL VIV ( IHMSF(1), 23, 'slCDTF', '(1)', STATUS ) + CALL VIV ( IHMSF(2), 42, 'slCDTF', '(2)', STATUS ) + CALL VIV ( IHMSF(3), 13, 'slCDTF', '(3)', STATUS ) + CALL VVD ( DFLOAT( IHMSF(4) ), 3333D0, 1000D0, 'slCDTF', + : '(4)', STATUS ) + + CALL slDDTF ( 4, -0.987654321D0, S, IHMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '-' ), 'slDDTF', 'S', STATUS ) + CALL VIV ( IHMSF(1), 23, 'slDDTF', '(1)', STATUS ) + CALL VIV ( IHMSF(2), 42, 'slDDTF', '(2)', STATUS ) + CALL VIV ( IHMSF(3), 13, 'slDDTF', '(3)', STATUS ) + CALL VIV ( IHMSF(4), 3333, 'slDDTF', '(4)', STATUS ) + + END + + SUBROUTINE T_CLDJ ( STATUS ) +*+ +* - - - - - - - +* T _ C L D J +* - - - - - - - +* +* Test slCLDJ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCLDJ, VVD, VIV. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + DOUBLE PRECISION D + + CALL slCLDJ ( 1899, 12, 31, D, J ) + CALL VVD ( D, 15019D0, 0D0, 'slCLDJ', 'D', STATUS ) + CALL VIV ( J, 0, 'slCLDJ', 'J', STATUS ) + + END + + SUBROUTINE T_CR2AF ( STATUS ) +*+ +* - - - - - - - - +* T _ C R A F +* - - - - - - - - +* +* Test slCRAF, slDRAF routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCRAF, VIV, VVD, slDRAF. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER IDMSF(4) + CHARACTER S + + CALL slCRAF ( 4, 2.345E0, S, IDMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '+' ), 'slCRAF', 'S', STATUS ) + CALL VIV ( IDMSF(1), 134, 'slCRAF', '(1)', STATUS ) + CALL VIV ( IDMSF(2), 21, 'slCRAF', '(2)', STATUS ) + CALL VIV ( IDMSF(3), 30, 'slCRAF', '(3)', STATUS ) + CALL VVD ( DBLE( IDMSF(4) ), 9706D0, 1000D0, 'slCRAF', + : '(4)', STATUS ) + + CALL slDRAF ( 4, 2.345D0, S, IDMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '+' ), 'slDRAF', 'S', STATUS ) + CALL VIV ( IDMSF(1), 134, 'slDRAF', '(1)', STATUS ) + CALL VIV ( IDMSF(2), 21, 'slDRAF', '(2)', STATUS ) + CALL VIV ( IDMSF(3), 30, 'slDRAF', '(3)', STATUS ) + CALL VIV ( IDMSF(4), 9706, 'slDRAF', '(4)', STATUS ) + + END + + SUBROUTINE T_CR2TF ( STATUS ) +*+ +* - - - - - - - - +* T _ C R T F +* - - - - - - - - +* +* Test slCRTF, slDRTF routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCRTF, VIV, VVD, slDRTF. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER IHMSF(4) + CHARACTER S + + CALL slCRTF ( 4, -3.01234E0, S, IHMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '-' ), 'slCRTF', 'S', STATUS ) + CALL VIV ( IHMSF(1), 11, 'slCRTF', '(1)', STATUS ) + CALL VIV ( IHMSF(2), 30, 'slCRTF', '(2)', STATUS ) + CALL VIV ( IHMSF(3), 22, 'slCRTF', '(3)', STATUS ) + CALL VVD ( DBLE( IHMSF(4) ), 6484D0, 1000D0, 'slCRTF', + : '(4)', STATUS ) + + CALL slDRTF ( 4, -3.01234D0, S, IHMSF ) + CALL VIV ( ICHAR( S ), ICHAR( '-' ), 'slDRTF', 'S', STATUS ) + CALL VIV ( IHMSF(1), 11, 'slDRTF', '(1)', STATUS ) + CALL VIV ( IHMSF(2), 30, 'slDRTF', '(2)', STATUS ) + CALL VIV ( IHMSF(3), 22, 'slDRTF', '(3)', STATUS ) + CALL VIV ( IHMSF(4), 6484, 'slDRTF', '(4)', STATUS ) + + END + + SUBROUTINE T_CS2C6 ( STATUS ) +*+ +* - - - - - - - - +* T _ S 2 C 6 +* - - - - - - - - +* +* Test slS2C6, slDSC6 routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slS2C6, VVD, slDSC6. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL V(6) + DOUBLE PRECISION DV(6) + + CALL slS2C6( -3.21E0, 0.123E0, 0.456E0, -7.8E-6, 9.01E-6, + : -1.23E-5, V ) + CALL VVD ( DBLE( V(1) ), -0.4514964673880165D0, + : 1D-6, 'slS2C6', 'X', STATUS ) + CALL VVD ( DBLE( V(2) ), 0.03093394277342585D0, + : 1D-6, 'slS2C6', 'Y', STATUS ) + CALL VVD ( DBLE( V(3) ), 0.05594668105108779D0, + : 1D-6, 'slS2C6', 'Z', STATUS ) + CALL VVD ( DBLE( V(4) ), 1.292270850663260D-5, + : 1D-6, 'slS2C6', 'XD', STATUS ) + CALL VVD ( DBLE( V(5) ), 2.652814182060692D-6, + : 1D-6, 'slS2C6', 'YD', STATUS ) + CALL VVD ( DBLE( V(6) ), 2.568431853930293D-6, + : 1D-6, 'slS2C6', 'ZD', STATUS ) + + CALL slDSC6( -3.21D0, 0.123D0, 0.456D0, -7.8D-6, 9.01D-6, + : -1.23D-5, DV ) + CALL VVD ( DV(1), -0.4514964673880165D0, 1D-12, 'slDSC6', + : 'X', STATUS ) + CALL VVD ( DV(2), 0.03093394277342585D0, 1D-12, 'slDSC6', + : 'Y', STATUS ) + CALL VVD ( DV(3), 0.05594668105108779D0, 1D-12, 'slDSC6', + : 'Z', STATUS ) + CALL VVD ( DV(4), 1.292270850663260D-5, 1D-12, 'slDSC6', + : 'XD', STATUS ) + CALL VVD ( DV(5), 2.652814182060692D-6, 1D-12, 'slDSC6', + : 'YD', STATUS ) + CALL VVD ( DV(6), 2.568431853930293D-6, 1D-12, 'slDSC6', + : 'ZD', STATUS ) + + END + + SUBROUTINE T_CTF2D ( STATUS ) +*+ +* - - - - - - - - +* T _ C T F D +* - - - - - - - - +* +* Test slCTFD, slDTFD routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCTFD, VVD, VIV, slDTFD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + REAL D + DOUBLE PRECISION DD + + CALL slCTFD (23, 56, 59.1E0, D, J) + CALL VVD ( DBLE( D ), 0.99790625D0, 1D-6, 'slCTFD', + : 'D', STATUS ) + CALL VIV ( J, 0, 'slCTFD', 'J', STATUS ) + + CALL slDTFD (23, 56, 59.1D0, DD, J) + CALL VVD ( DD, 0.99790625D0, 1D-12, 'slDTFD', 'D', STATUS ) + CALL VIV ( J, 0, 'slDTFD', 'J', STATUS ) + + END + + SUBROUTINE T_CTF2R ( STATUS ) +*+ +* - - - - - - - - +* T _ C T F R +* - - - - - - - - +* +* Test slCTFR, slDTFR routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCTFR, VVD, VIV, slDTFR. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + REAL R + DOUBLE PRECISION DR + + CALL slCTFR (23, 56, 59.1E0, R, J) + CALL VVD ( DBLE( R ), 6.270029887942679D0, 1D-6, 'slCTFR', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slCTFR', 'J', STATUS ) + + CALL slDTFR (23, 56, 59.1D0, DR, J) + CALL VVD ( DR, 6.270029887942679D0, 1D-12, 'slDTFR', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slDTFR', 'J', STATUS ) + + END + + SUBROUTINE T_DAT ( STATUS ) +*+ +* - - - - - - +* T _ D A T +* - - - - - - +* +* Test slDAT, slDTT, slDT routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slDAT, slDTT, slDT, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slDAT, slDTT, slDT + + + CALL VVD ( slDAT ( 43900D0 ), 18D0, 0D0, 'slDAT', + : ' ', STATUS ) + CALL VVD ( slDTT ( 40404D0 ), 39.709746D0, 1D-12, 'slDTT', + : ' ', STATUS ) + CALL VVD ( slDT ( 500D0 ), 4686.7D0, 1D-10, 'slDT', + : '500', STATUS ) + CALL VVD ( slDT ( 1400D0 ), 408D0, 1D-11, 'slDT', + : '1400', STATUS ) + CALL VVD ( slDT ( 1950D0 ), 27.99145626D0, 1D-12, 'slDT', + : '1950', STATUS ) + + END + + SUBROUTINE T_DBJIN ( STATUS ) +*+ +* - - - - - - - - +* T _ D B J I +* - - - - - - - - +* +* Test slDBJI routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slDBJI, VVD, VIV. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I, JA, JB + DOUBLE PRECISION D + CHARACTER*32 S + DATA S /' B1950, , J 2000, B1975 JE '/ + + I = 1 + D = 0D0 + + CALL slDBJI ( S, I, D, JA, JB ) + CALL VIV ( I, 9, 'slDBJI', 'I1', STATUS ) + CALL VVD ( D, 1950D0, 0D0, 'slDBJI', 'D1', STATUS ) + CALL VIV ( JA, 0, 'slDBJI', 'JA1', STATUS ) + CALL VIV ( JB, 1, 'slDBJI', 'JB1', STATUS ) + + CALL slDBJI ( S, I, D, JA, JB ) + CALL VIV ( I, 11, 'slDBJI', 'I2', STATUS ) + CALL VVD ( D, 1950D0, 0D0, 'slDBJI', 'D2', STATUS ) + CALL VIV ( JA, 1, 'slDBJI', 'JA2', STATUS ) + CALL VIV ( JB, 0, 'slDBJI', 'JB2', STATUS ) + + CALL slDBJI ( S, I, D, JA, JB ) + CALL VIV ( I, 19, 'slDBJI', 'I3', STATUS ) + CALL VVD ( D, 2000D0, 0D0, 'slDBJI', 'D3', STATUS ) + CALL VIV ( JA, 0, 'slDBJI', 'JA3', STATUS ) + CALL VIV ( JB, 2, 'slDBJI', 'JB3', STATUS ) + + CALL slDBJI ( S, I, D, JA, JB ) + CALL VIV ( I, 26, 'slDBJI', 'I4', STATUS ) + CALL VVD ( D, 1975D0, 0D0, 'slDBJI', 'D4', STATUS ) + CALL VIV ( JA, 0, 'slDBJI', 'JA4', STATUS ) + CALL VIV ( JB, 1, 'slDBJI', 'JB4', STATUS ) + + CALL slDBJI ( S, I, D, JA, JB ) + CALL VIV ( I, 26, 'slDBJI', 'I5', STATUS ) + CALL VVD ( D, 1975D0, 0D0, 'slDBJI', 'D5', STATUS ) + CALL VIV ( JA, 1, 'slDBJI', 'JA5', STATUS ) + CALL VIV ( JB, 0, 'slDBJI', 'JB5', STATUS ) + + END + + SUBROUTINE T_DJCAL ( STATUS ) +*+ +* - - - - - - - - +* T _ D J C A +* - - - - - - - - +* +* Test slDJCA, slDJCL routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slDJCA, VIV. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER IYDMF(4), J, IY, IM, ID + DOUBLE PRECISION DJM + DOUBLE PRECISION F + + DJM = 50123.9999D0 + + CALL slDJCA ( 4, DJM, IYDMF, J ) + CALL VIV ( IYDMF(1), 1996, 'slDJCA', 'Y', STATUS ) + CALL VIV ( IYDMF(2), 2, 'slDJCA', 'M', STATUS ) + CALL VIV ( IYDMF(3), 10, 'slDJCA', 'D', STATUS ) + CALL VIV ( IYDMF(4), 9999, 'slDJCA', 'F', STATUS ) + CALL VIV ( J, 0, 'slDJCA', 'J', STATUS ) + + CALL slDJCL ( DJM, IY, IM, ID, F, J ) + CALL VIV ( IY, 1996, 'slDJCL', 'Y', STATUS ) + CALL VIV ( IM, 2, 'slDJCL', 'M', STATUS ) + CALL VIV ( ID, 10, 'slDJCL', 'D', STATUS ) + CALL VVD ( F, 0.9999D0, 1D-7, 'slDJCL', 'F', STATUS ) + CALL VIV ( J, 0, 'slDJCL', 'J', STATUS ) + + END + + SUBROUTINE T_DMAT ( STATUS ) +*+ +* - - - - - - - +* T _ D M A T +* - - - - - - - +* +* Test slDMAT routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slDMAT, VVD, VIV. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J, IW(3) + DOUBLE PRECISION DA(3,3) + DOUBLE PRECISION DV(3) + DOUBLE PRECISION DD + + DATA DA/2.22D0, 1.6578D0, 1.380522D0, + : 1.6578D0, 1.380522D0, 1.22548578D0, + : 1.380522D0, 1.22548578D0, 1.1356276122D0/ + DATA DV/2.28625D0, 1.7128825D0, 1.429432225D0/ + + CALL slDMAT ( 3, DA, DV, DD, J, IW ) + + CALL VVD ( DA(1,1), 18.02550629769198D0, + : 1D-10, 'slDMAT', 'A(1,1)', STATUS ) + CALL VVD ( DA(1,2), -52.16386644917280607D0, + : 1D-10, 'slDMAT', 'A(1,2)', STATUS ) + CALL VVD ( DA(1,3), 34.37875949717850495D0, + : 1D-10, 'slDMAT', 'A(1,3)', STATUS ) + CALL VVD ( DA(2,1), -52.16386644917280607D0, + : 1D-10, 'slDMAT', 'A(2,1)', STATUS ) + CALL VVD ( DA(2,2), 168.1778099099805627D0, + : 1D-10, 'slDMAT', 'A(2,2)', STATUS ) + CALL VVD ( DA(2,3), -118.0722869694232670D0, + : 1D-10, 'slDMAT', 'A(2,3)', STATUS ) + CALL VVD ( DA(3,1), 34.37875949717850495D0, + : 1D-10, 'slDMAT', 'A(3,1)', STATUS ) + CALL VVD ( DA(3,2), -118.0722869694232670D0, + : 1D-10, 'slDMAT', 'A(3,2)', STATUS ) + CALL VVD ( DA(3,3), 86.50307003740151262D0, + : 1D-10, 'slDMAT', 'A(3,3)', STATUS ) + CALL VVD ( DV(1), 1.002346480763383D0, + : 1D-12, 'slDMAT', 'V(1)', STATUS ) + CALL VVD ( DV(2), 0.03285594016974583489D0, + : 1D-12, 'slDMAT', 'V(2)', STATUS ) + CALL VVD ( DV(3), 0.004760688414885247309D0, + : 1D-12, 'slDMAT', 'V(3)', STATUS ) + CALL VVD ( DD, 0.003658344147359863D0, + : 1D-12, 'slDMAT', 'D', STATUS ) + CALL VIV ( J, 0, 'slDMAT', 'J', STATUS ) + + END + + SUBROUTINE T_E2H ( STATUS ) +*+ +* - - - - - - - +* T _ E 2 H +* - - - - - - - +* +* Test slE2H, slDE2H, slH2E, slDH2E routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: All the above plus VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL H, D, P, A, E + DOUBLE PRECISION DH, DD, DP, DA, DE + + DH = -0.3D0 + DD = -1.1D0 + DP = -0.7D0 + + H = SNGL( DH ) + D = SNGL( DD ) + P = SNGL( DP ) + + CALL slDE2H ( DH, DD, DP, DA, DE ) + CALL VVD ( DA, 2.820087515852369D0, 1D-12, 'slDE2H', + : 'AZ', STATUS ) + CALL VVD ( DE, 1.132711866443304D0, 1D-12, 'slDE2H', + : 'El', STATUS ) + + CALL slE2H ( H, D, P, A, E ) + CALL VVD ( DBLE( A ), 2.820087515852369D0, 1D-6, 'slE2H', + : 'AZ', STATUS ) + CALL VVD ( DBLE( E ), 1.132711866443304D0, 1D-6, 'slE2H', + : 'El', STATUS ) + + CALL slDH2E ( DA, DE, DP, DH, DD ) + CALL VVD ( DH, -0.3D0, 1D-12, 'slDH2E', 'HA', STATUS ) + CALL VVD ( DD, -1.1D0, 1D-12, 'slDH2E', 'DEC', STATUS ) + + CALL slH2E ( A, E, P, H, D ) + CALL VVD ( DBLE( H ), -0.3D0, 1D-6, 'slH2E', + : 'HA', STATUS ) + CALL VVD ( DBLE( D ), -1.1D0, 1D-6, 'slH2E', + : 'DEC', STATUS ) + + END + + SUBROUTINE T_EARTH ( STATUS ) +*+ +* - - - - - - - - +* T _ E R T H +* - - - - - - - - +* +* Test slERTH routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slERTH, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL PV(6) + + CALL slERTH ( 1978, 174, 0.87E0, PV ) + + CALL VVD ( DBLE( PV(1) ), 3.590867086D-2, 1D-6, 'slERTH', + : 'PV(1)', STATUS ) + CALL VVD ( DBLE( PV(2) ), -9.319285116D-1, 1D-6, 'slERTH', + : 'PV(2)', STATUS ) + CALL VVD ( DBLE( PV(3) ), -4.041039435D-1, 1D-6, 'slERTH', + : 'PV(3)', STATUS ) + CALL VVD ( DBLE( PV(4) ), 1.956930055D-7, 1D-13, 'slERTH', + : 'PV(4)', STATUS ) + CALL VVD ( DBLE( PV(5) ), 5.743797400D-9, 1D-13, 'slERTH', + : 'PV(5)', STATUS ) + CALL VVD ( DBLE( PV(6) ), 2.512001677D-9, 1D-13, 'slERTH', + : 'PV(6)', STATUS ) + + END + + SUBROUTINE T_ECLEQ ( STATUS ) +*+ +* - - - - - - - - +* T _ E C E Q +* - - - - - - - - +* +* Test slECEQ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slECEQ, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R, D + + CALL slECEQ ( 1.234D0, -0.123D0, 43210D0, R, D ) + + CALL VVD ( R, 1.229910118208851D0, 1D-12, 'slECEQ', + : 'RA', STATUS ) + CALL VVD ( D, 0.2638461400411088D0, 1D-12, 'slECEQ', + : 'DEC', STATUS ) + + END + + SUBROUTINE T_ECMAT ( STATUS ) +*+ +* - - - - - - - - +* T _ E C M A +* - - - - - - - - +* +* Test slECMA routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slECMA, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RM(3,3) + + CALL slECMA ( 41234D0, RM ) + + CALL VVD ( RM(1,1), 1D0, 1D-12, 'slECMA', + : '(1,1)', STATUS ) + CALL VVD ( RM(1,2), 0D0, 1D-12, 'slECMA', + : '(1,2)', STATUS ) + CALL VVD ( RM(1,3), 0D0, 1D-12, 'slECMA', + : '(1,3)', STATUS ) + CALL VVD ( RM(2,1), 0D0, 1D-12, 'slECMA', + : '(2,1)', STATUS ) + CALL VVD ( RM(2,2), 0.917456575085716D0, 1D-12, 'slECMA', + : '(2,2)', STATUS ) + CALL VVD ( RM(2,3), 0.397835937079581D0, 1D-12, 'slECMA', + : '(2,3)', STATUS ) + CALL VVD ( RM(3,1), 0D0, 1D-12, 'slECMA', + : '(3,1)', STATUS ) + CALL VVD ( RM(3,2), -0.397835937079581D0, 1D-12, 'slECMA', + : '(3,2)', STATUS ) + CALL VVD ( RM(3,3), 0.917456575085716D0, 1D-12, 'slECMA', + : '(3,3)', STATUS ) + + END + + SUBROUTINE T_ECOR ( STATUS ) +*+ +* - - - - - - - +* T _ E C O R +* - - - - - - - +* +* Test slECOR routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slECOR, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL RV, Tl + + CALL slECOR ( 2.345E0, -0.567E0, 1995, 306, 0.037E0, RV, Tl ) + + CALL VVD ( DBLE( RV ), -19.182460D0, 1D-3, 'slECOR', + : 'RV', STATUS ) + CALL VVD ( DBLE( Tl ), -120.36632D0, 1D-2, 'slECOR', + : 'Tl', STATUS ) + + END + + SUBROUTINE T_EG50 ( STATUS ) +*+ +* - - - - - - - +* T _ E G 5 0 +* - - - - - - - +* +* Test slEG50 routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEG50, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DL, DB + + CALL slEG50 ( 3.012D0, 1.234D0, DL, DB ) + + CALL VVD ( DL, 2.305557953813397D0, 1D-12, 'slEG50', + : 'L', STATUS ) + CALL VVD ( DB, 0.7903600886585871D0, 1D-12, 'slEG50', + : 'B', STATUS ) + + END + + SUBROUTINE T_EPB ( STATUS ) + +*+ +* - - - - - - +* T _ E P B +* - - - - - - +* +* Test slEPB routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEPB, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEPB + + + CALL VVD ( slEPB ( 45123D0 ), 1982.419793168669D0, 1D-8, + : 'slEPB', ' ', STATUS ) + + END + + SUBROUTINE T_EPB2D ( STATUS ) +*+ +* - - - - - - - +* T _ E B 2 D +* - - - - - - - +* +* Test slEB2D routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEB2D, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEB2D + + + CALL VVD ( slEB2D ( 1975.5D0 ), 42595.5995279655D0, 1D-7, + : 'slEB2D', ' ', STATUS ) + + END + + SUBROUTINE T_EPCO ( STATUS ) +*+ +* - - - - - - - +* T _ E P C O +* - - - - - - - +* +* Test slEPCO routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEPCO, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEPCO + + + CALL VVD ( slEPCO ( 'B', 'J', 2000D0 ), 2000.001277513665D0, + : 1D-7, 'slEPCO', 'BJ', STATUS ) + CALL VVD ( slEPCO ( 'J', 'B', 1950D0 ), 1949.999790442300D0, + : 1D-7, 'slEPCO', 'JB', STATUS ) + CALL VVD ( slEPCO ( 'J', 'J', 2000D0 ), 2000D0, + : 1D-7, 'slEPCO', 'JJ', STATUS ) + + END + + SUBROUTINE T_EPJ ( STATUS ) +*+ +* - - - - - - +* T _ E P J +* - - - - - - +* +* Test slEPJ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEPJ, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEPJ + + + CALL VVD ( slEPJ ( 42999D0 ), 1976.603696098563D0, + : 1D-7, 'slEPJ', ' ', STATUS ) + + END + + SUBROUTINE T_EPJ2D ( STATUS ) +*+ +* - - - - - - - - +* T _ E J 2 D +* - - - - - - - - +* +* Test slEJ2D routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEJ2D, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEJ2D + + + CALL VVD ( slEJ2D ( 2010.077D0 ), 55225.124250D0, + : 1D-6, 'slEJ2D', ' ', STATUS ) + + END + + SUBROUTINE T_EQECL ( STATUS ) +*+ +* - - - - - - - - +* T _ E Q E C +* - - - - - - - - +* +* Test slEQEC routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEQEC, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DL, DB + + CALL slEQEC ( 0.789D0, -0.123D0, 46555D0, DL, DB ) + + CALL VVD ( DL, 0.7036566430349022D0, 1D-12, 'slEQEC', + : 'L', STATUS ) + CALL VVD ( DB, -0.4036047164116848D0, 1D-12, 'slEQEC', + : 'B', STATUS ) + + END + + SUBROUTINE T_EQEQX ( STATUS ) +*+ +* - - - - - - - - +* T _ E Q E X +* - - - - - - - - +* +* Test slEQEX routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEQEX, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slEQEX + + + CALL VVD ( slEQEX ( 41234D0 ), 5.376047445838358596D-5, + : 1D-17, 'slEQEX', ' ', STATUS ) + + END + + SUBROUTINE T_EQGAL ( STATUS ) +*+ +* - - - - - - - - +* T _ E Q G A +* - - - - - - - - +* +* Test slEQGA routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEQGA, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DL, DB + + CALL slEQGA ( 5.67D0, -1.23D0, DL, DB ) + + CALL VVD ( DL, 5.612270780904526D0, 1D-12, 'slEQGA', + : 'DL', STATUS ) + CALL VVD ( DB, -0.6800521449061520D0, 1D-12, 'slEQGA', + : 'DB', STATUS ) + + END + + SUBROUTINE T_ETRMS ( STATUS ) +*+ +* - - - - - - - - +* T _ E T R M +* - - - - - - - - +* +* Test slETRM routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slETRM, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION EV(3) + + CALL slETRM ( 1976.9D0, EV ) + + CALL VVD ( EV(1), -1.621617102537041D-6, 1D-18, 'slETRM', + : 'X', STATUS ) + CALL VVD ( EV(2), -3.310070088507914D-7, 1D-18, 'slETRM', + : 'Y', STATUS ) + CALL VVD ( EV(3), -1.435296627515719D-7, 1D-18, 'slETRM', + : 'Z', STATUS ) + + END + + SUBROUTINE T_EVP ( STATUS ) +*+ +* - - - - - - +* T _ E V P +* - - - - - - +* +* Test slEVP and slEPV routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slEVP, slEPV, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DVB(3), DPB(3), DVH(3), DPH(3) + + CALL slEVP ( 50100D0, 1990D0, DVB, DPB, DVH, DPH ) + + CALL VVD ( DVB(1), -1.807210068604058436D-7, 1D-14, 'slEVP', + : 'DVB(X)', STATUS ) + CALL VVD ( DVB(2), -8.385891022440320D-8, 1D-14, 'slEVP', + : 'DVB(Y)', STATUS ) + CALL VVD ( DVB(3), -3.635846882638055D-8, 1D-14, 'slEVP', + : 'DVB(Z)', STATUS ) + CALL VVD ( DPB(1), -0.4515615297360333D0, 1D-7, 'slEVP', + : 'DPB(X)', STATUS ) + CALL VVD ( DPB(2), 0.8103788166239596D0, 1D-7, 'slEVP', + : 'DPB(Y)', STATUS ) + CALL VVD ( DPB(3), 0.3514505204144827D0, 1D-7, 'slEVP', + : 'DPB(Z)', STATUS ) + CALL VVD ( DVH(1), -1.806354061156890855D-7, 1D-14, 'slEVP', + : 'DVH(X)', STATUS ) + CALL VVD ( DVH(2), -8.383798678086174D-8, 1D-14, 'slEVP', + : 'DVH(Y)', STATUS ) + CALL VVD ( DVH(3), -3.635185843644782D-8, 1D-14, 'slEVP', + : 'DVH(Z)', STATUS ) + CALL VVD ( DPH(1), -0.4478571659918565D0, 1D-7, 'slEVP', + : 'DPH(X)', STATUS ) + CALL VVD ( DPH(2), 0.8036439916076232D0, 1D-7, 'slEVP', + : 'DPH(Y)', STATUS ) + CALL VVD ( DPH(3), 0.3484298459102053D0, 1D-7, 'slEVP', + : 'DPH(Z)', STATUS ) + + CALL slEPV ( 53411.52501161D0, DPH, DVH, DPB, DVB ) + + CALL VVD ( DPH(1), -0.7757238809297653D0, 1D-12, 'slEPV', + : 'DPH(X)', STATUS ) + CALL VVD ( DPH(2), +0.5598052241363390D0, 1D-12, 'slEPV', + : 'DPH(Y)', STATUS ) + CALL VVD ( DPH(3), +0.2426998466481708D0, 1D-12, 'slEPV', + : 'DPH(Z)', STATUS ) + CALL VVD ( DVH(1), -0.0109189182414732D0, 1D-12, 'slEPV', + : 'DVH(X)', STATUS ) + CALL VVD ( DVH(2), -0.0124718726844084D0, 1D-12, 'slEPV', + : 'DVH(Y)', STATUS ) + CALL VVD ( DVH(3), -0.0054075694180650D0, 1D-12, 'slEPV', + : 'DVH(Z)', STATUS ) + CALL VVD ( DPB(1), -0.7714104440491060D0, 1D-12, 'slEPV', + : 'DPB(X)', STATUS ) + CALL VVD ( DPB(2), +0.5598412061824225D0, 1D-12, 'slEPV', + : 'DPB(Y)', STATUS ) + CALL VVD ( DPB(3), +0.2425996277722475D0, 1D-12, 'slEPV', + : 'DPB(Z)', STATUS ) + CALL VVD ( DVB(1), -0.0109187426811683D0, 1D-12, 'slEPV', + : 'DVB(X)', STATUS ) + CALL VVD ( DVB(2), -0.0124652546173285D0, 1D-12, 'slEPV', + : 'DVB(Y)', STATUS ) + CALL VVD ( DVB(3), -0.0054047731809662D0, 1D-12, 'slEPV', + : 'DVB(Z)', STATUS ) + + END + + SUBROUTINE T_FITXY ( STATUS ) +*+ +* - - - - - - - - +* T _ F T X Y +* - - - - - - - - +* +* Test slFTXY, slPXY, slINVF, slXYXY, slDCMF routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slFTXY, VVD, VIV, slPXY, slINVF, slXYXY, slDCMF. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J, NPTS + + PARAMETER (NPTS = 8) + + DOUBLE PRECISION XYE(2,NPTS) + DOUBLE PRECISION XYM(2,NPTS) + DOUBLE PRECISION COEFFS(6), XYP(2,NPTS), XRMS, YRMS, RRMS, + : BKWDS(6), X2, Y2, XZ, YZ, XS, YS, PERP, ORIENT + + DATA XYE/-23.4D0, -12.1D0, 32D0, -15.3D0, + : 10.9D0, 23.7D0, -3D0, 16.1D0, + : 45D0, 32.5D0, 8.6D0, -17D0, + : 15.3D0, 10D0, 121.7D0, -3.8D0/ + DATA XYM/-23.41D0, 12.12D0, 32.03D0, 15.34D0, + : 10.93D0,-23.72D0, -3.01D0, -16.10D0, + : 44.90D0,-32.46D0, 8.55D0, 17.02D0, + : 15.31D0,-10.07D0, 120.92D0, 3.81D0/ + +* Fit a 4-coeff linear model to relate two sets of (x,y) coordinates. + + CALL slFTXY ( 4, NPTS, XYE, XYM, COEFFS, J ) + CALL VVD ( COEFFS(1), -7.938263381515947D-3, + : 1D-12, 'slFTXY', '4/1', STATUS ) + CALL VVD ( COEFFS(2), 1.004640925187200D0, + : 1D-12, 'slFTXY', '4/2', STATUS ) + CALL VVD ( COEFFS(3), 3.976948048238268D-4, + : 1D-12, 'slFTXY', '4/3', STATUS ) + CALL VVD ( COEFFS(4), -2.501031681585021D-2, + : 1D-12, 'slFTXY', '4/4', STATUS ) + CALL VVD ( COEFFS(5), 3.976948048238268D-4, + : 1D-12, 'slFTXY', '4/5', STATUS ) + CALL VVD ( COEFFS(6), -1.004640925187200D0, + : 1D-12, 'slFTXY', '4/6', STATUS ) + CALL VIV ( J, 0, 'slFTXY', '4/J', STATUS ) + +* Same but 6-coeff. + + CALL slFTXY ( 6, NPTS, XYE, XYM, COEFFS, J ) + CALL VVD ( COEFFS(1), -2.617232551841476D-2, + : 1D-12, 'slFTXY', '6/1', STATUS ) + CALL VVD ( COEFFS(2), 1.005634905041421D0, + : 1D-12, 'slFTXY', '6/2', STATUS ) + CALL VVD ( COEFFS(3), 2.133045023329208D-3, + : 1D-12, 'slFTXY', '6/3', STATUS ) + CALL VVD ( COEFFS(4), 3.846993364417779909D-3, + : 1D-12, 'slFTXY', '6/4', STATUS ) + CALL VVD ( COEFFS(5), 1.301671386431460D-4, + : 1D-12, 'slFTXY', '6/5', STATUS ) + CALL VVD ( COEFFS(6), -0.9994827065693964D0, + : 1D-12, 'slFTXY', '6/6', STATUS ) + CALL VIV ( J, 0, 'slFTXY', '6/J', STATUS ) + +* Compute predicted coordinates and residuals. + + CALL slPXY ( NPTS, XYE, XYM, COEFFS, XYP, XRMS, YRMS, RRMS ) + CALL VVD ( XYP(1,1), -23.542232946855340D0, + : 1D-12, 'slPXY', 'X1', STATUS ) + CALL VVD ( XYP(2,1), -12.11293062297230597D0, + : 1D-12, 'slPXY', 'Y1', STATUS ) + CALL VVD ( XYP(1,2), 32.217034593616180D0, + : 1D-12, 'slPXY', 'X2', STATUS ) + CALL VVD ( XYP(2,2), -15.324048471959370D0, + : 1D-12, 'slPXY', 'Y2', STATUS ) + CALL VVD ( XYP(1,3), 10.914821358630950D0, + : 1D-12, 'slPXY', 'X3', STATUS ) + CALL VVD ( XYP(2,3), 23.712999520015880D0, + : 1D-12, 'slPXY', 'Y3', STATUS ) + CALL VVD ( XYP(1,4), -3.087475414568693D0, + : 1D-12, 'slPXY', 'X4', STATUS ) + CALL VVD ( XYP(2,4), 16.09512676604438414D0, + : 1D-12, 'slPXY', 'Y4', STATUS ) + CALL VVD ( XYP(1,5), 45.05759626938414666D0, + : 1D-12, 'slPXY', 'X5', STATUS ) + CALL VVD ( XYP(2,5), 32.45290015313210889D0, + : 1D-12, 'slPXY', 'Y5', STATUS ) + CALL VVD ( XYP(1,6), 8.608310538882801D0, + : 1D-12, 'slPXY', 'X6', STATUS ) + CALL VVD ( XYP(2,6), -17.006235743411300D0, + : 1D-12, 'slPXY', 'Y6', STATUS ) + CALL VVD ( XYP(1,7), 15.348618307280820D0, + : 1D-12, 'slPXY', 'X7', STATUS ) + CALL VVD ( XYP(2,7), 10.07063070741086835D0, + : 1D-12, 'slPXY', 'Y7', STATUS ) + CALL VVD ( XYP(1,8), 121.5833272936291482D0, + : 1D-12, 'slPXY', 'X8', STATUS ) + CALL VVD ( XYP(2,8), -3.788442308260240D0, + : 1D-12, 'slPXY', 'Y8', STATUS ) + CALL VVD ( XRMS ,0.1087247110488075D0, + : 1D-13, 'slPXY', 'XRMS', STATUS ) + CALL VVD ( YRMS, 0.03224481175794666D0, + : 1D-13, 'slPXY', 'YRMS', STATUS ) + CALL VVD ( RRMS, 0.1134054261398109D0, + : 1D-13, 'slPXY', 'RRMS', STATUS ) + +* Invert the model. + + CALL slINVF ( COEFFS, BKWDS, J ) + CALL VVD ( BKWDS(1), 0.02601750208015891D0, + : 1D-12, 'slINVF', '1', status) + CALL VVD ( BKWDS(2), 0.9943963945040283D0, + : 1D-12, 'slINVF', '2', status) + CALL VVD ( BKWDS(3), 0.002122190075497872D0, + : 1D-12, 'slINVF', '3', status) + CALL VVD ( BKWDS(4), 0.003852372795357474353D0, + : 1D-12, 'slINVF', '4', status) + CALL VVD ( BKWDS(5), 0.0001295047252932767D0, + : 1D-12, 'slINVF', '5', status) + CALL VVD ( BKWDS(6), -1.000517284779212D0, + : 1D-12, 'slINVF', '6', status) + CALL VIV ( J, 0, 'slINVF', 'J', STATUS ) + +* Transform one x,y. + + CALL slXYXY ( 44.5D0, 32.5D0, COEFFS, X2, Y2 ) + CALL VVD ( X2, 44.793904912083030D0, + : 1D-11, 'slXYXY', 'X', status) + CALL VVD ( Y2, -32.473548532471330D0, + : 1D-11, 'slXYXY', 'Y', status) + +* Decompose the fit into scales etc. + + CALL slDCMF ( COEFFS, XZ, YZ, XS, YS, PERP, ORIENT ) + CALL VVD ( XZ, -0.0260175020801628646D0, + : 1D-12, 'slDCMF', 'XZ', status) + CALL VVD ( YZ, -0.003852372795357474353D0, + : 1D-12, 'slDCMF', 'YZ', status) + CALL VVD ( XS, -1.00563491346569D0, + : 1D-12, 'slDCMF', 'XS', status) + CALL VVD ( YS, 0.999484982684761D0, + : 1D-12, 'slDCMF', 'YS', status) + CALL VVD ( PERP,-0.002004707996156263D0, + : 1D-12, 'slDCMF', 'P', status) + CALL VVD ( ORIENT, 3.14046086182333D0, + : 1D-12, 'slDCMF', 'O', status) + + END + + SUBROUTINE T_FK425 ( STATUS ) +*+ +* - - - - - - - - +* T _ F K 4 5 +* - - - - - - - - +* +* Test slFK45 routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slFK45. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R2000, D2000, DR2000, DD2000, P2000, V2000 + + CALL slFK45 ( 1.234D0, -0.123D0, -1D-5, 2D-6, 0.5D0, + : 20D0, R2000, D2000, DR2000, DD2000, P2000, + : V2000 ) + + CALL VVD ( R2000, 1.244117554618727D0, 1D-12, 'slFK45', + : 'R', STATUS ) + CALL VVD ( D2000, -0.1213164254458709D0, 1D-12, 'slFK45', + : 'D', STATUS ) + CALL VVD ( DR2000, -9.964265838268711D-6, 1D-17, 'slFK45', + : 'DR', STATUS ) + CALL VVD ( DD2000, 2.038065265773541D-6, 1D-17, 'slFK45', + : 'DD', STATUS ) + CALL VVD ( P2000, 0.4997443812415410D0, 1D-12, 'slFK45', + : 'P', STATUS ) + CALL VVD ( V2000, 20.010460915421010D0, 1D-11, 'slFK45', + : 'V', STATUS ) + + END + + SUBROUTINE T_FK45Z ( STATUS ) +*+ +* - - - - - - - - +* T _ F 4 5 Z +* - - - - - - - - +* +* Test slF45Z routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slF45Z. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R2000, D2000 + + CALL slF45Z ( 1.234D0, -0.123D0, 1984D0, R2000, D2000 ) + + CALL VVD ( R2000, 1.244616510731691D0, 1D-12, 'slF45Z', + : 'R', STATUS ) + CALL VVD ( D2000, -0.1214185839586555D0, 1D-12, 'slF45Z', + : 'D', STATUS ) + + END + + SUBROUTINE T_FK524 ( STATUS ) +*+ +* - - - - - - - - +* T _ F K 5 4 +* - - - - - - - - +* +* Test slFK54 routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slFK54. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R1950, D1950, DR1950, DD1950, P1950, V1950 + + CALL slFK54 ( 4.567D0, -1.23D0, -3D-5, 8D-6, 0.29D0, + : -35D0, R1950, D1950, DR1950, DD1950, P1950, + : V1950 ) + + CALL VVD ( R1950, 4.543778603272084D0, 1D-12, 'slFK54', + : 'R', STATUS ) + CALL VVD ( D1950, -1.229642790187574D0, 1D-12, 'slFK54', + : 'D', STATUS ) + CALL VVD ( DR1950, -2.957873121769244D-5, 1D-17, 'slFK54', + : 'DR', STATUS ) + CALL VVD ( DD1950, 8.117725309659079D-6, 1D-17, 'slFK54', + : 'DD', STATUS ) + CALL VVD ( P1950, 0.2898494999992917D0, 1D-12, 'slFK54', + : 'P', STATUS ) + CALL VVD ( V1950, -35.026862824252680D0, 1D-11, 'slFK54', + : 'V', STATUS ) + + END + + SUBROUTINE T_FK52H ( STATUS ) +*+ +* - - - - - - - - +* T _ F K 5 H +* - - - - - - - - +* +* Test slFK5H, slHFK5, slF5HZ, slHF5Z routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slFK54, slHFK5. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R5, D5, DR5, DD5, RH, DH, DRH, DDH + + CALL slFK5H ( 1.234D0, -0.987D0, 1D-6, -2D-6, RH, DH, DRH, + : DDH ) + CALL VVD ( RH, 1.234000000272122558D0, 1D-13, 'slFK5H', + : 'R', STATUS ) + CALL VVD ( DH, -0.9869999235218543959D0, 1D-13, 'slFK5H', + : 'D', STATUS ) + CALL VVD ( DRH, 0.000000993178295D0, 1D-13, 'slFK5H', + : 'DR', STATUS ) + CALL VVD ( DDH, -0.000001997665915D0, 1D-13, 'slFK5H', + : 'DD', STATUS ) + CALL slHFK5 ( RH, DH, DRH, DDH, r5, D5, DR5, DD5 ) + CALL VVD ( R5, 1.234D0, 1D-13, 'slHFK5', 'R', STATUS ) + CALL VVD ( D5, -0.987D0, 1D-13, 'slHFK5', 'D', STATUS ) + CALL VVD ( DR5, 1D-6, 1D-13, 'slHFK5', 'DR', STATUS ) + CALL VVD ( DD5, -2D-6, 1D-13, 'slHFK5', 'DD', STATUS ) + CALL slF5HZ ( 1.234D0, -0.987D0, 1980D0, RH, DH ) + CALL VVD ( RH, 1.234000136713611301D0, 1D-13, 'slF5HZ', + : 'R', STATUS ) + CALL VVD ( DH, -0.9869999702020807601D0, 1D-13, 'slF5HZ', + : 'D', STATUS ) + CALL slHF5Z ( RH, DH, 1980D0, R5, D5, DR5, DD5 ) + CALL VVD ( R5, 1.234D0, 1D-13, 'slHF5Z', 'R', STATUS ) + CALL VVD ( D5, -0.987D0, 1D-13, 'slHF5Z', 'D', STATUS ) + CALL VVD ( DR5, 0.000000006822074D0, 1D-13, 'slHF5Z', + : 'DR', STATUS ) + CALL VVD ( DD5, -0.000000002334012D0, 1D-13, 'slHF5Z', + : 'DD', STATUS ) + + END + + SUBROUTINE T_FK54Z ( STATUS ) +*+ +* - - - - - - - - +* T _ F 5 4 Z +* - - - - - - - - +* +* Test slF54Z routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slF54Z. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R1950, D1950, DR1950, DD1950 + + CALL slF54Z ( 0.001D0, -1.55D0, 1900D0, R1950, D1950, + : DR1950, DD1950 ) + + CALL VVD ( R1950, 6.271585543439484D0, 1D-12, 'slF54Z', + : 'R', STATUS ) + CALL VVD ( D1950, -1.554861715330319D0, 1D-12, 'slF54Z', + : 'D', STATUS ) + CALL VVD ( DR1950, -4.175410876044916011D-8, 1D-20, 'slF54Z', + : 'DR', STATUS ) + CALL VVD ( DD1950, 2.118595098308522D-8, 1D-20, 'slF54Z', + : 'DD', STATUS ) + + END + + SUBROUTINE T_FLOTIN ( STATUS ) +*+ +* - - - - - - - - - +* T _ R F L I +* - - - - - - - - - +* +* Test slRFLI, slDFLI routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slRFLI, VVD, VIV, slDFLI. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I, J + REAL FV + DOUBLE PRECISION DV + CHARACTER*33 S + DATA S /' 12.345, , -0 1E3-4 2000 E '/ + + I = 1 + FV = 0.0 + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 10, 'slRFLI', 'V5', STATUS ) + CALL VVD ( DBLE( FV ), 12.345D0, 1D-5, 'slRFLI', + : 'V1', STATUS ) + CALL VIV ( J, 0, 'slRFLI', 'J1', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 12, 'slRFLI', 'I2', STATUS ) + CALL VVD ( DBLE( FV ), 12.345D0, 1D-5, 'slRFLI', + : 'V2', STATUS ) + CALL VIV ( J, 1, 'slRFLI', 'J2', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 16, 'slRFLI', 'I3', STATUS ) + CALL VVD ( DBLE( FV ), 0D0, 0D0, 'slRFLI', 'V3', STATUS ) + CALL VIV ( J, -1, 'slRFLI', 'J3', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 19, 'slRFLI', 'I4', STATUS ) + CALL VVD ( DBLE( FV), 1000D0, 0D0, 'slRFLI', 'V4', STATUS ) + CALL VIV ( J, 0, 'slRFLI', 'J4', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 22, 'slRFLI', 'I5', STATUS ) + CALL VVD ( DBLE( FV ), -4D0, 0D0, 'slRFLI', 'V5', STATUS ) + CALL VIV ( J, -1, 'slRFLI', 'J5', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 28, 'slRFLI', 'I6', STATUS ) + CALL VVD ( DBLE( FV ), 2000D0, 0D0, 'slRFLI', + : 'V6', STATUS ) + CALL VIV ( J, 0, 'slRFLI', 'J6', STATUS ) + + CALL slRFLI ( S, I, FV, J ) + CALL VIV ( I, 34, 'slRFLI', 'I7', STATUS ) + CALL VVD ( DBLE( FV ), 2000D0, 0D0, 'slRFLI', + : 'V7', STATUS ) + CALL VIV ( J, 2, 'slRFLI', 'J7', STATUS ) + + I = 1 + DV = 0D0 + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 10, 'slDFLI', 'I1', STATUS ) + CALL VVD ( DV, 12.345D0, 1D-12, 'slDFLI', 'V1', STATUS ) + CALL VIV ( J, 0, 'slDFLI', 'J1', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 12, 'slDFLI', 'I2', STATUS ) + CALL VVD ( DV, 12.345D0, 1D-12, 'slDFLI', 'V2', STATUS ) + CALL VIV ( J, 1, 'slDFLI', 'J2', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 16, 'slDFLI', 'I3', STATUS ) + CALL VVD ( DV, 0D0, 0D0, 'slDFLI', 'V3', STATUS ) + CALL VIV ( J, -1, 'slDFLI', 'J3', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 19, 'slDFLI', 'I4', STATUS ) + CALL VVD ( DV, 1000D0, 0D0, 'slDFLI', 'V4', STATUS ) + CALL VIV ( J, 0, 'slDFLI', 'J4', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 22, 'slDFLI', 'I5', STATUS ) + CALL VVD ( DV, -4D0, 0D0, 'slDFLI', 'V5', STATUS ) + CALL VIV ( J, -1, 'slDFLI', 'J5', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 28, 'slDFLI', 'I6', STATUS ) + CALL VVD ( DV, 2000D0, 0D0, 'slDFLI', 'V6', STATUS ) + CALL VIV ( J, 0, 'slDFLI', 'J6', STATUS ) + + CALL slDFLI ( S, I, DV, J ) + CALL VIV ( I, 34, 'slDFLI', 'I7', STATUS ) + CALL VVD ( DV, 2000D0, 0D0, 'slDFLI', 'V7', STATUS ) + CALL VIV ( J, 2, 'slDFLI', 'J7', STATUS ) + + END + + SUBROUTINE T_GALEQ ( STATUS ) +*+ +* - - - - - - - - +* T _ G A E Q +* - - - - - - - - +* +* Test slGAEQ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slGAEQ, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DR, DD + + CALL slGAEQ ( 5.67D0, -1.23D0, DR, DD ) + + CALL VVD ( DR, 0.04729270418071426D0, 1D-12, 'slGAEQ', + : 'DR', STATUS ) + CALL VVD ( DD, -0.7834003666745548D0, 1D-12, 'slGAEQ', + : 'DD', STATUS ) + + END + + SUBROUTINE T_GALSUP ( STATUS ) +*+ +* - - - - - - - - - +* T _ G A S U +* - - - - - - - - - +* +* Test slGASU routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slGASU, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DSL, DSB + + CALL slGASU ( 6.1D0, -1.4D0, DSL, DSB ) + + CALL VVD ( DSL, 4.567933268859171D0, 1D-12, 'slGASU', + : 'DSL', STATUS ) + CALL VVD ( DSB, -0.01862369899731829D0, 1D-12, 'slGASU', + : 'DSB', STATUS ) + + END + + SUBROUTINE T_GE50 ( STATUS ) +*+ +* - - - - - - - +* T _ G E 5 0 +* - - - - - - - +* +* Test slGE50 routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slGE50, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DR, DD + + CALL slGE50 ( 6.1D0, -1.55D0, DR, DD ) + + CALL VVD ( DR, 0.1966825219934508D0, 1D-12, 'slGE50', + : 'DR', STATUS ) + CALL VVD ( DD, -0.4924752701678960D0, 1D-12, 'slGE50', + : 'DD', STATUS ) + + END + + SUBROUTINE T_GMST ( STATUS ) +*+ +* - - - - - - - +* T _ G M S T +* - - - - - - - +* +* Test slGMST and slGMSA routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slGMST, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slGMST, slGMSA + + + CALL VVD ( slGMST ( 43999.999D0 ), 3.9074971356487318D0, + : 1D-9, 'slGMST', ' ', STATUS ) + CALL VVD ( slGMSA ( 43999D0, 0.999D0 ), + : 3.9074971356487318D0, 1D-12, 'slGMSA', ' ', STATUS ) + + END + + SUBROUTINE T_INTIN ( STATUS ) +*+ +* - - - - - - - - +* T _ I N T I +* - - - - - - - - +* +* Test slINTI routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slINTI, VIV. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER*4 N + INTEGER I, J + CHARACTER*28 S + DATA S /' -12345, , -0 2000 + '/ + + I = 1 + N = 0 + + CALL slINTI ( S, I, N, J ) + CALL VIV ( I, 10, 'slINTI', 'I1', STATUS ) + CALL VLV ( N, -12345, 'slINTI', 'V1', STATUS ) + CALL VIV ( J, -1, 'slINTI', 'J1', STATUS ) + + CALL slINTI ( S, I, N, J ) + CALL VIV ( I, 12, 'slINTI', 'I2', STATUS ) + CALL VLV ( N, -12345, 'slINTI', 'V2', STATUS ) + CALL VIV ( J, 1, 'slINTI', 'J2', STATUS ) + + CALL slINTI ( S, I, N, J ) + CALL VIV ( I, 17, 'slINTI', 'I3', STATUS ) + CALL VLV ( N, 0, 'slINTI', 'V3', STATUS ) + CALL VIV ( J, -1, 'slINTI', 'J3', STATUS ) + + CALL slINTI ( S, I, N, J ) + CALL VIV ( I, 23, 'slINTI', 'I4', STATUS ) + CALL VLV ( N, 2000, 'slINTI', 'V4', STATUS ) + CALL VIV ( J, 0, 'slINTI', 'J4', STATUS ) + + CALL slINTI ( S, I, N, J ) + CALL VIV ( I, 29, 'slINTI', 'I5', STATUS ) + CALL VLV ( N, 2000, 'slINTI', 'V5', STATUS ) + CALL VIV ( J, 2, 'slINTI', 'J5', STATUS ) + + END + + SUBROUTINE T_KBJ ( STATUS ) +*+ +* - - - - - - +* T _ K B J +* - - - - - - +* +* Test slKBJ routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slKBJ, VCS, VIV. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + DOUBLE PRECISION E + CHARACTER K + DATA K /'?'/ + + E = 1950D0 + CALL slKBJ ( -1, E, K, J ) + CALL VCS ( K, ' ', 'slKBJ', 'JB1', STATUS ) + CALL VIV ( J, 1, 'slKBJ', 'J1', STATUS ) + CALL slKBJ ( 0, E, K, J ) + CALL VCS ( K, 'B', 'slKBJ', 'JB2', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J2', STATUS ) + CALL slKBJ ( 1, E, K, J ) + CALL VCS ( K, 'B', 'slKBJ', 'JB3', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J3', STATUS ) + CALL slKBJ ( 2, E, K, J ) + CALL VCS ( K, 'J', 'slKBJ', 'JB4', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J4', STATUS ) + CALL slKBJ ( 3, E, K, J ) + CALL VCS ( K, ' ', 'slKBJ', 'JB5', STATUS ) + CALL VIV ( J, 1, 'slKBJ', 'J5', STATUS ) + + E = 2000D0 + CALL slKBJ ( 0, E, K, J ) + CALL VCS ( K, 'J', 'slKBJ', 'JB6', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J6', STATUS ) + CALL slKBJ ( 1, E, K, J ) + CALL VCS ( K, 'B', 'slKBJ', 'jB7', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J7', STATUS ) + CALL slKBJ ( 2, E, K, J ) + CALL VCS ( K, 'J', 'slKBJ', 'JB8', STATUS ) + CALL VIV ( J, 0, 'slKBJ', 'J8', STATUS ) + + END + + SUBROUTINE T_MAP ( STATUS ) +*+ +* - - - - - - +* T _ M A P +* - - - - - - +* +* Test slMAP, slMAPA, slMAPQ, slMAPZ routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slMAP, slMAPA, slMAPQ, slMAPZ, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RA, DA, AMPRMS(21) + + CALL slMAP ( 6.123D0, -0.999D0, 1.23D-5, -0.987D-5, + : 0.123D0, 32.1D0, 1999D0, 43210.9D0, RA, DA ) + + CALL VVD ( RA, 6.117130429775647D0, 1D-12, 'slMAP', + : 'RA', STATUS ) + CALL VVD ( DA, -1.000880769038632D0, 1D-12, 'slMAP', + : 'DA', STATUS ) + + CALL slMAPA ( 2020D0, 45012.3D0, AMPRMS ) + + CALL VVD ( AMPRMS(1), -37.884188911704310D0, + : 1D-11, 'slMAPA', 'AMPRMS(1)', STATUS ) + CALL VVD ( AMPRMS(2), -0.7888341859486424D0, + : 1D-7, 'slMAPA', 'AMPRMS(2)', STATUS ) + CALL VVD ( AMPRMS(3), 0.5405321789059870D0, + : 1D-7, 'slMAPA', 'AMPRMS(3)', STATUS ) + CALL VVD ( AMPRMS(4), 0.2340784267119091D0, + : 1D-7, 'slMAPA', 'AMPRMS(4)', STATUS ) + CALL VVD ( AMPRMS(5), -0.8067807553217332071D0, + : 1D-7, 'slMAPA', 'AMPRMS(5)', STATUS ) + CALL VVD ( AMPRMS(6), 0.5420884771236513880D0, + : 1D-7, 'slMAPA', 'AMPRMS(6)', STATUS ) + CALL VVD ( AMPRMS(7), 0.2350423277034460899D0, + : 1D-7, 'slMAPA', 'AMPRMS(7)', STATUS ) + CALL VVD ( AMPRMS(8), 1.999729469227807D-8, + : 1D-12, 'slMAPA', 'AMPRMS(8)', STATUS ) + CALL VVD ( AMPRMS(9), -6.035531043691568494D-5, + : 1D-12, 'slMAPA', 'AMPRMS(9)', STATUS ) + CALL VVD ( AMPRMS(10), -7.381891582591552377D-5, + : 1D-11, 'slMAPA', 'AMPRMS(10)', STATUS ) + CALL VVD ( AMPRMS(11), -3.200897749853207412D-5, + : 1D-11, 'slMAPA', 'AMPRMS(11)', STATUS ) + CALL VVD ( AMPRMS(12), 0.9999999949417148D0, + : 1D-11, 'slMAPA', 'AMPRMS(12)', STATUS ) + CALL VVD ( AMPRMS(13), 0.9999566751478850D0, + : 1D-11, 'slMAPA', 'AMPRMS(13)', STATUS ) + CALL VVD ( AMPRMS(14), -8.537361890149777D-3, + : 1D-11, 'slMAPA', 'AMPRMS(14)', STATUS ) + CALL VVD ( AMPRMS(15), -3.709619811228171D-3, + : 1D-11, 'slMAPA', 'AMPRMS(15)', STATUS ) + CALL VVD ( AMPRMS(16), 8.537308717676752D-3, + : 1D-11, 'slMAPA', 'AMPRMS(16)', STATUS ) + CALL VVD ( AMPRMS(17), 0.9999635560607690D0, + : 1D-11, 'slMAPA', 'AMPRMS(17)', STATUS ) + CALL VVD ( AMPRMS(18), -3.016886324169151D-5, + : 1D-11, 'slMAPA', 'AMPRMS(18)', STATUS ) + CALL VVD ( AMPRMS(19), 3.709742180572510D-3, + : 1D-11, 'slMAPA', 'AMPRMS(19)', STATUS ) + CALL VVD ( AMPRMS(20), -1.502613373498668D-6, + : 1D-11, 'slMAPA', 'AMPRMS(20)', STATUS ) + CALL VVD ( AMPRMS(21), 0.9999931188816729D0, + : 1D-11, 'slMAPA', 'AMPRMS(21)', STATUS ) + + CALL slMAPQ ( 1.234D0, -0.987D0, -1.2D-5, -0.99D0, + : 0.75D0, -23.4D0, AMPRMS, RA, DA ) + + CALL VVD ( RA, 1.223337584930993D0, 1D-11, 'slMAPQ', + : 'RA', STATUS ) + CALL VVD ( DA, 0.5558838650379129D0, 1D-11, 'slMAPQ', + : 'DA', STATUS ) + + CALL slMAPZ ( 6.012D0, 1.234D0, AMPRMS, RA, DA ) + + CALL VVD ( RA, 6.006091119756597D0, 1D-11, 'slMAPZ', + : 'RA', STATUS ) + CALL VVD ( DA, 1.23045846622498D0, 1D-11, 'slMAPZ', + : 'DA', STATUS ) + + END + + SUBROUTINE T_MOON ( STATUS ) +*+ +* - - - - - - - +* T _ M O O N +* - - - - - - - +* +* Test slMOON and slDMON routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slMOON, slDMON, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL PV(6) + + CALL slMOON ( 1999, 365, 0.9E0, PV ) + + CALL VVD ( DBLE( PV(1) ), -2.155729505970773D-3, 1D-6, + : 'slMOON', '(1)', STATUS ) + CALL VVD ( DBLE( PV(2) ), -1.538107758633427D-3, 1D-6, + : 'slMOON', '(2)', STATUS ) + CALL VVD ( DBLE( PV(3) ), -4.003940552689305D-4, 1D-6 , + : 'slMOON', '(3)', STATUS ) + CALL VVD ( DBLE( PV(4) ), 3.629209419071314D-9, 1D-12, + : 'slMOON', '(4)', STATUS ) + CALL VVD ( DBLE( PV(5) ), -4.989667166259157D-9, 1D-12, + : 'slMOON', '(5)', STATUS ) + CALL VVD ( DBLE( PV(6) ), -2.160752457288307D-9, 1D-12, + : 'slMOON', '(6)', STATUS ) + + END + + SUBROUTINE T_NUT ( STATUS ) +*+ +* - - - - - - +* T _ N U T +* - - - - - - +* +* Test slNUT, slNUTC, slNUTC80 routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slNUT, slNUTC, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RMATN(3,3), DPSI, DEPS, EPS0 + + CALL slNUT ( 46012.34D0, RMATN ) + + CALL VVD ( RMATN(1,1), 9.999999969492166D-1, 1D-12, + : 'slNUT', '(1,1)', STATUS ) + CALL VVD ( RMATN(1,2), 7.166577986249302D-5, 1D-12, + : 'slNUT', '(1,2)', STATUS ) + CALL VVD ( RMATN(1,3), 3.107382973077677D-5, 1D-12, + : 'slNUT', '(1,3)', STATUS ) + CALL VVD ( RMATN(2,1), -7.166503970900504D-5, 1D-12, + : 'slNUT', '(2,1)', STATUS ) + CALL VVD ( RMATN(2,2), 9.999999971483732D-1, 1D-12, + : 'slNUT', '(2,2)', STATUS ) + CALL VVD ( RMATN(2,3), -2.381965032461830D-5, 1D-12, + : 'slNUT', '(2,3)', STATUS ) + CALL VVD ( RMATN(3,1), -3.107553669598237D-5, 1D-12, + : 'slNUT', '(3,1)', STATUS ) + CALL VVD ( RMATN(3,2), 2.381742334472628D-5, 1D-12, + : 'slNUT', '(3,2)', STATUS ) + CALL VVD ( RMATN(3,3), 9.999999992335206818D-1, 1D-12, + : 'slNUT', '(3,3)', STATUS ) + + CALL slNUTC ( 50123.4D0, DPSI, DEPS, EPS0 ) + + CALL VVD ( DPSI, 3.523550954747999709D-5, 1D-17, 'slNUTC', + : 'DPSI', STATUS ) + CALL VVD ( DEPS, -4.143371566683342D-5, 1D-17, 'slNUTC', + : 'DEPS', STATUS ) + CALL VVD ( EPS0, 0.4091014592901651D0, 1D-12, 'slNUTC', + : 'EPS0', STATUS ) + + CALL slNUTC80 ( 50123.4D0, DPSI, DEPS, EPS0 ) + + CALL VVD ( DPSI, 3.537714281665945321D-5, 1D-17, 'slNUTC80', + : 'DPSI', STATUS ) + CALL VVD ( DEPS, -4.140590085987148317D-5, 1D-17, 'slNUTC80', + : 'DEPS', STATUS ) + CALL VVD ( EPS0, 0.4091016349007751D0, 1D-12, 'slNUTC80', + : 'EPS0', STATUS ) + + END + + SUBROUTINE T_OBS ( STATUS ) +*+ +* - - - - - - +* T _ O B S +* - - - - - - +* +* Test slOBS routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slOBS, err, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER N + DOUBLE PRECISION W, P, H + CHARACTER*10 C + CHARACTER*40 NAME + + N = 0 + C = 'MMT' + CALL slOBS ( N, C, NAME, W, P, H ) + CALL VCS ( C, 'MMT', 'slOBS', '1/C', STATUS ) + CALL VCS ( NAME, 'MMT 6.5m, Mt Hopkins', 'slOBS', '1/NAME', + : STATUS ) + CALL VVD ( W, 1.935300584055477D0, 1D-8, 'slOBS', + : '1/W', STATUS ) + CALL VVD ( P, 0.5530735081550342238D0, 1D-10, 'slOBS', + : '1/P', STATUS ) + CALL VVD ( H, 2608D0, 1D-10, 'slOBS', + : '1/H', STATUS ) + + N = 61 + CALL slOBS ( N, C, NAME, W, P, H ) + CALL VCS ( C, 'KECK1', 'slOBS', '2/C', STATUS ) + CALL VCS ( NAME, 'Keck 10m Telescope #1', 'slOBS', + : '2/NAME', STATUS ) + CALL VVD ( W, 2.713545757918895D0, 1D-8, 'slOBS', + : '2/W', STATUS ) + CALL VVD ( P, 0.3460280563536619D0, 1D-8, 'slOBS', + : '2/P', STATUS ) + CALL VVD ( H, 4160D0, 1D-10, 'slOBS', + : '2/H', STATUS ) + + N = 83 + CALL slOBS ( N, C, NAME, W, P, H ) + CALL VCS ( C, 'MAGELLAN2', 'slOBS', '3/C', STATUS ) + CALL VCS ( NAME, 'Magellan 2, 6.5m, Las Campanas', + : 'slOBS', '3/NAME', STATUS ) + CALL VVD ( W, 1.233819305534497D0, 1D-8, 'slOBS', + : '3/W', STATUS ) + CALL VVD ( P, -0.506389344359954D0, 1D-8, 'slOBS', + : '3/P', STATUS ) + CALL VVD ( H, 2408D0, 1D-10, 'slOBS', + : '3/H', STATUS ) + + N = 84 + CALL slOBS ( N, C, NAME, W, P, H ) + CALL VCS ( NAME, '?', 'slOBS', '4/NAME', STATUS ) + + END + + SUBROUTINE T_PA ( STATUS ) +*+ +* - - - - - +* T _ P A +* - - - - - +* +* Test slPA routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPA, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slPA + + + CALL VVD ( slPA ( -1.567D0, 1.5123D0, 0.987D0 ), + : -1.486288540423851D0, 1D-12, 'slPA', ' ', STATUS ) + CALL VVD ( slPA ( 0D0, 0.789D0, 0.789D0 ), + : 0D0, 0D0, 'slPA', 'zenith', STATUS ) + + END + + SUBROUTINE T_PCD ( STATUS ) +*+ +* - - - - - - +* T _ P C D +* - - - - - - +* +* Test slPCD, slUPCD routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPCD, VVD, slUPCD. +* +* Last revision: 4 September 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DISCO, X, Y + + DISCO = 178.585D0 + X = 0.0123D0 + Y = -0.00987D0 + + CALL slPCD ( DISCO, X, Y ) + CALL VVD ( X, 0.01284630845735895D0, 1D-14, 'slPCD', + : 'X', STATUS ) + CALL VVD ( Y, -0.01030837922553926D0, 1D-14, 'slPCD', + : 'Y', STATUS ) + + CALL slUPCD ( DISCO, X, Y ) + CALL VVD ( X, 0.0123D0, 1D-14, 'slUPCD', + : 'X', STATUS ) + CALL VVD ( Y, -0.00987D0, 1D-14, 'slUPCD', + : 'Y', STATUS ) + + END + + SUBROUTINE T_PDA2H ( STATUS ) +*+ +* - - - - - - - - +* T _ P D A H +* - - - - - - - - +* +* Test slPDAH routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPDAH, VVD. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J1, J2 + DOUBLE PRECISION H1, H2 + + CALL slPDAH ( -0.51D0, -1.31D0, 3.1D0, H1, J1, H2, J2 ) + CALL VVD ( H1, -0.1161784556585304927D0, 1D-14, 'slPDAH', + : 'H1', STATUS ) + CALL VIV ( J1, 0, 'slPDAH', 'J1', STATUS ) + CALL VVD ( H2, -2.984787179226459D0, 1D-13, 'slPDAH', + : 'H2', STATUS ) + CALL VIV ( J2, 0, 'slPDAH', 'J2', STATUS ) + + END + + SUBROUTINE T_PDQ2H ( STATUS ) +*+ +* - - - - - - - - +* T _ P D Q H +* - - - - - - - - +* +* Test slPDQH routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPDQH, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J1, J2 + DOUBLE PRECISION H1, H2 + + CALL slPDQH ( 0.9D0, 0.2D0, 0.1D0, H1, J1, H2, J2 ) + CALL VVD ( H1, 0.1042809894435257D0, 1D-14, 'slPDQH', + : 'H1', STATUS ) + CALL VIV ( J1, 0, 'slPDQH', 'J1', STATUS ) + CALL VVD ( H2, 2.997450098818439D0, 1D-13, 'slPDQH', + : 'H2', STATUS ) + CALL VIV ( J2, 0, 'slPDQH', 'J2', STATUS ) + + END + + SUBROUTINE T_PERCOM ( STATUS ) +*+ +* - - - - - - - - - +* T _ P E R C O M +* - - - - - - - - - +* +* Test slCMBN, slPERM routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slCMBN, VIV, slPERM. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER LIST(3), I, J, ISTATE(4), IORDER(4) + + LIST(1) = 0 + + DO I = 1, 11 + CALL slCMBN ( 3, 5, LIST, J ) + END DO + + CALL VIV ( J, 1, 'slCMBN', 'J', STATUS ) + CALL VIV ( LIST(1), 1, 'slCMBN', 'LIST(1)', STATUS ) + CALL VIV ( LIST(2), 2, 'slCMBN', 'LIST(2)', STATUS ) + CALL VIV ( LIST(3), 3, 'slCMBN', 'LIST(3)', STATUS ) + + ISTATE(1) = -1 + + DO I = 1, 25 + CALL slPERM ( 4, ISTATE, IORDER, J ) + END DO + + CALL VIV ( J, 1, 'slPERM', 'J', STATUS ) + CALL VIV ( IORDER(1), 4, 'slPERM', 'IORDER(1)', STATUS ) + CALL VIV ( IORDER(2), 3, 'slPERM', 'IORDER(2)', STATUS ) + CALL VIV ( IORDER(3), 2, 'slPERM', 'IORDER(3)', STATUS ) + CALL VIV ( IORDER(4), 1, 'slPERM', 'IORDER(4)', STATUS ) + + END + + SUBROUTINE T_PLANET ( STATUS ) +*+ +* - - - - - - - - - +* T _ P L N T +* - - - - - - - - - +* +* Test slELUE, slPRTL, slPRTE, slPLNE, slPLNT, +* slPLTE, slPLTU, slPVEL, slPVUE, slRDPL, slUEEL +* and slUEPV routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slELUE, slPRTL, slPRTE, slPLNE, slPLNT, +* slPLTE, slPLTU, slPVEL, slPVUE, slRDPL, +* slUEEL, slUEPV, VIV, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J, JFORM + DOUBLE PRECISION U(13), PV(6), RA, DEC, R, DIAM, EPOCH, ORBINC, + : ANODE, PERIH, AORQ, E, AORL, DM + + + CALL slELUE ( 50000D0, 1, 49000D0, 0.1D0, 2D0, 0.2D0, + : 3D0, 0.05D0, 3D0, 0.003312D0, U, J ) + CALL VVD ( U(1), 1.000878908362435284D0, 1D-12, 'slELUE', + : 'U(1)', STATUS ) + CALL VVD ( U(2), -0.3336263027874777288D0, 1D-12, 'slELUE', + : 'U(2)', STATUS ) + CALL VVD ( U(3), 50000D0, 1D-12, 'slELUE', + : 'U(3)', STATUS ) + CALL VVD ( U(4), 2.840425801310305210D0, 1D-12, 'slELUE', + : 'U(4)', STATUS ) + CALL VVD ( U(5), 0.1264380368035014224D0, 1D-12, 'slELUE', + : 'U(5)', STATUS ) + CALL VVD ( U(6), -0.2287711835229143197D0, 1D-12, 'slELUE', + : 'U(6)', STATUS ) + CALL VVD ( U(7), -0.01301062595106185195D0, 1D-12, 'slELUE', + : 'U(7)', STATUS ) + CALL VVD ( U(8), 0.5657102158104651697D0, 1D-12, 'slELUE', + : 'U(8)', STATUS ) + CALL VVD ( U(9), 0.2189745287281794885D0, 1D-12, 'slELUE', + : 'U(9)', STATUS ) + CALL VVD ( U(10), 2.852427310959998500D0, 1D-12, 'slELUE', + : 'U(10)', STATUS ) + CALL VVD ( U(11), -0.01552349065435120900D0, 1D-12, 'slELUE', + : 'U(11)', STATUS ) + CALL VVD ( U(12), 50000D0, 1D-12, 'slELUE', + : 'U(12)', STATUS ) + CALL VVD ( U(13), 0D0, 1D-12, 'slELUE', + : 'U(13)', STATUS ) + CALL VIV ( J, 0, 'slELUE', 'J', STATUS ) + + CALL slPRTL ( 2, 43000D0, 43200D0, 43000D0, + : 0.2D0, 3D0, 4D0, 5D0, 0.02D0, 6D0, + : EPOCH, ORBINC, ANODE, PERIH, AORQ, E, AORL, J ) + CALL VVD ( EPOCH, 43200D0, 1D-10, 'slPRTL', + : 'EPOCH', STATUS ) + CALL VVD ( ORBINC, 0.1995661466545422381D0, 1D-7, 'slPRTL', + : 'ORBINC', STATUS ) + CALL VVD ( ANODE, 2.998052737821591215D0, 1D-7, 'slPRTL', + : 'ANODE', STATUS ) + CALL VVD ( PERIH, 4.009516448441143636D0, 1D-6, 'slPRTL', + : 'PERIH', STATUS ) + CALL VVD ( AORQ, 5.014216294790922323D0, 1D-7, 'slPRTL', + : 'AORQ', STATUS ) + CALL VVD ( E, 0.02281386258309823607D0, 1D-7, 'slPRTL', + : 'E', STATUS ) + CALL VVD ( AORL, 0.01735248648779583748D0, 1D-6, 'slPRTL', + : 'AORL', STATUS ) + CALL VIV ( J, 0, 'slPRTL', 'J', STATUS ) + + CALL slPRTE ( 50100D0, U, J ) + CALL VVD ( U(1), 1.000000000000000D0, 1D-12, 'slPRTE', + : 'U(1)', STATUS ) + CALL VVD ( U(2), -0.3329769417028020949D0, 1D-11, 'slPRTE', + : 'U(2)', STATUS ) + CALL VVD ( U(3), 50100D0, 1D-12, 'slPRTE', + : 'U(3)', STATUS ) + CALL VVD ( U(4), 2.638884303608524597D0, 1D-11, 'slPRTE', + : 'U(4)', STATUS ) + CALL VVD ( U(5), 1.070994304747824305D0, 1D-11, 'slPRTE', + : 'U(5)', STATUS ) + CALL VVD ( U(6), 0.1544112080167568589D0, 1D-11, 'slPRTE', + : 'U(6)', STATUS ) + CALL VVD ( U(7), -0.2188240619161439344D0, 1D-11, 'slPRTE', + : 'U(7)', STATUS ) + CALL VVD ( U(8), 0.5207557453451906385D0, 1D-11, 'slPRTE', + : 'U(8)', STATUS ) + CALL VVD ( U(9), 0.2217782439275216936D0, 1D-11, 'slPRTE', + : 'U(9)', STATUS ) + CALL VVD ( U(10), 2.852118859689216658D0, 1D-11, 'slPRTE', + : 'U(10)', STATUS ) + CALL VVD ( U(11), 0.01452010174371893229D0, 1D-11, 'slPRTE', + : 'U(11)', STATUS ) + CALL VVD ( U(12), 50100D0, 1D-12, 'slPRTE', + : 'U(12)', STATUS ) + CALL VVD ( U(13), 0D0, 1D-12, 'slPRTE', + : 'U(13)', STATUS ) + CALL VIV ( J, 0, 'slPRTE', 'J', STATUS ) + + CALL slPLNE ( 50600D0, 2, 50500D0, 0.1D0, 3D0, 5D0, + : 2D0, 0.3D0, 4D0, 0D0, PV, J ) + CALL VVD ( PV(1), 1.947628959288897677D0, 1D-12, 'slPLNE', + : 'PV(1)', STATUS ) + CALL VVD ( PV(2), -1.013736058752235271D0, 1D-12, 'slPLNE', + : 'PV(2)', STATUS ) + CALL VVD ( PV(3), -0.3536409947732733647D0, 1D-12, 'slPLNE', + : 'PV(3)', STATUS ) + CALL VVD ( PV(4), 2.742247411571786194D-8, 1D-19, 'slPLNE', + : 'PV(4)', STATUS ) + CALL VVD ( PV(5), 1.170467244079075911D-7, 1D-19, 'slPLNE', + : 'PV(5)', STATUS ) + CALL VVD ( PV(6), 3.709878268217564005D-8, 1D-19, 'slPLNE', + : 'PV(6)', STATUS ) + CALL VIV ( J, 0, 'slPLNE', 'J', STATUS ) + + CALL slPLNT ( 1D6, 0, PV, J ) + CALL VVD ( PV(1), 0D0, 0D0, 'slPLNT', + : 'PV(1) 1', STATUS ) + CALL VVD ( PV(2), 0D0, 0D0, 'slPLNT', + : 'PV(2) 1', STATUS ) + CALL VVD ( PV(3), 0D0, 0D0, 'slPLNT', + : 'PV(3) 1', STATUS ) + CALL VVD ( PV(4), 0D0, 0D0, 'slPLNT', + : 'PV(4) 1', STATUS ) + CALL VVD ( PV(5), 0D0, 0D0, 'slPLNT', + : 'PV(5) 1', STATUS ) + CALL VVD ( PV(6), 0D0, 0D0, 'slPLNT', + : 'PV(6) 1', STATUS ) + CALL VIV ( J, -1, 'slPLNT', 'J 1', STATUS ) + + CALL slPLNT ( 1D6, 10, PV, J ) + CALL VIV ( J, -1, 'slPLNT', 'J 2', STATUS ) + + CALL slPLNT ( -320000D0, 3, PV, J ) + CALL VVD ( PV(1), 0.9308038666827242603D0, 1D-11, 'slPLNT', + : 'PV(1) 3', STATUS ) + CALL VVD ( PV(2), 0.3258319040252137618D0, 1D-11, 'slPLNT', + : 'PV(2) 3', STATUS ) + CALL VVD ( PV(3), 0.1422794544477122021D0, 1D-11, 'slPLNT', + : 'PV(3) 3', STATUS ) + CALL VVD ( PV(4), -7.441503423889371696D-8, 1D-17, 'slPLNT', + : 'PV(4) 3', STATUS ) + CALL VVD ( PV(5), 1.699734557528650689D-7, 1D-17, 'slPLNT', + : 'PV(5) 3', STATUS ) + CALL VVD ( PV(6), 7.415505123001430864D-8, 1D-17, 'slPLNT', + : 'PV(6) 3', STATUS ) + CALL VIV ( J, 1, 'slPLNT', 'J 3', STATUS ) + + CALL slPLNT ( 43999.9D0, 1, PV, J ) + CALL VVD ( PV(1), 0.2945293959257422246D0, 1D-11, 'slPLNT', + : 'PV(1) 4', STATUS ) + CALL VVD ( PV(2), -0.2452204176601052181D0, 1D-11, 'slPLNT', + : 'PV(2) 4', STATUS ) + CALL VVD ( PV(3), -0.1615427700571978643D0, 1D-11, 'slPLNT', + : 'PV(3) 4', STATUS ) + CALL VVD ( PV(4), 1.636421147459047057D-7, 1D-18, 'slPLNT', + : 'PV(4) 4', STATUS ) + CALL VVD ( PV(5), 2.252949422574889753D-7, 1D-18, 'slPLNT', + : 'PV(5) 4', STATUS ) + CALL VVD ( PV(6), 1.033542799062371839D-7, 1D-18, 'slPLNT', + : 'PV(6) 4', STATUS ) + CALL VIV ( J, 0, 'slPLNT', 'J 4', STATUS ) + + CALL slPLTE ( 50600D0, -1.23D0, 0.456D0, 2, 50500D0, + : 0.1D0, 3D0, 5D0, 2D0, 0.3D0, 4D0, + : 0D0, RA, DEC, R, J ) + CALL VVD ( RA, 6.222958101333794007D0, 1D-10, 'slPLTE', + : 'RA', STATUS ) + CALL VVD ( DEC, 0.01142220305739771601D0, 1D-10, 'slPLTE', + : 'DEC', STATUS ) + CALL VVD ( R, 2.288902494080167624D0, 1D-8, 'slPLTE', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slPLTE', 'J', STATUS ) + + U(1) = 1.0005D0 + U(2) = -0.3D0 + U(3) = 55000D0 + U(4) = 2.8D0 + U(5) = 0.1D0 + U(6) = -0.2D0 + U(7) = -0.01D0 + U(8) = 0.5D0 + U(9) = 0.22D0 + U(10) = 2.8D0 + U(11) = -0.015D0 + U(12) = 55001D0 + U(13) = 0D0 + + CALL slPLTU ( 55001D0, -1.23D0, 0.456D0, U, RA, DEC, R, J ) + CALL VVD ( RA, 0.3531814831241686647D0, 1D-9, 'slPLTU', + : 'RA', STATUS ) + CALL VVD ( DEC, 0.06940344580567131328D0, 1D-9, 'slPLTU', + : 'DEC', STATUS ) + CALL VVD ( R, 3.031687170873274464D0, 1D-8, 'slPLTU', + : 'R', STATUS ) + CALL VIV ( J, 0, 'slPLTU', 'J', STATUS ) + + PV(1) = 0.3D0 + PV(2) = -0.2D0 + PV(3) = 0.1D0 + PV(4) = -0.9D-7 + PV(5) = 0.8D-7 + PV(6) = -0.7D-7 + CALL slPVEL ( PV, 50000D0, 0.00006D0, 1, + : JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, J ) + CALL VIV ( JFORM, 1, 'slPVEL', 'JFORM', STATUS ) + CALL VVD ( EPOCH, 50000D0, 1D-10, 'slPVEL', + : 'EPOCH', STATUS ) + CALL VVD ( ORBINC, 1.52099895268912D0, 1D-12, 'slPVEL', + : 'ORBINC', STATUS ) + CALL VVD ( ANODE, 2.720503180538650D0, 1D-12, 'slPVEL', + : 'ANODE', STATUS ) + CALL VVD ( PERIH, 2.194081512031836D0, 1D-12, 'slPVEL', + : 'PERIH', STATUS ) + CALL VVD ( AORQ, 0.2059371035373771D0, 1D-12, 'slPVEL', + : 'AORQ', STATUS ) + CALL VVD ( E, 0.9866822985810528D0, 1D-12, 'slPVEL', + : 'E', STATUS ) + CALL VVD ( AORL, 0.2012758344836794D0, 1D-12, 'slPVEL', + : 'AORL', STATUS ) + CALL VVD ( DM, 0.1840740507951820D0, 1D-12, 'slPVEL', + : 'DM', STATUS ) + CALL VIV ( J, 0, 'slPVEL', 'J', STATUS ) + + CALL slPVUE ( PV, 50000D0, 0.00006D0, U, J ) + CALL VVD ( U(1), 1.00006D0, 1D-12, 'slPVUE', + : 'U(1)', STATUS ) + CALL VVD ( U(2), -4.856142884511782D0, 1D-12, 'slPVUE', + : 'U(2)', STATUS ) + CALL VVD ( U(3), 50000D0, 1D-12, 'slPVUE', + : 'U(3)', STATUS ) + CALL VVD ( U(4), 0.3D0, 1D-12, 'slPVUE', + : 'U(4)', STATUS ) + CALL VVD ( U(5), -0.2D0, 1D-12, 'slPVUE', + : 'U(5)', STATUS ) + CALL VVD ( U(6), 0.1D0, 1D-12, 'slPVUE', + : 'U(6)', STATUS ) + CALL VVD ( U(7), -0.4520378601821727D0, 1D-12, 'slPVUE', + : 'U(7)', STATUS ) + CALL VVD ( U(8), 0.4018114312730424D0, 1D-12, 'slPVUE', + : 'U(8)', STATUS ) + CALL VVD ( U(9), -.3515850023639121D0, 1D-12, 'slPVUE', + : 'U(9)', STATUS ) + CALL VVD ( U(10), 0.3741657386773941D0, 1D-12, 'slPVUE', + : 'U(10)', STATUS ) + CALL VVD ( U(11), -0.2511321445456515D0, 1D-12, 'slPVUE', + : 'U(11)', STATUS ) + CALL VVD ( U(12), 50000D0, 1D-12, 'slPVUE', + : 'U(12)', STATUS ) + CALL VVD ( U(13), 0D0, 1D-12, 'slPVUE', + : 'U(13)', STATUS ) + CALL VIV ( J, 0, 'slPVUE', 'J', STATUS ) + + CALL slRDPL ( 40999.9D0, 0, 0.1D0, -0.9D0, RA, DEC, DIAM ) + CALL VVD ( RA, 5.772270359389275837D0, 1D-7, 'slRDPL', + : 'RA 0', STATUS ) + CALL VVD ( DEC, -0.2089207338795416192D0, 1D-7, 'slRDPL', + : 'DEC 0', STATUS ) + CALL VVD ( DIAM, 9.415338935229717875D-3, 1D-14, 'slRDPL', + : 'DIAM 0', STATUS ) + CALL slRDPL ( 41999.9D0, 1, 1.1D0, -0.9D0, RA, DEC, DIAM ) + CALL VVD ( RA, 3.866363420052936653D0, 1D-7, 'slRDPL', + : 'RA 1', STATUS ) + CALL VVD ( DEC, -0.2594430577550113130D0, 1D-7, 'slRDPL', + : 'DEC 1', STATUS ) + CALL VVD ( DIAM, 4.638468996795023071D-5, 1D-14, 'slRDPL', + : 'DIAM 1', STATUS ) + CALL slRDPL ( 42999.9D0, 2, 2.1D0, 0.9D0, RA, DEC, DIAM ) + CALL VVD ( RA, 2.695383203184077378D0, 1D-7, 'slRDPL', + : 'RA 2', STATUS ) + CALL VVD ( DEC, 0.2124044506294805126D0, 1D-7, 'slRDPL', + : 'DEC 2', STATUS ) + CALL VVD ( DIAM, 4.892222838681000389D-5, 1D-14, 'slRDPL', + : 'DIAM 2', STATUS ) + CALL slRDPL ( 43999.9D0, 3, 3.1D0, 0.9D0, RA, DEC, DIAM ) + CALL VVD ( RA, 2.908326678461540165D0, 1D-7, 'slRDPL', + : 'RA 3', STATUS ) + CALL VVD ( DEC, 0.08729783126905579385D0, 1D-7, 'slRDPL', + : 'DEC 3', STATUS ) + CALL VVD ( DIAM, 8.581305866034962476D-3, 1D-14, 'slRDPL', + : 'DIAM 3', STATUS ) + CALL slRDPL ( 44999.9D0, 4, -0.1D0, 1.1D0, RA, DEC, DIAM ) + CALL VVD ( RA, 3.429840787472851721D0, 1D-7, 'slRDPL', + : 'RA 4', STATUS ) + CALL VVD ( DEC, -0.06979851055261161013D0, 1D-7, 'slRDPL', + : 'DEC 4', STATUS ) + CALL VVD ( DIAM, 4.540536678439300199D-5, 1D-14, 'slRDPL', + : 'DIAM 4', STATUS ) + CALL slRDPL ( 45999.9D0, 5, -1.1D0, 0.1D0, RA, DEC, DIAM ) + CALL VVD ( RA, 4.864669466449422548D0, 1D-7, 'slRDPL', + : 'RA 5', STATUS ) + CALL VVD ( DEC, -0.4077714497908953354D0, 1D-7, 'slRDPL', + : 'DEC 5', STATUS ) + CALL VVD ( DIAM, 1.727945579027815576D-4, 1D-14, 'slRDPL', + : 'DIAM 5', STATUS ) + CALL slRDPL ( 46999.9D0, 6, -2.1D0, -0.1D0, RA, DEC, DIAM ) + CALL VVD ( RA, 4.432929829176388766D0, 1D-7, 'slRDPL', + : 'RA 6', STATUS ) + CALL VVD ( DEC, -0.3682820877854730530D0, 1D-7, 'slRDPL', + : 'DEC 6', STATUS ) + CALL VVD ( DIAM, 8.670829016099083311D-5, 1D-14, 'slRDPL', + : 'DIAM 6', STATUS ) + CALL slRDPL ( 47999.9D0, 7, -3.1D0, -1.1D0, RA, DEC, DIAM ) + CALL VVD ( RA, 4.894972492286818487D0, 1D-7, 'slRDPL', + : 'RA 7', STATUS ) + CALL VVD ( DEC, -0.4084068901053653125D0, 1D-7, 'slRDPL', + : 'DEC 7', STATUS ) + CALL VVD ( DIAM, 1.793916783975974163D-5, 1D-14, 'slRDPL', + : 'DIAM 7', STATUS ) + CALL slRDPL ( 48999.9D0, 8, 0D0, 0D0, RA, DEC, DIAM ) + CALL VVD ( RA, 5.066050284760144000D0, 1D-7, 'slRDPL', + : 'RA 8', STATUS ) + CALL VVD ( DEC, -0.3744690779683850609D0, 1D-7, 'slRDPL', + : 'DEC 8', STATUS ) + CALL VVD ( DIAM, 1.062210086082700563D-5, 1D-14, 'slRDPL', + : 'DIAM 8', STATUS ) + CALL slRDPL ( 49999.9D0, 9, 0D0, 0D0, RA, DEC, DIAM ) + CALL VVD ( RA, 4.179543143097200945D0, 1D-7, 'slRDPL', + : 'RA 9', STATUS ) + CALL VVD ( DEC, -0.1258021632894033300D0, 1D-7, 'slRDPL', + : 'DEC 9', STATUS ) + CALL VVD ( DIAM, 5.034057475664904352D-7, 1D-14, 'slRDPL', + : 'DIAM 9', STATUS ) + + CALL slUEEL ( U, 1, JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, J ) + CALL VIV ( JFORM, 1, 'slUEEL', 'JFORM', STATUS ) + CALL VVD ( EPOCH, 50000.00000000000D0, 1D-10, 'slPVEL', + : 'EPOCH', STATUS ) + CALL VVD ( ORBINC, 1.520998952689120D0, 1D-12, 'slUEEL', + : 'ORBINC', STATUS ) + CALL VVD ( ANODE, 2.720503180538650D0, 1D-12, 'slUEEL', + : 'ANODE', STATUS ) + CALL VVD ( PERIH, 2.194081512031836D0, 1D-12, 'slUEEL', + : 'PERIH', STATUS ) + CALL VVD ( AORQ, 0.2059371035373771D0, 1D-12, 'slUEEL', + : 'AORQ', STATUS ) + CALL VVD ( E, 0.9866822985810528D0, 1D-12, 'slUEEL', + : 'E', STATUS ) + CALL VVD ( AORL, 0.2012758344836794D0, 1D-12, 'slUEEL', + : 'AORL', STATUS ) + CALL VIV ( J, 0, 'slUEEL', 'J', STATUS ) + + CALL slUEPV ( 50010D0, U, PV, J ) + CALL VVD ( U(1), 1.00006D0, 1D-12, 'slUEPV', + : 'U(1)', STATUS ) + CALL VVD ( U(2), -4.856142884511782111D0, 1D-12, 'slUEPV', + : 'U(2)', STATUS ) + CALL VVD ( U(3), 50000D0, 1D-12, 'slUEPV', + : 'U(3)', STATUS ) + CALL VVD ( U(4), 0.3D0, 1D-12, 'slUEPV', + : 'U(4)', STATUS ) + CALL VVD ( U(5), -0.2D0, 1D-12, 'slUEPV', + : 'U(5)', STATUS ) + CALL VVD ( U(6), 0.1D0, 1D-12, 'slUEPV', + : 'U(6)', STATUS ) + CALL VVD ( U(7), -0.4520378601821727110D0, 1D-12, 'slUEPV', + : 'U(7)', STATUS ) + CALL VVD ( U(8), 0.4018114312730424097D0, 1D-12, 'slUEPV', + : 'U(8)', STATUS ) + CALL VVD ( U(9), -0.3515850023639121085D0, 1D-12, 'slUEPV', + : 'U(9)', STATUS ) + CALL VVD ( U(10), 0.3741657386773941386D0, 1D-12, 'slUEPV', + : 'U(10)', STATUS ) + CALL VVD ( U(11), -0.2511321445456515061D0, 1D-12, 'slUEPV', + : 'U(11)', STATUS ) + CALL VVD ( U(12), 50010.00000000000D0, 1D-12, 'slUEPV', + : 'U(12)', STATUS ) + CALL VVD ( U(13), 0.7194308220038886856D0, 1D-12, 'slUEPV', + : 'U(13)', STATUS ) + CALL VVD ( PV(1), 0.07944764084631667011D0, 1D-12, 'slUEPV', + : 'PV(1)', STATUS ) + CALL VVD ( PV(2), -0.04118141077419014775D0, 1D-12, 'slUEPV', + : 'PV(2)', STATUS ) + CALL VVD ( PV(3), 0.002915180702063625400D0, 1D-12, 'slUEPV', + : 'PV(3)', STATUS ) + CALL VVD ( PV(4), -0.6890132370721108608D-6, 1D-18,'slUEPV', + : 'PV(4)', STATUS ) + CALL VVD ( PV(5), 0.4326690733487621457D-6, 1D-18, 'slUEPV', + : 'PV(5)', STATUS ) + CALL VVD ( PV(6), -0.1763249096254134306D-6, 1D-18, 'slUEPV', + : 'PV(6)', STATUS ) + CALL VIV ( J, 0, 'slUEPV', 'J', STATUS ) + + END + + SUBROUTINE T_PM ( STATUS ) +*+ +* - - - - - +* T _ P M +* - - - - - +* +* Test slPM routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPM, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION R1, D1 + + CALL slPM ( 5.43D0, -0.87D0, -0.33D-5, 0.77D-5, 0.7D0, + : 50.3D0*365.2422D0/365.25D0, 1899D0, 1943D0, + : R1, D1 ) + CALL VVD ( R1, 5.429855087793875D0, 1D-12, 'slPM', + : 'R', STATUS ) + CALL VVD ( D1, -0.8696617307805072D0, 1D-12, 'slPM', + : 'D', STATUS ) + + END + + SUBROUTINE T_POLMO ( STATUS ) +*+ +* - - - - - - - - +* T _ P L M O +* - - - - - - - - +* +* Test slPLMO routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPLMO, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION ELONG, PHI, DAZ + + CALL slPLMO ( 0.7D0, -0.5D0, 1D-6, -2D-6, ELONG, PHI, DAZ ) + + CALL VVD ( ELONG, 0.7000004837322044D0, 1D-12, 'slPLMO', + : 'ELONG', STATUS ) + CALL VVD ( PHI, -0.4999979467222241D0, 1D-12, 'slPLMO', + : 'PHI', STATUS ) + CALL VVD ( DAZ, 1.008982781275728D-6, 1D-12, 'slPLMO', + : 'DAZ', STATUS ) + + END + + SUBROUTINE T_PREBN ( STATUS ) +*+ +* - - - - - - - - +* T _ P R B N +* - - - - - - - - +* +* Test slPRBN routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPRBN, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RMATP(3,3) + + CALL slPRBN ( 1925D0, 1975D0, RMATP ) + + CALL VVD ( RMATP(1,1), 9.999257613786738D-1, 1D-12, + : 'slPRBN', '(1,1)', STATUS ) + CALL VVD ( RMATP(1,2), -1.117444640880939D-2, 1D-12, + : 'slPRBN', '(1,2)', STATUS ) + CALL VVD ( RMATP(1,3), -4.858341150654265D-3, 1D-12, + : 'slPRBN', '(1,3)', STATUS ) + CALL VVD ( RMATP(2,1), 1.117444639746558D-2, 1D-12, + : 'slPRBN', '(2,1)', STATUS ) + CALL VVD ( RMATP(2,2), 9.999375635561940D-1, 1D-12, + : 'slPRBN', '(2,2)', STATUS ) + CALL VVD ( RMATP(2,3), -2.714797892626396D-5, 1D-12, + : 'slPRBN', '(2,3)', STATUS ) + CALL VVD ( RMATP(3,1), 4.858341176745641D-3, 1D-12, + : 'slPRBN', '(3,1)', STATUS ) + CALL VVD ( RMATP(3,2), -2.714330927085065D-5, 1D-12, + : 'slPRBN', '(3,2)', STATUS ) + CALL VVD ( RMATP(3,3), 9.999881978224798D-1, 1D-12, + : 'slPRBN', '(3,3)', STATUS ) + + END + + SUBROUTINE T_PREC ( STATUS ) +*+ +* - - - - - - - +* T _ P R E C +* - - - - - - - +* +* Test slPREC and slPREL routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPREC, slPREL, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RMATP(3,3) + + CALL slPREC ( 1925D0, 1975D0, RMATP ) + + CALL VVD ( RMATP(1,1), 9.999257249850045D-1, 1D-12, + : 'slPREC', '(1,1)', STATUS ) + CALL VVD ( RMATP(1,2), -1.117719859160180D-2, 1D-12, + : 'slPREC', '(1,2)', STATUS ) + CALL VVD ( RMATP(1,3), -4.859500474027002D-3, 1D-12, + : 'slPREC', '(1,3)', STATUS ) + CALL VVD ( RMATP(2,1), 1.117719858025860D-2, 1D-12, + : 'slPREC', '(2,1)', STATUS ) + CALL VVD ( RMATP(2,2), 9.999375327960091D-1, 1D-12, + : 'slPREC', '(2,2)', STATUS ) + CALL VVD ( RMATP(2,3), -2.716114374174549D-5, 1D-12, + : 'slPREC', '(2,3)', STATUS ) + CALL VVD ( RMATP(3,1), 4.859500500117173D-3, 1D-12, + : 'slPREC', '(3,1)', STATUS ) + CALL VVD ( RMATP(3,2), -2.715647545167383D-5, 1D-12, + : 'slPREC', '(3,2)', STATUS ) + CALL VVD ( RMATP(3,3), 9.999881921889954D-1, 1D-12, + : 'slPREC', '(3,3)', STATUS ) + + CALL slPREL ( 1925D0, 1975D0, RMATP ) + + CALL VVD ( RMATP(1,1), 9.999257331781050D-1, 1D-12, + : 'slPREC', '(1,1)', STATUS ) + CALL VVD ( RMATP(1,2), -1.117658038434041D-2, 1D-12, + : 'slPREC', '(1,2)', STATUS ) + CALL VVD ( RMATP(1,3), -4.859236477249598D-3, 1D-12, + : 'slPREC', '(1,3)', STATUS ) + CALL VVD ( RMATP(2,1), 1.117658037299592D-2, 1D-12, + : 'slPREC', '(2,1)', STATUS ) + CALL VVD ( RMATP(2,2), 9.999375397061558D-1, 1D-12, + : 'slPREC', '(2,2)', STATUS ) + CALL VVD ( RMATP(2,3), -2.715816653174189D-5, 1D-12, + : 'slPREC', '(2,3)', STATUS ) + CALL VVD ( RMATP(3,1), 4.859236503342703D-3, 1D-12, + : 'slPREC', '(3,1)', STATUS ) + CALL VVD ( RMATP(3,2), -2.715349745834860D-5, 1D-12, + : 'slPREC', '(3,2)', STATUS ) + CALL VVD ( RMATP(3,3), 9.999881934719490D-1, 1D-12, + : 'slPREC', '(3,3)', STATUS ) + + END + + SUBROUTINE T_PRECES ( STATUS ) +*+ +* - - - - - - - - - +* T _ P R C E +* - - - - - - - - - +* +* Test slPRCE routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPRCE, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RA, DC + + RA = 6.28D0 + DC = -1.123D0 + CALL slPRCE ( 'FK4', 1925D0, 1950D0, RA, DC ) + CALL VVD ( RA, 0.002403604864728447D0, 1D-12, 'slPRCE', + : 'R', STATUS ) + CALL VVD ( DC, -1.120570643322045D0, 1D-12, 'slPRCE', + : 'D', STATUS ) + + RA = 0.0123D0 + DC = 1.0987D0 + CALL slPRCE ( 'FK5', 2050D0, 1990D0, RA, DC ) + CALL VVD ( RA, 6.282003602708382D0, 1D-12, 'slPRCE', + : 'R', STATUS ) + CALL VVD ( DC, 1.092870326188383D0, 1D-12, 'slPRCE', + : 'D', STATUS ) + + END + + SUBROUTINE T_PRENUT ( STATUS ) +*+ +* - - - - - - - - - +* P R N U +* - - - - - - - - - +* +* Test slPRNU routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPRNU, VVD. +* +* Last revision: 16 November 2001 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION RMATPN(3,3) + + CALL slPRNU ( 1985D0, 50123.4567D0, RMATPN ) + + CALL VVD ( RMATPN(1,1), 9.999962358680738D-1, 1D-12, + : 'slPRNU', '(1,1)', STATUS ) + CALL VVD ( RMATPN(1,2), -2.516417057665452D-3, 1D-12, + : 'slPRNU', '(1,2)', STATUS ) + CALL VVD ( RMATPN(1,3), -1.093569785342370D-3, 1D-12, + : 'slPRNU', '(1,3)', STATUS ) + CALL VVD ( RMATPN(2,1), 2.516462370370876D-3, 1D-12, + : 'slPRNU', '(2,1)', STATUS ) + CALL VVD ( RMATPN(2,2), 9.999968329010883D-1, 1D-12, + : 'slPRNU', '(2,2)', STATUS ) + CALL VVD ( RMATPN(2,3), 4.006159587358310D-5, 1D-12, + : 'slPRNU', '(2,3)', STATUS ) + CALL VVD ( RMATPN(3,1), 1.093465510215479D-3, 1D-12, + : 'slPRNU', '(3,1)', STATUS ) + CALL VVD ( RMATPN(3,2), -4.281337229063151D-5, 1D-12, + : 'slPRNU', '(3,2)', STATUS ) + CALL VVD ( RMATPN(3,3), 9.999994012499173D-1, 1D-12, + : 'slPRNU', '(3,3)', STATUS ) + + END + + SUBROUTINE T_PVOBS ( STATUS ) +*+ +* - - - - - - - - +* T _ P V O B +* - - - - - - - - +* +* Test slPVOB routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slPVOB, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION PV(6) + + CALL slPVOB ( 0.5123D0, 3001D0, -0.567D0, PV ) + + CALL VVD ( PV(1), 0.3138647803054939D-4, 1D-16, 'slPVOB', + : '(1)', STATUS ) + CALL VVD ( PV(2),-0.1998515596527082D-4, 1D-16, 'slPVOB', + : '(2)', STATUS ) + CALL VVD ( PV(3), 0.2078572043443275D-4, 1D-16, 'slPVOB', + : '(3)', STATUS ) + CALL VVD ( PV(4), 0.1457340726851264D-8, 1D-20, 'slPVOB', + : '(4)', STATUS ) + CALL VVD ( PV(5), 0.2288738340888011D-8, 1D-20, 'slPVOB', + : '(5)', STATUS ) + CALL VVD ( PV(6), 0D0, 0D0, 'slPVOB', + : '(6)', STATUS ) + + END + + SUBROUTINE T_RANGE ( STATUS ) +*+ +* - - - - - - - - +* T _ R A 1 P +* - - - - - - - - +* +* Test slRA1P, slDA1P routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slRA1P, VVD, slDA1P. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL slRA1P + DOUBLE PRECISION slDA1P + + + CALL VVD ( DBLE( slRA1P ( -4.0 ) ), 2.283185307179586D0, + : 1D-6, 'slRA1P', ' ', STATUS ) + CALL VVD ( slDA1P ( -4D0 ), 2.283185307179586D0, + : 1D-12, 'slDA1P', ' ', STATUS ) + + END + + SUBROUTINE T_RANORM ( STATUS ) +*+ +* - - - - - - - - - +* T _ R A 2 P +* - - - - - - - - - +* +* Test slRA2P, slDA2P routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slRA2P, VVD, slDA2P. +* +* Last revision: 22 October 2006 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL slRA2P + DOUBLE PRECISION slDA2P + + + CALL VVD ( DBLE( slRA2P ( -0.1E0 ) ), 6.183185307179587D0, + : 1D-5, 'slRA2P', '1', STATUS ) + CALL VVD ( slDA2P ( -0.1D0 ), 6.183185307179587D0, + : 1D-12, 'slDA2P', '2', STATUS ) + + END + + SUBROUTINE T_RCC ( STATUS ) +*+ +* - - - - - - +* T _ R C C +* - - - - - - +* +* Test slRCC routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slRCC, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slRCC + + + CALL VVD ( slRCC ( 48939.123D0, 0.76543D0, 5.0123D0, + : 5525.242D0, 3190D0 ), + : -1.280131613589158D-3, 1D-15, 'slRCC', ' ', STATUS ) + + END + + SUBROUTINE T_REF ( STATUS ) +*+ +* - - - - - - +* T _ R E F +* - - - - - - +* +* Test slRFRO, slRFCO, slATMD, slREFV, slREFZ routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slRFRO, VVD, slRFCO, slRFCQ, slATMD, +* slDS2C, slREFV, slREFZ. +* +* Last revision: 17 January 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION REF, REFA, REFB, REFA2, REFB2, VU(3), VR(3), ZR + + CALL slRFRO ( 1.4D0, 3456.7D0, 280D0, 678.9D0, 0.9D0, 0.55D0, + : -0.3D0, 0.006D0, 1D-9, REF ) + CALL VVD ( REF, 0.00106715763018568D0, 1D-12, 'slRFRO', + : 'O', STATUS ) + + CALL slRFRO ( 1.4D0, 3456.7D0, 280D0, 678.9D0, 0.9D0, 1000D0, + : -0.3D0, 0.006D0, 1D-9, REF ) + CALL VVD ( REF, 0.001296416185295403D0, 1D-12, 'slRFRO', + : 'R', STATUS ) + + CALL slRFCQ ( 275.9D0, 709.3D0, 0.9D0, 101D0, REFA, REFB ) + CALL VVD ( REFA, 2.324736903790639D-4, 1D-12, 'slRFCQ', + : 'A/R', STATUS ) + CALL VVD ( REFB, -2.442884551059D-7, 1D-15, 'slRFCQ', + : 'B/R', STATUS ) + + CALL slRFCO ( 2111.1D0, 275.9D0, 709.3D0, 0.9D0, 101D0, + : -1.03D0, 0.0067D0, 1D-12, REFA, REFB ) + CALL VVD ( REFA, 2.324673985217244D-4, 1D-12, 'slRFCO', + : 'A/R', STATUS ) + CALL VVD ( REFB, -2.265040682496D-7, 1D-15, 'slRFCO', + : 'B/R', STATUS ) + + CALL slRFCQ ( 275.9D0, 709.3D0, 0.9D0, 0.77D0, REFA, REFB ) + CALL VVD ( REFA, 2.007406521596588D-4, 1D-12, 'slRFCQ', + : 'A', STATUS ) + CALL VVD ( REFB, -2.264210092590D-7, 1D-15, 'slRFCQ', + : 'B', STATUS ) + + CALL slRFCO ( 2111.1D0, 275.9D0, 709.3D0, 0.9D0, 0.77D0, + : -1.03D0, 0.0067D0, 1D-12, REFA, REFB ) + CALL VVD ( REFA, 2.007202720084551D-4, 1D-12, 'slRFCO', + : 'A', STATUS ) + CALL VVD ( REFB, -2.223037748876D-7, 1D-15, 'slRFCO', + : 'B', STATUS ) + + CALL slATMD ( 275.9D0, 709.3D0, 0.9D0, 0.77D0, + : REFA, REFB, 0.5D0, REFA2, REFB2 ) + CALL VVD ( REFA2, 2.034523658888048D-4, 1D-12, 'slATMD', + : 'A', STATUS ) + CALL VVD ( REFB2, -2.250855362179D-7, 1D-15, 'slATMD', + : 'B', STATUS ) + + CALL slDS2C ( 0.345D0, 0.456D0, VU ) + CALL slREFV ( VU, REFA, REFB, VR ) + CALL VVD ( VR(1), 0.8447487047790478D0, 1D-12, 'slREFV', + : 'X1', STATUS ) + CALL VVD ( VR(2), 0.3035794890562339D0, 1D-12, 'slREFV', + : 'Y1', STATUS ) + CALL VVD ( VR(3), 0.4407256738589851D0, 1D-12, 'slREFV', + : 'Z1', STATUS ) + + CALL slDS2C ( 3.7D0, 0.03D0, VU ) + CALL slREFV ( VU, REFA, REFB, VR ) + CALL VVD ( VR(1), -0.8476187691681673D0, 1D-12, 'slREFV', + : 'X2', STATUS ) + CALL VVD ( VR(2), -0.5295354802804889D0, 1D-12, 'slREFV', + : 'Y2', STATUS ) + CALL VVD ( VR(3), 0.0322914582168426D0, 1D-12, 'slREFV', + : 'Z2', STATUS ) + + CALL slREFZ ( 0.567D0, REFA, REFB, ZR ) + CALL VVD ( ZR, 0.566872285910534D0, 1D-12, 'slREFZ', + : 'hi el', STATUS ) + + CALL slREFZ ( 1.55D0, REFA, REFB, ZR ) + CALL VVD ( ZR, 1.545697350690958D0, 1D-12, 'slREFZ', + : 'lo el', STATUS ) + + END + + SUBROUTINE T_RV ( STATUS ) +*+ +* - - - - - +* T _ R V +* - - - - - +* +* Test slRVER, slRVGA, slRVLG, slRVLD, slRVLK routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: VVD, slRVER, slRVGA, slRVLG, slRVLD, slRVLK. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + REAL slRVER, slRVGA, slRVLG, slRVLD, slRVLK + + + CALL VVD ( DBLE( slRVER ( -0.777E0, 5.67E0, -0.3E0, + : 3.19E0 ) ), -0.1948098355075913D0, 1D-6, + : 'slRVER', ' ', STATUS ) + CALL VVD ( DBLE( slRVGA ( 1.11E0, -0.99E0 ) ), + : 158.9630759840254D0, 1D-3, 'slRVGA', ' ', STATUS ) + CALL VVD ( DBLE( slRVLG ( 3.97E0, 1.09E0 ) ), + : -197.818762175363D0, 1D-3, 'slRVLG', ' ', STATUS ) + CALL VVD ( DBLE( slRVLD ( 6.01E0, 0.1E0 ) ), + : -4.082811335150567D0, 1D-4, 'slRVLD', ' ', STATUS ) + CALL VVD ( DBLE( slRVLK ( 6.01E0, 0.1E0 ) ), + : -5.925180579830265D0, 1D-4, 'slRVLK', ' ', STATUS ) + + END + + SUBROUTINE T_SEP ( STATUS ) +*+ +* - - - - - - - +* T _ S E P +* - - - - - - - +* +* Test slDSEP, slDSEPV, slSEP, slSEPV routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slDSEP, slSEP, VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I + REAL slSEP, slSEPV + REAL R1(3), R2(3), AR1, BR1, AR2, BR2 + DOUBLE PRECISION slDSEP, slDSEPV + DOUBLE PRECISION D1(3), D2(3), AD1, BD1, AD2, BD2 + + + R1(1) = 1.0 + R1(2) = 0.1 + R1(3) = 0.2 + R2(1) = -3.0 + R2(2) = 1E-3 + R2(3) = 0.2 + + DO I = 1, 3 + D1(I) = DBLE( R1(I) ) + D2(I) = DBLE( R2(I) ) + END DO + + CALL slDC2S ( D1, AD1, BD1 ) + CALL slDC2S ( D2, AD2, BD2 ) + + AR1 = SNGL( AD1 ) + BR1 = SNGL( BD1 ) + AR2 = SNGL( AD2 ) + BR2 = SNGL( BD2 ) + + CALL VVD ( slDSEP ( AD1, BD1, AD2, BD2 ), + : 2.8603919190246608D0, 1D-7, 'slDSEP', ' ', STATUS ) + CALL VVD ( DBLE( slSEP ( AR1, BR1, AR2, BR2 ) ), + : 2.8603919190246608D0, 1D-4, 'slSEP', ' ', STATUS ) + CALL VVD ( slDSEPV ( D1, D2 ), + : 2.8603919190246608D0, 1D-7, 'slDSEPV', ' ', STATUS ) + CALL VVD ( DBLE( slSEPV ( R1, R2 ) ), + : 2.8603919190246608D0, 1D-4, 'slSEPV', ' ', STATUS ) + + END + + SUBROUTINE T_SMAT ( STATUS ) +*+ +* - - - - - - - +* T _ S M A T +* - - - - - - - +* +* Test slSMAT routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slSMAT, VVD, VIV. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J, IW(3) + REAL A(3,3) + REAL V(3) + REAL D + + DATA A/2.22E0, 1.6578E0, 1.380522E0, + : 1.6578E0, 1.380522E0, 1.22548578E0, + : 1.380522E0, 1.22548578E0, 1.1356276122E0/ + DATA V/2.28625E0, 1.7128825E0, 1.429432225E0/ + + + CALL slSMAT ( 3, A, V, D, J, IW ) + + CALL VVD ( DBLE( A(1,1) ), 18.02550629769198D0, + : 1D-2, 'slSMAT', 'A(0,0)', STATUS ) + CALL VVD ( DBLE( A(1,2) ), -52.16386644917481D0, + : 1D-2, 'slSMAT', 'A(0,1)', STATUS ) + CALL VVD ( DBLE( A(1,3) ), 34.37875949717994D0, + : 1D-2, 'slSMAT', 'A(0,2)', STATUS ) + CALL VVD ( DBLE( A(2,1) ), -52.16386644917477D0, + : 1D-2, 'slSMAT', 'A(1,0)', STATUS ) + CALL VVD ( DBLE( A(2,2) ), 168.1778099099869D0, + : 1D-1, 'slSMAT', 'A(1,1)', STATUS ) + CALL VVD ( DBLE( A(2,3) ), -118.0722869694278D0, + : 1D-2, 'slSMAT', 'A(1,2)', STATUS ) + CALL VVD ( DBLE( A(3,1) ), 34.37875949717988D0, + : 1D-2, 'slSMAT', 'A(2,0)', STATUS ) + CALL VVD ( DBLE( A(3,2) ), -118.07228696942770D0, + : 1D-2, 'slSMAT', 'A(2,1)', STATUS ) + CALL VVD ( DBLE( A(3,3) ), 86.50307003740468D0, + : 1D-2, 'slSMAT', 'A(2,2)', STATUS ) + CALL VVD ( DBLE( V(1) ), 1.002346480763383D0, + : 1D-4, 'slSMAT', 'V(1)', STATUS ) + CALL VVD ( DBLE( V(2) ), 0.0328559401697292D0, + : 1D-4, 'slSMAT', 'V(2)', STATUS ) + CALL VVD ( DBLE( V(3) ), 0.004760688414898454D0, + : 1D-4, 'slSMAT', 'V(3)', STATUS ) + CALL VVD ( DBLE( D ), 0.003658344147359863D0, + : 1D-4, 'slSMAT', 'D', STATUS ) + CALL VIV ( J, 0, 'slSMAT', 'J', STATUS ) + + END + + SUBROUTINE T_SUPGAL ( STATUS ) +*+ +* - - - - - - - - - +* T _ S U G A +* - - - - - - - - - +* +* Test slSUGA routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slSUGA, VVD. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION DL, DB + + CALL slSUGA ( 6.1D0, -1.4D0, Dl, DB ) + + CALL VVD ( DL, 3.798775860769474D0, 1D-12, 'slSUGA', + : 'DL', STATUS ) + CALL VVD ( DB, -0.1397070490669407D0, 1D-12, 'slSUGA', + : 'DB', STATUS ) + + END + + SUBROUTINE T_SVD ( STATUS ) +*+ +* - - - - - - +* T _ S V D +* - - - - - - +* +* Test slSVD, slSVDS, slSVDC routines. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: slSVD, VVD, slSVDS, slSVDC. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER M, N + INTEGER I, J + INTEGER MP, NP, NC + + PARAMETER (MP = 10) + PARAMETER (NP = 6) + PARAMETER (NC = 7) + + DOUBLE PRECISION A(MP,NP), W(NP), V(NP,NP), WORK(NP), + : B(MP), X(NP), C(NC,NC) + DOUBLE PRECISION VAL + + M = 5 + N = 4 + + DO I = 1, M + VAL = DFLOAT( ( I ) ) / 2D0 + B(I) = 23D0 - 3D0 * VAL - 11D0 * DSIN ( VAL ) + + : 13D0 * DCOS ( VAL ) + A(I,1) = 1D0 + A(I,2) = VAL + A(I,3) = DSIN ( VAL ) + A(I,4) = DCOS ( VAL ) + END DO + + CALL slSVD ( M, N, MP, NP, A, W, V, WORK, J ) + +* Allow U and V to have reversed signs. + IF (A(1,1) .GT. 0D0) THEN + DO I = 1, M + DO J = 1, N + A(I,J) = - A(I,J) + V(I,J) = - V(I,J) + END DO + END DO + END IF + + CALL VVD ( A(1,1), -0.21532492989299D0, 1D-12, 'slSVD', + : 'A(1,1)', STATUS ) + CALL VVD ( A(1,2), 0.67675050651267D0, 1D-12, 'slSVD', + : 'A(1,2)', STATUS ) + CALL VVD ( A(1,3), -0.37267876361644D0, 1D-12, 'slSVD', + : 'A(1,3)', STATUS ) + CALL VVD ( A(1,4), 0.58330405917160D0, 1D-12, 'slSVD', + : 'A(1,4)', STATUS ) + CALL VVD ( A(2,1), -0.33693420368121D0, 1D-12, 'slSVD', + : 'A(2,1)', STATUS ) + CALL VVD ( A(2,2), 0.48011695963936D0, 1D-12, 'slSVD', + : 'A(2,2)', STATUS ) + CALL VVD ( A(2,3), 0.62656568539705D0, 1D-12, 'slSVD', + : 'A(2,3)', STATUS ) + CALL VVD ( A(2,4), -0.17479918328198D0, 1D-12, 'slSVD', + : 'A(2,4)', STATUS ) + CALL VVD ( A(3,1), -0.44396825906047D0, 1D-12, 'slSVD', + : 'A(3,1)', STATUS ) + CALL VVD ( A(3,2), 0.18255923809825D0, 1D-12, 'slSVD', + : 'A(3,2)', STATUS ) + CALL VVD ( A(3,3), 0.02228154115994D0, 1D-12, 'slSVD', + : 'A(3,3)', STATUS ) + CALL VVD ( A(3,4), -0.51743308030238D0, 1D-12, 'slSVD', + : 'A(3,4)', STATUS ) + CALL VVD ( A(4,1), -0.53172583816951D0, 1D-12, 'slSVD', + : 'A(4,1)', STATUS ) + CALL VVD ( A(4,2), -0.16537863535943D0, 1D-12, 'slSVD', + : 'A(4,2)', STATUS ) + CALL VVD ( A(4,3), -0.61134201569990D0, 1D-12, 'slSVD', + : 'A(4,3)', STATUS ) + CALL VVD ( A(4,4), -0.28871221824912D0, 1D-12, 'slSVD', + : 'A(4,4)', STATUS ) + CALL VVD ( A(5,1), -0.60022523682867D0, 1D-12, 'slSVD', + : 'A(5,1)', STATUS ) + CALL VVD ( A(5,2), -0.50081781972404D0, 1D-12, 'slSVD', + : 'A(5,2)', STATUS ) + CALL VVD ( A(5,3), 0.30706750690326D0, 1D-12, 'slSVD', + : 'A(5,3)', STATUS ) + CALL VVD ( A(5,4), 0.52736124480318D0, 1D-12, 'slSVD', + : 'A(5,4)', STATUS ) + + CALL VVD ( W(1), 4.57362714220621D0, 1D-12, 'slSVD', + : 'W(1)', STATUS ) + CALL VVD ( W(2), 1.64056393111226D0, 1D-12, 'slSVD', + : 'W(2)', STATUS ) + CALL VVD ( W(3), 0.03999179717447D0, 1D-12, 'slSVD', + : 'W(3)', STATUS ) + CALL VVD ( W(4), 0.37267332634218D0, 1D-12, 'slSVD', + : 'W(4)', STATUS ) + + CALL VVD ( V(1,1), -0.46531525230679D0, 1D-12, 'slSVD', + : 'V(1,1)', STATUS ) + CALL VVD ( V(1,2), 0.41036514115630D0, 1D-12, 'slSVD', + : 'V(1,2)', STATUS ) + CALL VVD ( V(1,3), -0.70279526907678D0, 1D-12, 'slSVD', + : 'V(1,3)', STATUS ) + CALL VVD ( V(1,4), 0.34808185338758D0, 1D-12, 'slSVD', + : 'V(1,4)', STATUS ) + CALL VVD ( V(2,1), -0.80342444002914D0, 1D-12, 'slSVD', + : 'V(2,1)', STATUS ) + CALL VVD ( V(2,2), -0.29896472833787D0, 1D-12, 'slSVD', + : 'V(2,2)', STATUS ) + CALL VVD ( V(2,3), 0.46592932810178D0, 1D-12, 'slSVD', + : 'V(2,3)', STATUS ) + CALL VVD ( V(2,4), 0.21917828721921D0, 1D-12, 'slSVD', + : 'V(2,4)', STATUS ) + CALL VVD ( V(3,1), -0.36564497020801D0, 1D-12, 'slSVD', + : 'V(3,1)', STATUS ) + CALL VVD ( V(3,2), 0.28066812941896D0, 1D-12, 'slSVD', + : 'V(3,2)', STATUS ) + CALL VVD ( V(3,3), -0.03324480702665D0, 1D-12, 'slSVD', + : 'V(3,3)', STATUS ) + CALL VVD ( V(3,4), -0.88680546891402D0, 1D-12, 'slSVD', + : 'V(3,4)', STATUS ) + CALL VVD ( V(4,1), 0.06553350971918D0, 1D-12, 'slSVD', + : 'V(4,1)', STATUS ) + CALL VVD ( V(4,2), 0.81452191085452D0, 1D-12, 'slSVD', + : 'V(4,2)', STATUS ) + CALL VVD ( V(4,3), 0.53654771808636D0, 1D-12, 'slSVD', + : 'V(4,3)', STATUS ) + CALL VVD ( V(4,4), 0.21065602782287D0, 1D-12, 'slSVD', + : 'V(4,4)', STATUS ) + + CALL slSVDS ( M, N, MP, NP, B, A, W, V, WORK, X ) + + CALL VVD ( X(1), 23D0, 1D-12, 'slSVDS', 'X(1)', STATUS ) + CALL VVD ( X(2), -3D0, 1D-12, 'slSVDS', 'X(2)', STATUS ) + CALL VVD ( X(3), -11D0, 1D-12, 'slSVDS', 'X(3)', STATUS ) + CALL VVD ( X(4), 13D0, 1D-12, 'slSVDS', 'X(4)', STATUS ) + + CALL slSVDC ( N, NP, NC, W, V, WORK, C ) + + CALL VVD ( C(1,1), 309.77269378273270D0, 1D-10, + : 'slSVDC', 'C(1,1)', STATUS ) + CALL VVD ( C(1,2), -204.22043941662150D0, 1D-10, + : 'slSVDC', 'C(1,2)', STATUS ) + CALL VVD ( C(1,3), 12.43704316907477D0, 1D-10, + : 'slSVDC', 'C(1,3)', STATUS ) + CALL VVD ( C(1,4), -235.12299986206710D0, 1D-10, + : 'slSVDC', 'C(1,4)', STATUS ) + CALL VVD ( C(2,1), -204.22043941662150D0, 1D-10, + : 'slSVDC', 'C(2,1)', STATUS ) + CALL VVD ( C(2,2), 136.14695961108110D0, 1D-10, + : 'slSVDC', 'C(2,2)', STATUS ) + CALL VVD ( C(2,3), -11.10167446246327D0, 1D-10, + : 'slSVDC', 'C(2,3)', STATUS ) + CALL VVD ( C(2,4), 156.54937371198730D0, 1D-10, + : 'slSVDC', 'C(2,4)', STATUS ) + CALL VVD ( C(3,1), 12.43704316907477D0, 1D-10, + : 'slSVDC', 'C(3,1)', STATUS ) + CALL VVD ( C(3,2), -11.10167446246327D0, 1D-10, + : 'slSVDC', 'C(3,2)', STATUS ) + CALL VVD ( C(3,3), 6.38909830090602D0, 1D-10, + : 'slSVDC', 'C(3,3)', STATUS ) + CALL VVD ( C(3,4), -12.41424302586736D0, 1D-10, + : 'slSVDC', 'C(3,4)', STATUS ) + CALL VVD ( C(4,1), -235.12299986206710D0, 1D-10, + : 'slSVDC', 'C(4,1)', STATUS ) + CALL VVD ( C(4,2), 156.54937371198730D0, 1D-10, + : 'slSVDC', 'C(4,2)', STATUS ) + CALL VVD ( C(4,3), -12.41424302586736D0, 1D-10, + : 'slSVDC', 'C(4,3)', STATUS ) + CALL VVD ( C(4,4), 180.56719842359560D0, 1D-10, + : 'slSVDC', 'C(4,4)', STATUS ) + + END + + SUBROUTINE T_TP ( STATUS ) +*+ +* - - - - - - +* T _ T P +* - - - - - - +* +* Test spherical tangent-planD-projection routines: +* +* slS2TP slDSTP slDPSC +* slTP2S slDTPS slTPSC +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: all the above, plus VVD and VIV. +* +* Last revision: 10 July 2000 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + REAL R0, D0, R1, D1, X, Y, R2, D2, R01, D01, R02, D02 + DOUBLE PRECISION DR0, DD0, DR1, DD1, DX, DY, DR2, DD2, DR01, + : DD01, DR02, DD02 + + R0 = 3.1E0 + D0 = -0.9E0 + R1 = R0 + 0.2E0 + D1 = D0 - 0.1E0 + CALL slS2TP ( R1, D1, R0, D0, X, Y, J ) + CALL VVD ( DBLE( X ), 0.1086112301590404D0, 1D-6, 'slS2TP', + : 'X', STATUS ) + CALL VVD ( DBLE( Y ), -0.1095506200711452D0, 1D-6, 'slS2TP', + : 'Y', STATUS ) + CALL VIV ( J, 0, 'slS2TP', 'J', STATUS ) + CALL slTP2S ( X, Y, R0, D0, R2, D2 ) + CALL VVD ( DBLE( ( R2 - R1 ) ), 0D0, 1D-6, 'slTP2S', + : 'R', STATUS ) + CALL VVD ( DBLE( ( D2 - D1 ) ), 0D0, 1D-6, 'slTP2S', + : 'D', STATUS ) + CALL slTPSC ( X, Y, R2, D2, R01, D01, R02, D02, J ) + CALL VVD ( DBLE( R01 ), 3.1D0, 1D-6, 'slTPSC', + : 'R1', STATUS ) + CALL VVD ( DBLE( D01 ), -0.9D0, 1D-6, 'slTPSC', + : 'D1', STATUS ) + CALL VVD ( DBLE( R02 ), 0.3584073464102072D0, 1D-6, 'slTPSC', + : 'R2', STATUS ) + CALL VVD ( DBLE( D02 ), -2.023361658234722D0, 1D-6, 'slTPSC', + : 'D2', STATUS ) + CALL VIV ( J, 1, 'slTPSC', 'N', STATUS ) + + DR0 = 3.1D0 + DD0 = -0.9D0 + DR1 = DR0 + 0.2D0 + DD1 = DD0 - 0.1D0 + CALL slDSTP ( DR1, DD1, DR0, DD0, DX, DY, J ) + CALL VVD ( DX, 0.1086112301590404D0, 1D-12, 'slDSTP', + : 'X', STATUS ) + CALL VVD ( DY, -0.1095506200711452D0, 1D-12, 'slDSTP', + : 'Y', STATUS ) + CALL VIV ( J, 0, 'slDSTP', 'J', STATUS ) + CALL slDTPS ( DX, DY, DR0, DD0, DR2, DD2 ) + CALL VVD ( DR2 - DR1, 0D0, 1D-12, 'slDTPS', 'R', STATUS ) + CALL VVD ( DD2 - DD1, 0D0, 1D-12, 'slDTPS', 'D', STATUS ) + CALL slDPSC ( DX, DY, DR2, DD2, DR01, DD01, DR02, DD02, J ) + CALL VVD ( DR01, 3.1D0, 1D-12, 'slDPSC', 'R1', STATUS ) + CALL VVD ( DD01, -0.9D0, 1D-12, 'slDPSC', 'D1', STATUS ) + CALL VVD ( DR02, 0.3584073464102072D0, 1D-12, 'slDPSC', + : 'R2', STATUS ) + CALL VVD ( DD02, -2.023361658234722D0, 1D-12, 'slDPSC', + : 'D2', STATUS ) + CALL VIV ( J, 1, 'slDPSC', 'N', STATUS ) + + END + + SUBROUTINE T_TPV ( STATUS ) +*+ +* - - - - - - +* T _ T P V +* - - - - - - +* +* Test Cartesian tangent-planD-projection routines: +* +* slTP2V slV2TP slTPVC +* slDTPV slDVTP slDPVC +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: all the above, plus VVD and VIV. +* +* Last revision: 21 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER J + REAL RXI, RETA, RV(3), RV0(3), RTXI, RTETA, RTV(3), + : RTV01(3), RTV02(3) + DOUBLE PRECISION XI, ETA, X, Y, Z, V(3), V0(3), TXI, TETA, + : TV(3), TV01(3), TV02(3) + + XI = -0.1D0 + ETA = 0.055D0 + RXI = SNGL( XI ) + RETA = SNGL( ETA ) + + X = -0.7D0 + Y = -0.13D0 + Z = DSQRT ( 1D0 - X * X - Y * Y ) + RV(1) = SNGL( X ) + RV(2) = SNGL( Y ) + RV(3) = SNGL( Z ) + V(1) = X + V(2) = Y + V(3) = Z + + X = -0.72D0 + Y = -0.16D0 + Z = DSQRT ( 1D0 - X * X - Y * Y ) + RV0(1) = SNGL( X ) + RV0(2) = SNGL( Y ) + RV0(3) = SNGL( Z ) + V0(1) = X + V0(2) = Y + V0(3) = Z + + CALL slTP2V ( RXI, RETA, RV0, RTV ) + CALL VVD ( DBLE( RTV(1) ), -0.700887428128D0, 1D-6, 'slTP2V', + : 'V(1)', STATUS ) + CALL VVD ( DBLE( RTV(2) ), -0.05397407D0, 1D-6, 'slTP2V', + : 'V(2)', STATUS ) + CALL VVD ( DBLE( RTV(3) ), 0.711226836562D0, 1D-6, 'slTP2V', + : 'V(3)', STATUS ) + + CALL slDTPV ( XI, ETA, V0, TV ) + CALL VVD ( TV(1), -0.7008874281280771D0, 1D-13, 'slDTPV', + : 'V(1)', STATUS ) + CALL VVD ( TV(2), -0.05397406827952735D0, 1D-13, 'slDTPV', + : 'V(2)', STATUS ) + CALL VVD ( TV(3), 0.7112268365615617D0, 1D-13, 'slDTPV', + : 'V(3)', STATUS ) + + CALL slV2TP ( RV, RV0, RTXI, RTETA, J) + CALL VVD ( DBLE( RTXI ), -0.02497229197D0, 1D-6, 'slV2TP', + : 'XI', STATUS ) + CALL VVD ( DBLE( RTETA ), 0.03748140764D0, 1D-6, 'slV2TP', + : 'ETA', STATUS ) + CALL VIV ( J, 0, 'slV2TP', 'J', STATUS ) + + CALL slDVTP ( V, V0, TXI, TETA, J ) + CALL VVD ( TXI, -0.02497229197023852D0, 1D-13, 'slDVTP', + : 'XI', STATUS ) + CALL VVD ( TETA, 0.03748140764224765D0, 1D-13, 'slDVTP', + : 'ETA', STATUS ) + CALL VIV ( J, 0, 'slDVTP', 'J', STATUS ) + + CALL slTPVC ( RXI, RETA, RV, RTV01, RTV02, J ) + CALL VVD ( DBLE( RTV01(1) ), -0.7074573732537283D0, 1D-6, + : 'slTPVC', 'V01(1)', STATUS ) + CALL VVD ( DBLE( RTV01(2) ), -0.2372965765309941D0, 1D-6, + : 'slTPVC', 'V01(2)', STATUS ) + CALL VVD ( DBLE( RTV01(3) ), 0.6657284730245545D0, 1D-6, + : 'slTPVC', 'V01(3)', STATUS ) + CALL VVD ( DBLE( RTV02(1) ), -0.6680480104758149D0, 1D-6, + : 'slTPVC', 'V02(1)', STATUS ) + CALL VVD ( DBLE( RTV02(2) ), -0.02915588494045333D0, 1D-6, + : 'slTPVC', 'V02(2)', STATUS ) + CALL VVD ( DBLE( RTV02(3) ), 0.7435467638774610D0, 1D-6, + : 'slTPVC', 'V02(3)', STATUS ) + CALL VIV ( J, 1, 'slTPVC', 'N', STATUS ) + + CALL slDPVC ( XI, ETA, V, TV01, TV02, J ) + CALL VVD ( TV01(1), -0.7074573732537283D0, 1D-13, 'slDPVC', + : 'V01(1)', STATUS ) + CALL VVD ( TV01(2), -0.2372965765309941D0, 1D-13, 'slDPVC', + : 'V01(2)', STATUS ) + CALL VVD ( TV01(3), 0.6657284730245545D0, 1D-13, 'slDPVC', + : 'V01(3)', STATUS ) + CALL VVD ( TV02(1), -0.6680480104758149D0, 1D-13, 'slDPVC', + : 'V02(1)', STATUS ) + CALL VVD ( TV02(2), -0.02915588494045333D0, 1D-13, 'slDPVC', + : 'V02(2)', STATUS ) + CALL VVD ( TV02(3), 0.7435467638774610D0, 1D-13, 'slDPVC', + : 'V02(3)', STATUS ) + CALL VIV ( J, 1, 'slDPVC', 'N', STATUS ) + + END + + SUBROUTINE T_VECMAT ( STATUS ) +*+ +* - - - - - - - - - +* T _ V E C M A +* - - - - - - - - - +* +* Test all the 3-vector and 3x3 matrix routines: +* +* slAV2M slDAVM +* slCC2S slDC2S +* slCS2C slDS2C +* slEULR slDEUL +* slIMXV slDIMV +* slM2AV slDMAV +* slMXM slDMXM +* slMXV slDMXV +* slVDV slDVDV +* slVN slDVN +* slVXV slDVXV +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: all the above, plus VVD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + INTEGER I + REAL slVDV + REAL AV(3), RM1(3,3), RM2(3,3), RM(3,3), V1(3), V2(3), + : V3(3), V4(3), V5(3), VM, V6(3), V7(3) + DOUBLE PRECISION slDVDV + DOUBLE PRECISION DAV(3), DRM1(3,3), DRM2(3,3), DRM(3,3), + : DV1(3), DV2(3), DV3(3), DV4(3), DV5(3), + : DVM, DV6(3), DV7(3) + + +* Make a rotation matrix. + AV(1) = -0.123E0 + AV(2) = 0.0987E0 + AV(3) = 0.0654E0 + CALL slAV2M ( AV, RM1 ) + CALL VVD ( DBLE( RM1(1,1) ), 0.9930075842721269D0, + : 1D-6, 'slAV2M', '11', STATUS ) + CALL VVD ( DBLE( RM1(1,2) ), 0.05902743090199868D0, + : 1D-6, 'slAV2M', '12', STATUS ) + CALL VVD ( DBLE( RM1(1,3) ), -0.1022335560329612D0, + : 1D-6, 'slAV2M', '13', STATUS ) + CALL VVD ( DBLE( RM1(2,1) ), -0.07113807138648245D0, + : 1D-6, 'slAV2M', '21', STATUS ) + CALL VVD ( DBLE( RM1(2,2) ), 0.9903204657727545D0, + : 1D-6, 'slAV2M', '22', STATUS ) + CALL VVD ( DBLE( RM1(2,3) ), -0.1191836812279541D0, + : 1D-6, 'slAV2M', '23', STATUS ) + CALL VVD ( DBLE( RM1(3,1) ), 0.09420887631983825D0, + : 1D-6, 'slAV2M', '31', STATUS ) + CALL VVD ( DBLE( RM1(3,2) ), 0.1256229973879967D0, + : 1D-6, 'slAV2M', '32', STATUS ) + CALL VVD ( DBLE( RM1(3,3) ), 0.9875948309655174D0, + : 1D-6, 'slAV2M', '33', STATUS ) + +* Make another. + CALL slEULR ( 'YZY', 2.345E0, -0.333E0, 2.222E0, RM2 ) + CALL VVD ( DBLE( RM2(1,1) ), -0.1681574770810878D0, + : 1D-6, 'slEULR', '11', STATUS ) + CALL VVD ( DBLE( RM2(1,2) ), 0.1981362273264315D0, + : 1D-6, 'slEULR', '12', STATUS ) + CALL VVD ( DBLE( RM2(1,3) ), 0.9656423242187410D0, + : 1D-6, 'slEULR', '13', STATUS ) + CALL VVD ( DBLE( RM2(2,1) ), -0.2285369373983370D0, + : 1D-6, 'slEULR', '21', STATUS ) + CALL VVD ( DBLE( RM2(2,2) ), 0.9450659587140423D0, + : 1D-6, 'slEULR', '22', STATUS ) + CALL VVD ( DBLE( RM2(2,3) ), -0.2337117924378156D0, + : 1D-6, 'slEULR', '23', STATUS ) + CALL VVD ( DBLE( RM2(3,1) ), -0.9589024617479674D0, + : 1D-6, 'slEULR', '31', STATUS ) + CALL VVD ( DBLE( RM2(3,2) ), -0.2599853247796050D0, + : 1D-6, 'slEULR', '32', STATUS ) + CALL VVD ( DBLE( RM2(3,3) ), -0.1136384607117296D0, + : 1D-6, 'slEULR', '33', STATUS ) + +* Combine them. + CALL slMXM ( RM2, RM1, RM ) + CALL VVD ( DBLE( RM(1,1) ), -0.09010460088585805D0, + : 1D-6, 'slMXM', '11', STATUS ) + CALL VVD ( DBLE( RM(1,2) ), 0.3075993402463796D0, + : 1D-6, 'slMXM', '12', STATUS ) + CALL VVD ( DBLE( RM(1,3) ), 0.9472400998581048D0, + : 1D-6, 'slMXM', '13', STATUS ) + CALL VVD ( DBLE( RM(2,1) ), -0.3161868071070688D0, + : 1D-6, 'slMXM', '21', STATUS ) + CALL VVD ( DBLE( RM(2,2) ), 0.8930686362478707D0, + : 1D-6, 'slMXM', '22', STATUS ) + CALL VVD ( DBLE( RM(2,3) ),-0.3200848543149236D0, + : 1D-6, 'slMXM', '23', STATUS ) + CALL VVD ( DBLE( RM(3,1) ),-0.9444083141897035D0, + : 1D-6, 'slMXM', '31', STATUS ) + CALL VVD ( DBLE( RM(3,2) ),-0.3283459407855694D0, + : 1D-6, 'slMXM', '32', STATUS ) + CALL VVD ( DBLE( RM(3,3) ), 0.01678926022795169D0, + : 1D-6, 'slMXM', '33', STATUS ) + +* Create a vector. + CALL slCS2C ( 3.0123E0, -0.999E0, V1 ) + CALL VVD ( DBLE( V1(1) ), -0.5366267667260525D0, + : 1D-6, 'slCS2C', 'X', STATUS ) + CALL VVD ( DBLE( V1(2) ), 0.06977111097651444D0, + : 1D-6, 'slCS2C', 'Y', STATUS ) + CALL VVD ( DBLE( V1(3) ), -0.8409302618566215D0, + : 1D-6, 'slCS2C', 'Z', STATUS ) + +* Rotate it using the two matrices sequentially. + CALL slMXV ( RM1, V1, V2 ) + CALL slMXV ( RM2, V2, V3 ) + CALL VVD ( DBLE( V3(1) ), -0.7267487768696160D0, + : 1D-6, 'slMXV', 'X', STATUS ) + CALL VVD ( DBLE( V3(2) ), 0.5011537352639822D0, + : 1D-6, 'slMXV', 'Y', STATUS ) + CALL VVD ( DBLE( V3(3) ), 0.4697671220397141D0, + : 1D-6, 'slMXV', 'Z', STATUS ) + +* Derotate it using the combined matrix. + CALL slIMXV ( RM, V3, V4 ) + CALL VVD ( DBLE( V4(1) ), -0.5366267667260526D0, + : 1D-6, 'slIMXV', 'X', STATUS ) + CALL VVD ( DBLE( V4(2) ), 0.06977111097651445D0, + : 1D-6, 'slIMXV', 'Y', STATUS ) + CALL VVD ( DBLE( V4(3) ), -0.8409302618566215D0, + : 1D-6, 'slIMXV', 'Z', STATUS ) + +* Convert the combined matrix into an axial vector. + CALL slM2AV ( RM, V5 ) + CALL VVD ( DBLE( V5(1) ), 0.006889040510209034D0, + : 1D-6, 'slM2AV', 'X', STATUS ) + CALL VVD ( DBLE( V5(2) ), -1.577473205461961D0, + : 1D-6, 'slM2AV', 'Y', STATUS ) + CALL VVD ( DBLE( V5(3) ), 0.5201843672856759D0, + : 1D-6, 'slM2AV', 'Z', STATUS ) + +* Multiply it by a scalar and then normalize. + DO I = 1, 3 + V5(I) = V5(I) * 1000.0 + END DO + + CALL slVN ( V5, V6, VM ) + CALL VVD ( DBLE( V6(1) ), 0.004147420704640065D0, + : 1D-6, 'slVN', 'X', STATUS ) + CALL VVD ( DBLE( V6(2) ), -0.9496888606842218D0, + : 1D-6, 'slVN', 'Y', STATUS ) + CALL VVD ( DBLE( V6(3) ), 0.3131674740355448D0, + : 1D-6, 'slVN', 'Z', STATUS ) + CALL VVD ( DBLE( VM ), 1661.042127339937D0, + : 1D-3, 'slVN', 'M', STATUS ) + +* Dot product with the original vector. + CALL VVD ( DBLE( slVDV ( V6, V1 ) ), + : -0.3318384698006295D0, 1D-6, 'slVN', ' ', STATUS ) + +* Cross product with the original vector. + CALL slVXV (V6, V1, V7 ) + CALL VVD ( DBLE( V7(1) ), 0.7767720597123304D0, + : 1D-6, 'slVXV', 'X', STATUS ) + CALL VVD ( DBLE( V7(2) ), -0.1645663574562769D0, + : 1D-6, 'slVXV', 'Y', STATUS ) + CALL VVD ( DBLE( V7(3) ), -0.5093390925544726D0, + : 1D-6, 'slVXV', 'Z', STATUS ) + +* Same in double precision. + + DAV(1) = -0.123D0 + DAV(2) = 0.0987D0 + DAV(3) = 0.0654D0 + CALL slDAVM ( DAV, DRM1 ) + CALL VVD ( DRM1(1,1), 0.9930075842721269D0, 1D-12, + : 'slDAVM', '11', STATUS ) + CALL VVD ( DRM1(1,2), 0.05902743090199868D0, 1D-12, + : 'slDAVM', '12', STATUS ) + CALL VVD ( DRM1(1,3), -0.1022335560329612D0, 1D-12, + : 'slDAVM', '13', STATUS ) + CALL VVD ( DRM1(2,1), -0.07113807138648245D0, 1D-12, + : 'slDAVM', '21', STATUS ) + CALL VVD ( DRM1(2,2), 0.9903204657727545D0, 1D-12, + : 'slDAVM', '22', STATUS ) + CALL VVD ( DRM1(2,3), -0.1191836812279541D0, 1D-12, + : 'slDAVM', '23', STATUS ) + CALL VVD ( DRM1(3,1), 0.09420887631983825D0, 1D-12, + : 'slDAVM', '31', STATUS ) + CALL VVD ( DRM1(3,2), 0.1256229973879967D0, 1D-12, + : 'slDAVM', '32', STATUS ) + CALL VVD ( DRM1(3,3), 0.9875948309655174D0, 1D-12, + : 'slDAVM', '33', STATUS ) + + CALL slDEUL ( 'YZY', 2.345D0, -0.333D0, 2.222D0, DRM2 ) + CALL VVD ( DRM2(1,1), -0.1681574770810878D0, 1D-12, + : 'slDEUL', '11', STATUS ) + CALL VVD ( DRM2(1,2), 0.1981362273264315D0, 1D-12, + : 'slDEUL', '12', STATUS ) + CALL VVD ( DRM2(1,3), 0.9656423242187410D0, 1D-12, + : 'slDEUL', '13', STATUS ) + CALL VVD ( DRM2(2,1), -0.2285369373983370D0, 1D-12, + : 'slDEUL', '21', STATUS ) + CALL VVD ( DRM2(2,2), 0.9450659587140423D0, 1D-12, + : 'slDEUL', '22', STATUS ) + CALL VVD ( DRM2(2,3), -0.2337117924378156D0, 1D-12, + : 'slDEUL', '23', STATUS ) + CALL VVD ( DRM2(3,1), -0.9589024617479674D0, 1D-12, + : 'slDEUL', '31', STATUS ) + CALL VVD ( DRM2(3,2), -0.2599853247796050D0, 1D-12, + : 'slDEUL', '32', STATUS ) + CALL VVD ( DRM2(3,3), -0.1136384607117296D0, 1D-12, + : 'slDEUL', '33', STATUS ) + + CALL slDMXM ( DRM2, DRM1, DRM ) + CALL VVD ( DRM(1,1), -0.09010460088585805D0, 1D-12, + : 'slDMXM', '11', STATUS ) + CALL VVD ( DRM(1,2), 0.3075993402463796D0, 1D-12, + : 'slDMXM', '12', STATUS ) + CALL VVD ( DRM(1,3), 0.9472400998581048D0, 1D-12, + : 'slDMXM', '13', STATUS ) + CALL VVD ( DRM(2,1), -0.3161868071070688D0, 1D-12, + : 'slDMXM', '21', STATUS ) + CALL VVD ( DRM(2,2), 0.8930686362478707D0, 1D-12, + : 'slDMXM', '22', STATUS ) + CALL VVD ( DRM(2,3), -0.3200848543149236D0, 1D-12, + : 'slDMXM', '23', STATUS ) + CALL VVD ( DRM(3,1), -0.9444083141897035D0, 1D-12, + : 'slDMXM', '31', STATUS ) + CALL VVD ( DRM(3,2), -0.3283459407855694D0, 1D-12, + : 'slDMXM', '32', STATUS ) + CALL VVD ( DRM(3,3), 0.01678926022795169D0, 1D-12, + : 'slDMXM', '33', STATUS ) + + CALL slDS2C ( 3.0123D0, -0.999D0, DV1 ) + CALL VVD ( DV1(1), -0.5366267667260525D0, 1D-12, + : 'slDS2C', 'X', STATUS ) + CALL VVD ( DV1(2), 0.06977111097651444D0, 1D-12, + : 'slDS2C', 'Y', STATUS ) + CALL VVD ( DV1(3), -0.8409302618566215D0, 1D-12, + : 'slDS2C', 'Z', STATUS ) + + CALL slDMXV ( DRM1, DV1, DV2 ) + CALL slDMXV ( DRM2, DV2, DV3 ) + CALL VVD ( DV3(1), -0.7267487768696160D0, 1D-12, + : 'slDMXV', 'X', STATUS ) + CALL VVD ( DV3(2), 0.5011537352639822D0, 1D-12, + : 'slDMXV', 'Y', STATUS ) + CALL VVD ( DV3(3), 0.4697671220397141D0, 1D-12, + : 'slDMXV', 'Z', STATUS ) + + CALL slDIMV ( DRM, DV3, DV4 ) + CALL VVD ( DV4(1), -0.5366267667260526D0, 1D-12, + : 'slDIMV', 'X', STATUS ) + CALL VVD ( DV4(2), 0.06977111097651445D0, 1D-12, + : 'slDIMV', 'Y', STATUS ) + CALL VVD ( DV4(3), -0.8409302618566215D0, 1D-12, + : 'slDIMV', 'Z', STATUS ) + + CALL slDMAV ( DRM, DV5 ) + CALL VVD ( DV5(1), 0.006889040510209034D0, 1D-12, + : 'slDMAV', 'X', STATUS ) + CALL VVD ( DV5(2), -1.577473205461961D0, 1D-12, + : 'slDMAV', 'Y', STATUS ) + CALL VVD ( DV5(3), 0.5201843672856759D0, 1D-12, + : 'slDMAV', 'Z', STATUS ) + + DO I = 1, 3 + DV5(I) = DV5(I) * 1000D0 + END DO + + CALL slDVN ( DV5, DV6, DVM ) + CALL VVD ( DV6(1), 0.004147420704640065D0, 1D-12, + : 'slDVN', 'X', STATUS ) + CALL VVD ( DV6(2), -0.9496888606842218D0, 1D-12, + : 'slDVN', 'Y', STATUS ) + CALL VVD ( DV6(3), 0.3131674740355448D0, 1D-12, + : 'slDVN', 'Z', STATUS ) + CALL VVD ( DVM, 1661.042127339937D0, 1D-9, 'slDVN', + : 'M', STATUS ) + + CALL VVD ( slDVDV ( DV6, DV1 ), -0.3318384698006295D0, + : 1D-12, 'slDVN', ' ', STATUS ) + + CALL slDVXV (DV6, DV1, DV7 ) + CALL VVD ( DV7(1), 0.7767720597123304D0, 1D-12, + : 'slDVXV', 'X', STATUS ) + CALL VVD ( DV7(2), -0.1645663574562769D0, 1D-12, + : 'slDVXV', 'Y', STATUS ) + CALL VVD ( DV7(3), -0.5093390925544726D0, 1D-12, + : 'slDVXV', 'Z', STATUS ) + + END + + SUBROUTINE T_ZD ( STATUS ) +*+ +* - - - - - +* T _ Z D +* - - - - - +* +* Test slZD routine. +* +* Returned: +* STATUS LOGICAL .TRUE. = success, .FALSE. = fail +* +* Called: VVD, slZD. +* +* Last revision: 22 October 2005 +* +* Copyright CLRC/Starlink. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 59 Temple Place, Suite 330, +* Boston, MA 02111-1307 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + LOGICAL STATUS + + DOUBLE PRECISION slZD + + + CALL VVD ( slZD ( -1.023D0, -0.876D0, -0.432D0 ), + : 0.8963914139430839D0, 1D-12, 'slZD', ' ', STATUS ) + + END diff --git a/math/slalib/slalib.h b/math/slalib/slalib.h new file mode 100644 index 00000000..bf804c4f --- /dev/null +++ b/math/slalib/slalib.h @@ -0,0 +1,509 @@ +#ifndef SLALIBHDEF +#define SLALIBHDEF +/* +** Author: +** Patrick Wallace (ptw@tpsoft.demon.co.uk) +** +** License: +** This program is free software; you can redistribute it and/or modify +** it under the terms of the GNU General Public License as published by +** the Free Software Foundation; either version 2 of the License, or +** (at your option) any later version. +** +** This program is distributed in the hope that it will be useful, +** but WITHOUT ANY WARRANTY; without even the implied warranty of +** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +** GNU General Public License for more details. +** +** You should have received a copy of the GNU General Public License +** along with this program; if not, write to the Free Software +** Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 +** USA. +** +** Last revision: 10 December 2002 +** +*/ + +#ifdef __cplusplus +extern "C" { +#endif + +#include + +void slaAddet ( double rm, double dm, double eq, double *rc, double *dc ); + +void slaAfin ( const char *string, int *iptr, float *a, int *j ); + +double slaAirmas ( double zd ); + +void slaAltaz ( double ha, double dec, double phi, + double *az, double *azd, double *azdd, + double *el, double *eld, double *eldd, + double *pa, double *pad, double *padd ); + +void slaAmp ( double ra, double da, double date, double eq, + double *rm, double *dm ); + +void slaAmpqk ( double ra, double da, double amprms[21], + double *rm, double *dm ); + +void slaAop ( double rap, double dap, double date, double dut, + double elongm, double phim, double hm, double xp, + double yp, double tdk, double pmb, double rh, + double wl, double tlr, + double *aob, double *zob, double *hob, + double *dob, double *rob ); + +void slaAoppa ( double date, double dut, double elongm, double phim, + double hm, double xp, double yp, double tdk, double pmb, + double rh, double wl, double tlr, double aoprms[14] ); + +void slaAoppat ( double date, double aoprms[14] ); + +void slaAopqk ( double rap, double dap, double aoprms[14], + double *aob, double *zob, double *hob, + double *dob, double *rob ); + +void slaAtmdsp ( double tdk, double pmb, double rh, double wl1, + double a1, double b1, double wl2, double *a2, double *b2 ); + +void slaAv2m ( float axvec[3], float rmat[3][3] ); + +float slaBear ( float a1, float b1, float a2, float b2 ); + +void slaCaf2r ( int ideg, int iamin, float asec, float *rad, int *j ); + +void slaCaldj ( int iy, int im, int id, double *djm, int *j ); + +void slaCalyd ( int iy, int im, int id, int *ny, int *nd, int *j ); + +void slaCc2s ( float v[3], float *a, float *b ); + +void slaCc62s ( float v[6], float *a, float *b, float *r, + float *ad, float *bd, float *rd ); + +void slaCd2tf ( int ndp, float days, char *sign, int ihmsf[4] ); + +void slaCldj ( int iy, int im, int id, double *djm, int *j ); + +void slaClyd ( int iy, int im, int id, int *ny, int *nd, int *jstat ); + +void slaCombn ( int nsel, int ncand, int list[], int *j ); + +void slaCr2af ( int ndp, float angle, char *sign, int idmsf[4] ); + +void slaCr2tf ( int ndp, float angle, char *sign, int ihmsf[4] ); + +void slaCs2c ( float a, float b, float v[3] ); + +void slaCs2c6 ( float a, float b, float r, float ad, + float bd, float rd, float v[6] ); + +void slaCtf2d ( int ihour, int imin, float sec, float *days, int *j ); + +void slaCtf2r ( int ihour, int imin, float sec, float *rad, int *j ); + +void slaDaf2r ( int ideg, int iamin, double asec, double *rad, int *j ); + +void slaDafin ( const char *string, int *iptr, double *a, int *j ); + +double slaDat ( double dju ); + +void slaDav2m ( double axvec[3], double rmat[3][3] ); + +double slaDbear ( double a1, double b1, double a2, double b2 ); + +void slaDbjin ( const char *string, int *nstrt, + double *dreslt, int *jf1, int *jf2 ); + +void slaDc62s ( double v[6], double *a, double *b, double *r, + double *ad, double *bd, double *rd ); + +void slaDcc2s ( double v[3], double *a, double *b ); + +void slaDcmpf ( double coeffs[6], double *xz, double *yz, double *xs, + double *ys, double *perp, double *orient ); + +void slaDcs2c ( double a, double b, double v[3] ); + +void slaDd2tf ( int ndp, double days, char *sign, int ihmsf[4] ); + +void slaDe2h ( double ha, double dec, double phi, + double *az, double *el ); + +void slaDeuler ( const char *order, double phi, double theta, double psi, + double rmat[3][3] ); + +void slaDfltin ( const char *string, int *nstrt, double *dreslt, int *jflag ); + +void slaDh2e ( double az, double el, double phi, double *ha, double *dec); + +void slaDimxv ( double dm[3][3], double va[3], double vb[3] ); + +void slaDjcal ( int ndp, double djm, int iymdf[4], int *j ); + +void slaDjcl ( double djm, int *iy, int *im, int *id, double *fd, int *j ); + +void slaDm2av ( double rmat[3][3], double axvec[3] ); + +void slaDmat ( int n, double *a, double *y, double *d, int *jf, int *iw ); + +void slaDmoon ( double date, double pv[6] ); + +void slaDmxm ( double a[3][3], double b[3][3], double c[3][3] ); + +void slaDmxv ( double dm[3][3], double va[3], double vb[3] ); + +double slaDpav ( double v1[3], double v2[3] ); + +void slaDr2af ( int ndp, double angle, char *sign, int idmsf[4] ); + +void slaDr2tf ( int ndp, double angle, char *sign, int ihmsf[4] ); + +double slaDrange ( double angle ); + +double slaDranrm ( double angle ); + +void slaDs2c6 ( double a, double b, double r, double ad, double bd, + double rd, double v[6] ); + +void slaDs2tp ( double ra, double dec, double raz, double decz, + double *xi, double *eta, int *j ); + +double slaDsep ( double a1, double b1, double a2, double b2 ); + +double slaDsepv ( double v1[3], double v2[3] ); + +double slaDt ( double epoch ); + +void slaDtf2d ( int ihour, int imin, double sec, double *days, int *j ); + +void slaDtf2r ( int ihour, int imin, double sec, double *rad, int *j ); + +void slaDtp2s ( double xi, double eta, double raz, double decz, + double *ra, double *dec ); + +void slaDtp2v ( double xi, double eta, double v0[3], double v[3] ); + +void slaDtps2c ( double xi, double eta, double ra, double dec, + double *raz1, double *decz1, + double *raz2, double *decz2, int *n ); + +void slaDtpv2c ( double xi, double eta, double v[3], + double v01[3], double v02[3], int *n ); + +double slaDtt ( double dju ); + +void slaDv2tp ( double v[3], double v0[3], double *xi, double *eta, int *j ); + +double slaDvdv ( double va[3], double vb[3] ); + +void slaDvn ( double v[3], double uv[3], double *vm ); + +void slaDvxv ( double va[3], double vb[3], double vc[3] ); + +void slaE2h ( float ha, float dec, float phi, float *az, float *el ); + +void slaEarth ( int iy, int id, float fd, float posvel[6] ); + +void slaEcleq ( double dl, double db, double date, double *dr, double *dd ); + +void slaEcmat ( double date, double rmat[3][3] ); + +void slaEcor ( float rm, float dm, int iy, int id, float fd, + float *rv, float *tl ); + +void slaEg50 ( double dr, double dd, double *dl, double *db ); + +void slaEl2ue ( double date, int jform, double epoch, double orbinc, + double anode, double perih, double aorq, double e, + double aorl, double dm, double u[], int *jstat ); + +double slaEpb ( double date ); + +double slaEpb2d ( double epb ); + +double slaEpco ( char k0, char k, double e ); + +double slaEpj ( double date ); + +double slaEpj2d ( double epj ); + +void slaEqecl ( double dr, double dd, double date, double *dl, double *db ); + +double slaEqeqx ( double date ); + +void slaEqgal ( double dr, double dd, double *dl, double *db ); + +void slaEtrms ( double ep, double ev[3] ); + +void slaEuler ( const char *order, float phi, float theta, float psi, + float rmat[3][3] ); + +void slaEvp ( double date, double deqx, + double dvb[3], double dpb[3], + double dvh[3], double dph[3] ); + +void slaFitxy ( int itype, int np, double xye[][2], double xym[][2], + double coeffs[6], int *j ); + +void slaFk425 ( double r1950, double d1950, double dr1950, + double dd1950, double p1950, double v1950, + double *r2000, double *d2000, double *dr2000, + double *dd2000, double *p2000, double *v2000 ); + +void slaFk45z ( double r1950, double d1950, double bepoch, + double *r2000, double *d2000 ); + +void slaFk524 ( double r2000, double d2000, double dr2000, + double dd2000, double p2000, double v2000, + double *r1950, double *d1950, double *dr1950, + double *dd1950, double *p1950, double *v1950 ); + +void slaFk52h ( double r5, double d5, double dr5, double dd5, + double *dr, double *dh, double *drh, double *ddh ); + +void slaFk54z ( double r2000, double d2000, double bepoch, + double *r1950, double *d1950, + double *dr1950, double *dd1950 ); + +void slaFk5hz ( double r5, double d5, double epoch, + double *rh, double *dh ); + +void slaFlotin ( const char *string, int *nstrt, float *reslt, int *jflag ); + +void slaGaleq ( double dl, double db, double *dr, double *dd ); + +void slaGalsup ( double dl, double db, double *dsl, double *dsb ); + +void slaGe50 ( double dl, double db, double *dr, double *dd ); + +void slaGeoc ( double p, double h, double *r, double *z ); + +double slaGmst ( double ut1 ); + +double slaGmsta ( double date, double ut1 ); + +void slaH2e ( float az, float el, float phi, float *ha, float *dec ); + +void slaH2fk5 ( double dr, double dh, double drh, double ddh, + double *r5, double *d5, double *dr5, double *dd5 ); + +void slaHfk5z ( double rh, double dh, double epoch, + double *r5, double *d5, double *dr5, double *dd5 ); + +void slaImxv ( float rm[3][3], float va[3], float vb[3] ); + +void slaInt2in ( const char *string, int *nstrt, int *ireslt, int *jflag ); + +void slaIntin ( const char *string, int *nstrt, long *ireslt, int *jflag ); + +void slaInvf ( double fwds[6], double bkwds[6], int *j ); + +void slaKbj ( int jb, double e, char *k, int *j ); + +void slaM2av ( float rmat[3][3], float axvec[3] ); + +void slaMap ( double rm, double dm, double pr, double pd, + double px, double rv, double eq, double date, + double *ra, double *da ); + +void slaMappa ( double eq, double date, double amprms[21] ); + +void slaMapqk ( double rm, double dm, double pr, double pd, + double px, double rv, double amprms[21], + double *ra, double *da ); + +void slaMapqkz ( double rm, double dm, double amprms[21], + double *ra, double *da ); + +void slaMoon ( int iy, int id, float fd, float posvel[6] ); + +void slaMxm ( float a[3][3], float b[3][3], float c[3][3] ); + +void slaMxv ( float rm[3][3], float va[3], float vb[3] ); + +void slaNut ( double date, double rmatn[3][3] ); + +void slaNutc ( double date, double *dpsi, double *deps, double *eps0 ); + +void slaNutc80 ( double date, double *dpsi, double *deps, double *eps0 ); + +void slaOap ( const char *type, double ob1, double ob2, double date, + double dut, double elongm, double phim, double hm, + double xp, double yp, double tdk, double pmb, + double rh, double wl, double tlr, + double *rap, double *dap ); + +void slaOapqk ( const char *type, double ob1, double ob2, double aoprms[14], + double *rap, double *dap ); + +void slaObs ( int n, char *c, char *name, double *w, double *p, double *h ); + +double slaPa ( double ha, double dec, double phi ); + +double slaPav ( float v1[3], float v2[3] ); + +void slaPcd ( double disco, double *x, double *y ); + +void slaPda2h ( double p, double d, double a, + double *h1, int *j1, double *h2, int *j2 ); + +void slaPdq2h ( double p, double d, double q, + double *h1, int *j1, double *h2, int *j2 ); + +void slaPermut ( int n, int istate[], int iorder[], int *j ); + +void slaPertel (int jform, double date0, double date1, + double epoch0, double orbi0, double anode0, + double perih0, double aorq0, double e0, double am0, + double *epoch1, double *orbi1, double *anode1, + double *perih1, double *aorq1, double *e1, double *am1, + int *jstat ); + +void slaPertue ( double date, double u[], int *jstat ); + +void slaPlanel ( double date, int jform, double epoch, double orbinc, + double anode, double perih, double aorq, double e, + double aorl, double dm, double pv[6], int *jstat ); + +void slaPlanet ( double date, int np, double pv[6], int *j ); + +void slaPlante ( double date, double elong, double phi, int jform, + double epoch, double orbinc, double anode, double perih, + double aorq, double e, double aorl, double dm, + double *ra, double *dec, double *r, int *jstat ); + +void slaPlantu ( double date, double elong, double phi, double u[], + double *ra, double *dec, double *r, int *jstat ); + +void slaPm ( double r0, double d0, double pr, double pd, + double px, double rv, double ep0, double ep1, + double *r1, double *d1 ); + +void slaPolmo ( double elongm, double phim, double xp, double yp, + double *elong, double *phi, double *daz ); + +void slaPrebn ( double bep0, double bep1, double rmatp[3][3] ); + +void slaPrec ( double ep0, double ep1, double rmatp[3][3] ); + +void slaPrecl ( double ep0, double ep1, double rmatp[3][3] ); + +void slaPreces ( const char sys[3], double ep0, double ep1, + double *ra, double *dc ); + +void slaPrenut ( double epoch, double date, double rmatpn[3][3] ); + +void slaPv2el ( double pv[], double date, double pmass, int jformr, + int *jform, double *epoch, double *orbinc, + double *anode, double *perih, double *aorq, double *e, + double *aorl, double *dm, int *jstat ); + +void slaPv2ue ( double pv[], double date, double pmass, + double u[], int *jstat ); + +void slaPvobs ( double p, double h, double stl, double pv[6] ); + +void slaPxy ( int np, double xye[][2], double xym[][2], + double coeffs[6], + double xyp[][2], double *xrms, double *yrms, double *rrms ); + +float slaRange ( float angle ); + +float slaRanorm ( float angle ); + +double slaRcc ( double tdb, double ut1, double wl, double u, double v ); + +void slaRdplan ( double date, int np, double elong, double phi, + double *ra, double *dec, double *diam ); + +void slaRefco ( double hm, double tdk, double pmb, double rh, + double wl, double phi, double tlr, double eps, + double *refa, double *refb ); + +void slaRefcoq ( double tdk, double pmb, double rh, double wl, + double *refa, double *refb ); + +void slaRefro ( double zobs, double hm, double tdk, double pmb, + double rh, double wl, double phi, double tlr, double eps, + double *ref ); + +void slaRefv ( double vu[3], double refa, double refb, double vr[3] ); + +void slaRefz ( double zu, double refa, double refb, double *zr ); + +float slaRverot ( float phi, float ra, float da, float st ); + +float slaRvgalc ( float r2000, float d2000 ); + +float slaRvlg ( float r2000, float d2000 ); + +float slaRvlsrd ( float r2000, float d2000 ); + +float slaRvlsrk ( float r2000, float d2000 ); + +void slaS2tp ( float ra, float dec, float raz, float decz, + float *xi, float *eta, int *j ); + +float slaSep ( float a1, float b1, float a2, float b2 ); + +float slaSepv ( float v1[3], float v2[3] ); + +void slaSmat ( int n, float *a, float *y, float *d, int *jf, int *iw ); + +void slaSubet ( double rc, double dc, double eq, + double *rm, double *dm ); + +void slaSupgal ( double dsl, double dsb, double *dl, double *db ); + +void slaSvd ( int m, int n, int mp, int np, + double *a, double *w, double *v, double *work, + int *jstat ); + +void slaSvdcov ( int n, int np, int nc, + double *w, double *v, double *work, double *cvm ); + +void slaSvdsol ( int m, int n, int mp, int np, + double *b, double *u, double *w, double *v, + double *work, double *x ); + +void slaTp2s ( float xi, float eta, float raz, float decz, + float *ra, float *dec ); + +void slaTp2v ( float xi, float eta, float v0[3], float v[3] ); + +void slaTps2c ( float xi, float eta, float ra, float dec, + float *raz1, float *decz1, + float *raz2, float *decz2, int *n ); + +void slaTpv2c ( float xi, float eta, float v[3], + float v01[3], float v02[3], int *n ); + +void slaUe2el ( double u[], int jformr, + int *jform, double *epoch, double *orbinc, + double *anode, double *perih, double *aorq, double *e, + double *aorl, double *dm, int *jstat ); + +void slaUe2pv ( double date, double u[], double pv[], int *jstat ); + +void slaUnpcd ( double disco, double *x, double *y ); + +void slaV2tp ( float v[3], float v0[3], float *xi, float *eta, int *j ); + +float slaVdv ( float va[3], float vb[3] ); + +void slaVn ( float v[3], float uv[3], float *vm ); + +void slaVxv ( float va[3], float vb[3], float vc[3] ); + +void slaXy2xy ( double x1, double y1, double coeffs[6], + double *x2, double *y2 ); + +double slaZd ( double ha, double dec, double phi ); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/math/slalib/smat.f b/math/slalib/smat.f new file mode 100644 index 00000000..bd922c55 --- /dev/null +++ b/math/slalib/smat.f @@ -0,0 +1,159 @@ + SUBROUTINE slSMAT (N, A, Y, D, JF, IW) +*+ +* - - - - - +* S M A T +* - - - - - +* +* Matrix inversion & solution of simultaneous equations +* (single precision) +* +* For the set of n simultaneous equations in n unknowns: +* A.Y = X +* +* where: +* A is a non-singular N x N matrix +* Y is the vector of N unknowns +* X is the known vector +* +* SMATRX computes: +* the inverse of matrix A +* the determinant of matrix A +* the vector of N unknowns +* +* Arguments: +* +* symbol type dimension before after +* +* N int no. of unknowns unchanged +* A real (N,N) matrix inverse +* Y real (N) vector solution +* D real - determinant +* * JF int - singularity flag +* IW int (N) - workspace +* +* * JF is the singularity flag. If the matrix is non-singular, +* JF=0 is returned. If the matrix is singular, JF=-1 & D=0.0 are +* returned. In the latter case, the contents of array A on return +* are undefined. +* +* Algorithm: +* Gaussian elimination with partial pivoting. +* +* Speed: +* Very fast. +* +* Accuracy: +* Fairly accurate - errors 1 to 4 times those of routines optimised +* for accuracy. +* +* Note: replaces the obsolete slSMATRX routine. +* +* P.T.Wallace Starlink 10 September 1990 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER N + REAL A(N,N),Y(N),D + INTEGER JF + INTEGER IW(N) + + REAL SFA + PARAMETER (SFA=1E-20) + + INTEGER K,IMX,I,J,NP1MK,KI + REAL AMX,T,AKK,YK,AIK + + + JF=0 + D=1.0 + DO K=1,N + AMX=ABS(A(K,K)) + IMX=K + IF (K.NE.N) THEN + DO I=K+1,N + T=ABS(A(I,K)) + IF (T.GT.AMX) THEN + AMX=T + IMX=I + END IF + END DO + END IF + IF (AMX.LT.SFA) THEN + JF=-1 + ELSE + IF (IMX.NE.K) THEN + DO J=1,N + T=A(K,J) + A(K,J)=A(IMX,J) + A(IMX,J)=T + END DO + T=Y(K) + Y(K)=Y(IMX) + Y(IMX)=T + D=-D + END IF + IW(K)=IMX + AKK=A(K,K) + D=D*AKK + IF (ABS(D).LT.SFA) THEN + JF=-1 + ELSE + AKK=1.0/AKK + A(K,K)=AKK + DO J=1,N + IF (J.NE.K) A(K,J)=A(K,J)*AKK + END DO + YK=Y(K)*AKK + Y(K)=YK + DO I=1,N + AIK=A(I,K) + IF (I.NE.K) THEN + DO J=1,N + IF (J.NE.K) A(I,J)=A(I,J)-AIK*A(K,J) + END DO + Y(I)=Y(I)-AIK*YK + END IF + END DO + DO I=1,N + IF (I.NE.K) A(I,K)=-A(I,K)*AKK + END DO + END IF + END IF + END DO + IF (JF.NE.0) THEN + D=0.0 + ELSE + DO K=1,N + NP1MK=N+1-K + KI=IW(NP1MK) + IF (NP1MK.NE.KI) THEN + DO I=1,N + T=A(I,NP1MK) + A(I,NP1MK)=A(I,KI) + A(I,KI)=T + END DO + END IF + END DO + END IF + END diff --git a/math/slalib/subet.f b/math/slalib/subet.f new file mode 100644 index 00000000..04ed6f9d --- /dev/null +++ b/math/slalib/subet.f @@ -0,0 +1,84 @@ + SUBROUTINE slSUET (RC, DC, EQ, RM, DM) +*+ +* - - - - - - +* S U E T +* - - - - - - +* +* Remove the E-terms (elliptic component of annual aberration) +* from a pre IAU 1976 catalogue RA,Dec to give a mean place +* (double precision) +* +* Given: +* RC,DC dp RA,Dec (radians) with E-terms included +* EQ dp Besselian epoch of mean equator and equinox +* +* Returned: +* RM,DM dp RA,Dec (radians) without E-terms +* +* Called: +* slETRM, slDS2C, sla_,DVDV, slDC2S, slDA2P +* +* Explanation: +* Most star positions from pre-1984 optical catalogues (or +* derived from astrometry using such stars) embody the +* E-terms. This routine converts such a position to a +* formal mean place (allowing, for example, comparison with a +* pulsar timing position). +* +* Reference: +* Explanatory Supplement to the Astronomical Ephemeris, +* section 2D, page 48. +* +* P.T.Wallace Starlink 10 May 1990 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION RC,DC,EQ,RM,DM + + DOUBLE PRECISION slDA2P,slDVDV + DOUBLE PRECISION A(3),V(3),F + + INTEGER I + + + +* E-terms + CALL slETRM(EQ,A) + +* Spherical to Cartesian + CALL slDS2C(RC,DC,V) + +* Include the E-terms + F=1D0+slDVDV(V,A) + DO I=1,3 + V(I)=F*V(I)-A(I) + END DO + +* Cartesian to spherical + CALL slDC2S(V,RM,DM) + +* Bring RA into conventional range + RM=slDA2P(RM) + + END diff --git a/math/slalib/sun67.tex b/math/slalib/sun67.tex new file mode 100644 index 00000000..ab9c7ba9 --- /dev/null +++ b/math/slalib/sun67.tex @@ -0,0 +1,13140 @@ +\documentclass[11pt,twoside]{article} +\setcounter{tocdepth}{2} +\pagestyle{myheadings} + +% ----------------------------------------------------------------------------- +% ? Document identification +\newcommand{\stardoccategory} {Starlink User Note} +\newcommand{\stardocinitials} {SUN} +\newcommand{\stardocsource} {sun67.70} +\newcommand{\stardocnumber} {67.70} +\newcommand{\stardocauthors} {P.\,T.\,Wallace} +\newcommand{\stardocdate} {19 December 2005} +\newcommand{\stardoctitle} {SLALIB --- Positional Astronomy Library} +\newcommand{\stardocversion} {2.5-3} +\newcommand{\stardocmanual} {Programmer's Manual} +% ? End of document identification + +%%% Also see \nroutines definition later %%% + +% ----------------------------------------------------------------------------- + +\newcommand{\stardocname}{\stardocinitials /\stardocnumber} +\markright{\stardocname} + +%---------------------------------------------------- +% Comment out unwanted definitions to suit stationery + +\setlength{\textwidth}{160mm} % +\setlength{\textheight}{230mm} % European A4 +\setlength{\topmargin}{-5mm} % + +%\setlength{\textwidth}{167mm} % +%\setlength{\textheight}{220mm} % US Letter +%\setlength{\topmargin}{-10mm} % + +% +%---------------------------------------------------- + +\setlength{\textwidth}{160mm} +\setlength{\textheight}{230mm} +\setlength{\topmargin}{-2mm} +\setlength{\oddsidemargin}{0mm} +\setlength{\evensidemargin}{0mm} +\setlength{\parindent}{0mm} +\setlength{\parskip}{\medskipamount} +\setlength{\unitlength}{1mm} + +% ----------------------------------------------------------------------------- +% Hypertext definitions. +% ====================== +% These are used by the LaTeX2HTML translator in conjunction with star2html. + +% Comment.sty: version 2.0, 19 June 1992 +% Selectively in/exclude pieces of text. +% +% Author +% Victor Eijkhout +% Department of Computer Science +% University Tennessee at Knoxville +% 104 Ayres Hall +% Knoxville, TN 37996 +% USA + +% Do not remove the %begin{latexonly} and %end{latexonly} lines (used by +% star2html to signify raw TeX that latex2html cannot process). +%begin{latexonly} +\makeatletter +\def\makeinnocent#1{\catcode`#1=12 } +\def\csarg#1#2{\expandafter#1\csname#2\endcsname} + +\def\ThrowAwayComment#1{\begingroup + \def\CurrentComment{#1}% + \let\do\makeinnocent \dospecials + \makeinnocent\^^L% and whatever other special cases + \endlinechar`\^^M \catcode`\^^M=12 \xComment} +{\catcode`\^^M=12 \endlinechar=-1 % + \gdef\xComment#1^^M{\def\test{#1} + \csarg\ifx{PlainEnd\CurrentComment Test}\test + \let\html@next\endgroup + \else \csarg\ifx{LaLaEnd\CurrentComment Test}\test + \edef\html@next{\endgroup\noexpand\end{\CurrentComment}} + \else \let\html@next\xComment + \fi \fi \html@next} +} +\makeatother + +\def\includecomment + #1{\expandafter\def\csname#1\endcsname{}% + \expandafter\def\csname end#1\endcsname{}} +\def\excludecomment + #1{\expandafter\def\csname#1\endcsname{\ThrowAwayComment{#1}}% + {\escapechar=-1\relax + \csarg\xdef{PlainEnd#1Test}{\string\\end#1}% + \csarg\xdef{LaLaEnd#1Test}{\string\\end\string\{#1\string\}}% + }} + +% Define environments that ignore their contents. +\excludecomment{comment} +\excludecomment{rawhtml} +\excludecomment{htmlonly} + +% Hypertext commands etc. This is a condensed version of the html.sty +% file supplied with LaTeX2HTML by: Nikos Drakos & +% Jelle van Zeijl . The LaTeX2HTML documentation +% should be consulted about all commands (and the environments defined above) +% except \xref and \xlabel which are Starlink specific. + +\newcommand{\htmladdnormallinkfoot}[2]{#1\footnote{#2}} +\newcommand{\htmladdnormallink}[2]{#1} +\newcommand{\htmladdimg}[1]{} +\newenvironment{latexonly}{}{} +\newcommand{\hyperref}[4]{#2\ref{#4}#3} +\newcommand{\htmlref}[2]{#1} +\newcommand{\htmlimage}[1]{} +\newcommand{\htmladdtonavigation}[1]{} +\newcommand{\latexhtml}[2]{#1} +\newcommand{\html}[1]{} + +% Starlink cross-references and labels. +\newcommand{\xref}[3]{#1} +\newcommand{\xlabel}[1]{} + +% LaTeX2HTML symbol. +\newcommand{\latextohtml}{{\bf LaTeX}{2}{\tt{HTML}}} + +% Define command to re-centre underscore for Latex and leave as normal +% for HTML (severe problems with \_ in tabbing environments and \_\_ +% generally otherwise). +\newcommand{\latex}[1]{#1} +\newcommand{\setunderscore}{\renewcommand{\_}{{\tt\symbol{95}}}} +\latex{\setunderscore} + +% ----------------------------------------------------------------------------- +% Debugging. +% ========= +% Remove % on the following to debug links in the HTML version using Latex. + +% \newcommand{\hotlink}[2]{\fbox{\begin{tabular}[t]{@{}c@{}}#1\\\hline{\footnotesize #2}\end{tabular}}} +% \renewcommand{\htmladdnormallinkfoot}[2]{\hotlink{#1}{#2}} +% \renewcommand{\htmladdnormallink}[2]{\hotlink{#1}{#2}} +% \renewcommand{\hyperref}[4]{\hotlink{#1}{\S\ref{#4}}} +% \renewcommand{\htmlref}[2]{\hotlink{#1}{\S\ref{#2}}} +% \renewcommand{\xref}[3]{\hotlink{#1}{#2 -- #3}} +%end{latexonly} +% ----------------------------------------------------------------------------- +% ? Document specific \newcommand or \newenvironment commands. +%------------------------------------------------------------------------------ + +\newcommand{\nroutines} {188} +\newcommand{\radec} {$[\,\alpha,\delta\,]$} +\newcommand{\hadec} {$[\,h,\delta\,]$} +\newcommand{\xieta} {$[\,\xi,\eta\,]$} +\newcommand{\azel} {$[\,Az,El~]$} +\newcommand{\ecl} {$[\,\lambda,\beta~]$} +\newcommand{\gal} {$[\,l^{I\!I},b^{I\!I}\,]$} +\newcommand{\xy} {$[\,x,y\,]$} +\newcommand{\xyz} {$[\,x,y,z\,]$} +\newcommand{\xyzd} {$[\,\dot{x},\dot{y},\dot{z}\,]$} +\newcommand{\xyzxyzd} {$[\,x,y,z,\dot{x},\dot{y},\dot{z}\,]$} +\newcommand{\degree}[2] {$#1^{\circ} + \hspace{-0.37em}.\hspace{0.02em}#2$} + +\newcommand{\arcsec}[2] {\arcseci{#1}$\hspace{-0.4em}.#2$} +\begin{htmlonly} + \newcommand{\arcsec}[2] { + {$#1\hspace{-0.05em}^{'\hspace{-0.1em}'}\hspace{-0.4em}.#2$} + } +\end{htmlonly} + +\newcommand{\arcseci}[1] {$#1\hspace{-0.05em}$\raisebox{-0.5ex} + {$^{'\hspace{-0.1em}'}$}} +\begin{htmlonly} + \newcommand{\arcseci}[1] {$#1\hspace{-0.05em}^{'\hspace{-0.1em}'}$} +\end{htmlonly} + +\newcommand{\dms}[4] {$#1^{\circ}\,#2\raisebox{-0.5ex} + {$^{'}$}\,$\arcsec{#3}{#4}} +\begin{htmlonly} + \newcommand{\dms}[4]{$#1^{\circ}\,#2^{'}\,#3^{''}.#4$} +\end{htmlonly} + +\newcommand{\tseci}[1] {$#1$\mbox{$^{\rm s}$}} +\newcommand{\tsec}[2] {\tseci{#1}$\hspace{-0.3em}.#2$} +\begin{htmlonly} + \newcommand{\tsec}[2] {$#1^{\rm s}\hspace{-0.3em}.#2$} +\end{htmlonly} + +\newcommand{\hms}[4] {$#1^{\rm h}\,#2^{\rm m}\,$\tsec{#3}{#4}} +\begin{htmlonly} + \newcommand{\hms}[4] {$#1^{h}\,#2^{m}\,#3^{s}.#4$} +\end{htmlonly} + +\newcommand{\callhead}[1]{\goodbreak\vspace{\bigskipamount}{\large\bf{#1}}} +\newenvironment{callset}{\begin{list}{}{\setlength{\leftmargin}{2cm} + \setlength{\parsep}{\smallskipamount}}}{\end{list}} +\newcommand{\subp}[1]{\item\hspace{-1cm}#1\\} +\newcommand{\subq}[2]{\item\hspace{-1cm}#1\\\hspace*{-1cm}#2\\} +\newcommand{\name}[1]{\mbox{#1}} +\newcommand{\fortvar}[1]{\mbox{\em #1}} + +\newcommand{\routine}[3] +{\hbadness=10000 + \vbox + { + \rule{\textwidth}{0.3mm}\\ + {\Large {\bf #1} \hfill #2 \hfill {\bf #1}}\\ + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + #3 + \end{description} + \setlength{\topsep}{\oldspacing} + } +} + +% Replacement for HTML version (each routine in own subsection). +\begin{htmlonly} + \newcommand{\routine}[3] + { + \subsection{#1\xlabel{#1} - #2\label{#1}} + \begin{description} + #3 + \end{description} + } +\end{htmlonly} + +\newcommand{\action}[1] +{\item[ACTION]: #1} + +\begin{htmlonly} + \newcommand{\action}[1] + {\item[ACTION:] #1} +\end{htmlonly} + +\newcommand{\call}[1] +{\item[CALL]: \hspace{0.4em}{\tt #1}} +\newlength{\oldspacing} + +\begin{htmlonly} + \newcommand{\call}[1] + { + \item[CALL:] {\tt #1} + } +\end{htmlonly} + +\newcommand{\args}[2] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[#1]:\\[1.5ex] + \begin{tabular}{p{7em}p{6em}p{22em}} + #2 + \end{tabular} + \end{description} + \setlength{\topsep}{\oldspacing} +} +\begin{htmlonly} + \newcommand{\args}[2] + { + \begin{description} + \item[#1:]\\ + \begin{tabular}{p{7em}p{6em}l} + #2 + \end{tabular} + \end{description} + } +\end{htmlonly} + +\newcommand{\spec}[3] +{ + {\em {#1}} & {\bf \mbox{#2}} & {#3} +} + +\newcommand{\specel}[2] +{ + \multicolumn{1}{c}{#1} & {} & {#2} +} + +\newcommand{\anote}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[NOTE]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \newcommand{\anote}[1] + { + \begin{description} + \item[NOTE:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\notes}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[NOTES]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \newcommand{\notes}[1] + { + \begin{description} + \item[NOTES:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\aref}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[REFERENCE]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} + +\begin{htmlonly} + \newcommand{\aref}[1] + { + \begin{description} + \item[REFERENCE:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\refs}[1] +{ + \goodbreak + \setlength{\oldspacing}{\topsep} + \setlength{\topsep}{0.3ex} + \begin{description} + \item[REFERENCES]: + #1 + \end{description} + \setlength{\topsep}{\oldspacing} +} +\begin{htmlonly} + \newcommand{\refs}[1] + { + \begin{description} + \item[REFERENCES:] + #1 + \end{description} + } +\end{htmlonly} + +\newcommand{\exampleitem}{\item [EXAMPLE]:} +\begin{htmlonly} + \newcommand{\exampleitem}{\item [EXAMPLE:]} +\end{htmlonly} + +%------------------------------------------------------------------------------ +% ? End of document specific commands +% ----------------------------------------------------------------------------- +% Title Page. +% =========== +\renewcommand{\thepage}{\roman{page}} +\begin{document} +\thispagestyle{empty} + +% Latex document header. +% ====================== +\begin{latexonly} + CCLRC / {\sc Rutherford Appleton Laboratory} \hfill {\bf \stardocname}\\ + {\large Particle Physics \& Astronomy Research Council}\\ + {\large Starlink Project\\} + {\large \stardoccategory\ \stardocnumber} + \begin{flushright} + \stardocauthors\\ + \stardocdate + \end{flushright} + \vspace{-4mm} + \rule{\textwidth}{0.5mm} + \vspace{5mm} + \begin{center} + {\Huge\bf \stardoctitle \\ [2.5ex]} + {\LARGE\bf \stardocversion \\ [4ex]} + {\Huge\bf \stardocmanual} + \end{center} + \vspace{5mm} + +% ? Heading for abstract if used. + \vspace{10mm} + \begin{center} + {\Large\bf Abstract} + \end{center} +% ? End of heading for abstract. +\end{latexonly} + +% HTML documentation header. +% ========================== +\begin{htmlonly} + \xlabel{} + \begin{rawhtml}

\end{rawhtml} + \stardoctitle\\ + \stardocversion\\ + \stardocmanual + \begin{rawhtml}

\end{rawhtml} + +% ? Add picture here if required. +% ? End of picture + + \begin{rawhtml}

\end{rawhtml} + \stardoccategory\ \stardocnumber \\ + \stardocauthors \\ + \stardocdate + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{CCLRC}{http://www.cclrc.ac.uk} / + \htmladdnormallink{Rutherford Appleton Laboratory} + {http://www.cclrc.ac.uk} \\ + \htmladdnormallink{Particle Physics \& Astronomy Research Council} + {http://www.pparc.ac.uk} \\ + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{Starlink Project}{http://www.starlink.ac.uk/} + \begin{rawhtml}

\end{rawhtml} + \htmladdnormallink{\htmladdimg{source.gif} Retrieve hardcopy} + {http://www.starlink.ac.uk/cgi-bin/hcserver?\stardocsource}\\ + +% HTML document table of contents. +% ================================ +% Add table of contents header and a navigation button to return to this +% point in the document (this should always go before the abstract \section). + \label{stardoccontents} + \begin{rawhtml} +
+

Contents

+ \end{rawhtml} + \htmladdtonavigation{\htmlref{\htmladdimg{contents_motif.gif}} + {stardoccontents}} + +% ? New section for abstract if used. + \section{\xlabel{abstract}Abstract} +% ? End of new section for abstract +\end{htmlonly} + +% ----------------------------------------------------------------------------- +% ? Document Abstract. (if used) +% ================== +SLALIB is a library used by writers of positional-astronomy applications. +Most of the \nroutines\ routines are concerned with astronomical position +and time, +but a number have wider trigonometrical, numerical or general applications. +% ? End of document abstract +% ----------------------------------------------------------------------------- +% ? Latex document Table of Contents (if used). +% =========================================== + \newpage + \begin{latexonly} + \setlength{\parskip}{0mm} + \tableofcontents + \setlength{\parskip}{\medskipamount} + \markright{\stardocname} + \end{latexonly} +% ? End of Latex document table of contents +% ----------------------------------------------------------------------------- +\newpage +\renewcommand{\thepage}{\arabic{page}} +\setcounter{page}{1} + +\section{INTRODUCTION} +\subsection{Purpose} +SLALIB\footnote{The name isn't an acronym; +it just stands for ``Subprogram Library~A''.} +is a library of routines +intended to make accurate and reliable positional-astronomy +applications easier to write. +Most SLALIB routines are concerned with astronomical position and time, but a +number have wider trigonometrical, numerical or general applications. +The applications ASTROM, COCO, RV and TPOINT +all make extensive use of the SLALIB +routines, as do a number of telescope control systems around the world. +The SLALIB versions currently in service are written in +Fortran~77 and run on VAX/VMS, several Unix platforms and PC. +A proprietary ANSI~C version is also available from the author; it is +functionally similar to the Fortran version upon which the present +document concentrates. + +\subsection{Example Application} +Here is a simple example of an application program written +using SLALIB calls: + +\begin{verbatim} + PROGRAM FK4FK5 + * + * Read a B1950 position from I/O unit 5 and reply on I/O unit 6 + * with the J2000 equivalent. Enter a period to quit. + * + IMPLICIT NONE + CHARACTER C*80,S + INTEGER I,J,IHMSF(4),IDMSF(4) + DOUBLE PRECISION R4,D4,R5,D5 + LOGICAL BAD + + * Loop until a period is entered + C = ' ' + DO WHILE (C(:1).NE.'.') + + * Read h m s d ' " + READ (5,'(A)') C + IF (C(:1).NE.'.') THEN + BAD = .TRUE. + + * Decode the RA + I = 1 + CALL sla_DAFIN(C,I,R4,J) + IF (J.EQ.0) THEN + R4 = 15D0*R4 + + * Decode the Dec + CALL sla_DAFIN(C,I,D4,J) + IF (J.EQ.0) THEN + + * FK4 to FK5 + CALL sla_FK45Z(R4,D4,1950D0,R5,D5) + + * Format and output the result + CALL sla_DR2TF(2,R5,S,IHMSF) + CALL sla_DR2AF(1,D5,S,IDMSF) + WRITE (6, + : '(1X,I2.2,2I3.2,''.'',I2.2,2X,A,I2.2,2I3.2,''.'',I1)') + : IHMSF,S,IDMSF + BAD = .FALSE. + END IF + END IF + IF (BAD) WRITE (6,'(1X,''?'')') + END IF + END DO + + END +\end{verbatim} +In this example, SLALIB not only provides the complicated FK4 to +FK5 transformation but also +simplifies the tedious and error-prone tasks +of decoding and formatting angles +expressed as hours, minutes {\it etc}. The +example incorporates range checking, and avoids the +notorious ``minus zero'' problem (an often-perpetrated bug where +declinations between $0^{\circ}$ and $-1^{\circ}$ lose their minus +sign). +With a little extra elaboration and a few more calls to SLALIB, +defaulting can be provided (enabling unused fields to +be replaced with commas to avoid retyping), proper motions +can be handled, different epochs can be specified, and +so on. See the program COCO (SUN/56) for further ideas. + +\subsection{Scope} +SLALIB contains \nroutines\ routines covering the following topics: +\begin{itemize} +\item String Decoding, + Sexagesimal Conversions +\item Angles, Vectors \& Rotation Matrices +\item Calendars, + Time Scales +\item Precession \& Nutation +\item Proper Motion +\item FK4/FK5/Hipparcos, + Elliptic Aberration +\item Geocentric Coordinates +\item Apparent \& Observed Place +\item Azimuth \& Elevation +\item Refraction \& Air Mass +\item Ecliptic, + Galactic, + Supergalactic Coordinates +\item Ephemerides +\item Astrometry +\item Numerical Methods +\end{itemize} + +\subsection{Objectives} +SLALIB was designed to give application programmers +a basic set of positional-astronomy tools which were +accurate and easy to use. To this end, the library is: +\begin{itemize} +\item Readily available, including source code and documentation. +\item Supported and maintained. +\item Portable -- coded in standard languages and available for +multiple computers and operating systems. +\item Thoroughly commented, both for maintainability and to +assist those wishing to cannibalize the code. +\item Stable. +\item Trustworthy -- some care has gone into +testing SLALIB, both by comparison with published data and +by checks for internal consistency. +\item Rigorous -- corners are not cut, +even where the practical consequences would, as a rule, be +negligible. +\item Comprehensive, without including too many esoteric features +required only by specialists. +\item Practical -- almost all the routines have been written to +satisfy real needs encountered during the development of +real-life applications. +\item Environment-independent -- the package is +completely free of pauses, stops, I/O {\it etc}. +\item Self-contained -- SLALIB calls no other libraries. +\end{itemize} +A few {\it caveats}: +\begin{itemize} +\item SLALIB does not pretend to be canonical. It is in essence +an anthology, and the adopted algorithms are liable +to change as more up-to-date ones become available. +\item The functions aren't orthogonal -- there are several +cases of different +routines doing similar things, and many examples where +sequences of SLALIB calls have simply been packaged, all to +make applications less trouble to write. +\item There are omissions -- for example there are no +routines for calculating physical ephemerides of +Solar-System bodies. +\item SLALIB is not homogeneous, though important subsets +(for example the FK4/FK5 routines) are. +\item The library is not foolproof. You have to know what +you are trying to do ({\it e.g.}\ by reading textbooks on positional +astronomy), and it is the caller's responsibility to supply +sensible arguments (although enough internal validation is done to +avoid arithmetic errors). +\item Without being written in a wasteful +manner, SLALIB is nonetheless optimized for maintainability +rather than speed. In addition, there are many places +where considerable simplification would be possible if some +specified amount of accuracy could be sacrificed; such +compromises are left to the individual programmer and +are not allowed to limit SLALIB's value as a source +of comparison results. +\end{itemize} + +\subsection{Fortran Version} +The Fortran versions of SLALIB use ANSI Fortran~77 with a few +commonplace extensions. Just three out of the \nroutines\ routines require +platform-specific techniques and accordingly are supplied +in different forms. +SLALIB has been implemented on the following platforms: +VAX/VMS, +PC (Microsoft Fortran, Linux), +DECstation (Ultrix), +DEC Alpha (DEC Unix), +Sun (SunOS, Solaris), +Hewlett Packard (HP-UX), +CONVEX, +Perkin-Elmer and +Fujitsu. + +\subsection{C Version} +An ANSI C version of SLALIB is available from the author +but is not part of the Starlink release. +The functionality of this (proprietary) C version closely matches +that of the Starlink Fortran SLALIB, partly for the convenience of +existing users of the Fortran version, some of whom have in the past +implemented C ``wrappers''. The function names +cannot be the same as the Fortran versions because of potential +linking problems when +both forms of the library are present; the C routine which +is the equivalent of (for example) {\tt SLA\_REFRO} is {\tt slaRefro}. +The types of arguments follow the Fortran version, except +that integers are {\tt int} rather than {\tt long} (the one +exception being +{\tt slaIntin}, which returns a {\tt long} +and is supplemented by an additional routine, +not present in the Fortran SLALIB, called {\tt slaInt2in}, which returns +an {\tt int}). +Argument passing is by value +(except for arrays and strings of course) +for given arguments and by pointer for returned arguments. +All the C functions are re-entrant. + +The Fortran routines {\tt sla\_GRESID}, {\tt sla\_RANDOM} and +{\tt sla\_WAIT} have no C counterparts. + +Further details of the C version of SLALIB are available +from the author. The definitive guide to +the calling sequences is the file {\tt slalib.h}. + +\subsection{Future Versions} +The homogeneity and ease of use of SLALIB could perhaps be improved +in the future by turning to object-oriented techniques, in particular +through the C++ and Java languages. For example ``celestial +position'' could be a class and many of the transformations +could happen automatically. This requires further study and +would result in a complete redesign. Various attempts have been +made to do this, but none as yet has the author's seal of +approval. Furthermore, +the impact of Fortran~90 has yet to be assessed. Should compilers +become widely available, some internal recoding may be worthwhile +in order to simplify parts of the code. However, as with C++, +a redesign of the +application interfaces will be needed if the capabilities of the +new language are to be exploited to the full. + +\subsection{New Functions} +In a package like SLALIB it is difficult to know how far to go. Is it +enough to provide the primitive operations, or should more +complicated functions be packaged? Is it worth encroaching on +specialist areas, where individual experts have all written their +own software already? To what extent should CPU efficiency be +an issue? How much support of different numerical precisions is +required? And so on. + +In practice, almost all the routines in SLALIB are there because they were +needed for some specific application, and this is likely to remain the +pattern for any enhancements in the future. +Suggestions for additional SLALIB routines should be addressed to the +author. + +\subsection{Acknowledgements} +SLALIB is descended from a package of routines written +for the AAO 16-bit minicomputers +in the mid-1970s. The coming of the VAX +allowed a much more comprehensive and thorough package +to be designed for Starlink, especially important +at a time when the adoption +of the IAU 1976 resolutions meant that astronomers +would have to cope with a mixture of reference frames, +time scales and nomenclature. + +Much of the preparatory work on SLALIB was done by +Althea~Wilkinson of Manchester University. +During its development, +Andrew~Murray, +Catherine~Hohenkerk, +Andrew~Sinclair, +Bernard~Yallop +and +Brian~Emerson of Her Majesty's Nautical Almanac Office were consulted +on many occasions; their advice was indispensable. +I am especially grateful to +Catherine~Hohenkerk +for supplying preprints of papers, and test data. A number of +enhancements to SLALIB were at the suggestion of +Russell~Owen, University of Washington, +the late Phil~Hill, St~Andrews University, +Bill~Vacca, JILA, Boulder and +Ron~Maddalena, NRAO. +Mark~Calabretta, CSIRO Radiophysics, Sydney supplied changes to suit Convex. +I am indebted to Derek~Jones (RGO) for introducing me to the +``universal variables'' method of calculating orbits. + +The first C version of SLALIB was a hand-coded transcription +of the Starlink Fortran version carried out by +Steve~Eaton (University of Leeds) in the course of +MSc work. This was later +enhanced by John~Straede (AAO) and Martin~Shepherd (Caltech). +The current C SLALIB is a complete rewrite by the present author and +includes a comprehensive validation suite. +Additional comments on the C version came from Bob~Payne (NRAO) and +Jeremy~Bailey (AAO). + +\section{LINKING} + +On Unix systems (Linux, Sun, DEC Alpha {\it etc.}): +\begin{verse} +{\tt \%~~f77 progname.o -L/star/lib `sla\_link` -o progname} +\end{verse} +(The above assumes that all Starlink directories have been added to +the {\tt LD\_LIBRARY\_PATH} and {\tt PATH} environment variables +as described in SUN/202.) + +\pagebreak + +\section{SUBPROGRAM SPECIFICATIONS} +%----------------------------------------------------------------------- +\routine{SLA\_ADDET}{Add E-terms of Aberration} +{ + \action{Add the E-terms (elliptic component of annual aberration) to a + pre IAU 1976 mean place to conform to the old catalogue convention.} + \call{CALL sla\_ADDET (RM, DM, EQ, RC, DC)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{\radec\ without E-terms (radians)} \\ + \spec{EQ}{D}{Besselian epoch of mean equator and equinox} +} +\args{RETURNED} +{ + \spec{RC,DC}{D}{\radec\ with E-terms included (radians)} +} +\anote{Most star positions from pre-1984 optical catalogues (or + obtained by astrometry with respect to such stars) have the + E-terms built-in. If it is necessary to convert a formal mean + place (for example a pulsar timing position) to one + consistent with such a star catalogue, then the + \radec\ should be adjusted using this routine.} +\aref{{\it Explanatory Supplement to the Astronomical Ephemeris}, + section 2D, page 48.} +%----------------------------------------------------------------------- +\routine{SLA\_AFIN}{Sexagesimal character string to angle} +{ + \action{Decode a free-format sexagesimal string (degrees, arcminutes, + arcseconds) into a single precision floating point + number (radians).} + \call{CALL sla\_AFIN (STRING, NSTRT, RESLT, JF)} +} +\args{GIVEN} +{ + \spec{STRING}{C*(*)}{string containing deg, arcmin, arcsec fields} \\ + \spec{NSTRT}{I}{pointer to start of decode (beginning of STRING = 1)} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced past the decoded angle} \\ + \spec{RESLT}{R}{angle in radians} \\ + \spec{JF}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $+1$ = default, RESLT unchanged (note 2)} \\ + \spec{}{}{\hspace{0.7em} $-1$ = bad degrees (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-2$ = bad arcminutes (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-3$ = bad arcseconds (note 3)} \\ +} +\goodbreak +\setlength{\oldspacing}{\topsep} +\setlength{\topsep}{0.3ex} +\begin{description} + \exampleitem \\ [1.5ex] + \begin{tabular}{lll} + {\it argument} & {\it before} & {\it after} \\ \\ + STRING & $'$\verb*#-57 17 44.806 12 34 56.7#$'$ & unchanged \\ + NSTRT & 1 & 16 ({\it i.e.}\ pointing to 12...) \\ + RESLT & - & $-1.00000$ \\ + JF & - & 0 + \end{tabular} +\end{description} +A further call to sla\_AFIN, without adjustment of NSTRT, will +decode the second angle, \dms{12}{34}{56}{7}. +\setlength{\topsep}{\oldspacing} +\notes +{ + \begin{enumerate} + \item The first three ``fields'' in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the sla\_DFLTIN routine and is free-format. + \item Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and RESLT is + unchanged. In all other cases RESLT is changed. + \item Range checking: + \begin{itemize} + \item The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are absent. + \item The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + \item The arcseconds field is expected to be 0-59.9999... + \item Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting to + zero, and the result RESLT is computed and returned. + \end{itemize} + \item Further fields after the three expected ones are not treated as + an error. The pointer NSTRT is left in the correct state for + further decoding with the present routine or with sla\_DFLTIN + {\it etc}. See the example, above. + \item If STRING contains hours, minutes, seconds instead of + degrees {\it etc}, + or if the required units are turns (or days) instead of radians, + the result RESLT should be multiplied as follows: \\ [1.5ex] + \begin{tabular}{lll} + {\it for STRING} & {\it to obtain} & {\it multiply RESLT by} \\ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & radians & $1.0$ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & turns & $1/{2 \pi} = 0.1591549430918953358$ \\ + h m s & radians & $15.0$ \\ + h m s & days & $15/{2\pi} = 2.3873241463784300365$ \\ + \end{tabular} + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AIRMAS}{Air Mass} +{ + \action{Air mass at given zenith distance (double precision).} + \call{D~=~sla\_AIRMAS (ZD)} +} +\args{GIVEN} +{ + \spec{ZD}{D}{observed zenith distance (radians)} +} +\args{RETURNED} +{ + \spec{sla\_AIRMAS}{D}{air mass (1 at zenith)} +} +\notes +{ + \begin{enumerate} + \item The {\it observed}\/ zenith distance referred to above means + ``as affected by refraction''. + \item The routine uses Hardie's (1962) polynomial fit to Bemporad's + data for the relative air mass, $X$, in units of thickness at the + zenith as tabulated by Schoenberg (1929). This is adequate for all + normal needs as it is accurate to better than + 0.1\% up to $X = 6.8$ and better than 1\% up to $X = 10$. + Bemporad's tabulated values are unlikely to be trustworthy + to such accuracy + because of variations in density, pressure and other + conditions in the atmosphere from those assumed in his work. + \item The sign of the ZD is ignored. + \item At zenith distances greater than about $\zeta = 87^{\circ}$ the + air mass is held constant to avoid arithmetic overflows. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Hardie, R.H., 1962, in {\it Astronomical Techniques}\, + ed. W.A.\ Hiltner, University of Chicago Press, p180. + \item Schoenberg, E., 1929, Hdb.\ d.\ Ap., + Berlin, Julius Springer, 2, 268. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ALTAZ}{Velocities {\it etc.}\ for Altazimuth Mount} +{ + \action{Positions, velocities and accelerations for an altazimuth + telescope mount that is tracking a star (double precision).} + \call{CALL sla\_ALTAZ (\vtop{ + \hbox{HA, DEC, PHI,} + \hbox{AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)}}} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle} \\ + \spec{DEC}{D}{declination} \\ + \spec{PHI}{D}{observatory latitude} +} +\args{RETURNED} +{ + \spec{AZ}{D}{azimuth} \\ + \spec{AZD}{D}{azimuth velocity} \\ + \spec{AZDD}{D}{azimuth acceleration} \\ + \spec{EL}{D}{elevation} \\ + \spec{ELD}{D}{elevation velocity} \\ + \spec{ELDD}{D}{elevation acceleration} \\ + \spec{PA}{D}{parallactic angle} \\ + \spec{PAD}{D}{parallactic angle velocity} \\ + \spec{PADD}{D}{parallactic angle acceleration} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item Natural units are used throughout. HA, DEC, PHI, AZ, EL + and ZD are in radians. The velocities and accelerations + assume constant declination and constant rate of change of + hour angle (as for tracking a star); the units of AZD, ELD + and PAD are radians per radian of HA, while the units of AZDD, + ELDD and PADD are radians per radian of HA squared. To + convert into practical degree- and second-based units: + + \begin{center} + \begin{tabular}{rlcl} + angles & $\times 360/2\pi$ & $\rightarrow$ & degrees \\ + velocities & $\times (2\pi/86400) \times (360/2\pi)$ + & $\rightarrow$ & degree/sec \\ + accelerations & $\times (2\pi/86400)^2 \times (360/2\pi)$ + & $\rightarrow$ & degree/sec/sec \\ + \end{tabular} + \end{center} + + Note that the seconds here are sidereal rather than SI. One + sidereal second is about 0.99727 SI seconds. + + The velocity and acceleration factors assume the sidereal + tracking case. Their respective numerical values are (exactly) + 1/240 and (approximately) 1/3300236.9. + \item Azimuth is returned in the range $[\,0,2\pi\,]$; north is zero, + and east is $+\pi/2$. Elevation and parallactic angle are + returned in the range $\pm\pi$. Position angle is +ve + for a star west of the meridian and is the angle NP--star--zenith. + \item The latitude is geodetic as opposed to geocentric. The + hour angle and declination are topocentric. Refraction and + deficiencies in the telescope mounting are ignored. The + purpose of the routine is to give the general form of the + quantities. The details of a real telescope could profoundly + change the results, especially close to the zenith. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AMP}{Apparent to Mean} +{ + \action{Convert star \radec\ from geocentric apparent to + mean place (post IAU 1976).} + \call{CALL sla\_AMP (RA, DA, DATE, EQ, RM, DM)} +} +\args{GIVEN} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} \\ + \spec{DATE}{D}{TDB for apparent place (JD$-$2400000.5)} \\ + \spec{EQ}{D}{equinox: Julian epoch of mean place} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item Iterative techniques are used for the aberration and + light deflection corrections so that the routines + sla\_AMP (or sla\_AMPQK) and sla\_MAP (or sla\_MAPQK) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1~nanoarcsecond. + \item Where multiple apparent places are to be converted to + mean places, for a fixed date and equinox, it is more + efficient to use the sla\_MAPPA routine to compute the + required parameters once, followed by one call to + sla\_AMPQK per star. + \item For EQ=2000D0, + the agreement with ICRS sub-mas, limited by the + precession-nutation model (IAU 1976 precession, Shirai \& + Fukushima 2001 forced nutation and precession corrections). + \item The accuracy is further limited by the routine sla\_EVP, called + by sla\_MAPPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3~milliarcsecond. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AMPQK}{Quick Apparent to Mean} +{ + \action{Convert star \radec\ from geocentric apparent to mean place + (post IAU 1976). Use of this routine is appropriate when + efficiency is important and where many star positions are + all to be transformed for one epoch and equinox. The + star-independent parameters can be obtained by calling + the sla\_MAPPA routine.} + \call{CALL sla\_AMPQK (RA, DA, AMPRMS, RM, DM)} +} +\args{GIVEN} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession-nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item Iterative techniques are used for the aberration and + light deflection corrections so that the routines + sla\_AMP (or sla\_AMPQK) and sla\_MAP (or sla\_MAPQK) are + accurate inverses; even at the edge of the Sun's disc + the discrepancy is only about 1~nanoarcsecond. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOP}{Apparent to Observed} +{ + \action{Apparent to observed place, for sources distant from + the solar system.} + \call{CALL sla\_AOP (\vtop{ + \hbox{RAP, DAP, DATE, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB)}}} +} +\args{GIVEN} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec\ (radians)} \\ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (K; std=273.15D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mb; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{AOB}{D}{observed azimuth (radians: N=0, E=$90^{\circ}$)} \\ + \spec{ZOB}{D}{observed zenith distance (radians)} \\ + \spec{HOB}{D}{observed Hour Angle (radians)} \\ + \spec{DOB}{D}{observed $\delta$ (radians)} \\ + \spec{ROB}{D}{observed $\alpha$ (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Apparent}\/ \radec\ means the geocentric apparent + right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, the Sun's gravitational + lens effect, annual aberration, and precession-nutation. For + star positions in the FK5 system ({\it i.e.}\ J2000), these + effects can + be applied by means of the sla\_MAP {\it etc.}\ routines. + Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 ({\it i.e.}\ B1950) mean places would + first have to be converted to FK5, which can be done with the + sla\_FK425 {\it etc.}\ routines. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent \radec\ by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The \hadec\ is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation ({\it n.b.}\ not to the + refracted pole). Finally, the $\alpha$ is obtained by subtracting + the {\it h}\/ from the local apparent ST. + \item To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + \item This routine takes time to execute, due mainly to the + rigorous integration used to evaluate the refraction. + For processing multiple stars for one location and time, + call sla\_AOPPA once followed by one call per star to sla\_AOPQK. + Where a range of times within a limited period of a few hours + is involved, and the highest precision is not required, call + sla\_AOPPA once, followed by a call to sla\_AOPPAT each time the + time changes, followed by one call per star to sla\_AOPQK. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use + in the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in millibars, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52). Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is nearly proportional to the + pressure and that an accurate P value is important for + precise work. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections to the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOPPA}{Appt-to-Obs Parameters} +{ + \action{Pre-compute the set of apparent to observed place parameters + required by the ``quick'' routines sla\_AOPQK and sla\_OAPQK.} + \call{CALL sla\_AOPPA (\vtop{ + \hbox{DATE, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOPRMS)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (K; std=273.15D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mb; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel {(1)} {geodetic latitude (radians)} \\ + \specel {(2,3)} {sine and cosine of geodetic latitude} \\ + \specel {(4)} {magnitude of diurnal aberration vector} \\ + \specel {(5)} {height (HM)} \\ + \specel {(6)} {ambient temperature (TDK)} \\ + \specel {(7)} {pressure (PMB)} \\ + \specel {(8)} {relative humidity (RH)} \\ + \specel {(9)} {wavelength (WL)} \\ + \specel {(10)} {lapse rate (TLR)} \\ + \specel {(11,12)} {refraction constants A and B (radians)} \\ + \specel {(13)} {longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel {(14)} {local apparent sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. The ``sidereal $\Delta$UT'' which forms + part of AOPRMS(13) is the same quantity, but converted from solar + to sidereal seconds and expressed in radians. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use in + the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in millibars, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52). Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is nearly proportional to the + pressure and that an accurate P value is important for + precise work. + \item Repeated, computationally-expensive, calls to sla\_AOPPA for + times that are very close together can be avoided by calling + sla\_AOPPA just once and then using sla\_AOPPAT for the subsequent + times. Fresh calls to sla\_AOPPA will be needed only when changes + in the precession have grown to unacceptable levels or when + anything affecting the refraction has changed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AOPPAT}{Update Appt-to-Obs Parameters} +{ + \action{Recompute the sidereal time in the apparent to observed place + star-independent parameter block.} + \call{CALL sla\_AOPPAT (DATE, AOPRMS)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1-12)}{not required} \\ + \specel{(13)}{longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel{(14)}{not required} +} +\args{RETURNED} +{ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1-13)}{not changed} \\ + \specel{(14)}{local apparent sidereal time (radians)} +} +\anote{For more information, see sla\_AOPPA.} +%----------------------------------------------------------------------- +\routine{SLA\_AOPQK}{Quick Appt-to-Observed} +{ + \action{Quick apparent to observed place (but see Note~8, below).} + \call{CALL sla\_AOPQK (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB)} +} +\args{GIVEN} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec\ (radians)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel{(1)}{geodetic latitude (radians)} \\ + \specel{(2,3)}{sine and cosine of geodetic latitude} \\ + \specel{(4)}{magnitude of diurnal aberration vector} \\ + \specel{(5)}{height (metres)} \\ + \specel{(6)}{ambient temperature (K)} \\ + \specel{(7)}{pressure (mb)} \\ + \specel{(8)}{relative humidity (0\,--\,1)} \\ + \specel{(9)}{wavelength ($\mu{\rm m}$)} \\ + \specel{(10)}{lapse rate (K per metre)} \\ + \specel{(11,12)}{refraction constants A and B (radians)} \\ + \specel{(13)}{longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel{(14)}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{AOB}{D}{observed azimuth (radians: N=0, E=$90^{\circ}$)} \\ + \spec{ZOB}{D}{observed zenith distance (radians)} \\ + \spec{HOB}{D}{observed Hour Angle (radians)} \\ + \spec{DOB}{D}{observed Declination (radians)} \\ + \spec{ROB}{D}{observed Right Ascension (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine returns zenith distance rather than elevation + in order to reflect the fact that no allowance is made for + depression of the horizon. + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Apparent}\/ \radec\ means the geocentric apparent right ascension + and declination, which is obtained from a catalogue mean place + by allowing for space motion, parallax, the Sun's gravitational + lens effect, annual aberration and precession-nutation. For + star positions in the FK5 system ({\it i.e.}\ J2000), these effects can + be applied by means of the sla\_MAP {\it etc.}\ routines. Starting from + other mean place systems, additional transformations will be + needed; for example, FK4 ({\it i.e.}\ B1950) mean places would first + have to be converted to FK5, which can be done with the + sla\_FK425 {\it etc.}\ routines. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is obtained + from the geocentric apparent \radec\ by allowing for Earth + orientation and diurnal aberration, rotating from equator + to horizon coordinates, and then adjusting for refraction. + The \hadec\ is obtained by rotating back into equatorial + coordinates, using the geodetic latitude corrected for polar + motion, and is the position that would be seen by a perfect + equatorial located at the observer and with its polar axis + aligned to the Earth's axis of rotation ({\it n.b.}\ not to the + refracted pole). Finally, the $\alpha$ is obtained by subtracting + the {\it h}\/ from the local apparent ST. + \item To predict the required setting of a real telescope, the + observed place produced by this routine would have to be + adjusted for the tilt of the azimuth or polar axis of the + mounting (with appropriate corrections for mount flexures), + for non-perpendicularity between the mounting axes, for the + position of the rotator axis and the pointing axis relative + to it, for tube flexure, for gear and encoder errors, and + finally for encoder zero points. Some telescopes would, of + course, exhibit other properties which would need to be + accounted for at the appropriate point in the sequence. + \item The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the sla\_AOPPA routine. + If nothing has changed significantly except the time, the + sla\_AOPPAT routine may be used to perform the requisite + partial recomputation of AOPRMS. + \item At zenith distances beyond about $76^\circ$, the need for + special care with the corrections for refraction causes a + marked increase in execution time. Moreover, the effect + gets worse with increasing zenith distance. Adroit + programming in the calling application may allow the + problem to be reduced. Prepare an alternative AOPRMS array, + computed for zero air-pressure; this will disable the + refraction corrections and cause rapid execution. Using + this AOPRMS array, a preliminary call to the present routine + will, depending on the application, produce a rough position + which may be enough to establish whether the full, slow + calculation (using the real AOPRMS array) is worthwhile. + For example, there would be no need for the full calculation + if the preliminary call had already established that the + source was well below the elevation limits for a particular + telescope. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections to the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ATMDSP}{Atmospheric Dispersion} +{ + \action{Apply atmospheric-dispersion adjustments to refraction coefficients.} + \call{CALL sla\_ATMDSP (TDK, PMB, RH, WL1, A1, B1, WL2, A2, B2)} +} +\args{GIVEN} +{ + \spec{TDK}{D}{ambient temperature at the observer (K)} \\ + \spec{PMB}{D}{pressure at the observer (mb)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL1}{D}{base wavelength ($\mu{\rm m}$)} \\ + \spec{A1}{D}{refraction coefficient A for wavelength WL1 (radians)} \\ + \spec{B1}{D}{refraction coefficient B for wavelength WL1 (radians)} \\ + \spec{WL2}{D}{wavelength for which adjusted A,B required ($\mu{\rm m}$)} +} +\args{RETURNED} +{ + \spec{A2}{D}{refraction coefficient A for wavelength WL2 (radians)} \\ + \spec{B2}{D}{refraction coefficient B for wavelength WL2 (radians)} +} +\notes +{ + \begin{enumerate} + \item To use this routine, first call sla\_REFCO specifying WL1 as the + wavelength. This yields refraction coefficients A1, B1, correct + for that wavelength. Subsequently, calls to sla\_ATMDSP specifying + different wavelengths will produce new, slightly adjusted + refraction coefficients A2, B2, which apply to the specified wavelength. + \item Most of the atmospheric dispersion happens between $0.7\,\mu{\rm m}$ + and the UV atmospheric cutoff, and the effect increases strongly + towards the UV end. For this reason a blue reference wavelength + is recommended, for example $0.4\,\mu{\rm m}$. + \item The accuracy, for this set of conditions: \\[1pc] + \hspace*{5ex} \begin{tabular}{rcl} + height above sea level & ~ & 2000\,m \\ + latitude & ~ & $29^\circ$ \\ + pressure & ~ & 793\,mb \\ + temperature & ~ & $290^\circ$\,K \\ + humidity & ~ & 0.5 (50\%) \\ + lapse rate & ~ & $0.0065^\circ m^{-1}$ \\ + reference wavelength & ~ & $0.4\,\mu{\rm m}$ \\ + star elevation & ~ & $15^\circ$ \\ + \end{tabular}\\[1pc] + is about 2.5\,mas RMS between 0.3 and $1.0\,\mu{\rm m}$, and stays + within 4\,mas for the whole range longward of $0.3\,\mu{\rm m}$ + (compared with a total dispersion from 0.3 to $20\,\mu{\rm m}$ + of about \arcseci{11}). These errors are typical for ordinary + conditions; in extreme conditions values a few times this size + may occur. + \item If either wavelength exceeds $100\,\mu{\rm m}$, the radio case + is assumed and the returned refraction coefficients are the + same as the given ones. Note that radio refraction coefficients + cannot be turned into optical values using this routine, nor + vice versa. + \item The algorithm consists of calculation of the refractivity of the + air at the observer for the two wavelengths, using the methods + of the sla\_REFRO routine, and then scaling of the two refraction + coefficients according to classical refraction theory. This + amounts to scaling the A coefficient in proportion to $(\mu-1)$ and + the B coefficient almost in the same ratio (see R.M.Green, + {\it Spherical Astronomy,}\/ Cambridge University Press, 1985). + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_AV2M}{Rotation Matrix from Axial Vector} +{ + \action{Form the rotation matrix corresponding to a given axial vector + (single precision).} + \call{CALL sla\_AV2M (AXVEC, RMAT)} +} +\args{GIVEN} +{ + \spec{AXVEC}{R(3)}{axial vector (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some + arbitrary axis, called the Euler axis. The + {\it axial vector} supplied to this routine + has the same direction as the Euler axis, and its + magnitude is the amount of rotation in radians. + \item If AXVEC is null, the unit matrix is returned. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_BEAR}{Direction Between Points on a Sphere} +{ + \action{Returns the bearing (position angle) of one point on a + sphere seen from another (single precision).} + \call{R~=~sla\_BEAR (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{R}{spherical coordinates of one point} \\ + \spec{A2,B2}{R}{spherical coordinates of the other point} +} +\args{RETURNED} +{ + \spec{sla\_BEAR}{R}{bearing from first point to second} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are \radec, + $[\lambda,\phi]$ {\it etc.}, in radians. + \item The result is the bearing (position angle), in radians, + of point [A2,B2] as seen + from point [A1,B1]. It is in the range $\pm \pi$. The sense + is such that if [A2,B2] + is a small distance due east of [A1,B1] the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item If either B-coordinate is outside the range $\pm\pi/2$, the + result may correspond to ``the long way round''. + \item The routine sla\_PAV performs an equivalent function except + that the points are specified in the form of Cartesian unit + vectors. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CAF2R}{Deg,Arcmin,Arcsec to Radians} +{ + \action{Convert degrees, arcminutes, arcseconds to radians + (single precision).} + \call{CALL sla\_CAF2R (IDEG, IAMIN, ASEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IDEG}{I}{degrees} \\ + \spec{IAMIN}{I}{arcminutes} \\ + \spec{ASEC}{R}{arcseconds} +} +\args{RETURNED} +{ + \spec{RAD}{R}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 1 = IDEG outside range 0$-$359} \\ + \spec{}{}{\hspace{1.5em} 2 = IAMIN outside range 0$-$59} \\ + \spec{}{}{\hspace{1.5em} 3 = ASEC outside range 0$-$59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CALDJ}{Calendar Date to MJD} +{ + \action{Gregorian Calendar to Modified Julian Date, with century default.} + \call{CALL sla\_CALDJ (IY, IM, ID, DJM, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5) for $0^{\rm h}$} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (MJD not computed)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month (MJD not computed)} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day (MJD computed)} \\ +} +\notes +{ + \begin{enumerate} + \item This routine supports the {\it century default}\/ feature. + Acceptable years are: + \begin{itemize} + \item 00-49, interpreted as 2000\,--\,2049, + \item 50-99, interpreted as 1950\,--\,1999, and + \item 100 upwards, interpreted literally. + \end{itemize} + For 1-100AD use the routine sla\_CLDJ instead. + \item For year $n$BC use IY = $-(n-1)$. + \item When an invalid year or month is supplied (status J~=~1~or~2) + the MJD is {\bf not} computed. When an invalid day is supplied + (status J~=~3) the MJD {\bf is} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CALYD}{Calendar to Year, Day} +{ + \action{Gregorian calendar date to year and day in year, in a Julian + calendar aligned to the 20th/21st century Gregorian calendar, + with century default.} + \call{CALL sla\_CALYD (IY, IM, ID, NY, ND, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar: + year may optionally omit the century} +} +\args{RETURNED} +{ + \spec{NY}{I}{year (re-aligned Julian calendar)} \\ + \spec{ND}{I}{day in year (1 = January 1st)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (before $-4711$)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item This routine supports the {\it century default}\/ feature. + Acceptable years are: + \begin{itemize} + \item 00-49, interpreted as 2000\,--\,2049, + \item 50-99, interpreted as 1950\,--\,1999, and + \item other years after $-4712$, interpreted literally. + \end{itemize} + Use sla\_CLYD for years before 100AD. + \item The purpose of sla\_CALDJ is to support + sla\_EARTH, sla\_MOON and sla\_ECOR. + \item Between 1900~March~1 and 2100~February~28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + \item When an invalid year or month is supplied (status J~=~1 or J~=~2) + the results are {\bf not} computed. When a day is + supplied which is outside the conventional range (status J~=~3) + the results {\bf are} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CC2S}{Cartesian to Spherical} +{ + \action{Cartesian coordinates to spherical coordinates (single precision).} + \call{CALL sla\_CC2S (V, A, B)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{\xyz\ vector} +} +\args{RETURNED} +{ + \spec{A,B}{R}{spherical coordinates in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole. + \item If V is null, zero A and B are returned. + \item At either pole, zero A is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CC62S}{Cartesian 6-Vector to Spherical} +{ + \action{Conversion of position \& velocity in Cartesian coordinates + to spherical coordinates (single precision).} + \call{CALL sla\_CC62S (V, A, B, R, AD, BD, RD)} +} +\args{GIVEN} +{ + \spec{V}{R(6)}{\xyzxyzd} +} +\args{RETURNED} +{ + \spec{A}{R}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{R}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{R}{radial coordinate} \\ + \spec{AD}{R}{longitude derivative (radians per unit time)} \\ + \spec{BD}{R}{latitude derivative (radians per unit time)} \\ + \spec{RD}{R}{radial derivative} +} +%----------------------------------------------------------------------- +\routine{SLA\_CD2TF}{Days to Hour,Min,Sec} +{ + \action{Convert an interval in days to hours, minutes, seconds + (single precision).} + \call{CALL sla\_CD2TF (NDP, DAYS, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{DAYS}{R}{interval in days} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + DAYS, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). On some + architectures, for DAYS up to 1.0, + the available floating-point + precision corresponds roughly to NDP=3. This is well + below the ultimate limit of NDP=9 set by the capacity of a + typical 32-bit IHMSF(4). + \item The absolute value of DAYS may exceed 1.0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1.0 and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CLDJ}{Calendar to MJD} +{ + \action{Gregorian Calendar to Modified Julian Date.} + \call{CALL sla\_CLDJ (IY, IM, ID, DJM, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5) for $0^{\rm h}$} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item When an invalid year or month is supplied (status J~=~1~or~2) + the MJD is {\bf not} computed. When an invalid day is supplied + (status J~=~3) the MJD {\bf is} computed. + \item The year must be $-$4699 ({\it i.e.}\ 4700BC) or later. + For year $n$BC use IY = $-(n-1)$. + \item An alternative to the present routine is sla\_CALDJ, which + accepts a year with the century missing. + \end{enumerate} +} +\aref{The algorithm is adapted from Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_CLYD}{Calendar to Year, Day} +{ + \action{Gregorian calendar date to year and day in year, in a Julian + calendar aligned to the 20th/21st century Gregorian calendar.} + \call{CALL sla\_CLYD (IY, IM, ID, NY, ND, J)} +} +\args{GIVEN} +{ + \spec{IY,IM,ID}{I}{year, month, day in Gregorian calendar} +} +\args{RETURNED} +{ + \spec{NY}{I}{year (re-aligned Julian calendar)} \\ + \spec{ND}{I}{day in year (1 = January 1st)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = bad year (before $-4711$)} \\ + \spec{}{}{\hspace{1.5em} 2 = bad month} \\ + \spec{}{}{\hspace{1.5em} 3 = bad day} +} +\notes +{ + \begin{enumerate} + \item The purpose of sla\_CLYD is to support sla\_EARTH, + sla\_MOON and sla\_ECOR. + \item Between 1900~March~1 and 2100~February~28 it returns answers + which are consistent with the ordinary Gregorian calendar. + Outside this range there will be a discrepancy which increases + by one day for every non-leap century year. + \item When an invalid year or month is supplied (status J~=~1 or J~=~2) + the results are {\bf not} computed. When a day is + supplied which is outside the conventional range (status J~=~3) + the results {\bf are} computed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_COMBN}{Next Combination} +{ + \action{Generate the next combination, a subset of a specified size chosen + from a specified number of items.} + \call{CALL sla\_COMBN (NSEL, NCAND, LIST, J)} +} +\args{GIVEN} +{ + \spec{NSEL}{I}{number of items (subset size)} \\ + \spec{NCAND}{I}{number of candidates (set size)} +} +\args{GIVEN and RETURNED} +{ + \spec{LIST}{I(NSEL)}{latest combination, LIST(1)=0 to initialize} +} +\args{RETURNED} +{ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal NSEL or NCAND} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $+$1 = no more combinations available} +} +\notes +{ + \begin{enumerate} + \item NSEL and NCAND must both be at least 1, and NSEL must be less + than or equal to NCAND. + \item This routine returns, in the LIST array, a subset of NSEL integers + chosen from the range 1 to NCAND inclusive, in ascending order. + Before calling the routine for the first time, the caller must set + the first element of the LIST array to zero (any value less than 1 + will do) to cause initialization. + \item The first combination to be generated is: + \begin{verse} + LIST(1)=1, LIST(2)=2, \ldots, LIST(NSEL)=NSEL + \end{verse} + This is also the combination returned for the ``finished'' (J=1) case. + The final permutation to be generated is: + \begin{verse} + LIST(1)=NCAND, LIST(2)=NCAND$-$1, \ldots, \\ + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~LIST(NSEL)=NCAND$-$NSEL+1 + \end{verse} + \item If the ``finished'' (J=1) status is ignored, the routine + continues to deliver combinations, the pattern repeating + every NCAND!/(NSEL!(NCAND$-$NSEL)!) calls. + \item The algorithm is by R.\,F.\,Warren-Smith (private communication). + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CR2AF}{Radians to Deg,Arcmin,Arcsec} +{ + \action{Convert an angle in radians to degrees, arcminutes, + arcseconds (single precision).} + \call{CALL sla\_CR2AF (NDP, ANGLE, SIGN, IDMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of arcseconds} \\ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IDMSF}{I(4)}{degrees, arcminutes, arcseconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IDMSF(4). On some + architectures, for ANGLE up to 2pi, + the available floating-point + precision corresponds roughly to NDP=3. This is well + below the ultimate limit of NDP=9 set by the capacity of a + typical 32-bit IDMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to $360^{\circ}$, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CR2TF}{Radians to Hour,Min,Sec} +{ + \action{Convert an angle in radians to hours, minutes, seconds + (single precision).} + \call{CALL sla\_CR2TF (NDP, ANGLE, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size of + ANGLE, the format of REAL floating-point numbers on the target + machine, and the risk of overflowing IHMSF(4). On some + architectures, for ANGLE up to 2pi, + the available floating-point + precision corresponds roughly to NDP=3. This is well below + the ultimate limit of NDP=9 set by the capacity of a typical + 32-bit IHMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CS2C}{Spherical to Cartesian} +{ + \action{Spherical coordinates to Cartesian coordinates (single precision).} + \call{CALL sla\_CS2C (A, B, V)} +} +\args{GIVEN} +{ + \spec{A,B}{R}{spherical coordinates in radians: \radec\ {\it etc.}} +} +\args{RETURNED} +{ + \spec{V}{R(3)}{\xyz\ unit vector} +} +\anote{The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole.} +%----------------------------------------------------------------------- +\routine{SLA\_CS2C6}{Spherical Pos/Vel to Cartesian} +{ + \action{Conversion of position \& velocity in spherical coordinates + to Cartesian coordinates (single precision).} + \call{CALL sla\_CS2C6 (A, B, R, AD, BD, RD, V)} +} +\args{GIVEN} +{ + \spec{A}{R}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{R}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{R}{radial coordinate} \\ + \spec{AD}{R}{longitude derivative (radians per unit time)} \\ + \spec{BD}{R}{latitude derivative (radians per unit time)} \\ + \spec{RD}{R}{radial derivative} +} +\args{RETURNED} +{ + \spec{V}{R(6)}{\xyzxyzd} +} +\anote{The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole.} +%----------------------------------------------------------------------- +\routine{SLA\_CTF2D}{Hour,Min,Sec to Days} +{ + \action{Convert hours, minutes, seconds to days (single precision).} + \call{CALL sla\_CTF2D (IHOUR, IMIN, SEC, DAYS, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{R}{seconds} +} +\args{RETURNED} +{ + \spec{DAYS}{R}{interval in days} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_CTF2R}{Hour,Min,Sec to Radians} +{ + \action{Convert hours, minutes, seconds to radians (single precision).} + \call{CALL sla\_CTF2R (IHOUR, IMIN, SEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{R}{seconds} +} +\args{RETURNED} +{ + \spec{RAD}{R}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAF2R}{Deg,Arcmin,Arcsec to Radians} +{ + \action{Convert degrees, arcminutes, arcseconds to radians + (double precision).} + \call{CALL sla\_DAF2R (IDEG, IAMIN, ASEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IDEG}{I}{degrees} \\ + \spec{IAMIN}{I}{arcminutes} \\ + \spec{ASEC}{D}{arcseconds} +} +\args{RETURNED} +{ + \spec{RAD}{D}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 1 = IDEG outside range 0$-$359} \\ + \spec{}{}{\hspace{1.5em} 2 = IAMIN outside range 0$-$59} \\ + \spec{}{}{\hspace{1.5em} 3 = ASEC outside range 0$-$59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAFIN}{Sexagesimal character string to angle} +{ + \action{Decode a free-format sexagesimal string (degrees, arcminutes, + arcseconds) into a double precision floating point + number (radians).} + \call{CALL sla\_DAFIN (STRING, NSTRT, DRESLT, JF)} +} +\args{GIVEN} +{ + \spec{STRING}{C*(*)}{string containing deg, arcmin, arcsec fields} \\ + \spec{NSTRT}{I}{pointer to start of decode (beginning of STRING = 1)} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced past the decoded angle} \\ + \spec{DRESLT}{D}{angle in radians} \\ + \spec{JF}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $+1$ = default, DRESLT unchanged (note 2)} \\ + \spec{}{}{\hspace{0.7em} $-1$ = bad degrees (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-2$ = bad arcminutes (note 3)} \\ + \spec{}{}{\hspace{0.7em} $-3$ = bad arcseconds (note 3)} \\ +} +\goodbreak +\setlength{\oldspacing}{\topsep} +\setlength{\topsep}{0.3ex} +\begin{description} + \item [EXAMPLE]: \\ [1.5ex] + \begin{tabular}{lll} + {\it argument} & {\it before} & {\it after} \\ \\ + STRING & $'$\verb*}-57 17 44.806 12 34 56.7}$'$ & unchanged \\ + NSTRT & 1 & 16 ({\it i.e.}\ pointing to 12...) \\ + RESLT & - & $-1.00000${\tt D0} \\ + JF & - & 0 + \end{tabular} + \item A further call to sla\_DAFIN, without adjustment of NSTRT, will + decode the second angle, \dms{12}{34}{56}{7}. +\end{description} +\setlength{\topsep}{\oldspacing} +\notes +{ + \begin{enumerate} + \item The first three ``fields'' in STRING are degrees, arcminutes, + arcseconds, separated by spaces or commas. The degrees field + may be signed, but not the others. The decoding is carried + out by the sla\_DFLTIN routine and is free-format. + \item Successive fields may be absent, defaulting to zero. For + zero status, the only combinations allowed are degrees alone, + degrees and arcminutes, and all three fields present. If all + three fields are omitted, a status of +1 is returned and DRESLT is + unchanged. In all other cases DRESLT is changed. + \item Range checking: + \begin{itemize} + \item The degrees field is not range checked. However, it is + expected to be integral unless the other two fields are absent. + \item The arcminutes field is expected to be 0-59, and integral if + the arcseconds field is present. If the arcseconds field + is absent, the arcminutes is expected to be 0-59.9999... + \item The arcseconds field is expected to be 0-59.9999... + \item Decoding continues even when a check has failed. Under these + circumstances the field takes the supplied value, defaulting to + zero, and the result DRESLT is computed and returned. + \end{itemize} + \item Further fields after the three expected ones are not treated as + an error. The pointer NSTRT is left in the correct state for + further decoding with the present routine or with sla\_DFLTIN + {\it etc}. See the example, above. + \item If STRING contains hours, minutes, seconds instead of + degrees {\it etc}, + or if the required units are turns (or days) instead of radians, + the result DRESLT should be multiplied as follows: \\ [1.5ex] + \begin{tabular}{lll} + {\it for STRING} & {\it to obtain} & {\it multiply DRESLT by} \\ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & radians & $1.0D0$ \\ + ${\circ}$~~\raisebox{-0.7ex}{$'$}~~\raisebox{-0.7ex}{$''$} + & turns & $1/{2 \pi} = 0.1591549430918953358D0$ \\ + h m s & radians & $15.0D0$ \\ + h m s & days & $15/{2\pi} = 2.3873241463784300365D0$ + \end{tabular} + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_DAT}{TAI$-$UTC} +{ + \action{Increment to be applied to Coordinated Universal Time UTC to give + International Atomic Time TAI.} + \call{D~=~sla\_DAT (UTC)} +} +\args{GIVEN} +{ + \spec{UTC}{D}{UTC date as a modified JD (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_DAT}{D}{TAI$-$UTC in seconds} +} +\notes +{ + \begin{enumerate} + \item The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can be guaranteed only up to the end of the second + $23^{\rm h}\,59^{\rm m}\,59^{\rm s}$. + \item For epochs from 1961 January 1 onwards, the expressions from the + file {\tt ftp://maia.usno.navy.mil/ser7/tai-utc.dat} are used. + A 5ms time step at 1961~January~1 is taken from 2.58.1 (p87) of + the 1992 Explanatory Supplement. + \item UTC began at 1960 January 1.0 (JD 2436934.5) and it is improper + to call the routine with an earlier epoch. However, if this + is attempted, the TAI$-$UTC expression for the year 1960 is used. + \item This routine has to be updated on each occasion that a + leap second is announced, and programs using it relinked. + Refer to the program source code for information on when the + most recent leap second was added. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DAV2M}{Rotation Matrix from Axial Vector} +{ + \action{Form the rotation matrix corresponding to a given axial vector + (double precision).} + \call{CALL sla\_DAV2M (AXVEC, RMAT)} +} +\args{GIVEN} +{ + \spec{AXVEC}{D(3)}{axial vector (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some + arbitrary axis, called the Euler axis. The + {\it axial vector} supplied to this routine + has the same direction as the Euler axis, and its + magnitude is the amount of rotation in radians. + \item If AXVEC is null, the unit matrix is returned. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DBEAR}{Direction Between Points on a Sphere} +{ + \action{Returns the bearing (position angle) of one point on a + sphere relative to another (double precision).} + \call{D~=~sla\_DBEAR (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{D}{spherical coordinates of one point} \\ + \spec{A2,B2}{D}{spherical coordinates of the other point} +} +\args{RETURNED} +{ + \spec{sla\_DBEAR}{D}{bearing from first point to second} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are \radec, + $[\lambda,\phi]$ {\it etc.}, in radians. + \item The result is the bearing (position angle), in radians, + of point [A2,B2] as seen + from point [A1,B1]. It is in the range $\pm \pi$. The sense + is such that if [A2,B2] + is a small distance due east of [A1,B1] the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item If either B-coordinate is outside the range $\pm\pi/2$, the + result may correspond to ``the long way round''. + \item The routine sla\_DPAV performs an equivalent function except + that the points are specified in the form of Cartesian + vectors. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DBJIN}{Decode String to B/J Epoch (DP)} +{ + \action{Decode a character string into a DOUBLE PRECISION number, + with special provision for Besselian and Julian epochs. + The string syntax is as for sla\_DFLTIN, prefixed by + an optional `B' or `J'.} + \call{CALL sla\_DBJIN (STRING, NSTRT, DRESLT, J1, J2)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing field to be decoded} \\ + \spec{NSTRT}{I}{pointer to first character of field in string} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{incremented past the decoded field} \\ + \spec{DRESLT}{D}{result} \\ + \spec{J1}{I}{DFLTIN status:} \\ + \spec{}{}{\hspace{0.7em} $-$1 = $-$OK} \\ + \spec{}{}{\hspace{1.5em} 0 = +OK} \\ + \spec{}{}{\hspace{1.5em} 1 = null field} \\ + \spec{}{}{\hspace{1.5em} 2 = error} \\ + \spec{J2}{I}{syntax flag:} \\ + \spec{}{}{\hspace{1.5em} 0 = normal DFLTIN syntax} \\ + \spec{}{}{\hspace{1.5em} 1 = `B' or `b'} \\ + \spec{}{}{\hspace{1.5em} 2 = `J' or `j'} +} +\notes +{ + \begin{enumerate} + \item The purpose of the syntax extensions is to help cope with mixed + FK4 and FK5 data, allowing fields such as `B1950' or `J2000' + to be decoded. + \item In addition to the syntax accepted by sla\_DFLTIN, + the following two extensions are recognized by sla\_DBJIN: + \begin{enumerate} + \item A valid non-null field preceded by the character `B' + (or `b') is accepted. + \item A valid non-null field preceded by the character `J' + (or `j') is accepted. + \end{enumerate} + \item The calling program is told of the `B' or `J' through an + supplementary status argument. The rest of + the arguments are as for sla\_DFLTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DC62S}{Cartesian 6-Vector to Spherical} +{ + \action{Conversion of position \& velocity in Cartesian coordinates + to spherical coordinates (double precision).} + \call{CALL sla\_DC62S (V, A, B, R, AD, BD, RD)} +} +\args{GIVEN} +{ + \spec{V}{D(6)}{\xyzxyzd} +} +\args{RETURNED} +{ + \spec{A}{D}{longitude (radians)} \\ + \spec{B}{D}{latitude (radians)} \\ + \spec{R}{D}{radial coordinate} \\ + \spec{AD}{D}{longitude derivative (radians per unit time)} \\ + \spec{BD}{D}{latitude derivative (radians per unit time)} \\ + \spec{RD}{D}{radial derivative} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCC2S}{Cartesian to Spherical} +{ + \action{Cartesian coordinates to spherical coordinates (double precision).} + \call{CALL sla\_DCC2S (V, A, B)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{\xyz\ vector} +} +\args{RETURNED} +{ + \spec{A,B}{D}{spherical coordinates in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole. + \item If V is null, zero A and B are returned. + \item At either pole, zero A is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCMPF}{Interpret Linear Fit} +{ + \action{Decompose an \xy\ linear fit into its constituent parameters: + zero points, scales, nonperpendicularity and orientation.} + \call{CALL sla\_DCMPF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT)} +} +\args{GIVEN} +{ + \spec{COEFFS}{D(6)}{transformation coefficients (see note)} +} +\args{RETURNED} +{ + \spec{XZ}{D}{{\it x} zero point} \\ + \spec{YZ}{D}{{\it y} zero point} \\ + \spec{XS}{D}{{\it x} scale} \\ + \spec{YS}{D}{{\it y} scale} \\ + \spec{PERP}{D}{nonperpendicularity (radians)} \\ + \spec{ORIENT}{D}{orientation (radians)} +} +\notes +{ + \begin{enumerate} + \item The model relates two sets of \xy\ coordinates as follows. + Naming the six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms coordinates $[x_{1},y_{1}\,]$ into coordinates + $[x_{2},y_{2}\,]$ as follows: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + The sla\_DCMPF routine decomposes this transformation + into four steps: + \begin{enumerate} + \item Zero points: + \begin{verse} + $x' = x_{1} + {\rm XZ}$ \\ + $y' = y_{1} + {\rm YZ}$ + \end{verse} + \item Scales: + \begin{verse} + $x'' = x' {\rm XS}$ \\ + $y'' = y' {\rm YS}$ + \end{verse} + \item Nonperpendicularity: + \begin{verse} + $x''' = + x'' \cos {\rm PERP}/2 + y'' \sin {\rm PERP}/2$ \\ + $y''' = + x'' \sin {\rm PERP}/2 + y'' \cos {\rm PERP}/2$ + \end{verse} + \item Orientation: + \begin{verse} + $x_{2} = + x''' \cos {\rm ORIENT} + + y''' \sin {\rm ORIENT}$ \\ + $y_{2} = - x''' \sin {\rm ORIENT} + + y''' \cos {\rm ORIENT}$ + \end{verse} + \end{enumerate} + \item See also sla\_FITXY, sla\_PXY, sla\_INVF, sla\_XY2XY. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DCS2C}{Spherical to Cartesian} +{ + \action{Spherical coordinates to Cartesian coordinates (double precision).} + \call{CALL sla\_DCS2C (A, B, V)} +} +\args{GIVEN} +{ + \spec{A,B}{D}{spherical coordinates in radians: \radec\ {\it etc.}} +} +\args{RETURNED} +{ + \spec{V}{D(3)}{\xyz\ unit vector} +} +\anote{The spherical coordinates are longitude (+ve anticlockwise + looking from the +ve latitude pole) and latitude. The + Cartesian coordinates are right handed, with the {\it x}-axis + at zero longitude and latitude, and the {\it z}-axis at the + +ve latitude pole.} +%----------------------------------------------------------------------- +\routine{SLA\_DD2TF}{Days to Hour,Min,Sec} +{ + \action{Convert an interval in days into hours, minutes, seconds + (double precision).} + \call{CALL sla\_DD2TF (NDP, DAYS, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{DAYS}{D}{interval in days} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of DAYS, the format of DOUBLE PRECISION floating-point numbers + on the target machine, and the risk of overflowing IHMSF(4). + On some architectures, for DAYS up to 1D0, the available + floating-point precision corresponds roughly to NDP=12. + However, the practical limit is NDP=9, set by the capacity of + a typical 32-bit IHMSF(4). + \item The absolute value of DAYS may exceed 1D0. In cases where it + does not, it is up to the caller to test for and handle the + case where DAYS is very nearly 1D0 and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. +\end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DE2H}{$h,\delta$ to Az,El} +{ + \action{Equatorial to horizon coordinates + (double precision).} + \call{CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle (radians)} \\ + \spec{DEC}{D}{declination (radians)} \\ + \spec{PHI}{D}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{AZ}{D}{azimuth (radians)} \\ + \spec{EL}{D}{elevation (radians)} +} +\notes +{ + \begin{enumerate} + \item Azimuth is returned in the range $0\!-\!2\pi$; north is zero, + and east is $+\pi/2$. Elevation is returned in the range + $\pm\pi$. + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the {\it observed} \hadec, and the elevation + {\it in vacuo}, which would require the {\it topocentric} + \hadec. + If the effects of diurnal aberration can be neglected, the + {\it apparent} \hadec\ may be used instead of the topocentric + \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DEULER}{Euler Angles to Rotation Matrix} +{ + \action{Form a rotation matrix from the Euler angles -- three + successive rotations about specified Cartesian axes + (double precision).} + \call{CALL sla\_DEULER (ORDER, PHI, THETA, PSI, RMAT)} +} +\args{GIVEN} +{ + \spec{ORDER}{C}{specifies about which axes the rotations occur} \\ + \spec{PHI}{D}{1st rotation (radians)} \\ + \spec{THETA}{D}{2nd rotation (radians)} \\ + \spec{PSI}{D}{3rd rotation (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + \item The characters of ORDER define which axes the three successive + rotations are about. A typical value is `ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old {\it z}-axis, followed by THETA radians about the resulting + {\it x}-axis, + then PSI radians about the resulting {\it z}-axis. + \item The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labelling/numbering conventions apply; the {\it xyz} ($\equiv123$) + triad is right-handed. Thus, the `ZXZ' example given above + could be written `zxz' or `313' (or even `ZxZ' or `3xZ'). ORDER + is terminated by length or by the first unrecognized character. + Fewer than three rotations are acceptable, in which case the later + angle arguments are ignored. Zero rotations produces + the identity RMAT. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DFLTIN}{Decode a Double Precision Number} +{ + \action{Convert free-format input into double precision floating point.} + \call{CALL sla\_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{DRESLT}{D}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{DRESLT}{D}{result} \\ + \spec{JFLAG}{I}{status: $-$1~=~$-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_DFLTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space, and lowercase characters are + interpreted as uppercase. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n.n x \pm n$, + where $\pm$ is a sign + character `+' or `$-$', $n$ means a string of decimal digits, + `.' is a decimal point, and $x$, which indicates an exponent, + means `D' or `E'. Various combinations of these fields can be + omitted, and embedded blanks are permissible in certain places. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Embedded spaces are allowed only after +, $-$, D or E, + and after the decimal point if the first sequence of + digits is absent. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9,.,D,E or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_DFLTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 13, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item Both signs are optional. The default is +. + \item The mantissa $n.n$ defaults to unity. + \item The exponent $x\!\pm\!n$ defaults to `D0'. + \item The strings of decimal digits may be of any length. + \item The decimal point is optional for whole numbers. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$,0-9,.,D or E, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and DRESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_DFLTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_DFLTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item a +, $-$, D or E is left unsatisfied; or + \item the decimal point is present without at least + one decimal digit before or after it; or + \item an exponent more than 100 has been presented. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + sla\_DFLTIN does not detect that `1D999' is unacceptable + (on a computer where this is so) until the entire number + has been decoded. + \item Certain highly unlikely combinations of mantissa and + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + \item Decoding is left to right, one pass. + \item See also sla\_FLOTIN and sla\_INTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DH2E}{Az,El to $h,\delta$} +{ + \action{Horizon to equatorial coordinates + (double precision).} + \call{CALL sla\_DH2E (AZ, EL, PHI, HA, DEC)} +} +\args{GIVEN} +{ + \spec{AZ}{D}{azimuth (radians)} \\ + \spec{EL}{D}{elevation (radians)} \\ + \spec{PHI}{D}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{HA}{D}{hour angle (radians)} \\ + \spec{DEC}{D}{declination (radians)} +} +\notes +{ + \begin{enumerate} + \item The sign convention for azimuth is north zero, east $+\pi/2$. + \item HA is returned in the range $\pm\pi$. Declination is returned + in the range $\pm\pi/2$. + \item The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied + (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of \hadec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the {\it observed} \hadec, and the elevation + {\it in vacuo}, which will yield the {\it topocentric} + \hadec. If the + effects of diurnal aberration can be neglected, the + topocentric \hadec\ may be used as an approximation to the + {\it apparent} \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DIMXV}{Apply 3D Reverse Rotation} +{ + \action{Multiply a 3-vector by the inverse of a rotation + matrix (double precision).} + \call{CALL sla\_DIMXV (DM, VA, VB)} +} +\args{GIVEN} +{ + \spec{DM}{D(3,3)}{rotation matrix} \\ + \spec{VA}{D(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{D(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$^{T}\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix DM. + \item The main function of this routine is apply an inverse + rotation; under these circumstances, ${\bf M}$ is + {\it orthogonal}, with its inverse the same as its transpose. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DJCAL}{MJD to Gregorian for Output} +{ + \action{Modified Julian Date to Gregorian Calendar Date, expressed + in a form convenient for formatting messages (namely + rounded to a specified precision, and with the fields + stored in a single array).} + \call{CALL sla\_DJCAL (NDP, DJM, IYMDF, J)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of days in fraction} \\ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{IYMDF}{I(4)}{year, month, day, fraction in Gregorian calendar} \\ + \spec{J}{I}{status: nonzero = out of range} +} +\notes +{ + \begin{enumerate} + \item Any date after 4701BC March 1 is accepted. + \item Large NDP values risk internal overflows. It is typically safe + to use up to NDP=4. + \end{enumerate} +} +\aref{The algorithm is adapted from Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_DJCL}{MJD to Year,Month,Day,Frac} +{ + \action{Modified Julian Date to Gregorian year, month, day, + and fraction of a day.} + \call{CALL sla\_DJCL (DJM, IY, IM, ID, FD, J)} +} +\args{GIVEN} +{ + \spec{DJM}{D}{modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{IY}{I}{year} \\ + \spec{IM}{I}{month} \\ + \spec{ID}{I}{day} \\ + \spec{FD}{D}{fraction of day} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em}0~=~OK} \\ + \spec{}{}{\hspace{0.7em}$-$1~= unacceptable date} \\ + \spec{}{}{\hspace{0.7em}~~~~~~~~~~~~(before 4701\,BC~March~1)} +} +\aref{The algorithm is adapted from Hatcher, + {\it Q.\,Jl.\,R.\,astr.\,Soc.}\ (1984) {\bf 25}, 53-55.} +%----------------------------------------------------------------------- +\routine{SLA\_DM2AV}{Rotation Matrix to Axial Vector} +{ + \action{From a rotation matrix, determine the corresponding axial vector + (double precision).} + \call{CALL sla\_DM2AV (RMAT, AXVEC)} +} +\args{GIVEN} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\args{RETURNED} +{ + \spec{AXVEC}{D(3)}{axial vector (radians)} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis, + called the Euler axis. The {\it axial vector} returned by + this routine has the same direction as the Euler axis, and its + magnitude is the amount of rotation in radians. + \item The magnitude and direction of the axial vector can be separated + by means of the routine sla\_DVN. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \item If RMAT is null, so is the result. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DMAT}{Solve Simultaneous Equations} +{ + \action{Matrix inversion and solution of simultaneous equations + (double precision).} + \call{CALL sla\_DMAT (N, A, Y, D, JF, IW)} +} +\args{GIVEN} +{ + \spec{N}{I}{number of unknowns} \\ + \spec{A}{D(N,N)}{matrix} \\ + \spec{Y}{D(N)}{vector} +} +\args{RETURNED} +{ + \spec{A}{D(N,N)}{matrix inverse} \\ + \spec{Y}{D(N)}{solution} \\ + \spec{D}{D}{determinant} \\ + \spec{JF}{I}{singularity flag: 0=OK} \\ + \spec{IW}{I(N)}{workspace} +} +\notes +{ + \begin{enumerate} + \item For the set of $n$ simultaneous linear equations in $n$ unknowns: + \begin{verse} + {\bf A}$\cdot${\bf y} = {\bf x} + \end{verse} + where: + \begin{itemize} + \item {\bf A} is a non-singular $n \times n$ matrix, + \item {\bf y} is the vector of $n$ unknowns, and + \item {\bf x} is the known vector, + \end{itemize} + sla\_DMAT computes: + \begin{itemize} + \item the inverse of matrix {\bf A}, + \item the determinant of matrix {\bf A}, and + \item the vector of $n$ unknowns {\bf y}. + \end{itemize} + Argument N is the order $n$, A (given) is the matrix {\bf A}, + Y (given) is the vector {\bf x} and Y (returned) + is the vector {\bf y}. + The argument A (returned) is the inverse matrix {\bf A}$^{-1}$, + and D is {\it det}\/({\bf A}). + \item JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=$-$1 + and D=0D0 are returned. In the latter case, the contents + of array A on return are undefined. + \item The algorithm is Gaussian elimination with partial pivoting. + This method is very fast; some much slower algorithms can give + better accuracy, but only by a small factor. + \item This routine replaces the obsolete sla\_DMATRX. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DMOON}{Approx Moon Pos/Vel} +{ + \action{Approximate geocentric position and velocity of the Moon + (double precision).} + \call{CALL sla\_DMOON (DATE, PV)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (loosely ET) as a Modified Julian Date (JD$-$2400000.5) +} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{Moon \xyzxyzd, mean equator and equinox + of date (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item This routine is a full implementation of the algorithm + published by Meeus (see reference). + \item Meeus quotes accuracies of \arcseci{10} in longitude, + \arcseci{3} in latitude and \arcsec{0}{2} arcsec in HP + (equivalent to about 20~km in distance). Comparison with + JPL~DE200 over the interval 1960-2025 gives RMS errors of + \arcsec{3}{7} and 83~mas/hour in longitude, + \arcsec{2}{3} arcsec and 48~mas/hour in latitude, + 11~km and 81~mm/s in distance. + The maximum errors over the same interval are + \arcseci{18} and \arcsec{0}{50}/hour in longitude, + \arcseci{11} and \arcsec{0}{24}/hour in latitude, + 40~km and 0.29~m/s in distance. + \item The original algorithm is expressed in terms of the obsolete + time scale {\it Ephemeris Time}. Either TDB or TT can be used, + but not UT without incurring significant errors (\arcseci{30} at + the present time) due to the Moon's \arcsec{0}{5}/s movement. + \item The algorithm is based on pre IAU 1976 standards. However, + the result has been moved onto the new (FK5) equinox, an + adjustment which is in any case much smaller than the + intrinsic accuracy of the procedure. + \item Velocity is obtained by a complete analytical differentiation + of the Meeus model. + \end{enumerate} +} +\aref{Meeus, {\it l'Astronomie}, June 1984, p348.} +%----------------------------------------------------------------------- +\routine{SLA\_DMXM}{Multiply $3\times3$ Matrices} +{ + \action{Product of two $3\times3$ matrices (double precision).} + \call{CALL sla\_DMXM (A, B, C)} +} +\args{GIVEN} +{ + \spec{A}{D(3,3)}{matrix {\bf A}} \\ + \spec{B}{D(3,3)}{matrix {\bf B}} +} +\args{RETURNED} +{ + \spec{C}{D(3,3)}{matrix result: {\bf A}$\times${\bf B}} +} +\anote{To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. However, the routine is coded so as to + work properly on many platforms even if this rule is violated, + something that is {\bf not}, however, recommended.} +%----------------------------------------------------------------------- +\routine{SLA\_DMXV}{Apply 3D Rotation} +{ + \action{Multiply a 3-vector by a rotation matrix (double precision).} + \call{CALL sla\_DMXV (DM, VA, VB)} +} +\args{GIVEN} +{ + \spec{DM}{D(3,3)}{rotation matrix} \\ + \spec{VA}{D(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{D(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix DM. + \item The main function of this routine is apply a + rotation; under these circumstances, {\bf M} is a + {\it proper real orthogonal}\/ matrix. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly with many Fortran compilers even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DPAV}{Position-Angle Between Two Directions} +{ + \action{Returns the bearing (position angle) of one celestial + direction with respect to another (double precision).} + \call{D~=~sla\_DPAV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{D(3)}{vector to one point} \\ + \spec{V2}{D(3)}{vector to the other point} +} +\args{RETURNED} +{ + \spec{sla\_DPAV}{D}{position-angle of 2nd point with respect to 1st} +} +\notes +{ + \begin{enumerate} + \item The coordinate frames correspond to \radec, + $[\lambda,\phi]$ {\it etc.}. + \item The result is the bearing (position angle), in radians, + of point V2 as seen + from point V1. It is in the range $\pm \pi$. The sense + is such that if V2 + is a small distance due east of V1 the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item There is no requirement for either vector to be of unit length. + \item The routine sla\_DBEAR performs an equivalent function except + that the points are specified in the form of spherical coordinates. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_DR2AF}{Radians to Deg,Min,Sec,Frac} +{ + \action{Convert an angle in radians to degrees, arcminutes, arcseconds, + fraction (double precision).} + \call{CALL sla\_DR2AF (NDP, ANGLE, SIGN, IDMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of arcseconds} \\ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IDMSF}{I(4)}{degrees, arcminutes, arcseconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE PRECISION floating-point + numbers on the target machine, and the risk of overflowing + IDMSF(4). On some architectures, for ANGLE up to 2pi, the + available floating-point precision corresponds roughly to + NDP=12. However, the practical limit is NDP=9, set by the + capacity of a typical 32-bit IDMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to $360^{\circ}$, + by testing for IDMSF(1)=360 and setting IDMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DR2TF}{Radians to Hour,Min,Sec,Frac} +{ + \action{Convert an angle in radians to hours, minutes, seconds, + fraction (double precision).} + \call{CALL sla\_DR2TF (NDP, ANGLE, SIGN, IHMSF)} +} +\args{GIVEN} +{ + \spec{NDP}{I}{number of decimal places of seconds} \\ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{SIGN}{C}{`+' or `$-$'} \\ + \spec{IHMSF}{I(4)}{hours, minutes, seconds, fraction} +} +\notes +{ + \begin{enumerate} + \item NDP less than zero is interpreted as zero. + \item The largest useful value for NDP is determined by the size + of ANGLE, the format of DOUBLE PRECISION floating-point + numbers on the target machine, and the risk of overflowing + IHMSF(4). On some architectures, for ANGLE up to 2pi, the + available floating-point precision corresponds roughly to + NDP=12. However, the practical limit is NDP=9, set by the + capacity of a typical 32-bit IHMSF(4). + \item The absolute value of ANGLE may exceed $2\pi$. In cases where it + does not, it is up to the caller to test for and handle the + case where ANGLE is very nearly $2\pi$ and rounds up to 24~hours, + by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DRANGE}{Put Angle into Range $\pm\pi$} +{ + \action{Normalize an angle into the range $\pm\pi$ (double precision).} + \call{D~=~sla\_DRANGE (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_DRANGE}{D}{ANGLE expressed in the range $\pm\pi$.} +} +%----------------------------------------------------------------------- +\routine{SLA\_DRANRM}{Put Angle into Range $0\!-\!2\pi$} +{ + \action{Normalize an angle into the range $0\!-\!2\pi$ + (double precision).} + \call{D~=~sla\_DRANRM (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{D}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_DRANRM}{D}{ANGLE expressed in the range $0\!-\!2\pi$} +} +%----------------------------------------------------------------------- +\routine{SLA\_DS2C6}{Spherical Pos/Vel to Cartesian} +{ + \action{Conversion of position \& velocity in spherical coordinates + to Cartesian coordinates (double precision).} + \call{CALL sla\_DS2C6 (A, B, R, AD, BD, RD, V)} +} +\args{GIVEN} +{ + \spec{A}{D}{longitude (radians) -- for example $\alpha$} \\ + \spec{B}{D}{latitude (radians) -- for example $\delta$} \\ + \spec{R}{D}{radial coordinate} \\ + \spec{AD}{D}{longitude derivative (radians per unit time)} \\ + \spec{BD}{D}{latitude derivative (radians per unit time)} \\ + \spec{RD}{D}{radial derivative} +} +\args{RETURNED} +{ + \spec{V}{D(6)}{\xyzxyzd} +} +%----------------------------------------------------------------------- +\routine{SLA\_DS2TP}{Spherical to Tangent Plane} +{ + \action{Projection of spherical coordinates onto the tangent plane + (double precision).} + \call{CALL sla\_DS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{RA,DEC}{D}{spherical coordinates of star (radians)} \\ + \spec{RAZ,DECZ}{D}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{XI,ETA}{D}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DV2TP is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DSEP}{Angle Between 2 Points on Sphere} +{ + \action{Angle between two points on a sphere (double precision).} + \call{D~=~sla\_DSEP (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{D}{spherical coordinates of one point (radians)} \\ + \spec{A2,B2}{D}{spherical coordinates of the other point (radians)} +} +\args{RETURNED} +{ + \spec{sla\_DSEP}{D}{angle between [A1,B1] and [A2,B2] in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are right ascension and declination, + longitude and latitude, {\it etc.}, in radians. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DSEPV}{Angle Between 2 Vectors} +{ + \action{Angle between two vectors (double precision).} + \call{D~=~sla\_DSEPV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{D(3)}{first vector} \\ + \spec{V2}{D(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_DSEPV}{D}{angle between V1 and V2 in radians} +} +\notes +{ + \begin{enumerate} + \item There is no requirement for either vector to be of unit length. + \item If either vector is null, zero is returned. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DT}{Approximate ET minus UT} +{ + \action{Estimate $\Delta$T, the offset between dynamical time + and Universal Time, for a given historical epoch.} + \call{D~=~sla\_DT (EPOCH)} +} +\args{GIVEN} +{ + \spec{EPOCH}{D}{(Julian) epoch ({\it e.g.}\ 1850D0)} +} +\args{RETURNED} +{ + \spec{sla\_DT}{D}{approximate ET$-$UT (after 1984, TT$-$UT1) in seconds} +} +\notes +{ + \begin{enumerate} + \item Depending on the epoch, one of three parabolic approximations + is used: + +\begin{tabular}{lll} +& before AD 979 & Stephenson \& Morrison's 390 BC to AD 948 model \\ +& AD 979 to AD 1708 & Stephenson \& Morrison's AD 948 to AD 1600 model \\ +& after AD 1708 & McCarthy \& Babcock's post-1650 model +\end{tabular} + + The breakpoints are chosen to ensure continuity: they occur + at places where the adjacent models give the same answer as + each other. + \item The accuracy is modest, with errors of up to $20^{\rm s}$ during + the interval since 1650, rising to perhaps $30^{\rm m}$ + by 1000~BC. Comparatively accurate values from AD~1600 + are tabulated in + the {\it Astronomical Almanac}\/ (see section K8 of the 1995 + edition). + \item The use of {\tt DOUBLE PRECISION} for both argument and result is + simply for compatibility with other SLALIB time routines. + \item The models used are based on a lunar tidal acceleration value + of \arcsec{-26}{00} per century. + \end{enumerate} +} +\aref{Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + This contains references to the papers by Stephenson \& Morrison + and by McCarthy \& Babcock which describe the models used here.} +%----------------------------------------------------------------------- +\routine{SLA\_DTF2D}{Hour,Min,Sec to Days} +{ + \action{Convert hours, minutes, seconds to days (double precision).} + \call{CALL sla\_DTF2D (IHOUR, IMIN, SEC, DAYS, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{D}{seconds} +} +\args{RETURNED} +{ + \spec{DAYS}{D}{interval in days} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTF2R}{Hour,Min,Sec to Radians} +{ + \action{Convert hours, minutes, seconds to radians (double precision).} + \call{CALL sla\_DTF2R (IHOUR, IMIN, SEC, RAD, J)} +} +\args{GIVEN} +{ + \spec{IHOUR}{I}{hours} \\ + \spec{IMIN}{I}{minutes} \\ + \spec{SEC}{D}{seconds} +} +\args{RETURNED} +{ + \spec{RAD}{D}{angle in radians} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} 1 = IHOUR outside range 0-23} \\ + \spec{}{}{\hspace{1.5em} 2 = IMIN outside range 0-59} \\ + \spec{}{}{\hspace{1.5em} 3 = SEC outside range 0-59.999$\cdots$} +} +\notes +{ + \begin{enumerate} + \item The result is computed even if any of the range checks fail. + \item The sign must be dealt with outside this routine. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTP2S}{Tangent Plane to Spherical} +{ + \action{Transform tangent plane coordinates into spherical + coordinates (double precision)} + \call{CALL sla\_DTP2S (XI, ETA, RAZ, DECZ, RA, DEC)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane rectangular coordinates (radians)} \\ + \spec{RAZ,DECZ}{D}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{spherical coordinates (radians)} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DTP2V is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTP2V}{Tangent Plane to Direction Cosines} +{ + \action{Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star + (double precision).} + \call{CALL sla\_DTP2V (XI, ETA, V0, V)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane coordinates of star (radians)} \\ + \spec{V0}{D(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{V}{D(3)}{direction cosines of star} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, the returned vector V will + be wrong. + \item If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that $\alpha=0$ at + the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DTP2S. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTPS2C}{Plate centre from $\xi,\eta$ and $\alpha,\delta$} +{ + \action{From the tangent plane coordinates of a star of known \radec, + determine the \radec\ of the tangent point (double precision)} + \call{CALL sla\_DTPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane rectangular coordinates (radians)} \\ + \spec{RA,DEC}{D}{spherical coordinates (radians)} +} +\args{RETURNED} +{ + \spec{RAZ1,DECZ1}{D}{spherical coordinates of tangent point, + solution 1} \\ + \spec{RAZ2,DECZ2}{D}{spherical coordinates of tangent point, + solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The RAZ1 and RAZ2 values returned are in the range $0\!-\!2\pi$. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero $\xi$ value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of $\xi$ and $\delta$. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N\,=\,1 + indicates only one useful solution, the usual case; under + these circumstances, the second solution corresponds to the + ``over-the-pole'' case, and this is reflected in the values + of RAZ2 and DECZ2 which are returned. + \item The DECZ1 and DECZ2 values returned are in the range $\pm\pi$, + but in the ordinary, non-pole-crossing, case, the range is + $\pm\pi/2$. + \item RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2 are all in radians. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_DTPV2C is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTPV2C}{Plate centre from $\xi,\eta$ and $x,y,z$} +{ + \action{From the tangent plane coordinates of a star of known + direction cosines, determine the direction cosines + of the tangent point (double precision)} + \call{CALL sla\_DTPV2C (XI, ETA, V, V01, V02, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{D}{tangent plane coordinates of star (radians)} \\ + \spec{V}{D(3)}{direction cosines of star} +} +\args{RETURNED} +{ + \spec{V01}{D(3)}{direction cosines of tangent point, solution 1} \\ + \spec{V02}{D(3)}{direction cosines of tangent point, solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The vector V must be of unit length or the result will be wrong. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. + N\,=\,1 + indicates only one useful solution, the usual case; under these + circumstances, the second solution can be regarded as valid if + the vector V02 is interpreted as the ``over-the-pole'' case. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DTPS2C. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DTT}{TT minus UTC} +{ + \action{Compute $\Delta$TT, the increment to be applied to + Coordinated Universal Time UTC to give + Terrestrial Time TT.} + \call{D~=~sla\_DTT (DJU)} +} +\args{GIVEN} +{ + \spec{DJU}{D}{UTC date as a modified JD (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_DTT}{D}{TT$-$UTC in seconds} +} +\notes +{ + \begin{enumerate} + \item The UTC is specified to be a date rather than a time to indicate + that care needs to be taken not to specify an instant which lies + within a leap second. Though in most cases UTC can include the + fractional part, correct behaviour on the day of a leap second + can be guaranteed only up to the end of the second + $23^{\rm h}\,59^{\rm m}\,59^{\rm s}$. + \item Pre 1972 January 1 a fixed value of 10 + ET$-$TAI is returned. + \item TT is one interpretation of the defunct time scale + {\it Ephemeris Time}, ET. + \item See also the routine sla\_DT, which roughly estimates ET$-$UT for + historical epochs. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DV2TP}{Direction Cosines to Tangent Plane} +{ + \action{Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates + (double precision).} + \call{CALL sla\_DV2TP (V, V0, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{direction cosines of star} \\ + \spec{V0}{D(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{XI,ETA}{D}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + \item If V0 points at a pole, the returned $\xi,\eta$ + will be based on the + arbitrary assumption that $\alpha=0$ at the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_DS2TP. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_DVDV}{Scalar Product} +{ + \action{Scalar product of two 3-vectors (double precision).} + \call{D~=~sla\_DVDV (VA, VB)} +} +\args{GIVEN} +{ + \spec{VA}{D(3)}{first vector} \\ + \spec{VB}{D(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_DVDV}{D}{scalar product VA.VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_DVN}{Normalize Vector} +{ + \action{Normalize a 3-vector, also giving the modulus (double precision).} + \call{CALL sla\_DVN (V, UV, VM)} +} +\args{GIVEN} +{ + \spec{V}{D(3)}{vector} +} +\args{RETURNED} +{ + \spec{UV}{D(3)}{unit vector in direction of V} \\ + \spec{VM}{D}{modulus of V} +} +\anote{If the modulus of V is zero, UV is set to zero as well.} +%----------------------------------------------------------------------- +\routine{SLA\_DVXV}{Vector Product} +{ + \action{Vector product of two 3-vectors (double precision).} + \call{CALL sla\_DVXV (VA, VB, VC)} +} +\args{GIVEN} +{ + \spec{VA}{D(3)}{first vector} \\ + \spec{VB}{D(3)}{second vector} +} +\args{RETURNED} +{ + \spec{VC}{D(3)}{vector product VA$\times$VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_E2H}{$h,\delta$ to Az,El} +{ + \action{Equatorial to horizon coordinates + (single precision).} + \call{CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} +} +\args{GIVEN} +{ + \spec{HA}{R}{hour angle (radians)} \\ + \spec{DEC}{R}{declination (radians)} \\ + \spec{PHI}{R}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{AZ}{R}{azimuth (radians)} \\ + \spec{EL}{R}{elevation (radians)} +} +\notes +{ + \begin{enumerate} + \item Azimuth is returned in the range $0\!-\!2\pi$; north is zero, + and east is $+\pi/2$. Elevation is returned in the range + $\pm\pi$. + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied. + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type of azimuth and elevation. In + particular, it may be important to distinguish between + elevation as affected by refraction, which would + require the {\it observed} \hadec, and the elevation + {\it in vacuo}, which would require the {\it topocentric} + \hadec. + If the effects of diurnal aberration can be neglected, the + {\it apparent} \hadec\ may be used instead of the topocentric + \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude, and (for tracking a star) + sine and cosine of declination. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EARTH}{Approx Earth Pos/Vel} +{ + \action{Approximate heliocentric position and velocity of the Earth + (single precision).} + \call{CALL sla\_EARTH (IY, ID, FD, PV)} +} +\args{GIVEN} +{ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R}{fraction of day} +} +\args{RETURNED} +{ + \spec{PV}{R(6)}{Earth \xyzxyzd\ (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900~March~1 to 2100~February~28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item The Earth heliocentric 6-vector is referred to the + FK4 mean equator and equinox of date. + \item Maximum/RMS errors 1950-2050: + \begin{itemize} + \item 13/5~$\times10^{-5}$~AU = 19200/7600~km in position + \item 47/26~$\times10^{-10}$~AU~s$^{-1}$ = + 0.0070/0.0039~km~s$^{-1}$ in speed + \end{itemize} + \item More accurate results are obtainable with the routines sla\_EVP + and sla\_EPV. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ECLEQ}{Ecliptic to Equatorial} +{ + \action{Transformation from ecliptic longitude and latitude to + J2000.0 \radec.} + \call{CALL sla\_ECLEQ (DL, DB, DATE, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians)} \\ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{J2000.0 mean \radec\ (radians)} +} +%----------------------------------------------------------------------- +\routine{SLA\_ECMAT}{Form $\alpha,\delta\rightarrow\lambda,\beta$ Matrix} +{ + \action{Form the equatorial to ecliptic rotation matrix (IAU 1980 theory).} + \call{CALL sla\_ECMAT (DATE, RMAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RMAT}{D(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item RMAT is matrix {\bf M} in the expression + {\bf v}$_{ecl}$~=~{\bf M}$\cdot${\bf v}$_{equ}$. + \item The equator, equinox and ecliptic are mean of date. + \end{enumerate} +} +\aref{Murray, C.A., {\it Vectorial Astrometry}, section 4.3.} +%----------------------------------------------------------------------- +\routine{SLA\_ECOR}{RV \& Time Corrns to Sun} +{ + \action{Component of Earth orbit velocity and heliocentric + light time in a given direction.} + \call{CALL sla\_ECOR (RM, DM, IY, ID, FD, RV, TL)} +} +\args{GIVEN} +{ + \spec{RM,DM}{R}{mean \radec\ of date (radians)} \\ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R}{fraction of day} +} +\args{RETURNED} +{ + \spec{RV}{R}{component of Earth orbital velocity (km~s$^{-1}$)} \\ + \spec{TL}{R}{component of heliocentric light time (s)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item Sign convention: + \begin{itemize} + \item The velocity component is +ve when the + Earth is receding from + the given point on the sky. + \item The light time component is +ve + when the Earth lies between the Sun and + the given point on the sky. + \end{itemize} + \item Accuracy: + \begin{itemize} + \item The velocity component is usually within 0.004~km~s$^{-1}$ + of the correct value and is never in error by more than + 0.007~km~s$^{-1}$. + \item The error in light time correction is about + \tsec{0}{03} at worst, + but is usually better than \tsec{0}{01}. + \end{itemize} + For applications requiring higher accuracy, see the sla\_EVP + and sla\_EPV routines. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EG50}{B1950 $\alpha,\delta$ to Galactic} +{ + \action{Transformation from B1950.0 FK4 equatorial coordinates to + IAU 1958 galactic coordinates.} + \call{CALL sla\_EG50 (DR, DD, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{B1950.0 \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\anote{The equatorial coordinates are B1950.0 FK4. Use the + routine sla\_EQGAL if conversion from J2000.0 FK5 coordinates + is required.} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_EL2UE}{Conventional to Universal Elements} +{ + \action{Transform conventional osculating orbital elements + into ``universal'' form.} + \call{CALL sla\_EL2UE (\vtop{ + \hbox{DATE, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM,} + \hbox{U, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{epoch (TT MJD) of osculation (Note~3)} \\ + \spec{JFORM}{I}{choice of element set (1-3; Note~6)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, + approx} \\ \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.2em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.2em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.2em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.2em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item The ``universal'' elements are those which define the orbit for + the purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The companion routine is sla\_UE2PV. This takes the set of numbers + that the present routine outputs and uses them to derive the + object's position and velocity. A single prediction requires one + call to the present routine followed by one call to sla\_UE2PV; + for convenience, the two calls are packaged as the routine + sla\_PLANEL. Multiple predictions may be made by again calling the + present routine once, but then calling sla\_UE2PV multiple times, + which is faster than multiple calls to sla\_PLANEL. + \item DATE is the epoch of osculation. It is in the TT time scale + (formerly Ephemeris Time, ET) and is a Modified Julian Date + (JD$-$2400000.5). + \item The supplied orbital elements are with respect to the J2000 + ecliptic and equinox. The position and velocity parameters + returned in the array U are with respect to the mean equator and + equinox of epoch J2000, and are for the perihelion prior to the + specified epoch. + \item The universal elements returned in the array U are in canonical + units (solar masses, AU and canonical days). + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & longitude of perihelion $\varpi$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean longitude $L$ (radians) \\ + & DM & = & daily motion $n$ (radians) + \end{tabular} + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabular} + + \item Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%------------------------------------------------------------------------------ +\routine{SLA\_EPB}{MJD to Besselian Epoch} +{ + \action{Conversion of Modified Julian Date to Besselian Epoch.} + \call{D~=~sla\_EPB (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EPB}{D}{Besselian Epoch} +} +\aref{Lieske, J.H., 1979, {\it Astr.Astrophys.}\ {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPB2D}{Besselian Epoch to MJD} +{ + \action{Conversion of Besselian Epoch to Modified Julian Date.} + \call{D~=~sla\_EPB2D (EPB)} +} +\args{GIVEN} +{ + \spec{EPB}{D}{Besselian Epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPB2D}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\aref{Lieske, J.H., 1979. {\it Astr.Astrophys.}\ {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPCO}{Convert Epoch to B or J} +{ + \action{Convert an epoch to Besselian or Julian to match another one.} + \call{D~=~sla\_EPCO (K0, K, E)} + +} +\args{GIVEN} +{ + \spec{K0}{C}{form of result: `B'=Besselian, `J'=Julian} \\ + \spec{K}{C}{form of given epoch: `B' or `J'} \\ + \spec{E}{D}{epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPCO}{D}{the given epoch converted as necessary} +} +\notes +{ + \begin{enumerate} + \item The result is always either equal to or very close to + the given epoch E. The routine is required only in + applications where punctilious treatment of heterogeneous + mixtures of star positions is necessary. + \item K0 and K are not validated. They are interpreted as follows: + \begin{itemize} + \item If K0 and K are the same, the result is E. + \item If K0 is `B' and K isn't, the conversion is J to B. + \item In all other cases, the conversion is B to J. + \end{itemize} + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EPJ}{MJD to Julian Epoch} +{ + \action{Convert Modified Julian Date to Julian Epoch.} + \call{D~=~sla\_EPJ (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EPJ}{D}{Julian Epoch} +} +\aref{Lieske, J.H., 1979.\ {\it Astr.Astrophys.}, {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPJ2D}{Julian Epoch to MJD} +{ + \action{Convert Julian Epoch to Modified Julian Date.} + \call{D~=~sla\_EPJ2D (EPJ)} +} +\args{GIVEN} +{ + \spec{EPJ}{D}{Julian Epoch} +} +\args{RETURNED} +{ + \spec{sla\_EPJ2D}{D}{Modified Julian Date (JD$-$2400000.5)} +} +\aref{Lieske, J.H., 1979.\ {\it Astr.Astrophys.}, {\bf 73}, 282.} +%----------------------------------------------------------------------- +\routine{SLA\_EPV}{Earth Position \& Velocity (high accuracy)} +{ + \action{Earth position and velocity, heliocentric and barycentric, + with respect to the Barycentric Celestial Reference System.} + \call{CALL sla\_EPV (DATE, PH, VH, PB, VB)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB Modified Julian Date (Note~1)} +} +\args{RETURNED} +{ + \spec{PH}{D(3)}{heliocentric \xyz, AU} \\ + \spec{VH}{D(3)}{heliocentric \xyzd, AU~d$^{-1}$} \\ + \spec{PB}{D(3)}{barycentric \xyz, AU} \\ + \spec{VB}{D(3)}{barycentric \xyzd, AU~d$^{-1}$} +} +\notes +{ + \begin{enumerate} + \item The date is TDB as MJD (=JD$-$2400000.5). TT can be used + instead of TDB in most applications. + \item The vectors are with respect to the Barycentric Celestial + Reference System (BCRS). Positions are in AU; velocities are in + AU per TDB day. + \item The routine is a {\it simplified solution}\/ from the planetary + theory VSOP2000 (X.\,Moisson, P.\,Bretagnon, 2001, Celes. Mechanics + \& Dyn. Astron., {\bf 80}, 3/4, 205-213) and is an adaptation of + original Fortran code supplied by P.\,Bretagnon (private + communication, 2000). + \item Comparisons over the time span 1900-2100 with this simplified + solution and the JPL DE405 ephemeris give the following results: + + \begin{tabular}{lllll} + & & RMS & max \\ + & Heliocentric: \\ + & ~~~~~position error & 3.7 & 11.2 & km \\ + & ~~~~~velocity error & 1.4 & ~5.0 & mm/s \\ + & Barycentric: \\ + & ~~~~~position error & 4.6 & 13.4 & km \\ + & ~~~~~velocity error & 1.4 & ~4.9 & mm/s + \end{tabular} + + The results deteriorate outside this time span. + \item The routine sla\_EVP is faster but less accurate. + The present routine targets the case where high + accuracy is more important + than CPU time, yet the extra complication of reading a + pre-computed ephemeris is not justified. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EQECL}{J2000 $\alpha,\delta$ to Ecliptic} +{ + \action{Transformation from J2000.0 equatorial coordinates to + ecliptic longitude and latitude.} + \call{CALL sla\_EQECL (DR, DD, DATE, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{J2000.0 mean \radec\ (radians)} \\ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{ecliptic longitude and latitude + (mean of date, IAU 1980 theory, radians)} +} +%----------------------------------------------------------------------- +\routine{SLA\_EQEQX}{Equation of the Equinoxes} +{ + \action{Equation of the equinoxes (IAU 1994).} + \call{D~=~sla\_EQEQX (DATE)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_EQEQX}{D}{The equation of the equinoxes (radians)} +} +\notes{ + \begin{enumerate} + \item The equation of the equinoxes is defined here as GAST~$-$~GMST: + it is added to a {\it mean}\/ sidereal time to give the + {\it apparent}\/ sidereal time. + \item The change from the classic ``textbook'' expression + $\Delta\psi\,cos\,\epsilon$ occurred with IAU Resolution C7, + Recommendation~3 (1994). The new formulation takes into + account cross-terms between the various precession and + nutation quantities, amounting to about 3~milliarcsec. + The transition from the old to the new model officially + took place on 1997 February~27. + \end{enumerate} +} +\aref{Capitaine, N.\ \& Gontier, A.-M.\ (1993), + {\it Astron. Astrophys.}, + {\bf 275}, 645-650.} +%----------------------------------------------------------------------- +\routine{SLA\_EQGAL}{J2000 $\alpha,\delta$ to Galactic} +{ + \action{Transformation from J2000.0 FK5 equatorial coordinates to + IAU 1958 galactic coordinates.} + \call{CALL sla\_EQGAL (DR, DD, DL, DB)} +} +\args{GIVEN} +{ + \spec{DR,DD}{D}{J2000.0 \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\anote{The equatorial coordinates are J2000.0 FK5. Use the routine + sla\_EG50 if conversion from B1950.0 FK4 coordinates is required.} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_ETRMS}{E-terms of Aberration} +{ + \action{Compute the E-terms vector -- the part of the annual + aberration which arises from the eccentricity of the + Earth's orbit.} + \call{CALL sla\_ETRMS (EP, EV)} +} +\args{GIVEN} +{ + \spec{EP}{D}{Besselian epoch} +} +\args{RETURNED} +{ + \spec{EV}{D(3)}{E-terms as $[\Delta x, \Delta y, \Delta z\,]$} +} +\anote{Note the use of the J2000 aberration constant (\arcsec{20}{49552}). + This is a reflection of the fact that the E-terms embodied in + existing star catalogues were computed from a variety of + aberration constants. Rather than adopting one of the old + constants the latest value is used here.} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989. {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989. {\it Astr.J.}\ {\bf 97}, 274. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EULER}{Rotation Matrix from Euler Angles} +{ + \action{Form a rotation matrix from the Euler angles -- three + successive rotations about specified Cartesian axes + (single precision).} + \call{CALL sla\_EULER (ORDER, PHI, THETA, PSI, RMAT)} +} +\args{GIVEN} +{ + \spec{ORDER}{C*(*)}{specifies about which axes the rotations occur} \\ + \spec{PHI}{R}{1st rotation (radians)} \\ + \spec{THETA}{R}{2nd rotation (radians)} \\ + \spec{PSI}{R}{3rd rotation (radians)} +} +\args{RETURNED} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\notes +{ + \begin{enumerate} + \item A rotation is positive when the reference frame rotates + anticlockwise as seen looking towards the origin from the + positive region of the specified axis. + \item The characters of ORDER define which axes the three successive + rotations are about. A typical value is `ZXZ', indicating that + RMAT is to become the direction cosine matrix corresponding to + rotations of the reference frame through PHI radians about the + old {\it z}-axis, followed by THETA radians about the resulting + {\it x}-axis, + then PSI radians about the resulting {\it z}-axis. In detail: + \begin{itemize} + \item The axis names can be any of the following, in any order or + combination: X, Y, Z, uppercase or lowercase, 1, 2, 3. Normal + axis labelling/numbering conventions apply; + the {\it xyz} ($\equiv123$) + triad is right-handed. Thus, the `ZXZ' example given above + could be written `zxz' or `313' (or even `ZxZ' or `3xZ'). + \item ORDER is terminated by length or by the first unrecognized + character. + \item Fewer than three rotations are acceptable, in which case + the later angle arguments are ignored. + \end{itemize} + \item Zero rotations produces the identity RMAT. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_EVP}{Earth Position \& Velocity} +{ + \action{Barycentric and heliocentric velocity and position of the Earth.} + \call{CALL sla\_EVP (DATE, DEQX, DVB, DPB, DVH, DPH)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as a Modified Julian Date + (JD$-$2400000.5)} \\ + \spec{DEQX}{D}{Julian Epoch ({\it e.g.}\ 2000D0) of mean equator and + equinox of the vectors returned. If DEQX~$<0$, + all vectors are referred to the mean equator and + equinox (FK5) of date DATE.} +} +\args{RETURNED} +{ + \spec{DVB}{D(3)}{barycentric \xyzd, AU~s$^{-1}$} \\ + \spec{DPB}{D(3)}{barycentric \xyz, AU} \\ + \spec{DVH}{D(3)}{heliocentric \xyzd, AU~s$^{-1}$} \\ + \spec{DPH}{D(3)}{heliocentric \xyz, AU} +} +\notes +{ + \begin{enumerate} + \item This routine is accurate enough for many purposes but faster + and more compact than the sla\_EPV routine. The maximum + deviations from the JPL~DE96 ephemeris are as follows: + \begin{itemize} + \item velocity (barycentric or heliocentric): 420~mm~s$^{-1}$ + \item position (barycentric): 6900~km + \item position (heliocentric): 1600~km + \end{itemize} + \item The routine is adapted from the BARVEL and BARCOR + subroutines of Stumpff (1980). + Most of the changes are merely cosmetic and do not affect + the results at all. However, some adjustments have been + made so as to give results that refer to the IAU 1976 + `FK5' equinox and precession, although the differences these + changes make relative to the results from Stumpff's original + `FK4' version are smaller than the inherent accuracy of the + algorithm. One minor shortcoming in the original routines + that has {\bf not} been corrected is that slightly better + numerical accuracy could be achieved if the various polynomial + evaluations were to be so arranged that the smallest terms were + computed first. + \end{enumerate} +} +\aref {Stumpff, P., 1980., {\it Astron.Astrophys.Suppl.Ser.}\ + {\bf 41}, 1-8.} +%----------------------------------------------------------------------- +\routine{SLA\_FITXY}{Fit Linear Model to Two \xy\ Sets} +{ + \action{Fit a linear model to relate two sets of \xy\ coordinates.} + \call{CALL sla\_FITXY (ITYPE, NP, XYE, XYM, COEFFS, J)} +} +\args{GIVEN} +{ + \spec{ITYPE}{I}{type of model: 4 or 6 (note 1)} \\ + \spec{NP}{I}{number of samples (note 2)} \\ + \spec{XYE}{D(2,NP)}{expected \xy\ for each sample} \\ + \spec{XYM}{D(2,NP)}{measured \xy\ for each sample} +} +\args{RETURNED} +{ + \spec{COEFFS}{D(6)}{coefficients of model (note 3)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK} \\ + \spec{}{}{\hspace{0.7em} $-$1 = illegal ITYPE} \\ + \spec{}{}{\hspace{0.7em} $-$2 = insufficient data} \\ + \spec{}{}{\hspace{0.7em} $-$3 = singular solution} +} +\notes +{ + \begin{enumerate} + \item ITYPE, which must be either 4 or 6, selects the type of model + fitted. Both allowed ITYPE values produce a model COEFFS which + consists of six coefficients, namely the zero points and, for + each of XE and YE, the coefficient of XM and YM. For ITYPE=6, + all six coefficients are independent, modelling squash and shear + as well as origin, scale, and orientation. However, ITYPE=4 + selects the {\it solid body rotation}\/ option; the model COEFFS + still consists of the same six coefficients, but now two of + them are used twice (appropriately signed). Origin, scale + and orientation are still modelled, but not squash or shear -- + the units of X and Y have to be the same. + \item For NC=4, NP must be at least 2. For NC=6, NP must be at + least 3. + \item The model is returned in the array COEFFS. Naming the + six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms {\it measured}\/ coordinates + $[x_{m},y_{m}\,]$ into {\it expected}\/ coordinates + $[x_{e},y_{e}\,]$ as follows: + \begin{verse} + $x_{e} = a + bx_{m} + cy_{m}$ \\ + $y_{e} = d + ex_{m} + fy_{m}$ + \end{verse} + For the {\it solid body rotation}\/ option (ITYPE=4), the + magnitudes of $b$ and $f$, and of $c$ and $e$, are equal. The + signs of these coefficients depend on whether there is a + sign reversal between $[x_{e},y_{e}]$ and $[x_{m},y_{m}]$; + fits are performed + with and without a sign reversal and the best one chosen. + \item Error status values J=$-$1 and $-$2 leave COEFFS unchanged; + if J=$-$3 COEFFS may have been changed. + \item See also sla\_PXY, sla\_INVF, sla\_XY2XY, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK425}{FK4 to FK5} +{ + \action{Convert B1950.0 FK4 star data to J2000.0 FK5. + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU~1976, FK5, Fricke system. The precepts + of Smith~{\it et~al.}\ (see reference~1) are followed, + using the implementation + by Yallop~{\it et~al.}\ (reference~2) of a matrix method + due to Standish. + Kinoshita's development of Andoyer's post-Newcomb precession is + used. The numerical constants from + Seidelmann~{\it et~al.}\ (reference~3) are used canonically.} + \call{CALL sla\_FK425 (\vtop{ + \hbox{R1950,D1950,DR1950,DD1950,P1950,V1950,} + \hbox{R2000,D2000,DR2000,DD2000,P2000,V2000)}}} +} +\args{GIVEN} +{ + \spec{R1950}{D}{B1950.0 $\alpha$ (radians)} \\ + \spec{D1950}{D}{B1950.0 $\delta$ (radians)} \\ + \spec{DR1950}{D}{B1950.0 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 proper motion in $\delta$ + (radians per tropical year)} \\ + \spec{P1950}{D}{B1950.0 parallax (arcsec)} \\ + \spec{V1950}{D}{B1950.0 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\args{RETURNED} +{ + \spec{R2000}{D}{J2000.0 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 $\delta$ (radians)} \\ + \spec{DR2000}{D}{J2000.0 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD2000}{D}{J2000.0 proper motion in $\delta$ + (radians per Julian year)} \\ + \spec{P2000}{D}{J2000.0 parallax (arcsec)} \\ + \spec{V2000}{D}{J2000.0 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or after FK425 + is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch J2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK45Z, sla\_FK524, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK45Z}{FK4 to FK5, no P.M. or Parallax} +{ + \action{Convert B1950.0 FK4 star data to J2000.0 FK5 assuming zero + proper motion in the FK5 frame. + This routine converts stars from the old, Bessel-Newcomb, FK4 + system to the new, IAU~1976, FK5, Fricke system, in such a + way that the FK5 proper motion is zero. Because such a star + has, in general, a non-zero proper motion in the FK4 system, + the routine requires the epoch at which the position in the + FK4 system was determined. The method is from appendix~2 of + reference~1, but using the constants of reference~4.} + \call{CALL sla\_FK45Z (R1950, D1950, BEPOCH, R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R1950}{D}{B1950.0 FK4 $\alpha$ at epoch BEPOCH (radians)} \\ + \spec{D1950}{D}{B1950.0 FK4 $\delta$ at epoch BEPOCH (radians)} \\ + \spec{BEPOCH}{D}{Besselian epoch ({\it e.g.}\ 1979.3D0)} +} +\args{RETURNED} +{ + \spec{R2000}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 FK5 $\delta$ (radians)} +} +\notes +{ + \begin{enumerate} + \item The epoch BEPOCH is strictly speaking Besselian, but + if a Julian epoch is supplied the result will be + affected only to a negligible extent. + \item Conversion from Besselian epoch 1950.0 to Julian epoch + 2000.0 only is provided for. Conversions involving other + epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or + after FK45Z is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK425, sla\_FK524, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Aoki, S., {\it et al.}, 1983.\ {\it Astr.Astrophys.}, {\bf 128}, 263. + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK524}{FK5 to FK4} +{ + \action{Convert J2000.0 FK5 star data to B1950.0 FK4. + This routine converts stars from the new, IAU~1976, FK5, Fricke + system, to the old, Bessel-Newcomb, FK4 system. + The precepts of Smith~{\it et~al.}\ (reference~1) are followed, + using the implementation by Yallop~{\it et~al.}\ (reference~2) + of a matrix method due to Standish. Kinoshita's development of + Andoyer's post-Newcomb precession is used. The numerical + constants from Seidelmann~{\it et~al.}\ (reference~3) are + used canonically.} + \call{CALL sla\_FK524 (\vtop{ + \hbox{R2000, D2000, DR2000, DD2000, P2000, V2000,} + \hbox{R1950, D1950, DR1950, DD1950, P1950, V1950)}}} +} +\args{GIVEN} +{ + \spec{R2000}{D}{J2000.0 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 $\delta$ (radians)} \\ + \spec{DR2000}{D}{J2000.0 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD2000}{D}{J2000.0 proper motion in $\delta$ + (radians per Julian year)} \\ + \spec{P2000}{D}{J2000.0 parallax (arcsec)} \\ + \spec{V2000}{D}{J2000 radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\args{RETURNED} +{ + \spec{R1950}{D}{B1950.0 $\alpha$ (radians)} \\ + \spec{D1950}{D}{B1950.0 $\delta$ (radians)} \\ + \spec{DR1950}{D}{B1950.0 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 proper motion in $\delta$ + (radians per tropical year)} \\ + \spec{P1950}{D}{B1950.0 parallax (arcsec)} \\ + \spec{V1950}{D}{radial velocity (km~s$^{-1}$, +ve = moving away)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Note that conversion from Julian epoch 2000.0 to Besselian + epoch 1950.0 only is provided for. Conversions involving + other epochs will require use of the appropriate precession, + proper motion, and E-terms routines before and/or after + FK524 is called. + \item In the FK4 catalogue the proper motions of stars within + $10^{\circ}$ of the poles do not include the {\it differential + E-terms}\/ effect and should, strictly speaking, be handled + in a different manner from stars outside these regions. + However, given the general lack of homogeneity of the star + data available for routine astrometry, the difficulties of + handling positions that may have been determined from + astrometric fields spanning the polar and non-polar regions, + the likelihood that the differential E-terms effect was not + taken into account when allowing for proper motion in past + astrometry, and the undesirability of a discontinuity in + the algorithm, the decision has been made in this routine to + include the effect of differential E-terms on the proper + motions for all stars, whether polar or not. At epoch 2000, + and measuring on the sky rather than in terms of $\Delta\alpha$, + the errors resulting from this simplification are less than + 1~milliarcsecond in position and 1~milliarcsecond per + century in proper motion. + \item See also sla\_FK425, sla\_FK45Z, sla\_FK54Z. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Smith, C.A.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 265. + \item Yallop, B.D.\ {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 274. + \item Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK52H}{FK5 to Hipparcos} +{ + \action{Transform an FK5 (J2000) position and proper motion + into the frame of the Hipparcos catalogue.} + \call{CALL sla\_FK52H (R5, D5, DR5, DD5, RH, DH, DRH, DDH)} +} +\args{GIVEN} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{J2000.0 FK5 proper motion in $\delta$ + (radians per Julian year)} +} +\args{RETURNED} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{DRH}{D}{Hipparcos proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DDH}{D}{Hipparcos proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK5HZ, sla\_H2FK5, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_FK54Z}{FK5 to FK4, no P.M. or Parallax} +{ + \action{Convert a J2000.0 FK5 star position to B1950.0 FK4 assuming + FK5 zero proper motion and parallax. + This routine converts star positions from the new, IAU~1976, + FK5, Fricke system to the old, Bessel-Newcomb, FK4 system.} + \call{CALL sla\_FK54Z (R2000, D2000, BEPOCH, R1950, D1950, DR1950, DD1950)} +} +\args{GIVEN} +{ + \spec{R2000}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D2000}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{BEPOCH}{D}{Besselian epoch ({\it e.g.}\ 1950D0)} +} +\args{RETURNED} +{ + \spec{R1950}{D}{B1950.0 FK4 $\alpha$ at epoch BEPOCH (radians)} \\ + \spec{D1950}{D}{B1950.0 FK4 $\delta$ at epoch BEPOCH (radians)} \\ + \spec{DR1950}{D}{B1950.0 FK4 proper motion in $\alpha$ + (radians per tropical year)} \\ + \spec{DD1950}{D}{B1950.0 FK4 proper motion in $\delta$ + (radians per tropical year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item Conversion from Julian epoch 2000.0 to Besselian epoch 1950.0 + only is provided for. Conversions involving other epochs will + require use of the appropriate precession routines before and + after this routine is called. + \item Unlike in the sla\_FK524 routine, the FK5 proper motions, the + parallax and the radial velocity are presumed zero. + \item It was the intention that FK5 should be a close approximation + to an inertial frame, so that distant objects have zero proper + motion; such objects have (in general) non-zero proper motion + in FK4, and this routine returns those {\it fictitious proper + motions}. + \item The position returned by this routine is in the B1950 + reference frame but at Besselian epoch BEPOCH. For + comparison with catalogues the BEPOCH argument will + frequently be 1950D0. + \item See also sla\_FK425, sla\_FK45Z, sla\_FK524. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_FK5HZ}{FK5 to Hipparcos, no P.M.} +{ + \action{Transform an FK5 (J2000) star position into the frame of the + Hipparcos catalogue, assuming zero Hipparcos proper motion.} + \call{CALL sla\_FK5HZ (R5, D5, EPOCH, RH, DH)} +} +\args{GIVEN} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{EPOCH}{D}{Julian epoch (TDB)} +} +\args{RETURNED} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK52H, sla\_H2FK5, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_FLOTIN}{Decode a Real Number} +{ + \action{Convert free-format input into single precision floating point.} + \call{CALL sla\_FLOTIN (STRING, NSTRT, RESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{RESLT}{R}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{RESLT}{R}{result} \\ + \spec{JFLAG}{I}{status: $-$1~=~$-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_FLOTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space, and lowercase characters are + interpreted as uppercase. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n.n x \pm n$, + where $\pm$ is a sign + character `+' or `$-$', $n$ means a string of decimal digits, + `.' is a decimal point, and $x$, which indicates an exponent, + means `D' or `E'. Various combinations of these fields can be + omitted, and embedded blanks are permissible in certain places. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Embedded spaces are allowed only after +, $-$, D or E, + and after the decimal point if the first sequence of + digits is absent. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9,.,D,E or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_FLOTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 13, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item Both signs are optional. The default is +. + \item The mantissa $n.n$ defaults to unity. + \item The exponent $x\!\pm\!n$ defaults to `E0'. + \item The strings of decimal digits may be of any length. + \item The decimal point is optional for whole numbers. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$,0-9,.,D or E, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and RESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_FLOTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_FLOTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item a +, $-$, D or E is left unsatisfied; or + \item the decimal point is present without at least + one decimal digit before or after it; or + \item an exponent more than 100 has been presented. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. This + may be after the point at which a more sophisticated + program could have detected the error. For example, + sla\_FLOTIN does not detect that `1E999' is unacceptable + (on a computer where this is so) + until the entire number has been decoded. + \item Certain highly unlikely combinations of mantissa and + exponent can cause arithmetic faults during the + decode, in some cases despite the fact that they + together could be construed as a valid number. + \item Decoding is left to right, one pass. + \item See also sla\_DFLTIN and sla\_INTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GALEQ}{Galactic to J2000 $\alpha,\delta$} +{ + \action{Transformation from IAU 1958 galactic coordinates + to J2000.0 FK5 equatorial coordinates.} + \call{CALL sla\_GALEQ (DL, DB, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{J2000.0 \radec} +} +\notes +{ + \begin{enumerate} + \item All arguments are in radians. + \item The equatorial coordinates are J2000.0 FK5. Use the routine + sla\_GE50 if conversion to B1950.0 FK4 coordinates is + required. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GALSUP}{Galactic to Supergalactic} +{ + \action{Transformation from IAU 1958 galactic coordinates to + de Vaucouleurs supergalactic coordinates.} + \call{CALL sla\_GALSUP (DL, DB, DSL, DSB)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\args{RETURNED} +{ + \spec{DSL,DSB}{D}{supergalactic longitude and latitude (radians)} +} +\refs +{ + \begin{enumerate} + \item de Vaucouleurs, de Vaucouleurs, \& Corwin, {\it Second Reference + Catalogue of Bright Galaxies}, U.Texas, p8. + \item Systems \& Applied Sciences Corp., documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + \end{enumerate} + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is $l^{I\!I}=137.37$.) +} +%----------------------------------------------------------------------- +\routine{SLA\_GE50}{Galactic to B1950 $\alpha,\delta$} +{ + \action{Transformation from IAU 1958 galactic coordinates to + B1950.0 FK4 equatorial coordinates.} + \call{CALL sla\_GE50 (DL, DB, DR, DD)} +} +\args{GIVEN} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal} +} +\args{RETURNED} +{ + \spec{DR,DD}{D}{B1950.0 \radec} +} +\notes +{ + \begin{enumerate} + \item All arguments are in radians. + \item The equatorial coordinates are B1950.0 FK4. Use the + routine sla\_GALEQ if conversion to J2000.0 FK5 coordinates + is required. + \end{enumerate} +} +\aref{Blaauw {\it et al.}, 1960, {\it Mon.Not.R.astr.Soc.}, + {\bf 121}, 123.} +%----------------------------------------------------------------------- +\routine{SLA\_GEOC}{Geodetic to Geocentric} +{ + \action{Convert geodetic position to geocentric.} + \call{CALL sla\_GEOC (P, H, R, Z)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude (geodetic, radians)} \\ + \spec{H}{D}{height above reference spheroid (geodetic, metres)} +} +\args{RETURNED} +{ + \spec{R}{D}{distance from Earth axis (AU)} \\ + \spec{Z}{D}{distance from plane of Earth equator (AU)} +} +\notes +{ + \begin{enumerate} + \item Geocentric latitude can be obtained by evaluating {\tt ATAN2(Z,R)}. + \item IAU 1976 constants are used. + \end{enumerate} +} +\aref{Green, R.M., 1985.\ {\it Spherical Astronomy}, Cambridge U.P., p98.} +%----------------------------------------------------------------------- +\routine{SLA\_GMST}{UT to GMST} +{ + \action{Conversion from universal time UT1 to Greenwich mean + sidereal time.} + \call{D~=~sla\_GMST (UT1)} +} +\args{GIVEN} +{ + \spec{UT1}{D}{universal time (strictly UT1) expressed as + modified Julian Date (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{sla\_GMST}{D}{Greenwich mean sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item The IAU~1982 expression + (see page~S15 of the 1984 {\it Astronomical + Almanac})\/ is used, but rearranged to reduce rounding errors. This + expression is always described as giving the GMST at $0^{\rm h}$UT; + in fact, it gives the difference between the + GMST and the UT, which happens to equal the GMST (modulo + 24~hours) at $0^{\rm h}$UT each day. In sla\_GMST, the + entire UT is used directly as the argument for the + canonical formula, and the fractional part of the UT is + added separately; note that the factor $1.0027379\cdots$ does + not appear. + \item See also the routine sla\_GMSTA, which + delivers better numerical + precision by accepting the UT date and time as separate arguments. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GMSTA}{UT to GMST (extra precision)} +{ + \action{Conversion from universal time UT1 to Greenwich mean + sidereal time, with rounding errors minimized.} + \call{D~=~sla\_GMSTA (DATE, UT1)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{UT1 date as Modified Julian Date (integer part + of JD$-$2400000.5)} \\ + \spec{UT1}{D}{UT1 time (fraction of a day)} +} +\args{RETURNED} +{ + \spec{sla\_GMST}{D}{Greenwich mean sidereal time (radians)} +} +\notes +{ + \begin{enumerate} + \item The algorithm is derived from the IAU 1982 expression + (see page~S15 of the 1984 Astronomical Almanac). + \item There is no restriction on how the UT is apportioned between the + DATE and UT1 arguments. Either of the two arguments could, for + example, be zero and the entire date\,+\,time supplied in the other. + However, the routine is designed to deliver maximum accuracy when + the DATE argument is a whole number and the UT1 argument + lies in the range $[\,0,\,1\,]$, or {\it vice versa}. + \item See also the routine sla\_GMST, which accepts the UT1 as a single + argument. Compared with sla\_GMST, the extra numerical precision + delivered by the present routine is unlikely to be important in + an absolute sense, but may be useful when critically comparing + algorithms and in applications where two sidereal times close + together are differenced. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_GRESID}{Gaussian Residual} +{ + \action{Generate pseudo-random normal deviate or {\it Gaussian residual}.} + \call{R~=~sla\_GRESID (S)} +} +\args{GIVEN} +{ + \spec{S}{R}{standard deviation} +} +\notes +{ + \begin{enumerate} + \item The results of many calls to this routine will be + normally distributed with mean zero and standard deviation S. + \item The Box-Muller algorithm is used. + \item The implementation is machine-dependent. + \end{enumerate} +} +\aref{Ahrens \& Dieter, 1972.\ {\it Comm.A.C.M.}\ {\bf 15}, 873.} +%----------------------------------------------------------------------- +\routine{SLA\_H2E}{Az,El to $h,\delta$} +{ + \action{Horizon to equatorial coordinates + (single precision).} + \call{CALL sla\_H2E (AZ, EL, PHI, HA, DEC)} +} +\args{GIVEN} +{ + \spec{AZ}{R}{azimuth (radians)} \\ + \spec{EL}{R}{elevation (radians)} \\ + \spec{PHI}{R}{latitude (radians)} +} +\args{RETURNED} +{ + \spec{HA}{R}{hour angle (radians)} \\ + \spec{DEC}{R}{declination (radians)} +} +\notes +{ + \begin{enumerate} + \item The sign convention for azimuth is north zero, east $+\pi/2$. + \item HA is returned in the range $\pm\pi$. Declination is returned + in the range $\pm\pi$. + \item The latitude is (in principle) geodetic. In critical + applications, corrections for polar motion should be applied + (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of elevation in order to produce the required + type of \hadec. In particular, it may be important to + distinguish between the elevation as affected by refraction, + which will yield the {\it observed} \hadec, and the elevation + {\it in vacuo}, which will yield the {\it topocentric} + \hadec. If the + effects of diurnal aberration can be neglected, the + topocentric \hadec\ may be used as an approximation to the + {\it apparent} \hadec. + \item No range checking of arguments is carried out. + \item In applications which involve many such calculations, rather + than calling the present routine it will be more efficient to + use inline code, having previously computed fixed terms such + as sine and cosine of latitude. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_H2FK5}{Hipparcos to FK5} +{ + \action{Transform a Hipparcos star position and proper motion + into the FK5 (J2000) frame.} + \call{CALL sla\_H2FK5 (RH, DH, DRH, DDH, R5, D5, DR5, DD5)} +} +\args{GIVEN} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{DRH}{D}{Hipparcos proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DDH}{D}{Hipparcos proper motion in $\delta$ + (radians per Julian year)} +} +\args{RETURNED} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{FK5 J2000.0 proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item See also sla\_FK52H, sla\_FK5HZ, sla\_HFK5Z. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_HFK5Z}{Hipparcos to FK5, no P.M.} +{ + \action{Transform a Hipparcos star position + into the FK5 (J2000) frame assuming zero Hipparcos proper motion.} + \call{CALL sla\_HFK5Z (RH, DH, EPOCH, R5, D5, DR5, DD5)} +} +\args{GIVEN} +{ + \spec{RH}{D}{Hipparcos $\alpha$ (radians)} \\ + \spec{DH}{D}{Hipparcos $\delta$ (radians)} \\ + \spec{EPOCH}{D}{Julian epoch (TDB)} +} +\args{RETURNED} +{ + \spec{R5}{D}{J2000.0 FK5 $\alpha$ (radians)} \\ + \spec{D5}{D}{J2000.0 FK5 $\delta$ (radians)} \\ + \spec{DR5}{D}{J2000.0 FK5 proper motion in $\alpha$ + (radians per Julian year)} \\ + \spec{DD5}{D}{FK5 J2000.0 proper motion in $\delta$ + (radians per Julian year)} +} +\notes +{ + \begin{enumerate} + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item The FK5 to Hipparcos + transformation consists of a pure rotation and spin; + zonal errors in the FK5 catalogue are not taken into account. + \item The adopted epoch J2000.0 FK5 to Hipparcos orientation and spin + values are as follows (see reference): + + \vspace{2ex} + + ~~~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & + \multicolumn{1}{|c}{\it orientation} & + \multicolumn{1}{|c|}{\it ~~~spin~~~} \\ \hline + $x$ & $-19.9$~~~~ & ~$-0.30$~~ \\ + $y$ & $-9.1$~~~~ & ~$+0.60$~~ \\ + $z$ & $+22.9$~~~~ & ~$+0.70$~~ \\ \hline + & {\it mas}~~~~~ & ~{\it mas/y}~ \\ \hline + \end{tabular} + + \vspace{3ex} + + These orientation and spin components are interpreted as + {\it axial vectors.} An axial vector points at the pole of + the rotation and its length is the amount of rotation in radians. + \item It was the intention that Hipparcos should be a close + approximation to an inertial frame, so that distant objects + have zero proper motion; such objects have (in general) + non-zero proper motion in FK5, and this routine returns those + {\it fictitious proper motions.} + \item The position returned by this routine is in the FK5 J2000 + reference frame but at Julian epoch EPOCH. + \item See also sla\_FK52H, sla\_FK5HZ, sla\_H2FK5. + \end{enumerate} +} +\aref {Feissel, M.\ \& Mignard, F., 1998., {\it Astron.Astrophys.}\ + {\bf 331}, L33-L36.} +%----------------------------------------------------------------------- +\routine{SLA\_IMXV}{Apply 3D Reverse Rotation} +{ + \action{Multiply a 3-vector by the inverse of a rotation + matrix (single precision).} + \call{CALL sla\_IMXV (RM, VA, VB)} +} +\args{GIVEN} +{ + \spec{RM}{R(3,3)}{rotation matrix} \\ + \spec{VA}{R(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{R(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$^{T}\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix RM. + \item The main function of this routine is apply an inverse + rotation; under these circumstances, ${\bf M}$ is + {\it orthogonal}, with its inverse the same as its transpose. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly on the VAX and many other systems even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_INTIN}{Decode an Integer Number} +{ + \action{Convert free-format input into an integer.} + \call{CALL sla\_INTIN (STRING, NSTRT, IRESLT, JFLAG)} +} +\args{GIVEN} +{ + \spec{STRING}{C}{string containing number to be decoded} \\ + \spec{NSTRT}{I}{pointer to where decoding is to commence} \\ + \spec{IRESLT}{I}{current value of result} +} +\args{RETURNED} +{ + \spec{NSTRT}{I}{advanced to next number} \\ + \spec{IRESLT}{I}{result} \\ + \spec{JFLAG}{I}{status: $-$1 = $-$OK, 0~=~+OK, 1~=~null result, 2~=~error} +} +\notes +{ + \begin{enumerate} + \item The reason sla\_INTIN has separate `OK' status values + for + and $-$ is to enable minus zero to be detected. + This is of crucial importance + when decoding mixed-radix numbers. For example, an angle + expressed as degrees, arcminutes and arcseconds may have a + leading minus sign but a zero degrees field. + \item A TAB is interpreted as a space. {\it n.b.}\ The test for TAB is + ASCII-specific. + \item The basic format is the sequence of fields $\pm n$, + where $\pm$ is a sign + character `+' or `$-$', and $n$ means a string of decimal digits. + \item Spaces: + \begin{itemize} + \item Leading spaces are ignored. + \item Spaces between the sign and the number are allowed. + \item Trailing spaces are ignored; the first signifies + end of decoding and subsequent ones are skipped. + \end{itemize} + \item Delimiters: + \begin{itemize} + \item Any character other than +,$-$,0-9 or space may be + used to signal the end of the number and terminate decoding. + \item Comma is recognized by sla\_INTIN as a special case; it + is skipped, leaving the pointer on the next character. See + 9, below. + \item Decoding will in all cases terminate if end of string + is reached. + \end{itemize} + \item The sign is optional. The default is +. + \item A {\it null result}\/ occurs when the string of characters + being decoded does not begin with +,$-$ or 0-9, or + consists entirely of spaces. When this condition is + detected, JFLAG is set to 1 and IRESLT is left untouched. + \item NSTRT = 1 for the first character in the string. + \item On return from sla\_INTIN, NSTRT is set ready for the next + decode -- following trailing blanks and any comma. If a + delimiter other than comma is being used, NSTRT must be + incremented before the next call to sla\_INTIN, otherwise + all subsequent calls will return a null result. + \item Errors (JFLAG=2) occur when: + \begin{itemize} + \item there is a + or $-$ but no number; or + \item the number is greater than $2^{31}-1$. + \end{itemize} + \item When an error has been detected, NSTRT is left + pointing to the character following the last + one used before the error came to light. + \item See also sla\_FLOTIN and sla\_DFLTIN. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_INVF}{Invert Linear Model} +{ + \action{Invert a linear model of the type produced by the + sla\_FITXY routine.} + \call{CALL sla\_INVF (FWDS,BKWDS,J)} +} +\args{GIVEN} +{ + \spec{FWDS}{D(6)}{model coefficients} +} +\args{RETURNED} +{ + \spec{BKWDS}{D(6)}{inverse model} \\ + \spec{J}{I}{status: 0 = OK, $-$1 = no inverse} +} +\notes +{ + \begin{enumerate} + \item The models relate two sets of \xy\ coordinates as follows. + Naming the six elements of FWDS $a,b,c,d,e$ \& $f$, + where two sets of coordinates $[x_{1},y_{1}]$ and + $[x_{2},y_{2}\,]$ are related thus: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + The present routine generates a new set of coefficients + $p,q,r,s,t$ \& $u$ (the array BKWDS) such that: + \begin{verse} + $x_{1} = p + qx_{2} + ry_{2}$ \\ + $y_{1} = s + tx_{2} + uy_{2}$ + \end{verse} + \item Two successive calls to this routine will deliver a set + of coefficients equal to the starting values. + \item To comply with the ANSI Fortran 77 standard, FWDS and BKWDS must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly with many Fortran compilers even + if this rule is violated, something that is {\bf not}, however, + recommended. + \item See also sla\_FITXY, sla\_PXY, sla\_XY2XY, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_KBJ}{Select Epoch Prefix} +{ + \action{Select epoch prefix `B' or `J'.} + \call{CALL sla\_KBJ (JB, E, K, J)} +} +\args{GIVEN} +{ + \spec{JB}{I}{sla\_DBJIN prefix status: 0=none, 1=`B', 2=`J'} \\ + \spec{E}{D}{epoch -- Besselian or Julian} +} +\args{RETURNED} +{ + \spec{K}{C}{`B' or `J'} \\ + \spec{J}{I}{status: 0=OK} +} +\anote{The routine is mainly intended for use in conjunction with the + sla\_DBJIN routine. If the value of JB indicates that an explicit + B or J prefix was detected by sla\_DBJIN, a `B' or `J' + is returned to match. If JB indicates that no explicit B or J + was supplied, the choice is made on the basis of the epoch + itself; B is assumed for E $<1984$, otherwise J.} +%----------------------------------------------------------------------- +\routine{SLA\_M2AV}{Rotation Matrix to Axial Vector} +{ + \action{From a rotation matrix, determine the corresponding axial vector + (single precision).} + \call{CALL sla\_M2AV (RMAT, AXVEC)} +} +\args{GIVEN} +{ + \spec{RMAT}{R(3,3)}{rotation matrix} +} +\args{RETURNED} +{ + \spec{AXVEC}{R(3)}{axial vector (radians)} +} +\notes +{ + \begin{enumerate} + \item A rotation matrix describes a rotation about some arbitrary axis, + called the Euler axis. The {\it axial vector} returned by + this routine has the same direction as the Euler axis, and its + magnitude is the amount of rotation in radians. + \item The magnitude and direction of the axial vector can be separated + by means of the routine sla\_VN. + \item The reference frame rotates clockwise as seen looking along + the axial vector from the origin. + \item If RMAT is null, so is the result. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAP}{Mean to Apparent} +{ + \action{Transform star \radec\ from mean place to geocentric apparent. + The reference frames and time scales used are post IAU~1976.} + \call{CALL sla\_MAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{PR,PD}{D}{proper motions: \radec\ changes per Julian year} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{EQ}{D}{epoch and equinox of star data (Julian)} \\ + \spec{DATE}{D}{TDB for apparent place (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item EQ is the Julian epoch specifying both the reference + frame and the epoch of the position -- usually 2000. + For positions where the epoch and equinox are + different, use the routine sla\_PM to apply proper + motion corrections before using this routine. + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are per year rather than per century. + \item This routine may be wasteful for some applications + because it recomputes the Earth position/velocity and + the precession-nutation matrix each time, and because + it allows for parallax and proper motion. Where + multiple transformations are to be carried out for one + epoch, a faster method is to call the sla\_MAPPA routine + once and then either the sla\_MAPQK routine (which includes + parallax and proper motion) or sla\_MAPQKZ (which assumes + zero parallax and FK5 proper motion). + \item The accuracy, starting from ICRS star data, + is limited to about 1~mas by the + precession-nutation model used, SF2001. + A different precession-nutation model + can be introduced by using sla\_MAPPA and sla\_MAPQK (see + the previous note) and replacing the precession-nutation + matrix into the parameter array directly. + \item The accuracy is further limited by the routine sla\_EVP, called + by sla\_MAPPA, which computes the Earth position and + velocity using the methods of Stumpff. The maximum + error is about 0.3~milliarcsecond. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPPA}{Mean to Apparent Parameters} +{ + \action{Compute star-independent parameters in preparation for + conversions between mean place and geocentric apparent place. + The parameters produced by this routine are required in the + parallax, light deflection, aberration, and precession-nutation + parts of the mean/apparent transformations. + The reference frames and time scales used are post IAU~1976.} + \call{CALL sla\_MAPPA (EQ, DATE, AMPRMS)} +} +\args{GIVEN} +{ + \spec{EQ}{D}{epoch of mean equinox to be used (Julian)} \\ + \spec{DATE}{D}{TDB (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession-nutation $3\times3$ matrix} +} +\notes +{ + \begin{enumerate} + \item For DATE, the distinction between the required TDB and TT + is always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are + (in essence) referred to + the mean equinox and equator of epoch EQ. For + EQ=2000D0, they are referred to the ICRS. + \item The parameters produced by this routine are used by + sla\_MAPQK, sla\_MAPQKZ and sla\_AMPQK. + \item The accuracy, starting from ICRS star data, + is limited to about 1~mas by the precession-nutation + model used, SF2001. A different precession-nutation model + can be introduced by first calling the present routine + and then replacing the precession-nutation + matrix in AMPRMS(13-21) directly. + \item A further limit to the accuracy of routines using the + parameter array AMPRMS is + imposed by the routine sla\_EVP, used here to compute the + Earth position and velocity by the methods of Stumpff. + The maximum error in the resulting aberration corrections is + about 0.3 milliarcsecond. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPQK}{Quick Mean to Apparent} +{ + \action{Quick mean to apparent place: transform a star \radec\ from + mean place to geocentric apparent place, given the + star-independent parameters. The reference frames and + time scales used are post IAU~1976.} + \call{CALL sla\_MAPQK (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{PR,PD}{D}{proper motions: \radec\ changes per Julian year} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession-nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RA,DA}{D }{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item Use of this routine is appropriate when efficiency is important + and where many star positions, all referred to the same equator + and equinox, are to be transformed for one epoch. The + star-independent parameters can be obtained by calling the + sla\_MAPPA routine. + \item If the parallax and proper motions are zero the sla\_MAPQKZ + routine can be used instead. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are + (in essence) referred to + the mean equinox and equator of epoch EQ. For + EQ=2000D0, they are referred to the ICRS. + \item Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about \arcseci{920} of the + centre of the Sun's disc. The term has a maximum value of + about \arcsec{1}{85} at this radius, and decreases to zero as + the centre of the disc is approached. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MAPQKZ}{Quick Mean-Appt, no PM {\it etc.}} +{ + \action{Quick mean to apparent place: transform a star \radec\ from + mean place to geocentric apparent place, given the + star-independent parameters, and assuming zero parallax + and FK5 proper motion. + The reference frames and time scales used are post IAU~1976.} + \call{CALL sla\_MAPQKZ (RM, DM, AMPRMS, RA, DA)} +} +\args{GIVEN} +{ + \spec{RM,DM}{D}{mean \radec\ (radians)} \\ + \spec{AMPRMS}{D(21)}{star-independent mean-to-apparent parameters:} \\ + \specel {(1)} {time interval for proper motion (Julian years)} \\ + \specel {(2-4)} {barycentric position of the Earth (AU)} \\ + \specel {(5-7)} {heliocentric direction of the Earth (unit vector)} \\ + \specel {(8)} {(gravitational radius of + Sun)$\times 2 / $(Sun-Earth distance)} \\ + \specel {(9-11)} {{\bf v}: barycentric Earth velocity in units of c} \\ + \specel {(12)} {$\sqrt{1-\left|\mbox{\bf v}\right|^2}$} \\ + \specel {(13-21)} {precession-nutation $3\times3$ matrix} +} +\args{RETURNED} +{ + \spec{RA,DA}{D}{apparent \radec\ (radians)} +} +\notes +{ + \begin{enumerate} + \item Use of this routine is appropriate when efficiency is important + and where many star positions, all with parallax and proper + motion either zero or already allowed for, and all referred to + the same equator and equinox, are to be transformed for one + epoch. The star-independent parameters can be obtained by + calling the sla\_MAPPA routine. + \item The corresponding routine for the case of non-zero parallax + and FK5 proper motion is sla\_MAPQK. + \item The vectors AMPRMS(2-4) and AMPRMS(5-7) are + (in essence) referred to + the mean equinox and equator of epoch EQ. For + EQ=2000D0, they are referred to the ICRS. + \item Strictly speaking, the routine is not valid for solar-system + sources, though the error will usually be extremely small. + However, to prevent gross errors in the case where the + position of the Sun is specified, the gravitational + deflection term is restrained within about \arcseci{920} of the + centre of the Sun's disc. The term has a maximum value of + about \arcsec{1}{85} at this radius, and decreases to zero as + the centre of the disc is approached. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr.Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_MOON}{Approx Moon Pos/Vel} +{ + \action{Approximate geocentric position and velocity of the Moon + (single precision).} + \call{CALL sla\_MOON (IY, ID, FD, PV)} +} +\args{GIVEN} +{ + \spec{IY}{I}{year} \\ + \spec{ID}{I}{day in year (1 = Jan 1st)} \\ + \spec{FD}{R }{fraction of day} +} +\args{RETURNED} +{ + \spec{PV}{R(6)}{Moon \xyzxyzd, mean equator and equinox of + date (AU, AU~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item The date and time is TDB (loosely ET) in a Julian calendar + which has been aligned to the ordinary Gregorian + calendar for the interval 1900 March 1 to 2100 February 28. + The year and day can be obtained by calling sla\_CALYD or + sla\_CLYD. + \item The position is accurate to better than 0.5~arcminute + in direction and 1000~km in distance. The velocity + is accurate to better than \arcsec{0}{5} per hour in direction + and 4~metres per second in distance. (RMS figures with respect + to JPL DE200 for the interval 1960-2025 are \arcseci{14} and + \arcsec{0}{2} per hour in longitude, \arcseci{9} and \arcsec{0}{2} + per hour in latitude, 350~km and 2~metres per second in distance.) + Note that the distance accuracy is comparatively poor because this + routine is principally intended for computing topocentric direction. + \item This routine is only a partial implementation of the original + Meeus algorithm (reference below), which offers 4 times the + accuracy in direction and 20 times the accuracy in distance + when fully implemented (as it is in sla\_DMOON). + \end{enumerate} +} +\aref{Meeus, {\it l'Astronomie}, June 1984, p348.} +%----------------------------------------------------------------------- +\routine{SLA\_MXM}{Multiply $3\times3$ Matrices} +{ + \action{Product of two $3\times3$ matrices (single precision).} + \call{CALL sla\_MXM (A, B, C)} +} +\args{GIVEN} +{ + \spec{A}{R(3,3)}{matrix {\bf A}} \\ + \spec{B}{R(3,3)}{matrix {\bf B}} +} +\args{RETURNED} +{ + \spec{C}{R(3,3)}{matrix result: {\bf A}$\times${\bf B}} +} +\anote{To comply with the ANSI Fortran 77 standard, A, B and C must + be different arrays. The routine is, in fact, coded + so as to work properly with many Fortran compilers even + if this rule is violated, something that is {\bf not}, however, + recommended.} +%----------------------------------------------------------------------- +\routine{SLA\_MXV}{Apply 3D Rotation} +{ + \action{Multiply a 3-vector by a rotation matrix (single precision).} + \call{CALL sla\_MXV (RM, VA, VB)} +} +\args{GIVEN} +{ + \spec{RM}{R(3,3)}{rotation matrix} \\ + \spec{VA}{R(3)}{vector to be rotated} +} +\args{RETURNED} +{ + \spec{VB}{R(3)}{result vector} +} +\notes +{ + \begin{enumerate} + \item This routine performs the operation: + \begin{verse} + {\bf b} = {\bf M}$\cdot${\bf a} + \end{verse} + where {\bf a} and {\bf b} are the 3-vectors VA and VB + respectively, and {\bf M} is the $3\times3$ matrix RM. + \item The main function of this routine is apply a + rotation; under these circumstances, ${\bf M}$ is a + {\it proper real orthogonal}\/ matrix. + \item To comply with the ANSI Fortran 77 standard, VA and VB must + {\bf not} be the same array. The routine is, in fact, coded + so as to work properly with many Fortran compilers even + if this rule is violated, something that is {\bf not}, however, + recommended. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_NUT}{Nutation Matrix} +{ + \action{Form the matrix of nutation (SF2001 theory) for a given date.} + \call{CALL sla\_NUT (DATE, RMATN)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{RMATN}{D(3,3)}{nutation matrix} +} +\notes{ + \begin{enumerate} + \item The matrix is in the sense: + \begin{verse} + ${\bf v}_{true} = {\bf M}\times{\bf v}_{mean}$ + \end{verse} + where ${\bf v}_{true}$ is the star vector relative to the + true equator and equinox of date, {\bf M} is the + $3\times3$ matrix {\tt rmatn} and + ${\bf v}_{mean}$ is the star vector relative to the + mean equator and equinox of date. + \item The matrix represents forced nutation (but not free core nutation) + plus corrections to the IAU~1976 precession model. + \item Earth attitude predictions made by combining the present nutation + matrix with IAU~1976 precession are accurate to 1~mas (with respect + to the ICRS) for a few decades around 2000. + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Kaplan, G.H., 1981.\ {\it USNO circular No.\ 163}, pA3-6. + \item Shirai, T. \& Fukushima, T., 2001, Astron.J., {\bf 121}, + 3270-3283. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_NUTC}{Nutation Components} +{ + \action{Nutation (SF2001 theory): longitude \& obliquity + components, and mean obliquity.} + \call{CALL sla\_NUTC (DATE, DPSI, DEPS, EPS0)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DPSI,DEPS}{D}{nutation in longitude and obliquity (radians)} \\ + \spec{EPS0}{D}{mean obliquity (radians)} +} +\notes +{ + \begin{enumerate} + \item The routine predicts forced nutation (but not free core nutation) + plus corrections to the IAU~1976 precession model. + \item Earth attitude predictions made by combining the present nutation + model with IAU~1976 precession are accurate to 1~mas (with respect + to the ICRS) for a few decades around 2000. + \item The slaNutc80 routine is the equivalent of the present routine + but using the IAU 1980 nutation theory. The older theory is less + accurate, leading to errors as large as 350~mas over the interval + 1900-2100, mainly because of the error in the IAU~1976 precession. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Shirai, T. \& Fukushima, T., Astron.J.\ 121, 3270-3283 (2001). + \item Fukushima, T., Astron.Astrophys.\ 244, L11 (1991). + \item Simon, J. L., Bretagnon, P., Chapront, J., Chapront-Touze, M., + Francou, G. \& Laskar, J., Astron.Astrophys.\ 282, 663 (1994). + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_NUTC80}{Nutation Components, IAU 1980} +{ + \action{Nutation (IAU 1980 theory): longitude \& obliquity + components, and mean obliquity.} + \call{CALL sla\_NUTC80 (DATE, DPSI, DEPS, EPS0)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TDB (formerly ET) as Modified Julian Date + (JD$-$2400000.5)} +} +\args{RETURNED} +{ + \spec{DPSI,DEPS}{D}{nutation in longitude and obliquity (radians)} \\ + \spec{EPS0}{D}{mean obliquity (radians)} +} +\notes +{ + \begin{enumerate} + \item The IAU 1980 theory used in the present function has + errors as large as 350~mas over the interval + 1900-2100, mainly because of the error in the IAU~1976 + precession. For more accurate results, either the corrections + published in IERS {\it Bulletin~B}\/ + must be applied, or the + sla\_NUTC function can be used. The latter is based upon the + more recent SF2001 nutation theory and is of better + than 1\,mas accuracy. + \item The distinction between the required TDB and TT is + always negligible. Moreover, for all but the most + critical applications UTC is adequate. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Final report of the IAU Working Group on Nutation, + chairman P.K.Seidelmann, 1980. + \item Kaplan, G.H., 1981.\ {\it USNO circular no.\ 163}, pA3-6. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_OAP}{Observed to Apparent} +{ + \action{Observed to apparent place.} + \call{CALL sla\_OAP (\vtop{ + \hbox{TYPE, OB1, OB2, DATE, DUT, ELONGM, PHIM,} + \hbox{HM, XP, YP, TDK, PMB, RH, WL, TLR, RAP, DAP)}}} +} +\args{GIVEN} +{ + \spec{TYPE}{C*(*)}{type of coordinates -- `R', `H' or `A' (see below)} \\ + \spec{OB1}{D}{observed Az, HA or RA (radians; Az is N=0, E=$90^{\circ}$)} \\ + \spec{OB2}{D}{observed zenith distance or $\delta$ (radians)} \\ + \spec{DATE}{D }{UTC date/time (Modified Julian Date, JD$-$2400000.5)} \\ + \spec{DUT}{D}{$\Delta$UT: UT1$-$UTC (UTC seconds)} \\ + \spec{ELONGM}{D}{observer's mean longitude (radians, east +ve)} \\ + \spec{PHIM}{D}{observer's mean geodetic latitude (radians)} \\ + \spec{HM}{D}{observer's height above sea level (metres)} \\ + \spec{XP,YP}{D}{polar motion \xy\ coordinates (radians)} \\ + \spec{TDK}{D}{local ambient temperature (K; std=273.15D0)} \\ + \spec{PMB}{D}{local atmospheric pressure (mb; std=1013.25D0)} \\ + \spec{RH}{D}{local relative humidity (in the range 0D0\,--\,1D0)} \\ + \spec{WL}{D}{effective wavelength ($\mu{\rm m}$, {\it e.g.}\ 0.55D0)} \\ + \spec{TLR}{D}{tropospheric lapse rate (K per metre, + {\it e.g.}\ 0.0065D0)} +} +\args{RETURNED} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec} +} +\notes +{ + \begin{enumerate} + \item Only the first character of the TYPE argument is significant. + `R' or `r' indicates that OBS1 and OBS2 are the observed right + ascension and declination; `H' or `h' indicates that they are + hour angle (west +ve) and declination; anything else (`A' or + `a' is recommended) indicates that OBS1 and OBS2 are azimuth + (north zero, east $90^{\circ}$) and zenith distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed \hadec\ via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. {\it Observed}\/ \radec\ or \hadec\ thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation ({\it n.b.}\ not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent \radec\ is obtained. + \item Frequently, {\it mean}\/ rather than {\it apparent}\, + \radec\ will be required, + in which case further transformations will be necessary. The + sla\_AMP {\it etc.}\ routines will convert + the apparent \radec\ produced + by the present routine into an FK5 J2000 mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should FK4 B1950 + coordinates be required, the routines sla\_FK524 {\it etc.}\ will also + have to be applied. + \item To convert to apparent \radec\ the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + \item This routine takes time to execute, due mainly to the + rigorous integration used to evaluate the refraction. + For processing multiple stars for one location and time, + call sla\_AOPPA once followed by one call per star to sla\_OAPQK. + Where a range of times within a limited period of a few hours + is involved, and the highest precision is not required, call + sla\_AOPPA once, followed by a call to sla\_AOPPAT each time the + time changes, followed by one call per star to sla\_OAPQK. + \item The DATE argument is UTC expressed as an MJD. This is, + strictly speaking, wrong, because of leap seconds. However, + as long as the $\Delta$UT and the UTC are consistent there + are no difficulties, except during a leap second. In this + case, the start of the 61st second of the final minute should + begin a new MJD day and the old pre-leap $\Delta$UT should + continue to be used. As the 61st second completes, the MJD + should revert to the start of the day as, simultaneously, + the $\Delta$UT changes by one second to its post-leap new value. + \item The $\Delta$UT (UT1$-$UTC) is tabulated in IERS circulars and + elsewhere. It increases by exactly one second at the end of + each UTC leap second, introduced in order to keep $\Delta$UT + within $\pm$\tsec{0}{9}. + \item IMPORTANT -- TAKE CARE WITH THE LONGITUDE SIGN CONVENTION. The + longitude required by the present routine is {\bf east-positive}, + in accordance with geographical convention (and right-handed). + In particular, note that the longitudes returned by the + sla\_OBS routine are west-positive (as in the {\it Astronomical + Almanac}\/ before 1984) and must be reversed in sign before use + in the present routine. + \item The polar coordinates XP,YP can be obtained from IERS + circulars and equivalent publications. The + maximum amplitude is about \arcsec{0}{3}. If XP,YP values + are unavailable, use XP=YP=0D0. See page B60 of the 1988 + {\it Astronomical Almanac}\/ for a definition of the two angles. + \item The height above sea level of the observing station, HM, + can be obtained from the {\it Astronomical Almanac}\/ (Section J + in the 1988 edition), or via the routine sla\_OBS. If P, + the pressure in mb, is available, an adequate + estimate of HM can be obtained from the following expression: + \begin{quote} + {\tt HM=-29.3D0*TSL*LOG(P/1013.25D0)} + \end{quote} + where TSL is the approximate sea-level air temperature in K + (see {\it Astrophysical Quantities}, C.W.Allen, 3rd~edition, + \S 52). Similarly, if the pressure P is not known, + it can be estimated from the height of the observing + station, HM as follows: + \begin{quote} + {\tt P=1013.25D0*EXP(-HM/(29.3D0*TSL))} + \end{quote} + Note, however, that the refraction is nearly proportional to the + pressure and that an accurate P value is important for + precise work. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections from the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_OAPQK}{Quick Observed to Apparent} +{ + \action{Quick observed to apparent place.} + \call{CALL sla\_OAPQK (TYPE, OB1, OB2, AOPRMS, RAP, DAP)} +} +\args{GIVEN} +{ + \spec{TYPE}{C*(*)}{type of coordinates -- `R', `H' or `A' (see below)} \\ + \spec{OB1}{D}{observed Az, HA or RA (radians; Az is N=0, E=$90^{\circ}$)} \\ + \spec{OB2}{D}{observed zenith distance or $\delta$ (radians)} \\ + \spec{AOPRMS}{D(14)}{star-independent apparent-to-observed parameters:} \\ + \specel {(1)} {geodetic latitude (radians)} \\ + \specel {(2,3)} {sine and cosine of geodetic latitude} \\ + \specel {(4)} {magnitude of diurnal aberration vector} \\ + \specel {(5)} {height (HM)} \\ + \specel {(6)} {ambient temperature (TDK)} \\ + \specel {(7)} {pressure (PMB)} \\ + \specel {(8)} {relative humidity (RH)} \\ + \specel {(9)} {wavelength (WL)} \\ + \specel {(10)} {lapse rate (TLR)} \\ + \specel {(11,12)} {refraction constants A and B (radians)} \\ + \specel {(13)} {longitude + eqn of equinoxes + + ``sidereal $\Delta$UT'' (radians)} \\ + \specel {(14)} {local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{RAP,DAP}{D}{geocentric apparent \radec} +} +\notes +{ + \begin{enumerate} + \item Only the first character of the TYPE argument is significant. + `R' or `r' indicates that OBS1 and OBS2 are the observed right + ascension and declination; `H' or `h' indicates that they are + hour angle (west +ve) and declination; anything else (`A' or + `a' is recommended) indicates that OBS1 and OBS2 are Azimuth + (north zero, east $90^{\circ}$) and zenith distance. (Zenith + distance is used rather than elevation in order to reflect the + fact that no allowance is made for depression of the horizon.) + \item The accuracy of the result is limited by the corrections for + refraction. Providing the meteorological parameters are + known accurately and there are no gross local effects, the + predicted azimuth and elevation should be within about + \arcsec{0}{1} for $\zeta<70^{\circ}$. Even + at a topocentric zenith distance of + $90^{\circ}$, the accuracy in elevation should be better than + 1~arcminute; useful results are available for a further + $3^{\circ}$, beyond which the sla\_REFRO routine returns a + fixed value of the refraction. The complementary + routines sla\_AOP (or sla\_AOPQK) and sla\_OAP (or sla\_OAPQK) + are self-consistent to better than 1~microarcsecond all over + the celestial sphere. + \item It is advisable to take great care with units, as even + unlikely values of the input parameters are accepted and + processed in accordance with the models used. + \item {\it Observed}\/ \azel\ means the position that would be seen by a + perfect theodolite located at the observer. This is + related to the observed \hadec\ via the standard rotation, using + the geodetic latitude (corrected for polar motion), while the + observed HA and RA are related simply through the local + apparent ST. {\it Observed}\/ \radec\ or \hadec\ thus means the + position that would be seen by a perfect equatorial located + at the observer and with its polar axis aligned to the + Earth's axis of rotation ({\it n.b.}\ not to the refracted pole). + By removing from the observed place the effects of + atmospheric refraction and diurnal aberration, the + geocentric apparent \radec\ is obtained. + \item Frequently, {\it mean}\/ rather than {\it apparent}\, + \radec\ will be required, + in which case further transformations will be necessary. The + sla\_AMP {\it etc.}\ routines will convert + the apparent \radec\ produced + by the present routine into an FK5 J2000 mean place, by + allowing for the Sun's gravitational lens effect, annual + aberration, nutation and precession. Should FK4 B1950 + coordinates be required, the routines sla\_FK524 {\it etc.}\ will also + have to be applied. + \item To convert to apparent \radec\ the coordinates read from a + real telescope, corrections would have to be applied for + encoder zero points, gear and encoder errors, tube flexure, + the position of the rotator axis and the pointing axis + relative to it, non-perpendicularity between the mounting + axes, and finally for the tilt of the azimuth or polar axis + of the mounting (with appropriate corrections for mount + flexures). Some telescopes would, of course, exhibit other + properties which would need to be accounted for at the + appropriate point in the sequence. + \item The star-independent apparent-to-observed-place parameters + in AOPRMS may be computed by means of the sla\_AOPPA routine. + If nothing has changed significantly except the time, the + sla\_AOPPAT routine may be used to perform the requisite + partial recomputation of AOPRMS. + \item The azimuths {\it etc.}\ used by the present routine are with + respect to the celestial pole. Corrections from the terrestrial pole + can be computed using sla\_POLMO. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_OBS}{Observatory Parameters} +{ + \action{Look up an entry in a standard list of + groundbased observing stations parameters.} + \call{CALL sla\_OBS (N, C, NAME, W, P, H)} +} +\args{GIVEN} +{ + \spec{N}{I}{number specifying observing station} +} +\args{GIVEN or RETURNED} +{ + \spec{C}{C*(*)}{identifier specifying observing station} +} +\args{RETURNED} +{ + \spec{NAME}{C*(*)}{name of specified observing station} \\ + \spec{W}{D}{longitude (radians, west +ve)} \\ + \spec{P}{D}{geodetic latitude (radians, north +ve)} \\ + \spec{H}{D}{height above sea level (metres)} +} +\notes +{ + \begin{enumerate} + \item Station identifiers C may be up to 10 characters long, + and station names NAME may be up to 40 characters long. + \item C and N are {\it alternative}\/ ways of specifying the observing + station. The C option, which is the most generally useful, + may be selected by specifying an N value of zero or less. + If N is 1 or more, the parameters of the Nth station + in the currently supported list are interrogated, and + the station identifier C is returned as well as NAME, W, + P and H. + \item If the station parameters are not available, either because + the station identifier C is not recognized, or because an + N value greater than the number of stations supported is + given, a name of `?' is returned and W, P and H are left in + their current states. + \item Programs can obtain a list of all currently supported + stations by calling the routine repeatedly, with N=1,2,3... + When NAME=`?' is seen, the list of stations has been + exhausted. The stations at the time of writing are listed + below. + \item Station numbers, identifiers, names and other details are + subject to change and should not be hardwired into + application programs. + \item All station identifiers C are uppercase only; lower case + characters must be converted to uppercase by the calling + program. The station names returned may contain both upper- + and lowercase. All characters up to the first space are + checked; thus an abbreviated ID will return the parameters + for the first station in the list which matches the + abbreviation supplied, and no station in the list will ever + contain embedded spaces. C must not have leading spaces. + \item IMPORTANT -- BEWARE OF THE LONGITUDE SIGN CONVENTION. The + longitude returned by sla\_OBS is + {\bf west-positive}, following the pre-1984 {\it Astronomical + Almanac}. However, this sign convention is left-handed and is + the opposite of the one now used; elsewhere in + SLALIB the preferable east-positive convention is used. In + particular, note that for use in sla\_AOP, sla\_AOPPA and + sla\_OAP the sign of the longitude must be reversed. + \item Users are urged to inform the author of any improvements + they would like to see made. For example: + \begin{itemize} + \item typographical corrections + \item more accurate parameters + \item better station identifiers or names + \item additional stations + \end{itemize} + \end{enumerate} +Stations supported by sla\_OBS at the time of writing: + +\begin{tabbing} +xxxxxxxxxxxxxxxxx \= \kill +{\it ID} \> {\it NAME} \\ \\ +AAT \> Anglo-Australian 3.9m Telescope \\ +ANU2.3 \> Siding Spring 2.3m \\ +APO3.5 \> Apache Point 3.5m \\ +ARECIBO \> Arecibo 1000 foot \\ +ATCA \> Australia Telescope Compact Array \\ +BLOEMF \> Bloemfontein 1.52m \\ +BOSQALEGRE \> Bosque Alegre 1.54m \\ +CAMB1MILE \> Cambridge 1 mile \\ +CAMB5KM \> Cambridge 5 km \\ +CATALINA61 \> Catalina 61 inch \\ +CFHT \> Canada-France-Hawaii 3.6m Telescope \\ +CSO \> Caltech Sub-mm Observatory, Mauna Kea \\ +DAO72 \> DAO Victoria BC 1.85m \\ +DUNLAP74 \> David Dunlap 74 inch \\ +DUPONT \> Du Pont 2.5m Telescope, Las Campanas \\ +EFFELSBERG \> Effelsberg 100m \\ +ESO3.6 \> ESO 3.6m \\ +ESONTT \> ESO 3.5m NTT \\ +ESOSCHM \> ESO 1m Schmidt, La Silla \\ +FCRAO \> Five College Radio Astronomy Obs \\ +FLAGSTF61 \> USNO 61 inch astrograph, Flagstaff \\ +GBVA140 \> Greenbank 140 foot \\ +GBVA300 \> Greenbank 300 foot \\ +GEMININ \> Gemini North 8m \\ +GEMINIS \> Gemini South 8m \\ +HARVARD \> Harvard College Observatory 1.55m \\ +HPROV1.52 \> Haute Provence 1.52m \\ +HPROV1.93 \> Haute Provence 1.93m \\ +IRTF \> NASA IR Telescope Facility, Mauna Kea \\ +JCMT \> JCMT 15m \\ +JODRELL1 \> Jodrell Bank 250 foot \\ +KECK1 \> Keck 10m Telescope 1 \\ +KECK2 \> Keck 10m Telescope 2 \\ +KISO \> Kiso 1.05m Schmidt, Japan \\ +KOSMA3M \> Cologne Submillimeter Observatory 3m \\ +KOTTAMIA \> Kottamia 74 inch \\ +KPNO158 \> Kitt Peak 158 inch \\ +KPNO36FT \> Kitt Peak 36 foot \\ +KPNO84 \> Kitt Peak 84 inch \\ +KPNO90 \> Kitt Peak 90 inch \\ +LICK120 \> Lick 120 inch \\ +LOWELL72 \> Perkins 72 inch, Lowell \\ +LPO1 \> Jacobus Kapteyn 1m Telescope \\ +LPO2.5 \> Isaac Newton 2.5m Telescope \\ +LPO4.2 \> William Herschel 4.2m Telescope \\ +MAGELLAN1 \> Magellan 1, 6.5m, Las Campanas \\ +MAGELLAN2 \> Magellan 2, 6.5m, Las Campanas \\ +MAUNAK88 \> Mauna Kea 88 inch \\ +MCDONLD2.1 \> McDonald 2.1m \\ +MCDONLD2.7 \> McDonald 2.7m \\ +MMT \> MMT, Mt Hopkins \\ +MOPRA \> ATNF Mopra Observatory \\ +MTEKAR \> Mt Ekar 1.82m \\ +MTHOP1.5 \> Mt Hopkins 1.5m \\ +MTLEMMON60 \> Mt Lemmon 60 inch \\ +NOBEYAMA \> Nobeyama 45m \\ +OKAYAMA \> Okayama 1.88m \\ +PALOMAR200 \> Palomar 200 inch \\ +PALOMAR48 \> Palomar 48-inch Schmidt \\ +PALOMAR60 \> Palomar 60 inch \\ +PARKES \> Parkes 64m \\ +QUEBEC1.6 \> Quebec 1.6m \\ +SAAO74 \> Sutherland 74 inch \\ +SANPM83 \> San Pedro Martir 83 inch \\ +ST.ANDREWS \> St Andrews University Observatory \\ +STEWARD90 \> Steward 90 inch \\ +STROMLO74 \> Mount Stromlo 74 inch \\ +SUBARU \> Subaru 8m \\ +SUGARGROVE \> Sugar Grove 150 foot \\ +TAUTNBG \> Tautenburg 2m \\ +TAUTSCHM \> Tautenberg 1.34m Schmidt \\ +TIDBINBLA \> Tidbinbilla 64m \\ +TOLOLO1.5M \> Cerro Tololo 1.5m \\ +TOLOLO4M \> Cerro Tololo 4m \\ +UKIRT \> UK Infra Red Telescope \\ +UKST \> UK 1.2m Schmidt, Siding Spring \\ +USSR6 \> USSR 6m \\ +USSR600 \> USSR 600 foot \\ +VLA \> Very Large Array \\ +VLT1 \> ESO VLT 8m, UT1 \\ +VLT2 \> ESO VLT 8m, UT2 \\ +VLT3 \> ESO VLT 8m, UT3 \\ +VLT4 \> ESO VLT 8m, UT4 +\end{tabbing} +} +%----------------------------------------------------------------------- +\routine{SLA\_PA}{$h,\delta$ to Parallactic Angle} +{ + \action{Hour angle and declination to parallactic angle + (double precision).} + \call{D~=~sla\_PA (HA, DEC, PHI)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle in radians (geocentric apparent)} \\ + \spec{DEC}{D}{declination in radians (geocentric apparent)} \\ + \spec{PHI}{D}{latitude in radians (geodetic)} +} +\args{RETURNED} +{ + \spec{sla\_PA}{D}{parallactic angle (radians, in the range $\pm \pi$)} +} +\notes +{ + \begin{enumerate} + \item The parallactic angle at a point in the sky is the position + angle of the vertical, {\it i.e.}\ the angle between the direction to + the pole and to the zenith. In precise applications care must + be taken only to use geocentric apparent \hadec\ and to consider + separately the effects of atmospheric refraction and telescope + mount errors. + \item At the pole a zero result is returned. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PAV}{Position-Angle Between Two Directions} +{ + \action{Returns the bearing (position angle) of one celestial + direction with respect to another (single precision).} + \call{R~=~sla\_PAV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{R(3)}{vector to one point} \\ + \spec{V2}{R(3)}{vector to the other point} +} +\args{RETURNED} +{ + \spec{sla\_PAV}{R}{position-angle of 2nd point with respect to 1st} +} +\notes +{ + \begin{enumerate} + \item The coordinate frames correspond to \radec, + $[\lambda,\phi]$ {\it etc.}. + \item The result is the bearing (position angle), in radians, + of point V2 as seen + from point V1. It is in the range $\pm \pi$. The sense + is such that if V2 + is a small distance due east of V1 the result + is about $+\pi/2$. Zero is returned + if the two points are coincident. + \item There is no requirement for either vector to be of unit length. + \item The routine sla\_BEAR performs an equivalent function except + that the points are specified in the form of spherical coordinates. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PCD}{Apply Radial Distortion} +{ + \action{Apply pincushion/barrel distortion to a tangent-plane \xy.} + \call{CALL sla\_PCD (DISCO,X,Y)} +} +\args{GIVEN} +{ + \spec{DISCO}{D}{pincushion/barrel distortion coefficient} \\ + \spec{X,Y}{D}{tangent-plane \xy} +} +\args{RETURNED} +{ + \spec{X,Y}{D}{distorted \xy} +} +\notes +{ + \begin{enumerate} + \item The distortion is of the form $\rho = r (1 + c r^{2})$, where $r$ is + the radial distance from the tangent point, $c$ is the DISCO + argument, and $\rho$ is the radial distance in the presence of + the distortion. + \item For {\it pincushion}\/ distortion, C is +ve; for + {\it barrel}\/ distortion, C is $-$ve. + \item For X,Y in units of one projection radius (in the case of + a photographic plate, the focal length), the following + DISCO values apply: + + \vspace{2ex} + + \hspace{5em} + \begin{tabular}{|l|c|} \hline + Geometry & DISCO \\ \hline \hline + astrograph & 0.0 \\ \hline + Schmidt & $-$0.3333 \\ \hline + AAT PF doublet & +147.069 \\ \hline + AAT PF triplet & +178.585 \\ \hline + AAT f/8 & +21.20 \\ \hline + JKT f/8 & +14.6 \\ \hline + \end{tabular} + + \vspace{2ex} + + \item There is a companion routine, sla\_UNPCD, which performs the + inverse operation. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PDA2H}{H.A.\ for a Given Azimuth} +{ + \action{Hour Angle corresponding to a given azimuth (double precision).} + \call{CALL sla\_PDA2H (P, D, A, H1, J1, H2, J2)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude} \\ + \spec{D}{D}{declination} \\ + \spec{A}{D}{azimuth} +} +\args{RETURNED} +{ + \spec{H1}{D}{hour angle: first solution if any} \\ + \spec{J1}{I}{flag: 0 = solution 1 is valid} \\ + \spec{H2}{D}{hour angle: second solution if any} \\ + \spec{J2}{I}{flag: 0 = solution 2 is valid} +} +%----------------------------------------------------------------------- +\routine{SLA\_PDQ2H}{H.A.\ for a Given P.A.} +{ + \action{Hour Angle corresponding to a given parallactic angle + (double precision).} + \call{CALL sla\_PDQ2H (P, D, Q, H1, J1, H2, J2)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude} \\ + \spec{D}{D}{declination} \\ + \spec{Q}{D}{azimuth} +} +\args{RETURNED} +{ + \spec{H1}{D}{hour angle: first solution if any} \\ + \spec{J1}{I}{flag: 0 = solution 1 is valid} \\ + \spec{H2}{D}{hour angle: second solution if any} \\ + \spec{J2}{I}{flag: 0 = solution 2 is valid} +} +%----------------------------------------------------------------------- +\routine{SLA\_PERMUT}{Next Permutation} +{ + \action{Generate the next permutation of a specified number of items.} + \call{CALL sla\_PERMUT (N, ISTATE, IORDER, J)} +} +\args{GIVEN} +{ + \spec{N}{I}{number of items: there will be N! permutations} \\ + \spec{ISTATE}{I(N)}{state, ISTATE(1)$=-1$ to initialize} +} +\args{RETURNED} +{ + \spec{ISTATE}{I(N)}{state, updated ready for next time} \\ + \spec{IORDER}{I(N)}{next permutation of numbers 1,2,\ldots,N} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal N (zero or less is illegal)} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $+$1 = no more permutations available} +} +\notes +{ + \begin{enumerate} + \item This routine returns, in the IORDER array, the integers 1 to N + inclusive, in an order that depends on the current contents of + the ISTATE array. Before calling the routine for the first + time, the caller must set the first element of the ISTATE array + to $-1$ (any negative number will do) to cause the ISTATE array + to be fully initialized. + \item The first permutation to be generated is: + \begin{verse} + IORDER(1)=N, IORDER(2)=N-1, ..., IORDER(N)=1 + \end{verse} + This is also the permutation returned for the ``finished'' (J=1) case. + The final permutation to be generated is: + \begin{verse} + IORDER(1)=1, IORDER(2)=2, ..., IORDER(N)=N + \end{verse} + \item If the ``finished'' (J=1) status is ignored, the routine continues + to deliver permutations, the pattern repeating every~N!\,~calls. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PERTEL}{Perturbed Orbital Elements} +{ + \action{Update the osculating elements of an asteroid or comet by + applying planetary perturbations.} + \call{CALL sla\_PERTEL (\vtop{ + \hbox{JFORM, DATE0, DATE1,} + \hbox{EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0,} + \hbox{EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1,} + \hbox{JSTAT)}}} +} +\args{GIVEN (format and dates)} +{ + \spec{JFORM}{I}{choice of element set (2 or 3; Note~1)} \\ + \spec{DATE0}{D}{date of osculation (TT MJD) for the given} \\ + \spec{}{}{\hspace{1.5em} elements} \\ + \spec{DATE1}{D}{date of osculation (TT MJD) for the updated} \\ + \spec{}{}{\hspace{1.5em} elements} +} +\args{GIVEN (the unperturbed elements)} +{ + \spec{EPOCH0}{D}{epoch of the given element set + ($t_0$ or $T$, TT MJD;} \\ + \spec{}{}{\hspace{1.5em} Note~2)} \\ + \spec{ORBI0}{D}{inclination ($i$, radians)} \\ + \spec{ANODE0}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH0}{D}{argument of perihelion + ($\omega$, radians)} \\ + \spec{AORQ0}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E0}{D}{eccentricity ($e$)} \\ + \spec{AM0}{D}{mean anomaly ($M$, radians, JFORM=2 only)} +} +\args{RETURNED (the updated elements)} +{ + \spec{EPOCH1}{D}{epoch of the updated element set + ($t_0$ or $T$,} \\ + \spec{}{}{\hspace{1.5em} TT MJD; Note~2)} \\ + \spec{ORBI1}{D}{inclination ($i$, radians)} \\ + \spec{ANODE1}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH1}{D}{argument of perihelion + ($\omega$, radians)} \\ + \spec{AORQ1}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E1}{D}{eccentricity ($e$)} \\ + \spec{AM1}{D}{mean anomaly ($M$, radians, JFORM=2 only)} +} +\args{RETURNED (status flag)} +{ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{0.5em}+102 = warning, distant epoch} \\ + \spec{}{}{\hspace{0.5em}+101 = warning, large timespan + ($>100$ years)} \\ + \spec{}{}{\hspace{-1.8em}+1 to +10 = coincident with major planet + (Note~6)} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.2em} $-$2 = illegal E0} \\ + \spec{}{}{\hspace{1.2em} $-$3 = illegal AORQ0} \\ + \spec{}{}{\hspace{1.2em} $-$4 = internal error} \\ + \spec{}{}{\hspace{1.2em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item Two different element-format options are supported, as follows. \\ + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabular} + + \item DATE0, DATE1, EPOCH0 and EPOCH1 are all instants of time in + the TT time scale (formerly Ephemeris Time, ET), expressed + as Modified Julian Dates (JD$-$2400000.5). + \begin{itemize} + \item DATE0 is the instant at which the given + ({\it i.e.}\ unperturbed) osculating elements are correct. + \item DATE1 is the specified instant at which the updated osculating + elements are correct. + \item EPOCH0 and EPOCH1 will be the same as DATE0 and DATE1 + (respectively) for the JFORM=2 case, normally used for minor + planets. For the JFORM=3 case, the two epochs will refer to + perihelion passage and so will not, in general, be the same as + DATE0 and/or DATE1 though they may be similar to one another. + \end{itemize} + \item The elements are with respect to the J2000 ecliptic and mean equinox. + \item Unused elements (AM0 and AM1 for JFORM=3) are not accessed. + \item See the sla\_PERTUE routine for details of the algorithm used. + \item This routine is not intended to be used for major planets, which + is why JFORM=1 is not available and why there is no opportunity + to specify either the longitude of perihelion or the daily + motion. However, if JFORM=2 elements are somehow obtained for a + major planet and supplied to the routine, sensible results will, + in fact, be produced. This happens because the sla\_PERTUE routine + that is called to perform the calculations checks the separation + between the body and each of the planets and interprets a + suspiciously small value (0.001~AU) as an attempt to apply it to + the planet concerned. If this condition is detected, the + contribution from that planet is ignored, and the status is set to + the planet number (1--10 = Mercury, Venus, EMB, Mars, Jupiter, + Saturn, Uranus, Neptune, Earth, Moon) as a warning. + \end{enumerate} +} +\aref{Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199.} +%------------------------------------------------------------------------------ +\routine{SLA\_PERTUE}{Perturbed Universal Elements} +{ + \action{Update the universal elements of an asteroid or comet by + applying planetary perturbations.} + \call{CALL sla\_PERTUE (DATE, U, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{final epoch (TT MJD) for the updated elements} +} +\args{GIVEN and RETURNED} +{ + \spec{U}{D(13)}{universal elements (updated in place)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v_0}$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} +} +\args{RETURNED} +{ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{0.5em}+102 = warning, distant epoch} \\ + \spec{}{}{\hspace{0.5em}+101 = warning, large timespan + ($>100$ years)} \\ + \spec{}{}{\hspace{-1.8em}+1 to +10 = coincident with major planet + (Note~5)} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = numerical error} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + + \item The universal elements are with respect to the J2000 equator and + equinox. + + \item The epochs DATE, U(3) and U(12) are all Modified Julian Dates + (JD$-$2400000.5). + + \item The algorithm is a simplified form of Encke's method. It takes as + a basis the unperturbed motion of the body, and numerically + integrates the perturbing accelerations from the major planets. + The expression used is essentially Sterne's 6.7-2 (reference 1). + Everhart \& Pitkin (reference 2) suggest rectifying the orbit at + each integration step by propagating the new perturbed position + and velocity as the new universal variables. In the present + routine the orbit is rectified less frequently than this, in order + to gain a slight speed advantage. However, the rectification is + done directly in terms of position and velocity, as suggested by + Everhart \& Pitkin, bypassing the use of conventional orbital + elements. + + The $f(q)$ part of the full Encke method is not used. The purpose + of this part is to avoid subtracting two nearly equal quantities + when calculating the ``indirect member'', which takes account of the + small change in the Sun's attraction due to the slightly displaced + position of the perturbed body. A simpler, direct calculation in + double precision proves to be faster and not significantly less + accurate. + + Apart from employing a variable timestep, and occasionally + ``rectifying the orbit'' to keep the indirect member small, the + integration is done in a fairly straightforward way. The + acceleration estimated for the middle of the timestep is assumed + to apply throughout that timestep; it is also used in the + extrapolation of the perturbations to the middle of the next + timestep, to predict the new disturbed position. There is no + iteration within a timestep. + + Measures are taken to reach a compromise between execution time + and accuracy. The starting-point is the goal of achieving + arcsecond accuracy for ordinary minor planets over a ten-year + timespan. This goal dictates how large the timesteps can be, + which in turn dictates how frequently the unperturbed motion has + to be recalculated from the osculating elements. + + Within predetermined limits, the timestep for the numerical + integration is varied in length in inverse proportion to the + magnitude of the net acceleration on the body from the major + planets. + + The numerical integration requires estimates of the major-planet + motions. Approximate positions for the major planets (Pluto + alone is omitted) are obtained from the routine sla\_PLANET. Two + levels of interpolation are used, to enhance speed without + significantly degrading accuracy. At a low frequency, the routine + sla\_PLANET is called to generate updated position+velocity ``state + vectors''. The only task remaining to be carried out at the full + frequency ({\it i.e.}\ at each integration step) is to use the state + vectors to extrapolate the planetary positions. In place of a + strictly linear extrapolation, some allowance is made for the + curvature of the orbit by scaling back the radius vector as the + linear extrapolation goes off at a tangent. + + Various other approximations are made. For example, perturbations + by Pluto and the minor planets are neglected and relativistic + effects are not taken into account. + + In the interests of simplicity, the background calculations for + the major planets are carried out {\it en masse.} + The mean elements and + state vectors for all the planets are refreshed at the same time, + without regard for orbit curvature, mass or proximity. + + The Earth-Moon system is treated as a single body when the body is + distant but as separate bodies when closer to the EMB than the + parameter RNE, which incurs a time penalty but improves accuracy + for near-Earth objects. + + \item This routine is not intended to be used for major planets. + However, if major-planet elements are supplied, sensible results + will, in fact, be produced. This happens because the routine + checks the separation between the body and each of the planets and + interprets a suspiciously small value (0.001~AU) as an attempt to + apply the routine to the planet concerned. If this condition + is detected, the + contribution from that planet is ignored, and the status is set to + the planet number (1--10 = Mercury, Venus, EMB, + Mars, Jupiter, Saturn, Uranus, Neptune, Earth, Moon) as a warning. + \end{enumerate} +} +\refs{ + \begin{enumerate} + \item Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199. + \item Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PLANEL}{Planet Position from Elements} +{ + \action{Heliocentric position and velocity of a planet, + asteroid or comet, starting from orbital elements.} + \call{CALL sla\_PLANEL (\vtop{ + \hbox{DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, PV, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TT MJD of observation (JD$-$2400000.5,} \\ + \spec{}{}{\hspace{1.5em} Note~1)} \\ + \spec{JFORM}{I}{choice of element set (1-3, Note~3)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD, Note~4)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.5em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.5em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.5em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item DATE is the instant for which the prediction is required. It is + in the TT time scale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The elements are with respect to the J2000 ecliptic and equinox. + \item A choice of three different element-format options is available, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & longitude of perihelion $\varpi$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ \\ + & AORL & = & mean longitude $L$ (radians) \\ + & DM & = & daily motion $n$ (radians) + \end{tabular} + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ + \end{tabular} + + Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + + \item Each of the three element sets defines an unperturbed heliocentric + orbit. For a given epoch of observation, the position of the body + in its orbit can be predicted from these elements, which are + called {\it osculating elements,}\/ + using standard two-body analytical + solutions. However, due to planetary perturbations, a given set + of osculating elements remains usable for only as long as the + unperturbed orbit that it describes is an adequate approximation + to reality. Attached to such a set of elements is a date called + the {\it osculating epoch,}\/ + at which the elements are, momentarily, + a perfect representation of the instantaneous position and + velocity of the body. + + \vspace{1ex} + + Therefore, for any given problem there are up to three different + epochs in play, and it is vital to distinguish clearly between + them: + \begin{itemize} + \item The epoch of observation: the moment in time for which the + position of the body is to be predicted. + \item The epoch defining the position of the body: the moment + in time at which, in the absence of purturbations, the + specified position---mean longitude, mean anomaly, or + perihelion---is reached. + \item The osculating epoch: the moment in time at which the + given elements are correct. + \end{itemize} + For the major-planet and minor-planet cases it is usual to make + the epoch that defines the position of the body the same as the + epoch of osculation. Thus, only two different epochs are + involved: the epoch of the elements and the epoch of observation. + For comets, the epoch of perihelion fixes the position in the + orbit and in general a different epoch of osculation will be + chosen. Thus, all three types of epoch are involved. + + \vspace{1ex} + + \goodbreak + For the present routine: + \begin{itemize} + \item The epoch of observation is the argument DATE. + \item The epoch defining the position of the body is the argument + EPOCH. + \item The osculating epoch is not used and is assumed to be + close enough to the epoch of observation to deliver + adequate accuracy. If not, a preliminary call to + sla\_PERTEL may be used to update the element-set (and + its associated osculating epoch) by + applying planetary perturbations. + \end{itemize} + \item The reference frame for the result is equatorial and is with + respect to the mean equinox and ecliptic of epoch J2000. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%------------------------------------------------------------------------------ +\routine{SLA\_PLANET}{Planetary Ephemerides} +{ + \action{Approximate heliocentric position and velocity of a planet.} + \call{CALL sla\_PLANET (DATE, NP, PV, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5)} \\ + \spec{NP}{I}{planet:} \\ + \spec{}{}{\hspace{1.5em} 1\,=\,Mercury} \\ + \spec{}{}{\hspace{1.5em} 2\,=\,Venus} \\ + \spec{}{}{\hspace{1.5em} 3\,=\,Earth-Moon Barycentre} \\ + \spec{}{}{\hspace{1.5em} 4\,=\,Mars} \\ + \spec{}{}{\hspace{1.5em} 5\,=\,Jupiter} \\ + \spec{}{}{\hspace{1.5em} 6\,=\,Saturn} \\ + \spec{}{}{\hspace{1.5em} 7\,=\,Uranus} \\ + \spec{}{}{\hspace{1.5em} 8\,=\,Neptune} \\ + \spec{}{}{\hspace{1.5em} 9\,=\,Pluto} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} $+$1 = warning: date outside of range} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal NP (outside 1-9)} \\ + \spec{}{}{\hspace{1.5em} $-$2 = solution didn't converge} +} +\notes +{ + \begin{enumerate} + \item The epoch, DATE, is in the TDB time scale and is in the form + of a Modified Julian Date (JD$-$2400000.5). + \item The reference frame is equatorial and is with respect to + the mean equinox and ecliptic of epoch J2000. + \item If a planet number, NP, outside the range 1-9 is supplied, an error + status is returned (JSTAT~=~$-1$) and the PV vector + is set to zeroes. + \item The algorithm for obtaining the mean elements of the + planets from Mercury to Neptune is due to + J.\,L.\,Simon, P.\,Bretagnon, J.\,Chapront, + M.\,Chapront-Touze, G.\,Francou and J.\,Laskar (Bureau des + Longitudes, Paris, France). The (completely different) + algorithm for calculating the ecliptic coordinates of + Pluto is by Meeus. + \item Comparisons of the present routine with the JPL DE200 ephemeris + give the following RMS errors over the interval 1960-2025: + + \begin{tabular}{llll} + & & {\it position (km)} & {\it speed (metre/sec)} \\ \\ + & Mercury & \hspace{2em}334 & \hspace{2.5em}0.437 \\ + & Venus & \hspace{1.5em}1060 & \hspace{2.5em}0.855 \\ + & EMB & \hspace{1.5em}2010 & \hspace{2.5em}0.815 \\ + & Mars & \hspace{1.5em}7690 & \hspace{2.5em}1.98 \\ + & Jupiter & \hspace{1em}71700 & \hspace{2.5em}7.70 \\ + & Saturn & \hspace{0.5em}199000 & \hspace{2em}19.4 \\ + & Uranus & \hspace{0.5em}564000 & \hspace{2em}16.4 \\ + & Neptune & \hspace{0.5em}158000 & \hspace{2em}14.4 \\ + & Pluto & \hspace{1em}36400 & \hspace{2.5em}0.137 + \end{tabular} + + From comparisons with DE102, Simon {\it et al.}\/ quote the following + longitude accuracies over the interval 1800-2200: + + \begin{tabular}{lll} + & Mercury & \hspace{0.5em}\arcseci{4} \\ + & Venus & \hspace{0.5em}\arcseci{5} \\ + & EMB & \hspace{0.5em}\arcseci{6} \\ + & Mars & \arcseci{17} \\ + & Jupiter & \arcseci{71} \\ + & Saturn & \arcseci{81} \\ + & Uranus & \arcseci{86} \\ + & Neptune & \arcseci{11} + \end{tabular} + + In the case of Pluto, Meeus quotes an accuracy of \arcsec{0}{6} + in longitude and \arcsec{0}{2} in latitude for the period + 1885-2099. + + For all except Pluto, over the period 1000-3000, + the accuracy is better than 1.5 + times that over 1800-2200. Outside the interval 1000-3000 the + accuracy declines. For Pluto the accuracy declines rapidly + outside the period 1885-2099. Outside these ranges + (1885-2099 for Pluto, 1000-3000 for the rest) a ``date out + of range'' warning status ({\tt JSTAT=+1}) is returned. + \item The algorithms for (i)~Mercury through Neptune and + (ii)~Pluto are completely independent. In the Mercury + through Neptune case, the present SLALIB + implementation differs from the original + Simon {\it et al.}\/ Fortran code in the following respects: + \begin{itemize} + \item The date is supplied as a Modified Julian Date rather + a Julian Date (${\rm MJD} = ({\rm JD} - 2400000.5$). + \item The result is returned only in equatorial + Cartesian form; the ecliptic + longitude, latitude and radius vector are not returned. + \item The velocity is in AU per second, not AU per day. + \item Different error/warning status values are used. + \item Kepler's Equation is not solved inline. + \item Polynomials in T are nested to minimize rounding errors. + \item Explicit double-precision constants are used to avoid + mixed-mode expressions. + \item There are other, cosmetic, changes to comply with + Starlink/SLALIB style guidelines. + \end{itemize} + None of the above changes affects the result significantly. + \item For NP\,=\,3 the result is for the Earth-Moon Barycentre. To + obtain the heliocentric position and velocity of the Earth, + either use the SLALIB routine sla\_EVP (or sla\_EPV) + or call sla\_DMOON and + subtract 0.012150581 times the geocentric Moon vector from + the EMB vector produced by the present routine. (The Moon + vector should be precessed to J2000 first, but this can + be omitted for modern epochs without introducing significant + inaccuracy.) + \end{enumerate} +\refs +{ + \begin{enumerate} + \item Simon {\it et al.,}\/ + Astron.\ Astrophys.\ {\bf 282}, 663 (1994). + \item Meeus, J., + {\it Astronomical Algorithms,}\/ Willmann-Bell (1991). + \end{enumerate} +} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PLANTE}{\radec\ of Planet from Elements} +{ + \action{Topocentric apparent \radec\ of a Solar-System object whose + heliocentric orbital elements are known.} + \call{CALL sla\_PLANTE (\vtop{ + \hbox{DATE, ELONG, PHI, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, RA, DEC, R, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TT MJD of observation (JD$-$2400000.5,} \\ + \spec{}{}{\hspace{1.5em} Notes~1,5)} \\ + \spec{ELONG,PHI}{D}{observer's longitude (east +ve) and latitude} \\ + \spec{}{}{\hspace{1.5em} (radians, Note~2)} \\ + \spec{JFORM}{I}{choice of element set (1-3, Notes~3-6)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD, Note~5)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{topocentric apparent \radec\ (radians)} \\ + \spec{R}{D}{distance from observer (AU)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal JFORM} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal E} \\ + \spec{}{}{\hspace{1.5em} $-$3 = illegal AORQ} \\ + \spec{}{}{\hspace{1.5em} $-$4 = illegal DM} \\ + \spec{}{}{\hspace{1.5em} $-$5 = numerical error} +} +\notes +{ + \begin{enumerate} + \item DATE is the instant for which the prediction is + required. It is in the TT time scale (formerly + Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The longitude and latitude allow correction for geocentric + parallax. This is usually a small effect, but can become + important for near-Earth asteroids. Geocentric positions + can be generated by appropriate use of the routines + sla\_EVP (or sla\_EPV) and sla\_PLANEL. + \item The elements are with respect to the J2000 ecliptic and equinox. + \item A choice of three different element-format options is available, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & longitude of perihelion $\varpi$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ \\ + & AORL & = & mean longitude $L$ (radians) \\ + & DM & = & daily motion $n$ (radians) + \end{tabular} + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ + \end{tabular} + + Unused elements (DM for JFORM=2, AORL and DM for JFORM=3) are + not accessed. + + \item Each of the three element sets defines an unperturbed heliocentric + orbit. For a given epoch of observation, the position of the body + in its orbit can be predicted from these elements, which are + called {\it osculating elements,}\/ + using standard two-body analytical + solutions. However, due to planetary perturbations, a given set + of osculating elements remains usable for only as long as the + unperturbed orbit that it describes is an adequate approximation + to reality. Attached to such a set of elements is a date called + the {\it osculating epoch,}\/ + at which the elements are, momentarily, + a perfect representation of the instantaneous position and + velocity of the body. + + \vspace{1ex} + + Therefore, for any given problem there are up to three different + epochs in play, and it is vital to distinguish clearly between + them: + \begin{itemize} + \item The epoch of observation: the moment in time for which the + position of the body is to be predicted. + \item The epoch defining the position of the body: the moment + in time at which, in the absence of purturbations, the + specified position---mean longitude, mean anomaly, or + perihelion---is reached. + \item The osculating epoch: the moment in time at which the + given elements are correct. + \end{itemize} + For the major-planet and minor-planet cases it is usual to make + the epoch that defines the position of the body the same as the + epoch of osculation. Thus, only two different epochs are + involved: the epoch of the elements and the epoch of observation. + For comets, the epoch of perihelion fixes the position in the + orbit and in general a different epoch of osculation will be + chosen. Thus, all three types of epoch are involved. + + \vspace{1ex} + + \goodbreak + For the present routine: + \begin{itemize} + \item The epoch of observation is the argument DATE. + \item The epoch defining the position of the body is the argument + EPOCH. + \item The osculating epoch is not used and is assumed to be + close enough to the epoch of observation to deliver + adequate accuracy. If not, a preliminary call to + sla\_PERTEL may be used to update the element-set (and + its associated osculating epoch) by + applying planetary perturbations. + \end{itemize} + \item Two important sources for orbital elements are {\it Horizons,}\/ + operated by the Jet Propulsion Laboratory, Pasadena, + and the {\it Minor Planet Center,}\/ operated by the Center for + Astrophysics, Harvard. For further details, see Section~\ref{ephem}. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PLANTU}{\radec\ from Universal Elements} +{ + \action{Topocentric apparent \radec\ of a Solar-System object whose + heliocentric universal orbital elements are known.} + \call{CALL sla\_PLANTU (DATE, ELONG, PHI, U, RA, DEC, R, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{TT MJD of observation (JD$-$2400000.5)} \\ + \spec{ELONG,PHI}{D}{observer's longitude (east +ve) and latitude} \\ + \spec{}{}{\hspace{1.5em} radians)} +} +\args{GIVEN and RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v_0}$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{topocentric apparent \radec\ (radians)} \\ + \spec{R}{D}{distance from observer (AU)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = radius vector zero} \\ + \spec{}{}{\hspace{1.5em} $-$2 = failed to converge} +} +\notes +{ + \begin{enumerate} + \item DATE is the instant for which the prediction is + required. It is in the TT time scale (formerly + Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The longitude and latitude allow correction for geocentric + parallax. This is usually a small effect, but can become + important for near-Earth asteroids. Geocentric positions + can be generated by appropriate use of the routines + sla\_EVP (or sla\_EPV) and sla\_UE2PV. + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The universal elements are with respect to the J2000 ecliptic + and equinox. + \end{enumerate} +} +\refs{ + \begin{enumerate} + \item Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199. + \item Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983. + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_PM}{Proper Motion} +{ + \action{Apply corrections for proper motion to a star \radec.} + \call{CALL sla\_PM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1)} +} +\args{GIVEN} +{ + \spec{R0,D0}{D}{\radec\ at epoch EP0 (radians)} \\ + \spec{PR,PD}{D}{proper motions: rate of change of + \radec\ (radians per year)} \\ + \spec{PX}{D}{parallax (arcsec)} \\ + \spec{RV}{D}{radial velocity (km~s$^{-1}$, +ve if receding)} \\ + \spec{EP0}{D}{start epoch in years ({\it e.g.}\ Julian epoch)} \\ + \spec{EP1}{D}{end epoch in years (same system as EP0)} +} +\args{RETURNED} +{ + \spec{R1,D1}{D}{\radec\ at epoch EP1 (radians)} +} +\notes +{ +\begin{enumerate} +\item The $\alpha$ proper motions are $\dot{\alpha}$ rather than + $\dot{\alpha}\cos\delta$, and are in the same coordinate + system as R0,D0. +\item If the available proper motions are pre-FK5 they will be per + tropical year rather than per Julian year, and so the epochs + must both be Besselian rather than Julian. In such cases, a + scaling factor of 365.2422D0/365.25D0 should be applied to the + radial velocity before use also. +\end{enumerate} +} +\refs +{ + \begin{enumerate} + \item 1984 {\it Astronomical Almanac}, pp B39-B41. + \item Lederle \& Schwan, 1984.\ {\it Astr. Astrophys.}\ {\bf 134}, 1-6. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_POLMO}{Polar Motion} +{ + \action{Polar motion: correct site longitude and latitude for polar + motion and calculate azimuth difference between celestial and + terrestrial poles.} + \call{CALL sla\_POLMO (ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ)} +} +\args{GIVEN} +{ + \spec{ELONGM}{D}{mean longitude of the site (radians, east +ve)} \\ + \spec{PHIM}{D}{mean geodetic latitude of the site (radians)} \\ + \spec{XP}{D}{polar motion $x$-coordinate (radians)} \\ + \spec{YP}{D}{polar motion $y$-coordinate (radians)} +} +\args{RETURNED} +{ + \spec{ELONG}{D}{true longitude of the site (radians, east +ve)} \\ + \spec{PHI}{D}{true geodetic latitude of the site (radians)} \\ + \spec{DAZ}{D}{azimuth correction (terrestrial$-$celestial, radians)} +} +\notes +{ +\begin{enumerate} +\item ``Mean'' longitude and latitude are the (fixed) values for the + site's location with respect to the IERS terrestrial reference + frame; the latitude is geodetic. TAKE CARE WITH THE LONGITUDE + SIGN CONVENTION. The longitudes used by the present routine + are east-positive, in accordance with geographical convention + (and right-handed). In particular, note that the longitudes + returned by the sla\_OBS routine are west-positive, following + astronomical usage, and must be reversed in sign before use in + the present routine. +\item XP and YP are the (changing) coordinates of the Celestial + Ephemeris Pole with respect to the IERS Reference Pole. + XP is positive along the meridian at longitude $0^\circ$, + and YP is positive along the meridian at longitude + $270^\circ$ ({\it i.e.}\ $90^\circ$ west). Values for XP,YP can + be obtained from IERS circulars and equivalent publications; + the maximum amplitude observed so far is about \arcsec{0}{3}. +\item ``True'' longitude and latitude are the (moving) values for + the site's location with respect to the celestial ephemeris + pole and the meridian which corresponds to the Greenwich + apparent sidereal time. The true longitude and latitude + link the terrestrial coordinates with the standard celestial + models (for precession, nutation, sidereal time {\it etc}). +\item The azimuths produced by sla\_AOP and sla\_AOPQK are with + respect to due north as defined by the Celestial Ephemeris + Pole, and can therefore be called ``celestial azimuths''. + However, a telescope fixed to the Earth measures azimuth + essentially with respect to due north as defined by the + IERS Reference Pole, and can therefore be called ``terrestrial + azimuth''. Uncorrected, this would manifest itself as a + changing ``azimuth zero-point error''. The value DAZ is the + correction to be added to a celestial azimuth to produce + a terrestrial azimuth. +\item The present routine is rigorous. For most practical + purposes, the following simplified formulae provide an + adequate approximation: \\[2ex] + \hspace*{1em}\begin{tabular}{lll} + {\tt ELONG} & {\tt =} & + {\tt ELONGM+XP*COS(ELONGM)-YP*SIN(ELONGM)} \\ + {\tt PHI } & {\tt =} & + {\tt PHIM+(XP*SIN(ELONGM)+YP*COS(ELONGM))*TAN(PHIM)} \\ + {\tt DAZ } & {\tt =} & + {\tt -SQRT(XP*XP+YP*YP)*COS(ELONGM-ATAN2(XP,YP))/COS(PHIM)} \\ + \end{tabular} \\[2ex] + An alternative formulation for DAZ is:\\[2ex] + \hspace*{1em}\begin{tabular}{lll} + {\tt X } & {\tt =} & {\tt COS(ELONGM)*COS(PHIM)} \\ + {\tt Y } & {\tt =} & {\tt SIN(ELONGM)*COS(PHIM)} \\ + {\tt DAZ} & {\tt =} & {\tt ATAN2(-X*YP-Y*XP,X*X+Y*Y)} \\ + \end{tabular} +\end{enumerate} +} +\aref{Seidelmann, P.K.\ (ed), 1992. {\it Explanatory + Supplement to the Astronomical Almanac,}\/ ISBN~0-935702-68-7, + sections 3.27, 4.25, 4.52.} +%----------------------------------------------------------------------- +\routine{SLA\_PREBN}{Precession Matrix (FK4)} +{ + \action{Generate the matrix of precession between two epochs, + using the old, pre IAU~1976, Bessel-Newcomb model, in + Andoyer's formulation.} + \call{CALL sla\_PREBN (BEP0, BEP1, RMATP)} +} +\args{GIVEN} +{ + \spec{BEP0}{D}{beginning Besselian epoch} \\ + \spec{BEP1}{D}{ending Besselian epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\anote{The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch BEP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch BEP0.} +\aref{Smith {\it et al.}, 1989.\ {\it Astr.J.}\ {\bf 97}, 269.} +%----------------------------------------------------------------------- +\routine{SLA\_PREC}{Precession Matrix (FK5)} +{ + \action{Form the matrix of precession between two epochs (IAU 1976, FK5).} + \call{CALL sla\_PREC (EP0, EP1, RMATP)} +} +\args{GIVEN} +{ + \spec{EP0}{D}{beginning epoch} \\ + \spec{EP1}{D}{ending epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\notes +{ + \begin{enumerate} + \item The epochs are TDB Julian epochs. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch EP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch EP0. + \item Though the matrix method itself is rigorous, the precession + angles are expressed through canonical polynomials which are + valid only for a limited time span. There are also known + errors in the IAU precession rate. The absolute accuracy + of the present formulation is better than \arcsec{0}{1} from + 1960\,AD to 2040\,AD, better than \arcseci{1} from 1640\,AD to 2360\,AD, + and remains below \arcseci{3} for the whole of the period + 500\,BC to 3000\,AD. The errors exceed \arcseci{10} outside the + range 1200\,BC to 3900\,AD, exceed \arcseci{100} outside 4200\,BC to + 5600\,AD and exceed \arcseci{1000} outside 6800\,BC to 8200\,AD. + The SLALIB routine sla\_PRECL implements a more elaborate + model which is suitable for problems spanning several + thousand years. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Lieske, J.H., 1979.\ {\it Astr.Astrophys.}\ {\bf 73}, 282; + equations 6 \& 7, p283. + \item Kaplan, G.H., 1981.\ {\it USNO circular no.\ 163}, pA2. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PRECES}{Precession} +{ + \action{Precession -- either the old ``FK4'' (Bessel-Newcomb, pre~IAU~1976) + or new ``FK5'' (Fricke, post~IAU~1976) as required.} + \call{CALL sla\_PRECES (SYSTEM, EP0, EP1, RA, DC)} +} +\args{GIVEN} +{ + \spec{SYSTEM}{C}{precession to be applied: `FK4' or `FK5'} \\ + \spec{EP0,EP1}{D}{starting and ending epoch} \\ + \spec{RA,DC}{D}{\radec, mean equator \& equinox of epoch EP0} +} +\args{RETURNED} +{ + \spec{RA,DC}{D}{\radec, mean equator \& equinox of epoch EP1} +} +\notes +{ + \begin{enumerate} + \item Lowercase characters in SYSTEM are acceptable. + \item The epochs are Besselian if SYSTEM=`FK4' and Julian if `FK5'. + For example, to precess coordinates in the old system from + equinox 1900.0 to 1950.0 the call would be: + \begin{quote} + {\tt CALL sla\_PRECES ('FK4', 1900D0, 1950D0, RA, DC)} + \end{quote} + \item This routine will {\bf NOT} correctly convert between the old and + the new systems -- for example conversion from B1950 to J2000. + For these purposes see sla\_FK425, sla\_FK524, sla\_FK45Z and + sla\_FK54Z. + \item If an invalid SYSTEM is supplied, values of $-$99D0,$-$99D0 are + returned for both RA and DC. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PRECL}{Precession Matrix (latest)} +{ + \action{Form the matrix of precession between two epochs, using the + model of Simon {\it et al}.\ (1994), which is suitable for long + periods of time.} + \call{CALL sla\_PRECL (EP0, EP1, RMATP)} +} +\args{GIVEN} +{ + \spec{EP0}{D}{beginning epoch} \\ + \spec{EP1}{D}{ending epoch} +} +\args{RETURNED} +{ + \spec{RMATP}{D(3,3)}{precession matrix} +} +\notes +{ + \begin{enumerate} + \item The epochs are TDB Julian epochs. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{1}$ = {\bf M}$\cdot${\bf v}$_{0}$ + \end{verse} + where {\bf v}$_{1}$ is the star vector relative to the + mean equator and equinox of epoch EP1, {\bf M} is the + $3\times3$ matrix RMATP and + {\bf v}$_{0}$ is the star vector relative to the + mean equator and equinox of epoch EP0. + \item The absolute accuracy of the model is limited by the + uncertainty in the general precession, about \arcsec{0}{3} per + 1000~years. The remainder of the formulation provides a + precision of 1~milliarcsecond over the interval from 1000\,AD + to 3000\,AD, \arcsec{0}{1} from 1000\,BC to 5000\,AD and + \arcseci{1} from 4000\,BC to 8000\,AD. + \end{enumerate} +} +\aref{Simon, J.L.\ {\it et al}., 1994.\ {\it Astr.Astrophys.}\ {\bf 282}, + 663.} +%----------------------------------------------------------------------- +\routine{SLA\_PRENUT}{Precession-Nutation Matrix} +{ + \action{Form the matrix of precession and nutation (SF2001).} + \call{CALL sla\_PRENUT (EPOCH, DATE, RMATPN)} +} +\args{GIVEN} +{ + \spec{EPOCH}{D}{Julian Epoch for mean coordinates} \\ + \spec{DATE}{D}{Modified Julian Date (JD$-$2400000.5) + for true coordinates} +} +\args{RETURNED} +{ + \spec{RMATPN}{D(3,3)}{combined precession-nutation matrix} +} +\notes +{ + \begin{enumerate} + \item The epoch and date are TDB. TT (or even UTC) will do. + \item The matrix is in the sense: + \begin{verse} + {\bf v}$_{true}$ = {\bf M}$\cdot${\bf v}$_{mean}$ + \end{verse} + where {\bf v}$_{true}$ is the star vector relative to the + true equator and equinox of epoch DATE, {\bf M} is the + $3\times3$ matrix RMATPN and + {\bf v}$_{mean}$ is the star vector relative to the + mean equator and equinox of epoch EPOCH. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_PV2EL}{Orbital Elements from Position/Velocity} +{ + \action{Heliocentric osculating elements obtained from instantaneous + position and velocity.} + \call{CALL sla\_PV2EL (\vtop{ + \hbox{PV, DATE, PMASS, JFORMR, JFORM, EPOCH, ORBINC,} + \hbox{ANODE, PERIH, AORQ, E, AORL, DM, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} \\ + \spec{PMASS}{D}{mass of the planet (Sun = 1; Note~2)} \\ + \spec{JFORMR}{I}{requested element set (1-3; Note~3)} +} +\args{RETURNED} +{ + \spec{JFORM}{I}{element set actually returned (1-3; Note~4)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal JFORMR} \\ + \spec{}{}{\hspace{1.5em} $-$3 = position/velocity out of allowed range} +} +\notes +{ + \begin{enumerate} + \item The PV 6-vector is with respect to the mean equator and equinox of + epoch J2000. The orbital elements produced are with respect to + the J2000 ecliptic and mean equinox. + \item The mass, PMASS, is important only for the larger planets. For + most purposes ({\it e.g.}~asteroids) use 0D0. Values less than zero + are illegal. + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & longitude of perihelion $\varpi$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean longitude $L$ (radians) \\ + & DM & = & daily motion $n$ (radians) + \end{tabular} + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabular} + + \item It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + \begin{tabular}{llll} + & JFORMR & JFORM & meaning \\ \\ + & ~~~~~1 & ~~~~~1 & OK: elements are in the requested format \\ + & ~~~~~1 & ~~~~~2 & never happens \\ + & ~~~~~1 & ~~~~~3 & orbit not elliptical \\ + & ~~~~~2 & ~~~~~1 & never happens \\ + & ~~~~~2 & ~~~~~2 & OK: elements are in the requested format \\ + & ~~~~~2 & ~~~~~3 & orbit not elliptical \\ + & ~~~~~3 & ~~~~~1 & never happens \\ + & ~~~~~3 & ~~~~~2 & never happens \\ + & ~~~~~3 & ~~~~~3 & OK: elements are in the requested format + \end{tabular} + + \item The arguments returned for each value of JFORM ({\it cf.}\/ Note~5: + JFORM may not be the same as JFORMR) are as follows: + + \begin{tabular}{lllll} + & JFORM & 1 & 2 & 3 \\ \\ + & EPOCH & $t_0$ & $t_0$ & $T$ \\ + & ORBINC & $i$ & $i$ & $i$ \\ + & ANODE & $\Omega$ & $\Omega$ & $\Omega$ \\ + & PERIH & $\varpi$ & $\omega$ & $\omega$ \\ + & AORQ & $a$ & $a$ & $q$ \\ + & E & $e$ & $e$ & $e$ \\ + & AORL & $L$ & $M$ & - \\ + & DM & $n$ & - & - + \end{tabular} + + where: + + \begin{tabular}{lll} + & $t_0$ & is the epoch of the elements (MJD, TT) \\ + & $T$ & is the epoch of perihelion (MJD, TT) \\ + & $i$ & is the inclination (radians) \\ + & $\Omega$ & is the longitude of the ascending node (radians) \\ + & $\varpi$ & is the longitude of perihelion (radians) \\ + & $\omega$ & is the argument of perihelion (radians) \\ + & $a$ & is the mean distance (AU) \\ + & $q$ & is the perihelion distance (AU) \\ + & $e$ & is the eccentricity \\ + & $L$ & is the longitude (radians, $0-2\pi$) \\ + & $M$ & is the mean anomaly (radians, $0-2\pi$) \\ + & $n$ & is the daily motion (radians) \\ + & - & means no value is set + \end{tabular} + + \item At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + \item The osculating epoch for the returned elements is the argument + DATE. + \end{enumerate} +} +\aref{Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960.} +%----------------------------------------------------------------------- +\routine{SLA\_PV2UE}{Position/Velocity to Universal Elements} +{ + \action{Construct a universal element set based on an instantaneous + position and velocity.} + \call{CALL sla\_PV2UE (PV, DATE, PMASS, U, JSTAT)} +} +\args{GIVEN} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} \\ + \spec{PMASS}{D}{mass of the planet (Sun = 1; Note~2)} +} +\args{RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (Note~3)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.2em} $-$2 = too close to Sun} \\ + \spec{}{}{\hspace{1.2em} $-$3 = too slow} +} +\notes +{ + \begin{enumerate} + \item The PV 6-vector can be with respect to any chosen inertial frame, + and the resulting universal-element set will be with respect to + the same frame. A common choice will be mean equator and ecliptic + of epoch J2000. + \item The mass, PMASS, is important only for the larger planets. For + most purposes ({\it e.g.}~asteroids) use 0D0. Values less than zero + are illegal. + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%----------------------------------------------------------------------- +\routine{SLA\_PVOBS}{Observatory Position \& Velocity} +{ + \action{Position and velocity of an observing station.} + \call{CALL sla\_PVOBS (P, H, STL, PV)} +} +\args{GIVEN} +{ + \spec{P}{D}{latitude (geodetic, radians)} \\ + \spec{H}{D}{height above reference spheroid (geodetic, metres)} \\ + \spec{STL}{D}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{\xyzxyzd\ (AU, AU~s$^{-1}$, true equator and equinox + of date)} +} +\anote{IAU 1976 constants are used.} +%----------------------------------------------------------------------- +\routine{SLA\_PXY}{Apply Linear Model} +{ + \action{Given arrays of {\it expected}\/ and {\it measured}\, + \xy\ coordinates, and a + linear model relating them (as produced by sla\_FITXY), compute + the array of {\it predicted}\/ coordinates and the RMS residuals.} + \call{CALL sla\_PXY (NP,XYE,XYM,COEFFS,XYP,XRMS,YRMS,RRMS)} +} +\args{GIVEN} +{ + \spec{NP}{I}{number of samples} \\ + \spec{XYE}{D(2,NP)}{expected \xy\ for each sample} \\ + \spec{XYM}{D(2,NP)}{measured \xy\ for each sample} \\ + \spec{COEFFS}{D(6)}{coefficients of model (see below)} +} +\args{RETURNED} +{ + \spec{XYP}{D(2,NP)}{predicted \xy\ for each sample} \\ + \spec{XRMS}{D}{RMS in X} \\ + \spec{YRMS}{D}{RMS in Y} \\ + \spec{RRMS}{D }{total RMS (vector sum of XRMS and YRMS)} +} +\notes +{ + \begin{enumerate} + \item The model is supplied in the array COEFFS. Naming the + six elements of COEFFS $a,b,c,d,e$ \& $f$, + the model transforms {\it measured}\/ coordinates + $[x_{m},y_{m}\,]$ into {\it predicted}\/ coordinates + $[x_{p},y_{p}\,]$ as follows: + \begin{verse} + $x_{p} = a + bx_{m} + cy_{m}$ \\ + $y_{p} = d + ex_{m} + fy_{m}$ + \end{verse} + \item The residuals are $(x_{p}-x_{e})$ and $(y_{p}-y_{e})$. + \item If NP is less than or equal to zero, no coordinates are + transformed, and the RMS residuals are all zero. + \item See also sla\_FITXY, sla\_INVF, sla\_XY2XY, sla\_DCMPF + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RANDOM}{Random Number} +{ + \action{Generate pseudo-random real number in the range $0 \leq x < 1$.} + \call{R~=~sla\_RANDOM (SEED)} +} +\args{GIVEN} +{ + \spec{SEED}{R}{an arbitrary real number} +} +\args{RETURNED} +{ + \spec{SEED}{R}{a new arbitrary value} \\ + \spec{sla\_RANDOM}{R}{Pseudo-random real number $0 \leq x < 1$.} +} +\anote{The implementation is machine-dependent.} +%----------------------------------------------------------------------- +\routine{SLA\_RANGE}{Put Angle into Range $\pm\pi$} +{ + \action{Normalize an angle into the range $\pm\pi$ (single precision).} + \call{R~=~sla\_RANGE (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_RANGE}{R}{ANGLE expressed in the range $\pm\pi$.} +} +%----------------------------------------------------------------------- +\routine{SLA\_RANORM}{Put Angle into Range $0\!-\!2\pi$} +{ + \action{Normalize an angle into the range $0\!-\!2\pi$ (single precision).} + \call{R~=~sla\_RANORM (ANGLE)} +} +\args{GIVEN} +{ + \spec{ANGLE}{R}{angle in radians} +} +\args{RETURNED} +{ + \spec{sla\_RANORM}{R}{ANGLE expressed in the range $0\!-\!2\pi$} +} +%----------------------------------------------------------------------- +\routine{SLA\_RCC}{Barycentric Coordinate Time} +{ + \call{D~=~sla\_RCC (TDB, UT1, WL, U, V)} + \action{The relativistic clock correction: + the difference between {\it proper time}\/ at + a point on the Earth and + {\it coordinate time}\/ in the solar + system barycentric space-time frame of reference. + The proper time is Terrestrial Time, TT; + the coordinate time is an implementation of Barycentric + Dynamical Time, TDB.} +} +\args{GIVEN} +{ + \spec{TDB}{D}{TDB (MJD: JD$-$2400000.5)} \\ + \spec{UT1}{D}{universal time (fraction of one day)} \\ + \spec{WL}{D}{clock longitude (radians west)} \\ + \spec{U}{D}{clock distance from Earth spin axis (km)} \\ + \spec{V}{D}{clock distance north of Earth equatorial plane (km)} +} +\args{RETURNED} +{ + \spec{sla\_RCC}{D}{TDB$-$TT (sec; Note 1)} +} +\notes +{ + \begin{enumerate} + \item TDB is coordinate time in the solar system barycentre frame + of reference, in units chosen to eliminate the scale difference + with respect to terrestrial time. TT is the proper + time for clocks at mean sea level on the Earth. + \item The number returned by sla\_RCC comprises + a main (annual) sinusoidal term of amplitude + approximately 1.66ms, plus lunar and planetary terms up to about + 20$\mu$s, and diurnal terms up to 2$\mu$s. The + variation arises from the transverse Doppler effect and the + gravitational red-shift as the observer varies in speed and + moves through different gravitational potentials. + \item The argument TDB is, strictly, the barycentric coordinate time; + however, the terrestrial time (TT) can in practice be used without + significant loss of accuracy. + \item The geocentric model is that of Fairhead \& Bretagnon (1990), in + its full form. It was supplied by Fairhead (private communication) + as a Fortran subroutine. A number of coding changes were made to + this subroutine in order + match the calling sequence of previous versions of the present + routine, to comply with Starlink programming standards and to + avoid compilation problems on certain machines. The + numerical results are essentially unaffected by the + changes. + \item The topocentric model is from Moyer (1981) and Murray (1983). + It is an approximation to the expression + \[\frac{{\bf v}_e \cdot ( {\bf x} - {\bf x}_e )}{c^2}\] + where ${\bf v}_e$ is the barycentric velocity of + the Earth, ${\bf x}$ and ${\bf x}_e$ are the barycentric positions + of the observer and the Earth respectively, and + c is the speed of light. + It can be disabled, if necessary, by setting the arguments + U and V to zero. + \item During the interval 1950-2050, the absolute accuracy + is better than $\pm3$~nanoseconds + relative to direct numerical integrations using the JPL DE200/LE200 + solar system ephemeris. + \item The IAU 1976 definition of TDB was that it must differ from TT only by + periodic terms. Though practical, this is an imprecise definition + which ignores the existence of very long-period and secular effects + in the dynamics of the solar system. As a consequence, different + implementations of TDB will, in general, differ in zero-point and + will drift linearly relative to one other. In 1991 the IAU introduced + new time scales designed to overcome these objections: geocentric coordinate + time, TCG, and barycentric coordinate time, TCB. In principle, therefore, + TDB is obsolete. However, sla\_RCC + can be used to implement the periodic part of TCB$-$TCG. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Fairhead,\,L., \& Bretagnon,\,P., {\it Astron.\,Astrophys.,}\/ + {\bf 229}, 240-247 (1990). + \item Moyer,\,T.D., {\it Cel.\,Mech.,}\/ {\bf 23}, 33 (1981). + \item Murray,\,C.A., {\it Vectorial Astrometry,}\/ Adam Hilger (1983). + \item Seidelmann,\,P.K.\ {\it et al,}\/ {\it Explanatory Supplement to the + Astronomical Almanac,}\/ Chapter 2, University Science Books + (1992). + \item Simon,\,J.L., Bretagnon,\,P., Chapront,\,J., Chapront-Touze,\,M., + Francou,\,G.\ \& Laskar,\,J., {\it Astron.Astrophys.,}\/ + {\bf 282}, 663-683 (1994). + \end{enumerate} +} +%------------------------------------------------------------------------------ +\routine{SLA\_RDPLAN}{Apparent \radec\ of Planet} +{ + \action{Approximate topocentric apparent \radec\ and angular + size of a planet.} + \call{CALL sla\_RDPLAN (DATE, NP, ELONG, PHI, RA, DEC, DIAM)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{MJD of observation (JD$-$2400000.5)} \\ + \spec{NP}{I}{planet:} \\ + \spec{}{}{\hspace{1.5em} 1\,=\,Mercury} \\ + \spec{}{}{\hspace{1.5em} 2\,=\,Venus} \\ + \spec{}{}{\hspace{1.5em} 3\,=\,Moon} \\ + \spec{}{}{\hspace{1.5em} 4\,=\,Mars} \\ + \spec{}{}{\hspace{1.5em} 5\,=\,Jupiter} \\ + \spec{}{}{\hspace{1.5em} 6\,=\,Saturn} \\ + \spec{}{}{\hspace{1.5em} 7\,=\,Uranus} \\ + \spec{}{}{\hspace{1.5em} 8\,=\,Neptune} \\ + \spec{}{}{\hspace{1.5em} 9\,=\,Pluto} \\ + \spec{}{}{\hspace{0.44em} else\,=\,Sun} \\ + \spec{ELONG,PHI}{D}{observer's longitude (east +ve) and latitude + (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{D}{topocentric apparent \radec\ (radians)} \\ + \spec{DIAM}{D}{angular diameter (equatorial, radians)} +} +\notes +{ + \begin{enumerate} + \item The date is in a dynamical time scale (TDB, formerly ET) + and is in the form of a Modified + Julian Date (JD$-$2400000.5). For all practical purposes, TT can + be used instead of TDB, and for many applications UT will do + (except for the Moon). + \item The longitude and latitude allow correction for geocentric + parallax. This is a major effect for the Moon, but in the + context of the limited accuracy of the present routine its + effect on planetary positions is small (negligible for the + outer planets). Geocentric positions can be generated by + appropriate use of the routines sla\_DMOON and sla\_PLANET. + \item The direction accuracy (arcsec, 1000-3000\,AD) is of order: + + \begin{tabular}{lll} + & Sun & \hspace{0.5em}5 \\ + & Mercury & \hspace{0.5em}2 \\ + & Venus & 10 \\ + & Moon & 30 \\ + & Mars & 50 \\ + & Jupiter & 90 \\ + & Saturn & 90 \\ + & Uranus & 90 \\ + & Neptune & 10 \\ + & Pluto & \hspace{0.5em}1~~~(1885-2099\,AD only) + \end{tabular} + + The angular diameter accuracy is about 0.4\% for the Moon, + and 0.01\% or better for the Sun and planets. + For more information on accuracy, + refer to the routines sla\_PLANET and sla\_DMOON, + which the present routine uses. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFCO}{Refraction Constants} +{ + \action{Determine the constants $a$ and $b$ in the + atmospheric refraction model + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$, + where $\zeta$ is the {\it observed}\/ zenith distance + ({\it i.e.}\ affected by refraction) and $\Delta \zeta$ is + what to add to $\zeta$ to give the {\it topocentric}\, + ({\it i.e.\ in vacuo}) zenith distance.} + \call{CALL sla\_REFCO (HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REFA, REFB)} +} +\args{GIVEN} +{ + \spec{HM}{D}{height of the observer above sea level (metre)} \\ + \spec{TDK}{D}{ambient temperature at the observer K)} \\ + \spec{PMB}{D}{pressure at the observer (mb)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} \\ + \spec{PHI}{D}{latitude of the observer (radian, astronomical)} \\ + \spec{TLR}{D}{temperature lapse rate in the troposphere + ( K per metre)} \\ + \spec{EPS}{D}{precision required to terminate iteration (radian)} +} +\args{RETURNED} +{ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\notes +{ + \begin{enumerate} + \item Suggested values for the TLR and EPS arguments are 0.0065D0 and + 1D$-$8 respectively. The signs of both are immaterial. + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + \item The routine is a slower but more accurate alternative to the + sla\_REFCOQ routine. The constants it produces give perfect + agreement with sla\_REFRO at zenith distances + $\tan^{-1} 1$ ($45^\circ$) and $\tan^{-1} 4$ ($\sim 76^\circ$). + At other zenith distances, the model achieves: + \arcsec{0}{5} accuracy for $\zeta<80^{\circ}$, + \arcsec{0}{01} accuracy for $\zeta<60^{\circ}$, and + \arcsec{0}{001} accuracy for $\zeta<45^{\circ}$. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFCOQ}{Refraction Constants (fast)} +{ + \action{Determine the constants $a$ and $b$ in the + atmospheric refraction model + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$, + where $\zeta$ is the {\it observed}\/ zenith distance + ({\it i.e.}\ affected by refraction) and $\Delta \zeta$ is + what to add to $\zeta$ to give the {\it topocentric}\, + ({\it i.e.\ in vacuo}) zenith distance. (This is a fast + alternative to the sla\_REFCO routine -- see notes.)} + \call{CALL sla\_REFCOQ (TDK, PMB, RH, WL, REFA, REFB)} +} +\args{GIVEN} +{ + \spec{TDK}{D}{ambient temperature at the observer (K)} \\ + \spec{PMB}{D}{pressure at the observer (mb)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} +} +\args{RETURNED} +{ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\notes +{ + \begin{enumerate} + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + \item The model is an approximation, for moderate zenith distances, + to the predictions of the sla\_REFRO routine. The approximation + is maintained across a range of conditions, and applies to + both optical/IR and radio. + \item The algorithm is a fast alternative to the sla\_REFCO routine. + The latter calls the sla\_REFRO routine itself: this involves + integrations through a model atmosphere, and is costly in + processor time. However, the model which is produced is precisely + correct for two zenith distances ($45^\circ$ and $\sim\!76^\circ$) + and at other zenith distances is limited in accuracy only by the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ formulation + itself. The present routine is not as accurate, though it + satisfies most practical requirements. + \item The model omits the effects of (i)~height above sea level (apart + from the reduced pressure itself), (ii)~latitude ({\it i.e.}\ the + flattening of the Earth) and (iii)~variations in tropospheric + lapse rate. + \item The model has been tested using the following range of conditions: + \begin{itemize} + \item [$\cdot$] lapse rates 0.0055, 0.0065, 0.0075~K per metre + \item [$\cdot$] latitudes $0^\circ$, $25^\circ$, $50^\circ$, $75^\circ$ + \item [$\cdot$] heights 0, 2500, 5000 metres above sea level + \item [$\cdot$] pressures mean for height $-10$\% to $+5$\% in steps of $5$\% + \item [$\cdot$] temperatures $-10^\circ$ to $+20^\circ$ with respect to + $280$K at sea level + \item [$\cdot$] relative humidity 0, 0.5, 1 + \item [$\cdot$] wavelength 0.4, 0.6, \ldots\ $2\mu{\rm m}$, + radio + \item [$\cdot$] zenith distances $15^\circ$, $45^\circ$, $75^\circ$ + \end{itemize} + For the above conditions, the comparison with sla\_REFRO + was as follows: + + \vspace{2ex} + + ~~~~~~~~~~ + \begin{tabular}{|r|r|r|} \hline + & {\it worst} & {\it RMS} \\ \hline + optical/IR & 62 & 8 \\ + radio & 319 & 49 \\ \hline + & mas & mas \\ \hline + \end{tabular} + + \vspace{3ex} + + For this particular set of conditions: + \begin{itemize} + \item [$\cdot$] lapse rate 6.5 K km$^{-1}$ + \item [$\cdot$] latitude $50^\circ$ + \item [$\cdot$] sea level + \item [$\cdot$] pressure 1005\,mb + \item [$\cdot$] temperature $7^\circ$C + \item [$\cdot$] humidity 80\% + \item [$\cdot$] wavelength 5740\,\.{A} + \end{itemize} + the results were as follows: + + \vspace{2ex} + + ~~~~~~~~~~ + \begin{tabular}{|r|r|r|r|} \hline + \multicolumn{1}{|c}{$\zeta$} & + \multicolumn{1}{|c}{sla\_REFRO} & + \multicolumn{1}{|c}{sla\_REFCOQ} & + \multicolumn{1}{|c|}{Saastamoinen} \\ \hline + 10 & 10.27 & 10.27 & 10.27 \\ + 20 & 21.19 & 21.20 & 21.19 \\ + 30 & 33.61 & 33.61 & 33.60 \\ + 40 & 48.82 & 48.83 & 48.81 \\ + 45 & 58.16 & 58.18 & 58.16 \\ + 50 & 69.28 & 69.30 & 69.27 \\ + 55 & 82.97 & 82.99 & 82.95 \\ + 60 & 100.51 & 100.54 & 100.50 \\ + 65 & 124.23 & 124.26 & 124.20 \\ + 70 & 158.63 & 158.68 & 158.61 \\ + 72 & 177.32 & 177.37 & 177.31 \\ + 74 & 200.35 & 200.38 & 200.32 \\ + 76 & 229.45 & 229.43 & 229.42 \\ + 78 & 267.44 & 267.29 & 267.41 \\ + 80 & 319.13 & 318.55 & 319.10 \\ \hline + deg & arcsec & arcsec & arcsec \\ \hline + \end{tabular} + + \vspace{3ex} + + The values for Saastamoinen's formula (which includes terms + up to $\tan^5$) are taken from Hohenkerk \& Sinclair (1985). + + The results from the much slower but more accurate sla\_REFCO + routine have not been included in the tabulation as they are + identical to those in the sla\_REFRO column to the \arcsec{0}{01} + resolution used. + \item Outlandish input parameters are silently limited + to mathematically safe values. Zero pressure is permissible, + and causes zeroes to be returned. + \item The algorithm draws on several sources, as follows: + \begin{itemize} + \item The formula for the saturation vapour pressure of water as + a function of temperature and temperature is taken from + expressions A4.5-A4.7 of Gill (1982). + \item The formula for the water vapour pressure, given the + saturation pressure and the relative humidity is from + Crane (1976), expression 2.5.5. + \item The refractivity of air is a function of temperature, + total pressure, water-vapour pressure and, in the case + of optical/IR but not radio, wavelength. The formulae + for the two cases are developed from Hohenkerk \& Sinclair + (1985) and Rueger (2002). + \item The formula for $\beta~(=H_0/r_0)$ is + an adaption of expression 9 from Stone (1996). The + adaptations, arrived at empirically, consist of (i)~a + small adjustment to the coefficient and (ii)~a humidity + term for the radio case only. + \item The formulae for the refraction constants as a function of + $n-1$ and $\beta$ are from Green (1987), expression 4.31. + \end{itemize} + The first three items are as used in the sla\_REFRO routine. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Crane, R.K., Meeks, M.L.\ (ed), ``Refraction Effects in + the Neutral Atmosphere'', + {\it Methods of Experimental Physics: Astrophysics 12B,}\/ + Academic Press, 1976. + \item Gill, Adrian E., {\it Atmosphere-Ocean Dynamics,}\/ + Academic Press, 1982. + \item Green, R.M., {\it Spherical Astronomy,}\/ Cambridge + University Press, 1987. + \item Hohenkerk, C.Y., \& Sinclair, A.T., NAO Technical Note + No.~63, 1985. + \item Rueger, J.M., {\it Refractive Index Formulae for + Electronic Distance Measurement with Radio and Millimetre + Waves}, in Unisurv Report S-68, School of Surveying + and Spatial Information Systems, University of New South + Wales, Sydney, Australia, 2002. + \item Stone, Ronald C., P.A.S.P.~{\bf 108} 1051-1058, 1996. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFRO}{Refraction} +{ + \action{Atmospheric refraction, for radio or optical/IR wavelengths.} + \call{CALL sla\_REFRO (ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REF)} +} +\args{GIVEN} +{ + \spec{ZOBS}{D}{observed zenith distance of the source (radians)} \\ + \spec{HM}{D}{height of the observer above sea level (metre)} \\ + \spec{TDK}{D}{ambient temperature at the observer (K)} \\ + \spec{PMB}{D}{pressure at the observer (mb)} \\ + \spec{RH}{D}{relative humidity at the observer (range 0\,--\,1)} \\ + \spec{WL}{D}{effective wavelength of the source ($\mu{\rm m}$)} \\ + \spec{PHI}{D}{latitude of the observer (radian, astronomical)} \\ + \spec{TLR}{D}{temperature lapse rate in the troposphere + (K per metre)} \\ + \spec{EPS}{D}{precision required to terminate iteration (radian)} +} +\args{RETURNED} +{ + \spec{REF}{D}{refraction: {\it in vacuo}\/ ZD minus observed ZD (radians)} +} +\notes +{ + \begin{enumerate} + \item A suggested value for the TLR argument is 0.0065D0 (sign immaterial). + The refraction is significantly affected by TLR, and if studies + of the local atmosphere have been carried out a better TLR + value may be available. + \item A suggested value for the EPS argument is 1D$-$8. The result is + usually at least two orders of magnitude more computationally + precise than the supplied EPS value. + \item The routine computes the refraction for zenith distances up + to and a little beyond $90^\circ$ using the method of Hohenkerk + \& Sinclair (NAO Technical Notes 59 and 63, subsequently adopted + in the {\it Explanatory Supplement to the Astronomical Almanac,}\/ + 1992 -- see section 3.281). + \item The code is based on the {\tt AREF} + optical/IR refraction subroutine + (HMNAO, September 1984, RGO: Hohenkerk 1985), + with extensions to + support the radio case. The modifications to the original HMNAO + optical/IR refraction code which affect the results are: + \begin{itemize} + \item The angle arguments have been changed to radians, + any value of ZOBS is allowed (see Note~6, below) and + other argument values have been limited to safe values. + \item Revised values for the gas constants are used, from + Murray (1983). + \item A better model for $P_s(T)$ has been adopted, + from Gill (1982). + \item More accurate expressions for $Pw_o$ have been adopted + (again from Gill 1982). + \item The formula for the water vapour pressure, given the + saturation pressure and the relative humidity, is from + Crane (1976), expression 2.5.5. + \item Provision for radio wavelengths has been added using + expressions devised by A.\,T.\,Sinclair, RGO (Sinclair 1989). + The refractivity model is from Rueger (2002). + \item The optical refractivity for dry air is from IAG (1999). + \end{itemize} + \item The radio refraction is chosen by specifying WL $>100$~$\mu{\rm m}$. + Because the algorithm takes no account of the ionosphere, the + accuracy deteriorates at low frequencies, below about 30\,MHz. + \item Before use, the value of ZOBS is expressed in the range $\pm\pi$. + If this ranged ZOBS is negative, the result REF is computed from its + absolute value before being made negative to match. In addition, if + it has an absolute value greater than $93^\circ$, a fixed REF value + equal to the result for ZOBS~$=93^\circ$ is returned, appropriately + signed. + \item As in the original Hohenkerk \& Sinclair algorithm, fixed values + of the water vapour polytrope exponent, the height of the + tropopause, and the height at which refraction is negligible are + used. + \item The radio refraction has been tested against work done by + Iain~Coulson, JACH, (private communication 1995) for the + James Clerk Maxwell Telescope, Mauna Kea. For typical conditions, + agreement at the \arcsec{0}{1} level is achieved for moderate ZD, + worsening to perhaps \arcsec{0}{5}\,--\,\arcsec{1}{0} at ZD $80^\circ$. + At hot and humid sea-level sites the accuracy will not be as good. + \item It should be noted that the relative humidity RH is formally + defined in terms of ``mixing ratio'' rather than pressures or + densities as is often stated. It is the mass of water per unit + mass of dry air divided by that for saturated air at the same + temperature and pressure (see Gill 1982). The familiar + $\nu=p_w/p_s$ or $\nu=\rho_w/\rho_s$ expressions can differ from + the formal definition by several percent, significant in the + radio case. + \item The algorithm is designed for observers in the troposphere. The + supplied temperature, pressure and lapse rate are assumed to be + for a point in the troposphere and are used to define a model + atmosphere with the tropopause at 11km altitude and a constant + temperature above that. However, in practice, the refraction + values returned for stratospheric observers, at altitudes up to + 25km, are quite usable. + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Coulsen, I.\ 1995, private communication. + \item Crane, R.K., Meeks, M.L.\ (ed), 1976, + ``Refraction Effects in the Neutral Atmosphere'', + {\it Methods of Experimental Physics: Astrophysics 12B}, + Academic Press. + \item Gill, Adrian E.\ 1982, {\it Atmosphere-Ocean Dynamics}, + Academic Press. + \item Hohenkerk, C.Y.\ 1985, private communication. + \item Hohenkerk, C.Y., \& Sinclair, A.T.\ 1985, + {\it NAO Technical Note}\/ + No.~63, Royal Greenwich Observatory. + \item International Association of Geodesy, + XXIIth General Assembly, Birmingham, UK, 1999, + Resolution 3. + \item Murray, C.A.\ 1983, {\it Vectorial Astrometry,} + Adam Hilger, Bristol. + \item Seidelmann,\,P.K.\ {\it et al.}\ 1992, + {\it Explanatory Supplement to the + Astronomical Almanac}, Chapter 3, University Science Books. + \item Rueger, J.M.\ 2002, {\it Refractive Index Formulae for + Electronic Distance Measurement with Radio and Millimetre + Waves}, in Unisurv Report S-68, School of Surveying + and Spatial Information Systems, University of New South + Wales, Sydney, Australia. + \item Sinclair, A.T.\ 1989, private communication. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFV}{Apply Refraction to Vector} +{ + \action{Adjust an unrefracted Cartesian vector to include the effect of + atmospheric refraction, using the simple + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ model.} + \call{CALL sla\_REFV (VU, REFA, REFB, VR)} +} +\args{GIVEN} +{ + \spec{VU}{D}{unrefracted position of the source (\azel\ 3-vector)} \\ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\args{RETURNED} +{ + \spec{VR}{D}{refracted position of the source (\azel\ 3-vector)} +} +\notes +{ + \begin{enumerate} + \item This routine applies the adjustment for refraction in the + opposite sense to the usual one -- it takes an unrefracted + ({\it in vacuo}\/) position and produces an observed (refracted) + position, whereas the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the algorithm used here is equivalent to + one iteration of the Newton-Raphson method applied to the + above formula. + \item Though optimized for speed rather than precision, the present + routine achieves consistency with the refracted-to-unrefracted + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model at better than 1~microarcsecond within + $30^\circ$ of the zenith and remains within 1~milliarcsecond to + $\zeta=70^\circ$. The inherent accuracy of the model is, of + course, far worse than this -- see the documentation for sla\_REFCO + for more information. + \item At low elevations (below about $3^\circ$) the refraction + correction is held back to prevent arithmetic problems and + wildly wrong results. For optical/IR wavelengths, over a wide + range of observer heights and corresponding temperatures and + pressures, the following levels of accuracy (worst case) + are achieved, relative to numerical integration through a model + atmosphere: + \begin{center} + \begin{tabular}{ccl} + $\zeta_{obs}$ & {\it error} \\ \\ + $80^\circ$ & \arcsec{0}{7} \\ + $81^\circ$ & \arcsec{1}{3} \\ + $82^\circ$ & \arcsec{2}{5} \\ + $83^\circ$ & \arcseci{5} \\ + $84^\circ$ & \arcseci{10} \\ + $85^\circ$ & \arcseci{20} \\ + $86^\circ$ & \arcseci{55} \\ + $87^\circ$ & \arcseci{160} \\ + $88^\circ$ & \arcseci{360} \\ + $89^\circ$ & \arcseci{640} \\ + $90^\circ$ & \arcseci{1100} \\ + $91^\circ$ & \arcseci{1700} & $<$ high-altitude \\ + $92^\circ$ & \arcseci{2600} & $<$ sites only \\ + \end{tabular} + \end{center} + The results for radio are slightly worse over most of the range, + becoming significantly worse below $\zeta = 88^\circ$ + and unusable beyond $\zeta = 90^\circ$. + \item See also the routine sla\_REFZ, which performs the adjustment to + the zenith distance rather than in \xyz. + The present routine is faster than sla\_REFZ and, + except very low down, + is equally accurate for all practical purposes. However, beyond + about $\zeta=84^\circ$ sla\_REFZ should be used, and for the utmost + accuracy iterative use of sla\_REFRO should be considered. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_REFZ}{Apply Refraction to ZD} +{ + \action{Adjust an unrefracted zenith distance to include the effect of + atmospheric refraction, using the simple + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ model.} + \call{CALL sla\_REFZ (ZU, REFA, REFB, ZR)} +} +\args{GIVEN} +{ + \spec{ZU}{D}{unrefracted zenith distance of the source (radians)} \\ + \spec{REFA}{D}{$\tan \zeta$ coefficient (radians)} \\ + \spec{REFB}{D}{$\tan^{3} \zeta$ coefficient (radians)} +} +\args{RETURNED} +{ + \spec{ZR}{D}{refracted zenith distance (radians)} +} +\notes +{ + \begin{enumerate} + \item This routine applies the adjustment for refraction in the + opposite sense to the usual one -- it takes an unrefracted + ({\it in vacuo}\/) position and produces an observed (refracted) + position, whereas the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model strictly + applies to the case where an observed position is to have the + refraction removed. The unrefracted to refracted case is + harder, and requires an inverted form of the text-book + refraction models; the formula used here is based on the + Newton-Raphson method. For the utmost numerical consistency + with the refracted to unrefracted model, two iterations are + carried out, achieving agreement at the $10^{-11}$~arcsecond level + for $\zeta=80^\circ$. The inherent accuracy of the model + is, of course, far worse than this -- see the documentation for + sla\_REFCO for more information. + \item At $\zeta=83^\circ$, the rapidly-worsening + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + model is abandoned and an empirical formula takes over: + + \[\Delta \zeta = F \left( + \frac{0^\circ\hspace{-0.37em}.\hspace{0.02em}55445 + - 0^\circ\hspace{-0.37em}.\hspace{0.02em}01133 E + + 0^\circ\hspace{-0.37em}.\hspace{0.02em}00202 E^2} + {1 + 0.28385 E +0.02390 E^2} \right) \] + where $E=90^\circ-\zeta_{true}$ + and $F$ is a factor chosen to meet the + $\Delta \zeta = a \tan \zeta + b \tan^{3} \zeta$ + formula at $\zeta=83^\circ$. + + For optical/IR wavelengths, over a wide range of observer heights + and corresponding temperatures and pressures, the following levels + of accuracy (worst case) are achieved, + relative to numerical integration through a model atmosphere: + + \begin{center} + \begin{tabular}{ccl} + $\zeta_{obs}$ & {\it error} \\ \\ + $80^\circ$ & \arcsec{0}{7} \\ + $81^\circ$ & \arcsec{1}{3} \\ + $82^\circ$ & \arcsec{2}{4} \\ + $83^\circ$ & \arcsec{4}{7} \\ + $84^\circ$ & \arcsec{6}{2} \\ + $85^\circ$ & \arcsec{6}{4} \\ + $86^\circ$ & \arcseci{8} \\ + $87^\circ$ & \arcseci{10} \\ + $88^\circ$ & \arcseci{15} \\ + $89^\circ$ & \arcseci{30} \\ + $90^\circ$ & \arcseci{60} \\ + $91^\circ$ & \arcseci{150} & $<$ high-altitude \\ + $92^\circ$ & \arcseci{400} & $<$ sites only \\ + \end{tabular} + \end{center} + For radio wavelengths the errors are typically 50\% larger than + the optical figures and by $\zeta = 85^\circ$ are twice as bad, + worsening rapidly below that. To maintain \arcseci{1} accuracy + down to $\zeta = 85^\circ$ at the Green Bank site, Condon (2004) + has suggested amplifying the amount of refraction predicted by + sla\_REFZ below \degree{10}{8} elevation by the factor + $(1+0.00195*(10.8-E_{topo}))$, where $E_{topo}$ is the + unrefracted elevation in degrees. + + The high-ZD model is scaled to match the normal model at the + transition point; there is no glitch. + \item See also the routine sla\_REFV, which performs the adjustment in + \xyz , and with the emphasis on speed rather than numerical accuracy. + \end{enumerate} +} +\aref{Condon,\,J.J., {\it Refraction Corrections for the GBT,} PTCS/PN/35.2, + NRAO Green Bank, 2004.} +%----------------------------------------------------------------------- +\routine{SLA\_RVEROT}{RV Corrn to Earth Centre} +{ + \action{Velocity component in a given direction due to Earth rotation.} + \call{R~=~sla\_RVEROT (PHI, RA, DA, ST)} +} +\args{GIVEN} +{ + \spec{PHI}{R}{geodetic latitude of observing station (radians)} \\ + \spec{RA,DA}{R}{apparent \radec\ (radians)} \\ + \spec{ST}{R}{local apparent sidereal time (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVEROT}{R}{Component of Earth rotation in + direction [RA,DA]~(km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when the observatory + is receding from the given point on the sky. + \item Accuracy: the simple algorithm used assumes a spherical Earth and + an observing station at sea level; for actual observing + sites, the error is unlikely to be greater than 0.0005~km~s$^{-1}$. + For applications requiring greater accuracy, use the routine + sla\_PVOBS. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RVGALC}{RV Corrn to Galactic Centre} +{ + \action{Velocity component in a given direction due to the rotation + of the Galaxy.} + \call{R~=~sla\_RVGALC (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVGALC}{R}{Component of dynamical LSR motion in direction + R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when the LSR + is receding from the given point on the sky. + \item The Local Standard of Rest used here is a point in the + vicinity of the Sun which is in a circular orbit around + the Galactic centre. Sometimes called the {\it dynamical}\/ LSR, + it is not to be confused with a {\it kinematical}\/ LSR, which + is the mean standard of rest of star catalogues or stellar + populations. + \item The dynamical LSR velocity due to Galactic rotation is assumed to + be 220~km~s$^{-1}$ towards $l^{I\!I}=90^{\circ}$, + $b^{I\!I}=0$. + \end{enumerate} +} +\aref{Kerr \& Lynden-Bell (1986), MNRAS, 221, p1023.} +%----------------------------------------------------------------------- +\routine{SLA\_RVLG}{RV Corrn to Local Group} +{ + \action{Velocity component in a given direction due to the combination + of the rotation of the Galaxy and the motion of the Galaxy + relative to the mean motion of the local group.} + \call{R~=~sla\_RVLG (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLG}{R}{Component of {\bf solar} ({\it n.b.}) + motion in direction R2000,D2000 (km~s$^{-1}$)} +} +\anote{Sign convention: the result is positive when + the Sun is receding from the given point on the sky.} +\aref{{\it IAU Trans.}\ 1976.\ {\bf 16B}, p201.} +%----------------------------------------------------------------------- +\routine{SLA\_RVLSRD}{RV Corrn to Dynamical LSR} +{ + \action{Velocity component in a given direction due to the Sun's + motion with respect to the ``dynamical'' Local Standard of Rest.} + \call{R~=~sla\_RVLSRD (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLSRD}{R}{Component of {\it peculiar}\/ solar motion + in direction R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when + the Sun is receding from the given point on the sky. + \item The Local Standard of Rest used here is the {\it dynamical}\/ LSR, + a point in the vicinity of the Sun which is in a circular + orbit around the Galactic centre. The Sun's motion with + respect to the dynamical LSR is called the {\it peculiar}\/ solar + motion. + \item There is another type of LSR, called a {\it kinematical}\/ LSR. A + kinematical LSR is the mean standard of rest of specified star + catalogues or stellar populations, and several slightly + different kinematical LSRs are in use. The Sun's motion with + respect to an agreed kinematical LSR is known as the + {\it standard}\/ solar motion. + The dynamical LSR is seldom used by observational astronomers, + who conventionally use a kinematical LSR such as the one implemented + in the routine sla\_RVLSRK. + \item The peculiar solar motion is from Delhaye (1965), in {\it Stars + and Stellar Systems}, vol~5, p73: in Galactic Cartesian + coordinates (+9,+12,+7)~km~s$^{-1}$. + This corresponds to about 16.6~km~s$^{-1}$ + towards Galactic coordinates $l^{I\!I}=53^{\circ},b^{I\!I}=+25^{\circ}$. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_RVLSRK}{RV Corrn to Kinematical LSR} +{ + \action{Velocity component in a given direction due to the Sun's + motion with respect to a kinematical Local Standard of Rest.} + \call{R~=~sla\_RVLSRK (R2000, D2000)} +} +\args{GIVEN} +{ + \spec{R2000,D2000}{R}{J2000.0 mean \radec\ (radians)} +} +\args{RETURNED} +{ + \spec{sla\_RVLSRK}{R}{Component of {\it standard}\/ solar motion + in direction R2000,D2000 (km~s$^{-1}$)} +} +\notes +{ + \begin{enumerate} + \item Sign convention: the result is positive when + the Sun is receding from the given point on the sky. + \item The Local Standard of Rest used here is one of several + {\it kinematical}\/ LSRs in common use. A kinematical LSR is the + mean standard of rest of specified star catalogues or stellar + populations. The Sun's motion with respect to a kinematical + LSR is known as the {\it standard}\/ solar motion. + \item There is another sort of LSR, seldom used by observational + astronomers, called the {\it dynamical}\/ LSR. This is a + point in the vicinity of the Sun which is in a circular orbit + around the Galactic centre. The Sun's motion with respect to + the dynamical LSR is called the {\it peculiar}\/ solar motion. To + obtain a radial velocity correction with respect to the + dynamical LSR use the routine sla\_RVLSRD. + \item The adopted standard solar motion is 20~km~s$^{-1}$ + towards $\alpha=18^{\rm h},\delta=+30^{\circ}$ (1900). + \end{enumerate} +} +\refs +{ + \begin{enumerate} + \item Delhaye (1965), in {\it Stars and Stellar Systems}, vol~5, p73. + \item {\it Methods of Experimental Physics}\/ (ed Meeks), vol~12, + part~C, sec~6.1.5.2, p281. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_S2TP}{Spherical to Tangent Plane} +{ + \action{Projection of spherical coordinates onto the tangent plane + (single precision).} + \call{CALL sla\_S2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{RA,DEC}{R}{spherical coordinates of star (radians)} \\ + \spec{RAZ,DECZ}{R}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{XI,ETA}{R}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_V2TP is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SEP}{Angle Between 2 Points on Sphere} +{ + \action{Angle between two points on a sphere (single precision).} + \call{R~=~sla\_SEP (A1, B1, A2, B2)} +} +\args{GIVEN} +{ + \spec{A1,B1}{R}{spherical coordinates of one point (radians)} \\ + \spec{A2,B2}{R}{spherical coordinates of the other point (radians)} +} +\args{RETURNED} +{ + \spec{sla\_SEP}{R}{angle between [A1,B1] and [A2,B2] in radians} +} +\notes +{ + \begin{enumerate} + \item The spherical coordinates are right ascension and declination, + longitude and latitude, {\it etc.}\ in radians. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SEPV}{Angle Between 2 Vectors} +{ + \action{Angle between two vectors (single precision).} + \call{R~=~sla\_SEPV (V1, V2)} +} +\args{GIVEN} +{ + \spec{V1}{R(3)}{first vector} \\ + \spec{V2}{R(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_SEPV}{R}{angle between V1 and V2 in radians} +} +\notes +{ + \begin{enumerate} + \item There is no requirement for either vector to be of unit length. + \item If either vector is null, zero is returned. + \item The result is always positive. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SMAT}{Solve Simultaneous Equations} +{ + \action{Matrix inversion and solution of simultaneous equations + (single precision).} + \call{CALL sla\_SMAT (N, A, Y, D, JF, IW)} +} +\args{GIVEN} +{ + \spec{N}{I}{number of unknowns} \\ + \spec{A}{R(N,N)}{matrix} \\ + \spec{Y}{R(N)}{vector} +} +\args{RETURNED} +{ + \spec{A}{R(N,N)}{matrix inverse} \\ + \spec{Y}{R(N)}{solution} \\ + \spec{D}{R}{determinant} \\ + \spec{JF}{I}{singularity flag: 0=OK} \\ + \spec{IW}{I(N)}{workspace} +} +\notes +{ + \begin{enumerate} + \item For the set of $n$ simultaneous linear equations in $n$ unknowns: + \begin{verse} + {\bf A}$\cdot${\bf y} = {\bf x} + \end{verse} + where: + \begin{itemize} + \item {\bf A} is a non-singular $n \times n$ matrix, + \item {\bf y} is the vector of $n$ unknowns, and + \item {\bf x} is the known vector, + \end{itemize} + sla\_SMAT computes: + \begin{itemize} + \item the inverse of matrix {\bf A}, + \item the determinant of matrix {\bf A}, and + \item the vector of $n$ unknowns {\bf y}. + \end{itemize} + Argument N is the order $n$, A (given) is the matrix {\bf A}, + Y (given) is the vector {\bf x} and Y (returned) + is the vector {\bf y}. + The argument A (returned) is the inverse matrix {\bf A}$^{-1}$, + and D is {\it det}\/({\bf A}). + \item JF is the singularity flag. If the matrix is non-singular, + JF=0 is returned. If the matrix is singular, JF=$-$1 + and D=0.0 are returned. In the latter case, the contents + of array A on return are undefined. + \item The algorithm is Gaussian elimination with partial pivoting. + This method is very fast; some much slower algorithms can give + better accuracy, but only by a small factor. + \item This routine replaces the obsolete sla\_SMATRX. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_SUBET}{Remove E-terms} +{ + \action{Remove the E-terms (elliptic component of annual aberration) + from a pre IAU~1976 catalogue \radec\ to give a mean place.} + \call{CALL sla\_SUBET (RC, DC, EQ, RM, DM)} +} +\args{GIVEN} +{ + \spec{RC,DC}{D}{\radec\ with E-terms included (radians)} \\ + \spec{EQ}{D}{Besselian epoch of mean equator and equinox} +} +\args{RETURNED} +{ + \spec{RM,DM}{D}{\radec\ without E-terms (radians)} +} +\anote{Most star positions from pre-1984 optical catalogues (or + obtained by astrometry with respect to such stars) have the + E-terms built-in. This routine converts such a position to a + formal mean place (allowing, for example, comparison with a + pulsar timing position).} +\aref{{\it Explanatory Supplement to the Astronomical Ephemeris}, + section 2D, page 48.} +%----------------------------------------------------------------------- +\routine{SLA\_SUPGAL}{Supergalactic to Galactic} +{ + \action{Transformation from de Vaucouleurs supergalactic coordinates + to IAU 1958 galactic coordinates.} + \call{CALL sla\_SUPGAL (DSL, DSB, DL, DB)} +} +\args{GIVEN} +{ + \spec{DSL,DSB}{D}{supergalactic longitude and latitude (radians)} +} +\args{RETURNED} +{ + \spec{DL,DB}{D}{galactic longitude and latitude \gal\ (radians)} +} +\refs +{ + \begin{enumerate} + \item de Vaucouleurs, de Vaucouleurs, \& Corwin, {\it Second Reference + Catalogue of Bright Galaxies}, U.Texas, p8. + \item Systems \& Applied Sciences Corp., documentation for the + machine-readable version of the above catalogue, + Contract NAS 5-26490. + \end{enumerate} + (These two references give different values for the galactic + longitude of the supergalactic origin. Both are wrong; the + correct value is $l^{I\!I}=137.37$.) +} +%------------------------------------------------------------------------------ +\routine{SLA\_SVD}{Singular Value Decomposition} +{ + \action{Singular value decomposition. + This routine expresses a given matrix {\bf A} as the product of + three matrices {\bf U}, {\bf W}, {\bf V}$^{T}$: + + \begin{tabular}{ll} + & {\bf A} = {\bf U} $\cdot$ {\bf W} $\cdot$ {\bf V}$^{T}$ + \end{tabular} + + where: + + \begin{tabular}{lll} + & {\bf A} & is any $m$ (rows) $\times n$ (columns) matrix, + where $m \geq n$ \\ + & {\bf U} & is an $m \times n$ column-orthogonal matrix \\ + & {\bf W} & is an $n \times n$ diagonal matrix with + $w_{ii} \geq 0$ \\ + & {\bf V}$^{T}$ & is the transpose of an $n \times n$ + orthogonal matrix + \end{tabular} +} + \call{CALL sla\_SVD (M, N, MP, NP, A, W, V, WORK, JSTAT)} +} +\args{GIVEN} +{ + \spec{M,N}{I}{$m$, $n$, the numbers of rows and columns in matrix {\bf A}} \\ + \spec{MP,NP}{I}{physical dimensions of array containing matrix {\bf A}} \\ + \spec{A}{D(MP,NP)}{array containing $m \times n$ matrix {\bf A}} +} +\args{RETURNED} +{ + \spec{A}{D(MP,NP)}{array containing $m \times n$ column-orthogonal + matrix {\bf U}} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal + matrix {\bf V} ({\it n.b.}\ not {\bf V}$^{T}$)} \\ + \spec{WORK}{D(N)}{workspace} \\ + \spec{JSTAT}{I}{0~=~OK, $-$1~=~array A wrong shape, $>$0~=~index of W + for which convergence failed (see note~3, below)} +} +\notes +{ + \begin{enumerate} + \item M and N are the {\it logical}\/ dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger {\it physical}\/ dimensions, given by MP and NP. + \item V contains matrix V, not the transpose of matrix V. + \item If the status JSTAT is greater than zero, this need not + necessarily be treated as a failure. It means that, due to + chance properties of the matrix A, the QR transformation + phase of the routine did not fully converge in a predefined + number of iterations, something that very seldom occurs. + When this condition does arise, it is possible that the + elements of the diagonal matrix W have not been correctly + found. However, in practice the results are likely to + be trustworthy. Applications should report the condition + as a warning, but then proceed normally. + \end{enumerate} +} +\refs{The algorithm is an adaptation of the routine SVD in the {\it EISPACK}\, + library (Garbow~{\it et~al.}\ 1977, {\it EISPACK Guide Extension}, + Springer Verlag), which is a FORTRAN~66 implementation of the Algol + routine SVD of Wilkinson \& Reinsch 1971 ({\it Handbook for Automatic + Computation}, vol~2, ed Bauer~{\it et~al.}, Springer Verlag). These + references give full details of the algorithm used here. + A good account of the use of SVD in least squares problems is given + in {\it Numerical Recipes}\/ (Press~{\it et~al.}\ 1987, Cambridge + University Press), which includes another variant of the EISPACK code.} +%----------------------------------------------------------------------- +\routine{SLA\_SVDCOV}{Covariance Matrix from SVD} +{ + \action{From the {\bf W} and {\bf V} matrices from the SVD + factorization of a matrix + (as obtained from the sla\_SVD routine), obtain + the covariance matrix.} + \call{CALL sla\_SVDCOV (N, NP, NC, W, V, WORK, CVM)} +} +\args{GIVEN} +{ + \spec{N}{I}{$n$, the number of rows and columns in + matrices {\bf W} and {\bf V}} \\ + \spec{NP}{I}{first dimension of array containing $n \times n$ + matrix {\bf V}} \\ + \spec{NC}{I}{first dimension of array CVM} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal matrix {\bf V}} +} +\args{RETURNED} +{ + \spec{WORK}{D(N)}{workspace} \\ + \spec{CVM}{D(NC,NC)}{array to receive covariance matrix} +} +\aref{{\it Numerical Recipes}, section 14.3.} +%----------------------------------------------------------------------- +\routine{SLA\_SVDSOL}{Solution Vector from SVD} +{ + \action{From a given vector and the SVD of a matrix (as obtained from + the sla\_SVD routine), obtain the solution vector. + This routine solves the equation: + + \begin{tabular}{ll} + & {\bf A} $\cdot$ {\bf x} = {\bf b} + \end{tabular} + + where: + + \begin{tabular}{lll} + & {\bf A} & is a given $m$ (rows) $\times n$ (columns) + matrix, where $m \geq n$ \\ + & {\bf x} & is the $n$-vector we wish to find, and \\ + & {\bf b} & is a given $m$-vector + \end{tabular} + + by means of the {\it Singular Value Decomposition}\/ method (SVD).} + \call{CALL sla\_SVDSOL (M, N, MP, NP, B, U, W, V, WORK, X)} +} +\args{GIVEN} +{ + \spec{M,N}{I}{$m$, $n$, the numbers of rows and columns in matrix {\bf A}} \\ + \spec{MP,NP}{I}{physical dimensions of array containing matrix {\bf A}} \\ + \spec{B}{D(M)}{known vector {\bf b}} \\ + \spec{U}{D(MP,NP)}{array containing $m \times n$ matrix {\bf U}} \\ + \spec{W}{D(N)}{$n \times n$ diagonal matrix {\bf W} + (diagonal elements only)} \\ + \spec{V}{D(NP,NP)}{array containing $n \times n$ orthogonal matrix {\bf V}} +} +\args{RETURNED} +{ + \spec{WORK}{D(N)}{workspace} \\ + \spec{X}{D(N)}{unknown vector {\bf x}} +} +\notes +{ + \begin{enumerate} + \item In the Singular Value Decomposition method (SVD), + the matrix {\bf A} is first factorized (for example by + the routine sla\_SVD) into the following components: + + \begin{tabular}{ll} + & {\bf A} = {\bf U} $\cdot$ {\bf W} $\cdot$ {\bf V}$^{T}$ + \end{tabular} + + where: + + \begin{tabular}{lll} + & {\bf A} & is any $m$ (rows) $\times n$ (columns) matrix, + where $m > n$ \\ + & {\bf U} & is an $m \times n$ column-orthogonal matrix \\ + & {\bf W} & is an $n \times n$ diagonal matrix with + $w_{ii} \geq 0$ \\ + & {\bf V}$^{T}$ & is the transpose of an $n \times n$ + orthogonal matrix + \end{tabular} + + Note that $m$ and $n$ are the {\it logical}\/ dimensions of the + matrices and vectors concerned, which can be located in + arrays of larger {\it physical}\/ dimensions MP and NP. + The solution is then found from the expression: + + \begin{tabular}{ll} + & {\bf x} = {\bf V} $\cdot~[diag(1/${\bf W}$_{j})] + \cdot (${\bf U}$^{T} \cdot${\bf b}) + \end{tabular} + + \item If matrix {\bf A} is square, and if the diagonal matrix {\bf W} is not + altered, the method is equivalent to conventional solution + of simultaneous equations. + \item If $m > n$, the result is a least-squares fit. + \item If the solution is poorly determined, this shows up in the + SVD factorization as very small or zero {\bf W}$_{j}$ values. Where + a {\bf W}$_{j}$ value is small but non-zero it can be set to zero to + avoid ill effects. The present routine detects such zero + {\bf W}$_{j}$ values and produces a sensible solution, with highly + correlated terms kept under control rather than being allowed + to elope to infinity, and with meaningful values for the + other terms. + \end{enumerate} +} +\aref{{\it Numerical Recipes}, section 2.9.} +%----------------------------------------------------------------------- +\routine{SLA\_TP2S}{Tangent Plane to Spherical} +{ + \action{Transform tangent plane coordinates into spherical + coordinates (single precision)} + \call{CALL sla\_TP2S (XI, ETA, RAZ, DECZ, RA, DEC)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane rectangular coordinates (radians)} \\ + \spec{RAZ,DECZ}{R}{spherical coordinates of tangent point (radians)} +} +\args{RETURNED} +{ + \spec{RA,DEC}{R}{spherical coordinates (radians)} +} +\notes +{ + \begin{enumerate} + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_TP2V is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TP2V}{Tangent Plane to Direction Cosines} +{ + \action{Given the tangent-plane coordinates of a star and the direction + cosines of the tangent point, determine the direction cosines + of the star + (single precision).} + \call{CALL sla\_TP2V (XI, ETA, V0, V)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane coordinates of star (radians)} \\ + \spec{V0}{R(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{V}{R(3)}{direction cosines of star} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, the returned vector V will + be wrong. + \item If vector V0 points at a pole, the returned vector V will be + based on the arbitrary assumption that $\alpha=0$ at + the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_TP2S. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TPS2C}{Plate centre from $\xi,\eta$ and $\alpha,\delta$} +{ + \action{From the tangent plane coordinates of a star of known \radec, + determine the \radec\ of the tangent point (single precision)} + \call{CALL sla\_TPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane rectangular coordinates (radians)} \\ + \spec{RA,DEC}{R}{spherical coordinates (radians)} +} +\args{RETURNED} +{ + \spec{RAZ1,DECZ1}{R}{spherical coordinates of tangent point, + solution 1} \\ + \spec{RAZ2,DECZ2}{R}{spherical coordinates of tangent point, + solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The RAZ1 and RAZ2 values returned are in the range $0\!-\!2\pi$. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero $\xi$ value, and hence it is + meaningless to ask where the tangent point would have to be + to bring about this combination of $\xi$ and $\delta$. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. N\,=\,1 + indicates only one useful solution, the usual case; under + these circumstances, the second solution corresponds to the + ``over-the-pole'' case, and this is reflected in the values + of RAZ2 and DECZ2 which are returned. + \item The DECZ1 and DECZ2 values returned are in the range $\pm\pi$, + but in the ordinary, non-pole-crossing, case, the range is + $\pm\pi/2$. + \item RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2 are all in radians. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item When working in \xyz\ rather than spherical coordinates, the + equivalent Cartesian routine sla\_TPV2C is available. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_TPV2C}{Plate centre from $\xi,\eta$ and $x,y,z$} +{ + \action{From the tangent plane coordinates of a star of known + direction cosines, determine the direction cosines + of the tangent point (single precision)} + \call{CALL sla\_TPV2C (XI, ETA, V, V01, V02, N)} +} +\args{GIVEN} +{ + \spec{XI,ETA}{R}{tangent plane coordinates of star (radians)} \\ + \spec{V}{R(3)}{direction cosines of star} +} +\args{RETURNED} +{ + \spec{V01}{R(3)}{direction cosines of tangent point, solution 1} \\ + \spec{V01}{R(3)}{direction cosines of tangent point, solution 2} \\ + \spec{N}{I}{number of solutions:} \\ + \spec{}{}{\hspace{1em} 0 = no solutions returned (note 2)} \\ + \spec{}{}{\hspace{1em} 1 = only the first solution is useful (note 3)} \\ + \spec{}{}{\hspace{1em} 2 = there are two useful solutions (note 3)} +} +\notes +{ + \begin{enumerate} + \item The vector V must be of unit length or the result will be wrong. + \item Cases where there is no solution can only arise near the poles. + For example, it is clearly impossible for a star at the pole + itself to have a non-zero XI value. + \item Also near the poles, cases can arise where there are two useful + solutions. The argument N indicates whether the second of the + two solutions returned is useful. + N\,=\,1 + indicates only one useful solution, the usual case; under these + circumstances, the second solution can be regarded as valid if + the vector V02 is interpreted as the ``over-the-pole'' case. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_TPS2C. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_UE2EL}{Universal to Conventional Elements} +{ + \action{Transform universal elements into conventional heliocentric + osculating elements.} + \call{CALL sla\_UE2EL (\vtop{ + \hbox{U, JFORMR,} + \hbox{JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, JSTAT)}}} +} +\args{GIVEN} +{ + \spec{U}{D(13)}{universal orbital elements (updated; Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} \\ \\ + \spec{JFORMR}{I}{requested element set (1-3; Note~3)} +} +\args{RETURNED} +{ + \spec{JFORM}{I}{element set actually returned (1-3; Note~4)} \\ + \spec{EPOCH}{D}{epoch of elements ($t_0$ or $T$, TT MJD)} \\ + \spec{ORBINC}{D}{inclination ($i$, radians)} \\ + \spec{ANODE}{D}{longitude of the ascending node ($\Omega$, radians)} \\ + \spec{PERIH}{D}{longitude or argument of perihelion + ($\varpi$ or $\omega$,} \\ + \spec{}{}{\hspace{1.5em} radians)} \\ + \spec{AORQ}{D}{mean distance or perihelion distance ($a$ or $q$, AU)} \\ + \spec{E}{D}{eccentricity ($e$)} \\ + \spec{AORL}{D}{mean anomaly or longitude + ($M$ or $L$, radians,} \\ + \spec{}{}{\hspace{1.5em} JFORM=1,2 only)} \\ + \spec{DM}{D}{daily motion ($n$, radians, JFORM=1 only)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{2.3em} 0 = OK} \\ + \spec{}{}{\hspace{1.5em} $-$1 = illegal PMASS} \\ + \spec{}{}{\hspace{1.5em} $-$2 = illegal JFORMR} \\ + \spec{}{}{\hspace{1.5em} $-$3 = position/velocity out of allowed range} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference 2). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The universal elements are with respect to the mean equator and + equinox of epoch J2000. The orbital elements produced are with + respect to the J2000 ecliptic and mean equinox. + \item Three different element-format options are supported, as + follows. \\ + + JFORM=1, suitable for the major planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & longitude of perihelion $\varpi$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean longitude $L$ (radians) \\ + & DM & = & daily motion $n$ (radians) + \end{tabular} + + JFORM=2, suitable for minor planets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of elements $t_0$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & mean distance $a$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e < 1 )$ \\ + & AORL & = & mean anomaly $M$ (radians) + \end{tabular} + + JFORM=3, suitable for comets: + + \begin{tabular}{llll} + & EPOCH & = & epoch of perihelion $T$ (TT MJD) \\ + & ORBINC & = & inclination $i$ (radians) \\ + & ANODE & = & longitude of the ascending node $\Omega$ (radians) \\ + & PERIH & = & argument of perihelion $\omega$ (radians) \\ + & AORQ & = & perihelion distance $q$ (AU) \\ + & E & = & eccentricity $e$ $( 0 \leq e \leq 10 )$ + \end{tabular} + + \item It may not be possible to generate elements in the form + requested through JFORMR. The caller is notified of the form + of elements actually returned by means of the JFORM argument: + + \begin{tabular}{llll} + & JFORMR & JFORM & meaning \\ \\ + & ~~~~~1 & ~~~~~1 & OK: elements are in the requested format \\ + & ~~~~~1 & ~~~~~2 & never happens \\ + & ~~~~~1 & ~~~~~3 & orbit not elliptical \\ + & ~~~~~2 & ~~~~~1 & never happens \\ + & ~~~~~2 & ~~~~~2 & OK: elements are in the requested format \\ + & ~~~~~2 & ~~~~~3 & orbit not elliptical \\ + & ~~~~~3 & ~~~~~1 & never happens \\ + & ~~~~~3 & ~~~~~2 & never happens \\ + & ~~~~~3 & ~~~~~3 & OK: elements are in the requested format + \end{tabular} + + \item The arguments returned for each value of JFORM ({\it cf.}\/ Note~5: + JFORM may not be the same as JFORMR) are as follows: + + \begin{tabular}{lllll} + & JFORM & 1 & 2 & 3 \\ \\ + & EPOCH & $t_0$ & $t_0$ & $T$ \\ + & ORBINC & $i$ & $i$ & $i$ \\ + & ANODE & $\Omega$ & $\Omega$ & $\Omega$ \\ + & PERIH & $\varpi$ & $\omega$ & $\omega$ \\ + & AORQ & $a$ & $a$ & $q$ \\ + & E & $e$ & $e$ & $e$ \\ + & AORL & $L$ & $M$ & - \\ + & DM & $n$ & - & - + \end{tabular} + + where: + + \begin{tabular}{lll} + & $t_0$ & is the epoch of the elements (MJD, TT) \\ + & $T$ & is the epoch of perihelion (MJD, TT) \\ + & $i$ & is the inclination (radians) \\ + & $\Omega$ & is the longitude of the ascending node (radians) \\ + & $\varpi$ & is the longitude of perihelion (radians) \\ + & $\omega$ & is the argument of perihelion (radians) \\ + & $a$ & is the mean distance (AU) \\ + & $q$ & is the perihelion distance (AU) \\ + & $e$ & is the eccentricity \\ + & $L$ & is the longitude (radians, $0-2\pi$) \\ + & $M$ & is the mean anomaly (radians, $0-2\pi$) \\ + & $n$ & is the daily motion (radians) \\ + & - & means no value is set + \end{tabular} + + \item At very small inclinations, the longitude of the ascending node + ANODE becomes indeterminate and under some circumstances may be + set arbitrarily to zero. Similarly, if the orbit is close to + circular, the true anomaly becomes indeterminate and under some + circumstances may be set arbitrarily to zero. In such cases, + the other elements are automatically adjusted to compensate, + and so the elements remain a valid description of the orbit. + \end{enumerate} +} +\refs{ + \begin{enumerate} + \item Sterne, Theodore E., {\it An Introduction to Celestial Mechanics,}\/ + Interscience Publishers, 1960. Section 6.7, p199. + \item Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_UE2PV}{Pos/Vel from Universal Elements} +{ + \action{Heliocentric position and velocity of a planet, asteroid or comet, + starting from orbital elements in the ``universal variables'' form.} + \call{CALL sla\_UE2PV (DATE, U, PV, JSTAT)} +} +\args{GIVEN} +{ + \spec{DATE}{D}{date (TT Modified Julian Date = JD$-$2400000.5)} +} +\args{GIVEN and RETURNED} +{ + \spec{U}{D(13)}{universal orbital elements (updated; Note~1)} \\ + \specel {(1)} {combined mass ($M+m$)} \\ + \specel {(2)} {total energy of the orbit ($\alpha$)} \\ + \specel {(3)} {reference (osculating) epoch ($t_0$)} \\ + \specel {(4-6)} {position at reference epoch (${\rm \bf r}_0$)} \\ + \specel {(7-9)} {velocity at reference epoch (${\rm \bf v}_0$)} \\ + \specel {(10)} {heliocentric distance at reference epoch} \\ + \specel {(11)} {${\rm \bf r}_0.{\rm \bf v}_0$} \\ + \specel {(12)} {date ($t$)} \\ + \specel {(13)} {universal eccentric anomaly ($\psi$) of date, approx} +} +\args{RETURNED} +{ + \spec{PV}{D(6)}{heliocentric \xyzxyzd, equatorial, J2000} \\ + \spec{}{}{\hspace{1.5em} (AU, AU/s; Note~1)} \\ + \spec{JSTAT}{I}{status:} \\ + \spec{}{}{\hspace{1.95em} 0 = OK} \\ + \spec{}{}{\hspace{1.2em} $-$1 = radius vector zero} \\ + \spec{}{}{\hspace{1.2em} $-2$ = failed to converge} +} +\notes +{ + \begin{enumerate} + \setlength{\parskip}{\medskipamount} + \item The ``universal'' elements are those which define the orbit for the + purposes of the method of universal variables (see reference). + They consist of the combined mass of the two bodies, an epoch, + and the position and velocity vectors (arbitrary reference frame) + at that epoch. The parameter set used here includes also various + quantities that can, in fact, be derived from the other + information. This approach is taken to avoiding unnecessary + computation and loss of accuracy. The supplementary quantities + are (i)~$\alpha$, which is proportional to the total energy of the + orbit, (ii)~the heliocentric distance at epoch, + (iii)~the outwards component of the velocity at the given epoch, + (iv)~an estimate of $\psi$, the ``universal eccentric anomaly'' at a + given date and (v)~that date. + \item The companion routine is sla\_EL2UE. This takes the conventional + orbital elements and transforms them into the set of numbers + needed by the present routine. A single prediction requires one + one call to sla\_EL2UE followed by one call to the present routine; + for convenience, the two calls are packaged as the routine + sla\_PLANEL. Multiple predictions may be made by again + calling sla\_EL2UE once, but then calling the present routine + multiple times, which is faster than multiple calls to sla\_PLANEL. + + It is not obligatory to use sla\_EL2UE to obtain the parameters. + However, it should be noted that because sla\_EL2UE performs its + own validation, no checks on the contents of the array U are made + by the present routine. + \item DATE is the instant for which the prediction is required. It is + in the TT time scale (formerly Ephemeris Time, ET) and is a + Modified Julian Date (JD$-$2400000.5). + \item The universal elements supplied in the array U are in canonical + units (solar masses, AU and canonical days). The position and + velocity are not sensitive to the choice of reference frame. The + sla\_EL2UE routine in fact produces coordinates with respect to the + J2000 equator and equinox. + \item The algorithm was originally adapted from the EPHSLA program of + D.\,H.\,P.\,Jones (private communication, 1996). The method + is based on Stumpff's Universal Variables. + \end{enumerate} +} +\aref{Everhart, E. \& Pitkin, E.T., Am.~J.~Phys.~51, 712, 1983.} +%----------------------------------------------------------------------- +\routine{SLA\_UNPCD}{Remove Radial Distortion} +{ + \action{Remove pincushion/barrel distortion from a distorted + \xy\ to give tangent-plane \xy.} + \call{CALL sla\_UNPCD (DISCO,X,Y)} +} +\args{GIVEN} +{ + \spec{DISCO}{D}{pincushion/barrel distortion coefficient} \\ + \spec{X,Y}{D}{distorted \xy} +} +\args{RETURNED} +{ + \spec{X,Y}{D}{tangent-plane \xy} +} +\notes +{ + \begin{enumerate} + \item The distortion is of the form $\rho = r (1 + c r^{2})$, where $r$ is + the radial distance from the tangent point, $c$ is the DISCO + argument, and $\rho$ is the radial distance in the presence of + the distortion. + \item For {\it pincushion}\/ distortion, C is +ve; for + {\it barrel}\/ distortion, C is $-$ve. + \item For X,Y in units of one projection radius (in the case of + a photographic plate, the focal length), the following + DISCO values apply: + + \vspace{2ex} + + \hspace{5em} + \begin{tabular}{|l|c|} \hline + Geometry & DISCO \\ \hline \hline + astrograph & 0.0 \\ \hline + Schmidt & $-$0.3333 \\ \hline + AAT PF doublet & +147.069 \\ \hline + AAT PF triplet & +178.585 \\ \hline + AAT f/8 & +21.20 \\ \hline + JKT f/8 & +14.6 \\ \hline + \end{tabular} + + \vspace{2ex} + + \item The present routine is a rigorous inverse of the companion + routine sla\_PCD. The expression for $\rho$ in Note~1 + is rewritten in the form $x^3 + ax + b = 0$ and solved by + standard techniques. + + \item Cases where the cubic has multiple real roots can sometimes + occur, corresponding to extreme instances of barrel distortion + where up to three different undistorted \xy s all produce the + same distorted \xy. However, only one solution is returned, + the one that produces the smallest change in \xy. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_V2TP}{Direction Cosines to Tangent Plane} +{ + \action{Given the direction cosines of a star and of the tangent point, + determine the star's tangent-plane coordinates + (single precision).} + \call{CALL sla\_V2TP (V, V0, XI, ETA, J)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{direction cosines of star} \\ + \spec{V0}{R(3)}{direction cosines of tangent point} +} +\args{RETURNED} +{ + \spec{XI,ETA}{R}{tangent plane coordinates (radians)} \\ + \spec{J}{I}{status:} \\ + \spec{}{}{\hspace{1.5em} 0 = OK, star on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 1 = error, star too far from axis} \\ + \spec{}{}{\hspace{1.5em} 2 = error, antistar on tangent plane} \\ + \spec{}{}{\hspace{1.5em} 3 = error, antistar too far from axis} +} +\notes +{ + \begin{enumerate} + \item If vector V0 is not of unit length, or if vector V is of zero + length, the results will be wrong. + \item If V0 points at a pole, the returned $\xi,\eta$ + will be based on the + arbitrary assumption that $\alpha=0$ at the tangent point. + \item The projection is called the {\it gnomonic}\/ projection; the + Cartesian coordinates \xieta\ are called + {\it standard coordinates.}\/ The latter + are in units of the distance from the tangent plane to the projection + point, {\it i.e.}\ radians near the origin. + \item This routine is the Cartesian equivalent of the routine sla\_S2TP. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_VDV}{Scalar Product} +{ + \action{Scalar product of two 3-vectors (single precision).} + \call{R~=~sla\_VDV (VA, VB)} +} +\args{GIVEN} +{ + \spec{VA}{R(3)}{first vector} \\ + \spec{VB}{R(3)}{second vector} +} +\args{RETURNED} +{ + \spec{sla\_VDV}{R}{scalar product VA.VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_VN}{Normalize Vector} +{ + \action{Normalize a 3-vector, also giving the modulus (single precision).} + \call{CALL sla\_VN (V, UV, VM)} +} +\args{GIVEN} +{ + \spec{V}{R(3)}{vector} +} +\args{RETURNED} +{ + \spec{UV}{R(3)}{unit vector in direction of V} \\ + \spec{VM}{R}{modulus of V} +} +\anote{If the modulus of V is zero, UV is set to zero as well.} +%----------------------------------------------------------------------- +\routine{SLA\_VXV}{Vector Product} +{ + \action{Vector product of two 3-vectors (single precision).} + \call{CALL sla\_VXV (VA, VB, VC)} +} +\args{GIVEN} +{ + \spec{VA}{R(3)}{first vector} \\ + \spec{VB}{R(3)}{second vector} +} +\args{RETURNED} +{ + \spec{VC}{R(3)}{vector product VA$\times$VB} +} +%----------------------------------------------------------------------- +\routine{SLA\_WAIT}{Time Delay} +{ + \action{Wait for a specified interval.} + \call{CALL sla\_WAIT (DELAY)} +} +\args{GIVEN} +{ + \spec{DELAY}{R}{delay in seconds} +} +\notes +{ + \begin{enumerate} + \item The implementation is machine-specific. + \item The delay actually requested is restricted to the range + 100ns-200s in the present implementation. + \item There is no guarantee of accuracy, though on almost all + types of computer the program will certainly not + resume execution {\it before}\/ the stated interval has + elapsed. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_XY2XY}{Apply Linear Model to an \xy} +{ + \action{Transform one \xy\ into another using a linear model of the type + produced by the sla\_FITXY routine.} + \call{CALL sla\_XY2XY (X1, Y1, COEFFS, X2, Y2)} +} +\args{GIVEN} +{ + \spec{X1,Y1}{D}{\xy\ before transformation} \\ + \spec{COEFFS}{D(6)}{transformation coefficients (see note)} +} +\args{RETURNED} +{ + \spec{X2,Y2}{D}{\xy\ after transformation} +} +\notes +{ + \begin{enumerate} + \item The model relates two sets of \xy\ coordinates as follows. + Naming the six elements of COEFFS $a,b,c,d,e$ \& $f$, + the present routine performs the transformation: + \begin{verse} + $x_{2} = a + bx_{1} + cy_{1}$ \\ + $y_{2} = d + ex_{1} + fy_{1}$ + \end{verse} + \item See also sla\_FITXY, sla\_PXY, sla\_INVF, sla\_DCMPF. + \end{enumerate} +} +%----------------------------------------------------------------------- +\routine{SLA\_ZD}{$h,\delta$ to Zenith Distance} +{ + \action{Hour angle and declination to zenith distance + (double precision).} + \call{D~=~sla\_ZD (HA, DEC, PHI)} +} +\args{GIVEN} +{ + \spec{HA}{D}{hour angle in radians} \\ + \spec{DEC}{D}{declination in radians} \\ + \spec{PHI}{D}{latitude in radians} +} +\args{RETURNED} +{ + \spec{sla\_ZD}{D}{zenith distance (radians, $0\!-\!\pi$)} +} +\notes +{ + \begin{enumerate} + \item The latitude must be geodetic. In critical applications, + corrections for polar motion should be applied (see sla\_POLMO). + \item In some applications it will be important to specify the + correct type of hour angle and declination in order to + produce the required type + of zenith distance. In particular, it may be + important to distinguish between the zenith distance + as affected by refraction, which would require the + {\it observed}\/ \hadec, and the zenith distance {\it in vacuo}, + which would require the {\it topocentric}\/ \hadec. If + the effects of diurnal aberration can be neglected, the + {\it apparent}\/ \hadec\ may be used instead of the + {\it topocentric}\/ \hadec. + \item No range checking of arguments is done. + \item In applications which involve many zenith distance calculations, + rather than calling the present routine it will be more + efficient to use inline code, having previously computed fixed + terms such as sine and cosine of latitude, and perhaps sine and + cosine of declination. + \end{enumerate} +} +\vfill +\pagebreak + +\section{EXPLANATION AND EXAMPLES} +To guide the writer of positional-astronomy applications software, +this final chapter puts the SLALIB routines into the context of +astronomical phenomena and techniques, and presents a few +``cookbook'' examples +of the SLALIB calls in action. The astronomical content of the chapter +is not, of course, intended to be a substitute for specialist text-books on +positional astronomy, but may help bridge the gap between +such books and the SLALIB routines. For further reading, the following +cover a wide range of material and styles: +\begin{itemize} +\item {\it Explanatory Supplement to the Astronomical Almanac}, + ed.\ P.\,Kenneth~Seidelmann (1992), University Science Books. +\item {\it Vectorial Astrometry}, C.\,A.\,Murray (1983), Adam Hilger. +\item {\it Spherical Astronomy}, Robin~M.\,Green (1985), Cambridge + University Press. +\item {\it Spacecraft Attitude Determination and Control}, + ed.\ James~R.\,Wertz (1986), Reidel. +\item {\it Practical Astronomy with your Calculator}, + Peter~Duffett-Smith (1981), Cambridge University Press. +\end{itemize} +Also of considerable value, though out of date in places, are: +\begin{itemize} +\item {\it Explanatory Supplement to the Astronomical Ephemeris + and the American Ephemeris and Nautical Almanac}, RGO/USNO (1974), + HMSO. +\item {\it Textbook on Spherical Astronomy}, W.\,M.\,Smart (1977), + Cambridge University Press. +\end{itemize} +Only brief details of individual SLALIB routines are given here, and +readers will find it useful to refer to the subprogram specifications +elsewhere in this document. The source code for the SLALIB routines +(available in both Fortran and C) is also intended to be used as +documentation. + +\subsection {Spherical Trigonometry} +Celestial phenomena occur at such vast distances from the +observer that for most practical purposes there is no need to +work in 3D; only the direction +of a source matters, not how far away it is. Things can +therefore be viewed as if they were happening +on the inside of sphere with the observer at the centre -- +the {\it celestial sphere}. Problems involving +positions and orientations in the sky can then be solved by +using the formulae of {\it spherical trigonometry}, which +apply to {\it spherical triangles}, the sides of which are +{\it great circles}. + +Positions on the celestial sphere may be specified by using +a spherical polar coordinate system, defined in terms of +some fundamental plane and a line in that plane chosen to +represent zero longitude. Mathematicians usually work with the +co-latitude, with zero at the principal pole, whereas most +astronomical coordinate systems use latitude, reckoned plus and +minus from the equator. +Astronomical coordinate systems may be either right-handed +({\it e.g.}\ right ascension and declination \radec, +Galactic longitude and latitude \gal) +or left-handed ({\it e.g.}\ hour angle and +declination \hadec). In some cases +different conventions have been used in the past, a fruitful source of +mistakes. Azimuth and geographical longitude are examples; azimuth +is now generally reckoned north through east +(making a left-handed system); geographical longitude is now usually +taken to increase eastwards (a right-handed system) but astronomers +used to employ a west-positive convention. In reports +and program comments it is wise to spell out what convention +is being used, if there is any possibility of confusion. + +When applying spherical trigonometry formulae, attention must be +paid to +rounding errors (for example it is a bad idea to find a +small angle through its cosine) and to the possibility of +problems close to poles. +Also, if a formulation relies on inspection to establish +the quadrant of the result, it is an indication that a vector-related +method might be preferable. + +As well as providing many routines which work in terms of specific +spherical coordinates such as \radec, SLALIB provides +two routines which operate directly on generic spherical +coordinates: +sla\_SEP +computes the separation between +two points (the distance along a great circle) and +sla\_BEAR +computes the bearing (or {\it position angle}) +of one point seen from the other. The routines +sla\_DSEP +and +sla\_DBEAR +are double precision equivalents. As a simple demonstration +of SLALIB, we will use these facilities to estimate the distance from +London to Sydney and the initial compass heading: +\goodbreak +\begin{verbatim} + IMPLICIT NONE + + * Degrees to radians + REAL D2R + PARAMETER (D2R=0.01745329252) + + * Longitudes and latitudes (radians) for London and Sydney + REAL AL,BL,AS,BS + PARAMETER (AL=-0.2*D2R,BL=51.5*D2R,AS=151.2*D2R,BS=-33.9*D2R) + + * Earth radius in km (spherical approximation) + REAL RKM + PARAMETER (RKM=6375.0) + + REAL sla_SEP,sla_BEAR + + + * Distance and initial heading (N=0, E=90) + WRITE (*,'(1X,I5,'' km,'',I4,'' deg'')') + : NINT(sla_SEP(AL,BL,AS,BS)*RKM),NINT(sla_BEAR(AL,BL,AS,BS)/D2R) + + END +\end{verbatim} +\goodbreak +(The result is 17011~km, $61^\circ$.) + +The routines +sla\_SEPV, +sla\_DSEPV, +sla\_PAV, +sla\_DPAV +are equivalents of sla\_SEP, sla\_DSEP, sla\_BEAR and sla\_DBEAR +but starting from vectors +instead of spherical coordinates. + +\subsubsection{Formatting angles} +SLALIB has routines for decoding decimal numbers +from character form and for converting angles to and from +sexagesimal form (hours, minutes, seconds or degrees, +arcminutes, arcseconds). These apparently straightforward +operations contain hidden traps which the SLALIB routines +avoid. + +There are five routines for decoding numbers from a character +string, such as might be entered using a keyboard. +They all work in the same style, and successive calls +can work their way along a single string decoding +a sequence of numbers of assorted types. Number +fields can be separated by spaces or commas, and can be defaulted +to previous values or to preset defaults. + +Three of the routines decode single numbers: +sla\_INTIN +(integer), +sla\_FLOTIN +(single precision floating point) and +sla\_DFLTIN +(double precision). A minus sign can be +detected even when the number is zero; this avoids +the frequently-encountered ``minus zero'' bug, where +declinations {\it etc.}\ in +the range $0^{\circ}$ to $-1^{\circ}$ mysteriously migrate to +the range $0^{\circ}$ to $+1^{\circ}$. +Here is an example (in Fortran) where we wish to +read two numbers, an integer {\tt IX} and a real, {\tt Y}, +with {\tt IX} defaulting to zero and {\tt Y} defaulting to +{\tt IX}: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION Y + CHARACTER*80 A + INTEGER IX,I,J + + * Input the string to be decoded + READ (*,'(A)') A + + * Preset IX to its default value + IX = 0 + + * Point to the start of the string + I = 1 + + * Decode an integer + CALL sla_INTIN(A,I,IX,J) + IF (J.GT.1) GO TO ... (bad IX) + + * Preset Y to its default value + Y = DBLE(IX) + + * Decode a double precision number + CALL sla_DFLTIN(A,I,Y,J) + IF (J.GT.1) GO TO ... (bad Y) +\end{verbatim} +\goodbreak +Two additional routines decode a 3-field sexagesimal number: +sla\_AFIN +(degrees, arcminutes, arcseconds to single +precision radians) and +sla\_DAFIN +(the same but double precision). They also +work using other units such as hours {\it etc}.\ if +you multiply the result by the appropriate factor. An example +Fortran program which uses +sla\_DAFIN +was given earlier, in section 1.2. + +SLALIB provides four routines for expressing an angle in radians +in a preferred range. The function +sla\_RANGE +expresses an angle +in the range $\pm\pi$; +sla\_RANORM +expresses an angle in the range +$0-2\pi$. The functions +sla\_DRANGE +and +sla\_DRANRM +are double precision versions. + +Several routines +(sla\_CTF2D, +sla\_CR2AF +{\it etc.}) are provided to convert +angles to and from +sexagesimal form (hours, minute, seconds or degrees, +arcminutes and arcseconds). +They avoid the common +``converting from integer to real at the wrong time'' +bug, which produces angles like \hms{24}{59}{59}{999}. +Here is a program which displays an hour angle +stored in radians: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION HA + CHARACTER SIGN + INTEGER IHMSF(4) + : + CALL sla_DR2TF(3,HA,SIGN,IHMSF) + WRITE (*,'(1X,A,3I3.2,''.'',I3.3)') SIGN,IHMSF +\end{verbatim} +\goodbreak + +\subsection {Vectors and Matrices} +As an alternative to employing a spherical polar coordinate system, +the direction of an object can be defined in terms of the sum of any +three vectors as long as they are different and +not coplanar. In practice, three vectors at right angles are +usually chosen, forming a system +of {\it Cartesian coordinates}. The {\it x}- and {\it y}-axes +lie in the fundamental plane ({\it e.g.}\ the equator in the +case of \radec), with the {\it x}-axis pointing to zero longitude. +The {\it z}-axis is normal to the fundamental plane and points +towards positive latitudes. The {\it y}-axis can lie in either +of the two possible directions, depending on whether the +coordinate system is right-handed or left-handed. +The three axes are sometimes called +a {\it triad}. For most applications involving arbitrarily +distant objects such as stars, the vector which defines +the direction concerned is constrained to have unit length. +The {\it x}-, {\it y-} and {\it z-}components +can be regarded as the scalar (dot) product of this vector +onto the three axes of the triad in turn. Because the vector +is a unit vector, +each of the three dot-products is simply the cosine of the angle +between the unit vector and the axis concerned, and the +{\it x}-, {\it y-} and {\it z-}components are sometimes +called {\it direction cosines}. + +For some applications, including those involving objects +within the Solar System, unit vectors are inappropriate, and +it is necessary to use vectors scaled in length-units such as +AU, km {\it etc.} +In these cases the origin of the coordinate system may not be +the observer, but instead might be the Sun, the Solar-System +barycentre, the centre of the Earth {\it etc.} But whatever the application, +the final direction in which the observer sees the object can be +expressed as direction cosines. + +But where has this got us? Instead of two numbers -- a longitude and +a latitude -- we now have three numbers to look after +-- the {\it x}-, {\it y-} and +{\it z-}components -- whose quadratic sum we have somehow to contrive to +be unity. And, in addition to this apparent redundancy, +most people find it harder to visualize +problems in terms of \xyz\ than in $[\,\theta,\phi~]$. +Despite these objections, the vector approach turns out to have +significant advantages over the spherical trigonometry approach: +\begin{itemize} +\item Vector formulae tend to be much more succinct; one vector + operation is the equivalent of strings of sines and cosines. +\item The formulae are as a rule rigorous, even at the poles. +\item Accuracy is maintained all over the celestial sphere. + When one Cartesian component is nearly unity and + therefore insensitive to direction, the others become small + and therefore more precise. +\item Formulations usually deliver the quadrant of the result + without the need for any inspection (except within the + library function ATAN2). +\end{itemize} +A number of important transformations in positional +astronomy turn out to be nothing more than changes of coordinate +system, something which is especially convenient if +the vector approach is used. A direction with respect +to one triad can be expressed relative to another triad simply +by multiplying the \xyz\ column vector by the appropriate +$3\times3$ orthogonal matrix +(a tensor of Rank~2, or {\it dyadic}). The three rows of this +{\it rotation matrix}\/ +are the vectors in the old coordinate system of the three +new axes, and the transformation amounts to obtaining the +dot-product of the direction-vector with each of the three +new axes. Precession, nutation, \hadec\ to \azel, +\radec\ to \gal\ and so on are typical examples of the +technique. A useful property of the rotation matrices +is that they can be inverted simply by taking the transpose. + +The elements of these vectors and matrices are assorted combinations of +the sines and cosines of the various angles involved (hour angle, +declination and so on, depending on which transformation is +being applied). If you write out the matrix multiplications +in full you get expressions which are essentially the same as the +equivalent spherical trigonometry formulae. Indeed, many of the +standard formulae of spherical trigonometry are most easily +derived by expressing the problem initially in +terms of vectors. + +\subsubsection{Using vectors} +SLALIB provides conversions between spherical and vector +form +(sla\_CS2C, +sla\_CC2S +{\it etc.}), plus an assortment +of standard vector and matrix operations +(sla\_VDV, +sla\_MXV +{\it etc.}). +There are also routines +(sla\_EULER +{\it etc.}) for creating a rotation matrix +from three {\it Euler angles}\/ (successive rotations about +specified Cartesian axes). Instead of Euler angles, a rotation +matrix can be expressed as an {\it axial vector}\/ (the pole of the rotation, +and the amount of rotation), and routines are provided for this +(sla\_AV2M, +sla\_M2AV +{\it etc.}). + +Here is an example where spherical coordinates {\tt P1} and {\tt Q1} +undergo a coordinate transformation and become {\tt P2} and {\tt Q2}; +the transformation consists of a rotation of the coordinate system +through angles {\tt A}, {\tt B} and {\tt C} about the +{\it z}, new {\it y}\/ and new {\it z}\/ axes respectively: +\goodbreak +\begin{verbatim} + REAL A,B,C,R(3,3),P1,Q1,V1(3),V2(3),P2,Q2 + : + * Create rotation matrix + CALL sla_EULER('ZYZ',A,B,C,R) + + * Transform position (P1,Q1) from spherical to Cartesian + CALL sla_CS2C(P1,Q1,V1) + + * Apply the rotation + CALL sla_MXV(R,V1,V2) + + * Back to spherical + CALL sla_CC2S(V2,P2,Q2) +\end{verbatim} +\goodbreak +Small adjustments to the direction of a position +vector are often most conveniently described in terms of +$[\,\Delta x,\Delta y, \Delta z\,]$. Adding the correction +vector needs careful handling if the position +vector is to remain of length unity, an advisable precaution which +ensures that +the \xyz\ components are always available to mean the cosines of +the angles between the vector and the axis concerned. Two types +of shifts are commonly used, +the first where a small vector of arbitrary direction is +added to the unit vector, and the second where there is a displacement +in the latitude coordinate (declination, elevation {\it etc.}) alone. + +For a shift produced by adding a small \xyz\ vector ${\bf d}$ to a +unit vector ${\bf v}_1$, the resulting vector ${\bf v}_2$ has direction +$<{\bf v}_1+{\bf d}>$ but is no longer of unit length. A better approximation +is available if the result is multiplied by a scaling factor of +$(1-{\bf d}\cdot{\bf v}_1)$, where the dot +means scalar product. In Fortran: +\goodbreak +\begin{verbatim} + F = (1D0-(DX*V1X+DY*V1Y+DZ*V1Z)) + V2X = F*(V1X+DX) + V2Y = F*(V1Y+DY) + V2Z = F*(V1Z+DZ) +\end{verbatim} +\goodbreak +\noindent +The correction for diurnal aberration (discussed later) is +an example of this form of shift. + +As an example of the second kind of displacement +we will apply a small change in elevation $\delta E$ to an +\azel\ direction vector. The direction of the +result can be obtained by making the allowable approximation +${\tan \delta E\approx\delta E}$ and adding a adjustment +vector of length $\delta E$ normal +to the direction vector in the vertical plane containing the direction +vector. The $z$-component of the adjustment vector is +$\delta E \cos E$, +and the horizontal component is +$\delta E \sin E$ which has then to be +resolved into $x$ and $y$ in proportion to their current sizes. To +approximate a unit vector more closely, a correction factor of +$\cos \delta E$ can then be applied, which is nearly +$(1-\delta E^2 /2)$ for +small $\delta E$. Expressed in Fortran, for initial vector +{\tt V1X,V1Y,V1Z}, change in elevation {\tt DEL} +(+ve $\equiv$ upwards), and result +vector {\tt V2X,V2Y,V2Z}: +\goodbreak +\begin{verbatim} + COSDEL = 1D0-DEL*DEL/2D0 + R1 = SQRT(V1X*V1X+V1Y*V1Y) + F = COSDEL*(R1-DEL*V1Z)/R1 + V2X = F*V1X + V2Y = F*V1Y + V2Z = COSDEL*(V1Z+DEL*R1) +\end{verbatim} +\goodbreak +An example of this type of shift is the correction for atmospheric +refraction (see later). +Depending on the relationship between $\delta E$ and $E$, special +handling at the pole (the zenith for our example) may be required. + +SLALIB includes routines for the case where both a position +and a velocity are involved. The routines +sla\_CS2C6 +and +sla\_CC62S +convert from $[\theta,\phi,\dot{\theta},\dot{\phi}]$ +to \xyzxyzd\ and back; +sla\_DS2C6 +and +sla\_DC62S +are double precision equivalents. + +\subsection {Celestial Coordinate Systems} +SLALIB has routines to perform transformations +of celestial positions between different spherical +coordinate systems, including those shown in the following table: + +\begin{center} +\begin{tabular}{|l|c|c|c|c|c|c|} \hline +{\it system} & {\it symbols} & {\it longitude} & {\it latitude} & + {\it x-y plane} & {\it long.\ zero} & {\it RH/LH} +\\ \hline \hline +horizon & -- & azimuth & elevation & horizontal & north & L +\\ \hline +equatorial & $\alpha,\delta$ & R.A.\ & Dec.\ & equator & equinox & R +\\ \hline +local equ.\ & $h,\delta$ & H.A.\ & Dec.\ & equator & meridian & L +\\ \hline +ecliptic & $\lambda,\beta$ & ecl.\ long.\ & ecl.\ lat.\ & + ecliptic & equinox & R +\\ \hline +galactic & $l^{I\!I},b^{I\!I}$ & gal.\ long.\ & gal.\ lat.\ & + gal.\ equator & gal.\ centre & R +\\ \hline +supergalactic & SGL,SGB & SG long.\ & SG lat.\ & + SG equator & node w.\ gal.\ equ.\ & R +\\ \hline +\end{tabular} +\end{center} +Transformations between \hadec\ and \azel\ can be performed by +calling +sla\_E2H +and +sla\_H2E, +or, in double precision, +sla\_DE2H +and +sla\_DH2E. +There is also a routine for obtaining +zenith distance alone for a given \hadec, +sla\_ZD, +and one for determining the parallactic angle, +sla\_PA. +Three routines are included which relate to altazimuth telescope +mountings. For a given \hadec\ and latitude, +sla\_ALTAZ +returns the azimuth, elevation and parallactic angle, plus +velocities and accelerations for sidereal tracking. +The routines +sla\_PDA2H +and +sla\_PDQ2H +predict at what hour angle a given azimuth or +parallactic angle will be reached. + +The routines +sla\_EQECL +and +sla\_ECLEQ +transform between ecliptic +coordinates and \radec\/; there is also a routine for generating the +equatorial to ecliptic rotation matrix for a given date: +sla\_ECMAT. + +For conversion between Galactic coordinates and \radec\ there are +two sets of routines, depending on whether the \radec\ is +old-style, B1950, or new-style, J2000; +sla\_EG50 +and +sla\_GE50 +are \radec\ to \gal\ and {\it vice versa}\/ for the B1950 case, while +sla\_EQGAL +and +sla\_GALEQ +are the J2000 equivalents. + +Finally, the routines +sla\_GALSUP +and +sla\_SUPGAL +transform \gal\ to de~Vaucouleurs supergalactic longitude and latitude +and {\it vice versa.} + +It should be appreciated that the table, above, constitutes +a gross oversimplification. Apparently +simple concepts such as equator, equinox {\it etc.}\ are apt to be very hard to +pin down precisely (polar motion, orbital perturbations \ldots) and +some have several interpretations, all subtly different. The various +frames move in complicated ways with respect to one another or to +the stars (themselves in motion). And in some instances the +coordinate system is slightly distorted, so that the +ordinary rules of spherical trigonometry no longer strictly apply. + +These {\it caveats}\/ +apply particularly to the bewildering variety of different +\radec\ systems that are in use. Figure~1 shows how +some of these systems are related, to one another and +to the direction in which a celestial source actually +appears in the sky. At the top of the diagram are +the various sorts of {\it mean place}\/ +found in star catalogues and papers;\footnote{One frame not included in +Figure~1 is that of the Hipparcos catalogue. This is currently the +best available implementation in the optical of the {\it International +Celestial Reference System}\/ (ICRS), which is based on extragalactic +radio sources observed by VLBI. The distinction between FK5 J2000 +and Hipparcos coordinates only becomes important when accuracies of +50~mas or better are required. More details are given in +Section~4.14.} at the bottom is the +{\it observed}\/ \azel, where a perfect theodolite would +be pointed to see the source; and in the body of +the diagram are +the intermediate processing steps and coordinate +systems. To help +understand this diagram, and the SLALIB routines that can +be used to carry out the various calculations, we will look at the coordinate +systems involved, and the astronomical phenomena that +affect them. + +\begin{figure} +\begin{center} +\begin{tabular}{|cccccc|} \hline +& & & & & \\ +\hspace{5em} & \hspace{5em} & \hspace{5em} & + \hspace{5em} & \hspace{5em} & \hspace{5em} \\ +\multicolumn{2}{|c}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK4, \\ + any equinox + \vspace{0.5ex}}}} & + \multicolumn{2}{c}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK4, + no $\mu$, any equinox + \vspace{0.5ex}}}} & +\multicolumn{2}{c|}{\hspace{0em}\fbox{\parbox{8.5em}{\center \vspace{-2ex} + mean \radec, FK5, \\ + any equinox + \vspace{0.5ex}}}} \\ +& \multicolumn{2}{|c|}{} & \multicolumn{2}{c|}{} & \\ +\multicolumn{2}{|c}{space motion} & \multicolumn{1}{c|}{} & & + \multicolumn{2}{c|}{space motion} \\ +\multicolumn{2}{|c}{-- E-terms} & + \multicolumn{2}{c}{-- E-terms} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{precess to B1950} & \multicolumn{2}{c}{precess to B1950} & + \multicolumn{2}{c|}{precess to J2000} \\ +\multicolumn{2}{|c}{+ E-terms} & + \multicolumn{2}{c}{+ E-terms} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{FK4 to FK5, no $\mu$} & + \multicolumn{2}{c}{FK4 to FK5, no $\mu$} & \multicolumn{1}{c|}{} & \\ +\multicolumn{2}{|c}{parallax} & \multicolumn{1}{c|}{} & & + \multicolumn{2}{c|}{parallax} \\ +& \multicolumn{2}{|c|}{} & \multicolumn{2}{c|}{} & \\ \cline{2-5} +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{\parbox{18em}{\center \vspace{-2ex} + FK5, J2000, current epoch, geocentric + \vspace{0.5ex}}}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{light deflection} & \\ +& \multicolumn{4}{c}{annual aberration} & \\ +& \multicolumn{4}{c}{precession-nutation} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Apparent \radec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{Earth rotation} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Apparent \hadec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{diurnal aberration} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Topocentric \hadec}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\hadec\ to \azel} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Topocentric \azel}} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{refraction} & \\ +\multicolumn{3}{|c|}{} & & & \\ +& \multicolumn{4}{c}{\fbox{Observed \azel}} & \\ +& & & & & \\ +& & & & & \\ \hline +\end{tabular} +\end{center} +\vspace{-0.5ex} +\caption{\bf Relationship Between Celestial Coordinates} + +Star positions are published or catalogued using +one of the mean \radec\ systems shown at +the top. The ``FK4'' systems +were used before about 1980 and are usually +equinox B1950. The ``FK5'' system, equinox J2000, is now preferred, +or rather its modern equivalent, the International Celestial Reference +Frame (in the optical, the Hipparcos catalogue). +The figure relates a star's mean \radec\ to the actual +line-of-sight to the star. +Note that for the conventional choices of equinox, namely +B1950 or J2000, all of the precession and E-terms corrections +are superfluous. +\end{figure} + +\subsection{Precession and Nutation} +{\it Right ascension and declination}, (\radec), are the names +of the longitude and latitude in a spherical +polar coordinate system based on the Earth's axis of rotation. +The zero point of $\alpha$ is the point of intersection of +the {\it celestial +equator}\/ and the {\it ecliptic}\/ (the apparent path of the Sun +through the year) where the Sun moves into the northern +hemisphere. This point is called the +{\it first point of Aries}, +the {\it vernal equinox}\/ (with apologies to +southern-hemisphere readers) or simply the {\it equinox}.\footnote{With +the introduction of the International Celestial Reference System (ICRS), the +connection between (i)~star coordinates and (ii)~the Earth's orientation +and orbit has been broken. However, the orientation of the +International Celestial Reference Frame (ICRF) axes was, for convenience, +chosen to match J2000 FK5, and for most practical purposes ICRF coordinates +(for example entries in the Hipparcos catalogue) can be regarded as +synonymous with J2000 FK5. See Section 4.14 for further details.} + +This simple picture is unfortunately +complicated by the difficulty of defining +a suitable equator and equinox. One problem is that the +Sun's apparent diurnal and annual +motions are not completely regular, due to the +ellipticity of the Earth's orbit and its continuous disturbance +by the Moon and planets. This is dealt with by +separating the motion into (i)~a smooth and steady {\it mean Sun}\/ +and (ii)~a set of periodic corrections and perturbations; only the former +is involved in establishing reference systems and time scales. +A second, far larger problem, is that +the celestial equator and the ecliptic +are both moving with respect to the stars. +These motions arise because of the gravitational +interactions between the Earth and the other solar-system bodies. + +By far the largest effect is the +so-called ``precession of the equinoxes'', where the Earth's +rotation axis sweeps out a cone centred on the ecliptic +pole, completing one revolution in about 26,000 years. The +cause of the motion is the torque exerted on the distorted and +spinning Earth by the Sun and the Moon. Consider the effect of the +Sun alone, at or near the northern summer solstice. The Sun +`sees' the top (north pole) of the Earth tilted towards it +(by about \degree{23}{5}, the {\it obliquity of the +ecliptic}\/), +and sees the nearer part of the Earth's equatorial bulge +below centre and the further part above centre. +Although the Earth is in free fall, +the gravitational force on the nearer part of the +equatorial bulge is greater than that on the further part, and +so there is a net torque acting +as if to eliminate the tilt. Six months later the same thing +is happening in reverse, except that the torque is still +trying to eliminate the tilt. In between (at the equinoxes) the +torque shrinks to zero. A torque acting on a spinning body +is gyroscopically translated +into a precessional motion of the spin axis at right-angles to the torque, +and this happens to the Earth. +The motion varies during the +year, going through two maxima, but always acts in the +same direction. The Moon produces the same effect, +adding a contribution to the precession which peaks twice +per month. The Moon's proximity to the Earth more than compensates +for its smaller mass and gravitational attraction, so that it +in fact contributes most of the precessional effect. + +The complex interactions between the three bodies produce a +precessional motion that is wobbly rather than completely smooth. +However, the main 26,000-year component is on such a grand scale that +it dwarfs the remaining terms, the biggest of +which has an amplitude of only \arcseci{11} and a period of +about 18.6~years. This difference of scale makes it convenient to treat +these two components of the motion separately. The main 26,000-year +effect is called {\it luni-solar precession}; the smaller, +faster, periodic terms are called the {\it nutation}. + +Note that precession and nutation are simply +different frequency components of the same physical effect. It is +a common misconception that precession is caused +by the Sun and nutation is caused by the Moon. In fact +the Moon is responsible for two-thirds of the precession, and, +while it is true that much of the complex detail of the nutation is +a reflection of the intricacies of the lunar orbit, there are +nonetheless important solar terms in the nutation. + +In addition to and quite separate +from the precession-nutation effect, the orbit of the Earth-Moon system +is not fixed in orientation, a result of the attractions of the +planets. This slow (about \arcsec{0}{5}~per~year) +secular rotation of the ecliptic about a slowly-moving diameter is called, +confusingly, {\it planetary +precession}\/ and, along with the luni-solar precession is +included in the {\it general precession}. The equator and +ecliptic as affected by general precession +are what define the various ``mean'' \radec\ reference frames. + +The models for precession and nutation come from a combination +of observation and theory, and are subject to continuous +refinement. Nutation models in particular have reached a high +degree of sophistication, taking into account such things as +the non-rigidity of the Earth and the effects of +the planets; SLALIB's nutation +model (SF2001) involves 194 terms in each of $\psi$ (longitude) +and $\epsilon$ (obliquity), some as small as a few microarcseconds. + +\subsubsection{SLALIB support for precession and nutation} +SLALIB offers a choice of three precession models: +\begin{itemize} +\item The old Bessel-Newcomb, pre IAU~1976, ``FK4'' model, used for B1950 + star positions and other pre-1984.0 purposes +(sla\_PREBN). +\item The new Fricke, IAU~1976, ``FK5'' model, used for J2000 star + positions and other post-1984.0 purposes +(sla\_PREC). +\item A model published by Simon {\it et al.}\ which is more accurate than + the IAU~1976 model and which is suitable for long + periods of time +(sla\_PRECL). +\end{itemize} +In each case, the named SLALIB routine generates the $(3\times3)$ +{\it precession +matrix}\/ for a given start and finish time. For example, +here is the Fortran code for generating the rotation +matrix which describes the precession between the epochs +J2000 and J1985.372 (IAU 1976 model): +\goodbreak +\begin{verbatim} + DOUBLE PRECISION PMAT(3,3) + : + CALL sla_PREC(2000D0,1985.372D0,PMAT) +\end{verbatim} +\goodbreak +It is instructive to examine the resulting matrix: +\goodbreak +\begin{verbatim} + +0.9999936402 +0.0032709208 +0.0014214694 + -0.0032709208 +0.9999946505 -0.0000023247 + -0.0014214694 -0.0000023248 +0.9999989897 +\end{verbatim} +\goodbreak +Note that the diagonal elements are close to unity, and the +other elements are small. This shows that over an interval as +short as 15~years the precession isn't going to move a +position vector very far (in this case about \degree{0}{2}). + +For convenience, a direct \radec\ to \radec\ precession routine is +also provided +(sla\_PRECES), +suitable for either the old or the new system (but not a +mixture of the two). + +SLALIB provides two nutation models, the old IAU~1980 model, +implemented in the routine +slaNutc80, and a much more accurate newer theory, SF2001, +implemented in the routine +slaNutc. +Both return the components of nutation +in longitude and latitude (and also provide the obliquity) from +which a nutation matrix can be generated by calling +slaDeuler +(and from which the {\it equation of the equinoxes}, described +later, can be found). Alternatively, +the SF2001 nutation matrix can be generated in a single call by using +slaNut. The SF2001 nutation theory includes components that correct +for errors in the IAU~1976 precession and also for the +$\sim 23\,$mas +displacement between the mean J2000 and ICRS coordinate systems, +achieving a final accuracy well under 1\,mas in the present era. + +A rotation matrix for applying the entire precession-nutation +transformation in one go can be generated by calling +sla\_PRENUT. + +\subsection{Mean Places} +From a classical standpoint, +the main effect of the precession-nutation is an increase of about +\arcseci{50}/year in the ecliptic longitudes of the stars. It is therefore +essential, when reporting the position of an astronomical target, to +qualify the coordinates with a date, or {\it epoch}. +Specifying the epoch ties down the equator and +equinox which define the \radec\ coordinate system that is +being used. +\footnote{An equinox is, however, not required for coordinates +in the International Celestial Reference System. Such coordinates must +be labelled simply ``ICRS'', or the specific catalogue can be mentioned, +such as ``Hipparcos''; constructions such as ``Hipparcos, J2000'' are +redundant and misleading.} For simplicity, only +the smooth and steady ``precession'' part of the +complete precession-nutation effect is +included, thereby defining what is called the {\it mean}\/ +equator and equinox for the epoch concerned. We say a star +has a mean place of (for example) +\hms{12}{07}{58}{09}~\dms{-19}{44}{37}{1} ``with respect to the mean equator +and equinox of epoch J2000''. The short way of saying +this is ``\radec\ equinox J2000'' ({\bf not} ``\radec\ epoch J2000'', +which means something different to do with +proper motion). + +\subsection{Epoch} +The word ``epoch'' just means a significant +moment in time, and can be supplied +in a variety of forms, using different calendar systems and time scales. + +For the purpose of specifying the epochs associated with the +mean place of a star, two conventions exist. Both sorts of epoch +superficially resemble years AD but are not tied to the civil +(Gregorian) calendar; to distinguish them from ordinary calendar-years +there is often +a ``.0'' suffix (as in ``1950.0''), although any other fractional +part is perfectly legal ({\it e.g.}\ 1987.5). + +The older system, +{\it Besselian epoch}, is defined in such a way that its units are +tropical years of about 365.2422~days and its time scale is the +obsolete {\it Ephemeris Time}. +The start of the Besselian year is the moment +when the ecliptic longitude of the mean Sun is +$280^{\circ}$; this happens near the start of the +calendar year (which is why $280^{\circ}$ was chosen). + +The new system, {\it Julian epoch}, was adopted as +part of the IAU~1976 revisions (about which more will be said +in due course) and came formally into use at the +beginning of 1984. It uses the Julian year of exactly +365.25~days; Julian epoch 2000 is defined to be 2000~January~1.5 in the +TT time scale. + +For specifying mean places, various standard epochs are in use, the +most common ones being Besselian epoch 1950.0 and Julian epoch 2000.0. +To distinguish the two systems, Besselian epochs +are now prefixed ``B'' and Julian epochs are prefixed ``J''. +Epochs without an initial letter can be assumed to be Besselian +if before 1984.0, otherwise Julian. These details are supported by +the SLALIB routines +sla\_DBJIN +(decodes numbers from a +character string, accepting an optional leading B or J), +sla\_KBJ +(decides whether B or J depending on prefix or range) and +sla\_EPCO +(converts one epoch to match another). + +SLALIB has four routines for converting +Besselian and Julian epochs into other forms. +The functions +sla\_EPB2D +and +sla\_EPJ2D +convert Besselian and Julian epochs into MJD; the functions +sla\_EPB +and +sla\_EPJ +do the reverse. For example, to express B1950 as a Julian epoch: +\goodbreak +\begin{verbatim} + DOUBLE PRECISION sla_EPJ,sla_EPB2D + : + WRITE (*,'(1X,''J'',F10.5)') sla_EPJ(sla_EPB2D(1950D0)) +\end{verbatim} +\goodbreak +(The answer is J1949.99979.) + +\subsection{Proper Motion} +Stars in catalogues usually have, in addition to the +\radec\ coordinates, a {\it proper motion} $[\mu_\alpha,\mu_\delta]$. +This is an intrinsic motion +of the star across the background. Very few stars have a +proper motion which exceeds \arcseci{1}/year, and most are +far below this level. A star observed as part of normal +astronomy research will, as a rule, have a proper motion +which is unknown. + +Mean \radec\ and rate of change are not sufficient to pin +down a star; the epoch at which the \radec\ was or will +be correct is also needed. Note the distinction +between the epoch which specifies the +coordinate system and the epoch at which the star passed +through the given \radec. The full specification for a star +is \radec, proper motions, equinox and epoch (plus something to +identify which set of models for the precession {\it etc.}\ is +being used -- see the next section). +For convenience, coordinates given in star catalogues are almost +always adjusted to make the equinox and epoch the same -- for +example B1950 in the case of the SAO~catalogue. + +SLALIB provides one routine to handle proper motion on its own, +sla\_PM. +Proper motion is also allowed for in various other +routines as appropriate, for example +sla\_MAP +and +sla\_FK425. +Note that in all SLALIB routines which involve proper motion +the units are radians per year and the +$\alpha$ component is in the form $\dot{\alpha}$ ({\it i.e.}\ big +numbers near the poles). +Some star catalogues have proper motion per century, and +in some catalogues the $\alpha$ component is in the form +$\dot{\alpha}\cos\delta$ ({\it i.e.}\ angle on the sky). + +\subsection{Parallax and Radial Velocity} +For the utmost accuracy and the nearest stars, allowance can +be made for {\it annual parallax}\/ and for the effects of perspective +on the proper motion. + +Parallax is appreciable only for nearby stars; even +the nearest, Proxima Centauri, is displaced from its average +position by less than +an arcsecond as the Earth revolves in its orbit. + +For stars with a known parallax, knowledge of the radial velocity +allows the proper motion to be expressed as an actual space +motion in 3~dimensions. The proper motion is, +in fact, a snapshot of the transverse component of the +space motion, and in the case of nearby stars will +change with time due to perspective. + +SLALIB does not provide facilities for handling parallax +and radial-velocity on their own, but their contribution is +allowed for in such routines as +sla\_PM, +sla\_MAP +and +sla\_FK425. +Catalogue mean +places do not include the effects of parallax and are therefore +{\it barycentric}; when pointing telescopes {\it etc.}\ it is +usually most efficient to apply the slowly-changing +parallax correction to the mean place of the target early on +and to work with the {\it geocentric}\/ mean place. This latter +approach is implied in Figure~1. + +\subsection{Aberration} +The finite speed of light combined with the motion of the observer +around the Sun during the year causes apparent displacements of +the positions of the stars. The effect is called +the {\it annual aberration} (or ``stellar'' +aberration). Its maximum size, about \arcsec{20}{5}, +occurs for stars $90^{\circ}$ from the point towards which +the Earth is headed as it orbits the Sun; a star exactly in line with +the Earth's motion is not displaced. To receive the light of +a star, the telescope has to be offset slightly in the direction of +the Earth's motion. A familiar analogy is the need to tilt your +umbrella forward when on the move, to avoid getting wet. This +classical model is, +in fact, misleading in the context of light as opposed +to rain, but happens to give the same answer as a relativistic +treatment to first order (better than 1~milliarcsecond). + +Before the IAU 1976 resolutions, different +values for the approximately +\arcsec{20}{5} {\it aberration constant}\/ were employed +at different times, and this can complicate comparisons +between different catalogues. Another complication comes from +the so-called {\it E-terms of aberration}, +that small part of the annual aberration correction that is a +function of the eccentricity of the Earth's orbit. The E-terms, +maximum amplitude about \arcsec{0}{3}, +happen to be approximately constant for a given star, and so they +used to be incorporated in the catalogue \radec\/ +to reduce the labour of converting to and from apparent place. +The E-terms can be removed from a catalogue \radec\/ by +calling +sla\_SUBET +or applied (for example to allow a pulsar +timing-position to be plotted on a B1950 finding chart) +by calling +sla\_ADDET; +the E-terms vector itself can be obtained by calling +sla\_ETRMS. +Star positions post IAU 1976 are free of these distortions, and to +apply corrections for annual aberration involves the actual +barycentric velocity of the Earth rather than the use of +canonical circular-orbit models. + +The annual aberration is the aberration correction for +an imaginary observer at the Earth's centre. +The motion of a real observer around the Earth's rotation axis in +the course of the day makes a small extra contribution to the total +aberration effect called the {\it diurnal aberration}. Its +maximum amplitude is about \arcsec{0}{3}. + +No SLALIB routine is provided for calculating the aberration on +its own, though the required velocity vectors can be +generated using +sla\_EVP (or +sla\_EPV) +and +sla\_GEOC. +Annual and diurnal aberration are allowed for where required, for example in +sla\_MAP +{\it etc}.\ and +sla\_AOP +{\it etc}. Note that this sort +of aberration is different from the {\it planetary +aberration}, which is the apparent displacement of a solar-system +body, with respect to the ephemeris position, as a consequence +of the motion of {\it both}\/ the Earth and the source. The +planetary aberration can be computed either by correcting the +position of the solar-system body for light-time, followed by +the ordinary stellar aberration correction, or more +directly by expressing the position and velocity of the source +in the observer's frame and correcting for light-time alone. + +\subsection{Different Sorts of Mean Place} +A confusing aspect of the mean places used in the +pre-ICRS era is that they +are sensitive to the precise way they were determined. A mean +place is not directly observable, even with fundamental +instruments such as transit circles, and to produce one +will involve relying on some existing star catalogue, +for example the fundamental catalogues FK4 and FK5, +and applying given mathematical models of precession, nutation, +aberration and so on. +Note in particular that no star catalogue, +even a fundamental catalogue such as FK4 or +FK5, defines a coordinate system, strictly speaking; +it is merely a list of star positions and proper motions. +However, once the stars from a given catalogue +are used as position calibrators, {\it e.g.}\ for +transit-circle observations or for plate reductions, then a +broader sense of there being a coordinate grid naturally +arises, and such phrases as ``in the system of +the FK4'' can legitimately be employed. However, +there is no formal link between the +two concepts -- no ``standard least squares fit'' between +reality and the inevitably flawed catalogues. +All such +catalogues suffer at some level from systematic, zonal distortions +of both the star positions and of the proper motions, +and include measurement errors peculiar to individual +stars. + +Many of these complications are of little significance except to +specialists. However, observational astronomers cannot +escape exposure to at least the two main varieties of +mean place, loosely called +FK4 and FK5, and should be aware of +certain pitfalls. For most practical purposes the more recent +system, FK5, is free of surprises and tolerates naive +use well. FK4, in contrast, contains two important traps: +\begin{itemize} +\item The FK4 system rotates at about + \arcsec{0}{5} per century relative to distant galaxies. + This is manifested as a systematic distortion in the + proper motions of all FK4-derived catalogues, which will + in turn pollute any astrometry done using those catalogues. + For example, FK4-based astrometry of a QSO using plates + taken decades apart will reveal a non-zero {\it fictitious proper + motion}, and any FK4 star which happens to have zero proper + motion is, in fact, slowly moving against the distant + background. The FK4 frame rotates because it was + established before the nature of the Milky Way, and hence the + existence of systematic motions of nearby stars, had been + recognized. +\item Star positions in the FK4 system are part-corrected for + annual aberration (see above) and embody the so-called + E-terms of aberration. +\end{itemize} +The change from the old FK4-based system to FK5 +occurred at the beginning +of 1984 as part of a package of resolutions made by the IAU in 1976, +along with the adoption of J2000 as the reference epoch. Star +positions in the newer, FK5, system are free from the E-terms, and +the system is a much better approximation to an +inertial frame -- about five times better (and ICRS is hundreds +of times better still). + +It may occasionally be convenient to specify the FK4 fictitious proper +motion directly. In FK4, the centennial proper motion of (for example) +a QSO is: + +$\mu_\alpha=-$\tsec{0}{015869}$ + +(($\tsec{0}{029032}$~\sin \alpha + +$\tsec{0}{000340}$~\cos \alpha ) \sin \delta + -$\tsec{0}{000105}$~\cos \alpha + -$\tsec{0}{000083}$~\sin \alpha ) \sec \delta $ \\ +$\mu_\delta\,=+$\arcsec{0}{43549}$~\cos \alpha + -$\arcsec{0}{00510}$~\sin \alpha + + ($\arcsec{0}{00158}$~\sin \alpha + -$\arcsec{0}{00125}$~\cos \alpha ) \sin \delta + -$\arcsec{0}{00066}$~\cos \delta $ + +\subsection{Mean Place Transformations} +Figure~1 is based upon three varieties of mean \radec\ all of which are +of practical significance to observing astronomers in the present era: +\begin{itemize} + \item Old style (FK4) with known proper motion in the FK4 + system, and with parallax and radial velocity either + known or assumed zero. + \item Old style (FK4) with zero proper motion in FK5, + and with parallax and radial velocity assumed zero. + \item New style (FK5 or, loosely, ICRS) + with proper motion, parallax and + radial velocity either known or assumed zero. +\end{itemize} +The figure outlines the steps required to convert positions in +any of these systems to a J2000 \radec\ for the current +epoch, as might be required in a telescope-control +program for example. +Most of the steps can be carried out by calling a single +SLALIB routine; there are other SLALIB routines which +offer set-piece end-to-end transformation routines for common cases. +Note, however, that SLALIB does not set out to provide the capability +for arbitrary transformations of star-catalogue data +between all possible systems of mean \radec. +Only in the (common) cases of FK4, equinox and epoch B1950, +to FK5, equinox and epoch J2000, and {\it vice versa}\/ are +proper motion, parallax and radial velocity transformed +along with the star position itself, the +focus of SLALIB support. + +As an example of using SLALIB to transform mean places, here is +Fortran code that implements the top-left path of Figure~1. +An FK4 \radec\ of arbitrary equinox and epoch and with +known proper motion and +parallax is transformed into an FK5 J2000 \radec\ for the current +epoch. As a test star we will use $\alpha=$\hms{16}{09}{55}{13}, +$\delta=$\dms{-75}{59}{27}{2}, equinox 1900, epoch 1963.087, +$\mu_\alpha=$\tsec{-0}{0312}$/y$, $\mu_\delta=$\arcsec{+0}{103}$/y$, +parallax = \arcsec{0}{062}, radial velocity = $-34.22$~km/s. The +date of observation is 1994.35. +\goodbreak +\begin{verbatim} + IMPLICIT NONE + DOUBLE PRECISION AS2R,S2R + PARAMETER (AS2R=4.8481368110953599D-6,S2R=7.2722052166430399D-5) + INTEGER J,I + DOUBLE PRECISION R0,D0,EQ0,EP0,PR,PD,PX,RV,EP1,R1,D1,R2,D2,R3,D3, + : R4,D4,R5,D5,R6,D6,EP1D,EP1B,W(3),EB(3),PXR,V(3) + DOUBLE PRECISION sla_EPB,sla_EPJ2D + + * RA, Dec etc of example star + CALL sla_DTF2R(16,09,55.13D0,R0,J) + CALL sla_DAF2R(75,59,27.2D0,D0,J) + D0=-D0 + EQ0=1900D0 + EP0=1963.087D0 + PR=-0.0312D0*S2R + PD=+0.103D0*AS2R + PX=0.062D0 + RV=-34.22D0 + EP1=1994.35D0 + + * Epoch of observation as MJD and Besselian epoch + EP1D=sla_EPJ2D(EP1) + EP1B=sla_EPB(EP1D) + + * Space motion to the current epoch + CALL sla_PM(R0,D0,PR,PD,PX,RV,EP0,EP1B,R1,D1) + + * Remove E-terms of aberration for the original equinox + CALL sla_SUBET(R1,D1,EQ0,R2,D2) + + * Precess to B1950 + R3=R2 + D3=D2 + CALL sla_PRECES('FK4',EQ0,1950D0,R3,D3) + + * Add E-terms for the standard equinox B1950 + CALL sla_ADDET(R3,D3,1950D0,R4,D4) + + * Transform to J2000, no proper motion + CALL sla_FK45Z(R4,D4,EP1B,R5,D5) + + * Parallax + CALL sla_EVP(sla_EPJ2D(EP1),2000D0,W,EB,W,W) + PXR=PX*AS2R + CALL sla_DCS2C(R5,D5,V) + DO I=1,3 + V(I)=V(I)-PXR*EB(I) + END DO + CALL sla_DCC2S(V,R6,D6) + : +\end{verbatim} +\goodbreak +It is interesting to look at how the \radec\ changes during the +course of the calculation: +\begin{tabbing} +xxxxxxxxxxxxxx \= xxxxxxxxxxxxxxxxxxxxxxxxx \= x \= \kill +\> {\tt 16 09 55.130 -75 59 27.20} \> \> {\it original equinox and epoch} \\ +\> {\tt 16 09 54.155 -75 59 23.98} \> \> {\it with space motion} \\ +\> {\tt 16 09 54.229 -75 59 24.18} \> \> {\it with old E-terms removed} \\ +\> {\tt 16 16 28.213 -76 06 54.57} \> \> {\it precessed to 1950.0} \\ +\> {\tt 16 16 28.138 -76 06 54.37} \> \> {\it with new E-terms} \\ +\> {\tt 16 23 07.901 -76 13 58.87} \> \> {\it J2000, current epoch} \\ +\> {\tt 16 23 07.907 -76 13 58.92} \> \> {\it including parallax} +\end{tabbing} + +Other remarks about the above (unusually complicated) example: +\begin{itemize} +\item If the original equinox and epoch were B1950, as is quite + likely, then it would be unnecessary to treat space motions + and E-terms explicitly. Transformation to FK5 J2000 could + be accomplished simply by calling +sla\_FK425, after which + a call to +sla\_PM and the parallax code would complete the + work. +\item The rigorous treatment of the E-terms + has only a small effect on the result. Such refinements + are, nevertheless, worthwhile in order to facilitate comparisons and + to increase the chances that star positions from different + suppliers are compatible. +\item The FK4 to FK5 transformations, +sla\_FK425 + and +sla\_FK45Z, + are not as is sometimes assumed simply 50 years of precession, + though this indeed accounts for most of the change. The + transformations also include adjustments + to the equinox, a revised precession model, elimination of the + E-terms, a change to the proper-motion time unit and so on. + The reason there are two routines rather than just one + is that the FK4 frame rotates relative to the background, whereas + the FK5 frame is a much better approximation to an + inertial frame, and zero proper + motion in FK4 does not, therefore, mean zero proper motion in FK5. + SLALIB also provides two routines, +sla\_FK524 + and +sla\_FK54Z, + to perform the inverse transformations. +\item Some star catalogues (FK4 itself is one) were constructed using slightly + different procedures for the polar regions compared with + elsewhere. SLALIB ignores this inhomogeneity and always + applies the standard + transformations, irrespective of location on the celestial sphere. +\end{itemize} + +\subsection {Mean Place to Apparent Place} +The {\it geocentric apparent place}\/ of a source, or {\it apparent place}\/ +for short, +is the \radec\ if viewed from the centre of the Earth, +with respect to the true equator and equinox of date. +Transformation of an FK5 mean \radec, equinox J2000, +current epoch, to apparent place involves the following effects: +\goodbreak +\begin{itemize} + \item Light deflection -- the gravitational lens effect of + the sun. + \item Annual aberration. + \item Precession-nutation. +\end{itemize} +The {\it light deflection}\/ is seldom significant. Its value +at the limb of the Sun is about +\arcsec{1}{74}; it falls off rapidly with distance from the +Sun and has shrunk to about +\arcsec{0}{02} at an elongation of $20^\circ$. + +As already described, the {\it annual aberration}\/ +is a function of the Earth's velocity +relative to the solar system barycentre (available through the +SLALIB routines +sla\_EVP and +sla\_EPV) +and produces shifts of up to about \arcsec{20}{5}. + +The {\it precession-nutation}, from J2000 to the current epoch, is +expressed by a rotation matrix which is available through the +SLALIB routine +sla\_PRENUT. + +The whole mean-to-apparent transformation can be done using the SLALIB +routine +sla\_MAP. As a demonstration, here is a program which lists the +{\it North Polar Distance}\/ ($90^\circ-\delta$) of Polaris for +the decade of closest approach to the Pole: +\goodbreak +\begin{verbatim} + IMPLICIT NONE + DOUBLE PRECISION PI,PIBY2,D2R,S2R,AS2R + PARAMETER (PI=3.141592653589793238462643D0) + PARAMETER (D2R=PI/180D0, + : PIBY2=PI/2D0, + : S2R=PI/(12D0*3600D0), + : AS2R=PI/(180D0*3600D0)) + DOUBLE PRECISION RM,DM,PR,PD,DATE,RA,DA + INTEGER J,IDS,IDE,ID,IYMDF(4),I + + CALL sla_DTF2R(02,31,49.8131D0,RM,J) + CALL sla_DAF2R(89,15,50.661D0,DM,J) + PR=+21.7272D0*S2R/100D0 + PD=-1.571D0*AS2R/100D0 + WRITE (*,'(1X,'// + : '''Polaris north polar distance (deg) 2096-2105''/)') + WRITE (*,'(4X,''Date'',7X''NPD''/)') + CALL sla_CLDJ(2096,1,1,DATE,J) + IDS=NINT(DATE) + CALL sla_CLDJ(2105,12,31,DATE,J) + IDE=NINT(DATE) + DO ID=IDS,IDE,10 + DATE=DBLE(ID) + CALL sla_DJCAL(0,DATE,IYMDF,J) + CALL sla_MAP(RM,DM,PR,PD,0D0,0D0,2000D0,DATE,RA,DA) + WRITE (*,'(1X,I4,2I3.2,F9.5)') (IYMDF(I),I=1,3),(PIBY2-DA)/D2R + END DO + + END +\end{verbatim} +\goodbreak +For cases where the transformation has to be repeated for different +times or for more than one star, the straightforward +sla\_MAP +approach is apt to be +wasteful as both the Earth velocity and the +precession-nutation matrix can be re-calculated relatively +infrequently without ill effect. A more efficient method is to +perform the target-independent calculations only when necessary, +by calling +sla\_MAPPA, +and then to use either +sla\_MAPQKZ, +when only the \radec\/ is known, or +sla\_MAPQK, +when full catalogue positions, including proper motion, parallax and +radial velocity, are available. How frequently to call +sla\_MAPPA +depends on the accuracy objectives; once per +night will deliver sub-arcsecond accuracy for example. + +The routines +sla\_AMP +and +sla\_AMPQK +allow the reverse transformation, from apparent to mean place. + +\subsection{Apparent Place to Observed Place} +The {\it observed place}\/ of a source is its position as +seen by a perfect theodolite at the location of the +observer. Transformation of an apparent \radec\ to observed +place involves the following effects: +\goodbreak +\begin{itemize} + \item \radec\ to \hadec. + \item Diurnal aberration. + \item \hadec\ to \azel. + \item Refraction. +\end{itemize} +The transformation from apparent \radec\ to +apparent \hadec\ is made by allowing for +{\it Earth rotation}\/ through the {\it sidereal time}, $\theta$: +\[ h = \theta - \alpha \] +For this equation to work, $\alpha$ must be the apparent right +ascension for the time of observation, and $\theta$ must be +the {\it local apparent sidereal time}. The latter is obtained +as follows: +\begin{enumerate} +\item from civil time obtain the coordinated universal time, UTC + (more later on this); +\item add the UT1$-$UTC (typically a few tenths of a second) to + give the UT; +\item from the UT compute the Greenwich mean sidereal time (using +sla\_GMST); +\item add the observer's (east) longitude, giving the local mean + sidereal time; +\item add the equation of the equinoxes (using +sla\_EQEQX). +\end{enumerate} +The {\it equation of the equinoxes}\/~($=\Delta\psi\cos\epsilon$ plus +small terms) +is the effect of nutation on the sidereal time. +Its value is typically a second or less. It is +interesting to note that if the object of the exercise is to +transform a mean place all the way into an observed place (very +often the case), +then the equation of the +equinoxes and the longitude component of nutation can both be +omitted, removing a great deal of computation. However, SLALIB +follows the normal convention and works {\it via}\/ the apparent place. + +Note that for very precise work the observer's longitude should +be corrected for {\it polar motion}. This can be done with +sla\_POLMO. +The corrections are always less than about \arcsec{0}{3}, and +are futile unless the position of the observer's telescope is known +to better than a few metres. + +Tables of observed and +predicted UT1$-$UTC corrections and polar motion data +are published every few weeks by the International Earth Rotation Service. + +The transformation from apparent \hadec\ to {\it topocentric}\/ +\hadec\ consists of allowing for +{\it diurnal aberration}. This effect, maximum amplitude \arcsec{0}{2}, +was described earlier. There is no specific SLALIB routine +for computing the diurnal aberration, +though the routines +sla\_AOP {\it etc.}\ +include it, and the required velocity vector can be +determined by calling +sla\_GEOC. + +The next stage is the major coordinate rotation from local equatorial +coordinates \hadec\ into horizon coordinates. The SLALIB routines +sla\_E2H +{\it etc.}\ can be used for this. For high-precision +applications the mean geodetic latitude should be corrected for polar +motion. + +\subsubsection{Refraction} +The final correction is for atmospheric refraction. +This effect, which depends on local meteorological conditions and +the effective colour of the source/detector combination, +increases the observed elevation of the source by a +significant effect even at moderate zenith distances, and near the +horizon by over \degree{0}{5}. The amount of refraction can by +computed by calling the SLALIB routine +sla\_REFRO; +however, +this requires as input the observed zenith distance, which is what +we are trying to predict. For high precision it is +therefore necessary to iterate, using the topocentric +zenith distance as the initial estimate of the +observed zenith distance. + +The full +sla\_REFRO refraction calculation is onerous, and for +zenith distances of less than, say, $75^{\circ}$ the following +model can be used instead: + +\[ \zeta _{vac} \approx \zeta _{obs} + + A \tan \zeta _{obs} + + B \tan ^{3}\zeta _{obs} \] +where $\zeta _{vac}$ is the topocentric +zenith distance (i.e.\ {\it in vacuo}), +$\zeta _{obs}$ is the observed +zenith distance (i.e.\ affected by refraction), and $A$ and $B$ are +constants, about \arcseci{60} +and \arcsec{-0}{06} respectively for a sea-level site. +The two constants can be calculated for a given set of conditions +by calling either +sla\_REFCO or +sla\_REFCOQ. + +sla\_REFCO works by calling +sla\_REFRO for two zenith distances and fitting $A$ and $B$ +to match. The calculation is onerous, but delivers accurate +results whatever the conditions. +sla\_REFCOQ uses a direct formulation of $A$ and $B$ and +is much faster; it is slightly less accurate than +sla\_REFCO but more than adequate for most practical purposes. + +Like the full refraction model, the two-term formulation works in the wrong +direction for our purposes, predicting +the {\it in vacuo}\/ (topocentric) zenith distance +given the refracted (observed) zenith distance, +rather than {\it vice versa}. The obvious approach of +interchanging $\zeta _{vac}$ and $\zeta _{obs}$ and +reversing the signs, though approximately +correct, gives avoidable errors which are just significant in +some applications; for +example about \arcsec{0}{2} at $70^\circ$ zenith distance. A +much better result can easily be obtained, by using one Newton-Raphson +iteration as follows: + +\[ \zeta _{obs} \approx \zeta _{vac} + - \frac{A \tan \zeta _{vac} + B \tan ^{3}\zeta _{vac}} + {1 + ( A + 3 B \tan ^{2}\zeta _{vac} ) \sec ^{2}\zeta _{vac}}\] + +The effect of refraction can be applied to an unrefracted +zenith distance by calling +sla\_REFZ or to an unrefracted +\xyz\ by calling +sla\_REFV. +Over most of the sky these two routines deliver almost identical +results, but beyond $\zeta=83^\circ$ +sla\_REFV +becomes unacceptably inaccurate while +sla\_REFZ +remains usable. (However +sla\_REFV +is significantly faster, which may be important in some applications.) +SLALIB also provides a routine for computing the airmass, the function +sla\_AIRMAS. + +The refraction ``constants'' returned by +sla\_REFCO and +sla\_REFCOQ +are slightly affected by colour, especially at the blue end +of the spectrum. Where values for more than one +wavelength are needed, rather than calling +sla\_REFCO +several times it is more efficient to call +sla\_REFCO +just once, for a selected ``base'' wavelength, and then to call +sla\_ATMDSP +once for each wavelength of interest. + +All the SLALIB refraction routines work for radio wavelengths as well +as the optical/IR band. The radio refraction is very dependent on +humidity, and an accurate value must be supplied. There is no +wavelength dependence, however. The choice of optical/IR or +radio is made by specifying a wavelength greater than $100\mu {\rm m}$ +for the radio case. + +\subsubsection{Efficiency considerations} +The complete apparent place to observed place transformation +can be carried out by calling +sla\_AOP. +For improved efficiency +in cases of more than one star or a sequence of times, the +target-independent calculations can be done once by +calling +sla\_AOPPA, +the time can be updated by calling +sla\_AOPPAT, +and +sla\_AOPQK +can then be used to perform the +apparent-to-observed transformation. The reverse transformation +is available through +sla\_OAP +and +sla\_OAPQK. +({\it n.b.}\ These routines use accurate but computationally-expensive +refraction algorithms for zenith distances beyond about $76^\circ$. +For many purposes, in-line code tailored to the accuracy requirements +of the application will be preferable, for example ignoring +polar motion, +omitting diurnal aberration and using +sla\_REFZ +to apply the refraction.) + +\subsection{The Hipparcos Catalogue and the ICRS} +With effect from the beginning of 1998, the IAU adopted a new +reference system to replace FK5 J2000. The new system, called the +International Celestial Reference System (ICRS), differs profoundly +from all predecessors in that the link with solar-system dynamics +was broken; the ICRS axes are defined in terms of the coordinates +of a set of extragalactic sources, not in terms of the mean equator and +equinox at a given reference epoch. Although the ICRS and FK5 coordinates +of any given object are almost the same, the orientation of the new frame +was essentially arbitrary, and the close match to FK5 J2000 was contrived +purely for reasons of continuity and convenience. + +A distinction is made between the reference {\it system}\/ (the ICRS) +and {\it frame}\/ (ICRF). The ICRS is the set of prescriptions and +conventions together with the modelling required to define, at any +time, a triad of axes. The ICRF is a practical realization, and +currently consists of a catalogue of equatorial coordinates for 608 +extragalactic radio sources observed by VLBI. + +The best optical realization of the ICRF currently available is the +Hipparcos catalogue. The extragalactic sources were not directly +observable by the Hipparcos satellite and so the link from Hipparcos +to ICRF was established through a variety of indirect techniques: VLBI and +conventional interferometry of radio stars, photographic astrometry +and so on. The Hipparcos frame is aligned to the ICRF to within about +0.5~mas and 0.5~mas/year (at epoch 1991.25). + +The Hipparcos catalogue includes all of the FK5 stars, which has enabled +the orientation and spin of the latter to be studied. At epoch J2000, +the misalignment of the FK5 frame with respect to Hipparcos +(and hence ICRS) are about 32~mas and 1~mas/year respectively. +Consequently, for many practical purposes, including pointing +telescopes, the IAU 1976-1982 conventions on reference frames and +Earth orientation remain adequate and there is no need to change to +Hipparcos coordinates, new precession-nutation models and so on. +However, for the most exacting astrometric applications, SLALIB +provides some support for Hipparcos coordinates in the form of +four new routines: +sla\_FK52H and +sla\_H2FK5, +which transform FK5 positions and proper motions to the Hipparcos frame +and {\it vice versa,}\/ and +sla\_FK5HZ and +sla\_HFK5Z, +where the transformations are for stars whose Hipparcos proper motion is +zero. + +Further information on the ICRS can be found in the paper by M.\,Feissel +and F.\,Mignard, Astron.\,Astrophys. 331, L33-L36 (1988). + +\subsection{Time Scales} + +SLALIB provides for transformation between several time scales, and involves +use of one or two others. The full list is as follows: +\begin{itemize} +\item TAI: International Atomic Time +\item UTC: Coordinated Universal Time +\item TT: Terrestrial Time +\item TDB: Barycentric Dynamical Time. +\item UT: Universal Time +\item GMST: Greenwich mean sidereal time +\item GAST (or GST): Greenwich apparent sidereal time. +\item LAST: local apparent sidereal time +\end{itemize} +Strictly speaking, UT and the sidereal times are not {\it times}\/ in +the physics sense, but {\it angles}\/ that describe Earth rotation. + +Three obsolete time scales should be mentioned here to avoid confusion. +\begin{itemize} +\item GMT: Greenwich Mean Time -- can mean either UTC or UT. +\item ET: Ephemeris Time -- more or less the same as either TT or TDB. +\item TDT: Terrestrial Dynamical Time -- former name of TT. +\end{itemize} + +time scales that have no SLALIB support at present: +\begin{itemize} +\item Any form of local civil time (BST, PDT {\it etc.}) +\item TCG: geocentric coordinate time. +\item TCB: barycentric coordinate time. +\end{itemize} + +\subsubsection{Atomic Time: TAI} +{\it International Atomic Time,} TAI, is a ``laboratory'' +time scale with no link to astronomical observations +except in an historical sense. Its +unit is the SI second, which is defined in terms of a +specific number +of wavelengths of the radiation produced by a certain electronic +transition in the caesium 133 atom. It +is realized through a changing +population of high-precision atomic clocks held +at standards institutes in various countries. There is an +elaborate process of continuous intercomparison, leading to +a weighted average of all the clocks involved. + +Though TAI shares the same second as the more familiar UTC, the +two time scales are noticeably separated in epoch because of the +build-up of leap seconds (see the next section). +At the time of writing, UTC +lags over half a minute behind TAI. + +For any given date, the difference TAI$-$UTC +can be obtained by calling the SLALIB function +sla\_DAT. +Note, however, that an up-to-date copy of the function must be used if +the most recent leap seconds are required. For applications +where this is critical, mechanisms independent of SLALIB +and under local control must +be set up; in such cases +sla\_DAT +can be useful as an +independent check, for test dates within the range of the +available version. Up-to-date information on TAI$-$UTC is available +from {\tt ftp://maia.usno.navy.mil/ser7/tai-utc.dat}. + +\subsubsection{Universal Time: UT, UTC} +\label{UTC} +{\it Universal Time,} UT, or more specifically UT1, +is in effect mean solar time and is really an expression +of Earth rotation rather than a measure of time. +Originally +defined in terms of a point in the sky called ``the fictitious +mean Sun'', UT is now defined through its relationship +with Earth rotation angle +(formerly sidereal time). +Because the Earth's rotation rate is slightly irregular and +gradually decreasing,\footnote{The Earth is slowing +down because of tidal effects. The SI +second reflects the length-of-day in the mid-19th century, when +the astronomical observations that established modern timekeeping +were being made. Since then, +the average length-of-day has increased by roughly 2~ms. +Superimposed in this gradual slowdown are +variations (seasonal and decadal) that are geophysical in origin, +notably due to large scale movements of water and atmosphere. +Because of +conservation of angular momentum, as the Earth's rotation-rate +decreases, the Moon moves farther away. In 50 billion years the +distance of the Moon will be at a maximum, 44\% greater than now, at +which stage day and month will both equal 47 present days.} +the UT second is not precisely +matched to the SI second. This makes UT itself unsuitable for +use as a time scale. + +That role is instead taken by +{\it Coordinated Universal Time,} UTC, which is clock-based and +is the foundation of civil timekeeping. +Most time zones differ from UTC by an integer number +of hours, though a few ({\it e.g.}\ parts of Canada and Australia) differ +by $n+0.5$~hours. Since its introduction, UTC has been kept +roughly in step with UT by a variety of adjustments that are +agreed in advance and then carried out in a coordinated manner by +the timekeeping communities of different countries---hence the +name. Though rate +changes were used in the past, nowadays all such adjustments +are made by occasionally inserting +a whole second. This procedure is called +a {\it leap second}. Because the day length is now slightly longer +than 86400 SI seconds, a leap second amounts to stopping the UTC +clock for a second to let the Earth catch up. + +You need UT1 in order to point a telescope or antenna at a +celestial target. To obtain it +starting from UTC, you +have to look up the value of UT1$-$UTC for the date concerned +in tables published by the International Earth Rotation and +reference frames +Service; this quantity, kept in the range +$\pm$\tsec{0}{9} by means of leap +seconds, is then added to the UTC. The quantity UT1$-$UTC, +which typically changes by of order 1~ms per day, +can be obtained only by observation (VLBI using +extragalactic radio sources), though seasonal trends +are well known and the IERS listings are able to predict some way into +the future with adequate accuracy for pointing telescopes. + +UTC leap seconds are introduced as necessary, +usually at the end of December or June. +Because on the average the solar day is slightly longer +than the nominal 86,400~SI~seconds, leap seconds are always positive; +however, provision exists for negative leap seconds if needed. +The form of a leap second can be seen from the +following description of the end of June~1994: + +\hspace{3em} +\begin{tabular}{clrccc} \\ + & & & UTC & UT1$-$UTC & UT1 \\ \\ +1994 & June & 30 & 23 59 58 & $-0.218$ & 23 59 57.782 \\ + & & & 23 59 59 & $-0.218$ & 23 59 58.782 \\ + & & & 23 59 60 & $-0.218$ & 23 59 59.782 \\ + & July & 1 & 00 00 00 & $+0.782$ & 00 00 00.782 \\ + & & & 00 00 01 & $+0.782$ & 00 00 01.782 \\ +\end{tabular} +\goodbreak + +Note that UTC has to be expressed as hours, minutes and +seconds (or at least in seconds for a given date) if leap seconds +are to be taken into account in the +correct manner. +It is improper to express a UTC as a +Julian Date, for example, because there will be an ambiguity +during a leap second (in the above example, +1994~June~30 \hms{23}{59}{60}{0} and +1994~July~1 \hms{00}{00}{00}{0} would {\it both}\/ come out as +MJD~49534.00000). Although in the vast majority of +cases this won't matter, there are potential problems in +on-line data acquisition systems and in applications involving +taking the difference between two times. Note that although the functions +sla\_DAT +and +sla\_DTT +expect UTC in the form of an MJD, the meaning here is really a +whole-number {\it date}\/ rather than a time. +Though the functions will accept +a fractional part and will almost always function correctly, on a day +which ends with a leap +second incorrect results would be obtained during the leap second +itself because by then the MJD would have moved into the next day. + +\subsubsection{Sidereal Time: GMST, LAST {\it etc.}} +Sidereal time is like the time of day but relative to the +stars rather than to the Sun. After +one sidereal day the stars come back to the same place in the +sky, apart from sub-arcsecond precession effects. Because the Earth +rotates faster relative to the stars than to the Sun by one day +per year, the sidereal second is shorter than the solar +second; the ratio is about 0.9973. + +The {\it Greenwich mean sidereal time,} GMST, is +linked to UT1 by a numerical formula which +is implemented in the SLALIB functions +sla\_GMST +and +sla\_GMSTA. +There are, of course, no leap seconds in GMST, but the sidereal +second (measured in SI seconds) +changes in length along with the UT1 second, and also varies +over long periods of time because of slow changes in the Earth's +orbit. This makes sidereal time unsuitable for everything except +predicting the apparent directions of celestial sources, in other +words as an angle rather than a time. + +The {\it local apparent sidereal time,} LAST, is the apparent right +ascension of the local meridian, from which the hour angle of any +star can be determined knowing its right +ascension. LAST can be obtained from the +GMST by adding the east longitude (corrected for polar motion +in precise work) and the {\it equation of the equinoxes}. The +latter, already described, is an aspect of the nutation effect +and can be predicted by calling the SLALIB function +sla\_EQEQX +or, neglecting certain very small terms, by calling +sla\_NUTC +and using the expression $\Delta\psi\cos\epsilon$. + +GAST, or plain GST, is GMST plus the equation of the equinoxes. + +\subsubsection{Dynamical Time: TT, TDB} +Dynamical time (formerly Ephemeris Time, ET) +is the independent variable in the theories +which describe the motions of bodies in the solar system. When +using published formulae or +tables that model the position of the +Earth in its orbit, for example, or look up +the Moon's position in a precomputed ephemeris, the date and time +must be in terms of one of the dynamical time scales. It +is a common but understandable mistake to use UTC directly, in which +case the results will be over a minute out (at the time of writing). + +It is not hard to see why such time scales are necessary. +UTC would clearly be unsuitable as the argument of an +ephemeris because of leap seconds. +A solar-system ephemeris based on UT1 or sidereal time would somehow +have to include the unpredictable variations of the Earth's rotation. +TAI would work, but in principle +the ephemeris and the ensemble of atomic clocks would +eventually drift apart. +In effect, the ephemeris {\it is}\/ a clock, with the bodies of +the solar system the hands from which the ephemeris time is read. + +Only two of the dynamical time scales are of any great importance to +observational astronomers, TT and TDB. + +{\it Terrestrial Time,} TT, is +the theoretical time scale of apparent geocentric ephemerides of solar +system bodies. It applies to clocks at sea-level, and for practical purposes +it is tied to +Atomic Time TAI through the formula TT~$=$~TAI~$+$~\tsec{32}{184}. +In practice, therefore, the units of TT are ordinary SI seconds, and +the offset of \tsec{32}{184} with respect to TAI is fixed. +The SLALIB function +sla\_DTT +returns TT$-$UTC for a given UTC +({\it n.b.}~sla\_DTT +calls +sla\_DTT, +and the latter must be an up-to-date version if recent leap seconds are +to be taken into account). + +{\it Barycentric Dynamical Time,} TDB, is a +{\it coordinate time,} suitable +for labelling events that are most simply described in a context +where the bodies of the solar system +are absent. Applications include +the emission of pulsar radiation and the motions of the +solar-system bodies themselves. When the readings of the +observer's TT clock are labelled using such a +coordinate time, differences +are seen because the clock is affected by its +speed in the barycentric coordinate system +and the gravitational potential in which it is immersed. Equivalently, +observations of pulsars +expressed in TT would display similar variations (quite +apart from the familiar light-time effects). + +TDB is defined in such a way that it keeps close to TT +on the average, with the relativistic effects emerging as +quasi-periodic differences of maximum amplitude rather less +than 2\,ms. This is +negligible for many purposes, so that TT can act as +a perfectly adequate surrogate for TDB in most cases, +but unless taken into +account would swamp +long-term analysis of pulse arrival times from the +millisecond pulsars. + +Most of the variation between TDB and TT comes from the ellipticity of +the Earth's orbit; the TT clock's speed and +gravitational potential vary slightly +during the course of the year, and as a consequence +its rate as seen from an outside observer +varies due to transverse Doppler effect and gravitational +redshift. The main component is a sinusoidal variation of +amplitude \tsec{0}{0017}; higher harmonics, and terms +caused by Moon and planets, lie two orders of magnitude below +this dominant annual term. Diurnal (topocentric) terms, a +function of UT, are $2\,\mu$s or less. + +The IAU 1976 resolution defined TDB by +stipulating that TDB$-$TT consists of periodic terms only. +This provided +a good qualitative description, but turned out to +contain hidden assumptions about the form of the +solar-system ephemeris and hence lacked dynamical +rigour. A later resolution, in 1991, introduced new +coordinate time scales, TCG and TCB, and identified TDB as a +linear transformation of one of them (TCB) with a rate +chosen not to drift from TT on the average. Unfortunately +even this improved definition has proved to +contin ambiguities. The SLALIB +sla\_RCC function implements TDB in the way that is +most consistent with the 1976 definition and +with existing practice. It provides a model of +TDB$-$TT accurate to a few nanoseconds. + +Unlike TDB, the IAU 1991 coordinate time scales TCG and TCB +(not supported by SLALIB functions at present) +do not have their rates adjusted to track TT and consequently +gain on TT and TDB, by about +\tsec{0}{02}/year and \tsec{0}{5}/year respectively. + +As already pointed out, the distinction between TT and TDB is +of no practical importance for most purposes. For +example when calling +sla\_PRENUT +to generate a precession-nutation matrix, or when calling +sla\_EVP or +sla\_EPV +to predict the +Earth's position and velocity, the time argument is strictly +TDB, but TT is entirely adequate and will require much +less computation. + +The time scale used by the JPL solar-system ephemerides is called +$T_{eph}$ and is numerically the same as TDB. + +Predictions of topocentric solar-system phenomena such as +occultations and eclipses require solar time UT as well as dynamical +time. TT/TDB/ET is all that is required in order to compute the geocentric +circumstances, but if horizon coordinates or geocentric parallax +are to be tackled UT is also needed. A rough estimate +of $\Delta {\rm T} = {\rm ET} - {\rm UT}$ is +available via the function +sla\_DT. +For a given epoch ({\it e.g.}\ 1650) this returns an approximation +to $\Delta {\rm T}$ in seconds. + + + + +\subsection{Calendars} +The ordinary {\it Gregorian Calendar Date}, +together with a time of day, can be +used to express an epoch in any desired time scale. For many purposes, +however, a continuous count of days is more convenient, and for +this purpose the system of {\it Julian Day Number}\/ can be used. +JD zero is located about 7000~years ago, well before the +historical era, and is formally defined in terms of Greenwich noon; +for example Julian Day Number 2449444 began at noon +on 1994 April~1. {\it Julian Date}\/ +is the same system but with a fractional part appended; +Julian Date 2449443.5 was the midnight on which 1994 April~1 +commenced. Because of the unwieldy size of Julian Dates +and the awkwardness of the half-day offset, it is +accepted practice to remove the leading `24' and the trailing `.5', +producing what is called the {\it Modified Julian Date}: +MJD~=~JD$-2400000.5$. SLALIB routines use MJD, as opposed to +JD, throughout, largely to avoid loss of precision. +1994 April~1 commenced at MJD~49443.0. + +Despite JD (and hence MJD) being defined in terms of (in effect) +UT, the system can be used in conjunction with other time scales +such as TAI, TT and TDB (and even sidereal time through the +concept of {\it Greenwich Sidereal Date}). However, it is improper +to express a UTC as a JD or MJD because of leap seconds. + +SLALIB has six routines for converting to and from dates in +the Gregorian calendar. The routines +sla\_CLDJ +and +sla\_CALDJ +both convert a calendar date into an MJD, the former interpreting +years between 0 and 99 as 1st century and the latter as late 20th or +early 21st century. The routines sla\_DJCL +and +sla\_DJCAL +both convert an MJD into calendar year, month, day and fraction of a day; +the latter performs rounding to a specified precision, important +to avoid dates like `{\tt 2005 04 01.***}' appearing in messages. +Some of SLALIB's low-precision ephemeris routines +(sla\_EARTH, +sla\_MOON +and +sla\_ECOR) +work in terms of year plus day-in-year (where +day~1~=~January~1st, at least for the modern era). +This form of date can be generated by +calling +sla\_CALYD +(which defaults years 0-99 into 1950-2049) +or +sla\_CLYD +(which covers the full range from prehistoric times). + +\subsection{Geocentric Coordinates} +The location of the observer on the Earth is significant in a +number of ways. The most obvious, of course, is the effect of +longitude and latitude +on the observed \azel\ of a star. Less obvious is the need to +allow for geocentric parallax when finding the Moon with a +telescope (and when doing high-precision work involving the +Sun or planets), and the need to correct observed radial +velocities and apparent pulsar periods for the effects +of the Earth's rotation. + +The SLALIB routine +sla\_OBS +supplies details of groundbased observatories from an internal +list. This is useful when writing applications that apply to +more than one observatory; the user can enter a brief name, +or browse through a list, and be spared the trouble of typing +in the full latitude, longitude {\it etc}. The following +Fortran code returns the full name, longitude and latitude +of a specified observatory: +\goodbreak +\begin{verbatim} + CHARACTER IDENT*10,NAME*40 + DOUBLE PRECISION W,P,H + : + CALL sla_OBS(0,IDENT,NAME,W,P,H) + IF (NAME.EQ.'?') ... (not recognized) +\end{verbatim} +\goodbreak +(Beware of the longitude sign convention, which is west +ve +for historical reasons.) The following lists all +the supported observatories: +\goodbreak +\begin{verbatim} + : + INTEGER N + : + N=1 + NAME=' ' + DO WHILE (NAME.NE.'?') + CALL sla_OBS(N,IDENT,NAME,W,P,H) + IF (NAME.NE.'?') THEN + WRITE (*,'(1X,I3,4X,A,4X,A)') N,IDENT,NAME + N=N+1 + END IF + END DO +\end{verbatim} +\goodbreak +The routine +sla\_GEOC +converts a {\it geodetic latitude}\/ +(one referred to the local horizon) to a geocentric position, +taking into account the Earth's oblateness and also the height +above sea level of the observer. The results are expressed in +vector form, namely as the distance of the observer from +the spin axis and equator respectively. The {\it geocentric +latitude}\/ can be found be evaluating ATAN2 of the +two numbers. A full 3-D vector description of the position +and velocity of the observer is available through the routine +sla\_PVOBS. +For a specified geodetic latitude, height above +sea level, and local sidereal time, +sla\_PVOBS +generates a 6-element vector containing the position and +velocity with respect to the true equator and equinox of +date ({\it i.e.}\ compatible with apparent \radec). For +some applications it will be necessary to convert to a +mean \radec\ frame (notably FK5, J2000) by multiplying +elements 1-3 and 4-6 respectively with the appropriate +precession matrix. (In theory an additional correction to the +velocity vector is needed to allow for differential precession, +but this correction is always negligible.) + +See also the discussion of the routine +sla\_RVEROT, +later. + +\label{ephem} +\subsection{Ephemerides} +SLALIB includes routines for generating positions and +velocities of Solar-System bodies. The accuracy objectives are +modest, and the SLALIB facilities do not attempt +to compete with precomputed ephemerides such as +those provided by JPL, or with models containing +thousands of terms. It is also worth noting +that SLALIB's very accurate star coordinate conversion +routines are not strictly applicable to solar-system cases, +though they are adequate for most practical purposes. + +Earth/Sun ephemerides can be generated using the routines +sla\_EVP and +sla\_EPV, +each of which predict Earth position and velocity with respect to both the +solar-system barycentre and the +Sun. The two routines offer different trade-offs between +accuracy and execution time. For most purposes, +sla\_EVP is adequate: +maximum velocity error is 0.42~metres per second; maximum +heliocentric position error is 1600~km (equivalent to +about \arcseci{2} at 1~AU), with +barycentric position errors about 4 times worse. +The larger and slower +sla\_EPV +delivers $3\sigma$ results of 0.005~metres per second in velocity +and 15~km in position, and is particularly useful when predicting +apparent directions of near-Earth objects. +(The Sun's position as +seen from the Earth can, of course, be obtained simply by +reversing the signs of the Cartesian components of the +Earth\,:\,Sun vector.) + +Geocentric Moon ephemerides are available from +sla\_DMOON, +which predicts the Moon's position and velocity with respect to +the Earth's centre. Direction accuracy is usually better than +10~km (\arcseci{5}) and distance accuracy a little worse. + +Lower-precision but faster predictions for the Sun and Moon +can be made by calling +sla\_EARTH +and +sla\_MOON. +Both are single precision and accept dates in the form of +year, day-in-year and fraction of day +(starting from a calendar date you need to call +sla\_CLYD +or +sla\_CALYD +to get the required year and day). +The +sla\_EARTH +routine returns the heliocentric position and velocity +of the Earth's centre for the mean equator and +equinox of date. The accuracy is better than 20,000~km in position +and 10~metres per second in speed. +The +position and velocity of the Moon with respect to the +Earth's centre for the mean equator and ecliptic of date +can be obtained by calling +sla\_MOON. +The positional accuracy is better than \arcseci{30} in direction +and 1000~km in distance. + +Approximate ephemerides for all the major planets +can be generated by calling +sla\_PLANET +or +sla\_RDPLAN. These routines offer arcminute accuracy (much +better for the inner planets and for Pluto) over a span of several +millennia (but only $\pm100$ years for Pluto). +The routine +sla\_PLANET produces heliocentric position and +velocity in the form of equatorial \xyzxyzd\ for the +mean equator and equinox of J2000. The vectors +produced by +sla\_PLANET +can be used in a variety of ways according to the +requirements of the application concerned. The routine +sla\_RDPLAN +uses +sla\_PLANET +and +sla\_DMOON +to deal with the common case of predicting +a planet's apparent \radec\ and angular size as seen by a +terrestrial observer. + +Note that in predicting the position in the sky of a solar-system body +it is necessary to allow for geocentric parallax. This correction +is {\it essential}\/ in the case of the Moon, where the observer's +position on the Earth can affect the Moon's \radec\ by up to +$1^\circ$. The calculation can most conveniently be done by calling +sla\_PVOBS and subtracting the resulting 6-vector from the +one produced by +sla\_DMOON, as is demonstrated by the following example: +\goodbreak +\begin{verbatim} + * Demonstrate the size of the geocentric parallax correction + * in the case of the Moon. The test example is for the AAT, + * before midnight, in summer, near first quarter. + + IMPLICIT NONE + CHARACTER NAME*40,SH,SD + INTEGER J,I,IHMSF(4),IDMSF(4) + DOUBLE PRECISION SLONGW,SLAT,H,DJUTC,FDUTC,DJUT1,DJTT,STL, + : RMATN(3,3),PMM(6),PMT(6),RM,DM,PVO(6),TL + DOUBLE PRECISION sla_DTT,sla_GMST,sla_EQEQX,sla_DRANRM + + * Get AAT longitude and latitude in radians and height in metres + CALL sla_OBS(0,'AAT',NAME,SLONGW,SLAT,H) + + * UTC (1992 January 13, 11 13 59) to MJD + CALL sla_CLDJ(1992,1,13,DJUTC,J) + CALL sla_DTF2D(11,13,59.0D0,FDUTC,J) + DJUTC=DJUTC+FDUTC + + * UT1 (UT1-UTC value of -0.152 sec is from IERS Bulletin B) + DJUT1=DJUTC+(-0.152D0)/86400D0 + + * TT + DJTT=DJUTC+sla_DTT(DJUTC)/86400D0 + + * Local apparent sidereal time + STL=sla_GMST(DJUT1)-SLONGW+sla_EQEQX(DJTT) + + * Geocentric position/velocity of Moon (mean of date) + CALL sla_DMOON(DJTT,PMM) + + * Nutation to true equinox of date + CALL sla_NUT(DJTT,RMATN) + CALL sla_DMXV(RMATN,PMM,PMT) + CALL sla_DMXV(RMATN,PMM(4),PMT(4)) + + * Report geocentric HA,Dec + CALL sla_DCC2S(PMT,RM,DM) + CALL sla_DR2TF(2,sla_DRANRM(STL-RM),SH,IHMSF) + CALL sla_DR2AF(1,DM,SD,IDMSF) + WRITE (*,'(1X,'' geocentric:'',2X,A,I2.2,2I3.2,''.'',I2.2,'// + : '1X,A,I2.2,2I3.2,''.'',I1)') + : SH,IHMSF,SD,IDMSF + + * Geocentric position of observer (true equator and equinox of date) + CALL sla_PVOBS(SLAT,H,STL,PVO) + + * Place origin at observer + DO I=1,6 + PMT(I)=PMT(I)-PVO(I) + END DO + + * Allow for planetary aberration + TL=499.004782D0*SQRT(PMT(1)**2+PMT(2)**2+PMT(3)**2) + DO I=1,3 + PMT(I)=PMT(I)-TL*PMT(I+3) + END DO + + * Report topocentric HA,Dec + CALL sla_DCC2S(PMT,RM,DM) + CALL sla_DR2TF(2,sla_DRANRM(STL-RM),SH,IHMSF) + CALL sla_DR2AF(1,DM,SD,IDMSF) + WRITE (*,'(1X,''topocentric:'',2X,A,I2.2,2I3.2,''.'',I2.2,'// + : '1X,A,I2.2,2I3.2,''.'',I1)') + : SH,IHMSF,SD,IDMSF + END +\end{verbatim} +\goodbreak +The output produced is as follows: +\goodbreak +\begin{verbatim} + geocentric: +03 06 55.55 +15 03 38.8 + topocentric: +03 09 23.76 +15 40 51.4 +\end{verbatim} +\goodbreak +(An easier but +less instructive method of estimating the topocentric apparent place of the +Moon is to call the routine +sla\_RDPLAN.) + +As an example of using +sla\_PLANET, +the following program estimates the geocentric separation +between Venus and Jupiter during a close conjunction +in 2\,BC, which is a star-of-Bethlehem candidate: +\goodbreak +\begin{verbatim} + * Compute time and minimum geocentric apparent separation + * between Venus and Jupiter during the close conjunction of 2 BC. + + IMPLICIT NONE + + DOUBLE PRECISION SEPMIN,DJD0,FD,DJD,DJDM,PV(6),RMATP(3,3), + : PVM(6),PVE(6),TL,RV,DV,RJ,DJ,SEP + INTEGER IHOUR,IMIN,J,I,IHMIN,IMMIN + DOUBLE PRECISION sla_EPJ,sla_DSEP + + + * Search for closest approach on the given day + DJD0=1720859.5D0 + SEPMIN=1D10 + DO IHOUR=20,22 + DO IMIN=0,59 + CALL sla_DTF2D(IHOUR,IMIN,0D0,FD,J) + + * Julian date and MJD + DJD=DJD0+FD + DJDM=DJD-2400000.5D0 + + * Earth to Moon (mean of date) + CALL sla_DMOON(DJDM,PV) + + * Precess Moon position to J2000 + CALL sla_PRECL(sla_EPJ(DJDM),2000D0,RMATP) + CALL sla_DMXV(RMATP,PV,PVM) + + * Sun to Earth-Moon Barycentre (mean J2000) + CALL sla_PLANET(DJDM,3,PVE,J) + + * Correct from EMB to Earth + DO I=1,3 + PVE(I)=PVE(I)-0.012150581D0*PVM(I) + END DO + + * Sun to Venus + CALL sla_PLANET(DJDM,2,PV,J) + + * Earth to Venus + DO I=1,6 + PV(I)=PV(I)-PVE(I) + END DO + + * Light time to Venus (sec) + TL=499.004782D0*SQRT((PV(1)-PVE(1))**2+ + : (PV(2)-PVE(2))**2+ + : (PV(3)-PVE(3))**2) + + * Extrapolate backwards in time by that much + DO I=1,3 + PV(I)=PV(I)-TL*PV(I+3) + END DO + + * To RA,Dec + CALL sla_DCC2S(PV,RV,DV) + + * Same for Jupiter + CALL sla_PLANET(DJDM,5,PV,J) + DO I=1,6 + PV(I)=PV(I)-PVE(I) + END DO + TL=499.004782D0*SQRT((PV(1)-PVE(1))**2+ + : (PV(2)-PVE(2))**2+ + : (PV(3)-PVE(3))**2) + DO I=1,3 + PV(I)=PV(I)-TL*PV(I+3) + END DO + CALL sla_DCC2S(PV,RJ,DJ) + + * Separation (arcsec) + SEP=sla_DSEP(RV,DV,RJ,DJ) + + * Keep if smallest so far + IF (SEP.LT.SEPMIN) THEN + IHMIN=IHOUR + IMMIN=IMIN + SEPMIN=SEP + END IF + END DO + END DO + + * Report + WRITE (*,'(1X,I2.2,'':'',I2.2,F6.1)') IHMIN,IMMIN, + : 206264.8062D0*SEPMIN + + END +\end{verbatim} +\goodbreak +The output produced (the Ephemeris Time on the day in question, and +the closest approach in arcseconds) is as follows: +\goodbreak +\begin{verbatim} + 21:16 33.3 +\end{verbatim} +\goodbreak +For comparison, accurate JPL predictions +give a separation \arcseci{8} less than +the above estimate, occurring $30^{\rm m}$ earlier +(see {\it Sky and Telescope,}\/ April~1987, p\,357). + +The following program demonstrates +sla\_RDPLAN. +\begin{verbatim} + * For a given date, time and geographical location, output + * a table of planetary positions and diameters. + + IMPLICIT NONE + CHARACTER PNAMES(0:9)*7,B*80,S + INTEGER I,NP,IY,J,IM,ID,IHMSF(4),IDMSF(4) + DOUBLE PRECISION D15B2P,R2AS,FD,DJM,ELONG,PHI,RA,DEC,DIAM + PARAMETER (D15B2P=2.3873241463784300365D0, + : R2AS=206264.80625D0) + DATA PNAMES / 'Sun','Mercury','Venus','Moon','Mars','Jupiter', + : 'Saturn','Uranus','Neptune', 'Pluto' / + + + * Loop until 'end' typed + B=' ' + DO WHILE (B.NE.'END'.AND.B.NE.'end') + + * Get date, time and observer's location + PRINT *,'Date? (Y,M,D, Gregorian)' + READ (*,'(A)') B + IF (B.NE.'END'.AND.B.NE.'end') THEN + I=1 + CALL sla_INTIN(B,I,IY,J) + CALL sla_INTIN(B,I,IM,J) + CALL sla_INTIN(B,I,ID,J) + PRINT *,'Time? (H,M,S, dynamical)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,FD,J) + FD=FD*D15B2P + CALL sla_CLDJ(IY,IM,ID,DJM,J) + DJM=DJM+FD + PRINT *,'Longitude? (D,M,S, east +ve)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,ELONG,J) + PRINT *,'Latitude? (D,M,S, geodetic)' + READ (*,'(A)') B + I=1 + CALL sla_DAFIN(B,I,PHI,J) + + * Loop planet by planet + DO NP=0,9 + + * Get RA,Dec and diameter + CALL sla_RDPLAN(DJM,NP,ELONG,PHI,RA,DEC,DIAM) + + * One line of report + CALL sla_DR2TF(2,RA,S,IHMSF) + CALL sla_DR2AF(1,DEC,S,IDMSF) + WRITE (*, + : '(1X,A,2X,3I3.2,''.'',I2.2,2X,A,I2.2,2I3.2,''.'',I1,F8.1)') + : PNAMES(NP),IHMSF,S,IDMSF,R2AS*DIAM + + * Next planet + END DO + PRINT *,' ' + END IF + + * Next case + END DO + + END +\end{verbatim} +Entering the following data (for 1927~June~29 at $5^{\rm h}\,25^{\rm m}$~ET +and the position of Preston, UK): +\begin{verbatim} + 1927 6 29 + 5 25 + -2 42 + 53 46 +\end{verbatim} +produces the following report: +\begin{verbatim} + Sun 06 28 14.03 +23 17 17.3 1887.8 + Mercury 08 08 58.60 +19 20 57.1 9.3 + Venus 09 38 53.61 +15 35 32.8 22.8 + Moon 06 28 15.95 +23 17 21.3 1902.3 + Mars 09 06 49.33 +17 52 26.6 4.0 + Jupiter 00 11 12.08 -00 10 57.5 41.1 + Saturn 16 01 43.35 -18 36 55.9 18.2 + Uranus 00 13 33.54 +00 39 36.1 3.5 + Neptune 09 49 35.76 +13 38 40.8 2.2 + Pluto 07 05 29.51 +21 25 04.2 0.1 +\end{verbatim} +Inspection of the Sun and Moon data reveals that +a total solar eclipse is in progress. + +SLALIB also provides for the case where orbital elements (with respect +to the J2000 equinox and ecliptic) +are available. This allows predictions to be made for minor-planets and +(if you ignore non-gravitational effects) +comets. Furthermore, if major-planet elements for an epoch close to the date +in question are available, more accurate predictions can be made than +are offered by +sla\_RDPLAN and +sla\_PLANET. + +The SLALIB planetary-prediction +routines that work with orbital elements are +sla\_PLANTE (the orbital-elements equivalent of +sla\_RDPLAN), which predicts the topocentric \radec, and +sla\_PLANEL (the orbital-elements equivalent of +sla\_PLANET), which predicts the heliocentric \xyzxyzd\ with respect to the +J2000 equinox and equator. In addition, the routine +sla\_PV2EL does the inverse of +sla\_PLANEL, transforming \xyzxyzd\ into {\it osculating elements.} + +Osculating elements describe the unperturbed 2-body orbit. Depending +on accuracy requirements, this unperturbed orbit is an +adequate approximation to the actual orbit for a few weeks either +side of the specified epoch, outside which perturbations due to +the other bodies of the Solar System lead to +increasing errors. Given a minor planet's osculating elements for +a particular date, predictions for a date only +100 days earlier or later +are likely to be in error by several arcseconds. +These errors can +be reduced if new elements are generated which take account of +the perturbations of the major planets, and this is what the routine +sla\_PERTEL does. Once +sla\_PERTEL has been called, to provide osculating elements +close to the required date, the elements can be passed to +sla\_PLANEL or +sla\_PLANTE in the normal way. Predictions of arcsecond accuracy +over a span of a decade or more are available using this +technique. + +Three different combinations of orbital elements are +provided for, matching the usual conventions +for major planets, minor planets and +comets respectively. The choice is made through the +argument {\tt JFORM}: + +\vspace{1ex} +\hspace{3em} +\begin{tabular}{|c|c|c|} \hline +{\tt JFORM=1} & {\tt JFORM=2} & {\tt JFORM=3} \\ +\hline \hline +$t_0$ & $t_0$ & $T$ \\ +\hline +$i$ & $i$ & $i$ \\ +\hline +$\Omega$ & $\Omega$ & $\Omega$ \\ +\hline +$\varpi$ & $\omega$ & $\omega$ \\ +\hline +$a$ & $a$ & $q$ \\ +\hline +$e$ & $e$ & $e$ \\ +\hline +$L$ & $M$ & \\ +\hline +$n$ & & \\ +\hline +\end{tabular}\\[2ex] +The symbols have the following meanings: + +\vspace{-1ex} + +\begin{tabular}{lll} +& $t_0$ & epoch of osculation \\ +& $T$ & epoch of perihelion passage \\ +& $i$ & inclination of the orbit \\ +& $\Omega$ & longitude of the ascending node \\ +& $\varpi$ & longitude of perihelion ($\varpi = \Omega + \omega$) \\ +& $\omega$ & argument of perihelion \\ +& $a$ & semi-major axis of the orbital ellipse \\ +& $q$ & perihelion distance \\ +& $e$ & orbital eccentricity \\ +& $L$ & mean longitude ($L = \varpi + M$) \\ +& $M$ & mean anomaly \\ +& $n$ & mean motion \\ +\end{tabular} + +The mean motion, $n$, tells +sla\_PLANEL the mass of the planet. +If it is not available, it should be calculated +from $n^2 a^3 = k^2 (1+m)$, where $k = 0.01720209895$ and +m is the mass of the planet ($M_\odot = 1$); $a$ is in AU. + +Note that for any given problem there are up to three different +epochs in play, and it is vital to distinguish clearly between +them: +\begin{itemize} +\item The epoch of observation: the moment in time for which the + position of the body is to be predicted. +\item The epoch defining the position of the body: the moment in time + at which, in the absence of purturbations, the specified + position---mean longitude, mean anomaly, or perihelion---is + reached. +\item The epoch of osculation: the moment in time at which the given + elements precisely specify the body's position and velocity. +\end{itemize} + +For the major-planet and minor-planet cases it is usual to make +the epoch that defines the position of the body the same as the +epoch of osculation. Thus, for planets (major and +minor) only two different epochs are +involved: the epoch of the elements and the epoch of observation. +For comets, the epoch of perihelion fixes the position in the +orbit and in general a different epoch of osculation will be +chosen. Thus, for comets all three types of epoch are involved. +How many of the three elements are present in a given SLALIB +argument list depends on the routine concerned. + +Two important sources for orbital elements are the {\it Horizons}\/ +service, operated by the Jet Propulsion Laboratory, Pasadena, +and the Minor Planet Center, operated by the Center for +Astrophysics, Harvard. +The JPL elements (heliocentric, J2000 ecliptic and +equinox) and MPC elements +correspond to SLALIB arguments as shown in the following table, +where ``(rad)'' means conversion from degrees to radians, and +``(MJD)'' means ``subtract {\tt 2400000.5D0}'': + +\vspace{2ex} + +\begin{small} +\begin{tabular}{|c||c|c|c||c|c|} \hline +{\it SLALIB } & \multicolumn{3}{c||}{\it JPL} + & \multicolumn{2}{c|}{\it MPC} \\ +argument & major planet & minor planet & comet & minor planet & comet \\ +\hline \hline +{\tt JFORM} & {\tt 1} & {\tt 2} & {\tt 3} & {\tt 2} & {\tt 3} \\ +{\tt EPOCH} & {\tt JDCT} (MJD) & {\tt JDCT} (MJD) & {\tt Tp} (MJD) & + {\tt Epoch} (MJD) & {\tt T} (MJD) \\ +{\tt ORBINC} & {\tt IN} (rad) & {\tt IN} (rad) & {\tt IN} (rad) & + {\tt Incl.} (rad) & {\tt Incl.} (rad) \\ +{\tt ANODE} & {\tt OM} (rad) & {\tt OM} (rad) & {\tt OM} (rad) & + {\tt Node} (rad) & {\tt Node.} (rad) \\ +{\tt PERIH} & {\tt OM+W} (rad) & {\tt W} (rad) & {\tt W} (rad) & + {\tt Perih.} (rad) & {\tt Perih.} (rad) \\ +{\tt AORQ} & {\tt A} & {\tt A} & {\tt QR} & {\tt a} & {\tt q} \\ +{\tt E} & {\tt EC} & {\tt EC} & {\tt EC} & {\tt e} & {\tt e} \\ +{\tt AORL} & {\tt MA+OM+W} (rad) & {\tt MA} (rad) & & {\tt M} (rad) & \\ +{\tt DM} & {\tt N} (rad) & & & & \\ \hline +epoch of osculation & {\tt JDCT} (MJD) + & {\tt JDCT} (MJD) + & {\tt JDCT} (MJD) + & {\tt Epoch} (MJD) + & {\tt Epoch} (MJD) \\ +\hline +\end{tabular} +\end{small}\\[3ex] + +Conventional elements are not the only way of specifying an orbit. +The \xyzxyzd\ state vector is an equally valid specification, +and the so-called {\it method of universal variables}\/ allows +orbital calculations to be made directly, bypassing angular +quantities and avoiding Kepler's Equation. The universal-variables +approach has various advantages, including better handling of +near-parabolic cases and greater efficiency. +SLALIB uses universal variables for its internal +calculations and also offers a number of routines which +applications can call. + +The universal elements are the \xyzxyzd\ and its epoch, plus the mass +of the body. The SLALIB routines supplement these elements with +certain redundant values in order to +avoid unnecessary recomputation when the elements are next used. + +The routines +sla\_EL2UE and +sla\_UE2EL transform conventional elements into the +universal form and {\it vice versa.} +The routine +sla\_PV2UE takes an \xyzxyzd\ and forms the set of universal +elements; +sla\_UE2PV takes a set of universal elements and predicts the \xyzxyzd\ +for a specified epoch. +The routine +sla\_PERTUE provides updated universal elements, +taking into account perturbations from the major planets. +Starting with universal elements, the routine +sla\_PLANTU (the universal elements equivalent of +sla\_PLANTE) predicts topocentric \radec. + +\subsection{Radial Velocity and Light-Time Corrections} +When publishing high-resolution spectral observations +it is necessary to refer them to a specified standard of rest. +This involves knowing the component in the direction of the +source of the velocity of the observer. SLALIB provides a number +of routines for this purpose, allowing observations to be +referred to the Earth's centre, the Sun, a Local Standard of Rest +(either dynamical or kinematical), the centre of the Galaxy, and +the mean motion of the Local Group. + +The routine +sla\_RVEROT +corrects for the diurnal rotation of +the observer around the Earth's axis. This is always less than 0.5~km/s. + +No specific routine is provided to correct a radial velocity +from geocentric to heliocentric, but this can easily be done by calling +sla\_EVP +as follows (array declarations {\it etc}.\ omitted): +\goodbreak +\begin{verbatim} + : + * Star vector, J2000 + CALL sla_DCS2C(RM,DM,V) + + * Earth/Sun velocity and position, J2000 + CALL sla_EVP(TDB,2000D0,DVB,DPB,DVH,DPH) + + * Radial velocity correction due to Earth orbit (km/s) + VCORB = -sla_DVDV(V,DVH)*149.597870D6 + : +\end{verbatim} +\goodbreak +The maximum value of this correction is the Earth's orbital speed +of about 30~km/s. A related routine, +sla\_ECOR, +computes the light-time correction with respect to the Sun. It +would be used when reducing observations of a rapid variable-star +for instance. +For pulsar work the +sla\_EVP routine is not sufficiently accurate for +phase predictions, being limited to about 25~ms. The +alternative sla\_EPV routine will deliver pulse arrival times +accurate to 50~$\mu$s, but is significantly slower. + +To remove the intrinsic $\sim20$~km/s motion of the Sun relative +to other stars in the solar neighbourhood, +a velocity correction to a +{\it local standard of rest}\/ (LSR) is required. There are +opportunities for mistakes here. There are two sorts of LSR, +{\it dynamical}\/ and {\it kinematical}, and +multiple definitions exist for the latter. The +dynamical LSR is a point near the Sun which is in a circular +orbit around the Galactic centre; the Sun has a ``peculiar'' +motion relative to the dynamical LSR. A kinematical LSR is +the mean standard of rest of specified star catalogues or stellar +populations, and its precise definition depends on which +catalogues or populations were used and how the analysis was +carried out. The Sun's motion with respect to a kinematical +LSR is called the ``standard'' solar motion. Radial +velocity corrections to the dynamical LSR are produced by the routine +sla\_RVLSRD +and to the adopted kinematical LSR by +sla\_RVLSRK. +See the individual specifications for these routines for the +precise definition of the LSR in each case. + +For extragalactic sources, the centre of the Galaxy can be used as +a standard of rest. The radial velocity correction from the +dynamical LSR to the Galactic centre can be obtained by calling +sla\_RVGALC. +Its maximum value is 220~km/s. + +For very distant sources it is appropriate to work relative +to the mean motion of the Local Group. The routine for +computing the radial velocity correction in this case is +sla\_RVLG. +Note that in this case the correction is with respect to the +dynamical LSR, not the Galactic centre as might be expected. +This conforms to the IAU definition, and confers immunity from +revisions of the Galactic rotation speed. + +\subsection{Focal-Plane Astrometry} +The relationship between the position of a star image in +the focal plane of a telescope and the star's celestial +coordinates is usually described in terms of the {\it tangent plane}\/ +or {\it gnomonic}\/ projection. This is the projection produced +by a pin-hole camera and is a good approximation to the projection +geometry of a traditional large {\it f}\/-ratio astrographic refractor. +SLALIB includes a group of routines which transform +star positions between their observed places on the celestial +sphere and their \xy\ coordinates in the tangent plane. The +spherical coordinate system does not have to be \radec\ but +usually is. The so-called {\it standard coordinates}\/ of a star +are the tangent plane \xy, in radians, with respect to an origin +at the tangent point, with the $y$-axis pointing north and +the $x$-axis pointing east (in the direction of increasing $\alpha$). +The factor relating the standard coordinates to +the actual \xy\ coordinates in, say, millimetres is simply +the focal length of the telescope. + +Given the \radec\ of the {\it plate centre}\/ (the tangent point) +and the \radec\ of a star within the field, the standard +coordinates can be determined by calling +sla\_S2TP +(single precision) or +sla\_DS2TP +(double precision). The reverse transformation, where the +\xy\ is known and we wish to find the \radec, is carried out by calling +sla\_TP2S +or +sla\_DTP2S. +Occasionally we know the both the \xy\ and the \radec\ of a +star and need to deduce the \radec\ of the tangent point; +this can be done by calling +sla\_TPS2C +or +sla\_DTPS2C. +(All of these transformations apply not just to \radec\ but to +other spherical coordinate systems, of course.) +Equivalent (and faster) +routines are provided which work directly in \xyz\ instead of +spherical coordinates: +sla\_V2TP and +sla\_DV2TP, +sla\_TP2V and +sla\_DTP2V, +sla\_TPV2C and +sla\_DTPV2C. + +Even at the best of times, the tangent plane projection is merely an +approximation. Some telescopes and cameras exhibit considerable pincushion +or barrel distortion and some have a curved focal surface. +For example, neither Schmidt cameras nor (especially) +large reflecting telescopes with wide-field corrector lenses +are adequately modelled by tangent-plane geometry. In such +cases, however, it is still possible to do most of the work +using the (mathematically convenient) tangent-plane +projection by inserting an extra step which applies or +removes the distortion peculiar to the system concerned. +A simple $r_1=r_0(1+Kr_0^2)$ law works well in the +majority of cases; $r_0$ is the radial distance in the +tangent plane, $r_1$ is the radial distance after adding +the distortion, and $K$ is a constant which depends on the +telescope ($\theta$ is unaffected). The routine +sla\_PCD +applies the distortion to an \xy\ and +sla\_UNPCD +removes it. For \xy\ in radians, $K$ values range from $-1/3$ for the +tiny amount of barrel distortion in Schmidt geometry to several +hundred for the serious pincushion distortion +produced by wide-field correctors in big reflecting telescopes +(the AAT prime focus triplet corrector is about $K=+178.6$). + +SLALIB includes a group of routines which can be put together +to build a simple plate-reduction program. The heart of the group is +sla\_FITXY, +which fits a linear model to relate two sets of \xy\ coordinates, +in the case of a plate reduction the measured positions of the +images of a set of +reference stars and the standard +coordinates derived from their catalogue positions. The +model is of the form: +\[x_{p} = a + bx_{m} + cy_{m}\] +\[y_{p} = d + ex_{m} + fy_{m}\] + +where the {\it p}\/ subscript indicates ``predicted'' coordinates +(the model's approximation to the ideal ``expected'' coordinates) and the +{\it m}\/ subscript indicates ``measured coordinates''. The +six coefficients {\it a--f}\/ can optionally be +constrained to represent a ``solid body rotation'' free of +any squash or shear distortions. Without this constraint +the model can, to some extent, accommodate effects like refraction, +allowing mean places to be used directly and +avoiding the extra complications of a +full mean-apparent-observed transformation for each star. +Having obtained the linear model, +sla\_PXY +can be used to process the set of measured and expected +coordinates, giving the predicted coordinates and determining +the RMS residuals in {\it x}\/ and {\it y}. +The routine +sla\_XY2XY +transforms one \xy\ into another using the linear model. A model +can be inverted by calling +sla\_INVF, +and decomposed into zero points, scales, $x/y$ nonperpendicularity +and orientation by calling +sla\_DCMPF. + +\subsection{Numerical Methods} +SLALIB contains a small number of simple, general-purpose +numerical-methods routines. They have no specific +connection with positional astronomy but have proved useful in +applications to do with simulation and fitting. + +At the heart of many simulation programs is the generation of +pseudo-random numbers, evenly distributed in a given range: +sla\_RANDOM +does this. Pseudo-random normal deviates, or ``Gaussian +residuals'', are often required to simulate noise and +can be generated by means of the function +sla\_GRESID. +Neither routine will pass super-sophisticated +statistical tests, but they work adequately for most +practical purposes and avoid the need to call non-standard +library routines peculiar to one sort of computer. + +Applications which perform a least-squares fit using a traditional +normal-equations methods can accomplish the required matrix-inversion +by calling either +sla\_SMAT +(single precision) or +sla\_DMAT +(double). A generally better way to perform such fits is +to use singular value decomposition. SLALIB provides a routine +to do the decomposition itself, +sla\_SVD, +and two routines to use the results: +sla\_SVDSOL +generates the solution, and +sla\_SVDCOV +produces the covariance matrix. +A simple demonstration of the use of the SLALIB SVD +routines is given below. It generates 500 simulated data +points and fits them to a model which has 4 unknown coefficients. +(The arrays in the example are sized to accept up to 1000 +points and 20 unknowns.) The model is: +\[ y = C_{1} +C_{2}x +C_{3}sin{x} +C_{4}cos{x} \] +The test values for the four coefficients are +$C_1\!=\!+50.0$, +$C_2\!=\!-2.0$, +$C_3\!=\!-10.0$ and +$C_4\!=\!+25.0$. +Gaussian noise, $\sigma=5.0$, is added to each ``observation''. +\goodbreak +\begin{verbatim} + IMPLICIT NONE + + * Sizes of arrays, physical and logical + INTEGER MP,NP,NC,M,N + PARAMETER (MP=1000,NP=10,NC=20,M=500,N=4) + + * The unknowns we are going to solve for + DOUBLE PRECISION C1,C2,C3,C4 + PARAMETER (C1=50D0,C2=-2D0,C3=-10D0,C4=25D0) + + * Arrays + DOUBLE PRECISION A(MP,NP),W(NP),V(NP,NP), + : WORK(NP),B(MP),X(NP),CVM(NC,NC) + + DOUBLE PRECISION VAL,BF1,BF2,BF3,BF4,SD2,D,VAR + REAL sla_GRESID + INTEGER I,J + + * Fill the design matrix + DO I=1,M + + * Dummy independent variable + VAL=DBLE(I)/10D0 + + * The basis functions + BF1=1D0 + BF2=VAL + BF3=SIN(VAL) + BF4=COS(VAL) + + * The observed value, including deliberate Gaussian noise + B(I)=C1*BF1+C2*BF2+C3*BF3+C4*BF4+DBLE(sla_GRESID(5.0)) + + * Fill one row of the design matrix + A(I,1)=BF1 + A(I,2)=BF2 + A(I,3)=BF3 + A(I,4)=BF4 + END DO + + * Factorize the design matrix, solve and generate covariance matrix + CALL sla_SVD(M,N,MP,NP,A,W,V,WORK,J) + CALL sla_SVDSOL(M,N,MP,NP,B,A,W,V,WORK,X) + CALL sla_SVDCOV(N,NP,NC,W,V,WORK,CVM) + + * Compute the variance + SD2=0D0 + DO I=1,M + VAL=DBLE(I)/10D0 + BF1=1D0 + BF2=VAL + BF3=SIN(VAL) + BF4=COS(VAL) + D=B(I)-(X(1)*BF1+X(2)*BF2+X(3)*BF3+X(4)*BF4) + SD2=SD2+D*D + END DO + VAR=SD2/DBLE(M) + + * Report the RMS and the solution + WRITE (*,'(1X,''RMS ='',F5.2/)') SQRT(VAR) + DO I=1,N + WRITE (*,'(1X,''C'',I1,'' ='',F7.3,'' +/-'',F6.3)') + : I,X(I),SQRT(VAR*CVM(I,I)) + END DO + END +\end{verbatim} +\goodbreak +The program produces output like the following: +\goodbreak +\begin{verbatim} + RMS = 4.88 + + C1 = 50.192 +/- 0.439 + C2 = -2.002 +/- 0.015 + C3 = -9.771 +/- 0.310 + C4 = 25.275 +/- 0.310 +\end{verbatim} +\goodbreak +In this above example, essentially +identical results would be obtained if the more +commonplace normal-equations method had been used, and the large +$1000\times20$ array would have been avoided. However, the SVD method +comes into its own when the opportunity is taken to edit the W-matrix +(the so-called ``singular values'') in order to control +possible ill-conditioning. The procedure involves replacing with +zeroes any W-elements smaller than a nominated value, for example +0.001 times the largest W-element. Small W-elements indicate +ill-conditioning, which in the case of the normal-equations +method would produce spurious large coefficient values and +possible arithmetic overflows. Using SVD, the effect on the solution +of setting suspiciously small W-elements to zero is to restrain +the offending coefficients from moving very far. The +fact that action was taken can be reported to show the program user that +something is amiss. Furthermore, if element W(J) was set to zero, +the row numbers of the two biggest elements in the Jth column of the +V-matrix identify the pair of solution coefficients that are +dependent. + +A more detailed description of SVD and its use in least-squares +problems would be out of place here, and the reader is urged +to refer to the relevant sections of the book {\it Numerical Recipes} +(Press {\it et al.}, Cambridge University Press, 1987). + +The routines +sla\_COMBN +and +sla\_PERMUT +are useful for problems which involve combinations (different subsets) +and permutations (different orders). +Both return the next in a sequence of results, cycling through all the +possible results as the routine is called repeatedly. + +\vfill + +\pagebreak + +\section{SUMMARY OF CALLS} +The basic trigonometrical and numerical facilities are supplied in both single +and double precision versions. +Most of the more esoteric position and time routines use double precision +arguments only, even in cases where single precision would normally be adequate +in practice. +Certain routines with modest accuracy objectives are supplied in +single precision versions only. +In the calling sequences which follow, no attempt has been made +to distinguish between single and double precision argument names, +and frequently the same name is used on different occasions to +mean different things. +However, none of the routines uses a mixture of single and +double precision arguments; each routine is either wholly +single precision or wholly double precision. + +In the classified list, below, +{\it subroutine}\/ subprograms are those whose names and argument lists +are preceded by `CALL', whereas {\it function}\/ subprograms are +those beginning `R=' (when the result is REAL) or `D=' (when +the result is DOUBLE~PRECISION). + +The list is, of course, merely for quick reference; inexperienced +users {\bf must} refer to the detailed specifications given later. +In particular, {\bf don't guess} whether arguments are single or +double precision; the result could be a program that happens to +works on one sort of machine but not on another. + +\callhead{String Decoding} +\begin{callset} +\subp{CALL sla\_INTIN (STRING, NSTRT, IRESLT, JFLAG)} + Convert free-format string into integer +\subq{CALL sla\_FLOTIN (STRING, NSTRT, RESLT, JFLAG)} + {CALL sla\_DFLTIN (STRING, NSTRT, DRESLT, JFLAG)} + Convert free-format string into floating-point number +\subq{CALL sla\_AFIN (STRING, NSTRT, RESLT, JFLAG)} + {CALL sla\_DAFIN (STRING, NSTRT, DRESLT, JFLAG)} + Convert free-format string from deg,arcmin,arcsec to radians +\end{callset} + +\callhead{Sexagesimal Conversions} +\begin{callset} +\subq{CALL sla\_CTF2D (IHOUR, IMIN, SEC, DAYS, J)} + {CALL sla\_DTF2D (IHOUR, IMIN, SEC, DAYS, J)} + Hours, minutes, seconds to days +\subq{CALL sla\_CD2TF (NDP, DAYS, SIGN, IHMSF)} + {CALL sla\_DD2TF (NDP, DAYS, SIGN, IHMSF)} + Days to hours, minutes, seconds +\subq{CALL sla\_CTF2R (IHOUR, IMIN, SEC, RAD, J)} + {CALL sla\_DTF2R (IHOUR, IMIN, SEC, RAD, J)} + Hours, minutes, seconds to radians +\subq{CALL sla\_CR2TF (NDP, ANGLE, SIGN, IHMSF)} + {CALL sla\_DR2TF (NDP, ANGLE, SIGN, IHMSF)} + Radians to hours, minutes, seconds +\subq{CALL sla\_CAF2R (IDEG, IAMIN, ASEC, RAD, J)} + {CALL sla\_DAF2R (IDEG, IAMIN, ASEC, RAD, J)} + Degrees, arcminutes, arcseconds to radians +\subq{CALL sla\_CR2AF (NDP, ANGLE, SIGN, IDMSF)} + {CALL sla\_DR2AF (NDP, ANGLE, SIGN, IDMSF)} + Radians to degrees, arcminutes, arcseconds +\end{callset} + +\callhead{Angles, Vectors and Rotation Matrices} +\begin{callset} +\subq{R~=~sla\_RANGE (ANGLE)} + {D~=~sla\_DRANGE (ANGLE)} + Normalize angle into range $\pm\pi$ +\subq{R~=~sla\_RANORM (ANGLE)} + {D~=~sla\_DRANRM (ANGLE)} + Normalize angle into range $0\!-\!2\pi$ +\subq{CALL sla\_CS2C (A, B, V)} + {CALL sla\_DCS2C (A, B, V)} + Spherical coordinates to \xyz +\subq{CALL sla\_CC2S (V, A, B)} + {CALL sla\_DCC2S (V, A, B)} + \xyz\ to spherical coordinates +\subq{R~=~sla\_VDV (VA, VB)} + {D~=~sla\_DVDV (VA, VB)} + Scalar product of two 3-vectors +\subq{CALL sla\_VXV (VA, VB, VC)} + {CALL sla\_DVXV (VA, VB, VC)} + Vector product of two 3-vectors +\subq{CALL sla\_VN (V, UV, VM)} + {CALL sla\_DVN (V, UV, VM)} + Normalize a 3-vector also giving the modulus +\subq{R~=~sla\_SEP (A1, B1, A2, B2)} + {D~=~sla\_DSEP (A1, B1, A2, B2)} + Angle between two points on a sphere +\subq{R~=~sla\_SEPV (V1, V2)} + {D~=~sla\_DSEPV (V1, V2)} + Angle between two \xyz\ vectors +\subq{R~=~sla\_BEAR (A1, B1, A2, B2)} + {D~=~sla\_DBEAR (A1, B1, A2, B2)} + Direction of one point on a sphere seen from another +\subq{R~=~sla\_PAV (V1, V2)} + {D~=~sla\_DPAV (V1, V2)} + Position-angle of one \xyz\ with respect to another +\subq{CALL sla\_EULER (ORDER, PHI, THETA, PSI, RMAT)} + {CALL sla\_DEULER (ORDER, PHI, THETA, PSI, RMAT)} + Form rotation matrix from three Euler angles +\subq{CALL sla\_AV2M (AXVEC, RMAT)} + {CALL sla\_DAV2M (AXVEC, RMAT)} + Form rotation matrix from axial vector +\subq{CALL sla\_M2AV (RMAT, AXVEC)} + {CALL sla\_DM2AV (RMAT, AXVEC)} + Determine axial vector from rotation matrix +\subq{CALL sla\_MXV (RM, VA, VB)} + {CALL sla\_DMXV (DM, VA, VB)} + Rotate vector forwards +\subq{CALL sla\_IMXV (RM, VA, VB)} + {CALL sla\_DIMXV (DM, VA, VB)} + Rotate vector backwards +\subq{CALL sla\_MXM (A, B, C)} + {CALL sla\_DMXM (A, B, C)} + Product of two 3x3 matrices +\subq{CALL sla\_CS2C6 (A, B, R, AD, BD, RD, V)} + {CALL sla\_DS2C6 (A, B, R, AD, BD, RD, V)} + Conversion of position and velocity in spherical + coordinates to Cartesian coordinates +\subq{CALL sla\_CC62S (V, A, B, R, AD, BD, RD)} + {CALL sla\_DC62S (V, A, B, R, AD, BD, RD)} + Conversion of position and velocity in Cartesian + coordinates to spherical coordinates +\end{callset} + +\callhead{Calendars} +\begin{callset} +\subp{CALL sla\_CLDJ (IY, IM, ID, DJM, J)} + Gregorian Calendar to Modified Julian Date +\subp{CALL sla\_CALDJ (IY, IM, ID, DJM, J)} + Gregorian Calendar to Modified Julian Date, + permitting century default +\subp{CALL sla\_DJCAL (NDP, DJM, IYMDF, J)} + Modified Julian Date to Gregorian Calendar, + in a form convenient for formatted output +\subp{CALL sla\_DJCL (DJM, IY, IM, ID, FD, J)} + Modified Julian Date to Gregorian Year, Month, Day, Fraction +\subp{CALL sla\_CALYD (IY, IM, ID, NY, ND, J)} + Calendar to year and day in year, permitting century default +\subp{CALL sla\_CLYD (IY, IM, ID, NY, ND, J)} + Calendar to year and day in year +\subp{D~=~sla\_EPB (DATE)} + Modified Julian Date to Besselian Epoch +\subp{D~=~sla\_EPB2D (EPB)} + Besselian Epoch to Modified Julian Date +\subp{D~=~sla\_EPJ (DATE)} + Modified Julian Date to Julian Epoch +\subp{D~=~sla\_EPJ2D (EPJ)} + Julian Epoch to Modified Julian Date +\end{callset} + +\callhead{Time Scales} +\begin{callset} +\subp{D~=~sla\_GMST (UT1)} + Conversion from Universal Time to sidereal time +\subp{D~=~sla\_GMSTA (DATE, UT1)} + Conversion from Universal Time to sidereal time, rounding errors minimized +\subp{D~=~sla\_EQEQX (DATE)} + Equation of the equinoxes +\subp{D~=~sla\_DAT (DJU)} + Offset of Atomic Time from Coordinated Universal Time: TAI$-$UTC +\subp{D~=~sla\_DT (EPOCH)} + Approximate offset between dynamical time and universal time +\subp{D~=~sla\_DTT (DJU)} + Offset of Terrestrial Time from Coordinated Universal Time: TT$-$UTC +\subp{D~=~sla\_RCC (TDB, UT1, WL, U, V)} + Relativistic clock correction: TDB$-$TT +\end{callset} + +\callhead{Precession and Nutation} +\begin{callset} +\subp{CALL sla\_NUT (DATE, RMATN)} + Nutation matrix +\subp{CALL sla\_NUTC (DATE, DPSI, DEPS, EPS0)} + Longitude and obliquity components of nutation, and + mean obliquity +\subp{CALL sla\_NUTC80 (DATE, DPSI, DEPS, EPS0)} + Longitude and obliquity components of nutation, and + mean obliquity, IAU 1980 +\subp{CALL sla\_PREC (EP0, EP1, RMATP)} + Precession matrix (IAU) +\subp{CALL sla\_PRECL (EP0, EP1, RMATP)} + Precession matrix (suitable for long periods) +\subp{CALL sla\_PRENUT (EPOCH, DATE, RMATPN)} + Combined precession-nutation matrix +\subp{CALL sla\_PREBN (BEP0, BEP1, RMATP)} + Precession matrix, old system +\subp{CALL sla\_PRECES (SYSTEM, EP0, EP1, RA, DC)} + Precession, in either the old or the new system +\end{callset} + +\callhead{Proper Motion} +\begin{callset} +\subp{CALL sla\_PM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1)} + Adjust for proper motion +\end{callset} + +\callhead{FK4/FK5/Hipparcos Conversions} +\begin{callset} +\subp{CALL sla\_FK425 (\vtop + {\hbox{R1950, D1950, DR1950, DD1950, P1950, V1950,} + \hbox{R2000, D2000, DR2000, DD2000, P2000, V2000)}}} + Convert B1950.0 FK4 star data to J2000.0 FK5 +\subp{CALL sla\_FK45Z (R1950, D1950, EPOCH, R2000, D2000)} + Convert B1950.0 FK4 position to J2000.0 FK5 assuming zero + FK5 proper motion and no parallax +\subp{CALL sla\_FK524 (\vtop + {\hbox{R2000, D2000, DR2000, DD2000, P2000, V2000,} + \hbox{R1950, D1950, DR1950, DD1950, P1950, V1950)}}} + Convert J2000.0 FK5 star data to B1950.0 FK4 +\subp{CALL sla\_FK54Z (R2000, D2000, BEPOCH, + R1950, D1950, DR1950, DD1950)} + Convert J2000.0 FK5 position to B1950.0 FK4 assuming zero + FK5 proper motion and no parallax +\subp{CALL sla\_FK52H (R5, D5, DR5, DD5, RH, DH, DRH, DDH)} + Convert J2000.0 FK5 star data to Hipparcos +\subp{CALL sla\_FK5HZ (R5, D5, EPOCH, RH, DH )} + Convert J2000.0 FK5 position to Hipparcos assuming zero Hipparcos + proper motion +\subp{CALL sla\_H2FK5 (RH, DH, DRH, DDH, R5, D5, DR5, DD5)} + Convert Hipparcos star data to J2000.0 FK5 +\subp{CALL sla\_HFK5Z (RH, DH, EPOCH, R5, D5, DR5, DD5)} + Convert Hipparcos position to J2000.0 FK5 assuming zero Hipparcos + proper motion +\subp{CALL sla\_DBJIN (STRING, NSTRT, DRESLT, J1, J2)} + Like sla\_DFLTIN but with extensions to accept leading `B' and `J' +\subp{CALL sla\_KBJ (JB, E, K, J)} + Select epoch prefix `B' or `J' +\subp{D~=~sla\_EPCO (K0, K, E)} + Convert an epoch into the appropriate form -- `B' or `J' +\end{callset} + +\callhead{Elliptic Aberration} +\begin{callset} +\subp{CALL sla\_ETRMS (EP, EV)} + E-terms +\subp{CALL sla\_SUBET (RC, DC, EQ, RM, DM)} + Remove the E-terms +\subp{CALL sla\_ADDET (RM, DM, EQ, RC, DC)} + Add the E-terms +\end{callset} + +\callhead{Geographical and Geocentric Coordinates} +\begin{callset} +\subp{CALL sla\_OBS (NUMBER, ID, NAME, WLONG, PHI, HEIGHT)} + Interrogate list of observatory parameters +\subp{CALL sla\_GEOC (P, H, R, Z)} + Convert geodetic position to geocentric +\subp{CALL sla\_POLMO (ELONGM, PHIM, XP, YP, ELONG, PHI, DAZ)} + Polar motion +\subp{CALL sla\_PVOBS (P, H, STL, PV)} + Position and velocity of observatory +\end{callset} + +\callhead{Apparent and Observed Place} +\begin{callset} +\subp{CALL sla\_MAP (RM, DM, PR, PD, PX, RV, EQ, DATE, RA, DA)} + Mean place to geocentric apparent place +\subp{CALL sla\_MAPPA (EQ, DATE, AMPRMS)} + Precompute mean to apparent parameters +\subp{CALL sla\_MAPQK (RM, DM, PR, PD, PX, RV, AMPRMS, RA, DA)} + Mean to apparent using precomputed parameters +\subp{CALL sla\_MAPQKZ (RM, DM, AMPRMS, RA, DA)} + Mean to apparent using precomputed parameters, for zero proper + motion, parallax and radial velocity +\subp{CALL sla\_AMP (RA, DA, DATE, EQ, RM, DM)} + Geocentric apparent place to mean place +\subp{CALL sla\_AMPQK (RA, DA, AMPRMS, RM, DM)} + Apparent to mean using precomputed parameters +\subp{CALL sla\_AOP (\vtop + {\hbox{RAP, DAP, UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOB, ZOB, HOB, DOB, ROB)}}} + Apparent place to observed place +\subp{CALL sla\_AOPPA (\vtop + {\hbox{UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, AOPRMS)}}} + Precompute apparent to observed parameters +\subp{CALL sla\_AOPPAT (UTC, AOPRMS)} + Update sidereal time in apparent to observed parameters +\subp{CALL sla\_AOPQK (RAP, DAP, AOPRMS, AOB, ZOB, HOB, DOB, ROB)} + Apparent to observed using precomputed parameters +\subp{CALL sla\_OAP (\vtop + {\hbox{TYPE, OB1, OB2, UTC, DUT, ELONGM, PHIM, HM, XP, YP,} + \hbox{TDK, PMB, RH, WL, TLR, RAP, DAP)}}} + Observed to apparent +\subp{CALL sla\_OAPQK (TYPE, OB1, OB2, AOPRMS, RA, DA)} + Observed to apparent using precomputed parameters +\end{callset} + +\callhead{Azimuth and Elevation} +\begin{callset} +\subp{CALL sla\_ALTAZ (\vtop + {\hbox{HA, DEC, PHI,} + \hbox{AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)}}} + Positions, velocities {\it etc.}\ for an altazimuth mount +\subq{CALL sla\_E2H (HA, DEC, PHI, AZ, EL)} + {CALL sla\_DE2H (HA, DEC, PHI, AZ, EL)} + \hadec\ to \azel +\subq{CALL sla\_H2E (AZ, EL, PHI, HA, DEC)} + {CALL sla\_DH2E (AZ, EL, PHI, HA, DEC)} + \azel\ to \hadec +\subp{CALL sla\_PDA2H (P, D, A, H1, J1, H2, J2)} + Hour Angle corresponding to a given azimuth +\subp{CALL sla\_PDQ2H (P, D, Q, H1, J1, H2, J2)} + Hour Angle corresponding to a given parallactic angle +\subp{D~=~sla\_PA (HA, DEC, PHI)} + \hadec\ to parallactic angle +\subp{D~=~sla\_ZD (HA, DEC, PHI)} + \hadec\ to zenith distance +\end{callset} + +\callhead{Refraction and Air Mass} +\begin{callset} +\subp{CALL sla\_REFRO (ZOBS, HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REF)} + Change in zenith distance due to refraction +\subp{CALL sla\_REFCO (HM, TDK, PMB, RH, WL, PHI, TLR, EPS, REFA, REFB)} + Constants for simple refraction model (accurate) +\subp{CALL sla\_REFCOQ (TDK, PMB, RH, WL, REFA, REFB)} + Constants for simple refraction model (fast) +\subp{CALL sla\_ATMDSP ( TDK, PMB, RH, WL1, REFA1, REFB1, WL2, REFA2, REFB2 )} + Adjust refraction constants for colour +\subp{CALL sla\_REFZ (ZU, REFA, REFB, ZR)} + Unrefracted to refracted ZD, simple model +\subp{CALL sla\_REFV (VU, REFA, REFB, VR)} + Unrefracted to refracted \azel\ vector, simple model +\subp{D~=~sla\_AIRMAS (ZD)} + Air mass +\end{callset} + +\callhead{Ecliptic Coordinates} +\begin{callset} +\subp{CALL sla\_ECMAT (DATE, RMAT)} + Equatorial to ecliptic rotation matrix +\subp{CALL sla\_EQECL (DR, DD, DATE, DL, DB)} + J2000.0 `FK5' to ecliptic coordinates +\subp{CALL sla\_ECLEQ (DL, DB, DATE, DR, DD)} + Ecliptic coordinates to J2000.0 `FK5' +\end{callset} + +\callhead{Galactic Coordinates} +\begin{callset} +\subp{CALL sla\_EG50 (DR, DD, DL, DB)} + B1950.0 `FK4' to galactic +\subp{CALL sla\_GE50 (DL, DB, DR, DD)} + Galactic to B1950.0 `FK4' +\subp{CALL sla\_EQGAL (DR, DD, DL, DB)} + J2000.0 `FK5' to galactic +\subp{CALL sla\_GALEQ (DL, DB, DR, DD)} + Galactic to J2000.0 `FK5' +\end{callset} + +\callhead{Supergalactic Coordinates} +\begin{callset} +\subp{CALL sla\_GALSUP (DL, DB, DSL, DSB)} + Galactic to supergalactic +\subp{CALL sla\_SUPGAL (DSL, DSB, DL, DB)} + Supergalactic to galactic +\end{callset} + +\callhead{Ephemerides} +\begin{callset} +\subp{CALL sla\_DMOON (DATE, PV)} + Approximate geocentric position and velocity of the Moon +\subp{CALL sla\_EARTH (IY, ID, FD, PV)} + Approximate heliocentric position and velocity of the Earth +\subp{CALL sla\_EPV (DATE, DPH, DVH, DPB, DVB )} + Heliocentric and barycentric position and velocity of the Earth +\subp{CALL sla\_EVP (DATE, DEQX, DVB, DPB, DVH, DPH)} + Barycentric and heliocentric velocity and position of the Earth +\subp{CALL sla\_MOON (IY, ID, FD, PV)} + Approximate geocentric position and velocity of the Moon +\subp{CALL sla\_PLANET (DATE, NP, PV, JSTAT)} + Approximate heliocentric position and velocity of a planet +\subp{CALL sla\_RDPLAN (DATE, NP, ELONG, PHI, RA, DEC, DIAM)} + Approximate topocentric apparent place of a planet +\subp{CALL sla\_PLANEL (\vtop + {\hbox{DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, PV, JSTAT)}}} + Heliocentric position and velocity of a planet, asteroid or + comet, starting from orbital elements +\subp{CALL sla\_PLANTE (\vtop + {\hbox{DATE, ELONG, PHI, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM, RA, DEC, R, JSTAT)}}} + Topocentric apparent place of a Solar-System object whose + heliocentric orbital elements are known +\subp{CALL sla\_PLANTU (DATE, ELONG, PHI, U, RA, DEC, R, JSTAT)} + Topocentric apparent place of a Solar-System object whose + heliocentric universal orbital elements are known +\subp{CALL sla\_PV2EL (\vtop + {\hbox{PV, DATE, PMASS, JFORMR, JFORM, EPOCH, ORBINC,} + \hbox{ANODE, PERIH, AORQ, E, AORL, DM, JSTAT)}}} + Orbital elements of a planet from instantaneous position and velocity +\subp{CALL sla\_PERTEL (\vtop + {\hbox{JFORM, DATE0, DATE1,} + \hbox{EPOCH0, ORBI0, ANODE0, PERIH0, AORQ0, E0, AM0,} + \hbox{EPOCH1, ORBI1, ANODE1, PERIH1, AORQ1, E1, AM1,} + \hbox{JSTAT)}}} + Update elements by applying perturbations +\subp{CALL sla\_EL2UE (\vtop + {\hbox{DATE, JFORM, EPOCH, ORBINC, ANODE,} + \hbox{PERIH, AORQ, E, AORL, DM,} + \hbox{U, JSTAT)}}} + Transform conventional elements to universal elements +\subp{CALL sla\_UE2EL (\vtop + {\hbox{U, JFORMR,} + \hbox{JFORM, EPOCH, ORBINC, ANODE, PERIH,} + \hbox{AORQ, E, AORL, DM, JSTAT)}}} + Transform universal elements to conventional elements +\subp{CALL sla\_PV2UE (PV, DATE, PMASS, U, JSTAT)} + Package a position and velocity for use as universal elements +\subp{CALL sla\_UE2PV (DATE, U, PV, JSTAT)} + Extract the position and velocity from universal elements +\subp{CALL sla\_PERTUE (DATE, U, JSTAT)} + Update universal elements by applying perturbations +\subp{R~=~sla\_RVEROT (PHI, RA, DA, ST)} + Velocity component due to rotation of the Earth +\subp{CALL sla\_ECOR (RM, DM, IY, ID, FD, RV, TL)} + Components of velocity and light time due to Earth orbital motion +\subp{R~=~sla\_RVLSRD (R2000, D2000)} + Velocity component due to solar motion wrt dynamical LSR +\subp{R~=~sla\_RVLSRK (R2000, D2000)} + Velocity component due to solar motion wrt kinematical LSR +\subp{R~=~sla\_RVGALC (R2000, D2000)} + Velocity component due to rotation of the Galaxy +\subp{R~=~sla\_RVLG (R2000, D2000)} + Velocity component due to rotation and translation of the + Galaxy, relative to the mean motion of the local group +\end{callset} + +\callhead{Astrometry} +\begin{callset} +\subq{CALL sla\_S2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} + {CALL sla\_DS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)} + Transform spherical coordinates into tangent plane +\subq{CALL sla\_V2TP (V, V0, XI, ETA, J)} + {CALL sla\_DV2TP (V, V0, XI, ETA, J)} + Transform \xyz\ into tangent plane coordinates +\subq{CALL sla\_DTP2S (XI, ETA, RAZ, DECZ, RA, DEC)} + {CALL sla\_TP2S (XI, ETA, RAZ, DECZ, RA, DEC)} + Transform tangent plane coordinates into spherical coordinates +\subq{CALL sla\_DTP2V (XI, ETA, V0, V)} + {CALL sla\_TP2V (XI, ETA, V0, V)} + Transform tangent plane coordinates into \xyz +\subq{CALL sla\_DTPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} + {CALL sla\_TPS2C (XI, ETA, RA, DEC, RAZ1, DECZ1, RAZ2, DECZ2, N)} + Get plate centre from star \radec\ and tangent plane coordinates +\subq{CALL sla\_DTPV2C (XI, ETA, V, V01, V02, N)} + {CALL sla\_TPV2C (XI, ETA, V, V01, V02, N)} + Get plate centre from star \xyz\ and tangent plane coordinates +\subp{CALL sla\_PCD (DISCO, X, Y)} + Apply pincushion/barrel distortion +\subp{CALL sla\_UNPCD (DISCO, X, Y)} + Remove pincushion/barrel distortion +\subp{CALL sla\_FITXY (ITYPE, NP, XYE, XYM, COEFFS, J)} + Fit a linear model to relate two sets of \xy\ coordinates +\subp{CALL sla\_PXY (NP, XYE, XYM, COEFFS, XYP, XRMS, YRMS, RRMS)} + Compute predicted coordinates and residuals +\subp{CALL sla\_INVF (FWDS, BKWDS, J)} + Invert a linear model +\subp{CALL sla\_XY2XY (X1, Y1, COEFFS, X2, Y2)} + Transform one \xy +\subp{CALL sla\_DCMPF (COEFFS, XZ, YZ, XS, YS, PERP, ORIENT)} + Decompose a linear fit into scales {\it etc.} +\end{callset} + +\callhead{Numerical Methods} +\begin{callset} +\subp{CALL sla\_COMBN (NSEL, NCAND, LIST, J)} + Next combination (subset from a specified number of items) +\subp{CALL sla\_PERMUT (N, ISTATE, IORDER, J)} + Next permutation of a specified number of items +\subq{CALL sla\_SMAT (N, A, Y, D, JF, IW)} + {CALL sla\_DMAT (N, A, Y, D, JF, IW)} + Matrix inversion and solution of simultaneous equations +\subp{CALL sla\_SVD (M, N, MP, NP, A, W, V, WORK, JSTAT)} + Singular value decomposition of a matrix +\subp{CALL sla\_SVDSOL (M, N, MP, NP, B, U, W, V, WORK, X)} + Solution from given vector plus SVD +\subp{CALL sla\_SVDCOV (N, NP, NC, W, V, WORK, CVM)} + Covariance matrix from SVD +\subp{R~=~sla\_RANDOM (SEED)} + Generate pseudo-random real number in the range {$0 \leq x < 1$} +\subp{R~=~sla\_GRESID (S)} + Generate pseudo-random normal deviate ($\equiv$ `Gaussian residual') +\end{callset} + +\callhead{Real-time} +\begin{callset} +\subp{CALL sla\_WAIT (DELAY)} + Interval wait +\end{callset} + +\end{document} diff --git a/math/slalib/supgal.f b/math/slalib/supgal.f new file mode 100644 index 00000000..4df6b10d --- /dev/null +++ b/math/slalib/supgal.f @@ -0,0 +1,97 @@ + SUBROUTINE slSUGA (DSL, DSB, DL, DB) +*+ +* - - - - - - - +* S U G A +* - - - - - - - +* +* Transformation from de Vaucouleurs supergalactic coordinates +* to IAU 1958 galactic coordinates (double precision) +* +* Given: +* DSL,DSB dp supergalactic longitude and latitude +* +* Returned: +* DL,DB dp galactic longitude and latitude L2,B2 +* +* (all arguments are radians) +* +* Called: +* slDS2C, slDIMV, slDC2S, slDA2P, slDA1P +* +* References: +* +* de Vaucouleurs, de Vaucouleurs, & Corwin, Second Reference +* Catalogue of Bright Galaxies, U. Texas, page 8. +* +* Systems & Applied Sciences Corp., Documentation for the +* machine-readable version of the above catalogue, +* Contract NAS 5-26490. +* +* (These two references give different values for the galactic +* longitude of the supergalactic origin. Both are wrong; the +* correct value is L2=137.37.) +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DSL,DSB,DL,DB + + DOUBLE PRECISION slDA2P,slDA1P + + DOUBLE PRECISION V1(3),V2(3) + +* +* System of supergalactic coordinates: +* +* SGL SGB L2 B2 (deg) +* - +90 47.37 +6.32 +* 0 0 - 0 +* +* Galactic to supergalactic rotation matrix: +* + DOUBLE PRECISION RMAT(3,3) + DATA RMAT(1,1),RMAT(1,2),RMAT(1,3), + : RMAT(2,1),RMAT(2,2),RMAT(2,3), + : RMAT(3,1),RMAT(3,2),RMAT(3,3)/ + : -0.735742574804D0,+0.677261296414D0,+0.000000000000D0, + : -0.074553778365D0,-0.080991471307D0,+0.993922590400D0, + : +0.673145302109D0,+0.731271165817D0,+0.110081262225D0/ + + + +* Spherical to Cartesian + CALL slDS2C(DSL,DSB,V1) + +* Supergalactic to galactic + CALL slDIMV(RMAT,V1,V2) + +* Cartesian to spherical + CALL slDC2S(V2,DL,DB) + +* Express in conventional ranges + DL=slDA2P(DL) + DB=slDA1P(DB) + + END diff --git a/math/slalib/svd.f b/math/slalib/svd.f new file mode 100644 index 00000000..59f53cfd --- /dev/null +++ b/math/slalib/svd.f @@ -0,0 +1,401 @@ + SUBROUTINE slSVD (M, N, MP, NP, A, W, V, WORK, JSTAT) +*+ +* - - - - +* S V D +* - - - - +* +* Singular value decomposition (double precision) +* +* This routine expresses a given matrix A as the product of +* three matrices U, W, V: +* +* A = U x W x VT +* +* Where: +* +* A is any M (rows) x N (columns) matrix, where M.GE.N +* U is an M x N column-orthogonal matrix +* W is an N x N diagonal matrix with W(I,I).GE.0 +* VT is the transpose of an N x N orthogonal matrix +* +* Note that M and N, above, are the LOGICAL dimensions of the +* matrices and vectors concerned, which can be located in +* arrays of larger PHYSICAL dimensions, given by MP and NP. +* +* Given: +* M,N i numbers of rows and columns in matrix A +* MP,NP i physical dimensions of array containing matrix A +* A d(MP,NP) array containing MxN matrix A +* +* Returned: +* A d(MP,NP) array containing MxN column-orthogonal matrix U +* W d(N) NxN diagonal matrix W (diagonal elements only) +* V d(NP,NP) array containing NxN orthogonal matrix V +* WORK d(N) workspace +* JSTAT i 0 = OK, -1 = A wrong shape, >0 = index of W +* for which convergence failed. See note 2, below. +* +* Notes: +* +* 1) V contains matrix V, not the transpose of matrix V. +* +* 2) If the status JSTAT is greater than zero, this need not +* necessarily be treated as a failure. It means that, due to +* chance properties of the matrix A, the QR transformation +* phase of the routine did not fully converge in a predefined +* number of iterations, something that very seldom occurs. +* When this condition does arise, it is possible that the +* elements of the diagonal matrix W have not been correctly +* found. However, in practice the results are likely to +* be trustworthy. Applications should report the condition +* as a warning, but then proceed normally. +* +* References: +* The algorithm is an adaptation of the routine SVD in the EISPACK +* library (Garbow et al 1977, EISPACK Guide Extension, Springer +* Verlag), which is a FORTRAN 66 implementation of the Algol +* routine SVD of Wilkinson & Reinsch 1971 (Handbook for Automatic +* Computation, vol 2, ed Bauer et al, Springer Verlag). These +* references give full details of the algorithm used here. A good +* account of the use of SVD in least squares problems is given in +* Numerical Recipes (Press et al 1986, Cambridge University Press), +* which includes another variant of the EISPACK code. +* +* Last revision: 8 September 2005 +* +* Copyright P.T.Wallace. All rights reserved. +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER M,N,MP,NP + DOUBLE PRECISION A(MP,NP),W(N),V(NP,NP),WORK(N) + INTEGER JSTAT + +* Maximum number of iterations in QR phase + INTEGER ITMAX + PARAMETER (ITMAX=30) + + INTEGER L,L1,I,K,J,K1,ITS,I1 + LOGICAL CANCEL + DOUBLE PRECISION G,SCALE,AN,S,X,F,H,C,Y,Z + + + +* Variable initializations to avoid compiler warnings. + L = 0 + L1 = 0 + +* Check that the matrix is the right shape + IF (M.LT.N) THEN + +* No: error status + JSTAT = -1 + + ELSE + +* Yes: preset the status to OK + JSTAT = 0 + +* +* Householder reduction to bidiagonal form +* ---------------------------------------- + + G = 0D0 + SCALE = 0D0 + AN = 0D0 + DO I=1,N + L = I+1 + WORK(I) = SCALE*G + G = 0D0 + S = 0D0 + SCALE = 0D0 + IF (I.LE.M) THEN + DO K=I,M + SCALE = SCALE+ABS(A(K,I)) + END DO + IF (SCALE.NE.0D0) THEN + DO K=I,M + X = A(K,I)/SCALE + A(K,I) = X + S = S+X*X + END DO + F = A(I,I) + G = -SIGN(SQRT(S),F) + H = F*G-S + A(I,I) = F-G + IF (I.NE.N) THEN + DO J=L,N + S = 0D0 + DO K=I,M + S = S+A(K,I)*A(K,J) + END DO + F = S/H + DO K=I,M + A(K,J) = A(K,J)+F*A(K,I) + END DO + END DO + END IF + DO K=I,M + A(K,I) = SCALE*A(K,I) + END DO + END IF + END IF + W(I) = SCALE*G + G = 0D0 + S = 0D0 + SCALE = 0D0 + IF (I.LE.M .AND. I.NE.N) THEN + DO K=L,N + SCALE = SCALE+ABS(A(I,K)) + END DO + IF (SCALE.NE.0D0) THEN + DO K=L,N + X = A(I,K)/SCALE + A(I,K) = X + S = S+X*X + END DO + F = A(I,L) + G = -SIGN(SQRT(S),F) + H = F*G-S + A(I,L) = F-G + DO K=L,N + WORK(K) = A(I,K)/H + END DO + IF (I.NE.M) THEN + DO J=L,M + S = 0D0 + DO K=L,N + S = S+A(J,K)*A(I,K) + END DO + DO K=L,N + A(J,K) = A(J,K)+S*WORK(K) + END DO + END DO + END IF + DO K=L,N + A(I,K) = SCALE*A(I,K) + END DO + END IF + END IF + +* Overestimate of largest column norm for convergence test + AN = MAX(AN,ABS(W(I))+ABS(WORK(I))) + + END DO + +* +* Accumulation of right-hand transformations +* ------------------------------------------ + + DO I=N,1,-1 + IF (I.NE.N) THEN + IF (G.NE.0D0) THEN + DO J=L,N + V(J,I) = (A(I,J)/A(I,L))/G + END DO + DO J=L,N + S = 0D0 + DO K=L,N + S = S+A(I,K)*V(K,J) + END DO + DO K=L,N + V(K,J) = V(K,J)+S*V(K,I) + END DO + END DO + END IF + DO J=L,N + V(I,J) = 0D0 + V(J,I) = 0D0 + END DO + END IF + V(I,I) = 1D0 + G = WORK(I) + L = I + END DO + +* +* Accumulation of left-hand transformations +* ----------------------------------------- + + DO I=N,1,-1 + L = I+1 + G = W(I) + IF (I.NE.N) THEN + DO J=L,N + A(I,J) = 0D0 + END DO + END IF + IF (G.NE.0D0) THEN + IF (I.NE.N) THEN + DO J=L,N + S = 0D0 + DO K=L,M + S = S+A(K,I)*A(K,J) + END DO + F = (S/A(I,I))/G + DO K=I,M + A(K,J) = A(K,J)+F*A(K,I) + END DO + END DO + END IF + DO J=I,M + A(J,I) = A(J,I)/G + END DO + ELSE + DO J=I,M + A(J,I) = 0D0 + END DO + END IF + A(I,I) = A(I,I)+1D0 + END DO + +* +* Diagonalisation of the bidiagonal form +* -------------------------------------- + + DO K=N,1,-1 + K1 = K-1 + +* Iterate until converged + ITS = 0 + DO WHILE (ITS.LT.ITMAX) + ITS = ITS+1 + +* Test for splitting into submatrices + CANCEL = .TRUE. + DO L=K,1,-1 + L1 = L-1 + IF (AN+ABS(WORK(L)).EQ.AN) THEN + CANCEL = .FALSE. + GO TO 10 + END IF +* (Following never attempted for L=1 because WORK(1) is zero) + IF (AN+ABS(W(L1)).EQ.AN) GO TO 10 + END DO + 10 CONTINUE + +* Cancellation of WORK(L) if L>1 + IF (CANCEL) THEN + C = 0D0 + S = 1D0 + DO I=L,K + F = S*WORK(I) + IF (AN+ABS(F).EQ.AN) GO TO 20 + G = W(I) + H = SQRT(F*F+G*G) + W(I) = H + C = G/H + S = -F/H + DO J=1,M + Y = A(J,L1) + Z = A(J,I) + A(J,L1) = Y*C+Z*S + A(J,I) = -Y*S+Z*C + END DO + END DO + 20 CONTINUE + END IF + +* Converged? + Z = W(K) + IF (L.EQ.K) THEN + +* Yes: stop iterating + ITS = ITMAX + +* Ensure singular values non-negative + IF (Z.LT.0D0) THEN + W(K) = -Z + DO J=1,N + V(J,K) = -V(J,K) + END DO + END IF + ELSE + +* Not converged yet: set status if iteration limit reached + IF (ITS.EQ.ITMAX) JSTAT = K + +* Shift from bottom 2x2 minor + X = W(L) + Y = W(K1) + G = WORK(K1) + H = WORK(K) + F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2D0*H*Y) + IF (ABS(F).LE.1D15) THEN + G = SQRT(F*F+1D0) + ELSE + G = ABS(F) + END IF + F = ((X-Z)*(X+Z)+H*(Y/(F+SIGN(G,F))-H))/X + +* Next QR transformation + C = 1D0 + S = 1D0 + DO I1=L,K1 + I = I1+1 + G = WORK(I) + Y = W(I) + H = S*G + G = C*G + Z = SQRT(F*F+H*H) + WORK(I1) = Z + IF (Z.NE.0D0) THEN + C = F/Z + S = H/Z + ELSE + C = 1D0 + S = 0D0 + END IF + F = X*C+G*S + G = -X*S+G*C + H = Y*S + Y = Y*C + DO J=1,N + X = V(J,I1) + Z = V(J,I) + V(J,I1) = X*C+Z*S + V(J,I) = -X*S+Z*C + END DO + Z = SQRT(F*F+H*H) + W(I1) = Z + IF (Z.NE.0D0) THEN + C = F/Z + S = H/Z + END IF + F = C*G+S*Y + X = -S*G+C*Y + DO J=1,M + Y = A(J,I1) + Z = A(J,I) + A(J,I1) = Y*C+Z*S + A(J,I) = -Y*S+Z*C + END DO + END DO + WORK(L) = 0D0 + WORK(K) = F + W(K) = X + END IF + END DO + END DO + END IF + + END diff --git a/math/slalib/svdcov.f b/math/slalib/svdcov.f new file mode 100644 index 00000000..02a6be0e --- /dev/null +++ b/math/slalib/svdcov.f @@ -0,0 +1,78 @@ + SUBROUTINE slSVDC (N, NP, NC, W, V, WORK, CVM) +*+ +* - - - - - - - +* S V D C +* - - - - - - - +* +* From the W and V matrices from the SVD factorisation of a matrix +* (as obtained from the slSVD routine), obtain the covariance matrix. +* +* (double precision) +* +* Given: +* N i number of rows and columns in matrices W and V +* NP i first dimension of array containing matrix V +* NC i first dimension of array to receive CVM +* W d(N) NxN diagonal matrix W (diagonal elements only) +* V d(NP,NP) array containing NxN orthogonal matrix V +* +* Returned: +* WORK d(N) workspace +* CVM d(NC,NC) array to receive covariance matrix +* +* Reference: +* Numerical Recipes, section 14.3. +* +* P.T.Wallace Starlink December 1988 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER N,NP,NC + DOUBLE PRECISION W(N),V(NP,NP),WORK(N),CVM(NC,NC) + + INTEGER I,J,K + DOUBLE PRECISION S + + + + DO I=1,N + S=W(I) + IF (S.NE.0D0) THEN + WORK(I)=1D0/(S*S) + ELSE + WORK(I)=0D0 + END IF + END DO + DO I=1,N + DO J=1,I + S=0D0 + DO K=1,N + S=S+V(I,K)*V(J,K)*WORK(K) + END DO + CVM(I,J)=S + CVM(J,I)=S + END DO + END DO + + END diff --git a/math/slalib/svdsol.f b/math/slalib/svdsol.f new file mode 100644 index 00000000..53209f2d --- /dev/null +++ b/math/slalib/svdsol.f @@ -0,0 +1,127 @@ + SUBROUTINE slSVDS (M, N, MP, NP, B, U, W, V, WORK, X) +*+ +* - - - - - - - +* S V D S +* - - - - - - - +* +* From a given vector and the SVD of a matrix (as obtained from +* the SVD routine), obtain the solution vector (double precision) +* +* This routine solves the equation: +* +* A . x = b +* +* where: +* +* A is a given M (rows) x N (columns) matrix, where M.GE.N +* x is the N-vector we wish to find +* b is a given M-vector +* +* by means of the Singular Value Decomposition method (SVD). In +* this method, the matrix A is first factorised (for example by +* the routine slSVD) into the following components: +* +* A = U x W x VT +* +* where: +* +* A is the M (rows) x N (columns) matrix +* U is an M x N column-orthogonal matrix +* W is an N x N diagonal matrix with W(I,I).GE.0 +* VT is the transpose of an NxN orthogonal matrix +* +* Note that M and N, above, are the LOGICAL dimensions of the +* matrices and vectors concerned, which can be located in +* arrays of larger PHYSICAL dimensions MP and NP. +* +* The solution is found from the expression: +* +* x = V . [diag(1/Wj)] . (transpose(U) . b) +* +* Notes: +* +* 1) If matrix A is square, and if the diagonal matrix W is not +* adjusted, the method is equivalent to conventional solution +* of simultaneous equations. +* +* 2) If M>N, the result is a least-squares fit. +* +* 3) If the solution is poorly determined, this shows up in the +* SVD factorisation as very small or zero Wj values. Where +* a Wj value is small but non-zero it can be set to zero to +* avoid ill effects. The present routine detects such zero +* Wj values and produces a sensible solution, with highly +* correlated terms kept under control rather than being allowed +* to elope to infinity, and with meaningful values for the +* other terms. +* +* Given: +* M,N i numbers of rows and columns in matrix A +* MP,NP i physical dimensions of array containing matrix A +* B d(M) known vector b +* U d(MP,NP) array containing MxN matrix U +* W d(N) NxN diagonal matrix W (diagonal elements only) +* V d(NP,NP) array containing NxN orthogonal matrix V +* +* Returned: +* WORK d(N) workspace +* X d(N) unknown vector x +* +* Reference: +* Numerical Recipes, section 2.9. +* +* P.T.Wallace Starlink 29 October 1993 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + INTEGER M,N,MP,NP + DOUBLE PRECISION B(M),U(MP,NP),W(N),V(NP,NP),WORK(N),X(N) + + INTEGER J,I,JJ + DOUBLE PRECISION S + + + +* Calculate [diag(1/Wj)] . transpose(U) . b (or zero for zero Wj) + DO J=1,N + S=0D0 + IF (W(J).NE.0D0) THEN + DO I=1,M + S=S+U(I,J)*B(I) + END DO + S=S/W(J) + END IF + WORK(J)=S + END DO + +* Multiply by matrix V to get result + DO J=1,N + S=0D0 + DO JJ=1,N + S=S+V(J,JJ)*WORK(JJ) + END DO + X(J)=S + END DO + + END diff --git a/math/slalib/tp2s.f b/math/slalib/tp2s.f new file mode 100644 index 00000000..f8d31895 --- /dev/null +++ b/math/slalib/tp2s.f @@ -0,0 +1,60 @@ + SUBROUTINE slTP2S (XI, ETA, RAZ, DECZ, RA, DEC) +*+ +* - - - - - +* T P 2 S +* - - - - - +* +* Transform tangent plane coordinates into spherical +* (single precision) +* +* Given: +* XI,ETA real tangent plane rectangular coordinates +* RAZ,DECZ real spherical coordinates of tangent point +* +* Returned: +* RA,DEC real spherical coordinates (0-2pi,+/-pi/2) +* +* Called: slRA2P +* +* P.T.Wallace Starlink 24 July 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL XI,ETA,RAZ,DECZ,RA,DEC + + REAL slRA2P + + REAL SDECZ,CDECZ,DENOM + + + + SDECZ=SIN(DECZ) + CDECZ=COS(DECZ) + + DENOM=CDECZ-ETA*SDECZ + + RA=slRA2P(ATAN2(XI,DENOM)+RAZ) + DEC=ATAN2(SDECZ+ETA*CDECZ,SQRT(XI*XI+DENOM*DENOM)) + + END diff --git a/math/slalib/tp2v.f b/math/slalib/tp2v.f new file mode 100644 index 00000000..ba2ff7dd --- /dev/null +++ b/math/slalib/tp2v.f @@ -0,0 +1,74 @@ + SUBROUTINE slTP2V (XI, ETA, V0, V) +*+ +* - - - - - +* T P 2 V +* - - - - - +* +* Given the tangent-plane coordinates of a star and the direction +* cosines of the tangent point, determine the direction cosines +* of the star. +* +* (single precision) +* +* Given: +* XI,ETA r tangent plane coordinates of star +* V0 r(3) direction cosines of tangent point +* +* Returned: +* V r(3) direction cosines of star +* +* Notes: +* +* 1 If vector V0 is not of unit length, the returned vector V will +* be wrong. +* +* 2 If vector V0 points at a pole, the returned vector V will be +* based on the arbitrary assumption that the RA of the tangent +* point is zero. +* +* 3 This routine is the Cartesian equivalent of the routine slTP2S. +* +* P.T.Wallace Starlink 11 February 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL XI,ETA,V0(3),V(3) + + REAL X,Y,Z,F,R + + + X=V0(1) + Y=V0(2) + Z=V0(3) + F=SQRT(1.0+XI*XI+ETA*ETA) + R=SQRT(X*X+Y*Y) + IF (R.EQ.0.0) THEN + R=1E-20 + X=R + END IF + V(1)=(X-(XI*Y+ETA*X*Z)/R)/F + V(2)=(Y+(XI*X-ETA*Y*Z)/R)/F + V(3)=(Z+ETA*R)/F + + END diff --git a/math/slalib/tps2c.f b/math/slalib/tps2c.f new file mode 100644 index 00000000..80873699 --- /dev/null +++ b/math/slalib/tps2c.f @@ -0,0 +1,109 @@ + SUBROUTINE slTPSC (XI, ETA, RA, DEC, RAZ1, DECZ1, + : RAZ2, DECZ2, N) +*+ +* - - - - - - +* T P S C +* - - - - - - +* +* From the tangent plane coordinates of a star of known RA,Dec, +* determine the RA,Dec of the tangent point. +* +* (single precision) +* +* Given: +* XI,ETA r tangent plane rectangular coordinates +* RA,DEC r spherical coordinates +* +* Returned: +* RAZ1,DECZ1 r spherical coordinates of tangent point, solution 1 +* RAZ2,DECZ2 r spherical coordinates of tangent point, solution 2 +* N i number of solutions: +* 0 = no solutions returned (note 2) +* 1 = only the first solution is useful (note 3) +* 2 = both solutions are useful (note 3) +* +* Notes: +* +* 1 The RAZ1 and RAZ2 values are returned in the range 0-2pi. +* +* 2 Cases where there is no solution can only arise near the poles. +* For example, it is clearly impossible for a star at the pole +* itself to have a non-zero XI value, and hence it is +* meaningless to ask where the tangent point would have to be +* to bring about this combination of XI and DEC. +* +* 3 Also near the poles, cases can arise where there are two useful +* solutions. The argument N indicates whether the second of the +* two solutions returned is useful. N=1 indicates only one useful +* solution, the usual case; under these circumstances, the second +* solution corresponds to the "over-the-pole" case, and this is +* reflected in the values of RAZ2 and DECZ2 which are returned. +* +* 4 The DECZ1 and DECZ2 values are returned in the range +/-pi, but +* in the usual, non-pole-crossing, case, the range is +/-pi/2. +* +* 5 This routine is the spherical equivalent of the routine slDPVC. +* +* Called: slRA2P +* +* P.T.Wallace Starlink 5 June 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL XI,ETA,RA,DEC,RAZ1,DECZ1,RAZ2,DECZ2 + INTEGER N + + REAL X2,Y2,SD,CD,SDF,R2,R,S,C + + REAL slRA2P + + + X2=XI*XI + Y2=ETA*ETA + SD=SIN(DEC) + CD=COS(DEC) + SDF=SD*SQRT(1.0+X2+Y2) + R2=CD*CD*(1.0+Y2)-SD*SD*X2 + IF (R2.GE.0.0) THEN + R=SQRT(R2) + S=SDF-ETA*R + C=SDF*ETA+R + IF (XI.EQ.0.0.AND.R.EQ.0.0) R=1.0 + RAZ1=slRA2P(RA-ATAN2(XI,R)) + DECZ1=ATAN2(S,C) + R=-R + S=SDF-ETA*R + C=SDF*ETA+R + RAZ2=slRA2P(RA-ATAN2(XI,R)) + DECZ2=ATAN2(S,C) + IF (ABS(SDF).LT.1.0) THEN + N=1 + ELSE + N=2 + END IF + ELSE + N=0 + END IF + + END diff --git a/math/slalib/tpv2c.f b/math/slalib/tpv2c.f new file mode 100644 index 00000000..2c01fe73 --- /dev/null +++ b/math/slalib/tpv2c.f @@ -0,0 +1,101 @@ + SUBROUTINE slTPVC (XI, ETA, V, V01, V02, N) +*+ +* - - - - - - +* T P V C +* - - - - - - +* +* Given the tangent-plane coordinates of a star and its direction +* cosines, determine the direction cosines of the tangent-point. +* +* (single precision) +* +* Given: +* XI,ETA r tangent plane coordinates of star +* V r(3) direction cosines of star +* +* Returned: +* V01 r(3) direction cosines of tangent point, solution 1 +* V02 r(3) direction cosines of tangent point, solution 2 +* N i number of solutions: +* 0 = no solutions returned (note 2) +* 1 = only the first solution is useful (note 3) +* 2 = both solutions are useful (note 3) +* +* Notes: +* +* 1 The vector V must be of unit length or the result will be wrong. +* +* 2 Cases where there is no solution can only arise near the poles. +* For example, it is clearly impossible for a star at the pole +* itself to have a non-zero XI value, and hence it is meaningless +* to ask where the tangent point would have to be. +* +* 3 Also near the poles, cases can arise where there are two useful +* solutions. The argument N indicates whether the second of the +* two solutions returned is useful. N=1 indicates only one useful +* solution, the usual case; under these circumstances, the second +* solution can be regarded as valid if the vector V02 is interpreted +* as the "over-the-pole" case. +* +* 4 This routine is the Cartesian equivalent of the routine slTPSC. +* +* P.T.Wallace Starlink 5 June 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL XI,ETA,V(3),V01(3),V02(3) + INTEGER N + + REAL X,Y,Z,RXY2,XI2,ETA2P1,SDF,R2,R,C + + + X=V(1) + Y=V(2) + Z=V(3) + RXY2=X*X+Y*Y + XI2=XI*XI + ETA2P1=ETA*ETA+1.0 + SDF=Z*SQRT(XI2+ETA2P1) + R2=RXY2*ETA2P1-Z*Z*XI2 + IF (R2.GT.0.0) THEN + R=SQRT(R2) + C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2))) + V01(1)=C*(X*R+Y*XI) + V01(2)=C*(Y*R-X*XI) + V01(3)=(SDF-ETA*R)/ETA2P1 + R=-R + C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2))) + V02(1)=C*(X*R+Y*XI) + V02(2)=C*(Y*R-X*XI) + V02(3)=(SDF-ETA*R)/ETA2P1 + IF (ABS(SDF).LT.1.0) THEN + N=1 + ELSE + N=2 + END IF + ELSE + N=0 + END IF + + END diff --git a/math/slalib/ue2el.f b/math/slalib/ue2el.f new file mode 100644 index 00000000..303c63f6 --- /dev/null +++ b/math/slalib/ue2el.f @@ -0,0 +1,212 @@ + SUBROUTINE slUEEL (U, JFORMR, + : JFORM, EPOCH, ORBINC, ANODE, PERIH, + : AORQ, E, AORL, DM, JSTAT) +*+ +* - - - - - - +* U E E L +* - - - - - - +* +* Transform universal elements into conventional heliocentric +* osculating elements. +* +* Given: +* U d(13) universal orbital elements (Note 1) +* +* (1) combined mass (M+m) +* (2) total energy of the orbit (alpha) +* (3) reference (osculating) epoch (t0) +* (4-6) position at reference epoch (r0) +* (7-9) velocity at reference epoch (v0) +* (10) heliocentric distance at reference epoch +* (11) r0.v0 +* (12) date (t) +* (13) universal eccentric anomaly (psi) of date, approx +* +* JFORMR i requested element set (1-3; Note 3) +* +* Returned: +* JFORM d element set actually returned (1-3; Note 4) +* EPOCH d epoch of elements (TT MJD) +* ORBINC d inclination (radians) +* ANODE d longitude of the ascending node (radians) +* PERIH d longitude or argument of perihelion (radians) +* AORQ d mean distance or perihelion distance (AU) +* E d eccentricity +* AORL d mean anomaly or longitude (radians, JFORM=1,2 only) +* DM d daily motion (radians, JFORM=1 only) +* JSTAT i status: 0 = OK +* -1 = illegal combined mass +* -2 = illegal JFORMR +* -3 = position/velocity out of range +* +* Notes +* +* 1 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference 2). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* 2 The universal elements are with respect to the mean equator and +* equinox of epoch J2000. The orbital elements produced are with +* respect to the J2000 ecliptic and mean equinox. +* +* 3 Three different element-format options are supported: +* +* Option JFORM=1, suitable for the major planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = longitude of perihelion, curly pi (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e +* AORL = mean longitude L (radians) +* DM = daily motion (radians) +* +* Option JFORM=2, suitable for minor planets: +* +* EPOCH = epoch of elements (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = mean distance, a (AU) +* E = eccentricity, e +* AORL = mean anomaly M (radians) +* +* Option JFORM=3, suitable for comets: +* +* EPOCH = epoch of perihelion (TT MJD) +* ORBINC = inclination i (radians) +* ANODE = longitude of the ascending node, big omega (radians) +* PERIH = argument of perihelion, little omega (radians) +* AORQ = perihelion distance, q (AU) +* E = eccentricity, e +* +* 4 It may not be possible to generate elements in the form +* requested through JFORMR. The caller is notified of the form +* of elements actually returned by means of the JFORM argument: +* +* JFORMR JFORM meaning +* +* 1 1 OK - elements are in the requested format +* 1 2 never happens +* 1 3 orbit not elliptical +* +* 2 1 never happens +* 2 2 OK - elements are in the requested format +* 2 3 orbit not elliptical +* +* 3 1 never happens +* 3 2 never happens +* 3 3 OK - elements are in the requested format +* +* 5 The arguments returned for each value of JFORM (cf Note 6: JFORM +* may not be the same as JFORMR) are as follows: +* +* JFORM 1 2 3 +* EPOCH t0 t0 T +* ORBINC i i i +* ANODE Omega Omega Omega +* PERIH curly pi omega omega +* AORQ a a q +* E e e e +* AORL L M - +* DM n - - +* +* where: +* +* t0 is the epoch of the elements (MJD, TT) +* T " epoch of perihelion (MJD, TT) +* i " inclination (radians) +* Omega " longitude of the ascending node (radians) +* curly pi " longitude of perihelion (radians) +* omega " argument of perihelion (radians) +* a " mean distance (AU) +* q " perihelion distance (AU) +* e " eccentricity +* L " longitude (radians, 0-2pi) +* M " mean anomaly (radians, 0-2pi) +* n " daily motion (radians) +* - means no value is set +* +* 6 At very small inclinations, the longitude of the ascending node +* ANODE becomes indeterminate and under some circumstances may be +* set arbitrarily to zero. Similarly, if the orbit is close to +* circular, the true anomaly becomes indeterminate and under some +* circumstances may be set arbitrarily to zero. In such cases, +* the other elements are automatically adjusted to compensate, +* and so the elements remain a valid description of the orbit. +* +* References: +* +* 1 Sterne, Theodore E., "An Introduction to Celestial Mechanics", +* Interscience Publishers Inc., 1960. Section 6.7, p199. +* +* 2 Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* Called: slPVEL +* +* P.T.Wallace Starlink 18 March 1999 +* +* Copyright (C) 1999 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION U(13) + INTEGER JFORMR,JFORM + DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM + INTEGER JSTAT + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Canonical days to seconds + DOUBLE PRECISION CD2S + PARAMETER (CD2S=GCON/86400D0) + + INTEGER I + DOUBLE PRECISION PMASS,DATE,PV(6) + + +* Unpack the universal elements. + PMASS = U(1)-1D0 + DATE = U(3) + DO I=1,3 + PV(I) = U(I+3) + PV(I+3) = U(I+6)*CD2S + END DO + +* Convert the position and velocity etc into conventional elements. + CALL slPVEL(PV,DATE,PMASS,JFORMR,JFORM,EPOCH,ORBINC,ANODE, + : PERIH,AORQ,E,AORL,DM,JSTAT) + + END diff --git a/math/slalib/ue2pv.f b/math/slalib/ue2pv.f new file mode 100644 index 00000000..8024bc65 --- /dev/null +++ b/math/slalib/ue2pv.f @@ -0,0 +1,253 @@ + SUBROUTINE slUEPV ( DATE, U, PV, JSTAT ) +*+ +* - - - - - - +* U E P V +* - - - - - - +* +* Heliocentric position and velocity of a planet, asteroid or comet, +* starting from orbital elements in the "universal variables" form. +* +* Given: +* DATE d date, Modified Julian Date (JD-2400000.5) +* +* Given and returned: +* U d(13) universal orbital elements (updated; Note 1) +* +* given (1) combined mass (M+m) +* " (2) total energy of the orbit (alpha) +* " (3) reference (osculating) epoch (t0) +* " (4-6) position at reference epoch (r0) +* " (7-9) velocity at reference epoch (v0) +* " (10) heliocentric distance at reference epoch +* " (11) r0.v0 +* returned (12) date (t) +* " (13) universal eccentric anomaly (psi) of date +* +* Returned: +* PV d(6) position (AU) and velocity (AU/s) +* JSTAT i status: 0 = OK +* -1 = radius vector zero +* -2 = failed to converge +* +* Notes +* +* 1 The "universal" elements are those which define the orbit for the +* purposes of the method of universal variables (see reference). +* They consist of the combined mass of the two bodies, an epoch, +* and the position and velocity vectors (arbitrary reference frame) +* at that epoch. The parameter set used here includes also various +* quantities that can, in fact, be derived from the other +* information. This approach is taken to avoiding unnecessary +* computation and loss of accuracy. The supplementary quantities +* are (i) alpha, which is proportional to the total energy of the +* orbit, (ii) the heliocentric distance at epoch, (iii) the +* outwards component of the velocity at the given epoch, (iv) an +* estimate of psi, the "universal eccentric anomaly" at a given +* date and (v) that date. +* +* 2 The companion routine is slELUE. This takes the conventional +* orbital elements and transforms them into the set of numbers +* needed by the present routine. A single prediction requires one +* one call to slELUE followed by one call to the present routine; +* for convenience, the two calls are packaged as the routine +* slPLNE. Multiple predictions may be made by again +* calling slELUE once, but then calling the present routine +* multiple times, which is faster than multiple calls to slPLNE. +* +* It is not obligatory to use slELUE to obtain the parameters. +* However, it should be noted that because slELUE performs its +* own validation, no checks on the contents of the array U are made +* by the present routine. +* +* 3 DATE is the instant for which the prediction is required. It is +* in the TT timescale (formerly Ephemeris Time, ET) and is a +* Modified Julian Date (JD-2400000.5). +* +* 4 The universal elements supplied in the array U are in canonical +* units (solar masses, AU and canonical days). The position and +* velocity are not sensitive to the choice of reference frame. The +* slELUE routine in fact produces coordinates with respect to the +* J2000 equator and equinox. +* +* 5 The algorithm was originally adapted from the EPHSLA program of +* D.H.P.Jones (private communication, 1996). The method is based +* on Stumpff's Universal Variables. +* +* Reference: Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983. +* +* P.T.Wallace Starlink 22 October 2005 +* +* Copyright (C) 2005 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DATE,U(13),PV(6) + INTEGER JSTAT + +* Gaussian gravitational constant (exact) + DOUBLE PRECISION GCON + PARAMETER (GCON=0.01720209895D0) + +* Canonical days to seconds + DOUBLE PRECISION CD2S + PARAMETER (CD2S=GCON/86400D0) + +* Test value for solution and maximum number of iterations + DOUBLE PRECISION TEST + INTEGER NITMAX + PARAMETER (TEST=1D-13,NITMAX=25) + + INTEGER I,NIT,N + + DOUBLE PRECISION CM,ALPHA,T0,P0(3),V0(3),R0,SIGMA0,T,PSI,DT,W, + : TOL,PSJ,PSJ2,BETA,S0,S1,S2,S3, + : FF,R,FLAST,PLAST,F,G,FD,GD + + + +* Unpack the parameters. + CM = U(1) + ALPHA = U(2) + T0 = U(3) + DO I=1,3 + P0(I) = U(I+3) + V0(I) = U(I+6) + END DO + R0 = U(10) + SIGMA0 = U(11) + T = U(12) + PSI = U(13) + +* Approximately update the universal eccentric anomaly. + PSI = PSI+(DATE-T)*GCON/R0 + +* Time from reference epoch to date (in Canonical Days: a canonical +* day is 58.1324409... days, defined as 1/GCON). + DT = (DATE-T0)*GCON + +* Refine the universal eccentric anomaly, psi. + NIT = 1 + W = 1D0 + TOL = 0D0 + DO WHILE (ABS(W).GE.TOL) + +* Form half angles until BETA small enough. + N = 0 + PSJ = PSI + PSJ2 = PSJ*PSJ + BETA = ALPHA*PSJ2 + DO WHILE (ABS(BETA).GT.0.7D0) + N = N+1 + BETA = BETA/4D0 + PSJ = PSJ/2D0 + PSJ2 = PSJ2/4D0 + END DO + +* Calculate Universal Variables S0,S1,S2,S3 by nested series. + S3 = PSJ*PSJ2*((((((BETA/210D0+1D0) + : *BETA/156D0+1D0) + : *BETA/110D0+1D0) + : *BETA/72D0+1D0) + : *BETA/42D0+1D0) + : *BETA/20D0+1D0)/6D0 + S2 = PSJ2*((((((BETA/182D0+1D0) + : *BETA/132D0+1D0) + : *BETA/90D0+1D0) + : *BETA/56D0+1D0) + : *BETA/30D0+1D0) + : *BETA/12D0+1D0)/2D0 + S1 = PSJ+ALPHA*S3 + S0 = 1D0+ALPHA*S2 + +* Undo the angle-halving. + TOL = TEST + DO WHILE (N.GT.0) + S3 = 2D0*(S0*S3+PSJ*S2) + S2 = 2D0*S1*S1 + S1 = 2D0*S0*S1 + S0 = 2D0*S0*S0-1D0 + PSJ = PSJ+PSJ + TOL = TOL+TOL + N = N-1 + END DO + +* Values of F and F' corresponding to the current value of psi. + FF = R0*S1+SIGMA0*S2+CM*S3-DT + R = R0*S0+SIGMA0*S1+CM*S2 + +* If first iteration, create dummy "last F". + IF ( NIT.EQ.1) FLAST = FF + +* Check for sign change. + IF ( FF*FLAST.LT.0D0 ) THEN + +* Sign change: get psi adjustment using secant method. + W = FF*(PLAST-PSI)/(FLAST-FF) + ELSE + +* No sign change: use Newton-Raphson method instead. + IF (R.EQ.0D0) GO TO 9010 + W = FF/R + END IF + +* Save the last psi and F values. + PLAST = PSI + FLAST = FF + +* Apply the Newton-Raphson or secant adjustment to psi. + PSI = PSI-W + +* Next iteration, unless too many already. + IF (NIT.GT.NITMAX) GO TO 9020 + NIT = NIT+1 + END DO + +* Project the position and velocity vectors (scaling velocity to AU/s). + W = CM*S2 + F = 1D0-W/R0 + G = DT-CM*S3 + FD = -CM*S1/(R0*R) + GD = 1D0-W/R + DO I=1,3 + PV(I) = P0(I)*F+V0(I)*G + PV(I+3) = CD2S*(P0(I)*FD+V0(I)*GD) + END DO + +* Update the parameters to allow speedy prediction of PSI next time. + U(12) = DATE + U(13) = PSI + +* OK exit. + JSTAT = 0 + GO TO 9999 + +* Null radius vector. + 9010 CONTINUE + JSTAT = -1 + GO TO 9999 + +* Failed to converge. + 9020 CONTINUE + JSTAT = -2 + + 9999 CONTINUE + END diff --git a/math/slalib/unpcd.f b/math/slalib/unpcd.f new file mode 100644 index 00000000..c4de5fbb --- /dev/null +++ b/math/slalib/unpcd.f @@ -0,0 +1,145 @@ + SUBROUTINE slUPCD ( DISCO, X, Y ) +*+ +* - - - - - - +* U P C D +* - - - - - - +* +* Remove pincushion/barrel distortion from a distorted [x,y] to give +* tangent-plane [x,y]. +* +* Given: +* DISCO d pincushion/barrel distortion coefficient +* X,Y d distorted coordinates +* +* Returned: +* X,Y d tangent-plane coordinates +* +* Notes: +* +* 1) The distortion is of the form RP = R*(1+C*R^2), where R is +* the radial distance from the tangent point, C is the DISCO +* argument, and RP is the radial distance in the presence of +* the distortion. +* +* 2) For pincushion distortion, C is +ve; for barrel distortion, +* C is -ve. +* +* 3) For X,Y in "radians" - units of one projection radius, +* which in the case of a photograph is the focal length of +* the camera - the following DISCO values apply: +* +* Geometry DISCO +* +* astrograph 0.0 +* Schmidt -0.3333 +* AAT PF doublet +147.069 +* AAT PF triplet +178.585 +* AAT f/8 +21.20 +* JKT f/8 +13.32 +* +* 4) The present routine is a rigorous inverse of the companion +* routine slPCD. The expression for RP in Note 1 is rewritten +* in the form x^3+a*x+b=0 and solved by standard techniques. +* +* 5) Cases where the cubic has multiple real roots can sometimes +* occur, corresponding to extreme instances of barrel distortion +* where up to three different undistorted [X,Y]s all produce the +* same distorted [X,Y]. However, only one solution is returned, +* the one that produces the smallest change in [X,Y]. +* +* P.T.Wallace Starlink 3 September 2000 +* +* Copyright (C) 2000 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION DISCO,X,Y + + DOUBLE PRECISION THIRD + PARAMETER (THIRD=1D0/3D0) + DOUBLE PRECISION D2PI + PARAMETER (D2PI=6.283185307179586476925286766559D0) + + DOUBLE PRECISION RP,Q,R,D,W,S,T,F,C,T3,F1,F2,F3,W1,W2,W3 + + + +* Distance of the point from the origin. + RP = SQRT(X*X+Y*Y) + +* If zero, or if no distortion, no action is necessary. + IF (RP.NE.0D0.AND.DISCO.NE.0D0) THEN + +* Begin algebraic solution. + Q = 1D0/(3D0*DISCO) + R = RP/(2D0*DISCO) + W = Q*Q*Q+R*R + +* Continue if one real root, or three of which only one is positive. + IF (W.GE.0D0) THEN + D = SQRT(W) + W = R+D + S = SIGN(ABS(W)**THIRD,W) + W = R-D + T = SIGN((ABS(W))**THIRD,W) + F = S+T + ELSE + +* Three different real roots: use geometrical method instead. + W = 2D0/SQRT(-3D0*DISCO) + C = 4D0*RP/(DISCO*W*W*W) + S = SQRT(1D0-MIN(C*C,1D0)) + T3 = ATAN2(S,C) + +* The three solutions. + F1 = W*COS((D2PI-T3)/3D0) + F2 = W*COS((T3)/3D0) + F3 = W*COS((D2PI+T3)/3D0) + +* Pick the one that moves [X,Y] least. + W1 = ABS(F1-RP) + W2 = ABS(F2-RP) + W3 = ABS(F3-RP) + IF (W1.LT.W2) THEN + IF (W1.LT.W3) THEN + F = F1 + ELSE + F = F3 + END IF + ELSE + IF (W2.LT.W3) THEN + F = F2 + ELSE + F = F3 + END IF + END IF + + END IF + +* Remove the distortion. + F = F/RP + X = F*X + Y = F*Y + + END IF + + END diff --git a/math/slalib/v2tp.f b/math/slalib/v2tp.f new file mode 100644 index 00000000..bb56af7a --- /dev/null +++ b/math/slalib/v2tp.f @@ -0,0 +1,96 @@ + SUBROUTINE slV2TP (V, V0, XI, ETA, J) +*+ +* - - - - - +* V 2 T P +* - - - - - +* +* Given the direction cosines of a star and of the tangent point, +* determine the star's tangent-plane coordinates. +* +* (single precision) +* +* Given: +* V r(3) direction cosines of star +* V0 r(3) direction cosines of tangent point +* +* Returned: +* XI,ETA r tangent plane coordinates of star +* J i status: 0 = OK +* 1 = error, star too far from axis +* 2 = error, antistar on tangent plane +* 3 = error, antistar too far from axis +* +* Notes: +* +* 1 If vector V0 is not of unit length, or if vector V is of zero +* length, the results will be wrong. +* +* 2 If V0 points at a pole, the returned XI,ETA will be based on the +* arbitrary assumption that the RA of the tangent point is zero. +* +* 3 This routine is the Cartesian equivalent of the routine slS2TP. +* +* P.T.Wallace Starlink 27 November 1996 +* +* Copyright (C) 1996 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V(3),V0(3),XI,ETA + INTEGER J + + REAL X,Y,Z,X0,Y0,Z0,R2,R,W,D + + REAL TINY + PARAMETER (TINY=1E-6) + + + X=V(1) + Y=V(2) + Z=V(3) + X0=V0(1) + Y0=V0(2) + Z0=V0(3) + R2=X0*X0+Y0*Y0 + R=SQRT(R2) + IF (R.EQ.0.0) THEN + R=1E-20 + X0=R + END IF + W=X*X0+Y*Y0 + D=W+Z*Z0 + IF (D.GT.TINY) THEN + J=0 + ELSE IF (D.GE.0.0) THEN + J=1 + D=TINY + ELSE IF (D.GT.-TINY) THEN + J=2 + D=-TINY + ELSE + J=3 + END IF + D=D*R + XI=(Y*X0-X*Y0)/D + ETA=(Z*R2-Z0*W)/D + + END diff --git a/math/slalib/vdv.f b/math/slalib/vdv.f new file mode 100644 index 00000000..fc686b9d --- /dev/null +++ b/math/slalib/vdv.f @@ -0,0 +1,45 @@ + REAL FUNCTION slVDV (VA, VB) +*+ +* - - - - +* V D V +* - - - - +* +* Scalar product of two 3-vectors (single precision) +* +* Given: +* VA real(3) first vector +* VB real(3) second vector +* +* The result is the scalar product VA.VB (single precision) +* +* P.T.Wallace Starlink November 1984 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL VA(3),VB(3) + + + slVDV=VA(1)*VB(1)+VA(2)*VB(2)+VA(3)*VB(3) + + END diff --git a/math/slalib/veri.f.in b/math/slalib/veri.f.in new file mode 100644 index 00000000..76eb4380 --- /dev/null +++ b/math/slalib/veri.f.in @@ -0,0 +1,52 @@ + INTEGER FUNCTION sla_VERI () +*+ +* - - - - - +* V E R I +* - - - - - +* +* Report the SLALIB version number as an integer. +* +* Given: +* None +* +* The result is the SLALIB version number as an integer m*1e6+n*1e3+r, +* where m is the major version, n the minor version and r the release +* number. +* +* Notes: +* +* To obtain the version number in a printable form, see +* subroutine sla_vers(version). +* +* The sla_veri subroutine was introduced in SLALIB version 2.5-1, so +* if this function is absent, one can only tell that the release +* predates that one. +* +* Norman Gray Starlink 8 April 2005 +* +* Copyright (C) 2005 Council for the Central Laboratory of the +* Research Councils +* +* Licence: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + sla_VERI=@PACKAGE_VERSION_INTEGER@ + + END diff --git a/math/slalib/vers.f.in b/math/slalib/vers.f.in new file mode 100644 index 00000000..b9ef9544 --- /dev/null +++ b/math/slalib/vers.f.in @@ -0,0 +1,58 @@ + SUBROUTINE sla_VERS (VERSION) +*+ +* - - - - - +* V E R S +* - - - - - +* +* Report the SLALIB version number. +* +* Given: +* None +* +* Returned: +* VERSION c*(*) Version number, in the form 'm.n-r'. +* The major version is m, the minor version n, and +* release r. The string passed in should be at least +* 8 characters in length, to account for the (remote) +* possibility that these numbers will ever go to +* two digits. +* +* Notes: +* +* To obtain the version number in a more easily processed form, see +* function sla_veri(). +* +* The sla_vers subroutine was introduced in SLALIB version 2.5-1, so +* if this function is absent, one can only tell that the release +* predates that one. +* +* Norman Gray Starlink 8 April 2005 +* +* Copyright (C) 2005 Council for the Central Laboratory of the +* Research Councils +* +* Licence: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + CHARACTER VERSION*(*) + + VERSION='@PACKAGE_VERSION@' + + END diff --git a/math/slalib/vn.f b/math/slalib/vn.f new file mode 100644 index 00000000..8bbb33d9 --- /dev/null +++ b/math/slalib/vn.f @@ -0,0 +1,64 @@ + SUBROUTINE slVN (V, UV, VM) +*+ +* - - - +* V N +* - - - +* +* Normalizes a 3-vector also giving the modulus (single precision) +* +* Given: +* V real(3) vector +* +* Returned: +* UV real(3) unit vector in direction of V +* VM real modulus of V +* +* If the modulus of V is zero, UV is set to zero as well +* +* P.T.Wallace Starlink 23 November 1995 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL V(3),UV(3),VM + + INTEGER I + REAL W1,W2 + + +* Modulus + W1=0.0 + DO I=1,3 + W2=V(I) + W1=W1+W2*W2 + END DO + W1=SQRT(W1) + VM=W1 + +* Normalize the vector + IF (W1.LE.0.0) W1=1.0 + DO I=1,3 + UV(I)=V(I)/W1 + END DO + + END diff --git a/math/slalib/vxv.f b/math/slalib/vxv.f new file mode 100644 index 00000000..688764bd --- /dev/null +++ b/math/slalib/vxv.f @@ -0,0 +1,57 @@ + SUBROUTINE slVXV (VA, VB, VC) +*+ +* - - - - +* V X V +* - - - - +* +* Vector product of two 3-vectors (single precision) +* +* Given: +* VA real(3) first vector +* VB real(3) second vector +* +* Returned: +* VC real(3) vector result +* +* P.T.Wallace Starlink March 1986 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + REAL VA(3),VB(3),VC(3) + + REAL VW(3) + INTEGER I + + +* Form the vector product VA cross VB + VW(1)=VA(2)*VB(3)-VA(3)*VB(2) + VW(2)=VA(3)*VB(1)-VA(1)*VB(3) + VW(3)=VA(1)*VB(2)-VA(2)*VB(1) + +* Return the result + DO I=1,3 + VC(I)=VW(I) + END DO + + END diff --git a/math/slalib/wait.f__vms b/math/slalib/wait.f__vms new file mode 100644 index 00000000..5897e7e6 --- /dev/null +++ b/math/slalib/wait.f__vms @@ -0,0 +1,60 @@ + SUBROUTINE sla_WAIT (DELAY) +*+ +* - - - - - +* W A I T +* - - - - - +* +* Interval wait +* +* !!! VAX/VMS specific !!! +* +* Given: +* DELAY real delay in seconds +* +* A delay 100ns < DELAY < 200s is requested. +* +* P.T.Wallace Starlink 14 October 1991 +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL DELAY + + INTEGER JSTAT + INTEGER SYS$SCHDWK,SYS$HIBER + + INTEGER IDT(2) + DATA IDT(2)/-1/ + + + +* Encode delta time + IDT(1)=-NINT(MAX(1.0,1E7*MIN(200.0,DELAY))) + + +* Schedule a wakeup + JSTAT=SYS$SCHDWK(,,IDT,) + IF (.NOT.JSTAT) CALL LIB$STOP(%VAL(JSTAT)) + +* Hibernate + JSTAT=SYS$HIBER() + IF (.NOT.JSTAT) CALL LIB$STOP(%VAL(JSTAT)) + + END diff --git a/math/slalib/wait.f__win b/math/slalib/wait.f__win new file mode 100644 index 00000000..b018650c --- /dev/null +++ b/math/slalib/wait.f__win @@ -0,0 +1,83 @@ + SUBROUTINE sla_WAIT (DELAY) +*+ +* - - - - - +* W A I T +* - - - - - +* +* Interval wait +* +* !!! PC only - Microsoft Fortran specific !!! +* +* Given: +* DELAY real delay in seconds +* +* A delay of up to 10000 seconds occurs. +* +* Called: GETTIM (Microsoft Fortran run-time library) +* +* P.T.Wallace Starlink 14 October 1991 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL DELAY + + INTEGER IDELAY,IH,IM,IS,I,IT,IT0,IDT + LOGICAL FIRST,LOOP + + + + +* Convert requested delay to 0.01 second ticks + IDELAY=NINT(MAX(MIN(DELAY,1E4),0.0)*1E2) + +* Set "note start time" flag + FIRST=.TRUE. + +* Set "wait in progress" flag + LOOP=.TRUE. + +* Main loop + DO WHILE (LOOP) + +* Get the current time and convert to 0.01 second ticks + CALL GETTIM(IH,IM,IS,I) + IT=((IH*60+IM)*60+IS)*100+I + +* First time through the loop? + IF (FIRST) THEN + +* Yes: note the time and reset the flag + IT0=IT + FIRST=.FALSE. + ELSE + +* No: subtract the start time, handling 0 hours wrap + IDT=IT-IT0 + IF (IDT.LT.0) IDT=IDT+8640000 + +* If the requested delay has elapsed, stop looping + LOOP=IDT.LT.IDELAY + END IF + END DO + + END diff --git a/math/slalib/wait.fdefault b/math/slalib/wait.fdefault new file mode 100644 index 00000000..75e2720f --- /dev/null +++ b/math/slalib/wait.fdefault @@ -0,0 +1,49 @@ + SUBROUTINE sla_WAIT (DELAY) +*+ +* - - - - - +* W A I T +* - - - - - +* +* Interval wait +* +* !!! Version for: SPARC/SunOS4, +* SPARC/Solaris2, +* DEC Mips/Ultrix +* DEC AXP/Digital Unix +* Intel/Linux +* Convex +* +* Given: +* DELAY real delay in seconds +* +* Called: SLEEP (a Fortran Intrinsic on all obove platforms) +* +* P.T.Wallace Starlink 22 January 1998 +* +* Copyright (C) 1998 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +*- + + IMPLICIT NONE + + REAL DELAY + + CALL SLEEP(NINT(DELAY)) + + END diff --git a/math/slalib/xy2xy.f b/math/slalib/xy2xy.f new file mode 100644 index 00000000..b9c770a3 --- /dev/null +++ b/math/slalib/xy2xy.f @@ -0,0 +1,67 @@ + SUBROUTINE slXYXY (X1,Y1,COEFFS,X2,Y2) +*+ +* - - - - - - +* X Y X Y +* - - - - - - +* +* Transform one [X,Y] into another using a linear model of the type +* produced by the slFTXY routine. +* +* Given: +* X1 d x-coordinate +* Y1 d y-coordinate +* COEFFS d(6) transformation coefficients (see note) +* +* Returned: +* X2 d x-coordinate +* Y2 d y-coordinate +* +* The model relates two sets of [X,Y] coordinates as follows. +* Naming the elements of COEFFS: +* +* COEFFS(1) = A +* COEFFS(2) = B +* COEFFS(3) = C +* COEFFS(4) = D +* COEFFS(5) = E +* COEFFS(6) = F +* +* the present routine performs the transformation: +* +* X2 = A + B*X1 + C*Y1 +* Y2 = D + E*X1 + F*Y1 +* +* See also slFTXY, slPXY, slINVF, slDCMF +* +* P.T.Wallace Starlink 5 December 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION X1,Y1,COEFFS(6),X2,Y2 + + + X2=COEFFS(1)+COEFFS(2)*X1+COEFFS(3)*Y1 + Y2=COEFFS(4)+COEFFS(5)*X1+COEFFS(6)*Y1 + + END diff --git a/math/slalib/zd.f b/math/slalib/zd.f new file mode 100644 index 00000000..c7376266 --- /dev/null +++ b/math/slalib/zd.f @@ -0,0 +1,80 @@ + DOUBLE PRECISION FUNCTION slZD (HA, DEC, PHI) +*+ +* - - - +* Z D +* - - - +* +* HA, Dec to Zenith Distance (double precision) +* +* Given: +* HA d Hour Angle in radians +* DEC d declination in radians +* PHI d observatory latitude in radians +* +* The result is in the range 0 to pi. +* +* Notes: +* +* 1) The latitude must be geodetic. In critical applications, +* corrections for polar motion should be applied. +* +* 2) In some applications it will be important to specify the +* correct type of hour angle and declination in order to +* produce the required type of zenith distance. In particular, +* it may be important to distinguish between the zenith distance +* as affected by refraction, which would require the "observed" +* HA,Dec, and the zenith distance in vacuo, which would require +* the "topocentric" HA,Dec. If the effects of diurnal aberration +* can be neglected, the "apparent" HA,Dec may be used instead of +* the topocentric HA,Dec. +* +* 3) No range checking of arguments is done. +* +* 4) In applications which involve many zenith distance calculations, +* rather than calling the present routine it will be more efficient +* to use inline code, having previously computed fixed terms such +* as sine and cosine of latitude, and perhaps sine and cosine of +* declination. +* +* P.T.Wallace Starlink 3 April 1994 +* +* Copyright (C) 1995 Rutherford Appleton Laboratory +* +* License: +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program (see SLA_CONDITIONS); if not, write to the +* Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +* Boston, MA 02110-1301 USA +* +* Copyright (C) 1995 Association of Universities for Research in Astronomy Inc. +*- + + IMPLICIT NONE + + DOUBLE PRECISION HA,DEC,PHI + + DOUBLE PRECISION SH,CH,SD,CD,SP,CP,X,Y,Z + + + SH=SIN(HA) + CH=COS(HA) + SD=SIN(DEC) + CD=COS(DEC) + SP=SIN(PHI) + CP=COS(PHI) + X=CH*CD*SP-SD*CP + Y=SH*CD + Z=CH*CD*CP+SD*SP + slZD=ATAN2(SQRT(X*X+Y*Y),Z) + + END diff --git a/math/surfit/doc/iscoeff.hlp b/math/surfit/doc/iscoeff.hlp new file mode 100644 index 00000000..ea0b292c --- /dev/null +++ b/math/surfit/doc/iscoeff.hlp @@ -0,0 +1,63 @@ +.help iscoeff Apr85 "Surfit Package" +.ih +NAME +iscoeff - get the number and values of the surface coefficients +.ih +SYNOPSIS +iscoeff (sf, coeff, ncoeff) + +.nf +pointer sf # surface descriptor +real coeff[ncoeff] # coefficient array +int ncoeff # number of coefficients +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls coeff +Array of coefficients. +.le +.ls ncoeff +The number of coefficients. +.le + +.ih +DESCRIPTION +ISCOEFF fetches the coefficient array and the number of coefficients from +the surface descriptor structure. A 1-D array ncoeff elements long +is required to hold the coefficients where ncoeff is defined as follows: + +.nf + SF_LEGENDRE: nxcoeff = xorder + nycoeff = yorder + ncoeff = xorder * yorder xterms = yes + ncoeff = nycoeff + nxcoeff - 1 xterms = no + + SF_CHEBYSHEV: nxcoeff = xorder + nycoeff = yorder + ncoeff = xorder * yorder xterms = yes + ncoeff = nycoeff + nxcoeff - 1 xterms = no + + SF_SPLINE3: nxcoeff = xorder + 3 + nycoeff = yorder + 3 + ncoeff = (xorder + 3) * (yorder + 3) + + SF_SPLINE1: nxcoeff = xorder + 1 + nycoeff = yorder + 1 + ncoeff = (xorder + 1) * (yorder + 1) + +.fi + +The coefficient of basis function B(i,x) * B(j,y) will be stored in +element (i - 1) * +nycoeff + j of the array coeff if the xterms parameter was set +to yes by ISINIT. Otherwise the nycoeff y-term coefficients will be output +first followed by the (nxcoeff - 1) x-term coefficients. + +.ih +NOTES +.ih +SEE ALSO +.endhelp diff --git a/math/surfit/doc/iseval.hlp b/math/surfit/doc/iseval.hlp new file mode 100644 index 00000000..53853cfe --- /dev/null +++ b/math/surfit/doc/iseval.hlp @@ -0,0 +1,34 @@ +.help iseval Apr85 "Surfit Package" +.ih +NAME +iseval -- evaluate the fitted surface at x and y +.ih +SYNOPSIS +y = iseval (sf, x, y) + +.nf +pointer sf # surface descriptor +real x # x value, 1 <= x <= ncols +real y # y value, 1 <= y <= nlines +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y values at which the surface is to be evaluated. +.le +.ih +DESCRIPTION +Evaluate the surface at the specified value of x and y. ISEVAL is a real +valued function which returns the fitted value. +.ih +NOTES +ISEVAL uses the coefficient array stored in the surface descriptor structure. +Checking for out of bounds x and y values is the responsibility of the calling +program. +.ih +SEE ALSO +isvector +.endhelp diff --git a/math/surfit/doc/isfree.hlp b/math/surfit/doc/isfree.hlp new file mode 100644 index 00000000..04f52b5f --- /dev/null +++ b/math/surfit/doc/isfree.hlp @@ -0,0 +1,27 @@ +.help isfree Apr85 "Surfit Package" +.ih +NAME +isfree -- free the surface grid descriptor structure +.ih +SYNOPSIS +isfree (sf) + +.nf +pointer sf # surface descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ih +DESCRIPTION +Frees the surface descriptor structure and all the vectors and arrays used +by the numerical routines. +.ih +NOTES +ISFREE should be called after the surface fit is complete. +.ih +SEE ALSO +isinit +.endhelp diff --git a/math/surfit/doc/isinit.hlp b/math/surfit/doc/isinit.hlp new file mode 100644 index 00000000..e0f2123c --- /dev/null +++ b/math/surfit/doc/isinit.hlp @@ -0,0 +1,61 @@ +.help isinit Apr85 "Surfit Package" +.ih +NAME +isinit -- initialize surface grid descriptor +.ih +SYNOPSIS +include + +.nf +isinit (sf, surface_type, xorder, yorder, xterms, ncols, nlines) +.fi + +.nf +pointer sf # surface descriptor +int surface_type # surface function +int xorder # order of function in x +int yorder # order of function in y +int xterms # include cross-terms? (YES/NO) +int ncols # number of columns in the surface grid +int nlines # number of lines in the surface grid +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls surface_type +Fitting function. Permitted values are SF_LEGENDRE and SF_CHEBYSHEV for +the Legendre and Chebyshev polynomials and SF_SPLINE1 and SF_SPLINE3 +for the linear and bicubic splines. +.le +.ls xorder, yorder +Order of the polynomial to be fit in x and y or the number of spline pieces to +be fit in x and y. The orders must be greater than or equal to 1. +.le +.ls xterms +Include cross-terms? If xterms = YES coefficients are fit to terms containing +the cross products of x and y polynomials. Xterms defaults to YES for the +spline functions. +.le +.ls ncols +The number of columns in the surface grid. The surface is assumed to lie +on a rectangular grid such that 1 <= x <= ncols. +.le +.ls nlines +The number of lines in the surface to be grid. The surface is assumed to lie +on a rectangular grid such that 1 <= y <= nlines. +.le +.ih +DESCRIPTION +ISINIT allocates space for the surface descriptor and the arrays and vectors +used by the numerical routines. It initializes all arrays and vectors to zero, +calculates and stores the basis functions in x and y +and returns the surface descriptor to the calling routine. +.ih +NOTES +ISINIT must be the first SURFIT routine called. +.ih +SEE ALSO +isfree +.endhelp diff --git a/math/surfit/doc/islaccum.hlp b/math/surfit/doc/islaccum.hlp new file mode 100644 index 00000000..48481cf0 --- /dev/null +++ b/math/surfit/doc/islaccum.hlp @@ -0,0 +1,60 @@ +.help islaccum Apr85 "Surfit Package" +.ih +NAME +islaccum -- accumulate a surface grid line into the fit +.ih +SYNOPSIS +include + +islaccum (sf, cols, lineno, z, w, npts, wtflag) + +.nf +pointer sf # surface grid descriptor +int cols[npts] # column values, 1 <= col[i] <= ncols +int lineno # number of line, 1 <= lineno <= nlines +real z[npts] # surface values on lineno at cols +real w[npts] # array of weights +int npts # number of surface values, npts <= ncols +int wtflag # type of weighting desired +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls cols +The column numbers of surface grid points on line lineno to be added to the +dataset. +.le +.ls lineno +The line number of the surface grid line to be added to the data set. +.le +.ls z +The data values. +.le +.ls w +The array of weights for the data points. +.le +.ls npts +The number of surface grid values on line number lineno to be added to the +data set. +.le +.ls wtflag +Type of weighting. The options are SF_USER and SF_UNIFORM. If wtflag +equals SF_USER the weight for each data point is supplied by the user +and points with zero-valued weights are not included in the fit. +If wtflag equals SF_UNIFORM the routine sets the weights to 1. +.le +.ih +DESCRIPTION +ISLACCUM computes the contribution of each data point to the normal +equations in x, sums that contribution into the appropriate arrays and +vectors and stores these intermediate results for use by ISLSOLVE. +.ih +NOTES +Checking for out of bounds col values and INDEF valued data points is +the responsibility of the calling program. +.ih +SEE ALSO +isinit, islfit, islrefit, islsolve, islzero, issolve, isfree +.endhelp diff --git a/math/surfit/doc/islfit.hlp b/math/surfit/doc/islfit.hlp new file mode 100644 index 00000000..5adf0a59 --- /dev/null +++ b/math/surfit/doc/islfit.hlp @@ -0,0 +1,67 @@ +.help islfit Apr85 "Surfit Package" +.ih +NAME +islfit -- fit a surface grid line +.ih +SYNOPSIS +include + +islfit (sf, cols, lineno, z, w, npts, wtflag, ier) + +.nf +pointer sf # surface grid descriptor +real cols[npts] # array of column numbers, 1 <= cols[i] <= ncols +int lineno # number of surface grid line to be added +real z[npts] # data values +real w[npts] # weight array +int npts # number of data points, npts <= ncols +int wtflag # type of weighting +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls cols +The column numbers of surface grid points to be added to the dataset. +.le +.ls lineno +The line number of the surface grid line to be added to the dataset. +.le +.ls z +Array of data values. +.le +.ls w +Array of weights. +.le +.ls npts +Number of data points. +.le +.ls wtflag +Type of weighting. The options are SF_USER and SF_UNIFORM. If wtflag = +SF_USER individual weights for each data point are supplied by the calling +program and points with zero-valued weights are not included in the fit. +If wtflag = SF_UNIFORM, all weights are assigned values of 1. +.le +.ls ier +Error code for the fit. The options are OK, SINGULAR and NO_DEG_FREEDOM. +If ier = SINGULAR, the numerical routines will compute a solution but one +or more of the coefficients will be zero. If ier = NO_DEG_FREEDOM there +were too few data points to solve the matrix equations and the routine +returns without fitting the data. +.le +.ih +DESCRIPTION +ISLFIT zeroes the appropriate arrays and vectors, +computes the contribution of each data point to the normal equations +in x and accumulates it into the appropriate array and vector elements. The +x coefficients are stored for later use by ISSOLVE. +.ih +NOTES +Checking for out of bounds col values and INDEF values pixels is the +responsibility of the user. +.ih +SEE ALSO +isinit, islrefit, islaccum, islsolve, islzero, issolve, isfree +.endhelp diff --git a/math/surfit/doc/islrefit.hlp b/math/surfit/doc/islrefit.hlp new file mode 100644 index 00000000..c34476d6 --- /dev/null +++ b/math/surfit/doc/islrefit.hlp @@ -0,0 +1,51 @@ +.help islrefit Aug85 "Gsurfit Package" +.ih +NAME +islrefit -- refit surface grid line assuming old cols, w vector +.ih +SYNOPSIS +include + +islrefit (sf, cols, lineno, z, w) + +.nf +pointer sf # surface grid descriptor +int cols[ARB] # columns to be fit, 1 <= cols[i] <= ncols +int lineno # line number of surface grid line to be fit +real z[ARB] # array of data values +real w[ARB] # array of weights +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls cols +The column numbers of the surface grid line to be added to the dataset. +.le +.ls lineno +The number of the surface grid line to be added to the dataset. +.le +.ls z +Array of data values. +.le +.ls w +Array of weights. +.le +.ih +DESCRIPTION +In some applications the cols, and w values remain unchanged from fit +to fit and only the z values vary. In this case it is redundant to +reaccumulate the matrix and perform the Cholesky factorization for each +succeeding surface grid line. ISLREFIT +zeros and reaccumulates the vector on the right hand side of the matrix +equation and performs the forward and back substitution phase to fit for +a new coefficient vector. +.ih +NOTES +It is the responsibility of the calling program to check for out of bounds +column values and INDEF valued pixels. +.ih +SEE ALSO +isinit, islfit, islaccum, islsolve, islzero, issolve, isfree +.endhelp diff --git a/math/surfit/doc/islsolve.hlp b/math/surfit/doc/islsolve.hlp new file mode 100644 index 00000000..752cbc19 --- /dev/null +++ b/math/surfit/doc/islsolve.hlp @@ -0,0 +1,45 @@ +.help islsolve Apr85 "Surfit Package" +.ih +NAME +islsolve -- solve the equations for a surface grid line +.ih +SYNOPSIS +include + +islsolve (sf, lineno, ier) + +.nf +pointer sf # surface grid descriptor +int lineno # surface grid line number +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls lineno +The number of the surface grid line to be added to the dataset. +.le +.ls ier +Error code returned by the fitting routines. The options are OK, SINGULAR, +and NO_DEG_FREEDOM. If ier = SINGULAR the matrix is singular, ISLSOLVE +will compute a solution to the normal equations but one or more of the +coefficients will be zero. If ier = NO_DEG_FREEDOM, too few data points +exist for a reasonable solution to be computed and ISLSOLVE returns without +fitting the data. +.le +.ih +DESCRIPTION +ISLSOLVE computes the Cholesky factorization of the data matrix and +solves for the coefficients +of the x fitting function by forward and back substitution. +An error code is +returned by ISLSOLVE if it is unable to solve the normal equations as +formulated. +.ih +NOTES +.ih +SEE ALSO +isinit, islfit, islrefit, islaccum, islzero, issolve, isfree +.endhelp diff --git a/math/surfit/doc/islzero.hlp b/math/surfit/doc/islzero.hlp new file mode 100644 index 00000000..cbdb9515 --- /dev/null +++ b/math/surfit/doc/islzero.hlp @@ -0,0 +1,32 @@ +.help islzero Apr85 "Surfit Package" +.ih +NAME +islzero -- set up for a new surface grid line fit +.ih +SYNOPSIS +islzero (sf, lineno) + +.nf +pointer sf # surface grid descriptor +int lineno # surface grid line number +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls lineno +Line number of the surface grid line fit to be zeroed. +.le +.ih +DESCRIPTION +ISLZERO zeros the appropriate arrays and vectors for the surface grid line +number line number. The line can then be refit by calls to ISLACCUM and +ISLSOLVE. Alternatively a single call to ISLFIT can perform the combined +functions of ISLZERO, ISLACCUM and ISLSOLVE. +.ih +NOTES +.ih +SEE ALSO +isinit, islfit, islrefit, islaccum, islsolve, issolve +.endhelp diff --git a/math/surfit/doc/isreplace.hlp b/math/surfit/doc/isreplace.hlp new file mode 100644 index 00000000..d248e5f8 --- /dev/null +++ b/math/surfit/doc/isreplace.hlp @@ -0,0 +1,33 @@ +.help isreplace Apr1985 "Surfit Package" +.ih +NAME +isreplace -- restore a surface fit saved by issave +.ih +SYNOPSIS +isreplace (sf, fit) + +.nf +pointer sf # surface grid descriptor +real fit[ARB] # fit array +.fi + +.ih +ARGUMENTS + +.ls sf +The pointer to the surface grid descriptor. +.le +.ls fit +The array containing the fit parameters and coefficients. +.le + +.ih +DESCRIPTION + +ISREPLACE restores the fit saved by ISSAVE for use by ISEVAL or ISVECTOR. +.ih +NOTES +.ih +SEE ALSO +issave +.endhelp diff --git a/math/surfit/doc/isresolve.hlp b/math/surfit/doc/isresolve.hlp new file mode 100644 index 00000000..afed8ed8 --- /dev/null +++ b/math/surfit/doc/isresolve.hlp @@ -0,0 +1,45 @@ +.help isresolve Aug85 "Surfit Package" +.ih +NAME +isresolve -- resolve the surface, same lines array +.ih +SYNOPSIS +include + +isresolve (sf, lines, ier) + +.nf +pointer sf # surface grid descriptor +int lines[nlines] # surface grid line numbers, 1 <= lines[i] <= nlines +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls nlines +The number of surface grid lines to be fit. +.le +.ls ier +Error code returned by the fitting routines. The options are OK, SINGULAR, +and NO_DEG_FREEDOM. If ier = SINGULAR the matrix is singular, ISSOLVE +will compute a solution to the normal equations but one or more of the +coefficients will be zero. If ier = NO_DEG_FREEDOM, too few data points +exist for a reasonable solution to be computed. ISSOLVE returns without +fitting the data. +.le +.ih +DESCRIPTION +In some applications it is necessary to refit the same surface several +times with the same lines array. In this case it is inefficient to reaccumulate +the matrices and calculate the Cholesky factorization for each fit. +ISERESOLVE reaccumulates only the right side of the equation. +.ih +NOTES +It is the responsibility of the calling program to check for out of bounds +lines values. +.ih +SEE ALSO +issolve, isinit, slzero, islfit, islrefit, islaccum, islresolve, isfree +.endhelp diff --git a/math/surfit/doc/issave.hlp b/math/surfit/doc/issave.hlp new file mode 100644 index 00000000..6ec97cd6 --- /dev/null +++ b/math/surfit/doc/issave.hlp @@ -0,0 +1,55 @@ +.help issave Apr85 "Surfit Package" +.ih +NAME +issave - save the surface fit +.ih +SYNOPSIS +issave (sf, fit) + +.nf +pointer sf # surface descriptor +real fit[ARB] # fit array +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor. +.le +.ls fit +Array for storing the fit. The fit array must be at least SAVE_COEFF + ncoeff +elements long. +.le + +.ih +DESCRIPTION +ISSAVE stores the surface parameters and coefficient array +in the 1-D reall array fit. Fit must be at least ncoeff + SAVE_COEFF +elements long where ncoeff is defined as follows. + +.nf + SF_LEGENDRE: nxcoeff = xorder + nycoeff = yorder + ncoeff = xorder * yorder xterms = yes + ncoeff = nycoeff + nxcoeff - 1 xterms = no + + SF_CHEBYSHEV: nxcoeff = xorder + nycoeff = yorder + ncoeff = xorder * yorder xterms = yes + ncoeff = nycoeff + nxcoeff - 1 xterms = no + + SF_SPLINE3: nxcoeff = xorder + 3 + nycoeff = yorder + 3 + ncoeff = (xorder + 3) * (yorder + 3) + + SF_SPLINE1: nxcoeff = xorder + 1 + nycoeff = yorder + 1 + ncoeff = (xorder + 1) * (yorder + 1) + +.fi + +.ih +NOTES +.ih +SEE ALSO +isreplace +.endhelp diff --git a/math/surfit/doc/issolve.hlp b/math/surfit/doc/issolve.hlp new file mode 100644 index 00000000..312d69a3 --- /dev/null +++ b/math/surfit/doc/issolve.hlp @@ -0,0 +1,49 @@ +.help issolve Aug85 "Surfit Package" +.ih +NAME +issolve -- solve the surface +.ih +SYNOPSIS +include + +issolve (sf, lines, nlines, ier) + +.nf +pointer sf # surface grid descriptor +int lines[nlines] # surface grid line numbers, 1 <= lines[i] <= nlines +int nlines # number of lines +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls lines +The line number of surface grid lines to be included in the fit. +.le +.ls nlines +The number of surface grid lines to be fit. +.le +.ls ier +Error code returned by the fitting routines. The options are OK, SINGULAR, +and NO_DEG_FREEDOM. If ier = SINGULAR the matrix is singular, ISSOLVE +will compute a solution to the normal equations but one or more of the +coefficients will be zero. If ier = NO_DEG_FREEDOM, too few data points +exist for a reasonable solution to be computed. ISSOLVE returns without +fitting the data. +.le +.ih +DESCRIPTION +ISSOLVE solves for the surface coefficients. +An error code is +returned by ISSOLVE if it is unable to solve the normal equations as +formulated. +.ih +NOTES +It is the responsibility of the calling program to check for out of bounds +lines values. +.ih +SEE ALSO +isinit, slzero, islfit, islrefit, islaccum, islresolve, isfree +.endhelp diff --git a/math/surfit/doc/isvector.hlp b/math/surfit/doc/isvector.hlp new file mode 100644 index 00000000..fabbdcc7 --- /dev/null +++ b/math/surfit/doc/isvector.hlp @@ -0,0 +1,41 @@ +.help isvector Aug85 "Surfit Package" +.ih +NAME +isvector -- evaluate the fitted surface at a set of points +.ih +SYNOPSIS +isvector (sf, x, y, zfit, npts) + +.nf +pointer sf # surface grid descriptor +real x[npts] # x array, 1 <= x[i] <= ncols +real y[npts] # y array, 1 <= y[i] <= nlines +real zfit[npts] # data values +int npts # number of data points +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ls x, y +Arrays of x and y values. +.le +.ls zfit +Array of fitted values. +.le +.ls npts +The number of points to be fit. +.le +.ih +DESCRIPTION +Fit the surface to an array of x and y values. ISVECTOR uses the coefficients +stored in the surface descriptor structure. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the +calling program. +.ih +SEE ALSO +iseval +.endhelp diff --git a/math/surfit/doc/iszero.hlp b/math/surfit/doc/iszero.hlp new file mode 100644 index 00000000..4c338807 --- /dev/null +++ b/math/surfit/doc/iszero.hlp @@ -0,0 +1,26 @@ +.help iszero Aug85 "Surfit Package" +.ih +NAME +iszero -- set up for a new surface fit +.ih +SYNOPSIS +iszero (sf) + +.nf +pointer sf # surface grid descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface grid descriptor structure. +.le +.ih +DESCRIPTION +ISZERO zeros all matrices and vectors used by the fitting program. It +should be used only if one wishes to refit the surface from scratch. +.ih +NOTES +.ih +SEE ALSO +isinit, islzero, islaccum, islfit, islrefit, islsolve, issolve, isfree +.endhelp diff --git a/math/surfit/doc/surfit.hd b/math/surfit/doc/surfit.hd new file mode 100644 index 00000000..18e7ec1a --- /dev/null +++ b/math/surfit/doc/surfit.hd @@ -0,0 +1,19 @@ +# HELP Directory for SURFIT package + +$surfit = "math$surfit/" + +iscoeff hlp = iscoeff.hlp, src = surfit$iscoeff.x +iseval hlp = iseval.hlp, src = surfit$iseval.x +isfree hlp = isfree.hlp, src = surfit$isfree.x +isinit hlp = isinit.hlp, src = surfit$isinit.x +islaccum hlp = islaccum.hlp, src = surfit$islaccum.x +islfit hlp = islfit.hlp, src = surfit$islfit.x +islrefit hlp = islrefit.hlp, src = surfit$islrefit.x +islsolve hlp = islsolve.hlp, src = surfit$islsolve.x +islzero hlp = islzero.hlp, src = surfit$islzero.x +isreplace hlp = isreplace.hlp, src = surfit$isreplace.x +isresolve hlp = isresolve.hlp, src = surfit$isresolve.x +issave hlp = issave.hlp, src = surfit$issave.x +issolve hlp = issolve.hlp, src = surfit$issolve.x +isvector hlp = isvector.hlp, src = surfit$isvector.x +iszero hlp = iszero.hlp, src = surfit$iszero.x diff --git a/math/surfit/doc/surfit.hlp b/math/surfit/doc/surfit.hlp new file mode 100644 index 00000000..a7c347cc --- /dev/null +++ b/math/surfit/doc/surfit.hlp @@ -0,0 +1,157 @@ +.help surfit Aug84 "Math Package" + +.ih +NAME +surfit -- set of routines for fitting gridded surface data + + +.ih +SYNOPSIS + +The surface is defined in the following way. The x and y values are +assumed to be integers and lie in the range 0 <= x <= ncols + 1 and +0 <= y <= nlines + 1. The package prefix is for image surface fit. +Package routines with a prefix followed by l operate on individual +image lines only. + +.nf + isinit (sf, surf_type, xorder, yorder, xterms, ncols, nlines) + iszero (sf) + islzero (sf, lineno) + islaccum (sf, cols, lineno, z, w, ncols, wtflag) + islsolve (sf, lineno, ier) + islfit (sf, cols, lineno, z, w, ncols, wtflag, ier) + islrefit (sf, cols, lineno, z, w, ier) + issolve (sf, lines, nlines, ier) + isresolve (sf, lines, ier) + z = iseval (sf, x, y) + isvector (sf, x, y, zfit, npts) + issave (sf, surface) + isrestore (sf, surface) + isfree (sf) +.fi + +.ih +DESCRIPTION + +The SURFIT package provides a set of routines for fitting surfaces to functions +linear in their coefficients using the tensor product method and least squares +techniques. The basic numerical +technique employed is the solution of the normal equations by the Cholesky +method. + +.ih +NOTES + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Include an include statement in the calling program to make the +SURFIT package definitions available to the user program. +.le +.ls (2) +Call ISINIT to initialize the surface fitting parameters. +.le +.ls (3) +Call ISLACCUM to select a weighting function and accumulate data points +for each line into the appropriate arrays and vectors. Call ISLSOLVE +to compute the coefficients in x for each line. The coefficients are +stored inside SURFIT. Repeat this procedure for each line. ISLACCUM +and SFLSOLVE can be combined by a call to SFLFIT. If the x values +and weights remain the same from line to line ISLREFIT can be called. +.le +.ls (4) +Call ISSOLVE to solve for the surface coefficients. +.le +.ls (5) +Call ISEVAL or ISVECTOR to evaluate the fitted surface at the x and y +value(s) of interest. +.le +.ls (6) +Call ISFREE to release the space allocated for the fit. +.le +.le + +.ih +EXAMPLES + +.nf +Example 1: Fit a 2nd order Lengendre polynomial in x and y to an image +and output the fitted image + +include +include + + + old = immap (old_image, READ_ONLY, 0) + new = immap (new_image, NEW_COPY, 0) + + ncols = IM_LEN(old, 1) + nlines = IM_LEN(old, 2) + + # initialize surface fit + call isinit (sf, LEGENDRE, 3, 3, YES, ncols, nlines) + + # allocate space for lines, columns and weight arrays + call malloc (cols, ncols, TY_INT) + call malloc (lines, nlines, TY_INT) + call malloc (weight, ncols, TY_REAL) + + # initialize lines and columns arrays + do i = 1, ncols + Memi[cols - 1 + i] = i + do i = 1, nlines + Memi[lines - 1 + i] = i + + # fit the surface in x line by line + call amovkl (long(1), v, IM_MAXDIM) + do i = 1, nlines { + if (imgnlr (old, inbuf, v) == EOF) + call error (0, "Error reading image.") + if (i == 1) { + call islfit (sf, Memi[cols], i, Memr[inbuf], Memr[weight], + ncols, SF_WTSUNIFORM, ier) + if (ier != OK) + ... + } else + call islrefit (sf, Memi[cols], i, Memr[inbuf], Memr[weight], + ier) + } + + # solve for surface coefficients + call issolve (sf, Memi[lines], nlines, ier) + + # free space used in fitting arrays + call mfree (cols, TY_INT) + call mfree (lines, TY_INT) + call mfree (weight, TY_REAL) + + # allocate space for x and y arrays + call malloc (x, ncols, TY_REAL) + call malloc (y, ncols, TY_REAL) + + # intialize z array + do i = 1, ncols + Memr[x - 1 + i] = real (i) + + # create fitted image + call amovkl (long(10, v, IM_MAXDIM) + do i = 1, nlines { + if (impnlr (new, outbuf, v) == EOF) + call error (0, "Error writing image.") + call amovkr (real (i), Memr[y], ncols) + call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) + } + + # close files and cleanup + call mfree (x, TY_REAL) + call mfree (y, TY_REAL + + call isfree (sf) + + call imunmap (old) + call imunmap (new) + +.fi +.endhelp diff --git a/math/surfit/doc/surfit.men b/math/surfit/doc/surfit.men new file mode 100644 index 00000000..4a3b3258 --- /dev/null +++ b/math/surfit/doc/surfit.men @@ -0,0 +1,15 @@ + isinit - initialize surface descriptor + iscoeff - get coefficients of surface + iseval - evaluate the surface at a point + isfree - free surface descriptor + islaccum - accumulate surface at a given line number + islfit - fit the surface at a given line number + islrefit - refit the surface at a given line number, same columns + islsolve - solve the surface at a given line number + islzero - zero the fit for a given line number + issolve - solve the surface + isreplace - restore the surface fit + isresolve - resolve surface, same lines + issave - save the surface fit + isvector - fit surface at a set of (x,y) values + iszero - zero the surface fit diff --git a/math/surfit/doc/surfit.spc b/math/surfit/doc/surfit.spc new file mode 100644 index 00000000..07f2b934 --- /dev/null +++ b/math/surfit/doc/surfit.spc @@ -0,0 +1,500 @@ +.help surfit Aug84 "Math Package" +.CE +Specifications for the Surface Fitting Package +.CE +Lindsey Davis +.CE +August 1984 +.CE +First Draft + +.sh +1. Introduction + +The SURFIT package provides a set of routines for fitting surfaces to functions +linear in their coefficients using least squares techniques. The basic numerical +technique employed is the solution of the normal equations by the Cholesky +method. + +.sh +2. Requirements + +.ls (1) +The package shall take as input a surface or section of +a surface. +The data are assumed to be on a rectangular grid and to have the following +ranges, 0 <= x <= ncols + 1 and 0 <= y <= nlines + 1. +The package routines assume that data values equal to INDEF have +been removed from the data set or replaced with appropriate interpolated +values prior to entering the package routines. It is not necessary that +all the data be present to perform the fit. +.le +.ls (2) +The package shall perform the following operations: +.ls o +Determine the coefficients of the fitting function by solving the normal +equations. The surface fitting function is selected at run time from the +following list: (1) SF_LEGENDRE, Legendre polynomials in x and y, +(2) SF_CHEBYSHEV, Chebyshev polynomials in x and y, (3) SF_SPLINE3, bicubic +spline with break points evenly spaced in x and y. The calling sequence +must be invariant to the form of the fitting function. +.le +.ls o +Set an error code if the numerical routines are unable to fit the specified +function. +.le +.ls o +Optionally output the values of the coefficients. The coefficients will be +stored internal to the SURFIT package. However in some applications it is +the coefficients which are of primary interest. A package routine shall +exist to extract the coefficients from the curve descriptor structure. +.le +.ls o +Evaluate the surface at arbitrary value(s) of x and y. The evaluating +routines shall use the calculated coefficients and the user supplied +x values(s). +.le +.ls o +Be capable of storing the fitted surface parameters and coefficients in a +user supplied array and restoring the saved fit for later use by the +evaluating routines. +.le +.ls o +Input surface parameters and surface coefficients derived external to +the surfit package into the surfit format for use by the evaluate +routines. +.le +.le +.ls (3) +The program shall perform a weighted fit to the surface using a user +supplied weight array and weight flag. The weighting options will be +SF_WTSUSER and SF_WTSUNIFORM. In SF_WTSUNIFORM mode the package routines +set all the weights to 1. In SF_WTSUSER mode the package routines apply +user supplied weights to the individual data points. +.le +.ls (4) +The input data set, output coefficients, error and fitted z arrays are +single precision real quantities. All package arithmetic shall be performed +in single precision. +.le + +.sh +3. Specifications + +.sh +3.1. List of Routines + + +The surface is defined in the following way. The x and y values are +assumed to be integers and lie in the range 0 <= x <= ncols + 1 and +0 <= y <= nlines + 1. The package prefix is is for image surface fit. +Package routines with a prefix followed by l operate on individual +image lines only. + +.nf + z = f (col, line) +.fi + +.nf + isinit (sf, surf_type, xorder, yorder, xterms, ncols, nlines) + iszero (sf) + islzero (sf, lineno) + islaccum (sf, cols, lineno, z, w, ncols, wtflag) + islsolve (sf, lineno, ier) + islfit (sf, cols, lineno, z, w, ncols, wtflag, ier) + islrefit (sf, cols, lineno, z, w, ier) + issolve (sf, lines, nlines, ier) + isresolve (sf, lines, ier) + z = iseval (sf, x, y) + isvector (sf, x, y, zfit, npts) + issave (sf, surface) + isrestore (sf, surface) + isfree (sf) +.fi + +.sh +3.2. Algorithms + +.sh +3.2.1. Polynomial Basis Functions + +The approximating function is assumed to be of the following form, + +.nf + f(x,y) = sum (a[i,j] * F(i,x) * F(j,y)) i = 1...nxcoeff j = 1...nycoeff +.fi + +where the F(i,x) are the polynomial basis functions containing terms of order +x**(i-1) and the a(i,j) are the coefficients. In order to avoid a very +ill-conditioned linear system for moderate or large i, the Legendre and +Chebyshev polynomials were chosen for the basis functions. The Chebyshev +and Legendre polynomials are orthogonal over -1. <= x,y <= 1. The data x and +y values are normalized to this regime using the number of lines and columns +supplied by the user. For each data point the basis +functions are calculated using the following recursion relations. The +cross terms are optional. + +Legendre series: +.nf + + F(1,x) = 1. + F(2,x) = x + F(i,x) = [(2*i-1)*x*F(i-1,x)-(i-2)*F(i-2,x)]/(i-1) + F(1,y) = 1. + F(2,y) = y + F(j,y) = [(2*j-1)*y*F(j-1,y)-(j-2)*F(j-2,y)]/(j-1) + +.fi +Chebyshev series: +.nf + + F(1,x) = 1. + F(2,x) = x + F(i,x) = 2.*x*F(i-1,x)-F(i-2,x) + F(1,y) = 1. + F(2,y) = y + F(j,y) = 2.*y*F(j-1,y)-F(j-2,y) +.fi + + +.sh +3.2.2. Bicubic Cardinal B-spline + +The approximating function is of the form + +.nf + f(x,y) = sum (x(i,j) * F(i,x) * F(j,y)) i=1...nxcoeff j=1...nycoeff +.fi + +where the basis functions, F(i,x), are the cubic cardinal B-splines +(Prenter 1975). The user supplies the number of columns and lines and the +number of polynomial pieces in x and y, nxpieces and nypieces, to be fit +to the data set. The number of bicubic spline coefficients, ncoeff, will be + +.nf + nxcoeff = (nxpieces + 3) + nycoeff = (nypieces + 3) + ncoeff = nxcoeff * nycoeff +.fi + +The cardinal B-spline is stored in a lookup table. For each x and y the +appropriate break point is selected and the four non-zero B-splines are +calculated by nearest neighbour interpolation in the lookup table. + +.sh +3.2.3. Method of Solution + +.sh +3.2.3.1. Full Surface Fit + +The normal equations are accumulated in the following form. + +.nf + c * x = b + c[i,j] = (B(i,x,y), B(j,x,y)) + b[j] = (B(j,x,y), S(x,y)) +.fi + +B(i,x,y) is the ith basis function at x and y, S(x,y) is the surface to +be approximated and the inner product of two functions G and H is +given by + +.nf + (G,H) = sum (w[i] * G(x[i],y[i]) * H(x[i],y[i])) i = 1...npts +.fi + +Since the matrix c is symmetric and positive semi-definite it may +be solved by the Cholesky method. +The coefficient matrix c can be written as + +.nf + c = l * d * l-transpose +.fi + +where l is a unit lower triangular matrix and d is the diagonal of c +(de Boor 1978). Near zero pivots are handled in the following way. +At the nth elimination step the current value of the nth diagonal +element is compared with the original nth diagonal element. If the +diagonal element has been reduced by one computer word length, the +entire nth row is declared linearly dependent on the previous n-1 +rows and x(n) = 0. + +The triangular system + +.nf + l * w = b +.fi + +is solved for w (forward substitution), the vector d ** (-1) * w is +computed and the triangular system + +.nf + l-transpose * x = d ** (-1) * w +.fi + +solved for the coefficients, x (backward substitution). + + +.sh +3.2.3.2. Line by Line Fit + +Each line of the surface can be represented by the following equation. + +.nf + S(x,yo) = a[i](yo) * B[i](x) i = 1...nxcoeff for each yo +.fi + +The normal equations for each image line are formed + +.nf + c * a = b + c[i,j] = (B(i,x), B(j,x)) + b[j] = (B(j,x), S(x,yo)) +.fi + +and solved for a as described in the previous section. +After fitting the entire image matrix a has nxcoeff columns and +nlines rows. + +For each column i in a the normal equations +are formed and solved for the c[i,j] + +.nf + c * x = b + c[j,k] = (B(j,y), B(k,x)) + b[i,j] = (a[i](y), B(j,y)) +.fi + +.sh +3.2.4. Number of Operations + +It is worth while to calculate the number of operations reqired to compute +the surface fit by the full surface method versus the line by line method. +The number of operations required to accumulate the normal equations +and solve the set is the following + +.nf + nop = npts * order ** 2 / 2 + order ** 3 /6 +.fi + +where the first term is the number of operations required to accumulate the +matrix and the second is the number required to solve the system. + +.nf +Example 1: full surface, 3 by 3 polynomial no cross terms, 512 by 512 image + + norder = 5 + npts = 512 * 512 + nops(accum) = 3,276,800 + nops(solve) = 21 + +Example 2: full surface, 30 by 30 spline, 512 by 512 image + + norder = 900 + npts = 512 * 512 + nops(accum) = 1.062 * 10 ** 11 + nops(solve) = 1.216 * 10 ** 8 + +Example 3: line by line method, 3 by 3 polynomial, 512 by 512 image + + step 1 solve for a coefficients + norder = 3 + npts = 512 + nlines = 512 + nops(accum) = 1,179,648 + nops(solve) = 2304 + + step 2 solve for c coefficients + norder = 3 + npts = 512 + nlines = 3 + nops(accum) = 6912 + nops(solve) = 14 + +Example 4: line by line method, 30 by 30 spline, 512 by 512 image + + step 1 solve coefficients + norder = 30 + npts = 512 + nlines = 512 + nops(accum) = 117,964,800 + nops(solve) = 2,304,000 + + step 2 solve for c coefficients + norder = 30 + npts = 512 + nlines = 30 + nops(accum) = 6,912,000 + nops(solve) = 135,000 +.fi + +The figures for the line by line method are worst case numbers. If the +x values remain the same from line to line then the coefficient matrix +only has to be accumulated and inverted twice. +For the bicubic spline function the number of operations is significantly +reduced by taking advantage of the banded nature of the matrices. + +.sh +4. Usage + +.sh +4.1. User Notes + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Include an include statement in the calling program to make the +SURFIT package definitions available to the user program. +.le +.ls (2) +Call SFINIT to initialize the surface fitting parameters. +.le +.ls (3) +Call SFLACCUM to select a weighting function and accumulate data points +for each line into the appropriate arrays and vectors. Call SFLSOLVE +to compute the coefficients in x for each line. The coefficents are +stored inside SURFIT. Repeat this procedure for each line. SFLACCUM +and SFLSOLVE can be combined by a call to SFLFIT. If the x values +and weights remain the same from line to line SFLREFIT can be called. +.le +.ls (4) +Call SFSOLVE to solve for the surface coefficients. +.le +.ls (5) +Call SFEVAL or SFVECTOR to evaluate the fitted surface at the x and y +value(s) of interest. +.le +.ls (6) +Call SFFREE to release the space allocated for the fit. +.le +.le + +.sh +4.2. Examples + +.nf +Example 1: Fit a 2nd order Lengendre polynomial in x and y to an image +and output the fitted image + +include +include + + + old = immap (old_image, READ_ONLY, 0) + new = immap (new_image, NEW_COPY, 0) + + ncols = IM_LEN(old, 1) + nlines = IM_LEN(old, 2) + + # initialize surface fit + call isinit (sf, LEGENDRE, 3, 3, YES, ncols, nlines) + + # allocate space for lines, columns and weight arrays + call malloc (cols, ncols, TY_INT) + call malloc (lines, nlines, TY_INT) + call malloc (weight, ncols, TY_REAL) + + # initialize lines and columns arrays + do i = 1, ncols + Memi[cols - 1 + i] = i + do i = 1, nlines + Memi[lines - 1 + i] = i + + # fit the surface in x line by line + call amovkl (long(1), v, IM_MAXDIM) + do i = 1, nlines { + if (imgnlr (old, inbuf, v) == EOF) + call error (0, "Error reading image.") + if (i == 1) { + call islfit (sf, Memi[cols], i, Memr[inbuf], Memr[weight], + ncols, SF_WTSUNIFORM, ier) + if (ier != OK) + ... + } else + call sflrefit (sf, Memi[cols], i, Memr[inbuf], Memr[weight], + ier) + } + + # solve for surface coefficients + call issolve (sf, Memi[lines], nlines, ier) + + # free space used in fitting arrays + call mfree (cols, TY_INT) + call mfree (lines, TY_INT) + call mfree (weight, TY_REAL) + + # allocate space for x and y arrays + call malloc (x, ncols, TY_REAL) + call malloc (y, ncols, TY_REAL) + + # intialize z array + do i = 1, ncols + Memr[x - 1 + i] = real (i) + + # create fitted image + call amovkl (long(10, v, IM_MAXDIM) + do i = 1, nlines { + if (impnlr (new, outbuf, v) == EOF) + call error (0, "Error writing image.") + call amovkr (real (i), Memr[y], ncols) + call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) + } + + # close files and cleanup + call mfree (x, TY_REAL) + call mfree (y, TY_REAL + + call isfree (sf) + + call imunmap (old) + call imunmap (new) + +.fi +.sh +5. Detailed Design + +.sh +5.1. Surface Descriptor Structure + +To be written when specifications are finalised. + +.sh +5.2. Storage Requirements + +The minimum storage requirements for the full surface fit method +assuming that points are to be rejected from the fit without revaluating +the matrix are the following. + +.nf + (nxcoeff*nycoeff) ** 2 -- coefficient array plus triangularized matrix + nxcoeff*nycoeff -- right side + nxcoeff*nycoeff -- solution vector +.fi + +For a 30 by 30 spline roughly 811,800 storage units are required. +For a 3 by 3 polynomial the requirements are 675 storage units. The +requirements are roughly half when rejection is disabled. + +The minimum storage requirements for the line by line method are + +.nf + nx*nx*2 -- The x matrix and its factorization + nx*nlines -- The x coefficient matrix + ny*ny*2 -- The y matrix and its factorization + nx*ny -- The solution +.fi + + +.sh +6. References + +.ls (1) +Carl de Boor, "A Practical Guide to Splines", 1978, Springer-Verlag New York +Inc. +.le +.ls (2) +P.M. Prenter, "Splines and Variational Methods", 1975, John Wiley and Sons +Inc. +.le +.endhelp diff --git a/math/surfit/iscoeff.x b/math/surfit/iscoeff.x new file mode 100644 index 00000000..f656e7e6 --- /dev/null +++ b/math/surfit/iscoeff.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "surfitdef.h" + +# ISCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the surface type is a bicubic spline or polynomials with cross terms +# then the number of coefficients is SF_NXCOEFF(sf) * SF_NYCOEFF(sf) and +# the coefficient of B(i,x) * B(j,y) will be stored in element +# (i - 1) * SF_NYCOEFF(sf) + j of the array coeff. Otherwise the number +# of coefficients will be (SF_NXCOEFF(sf) + SF_NYCOEFF(sf) - 1), and +# the SF_NYCOEFF(sf) y coefficients will be output first followed by +# the (SF_NXCOEFF(sf) - 1) x coefficients. + +procedure iscoeff (sf, coeff, ncoeff) + +pointer sf # pointer to the surface fitting descriptor +real coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +int i +pointer cptr + +begin + # calculate the number of coefficients + if (SF_XTERMS(sf) == NO) { + ncoeff = SF_NXCOEFF(sf) + SF_NYCOEFF(sf) - 1 + call amovr (COEFF(SF_COEFF(sf)), coeff, SF_NYCOEFF(sf)) + cptr = SF_COEFF(sf) + SF_NYCOEFF(sf) + do i = SF_NYCOEFF(sf) + 1, ncoeff { + coeff[i] = COEFF(cptr) + cptr = cptr + SF_NYCOEFF(sf) + } + } else { + ncoeff = SF_NXCOEFF(sf) * SF_NYCOEFF(sf) + call amovr (COEFF(SF_COEFF(sf)), coeff, ncoeff) + } +end diff --git a/math/surfit/iseval.x b/math/surfit/iseval.x new file mode 100644 index 00000000..08ef5f89 --- /dev/null +++ b/math/surfit/iseval.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISEVAL -- Procedure to evaluate the fitted surface at a single point. +# The SF_NXCOEFF(sf) by SF_NYCOEFF(sf) coefficients are stored in the +# SF_NYCOEFF(sf) by SF_NXCOEFF(sf) matrix COEFF. The j-th element of the ith +# row of COEFF contains the coefficient of the i-th basis function in x and +# the j-th basis function in y. + +real procedure iseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +real x # x value +real y # y value + +real sum, accum +int i, k, leftx, lefty, yorder +pointer sp, xb, xzb, yb, yzb, czptr + +begin + # allocate space for the basis functions + call smark (sp) + call salloc (xb, SF_XORDER(sf), MEM_TYPE) + xzb = xb - 1 + call salloc (yb, SF_YORDER(sf), MEM_TYPE) + yzb = yb - 1 + + # calculate the basis functions + switch (SF_TYPE(sf)) { + case SF_CHEBYSHEV: + leftx = 0 + lefty = 0 + czptr = SF_COEFF(sf) - 1 + call sf_b1cheb (x, SF_XORDER(sf), SF_XMAXMIN(sf), SF_XRANGE(sf), + XBS(xb)) + call sf_b1cheb (y, SF_YORDER(sf), SF_YMAXMIN(sf), SF_YRANGE(sf), + YBS(yb)) + + case SF_LEGENDRE: + leftx = 0 + lefty = 0 + czptr = SF_COEFF(sf) - 1 + call sf_b1leg (x, SF_XORDER(sf), SF_XMAXMIN(sf), SF_XRANGE(sf), + XBS(xb)) + call sf_b1leg (y, SF_YORDER(sf), SF_YMAXMIN(sf), SF_YRANGE(sf), + YBS(yb)) + + case SF_SPLINE3: + call sf_b1spline3 (x, SF_NXPIECES(sf), -SF_XMIN(sf), + SF_XSPACING(sf), XBS(xb), leftx) + call sf_b1spline3 (y, SF_NYPIECES(sf), -SF_YMIN(sf), + SF_YSPACING(sf), YBS(yb), lefty) + czptr = SF_COEFF(sf) - 1 + lefty + leftx * SF_NYCOEFF(sf) + + case SF_SPLINE1: + call sf_b1spline1 (x, SF_NXPIECES(sf), -SF_XMIN(sf), + SF_XSPACING(sf), XBS(xb), leftx) + call sf_b1spline1 (y, SF_NYPIECES(sf), -SF_YMIN(sf), + SF_YSPACING(sf), YBS(yb), lefty) + czptr = SF_COEFF(sf) - 1 + lefty + leftx * SF_NYCOEFF(sf) + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + yorder = SF_YORDER(sf) + do i = 1, SF_XORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, yorder { + accum = accum + COEFF(czptr+k) * YBS(yzb+k) + } + accum = accum * XBS(xzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if SF_XTERMS(sf) = NO + if (SF_XTERMS(sf) == NO) + yorder = 1 + + czptr = czptr + SF_NYCOEFF(sf) + } + + call sfree (sp) + + return (sum) +end diff --git a/math/surfit/isfree.x b/math/surfit/isfree.x new file mode 100644 index 00000000..2eb25891 --- /dev/null +++ b/math/surfit/isfree.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "surfitdef.h" + +# ISFREE -- Procedure to free the surface descriptor + +procedure isfree (sf) + +pointer sf # pointer to the surface descriptor +errchk mfree + +begin + # free arrays in memory + + # first the basis functions + if (SF_XBASIS(sf) != NULL) + call mfree (SF_XBASIS(sf), MEM_TYPE) + if (SF_XLEFT(sf) != NULL) + call mfree (SF_XLEFT(sf), TY_INT) + if (SF_YBASIS(sf) != NULL) + call mfree (SF_YBASIS(sf), MEM_TYPE) + if (SF_YLEFT(sf) != NULL) + call mfree (SF_YLEFT(sf), TY_INT) + + # next the x and y matrices + if (SF_XMATRIX(sf) != NULL) + call mfree (SF_XMATRIX(sf), MEM_TYPE) + if (SF_YMATRIX(sf) != NULL) + call mfree (SF_YMATRIX(sf), MEM_TYPE) + + # last the coefficient matrices + if (SF_XCOEFF(sf) != NULL) + call mfree (SF_XCOEFF(sf), MEM_TYPE) + if (SF_COEFF(sf) != NULL) + call mfree (SF_COEFF(sf), MEM_TYPE) + + if (SF_WZ(sf) != NULL) + call mfree (SF_WZ(sf), MEM_TYPE) + if (SF_TLEFT(sf) != NULL) + call mfree (SF_TLEFT(sf), TY_INT) + + # free surface descriptor + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/surfit/isinit.x b/math/surfit/isinit.x new file mode 100644 index 00000000..ade35b47 --- /dev/null +++ b/math/surfit/isinit.x @@ -0,0 +1,167 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISINIT -- Procedure to set up the surface descriptor. + +procedure isinit (sf, surf_type, xorder, yorder, xterms, ncols, nlines) + +pointer sf # pointer to surface descriptor structure +int surf_type # type of surface to be fitted +int xorder # x order of surface to be fit, or in the case of the + # spline the number of polynomial pieces in x to be fit +int yorder # y order of surface to be fit, or in the case of the + # spline the number of polynomial pieces in y to be fit +int xterms # cross terms for polynomials? +int ncols # number of columns in the surface +int nlines # number of lines in the surface + +int i +pointer x, y +pointer sp +errchk malloc, calloc + +begin + # allocate space for the surface descriptor + call malloc (sf, LEN_SFSTRUCT, TY_STRUCT) + + if (xorder < 1 || yorder < 1) + call error (0, "SFLINIT: Illegal order.") + + if (ncols < 1) + call error (0, "SFLINIT: x data range is 0.") + if (nlines < 1) + call error (0, "SFLINIT: y data range is 0.") + + switch (surf_type) { + + case SF_CHEBYSHEV, SF_LEGENDRE: + SF_NXCOEFF(sf) = xorder + SF_XORDER(sf) = xorder + SF_XRANGE(sf) = 2. / real (ncols + 1) + SF_XMAXMIN(sf) = - real (ncols + 1) / 2. + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_NYCOEFF(sf) = yorder + SF_YORDER(sf) = yorder + SF_YRANGE(sf) = 2. / real (nlines + 1) + SF_YMAXMIN(sf) = - real (nlines + 1) / 2. + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = xterms + + case SF_SPLINE3: + SF_NXCOEFF(sf) = (xorder + SPLINE3_ORDER - 1) + SF_XORDER(sf) = SPLINE3_ORDER + SF_NXPIECES(sf) = xorder - 1 + SF_XSPACING(sf) = xorder / real (ncols + 1) + SF_NYCOEFF(sf) = (yorder + SPLINE3_ORDER - 1) + SF_YORDER(sf) = SPLINE3_ORDER + SF_NYPIECES(sf) = yorder - 1 + SF_YSPACING(sf) = yorder / real (nlines + 1) + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = YES + + case SF_SPLINE1: + SF_NXCOEFF(sf) = (xorder + SPLINE1_ORDER - 1) + SF_XORDER(sf) = SPLINE1_ORDER + SF_NXPIECES(sf) = xorder - 1 + SF_XSPACING(sf) = xorder / real (ncols + 1) + SF_NYCOEFF(sf) = (yorder + SPLINE1_ORDER - 1) + SF_YORDER(sf) = SPLINE1_ORDER + SF_NYPIECES(sf) = yorder - 1 + SF_YSPACING(sf) = yorder / real (nlines + 1) + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = YES + + default: + call error (0, "SFINIT: Unknown surface type.") + } + + SF_TYPE(sf) = surf_type + SF_NLINES(sf) = nlines + SF_NCOLS(sf) = ncols + + # allocate space for the matrix and vectors + call calloc (SF_XBASIS(sf), SF_XORDER(sf) * SF_NCOLS(sf), + MEM_TYPE) + call calloc (SF_YBASIS(sf), SF_YORDER(sf) * SF_NLINES(sf), + MEM_TYPE) + call calloc (SF_XMATRIX(sf), SF_XORDER(sf) * SF_NXCOEFF(sf), MEM_TYPE) + call calloc (SF_XCOEFF(sf), SF_NLINES(sf) * SF_NXCOEFF(sf), MEM_TYPE) + call calloc (SF_YMATRIX(sf), SF_YORDER(sf) * SF_NYCOEFF(sf), MEM_TYPE) + call calloc (SF_COEFF(sf), SF_NXCOEFF(sf) * SF_NYCOEFF(sf), MEM_TYPE) + + # allocate temporary space + call smark (sp) + call salloc (x, SF_NCOLS(sf), MEM_TYPE) + call salloc (y, SF_NLINES(sf), MEM_TYPE) + + # calculate all possible x basis functions and store + do i = 1, SF_NCOLS(sf) + Memr[x+i-1] = i + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE: + SF_XLEFT(sf) = NULL + call sf_bleg (Memr[x], SF_NCOLS(sf), SF_XORDER(sf), SF_XMAXMIN(sf), + SF_XRANGE(sf), XBASIS(SF_XBASIS(sf))) + + case SF_CHEBYSHEV: + SF_XLEFT(sf) = NULL + call sf_bcheb (Memr[x], SF_NCOLS(sf), SF_XORDER(sf), SF_XMAXMIN(sf), + SF_XRANGE(sf), XBASIS(SF_XBASIS(sf))) + + case SF_SPLINE3: + call calloc (SF_XLEFT(sf), SF_NCOLS(sf), TY_INT) + call sf_bspline3 (Memr[x], SF_NCOLS(sf), SF_NXPIECES(sf), + -SF_XMIN(sf), SF_XSPACING(sf), XBASIS(SF_XBASIS(sf)), + XLEFT(SF_XLEFT(sf))) + + case SF_SPLINE1: + call calloc (SF_XLEFT(sf), SF_NCOLS(sf), TY_INT) + call sf_bspline1 (Memr[x], SF_NCOLS(sf), SF_NXPIECES(sf), + -SF_XMIN(sf), SF_XSPACING(sf), XBASIS(SF_XBASIS(sf)), + XLEFT(SF_XLEFT(sf))) + } + + # calculate all possible y basis functions and store + do i = 1, SF_NLINES(sf) + Memr[y+i-1] = i + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE: + SF_YLEFT(sf) = NULL + call sf_bleg (Memr[y], SF_NLINES(sf), SF_YORDER(sf), + SF_YMAXMIN(sf), SF_YRANGE(sf), YBASIS(SF_YBASIS(sf))) + + case SF_CHEBYSHEV: + SF_YLEFT(sf) = NULL + call sf_bcheb (Memr[y], SF_NLINES(sf), SF_YORDER(sf), + SF_YMAXMIN(sf), SF_YRANGE(sf), YBASIS(SF_YBASIS(sf))) + + case SF_SPLINE3: + call calloc (SF_YLEFT(sf), SF_NLINES(sf), TY_INT) + call sf_bspline3 (Memr[y], SF_NLINES(sf), SF_NYPIECES(sf), + -SF_YMIN(sf), SF_YSPACING(sf), YBASIS(SF_YBASIS(sf)), + YLEFT(SF_YLEFT(sf))) + + case SF_SPLINE1: + call calloc (SF_YLEFT(sf), SF_NLINES(sf), TY_INT) + call sf_bspline1 (Memr[y], SF_NLINES(sf), SF_NYPIECES(sf), + -SF_YMIN(sf), SF_YSPACING(sf), YBASIS(SF_YBASIS(sf)), + YLEFT(SF_YLEFT(sf))) + } + + SF_WZ(sf) = NULL + SF_TLEFT(sf) = NULL + + call sfree (sp) +end diff --git a/math/surfit/islaccum.x b/math/surfit/islaccum.x new file mode 100644 index 00000000..cc69323a --- /dev/null +++ b/math/surfit/islaccum.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISLACCUM -- Procedure to add points on a line to the data set. +# The inner products of the non-zero x basis functions are stored +# in the SF_XORDER(sf) by SF_NXCOEFF(sf) matrix XMATRIX. The +# main diagonal is stored in the first row of XMATRIX. Successive +# non-zero diagonals are stored in the succeeding rows. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner products +# of the data ordinates and the non-zero x basis functions are +# caculated and stored in the lineno-th row of the SF_NXCOEFF(sf) +# by SF_NLINES(sf) matrix XCOEFF. + +procedure islaccum (sf, cols, lineno, z, w, ncols, wtflag) + +pointer sf # pointer to surface descriptor +int cols[ncols] # column values +int lineno # lineno of data being accumulated +real z[ncols] # surface values on lineno at cols +real w[ncols] # weight of the data points +int ncols # number of data points +int wtflag # type of weighting desired + +int i, ii, j, k +pointer xbzptr, xbptr +pointer xlzptr +pointer xmzptr, xmindex +pointer xczptr, xcindex +pointer bw, rows, left +pointer sp + +begin + # count the number of points + SF_NXPTS(sf) = SF_NXPTS(sf) + ncols + + # calculate the weights, default is uniform weighting + switch (wtflag) { + case SF_UNIFORM: + call amovkr (1.0, w, ncols) + case SF_USER: + # do not alter weights + default: + call amovkr (1.0, w, ncols) + } + + # set up temporary storage + call smark (sp) + call salloc (bw, ncols, TY_REAL) + call salloc (left, ncols, TY_INT) + call salloc (rows, ncols, TY_INT) + + # set up the pointers + xbzptr = SF_XBASIS(sf) - 1 + xmzptr = SF_XMATRIX(sf) + xczptr = SF_XCOEFF(sf) + (lineno - 1) * SF_NXCOEFF(sf) - 1 + + # accumulate the line + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + + do i = 1, SF_XORDER(sf) { + do j = 1, ncols + Memr[bw+j-1] = w[j] * XBASIS(xbzptr+cols[j]) + xcindex = xczptr + i + do j = 1, ncols + XCOEFF(xcindex) = XCOEFF(xcindex) + Memr[bw+j-1] * z[j] + xbptr = xbzptr + ii = 0 + do k = i, SF_XORDER(sf) { + xmindex = xmzptr + ii + do j = 1, ncols + XMATRIX(xmindex) = XMATRIX(xmindex) + Memr[bw+j-1] * + XBASIS(xbptr+cols[j]) + ii = ii + 1 + xbptr = xbptr + SF_NCOLS(sf) + } + xbzptr = xbzptr + SF_NCOLS(sf) + xmzptr = xmzptr + SF_XORDER(sf) + } + + case SF_SPLINE3, SF_SPLINE1: + + xlzptr = SF_XLEFT(sf) - 1 + do j = 1, ncols + Memi[left+j-1] = XLEFT(xlzptr+cols[j]) + call amulki (Memi[left], SF_XORDER(sf), Memi[rows], ncols) + call aaddki (Memi[rows], SF_XMATRIX(sf), Memi[rows], ncols) + call aaddki (Memi[left], xczptr, Memi[left], ncols) + + do i = 1, SF_XORDER(sf) { + do j = 1, ncols { + Memr[bw+j-1] = w[j] * XBASIS(xbzptr+cols[j]) + xcindex = Memi[left+j-1] + i + XCOEFF(xcindex) = XCOEFF(xcindex) + Memr[bw+j-1] * z[j] + } + xbptr = xbzptr + ii = 0 + do k = i, SF_XORDER(sf) { + do j = 1, ncols { + xmindex = Memi[rows+j-1] + ii + XMATRIX(xmindex) = XMATRIX(xmindex) + Memr[bw+j-1] * + XBASIS(xbptr+cols[j]) + } + ii = ii + 1 + xbptr = xbptr + SF_NCOLS(sf) + } + xbzptr = xbzptr + SF_NCOLS(sf) + call aaddki (Memi[rows], SF_XORDER(sf), Memi[rows], ncols) + } + } + + # release space + call sfree (sp) +end diff --git a/math/surfit/islfit.x b/math/surfit/islfit.x new file mode 100644 index 00000000..7b60c361 --- /dev/null +++ b/math/surfit/islfit.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISLFIT -- Procedure to fit a single line of a surface. The inner products +# of the x basis functions are calculated and accumulated into the +# SF_XORDER(sf) by SF_NXCOEFF(sf) matrix XMATRIX. The main diagonal is stored +# in the first row of XMATRIX followed by the non-zero lower diagonals. This +# method of storage is very efficient for the large symmetric banded matrices +# generated by spline fits. The Cholesky factorization of XMATRIX is calculated +# and stored in XMATRIX destroying the original data. The inner products +# of the x basis functions and the data ordinates are stored in the lineno-th +# row of the SF_NXCOEFF(sf) by SF_NLINES(sf) matrix XCOEFF. The x coefficients +# for each line are calculated by forward and back substitution and +# stored in the lineno-th line of XCOEFF destroying the original data. + +procedure islfit (sf, cols, lineno, z, w, ncols, wtflag, ier) + +pointer sf # pointer to the surface descriptor +int cols[ncols] # array of columns +int lineno # lineno +real z[ncols] # the surface values +real w[ncols] # array of weights +int ncols # the number of columns +int wtflag # type of weighting +int ier # error codes + +int i, ii, j, k +pointer xbzptr, xbptr +pointer xmzptr, xmindex +pointer xczptr, xcindex +pointer xlzptr +pointer left, rows, bw +pointer sp +real adotr() + +begin + # index the pointers + xbzptr = SF_XBASIS(sf) - 1 + xmzptr = SF_XMATRIX(sf) + xczptr = SF_XCOEFF(sf) + (lineno - 1) * SF_NXCOEFF(sf) - 1 + + # zero the accumulators + call aclrr (XMATRIX(SF_XMATRIX(sf)), SF_NXCOEFF(sf) * SF_XORDER(sf)) + call aclrr (XCOEFF(xczptr + 1), SF_NXCOEFF(sf)) + + # free space used by previous islrefit calls + if (SF_WZ(sf) != NULL) + call mfree (SF_WZ(sf), MEM_TYPE) + if (SF_TLEFT(sf) != NULL) + call mfree (SF_TLEFT(sf), TY_INT) + + # reset number of points + SF_NXPTS(sf) = ncols + + # calculate the weights, default is uniform weighting + switch (wtflag) { + case SF_UNIFORM: + call amovkr (1.0, w, ncols) + case SF_USER: + # do not alter weights + default: + call amovkr (1.0, w, ncols) + } + + # allocate temporary space + call smark (sp) + call salloc (bw, ncols, TY_REAL) + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + + do i = 1, SF_XORDER(sf) { + do j = 1, ncols + Memr[bw+j-1] = w[j] * XBASIS(xbzptr+cols[j]) + + xcindex = xczptr + i + XCOEFF(xcindex) = XCOEFF(xcindex) + adotr (Memr[bw], z, ncols) + + xbptr = xbzptr + ii = 0 + do k = i, SF_XORDER(sf) { + xmindex = xmzptr + ii + do j = 1, ncols + XMATRIX(xmindex) = XMATRIX(xmindex) + Memr[bw+j-1] * + XBASIS(xbptr+cols[j]) + ii = ii + 1 + xbptr = xbptr + SF_NCOLS(sf) + } + + xbzptr = xbzptr + SF_NCOLS(sf) + xmzptr = xmzptr + SF_XORDER(sf) + } + + case SF_SPLINE3, SF_SPLINE1: + xlzptr = SF_XLEFT(sf) - 1 + + call salloc (left, ncols, TY_INT) + call salloc (rows, ncols, TY_INT) + + do j = 1, ncols + Memi[left+j-1] = XLEFT(xlzptr+cols[j]) + call amulki (Memi[left], SF_XORDER(sf), Memi[rows], ncols) + call aaddki (Memi[rows], SF_XMATRIX(sf), Memi[rows], ncols) + call aaddki (Memi[left], xczptr, Memi[left], ncols) + + do i = 1, SF_XORDER(sf) { + do j = 1, ncols { + Memr[bw+j-1] = w[j] * XBASIS(xbzptr+cols[j]) + xcindex = Memi[left+j-1] + i + XCOEFF(xcindex) = XCOEFF(xcindex) + Memr[bw+j-1] * z[j] + } + + xbptr = xbzptr + ii = 0 + do k = i, SF_XORDER(sf) { + do j = 1, ncols { + xmindex = Memi[rows+j-1] + ii + XMATRIX(xmindex) = XMATRIX(xmindex) + Memr[bw+j-1] * + XBASIS(xbptr+cols[j]) + } + ii = ii + 1 + xbptr = xbptr + SF_NCOLS(sf) + } + + xbzptr = xbzptr + SF_NCOLS(sf) + call aaddki (Memi[rows], SF_XORDER(sf), Memi[rows], ncols) + } + } + + # release space + call sfree (sp) + + # return if not enough data points + ier = OK + if ((SF_NXPTS(sf) - SF_NXCOEFF(sf)) < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of XMATRIX + call sfchofac (XMATRIX(SF_XMATRIX(sf)), SF_XORDER(sf), SF_NXCOEFF(sf), + XMATRIX(SF_XMATRIX(sf)), ier) + + # calculate the x coefficients for lineno-th image line and place in the + # lineno-th row of XCOEFF + call sfchoslv (XMATRIX(SF_XMATRIX(sf)), SF_XORDER(sf), SF_NXCOEFF(sf), + XCOEFF(xczptr + 1), XCOEFF(xczptr + 1)) +end diff --git a/math/surfit/islrefit.x b/math/surfit/islrefit.x new file mode 100644 index 00000000..b0430e5b --- /dev/null +++ b/math/surfit/islrefit.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISLREFIT -- Procedure to refit the data assuming that the cols and w +# arrays do not change. SIFLREFIT assumes that the Cholesky factorization +# of XMATRIX is stored in XMATRIX. The inner products of the x basis +# functions and the data ordinates are accumulated into the lineno-th +# row of the SF_NXCOEFF(sf) by SF_NLINES(sf) matrix XCOEFF. The coefficients +# for line number lineno are calculated by forward and back +# substitution and placed in the lineno-th row of XCOEFF replacing the +# original data. + +procedure islrefit (sf, cols, lineno, z, w) + +pointer sf # pointer to surface descriptor +int cols[ARB] # columns to be fit +int lineno # line number +real z[ARB] # surface values +real w[ARB] # weight values + +int i, j +pointer xbzptr, xczptr, xcindex, xlzptr + +begin + # set pointers + xbzptr = SF_XBASIS(sf) - 1 + xczptr = SF_XCOEFF(sf) + (lineno - 1) * SF_NXCOEFF(sf) - 1 + xlzptr = SF_XLEFT(sf) - 1 + + # reset lineno-th row of the x coefficient matrix + call aclrr (XCOEFF(xczptr+1), SF_NXCOEFF(sf)) + + if (SF_WZ(sf) == NULL) + call malloc (SF_WZ(sf), SF_NXPTS(sf), MEM_TYPE) + + # calculate new right sides + call amulr (w, z, Memr[SF_WZ(sf)], SF_NXPTS(sf)) + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + + do i = 1, SF_XORDER(sf) { + xcindex = xczptr + i + do j = 1, SF_NXPTS(sf) + XCOEFF(xcindex) = XCOEFF(xcindex) + Memr[SF_WZ(sf)+j-1] * + XBASIS(xbzptr+cols[j]) + xbzptr = xbzptr + SF_NCOLS(sf) + } + + case SF_SPLINE3, SF_SPLINE1: + + if (SF_TLEFT(sf) == NULL) + call malloc (SF_TLEFT(sf), SF_NXPTS(sf), TY_INT) + + do i = 1, SF_NXPTS(sf) + Memi[SF_TLEFT(sf)+i-1] = XLEFT(xlzptr+cols[i]) + xczptr + + do i = 1, SF_XORDER(sf) { + do j = 1, SF_NXPTS(sf) { + xcindex = Memi[SF_TLEFT(sf)+j-1] + i + XCOEFF(xcindex) = XCOEFF(xcindex) + Memr[SF_WZ(sf)+j-1] * + XBASIS(xbzptr+cols[j]) + } + xbzptr = xbzptr + SF_NCOLS(sf) + } + + } + + # solve for the new x coefficients for line number lineno + call sfchoslv (XMATRIX(SF_XMATRIX(sf)), SF_XORDER(sf), SF_NXCOEFF(sf), + XCOEFF(xczptr+1), XCOEFF(xczptr+1)) +end diff --git a/math/surfit/islsolve.x b/math/surfit/islsolve.x new file mode 100644 index 00000000..11d0d313 --- /dev/null +++ b/math/surfit/islsolve.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISLSOLVE -- Procedure to solve for the x coefficients of image line +# number lineno. The inner products of the x basis functions are assumed +# to be in the SF_XORDER(sf) by SF_NXCOEFF(sf) array XMATRIX, +# while the inner products of the basis functions and +# the data ordinated for line number lineno are assumed to be in the +# lineno-th row of the SF_NXCOEFF(sf) by SF_NLINES(sf) matrix XCOEFF. +# The Cholesky factorization of XMATRIX is calculated and placed +# in XMATRIX overwriting the original data. The x coefficients for +# line number lineno are calculated and placed in the lineno-th row +# of XCOEFF replacing the original data. + +procedure islsolve (sf, lineno, ier) + +pointer sf # pointer to the surface descriptor structure +int lineno # line being fitted in x +int ier # ier = 0, everything OK + # ier = 1, matrix is singular + # ier = 2, no degree of freedom + +pointer xcptr + +begin + # return if there are insuffucient points to solve the matrix + ier = OK + if ((SF_NXPTS(sf) - SF_NXCOEFF(sf)) < 0 ) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the x matrix and store + # separately for possible use by SFLREFIT + + call sfchofac (XMATRIX(SF_XMATRIX(sf)), SF_XORDER(sf), SF_NXCOEFF(sf), + XMATRIX(SF_XMATRIX(sf)), ier) + + # solve for the x coefficients for line lineno assuming the + # data are in row lineno of xcoeff, the solution is placed + # on top of the data + + xcptr = SF_XCOEFF(sf) + (lineno - 1) * SF_NXCOEFF(sf) + call sfchoslv (XMATRIX(SF_XMATRIX(sf)), SF_XORDER(sf), SF_NXCOEFF(sf), + XCOEFF(xcptr), XCOEFF(xcptr)) +end diff --git a/math/surfit/islzero.x b/math/surfit/islzero.x new file mode 100644 index 00000000..03034f01 --- /dev/null +++ b/math/surfit/islzero.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "surfitdef.h" + +# ISLZERO -- Procedure to zero the accumulators for line number lineno. + +procedure islzero (sf, lineno) + +pointer sf # pointer to the surface descriptor +int lineno # line number +pointer xcptr + +begin + SF_NXPTS(sf) = 0 + + call aclrr (XMATRIX(SF_XMATRIX(sf)), + SF_XORDER(sf) * SF_NXCOEFF(sf)) + xcptr = SF_XCOEFF(sf) + (lineno - 1) * SF_NXCOEFF(sf) + call aclrr (XCOEFF(xcptr), SF_NXCOEFF(sf)) + + if (SF_WZ(sf) != NULL) + call mfree (SF_WZ(sf), MEM_TYPE) + if (SF_TLEFT(sf) != NULL) + call mfree (SF_TLEFT(sf), TY_INT) +end diff --git a/math/surfit/isreplace.x b/math/surfit/isreplace.x new file mode 100644 index 00000000..1ba69479 --- /dev/null +++ b/math/surfit/isreplace.x @@ -0,0 +1,114 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISREPLACE -- Procedure to restore the surface fit stored by SIFSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# number of columns and number of lines, are stored in the first +# six elements of the real array fit, followed by the SF_NYCOEFF(sf) * +# SF_NYCOEFF(sf) surface coefficients. The coefficient of B(i,x) * B(j,y) +# is stored in element number 6 + (i - 1) * SF_NYCOEFF(sf) + j of the +# array fit. + +procedure isreplace (sf, fit) + +pointer sf # surface descriptor +real fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, ncols, nlines + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_SFSTRUCT, TY_STRUCT) + + xorder = nint (SF_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "SFRESTORE: Illegal x order.") + yorder = nint (SF_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "SFRESTORE: Illegal y order.") + + ncols = nint (SF_SAVENCOLS(fit)) + if (ncols < 1) + call error (0, "SFRESTORE: Illegal x range.") + nlines = nint (SF_SAVENLINES(fit)) + if (nlines < 1) + call error (0, "SFRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (SF_SAVETYPE(fit)) + + switch (surface_type) { + case SF_LEGENDRE, SF_CHEBYSHEV: + SF_NXCOEFF(sf) = xorder + SF_XORDER(sf) = xorder + SF_XRANGE(sf) = 2. / real (ncols + 1) + SF_XMAXMIN(sf) = - real (ncols + 1) / 2. + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_NYCOEFF(sf) = yorder + SF_YORDER(sf) = yorder + SF_YRANGE(sf) = 2. / real (nlines + 1) + SF_YMAXMIN(sf) = - real (nlines + 1) / 2. + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = SF_SAVEXTERMS(fit) + + case SF_SPLINE3: + SF_NXCOEFF(sf) = (xorder + SPLINE3_ORDER - 1) + SF_XORDER(sf) = SPLINE3_ORDER + SF_NXPIECES(sf) = xorder - 1 + SF_XSPACING(sf) = xorder / real (ncols + 1) + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_NYCOEFF(sf) = (yorder + SPLINE3_ORDER - 1) + SF_YORDER(sf) = SPLINE3_ORDER + SF_NYPIECES(sf) = yorder - 1 + SF_YSPACING(sf) = yorder / real (nlines + 1) + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = YES + + case SF_SPLINE1: + SF_NXCOEFF(sf) = (xorder + SPLINE1_ORDER - 1) + SF_XORDER(sf) = SPLINE1_ORDER + SF_NXPIECES(sf) = xorder - 1 + SF_XSPACING(sf) = xorder / real (ncols + 1) + SF_XMIN(sf) = 0. + SF_XMAX(sf) = real (ncols + 1) + SF_NYCOEFF(sf) = (yorder + SPLINE1_ORDER - 1) + SF_YORDER(sf) = SPLINE1_ORDER + SF_NYPIECES(sf) = yorder - 1 + SF_YSPACING(sf) = yorder / real (nlines + 1) + SF_YMIN(sf) = 0. + SF_YMAX(sf) = real (nlines + 1) + SF_XTERMS(sf) = YES + + default: + call error (0, "SFRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + SF_TYPE(sf) = surface_type + SF_NLINES(sf) = nlines + SF_NCOLS(sf) = ncols + + # allocate space for the coefficient array + SF_XBASIS(sf) = NULL + SF_YBASIS(sf) = NULL + SF_XMATRIX(sf) = NULL + SF_YMATRIX(sf) = NULL + SF_XCOEFF(sf) = NULL + SF_WZ(sf) = NULL + SF_TLEFT(sf) = NULL + + call calloc (SF_COEFF(sf), SF_NXCOEFF(sf) * SF_NYCOEFF(sf), MEM_TYPE) + + # restore coefficient array + call amovr (fit[SF_SAVECOEFF+1], COEFF(SF_COEFF(sf)), SF_NYCOEFF(sf) * + SF_NXCOEFF(sf)) +end diff --git a/math/surfit/isresolve.x b/math/surfit/isresolve.x new file mode 100644 index 00000000..7af6a8da --- /dev/null +++ b/math/surfit/isresolve.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISRESOLVE -- Procedure to solve the x coefficient matrix for the surface +# coefficients assuming that the lines array is unchanged since the last +# call to SIFSOLVE. The Cholesky factorization of YMATRIX is assumed to be +# stored in YMATRIX. The inner product of the y basis functions and i-th +# column of XCOEFF containing the i-th x coefficients for each line are +# calculated and stored in the i-th row of the SF_NYCOEFF(sf) by +# SF_NXCOEFF(sf) array COEFF. Each of the SF_NXCOEFF(sf) rows of COEFF +# is solved to determine the SF_NYCOEFF(sf) by SF_NXCOEFF(sf) surface +# coefficients. After a call to SIFSOLVE the coefficient for the i-th +# y basis function and the j-th x coefficient is found in the j-th row +# and i-th column of COEFF. + +procedure isresolve (sf, lines, ier) + +pointer sf # pointer to the surface descriptor structure +int lines[ARB] # line numbers included in the fit +int ier # error code + +int i, j, k, nxcoeff +pointer ybzptr +pointer ylzptr +pointer xczptr, xcptr, xcindex +pointer czptr, cptr +pointer left, tleft +pointer sp + +begin + # define pointers + ybzptr = SF_YBASIS(sf) - 1 + xczptr = SF_XCOEFF(sf) - SF_NXCOEFF(sf) - 1 + czptr = SF_COEFF(sf) - 1 + + # zero out coefficient matrix + call aclrr (COEFF(SF_COEFF(sf)), SF_NXCOEFF(sf) * SF_NYCOEFF(sf)) + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + + # loop over the y basis functions + nxcoeff = SF_NXCOEFF(sf) + do i = 1, SF_YORDER(sf) { + cptr = czptr + i + do k = 1, nxcoeff { + xcptr = xczptr + k + do j = 1, SF_NYPTS(sf) { + xcindex = xcptr + lines[j] * SF_NXCOEFF(sf) + COEFF(cptr) = COEFF(cptr) + + YBASIS(ybzptr+lines[j]) * XCOEFF(xcindex) + } + cptr = cptr + SF_NYCOEFF(sf) + } + + ybzptr = ybzptr + SF_NYPTS(sf) + + # if SF_XTERMS(sf) = NO do not accumulate elements + # of COEFF where i != 1 and k != 1 + if (SF_XTERMS(sf) == NO) + nxcoeff = 1 + } + + case SF_SPLINE3, SF_SPLINE1: + call smark (sp) + call salloc (left, SF_NYPTS(sf), TY_INT) + call salloc (tleft, SF_NYPTS(sf), TY_INT) + + ylzptr = SF_YLEFT(sf) - 1 + do j = 1, SF_NYPTS(sf) + Memi[left+j-1] = YLEFT(ylzptr+lines[j]) + call aaddki (Memi[left], czptr, Memi[left], SF_NYPTS(sf)) + + nxcoeff = SF_NXCOEFF(sf) + do i = 1, SF_YORDER(sf) { + call aaddki (Memi[left], i, Memi[tleft], SF_NYPTS(sf)) + do k = 1, nxcoeff { + xcptr = xczptr + k + do j = 1, SF_NYPTS(sf) { + cptr = Memi[tleft+j-1] + xcindex = xcptr + lines[j] * SF_NXCOEFF(sf) + COEFF(cptr) = COEFF(cptr) + YBASIS(ybzptr+lines[j]) * + XCOEFF(xcindex) + } + call aaddki (Memi[tleft], SF_NYCOEFF(sf), Memi[tleft], + SF_NYPTS(sf)) + } + + ybzptr = ybzptr + SF_NYPTS(sf) + } + + call sfree (sp) + } + + # return if not enough points + ier = OK + if ((SF_NYPTS(sf) - SF_NYCOEFF(sf)) < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (SF_XTERMS(sf) == YES) { + + # solve for the nxcoeff right sides + cptr = SF_COEFF(sf) + do i = 1, SF_NXCOEFF(sf) { + call sfchoslv (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf), + SF_NYCOEFF(sf), COEFF(cptr), COEFF(cptr)) + cptr = cptr + SF_NYCOEFF(sf) + } + + } else { + + # solve for the y coefficients + cptr = SF_NYCOEFF(sf) + call sfchoslv (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf), + SF_NYCOEFF(sf), COEFF(cptr), COEFF(cptr)) + + # solve for the x coefficients + do i = 2, SF_NXCOEFF(sf) { + cptr = czptr + SF_NYCOEFF(sf) + COEFF(cptr) = COEFF(cptr) / SF_NYPTS(sf) + } + } +end diff --git a/math/surfit/issave.x b/math/surfit/issave.x new file mode 100644 index 00000000..5a3ecab8 --- /dev/null +++ b/math/surfit/issave.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to SIFSAVE the first six elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, ncols +# and nlines. The remaining spaces are filled by the SF_NYCOEFF(sf) * +# SF_NXCOEFF(sf) surface coefficients. The coefficient of B(i,x) * B(j,y) +# is located in element number 6 + (i - 1) * SF_NYCOEFF(sf) + j of the +# array fit where i <= SF_NXCOEFF(sf) and j <= SF_NYCOEFF(sf). + +procedure issave (sf, fit) + +pointer sf # pointer to the surface descriptor +real fit[ARB] # array for storing fit + +begin + # get the surface parameters + + # order is surface type dependent + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + SF_SAVEXORDER(fit) = SF_XORDER(sf) + SF_SAVEYORDER(fit) = SF_YORDER(sf) + case SF_SPLINE3, SF_SPLINE1: + SF_SAVEXORDER(fit) = SF_NXPIECES(sf) + 1 + SF_SAVEYORDER(fit) = SF_NYPIECES(sf) + 1 + default: + call error (0, "SIFSAVE: Unknown surface type.") + } + + # save remaining parameters + SF_SAVETYPE(fit) = SF_TYPE(sf) + SF_SAVENLINES(fit) = SF_NLINES(sf) + SF_SAVENCOLS(fit) = SF_NCOLS(sf) + SF_SAVEXTERMS(fit) = SF_XTERMS(sf) + + # save the coefficients + call amovr (COEFF(SF_COEFF(sf)), fit[SF_SAVECOEFF+1], SF_NXCOEFF(sf) * + SF_NYCOEFF(sf)) +end diff --git a/math/surfit/issolve.x b/math/surfit/issolve.x new file mode 100644 index 00000000..7790ef60 --- /dev/null +++ b/math/surfit/issolve.x @@ -0,0 +1,169 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISSOLVE -- Procedure to solve the x coefficient matrix for the surface +# coefficients. The inner products of the y basis functions are accumulated +# and stored in the SF_YORDER(sf) by SF_NYCOEFF(sf) array YMATRIX. The +# main diagonal of YMATRIX is stored in the first row of YMATRIX followed +# by the remaining non-zero lower diagonals. The Cholesky factorization +# of YMATRIX is calculated and stored on top of YMATRIX destroying the +# original data. The inner products of the y basis functions and +# and the i-th column of the SF_NXCOEFF(sf) by SF_NLINES(sf) matrix XCOEFF +# containing the i-th x coefficients for each line are calculated and +# placed in the i-th row of the SF_NYCOEFF(sf) by SF_NXCOEFF(sf) matrix +# COEFF. Each of the SF_NXCOEFF(sf) rows of COEFF is solved to determine +# the SF_NXCOEFF(sf) by SF_NYCOEFF(sf) surface coefficients. After a +# call to SIFSOLVE the coefficient of the i-th x basis function and the +# j-th y basis function will be found in the j-th column and i-th row +# of COEFF. + +procedure issolve (sf, lines, nlines, ier) + +pointer sf # pointer to the curve descriptor structure +int lines[ARB] # line numbers included in the fit +int nlines # number of lines fit +int ier # error code + +int i, ii, j, k, nxcoeff +pointer ybzptr, ybptr +pointer ylzptr +pointer ymzptr, ymindex +pointer xczptr, xcptr, xcindex +pointer czptr, cptr +pointer left, tleft, rows +pointer sp + +begin + # define pointers + ybzptr = SF_YBASIS(sf) - 1 + ymzptr = SF_YMATRIX(sf) + xczptr = SF_XCOEFF(sf) - SF_NXCOEFF(sf) - 1 + czptr = SF_COEFF(sf) - 1 + + # zero out coefficient matrix and the y coefficient matrix + call aclrr (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf) * SF_NYCOEFF(sf)) + call aclrr (COEFF(SF_COEFF(sf)), SF_NXCOEFF(sf) * SF_NYCOEFF(sf)) + + # increment the number of points + SF_NYPTS(sf) = nlines + + switch (SF_TYPE(sf)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + + # accumulate the y value in the y matrix + nxcoeff = SF_NXCOEFF(sf) + do i = 1, SF_YORDER(sf) { + cptr = czptr + i + do k = 1, nxcoeff { + xcptr = xczptr + k + do j = 1, nlines { + xcindex = xcptr + lines[j] * SF_NXCOEFF(sf) + COEFF(cptr) = COEFF(cptr) + + YBASIS(ybzptr+lines[j]) * XCOEFF(xcindex) + } + cptr = cptr + SF_NYCOEFF(sf) + } + ii = 0 + ybptr = ybzptr + do k = i, SF_YORDER(sf) { + ymindex = ymzptr + ii + do j = 1, nlines + YMATRIX(ymindex) = YMATRIX(ymindex) + + YBASIS(ybzptr+lines[j]) * + YBASIS(ybptr+lines[j]) + ii = ii + 1 + ybptr = ybptr + SF_NLINES(sf) + } + + if (SF_XTERMS(sf) == NO) + nxcoeff = 1 + + ybzptr = ybzptr + SF_NLINES(sf) + ymzptr = ymzptr + SF_YORDER(sf) + } + + case SF_SPLINE3, SF_SPLINE1: + + call smark (sp) + call salloc (left, nlines, TY_INT) + call salloc (tleft, nlines, TY_INT) + call salloc (rows, nlines, TY_INT) + + ylzptr = SF_YLEFT(sf) - 1 + do j = 1, nlines + Memi[left+j-1] = YLEFT(ylzptr+lines[j]) + call amulki (Memi[left], SF_YORDER(sf), Memi[rows], nlines) + call aaddki (Memi[rows], SF_YMATRIX(sf), Memi[rows], nlines) + call aaddki (Memi[left], czptr, Memi[left], nlines) + + # accumulate the y value in the y matrix + nxcoeff = SF_NXCOEFF(sf) + do i = 1, SF_YORDER(sf) { + call aaddki (Memi[left], i, Memi[tleft], nlines) + do k = 1, nxcoeff { + xcptr = xczptr + k + do j = 1, nlines { + cptr = Memi[tleft+j-1] + xcindex = xcptr + lines[j] * SF_NXCOEFF(sf) + COEFF(cptr) = COEFF(cptr) + YBASIS(ybzptr+lines[j]) * + XCOEFF(xcindex) + } + call aaddki (Memi[tleft], SF_NYCOEFF(sf), Memi[tleft], + nlines) + } + ii = 0 + ybptr = ybzptr + do k = i, SF_YORDER(sf) { + do j = 1, nlines { + ymindex = Memi[rows+j-1] + ii + YMATRIX(ymindex) = YMATRIX(ymindex) + + YBASIS(ybzptr+lines[j]) * + YBASIS(ybptr+lines[j]) + } + ii = ii + 1 + ybptr = ybptr + SF_NLINES(sf) + } + + ybzptr = ybzptr + SF_NLINES(sf) + call aaddki (Memi[rows], SF_YORDER(sf), Memi[rows], nlines) + } + + call sfree (sp) + + } + + # return if not enough points + ier = OK + if ((SF_NYPTS(sf) - SF_NYCOEFF(sf)) < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the y matrix + call sfchofac (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf), SF_NYCOEFF(sf), + YMATRIX(SF_YMATRIX(sf)), ier) + + if (SF_XTERMS(sf) == YES) { + + # solve for the nxcoeff right sides + cptr = SF_COEFF(sf) + do i = 1, SF_NXCOEFF(sf) { + call sfchoslv (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf), + SF_NYCOEFF(sf), COEFF(cptr), COEFF(cptr)) + cptr = cptr + SF_NYCOEFF(sf) + } + + } else { + + cptr = SF_COEFF(sf) + call sfchoslv (YMATRIX(SF_YMATRIX(sf)), SF_YORDER(sf), + SF_NYCOEFF(sf), COEFF(cptr), COEFF(cptr)) + + do i = 2, SF_NXCOEFF(sf) { + cptr = cptr + SF_NYCOEFF(sf) + COEFF(cptr) = COEFF(cptr) / SF_NYPTS(sf) + } + } +end diff --git a/math/surfit/isvector.x b/math/surfit/isvector.x new file mode 100644 index 00000000..023d3f4d --- /dev/null +++ b/math/surfit/isvector.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" + +# ISVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The SF_NXCOEFF(sf) by SF_NYCOEFF(sf) coefficients are stored in the +# SF_NYCOEFF(sf) by SF_NXCOEFF(sf) matrix COEFF. The j-th element of the ith +# row of COEFF contains the coefficient of the i-th basis function in x and +# the j-th basis function in y. + +procedure isvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +real x[ARB] # x value +real y[ARB] # y value +real zfit[ARB] # fits surface values +int npts # number of data points + +int i +pointer xcoeff, cptr, sp + +begin + # evaluate the surface along the vector + switch (SF_TYPE(sf)) { + case SF_CHEBYSHEV: + if (SF_XORDER(sf) == 1) { + call cv_evcheb (COEFF(SF_COEFF(sf)), y, zfit, npts, + SF_YORDER(sf), SF_YMAXMIN(sf), SF_YRANGE(sf)) + } else if (SF_YORDER(sf) == 1) { + call smark (sp) + call salloc (xcoeff, SF_NXCOEFF(sf), MEM_TYPE) + cptr = SF_COEFF(sf) + do i = 1, SF_NXCOEFF(sf) { + Memr[xcoeff+i-1] = COEFF(cptr) + cptr = cptr + SF_NYCOEFF(sf) + } + call cv_evcheb (Memr[xcoeff], x, zfit, npts, + SF_XORDER(sf), SF_XMAXMIN(sf), SF_XRANGE(sf)) + call sfree (sp) + } else + call sf_evcheb (COEFF(SF_COEFF(sf)), x, y, zfit, npts, + SF_XTERMS(sf), SF_XORDER(sf), SF_YORDER(sf), SF_XMAXMIN(sf), + SF_XRANGE(sf), SF_YMAXMIN(sf), SF_YRANGE(sf)) + + case SF_LEGENDRE: + if (SF_XORDER(sf) == 1) { + call cv_evleg (COEFF(SF_COEFF(sf)), y, zfit, npts, + SF_YORDER(sf), SF_YMAXMIN(sf), SF_YRANGE(sf)) + } else if (SF_YORDER(sf) == 1) { + call smark (sp) + call salloc (xcoeff, SF_NXCOEFF(sf), MEM_TYPE) + cptr = SF_COEFF(sf) + do i = 1, SF_NXCOEFF(sf) { + Memr[xcoeff+i-1] = COEFF(cptr) + cptr = cptr + SF_NYCOEFF(sf) + } + call cv_evcheb (Memr[xcoeff], x, zfit, npts, + SF_XORDER(sf), SF_XMAXMIN(sf), SF_XRANGE(sf)) + call sfree (sp) + } else + call sf_evleg (COEFF(SF_COEFF(sf)), x, y, zfit, npts, + SF_XTERMS(sf), SF_XORDER(sf), SF_YORDER(sf), SF_XMAXMIN(sf), + SF_XRANGE(sf), SF_YMAXMIN(sf), SF_YRANGE(sf)) + + case SF_SPLINE3: + call sf_evspline3 (COEFF(SF_COEFF(sf)), x, y, zfit, npts, + SF_NXPIECES(sf), SF_NYPIECES(sf), -SF_XMIN(sf), SF_XSPACING(sf), + -SF_YMIN(sf), SF_YSPACING(sf)) + + case SF_SPLINE1: + call sf_evspline1 (COEFF(SF_COEFF(sf)), x, y, zfit, npts, + SF_NXPIECES(sf), SF_NYPIECES(sf), -SF_XMIN(sf), SF_XSPACING(sf), + -SF_YMIN(sf), SF_YSPACING(sf)) + } +end diff --git a/math/surfit/iszero.x b/math/surfit/iszero.x new file mode 100644 index 00000000..d453d1fd --- /dev/null +++ b/math/surfit/iszero.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "surfitdef.h" + +# ISZERO -- Procedure to zero the accumulators for line number lineno. + +procedure iszero (sf) + +pointer sf # pointer to the surface descriptor + +begin + SF_NXPTS(sf) = 0 + SF_NYPTS(sf) = 0 + + call aclrr (XMATRIX(SF_XMATRIX(sf)), + SF_XORDER(sf) * SF_NXCOEFF(sf)) + call aclrr (YMATRIX(SF_YMATRIX(sf)), + SF_YORDER(sf) * SF_NYCOEFF(sf)) + call aclrr (XCOEFF(SF_XCOEFF(sf)), SF_NXCOEFF(sf) * SF_NLINES(sf)) + call aclrr (COEFF(SF_COEFF(sf)), SF_NXCOEFF(sf) * SF_NYCOEFF(sf)) + + if (SF_WZ(sf) != NULL) + call mfree (SF_WZ(sf), MEM_TYPE) + if (SF_TLEFT(sf) != NULL) + call mfree (SF_TLEFT(sf), TY_INT) +end diff --git a/math/surfit/mkpkg b/math/surfit/mkpkg new file mode 100644 index 00000000..58948e29 --- /dev/null +++ b/math/surfit/mkpkg @@ -0,0 +1,29 @@ +# Surface fitting tools library. + +$checkout libsurfit.a lib$ +$update libsurfit.a +$checkin libsurfit.a lib$ +$exit + +libsurfit.a: + iscoeff.x surfitdef.h + iseval.x surfitdef.h + isfree.x surfitdef.h + isinit.x surfitdef.h + islaccum.x surfitdef.h + islfit.x surfitdef.h + islrefit.x surfitdef.h + islsolve.x surfitdef.h + islzero.x surfitdef.h + isreplace.x surfitdef.h + isresolve.x surfitdef.h + issave.x surfitdef.h + issolve.x surfitdef.h + isvector.x surfitdef.h + iszero.x surfitdef.h + sf_b1eval.x + sf_beval.x + sf_f1deval.x + sf_feval.x + sfchomat.x surfitdef.h + ; diff --git a/math/surfit/sf_b1eval.x b/math/surfit/sf_b1eval.x new file mode 100644 index 00000000..d07006fc --- /dev/null +++ b/math/surfit/sf_b1eval.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SF_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure sf_b1leg (x, order, k1, k2, basis) + +real x # array of data points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i +real ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# SF_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure sf_b1cheb (x, order, k1, k2, basis) + +real x # number of data points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i +real xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end + + +# SF_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure sf_b1spline1 (x, npieces, k1, k2, basis, left) + +real x # set of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left # index of the appropriate spline functions + +real xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = xnorm - left + basis[1] = 1. - basis[2] +end + + +# SF_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure sf_b1spline3 (x, npieces, k1, k2, basis, left) + +real x # array of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +real sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = sx - left + tx = 1. - sx + + basis[1] = tx * tx * tx + basis[2] = 1. + tx * (3. + tx * (3. - 3. * tx)) + basis[3] = 1. + sx * (3. + sx * (3. - 3. * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/surfit/sf_beval.x b/math/surfit/sf_beval.x new file mode 100644 index 00000000..301967f9 --- /dev/null +++ b/math/surfit/sf_beval.x @@ -0,0 +1,143 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SF_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure sf_bcheb (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1., basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkr (basis[bptr], 2., basis[bptr], npts) + call asubr (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# SF_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure sf_bleg (x, npts, order, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int k, bptr +real ri, ri1, ri2 + +begin + bptr = 1 + + do k = 1, order { + if (k == 1) + call amovkr (1., basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsur (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end + + +# SF_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure sf_bspline1 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call altar (x, basis[1+npts], npts, k1, k2) + call achtri (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = basis[npts+k] - left[k] + basis[k] = 1. - basis[npts+k] + } +end + + +# SF_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure sf_bspline3 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + + # calculate the index of the first non-zero coeff + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], left, npts) + call aminki (left, npieces, left, npts) + + # normalize x to 0 to 1 + do i = 1, npts { + Memr[sx+i-1] = Memr[sx+i-1] - left[i] + Memr[tx+i-1] = 1. - Memr[sx+i-1] + } + + # calculate the basis function + call apowkr (Memr[tx], 3, basis, npts) + do i = 1, npts { + basis[npts+i] = 1. + Memr[tx+i-1] * (3. + Memr[tx+i-1] * (3. - + 3. * Memr[tx+i-1])) + basis[2*npts+i] = 1. + Memr[sx+i-1] * (3. + Memr[sx+i-1] * (3. - + 3. * Memr[sx+i-1])) + } + call apowkr (Memr[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/surfit/sf_f1deval.x b/math/surfit/sf_f1deval.x new file mode 100644 index 00000000..01cb98d0 --- /dev/null +++ b/math/surfit/sf_f1deval.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure cv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real c1, c2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmr (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + call amulkr (Memr[sx], 2., Memr[sx], npts) + do i = 3, order { + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call asubr (Memr[pn], Memr[pnm2], Memr[pn], npts) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure cv_evleg (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real ri, ri1, ri2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmr (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call awsur (Memr[pn], Memr[pnm2], Memr[pn], npts, ri1, ri2) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure cv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coefficients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +real k1, k2 # normalizing constants + +int j +pointer sx, tx, index +pointer sp + +begin + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memr[sx+j-1] = Memr[sx+j-1] - Memi[index+j-1] + Memr[tx+j-1] = 1. - Memr[sx+j-1] + } + + # calculate yfit using the two non-zero basis function + call aclrr (yfit, npts) + do j = 1, npts + yfit[j] = Memr[tx+j-1] * coeff[1+Memi[index+j-1]] + + Memr[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure cv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coeffcients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (temp, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memr[sx+j-1] = Memr[sx+j-1] - Memi[index+j-1] + Memr[tx+j-1] = 1. - Memr[sx+j-1] + } + + # calculate yfit using the four non-zero basis function + call aclrr (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowkr (Memr[tx], 3, Memr[temp], npts) + case 2: + do j = 1, npts { + Memr[temp+j-1] = 1. + Memr[tx+j-1] * (3. + Memr[tx+j-1] * + (3. - 3. * Memr[tx+j-1])) + } + case 3: + do j = 1, npts { + Memr[temp+j-1] = 1. + Memr[sx+j-1] * (3. + Memr[sx+j-1] * + (3. - 3. * Memr[sx+j-1])) + } + case 4: + call apowkr (Memr[sx], 3, Memr[temp], npts) + } + + do j = 1, npts + Memr[temp+j-1] = Memr[temp+j-1] * coeff[i+Memi[index+j-1]] + call aaddr (yfit, Memr[temp], yfit, npts) + } + + # free space + call sfree (sp) +end diff --git a/math/surfit/sf_feval.x b/math/surfit/sf_feval.x new file mode 100644 index 00000000..58b2f765 --- /dev/null +++ b/math/surfit/sf_feval.x @@ -0,0 +1,280 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SF_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure sf_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, j +int ytorder, cptr +pointer sp +pointer xb, yb, accum +pointer ybzptr, ybptr, xbzptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call sf_bcheb (x, npts, xorder, k1x, k2x, Memr[xb]) + call sf_bcheb (y, npts, yorder, k1y, k2y, Memr[yb]) + + # clear the accumulator + call aclrr (zfit, npts) + + # accumulate the values + cptr = 0 + ybzptr = yb - 1 + xbzptr = xb - 1 + ytorder = yorder + + do i = 1, xorder { + call aclrr (Memr[accum], npts) + ybptr = ybzptr + do k = 1, ytorder { + do j = 1, npts + Memr[accum+j-1] = Memr[accum+j-1] + coeff[cptr+k] * + Memr[ybptr+j] + ybptr = ybptr + npts + } + do j = 1, npts + zfit[j] = zfit[j] + Memr[accum+j-1] * Memr[xbzptr+j] + + if (xterms == NO) + ytorder = 1 + + cptr = cptr + yorder + xbzptr = xbzptr + npts + } + + # free temporary space + call sfree (sp) +end + + +# SF_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure sf_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, j +int ytorder, cptr +pointer sp +pointer xb, yb, accum +pointer ybzptr, ybptr, xbzptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call sf_bleg (x, npts, xorder, k1x, k2x, Memr[xb]) + call sf_bleg (y, npts, yorder, k1y, k2y, Memr[yb]) + + # clear the accumulator + call aclrr (zfit, npts) + + # accumulate the values + cptr = 0 + ybzptr = yb - 1 + xbzptr = xb - 1 + ytorder = yorder + + do i = 1, xorder { + call aclrr (Memr[accum], npts) + ybptr = ybzptr + do k = 1, ytorder { + do j = 1, npts + Memr[accum+j-1] = Memr[accum+j-1] + coeff[cptr+k] * + Memr[ybptr+j] + ybptr = ybptr + npts + } + do j = 1, npts + zfit[j] = zfit[j] + Memr[accum+j-1] * Memr[xbzptr+j] + + if (xterms == NO) + ytorder = 1 + + cptr = cptr + yorder + xbzptr = xbzptr + npts + } + + # free temporary space + call sfree (sp) +end + + +# SF_EVSPLINE3 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure sf_evspline3 (coeff, x, y, zfit, npts, nxpieces, nypieces, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # array of coefficients +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of fitted values +int npts # number of data points +int nxpieces, nypieces # number of fitted points minus 1 +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, j, k, cindex +pointer xb, xbzptr, yb, ybzptr, ybptr +pointer accum, leftx, lefty +pointer sp + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, 4 * npts, TY_REAL) + call salloc (yb, 4 * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + call salloc (leftx, npts, TY_INT) + call salloc (lefty, npts, TY_INT) + + # calculate basis functions + call sf_bspline3 (x, npts, nxpieces, k1x, k2x, Memr[xb], Memi[leftx]) + call sf_bspline3 (y, npts, nypieces, k1y, k2y, Memr[yb], Memi[lefty]) + + # set up the indexing + call amulki (Memi[leftx], (nypieces+4), Memi[leftx], npts) + call aaddi (Memi[leftx], Memi[lefty], Memi[lefty], npts) + + # clear the accumulator + call aclrr (zfit, npts) + + # accumulate the values + + ybzptr = yb - 1 + xbzptr = xb - 1 + + do i = 1, 4 { + call aclrr (Memr[accum], npts) + ybptr = ybzptr + do k = 1, 4 { + do j = 1, npts { + cindex = k + Memi[lefty+j-1] + Memr[accum+j-1] = Memr[accum+j-1] + coeff[cindex] * + Memr[ybptr+j] + } + ybptr = ybptr + npts + } + do j = 1, npts + zfit[j] = zfit[j] + Memr[accum+j-1] * Memr[xbzptr+j] + + xbzptr = xbzptr + npts + call aaddki (Memi[lefty], (nypieces+4), Memi[lefty], npts) + } + + # free temporary space + call sfree (sp) +end + + +# SF_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure sf_evspline1 (coeff, x, y, zfit, npts, nxpieces, nypieces, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # array of coefficients +real x[npts] # array of x values +real y[npts] # array of y values +real zfit[npts] # array of fitted values +int npts # number of data points +int nxpieces, nypieces # number of fitted points minus 1 +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, j, k, cindex +pointer xb, xbzptr, yb, ybzptr, ybptr +pointer accum, leftx, lefty +pointer sp + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, 2 * npts, TY_REAL) + call salloc (yb, 2 * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + call salloc (leftx, npts, TY_INT) + call salloc (lefty, npts, TY_INT) + + # calculate basis functions + call sf_bspline1 (x, npts, nxpieces, k1x, k2x, Memr[xb], Memi[leftx]) + call sf_bspline1 (y, npts, nypieces, k1y, k2y, Memr[yb], Memi[lefty]) + + # set up the indexing + call amulki (Memi[leftx], (nypieces+2), Memi[leftx], npts) + call aaddi (Memi[leftx], Memi[lefty], Memi[lefty], npts) + + # clear the accumulator + call aclrr (zfit, npts) + + # accumulate the values + + ybzptr = yb - 1 + xbzptr = xb - 1 + + do i = 1, 2 { + call aclrr (Memr[accum], npts) + ybptr = ybzptr + do k = 1, 2 { + do j = 1, npts { + cindex = k + Memi[lefty+j-1] + Memr[accum+j-1] = Memr[accum+j-1] + coeff[cindex] * + Memr[ybptr+j] + } + ybptr = ybptr + npts + } + do j = 1, npts + zfit[j] = zfit[j] + Memr[accum+j-1] * Memr[xbzptr+j] + + xbzptr = xbzptr + npts + call aaddki (Memi[lefty], (nypieces+2), Memi[lefty], npts) + } + + # free temporary space + call sfree (sp) +end diff --git a/math/surfit/sfchomat.x b/math/surfit/sfchomat.x new file mode 100644 index 00000000..419fe777 --- /dev/null +++ b/math/surfit/sfchomat.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "surfitdef.h" +include + +# SFCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure sfchofac (matrix, nbands, nrows, matfac, ier) + +VAR_TYPE matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +VAR_TYPE matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +VAR_TYPE ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + # test to see if matrix is singular + if (((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= DELTA) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# SFCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# SFCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure sfchoslv (matfac, nbands, nrows, vector, coeff) + +VAR_TYPE matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +VAR_TYPE vector[nrows] # right side of matrix equation +VAR_TYPE coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/surfit/surfitdef.h b/math/surfit/surfitdef.h new file mode 100644 index 00000000..846109ea --- /dev/null +++ b/math/surfit/surfitdef.h @@ -0,0 +1,74 @@ +# set up the curve fitting structure + +define LEN_SFSTRUCT 35 + +define SF_TYPE Memi[$1] # Type of curve to be fitted +define SF_NXCOEFF Memi[$1+1] # Number of coefficients +define SF_XORDER Memi[$1+2] # Order of the fit in x +define SF_NXPIECES Memi[$1+3] # Number of x polynomial pieces - 1 +define SF_NCOLS Memi[$1+4] # Maximum x value +define SF_NXPTS Memi[$1+5] # Number of points in x +define SF_NYCOEFF Memi[$1+6] # Number of y coefficients +define SF_YORDER Memi[$1+7] # Order of the fit in y +define SF_NYPIECES Memi[$1+8] # Number of y polynomial pieces - 1 +define SF_NLINES Memi[$1+9] # Minimum x value +define SF_NYPTS Memi[$1+10] # Number of y points +define SF_XTERMS Memi[$1+11] # cross terms? + +define SF_XBASIS Memi[$1+12] # Pointer to the x basis functions +define SF_XLEFT Memi[$1+13] # Indices to x basis functions, spline +define SF_YBASIS Memi[$1+14] # Pointer to the y basis functions +define SF_YLEFT Memi[$1+15] # Indices to y basis functions, spline +define SF_XMATRIX Memi[$1+16] # Pointer to x data matrix +define SF_YMATRIX Memi[$1+17] # Pointer to y data matrix +define SF_XCOEFF Memi[$1+18] # X coefficient matrix +define SF_COEFF Memi[$1+19] # Pointer to coefficient vector + +define SF_XMIN Memr[P2R($1+20)] # Min x value +define SF_XMAX Memr[P2R($1+21)] # Max x value +define SF_XRANGE Memr[P2R($1+22)] # 2. / (xmax - xmin), polynomials +define SF_XMAXMIN Memr[P2R($1+23)] # - (xmax + xmin) / 2., polynomials +define SF_XSPACING Memr[P2R($1+24)] # order / (xmax - xmin), splines +define SF_YMIN Memr[P2R($1+25)] # Min y value +define SF_YMAX Memr[P2R($1+26)] # Max y value +define SF_YRANGE Memr[P2R($1+27)] # 2. / (ymax - ymin), polynomials +define SF_YMAXMIN Memr[P2R($1+28)] # - (ymax + ymin) / 2., polynomials +define SF_YSPACING Memr[P2R($1+29)] # order / (ymax - ymin), splines + +define SF_WZ Memi[$1+30] +define SF_TLEFT Memi[$1+31] + +# matrix and vector element definitions + +define XBASIS Memr[P2P($1)] # +define XBS Memr[P2P($1)] # +define YBASIS Memr[P2P($1)] # +define YBS Memr[P2P($1)] # +define XMATRIX Memr[P2P($1)] # +define XCHOFAC Memr[P2P($1)] # +define YMATRIX Memr[P2P($1)] # +define XCOEFF Memr[P2P($1)] # +define COEFF Memr[P2P($1)] # +define XLEFT Memi[$1] # +define YLEFT Memi[$1] # + +# structure definitions for the save restore functions + +define SF_SAVETYPE $1[1] +define SF_SAVEXORDER $1[2] +define SF_SAVEYORDER $1[3] +define SF_SAVEXTERMS $1[4] +define SF_SAVENCOLS $1[5] +define SF_SAVENLINES $1[6] +define SF_SAVECOEFF 6 + +# miscellaneous + +define SPLINE3_ORDER 4 +define SPLINE1_ORDER 2 + +# data type + +define MEM_TYPE TY_REAL +define VAR_TYPE real +define DELTA EPSILON -- cgit