C$Procedure      CKW06 ( CK, Write segment, type 6 )

      SUBROUTINE CKW06 ( HANDLE,  INST,    REF,     AVFLAG,
     .                   FIRST,   LAST,    SEGID,   NMINI,
     .                   NPKTS,   SUBTPS,  DEGRES,  PACKTS,
     .                   RATES,   SCLKDP,  IVLBDS,  SELLST )

C$ Abstract
C
C     Write a type 6 segment to a CK file.
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     CK
C     DAF
C     NAIF_IDS
C     SCLK
C     SPC
C     TIME
C
C$ Keywords
C
C     ATTITUDE
C     FILES
C     POINTING
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'ck06.inc'
      INCLUDE 'ckparam.inc'

      INTEGER               HANDLE
      INTEGER               INST
      CHARACTER*(*)         REF
      LOGICAL               AVFLAG
      DOUBLE PRECISION      FIRST
      DOUBLE PRECISION      LAST
      CHARACTER*(*)         SEGID
      INTEGER               NMINI
      INTEGER               NPKTS  ( * )
      INTEGER               SUBTPS ( * )
      INTEGER               DEGRES ( * )
      DOUBLE PRECISION      PACKTS ( * )
      DOUBLE PRECISION      RATES  ( * )
      DOUBLE PRECISION      SCLKDP ( * )
      DOUBLE PRECISION      IVLBDS ( * )
      LOGICAL               SELLST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   Handle of a CK file open for writing.
C     INST       I   NAIF instrument ID code.
C     REF        I   Reference frame name.
C     AVFLAG     I   True if the segment will contain angular velocity.
C     FIRST      I   Start time of interval covered by segment.
C     LAST       I   End time of interval covered by segment.
C     SEGID      I   Segment identifier.
C     NMINI      I   Number of mini-segments.
C     NPKTS      I   Array of packet counts of mini-segments.
C     SUBTPS     I   Array of segment subtypes of mini-segments.
C     DEGRES     I   Array of polynomial degrees of mini-segments.
C     PACKTS     I   Array of data packets of mini-segments.
C     RATES      I   Nominal SCLK rates in seconds per tick.
C     SCLKDP     I   Array of epochs of mini-segments.
C     IVLBDS     I   Mini-segment interval bounds.
C     SELLST     I   Interval selection flag.
C     MAXDEG     P   Maximum allowed degree of interpolating polynomial.
C
C$ Detailed_Input
C
C     HANDLE         is the handle of a CK file that has been opened
C                    for writing.
C
C
C     INST           is a NAIF integer code associated with an
C                    instrument or spacecraft structure whose
C                    orientation is described by the segment to be
C                    created. INST is treated by the SPICE frame
C                    subsystem as a CK frame class ID (see the
C                    Frames Required Reading for details).
C
C
C     AVFLAG         is a logical flag which indicates whether or not
C                    the segment will contain angular velocity.
C
C
C     REF            is the NAIF name for a reference frame relative to
C                    which the pointing (attitude) information for INST
C                    is specified.
C
C     FIRST,
C     LAST           are, respectively, the bounds of the time interval
C                    over which the segment defines the attitude of
C                    INST. FIRST and LAST are encoded SCLK times.
C
C                    FIRST must be greater than or equal to the first
C                    mini-segment interval start time; LAST must be
C                    less than or equal to the last mini-segment
C                    interval stop time. See the description of IVLBDS
C                    below.
C
C
C     SEGID          is the segment identifier. A CK segment
C                    identifier may contain up to 40 characters.
C
C
C     NMINI          is the number of mini-segments comprised by
C                    the input data. Each mini-segment contains data
C                    that could be stored in a type 5 segment.
C                    The parameters and data of a mini-segment are:
C
C                       - a packet count
C                       - a type 6 subtype
C                       - an interpolating polynomial degree
C                       - a nominal SCLK rate in seconds/tick
C                       - a sequence of type 6 data packets
C                       - a sequence of packet epochs
C
C                    These inputs are described below.
C
C
C     NPKTS          is an array of packet counts. The Ith element of
C                    NPKTS is the packet count of the Ith mini-segment.
C
C                    NPKTS has dimension NMINI.
C
C
C     SUBTPS         is an array of type 6 subtypes. The Ith element of
C                    SUBTPS is the subtype of the packets associated
C                    with the Ith mini-segment.
C
C                    SUBTPS has dimension NMINI.
C
C
C     DEGRES         is an array of interpolating polynomial degrees.
C                    The Ith element of DEGRES is the polynomial degree
C                    of the packets associated with the Ith
C                    mini-segment.
C
C                    For subtypes 0 and 2, interpolation degrees must be
C                    equivalent to 3 mod 4, that is, they must be in
C                    the set
C
C                       { 3, 7, 11, ..., MAXDEG }
C
C                    For subtypes 1 and 3, interpolation degrees must
C                    be odd and must be in the range 1:MAXDEG.
C
C                    DEGRES has dimension NMINI.
C
C
C     PACKTS         is an array of data packets representing the
C                    orientation of INST relative to the frame REF. The
C                    packets for a given mini-segment are stored
C                    contiguously in increasing time order. The order
C                    of the sets of packets for different mini-segments
C                    is the same as the order of their corresponding
C                    mini-segment intervals.
C
C                    Each packet contains a SPICE-style quaternion and
C                    optionally, depending on the segment subtype,
C                    attitude derivative data, from which a C-matrix
C                    and an angular velocity vector may be derived.
C
C                    See the discussion of quaternion styles in
C                    Particulars below.
C
C                    The C-matrix CMAT represented by the Ith data
C                    packet is a rotation matrix that transforms the
C                    components of a vector expressed in the base frame
C                    specified by REF to components expressed in the
C                    instrument fixed frame at the time SCLKDP(I).
C
C                    Thus, if a vector V has components x, y, z in the
C                    base frame, then V has components x', y', z'
C                    in the instrument fixed frame where:
C
C                       [ x' ]     [          ] [ x ]
C                       | y' |  =  |   CMAT   | | y |
C                       [ z' ]     [          ] [ z ]
C
C                    Attitude derivative information either explicitly
C                    contained in, or else derived from, PACKTS(I)
C                    gives the angular velocity of the instrument fixed
C                    frame at time SCLKDP(I) with respect to the
C                    reference frame specified by REF.
C
C                    The direction of an angular velocity vector gives
C                    the right-handed axis about which the instrument
C                    fixed reference frame is rotating. The magnitude
C                    of the vector is the magnitude of the
C                    instantaneous velocity of the rotation, in radians
C                    per second.
C
C                    Packet contents and the corresponding
C                    interpolation methods depend on the segment
C                    subtype, and are as follows:
C
C                       Subtype 0:  Hermite interpolation, 8-element
C                                   packets. Quaternion and quaternion
C                                   derivatives only, no angular
C                                   velocity vector provided.
C                                   Quaternion elements are listed
C                                   first, followed by derivatives.
C                                   Angular velocity is derived from
C                                   the quaternions and quaternion
C                                   derivatives.
C
C                       Subtype 1:  Lagrange interpolation, 4-element
C                                   packets. Quaternion only. Angular
C                                   velocity is derived by
C                                   differentiating the interpolating
C                                   polynomials.
C
C                       Subtype 2:  Hermite interpolation, 14-element
C                                   packets. Quaternion and angular
C                                   velocity vector, as well as
C                                   derivatives of each, are provided.
C                                   The quaternion comes first, then
C                                   quaternion derivatives, then
C                                   angular velocity and its
C                                   derivatives.
C
C                       Subtype 3:  Lagrange interpolation, 7-element
C                                   packets. Quaternion and angular
C                                   velocity vector provided.  The
C                                   quaternion comes first.
C
C                    Angular velocity is always specified relative to
C                    the base frame.
C
C                    Units of the input data are:
C
C                       Quaternions                unitless
C                       Quaternion derivatives     1/TDB second
C                       Angular velocity           radians/TDB second
C                       Angular acceleration       radians/TDB second**2
C
C                    For the Hermite subtypes (0 and 2), quaternion
C                    representations must be selected so that, for
C                    consecutive quaternions Q(I) and Q(I+1) in a
C                    mini-segment, the distance between Q and Q(I+1) is
C                    less than the distance between Q and -Q(I+1). The
C                    Lagrange subtypes do not have this restriction.
C
C
C     RATES          is an array of nominal rates of the spacecraft
C                    clock associated with INST. The Ith element of
C                    rates is the clock rate for the packets associated
C                    with the Ith mini-segment. Units are seconds per
C                    tick. Spacecraft clock rates are used to scale
C                    angular velocity to radians/second.
C
C
C     SCLKDP         is an array containing epochs for all input
C                    mini-segments. The epochs have a one-to-one
C                    relationship with the packets in the input
C                    packet array. The epochs are encoded SCLK times.
C
C                    The epochs for a given mini-segment are stored
C                    contiguously in increasing order. The order of the
C                    sets of epochs for different mini-segments is the
C                    same as the order of their corresponding
C                    mini-segment intervals.
C
C                    For each mini-segment, "padding" is allowed: the
C                    sequence of epochs for that mini-segment may start
C                    before the corresponding mini-segment interval
C                    start time and end after the corresponding
C                    mini-segment interval stop time. Padding is used
C                    to control behavior of interpolating polynomials
C                    near mini-segment interval boundaries.
C
C                    Due to possible use of padding, the elements of
C                    SCLKDP, taken as a whole, might not be in
C                    increasing order.
C
C
C     IVLBDS         is an array of mini-segment interval boundary
C                    times. This array is a strictly increasing list of
C                    the mini-segment interval start times, to which
C                    the end time for the last interval is appended.
C                    The interval bounds are encoded SCLK times.
C
C                    The Ith mini-segment interval is the time
C                    coverage interval of the Ith mini-segment (see the
C                    description of NPKTS above).
C
C                    For each mini-segment, the corresponding
C                    mini-segment interval's start time is greater
C                    than or equal to the mini-segment's first epoch.
C                    The interval's stop time may exceed the
C                    mini-segment's last epoch, allowing a single
C                    coverage gap to exist between a mini-segment's
C                    last epoch and its interval stop time.
C
C                    The "interpolation interval" of the ith
C                    mini-segment is contained in the ith mini-segment
C                    interval: the interpolation interval extends from
C                    IVLBDS(I) to the minimum of IVLBDS(I+1) and the
C                    last epoch of the mini-segment.
C
C                    For each mini-segment interval other than the
C                    last, the interval's coverage stop time coincides
C                    with the coverage start time of the next interval.
C
C                    IVLBDS has dimension NMINI+1.
C
C
C     SELLST         is a logical flag indicating to the CK type 6
C                    segment reader CKR06 how to select the
C                    mini-segment interval when a request time
C                    coincides with a time boundary shared by two
C                    mini-segment intervals. When SELLST ("select
C                    last") is .TRUE., the later interval is selected;
C                    otherwise the earlier interval is selected.
C
C$ Detailed_Output
C
C     None.  See $Particulars for a description of the effect of this
C     routine.
C
C$ Parameters
C
C     MAXDEG         is the maximum allowed degree of the interpolating
C                    polynomial.
C
C                    See the INCLUDE file ck06.inc for the value of
C                    MAXDEG.
C
C$ Exceptions
C
C     If any of the following exceptions occur, this routine will return
C     without creating a new segment.
C
C
C     1)  If FIRST is greater than LAST then the error
C         SPICE(BADDESCRTIMES) will be signaled.
C
C     2)  If REF is not a recognized name, the error
C         SPICE(INVALIDREFFRAME) is signaled.
C
C     3)  If the last non-blank character of SEGID occurs past index
C         40, the error SPICE(SEGIDTOOLONG) is signaled.
C
C     4)  If SEGID contains any nonprintable characters, the error
C         SPICE(NONPRINTABLECHARS) is signaled.
C
C     5)  If NMINI is not at least 1, the error SPICE(INVALIDCOUNT)
C         is signaled.
C
C     6)  If the elements of the array IVLBDS are not in strictly
C         increasing order, the error SPICE(BOUNDSOUTOFORDER) will be
C         signaled.
C
C     7)  If the first interval start time IVLBDS(1) is greater than
C         FIRST, or if the last interval end time IVLBDS(NMINI+1) is
C         less than LAST, the error SPICE(COVERAGEGAP) will be
C         signaled.
C
C     8)  If any packet count in the array NPKTS is not at least 2, the
C         error SPICE(TOOFEWPACKETS) will be signaled.
C
C     9)  If any subtype code in the array SUBTPS is not recognized,
C         the error SPICE(INVALIDSUBTYPE) will be signaled.
C
C    10)  If any interpolation degree in the array DEGRES is not at
C         least 1 or is greater than MAXDEG, the error
C         SPICE(INVALIDDEGREE) is signaled.
C
C    11)  If the window size implied by any element of the array DEGRES
C         is odd, the error SPICE(BADWINDOWSIZE) is signaled.
C
C    12)  If the elements of the array SCLKDP corresponding
C         to a given mini-segment are not in strictly
C         increasing order, the error SPICE(TIMESOUTOFORDER) will be
C         signaled.
C
C    13)  If the first epoch of a mini-segment exceeds the start time
C         of the associated mini-segment interval, or if the last
C         epoch of a mini-segment is less than the interval start
C         time, the error SPICE(BOUNDSDISAGREE) is signaled. However,
C         the last epoch of a mini-segment may be less than the end
C         time of the corresponding mini-segment interval.
C
C    14)  If any quaternion has magnitude zero, the error
C         SPICE(ZEROQUATERNION) is signaled.
C
C    15)  Any error that occurs while writing the output segment will
C         be diagnosed by routines in the call tree of this routine.
C
C    16)  This routine assumes that the rotation between adjacent
C         quaternions that are stored in the same interval has a
C         rotation angle of THETA radians, where
C
C            0  <  THETA  <  pi.
C               _
C
C         The routines that evaluate the data in the segment produced
C         by this routine cannot distinguish between rotations of THETA
C         radians, where THETA is in the interval [0, pi), and
C         rotations of
C
C            THETA   +   2 * k * pi
C
C         radians, where k is any integer.  These "large" rotations will
C         yield invalid results when interpolated. The segment creator
C         must ensure that the data stored in the segment will not be
C         subject to this sort of ambiguity.
C
C    17)  For the Hermite subtypes (0 and 2), quaternion
C         representations must be selected so that, for consecutive
C         quaternions Q(I) and Q(I+1) in a mini-segment, the distance
C         between Q and Q(I+1) is less than the distance between Q and
C         -Q(I+1).
C
C         If a pair of quaternions violating this condition is found
C         in the input array PACKTS, the error SPICE(BADQUATSIGN) will
C         be signaled.
C
C    18)  If any element of the input RATES array is non-positive, the
C         error SPICE(INVALIDSCLKRATE) will be signaled.
C
C$ Files
C
C     A new type 6 CK segment is written to the CK file attached
C     to HANDLE.
C
C$ Particulars
C
C     This routine writes a CK type 6 data segment to the open CK
C     file according to the format described in the type 6 section of
C     the CK Required Reading. The CK file must have been opened with
C     write access.
C
C
C     Quaternion Styles
C     -----------------
C
C     There are different "styles" of quaternions used in
C     science and engineering applications. Quaternion styles
C     are characterized by
C
C        - The order of quaternion elements
C
C        - The quaternion multiplication formula
C
C        - The convention for associating quaternions
C          with rotation matrices
C
C     Two of the commonly used styles are
C
C        - "SPICE"
C
C           > Invented by Sir William Rowan Hamilton
C           > Frequently used in mathematics and physics textbooks
C
C        - "Engineering"
C
C           > Widely used in aerospace engineering applications
C
C
C     SPICELIB subroutine interfaces ALWAYS use SPICE quaternions.
C     Quaternions of any other style must be converted to SPICE
C     quaternions before they are passed to SPICELIB routines.
C
C
C     Relationship between SPICE and Engineering Quaternions
C     ------------------------------------------------------
C
C     Let M be a rotation matrix such that for any vector V,
C
C        M*V
C
C     is the result of rotating V by theta radians in the
C     counterclockwise direction about unit rotation axis vector A.
C     Then the SPICE quaternions representing M are
C
C        (+/-) (  cos(theta/2),
C                 sin(theta/2) A(1),
C                 sin(theta/2) A(2),
C                 sin(theta/2) A(3)  )
C
C     while the engineering quaternions representing M are
C
C        (+/-) ( -sin(theta/2) A(1),
C                -sin(theta/2) A(2),
C                -sin(theta/2) A(3),
C                 cos(theta/2)       )
C
C     For both styles of quaternions, if a quaternion q represents
C     a rotation matrix M, then -q represents M as well.
C
C     Given an engineering quaternion
C
C        QENG   = ( q0,  q1,  q2,  q3 )
C
C     the equivalent SPICE quaternion is
C
C        QSPICE = ( q3, -q0, -q1, -q2 )
C
C
C     Associating SPICE Quaternions with Rotation Matrices
C     ----------------------------------------------------
C
C     Let FROM and TO be two right-handed reference frames, for
C     example, an inertial frame and a spacecraft-fixed frame. Let the
C     symbols
C
C        V    ,   V
C         FROM     TO
C
C     denote, respectively, an arbitrary vector expressed relative to
C     the FROM and TO frames. Let M denote the transformation matrix
C     that transforms vectors from frame FROM to frame TO; then
C
C        V   =  M * V
C         TO         FROM
C
C     where the expression on the right hand side represents left
C     multiplication of the vector by the matrix.
C
C     Then if the unit-length SPICE quaternion q represents M, where
C
C        q = (q0, q1, q2, q3)
C
C     the elements of M are derived from the elements of q as follows:
C
C          +-                                                         -+
C          |           2    2                                          |
C          | 1 - 2*( q2 + q3 )   2*(q1*q2 - q0*q3)   2*(q1*q3 + q0*q2) |
C          |                                                           |
C          |                                                           |
C          |                               2    2                      |
C      M = | 2*(q1*q2 + q0*q3)   1 - 2*( q1 + q3 )   2*(q2*q3 - q0*q1) |
C          |                                                           |
C          |                                                           |
C          |                                                   2    2  |
C          | 2*(q1*q3 - q0*q2)   2*(q2*q3 + q0*q1)   1 - 2*( q1 + q2 ) |
C          |                                                           |
C          +-                                                         -+
C
C     Note that substituting the elements of -q for those of q in the
C     right hand side leaves each element of M unchanged; this shows
C     that if a quaternion q represents a matrix M, then so does the
C     quaternion -q.
C
C     To map the rotation matrix M to a unit quaternion, we start by
C     decomposing the rotation matrix as a sum of symmetric
C     and skew-symmetric parts:
C
C                                        2
C        M = [ I  +  (1-cos(theta)) OMEGA  ] + [ sin(theta) OMEGA ]
C
C                     symmetric                   skew-symmetric
C
C
C     OMEGA is a skew-symmetric matrix of the form
C
C                   +-             -+
C                   |  0   -n3   n2 |
C                   |               |
C         OMEGA  =  |  n3   0   -n1 |
C                   |               |
C                   | -n2   n1   0  |
C                   +-             -+
C
C     The vector N of matrix entries (n1, n2, n3) is the rotation axis
C     of M and theta is M's rotation angle.  Note that N and theta
C     are not unique.
C
C     Let
C
C        C = cos(theta/2)
C        S = sin(theta/2)
C
C     Then the unit quaternions Q corresponding to M are
C
C        Q = +/- ( C, S*n1, S*n2, S*n3 )
C
C     The mappings between quaternions and the corresponding rotations
C     are carried out by the SPICELIB routines
C
C        Q2M {quaternion to matrix}
C        M2Q {matrix to quaternion}
C
C     M2Q always returns a quaternion with scalar part greater than
C     or equal to zero.
C
C
C     SPICE Quaternion Multiplication Formula
C     ---------------------------------------
C
C     Given a SPICE quaternion
C
C        Q = ( q0, q1, q2, q3 )
C
C     corresponding to rotation axis A and angle theta as above, we can
C     represent Q using "scalar + vector" notation as follows:
C
C        s =   q0           = cos(theta/2)
C
C        v = ( q1, q2, q3 ) = sin(theta/2) * A
C
C        Q = s + v
C
C     Let Q1 and Q2 be SPICE quaternions with respective scalar
C     and vector parts s1, s2 and v1, v2:
C
C        Q1 = s1 + v1
C        Q2 = s2 + v2
C
C     We represent the dot product of v1 and v2 by
C
C        <v1, v2>
C
C     and the cross product of v1 and v2 by
C
C        v1 x v2
C
C     Then the SPICE quaternion product is
C
C        Q1*Q2 = s1*s2 - <v1,v2>  + s1*v2 + s2*v1 + (v1 x v2)
C
C     If Q1 and Q2 represent the rotation matrices M1 and M2
C     respectively, then the quaternion product
C
C        Q1*Q2
C
C     represents the matrix product
C
C        M1*M2
C
C
C$ Examples
C
C     Suppose that you have states and are prepared to produce
C     a segment of type 6 in a CK file.
C
C     The following code fragment could be used to add the new segment
C     to a previously opened CK file attached to HANDLE. The file must
C     have been opened with write access.
C
C        C
C        C     Create a segment identifier.
C        C
C              SEGID = 'MY_SAMPLE_CK_TYPE_6_SEGMENT'
C
C        C
C        C     Write the segment.
C        C
C              CALL CKW06 ( HANDLE,  INST,    REF,     AVFLAG,
C             .             FIRST,   LAST,    SEGID,   NMINI,
C             .             NPKTS,   SUBTPS,  DEGRES,  PACKTS,
C             .             RATES,   SCLKDP,  IVLBDS,  SELLST  )
C
C
C$ Restrictions
C
C     None.
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-AUG-2015 (NJB)
C
C        Added check for invalid SCLK rates.
C
C        Corrected error in header Exceptions section: changed
C        subscript N+1 to NMINI+1. Corrected typo in description
C        of subtype 2 data. Added mention of angular acceleration
C        units.
C
C-    SPICELIB Version 1.0.0, 14-MAR-2014 (NJB) (BVS)
C
C-&

C$ Index_Entries
C
C     write spk type_6 ephemeris data segment
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDISTG
      INTEGER               LASTNB

      LOGICAL               EVEN
      LOGICAL               FAILED
      LOGICAL               ODD
      LOGICAL               RETURN
      LOGICAL               VZEROG

C
C     Local parameters
C
      INTEGER               SIDLEN
      PARAMETER           ( SIDLEN =  40 )

      INTEGER               FPRINT
      PARAMETER           ( FPRINT =  32 )

      INTEGER               LPRINT
      PARAMETER           ( LPRINT = 126 )

      INTEGER               ND
      PARAMETER           ( ND     =   2 )

      INTEGER               NI
      PARAMETER           ( NI     =   6 )

      INTEGER               DSCSIZ
      PARAMETER           ( DSCSIZ =   5 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE  =  6 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

C
C     Packet structure parameters
C
      INTEGER               QIDX
      PARAMETER           ( QIDX   = 1 )

C
C     Local variables
C
      DOUBLE PRECISION      DC     ( ND )
      DOUBLE PRECISION      DESCR  ( DSCSIZ )
      DOUBLE PRECISION      PREVQ  ( 0 : 3 )
      DOUBLE PRECISION      Q      ( 0 : 3 )
      DOUBLE PRECISION      QNEG   ( 0 : 3 )

      INTEGER               ADDR
      INTEGER               BEPIX
      INTEGER               CHRCOD
      INTEGER               EEPIX
      INTEGER               I
      INTEGER               IC     ( NI )
      INTEGER               ISEL
      INTEGER               J
      INTEGER               K
      INTEGER               MINISZ
      INTEGER               NDIR
      INTEGER               PKTBEG
      INTEGER               PKTDSZ
      INTEGER               PKTEND
      INTEGER               PKTSIZ
      INTEGER               PKTSZS ( 0 : C06NST-1 )
      INTEGER               REFCOD
      INTEGER               SEGBEG
      INTEGER               SEGEND
      INTEGER               SUBTYP
      INTEGER               WINSIZ

C
C     Saved values
C
      SAVE                  PKTSZS

C
C     Initial values
C
      DATA                  PKTSZS  /  C06PS0, C06PS1, C06PS2, C06PS3 /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'CKW06' )

C
C     Start with a parameter compatibility check.
C
      IF ( CKMRSZ .LT. MAXRSZ ) THEN

         CALL SETMSG ( 'CK type 6 record size is #, but '
     .   //            'CKPFS record size is #.'
     .   //            'is #.'                            )
         CALL ERRINT ( '#',  MAXRSZ                       )
         CALL ERRINT ( '#',  CKMRSZ                       )
         CALL SIGERR ( 'SPICE(BUG)'                       )
         CALL CHKOUT ( 'CKW06'                            )
         RETURN

      END IF

C
C     Make sure the segment descriptor bounds are
C     correctly ordered.
C
      IF ( LAST .LT. FIRST ) THEN

         CALL SETMSG ( 'Segment start time is #; stop time is #; '
     .   //            'bounds must be in nondecreasing order.'    )
         CALL ERRDP  ( '#', FIRST                                  )
         CALL ERRDP  ( '#', LAST                                   )
         CALL SIGERR ( 'SPICE(BADDESCRTIMES)'                      )
         CALL CHKOUT ( 'CKW06'                                     )
         RETURN

      END IF

C
C     Get the NAIF integer code for the reference frame.
C
      CALL NAMFRM ( REF, REFCOD )

      IF ( REFCOD .EQ. 0 ) THEN

         CALL SETMSG ( 'The reference frame # is not supported.' )
         CALL ERRCH  ( '#', REF                                  )
         CALL SIGERR ( 'SPICE(INVALIDREFFRAME)'                  )
         CALL CHKOUT ( 'CKW06'                                   )
         RETURN

      END IF

C
C     Check to see if the segment identifier is too long.
C
      IF ( LASTNB(SEGID) .GT. SIDLEN ) THEN

         CALL SETMSG ( 'Segment identifier contains more than '
     .   //            '40 characters.'                        )
         CALL SIGERR ( 'SPICE(SEGIDTOOLONG)'                   )
         CALL CHKOUT ( 'CKW06'                                 )
         RETURN

      END IF

C
C     Now check that all the characters in the segment identifier
C     can be printed.
C
      DO I = 1, LASTNB(SEGID)

         CHRCOD = ICHAR( SEGID(I:I) )

         IF ( ( CHRCOD .LT. FPRINT ) .OR. ( CHRCOD .GT. LPRINT ) ) THEN

            CALL SETMSG ( 'The segment identifier contains '
     .      //            'nonprintable characters'         )
            CALL SIGERR ( 'SPICE(NONPRINTABLECHARS)'        )
            CALL CHKOUT ( 'CKW06'                           )
            RETURN

         END IF

      END DO

C
C     The mini-segment count must be positive.
C
      IF ( NMINI .LT. 1 ) THEN

         CALL SETMSG ( 'Mini-segment count was #; '
     .   //            'this count must be positive.' )
         CALL ERRINT ( '#', NMINI                     )
         CALL SIGERR ( 'SPICE(INVALIDCOUNT)'          )
         CALL CHKOUT ( 'CKW06'                        )
         RETURN

      END IF

C
C     Make sure the interval bounds form a strictly
C     increasing sequence.
C
C     Note that there are NMINI+1 bounds.
C
      DO I = 1, NMINI

         IF ( IVLBDS(I) .GE. IVLBDS(I+1) ) THEN

            CALL SETMSG ( 'Mini-segment interval '
     .      //            'bounds at indices # and # '
     .      //            'are # and # respectively. The '
     .      //            'difference is #. The bounds are '
     .      //            'required to be strictly increasing.' )
            CALL ERRINT ( '#', I                                )
            CALL ERRINT ( '#', I+1                              )
            CALL ERRDP  ( '#', IVLBDS(I)                        )
            CALL ERRDP  ( '#', IVLBDS(I+1)                      )
            CALL ERRDP  ( '#', IVLBDS(I+1) - IVLBDS(I)          )
            CALL SIGERR ( 'SPICE(BOUNDSOUTOFORDER)'             )
            CALL CHKOUT ( 'CKW06'                               )
            RETURN

         END IF

      END DO

C
C     Make sure the time span of the descriptor doesn't extend
C     beyond the span of the interval bounds.
C
      IF (      ( FIRST .LT. IVLBDS(1        ) )
     .     .OR. ( LAST  .GT. IVLBDS(NMINI+1) ) ) THEN

         CALL SETMSG ( 'First mini-segment interval '
     .   //            'start time is #; segment start time '
     .   //            'is #; segment stop time is #; '
     .   //            'last mini-segment interval stop '
     .   //            'time is #. This sequence of times '
     .   //            'is required to be non-decreasing: '
     .   //            'segment coverage must be contained '
     .   //            'within the union of the mini-segment '
     .   //            'intervals.'                            )
         CALL ERRDP  ( '#', IVLBDS(1)                          )
         CALL ERRDP  ( '#', FIRST                              )
         CALL ERRDP  ( '#', LAST                               )
         CALL ERRDP  ( '#', IVLBDS(NMINI+1)                    )
         CALL SIGERR ( 'SPICE(COVERAGEGAP)'                    )
         CALL CHKOUT ( 'CKW06'                                 )
         RETURN

      END IF

C
C     Check the input data before writing to the file.
C
C     This order of operations entails some redundant
C     calculations, but it allows for rapid error
C     detection.
C
C     Initialize the mini-segment packet array indices,
C     and those of the mini-segment epoch array as well.
C
      PKTBEG = 0
      PKTEND = 0

      BEPIX  = 0
      EEPIX  = 0

      DO I = 1, NMINI
C
C        First, just make sure the packet count for the current
C        mini-segment is at least two. This check reduces our chances
C        of a subscript range violation.
C
C        Check the number of packets.
C
         IF ( NPKTS(I) .LT. 2 ) THEN

            CALL SETMSG ( 'At least 2 packets are required '
     .      //            'for CK type 6. Number of packets '
     .      //            'supplied was # in mini-segment at index #.' )
            CALL ERRINT ( '#', NPKTS(I)                                )
            CALL ERRINT ( '#', I                                       )
            CALL SIGERR ( 'SPICE(TOOFEWPACKETS)'                       )
            CALL CHKOUT ( 'CKW06'                                      )
            RETURN

         END IF

C
C        Set the packet size, which is a function of the subtype. Also
C        set the window size. First check the subtype, which will be
C        used as an array index.
C
         SUBTYP = SUBTPS(I)

         IF (  ( SUBTYP .LT. 0 ) .OR. ( SUBTYP .GT. C06NST-1 ) ) THEN

            CALL SETMSG ( 'Unexpected CK type 6 subtype # '
     .      //            'found in mini-segment #.'       )
            CALL ERRINT ( '#',  SUBTYP                     )
            CALL ERRINT ( '#',  I                          )
            CALL SIGERR ( 'SPICE(INVALIDSUBTYPE)'          )
            CALL CHKOUT ( 'CKW06'                          )
            RETURN

         END IF

         PKTSIZ = PKTSZS ( SUBTYP )

         IF ( ODD(SUBTYP) ) THEN

            WINSIZ =   DEGRES(I) + 1
         ELSE
            WINSIZ = ( DEGRES(I) + 1 ) / 2
         END IF

C
C        Make sure the SCLK rates in this mini-segment are positive.
C
         IF ( RATES(I) .LE. 0.D0 ) THEN

            CALL SETMSG ( 'SCLK rate at index # was #; rate must '
     .      //            'be positive.'                           )
            CALL ERRINT ( '#',  I                                  )
            CALL ERRDP  ( '#',  RATES(I)                           )
            CALL SIGERR ( 'SPICE(INVALIDSCLKRATE)'                 )
            CALL CHKOUT ( 'CKW06'                                  )
            RETURN

         END IF

C
C        Update the packet range pointers for this mini-segment.
C
         PKTBEG = PKTEND + 1
         PKTEND = PKTBEG - 1  +  NPKTS(I)*PKTSIZ

C
C        Make sure that the degree of the interpolating polynomials is
C        in range.
C
         IF (      ( DEGRES(I) .LT. 1      )
     .        .OR. ( DEGRES(I) .GT. MAXDEG )  )  THEN

            CALL SETMSG ( 'The interpolating polynomials of '
     .      //            'mini-segment # have degree #; the '
     .      //            'valid degree range is [1, #]'      )
            CALL ERRINT ( '#', I                              )
            CALL ERRINT ( '#', DEGRES(I)                      )
            CALL ERRINT ( '#', MAXDEG                         )
            CALL SIGERR ( 'SPICE(INVALIDDEGREE)'              )
            CALL CHKOUT ( 'CKW06'                             )
            RETURN

         END IF

C
C        Make sure that the window size is even.
C
         IF (  ODD( WINSIZ )  )  THEN

            CALL SETMSG ( 'The interpolating polynomials of '
     .      //            'mini-segment # have window size # '
     .      //            'and degree # for CK type 6. '
     .      //            'The mini-segment subtype is #. '
     .      //            'The degree must be equivalent to 3 '
     .      //            'mod 4 for subtypes 0 or 2 (Hermite '
     .      //            'interpolation) and odd for subtypes '
     .      //            '1 or 3 (Lagrange interpolation).'     )
            CALL ERRINT ( '#', I                                 )
            CALL ERRINT ( '#', WINSIZ                            )
            CALL ERRINT ( '#', DEGRES(I)                         )
            CALL ERRINT ( '#', SUBTPS(I)                         )
            CALL SIGERR ( 'SPICE(BADWINDOWSIZE)'                 )
            CALL CHKOUT ( 'CKW06'                                )
            RETURN

         END IF

C
C        Make sure the epochs of the Ith mini-segment form a
C        strictly increasing sequence.
C
C        To start out, determine the indices of the epoch sequence
C        of the Ith mini-segment. We'll call the begin and end
C        epoch indices BEPIX and EEPIX respectively.
C
         BEPIX  =  EEPIX + 1
         EEPIX  =  BEPIX - 1 +  NPKTS(I)

         DO J = 1, NPKTS(I) - 1

            K = BEPIX + J - 1

            IF ( SCLKDP(K) .GE. SCLKDP(K+1) ) THEN

               CALL SETMSG ( 'In mini-segment #, epoch # having '
     .         //            'mini-segment-relative index # and '
     .         //            'array-relative index # is greater '
     .         //            'than or equal to its successor #.' )
               CALL ERRINT ( '#',  I                             )
               CALL ERRDP  ( '#',  SCLKDP(K  )                   )
               CALL ERRINT ( '#',  J                             )
               CALL ERRINT ( '#',  K                             )
               CALL ERRDP  ( '#',  SCLKDP(K+1)                   )
               CALL SIGERR ( 'SPICE(TIMESOUTOFORDER)'            )
               CALL CHKOUT ( 'CKW06'                             )
               RETURN

            END IF

         END DO

C
C        Make sure that the span of the input epochs of the Ith
C        mini-segment includes the start of the Ith mini-segment
C        interval. Note that the stop time need not be covered, since
C        gaps are allowed at the right ends of mini-segment intervals.
C
         IF (  SCLKDP(BEPIX) .GT. IVLBDS(I) ) THEN

            CALL SETMSG ( 'Mini-segment interval # start time # '
     .      //            'precedes mini-segment''s first epoch #.' )
            CALL ERRINT ( '#',  I                                   )
            CALL ERRDP  ( '#',  IVLBDS(I)                           )
            CALL ERRDP  ( '#',  SCLKDP(BEPIX)                       )
            CALL SIGERR ( 'SPICE(BOUNDSDISAGREE)'                   )
            CALL CHKOUT ( 'CKW06'                                   )
            RETURN

         ELSE IF (  SCLKDP(EEPIX) .LT. IVLBDS(I) ) THEN

            CALL SETMSG ( 'Mini-segment interval # start time # '
     .      //            'follows mini-segment''s last epoch #.'   )
            CALL ERRINT ( '#',  I                                   )
            CALL ERRDP  ( '#',  IVLBDS(I)                           )
            CALL ERRDP  ( '#',  SCLKDP(EEPIX)                       )
            CALL SIGERR ( 'SPICE(BOUNDSDISAGREE)'                   )
            CALL CHKOUT ( 'CKW06'                                   )
            RETURN

         END IF

C
C        Make sure that the quaternions are non-zero. This is just a
C        check for uninitialized data.
C
C        For the Hermite subtypes, make sure quaternions are suitable
C        for interpolation.
C
         DO J = 1, NPKTS(I)
C
C           We have to address the quaternion explicitly, since the
C           shape of the packet array is not known at compile time.
C
            ADDR = PKTBEG  +  ( PKTSIZ*(J-1) )  -  1  +  QIDX

            IF (  VZEROG( PACKTS(ADDR), 4 )  ) THEN

               CALL SETMSG ( 'The quaternion in packet # within '
     .         //            'mini-segment # has magnitude zero.' )
               CALL ERRINT ( '#', J                               )
               CALL ERRINT ( '#', I                               )
               CALL SIGERR ( 'SPICE(ZEROQUATERNION)'              )
               CALL CHKOUT ( 'CKW06'                              )
               RETURN

            END IF

C
C           For the Hermite subtypes, each quaternion must be closer
C           than its negative to its predecessor in the quaternion
C           sequence.
C

            IF (  ( J .GT. 1 )  .AND.  EVEN(SUBTYP)  ) THEN
C
C              Compare the distance between the current quaternion
C              and its predecessor vs the distance between the
C              negative of the current quaternion and its predecessor.
C
               CALL MOVED  ( PACKTS(ADDR),        4, Q     )
               CALL MOVED  ( PACKTS(ADDR-PKTSIZ), 4, PREVQ )
               CALL VMINUG ( Q, 4, QNEG )

               IF (      VDISTG(PREVQ, QNEG, 4 )
     .              .LT. VDISTG(PREVQ, Q,    4 )  ) THEN

                  CALL SETMSG ( 'The quaternion in packet # within '
     .            //            'mini-segment # is farther than its '
     .            //            'negative from its predecessor at '
     .            //            'index #. This makes the quaternion '
     .            //            'sequence unsuitable for Hermite '
     .            //            'interpolation. The quaternions, and '
     .            //            'if applicable, their derivatives, '
     .            //            'must be adjusted before they are '
     .            //            'passed to this routine.'              )
                  CALL ERRINT ( '#', J                                 )
                  CALL ERRINT ( '#', I                                 )
                  CALL ERRINT ( '#', J-1                               )
                  CALL SIGERR ( 'SPICE(BADQUATSIGN)'                   )
                  CALL CHKOUT ( 'CKW06'                                )
                  RETURN

               END IF

            END IF

         END DO

      END DO

C
C     If we made it this far, we're ready to start writing the segment.
C
C     The type 6 segment structure is eloquently described by this
C     diagram from the CK Required Reading:
C
C        +---------------------------------------+
C        | Mini-segment 1                        |
C        +---------------------------------------+
C              .
C              .
C              .
C        +---------------------------------------+
C        | Mini-segment N                        |
C        +---------------------------------------+
C        | Mini-segment interval 1 start time    |
C        +---------------------------------------+
C              .
C              .
C              .
C        +---------------------------------------+
C        | Mini-segment interval N start time    |
C        +---------------------------------------+
C        | Mini-segment interval N stop time     |
C        +---------------------------------------+
C        | Mini-seg. interval start time 100     | (First interval
C        +---------------------------------------+  directory)
C              .
C              .
C              .
C        +---------------------------------------+
C        | Mini-seg. ival. start time (N/100)*100| (Last interval
C        +---------------------------------------+  directory)
C        | Mini-segment 1 start pointer          |
C        +---------------------------------------+
C              .
C              .
C              .
C        +---------------------------------------+
C        | Mini-segment N start pointer          |
C        +---------------------------------------+
C        | Mini-segment N stop pointer + 1       |
C        +---------------------------------------+
C        | Boundary choice flag                  |
C        +---------------------------------------+
C        | Number of intervals                   |
C        +---------------------------------------+
C
C     CK type 6 mini-segments have the following structure:
C
C        +-----------------------+
C        | Packet 1              |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | Packet M              |
C        +-----------------------+
C        | Epoch 1               |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | Epoch M               |
C        +-----------------------+
C        | Epoch 100             | (First time tag directory)
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | Epoch ((M-1)/100)*100 | (Last time tag directory)
C        +-----------------------+
C        | Clock rate (sec/tick) |
C        +-----------------------+
C        | Subtype code          |
C        +-----------------------+
C        | Window size           |
C        +-----------------------+
C        | Number of packets     |
C        +-----------------------+
C
C     Note that the set of parameters at the end of a mini-segment does
C     not contain an mini-segment interval count. This is because,
C     unlike a CK type 5 segment, a CK type 6 segment can contain at
C     most one gap. If present, the gap is located at the end of
C     mini-segment's mini-segment interval.
C
C     Create the segment descriptor. We don't use CKPDS because
C     that routine doesn't allow creation of a singleton segment.
C
      IC(1) = INST
      IC(2) = REFCOD
      IC(3) = DTYPE

      IF ( AVFLAG ) THEN
         IC(4) = 1
      ELSE
         IC(4) = 0
      END IF

      DC(1) = FIRST
      DC(2) = LAST

      CALL DAFPS  ( ND, NI, DC, IC, DESCR )

C
C     Begin a new segment.
C
      CALL DAFBNA ( HANDLE, DESCR, SEGID )

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

C
C     Re-initialize the mini-segment packet array indices,
C     and those of the mini-segment epoch array as well.
C
      PKTBEG = 0
      PKTEND = 0

      BEPIX  = 0
      EEPIX  = 0

C
C     Write data for each mini-segment to the file.
C
      DO I = 1, NMINI
C
C        Set the packet size, which is a function of the subtype.
C
         SUBTYP = SUBTPS ( I )

         PKTSIZ = PKTSZS ( SUBTYP )

         IF ( ODD(SUBTYP) ) THEN

            WINSIZ =   DEGRES(I) + 1
         ELSE
            WINSIZ = ( DEGRES(I) + 1 ) / 2
         END IF

C
C        Now that we have the packet size, we can compute
C        mini-segment packet index range. We'll let PKTDSZ
C        be the total count of packet data entries for this
C        mini-segment.
C
         PKTDSZ = NPKTS(I) * PKTSIZ

         PKTBEG = PKTEND  +  1
         PKTEND = PKTBEG  -  1  +  PKTDSZ

C
C        At this point, we're read to start writing the
C        current mini-segment to the file. Start with the
C        packet data.
C
         CALL DAFADA ( PACKTS(PKTBEG), PKTDSZ )

C
C        Write the epochs for this mini-segment.
C
         BEPIX = EEPIX + 1
         EEPIX = BEPIX - 1 + NPKTS(I)

         CALL DAFADA ( SCLKDP(BEPIX), NPKTS(I) )

C
C        Compute the number of epoch directories for the
C        current mini-segment.
C
         NDIR = ( NPKTS(I) - 1 ) / DIRSIZ

C
C        Write the epoch directories to the segment.
C
         DO J = 1, NDIR

            K = BEPIX  -  1  +  ( J * DIRSIZ )

            CALL DAFADA ( SCLKDP(K), 1 )

         END DO

C
C        Write the mini-segment's SCLK rate, subtype, window size, and
C        packet count to the segment.
C
         CALL DAFADA ( RATES(I),           1 )
         CALL DAFADA ( DBLE( SUBTPS(I) ),  1 )
         CALL DAFADA ( DBLE( WINSIZ    ),  1 )
         CALL DAFADA ( DBLE( NPKTS(I)  ),  1 )

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

      END DO

C
C     We've finished writing the mini-segments.
C
C     Next write the mini-segment interval bounds.
C
      CALL DAFADA ( IVLBDS, NMINI+1 )

C
C     Create and write directories for the interval
C     bounds.
C
C     The directory count is the interval bound count
C     (N+1), minus 1, divided by the directory size.
C
      NDIR = NMINI / DIRSIZ

      DO I = 1, NDIR
         CALL DAFADA (  IVLBDS( DIRSIZ*I ),  1  )
      END DO

C
C     Now we compute and write the start/stop pointers
C     for each mini-segment.
C
C     The pointers are relative to the DAF address
C     preceding the segment. For example, a pointer
C     to the first DAF address in the segment has
C     value 1.
C
      SEGEND = 0

      DO I = 1, NMINI
C
C        Set the packet size, which is a function of the subtype. Also
C        set the window size. First check the subtype, which will be
C        used as an array index.
C
         PKTSIZ = PKTSZS ( SUBTPS(I) )

C
C        In order to compute the end pointer of the current
C        mini-segment, we must compute the size, in terms
C        of DAF addresses, of this mini-segment. The formula
C        for the size is
C
C            size =     n_packets * packet_size
C                    +  n_epochs
C                    +  n_epoch_directories
C                    +  4
C
C                 =     n_packets * ( packet_size + 1 )
C                    +  ( n_packets - 1 ) / DIRSIZ
C                    +  4
C
         MINISZ =       NPKTS(I) * ( PKTSIZ + 1 )
     .              + ( NPKTS(I) - 1 ) / DIRSIZ
     .              +   4

         SEGBEG = SEGEND + 1
         SEGEND = SEGBEG + MINISZ - 1

C
C        Write the mini-segment begin pointer.
C
C        After the loop terminates, the final end pointer, incremented
C        by 1, will be written.
C
         CALL DAFADA ( DBLE(SEGBEG), 1 )

      END DO

C
C     Write the last mini-segment end pointer, incremented by one.
C     SEGEND was computed on the last iteration of the above loop.
C
      CALL DAFADA ( DBLE(SEGEND+1), 1 )

C
C     Write out the interval selection flag. The input
C     boolean value is represented by a numeric constant.
C
      IF ( SELLST ) THEN

         ISEL = ITRUE
      ELSE
         ISEL = IFALSE
      END IF

      CALL DAFADA ( DBLE( ISEL ),  1 )

C
C     Write the mini-segment/mini-segment interval count.
C
      CALL DAFADA ( DBLE(NMINI), 1 )

C
C     End the segment.
C
      CALL DAFENA

      CALL CHKOUT ( 'CKW06' )
      RETURN
      END


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

! RDFD
! Tool for calculating Radial Distribution Functions from xyz files
! The extra 'D' shows that the RDF is calculated as a function of distance from some centre and binned
! The centre is a position and not an atom
!
! rdfd <xyzfile> <symbol> <symbol> <centre x y z> <distance cutoff> <distance binwidth> <rdf cutoff> <rdf binwidth> <output file> <decimation> <from> <to> <IO_Rate>
program RDFD

    use libatoms_module

    implicit none

    type(Atoms)                           :: at
    type(InOutput)                        :: xyzfile, datafile
    integer                               :: Za, Zb
    integer                               :: frames_read, frames_processed
    integer                               :: status
    integer                               :: i, j

    !Binning & histograms
    integer                               :: rdf_bin, dist_bin
    integer                               :: num_rdf_bins, num_dist_bins
    integer                               :: num_A_atoms, num_B_atoms
    real(dp)                              :: r, B_density
    integer,  allocatable, dimension(:,:) :: rdf_data
    integer,  allocatable, dimension(:)   :: num_atoms

    !Input
    type(Dictionary)                      :: params_in
    character(STRING_LENGTH)               :: xyzfilename, datafilename
    real(dp)                              :: d_cutoff, d_binwidth
    real(dp)                              :: rdf_cutoff, rdf_binwidth
    real(dp), dimension(3)                :: centre
    character(STRING_LENGTH)               :: mask1, mask2
    integer                               :: IO_Rate
    integer                               :: decimation
    integer                               :: from, to
    logical                               :: Gaussian_smoothing
    real(dp)                              :: Gaussian_sigma

    !Start up LOTF, suppressing messages
    call system_initialise(PRINT_NORMAL)
    call verbosity_push(PRINT_NORMAL)

#ifdef DEBUG
    call print('********** DEBUG BUILD **********')
    call print('')
#endif

    call initialise(params_in)
    call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'AtomMask1', param_mandatory, mask1, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'AtomMask2', param_mandatory, mask2, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'centre', '0. 0. 0.', centre, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'RDFCutoff', param_mandatory, rdf_cutoff, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'RDFBinWidth', param_mandatory, rdf_binwidth, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'DistCutoff', param_mandatory, d_cutoff, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'DistBinWidth', param_mandatory, d_binwidth, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'from', '0', from, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'to', '0', to, help_string="No help yet.  This source file was $LastChangedBy$")
    call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet.  This source file was $LastChangedBy$")
!    call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet.  This source file was $LastChangedBy$")
!    call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet.  This source file was $LastChangedBy$")
    if (.not. param_read_args(params_in)) then
       if (EXEC_NAME == '<UNKNOWN>') then
          call print_usage
       else
          call print_usage(EXEC_NAME)
       end if
      call system_abort('could not parse argument line')
    end if
    call finalise(params_in)

    call print('Run_parameters: ')
    call print('==================================')
    call print('    Input file: '//trim(xyzfilename))
    call print('   Output file: '//trim(datafilename))
    call print('     AtomMask1: '//trim(mask1))
    call print('     AtomMask2: '//trim(mask2))
    call print('        centre: '//round(centre(1),3)//' '//round(centre(2),3)//' '//round(centre(3),3))
    call print('     RDFCutoff: '//round(rdf_cutoff,3))
    call print('   RDFBinWidth: '//round(rdf_binwidth,3))
    call print('    DistCutoff: '//round(d_cutoff,3))
    call print('  DistBinWidth: '//round(d_binwidth,3))
    call print('    decimation: '//decimation)
    if (decimation == 1) then
       call print('             Processing every frame')
    else
       write(line,'(a,i0,a,a)')'             Processing every ',decimation,th(decimation),' frame'
       call print(line)
    end if
    call print('    from Frame: '//from)
    call print('      to Frame: '//to)
    call print('       IO_Rate: '//IO_Rate)
    call print('     Gaussians: '//Gaussian_smoothing)
    if (Gaussian_smoothing) call print('        sigma: '//round(Gaussian_sigma,3))
    call print('==================================')
    call print('')

    call initialise(xyzfile,xyzfilename,action=INPUT)

    call print('Mask 1:')
    call print('=======')
    Za = Atomic_Number(mask1)
    call print('')
    call print('Selecting all '//trim(ElementName(Za))//' atoms (Z = '//Za//')')
    call print('')

    call print('Mask 2:')
    call print('=======')
    Zb = Atomic_Number(mask2)
    call print('')
    call print('Selecting all '//trim(ElementName(Zb))//' atoms (Z = '//Zb//')')
    call print('')

    if (d_cutoff < 0.0_dp) call system_abort('Distance cutoff < 0.0 Angstroms')
    if (d_binwidth < 0.0_dp) call system_abort('Distance bin width < 0.0 Angstroms')
    if (rdf_cutoff < 0.0_dp) call system_abort('RDF cutoff < 0.0 Angstroms')
    if (rdf_binwidth < 0.0_dp) call system_abort('RDF bin width < 0.0 Angstroms')

    !Make the number of bins and bin widths consistent
    num_rdf_bins = ceiling(rdf_cutoff / rdf_binwidth)
    rdf_binwidth = rdf_cutoff / real(num_rdf_bins,dp)
    num_dist_bins = ceiling(d_cutoff / d_binwidth)
    d_binwidth = d_cutoff / real(num_dist_bins,dp)

    !Set up arrays
    allocate( rdf_data(num_rdf_bins,num_dist_bins), num_atoms(num_dist_bins) )

    rdf_data = 0
    num_atoms = 0

    call print('')
    call print('RDFs from ('//centre//') out to '//round(d_cutoff,3)//'A')
    call print('Each RDF has '//num_rdf_bins//' bins x '//round(rdf_binwidth,3)//'A per bin = '//round(rdf_cutoff,3)//'A cutoff')
    call print('')

    call print('Reading data...')
    frames_read = 0
    frames_processed = 0

    do

       call read_xyz(at,xyzfile,status=status)
       if (status/=0) then
          if (frames_processed > 1) call write_data
          exit
       end if
       frames_read = frames_read + 1

       ! Do the calculation between form and to:
       if (frames_read.ge.from) then
          if ((frames_read.gt.to) .and.(to.gt.0)) exit
          ! Loop over all atoms
          num_A_atoms = 0
          num_B_atoms = 0
          do i = 1, at%N

             !Count 'B' atoms
             if (at%Z(i) == Zb) num_B_atoms = num_B_atoms + 1

             !Do we have an 'A' atom?
             if (at%Z(i) /= Za) cycle

             num_A_atoms = num_A_atoms + 1

             !Is this 'A' atom within the cutoff of the centre?
             r = distance_min_image(at,i,centre)
             if (r >= d_cutoff) cycle

             !Increase the atom count at this distance
             dist_bin = bin(0.0_dp,d_cutoff,d_binwidth,r)
             num_atoms(dist_bin) = num_atoms(dist_bin) + 1

             !Loop over all other atoms
             do j = 1, at%N

                ! Skip self
                if (i==j) cycle

                !Do we have a 'B' atom?
                if (at%Z(j) /= Zb) cycle

                !Is this 'B' atom within the rdf cutoff of the 'A' atom?
                r = distance_min_image(at,i,j)
                if (r >= rdf_cutoff) cycle

                !Increase the count at this distance
                rdf_bin = bin(0.0_dp,rdf_cutoff,rdf_binwidth,r)
                rdf_data(rdf_bin,dist_bin) = rdf_data(rdf_bin,dist_bin) + 1

             end do

          end do

          B_density = real(num_B_atoms,dp) / cell_volume(at)

          frames_processed = frames_processed + 1
          write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',frames_read

          if (mod(frames_processed,IO_Rate)==0) then
             !call print('writing data to datafile '//trim(datafile%filename))
             call write_data
          endif
       endif

       !Skip ahead (decimation-1) frames
       do i = 1, (decimation-1)
          call read_xyz(xyzfile,status)
          if (status/=0) exit
          frames_read = frames_read + 1
       end do
          if (status/=0) exit

    end do

    call print('Finished.')
    call print('Read '//frames_read//' frames, processed '//frames_processed//' frames.')

    call verbosity_pop
    call system_finalise()

contains

  subroutine write_data

    integer  :: i, j
    real(dp) :: dist, rdf_dist, rdf, rdf_int, dV

    call initialise(datafile,datafilename,action=OUTPUT)

    do i = 1, num_dist_bins

       dist = (real(i,dp)-0.5_dp)*d_binwidth

       do j = 1, num_rdf_bins

          rdf_dist = (real(j,dp)-0.5_dp)*rdf_binwidth
          dV = PI*rdf_binwidth * ( 4.0_dp*rdf_dist*rdf_dist + rdf_binwidth*rdf_binwidth/3.0_dp )

          if (num_atoms(i) > 0) then
             rdf_int = real(rdf_data(j,i),dp) / (real(num_atoms(i),dp))
          else
             rdf_int = 0
          end if
          rdf = rdf_int / ( dV * B_density )

          call print(round(dist,5)//' '//round(rdf_dist,5)//' '//round(rdf,5)//' '//round(rdf_int,5),file=datafile)

       end do

       call print('',file=datafile) !Insert blank line to separate data sets

    end do

    call finalise(datafile)

  end subroutine write_data

  subroutine print_usage(name)

    character(*), optional, intent(in) :: name

    if (present(name)) then
       write(line,'(3a)')'Usage: ',trim(name),' <xyzfile> <AtomMask1> <AtomMask2> <Centre> <DistCutoff> <DistBinwidth> <RDFCutoff> <RDFBinWidth> <datafile> [<decimation>] [<from>] [<to>] [<IO_Rate>]'
    else
       write(line,'(a)')'Usage: rdfd <xyzfile> <AtomMask1> <AtomMask2> <Centre> <DistCutoff> <DistBinwidth> <RDFCutoff> <RDFBinWidth> <datafile> [<decimation>] [<from>] [<to>] [<IO_Rate>]'
    end if
    call print(line)
    call print(' <xyzfile>       The input xyz file.')
    call print(' <AtomMask1>     An element symbol, e.g. H or Ca')
    call print(' <AtomMask2>     An element symbol, e.g. H or Ca')
    call print(' <Centre>        The central atom.')
    call print(' <DistBinWidth>  The width of bins into which rdfs are placed.')
    call print(' <DistCutoff>    The cutoff radius for the distance from the centre.')
    call print(' <RDFCutoff>    The cutoff radius for the RDF in Angstroms.')
    call print(' <RDFBinWidth>  The width of each bin in Angstroms used for individual rdf calculations.')
    call print(' <datafile>      The output data file.')
    call print(' <decimation>    Optional. Only process 1 out of every n frames')
    call print(' <fromn>         Optional. Only process frames from this frame')
    call print(' <to>            Optional. Only process frames until this frame')
    call print(' <IO_Rate>       Optional. Write data after every n processed frames')
    call print('')

    call verbosity_pop
    call system_finalise

  end subroutine print_usage

end program RDFD


! This program is an example of use of the albedo module.

! To-do:

! Separate executable that will now use this file
! 1. run the correlated-K module, no output to disk
! 2. take MOD06 cloud information to fill in the cloud positions
! 3. run DISORT (new one that supposedly does GFORTRAN) to simulate the radiances
!    over an entire granule's worth.
! 4. Output that data to a file and visualize the resulting reflectance/radiance
! 5. send it to Arlindo and grin evilly

program read_albedo

	use general_array_io, only:read_float_array, write_float_array, write_int_array, read_int_array, GetWidHt, write_byte_array
	use global_model_grids
	use modis_albedo
	use emissivity
	use modis_numerical_module, only: linearinterpolation
	use geos5_io_module

	use hdf5

	implicit none

	character(len=200) :: MOD03_name, output_name, &
		emissivity_name, ocean_name, IGBP_name, &
		geos5_file

! there are 7 albedo files
	integer, parameter :: nbands = 7
	integer, parameter :: num_albs = 46
	integer, parameter :: albedo_tags(num_albs) = (/1, 9, 17, 25, 33, 41, 49, 57, 65, 73, 81, 89, &
		97, 105, 113, 121, 129, 137, 145, 153, 161, 169, 177, 185, 193, 201, 209, 217, 225, 233, &
		241, 249, 257, 265, 273, 281, 289, 297, 305, 313, 321, 329, 337, 345, 353, 361 /)
	real, parameter :: albedo_factor = 0.001

	integer*2, parameter :: season_break(4) = (/ 60, 152, 244, 335 /)

	integer, parameter :: emis_channels(11) = (/ 20, 22, 27, 28, 29, 31, 32, 33, 34, 35, 36 /)

	integer :: modis_wid, modis_ht, start(2), stride(2), edge(2)
	integer :: year, day_of_year, file_id(1), err_code, i, fid(1), edg(2), albedo_year

	integer*1, dimension(:,:), allocatable :: ecosystem_flag
	real, dimension(:,:), allocatable :: latitude, longitude, snow_ice_fraction, solar_zenith, sensor_zenith
	real, dimension(:,:), allocatable :: solar_azimuth, sensor_azimuth, relative_azimuth_angle
	integer*2, dimension(:,:,:), allocatable :: surface_albedo, emissive_albedo
	real, dimension(:,:,:), allocatable :: ocean_albedo
	real, dimension(:,:,:), allocatable :: temp_albedo

	character(len=200) :: albedo_files(nbands)
	character(len=200) :: albedo_path, albedo_dir, albedo_single
	character(len=3) :: doy_tag
	character(len=400) :: snow_albedo_filename, db_albedo_name

	integer :: num_Iter, lat_start, lat_end, j
	integer :: start_time, end_time, crate, cmax
	character(len=10) :: platform_name
	logical :: useoffset
	real*8, parameter :: d2r = 0.017453292519943295d0
	integer*1 :: leap_offset
	integer*1, dimension(:,:), allocatable :: land_mask

	integer, parameter :: nszen = 33, nvzen = 28, nraz = 37, nws = 3
	real :: lib_szen(nszen), lib_vzen(nvzen), lib_phi(nraz)
	real :: library_ocean(nszen, nvzen, nraz, 15, nws)
	real :: albedo_vector(15)

	character(len=300) :: parfile

	character(len=10) :: band_dir(nbands)

! GEOS-5 QUIERY

	integer :: grid_xsize, grid_xstart, iend
	integer :: grid_ysize, grid_ystart, jend

    real, allocatable, dimension(:,:)  :: wind_speed

	real, dimension(:,:), allocatable :: met_temp1, met_temp2, met_temp3, met_temp4
	real :: xx(2), yy1(2), yy2(2)
	real :: met_date(2), frac_time

   real, dimension(:,:), allocatable :: Tsfc, colO3
	integer :: MYTIME, MYMONTH
	integer, parameter :: model_layers = 101
	integer :: model_i, model_j
	real :: snow, ice

	integer :: gfile_id(2)

! END GEOS-5 QUIERY

	band_dir = (/ "MCD43GS066", "MCD43GS086", "MCD43GS047", "MCD43GS056",   &
		      "MCD43GS124", "MCD43GS164", "MCD43GS213"  /)

	call system_clock(start_time, crate, cmax)

	lib_szen(1:13)   = (/ (0.05 * i+0.15, i=0,12) /) !numOfSolarAngs = 33, numOfViewAngs = 28
	lib_vzen(1:8)     = (/(0.05 * i + 0.40,i=0,7) /)
	lib_szen(14:nszen)   = (/ (0.0125 * i+0.7625, i=0,19) /) !numOfSolarAngs = 33, numOfViewAngs = 28
	lib_vzen(9:nvzen)     = (/(0.0125 * i + 0.7625,i=0,19) /)
    lib_phi(1:nraz)= (/ (5.0 * i,i=0,nraz-1)/)

	call getarg(1, parfile)
	call read_par_file(parfile)

	print*, year, day_of_year, MYTIME
	print*, "mod03: ", MOD03_name
	print*, "output: ", output_name
	print*, "GEOS: ", geos5_file
	print*, "alb_path: ", albedo_path

! select the albedo directory to read from based on year/date information
! this code needs to go wherever the initial decision on input files is being made
	albedo_year = year
	if (albedo_year > 2016) albedo_year = 2016

	do i=1, num_albs
		if (day_of_year < albedo_tags(i)) exit
	end do
	i=i-1

	if (day_of_year < 17) then
		write(doy_tag, '(a2,i1)') "00", albedo_tags(i)
	else if (day_of_year >= 17 .and. day_of_year < 105) then
		write(doy_tag, '(a1,i2)') "0", albedo_tags(i)
	else
		write(doy_tag, '(i3)') albedo_tags(i)
	endif

	write(albedo_dir, '(i4,a1,a3,a1)') albedo_year, "/", doy_tag , "/"
	print*, trim(albedo_dir)

! generate the filenames as they contain year/date information
	do i=1, nbands
		write(albedo_single, '(a16,i1,a1,a3,a1,i4,a9)') "MCD43GF_wsa_Band", i, "_", doy_tag, "_", albedo_year, "_V006.hdf"
		albedo_files(i) = trim(albedo_path) // trim(band_dir(i)) // "/" // trim(albedo_dir) // trim(albedo_single)
		print*, trim(albedo_files(i))
	end do

! now we know what to read, grab a granule and get its information
! in reality this information will come from somewhere else within the model
! so this is technically junk code.

	file_id(1) = sfstart(MOD03_name, DFACC_READ)
	call GetWidHt(file_id, "Latitude", modis_wid, modis_ht)

! we will go to 10 km
	modis_wid = modis_wid
	modis_ht = modis_ht

	allocate(latitude(modis_wid, modis_ht), &
			 longitude(modis_wid, modis_ht), &
			 ecosystem_flag(modis_wid, modis_ht), &
			 surface_albedo(modis_wid, modis_ht, 13), &
			 emissive_albedo(modis_wid, modis_ht, 2), &
			 ocean_albedo(modis_wid, modis_ht, 7), &
			 snow_ice_fraction(modis_wid, modis_ht))

	allocate(solar_zenith(modis_wid, modis_ht), &
			 sensor_zenith(modis_wid, modis_ht), &
			 solar_azimuth(modis_wid, modis_ht), &
			 sensor_azimuth(modis_wid, modis_ht), &
			 relative_azimuth_angle(modis_wid, modis_ht))

	allocate(land_mask(modis_wid, modis_ht))

	start = 0
	stride = 1
	edge = (/ modis_wid, modis_ht /)

	call read_float_array(file_id, "Latitude", start, stride, edge, latitude, err_code)
	call read_float_array(file_id, "Longitude", start, stride, edge, longitude, err_code)

	useoffset = .false.
	call read_int_array(file_id, "SensorZenith", start, stride, edge, useoffset, sensor_zenith, err_code)
	call read_int_array(file_id, "SensorAzimuth", start, stride, edge, useoffset, sensor_azimuth, err_code)
	call read_int_array(file_id, "SolarZenith", start, stride, edge, useoffset, solar_zenith, err_code)
	call read_int_array(file_id, "SolarAzimuth", start, stride, edge, useoffset, solar_azimuth, err_code)

	err_code = sfend(file_id(1))

	solar_zenith = cos(solar_zenith*d2r)
	sensor_zenith = cos(sensor_zenith*d2r)

!  calculate the relative azimuth (From MOD06)

   relative_azimuth_angle =  solar_azimuth + 180. - sensor_azimuth

	deallocate(solar_azimuth)
	deallocate(sensor_azimuth)

	do j = 1,  modis_ht
		do i = 1, modis_wid

       if (relative_azimuth_angle(i,j) <= 0.) relative_azimuth_angle(i,j) = -relative_azimuth_angle(i,j)
       if (relative_azimuth_angle(i,j) > 180.) relative_azimuth_angle(i,j) = 360. - relative_azimuth_angle(i,j)
     enddo
   enddo

   relative_azimuth_angle = abs(relative_azimuth_angle)
   where(relative_azimuth_angle > 180.) relative_azimuth_angle =360. - relative_azimuth_angle

! now we are read in the ocean surface albedo table from our snazzy lookup table that
! we've calculated from a DISORT run.

	file_id(1) = sfstart(ocean_name, DFACC_READ)
	call read_float_array(file_id, "Ocean_Reflectance", (/ 0,0,0,0,0 /), (/ 1,1,1,1,1 /), &
								(/ nszen, nvzen, nraz, 13, nws /), library_ocean, err_code)
	err_code = sfend(file_id(1))

	print*, library_ocean(1,1,1,1,:)

! GEOS-5 QUIERY
	file_id(1) = sfstart(output_name, DFACC_CREATE)

    allocate(wind_speed(modis_wid, modis_ht))
    allocate(met_temp1(modis_wid, modis_ht))
    allocate(met_temp2(modis_wid, modis_ht))

	call h5open_f(err_code)

	call h5fopen_f(geos5_file, H5F_ACC_RDONLY_F, gfile_id(1), err_code)

	call read_float_array_g5(gfile_id, 1, "U10M", (/0,0,0/), (/1,1,1/), (/ modis_wid, modis_ht, 1/), 2, met_temp1, err_code)
	call read_float_array_g5(gfile_id, 1, "V10M", (/0,0,0/), (/1,1,1/), (/ modis_wid, modis_ht, 1/), 2, met_temp2, err_code)

	do j=1, modis_ht
		do i=1, modis_wid

			wind_speed(i,j) = sqrt( met_temp1(i,j) ** 2 + met_temp2(i,j) ** 2 )

		end do
	end do

	call read_float_array_g5(gfile_id, 1, "FRSEAICE", (/ grid_xstart, grid_ystart, 0/), (/1,1,1/), (/  modis_wid, modis_ht, 1/), 2, met_temp1, err_code)
	call read_float_array_g5(gfile_id, 1, "FRSNO", (/ grid_xstart, grid_ystart, 0/), (/1,1,1/), (/  modis_wid, modis_ht, 1/), 2, met_temp2, err_code)

	snow_ice_fraction = 0.

	do j=1, modis_ht
		do i=1, modis_wid

			ice = met_temp1(i,j)
			snow = met_temp2(i,j)

			if (ice > 0. .and. ice <= 1.) snow_ice_fraction(i,j) = ice
			if (snow > 0.5 .and. snow <= 1.) snow_ice_fraction(i,j) = snow

		end do
	end do

	call h5fclose_f(gfile_id(1), err_code)

	call write_float_array(file_id, "snow_ice_fraction", (/0,0/), (/1,1/), (/modis_wid, modis_ht/), snow_ice_fraction, err_code)

	deallocate(met_temp1, met_temp2)

	call h5close_f(err_code)

! END GEOS-5 QUIERY

! at this point, we are ready to read the albedo. The albedo has to be read in pieces in order to not overwhelm
! the system memory. The albedo files are very large.

! we will take out the NISE stuff later once we know what exactly GEOS-5 can give us.

	num_iter = modis_ht / 100 + 1

	do i=1, num_iter

		lat_start = (i-1)*100 + 1
		if (i==num_iter) then
			lat_end = modis_ht
		else
			lat_end = lat_start + 99
		endif

		print*, lat_start, lat_end

		call getAlbedoEco(latitude(:, lat_start:lat_end), &
						longitude (:, lat_start:lat_end), &
						day_of_year, albedo_files, IGBP_name, &
						snow_albedo_filename, &
						snow_ice_fraction(:, lat_start:lat_end), &
						surface_albedo(:, lat_start:lat_end, 1:7), &
						land_mask(:, lat_start:lat_end) )

	end do

! write the output to disk.
	stride = 1

	call write_float_array(file_id, "Phi", start, stride, edge, relative_azimuth_angle, err_code)

! now calculate surface albedo for channels 17, 18, 19 and 26 based on information we already have
! 18 and 19 share the albedo because they are basically the same channel.

	do j=1, modis_ht
		do i=1, modis_wid

			surface_albedo(i,j,10) = int( linearinterpolation( (/ 0.858, 1.24 /), (/ surface_albedo(i,j,2)*1., surface_albedo(i,j,5)*1. /), &
										0.905 ) )
			surface_albedo(i,j,11) = int( linearinterpolation( (/ 0.858, 1.24 /), (/ surface_albedo(i,j,2)*1., surface_albedo(i,j,5)*1. /), &
										0.94 ) )
			surface_albedo(i,j,12) = int( linearinterpolation( (/ 0.858, 1.24 /), (/ surface_albedo(i,j,2)*1., surface_albedo(i,j,5)*1. /), &
										0.94 ) )
			surface_albedo(i,j,13) = linearinterpolation( (/ 1.24, 1.64 /), (/ surface_albedo(i,j,5)*1., surface_albedo(i,j,6)*1. /), &
										1.375 )

		end do
	end do

! now we will get surface albedo for 412 and 430nm channels 8 and 9
	if ( mod(year,4) == 0 .and. mod(year,400) /= 0) then
		leap_offset = 1
	else
		leap_offset = 0
	endif

	if ( day_of_year+leap_offset < season_break(1)+leap_offset .or. day_of_year+leap_offset >= season_break(4)+leap_offset) &
		db_albedo_name = "LIB/aqua_modis_surfdb_winter_20110913.hdf"
	if ( day_of_year+leap_offset >= season_break(1)+leap_offset .and. day_of_year+leap_offset < season_break(2)+leap_offset) &
		db_albedo_name = "LIB/aqua_modis_surfdb_spring_20110913.hdf"
	if ( day_of_year+leap_offset >= season_break(2)+leap_offset .and. day_of_year+leap_offset < season_break(3)+leap_offset) &
		db_albedo_name = "LIB/aqua_modis_surfdb_summer_20110913.hdf"
	if ( day_of_year+leap_offset >= season_break(3)+leap_offset .and. day_of_year+leap_offset < season_break(4)+leap_offset) &
		db_albedo_name = "LIB/aqua_modis_surfdb_fall_20110913.hdf"

	allocate(temp_albedo(modis_wid, modis_ht, 1))

	call get_db_albedo(db_albedo_name, latitude, longitude, temp_albedo(:,:,1))

	surface_albedo(:,:,8) = int(temp_albedo(:,:,1)*10.)
! we need to match resolutions on these suckers as much as possible
	where(land_mask(:,:) == 0) surface_albedo(:,:,8) = 32767

	do j=1, modis_ht
		do i=1, modis_wid
			surface_albedo(i,j,9) = int( linearinterpolation( (/ 0.421, 0.469 /), (/ surface_albedo(i,j,1)*1., surface_albedo(i,j,3)*1. /), &
										0.443 ) )
		end do
	end do

! this is where we fill in the surface albedo. Wind speed has been read from GEOS-5
	print*, lib_szen
	print*, lib_vzen
	print*, lib_phi

	do j=1, modis_ht
		do i=1, modis_wid

			if (land_mask(i,j) == 0 .and. snow_ice_fraction(i,j) == 0. ) then ! this means ocean and no snow/ice

				call interpolate_albedo(library_ocean, &
							lib_szen, lib_vzen, lib_phi, &
							wind_speed(i,j), &
							solar_zenith(i,j), sensor_zenith(i,j), relative_azimuth_angle(i,j), &
							 albedo_vector)

				surface_albedo(i,j,:) = int( albedo_vector(1:13)*1000. )
				emissive_albedo(i,j,1:2) = int( albedo_vector(14:15)*1000. )

			endif

		end do

	end do

	call write_float_array(file_id, "wind_speed", start, stride, edge, wind_speed, err_code)

	deallocate(wind_speed)

	where (snow_ice_fraction /= 0.) land_mask = 1
	call write_byte_array(file_id, "Ocean_Mask", start, stride, edge, land_mask, err_code)

	call write_int_array(file_id, "Surface_Albedo_1", start, stride, edge, surface_albedo(:,:,1), err_code)
	call write_int_array(file_id, "Surface_Albedo_2", start, stride, edge, surface_albedo(:,:,2), err_code)
	call write_int_array(file_id, "Surface_Albedo_3", start, stride, edge, surface_albedo(:,:,3), err_code)
	call write_int_array(file_id, "Surface_Albedo_4", start, stride, edge, surface_albedo(:,:,4), err_code)
	call write_int_array(file_id, "Surface_Albedo_5", start, stride, edge, surface_albedo(:,:,5), err_code)
	call write_int_array(file_id, "Surface_Albedo_6", start, stride, edge, surface_albedo(:,:,6), err_code)
	call write_int_array(file_id, "Surface_Albedo_7", start, stride, edge, surface_albedo(:,:,7), err_code)
	call write_int_array(file_id, "Surface_Albedo_8", start, stride, edge, surface_albedo(:,:,8), err_code)
	call write_int_array(file_id, "Surface_Albedo_9", start, stride, edge, surface_albedo(:,:,9), err_code)
	call write_int_array(file_id, "Surface_Albedo_17", start, stride, edge, surface_albedo(:,:,10), err_code)
	call write_int_array(file_id, "Surface_Albedo_18", start, stride, edge, surface_albedo(:,:,11), err_code)
	call write_int_array(file_id, "Surface_Albedo_19", start, stride, edge, surface_albedo(:,:,12), err_code)
	call write_int_array(file_id, "Surface_Albedo_26", start, stride, edge, surface_albedo(:,:,13), err_code)

	print*, "1,2,3,4,5,6,7,8,9,17,18,19,26"
	print*, surface_albedo(630, 305, 1:13)

	err_code = sfend(file_id(1))

	deallocate(snow_ice_fraction)
	deallocate(surface_albedo)
	deallocate(temp_albedo)

! now that we've extracted the surface albedo from MOD43 files, we need to add the surface albedo
! for all the emissive channels, of which there are 11: 20, 22, 27, 28, 29, 31, 32, 33, 34, 35 and 36

	allocate(surface_albedo(modis_wid, modis_ht, 11), temp_albedo(modis_wid, modis_ht, 11))

	platform_name = "Aqua"
	call get_emissivity(emissivity_name, emis_channels, platform_name, latitude, longitude, temp_albedo)

	surface_albedo = int( (1. - temp_albedo) * 1000. )
! match the resolutions with original surface albedo
	do j=1, modis_ht
		do i=1, modis_wid

			if (land_mask(i,j) == 0) then
				surface_albedo(i,j,1:2) = emissive_albedo(i,j,1:2)
				surface_albedo(i,j,3:11) = int( (1-0.985)*1000.)
			endif

		end do
	end do

	deallocate(temp_albedo)

	file_id(1) = sfstart(output_name, DFACC_WRITE)
	call write_int_array(file_id, "Surface_Albedo_20", start, stride, edge, surface_albedo(:,:,1), err_code)
	call write_int_array(file_id, "Surface_Albedo_22", start, stride, edge, surface_albedo(:,:,2), err_code)
	call write_int_array(file_id, "Surface_Albedo_27", start, stride, edge, surface_albedo(:,:,3), err_code)
	call write_int_array(file_id, "Surface_Albedo_28", start, stride, edge, surface_albedo(:,:,4), err_code)
	call write_int_array(file_id, "Surface_Albedo_29", start, stride, edge, surface_albedo(:,:,5), err_code)
	call write_int_array(file_id, "Surface_Albedo_31", start, stride, edge, surface_albedo(:,:,6), err_code)
	call write_int_array(file_id, "Surface_Albedo_32", start, stride, edge, surface_albedo(:,:,7), err_code)
	call write_int_array(file_id, "Surface_Albedo_33", start, stride, edge, surface_albedo(:,:,8), err_code)
	call write_int_array(file_id, "Surface_Albedo_34", start, stride, edge, surface_albedo(:,:,9), err_code)
	call write_int_array(file_id, "Surface_Albedo_35", start, stride, edge, surface_albedo(:,:,10), err_code)
	call write_int_array(file_id, "Surface_Albedo_36", start, stride, edge, surface_albedo(:,:,11), err_code)

	print*, "20,22,27,28, 29, 31, 32, 33, 34, 35, 36"
	print*, surface_albedo(630, 305, 1:11)

	err_code = sfend(file_id(1))

	deallocate(latitude, longitude, ecosystem_flag, surface_albedo, ocean_albedo)
	deallocate(land_mask)

	call system_clock(end_time, crate, cmax)

	print*, "Time: ", (end_time - start_time) / (crate*1.0) / 60., "min"

contains

	subroutine read_par_file(parfile_name)

		character*(*), intent(in) :: parfile_name
		character(len=200) :: dummy, input_dir, temp
		character(len=4) :: ytemp, doytemp, ttemp

		open (unit=20, file=parfile_name)

		read(20,*) dummy
		read(20, *) ytemp, doytemp, ttemp

		read(ytemp, *) year
		read(doytemp, *) day_of_year
		read(ttemp, *) MYTIME

		input_dir = "inputs-" // trim(ytemp) // trim(doytemp) // "." // trim(ttemp) // "/"

		read(20,*) dummy
		read(20,'(a)') temp
		MOD03_name = trim(input_dir) // trim(temp)

		read(20,*) dummy
		read(20,'(a)') temp
		output_name = trim(input_dir) // trim(temp)

		read(20,*) dummy
		read(20,*) dummy

		read(20,*) dummy
		read(20,'(a)') temp
		geos5_file = trim(input_dir) // trim(temp)

		read(20,*) dummy
		read(20,'(a)') temp
		albedo_path = trim(temp)

! The ecosystem flag should come from IGBP

		snow_albedo_filename = "LIB/AlbSnwSts.ByNISE.W90.D90.WS.Hemi.2000-2004.YrAvg.hdf"
		emissivity_name = "LIB/global_emiss_intABI_2005001.hdf"
		ocean_name = "LIB/Ocean_Reflectance.hdf"
		IGBP_name = "LIB/IGBP.EcoMap.NtoS.2004.149.v004.hdf"

		close(20)

	end subroutine read_par_file

end program read_albedo


      subroutine setboostatoms
      include 'moldy.h'
c
      integer*4 i, j, ii, ihe, ijk
      real*8 xij, yij, zij, rxij, ryij, rzij, r2
      real*8 xhea, yhea, zhea, rij
      integer*4 idya1, iikey

      ihenum = 0
      do i = 1, nn1
         if(atpe(i) .gt. -3.89)then
           ihenum = ihenum + 1
           iheid(ihenum) = i
         endif
      end do
      write(*,*) 'total number of atoms with Ep>-3.89eV is ', ihenum
c determine the surrounding atoms of these accelerating atoms
      do ihe = 1,ihenum
         ijk = iheid(ihe)
         xhea = x0(ijk)
         yhea = y0(ijk)
         zhea = z0(ijk)
c idya: the number of found near-by atoms around current He position
          idya1 = idya

c loop over all the atoms to find the atoms close to the current
c He position, distance less than 3 angstrom
          do i = 1, nn1
            xij = (x0(i)-xhea)*b0(1,1)
            yij = (y0(i)-yhea)*b0(2,2)
            zij = (z0(i)-zhea)*b0(3,3)
            if(xij.ge. b0(1,1)/2.0d0) xij = xij - b0(1,1)
            if(xij.lt.-b0(1,1)/2.0d0) xij = xij + b0(1,1)
            if(yij.ge. b0(2,2)/2.0d0) yij = yij - b0(2,2)
            if(yij.lt.-b0(2,2)/2.0d0) yij = yij + b0(2,2)
            if(zij.ge. b0(3,3)/2.0d0) zij = zij - b0(3,3)
            if(zij.lt.-b0(3,3)/2.0d0) zij = zij + b0(3,3)
            rij = sqrt(yij*yij + zij*zij)
c for loops, we consider the distance around one B
           if(abs(xij).le.0.5*b0(1,1) .and. rij .lt. 3.5d0)then
              iikey = 1
c idya_n(i): store the id of atoms near by He atoms
              do j = 1, idya1
                 iii = idya_n(j)
                 if(iii .eq. i)then
                   iikey = 0
                   exit
                 endif
              end do

              if(iikey .eq. 1)then
                idya = idya + 1
                idya_n(idya) = i
                xjp(idya) = x0(i)
                yjp(idya) = y0(i)
                zjp(idya) = z0(i)
              endif
            endif
         end do
      end do

      write(*,*) 'total accelerating atoms = ', idya

      do i = 1, idya
         ii = idya_n(i)
         x00 = xjp(i)*b0(1,1)
         y00 = yjp(i)*b0(2,2)
         z00 = zjp(i)*b0(3,3)
         write(*,*) x00, y00, z00, id(ii), ii
      end do

      open(unit=21,file='mdyn_region.psi',position='append')
      write(21,'(a)') 'ITEM: TIMESTEP'
      write(21,'(i9)') nst
      write(21,'(a)') 'ITEM: NUMBER OF ATOMS'
      write(21,'(i6)') idya
      write(21,'(a)') 'ITEM: BOX BOUNDS'
      write(21,'(2(f18.9))') -b0(1,1)/2.0d0, b0(1,1)/2.0d0
      write(21,'(2(f18.9))') -b0(2,2)/2.0d0, b0(2,2)/2.0d0
      write(21,'(2(f18.9))') -b0(3,3)/2.0d0, b0(3,3)/2.0d0
      write(21,'(a)') 'ITEM: ATOMS id x y z itype pe ke pre shr'
      do 12211 j = 1, idya
         iij = idya_n(j)
         xiij = x0(iij)*b0(1,1)
         yiij = y0(iij)*b0(2,2)
         ziij = z0(iij)*b0(3,3)
         write(21,'(i6,2x,3(f12.5),2x,i2,4(f12.5))')
     &   iij,xiij,yiij,ziij,id(iij),atpe(iij),ekin(iij),atpress(iij),
     &        atshear(iij)
12211 continue
      close(21)

      return
      end subroutine