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