C$Procedure      SPKW19 ( Write SPK segment, type 19 )

      SUBROUTINE SPKW19 ( HANDLE,  BODY,    CENTER,  FRAME,
     .                    FIRST,   LAST,    SEGID,   NINTVL,
     .                    NPKTS,   SUBTPS,  DEGRES,  PACKTS,
     .                    EPOCHS,  IVLBDS,  SELLST          )

C$ Abstract
C
C     Write a type 19 segment to an SPK 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     DAF
C     NAIF_IDS
C     SPC
C     SPK
C     TIME
C
C$ Keywords
C
C     EPHEMERIS
C     FILES
C
C$ Declarations

      IMPLICIT NONE

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

      INTEGER               HANDLE
      INTEGER               BODY
      INTEGER               CENTER
      CHARACTER*(*)         FRAME
      DOUBLE PRECISION      FIRST
      DOUBLE PRECISION      LAST
      CHARACTER*(*)         SEGID
      INTEGER               NINTVL
      INTEGER               NPKTS  ( * )
      INTEGER               SUBTPS ( * )
      INTEGER               DEGRES ( * )
      DOUBLE PRECISION      PACKTS ( * )
      DOUBLE PRECISION      EPOCHS ( * )
      DOUBLE PRECISION      IVLBDS ( * )
      LOGICAL               SELLST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   Handle of an SPK file open for writing.
C     BODY       I   NAIF ID code for an ephemeris object.
C     CENTER     I   NAIF ID code for center of motion of BODY.
C     FRAME      I   Reference frame name.
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     NINTVL     I   Number of mini-segments and interpolation
C                    intervals.
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     EPOCHS     I   Array of epochs of mini-segments.
C     IVLBDS     I   Interpolation 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 an SPK file that has been opened
C                    for writing.
C
C
C     BODY           is the NAIF integer code for an ephemeris object
C                    whose state relative to another body is described
C                    by the segment to be created.
C
C
C     CENTER         is the NAIF integer code for the center of motion
C                    of the object identified by BODY.
C
C
C     FRAME          is the NAIF name for a reference frame
C                    relative to which the state information for BODY
C                    is specified.
C
C     FIRST,
C     LAST           are, respectively, the bounds of the time interval
C                    over which the segment defines the state of BODY.
C
C                    FIRST must be greater than or equal to the first
C                    interpolation interval start time; LAST must be
C                    less than or equal to the last interpolation
C                    interval stop time. See the description of IVLBDS
C                    below.
C
C
C     SEGID          is the segment identifier. An SPK segment
C                    identifier may contain up to 40 characters.
C
C
C     NINTVL         is the number of interpolation intervals
C                    associated with the input data. The interpolation
C                    intervals are associated with data sets referred
C                    to as "mini-segments."
C
C                    The input data comprising each mini-segment are:
C
C                       - a packet count
C                       - a type 19 subtype
C                       - an interpolating polynomial degree
C                       - a sequence of type 19 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 interpolation
C                    interval/mini-segment.
C
C                    NPKTS has dimension NINTVL.
C
C
C     SUBTPS         is an array of type 19 subtypes. The Ith element
C                    of SUBTPS is the subtype of the packets associated
C                    with the Ith interpolation interval/mini-segment.
C
C                    SUBTPS has dimension NINTVL.
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                    interpolation interval/mini-segment.
C
C                    For subtype 0, 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 subtype 1, interpolation degrees must be odd
C                    and must be in the range 1:MAXDEG.
C
C                    DEGRES has dimension NINTVL.
C
C
C     PACKTS         is an array containing data packets for all input
C                    mini-segments. The packets for a given
C                    mini-segment are stored contiguously in increasing
C                    time order. The order of the sets of packets for
C                    different mini-segments is the same as the order
C                    of their corresponding interpolation intervals.
C
C                    Each packet represents geometric states of BODY
C                    relative to CENTER, specified relative to FRAME.
C                    The packet structure depends on the segment
C                    subtype as follows:
C
C                       Type 0 (indicated by code S19TP0):
C
C                           x,  y,  z,  dx/dt,  dy/dt,  dz/dt,
C                           vx, vy, vz, dvx/dt, dvy/dt, dvz/dt
C
C                       where x, y, z represent Cartesian position
C                       components and  vx, vy, vz represent Cartesian
C                       velocity components.  Note well:  vx, vy, and
C                       vz *are not necessarily equal* to the time
C                       derivatives of x, y, and z. This packet
C                       structure mimics that of the Rosetta/MEX orbit
C                       file.
C
C                       Type 1 (indicated by code S19TP1):
C
C                           x,  y,  z,  dx/dt,  dy/dt,  dz/dt
C
C                       where x, y, z represent Cartesian position
C                       components and  vx, vy, vz represent Cartesian
C                       velocity components.
C
C
C                       Type 2 (indicated by code S19TP2):
C
C                           Data are identical to type 1; only the
C                           interpolation algorithm is different.
C
C                    Position units are kilometers, velocity units
C                    are kilometers per second, and acceleration units
C                    are kilometers per second per second.
C
C
C     EPOCHS         is an array containing epochs for all input
C                    mini-segments. Each epoch is expressed as seconds
C                    past J2000 TDB. The epochs have a one-to-one
C                    relationship with the packets in the input packet
C                    array.
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                    interpolation 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 interpolation interval
C                    start time and end after the corresponding
C                    interpolation interval stop time. Padding is used
C                    to control behavior of interpolating polynomials
C                    near interpolation interval boundaries.
C
C                    Due to possible use of padding, the elements of
C                    EPOCHS, taken as a whole, may not be in increasing
C                    order.
C
C
C     IVLBDS         is an array of interpolation interval boundary
C                    times. This array is an ordered list of the
C                    interpolation interval start times, to which the
C                    the end time for the last interval is appended.
C
C                    The Ith interpolation 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                    interpolation interval's start time is greater
C                    than or equal to the mini-segment's first epoch,
C                    and the interval's stop time is less than or equal
C                    to the mini-segment's last epoch.
C
C                    For each interpolation interval other than the
C                    last, the interval's coverage stop time coincides
C                    with the coverage start time of the next interval.
C                    There are no coverage gaps, and coverage overlap
C                    for adjacent intervals consists of a single epoch.
C
C                    IVLBDS has dimension NINTVL+1.
C
C
C     SELLST         is a logical flag indicating to the SPK type 19
C                    segment reader SPKR19 how to select the
C                    interpolation interval when a request time
C                    coincides with a time boundary shared by two
C                    interpolation intervals. When SELLST ("select
C                    last") is .TRUE., the later interval is selected;
C                    otherwise the earlier interval is selected.
C
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 spk19.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 FRAME 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 NINTVL 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(N+1) is less
C         than LAST, the error SPICE(COVERAGEGAP) will be 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
C         is not at least 1 or is greater than MAXDEG, the
C         error 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 EPOCHS corresponding to a given
C         mini-segment are not in strictly increasing order, the error
C         SPICE(TIMESOUTOFORDER) will be signaled.
C
C    13)  If the first epoch of a mini-segment exceeds the start
C         time of the associated interpolation interval, or if the
C         last epoch of the mini-segment precedes the end time of the
C         interpolation interval, the error SPICE(BOUNDSDISAGREE)
C         is signaled.
C
C    14)  Any error that occurs while writing the output segment will
C         be diagnosed by routines in the call tree of this routine.
C
C$ Files
C
C     A new type 19 SPK segment is written to the SPK file attached
C     to HANDLE.
C
C$ Particulars
C
C     This routine writes an SPK type 19 data segment to the open SPK
C     file according to the format described in the type 19 section of
C     the SPK Required Reading. The SPK file must have been opened with
C     write access.
C
C$ Examples
C
C     Suppose that you have states and are prepared to produce
C     a segment of type 19 in an SPK file.
C
C     The following code fragment could be used to add the new segment
C     to a previously opened SPK 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_SPK_TYPE_19_SEGMENT'
C
C        C
C        C     Write the segment.
C        C
C              CALL SPKW19 ( HANDLE,  BODY,    CENTER,  FRAME,
C             .              FIRST,   LAST,    SEGID,   NINTVL,
C             .              NPKTS,   SUBTPS,  DEGRES,  PACKTS,
C             .              EPOCHS,  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, 21-DEC-2015 (NJB)
C
C        Updated to support subtype 2.
C
C-    SPICELIB Version 1.0.0, 05-FEB-2014 (NJB) (BVS)
C
C-&

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

C
C     SPICELIB functions
C
      INTEGER               LASTNB

      LOGICAL               FAILED
      LOGICAL               ODD
      LOGICAL               RETURN

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  =  19 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

C
C     Local variables
C
      DOUBLE PRECISION      DC     ( ND )
      DOUBLE PRECISION      DESCR  ( DSCSIZ )

      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 : S19NST-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  /  S19PS0, S19PS1, S19PS2 /

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

      CALL CHKIN ( 'SPKW19' )

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

         CALL SETMSG ( 'SPK type 19 record size may be as '
     .   //            'large as #, but SPKPVN record size '
     .   //            'is #.'                              )
         CALL ERRINT ( '#',  MAXRSZ                         )
         CALL ERRINT ( '#',  MAXREC                         )
         CALL SIGERR ( 'SPICE(BUG0)'                        )
         CALL CHKOUT ( 'SPKW19'                             )
         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 ( 'SPKW19'                                    )
         RETURN

      END IF

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

      IF ( REFCOD .EQ. 0 ) THEN

         CALL SETMSG ( 'The reference frame # is not supported.'   )
         CALL ERRCH  ( '#', FRAME                                  )
         CALL SIGERR ( 'SPICE(INVALIDREFFRAME)'                    )
         CALL CHKOUT ( 'SPKW19'                                  )
         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 ( 'SPKW19'                                )
         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 ( 'SPKW19'                          )
            RETURN

         END IF

      END DO

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

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

      END IF

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

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

            CALL SETMSG ( '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 ( 'SPKW19'                              )
            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(NINTVL+1) ) ) THEN

         CALL SETMSG ( 'First interval start time is #; '
     .   //            'segment start time is #; segment '
     .   //            'stop time is #; last interval stop '
     .   //            'time is #. This sequence of times '
     .   //            'is required to be non-decreasing: '
     .   //            'segment coverage must be contained '
     .   //            'within the union of the interpolation '
     .   //            'intervals.'                            )
         CALL ERRDP  ( '#', IVLBDS(1)                          )
         CALL ERRDP  ( '#', FIRST                              )
         CALL ERRDP  ( '#', LAST                               )
         CALL ERRDP  ( '#', IVLBDS(NINTVL+1)                   )
         CALL SIGERR ( 'SPICE(COVERAGEGAP)'                    )
         CALL CHKOUT ( 'SPKW19'                                )
         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, NINTVL
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 SPK type 19. Number of packets '
     .      //            'supplied was # in mini-segment at index #.' )
            CALL ERRINT ( '#', NPKTS(I)                                )
            CALL ERRINT ( '#', I                                       )
            CALL SIGERR ( 'SPICE(TOOFEWPACKETS)'                       )
            CALL CHKOUT ( 'SPKW19'                                     )
            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. S19NST-1 ) ) THEN

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

         END IF

         PKTSIZ = PKTSZS ( SUBTYP )

         IF ( SUBTYP .EQ. S19TP0 ) THEN

            WINSIZ = ( DEGRES(I) + 1 ) / 2

         ELSE IF ( SUBTYP .EQ. S19TP1 ) THEN

            WINSIZ =   DEGRES(I) + 1

         ELSE IF ( SUBTYP .EQ. S19TP2 ) THEN

            WINSIZ = ( DEGRES(I) + 1 ) / 2

         ELSE
            CALL SETMSG ( 'Subtype = #; not expected.' )
            CALL ERRINT ( '#', SUBTYP                  )
            CALL SIGERR ( 'SPICE(BUG1)'                )
         END IF

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 ( 'SPKW19'                            )
            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 SPK type 19. '
     .      //            'The mini-segment subtype is #. '
     .      //            'The degree must be equivalent to 3 '
     .      //            'mod 4 for subtype 0 (Hermite '
     .      //            'interpolation) and be odd for subtype '
     .      //            '1 (Lagrange interpolation).'          )
            CALL ERRINT ( '#', I                                 )
            CALL ERRINT ( '#', WINSIZ                            )
            CALL ERRINT ( '#', DEGRES(I)                         )
            CALL ERRINT ( '#', SUBTPS(I)                         )
            CALL SIGERR ( 'SPICE(BADWINDOWSIZE)'                 )
            CALL CHKOUT ( 'SPKW19'                               )
            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 ( EPOCHS(K) .GE. EPOCHS(K+1) ) THEN

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

            END IF

         END DO

C
C        Make sure that the span of the input epochs of the Ith
C        mini-segment includes the Ith interpolation interval.
C
         IF (  EPOCHS(BEPIX) .GT. IVLBDS(I) ) THEN

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

         ELSE IF (  EPOCHS(EEPIX) .LT. IVLBDS(I+1) ) THEN

            CALL SETMSG ( 'Interpolation interval # end time # '
     .      //            'exceeds mini-segment''s last epoch #.'   )
            CALL ERRINT ( '#',  I                                   )
            CALL ERRDP  ( '#',  IVLBDS(I+1)                         )
            CALL ERRDP  ( '#',  EPOCHS(EEPIX)                       )
            CALL SIGERR ( 'SPICE(BOUNDSDISAGREE)'                   )
            CALL CHKOUT ( 'SPKW19'                                  )
            RETURN

         END IF

      END DO

C
C     If we made it this far, we're ready to start writing the segment.
C
C     The type 19 segment structure is eloquently described by this
C     diagram from the SPK Required Reading:
C
C        +--------------------------------+
C        | Interval 1 mini-segment        |
C        +--------------------------------+
C              .
C              .
C              .
C        +--------------------------------+
C        | Interval N mini-segment        |
C        +--------------------------------+
C        | Interval 1 start time          |
C        +--------------------------------+
C              .
C              .
C              .
C        +--------------------------------+
C        | Interval N start time          |
C        +--------------------------------+
C        | Interval N stop time           |
C        +--------------------------------+
C        | Interval start 100             | (First interval directory)
C        +--------------------------------+
C              .
C              .
C              .
C        +--------------------------------+
C        | Interval start (N/100)*100     | (Last interval directory)
C        +--------------------------------+
C        | Interval 1 start pointer       |
C        +--------------------------------+
C              .
C              .
C              .
C        +--------------------------------+
C        | Interval N start pointer       |
C        +--------------------------------+
C        | Interval N stop pointer + 1    |
C        +--------------------------------+
C        | Boundary choice flag           |
C        +--------------------------------+
C        | Number of intervals            |
C        +--------------------------------+
C
C
C     SPK type 19 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        | Subtype code          |
C        +-----------------------+
C        | Window size           |
C        +-----------------------+
C        | Number of packets     |
C        +-----------------------+
C
C
C     Create the segment descriptor. We don't use SPKPDS because
C     that routine doesn't allow creation of a singleton segment.
C
      IC(1) = BODY
      IC(2) = CENTER
      IC(3) = REFCOD
      IC(4) = DTYPE

      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 ( 'SPKW19' )
         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, NINTVL
C
C        Set the packet size, which is a function of the subtype.
C
         SUBTYP = SUBTPS ( I )

         PKTSIZ = PKTSZS ( SUBTYP )

         IF ( SUBTYP .EQ. S19TP0 ) THEN

            WINSIZ = ( DEGRES(I) + 1 ) / 2

         ELSE IF ( SUBTYP .EQ. S19TP1 ) THEN

            WINSIZ =   DEGRES(I) + 1

         ELSE IF ( SUBTYP .EQ. S19TP2 ) THEN

            WINSIZ = ( DEGRES(I) + 1 ) / 2

         ELSE
            CALL SETMSG ( 'Subtype = #; not expected.' )
            CALL ERRINT ( '#', SUBTYP                  )
            CALL SIGERR ( 'SPICE(BUG2)'                )
         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 ( EPOCHS(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 ( EPOCHS(K), 1 )

         END DO

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

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

      END DO

C
C     We've finished writing the mini-segments.
C
C     Next write the interpolation interval bounds.
C
      CALL DAFADA ( IVLBDS, NINTVL+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 = NINTVL / 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, NINTVL
C
C        Set the packet size, which is a function of the subtype.
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                    +  3
C
C                 =     n_packets * ( packet_size + 1 )
C                    +  ( n_packets - 1 ) / DIRSIZ
C                    +  3
C
         MINISZ =       NPKTS(I) * ( PKTSIZ + 1 )
     .              + ( NPKTS(I) - 1 ) / DIRSIZ
     .              +   3

         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/interpolation interval count.
C
      CALL DAFADA ( DBLE(NINTVL), 1 )

C
C     End the segment.
C
      CALL DAFENA

      CALL CHKOUT ( 'SPKW19' )
      RETURN
      END


program gemini3d_run
!! for use from terminal/CMake, computes optimal MPI count
!! for a particular simulation

use hwloc_ifc, only : get_cpu_count
use runner, only : clean_output
use reader, only: get_simsize3
use autogrid, only : grid_auto, max_mpi
use help, only : help_gemini_run
use config, only : get_compiler_vendor
use, intrinsic :: iso_fortran_env, only : stderr=>error_unit

implicit none (type, external)

integer :: i, lx1, lx2all, lx3all, lid, lid2, lid3, Ncpu, argc
character(1000) :: buf
character(:), allocatable :: path, gem_exe, cmd, mpiexec, extra, git_revision
logical :: exists, plan

plan = .false.

Ncpu = get_cpu_count()
print '(A,I0)', 'gemini3d.run: detected CPU count: ', Ncpu

git_revision = "@git_rev@"

argc = command_argument_count()

if(argc < 1) call help_gemini_run(git_revision)

call get_command_argument(1, buf)
path = trim(buf)

do i = 2, argc
  call get_command_argument(i, buf)

  select case (buf)
  case ('-h', '-help')
    call help_gemini_run(git_revision)
  case ('-compiler')
    print '(A)', get_compiler_vendor()
    stop
  case ('-git')
    print '(A)', git_revision
    stop
  case ('-n')
    call get_command_argument(i+1, buf)
    read(buf, '(I6)') Ncpu
  case ('-gemexe')
    call get_command_argument(i+1, buf)
    gem_exe = trim(buf)
  case ('-mpiexec')
    call get_command_argument(i+1, buf)
    mpiexec = trim(buf)
    inquire(file=mpiexec, exist=exists)
    if(.not.exists) error stop mpiexec // ' is not a file.'
  case ('-dryrun')
    extra = '-dryrun'
  case ('-plan')
    plan = .true.
  end select
end do

!> setup run
call get_simsize3(path // '/inputs', lx1, lx2all, lx3all)

if(Ncpu > 1) then
  lid = max_mpi(lx2all, lx3all, Ncpu)
else
  lid = 1
endif

!> checks consistency
call grid_auto(lx2all, lx3all, lid, lid2, lid3)

print '(A,I0,A1,I0,A,I0,A1,I0,A,I0)', 'MPI partition of lx2, lx3: ', lx2all, ' ',lx3all, &
' is lid2, lid3: ',lid2,' ',lid3, ' using total MPI images: ', lid

if(plan) stop

!> Find gemini.bin, the main program
if(.not.allocated(gem_exe)) gem_exe = 'gemini.bin'
inquire(file=gem_exe, exist=exists)
if(.not.exists) then
  inquire(file=gem_exe // '.exe', exist=exists)
  if(exists) then
    gem_exe = gem_exe // '.exe'
  endif
endif

inquire(file=gem_exe, exist=exists)
if(.not. exists) error stop "please specify path to gemini.bin with '-gemexe path/to/gemini.bin'"

if(.not.allocated(mpiexec)) mpiexec = 'mpiexec'

if(.not.allocated(extra)) extra = ''

!> remove old output files
call clean_output(path)

!> run gemini.bin
if(lid > 1) then
  write(buf, '(A1,A,A,I0,1X,A,1X,A,1X,A)') '"',mpiexec, '" -n ', lid, gem_exe, path, extra
else
  write(buf, '(A,1X,A,1X,A)') gem_exe, path, extra
endif
!! quotes are for mpiexec path with spaces
cmd = trim(buf)
print *, cmd
call execute_command_line(cmd, exitstat=i)

if (i/=0) error stop 'gemini.bin run failure'

end program


      SUBROUTINE readi(NA,ND,NT,NE,NAX,NDX,NTX,NEX,NF,NFX,NTZ
     2,NTZX,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE READS ALL SOIL AND TOPOGRAPHIC INPUT FILES
C
      include "parameters.h"
      include "filec.h"
      include "files.h"
      include "blkc.h"
      include "blk2a.h"
      include "blk2b.h"
      include "blk2c.h"
      include "blk8a.h"
      include "blk8b.h"
      include "blk17.h"
      DIMENSION NA(10),ND(10),NM(JY,JX),DHI(JX),DVI(JY)
      CHARACTER*16 DATA(30),DATAC(30,250,250),DATAP(JP,JY,JX)
     2,DATAM(JP,JY,JX),DATAX(JP),DATAY(JP),DATAZ(JP,JY,JX)
     3,OUTS(10),OUTP(10),OUTFILS(10,JY,JX),OUTFILP(10,JP,JY,JX)
      CHARACTER*3 CHOICE(102,20)
      CHARACTER*8 CDATE
      CHARACTER*16 OUTW,OUTI,OUTT,OUTN,OUTF
      CHARACTER*4 CHARY
      CHARACTER*1 TTYPE,CTYPE,IVAR(20),VAR(50),TYP(50)
      CHARACTER*80 PREFIX
      DIMENSION IDAT(20),DAT(50),DATK(50)
      PARAMETER (TWILGT=0.06976)
C
C     OPEN SITE, TOPOGRAPHY, AND WEATHER FILES FROM
C     FILE NAMES IN DATA ARRAYS LOADED IN 'MAIN'
C
      OPEN(18,FILE='logfile1',STATUS='UNKNOWN')
      OPEN(19,FILE='logfile2',STATUS='UNKNOWN')
      OPEN(20,FILE='logfile3',STATUS='UNKNOWN')
      OPEN(1,FILE=TRIM(PREFIX)//DATA(1),STATUS='OLD')
      OPEN(7,FILE=TRIM(PREFIX)//DATA(2),STATUS='OLD')
      WRITE(18,5000)'  17 APR 2019'
5000  FORMAT(A16)
      NF=1
      NFX=1
      NTZ=0
C
C     READ SITE DATA
C
      READ(1,*)ALATG,ALTIG,ATCAG,IPRCG
      READ(1,*)OXYEG,Z2GEG,CO2EIG,CH4EG,Z2OEG,ZNH3EG
      READ(1,*)IETYPG,ISALTG,IERSNG,NCNG,DTBLIG,DDRGIG,DTBLGG
      READ(1,*)RCHQNG,RCHQEG,RCHQSG,RCHQWG,RCHGNUG,RCHGEUG,RCHGSUG
     2,RCHGWUG,RCHGNTG,RCHGETG,RCHGSTG,RCHGWTG,RCHGDG
      READ(1,*)(DHI(NX),NX=1,NHE)
      READ(1,*)(DVI(NY),NY=1,NVS)
      CLOSE(1)
      DO 9895 NX=NHW,NHE
      DO 9890 NY=NVN,NVS
      ALAT(NY,NX)=ALATG
      ALTI(NY,NX)=ALTIG
      ATCAI(NY,NX)=ATCAG
      IPRC(NY,NX)=IPRCG
      OXYE(NY,NX)=OXYEG
      Z2GE(NY,NX)=Z2GEG
      CO2EI(NY,NX)=CO2EIG
      CH4E(NY,NX)=CH4EG
      Z2OE(NY,NX)=Z2OEG
      ZNH3E(NY,NX)=ZNH3EG
      IETYP(NY,NX)=IETYPG
      IERSN(NY,NX)=IERSNG
      NCN(NY,NX)=NCNG
      DTBLI(NY,NX)=DTBLIG
      DDRGI(NY,NX)=DDRGIG
      DTBLG(NY,NX)=DTBLGG
      RCHQN(NY,NX)=RCHQNG
      RCHQE(NY,NX)=RCHQEG
      RCHQS(NY,NX)=RCHQSG
      RCHQW(NY,NX)=RCHQWG
      RCHGNU(NY,NX)=RCHGNUG
      RCHGEU(NY,NX)=RCHGEUG
      RCHGSU(NY,NX)=RCHGSUG
      RCHGWU(NY,NX)=RCHGWUG
      RCHGNT(NY,NX)=RCHGNTG
      RCHGET(NY,NX)=RCHGETG
      RCHGST(NY,NX)=RCHGSTG
      RCHGWT(NY,NX)=RCHGWTG
      RCHGD(NY,NX)=RCHGDG
      DH(NY,NX)=DHI(NX)
      DV(NY,NX)=DVI(NY)
      CO2E(NY,NX)=CO2EI(NY,NX)
      H2GE(NY,NX)=1.0E-03
      IF(ALAT(NY,NX).GT.0.0)THEN
      XI=173
      ELSE
      XI=356
      ENDIF
      DECDAY=XI+100
      DECLIN=SIN((DECDAY*0.9863)*1.7453E-02)*(-23.47)
      AZI=SIN(ALAT(NY,NX)*1.7453E-02)*SIN(DECLIN*1.7453E-02)
      DEC=COS(ALAT(NY,NX)*1.7453E-02)*COS(DECLIN*1.7453E-02)
      IF(AZI/DEC.GE.1.0-TWILGT)THEN
      DYLM(NY,NX)=24.0
      ELSEIF(AZI/DEC.LE.-1.0+TWILGT)THEN
      DYLM(NY,NX)=0.0
      ELSE
      DYLM(NY,NX)=12.0*(1.0+2.0/3.1416*ASIN(TWILGT+AZI/DEC))
      ENDIF
9890  CONTINUE
9895  CONTINUE
      DO 9885 NX=NHW,NHE+1
      DO 9880 NY=NVN,NVS+1
      ISALT(NY,NX)=ISALTG
9880  CONTINUE
9885  CONTINUE
C
C     READ TOPOGRAPHY DATA AND SOIL FILE NAME FOR EACH GRID CELL
C
50    READ(7,*,END=20)NH1,NV1,NH2,NV2,ASPX,SL2,SL1,DPTHSX
      READ(7,52)DATA(7)
52    FORMAT(A16)
C
C     OPEN AND READ SOIL FILE
C
      OPEN(9,FILE=TRIM(PREFIX)//DATA(7),STATUS='OLD')
      DO 9995 NX=NH1,NH2
      DO 9990 NY=NV1,NV2
C
C     SURFACE SLOPES AND ASPECTS
C
      ASP(NY,NX)=ASPX
      SL(1,NY,NX)=SL1
      SL(2,NY,NX)=SL2
      DPTHS(NY,NX)=DPTHSX
      ASP(NY,NX)=450.0-ASP(NY,NX)
      IF(ASP(NY,NX).GE.360.0)ASP(NY,NX)=ASP(NY,NX)-360.0
C
C     SURFACE RESIDUE C, N AND P
C
      READ(9,*)PSIFC(NY,NX),PSIWP(NY,NX),ALBS(NY,NX),PH(0,NY,NX)
     2,RSC(1,0,NY,NX),RSN(1,0,NY,NX),RSP(1,0,NY,NX)
     3,RSC(0,0,NY,NX),RSN(0,0,NY,NX),RSP(0,0,NY,NX)
     4,RSC(2,0,NY,NX),RSN(2,0,NY,NX),RSP(2,0,NY,NX)
     5,IXTYP(1,NY,NX),IXTYP(2,NY,NX)
     6,NU(NY,NX),NJ(NY,NX),NL1,NL2,ISOILR(NY,NX)
      NK(NY,NX)=NJ(NY,NX)+1
      NM(NY,NX)=NJ(NY,NX)+NL1
      NL(NY,NX)=NM(NY,NX)+NL2
C
C     PHYSICAL PROPERTIES
C
      READ(9,*)(CDPTH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(BKDS(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     HYDROLOGIC PROPERTIES
C
      READ(9,*)(FC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(WP(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(SCNV(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(SCNH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     PHYSICAL PROPERTIES
C
      READ(9,*)(CSAND(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CSILT(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(FHOL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(ROCK(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     CHEMICAL PROPERTIES
C
      READ(9,*)(PH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CEC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(AEC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     ORGANIC C, N AND P CONCENTRATIONS
C
      READ(9,*)(CORGC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGR(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGN(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGP(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     INORGANIC N AND P CONCENTRATIONS
C
      READ(9,*)(CNH4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CNO3(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CPO4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     CATION AND ANION CONCENTRATIONS
C
      READ(9,*)(CAL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFE(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CMG(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CNA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CKA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CSO4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     PRECIPITATED MINERAL CONCENTRATIONS
C
      READ(9,*)(CALPO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFEPO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCAPD(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCAPH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CALOH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFEOH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCACO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCASO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     GAPON SELECTIVITY CO-EFFICIENTS
C
      READ(9,*)(GKC4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCM(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCN(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCK(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     INITIAL WATER, ICE CONTENTS
C
      READ(9,*)(THW(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(THI(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     INITIAL PLANT AND ANIMAL RESIDUE C, N AND P
C
      READ(9,*)(RSC(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSC(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSC(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      REWIND(9)
      RSC(1,0,NY,NX)=AMAX1(1.0E-03,RSC(1,0,NY,NX))
      RSN(1,0,NY,NX)=AMAX1(0.04E-03,RSN(1,0,NY,NX))
      RSP(1,0,NY,NX)=AMAX1(0.004E-03,RSP(1,0,NY,NX))
      CDPTH(0,NY,NX)=0.0
C
C     ADD SOIL BOUNDARY LAYERS ABOVE ROOTING ZONE
C
      IF(NU(NY,NX).GT.1)THEN
      DO 31 L=NU(NY,NX)-1,0,-1
      IF(BKDS(L+1,NY,NX).GT.0.025)THEN
      CDPTH(L,NY,NX)=CDPTH(L+1,NY,NX)-0.01
      ELSE
      CDPTH(L,NY,NX)=CDPTH(L+1,NY,NX)-0.02
      ENDIF
      IF(L.GT.0)THEN
      BKDS(L,NY,NX)=BKDS(L+1,NY,NX)
      FC(L,NY,NX)=FC(L+1,NY,NX)
      WP(L,NY,NX)=WP(L+1,NY,NX)
      SCNV(L,NY,NX)=SCNV(L+1,NY,NX)
      SCNH(L,NY,NX)=SCNH(L+1,NY,NX)
      CSAND(L,NY,NX)=CSAND(L+1,NY,NX)
      CSILT(L,NY,NX)=CSILT(L+1,NY,NX)
      CCLAY(L,NY,NX)=CCLAY(L+1,NY,NX)
      FHOL(L,NY,NX)=FHOL(L+1,NY,NX)
      ROCK(L,NY,NX)=ROCK(L+1,NY,NX)
      PH(L,NY,NX)=PH(L+1,NY,NX)
      CEC(L,NY,NX)=CEC(L+1,NY,NX)
      AEC(L,NY,NX)=AEC(L+1,NY,NX)
      CORGC(L,NY,NX)=0.0*CORGC(L+1,NY,NX)
      CORGR(L,NY,NX)=0.0*CORGR(L+1,NY,NX)
      CORGN(L,NY,NX)=0.0*CORGN(L+1,NY,NX)
      CORGP(L,NY,NX)=0.0*CORGP(L+1,NY,NX)
      CNH4(L,NY,NX)=CNH4(L+1,NY,NX)
      CNO3(L,NY,NX)=CNO3(L+1,NY,NX)
      CPO4(L,NY,NX)=CPO4(L+1,NY,NX)
      CAL(L,NY,NX)=CAL(L+1,NY,NX)
      CFE(L,NY,NX)=CFE(L+1,NY,NX)
      CCA(L,NY,NX)=CCA(L+1,NY,NX)
      CMG(L,NY,NX)=CMG(L+1,NY,NX)
      CNA(L,NY,NX)=CNA(L+1,NY,NX)
      CKA(L,NY,NX)=CKA(L+1,NY,NX)
      CSO4(L,NY,NX)=CSO4(L+1,NY,NX)
      CCL(L,NY,NX)=CCL(L+1,NY,NX)
      CALOH(L,NY,NX)=CALOH(L+1,NY,NX)
      CFEOH(L,NY,NX)=CFEOH(L+1,NY,NX)
      CCACO(L,NY,NX)=CCACO(L+1,NY,NX)
      CCASO(L,NY,NX)=CCASO(L+1,NY,NX)
      CALPO(L,NY,NX)=CALPO(L+1,NY,NX)
      CFEPO(L,NY,NX)=CFEPO(L+1,NY,NX)
      CCAPD(L,NY,NX)=CCAPD(L+1,NY,NX)
      CCAPH(L,NY,NX)=CCAPH(L+1,NY,NX)
      GKC4(L,NY,NX)=GKC4(L+1,NY,NX)
      GKCH(L,NY,NX)=GKCH(L+1,NY,NX)
      GKCA(L,NY,NX)=GKCA(L+1,NY,NX)
      GKCM(L,NY,NX)=GKCM(L+1,NY,NX)
      GKCN(L,NY,NX)=GKCN(L+1,NY,NX)
      GKCK(L,NY,NX)=GKCK(L+1,NY,NX)
      THW(L,NY,NX)=THW(L+1,NY,NX)
      THI(L,NY,NX)=THI(L+1,NY,NX)
      ISOIL(1,L,NY,NX)=ISOIL(1,L+1,NY,NX)
      ISOIL(2,L,NY,NX)=ISOIL(2,L+1,NY,NX)
      ISOIL(3,L,NY,NX)=ISOIL(3,L+1,NY,NX)
      ISOIL(4,L,NY,NX)=ISOIL(4,L+1,NY,NX)
      RSC(1,L,NY,NX)=0.0
      RSN(1,L,NY,NX)=0.0
      RSP(1,L,NY,NX)=0.0
      RSC(0,L,NY,NX)=0.0
      RSN(0,L,NY,NX)=0.0
      RSP(0,L,NY,NX)=0.0
      RSC(2,L,NY,NX)=0.0
      RSN(2,L,NY,NX)=0.0
      RSP(2,L,NY,NX)=0.0
      ENDIF
31    CONTINUE
      ENDIF
C
C     ADD SOIL BOUNDARY LAYERS BELOW ROOTING ZONE
C
      DO 32 L=NM(NY,NX)+1,JZ
      CDPTH(L,NY,NX)=2.0*CDPTH(L-1,NY,NX)-1.0*CDPTH(L-2,NY,NX)
      BKDS(L,NY,NX)=BKDS(L-1,NY,NX)
      FC(L,NY,NX)=FC(L-1,NY,NX)
      WP(L,NY,NX)=WP(L-1,NY,NX)
      SCNV(L,NY,NX)=SCNV(L-1,NY,NX)
      SCNH(L,NY,NX)=SCNH(L-1,NY,NX)
      CSAND(L,NY,NX)=CSAND(L-1,NY,NX)
      CSILT(L,NY,NX)=CSILT(L-1,NY,NX)
      CCLAY(L,NY,NX)=CCLAY(L-1,NY,NX)
      FHOL(L,NY,NX)=FHOL(L-1,NY,NX)
      ROCK(L,NY,NX)=ROCK(L-1,NY,NX)
      PH(L,NY,NX)=PH(L-1,NY,NX)
      CEC(L,NY,NX)=CEC(L-1,NY,NX)
      AEC(L,NY,NX)=AEC(L-1,NY,NX)
C     IF(IPRC(NY,NX).EQ.0)THEN
      CORGC(L,NY,NX)=0.0*CORGC(L-1,NY,NX)
      CORGR(L,NY,NX)=0.0*CORGR(L-1,NY,NX)
      CORGN(L,NY,NX)=0.0*CORGN(L-1,NY,NX)
      CORGP(L,NY,NX)=0.0*CORGP(L-1,NY,NX)
C     ELSE
C     CORGC(L,NY,NX)=CORGC(L-1,NY,NX)
C     CORGR(L,NY,NX)=CORGR(L-1,NY,NX)
C     CORGN(L,NY,NX)=CORGN(L-1,NY,NX)
C     CORGP(L,NY,NX)=CORGP(L-1,NY,NX)
C     ENDIF
      CNH4(L,NY,NX)=CNH4(L-1,NY,NX)
      CNO3(L,NY,NX)=CNO3(L-1,NY,NX)
      CPO4(L,NY,NX)=CPO4(L-1,NY,NX)
      CAL(L,NY,NX)=CAL(L-1,NY,NX)
      CFE(L,NY,NX)=CFE(L-1,NY,NX)
      CCA(L,NY,NX)=CCA(L-1,NY,NX)
      CMG(L,NY,NX)=CMG(L-1,NY,NX)
      CNA(L,NY,NX)=CNA(L-1,NY,NX)
      CKA(L,NY,NX)=CKA(L-1,NY,NX)
      CSO4(L,NY,NX)=CSO4(L-1,NY,NX)
      CCL(L,NY,NX)=CCL(L-1,NY,NX)
      CALOH(L,NY,NX)=CALOH(L-1,NY,NX)
      CFEOH(L,NY,NX)=CFEOH(L-1,NY,NX)
      CCACO(L,NY,NX)=CCACO(L-1,NY,NX)
      CCASO(L,NY,NX)=CCASO(L-1,NY,NX)
      CALPO(L,NY,NX)=CALPO(L-1,NY,NX)
      CFEPO(L,NY,NX)=CFEPO(L-1,NY,NX)
      CCAPD(L,NY,NX)=CCAPD(L-1,NY,NX)
      CCAPH(L,NY,NX)=CCAPH(L-1,NY,NX)
      GKC4(L,NY,NX)=GKC4(L-1,NY,NX)
      GKCH(L,NY,NX)=GKCH(L-1,NY,NX)
      GKCA(L,NY,NX)=GKCA(L-1,NY,NX)
      GKCM(L,NY,NX)=GKCM(L-1,NY,NX)
      GKCN(L,NY,NX)=GKCN(L-1,NY,NX)
      GKCK(L,NY,NX)=GKCK(L-1,NY,NX)
      THW(L,NY,NX)=THW(L-1,NY,NX)
      THI(L,NY,NX)=THI(L-1,NY,NX)
      ISOIL(1,L,NY,NX)=ISOIL(1,L-1,NY,NX)
      ISOIL(2,L,NY,NX)=ISOIL(2,L-1,NY,NX)
      ISOIL(3,L,NY,NX)=ISOIL(3,L-1,NY,NX)
      ISOIL(4,L,NY,NX)=ISOIL(4,L-1,NY,NX)
      RSC(1,L,NY,NX)=0.0
      RSN(1,L,NY,NX)=0.0
      RSP(1,L,NY,NX)=0.0
      RSC(0,L,NY,NX)=0.0
      RSN(0,L,NY,NX)=0.0
      RSP(0,L,NY,NX)=0.0
      RSC(2,L,NY,NX)=0.0
      RSN(2,L,NY,NX)=0.0
      RSP(2,L,NY,NX)=0.0
32    CONTINUE
C
C     CALCULATE DERIVED SOIL PROPERTIES FROM INPUT SOIL PROPERTIES
C
      DO 28 L=1,NL(NY,NX)
      FMPR(L,NY,NX)=(1.0-ROCK(L,NY,NX))*(1.0-FHOL(L,NY,NX))
      BKDS(L,NY,NX)=BKDS(L,NY,NX)/(1.0-FHOL(L,NY,NX))
      FC(L,NY,NX)=FC(L,NY,NX)/(1.0-FHOL(L,NY,NX))
      WP(L,NY,NX)=WP(L,NY,NX)/(1.0-FHOL(L,NY,NX))
      SCNV(L,NY,NX)=0.1*SCNV(L,NY,NX)*FMPR(L,NY,NX)
      SCNH(L,NY,NX)=0.1*SCNH(L,NY,NX)*FMPR(L,NY,NX)
      CCLAY(L,NY,NX)=AMAX1(0.0,1.0E+03-(CSAND(L,NY,NX)
     2+CSILT(L,NY,NX)))
      CORGC(L,NY,NX)=CORGC(L,NY,NX)*1.0E+03
      CORGR(L,NY,NX)=CORGR(L,NY,NX)*1.0E+03
      CORGCX=CORGC(L,NY,NX)+(RSC(1,L,NY,NX)+RSC(0,L,NY,NX))
     2/(BKDS(L,NY,NX)*(CDPTH(L,NY,NX)-CDPTH(L-1,NY,NX)))
      CSAND(L,NY,NX)=CSAND(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGCX/0.5E+06))
      CSILT(L,NY,NX)=CSILT(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGCX/0.5E+06))
      CCLAY(L,NY,NX)=CCLAY(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGCX/0.5E+06))
      CEC(L,NY,NX)=CEC(L,NY,NX)*10.0
      AEC(L,NY,NX)=AEC(L,NY,NX)*10.0
      CNH4(L,NY,NX)=CNH4(L,NY,NX)/14.0
      CNO3(L,NY,NX)=CNO3(L,NY,NX)/14.0
      CPO4(L,NY,NX)=CPO4(L,NY,NX)/31.0
      CAL(L,NY,NX)=CAL(L,NY,NX)/27.0
      CFE(L,NY,NX)=CFE(L,NY,NX)/56.0
      CCA(L,NY,NX)=CCA(L,NY,NX)/40.0
      CMG(L,NY,NX)=CMG(L,NY,NX)/24.3
      CNA(L,NY,NX)=CNA(L,NY,NX)/23.0
      CKA(L,NY,NX)=CKA(L,NY,NX)/39.1
      CSO4(L,NY,NX)=CSO4(L,NY,NX)/32.0
      CCL(L,NY,NX)=CCL(L,NY,NX)/35.5
      CALPO(L,NY,NX)=CALPO(L,NY,NX)/31.0
      CFEPO(L,NY,NX)=CFEPO(L,NY,NX)/31.0
      CCAPD(L,NY,NX)=CCAPD(L,NY,NX)/31.0
      CCAPH(L,NY,NX)=CCAPH(L,NY,NX)/(31.0*3.0)
      CALOH(L,NY,NX)=CALOH(L,NY,NX)/27.0
      CFEOH(L,NY,NX)=CFEOH(L,NY,NX)/56.0
      CCACO(L,NY,NX)=CCACO(L,NY,NX)/40.0
      CCASO(L,NY,NX)=CCASO(L,NY,NX)/40.0
      IF(FC(L,NY,NX).LT.0.0)THEN
      ISOIL(1,L,NY,NX)=1
      PSIFC(NY,NX)=-0.033
      ELSE
      ISOIL(1,L,NY,NX)=0
      ENDIF
      IF(WP(L,NY,NX).LT.0.0)THEN
      ISOIL(2,L,NY,NX)=1
      PSIWP(NY,NX)=-1.5
      ELSE
      ISOIL(2,L,NY,NX)=0
      ENDIF
      IF(SCNV(L,NY,NX).LT.0.0)THEN
      ISOIL(3,L,NY,NX)=1
      ELSE
      ISOIL(3,L,NY,NX)=0
      ENDIF
      IF(SCNH(L,NY,NX).LT.0.0)THEN
      ISOIL(4,L,NY,NX)=1
      ELSE
      ISOIL(4,L,NY,NX)=0
      ENDIF
C     IF(BKDS(L,NY,NX).EQ.0.0)THEN
C     FC(L,NY,NX)=1.0
C     WP(L,NY,NX)=1.0
C     ISOIL(1,L,NY,NX)=0
C     ISOIL(2,L,NY,NX)=0
C     CCLAY(L,NY,NX)=0.0
C     ENDIF
C
C     BIOCHEMISTRY 130:117-131
C
      IF(CORGN(L,NY,NX).LT.0.0)THEN
      CORGN(L,NY,NX)=AMIN1(0.125*CORGC(L,NY,NX)
     2,8.9E+02*(CORGC(L,NY,NX)/1.0E+04)**0.80)
C     WRITE(*,1111)'CORGN',L,CORGN(L,NY,NX),CORGC(L,NY,NX)
      ENDIF
      IF(CORGP(L,NY,NX).LT.0.0)THEN
      CORGP(L,NY,NX)=AMIN1(0.0125*CORGC(L,NY,NX)
     2,1.2E+02*(CORGC(L,NY,NX)/1.0E+04)**0.52)
C     WRITE(*,1111)'CORGP',L,CORGP(L,NY,NX),CORGC(L,NY,NX)
      ENDIF
      IF(CEC(L,NY,NX).LT.0.0)THEN
      CEC(L,NY,NX)=10.0*(200.0*2.0*CORGC(L,NY,NX)/1.0E+06
     2+80.0*CCLAY(L,NY,NX)+20.0*CSILT(L,NY,NX)
     3+5.0*CSAND(L,NY,NX))
C     WRITE(*,1111)'CEC',L,CEC(L,NY,NX),CORGC(L,NY,NX)
C    2,CCLAY(L,NY,NX),CSILT(L,NY,NX),CSAND(L,NY,NX)
1111  FORMAT(A8,1I4,12E12.4)
      ENDIF
28    CONTINUE
9990  CONTINUE
9995  CONTINUE
      CLOSE(9)
      GO TO 50
20    CONTINUE
      CLOSE(7)
      DO 9975 NX=NHW,NHE
      NL(NVS+1,NX)=NL(NVS,NX)
C     WRITE(*,2223)'NHE',NX,NHW,NHE,NVS,NL(NVS,NX)
9975  CONTINUE
      DO 9970 NY=NVN,NVS
      NL(NY,NHE+1)=NL(NY,NHE)
C     WRITE(*,2223)'NVS',NY,NVN,NVS,NHE,NL(NY,NHE)
2223  FORMAT(A8,6I4)
9970  CONTINUE
      NL(NVS+1,NHE+1)=NL(NVS,NHE)
      IOLD=0
      RETURN
      END


      PROGRAM reformat
! Reformat the ensemble-averaged output to the usual WMO TRAN format
!   -- sk2out, and to kml -- kmlout, called by sk2out
! File usage:
!    fort.31 -- forecast file input
!    fort.47 -- seaice_forecast.points

!    fort.60 -- output
!    fort.61 -- output
!    fort.62 -- output
!    fort.63 -- output
!    fort.64 -- output
!    fort.70 -- kml output
!    fort.90 -- echo $PDY > fort.90
!    fort.91 -- seaice_quote (for tran file construction)
!
! Robert Grumbine original version 2 June 2014

      IMPLICIT none

      INTEGER npts, tmp, ndays, time
      PARAMETER (tmp = 360*180)
      PARAMETER (ndays = 16)
      INTEGER skpt(tmp)
      REAL lat(tmp), lon(tmp), x0(tmp), y0(tmp)
      REAL dir(tmp,ndays), dist(tmp,ndays)

      INTEGER i, funit2, code

      funit2 = 31
      OPEN(31, FORM="FORMATTED", STATUS="OLD")

! Read in skiles point locations:
      OPEN(47,FILE="seaice_forecast.points",FORM="FORMATTED",
     1              STATUS="OLD")
      DO i = 1, 207
        READ(47, *) skpt(i), y0(i), x0(i)
      ENDDO

! Read in forecast and skiles point locations
      npts = tmp
      CALL getfcst(funit2, x0, y0, dir, dist, code, npts, ndays)
!      PRINT *,'getfcst return code = ',code
      DO i = 1, npts
        skpt(i) = i
      ENDDO
!      PRINT *,'x0 y0 1 = ',x0(1), y0(1), dir(1,5), dist(1,5)

! Call sk2out day by day, as in original
      DO i = 1, ndays !forecast days
!CD        PRINT *,'printing out day ',i
        time = i*24
        CALL sk2out(x0, y0, dir(:,i), dist(:,i), skpt, npts, time)
      ENDDO

      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ff_egh: Only used for hessian fit: QMDFF bonded energies
!           and gradients: add restraints!
!
!     part of QMDFF
!
subroutine ff_egh(n,at,xyz,e,g,iiaa)
use qmdff
implicit none
integer n,at(n)
real*8  xyz(3,n),e,g(3,n)
integer iiaa
real*8 vp(3),dt,deddt,rp,cosa,rab2,rcb2,vlen,rmul1,rmul2
real*8 cosna(4),sinna(4),v(4),sa(4),ca(4),phix(4),dphi(4)
real*8 va(3),vb(3),vc(3),vd(3),vba(3),vcb(3),vdc(3),vab(3)
real*8 vca(3),vdb(3),vt(3),vu(3),vtu(3),dedt(3),dedu(3)
real*8 deda(3),dedb(3),dedc(3),dedd(3),vtmp1(3),vtmp2(3)
real*8 rt2,ru2,rtu,rcb,rtru,damp,damp2,rac2,racut,valijkl
real*8 aai,aai2,r2,rjk,dampjk,damp2jk,dampij,damp2ij,dampjl
real*8 rkl,rjl,dampkl,damp2kl,damp2jl,term1(3),term2(3),term3(3)
integer ib,id
real*8 dda(3),ddb(3),ddc(3),ddd(3)

real*8 r,thab,thbc,ra(3),fac,eb,or,kij,rij,alpha,dij
real*8 dei(3),dej(3),dek(3),kijk,rb(3),ea,dedtheta,omega
real*8 c0,c1,c2,theta,sinth,costh,expo,ban
real*8 dphidri(3),dphidrj(3),dphidrk(3),dphidrl(3),step
real*8 et,phi0,rn,kijkl,dedphi,phi,cosrph,cosrph0,er,el
real*8 dphi1,dphi2,x1cos,x2cos,x1sin,x2sin,phipi,e1,e2,ef
integer i,j,k,l,m,ic,ia,list(4),jj,mm,ii,kk,it,nt,it2

e=0
g=0
!
!     basically the same as for ff_eg!
!
!     strech (bonds)
do m=1,nbond
   i=bond(1,m)
   j=bond(2,m)
   if (iiaa.ne.i.and.iiaa.ne.j) cycle
   r2=((xyz(1,i)-xyz(1,j))**2 &
     &  +(xyz(2,i)-xyz(2,j))**2 &
     &  +(xyz(3,i)-xyz(3,j))**2)
   r =sqrt(r2)
   do ic=1,3
      ra(ic)=xyz(ic,i)-xyz(ic,j)
   end do
   rij=vbond(1,m)
   kij=vbond(2,m)
   aai=vbond(3,m)
   aai2 =aai/2
   e=e+    kij*(1.+(rij/r)**aai - 2.*(rij/r)**aai2 )
   fac=aai*kij*(   -(rij/r)**aai  +  (rij/r)**aai2 )/r2
   do ic=1,3
      g(ic,i)=g(ic,i)+fac*ra(ic)
      g(ic,j)=g(ic,j)-fac*ra(ic)
   end do
end do
!
!     bends (1-2-3 angles)
!
do m=1,nangl
   j = angl(1,m)
   i = angl(2,m)
   k = angl(3,m)
   if(iiaa.ne.i.and.iiaa.ne.j.and.iiaa.ne.k) cycle
   c0  =vangl(1,m)
   kijk=vangl(2,m)
   va(1:3) = xyz(1:3,i)
   vb(1:3) = xyz(1:3,j)
   vc(1:3) = xyz(1:3,k)
   call vsub(va,vb,vab,3)
   call vsub(vc,vb,vcb,3)
   rab2 = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
   rcb2 = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
   call crprod(vcb,vab,vp)
   rp = vlen(vp)+1.d-14
   call impsc(vab,vcb,cosa)
   cosa = dble(min(1.0d0,max(-1.0d0,cosa)))
   theta= dacos(cosa)

   call abdamp(at(i),at(j),rab2,dampij,damp2ij)
   call abdamp(at(k),at(j),rcb2,dampjk,damp2jk)
   damp=dampij*dampjk

   if (pi-c0.lt.1.d-6) then
      dt  = theta - c0
      ea  = kijk * dt**2
      deddt = 2.d0 * kijk * dt
   else
      ea=kijk*(cosa-cos(c0))**2
      deddt=2.*kijk*sin(theta)*(cos(c0)-cosa)
   end if

   e = e + ea * damp
   call crprod(vab,vp,deda)
   rmul1 = -deddt / (rab2*rp)
   call vscal(deda,3,rmul1)
   call crprod(vcb,vp,dedc)
   rmul2 =  deddt / (rcb2*rp)
   call vscal(dedc,3,rmul2)
   call vadd(deda,dedc,dedb,3)
   term1(1:3)=ea*damp2ij*dampjk*vab(1:3)
   term2(1:3)=ea*damp2jk*dampij*vcb(1:3)
   g(1:3,i) = g(1:3,i) + deda(1:3)*damp+term1(1:3)
   g(1:3,j) = g(1:3,j) - dedb(1:3)*damp-term1(1:3)-term2(1:3)
   g(1:3,k) = g(1:3,k) + dedc(1:3)*damp+term2(1:3)
end do
!
!     torsional angles
!
do m=1,ntors
   i=tors(1,m)
   j=tors(2,m)
   k=tors(3,m)
   l=tors(4,m)
   if (iiaa.ne.i.and.iiaa.ne.j.and.iiaa.ne.k.and.iiaa.ne.l) cycle
   nt=tors(5,m)
   phi0 =vtors(1,m)
!
!     usual torsional angles
!
   if (tors(6,m).ne.2) then
      vab(1:3) = xyz(1:3,i)-xyz(1:3,j)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,k)-xyz(1:3,l)
      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rkl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(k),at(l),rkl,dampkl,damp2kl)
      damp= dampjk*dampij*dampkl

      phi=valijkl(n,xyz,i,j,k,l)
      call dphidr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      et=0
      dij=0
      mm=3
      do it=1,nt
         rn=vtors(mm,m)
         dphi1=phi-phi0
         dphi2=phi+phi0-pi2
         c1=rn*dphi1+vtors(mm+1,m)
         c2=rn*dphi2+vtors(mm+1,m)
         x1cos=cos(c1)
         x2cos=cos(c2)
         x1sin=sin(c1)
         x2sin=sin(c2)
         phipi=phi-pi
         ef=erf(phipi)
         e1=vtors(mm+2,m)*(1.+x1cos)
         e2=vtors(mm+2,m)*(1.+x2cos)
         et=et+0.5*(1.-ef)*e1+(0.5+0.5*ef)*e2
         expo=exp(-phipi**2)/spi
         dij=dij-expo*e1- 0.5*(1.-ef)*vtors(mm+2,m)*x1sin*rn+ &
           &  expo*e2-(0.5+0.5*ef)*vtors(mm+2,m)*x2sin*rn
         mm=mm+3
      end do
      et=et*vtors(2,m)
      dij=dij*vtors(2,m)*damp

      term1(1:3)=et*damp2ij*dampjk*dampkl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampkl*vcb(1:3)
      term3(1:3)=et*damp2kl*dampij*dampjk*vdc(1:3)

      g(1:3,i)=g(1:3,i)+dij*dda(1:3)+term1
      g(1:3,j)=g(1:3,j)+dij*ddb(1:3)-term1+term2
      g(1:3,k)=g(1:3,k)+dij*ddc(1:3)+term3-term2
      g(1:3,l)=g(1:3,l)+dij*ddd(1:3)-term3
      e=e+et*damp
!
!     inversion angles
!
   else
      vab(1:3) = xyz(1:3,j)-xyz(1:3,i)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,j)-xyz(1:3,l)
      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rjl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(j),at(l),rjl,dampjl,damp2jl)
      damp= dampjk*dampij*dampjl

      phi=omega(n,xyz,i,j,k,l)
      call domegadr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      rn=vtors(3,m)
      if(rn.gt.1.d-6)then
         dphi1=phi-phi0
         c1=dphi1+pi
         x1cos=cos(c1)
         x1sin=sin(c1)
         et   =(1.+x1cos)*vtors(2,m)
         dij  =-x1sin*vtors(2,m)*damp
      else
         et =   vtors(2,m)*(cos(phi) -cos(phi0))**2
         dij=2.*vtors(2,m)* sin(phi)*(cos(phi0)-cos(phi))*damp
      end if

      term1(1:3)=et*damp2ij*dampjk*dampjl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampjl*vcb(1:3)
      term3(1:3)=et*damp2jl*dampij*dampjk*vdc(1:3)

      g(1:3,i)=g(1:3,i)+dij*dda(1:3)-term1
      g(1:3,j)=g(1:3,j)+dij*ddb(1:3)+term1+term2+term3
      g(1:3,k)=g(1:3,k)+dij*ddc(1:3)-term2
      g(1:3,l)=g(1:3,l)+dij*ddd(1:3)-term3
      e=e+et*damp
   end if
end do
!
!     add harmonic restraint potential for force constant elongation
!
call egrestrain(n,xyz,g,er)

e = e + er

return
end subroutine ff_egh