      subroutine xprep(iph0, idwopt, nat, inclus, npot,
     $            iphat, rmax, rat,
     $            izx, rnrmav, temper, thetad, sig2,
     $            minv, rdirec )

      implicit real (a-h,o-z)
      implicit integer (i-n)
c--------------------------------------------------------------------
c This subroutine prepares geometrical information for a subsequent
c call to the fms full multiple scattering package.  Information is
c passed to fms via common blocks (which live in header files during
c development).
c
c These header files are required:  dim.h xparam.h  xstruc.h
c dim.h and xparam.h must be included in the calling routine
c This routine calls wlog, so must be compiled with it
c
c This is the main file of xpreppack for use with the full multiple
c scattering package (fmspack).  The calling protocol for xpreppack
c and fmspack is;
c
c      include '../HEADERS/dim.h'
c      include 'xparam.h'
c      ...
c      call xprep(iph0, idwopt, nat, inclus, npot, iphat, rmax, rat,
c $        izx, rnrmav, temper, thetad)
c      energy loop {
c         ...
c         call fms(nsp, inclus, npot, ck, lipotx, xphase, ik, iverb, gg)
c         ... }
c
c xpreppack contains the following routines:
c   xprep:  main routine of xpreppack
c   getang: determine angles between the z axis and all pairs of atoms
c   rotxan: get all rotation matrix elements for the cluster
c   rotint: initialize arrays used in the construction of rotation
c           matrices
c   sortat: organize atoms and potentials lists for computational and
c             organizational efficiency
c   atheap: heap sort extended cluster by distance from central atom
c   xanlm:  get all legendre normalization factor
c   factst: part of legendre factor computation
c
c xpreppack currently supports use of the Debye-Waller factors for
c   estimating the effect of thermal disorder on the xanes spectrum.
c   It does this by filling a matrix with the pairwise mean square
c   displacement between atoms.  Other forms of this calculation may
c   be included in the future.  Note that it is strictly impossible
c   to correctly model disorder in the MS scattering contribution to
c   the spectrum when using the FMS technique.
c--------------------------------------------------------------------
c  input:
c     iph0:   potential index for DOS calculations (added by ala to
c             handle other-than-the-central atom) (iph0=0 for the
c             absorbing atom)
c     nat:    number of atoms in extended cluster
c     npot:   number of unique potentials in cluster
c     iphat:  (natxx) potential index for each atom in extended
c             cluster
c     rmax:   radial size of cluster
c     rat:    (3, natxx) coordiantes of each atom in extended cluster
c             as read from geometry file
c  input for correlated debye model:
c     izx:    (natxx) Z number of each atom in the cluster
c     rnrmav: average norman radius in cluster (from phase.pad)
c     temper: sample temperature
c     thetad: Debye temperature
c
c  output:
c     inclus: number of atoms in cluster (inclus <= nat)
c
c  output (all via commmon blocks in xstruc.h):
c     xphi:  matrix of angles between the z axis and pairs of atoms
c     xrat:  xyz coordinates of the atoms in the cluster, the first
c            npot+1 entries are examples of each unique potential
c     iphx:  potential indeces of each atom in the cluster, ordered
c            like xrat
c     drix:  huge matrix containing all rotation matrix elements
c            needed for computation of free elctron propagators
c     xnlm:  matrix of legendre polynomial normalization factors
c--------------------------------------------------------------------

      include '../HEADERS/dim.h'
      include '../HEADERS/parallel.h'
      include 'xparam.h'
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/
c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/
c********************************************************************
c**** save Clebsch-Gordon coefficients: <LS|J>
      dimension t3jp(0:lx, -lx:lx, 2), t3jm(0:lx, -lx:lx, 2)
      common /t3j/ t3jp, t3jm
      save   /t3j/
c********************************************************************
      parameter(zero=0.e0)
      parameter (bohr = 0.529 177 249e0)
      integer   iphat(natxx), iphat2(natxx), izx(0:nphasx), izpair(0:2)
      dimension rat(3,natxx), rat2(3,natxx)
      double precision ra(natxx)
      character*78 line
c     sigms is written in double precision.  these are the variables
c     that it uses
      double precision dtemp, dthet, drs, dsigsq, pair(3,0:2)
      double precision sig2mx, sig2x(0:nphx,0:nphx)
c     iwarn - needed to wrtite waqrning just one time
      integer iwarn
      save iwarn
      data  iwarn /0/
      double precision cwig3j
      external cwig3j

c     Josh - logical flag for reading in dw factors
      logical readdw
c     Josh END

c  initialize geometrical arrays
      do 30 i=1,nclusx
        do 10 j=1,nclusx
          xphi(j,i) = zero
 10     continue
        do 20 j=1,3
          xrat(j,i) = zero
 20     continue
        iphx(i) = 0
 30   continue
      inclus = 0

c --- find the central atom, ipot=iph0 (iph0=0 for the absorbing atom)
      icen = 0
      do 40 i=1,nat
        iphat2(i) = iphat(i)
        if (iphat(i).eq.iph0) then
            if (icen.eq.0) then
                icen = i
            elseif (iph0.eq.0) then
                call wlog('* * * ERROR!  More than one atom '//
     $                      'in the extended cluster have ipot=0')
                call wlog('      You may only have one central atom.')
                call wlog('      Stopping in xprep.')
                call par_stop('XPREP-1')
            endif
        endif
 40   continue
c --- make sure central atom is at (0,0,0)
      do 45 i=1,nat
        rat2(1,i) = rat(1,i)-rat(1,icen)
        rat2(2,i) = rat(2,i)-rat(2,icen)
        rat2(3,i) = rat(3,i)-rat(3,icen)
 45   continue

c --- sort the atoms from extended cluster by distance from central
c     atom.
      call atheap(nat, rat2, iphat2, ra)

c --- define cluster from extended cluster by as those closer than
c     rmax to central atom
      inclus=0
      rmax2 = rmax**2
      do 50 i=1,nat
        rr = (rat2(1,i)**2 + rat2(2,i)**2 + rat2(3,i)**2)
        if (rr .gt. rmax2) then
            inclus = i-1
            goto 60
        endif
 50   continue
 60   continue
      if (inclus.eq.0) inclus=nat

c --- sanity check size of cluster
      if (inclus.gt.nclusx) then
        if (iwarn.eq.0) then
          call wlog('* * * WARNING preparing cluster for '//
     $                'FMS calculation.')
          write(line,400) inclus
 400      format('      You specified a cluster of ', i3,
     $                ' atoms for the FMS calculation.')
          call wlog(line)
          write(line,410)nclusx
          call wlog(line)
 410      format('      This exceeds the hard wired limit of ', i3,
     $                ' atoms.')
          write(line,420)nclusx
          call wlog(line)
 420      format('      The cluster size was reset to ', i3,
     $                ' and the calculation will continue.')
          iwarn = 1
        endif
        inclus = nclusx
      endif

c --- make the first few entries in xrat represent each of the
c     unique potentials, sorting around the chosen center
c     (iph0=0 for the absorbing atom)
c     call sortat(iph0, inclus, npot, iphat2, iphx, rat2, xrat)
      do 430 iat = 1, inclus
          iphx(iat) = iphat2(iat)
          xrat(1,iat) = real (rat2(1,iat))
          xrat(2,iat) = real (rat2(2,iat))
          xrat(3,iat) = real (rat2(3,iat))
 430  continue

c --- Calculate and store rotation matrix elements and phi angles
c     the k loop calculates the forward then the backward rotation
c     for an atom pair (ij). k = 0-->forward, 1-->backward
      call rotint
      lplus1 = lx+1
      mplus1 = lx+1
      do 150  i=1,inclus
        do 140 j=1,inclus
          rr = (xrat(1,i)-xrat(1,j))**2 + (xrat(2,i)-xrat(2,j))**2 +
     1         (xrat(3,i)-xrat(3,j))**2
c         if (rr.gt. rdirec**2) goto 140

          call getang(nclusx, xrat, i, j, xbeta, xphi(i,j))
          if (i.eq.j) goto 140
          do 130 k=0,1
            if (k.eq.1) xbeta = (-1) * xbeta
            call rotxan(lplus1, mplus1, xbeta, i, j, k)
 130      continue
 140    continue
 150  continue

c --- calculate spherical harmonic normalization factors
      call xanlm(lplus1,mplus1)

c --- calculate array of correlated debye waller factors
c     initialize
      do 200 iat2=1,nclusx
      do 200 iat1=1,nclusx
        sigsqr(iat1,iat2) = zero
 200  continue

c            Josh - open dwfac.dat for reading precalculated dw factors
c                   and set logical flag readdw
c             open(unit=47,file='dwfac.dat',status='unknown',iostat=ios)
c            Temporary - write output file sigsqr.dat
c             open(unit=48,file='sigsqr.dat',status='replace')
c             if(ios.le.0) readdw = .true.
c            Josh END

c     open files for sigrm and sigem
      if (idwopt.eq.1.and.master) then
         iem = 111
         open(unit=iem,file='s2_em.dat',status='unknown', iostat=ios)
         call chopen (ios, 's2_em.dat', 'sigem')
      endif
      if (idwopt.ge.1) then
         if(master) then
           irm1 =113
           open(unit=irm1,file='s2_rm2.dat',status='unknown',
     .          iostat=ios)
           call chopen (ios, 's2_rm2.dat', 'sigrm')
           irm2 = 112
           open(unit=irm2,file='s2_rm1.dat',status='unknown',
     .          iostat=ios)
           call chopen (ios, 's2_rm1.dat', 'sigrm')
         endif

c        initialize statistics for max DW factors and set rmaxem
         sig2mx=0
         do 446 iph1=0,nphx
         do 446 iph2=0,nphx
  446    sig2x(iph1,iph2) = 0
         rmaxem = 20.0
         do 447 i = 2,inclus
           rr = 0
           do 448 j=1,3
  448      rr = rr + (xrat(j,i)-xrat(j,1))**2
           rr = sqrt(rr)
           if (rr.lt.rmaxem) rmaxem = rr
  447    continue
         rmaxem = max(2.2*rmaxem, 5.0/bohr)
      endif

      npair = 0
      do 250 iat1=1,inclus-1
        do 240 iat2=iat1+1, inclus
          rr = (xrat(1,iat1)-xrat(1,iat2))**2 +
     1    (xrat(2,iat1)-xrat(2,iat2))**2 +(xrat(3,iat1)-xrat(3,iat2))**2
c         if (rr.gt. rdirec**2) goto 240

          if (idwopt.ge.0) then
             do 230 ipair=1,3
               pair(ipair,0) = dble(xrat(ipair, iat1)*bohr)
               pair(ipair,1) = dble(xrat(ipair, iat2)*bohr)
               pair(ipair,2) = dble(pair(ipair,0))
 230         continue
             izpair(0) = izx(iphx(iat1))
             izpair(1) = izx(iphx(iat2))
             izpair(2) = izpair(0)
             dtemp = dble(temper)
             dthet = dble(thetad)
             drs   = dble(rnrmav)
             ipath0=0
             if (idwopt.eq.0) then
c               use CD model
                call sigms(dtemp,dthet,drs,2,2,pair,izpair,dsigsq)
             elseif (idwopt.eq.1) then
                xr12 = (xrat(1,iat1) - xrat(1,iat2))**2
                yr12 = (xrat(2,iat1) - xrat(2,iat2))**2
                zr12 = (xrat(3,iat1) - xrat(3,iat2))**2
                rr12 = sqrt(xr12 +yr12 +zr12)
                if (rr12.le.rmaxem) then
c                  use EM method
                   npair = npair + 1
                   if (mod(npair,100).eq.0) then
                      write (line, 337) npair
  337                 format('    Doing DW factors via EM method for',
     1                ' the pair number ', i5)
                      call wlog(line)
                   endif
                   call sigem
     1             (sig2mx,sig2x,iem,dtemp,ipath0,2,pair,dsigsq)
                else
c                  use RM method
                   call sigrm
     1             (sig2mx,sig2x,irm1,irm2,dtemp,ipath0,2,pair,dsigsq)
                endif
             else
c               use RM
                call sigrm
     1          (sig2mx,sig2x,irm1,irm2,dtemp,ipath0,2,pair,dsigsq)
             endif
             sigsqr(iat1,iat2) = real(dsigsq)
c            Josh - Temporary. write to sigsqr.dat
c             write(48,*) iat1, iat2, sigsqr(iat1,iat2)
          endif
          sigsqr(iat1,iat2) = sigsqr(iat1,iat2) + sig2
          sigsqr(iat2,iat1) = sigsqr(iat1,iat2)
 240    continue
 250  continue

c     Josh - if file dwfac.dat exists, read lines
c            iat1   iat2   dwfac
c            from it and set sigsqr(iat1,iat2) = dwfac
c      if(readdw) then
c         do i = 1, 1000
c            call RdCmt(47,'#*cC')
c            read(47,*, end=255) iat1, iat2, sigsqr(iat1,iat2)
c         end do
c 255     continue
c      end if
c      close(47)
c     Josh END

c     close output for sigem sigrm
      if (master) then
        if (idwopt.eq.1) close (unit=iem)
        if (idwopt.ge.1) close (unit=irm1)
        if (idwopt.ge.1) close (unit=irm2)
      endif

c     Calculate Clebsch-Gordon coefficients <LS|J>
      do 70  l1 = 0, lx
      do 70  mm = -l1, l1
      do 70  isp1 = 1, 2
        j1 = 2 * l1
        j2 = 1
        j3p = j1 + 1
        j3m = j1 - 1
        m1 = 2*mm
        m2 = 2*isp1 - 3
c  j = l+1/2
        t3jp( l1, mm, isp1) = sqrt( j3p + 1.0e0 ) *
     1                 real( cwig3j( j1, j2, j3p, m1, m2, 2) )
        if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0)
     1          t3jp( l1, mm, isp1) = - t3jp( l1, mm, isp1)

c  j = l-1/2
        t3jm( l1, mm, isp1) = sqrt( j3m + 1.0e0 ) *
     1                 real( cwig3j( j1, j2, j3m, m1, m2, 2) )
        if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0)
     1          t3jm( l1, mm, isp1) = - t3jm( l1, mm, isp1)
  70  continue

      return
c  end subroutine xprep
      end


C$Procedure  SPKR19 ( SPK, read record from segment, type 19 )

      SUBROUTINE SPKR19 ( HANDLE, DESCR, ET, RECORD )
      IMPLICIT NONE

C$ Abstract
C
C     Read a single SPK data record from a segment of type 19
C     (ESOC/DDID Piecewise Interpolation).
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

      INCLUDE 'spk19.inc'
      INCLUDE 'spkrec.inc'

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR    ( 5 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     ET         I   Target epoch.
C     RECORD     O   Data record.
C
C$ Detailed_Input
C
C     HANDLE,
C     DESCR       are the file handle and segment descriptor for an SPK
C                 segment of type 19. The SPK file designated by HANDLE
C                 must be open for read access.
C
C     ET          is an epoch for which a data record from a specific
C                 segment is required. ET is expressed as seconds past
C                 J2000 TDB.
C
C$ Detailed_Output
C
C     RECORD      is an array of data from the specified segment which,
C                 when evaluated at epoch ET, will give the state
C                 (position and velocity) of the target body identified
C                 by the input segment descriptor. The descriptor
C                 specifies the center of motion and reference frame of
C                 the state.
C
C                 The structure of the record is as follows:
C
C                    +----------------------+
C                    | subtype code         |
C                    +----------------------+
C                    | number of packets (n)|
C                    +----------------------+
C                    | packet 1             |
C                    +----------------------+
C                    | packet 2             |
C                    +----------------------+
C                                .
C                                .
C                                .
C                    +----------------------+
C                    | packet n             |
C                    +----------------------+
C                    | epochs 1--n          |
C                    +----------------------+
C
C                 The packet size is a function of the type 19 subtype.
C                 All packets in a record have the same size.
C
C$ Parameters
C
C     See the Fortran INCLUDE file spk19.inc.
C
C$ Exceptions
C
C     1) If the input HANDLE does not designate a loaded SPK file, the
C        error will be diagnosed by routines called by this routine.
C
C     2) If the segment specified by DESCR is not of data type 19,
C        the error 'SPICE(WRONGSPKTYPE)' is signaled.
C
C     3) If the input ET value is not within the range specified
C        in the segment descriptor, the error SPICE(TIMEOUTOFBOUNDS)
C        is signaled.
C
C     4) If the window size is non-positive or greater than the
C        maximum allowed value, the error SPICE(INVALIDVALUE) is
C        signaled.
C
C     5) If the window size is not compatible with the segment
C        subtype, the error SPICE(INVALIDVALUE) is signaled.
C
C     6) If the segment subtype is not recognized, the error
C        SPICE(NOTSUPPORTED) is signaled.
C
C$ Files
C
C     See argument HANDLE.
C
C$ Particulars
C
C     SPICE user applications normally will have no need to call this
C     routine directly. For further information, see the headers of the
C     SPICE SPK APIs
C
C        SPKEZR
C        SPKPOS
C
C     the SPK Required Reading file spk.req, and the SPICE SPK
C     tutorial.
C
C     See the SPK Required Reading file for a description of the
C     structure of a data type 19 segment.
C
C$ Examples
C
C     The data returned by the SPKRnn routine is in its rawest form,
C     taken directly from the segment.  As such, it will be meaningless
C     to a user unless he/she understands the structure of the data type
C     completely.  Given that understanding, however, the SPKRxx
C     routines might be used to "dump" and check segment data for a
C     particular epoch.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     C
C     C     Look at parts of the descriptor.
C     C
C           CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C           CENTER = ICD( 2 )
C           REF    = ICD( 3 )
C           TYPE   = ICD( 4 )
C
C           IF ( TYPE .EQ. 19 ) THEN
C              CALL SPKR19 ( HANDLE, DESCR, ET, RECORD )
C                  .
C                  .  Look at the RECORD data.
C                  .
C           END IF
C
C$ Restrictions
C
C     1)  Correctness of inputs must be ensured by the caller of
C         this routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     B.V. Semenov    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 11-MAY-2015 (NJB)
C
C        Updated to support subtype 2.
C
C-    SPICELIB Version 1.0.0, 14-MAR-2014 (NJB) (BVS)
C
C-&

C$ Index_Entries
C
C     read record from type_19 spk segment
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               LSTLED
      INTEGER               LSTLTD

      LOGICAL               ODD
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               ND
      PARAMETER           ( ND     = 2 )

      INTEGER               NI
      PARAMETER           ( NI     = 6 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = DIRSIZ + 1 )

      INTEGER               CTRLSZ
      PARAMETER           ( CTRLSZ = 3 )

C
C     Maximum window sizes, based on subtypes:
C
      INTEGER               S19MW0
      PARAMETER           ( S19MW0 =  ( MAXDEG + 1 )/2  )

      INTEGER               S19MW1
      PARAMETER           ( S19MW1 =  ( MAXDEG + 1 )    )

      INTEGER               S19MW2
      PARAMETER           ( S19MW2 =  ( MAXDEG + 1 )    )

C
C     Local variables
C
      DOUBLE PRECISION      BUFFER ( BUFSIZ )
      DOUBLE PRECISION      CONTRL ( CTRLSZ )
      DOUBLE PRECISION      DC     ( ND )
      DOUBLE PRECISION      MINTIM ( ND )
      DOUBLE PRECISION      SVBTIM
      DOUBLE PRECISION      SVETIM

      INTEGER               BADDR
      INTEGER               BEGIDX
      INTEGER               BUFBAS
      INTEGER               DIRBAS
      INTEGER               EADDR
      INTEGER               ENDIDX
      INTEGER               FIRST
      INTEGER               GROUP
      INTEGER               HIGH
      INTEGER               I
      INTEGER               IC     ( NI )
      INTEGER               ISEL
      INTEGER               IVBAS
      INTEGER               IVBIX
      INTEGER               IVEIX
      INTEGER               LAST
      INTEGER               LOW
      INTEGER               LSIZE
      INTEGER               MAXWND
      INTEGER               MINIB
      INTEGER               MINIE
      INTEGER               MINIIX
      INTEGER               MXWNSZ ( 0 : S19NST-1 )
      INTEGER               N
      INTEGER               NDIR
      INTEGER               NPKDIR
      INTEGER               NPKT
      INTEGER               NRCPKT
      INTEGER               NREAD
      INTEGER               PKDBAS
      INTEGER               PKTSIZ
      INTEGER               PKTSZS ( 0 : S19NST-1 )
      INTEGER               REMAIN
      INTEGER               RSIZE
      INTEGER               SUBTYP
      INTEGER               SVBEG
      INTEGER               SVHAN
      INTEGER               SVMIIX
      INTEGER               SVMINB
      INTEGER               SVN
      INTEGER               SVNPKT
      INTEGER               SVPKDB
      INTEGER               SVPKND
      INTEGER               SVPKSZ
      INTEGER               SVSTYP
      INTEGER               SVWNSZ
      INTEGER               TIMBAS
      INTEGER               TYPE
      INTEGER               WNDSIZ

      LOGICAL               IVLSEL
      LOGICAL               PASS1
      LOGICAL               PRVOK
      LOGICAL               SAMIVL
      LOGICAL               SAMSEG
      LOGICAL               SVLAST
      LOGICAL               SVOK

C
C     Saved variables
C
      SAVE                  MXWNSZ
      SAVE                  PASS1
      SAVE                  PKTSZS
      SAVE                  SVBEG
      SAVE                  SVBTIM
      SAVE                  SVETIM
      SAVE                  SVHAN
      SAVE                  SVLAST
      SAVE                  SVMIIX
      SAVE                  SVMINB
      SAVE                  SVN
      SAVE                  SVNPKT
      SAVE                  SVOK
      SAVE                  SVPKDB
      SAVE                  SVPKND
      SAVE                  SVPKSZ
      SAVE                  SVSTYP
      SAVE                  SVWNSZ

C
C     Initial values
C
      DATA                  MXWNSZ  /  S19MW0, S19MW1, S19MW2 /
      DATA                  PASS1   /  .TRUE.  /
      DATA                  PKTSZS  /  S19PS0, S19PS1, S19PS2 /
      DATA                  SVBEG   /  -1      /
      DATA                  SVBTIM  /   0.D0   /
      DATA                  SVETIM  /  -1.D0   /
      DATA                  SVHAN   /   0      /
      DATA                  SVLAST  /  .FALSE. /
      DATA                  SVMIIX  /  -1      /
      DATA                  SVMINB  /  -1      /
      DATA                  SVN     /  -1      /
      DATA                  SVNPKT  /  -1      /
      DATA                  SVOK    /  .FALSE. /
      DATA                  SVPKDB  /  -1      /
      DATA                  SVPKND  /  -1      /
      DATA                  SVPKSZ  /  -1      /
      DATA                  SVSTYP  /  -1      /
      DATA                  SVWNSZ  /  -1      /

      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'SPKR19' )

C
C     Before any error checks are done, copy the status from
C     the previous call. Set the saved status variable to
C     .FALSE. here so it will be .FALSE. on exit unless this
C     call is successful.
C
      PRVOK = SVOK
      SVOK  = .FALSE.

C
C     Terminology: below, the phrase "base address of 'X'" refers to
C     the DAF address immediately preceding X. Base addresses simplify
C     mapping DAF array (here "array" means an array stored in
C     consecutive DAF addresses, not "segment") indices to DAF
C     addresses, since the DAF address of the Ith array element is
C     obtained by adding I to the DAF array's base address.
C
C     Key variables:
C
C        Name      Meaning
C        ----      -------
C        BADDR     Segment begin DAF address.
C
C        DIRBAS    Base address of interpolation interval directory.
C
C        EADDR     Segment end DAF address.
C
C        FIRST     Index (mini-segment-relative) of first time tag in
C                  sequence transferred to to output record.
C
C        HIGH      Index (mini-segment-relative) of time tag following
C                  the tag at index LOW (see description below).
C
C        IVBIX     Index in the interpolation interval bounds array of
C                  the start time of the applicable interval.
C
C        IVLBAS    Base address of interpolation interval time bounds.
C
C        IVLSEL    Interval selection flag: this routine selects the
C                  last applicable interval if true; otherwise it
C                  selects the first applicable interval.
C
C        LAST      Index (mini-segment-relative) of last time tag in
C                  sequence transferred to the output record.
C
C        LOW       Index (mini-segment-relative) of last time tag less
C                  than the request time, or of the first time tag if
C                  this tag equals the request time.
C
C        MINIB,
C        MINIE     Mini-segment begin and end DAF addresses. These
C                  addresses are absolute, not segment-relative.
C
C        MINIIX    Interpolation interval/mini-segment index.
C
C        N         Count of interpolation intervals/mini-segments.
C
C        NDIR      Number of interpolation interval time bounds
C                  directories.
C
C        NPKDIR    Number of packet directory entries for current
C                  mini-segment.
C
C        NPKT      Packet count for current mini-segment.
C
C        NRCPKT    Output record packet count. Note that this count,
C                  due to reduction of order at mini-segment
C                  boundaries, may be smaller than the window size
C                  stored in the current mini-segment.
C
C        PKDBAS    Base address of packet directory for current
C                  mini-segment.
C
C        PKTSIZ    Size of packets of current mini-segment.
C
C        SUBTYP    Subtype of current mini-segment.
C
C        TIMBAS    Base address of time tags of current mini-segment.
C
C        WNDSIZ    Interpolation window size of current mini-segment.
C
C
C     Re-used variables: the variables shown in the list below
C     are used as short-duration variables, much like loop index
C     variables; they are re-used as needed.
C
C        BUFBAS
C        BUFFER
C        GROUP
C        NREAD
C        REMAIN
C
C     Start with a parameter compatibility check on the first
C     pass.
C
      IF ( PASS1 ) THEN

         IF ( MAXREC .LT. MAXRSZ ) THEN

            CALL SETMSG ( 'SPK type 19 record size may be as '
     .      //            'large as #, but SPKPVN record size '
     .      //            '(defined in spkrec.inc) is #.'      )
            CALL ERRINT ( '#',  MAXRSZ                         )
            CALL ERRINT ( '#',  MAXREC                         )
            CALL SIGERR ( 'SPICE(BUG)'                         )

         END IF

C
C        Indicate the first pass was completed.
C
         PASS1 = .FALSE.

      END IF

C
C     Unpack the segment descriptor, and get the start and end
C     addresses of the segment.
C
      CALL DAFUS ( DESCR, 2, 6, DC, IC )

      TYPE  = IC( 4 )
      BADDR = IC( 5 )
      EADDR = IC( 6 )

C
C     Check the request time against the bounds in the segment
C     descriptor.
C
      IF (  ( ET .LT. DC(1) )  .OR.  ( ET .GT. DC(2) )  )  THEN

         CALL SETMSG( 'Request time # is outside of descriptor '
     .   //           'bounds # : #.'                           )
         CALL ERRDP ( '#',  ET                                  )
         CALL ERRDP ( '#',  DC(1)                               )
         CALL ERRDP ( '#',  DC(2)                               )
         CALL SIGERR( 'SPICE(TIMEOUTOFBOUNDS)'                  )
         CALL CHKOUT( 'SPKR19'                                  )
         RETURN

      END IF

C
C     Decide whether we're looking at the same segment we saw on the
C     previous call, and whether the interpolation interval used on
C     that call is still applicable.
C
C     Re-use of data from a previous call requires that the saved
C     data were set on a successful call.
C
      SAMSEG  =       ( HANDLE .EQ.  SVHAN )
     .          .AND. ( BADDR  .EQ.  SVBEG )
     .          .AND.                PRVOK

C
C     Give SAMIVL an initial value. If we do have the
C     same interval, update SAMIVL to indicate this.
C
      SAMIVL = .FALSE.

      IF ( SAMSEG ) THEN
C
C        We now assume that all data saved from the last
C        read of this segment are valid.
C
         IF ( SVLAST ) THEN
C
C           We pick the last interval containing ET. For
C           all intervals but the last, ET must be
C           less than the interval end time.
C
            IF ( SVMIIX .LT. SVN ) THEN

               SAMIVL =       ( ET .GE. SVBTIM )
     .                  .AND. ( ET .LT. SVETIM )
            ELSE

               SAMIVL =         ET .GE. SVBTIM
     .                  .AND. ( ET .LE. SVETIM )

            END IF

         ELSE
C
C           We pick the first interval containing ET. For
C           all intervals but the first, ET must be
C           greater than the interval start time.
C
            IF ( SVMIIX .GT. 1 ) THEN

               SAMIVL =       ( ET  .GT. SVBTIM )
     .                  .AND. ( ET  .LE. SVETIM )

            ELSE

               SAMIVL =         ET  .GE. SVBTIM
     .                  .AND. ( ET  .LE. SVETIM )

            END IF

         END IF

      END IF

      IF ( SAMSEG .AND. SAMIVL ) THEN
C
C        We're looking at the same segment as last time, and the
C        interpolation interval we looked up last time is applicable
C        for the input time ET.
C
C        Simply restore the segment and interval parameters we
C        saved from the previous lookup.
C
C        We don't need to restore the segment start DAF address
C        BADDR, since we've already extracted it from DESCR.
C
C        Restore
C
C           - The mini-segment's packet directory count
C           - The mini-segment's packet directory base address
C
         NPKDIR = SVPKND
         PKDBAS = SVPKDB

C
C        Restore
C
C           - The mini-segment/interval count
C           - The mini-segment/interval index
C           - The mini-segment/interval start pointer
C
         N      = SVN
         MINIIX = SVMIIX
         MINIB  = SVMINB

C
C        Restore
C
C           - The mini-segment subtype
C           - The mini-segment packet size
C           - The mini-segment packet count
C           - The mini-segment window size
C
         SUBTYP = SVSTYP
         PKTSIZ = SVPKSZ
         NPKT   = SVNPKT
         WNDSIZ = SVWNSZ

      ELSE
C
C        The segment and interval information for the current segment
C        must be looked up.
C
C        Perform checks on this segment.
C
C        Make sure that this really is a type 19 data segment.
C
         IF ( TYPE .NE. 19 ) THEN

            CALL SETMSG( 'You are attempting to locate type * '
     .      //           'data in a type 19 data segment.'      )
            CALL ERRINT( '*',  TYPE                             )
            CALL SIGERR( 'SPICE(WRONGSPKTYPE)'                  )
            CALL CHKOUT( 'SPKR19'                               )
            RETURN
         END IF

C
C        Locate the interpolation interval that contains the request
C        time.
C
C        Before getting started, we need to determine which interval to
C        use if the request time lies on a boundary between two
C        intervals. The segment's interval selection flag tells us how
C        to resolve this.
C
         CALL DAFGDA ( HANDLE, EADDR-1, EADDR, CONTRL )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

         ISEL   = NINT ( CONTRL(1) )
         N      = NINT ( CONTRL(2) )

         IVLSEL = ISEL .EQ. ITRUE

C
C        Determine the number of interval directory entries in the
C        segment. Note that for most SPK types, this computation is
C        performed by computing
C
C           ( N - 1 ) / DIRSIZ
C
C        where N is the segment's epoch count.
C
C        However the set of items in this case is a sequence
C        of N start times followed by a final stop time, so
C        the epoch count is
C
C           N + 1
C
C        and the numerator in the ratio above is incremented by 1.
C
         NDIR = N / DIRSIZ

C
C        Note that the directory placement scheme always leaves
C        a non-empty set of epochs following the last directory
C        entry.
C
C        Let DIRBAS be the base address of the interval directory.
C        We'll compute DIRBAS whether or not the interval directory
C        is non-empty.
C
C        If the interval directory is non-empty, it spans the address
C        range
C
C           DIRBAS+1 : DIRBAS+NDIR
C
C        We compute DIRBAS by starting at the end of the segment
C        and skipping over the control area, the mini-segment
C        start/stop pointers, and the interval directory itself.
C
         DIRBAS = EADDR - 2 - ( N + 1 ) - NDIR

C
C        The way we search the directory depends on the treatment
C        of request times that lie on interval boundaries.
C
         IF ( IVLSEL ) THEN
C
C           If there is an interval directory, search it to determine
C           the group of interval times to search next.
C
            IF ( NDIR .GT. 0 ) THEN
C
C              Find the last directory entry *less than or equal to*
C              the request time. The directory entry *after* that one,
C              if such exists, is the one to pick.
C
               NREAD  = MIN ( NDIR, BUFSIZ )
               BUFBAS = DIRBAS

C
C              Fetch the current batch of directory entries.
C
               CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

               IF ( FAILED() ) THEN
                  CALL CHKOUT( 'SPKR19' )
                  RETURN
               END IF

               REMAIN = NDIR - NREAD

C
C              The variable NREAD always contains a positive value at
C              this point, so we can use it as an array index.
C
               DO WHILE (       ( REMAIN        .GT. 0  )
     .                    .AND. ( BUFFER(NREAD) .LE. ET )  )

                  BUFBAS = BUFBAS + NREAD
                  NREAD  = MIN ( REMAIN, BUFSIZ )
C
C                 Fetch the current batch of directory entries.
C
                  CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

                  IF ( FAILED() ) THEN
                     CALL CHKOUT( 'SPKR19' )
                     RETURN
                  END IF

                  REMAIN = REMAIN - NREAD

               END DO

C
C              Count the directory entries that are less than or equal
C              to ET. The number we skipped over before the final loop
C              iteration is BUFBAS-DIRBAS. The index of the group of
C              epochs containing ET exceeds the skipped directory count
C              by 1.
C
               GROUP =    BUFBAS - DIRBAS
     .                 +  LSTLED ( ET, NREAD, BUFFER )
     .                 +  1

            ELSE
C
C              There's no question about which group of epochs to
C              search.
C
               GROUP = 1

            END IF

C
C           Let IVBAS be the base address of the sequence of interval
C           time bounds.
C
            IVBAS  = DIRBAS - ( N + 1 )

C
C           Now find the index of the last interval boundary less than
C           or equal to ET. We'll need to read the current group of
C           epochs first, so compute the base of the range of addresses
C           containing this group.

            BUFBAS = IVBAS + ( ( GROUP - 1 ) * DIRSIZ )

C
C           Compute the number of epochs to read. Note that all groups
C           of epochs except the last have DIRSIZ elements.
C
            REMAIN = ( N + 1 ) - ( ( GROUP - 1 ) * DIRSIZ )
C
C           Note that REMAIN is always non-zero, since there's always
C           at least one epoch that exceeds the last directory entry.
C
            NREAD  = MIN ( DIRSIZ, REMAIN )

            CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

            IF ( FAILED() ) THEN
               CALL CHKOUT( 'SPKR19' )
               RETURN
            END IF

C
C           Find the index of the first epoch greater than ET. The case
C           where ET matches the final epoch must be handled here,
C           since in this case no epoch exceeds ET.
C
            IVEIX =    BUFBAS - IVBAS
     .              +  LSTLED ( ET, NREAD, BUFFER )
     .              +  1

            IVEIX = MIN ( IVEIX,  N+1 )

C
C           Backstop test:
C
            IF ( IVEIX .LT. 2 ) THEN

               CALL SETMSG ( 'IVEIX = #.' )
               CALL ERRINT ( '#', IVEIX   )
               CALL SIGERR ( 'SPICE(BUG)' )
               CALL CHKOUT ( 'SPKR19'     )
               RETURN

            END IF

C
C           The epoch at index IVEIX is the end time of the
C           interpolation interval we'll use. The index of
C           the interval itself is IVEIX - 1.
C
            MINIIX = IVEIX - 1

         ELSE
C
C           IVLSEL is .FALSE., meaning we must pick the first interval
C           containing the request time.
C
C           If there is an interval directory, search it to determine
C           the group of interval times to search next.
C
            IF ( NDIR .GT. 0 ) THEN
C
C              Find the last directory entry *less than* the request
C              time. The directory entry *after* that one, if such
C              exists, is the one to pick.
C
               NREAD  = MIN ( NDIR, BUFSIZ )
               BUFBAS = DIRBAS
               REMAIN = NDIR - NREAD

C
C              Fetch the current batch of directory entries.
C
               CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

               IF ( FAILED() ) THEN
                  CALL CHKOUT( 'SPKR19' )
                  RETURN
               END IF

C
C              The variable NREAD always contains a positive value at
C              this point, so we can use it as an array index.
C
                DO WHILE (      ( REMAIN        .GT. 0  )
     .                    .AND. ( BUFFER(NREAD) .LT. ET )  )

                  BUFBAS = BUFBAS + NREAD
                  NREAD  = MIN ( REMAIN, BUFSIZ )
C
C                 Fetch the current batch of directory entries.
C
                  CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

                  IF ( FAILED() ) THEN
                     CALL CHKOUT( 'SPKR19' )
                     RETURN
                  END IF

                  REMAIN = REMAIN - NREAD

               END DO

C
C              Count the directory entries that are less than ET. The
C              number we skipped over before the final loop iteration
C              is BUFBAS-DIRBAS. The index of the group of epochs
C              containing ET exceeds the skipped directory count by 1.
C
               GROUP =    BUFBAS - DIRBAS
     .                 +  LSTLTD ( ET, NREAD, BUFFER )
     .                 +  1

            ELSE
C
C              There's no question about which group of epochs to
C              search.
C
               GROUP = 1

            END IF

C
C           Let IVBAS be the base address of the sequence of interval
C           time bounds.
C
            IVBAS  = DIRBAS - ( N + 1 )

C
C           Now find the index of the last interval epoch less than ET.
C           We'll need to read the current group of epochs first, so
C           compute the base of the range of addresses containing this
C           group.

            BUFBAS = IVBAS + ( ( GROUP - 1 ) * DIRSIZ )

C
C           Compute the number of epochs to read. Note that all groups
C           of epochs except the last have DIRSIZ elements.
C
            REMAIN = ( N + 1 ) - ( ( GROUP - 1 ) * DIRSIZ )
C
C           Note that REMAIN is always non-zero, since there's always
C           at least one epoch that exceeds the last directory entry.
C
            NREAD  = MIN ( DIRSIZ, REMAIN )

            CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

            IF ( FAILED() ) THEN
               CALL CHKOUT( 'SPKR19' )
               RETURN
            END IF

C
C           Find the index of the last epoch less than ET. The case
C           where ET matches the first epoch must be handled here,
C           since in this case no epoch precedes ET.
C
            IVBIX =    BUFBAS - IVBAS
     .              +  LSTLTD ( ET, NREAD, BUFFER )

            IVBIX = MAX ( IVBIX,  1 )

C
C           Backstop test:
C
            IF ( IVBIX .GT. N ) THEN

               CALL SETMSG ( 'IVBIX = #.' )
               CALL ERRINT ( '#', IVBIX   )
               CALL SIGERR ( 'SPICE(BUG)' )
               CALL CHKOUT ( 'SPKR19'     )
               RETURN

            END IF

C
C           The epoch at index IVBIX is the begin time of the
C           interpolation interval we'll use. The index of the interval
C           itself is also IVBIX.
C
            MINIIX = IVBIX

         END IF
C
C        This is the end of the IF block that handles mini-segment
C        selection for the two possible values of IVLSEL.
C
C        Look up the begin and end pointers of the mini-segment at index
C        MINIIX. For the first N-1 mini-segments, the "end pointer"
C        of one mini-segment is the "begin" pointer of the next.
C
         BUFBAS = EADDR - 2 - ( N + 1 ) + ( MINIIX - 1 )

         CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+2, BUFFER )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

         MINIB = NINT ( BUFFER(1) ) + BADDR - 1
C
C        Note that the end of the current mini-segment
C        precedes the start of the next mini-segment by
C        one address.
C
         MINIE = NINT ( BUFFER(2) ) + BADDR - 2

C
C        Look up the time bounds of the mini-segment at index MINIIX.
C        These bounds are used quite a bit farther on, when we save
C        them for future use.
C
         CALL DAFGDA ( HANDLE, IVBAS+MINIIX, IVBAS+MINIIX+1, MINTIM )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

C
C        From this point onward, we'll work with the mini-segment
C        that occupies the address range MINIB : MINIE.
C
C        Look up the control area of the mini-segment.
C
         CALL DAFGDA ( HANDLE, MINIE-CTRLSZ+1, MINIE, CONTRL )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

C
C        Fetch the control area parameters for the mini-segment.
C
         SUBTYP  =  NINT ( CONTRL(1) )
         WNDSIZ  =  NINT ( CONTRL(2) )
         NPKT    =  NINT ( CONTRL(3) )

         IF (  ( SUBTYP .LT. 0 ) .OR. ( SUBTYP .GE. S19NST ) ) THEN

            CALL SETMSG ( 'Unexpected SPK type 19 subtype # found in '
     .      //            'type 19 segment within mini-segment #.'     )
            CALL ERRINT ( '#',  SUBTYP                                 )
            CALL ERRINT ( '#',  MINIIX                                 )
            CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                        )
            CALL CHKOUT ( 'SPKR19'                                     )
            RETURN

         END IF

         PKTSIZ = PKTSZS ( SUBTYP )
         MAXWND = MXWNSZ ( SUBTYP )

C
C        Check the window size.
C
         IF ( ( WNDSIZ .LT. 2 ) .OR. ( WNDSIZ .GT. MAXWND ) ) THEN

            CALL SETMSG ( 'Window size in type 19 segment was #; must '
     .      //            'be in the range 2:# for subtype #. '
     .      //            'Mini-segment index is #.'                   )
            CALL ERRINT ( '#',  WNDSIZ                                 )
            CALL ERRINT ( '#',  MAXWND                                 )
            CALL ERRINT ( '#',  SUBTYP                                 )
            CALL ERRINT ( '#',  MINIIX                                 )
            CALL SIGERR ( 'SPICE(INVALIDVALUE)'                        )
            CALL CHKOUT ( 'SPKR19'                                     )
            RETURN

         END IF

         IF ( ODD(WNDSIZ) ) THEN

            CALL SETMSG ( 'Window size in type 19 segment was #; '
     .      //            'must be even for subtype #. '
     .      //            'Mini-segment index is #.'               )
            CALL ERRINT ( '#',  WNDSIZ                             )
            CALL ERRINT ( '#',  SUBTYP                             )
            CALL ERRINT ( '#',  MINIIX                             )
            CALL SIGERR ( 'SPICE(INVALIDVALUE)'                    )
            CALL CHKOUT ( 'SPKR19'                                 )
            RETURN

         END IF

C
C        Compute the number of packet directory entries for
C        the current mini-segment/interval.
C
         NPKDIR  =  (NPKT-1) / DIRSIZ
C
C        Compute the base address of the sequence of packet
C        directory entries for the current mini-segment/interval.
C
         PKDBAS  =  MINIB - 1 + ( NPKT * ( PKTSIZ + 1 ) )

C
C        The test below is done for safety. No SPICE error s
C        should ever be detected at this point.
C
         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

C
C        If we made it this far, we did so without a SPICE error. We
C        have valid segment parameters which can be saved for the next
C        call.
C
C        Save
C
C           - The DAF handle
C           - The segment begin DAF address
C           - The segment's "select last/first interval" flag
C
         SVHAN  = HANDLE
         SVBEG  = BADDR
         SVLAST = IVLSEL

C
C        Save the time bounds of the applicable mini-segment/interval.
C
         SVBTIM = MINTIM(1)
         SVETIM = MINTIM(2)

C
C        Save
C
C           - The mini-segment/interval directory count
C           - The mini-segment/interval directory base address
C
         SVPKND = NPKDIR
         SVPKDB = PKDBAS

C
C        Save
C
C           - The mini-segment/interval count
C           - The mini-segment/interval index
C           - The mini-segment/interval start pointer
C
         SVN    = N
         SVMIIX = MINIIX
         SVMINB = MINIB

C
C        Save
C
C           - The mini-segment subtype
C           - The mini-segment packet size
C           - The mini-segment packet count
C           - The mini-segment window size
C
         SVSTYP = SUBTYP
         SVPKSZ = PKTSIZ
         SVNPKT = NPKT
         SVWNSZ = WNDSIZ

      END IF

C
C     We're ready to construct the output record. The first step is to
C     identify the indices of the packets and epochs corresponding to
C     the request.
C
C     We'll now select the set of packets that define the interpolating
C     polynomials.   We'll start out by finding the first directory
C     entry that is greater than or equal to the request epoch.  We'll
C     use the variable GROUP to indicate the set of epochs to search
C     within, once we've found the right directory entry.
C
      IF ( NPKDIR .EQ. 0 ) THEN
C
C        There's no mystery about which group of epochs to search.
C
         GROUP  = 1

      ELSE
C
C        There's at least one directory entry. Find the first directory
C        entry whose time is greater than or equal to the request time,
C        if there is such an entry.  We'll search linearly through the
C        directory entries, reading up to DIRSIZ of them at a time.
C        Having found the correct set of directory entries, we'll
C        perform a binary search within that set for the desired entry.
C
         BUFBAS  =  PKDBAS
         NREAD   =  MIN ( NPKDIR, DIRSIZ )
         REMAIN  =  NPKDIR - NREAD

         CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'SPKR19' )
            RETURN
         END IF

         DO WHILE (       ( BUFFER(NREAD) .LT. ET )
     .              .AND. ( REMAIN        .GT. 0  )   )

            BUFBAS  =  BUFBAS + NREAD
            NREAD   =  MIN ( REMAIN, DIRSIZ )
            REMAIN  =  REMAIN - NREAD
C
C           Note:  NREAD is always > 0 here.
C
            CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

            IF ( FAILED() ) THEN
               CALL CHKOUT ( 'SPKR19' )
               RETURN
            END IF

         END DO

C
C        At this point, BUFBAS - PKDBAS is the number of directory
C        entries preceding the one contained in BUFFER(1).
C
         GROUP  =     ( BUFBAS - PKDBAS )
     .              +   LSTLTD ( ET, NREAD, BUFFER )
     .              +   1
      END IF

C
C     GROUP now indicates the set of epochs in which to search for the
C     request epoch.  If GROUP is 1, the request time lies within the
C     inclusive time interval bounded by the first and last epochs of
C     the first group.  Otherwise, the request time lies in the time
C     interval bounded by the last element of the preceding group and
C     the last element of the current group.
C
C     We'll use the variable names BEGIDX and ENDIDX to refer to
C     the indices, relative to the set of time tags, of the first
C     and last time tags in the set we're going to look up.
C
      IF ( GROUP .EQ. 1 ) THEN

         BEGIDX  =  1
         ENDIDX  =  MIN ( NPKT, DIRSIZ )

      ELSE
C
C        If the group index is greater than 1, we'll include the last
C        time tag of the previous group in the set of time tags we look
C        up.  That way, the request time is bracketed by the time tag
C        set we look up.
C
         BEGIDX  =      (  GROUP  - 1 ) * DIRSIZ
         ENDIDX  =  MIN (  BEGIDX + DIRSIZ,  NPKT  )

      END IF

      TIMBAS  =  PKDBAS - NPKT

      CALL DAFGDA ( HANDLE, TIMBAS+BEGIDX, TIMBAS+ENDIDX, BUFFER )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'SPKR19' )
         RETURN
      END IF

C
C     Find two adjacent epochs bounding the request epoch.  The request
C     time cannot be greater than all of epochs in the group, and it
C     cannot precede the first element of the group.
C
      I  =  LSTLTD (  ET,  ENDIDX-BEGIDX+1,  BUFFER  )

C
C     The variables LOW and high are the indices of a pair of time
C     tags that bracket the request time.
C
      IF ( I .EQ. 0 ) THEN
         LOW  =  1
      ELSE
         LOW  =  BEGIDX + I - 1
      END IF

      HIGH  =  LOW  +  1

C
C     Now select the set of packets used for interpolation.  Note
C     that the window size is known to be even.
C
C     Unlike SPK types 8, 9, 12, and 13, for type 19 we allow the
C     window size to shrink when the window must be truncated due to
C     proximity to an interval boundary.
C
C     The nominal bracketing epochs we've found are the (WNDSIZ/2)nd
C     and (WNDSIZ/2 + 1)st of the interpolating set.  If the
C     request time is too close to one end of the coverage interval,
C     we reduce the window size, after which one endpoint of the
C     window will coincide with an endpoint of the coverage interval.
C
C     Let LSIZE be the size of the "left half" of the window:  the
C     size set of window epochs to the left of the request time.
C     We want this size to be WNDSIZ/2, but if not enough states are
C     available, the set ranges from index 1 to index LOW.
C

      LSIZE =  MIN ( WNDSIZ/2, LOW )

C
C     RSIZE is defined analogously for the right half of the window.
C
      RSIZE =  MIN (  WNDSIZ/2,  ( NPKT - HIGH + 1 )  )

C
C     The actual window size is simply the sum of LSIZE and RSIZE.
C
      NRCPKT =  LSIZE + RSIZE

C
C     FIRST and LAST are the endpoints of the range of indices of
C     time tags (and packets) we'll collect in the output record.
C
      FIRST =  LOW    -  LSIZE   +  1

      LAST  =  FIRST  +  NRCPKT  -  1

C
C     We're ready to construct the output record.
C
C     Put the subtype and window size into the output record.
C
      RECORD(1) =  SUBTYP

      RECORD(2) =  NRCPKT

C
C     Read the packets.
C
      CALL DAFGDA ( HANDLE,
     .              MINIB + (FIRST-1)*PKTSIZ,
     .              MINIB +      LAST*PKTSIZ  -  1,
     .              RECORD(3)                       )

C
C     Finally, add the epochs to the output record.
C     Read the sequence of time tags.
C
      BUFBAS  =  ( MINIB - 1 )  +  ( NPKT * PKTSIZ )  +  ( FIRST - 1 )

      CALL DAFGDA ( HANDLE,
     .              BUFBAS+1,
     .              BUFBAS+NRCPKT,
     .              RECORD( 3 + NRCPKT*PKTSIZ )  )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'SPKR19' )
         RETURN
      END IF

C
C     The call was successful. Record this fact so that saved
C     interval data are available for re-use.
C
      SVOK = .TRUE.

      CALL CHKOUT ( 'SPKR19' )
      RETURN
      END


module bulge

  use dm       ! Contains dm structure and dm exploitation functions
  use stars    ! Contains stars structure and stars exploitation functions
  use dust     ! Contains dust structure definition and dust exploitation functions

  public

  !*****************************************************************************************************************
  !
  !  OVERVIEW
  !
  !  bulge_module defines the bulge data structure univ(ts)%halo(ih)%galaxy%bulge
  !
  !  In the header of the module are defined output properties of the bulge component (labels, units and formats).
  !  The bulge module contains the defintion of this structure and all functions and subroutines associated to the bulge structure.
  !  In the current model, the bulge component is considered as a passive component, gas is only considered as non-star-forming gas
  !  The gas contained in the bulge comes from the stellar evolution cycle.
  !  During a merger event, all the gas produced by stars in the bulge is transfered to the diffuse disc gas component
  !  The bulge evolution procedure is divided in two processes, bulge_evolve_I and bulge_evolve_II
  !
  !  MPI PROCESSES IN THIS MODULE
  !
  !   bulge_send_data                                 : send specific informations about a bulge in a given galaxy
  !
  !   bulge_receive_data                              : receive specific informations about a bulge in a given galaxy
  !
  !  SUBROUTINES IN THIS MODULE
  !
  !   bulge_void                                      : init all properties of the bulge structure
  !
  !   bulge_copy                                      : copy a bulge component to an other one
  !
  !   bulge_evolve_I                                  : first part (PREDICTOR) of the bulge evolution scheme
  !      called by : galaxy_evolve                         compute input, output and evolution rates associated to the gas structuration history
  !
  !   bulge_evolve_II                                 : second part (CORRECTOR) of the bulge evolution scheme
  !       called by : galaxy_evolve
  !
  !   bulge_deallocate                                : deallocate all allocated array used in a bulge structure
  !
  !  FUNCTIONS IN THIS MODULE
  !
  !   bulge_mass                                      : returns the mass of the bulge component (or the mass of a sub-bulge component gas or stars)
  !
  !   bulge_gas_signature                             : return the signature of a given gas component
  !
  !   bulge_frac_mass_radius                          : returns the radius which enclose a given fraction of the bulge mass
  !
  !   isolated_bulge_velocity (INTERFACE VERSION)     : returns the rotational velocity of an isolated bulge (Hernquist profile)
  !
  !   isolated_bulge_velocity_ (CORE VERSION)
  !
  !   stellar_velocity_dispersion                     : returns the stellar velovity dispersion (Herquist 1990 Eq. (10))
  !
  !  PRINTING PROCEDURES
  !
  !   bulge_load_bulge_data
  !      called by  : bulge_print                     :  create the output property list of the bulge component
  !
  !   disc_print                                      : print bulge-properties in output files
  !       called by : bulge_evolve_II
  !
  !*****************************************************************************************************************

  type bulge_type
    ! Evolution
    real(kind=8)      :: life_time ! the time evolution of this bulbe component
    real(kind=8)      :: age_form  ! age of the universe when the first bulge has been formed
    !
    ! main components
    type(gas_type)    :: no_sfg    ! a no star forming gas (gas coming from stellar wind produced by stars evolving in the bulge)
    type(stars_type)  :: stars     ! the stellar component
    type(dust_type)   :: dust      ! the dust component
    ! bulge properties
    real(kind=8)      :: rb        ! the hernquist radius [kpc]
    real(kind=8)      :: t_dyn     ! the dynamical time of the bulge (V(size)/size) in [Gyr]
    real(kind=8)      :: dV        ! velocity dispersion of the stellar component
  end type bulge_type

  real(kind=8)        :: bulge_dt_min_use ! minimal time-step used at the bulge scale

  ! hdu reference for bulge structure
  integer(kind=4)           :: hdu_bulge
  ! printable properties for bulge structure
  integer(kind=4),parameter :: nb_bulge_field = 12 ! Number of bulge properties saved
  ! Name of each output colomn data
  character(len=ttype_len),dimension(nb_bulge_field) :: ttype_bulge = (/'bulge_age_form        ','bulge_unstr_gas       ','bulge_mZ              ', &
                                                                        'bulge_mH              ','bulge_mC              ','bulge_mN              ', &
                                                                        'bulge_mO              ','bulge_mFe             ','bulge_OH_index        ', &
                                                                        'bulge_rb              ','bulge_t_dyn           ','bulge_dV              '/)
  ! Physical unit of each column data
  character(len=tunit_len),dimension(nb_bulge_field) :: tunit_bulge = (/'Gyr         ','M_sun       ','M_sun       ','M_sun       ','M_sun       ', &
                                                                        'M_sun       ','M_sun       ','M_sun       ','wounit      ','kpc         ', &
                                                                        'Gyr         ','km/s        '/)
  ! Data type of each column data
  character(len=tform_len),dimension(nb_bulge_field) :: tform_bulge = (/'1E','1E','1E','1E','1E','1E','1E','1E','1E','1E','1E','1E'/)

  ! *** STARS ***
  ! Name of each output colomn data
  character(len=ttype_len),dimension(nb_stars_field) :: ttype_starsb = (/'bulge_stars_mass      ','bulge_stars_f_young   ', &
                                                                         'bulge_stars_age_MW    ','bulge_stars_dage_MW   ', &
                                                                         'bulge_stars_age_LW    ','bulge_stars_dage_LW   ', &
                                                                         'bulge_stars_Z_MW      ','bulge_stars_Z_LW      '/)
  ! Physical unit of each column data
  character(len=tunit_len),dimension(nb_stars_field) :: tunit_starsb = (/'M_sun       ','wounit      ','Gyr         ','Gyr         ', &
                                                                         'Gyr         ','Gyr         ','Z_sun       ','Z_sun       '/)
  ! Data type of each column data
  character(len=tform_len),dimension(nb_stars_field) :: tform_starsb = (/'1E','1E','1E','1E','1E','1E','1E','1E'/)

  ! *** DUSTS ***
  ! Name of each output colomn data
  character(len=ttype_len),dimension(nb_dust_field) :: ttype_dustb = (/'bulge_dust_f_pah      ','bulge_dust_f_bg       ', &
                                                                       'bulge_dust_tau        ','bulge_dust_mZmH       '/)
  ! Physical unit of each column data
  character(len=tunit_len),dimension(nb_dust_field) :: tunit_dustb = (/'w_o_unit    ','w_o_unit    ','w_o_unit    ','w_o_unit    '/)

  ! Data type of each column data
  character(len=tform_len),dimension(nb_dust_field) :: tform_dustb = (/'1E','1E','1E','1E'/)

contains

  !*****************************************************************************************************************
  !
  ! MPI PROCESSES
  !
  !*****************************************************************************************************************

#ifdef LUMINOUS_PROCESSES
! -------------------------------------------------
  subroutine bulge_send_data(bulge)

    ! SEND SPECIFIC INFORMATIONS ABOUT A bulge

    implicit none

    logical                       :: go_down

    type(bulge_type),intent(in)   :: bulge

    ! data are sent by physical process and receive by luminous process

    go_down = .false.

    if (bulge_mass(bulge,component='stars') .gt. 0.d0) then
        !
        ! the bulge have a stellar population
        go_down = .true.
        call MPI_SEND(go_down,1,MPI_LOGICAL,rank+1,bulge_tag+1,MPI_COMM_WORLD,ierror)
        ! send bulge typical radius
        call MPI_SEND(bulge%rb,1,MPI_REAL8,rank+1,bulge_tag+2,MPI_COMM_WORLD,ierror)
        ! send stellar population of the bulge
        call stars_send_data(bulge%stars)
        ! send dust component
        call dust_send_data(bulge%dust)
    else
        !
        ! send exit loop order
        call MPI_SEND(go_down,1,MPI_LOGICAL,rank+1,bulge_tag+1,MPI_COMM_WORLD,ierror)
    end if

    return
  end subroutine bulge_send_data

  !*****************************************************************************************************************

  subroutine bulge_receive_data(bulge)

    ! RECEIVE SPECIFIC INFORMATIONS ABOUT A bulge

    implicit none

    logical                       :: go_down

    type(bulge_type),intent(out)  :: bulge

    ! data are sent by physical process and receive by luminous process

    call bulge_void(bulge)  ! init the bulge

    ! receive exit loop order
    call MPI_RECV(go_down,1,MPI_LOGICAL,rank-1,bulge_tag+1,MPI_COMM_WORLD,statut,ierror)

    if (go_down) then
        !
        ! receive bulge typical radius
        call MPI_RECV(bulge%rb,1,MPI_REAL8,rank-1,bulge_tag+2,MPI_COMM_WORLD,statut,ierror)
        ! receive stellar population of the bulge
        call stars_receive_data(bulge%stars)
        ! receive data from dust component
        call dust_receive_data(bulge%dust)
    end if

    return
  end subroutine bulge_receive_data
! -------------------------------------------------
#endif
! LUMINOUS_PROCESSES

  !*****************************************************************************************************************

  subroutine bulge_void(bulge)

    ! INIT OR VOID A BULGE COMPONENT

    implicit none
    type(bulge_type),intent(inout) :: bulge

    ! Evolution
    bulge%life_time         = 0.d0                ! will be incremented in bulge_evolve_II
    bulge%age_form          = 0.d0                ! will be set in galaxy_merge
    !
    ! main components
    call gas_void(bulge%no_sfg)                   ! void the diffuse gas phase
    call stars_void(bulge%stars)                  ! void the stellar component
    call dust_void(bulge%dust,init_geom='dwek  ') ! void and init the dust component
    ! bulge properties
    bulge%rb                = 0.d0                ! will be set in galaxy_merge during the bulge formation process
    bulge%t_dyn             = 0.d0                ! init to null value
    bulge%dV                = 0.d0                ! init to null value

    return
  end subroutine bulge_void

  !*****************************************************************************************************************

  subroutine bulge_copy(bulge1,bulge2)

    ! COPY bulge2 IN bulge1 COMPONENT

    implicit none

    type(bulge_type),intent(inout) :: bulge1
    type(bulge_type),intent(in)    :: bulge2

    ! Evolution
    bulge1%life_time         = bulge2%life_time
    bulge1%age_form          = bulge2%age_form
    !
    ! main components
    call gas_copy(bulge1%no_sfg,bulge2%no_sfg)
    call stars_copy(bulge1%stars,bulge2%stars)
    call dust_copy(bulge1%dust,bulge2%dust)
    !
    ! bulge properties
    bulge1%rb                = bulge2%rb
    bulge1%t_dyn             = bulge2%t_dyn
    bulge1%dV                = bulge2%dV

    return
  end subroutine bulge_copy

  !*****************************************************************************************************************

  subroutine bulge_evolve_I(bulge,dt_optim)

    ! FIRST STEP OF THE BULGE EVOLUTION SCHEME
    ! This subroutine compute evolution rate associated to gas and stellar population components.

    ! In the same scheme than for a disc structure, the bulge evolution scheme is based on two successive subroutines:
    ! bulge evolve_I and bulge_evolve_II
    ! the first routine computes evolution rates (mass transfer rate) the second one, applies these evolution rates onto gas and/or stellar components
    ! to compute new masses.
    ! The bulge structure is very simple in this model, it is composed of a stellar population and a diffuse gas component.
    ! No stars are formed in the bulge structure.
    ! The gas accumulated during bulge evolution only comes from the stellar evolution.
    ! During a merger event, the gas is transferred in the disc structure.

    implicit none

    real(kind=8),intent(out)       :: dt_optim             ! the global optimal evolution time-step
    real(kind=8)                   :: dt_gas               ! the optimal time-step for gas component
    real(kind=8)                   :: dt_stars             ! the optimal time-step for the stellar population

    type(gas_type)                 :: void                 ! a null gas component
    type(bulge_type),intent(inout) :: bulge                ! the bulge component

#ifdef PRINTALL
! -------------------------------------------------
    call IO_print_message('bulge_evolve_I',only_rank=rank,component='bulge')
! -------------------------------------------------
#endif

    ! *****************************
    ! GAS
    ! *****************************
    !
    ! In the bulge evolution scheme, the gas evolving into the bulge is only produced by stellar evolution,
    !
    call gas_void(void)
    dt_gas = gas_dt_optim(bulge%no_sfg,bulge%stars%loss_rate,void,called_by='bulge_evolve_I')
    !
    ! *****************************
    ! STARS
    ! *****************************
    !
    ! in the bulge evolution sheme no stars are formed into the bulge.
    ! In this context the evolution of the the stellar popualtion is only linked to the loss_rate
    dt_stars = -1.d0 ! init
    dt_stars = stars_dt_optim(bulge%stars,void)
    !
    ! *****************************
    ! COMPUTE THE OPTIMAL TIME-STEP
    ! *****************************
    !
    dt_optim = -1.d0 ! init
    if (dt_gas .gt. 0.d0) dt_optim = dt_gas
    !
    if (dt_optim .gt. 0.d0) then
      !
      if (dt_stars .gt. 0.d0) then
        !
        dt_optim = min(dt_stars,dt_optim)
      end if
    else
      !
      if (dt_stars .gt. 0.d0) then
        !
        dt_optim = dt_stars
      end if
    end if
    !
    if (dt_optim .eq. 0.d0) then
        !
        call IO_print_warning_message('dt = 0.',only_rank=rank,called_by='bulge_evolve_I')
#ifdef PRINT_WARNING
! -------------------------------------------------
        call IO_print_message('used',only_rank=rank,component='bulge', &
                param_name = (/'dt_optim                 ','dt_gas                   ','dt_stars                 '/), &
                real_param_val  = (/dt_optim,dt_gas,dt_stars/))
! -------------------------------------------------
#endif
! PRINT_WARNING
    end if
    !
    if ((dt_optim .gt. 0.d0) .and. (dt_optim .lt. num_precision)) then
        !
        call IO_print_warning_message('Very small timestep',only_rank=rank,called_by='bulge_evolve_I')
#ifdef PRINT_WARNING
! -------------------------------------------------
        call IO_print_message('used',only_rank=rank,component='bulge', &
                param_name = (/'dt_optim                 ','dt_gas                   ','dt_stars                 '/), &
                real_param_val  = (/dt_optim,dt_gas,dt_stars/))
! -------------------------------------------------
#endif
! PRINT_WARNING
    end if
    !
#ifdef PRINTALL
! -------------------------------------------------
    call IO_print_message('bulge_evolve_I ... done ',only_rank=rank,component='bulge')
! -------------------------------------------------
#endif

    return
  end subroutine bulge_evolve_I

  !*****************************************************************************************************************

  subroutine bulge_evolve_II(bulge,dt)

    ! SECOND STEP OF THE BULGE EVOLUTION SCHEME (EVOLVE MASS COMPONENT)
    ! take into account evolution rates computed in bulge_evolve_I

    implicit none

    real(kind=8),intent(in)           :: dt                    ! the evolution time-step
    real(kind=8)                      :: Unosfg, dU            ! mass variation test

    type(gas_type)                    :: loss_rate_prior       ! mass loss rate used as prior value in bulge_evolve_I
    type(gas_type)                    :: loss_rate             ! effective stellar mass loss rate

    type(bulge_type),intent(inout)    :: bulge                 ! the bulge component

#ifdef PRINTALL
! -------------------------------------------------
    call IO_print_message('bulge_evolve_II',only_rank=rank,component='bulge')
! -------------------------------------------------
#endif

    if (dt .le. 0.d0) then
      !
      call IO_print_error_message('dt <= 0.',called_by = 'bulge_evolve_II')
      stop ! stop the program
    end if

    if (bulge_mass(bulge) .gt. 0.d0) then
        !
        ! Evolution
        if ((bulge%life_time .eq. 0.d0) .and. (bulge%age_form .gt. 0.d0)) then
            !
            ! print the starting state of the bulge component
            if (FOLLOW_UP .and. PR_FOLLOW_UP) call bulge_print(follow_up_unit(current_index),'fits',bulge)
        end if
        !
        Unosfg = bulge_mass(bulge,component='nosfg')
        !
        ! *****************************
        ! STARS
        ! *****************************
        !
        ! Save the previous mass loss rate, used as prior
        loss_rate_prior = bulge%stars%loss_rate
        call stars_evolve(bulge%stars,dt,loss_rate)
        !
        ! *****************************
        ! GAS
        ! *****************************
        !
        ! Add gas ejected by stars to the diffuse gas reservoir (no_sfg)
        call gas_add(bulge%no_sfg,loss_rate*dt)
        !
        ! Test nosfg mass variation
        if (Unosfg .gt. M_gas_min) then
            !
            dU = abs(bulge_mass(bulge,component='nosfg')-Unosfg)
            if ((abs(dU)/Unosfg) .gt. physical_precision) then
              !
              call IO_print_error_message('No quasi-static state of the nosfg component',only_rank=rank,called_by='bulge_evolve_II')
              call IO_print_message('with',only_rank=rank,component='bulge', &
                          param_name = (/'dU/U (%)                 ','U                        ','dU                       ',&
                                         'loss_rate_prior          ','loss_rate                '/), &
                          real_param_val = (/1.d2*dU/Unosfg,Unosfg,dU,gas_mass(loss_rate_prior),gas_mass(loss_rate)/))
              stop  ! stop the program
            end if
        end if
        !
        ! *****************************
        ! DUST
        ! *****************************
        ! evolve dust properties
        ! dust_evolve(d,gas,rc,incl), rc is the half mass radius
        call dust_evolve(bulge%dust,bulge%no_sfg,(1.d0+sqrt(2.d0))*bulge%rb)
        !
        ! *****************************
        ! SET bulge PROPERTIES
        ! *****************************
        !
        ! Add time to the bulge evolution time
        bulge%life_time = bulge%life_time + dt
        ! Update stellar velocity dispersion
        bulge%dV = stellar_velocity_dispersion(bulge)
        !
        ! Print instantaneous bulge properties of the followed bulge
        if (FOLLOW_UP .and. PR_FOLLOW_UP) call bulge_print(follow_up_unit(current_index),'fits',bulge)
     end if

#ifdef PRINTALL
! -------------------------------------------------
     call IO_print_message('bulge_evolve_II ... done ',only_rank=rank,component='bulge')
! -------------------------------------------------
#endif

     return
  end subroutine bulge_evolve_II

  !*****************************************************************************************************************

  subroutine bulge_deallocate(bulge)

    implicit none

    type(bulge_type),intent(inout) :: bulge  ! a bulge component

    call stars_deallocate(bulge%stars)

    return
  end subroutine bulge_deallocate

  !*****************************************************************************************************************
  !
  ! FUNCTIONS
  !
  !*****************************************************************************************************************

  function bulge_mass(bulge,r,component)

    ! RETURN THE TOTAL BULGE MASS
    ! component is : no_sfg, all_gas or stars
    ! if r is present, return mass enclosed in the radius r

    implicit none

    character(*),intent(in),optional  :: component    ! allow to select the bulge component (sfg, non-sfg, stars)
    character(MAXPATHSIZE)            :: message      ! a message to display

    real(kind=8),intent(in),optional  :: r            ! radius
    real(kind=8)                      :: bulge_mass   ! the bulge mass

    type(bulge_type),intent(in)       :: bulge        ! a bulge component

    bulge_mass = gas_mass(bulge%no_sfg) + stars_mass(bulge%stars)

    if (bulge_mass .le. 0.d0) return ! no bulge

    if (present(component)) then
       !
       select case (trim(component))
       case ('no_sfg','all_gas','gas','nosfg')
          bulge_mass = gas_mass(bulge%no_sfg)
       case ('stars')
          bulge_mass = stars_mass(bulge%stars)
       case default
          write(message,'(a,a,a)') 'Keyword ', trim(component), ' not defined'
          call IO_print_error_message(trim(message),only_rank=rank,called_by='bulge_mass')
          stop  ! stop the program
       end select
    else
       !
       bulge_mass = gas_mass(bulge%no_sfg) + stars_mass(bulge%stars)
    end if
    !
    ! ADAPT TO THE RADIUS R
    if (present(r)) then
      !
      if (r .le. 0.d0) then
        !
        call IO_print_error_message('r <= 0.',only_rank=rank,called_by='bulge_mass')
        stop  ! stop the program
      end if
      if (bulge%rb .le. 0.d0) then
        !
        call IO_print_error_message('rb <= 0.',only_rank=rank,called_by='bulge_mass')
        stop  ! stop the program
      endif
      bulge_mass = bulge_mass*r**2./(r+bulge%rb)**2.   ! apply geometrical function
    end if
    !
    ! CHECK the results and crash the code if bulge_mass is NAN
    if (is_NaN(bulge_mass)) then
      !
      call IO_print_error_message('bulge_mass is NaN',only_rank=rank,called_by='bulge_mass')
      call IO_print_message('with',only_rank=rank,component='bulge', &
               param_name = (/'non-sfg                  ','stars                    '/), &
               real_param_val  = (/gas_mass(bulge%no_sfg),stars_mass(bulge%stars)/))
      stop  ! stop the program
    end if

    return
  end function bulge_mass

  !*****************************************************************************************************************

  function bulge_gas_signature(bulge,component)

    ! RETURN A GAS SIGNATURE (A NORMALIZED GAS OBJECT)

    implicit none

    character(*),intent(in),optional  :: component           ! allow to select the bulge component (sfg, non-sfg)
    character(MAXPATHSIZE)            :: message             ! a message to display

    type(gas_type)                    :: bulge_gas_signature ! the gas signature

    type(bulge_type),intent(in)       :: bulge               ! a bulge component

    if (present(component)) then
        !
        select case (trim(component))
        case ('no_sfg','nosfg')
            bulge_gas_signature = gas_signature(bulge%no_sfg)
        case ('all_gas','gas')
            bulge_gas_signature = gas_signature(bulge%no_sfg)
        case default
            write(message,'(a,a,a)') 'Keyword ', trim(component), ' not defined'
            call IO_print_error_message(message,only_rank=rank,called_by='bulge_gas_signature')
            stop  ! stop the program
        end select
    else
        !
        ! use all gas as defaut value
        bulge_gas_signature = gas_signature(bulge%no_sfg)
    end if

    return
  end function bulge_gas_signature

  !*****************************************************************************************************************

  function bulge_frac_mass_radius(bulge,frac,component)

    ! RETURN THE RADIUS THAT CONTAINS 100*frac % OF THE bulge MASS

    implicit none

    character(*),intent(in),optional  :: component               ! allow to select the bulge component (sfg, non-sfg, stars, agn)

    real(kind=8),intent(in)           :: frac                    ! fraction of the bulge mass
    real(kind=8)                      :: bulge_frac_mass_radius  ! the radius which enclose the given mass fraction
    real(kind=8)                      :: mass, r
    real(kind=8)                      :: r_min, r_max            ! [r_min : r_max] interval in which a solution for galaxy_frac_mass_radius is searched

    type(bulge_type),intent(in)        :: bulge                  ! a bulge component

    bulge_frac_mass_radius = 0.d0
    if (bulge_mass(bulge,component=component) .le. 0.d0) return ! no bulge

    r_min = 0.d0              ! init
    r_max = 1.d2*bulge%rb      ! init
    if (r_max .le. 0.d0) then
      !
      call IO_print_error_message('r_max <= 0', &
            only_rank = rank, called_by = 'bulge_frac_mass_radius')
      call IO_print_message('used',only_rank=rank,component='bulge',&
        param_name=(/'bulge%rb                 '/), &
        real_param_val =(/bulge%rb/))
      stop ! stop the program
    end if
    !
    ! Test with r_max and crash the code if the optimal radius is larger than this barrier.
    mass = bulge_mass(bulge,r=r_max,component=component)
    if (mass .lt. frac*bulge_mass(bulge,component=component)) then
      !
      call IO_print_error_message('Optimal r > r_max', &
            only_rank = rank, called_by = 'bulge_frac_mass_radius')
      call IO_print_message('used',only_rank=rank,component='bulge',&
        param_name=(/'bulge%rb                 '/), &
        real_param_val =(/bulge%rb/))
      stop ! stop the program
    end if

    r = r_max  ! init
    do while (((abs(mass-frac*bulge_mass(bulge,component=component))/(frac*bulge_mass(bulge,component=component))) .gt. num_precision) &
      .and. (r_min .ne. r_max))
       !
       r = 5.d-1*(r_min+r_max)
       mass = bulge_mass(bulge,r=r,component=component)
       ! The bulge mass is an incresing function of the radius
       if (mass .le. frac*bulge_mass(bulge,component=component)) then
          !
          r_min = r
       else
          !
          r_max = r
       end if
    end do
    !
    ! Test the result and crash the code if the optimal radius is smaller than 0.
    if (r .gt. 0.d0) then
      !
      bulge_frac_mass_radius = r
    else
      !
      call IO_print_error_message('Optimal r < 0', &
            only_rank = rank, called_by = 'bulge_frac_mass_radius')
      call IO_print_message('used',only_rank=rank,component='bulge',&
        param_name=(/'bulge%rb                 '/), &
        real_param_val =(/bulge%rb/))
      stop ! stop the program
    end if

    return
  end function bulge_frac_mass_radius

  !*****************************************************************************************************************

  function isolated_bulge_velocity(r,bulge) ! INTERFACE VERSION

    ! COMPUTE THE ROTATIONNAL VELOCITY OF A ISOLATED BULGE

    implicit none

    real(kind=8),intent(in)       :: r                       ! the radius
    real(kind=8)                  :: isolated_bulge_velocity ! in code unit

    type(bulge_type),intent(in)   :: bulge                   ! the bulge component

    isolated_bulge_velocity = 0.d0

    if (bulge_mass(bulge) .le. 0.d0) return

    isolated_bulge_velocity = isolated_bulge_velocity_(r,(/bulge%rb,bulge_mass(bulge,r=r)/))

    return
  end function isolated_bulge_velocity

  !*****************************************************************************************************************

  function isolated_bulge_velocity_(r,param)

    ! COMPUTE THE ROTATIONNAL VELOCITY OF A ISOLATED BULGE

    implicit none

    real(kind=8),intent(in)   :: r          ! the radius
    real(kind=8),intent(in)   :: param(2)   ! parameter array : param(1) = bulge%rb
                                            !                   param(2) = bulge_mass(bulge,r=r)
    real(kind=8)              :: isolated_bulge_velocity_ ! in code unit

    isolated_bulge_velocity_ = 0.d0  ! init

    if (param(2) .le. 0.d0) return

    isolated_bulge_velocity_ = sqrt(gravconst_code_unit*param(2)/r)

    return
  end function isolated_bulge_velocity_

  !*****************************************************************************************************************

  function stellar_velocity_dispersion(bulge)

    ! RETURN THE STELLAR VELOCITY DISPERSION IN A GIVEN BULGE
    ! Based on Herquist+1990 Eq. (10)

    implicit none

    real(kind=8)                :: r50,r0,rb      ! radius
    real(kind=8)                :: Ms             ! stellar mass
    real(kind=8)                :: dV             ! stellar velocity dispersion
    real(kind=8)                :: stellar_velocity_dispersion

    type(bulge_type),intent(in) :: bulge          ! the bulge component

    stellar_velocity_dispersion = 0.d0 ! init

    ! compute stellar mass
    Ms = bulge_mass(bulge,component='stars')

    if (Ms .le. 0.d0) return
    ! @ this point the bulge contains stars

    ! compute half-mass radius
    r50 = bulge_frac_mass_radius(bulge,5.d-1)  ! the half_mass radius [~ (1+sqrt(2))*bulge%rb]
    ! save rb
    rb = bulge%rb
    ! compute r0
    r0  = R50/rb
    !
    dV = 1.2d1*r50*(r50+rb)**3./rb**4.*log((r50+rb)/r50)
    dV = dV - (r50/(r50+rb))*(2.5d1+5.2d1*r0+4.2d1*r0**2.+1.2d1*r0**3.)
    dV = dV*gravconst_code_unit*Ms/(1.2d1*rb)
    dV = sqrt(dV)                              ! Code unit kpc/Gyr

    stellar_velocity_dispersion = dV

    return
  end function stellar_velocity_dispersion

  !*****************************************************************************************************************
  !
  ! PRINTING PROCEDURES
  !
  !*****************************************************************************************************************

  subroutine bulge_load_bulge_data(bulge,bulge_data)

    ! CREATE THE BULGE OUTPUT PROPERTIES LIST

    implicit none

    real(kind=8), intent(inout) :: bulge_data(nb_bulge_field+nb_stars_field+nb_dust_field)
    real(kind=8)                :: starsb_data(nb_stars_field)
    real(kind=8)                :: dust_data(nb_dust_field)

    type(bulge_type),intent(in) :: bulge   ! bulge component

    call stars_load_stars_data(bulge%stars,starsb_data)

    call dust_load_dust_data(bulge%dust,dust_data)

    ! For information
    !'bulge_age_form        ','bulge_no_sfg          ','bulge_mZ              ', &
    !'bulge_mH              ','bulge_mC              ','bulge_mN              ', &
    !'bulge_mO              ','bulge_mFe             ','bulge_m_stars         ', &
    !'bulge_rb              ','bulge_t_dyn           ','bulge_dV              '

    bulge_data = (/bulge%age_form, mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='Metals'), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='H1'), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='C12'), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='N14'), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='O16'), &
                   mass_code_unit_in_M_Sun*gas_mass(bulge%no_sfg,component='Fe56'), &
                   12.d0 + log10(O_H(bulge%no_sfg)), &
                   bulge%rb, bulge%t_dyn, bulge%dV*vel_code_unit_2_kmPerSec,starsb_data,dust_data/)

    return
  end subroutine bulge_load_bulge_data

 !*****************************************************************************************************************

  subroutine bulge_print(unit,form,bulge)

    ! PRINT BULGE-PROPERTIES IN eGALICS OUTPUT FILE

    implicit none

    integer(kind=4),intent(in)  :: unit    ! file unit
    integer(kind=4)             :: status,i,hdutype

    character(*)                :: form  ! fits or tmp_bin

    real(kind=8)                :: bulge_data(nb_bulge_field+nb_stars_field+nb_dust_field)

    type(bulge_type),intent(in) :: bulge  ! bulge component

    call bulge_load_bulge_data(bulge,bulge_data)

    select case (trim(form))
      case ('tmp_bin')
        write(unit) bulge_data  ! directly write data in the tmp binary output file
      case ('fits')
        ! move to dm extension
        call ftmahd(unit,hdu_bulge,hdutype,status)
        !
        if (status .gt. 0) then
          !
          call IO_print_error_message('ftmahd status', &
                only_rank = rank, called_by = 'bulge_print')
          stop ! stop the program
        end if
        !
        ! init
        call ftirow(unit,0,1,status)
        if (status .gt. 0) then
          !
          call IO_print_error_message('ftirow status', &
                only_rank = rank, called_by = 'bulge_print')
          stop ! stop the program
        end if
        ! write data in the dm entension
        call ftpcld(unit,1,1,1,1,bulge%age_form+bulge%life_time,status)
        do i=2, nb_bulge_field+nb_stars_field+nb_dust_field+1
          call ftpcld(unit,i,1,1,1,bulge_data(i-1),status)
          if (status .gt. 0) then
            !
            call IO_print_error_message('ftpcld status', &
                only_rank = rank, called_by = 'bulge_print')
            stop ! stop the program
          end if
        end do
      case default
        call IO_print_error_message('Unknwon output data format', &
                only_rank = rank, called_by = 'bulge_print')
        stop ! stop the program
    end select

    return
  end subroutine bulge_print

  !*****************************************************************************************************************

end module bulge