IMPLICIT NONE

      DOUBLE PRECISION AS2R
      PARAMETER ( AS2R = 4.848136811095359935899141D-6 )

      DOUBLE PRECISION ASTROM(30)

      INTEGER J
      DOUBLE PRECISION PHI, ELONG, HM, PHPA, TC, RH, WL,
     :                 UTC1, UTC2, TAI1, TAI2, TT1, TT2, XP, YP, DUT1,
     :                 DX, DY, RC, DC, PR, PD, PX, RV,
     :                 EO, RI, DI, RCA, DCA, RA, DA,
     :                 AOT, ZOT, HOT, DOT, ROT, AOB, ZOB, HOB, DOB, ROB,
     :                 PVH(3,2), PVB(3,2), R(3,3), X, Y, S, B(8,3)

      DOUBLE PRECISION iau_ANP, iau_S06


*  Site longitude, latitude (radians) and height above the geoid (m).
      CALL iau_AF2A ( '-', 5, 41, 54.2D0, ELONG, J )
      IF ( J .NE. 0 ) STOP
      CALL iau_AF2A ( '-', 15, 57, 42.8D0, PHI, J )
      IF ( J .NE. 0 ) STOP
      HM = 625D0

*  Ambient pressure (HPa), temperature (C) and relative humidity (frac).
      PHPA = 952D0
      TC = 18.5D0
      RH = 0.83D0

*  Effective color (microns).
      WL = 0.55D0

*  UTC date.
      CALL iau_DTF2D ( 'UTC', 2013, 4, 2, 23, 15, 43.55D0,
     :                 UTC1, UTC2, J )
      IF ( J .NE. 0 ) STOP

*  TT date.
      CALL iau_UTCTAI ( UTC1, UTC2, TAI1, TAI2, J )
      IF ( J .NE. 0 ) STOP
      CALL iau_TAITT ( TAI1, TAI2, TT1, TT2, J )
      IF ( J .NE. 0 ) STOP

*  EOPs:  polar motion in radians, UT1-UTC in seconds.
      XP = 50.995D-3 * AS2R
      YP = 376.723D-3 * AS2R
      DUT1 = 155.0675D-3

*  Corrections to IAU 2000A CIP (radians).
      DX = 0.269D-3 * AS2R
      DY = -0.274D-3 * AS2R

*  Star ICRS RA,Dec (radians).
      CALL iau_TF2A ( ' ', 14, 34, 16.81183D0, RC, J )
      IF ( J .NE. 0 ) STOP
      CALL iau_AF2A ( '-', 12, 31, 10.3965D0, DC, J )
      IF ( J .NE. 0 ) STOP
      CALL REPRD ( 'ICRS, epoch J2000.0:', RC, DC )

*  Proper motion: RA/Dec derivatives, epoch J2000.0.
      PR = ATAN2 ( -354.45D-3 * AS2R, COS(DC) )
      PD = 595.35D-3 * AS2R

*  Parallax (arcsec) and recession speed (km/s).
      PX = 164.99D-3
      RV = 0D0

*  ICRS to CIRS (geocentric observer).
      CALL iau_ATCI13 ( RC, DC, PR, PD, PX, RV, TT1, TT2, RI, DI, EO )
      CALL REPRD ( 'catalog -> CIRS:', RI, DI )

*  CIRS to ICRS (astrometric).
      CALL iau_ATIC13 ( RI, DI, TT1, TT2, RCA, DCA, EO )
      CALL REPRD ( 'CIRS -> astrometric:', RCA, DCA )

*  ICRS (astrometric) to CIRS (geocentric observer).
      CALL iau_ATCI13 ( RCA, DCA, 0D0, 0D0, 0D0, 0D0, TT1, TT2,
     :                  RI, DI, EO )
      CALL REPRD ( 'astrometric -> CIRS:', RI, DI )

*  Apparent place.
      RA = iau_ANP ( RI - EO )
      DA = DI
      CALL REPRD ( 'geocentric apparent:', RA, DA )

*  CIRS to topocentric.
      CALL iau_ATIO13 ( RI, DI, UTC1, UTC2, DUT1, ELONG, PHI, HM,
     :                  XP, YP, 0D0, 0D0, 0D0, 0D0,
     :                  AOT, ZOT, HOT, DOT, ROT, J )
      IF ( J .NE. 0 ) STOP
      CALL REPRD ( 'CIRS -> topocentric:', ROT, DOT )

*  CIRS to observed.
      CALL iau_ATIO13 ( RI, DI, UTC1, UTC2, DUT1, ELONG, PHI, HM,
     :                  XP, YP, PHPA, TC, RH, WL,
     :                  AOB, ZOB, HOB, DOB, ROB, J )
      IF ( J .NE. 0 ) STOP
      CALL REPRD ( 'CIRS -> observed:', ROB, DOB )

*  ICRS to observed.
      CALL iau_ATCO13 ( RC, DC, PR, PD, PX, RV, UTC1, UTC2, DUT1,
     :                  ELONG, PHI, HM, XP, YP, PHPA, TC, RH, WL,
     :                  AOB, ZOB, HOB, DOB, ROB, EO, J )
      IF ( J .NE. 0 ) STOP
      CALL REPRD ( 'ICRS -> observed:', ROB, DOB )

*  ICRS to CIRS using some user-supplied parameters.

*  JPL DE405 barycentric Earth ephemeris.
      CALL iau_EPV00 ( TT1, TT2, PVH, PVB, J )
      IF ( J .NE. 0 ) STOP
      PVB(1,1) = -0.9741704366519668D0
      PVB(2,1) = -0.2115201000882231D0
      PVB(3,1) = -0.0917583114068277D0
      PVB(1,2) =  0.0036436589347388D0
      PVB(2,2) = -0.0154287318503146D0
      PVB(3,2) = -0.0066892203821059D0

*  IAU 2000A CIP.
      CALL iau_PNM00A ( TT1, TT2, R )
      CALL iau_BPN2XY ( R, X, Y )

*  Apply IERS corrections.
      X = X + DX
      Y = Y + DY

*  SOFA CIO locator.
      S = iau_S06 ( TT1, TT2, X, Y )

*  Populate the context.
      CALL iau_APCI ( TT1, TT2, PVB, PVH, X, Y, S, ASTROM )

*  Carry out the transformation and report the results.
      CALL iau_ATCIQ ( RC, DC, PR, PD, PX, RV, ASTROM, RI, DI )
      CALL REPRD ( 'ICRS -> CIRS (JPL, IERS):', RI, DI )

*  The same but with Saturn then Jupiter then Sun light deflection.

      B(1,1) = 0.00028574D0
      B(2,1) = 3D-10
      B(3,1) = -7.8101442680818964D0
      B(4,1) = -5.6095668114887358D0
      B(5,1) = -1.9807981923749924D0
      B(6,1) =  0.0030723248971152D0
      B(7,1) = -0.0040699547707598D0
      B(8,1) = -0.0018133584165345D0

      B(1,2) = 0.00095435D0
      B(2,2) = 3D-9
      B(3,2) =  0.7380987962351833D0
      B(4,2) =  4.6365869247538951D0
      B(5,2) =  1.9693136030111202D0
      B(6,2) = -0.0075581692172088D0
      B(7,2) =  0.0012691372216750D0
      B(8,2) =  0.0007279990012801D0

      B(1,3) = 1D0
      B(2,3) = 6D-6
      B(3,3) = -0.0007121743770509D0
      B(4,3) = -0.0023047830339257D0
      B(5,3) = -0.0010586596574639D0
      B(6,3) =  0.0000062923521264D0
      B(7,3) = -0.0000003308883872D0
      B(8,3) = -0.0000002964866231D0

      CALL iau_ATCIQN ( RC, DC, PR, PD, PX, RV, ASTROM, 3, B, RI, DI )
      CALL REPRD ( 'ICRS -> CIRS (+ planets):', RI, DI )

*  CIRS to ICRS (astrometric).
      CALL iau_ATICQN ( RI, DI, ASTROM, 3, B, RCA, DCA )
      CALL REPRD ( 'CIRS -> astrometric:', RCA, DCA )

      END

      SUBROUTINE REPRD ( S, RA, DC )
      IMPLICIT NONE
      CHARACTER *(*) S
      DOUBLE PRECISION RA, DC

      CHARACTER PM
      INTEGER IHMSF(4), IDMSF(4)

      CALL iau_A2TF ( 7, RA, PM, IHMSF )
      CALL iau_A2AF ( 6, DC, PM, IDMSF )
      WRITE ( *, '(A25,3I3.2,''.'',I7.7,1X,A,I2.2,2I3.2,''.'',I6.6)' )
     :                                           S, IHMSF, PM, IDMSF

      END