C       ===============================================
        SUBROUTINE FINDIS95( Iopt, OutCut, Cand, Ierr )
C       ===============================================
C
C       Author       Ralph Sinkus
C       Modified     G. Briskin
c                    Option 4 added
c       Modified     A. Lopez-Duran, O.Ruske, S. Schlensted
c                    Found bug in option 4, and fixed it
c       Modified     A.Lopez-Duran
c                    Option 5 added
c
C...    Routine for siNISTra
C...    Finds among candidates stored in CANDAT the DIS e-
c
C       INPUT :
c
c...    Iopt = 1  <-> candidate with highest probability from siNISTra.
c...                  If 2 or more candidates have the same probability,
c...                  the one with highest energy is going to be picked up
c...                  as the DIS e-
c...                  !!! Candidates with Yel>0.99 are NOT considered. !!!!
c
c...         = 2  <-> candidate with highest E
c
c...         = 3  <-> candidate with highest Pt
c
c...         = 4  <-> candidate with highest probability from siNISTra.
c...                  If 2 or more candidates have the same probability,
c...                  the one with highest energy is going to be picked up
c...                  as the DIS e-. (doVCTDCA has to be set .TRUE. in SIDAT95)
c...                  !!! Candidates with Yel>0.99 are NOT considered. !!!!
c...                  !!! Candidates in BCAL, FCAL(Re>70) and RCAL(Re>50) which
c...                      DO NOT have a track pointing to it are NOT considered !!!
c...
c...         = 5  <-> same as option 4, but track region calculated using the
c...                  event vertex instead of z vertex = 0.0
c
c       OutCut = 0.9   <> Cut in probability of NN. This value is recommended
c
c
c       OUTPUT :
c
c...   Cand           <> Number of candidate which is supposed to be the DIS e-
c...    Ierr = 0       <> No error
c...         = 1       <> WARNING !!!!!!!!!!!!!!!!
c...
#include "partap.inc"
#include "sidat95.inc"
#include "vctvtx.inc"

      INTEGER Iopt,Cand,Ierr
      REAL    OutMax, Emax, PtMax, Pt, OutCut
      REAL    Yel
      INTEGER I,K,NoutMax
      logical first
      data    first /.true./
*-->  initial energy of e+ and other stuff
      Real       eE0
      Parameter( eE0=27.52 )

      Real       twoeE0
      PARAMETER( twoeE0 = 2.0*eE0 )

      Real       eE,eY,eX,eZ,eR
      Real       Zvtx
      Logical    LGOOD
*
* Variables for option 5
* -------------------------------------------------
      real       vz, d_FCal, d_RCal, r_FCal, r_RCal
      real       line, point
*
*                 3 super layers  4 super layers
      real        t_slay,         f_slay,
*                 f side of CTD   r side of CTD
     &            f_ctd ,         r_ctd ,
*                 distance to FCal, RCal
     &            f_cal ,         r_cal ,
*                 radius of BCal
     &            r_BCal,
     &            f_rat ,         r_rat
*
      parameter ( t_slay = 35.,   f_slay = 45.4,
     &            f_ctd  = 106.,  r_ctd  = 101.,
     &            f_cal  = 226.1, r_cal  = 152.1,
     &            r_BCal = 125.6)
* -------------------------------------------------
*
c...    Initialize
      Cand    = 0
      Ierr    = 0
      NoutMin = 0
      Emax    = 0.0
      PtMax   = 0.0

      if(first)then
         first =.false.
       WRITE(6,*) '**********************************'
       WRITE(6,*) '* This is findis95   Version 2.0 *'
       WRITE(6,*) '*   This version includes        *'
       WRITE(6,*) '*   options 4 and 5              *'
       WRITE(6,*) '**********************************'
      endif
C...    check for negative OutCut
      IF ( OutCut.LT.0.0 ) THEN
       WRITE(6,*) '**********************************'
       WRITE(6,*) '* This is siNISTra95 Version 1.1 *'
       WRITE(6,*) '*   Probability definition has   *'
       WRITE(6,*) '*   changed !                    *'
       WRITE(6,*) '*   Electromagnetic objects      *'
       WRITE(6,*) '*   populate now the probability *'
       WRITE(6,*) '*   region close to one !        *'
       WRITE(6,*) '*   Chose OutCut = 0.9 !         *'
       WRITE(6,*) '* Program stopped by siNISTra95  *'
       WRITE(6,*) '**********************************'
       STOP '---- Program aborted by siNISTra95 ----'
      EndIf

C...    No candidates available
      If ( Ncand.EQ.0 ) GOTO 1000

*-->  VC - Reconstructed Vertex....................
      If ( CouTab(VCTVTX).GT.0 ) Then
       Call FetTab(VCTVTX,ID,1)
       Zvtx = VCTVTX_V(3)
      Else
       Zvtx = 0.0
      EndIf

*-->  Check if the Vertex is cosher, a la elecpo
      If (Zvtx.LT.-148. .OR. Zvtx.GT.235.) Then
       Zvtx = 0.0
      EndIf

      IF ( Iopt.EQ.1 ) THEN
C...     find highest probability among candidates with OUT values above OutCut
       OutMax = -1.0
       Do I=1,Ncand
        eE  = CANDAT(2,I)
        eX  = CANDAT(3,I)
        eY  = CANDAT(4,I)
        eZ  = CANDAT(5,I) - Zvtx
        Yel = 1. -  (eE/twoeE0) *
     &       (1. - eZ/Sqrt(eX**2+eY**2+eZ**2))

        IF ( CANDAT(1,I) .GE. OutCut .AND.
     &       Yel.LT.0.99             .AND.
     &       CANDAT(1,I) .GT. OutMax
     &       ) OutMax = CANDAT(1,I)
       EndDo
C...      found at least a candidate ?
       IF ( OutMax.EQ.-1.0 ) RETURN

C...      how often does this maximal out values appear ?
       DO I=1,Ncand
        IF ( CANDAT(1,I) .EQ. Outmax ) NoutMax = NoutMax + 1
       END DO
       IF ( NoutMax .EQ. 1 ) THEN
        DO I=1,Ncand
         IF ( CANDAT(1,I) .EQ. OutMax ) Cand = I
        END DO
       ELSE
C...        find among those candidates the one with highest E
        DO I=1,Ncand
         IF ( OutMax .EQ. CANDAT(1,I) .AND.
     &        Emax   .LT. CANDAT(2,I)
     &        ) Emax = CANDAT(2,I)
        END DO
        DO I=1,Ncand
         IF ( CANDAT(2,I) .EQ. Emax ) Cand = I
        END DO
       END IF

      ELSE IF ( Iopt .EQ. 2 ) THEN
       DO I=1,Ncand
        IF ( CANDAT(1,I).GE.OutCut .AND.
     &       Emax .LT. CANDAT(2,I)
     &       ) THEN
         Emax = CANDAT(2,I)
         Cand = I
        END IF
       END DO

      ElseIf ( Iopt .EQ. 3 ) Then

       DO I=1,Ncand
        IF ( CANDAT(1,I).GE.OutCut ) THEN
         Pt = CANDAT(2,I) * ( (CANDAT(3,I)**2+CANDAT(4,I)**2) /
     &        (CANDAT(3,I)**2+CANDAT(4,I)**2+CANDAT(5,I)**2)
     &        )**0.5
         IF ( Ptmax .LT. Pt ) THEN
          Ptmax = Pt
          Cand  = I
         END IF
        END IF
       END DO

      ElseIf (Iopt.EQ.4.AND.doVCTDCA) Then

C...      find highest probability among candidates with OUT values above OutCut
       OutMax = -1.0
       Do I=1,Ncand

        eE  = CANDAT(2,I)
        eX  = CANDAT(3,I)
        eY  = CANDAT(4,I)
        eZ  = CANDAT(5,I)
        eR  = Sqrt(eX**2+eY**2)

        LGOOD = .TRUE.

        If ( CANDAT(15,I).EQ.0 ) Then
           If( eZ.LT.0. ) then
              if( eR.GT.50. ) LGOOD=.FALSE.
           else
              if( eR.GT.70. ) LGOOD=.FALSE.
           endif
        endif

        eZ  = eZ - Zvtx
        Yel = 1. -  (eE/twoeE0) *
     &       (1. - eZ/Sqrt(eX**2+eY**2+eZ**2))

        If (Yel.LT.0.99.AND.LGOOD) Then
         If(CANDAT(1,I).GE.OutCut.AND.CANDAT(1,I).GT.OutMax)Then
          OutMax = CANDAT(1,I)
         EndIf
        EndIf

       EndDo

C...      found at least a candidate ?
       If ( OutMax.EQ.-1.0 ) Return

C...      how often does this maximal out values appear ?
       Do I=1,Ncand
        If (CANDAT(1,I).EQ.Outmax) NoutMax = NoutMax + 1
       EndDo

       If ( NoutMax .EQ. 1 ) Then

        Do I=1,Ncand
         If (CANDAT(1,I).EQ.OutMax) Then
          Cand = I
          Return
         EndIf
        EndDo

       Else
*==>    Find among those candidates the one with highest E
        Do I=1,Ncand
         If(CANDAT(1,I).EQ.OutMax.AND.Emax.LT.CANDAT(2,I))Then
          Emax = CANDAT(2,I)
          Cand = I
         EndIf
        EndDo

       EndIf

      ElseIf ( Iopt.EQ.5.AND.doVCTDCA) Then

C... FINDIS option 5
C
         OutMax = -1.0
         Do I=1,Ncand
* Cand position
            eE  = CANDAT(2,I)
            eX  = CANDAT(3,I)
            eY  = CANDAT(4,I)
            eZ  = CANDAT(5,I)
            eR  = Sqrt(eX**2+eY**2)
            vz  = zvtx
* Correct distance to cal. with vertex
            d_FCal = f_cal - vz
            d_Rcal = r_cal + vz
* Ini. flag
            LGOOD  = .TRUE.
            If ( CANDAT(15,I).EQ.0 ) Then
* If cand. no track
               If     ( eZ.LT.-140. ) then                 !e in RCal
* Calculate track region for RCal
                  r_rat  = f_slay / (r_ctd + vz)
                  r_Rcal = d_Rcal * r_rat
* Look if vtx inside CTD and electron in track region
                  if( eR.GT. r_RCal .and.
     &                vz.gt.-r_ctd) LGOOD=.FALSE.
               elseif ( eZ.GT. 220. ) then                 !e in FCal
* Calculate track region for FCal
                  f_rat  = f_slay / (f_ctd - vz)
                  r_Fcal = d_Fcal * f_rat
* Look if vtx inside CTD and electron in track region
                  if( eR.GT. r_FCal .and.
     &                 vz.lt. f_ctd) LGOOD=.FALSE.
               else                                        !e in BCal
                  if( vz.lt.f_ctd.and.vz.gt.-r_ctd)then    !vtx inside CTD
* If electron in BCal and electron position and vtx in CTD region, always track
                     if( eZ.lt.f_ctd.and.eZ.gt.-r_ctd)then !z inside CTD
                        LGOOD = .FALSE.
                     else                                  !z outside CTD
                        if(eZ.lt.vz)then                   !z position wrt vtx
* Calculate intercept point between vtx-electron and CTD
                           line   = R_ctd
                           point  = r_BCal * ( line + vz) / (vz - eZ)
* If intercept point greater than 5 superlayers, electron in CTD region
                           if (point.gt.f_slay) LGOOD = .FALSE.
                        else
                           line   = f_ctd
                           point  = r_BCal * ( line - vz) / (eZ - vZ)
                           if (point.gt.f_slay) LGOOD = .FALSE.
                        endif
                     endif
                  else                                      !vtx outside CTD
                     write(6,*)'This is findis95 option 5'
                     write(6,*)'WARNING!!!, vtx outside CTD'
                     write(6,*)'Do not trust the result!!!!'
                     if(vz.gt.f_ctd.and.vz.gt.eZ)then
                        line   = f_ctd
                        point  = r_BCal * ( line + vz) / (vz - eZ)
                        if (point.lt.f_slay) LGOOD = .FALSE.
                     elseif(vz.lt.-r_ctd.and.vz.lt.eZ)then
                        line   = r_ctd
                        point  = r_BCal * ( line - vz) / (eZ - vz)
                        if (point.lt.f_slay) LGOOD = .FALSE.
                     endif
                  endif
               endif
            endif
* Continue as other options
        eZ  = eZ - Zvtx
        Yel = 1. -  (eE/twoeE0) *
     &       (1. - eZ/Sqrt(eX**2+eY**2+eZ**2))

        If (Yel.LT.0.99.AND.LGOOD) Then
         If(CANDAT(1,I).GE.OutCut.AND.CANDAT(1,I).GT.OutMax)Then
          OutMax = CANDAT(1,I)
         EndIf
        EndIf

       EndDo

C...      found at least a candidate ?
       If ( OutMax.EQ.-1.0 ) Return

C...      how often does this maximal out values appear ?
       Do I=1,Ncand
        If (CANDAT(1,I).EQ.Outmax) NoutMax = NoutMax + 1
       EndDo

       If ( NoutMax .EQ. 1 ) Then

        Do I=1,Ncand
         If (CANDAT(1,I).EQ.OutMax) Then
          Cand = I
          Return
         EndIf
        EndDo

       Else
*==>    Find among those candidates the one with highest E
        Do I=1,Ncand
         If(CANDAT(1,I).EQ.OutMax.AND.Emax.LT.CANDAT(2,I))Then
          Emax = CANDAT(2,I)
          Cand = I
         EndIf
        EndDo

       EndIf

      Else
       Write(6,*) 'FINDIS95: Option not yet implemented'
      EndIf

 1000 CONTINUE

      RETURN
      END


      subroutine dead_material_energy(EnergyOut,EnergyIn,cal,srtd,pres
     $     ,montecarlo,mode,scalefactor)

C
C  Gives the presampler or srtd corrected energy for the electron
C
C  Input:
C     real EnergyIn = Energy of electron before presampler or
C                     SRTD corrections. This may be the same or different from
C                     cal(4) depending on if other (non-uniformity) corrections
C                     have been applied.
C
C     real cal(4):
C       cal(1) = elecpo X of electron (not used)
C       cal(2) = elecpo Y of electron (not used)
C       cal(3) = elecpo Z of electron
C       cal(4) = Cal energy (not used)
C
C     real srtd(4):
C      srtd(1) = srtd X
C      srtd(2) = srtd Y
C      srtd(3) = srtd Z (not used)
C      srtd(4) = mips from SRTDELEC (sum of x and y planes)
C
C     real pres = presampler mips sum from  3x3 tiles.
C         This is the second element of the presampler array from prclus.
C
C     integer mode = way to perform correction for systematic checks
C         mode = 0  Apply nominal correction
C         mode = 1  Shift data correction up by systematic error and
C                         mc down by systematic error.
C         mode = 2  Shift data correction down by systematic error and
C                         mc up by systematic error.
C
C     Logical Montecarlo = True if montecarlo. False if data.
C
C  Output:
C     real EnergyOut = Electron energy after presampler or SRTD corrections.
C
C
C     Version 1.1  July 7, 1998 Mike Wodarczyk
C         Changed the presampler and SRTD correction values. (code is the same).
C         The new values are based on KP and compton corrections fitting the
C         peak of (Cal+corr*mips) / Predicted and choosing corr so the peak=1.
C
      implicit none
	real scalefactor
      real EnergyOut,EnergyIn
      real cal(4),srtd(4), pres
      logical montecarlo
      integer mode

      integer whatToUse
      integer useCAL, useSRTD, usePRES
      parameter ( useCAL    = 1 )
      parameter ( useSRTD   = 2 )
      parameter ( usePRES   = 3 )

      real MAXMIP
      PARAMETER ( MAXMIP = 1000. ) ! stay away from high default values.

      real McSrtdCorr
      parameter ( McSrtdCorr = 0.039 )
      real DataSrtdCorr
      parameter ( DataSrtdCorr = 0.039 )
      real McSrtdCorrErr
      parameter ( McSrtdCorrErr = 0.005 )
      real DataSrtdCorrErr
      parameter ( DataSrtdCorrErr = 0.005 )

      real McPresCorr
      parameter ( McPresCorr = 0.0790 )
      real DataPresCorr
      parameter ( DataPresCorr = 0.0654 )
      real McPresCorrErr
      parameter ( McPresCorrErr = 0.005 )
      real DataPresCorrErr
      parameter ( DataPresCorrErr = 0.005 )

      real SRTDedge
C     Use SRTD away from the edge by SRTDedge cm
      parameter ( SRTDedge = 2.0 )

      real PresCorr,SRTDCorr, PresErr, SRTDErr

      if ( montecarlo) then
         PresCorr = McPresCorr
         SRTDCorr = McSRTDCorr
C  for MC systematic, shift the correction the opposite way relative to
C     the data shift.
         PresErr  = -1.*McPresCorrErr
         SRTDErr  = -1.*McSRTDCorrErr
      else
         PresCorr = DataPresCorr
         SRTDCorr = DataSRTDCorr
         PresErr  = DataPresCorrErr
         SRTDErr  = DataSRTDCorrErr
      endif

      if ( mode.eq. 1) then
         PresCorr = PresCorr + PresErr
         SRTDCorr = SRTDCorr + SRTDErr
      else if ( mode .eq. 2) then
         PresCorr = PresCorr - PresErr
         SRTDCorr = SRTDCorr - SRTDErr
      else if (mode .ne. 0) then
         write(*,*) 'Error in dead_material_energy.'
         write(*,*) ' Mode = ',WhatToUse
         stop
      endif

      WhatToUse = UseCAL

C -------------------------------
C  See if we can use Presampler
C
C  Require an RCAL electron that it has mips in valid range
C  I saw no events between 0 and 0.025 mips in data.  I use
C  0.025 as a lower cut off so there are no "0" rounding problems.
C -------------------------------
      if ( cal(3).lt.-140 .and. pres.gt.0.025 .and. pres.lt.MAXMIP) then
         WhatToUse  = UsePRES
      endif

C -------------------------------
C  See if we can use SRTD
C
C  require an cal position to be in RCAL and the SRTD mips to be o.k.
C  then require that the electron is within SRTDedge cm of the srtd edge.
C
C -------------------------------
      if ( cal(3).lt.-140 .and.srtd(4).gt.0.4.and.srtd(4).lt.MAXMIP )
     $     then
         if (srtd(1).gt.(-34+srtdedge).and.srtd(1).lt.(34-srtdedge).and
     $        .(srtd(1).gt.(-10-srtdedge).and.srtd(2).gt.(-28+srtdedge)
     $        .or.srtd(1).le.(-10-srtdedge).and.srtd(2).gt.-40+srtdedge)
     $        .and.(srtd(1).ge.(10+srtdedge).and.srtd(2).lt.(40-srtdedge
     $        ).or.srtd(1).lt.(10+srtdedge).and.srtd(2).lt.28-srtdedge)
     $        )then
            WhatToUse = UseSRTD
         endif
      endif

      if (WhatToUse .eq. useCal) then
         EnergyOut = EnergyIn         ! by default use the cal
      else if (WhatToUse .eq. usePres) then
         if (montecarlo) then
            EnergyOut = EnergyIn + pres*McPresCorr*scalefactor
         else
            EnergyOut = EnergyIn + pres*DataPresCorr*scalefactor
         endif
      else if (WhatToUse .eq. useSRTD) then
         if (montecarlo) then
            EnergyOut = EnergyIn + srtd(4)*McSrtdCorr*scalefactor
         else
            EnergyOut = EnergyIn + srtd(4)*DataSrtdCorr*scalefactor
         endif
      else
         write(*,*) 'Error in dead_material_energy.  coding error.'
         write(*,*) ' WhatToUse = ',WhatToUse
         stop
      endif

      return
      end


C$Procedure ZZSPKGO0 ( S/P Kernel, geometric state )

      SUBROUTINE ZZSPKGO0 ( TARG, ET, REF, OBS, STATE, LT )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Compute the geometric state (position and velocity) of a target
C     body relative to an observing body.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'ninert.inc'
      INCLUDE               'zzctr.inc'

      INTEGER               TARG
      DOUBLE PRECISION      ET
      CHARACTER*(*)         REF
      INTEGER               OBS
      DOUBLE PRECISION      STATE    ( 6 )
      DOUBLE PRECISION      LT

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     TARG       I   Target body.
C     ET         I   Target epoch.
C     REF        I   Target reference frame.
C     OBS        I   Observing body.
C     STATE      O   State of target.
C     LT         O   Light time.
C
C$ Detailed_Input
C
C     TARG        is the standard NAIF ID code for a target body.
C
C     ET          is the epoch (ephemeris time) at which the state
C                 of the target body is to be computed.
C
C     REF         is the name of the reference frame to
C                 which the vectors returned by the routine should
C                 be rotated. This may be any frame supported by
C                 the SPICELIB subroutine ZZFRMCH0.
C
C     OBS         is the standard NAIF ID code for an observing body.
C
C$ Detailed_Output
C
C     STATE       contains the geometric position and velocity of the
C                 target body, relative to the observing body, at epoch
C                 ET. STATE has six elements: the first three contain
C                 the target's position; the last three contain the
C                 target's velocity. These vectors are transformed into
C                 the specified reference frame. Units are always km
C                 and km/sec.
C
C     LT          is the one-way light time in seconds from the
C                 observing body to the geometric position of the
C                 target body at the specified epoch.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If insufficient ephemeris data has been loaded to compute
C        the necessary states, the error SPICE(SPKINSUFFDATA) is
C        signaled.
C
C$ Files
C
C     See: $Restrictions.
C
C$ Particulars
C
C     ZZSPKGO0 computes the geometric state, T(t), of the target
C     body and the geometric state, O(t), of the observing body
C     relative to the first common center of motion.  Subtracting
C     O(t) from T(t) gives the geometric state of the target
C     body relative to the observer.
C
C
C        CENTER ----- O(t)
C            |      /
C            |     /
C            |    /
C            |   /  T(t) - O(t)
C            |  /
C           T(t)
C
C
C     The one-way light time, tau, is given by
C
C
C               | T(t) - O(t) |
C        tau = -----------------
C                      c
C
C
C     For example, if the observing body is -94, the Mars Observer
C     spacecraft, and the target body is 401, Phobos, then the
C     first common center is probably 4, the Mars Barycenter.
C     O(t) is the state of -94 relative to 4 and T(t) is the
C     state of 401 relative to 4.
C
C     The center could also be the Solar System Barycenter, body 0.
C     For example, if the observer is 399, Earth, and the target
C     is 299, Venus, then O(t) would be the state of 399 relative
C     to 0 and T(t) would be the state of 299 relative to 0.
C
C     Ephemeris data from more than one segment may be required
C     to determine the states of the target body and observer
C     relative to a common center.  ZZSPKGO0 reads as many segments
C     as necessary, from as many files as necessary, using files
C     that have been loaded by previous calls to SPKLEF (load
C     ephemeris file).
C
C     ZZSPKGO0 is similar to SPKEZ but returns geometric states
C     only, with no option to make planetary (light-time) nor
C     stellar aberration corrections.  The geometric states
C     returned by SPKEZ and ZZSPKGO0 are the same.
C
C$ Examples
C
C     The following code example computes the geometric
C     state of the moon with respect to the earth and
C     then prints the distance of the moon from the
C     the earth at a number of epochs.
C
C     Assume the SPK file SAMPLE.BSP contains ephemeris data
C     for the moon relative to earth over the time interval
C     from BEGIN to END.
C
C            INTEGER               EARTH
C            PARAMETER           ( EARTH = 399 )
C
C            INTEGER               MOON
C            PARAMETER           ( MOON  = 301 )
C
C            INTEGER               N
C            PARAMETER           ( N     = 100 )
C
C            INTEGER               I
C            CHARACTER*(20)        UTC
C            DOUBLE PRECISION      BEGIN
C            DOUBLE PRECISION      DELTA
C            DOUBLE PRECISION      END
C            DOUBLE PRECISION      ET
C            DOUBLE PRECISION      LT
C            DOUBLE PRECISION      STATE ( 6 )
C
C            DOUBLE PRECISION      VNORM
C
C     C
C     C      Load the binary SPK ephemeris file.
C     C
C            CALL FURNSH ( 'SAMPLE.BSP' )
C
C            .
C            .
C            .
C
C     C
C     C      Divide the interval of coverage [BEGIN,END] into
C     C      N steps.  At each step, compute the state, and
C     C      print out the epoch in UTC time and position norm.
C     C
C            DELTA = ( END - BEGIN ) / N
C
C            DO I = 0, N
C
C               ET = BEGIN + I*DELTA
C
C               CALL ZZSPKGO0 ( MOON, ET, 'J2000', EARTH, STATE, LT )
C
C               CALL ET2UTC ( ET, 'C', 0, UTC )
C
C               WRITE (*,*) UTC, VNORM ( STATE )
C
C            END DO
C
C$ Restrictions
C
C     1) SPICE Private routine.
C
C     2) The ephemeris files to be used by ZZSPKGO0 must be loaded
C        by SPKLEF before ZZSPKGO0 is called.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman  (JPL)
C     J.E. McLean   (JPL)
C     B.V. Semenov  (JPL)
C     W.L. Taber    (JPL)
C     W.D. Wright   (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 08-JAN-2014 (BVS)
C
C        Updated to save the input frame name and POOL state counter
C        and to do frame name-ID conversion only if the counter has
C        changed.
C
C        Updated to map the input frame name to its ID by first calling
C        ZZNAMFRM, and then calling IRFNUM. The side effect of this
C        change is that now the frame with the fixed name 'DEFAULT'
C        that can be associated with any code via CHGIRF's entry point
C        IRFDEF will be fully masked by a frame with indentical name
C        defined via a text kernel. Previously the CHGIRF's 'DEFAULT'
C        frame masked the text kernel frame with the same name.
C
C        Fixed description of STATE in Detailed Output. Replaced
C        SPKLEF with FURNSH and fixed errors in Examples.
C
C-    SPICELIB Version 1.1.0, 06-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADDG calls.
C
C-    SPICELIB Version 1.0.0, 05-JAN-2005 (NJB)
C
C        Based on SPICELIB Version 2.3.0, 05-JAN-2005 (NJB)
C
C-&

C$ Index_Entries
C
C     geometric state of one body relative to another
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 06-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADDG calls.
C
C-&

C
C     This is the idea:
C
C     Every body moves with respect to some center. The center
C     is itself a body, which in turn moves about some other
C     center.  If we begin at the target body (T), follow
C     the chain,
C
C                                   T
C                                     \
C           SSB                        \
C               \                     C[1]
C                \                     /
C                 \                   /
C                  \                 /
C                   \               /
C                  C[3]-----------C[2]
C
C     and avoid circular definitions (A moves about B, and B moves
C     about A), eventually we get the state relative to the solar
C     system barycenter (which, for our purposes, doesn't move).
C     Thus,
C
C        T    = T     + C[1]     + C[2]     + ... + C[n]
C         SSB    C[1]       C[2]       [C3]             SSB
C
C     where
C
C        X
C         Y
C
C     is the state of body X relative to body Y.
C
C     However, we don't want to follow each chain back to the SSB
C     if it isn't necessary.  Instead we will just follow the chain
C     of the target body and follow the chain of the observing body
C     until we find a common node in the tree.
C
C     In the example below, C is the first common node.  We compute
C     the state of TARG relative to C and the state of OBS relative
C     to C, then subtract the two states.
C
C                                   TARG
C                                     \
C           SSB                        \
C               \                       A
C                \                     /            OBS
C                 \                   /              |
C                  \                 /               |
C                   \               /                |
C                    B-------------C-----------------D
C
C

C
C
C     SPICELIB functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

      DOUBLE PRECISION      CLIGHT
      DOUBLE PRECISION      VNORM

      INTEGER               FRSTNP
      INTEGER               ISRCHI

C
C     Local parameters
C
      CHARACTER*(*)         RNAME
      PARAMETER           ( RNAME  =  'ZZSPKGO0' )

C
C     CHLEN is the maximum length of a chain.  That is,
C     it is the maximum number of bodies in the chain from
C     the target or observer to the SSB.
C
      INTEGER               CHLEN
      PARAMETER           ( CHLEN = 20 )

      INTEGER               SSB
      PARAMETER           ( SSB   =  0 )

C
C     Saved frame name length.
C
      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN = 32 )

C
C     Local variables
C
      CHARACTER*(40)        IDENT
      CHARACTER*(40)        TNAME
      CHARACTER*(40)        ONAME
      CHARACTER*(80)        TSTRING

      DOUBLE PRECISION      DESCR  ( 5        )
      DOUBLE PRECISION      SOBS   ( 6        )
      DOUBLE PRECISION      STARG  ( 6, CHLEN )
      DOUBLE PRECISION      STEMP  ( 6        )

      DOUBLE PRECISION      STXFRM ( 6, 6     )
      DOUBLE PRECISION      ROT    ( 3, 3     )
      DOUBLE PRECISION      VTEMP  ( 6        )

      INTEGER               CFRAME
      INTEGER               COBS
      INTEGER               CTARG  (    CHLEN )
      INTEGER               TFRAME (    CHLEN )
      INTEGER               CTPOS
      INTEGER               HANDLE
      INTEGER               I
      INTEGER               LEGS
      INTEGER               NCT
      INTEGER               REFID
      INTEGER               TMPFRM

      LOGICAL               FOUND
      LOGICAL               NOFRM
      LOGICAL               ISINRT

C
C     Saved frame name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(FRNMLN)    SVREF
      INTEGER               SVREFI

      LOGICAL               FIRST

C
C     Saved frame name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVREF
      SAVE                  SVREFI

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

C
C     In-line Function Definitions
C
      ISINRT ( TMPFRM, CFRAME ) =       CFRAME .GT. 0
     .                            .AND. CFRAME .LE. NINERT
     .                            .AND. TMPFRM .GT. 0
     .                            .AND. TMPFRM .LE. NINERT

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( RNAME )
      END IF

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

C
C     We take care of the obvious case first.  It TARG and OBS are the
C     same we can just fill in zero.
C
      IF ( TARG .EQ. OBS ) THEN

         LT = 0.0D0

         CALL CLEARD ( 6, STATE )
         CALL CHKOUT ( RNAME )
         RETURN

      END IF

C
C     CTARG contains the integer codes of the bodies in the
C     target body chain, beginning with TARG itself and then
C     the successive centers of motion.
C
C     STARG(1,I) is the state of the target body relative
C     to CTARG(I).  The id-code of the frame of this state is
C     stored in TFRAME(I).
C
C     COBS and SOBS will contain the centers and states of the
C     observing body.  (They are single elements instead of arrays
C     because we only need the current center and state of the
C     observer relative to it.)
C
C     First, we construct CTARG and STARG.  CTARG(1) is
C     just the target itself, and STARG(1,1) is just a zero
C     vector, that is, the state of the target relative
C     to itself.
C
C     Then we follow the chain, filling up CTARG and STARG
C     as we go.  We use SPKSFS to search through loaded
C     files to find the first segment applicable to CTARG(1)
C     and time ET.  Then we use SPKPVN to compute the state
C     of the body CTARG(1) at ET in the segment that was found
C     and get its center and frame of motion (CTARG(2) and TFRAME(2).
C
C     We repeat the process for CTARG(2) and so on, until
C     there is no data found for some CTARG(I) or until we
C     reach the SSB.
C
C     Next, we find centers and states in a similar manner
C     for the observer.  It's a similar construction as
C     described above, but I is always 1.  COBS and SOBS
C     are overwritten with each new center and state,
C     beginning at OBS.  However, we stop when we encounter
C     a common center of motion, that is when COBS is equal
C     to CTARG(I) for some I.
C
C     Finally, we compute the desired state of the target
C     relative to the observer by subtracting the state of
C     the observing body relative to the common node from
C     the state of the target body relative to the common
C     node.
C
C     CTPOS is the position in CTARG of the common node.
C
C     Since the upgrade to use hashes and counter bypass ZZNAMFRM
C     became more efficient in looking up frame IDs than IRFNUM. So the
C     original order of calls "IRFNUM first, NAMFRM second" was
C     switched to "ZZNAMFRM first, IRFNUM second".
C
C     The call to IRFNUM, now redundant for built-in inertial frames,
C     was preserved to for a sole reason -- to still support the
C     ancient and barely documented ability for the users to associate
C     a frame with the fixed name 'DEFAULT' with any CHGIRF inertial
C     frame code via CHGIRF's entry point IRFDEF.
C
C     Note that in the case of ZZNAMFRM's failure to resolve name and
C     IRFNUM's success to do so, the code returned by IRFNUM for
C     'DEFAULT' frame is *not* copied to the saved code SVREFI (which
C     would be set to 0 by ZZNAMFRM) to make sure that on subsequent
C     calls ZZNAMFRM does not do a bypass (as SVREFI always forced look
C     up) and calls IRFNUM again to reset the 'DEFAULT's frame ID
C     should it change between the calls.
C
      CALL ZZNAMFRM ( SVCTR1, SVREF, SVREFI, REF, REFID )

      IF ( REFID .EQ. 0 ) THEN
         CALL IRFNUM ( REF, REFID )
      END IF

      IF ( REFID .EQ. 0 ) THEN

         IF (  FRSTNP(REF) .GT. 0 ) THEN

            CALL SETMSG ( 'The string supplied to specify the '
     .      //            'reference frame, (''#'') contains '
     .      //            'non-printing characters.  The two '
     .      //            'most common causes for this kind '
     .      //            'of error are: 1. an error in the '
     .      //            'call to ZZSPKGO0; 2. an '
     .      //            'uninitialized variable. ' )
            CALL ERRCH  ( '#', REF )

         ELSE IF ( REF .EQ. ' ' ) THEN

            CALL SETMSG ( 'The string supplied to specify the '
     .      //            'reference frame is blank.  The most '
     .      //            'common cause for this kind of error '
     .      //            'is an uninitialized variable. ' )

         ELSE

            CALL SETMSG ( 'The string supplied to specify the '
     .      //            'reference frame was ''#''.  This '
     .      //            'frame is not recognized. Possible '
     .      //            'causes for this error are: 1. failure '
     .      //            'to load the frame definition into the '
     .      //            'kernel pool; 2. An out-of-date '
     .      //            'edition of the toolkit. ' )
            CALL ERRCH  ( '#', REF )

         END IF

         CALL SIGERR ( 'SPICE(UNKNOWNFRAME)'  )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

      END IF

C
C     Fill in CTARG and STARG until no more data is found
C     or until we reach the SSB.  If the chain gets too
C     long to fit in CTARG, that is if I equals CHLEN,
C     then overwrite the last elements of CTARG and STARG.
C
C     Note the check for FAILED in the loop.  If SPKSFS
C     or SPKPVN happens to fail during execution, and the
C     current error handling action is to NOT abort, then
C     FOUND may be stuck at TRUE, CTARG(I) will never
C     become zero, and the loop will execute indefinitely.
C
C
C     Construct CTARG and STARG.  Begin by assigning the
C     first elements:  TARG and the state of TARG relative
C     to itself.
C
      I        =  1
      CTARG(I) =  TARG
      FOUND    = .TRUE.

      CALL CLEARD ( 6, STARG(1,I) )

      DO WHILE (           FOUND
     .            .AND.  ( I        .LT. CHLEN )
     .            .AND.  ( CTARG(I) .NE. OBS   )
     .            .AND.  ( CTARG(I) .NE. SSB   )  )

C
C        Find a file and segment that has state
C        data for CTARG(I).
C
         CALL SPKSFS ( CTARG(I), ET, HANDLE, DESCR, IDENT, FOUND )

         IF ( FOUND ) THEN
C
C           Get the state of CTARG(I) relative to some
C           center of motion.  This new center goes in
C           CTARG(I+1) and the state is called STEMP.
C
            I = I + 1

            CALL SPKPVN ( HANDLE,    DESCR,      ET,
     .                    TFRAME(I), STARG(1,I), CTARG(I) )
C
C           Here's what we have.  STARG is the state of CTARG(I-1)
C           relative to CTARG(I) in reference frame TFRAME(I)
C
C           If one of the routines above failed during
C           execution, we just give up and check out.
C
            IF ( FAILED() ) THEN
               CALL CHKOUT ( RNAME )
               RETURN
            END IF

         END IF

      END DO

      TFRAME(1) = TFRAME(2)
C
C     If the loop above ended because we ran out of
C     room in the arrays CTARG and STARG, then we
C     continue finding states but we overwrite the
C     last elements of CTARG and STARG.
C
C     If, as a result, the first common node is
C     overwritten, we'll just have to settle for
C     the last common node.  This will cause a small
C     loss of precision, but it's better than other
C     alternatives.
C
      IF ( I .EQ. CHLEN ) THEN

         DO WHILE (      FOUND
     .             .AND. CTARG(CHLEN) .NE. SSB
     .             .AND. CTARG(CHLEN) .NE. OBS )

C
C           Find a file and segment that has state
C           data for CTARG(CHLEN).
C
            CALL SPKSFS ( CTARG(CHLEN), ET, HANDLE, DESCR, IDENT, FOUND)

            IF ( FOUND ) THEN
C
C              Get the state of CTARG(CHLEN) relative to
C              some center of motion.  The new center
C              overwrites the old.  The state is called
C              STEMP.
C
               CALL SPKPVN ( HANDLE, DESCR, ET, TMPFRM, STEMP,
     .                       CTARG(CHLEN))

C
C              Add STEMP to the state of TARG relative to
C              the old center to get the state of TARG
C              relative to the new center.  Overwrite
C              the last element of STARG.
C
               IF ( TFRAME(CHLEN) .EQ. TMPFRM ) THEN

                  CALL MOVED ( STARG(1,CHLEN), 6, VTEMP )

               ELSE IF ( ISINRT ( TFRAME(CHLEN), TMPFRM ) ) THEN

                  CALL IRFROT( TFRAME(CHLEN), TMPFRM,         ROT      )
                  CALL MXV   ( ROT,           STARG(1,CHLEN), VTEMP(1) )
                  CALL MXV   ( ROT,           STARG(4,CHLEN), VTEMP(4) )

               ELSE

                  CALL ZZFRMCH0( TFRAME(CHLEN), TMPFRM,   ET,   STXFRM )

                  IF ( FAILED() ) THEN
                     CALL CHKOUT ( RNAME )
                     RETURN
                  END IF

                  CALL MXVG  ( STXFRM, STARG (1,CHLEN), 6, 6, VTEMP  )

               END IF

               CALL VADDG ( VTEMP,  STEMP,        6, STARG(1,CHLEN) )

               TFRAME(CHLEN) = TMPFRM

C
C              If one of the routines above failed during
C              execution, we just give up and check out.
C
               IF ( FAILED() ) THEN
                  CALL CHKOUT ( RNAME )
                  RETURN
               END IF

            END IF

         END DO

      END IF

      NCT = I
C
C     NCT is the number of elements in CTARG,
C     the chain length.  We have in hand the following information
C
C        STARG(1...6,K)  state of body
C        CTARG(K-1)      relative to body CTARG(K) in the frame
C        TFRAME(K)
C
C
C     For K = 2,..., NCT.
C
C     CTARG(1) = TARG
C     STARG(1...6,1) = ( 0, 0, 0, 0, 0, 0 )
C     TFRAME(1)      = TFRAME(2)
C

C
C     Now follow the observer's chain.  Assign
C     the first values for COBS and SOBS.
C
      COBS = OBS
      CALL CLEARD ( 6, SOBS )

C
C     Perhaps we have a common node already.
C     If so it will be the last node on the
C     list CTARG.
C
C     We let CTPOS will be the position of the common
C     node in CTARG if one is found.  It will
C     be zero if COBS is not found in CTARG.
C
      IF ( CTARG(NCT) .EQ. COBS ) THEN
         CTPOS  = NCT
         CFRAME = TFRAME(CTPOS)
      ELSE
         CTPOS  = 0
      END IF

C
C     Repeat the same loop as above, but each time
C     we encounter a new center of motion, check to
C     see if it is a common node.  (When CTPOS is
C     not zero, CTARG(CTPOS) is the first common node.)
C
C     Note that we don't need a centers array nor a
C     states array, just a single center and state
C     is sufficient --- we just keep overwriting them.
C     When the common node is found, we have everything
C     we need in that one center (COBS) and state
C     (SOBS-state of the target relative to COBS).
C
      FOUND  = .TRUE.
      NOFRM  = .TRUE.
      LEGS   =  0

      DO WHILE (           FOUND
     .            .AND.  ( COBS  .NE. SSB )
     .            .AND.  ( CTPOS .EQ. 0   )  )

C
C        Find a file and segment that has state
C        data for COBS.
C
         CALL SPKSFS ( COBS, ET, HANDLE, DESCR, IDENT, FOUND )

         IF ( FOUND ) THEN
C
C           Get the state of COBS; call it STEMP.
C           The center of motion of COBS becomes the
C           new COBS.
C
            IF ( LEGS .EQ. 0 ) THEN
               CALL SPKPVN ( HANDLE, DESCR, ET, TMPFRM, SOBS,  COBS )
            ELSE
               CALL SPKPVN ( HANDLE, DESCR, ET, TMPFRM, STEMP, COBS )
            END IF

            IF ( NOFRM ) THEN
               NOFRM  = .FALSE.
               CFRAME = TMPFRM
            END IF
C
C           Add STEMP to the state of OBS relative to
C           the old COBS to get the state of OBS
C           relative to the new COBS.
C
            IF ( CFRAME .EQ. TMPFRM ) THEN
C
C              On the first leg of the state of the observer, we
C              don't have to add anything, the state of the observer
C              is already in SOBS.  We only have to add when the
C              number of legs in the observer state is one or greater.
C
               IF ( LEGS .GT. 0 ) THEN
                  CALL VADDG ( SOBS,  STEMP, 6, VTEMP )
                  CALL MOVED ( VTEMP,        6, SOBS  )
               END IF

            ELSE IF ( ISINRT( CFRAME, TMPFRM ) ) THEN

               CALL IRFROT ( CFRAME, TMPFRM, ROT )
               CALL MXV    ( ROT,    SOBS(1),   VTEMP(1)  )
               CALL MXV    ( ROT,    SOBS(4),   VTEMP(4)  )
               CALL VADDG  ( VTEMP,  STEMP,     6, SOBS   )
               CFRAME = TMPFRM

            ELSE

               CALL ZZFRMCH0 ( CFRAME, TMPFRM, ET,   STXFRM )

               IF ( FAILED() ) THEN
                  CALL CHKOUT ( RNAME )
                  RETURN
               END IF

               CALL MXVG   ( STXFRM, SOBS,   6, 6, VTEMP  )
               CALL VADDG  ( VTEMP,  STEMP,     6, SOBS   )
               CFRAME = TMPFRM

            END IF

C
C           Check failed.  We don't want to loop
C           indefinitely.
C
            IF ( FAILED() ) THEN
               CALL CHKOUT ( RNAME )
               RETURN
            END IF

C
C           We now have one more leg of the path for OBS.  Set
C           LEGS to reflect this.  Then see if the new center
C           is a common node. If not, repeat the loop.
C
            LEGS  = LEGS + 1
            CTPOS = ISRCHI ( COBS, NCT, CTARG )

         END IF

      END DO

C
C     If CTPOS is zero at this point, it means we
C     have not found a common node though we have
C     searched through all the available data.
C
      IF ( CTPOS .EQ. 0 ) THEN

         CALL BODC2N ( TARG, TNAME,   FOUND )

         IF ( FOUND ) THEN
            CALL PREFIX ( '# (',  0,        TNAME )
            CALL SUFFIX ( ')',    0,        TNAME )
            CALL REPMI  ( TNAME, '#', TARG, TNAME )
         ELSE
            CALL INTSTR ( TARG, TNAME )
         END IF

         CALL BODC2N ( OBS,  ONAME,   FOUND )

         IF ( FOUND ) THEN
            CALL PREFIX ( '# (',  0,       ONAME )
            CALL SUFFIX ( ')',    0,       ONAME )
            CALL REPMI  ( ONAME, '#', OBS, ONAME )
         ELSE
            CALL INTSTR ( OBS, ONAME )
         END IF

         CALL SETMSG ( 'Insufficient ephemeris data has been '
     .   //            'loaded to compute the state of TARG '
     .   //            'relative to OBS at the ephemeris epoch '
     .   //            '#. ' )

         CALL ETCAL  (  ET,    TSTRING                                 )
         CALL ERRCH  ( 'TARG', TNAME                                   )
         CALL ERRCH  ( 'OBS',  ONAME                                   )
         CALL ERRCH  ( '#',    TSTRING                                 )
         CALL SIGERR ( 'SPICE(SPKINSUFFDATA)'                          )
         CALL CHKOUT ( RNAME                                           )
         RETURN

      END IF

C
C     If CTPOS is not zero, then we have reached a
C     common node, specifically,
C
C        CTARG(CTPOS) = COBS = CENTER
C
C     (in diagram below).  The STATE of the target
C     (TARG) relative to the observer (OBS) is just
C
C        STARG(1,CTPOS) - SOBS.
C
C
C
C                     SOBS
C         CENTER ---------------->OBS
C            |                  .
C            |                .
C         S  |              .   E
C         T  |            .   T
C         A  |          .   A
C         R  |        .   T
C         G  |      .   S
C            |    .
C            |  .
C            V L
C           TARG
C
C
C     And the light-time between them is just
C
C               | STATE |
C          LT = ---------
C                   c
C
C
C     Compute the state of the target relative to CTARG(CTPOS)
C
      IF ( CTPOS .EQ. 1 ) THEN
         TFRAME(1) = CFRAME
      END IF

      DO I = 2, CTPOS-1

         IF ( TFRAME(I) .EQ. TFRAME(I+1) ) THEN

            CALL VADDG  ( STARG(1,I), STARG(1,I+1), 6, VTEMP        )
            CALL MOVED  ( VTEMP,                    6, STARG(1,I+1) )

         ELSE IF ( ISINRT ( TFRAME(I), TFRAME(I+1) ) ) THEN

            CALL IRFROT ( TFRAME(I),  TFRAME(I+1),     ROT          )
            CALL MXV    ( ROT,        STARG(1,I),      STEMP(1)     )
            CALL MXV    ( ROT,        STARG(4,I),      STEMP(4)     )
            CALL VADDG  ( STEMP,      STARG(1,I+1), 6, VTEMP        )
            CALL MOVED  ( VTEMP,                    6, STARG(1,I+1) )

         ELSE

            CALL ZZFRMCH0 ( TFRAME(I),  TFRAME(I+1), ET,  STXFRM       )

            IF ( FAILED() ) THEN
               CALL CHKOUT ( RNAME )
               RETURN
            END IF

            CALL MXVG   ( STXFRM,     STARG(1,I),  6,6, STEMP        )
            CALL VADDG  ( STEMP,      STARG(1,I+1),  6, VTEMP        )
            CALL MOVED  ( VTEMP,                     6, STARG(1,I+1) )

         END IF

      END DO

C
C     To avoid unnecessary frame transformations we'll do
C     a bit of extra decision making here.  It's a lot
C     faster to make logical checks than it is to compute
C     frame transformations.
C
      IF ( TFRAME(CTPOS) .EQ. CFRAME ) THEN

         CALL VSUBG  ( STARG(1,CTPOS), SOBS, 6,   STATE  )

      ELSE IF ( TFRAME(CTPOS) .EQ. REFID ) THEN

C
C        If the last frame associated with the target is already
C        in the requested output frame, we convert the state of
C        the observer to that frame and then subtract the state
C        of the observer from the state of the target.
C
         IF ( ISINRT( CFRAME, REFID ) ) THEN

            CALL IRFROT ( CFRAME, REFID,   ROT      )
            CALL MXV    ( ROT,    SOBS(1), STEMP(1) )
            CALL MXV    ( ROT,    SOBS(4), STEMP(4) )

         ELSE

            CALL ZZFRMCH0 ( CFRAME, REFID, ET,  STXFRM )

            IF ( FAILED() ) THEN
               CALL CHKOUT ( RNAME )
               RETURN
            END IF

            CALL MXVG   ( STXFRM, SOBS,  6,6, STEMP  )

         END IF

C
C        We've now transformed SOBS into the requested reference frame.
C        Set CFRAME to reflect this.
C
         CFRAME = REFID
         CALL VSUBG ( STARG(1,CTPOS),  STEMP, 6, STATE )

      ELSE IF ( ISINRT( TFRAME(CTPOS), CFRAME ) ) THEN

C
C        If both frames are inertial we use IRFROT instead of
C        ZZFRMCH0 to get things into a common frame.
C
         CALL IRFROT ( TFRAME(CTPOS),  CFRAME,               ROT      )
         CALL MXV    ( ROT,            STARG(1,CTPOS),       STEMP(1) )
         CALL MXV    ( ROT,            STARG(4,CTPOS),       STEMP(4) )
         CALL VSUBG  ( STEMP,          SOBS,            6,   STATE    )

      ELSE
C
C        Use the more general routine ZZFRMCH0 to make the
C        transformation.
C
         CALL ZZFRMCH0 ( TFRAME(CTPOS),  CFRAME,          ET,  STXFRM )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

         CALL MXVG   ( STXFRM,         STARG(1,CTPOS),  6,6, STEMP  )
         CALL VSUBG  ( STEMP,          SOBS,            6,   STATE  )

      END IF

C
C     Finally, rotate as needed into the requested frame.
C
      IF ( CFRAME .EQ. REFID ) THEN

C
C        We don't have to do anything in this case.
C

      ELSE IF ( ISINRT ( CFRAME, REFID ) ) THEN
C
C        Since both frames are inertial, we use the more direct
C        routine IRFROT to get the transformation to REFID.
C
         CALL IRFROT ( CFRAME,  REFID,      ROT      )
         CALL MXV    ( ROT,     STATE(1),   STEMP(1) )
         CALL MXV    ( ROT,     STATE(4),   STEMP(4) )
         CALL MOVED  ( STEMP,   6,          STATE    )

      ELSE

         CALL ZZFRMCH0 ( CFRAME,  REFID, ET,  STXFRM )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

         CALL MXVG   ( STXFRM,  STATE, 6, 6, STEMP )
         CALL MOVED  ( STEMP,          6,    STATE )

      END IF

      LT = VNORM  ( STATE ) / CLIGHT()

      CALL CHKOUT ( RNAME )
      RETURN
      END


*deck sf3eq5
      subroutine sf3eq5( a,        cx,       eta,      g4,
     &         h4,       icb,      icc,      ipt,      is,
     &         isf,      js,       jsf,      ijgt,     ijx,
     &         ijy,      ijz,      klgt,     klx,      kly,
     &         klz,      lmnp1,    lmnv,     mcons,    nc,
     &         ncon,     nfct,     ngw,      nrcr,     nt,
     &         ntl,      ntu,      x,        y,        z,
     &         zet )
      implicit real*8 (a-h,o-z)
      logical ec
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      common /cxindx/ ntij,ntik,ntil,ntkl,ntjl,ntjk,ntij1,ntjk1,ntkl1,
     1  ijcxst(2),ikcxst(2),ilcxst(2),klcxst(2),jlcxst(2),jkcxst(2)
      common /dim21/ ipq(256)
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
      common /sf3ao/ ibl
      dimension a(*),cx(*),eta(mrcru,mconu,*),g4(*),h4(*),icb(4,24,*),
     1  ipt(*),ijgt(*),ijx(*),ijy(*),ijz(*),klgt(*),klx(*),kly(*),
     2  klz(*),lmnp1(*),lmnv(3,*),mcons(*),nc(*),ncon(*),nfct(*),ngw(*),
     3  nrcr(*),nt(*),ntl(*),ntu(*),x(mcu,*),y(mcu,*),z(mcu,*),
     4  zet(mconu,*)
      dimension ec(3), icxbg(3), jbl(2), kcxbg(3,3)
c
      ic=icb(inx,1,icc)
      jc=icb(jnx,1,icc)
      kc=icb(knx,1,icc)
      lc=icb(lnx,1,icc)
      icxbg(1)=ijcxst(2)+((ic-1)*nc(js)+(jc-1))*ntij
      icxbg(2)=icxbg(1)+(kc-jc)*ntij
      icxbg(3)=icxbg(2)+(lc-kc)*ntij
      kcxbg(1,1)=jkcxst(1)+ipq((kc-1)*nt(jsf)+1)*nprk(1,1)+(lc-1)*ntjk1
      kcxbg(1,3)=jkcxst(1)+ipq((jc-1)*nt(jsf)+1)*nprk(1,1)+(kc-1)*ntjk1
      kcxbg(1,2)=kcxbg(1,3)+(lc-kc)*ntjk1
      kcxbg(2,1)=jkcxst(2)+((kc-1)*nc(js)+(lc-1))*ntjk
      kcxbg(3,1)=kcxbg(2,1)-(kc-lc)*((nc(js)-1)*ntjk)
      kcxbg(2,2)=kcxbg(2,1)+(jc-kc)*nc(js)*ntjk
      kcxbg(3,2)=kcxbg(2,2)-(jc-lc)*((nc(js)-1)*ntjk)
      kcxbg(2,3)=kcxbg(2,2)+(kc-lc)*ntjk
      kcxbg(3,3)=kcxbg(2,3)-(jc-kc)*((nc(js)-1)*ntjk)
      ec(1)=kc.eq.lc
      ec(2)=jc.eq.lc
      ec(3)=jc.eq.kc
      do 12 jesfb=1,2
        jbl(jesfb)=0
        do 10 ist=1,nst
          jbl(jesfb)=jbl(jesfb)+npriri(2,1,ist)*nprirk(jesfb,1,ist)
   10   continue
   12 continue
      jbld=jbl(2)-jbl(1)
      jblkl=ipq(jrcru)*jbl(2)+jrcru*jbl(1)
      if(ec(1)) then
        nwt1(1) = 1
        if(ec(3)) then
          iscmu = 1
          go to 48
        else
          iscmu = 2
          go to 44
        endif
      endif
      if(ec(3)) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 1
        go to 52
      endif
      if(ngw(icc).eq.1) go to 40
      isw2 = 2
      isw3 = 3
      do 24 igw=2,ngw(icc)
        if(icb(inx,igw,icc).ne.ic) go to 24
        if (icb(knx,igw,icc) .eq. jc) isw2 = 1
        if (icb(lnx,igw,icc) .eq. kc) isw3 = min(isw3,2)
        if (icb(lnx,igw,icc) .eq. jc) isw3 = 1
   24 continue
      if(isw3.eq.1) then
        if(isw2.eq.1) then
          iscmu = 1
          nwt1(1) = 3
          go to 48
        else
          iscmu = 2
          nwt1(1) = 2
          go to 44
        endif
      elseif(isw3.eq.2) then
        iscmu = 2
        nwt1(1) = 1
        nwt1(2) = 2
        go to 48
      elseif(isw2.eq.1) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 2
        go to 52
      endif
   40 iscmu = 3
      nwt1(1) = 1
   44 nwt1(2) = 1
   48 iscml = 1
   52 nwt2 = nwt * nfct(icc)
      ngtj=nt(jsf)**2
      do 98 iscm=iscml,iscmu
      fnfct=nwt1(iscm)*nwt2
      if(iscm-2) 56, 60, 64
   56 call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,jc,js,jsf,kc,js,jsf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 68
   60 call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,kc,js,jsf,jc,js,jsf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 68
   64 call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,lc,js,jsf,jc,js,jsf,kc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
   68 ndxj=1
      iblbij=0
      do 96 ircr=1,ircru
      do 94 jrcr=1,jrcru
      do 92 krcr=1,jrcru
      if(ec(iscm)) lrcru=krcr
      do 90 lrcr=1,lrcru
      if(krcr-lrcr) 70, 72, 74
   70 iblb=iblbij+(ipq(lrcr)+(krcr-1))*jbl(2)-(lrcr-1)*jbld
      kesfb=2
      kcxbg1=kcxbg(3,iscm)
      ngtk=1
      ngtl=nt(jsf)
      go to 78
   72 iblb=iblbij+ipq(krcr)*jbl(2)+(krcr-1)*jbl(1)
      kesfb=1
      go to 76
   74 iblb=iblbij+(ipq(krcr)+(lrcr-1))*jbl(2)-(krcr-1)*jbld
      kesfb=2
   76 kcxbg1=kcxbg(kesfb,iscm)
      ngtk=nt(jsf)
      ngtl=1
   78 icxs(2,iscm)=icxbg(iscm)
      do 88 it=itl,itu
        do 86 jt=jtl,jtu
          kcxs(kesfb,iscm)=kcxbg1
          ndxk=ndxj
          do 84 kt=jtl,jtu
            if(krcr.eq.lrcr.and.ec(iscm)) ltu=kt
            ndxl=ndxk
            do 82 lt=jtl,ltu
              val=g4(ndxl)
              if(abs(val).le.cutoff) go to 80
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, iscm, val )
   80         ndxl=ndxl+ngtl
              kcxs(kesfb,iscm)=kcxs(kesfb,iscm)+nprk(kesfb,1)
   82       continue
            ndxk=ndxk+ngtk
   84     continue
          ndxj=ndxj+ngtj
          icxs(2,iscm)=icxs(2,iscm)+npri(2,1)
   86   continue
   88 continue
   90 continue
   92 continue
      iblbij=iblbij+jblkl
   94 continue
   96 continue
   98 continue
      return
      end