C$Procedure       SCPS01 ( Convert type 1 SCLK string to ticks )

      SUBROUTINE SCPS01 ( SC, CLKSTR, ERROR, MSG, TICKS )

C$ Abstract
C
C     Convert a character representation of a type 1 spacecraft clock
C     count to ticks.
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     SCLK
C
C$ Keywords
C
C     CONVERSION
C     TIME
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'sclk.inc'

      INTEGER               SC
      CHARACTER*(*)         CLKSTR
      LOGICAL               ERROR
      CHARACTER*(*)         MSG
      DOUBLE PRECISION      TICKS

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     SC         I   NAIF spacecraft ID code.
C     CLKSTR     I   Character representation of a clock count.
C     ERROR      O   Parsing error flag.
C     MSG        O   Output message for parsing error.
C     TICKS      O   Number of ticks represented by the clock count.
C     MXNFLD     P   Maximum number of allowed fields in an SCLK string.
C     DELIMS     P   The accepted delimiters of an SCLK string.
C     DPLEN      P   Maximum width of a clock field.
C
C$ Detailed_Input
C
C     SC         is a NAIF spacecraft identification code.  See the
C                `Examples' section below, and also the NAIF_IDS
C                required reading file for a complete list of body ID
C                codes.
C
C
C     CLKSTR     on input is the character representation of a
C                spacecraft clock count (SCLK), without a partition
C                number.
C
C                Using Galileo as an example, a SCLK string without
C                a partition number has the form
C
C                               wwwwwwww:xx:y:z
C
C                where z is a mod-8 counter (values 0-7) which
C                increments approximately once every 8 1/3 ms., y is a
C                mod-10 counter (values 0-9) which increments once
C                every time z turns over, i.e., approximately once every
C                66 2/3 ms., xx is a mod-91 (values 0-90) counter
C                which increments once every time y turns over, i.e.,
C                once every 2/3 seconds. wwwwwwww is the Real-Time
C                Image Count (RIM), which increments once every time
C                xx turns over, i.e., once every 60 2/3 seconds. The
C                roll-over expression for the RIM is 16777215, which
C                corresponds to approximately 32 years.
C
C                wwwwwwww, xx, y, and z are referred to interchangeably
C                as the fields or components of the spacecraft count.
C                SCLK components may be separated by any of the
C                single character delimiters in the string DELIMS, with
C                any number of spaces separating the components and
C                the delimiters. The presence of the RIM component
C                is required. Successive components may be omitted, and
C                in such cases are assumed to represent zero values.
C
C                Values for the individual components may exceed the
C                maximum expected values. For instance, '0:0:0:9' is
C                an acceptable Galileo clock string, and indicates the
C                same time interval as '0:0:1:1'.
C
C                Consecutive delimiters containing no intervening digits
C                are treated as if they delimit zero components, except
C                in the case of blanks.  Consecutive blanks are treated
C                as a single blank.
C
C                Trailing zeros should always be included to match the
C                length of the counter.  For example, a Galileo clock
C                count of '25684.90' should not be represented as
C                '25684.9'.
C
C                Some spacecraft clock components have offset, or
C                starting, values different from zero.  For example,
C                with an offset value of 1, a mod 20 counter would
C                cycle from 1 to 20 instead of from 0 to 19.
C
C                See the SCLK required reading for a detailed
C                description of the Galileo, Mars Observer, and Voyager
C                clock formats.
C
C                See the `Examples' section in SCPS01, below.
C
C$ Detailed_Output
C
C     ERROR      is true if an error occurred parsing the input clock
C                string and converting it to ticks.
C
C     MSG        is the message generated if an error occurred parsing
C                the input clock string.
C
C     TICKS      is the number of "ticks" corresponding to the input
C                spacecraft clock string CLKSTR.  "Ticks" are the units
C                in which encoded SCLK strings are represented.
C
C                A typical Galileo SCLK string looks like
C
C                             'wwwwwwww xx y z',
C
C                as described above. Since z is the mod-8 (one tick)
C                counter, the number of ticks represented by y is 8*y.
C                And since y is the mod-10 counter, the number of ticks
C                represented by xx is 10*8*xx. The total number of
C                ticks represented by the above string is
C
C                              wwwwwwww( 7280 ) +
C                                    xx(   80 ) +
C                                     y(    8 ) +
C                                     z
C
C                Clock strings for other spacecraft are converted in
C                a similar manner.
C
C                See Examples below.
C
C$ Parameters
C
C     See the INCLUDE file sclk.inc.
C
C$ Exceptions
C
C     1)  This routine assumes that that an SCLK kernel appropriate
C         to the spacecraft clock identified by the input argument SC
C         has been loaded.  If an SCLK kernel has not been loaded,
C         does not contain all of the required data, or contains
C         invalid data, error diagnoses will be performed by routines
C         called by this routine.  The output argument TICKS will not
C         be modified.
C
C         The variables that must be set by the SCLK kernel are:
C
C            -  The number of fields in an (unabridged) SCLK string
C            -  The output delimiter code
C            -  The parallel time system code
C            -  The moduli of the fields of an SCLK string
C            -  The offsets for each clock field.
C            -  The SCLK coefficients array
C            -  The partition start times
C            -  The partition end times
C
C         When using SCLK kernels that map SCLK to a time system other
C         than ET (also called barycentric dynamical time---`TDB'), it
C         is necessary to have a leapseconds kernel loaded at the time
C         this routine is called.  If a leapseconds kernel is required
C         for conversion between SCLK and ET but is not loaded, the
C         error will be diagnosed by routines called by this routine.
C         The output argument TICKS will not be modified.
C
C         The time system that an SCLK kernel maps SCLK to is indicated
C         by the variable SCLK_TIME_SYSTEM_nn in the kernel, where nn
C         is the negative of the NAIF integer code for the spacecraft.
C         The time system used in a kernel is TDB if and only if the
C         variable is assigned the value 1.
C
C
C     2)  If any of the following kernel variables have invalid values,
C         the error will be diagnosed by routines called by this
C         routine:
C
C            -  The time system code
C            -  The number of SCLK coefficients
C            -  The number of partition start times
C            -  The number of partition end times
C            -  The number of fields of a SCLK string
C            -  The number of moduli for a SCLK string
C
C         If the number of values for any item read from the kernel
C         pool exceeds the maximum allowed value, it is may not be
C         possible to diagnose the error correctly, since overwriting
C         of memory may occur.  This particular type of error is not
C         diagnosed by this routine.
C
C
C     3)  The input argument CLKSTR may be invalid for a variety of
C         reasons:
C
C            -- One of the extracted clock components cannot be parsed
C               as an integer
C
C            -- CLKSTR contains too many components
C
C            -- the value  of one of the components is less than the
C               offset value
C
C         If any of these conditions is detected, the error
C         SPICE(INVALIDSCLKSTRING) is signaled.  The output argument
C         TICKS will not be modified.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine converts a character string representation of a
C     spacecraft clock count into the number of ticks represented
C     by the clock count.  An important distinction between this type
C     of conversion and that carried out by SCENCD is that this routine
C     treats spacecraft clock times as representations of time
C     intervals, not absolute times.
C
C     This routine does not make use of any partition information.
C     See SCENCD for details on how to make use of partition numbers.
C
C$ Examples
C
C     1)  Below are some examples illustrating various inputs and the
C         resulting outputs for the Galileo spacecraft.
C
C         CLKSTR                TICKS
C         ----------------      --------------------
C         '0:0:0:1'             1
C         '0:0:1'               8
C         '0:1'                 80
C         '1'                   7280
C         '1 0 0 0'             7280
C         '1,0,0,0'             7280
C         '1:90'                14480
C         '1:9'                 8000
C         '1:09'                8000
C         '0-0-10'              80   |--  Third component is supposed
C         '0-1-0'               80   |    to be a mod-10 count.
C         '0/1/0'               Error: '/' is not an accepted delimiter.
C         '1: 00 : 0 : 1'       7281
C         '1:::1'               7281
C         '1.1.1.1.1'           Error: Too many components
C         '1.1.1.1.'            Error: The last delimiter signals that
C                                      a fifth component will follow.
C
C
C         The following examples are for the Voyager 2 spacecraft. Note
C         that the last component of the Voyager clock has an offset
C         value of 1.
C
C         CLKSTR                TICKS
C         ----------------      --------------------
C         '0.0.001'             0
C         '0:0:002'             1
C         '0:01'                800
C         '1'                   48000
C         '1.0'                 48000
C         '1.0.0'               Error: The 3rd component is never 0.
C         '0.0:100'             99
C         '0-60-1'              48000
C         '1-1-1'               48800
C         '1-1-2'               48801
C
C
C$ Restrictions
C
C     1)  An SCLK kernel appropriate to the spacecraft clock identified
C         by SC must be loaded at the time this routine is called.
C
C     2)  If the SCLK kernel used with this routine does not map SCLK
C         directly to barycentric dynamical time, a leapseconds kernel
C         must be loaded at the time this routine is called.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman (JPL)
C     J.M. Lynch   (JPL)
C     R.E. Thurman (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 11-FEB-2008 (NJB)
C
C        Global parameters are now declared in the Fortran
C        INCLUDE file sclk.inc.
C
C-    SPICELIB Version 1.0.0, 25-FEB-1993 (JML)
C
C-&

C$ Index_Entries
C
C     convert type_1 spacecraft_clock string to ticks
C
C-&

C
C     SPICELIB functions
C

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               ERRLEN
      PARAMETER           ( ERRLEN =    240 )

      INTEGER               NAMLEN
      PARAMETER           ( NAMLEN =     60 )

      INTEGER               MSGLEN
      PARAMETER           ( MSGLEN =    320 )

      INTEGER               INITSC
      PARAMETER           ( INITSC =      0 )

      DOUBLE PRECISION      INITID
      PARAMETER           ( INITID = -1.D20 )

C
C     Following are parameters for the indices within the
C     array NAMLST of the kernel variable names.
C

      INTEGER               NFLIDX
      PARAMETER           ( NFLIDX = 1 )

      INTEGER               OFFIDX
      PARAMETER           ( OFFIDX = NFLIDX + 1 )

      INTEGER               MODIDX
      PARAMETER           ( MODIDX = OFFIDX + 1 )

      INTEGER               NKITEM
      PARAMETER           ( NKITEM = MODIDX )

C
C     Local variables
C
      CHARACTER*(DPLEN)     CMP    ( MXNFLD )
      CHARACTER*(ERRLEN)    STRERR
      CHARACTER*(NAMLEN)    NAMLST ( NKITEM )

      DOUBLE PRECISION      CMPTKS ( MXNFLD )
      DOUBLE PRECISION      CMPVAL ( MXNFLD )
      DOUBLE PRECISION      MODULI ( MXNFLD )
      DOUBLE PRECISION      OFFSET ( MXNFLD )

      INTEGER               I
      INTEGER               N
      INTEGER               NFIELD
      INTEGER               PNTR

C
C     Save everything
C
      SAVE

      DATA NAMLST / 'SCLK01_N_FIELDS',
     .              'SCLK01_OFFSETS',
     .              'SCLK01_MODULI'        /

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

C
C     Start off with the error flag and message set for a regular
C     SPICE error.
C
      ERROR = .TRUE.
      MSG   = 'SPICELIB error detected.'

C
C     Our first piece of business is to look up all of the data
C     we require from the kernel pool.  We must form the names
C     of the items we want using the input S/C ID code.  The items
C     we need are:
C
C        -  The number of fields in an (unabridged) SCLK string
C        -  The moduli of the fields of an SCLK string
C        -  The offsets for each clock field.
C

      CALL SCLI01 ( NAMLST(NFLIDX), SC, MXNFLD, N, NFIELD )
      CALL SCLD01 ( NAMLST(MODIDX), SC, MXNFLD, N, MODULI )
      CALL SCLD01 ( NAMLST(OFFIDX), SC, MXNFLD, N, OFFSET )

C
C     Don't try to continue if we had a lookup error.
C
      IF ( FAILED() ) THEN
         CALL CHKOUT( 'SCPS01' )
         RETURN
      END IF

C
C     If our clock string is blank, we can stop now.
C
      IF ( CLKSTR .EQ. ' ' ) THEN

         MSG =  'Non partition part of the input clock string is ' //
     .          'blank.'

         ERROR = .TRUE.

         CALL CHKOUT ( 'SCPS01' )
         RETURN

      END IF

C
C     Determine how many ticks is each field is worth.
C
      CMPTKS( NFIELD ) = 1.D0

      DO  I = NFIELD-1, 1, -1
         CMPTKS(I) = CMPTKS(I+1) * MODULI(I+1)
      END DO

C
C     Parse the clock components from the input string. There should
C     be at most NFIELD of them, but, in order to check for too long
C     a clock string, we'll let LPARSM take up to MXNFLD components and
C     then test for an error.
C
      CALL LPARSM ( CLKSTR, DELIMS, MXNFLD, N, CMP )

C
C     If the string has too many fields for the specified spacecraft
C     then signal an error.
C
      IF  ( N .GT. NFIELD )  THEN

         ERROR = .TRUE.

         MSG = 'Input clock string # has # fields; maximum for this ' //
     .         'spacecraft clock is #.'

         CALL REPMC ( MSG, '#', CLKSTR, MSG )
         CALL REPMI ( MSG, '#', N,      MSG )
         CALL REPMI ( MSG, '#', NFIELD, MSG )

         CALL CHKOUT ( 'SCPS01' )
         RETURN

      END IF

C
C     Convert each of the components into numbers.  Error if any
C     of the conversions screw up.
C
      DO I = 1, N

         IF ( CMP(I) .EQ. ' ' )  THEN
            CMPVAL(I) = OFFSET(I)
         ELSE
            CALL NPARSD ( CMP(I), CMPVAL(I), STRERR, PNTR )
         END IF

         IF ( STRERR .NE. ' ' ) THEN

            ERROR = .TRUE.

            MSG = 'Could not parse SCLK component # from ' //
     .            '# as a number.'

            CALL REPMC ( MSG, '#', CMP(I), MSG )
            CALL REPMC ( MSG, '#', CLKSTR, MSG )

            CALL CHKOUT ( 'SCPS01' )
            RETURN

         END IF

C
C        Subtract off the offset value so that we can do base ten
C        arithmetic.  Also, if any of the components become negative
C        as a result of the subtraction, then that component must
C        have been invalid.
C
         CMPVAL(I) = CMPVAL(I) - OFFSET(I)

         IF  ( ANINT( CMPVAL(I) ) .LT. 0.D0  )   THEN

            ERROR = .TRUE.

            MSG = 'Component number #, # in the SCLK string ' //
     .            ' # is invalid.'

            CALL REPMI ( MSG, '#', I,      MSG )
            CALL REPMC ( MSG, '#', CMP(I), MSG )
            CALL REPMC ( MSG, '#', CLKSTR, MSG )

            CALL CHKOUT ( 'SCPS01' )
            RETURN

         END IF

      END DO

C
C     Convert to ticks by multiplying the value of each component by
C     the number of ticks each component count represents, and then
C     add up the results.
C
      TICKS = 0.D0

      DO I = 1, N
         TICKS = TICKS + CMPVAL(I)*CMPTKS(I)
      END DO

      ERROR = .FALSE.

      MSG   = ' '

      CALL CHKOUT ( 'SCPS01' )
      RETURN
      END


*********************************************************************
*  This file contains Navigation routines extracted from a
*  University of Wisconsin "GARTAPE" document.
*
*  Local modifications:
*
*    - In NVXINI, commented out MISVAL DATA statement. Apparently,
*      this is only used with SKEW, which we don't use
*    - Deleted routines MOVB, MOVC, LIT and CLIT which moved bytes
*      from one data type to another. Replaced with EQUIV statments
*      where needed.
*
*    - Made a change in SATVEC to fix problem with some "constants"
*      not being saved.
*
*   Jim Cowie (NPS)   10/93  Originally used on VMS, GEMPAK5.0, moved
*                            to IRIX 4.0, GEMPAK5.1
*   Jim Cowie/COMET    1/95  Renamed some routines to accomadate GVAR
*			     navigation
*
*				NVXINI --> GOSINI
*				NVXSAE --> GOSSAE
*				NVXEAS --> GOSEAS
*				NVXOPT --> GOSOPT
*
*********************************************************************
*                  NAVIGATION SUBROUTINE PACKAGE
*********************************************************************
*     FOLLOWING ARE LISTINGS OF FORTRAN/77 SUBROUTINES AND FUNCTIONS
* THAT PERFORM THE VARIOUS STEPS REQUIRED TO 'NAVIGATE' A SATELLITE
* AREA. IF THESE ROUTINES ARE USED THEY SHOULD BE INSTALLED ON THE
* COMPUTER AS A PACKAGE SINCE THEY SHARE SOME DATA THROUGH COMMON BLOCKS.
* EACH ROUTINE CONTAINS A BRIEF DESCRIPTION OF ITS FUNCTION AND WHAT
* INPUTS ARE REQUIRED.
*     TO NAVIGATE A SATELLITE IMAGE OR AREA, THE PARAMETERS CONTAINED IN
* THE 'NAV ' BLOCK ON THE TAPE MUST BE MOVED TO AN ARRAY CALLED 'IARR'.
* IARR(1) SHOULD CONTAIN 'GOES' IN EBCDIC.
*     THE CALL ISTAT= NVXINI(1,IARR) WILL INITIALIZE THE NAVIGATION
* PACKAGE. IF ISTAT IS RETURNED AS 0, THE INITIALIZATION WAS SUCCESSFUL.
* THIS MUST BE DONE PRIOR TO USING THE ROUTINES IN THE PACKAGE.
*     TO TRANSFORM LINE AND ELEMENT FROM THE SATELLITE AREA TO EARTH
* COORDINATES, USE THE CALL ISTAT= GOSSAE(XLIN,XELE,0.,XLAT,XLON,XDUMMY).
* INPUTS ARE REAL*4 XLIN= SATELLITE LINE NUMBER
*                   XELE= SATELLITE ELEMENT NUMBER
* BOTH INPUTS ARE BASED ON FULL RESOLUTION.
* OUTPUTS ARE REAL*4 XLAT= LATITUDE OF PIXEL
*                    XLON= LONGITUDE OF PIXEL
* NORTH AND WEST ARE POSITIVE.
* THE PARAMETERS, 0. AND XDUMMY, ARE USED IN 3-DIMENSIONAL NAVIGATION.
* IF ISTAT= 0 THE TRANSFORMATION WAS SUCCESSFUL. IF ISTAT= -1 THE
* TRANSFORMATION WAS NOT POSSIBLE (E.G. ARGUMENTS OUT OF RANGE).
*     TO TRANSFORM EARTH COORDINATES (LATITUDE, LONGITUDE) TO SATELLITE
* COORDINATES, CALL ISTAT= GOSEAS(XLAT,XLON,0.,XLIN,XELE,XDUMMY).
* THE ARGUMENTS AND RETURN VALUE ARE THE SAME AS THE ABOVE CALL.
*     NORMALLY, TRANSFORMATIONS ARE MADE TO AND FROM LATITUDE AND
* LONGITUDE. IF THIS IS NOT DESIRED, SUCH AS WITH POINTS NEAR THE POLE,
* EARTH BASED COORDINATES MAY BE CHANGED TO RECTANGULAR COORDINATES
* (X,Y,Z). THESE COORDINATES HAVE THE ORIGIN AT THE EARTH'S CENTER WITH
* THE X-AXIS PASSING THROUGH THE EQUATOR AT 0 DEGREES, THE Y-AXIS PASSING
* THROUGH THE EQUATOR AT 90 DEGREES EAST (-90 DEG.) AND THE Z-AXIS
* PASSING THROUGH THE NORTH POLE.
*     THE CALL ISTAT= NVXINI(2,'XYZ') WILL CAUSE THE ROUTINES GOSSAE AND
* GOSEAS TO PERFORM THE FOLLOWING FUNCTIONS:
* ISTAT= GOSSAE(XLIN,XELE,0.,X,Y,Z)
* WHERE XLIN= SATELLITE LINE NUMBER
*       XELE= SATELLITE ELEMENT NUMBER
*      X,Y,Z ARE THE RECTANGLUAR COORDINATES DESCRIBED ABOVE.
* ISTAT= GOSEAS(X,Y,Z,XLIN,XELE,XDUMMY) ARGUMENTS AS DESCRIBED ABOVE.
* IT IS POSSIBLE TO RETURN TO LATITUDE LONGITUDE COORDINATES WITH THE
* CALL ISTAT= NVXINI(2,'LL').
*
C***********************************************************************

      INTEGER FUNCTION GOSINI(IFUNC,IARR)
C
C THIS ROUTINE SETS UP COMMON BLOCKS NAVCOM AND NAVINI FOR USE BY THE
C NAVIGATION TRANSFORMATION ROUTINES GOSSAE AND GOSEAS.
C NVXINI SHOULD BE RECALLED EVERY TIME A TRANSFORMATION IS DESIRED
C FOR A PICTURE WITH A DIFFERENT TIME THAN THE PREVIOUS CALL.
C IFUNC IS 1 (INITIALIZE; SET UP COMMON BLOCKS)
C          2 (ACCEPT/PRODUCE ALL EARTH COORDINATES IN LAT/LON
C            FORM IF IARR IS 'LL  ' OR IN THE X,Y,Z COORDINATE FRAME
C            IF IARR IS 'XYZ '.
C            THIS AFFECTS ALL SUBSEQUENT GOSEAS OR GOSSAE CALLS.)
C IARR IS AN INTEGER ARRAY (DIM 128) IF IFUNC=1, CONTAINING NAV
C        PARAMETERS
C
      INTEGER IARR(*)
      CHARACTER*2 CLLSW
      COMMON/NAVCOM/NAVDAY,LINTOT,DEGLIN,IELTOT,DEGELE,SPINRA,IETIMY,IET
     1IMH,SEMIMA,OECCEN,ORBINC,PERHEL,ASNODE,NOPCLN,DECLIN,RASCEN,PICLIN
     2,PRERAT,PREDIR,PITCH,YAW,ROLL,SKEW
      COMMON /BETCOM/IAJUST,IBTCON,NEGBET,ISEANG
      COMMON /VASCOM/SCAN1,TIME1,SCAN2,TIME2
      COMMON /NAVINI/
     1  EMEGA,AB,ASQ,BSQ,R,RSQ,
     2  RDPDG,
     3  NUMSEN,TOTLIN,RADLIN,
     4  TOTELE,RADELE,PICELE,
     5  CPITCH,CYAW,CROLL,
     6  PSKEW,
     7  RFACT,ROASIN,TMPSCL,
     8  B11,B12,B13,B21,B22,B23,B31,B32,B33,
     9  GAMMA,GAMDOT,
     A  ROTM11,ROTM13,ROTM21,ROTM23,ROTM31,ROTM33,
     B  PICTIM,XREF
      COMMON /NVUNIT/ LLSW
*      DATA MISVAL/Z80808080/
      DATA JINIT/0/

*** NPS MOD *************************************************
*   added these EQUIV's for replacing calls to MOVWC
*
      CHARACTER*2     CI2CV
      INTEGER*2       I2CV
      EQUIVALENCE  ( CI2CV, I2CV )
      CHARACTER*4     CI4CV
      INTEGER*4       I4CV
      EQUIVALENCE     ( CI4CV, I4CV )
**** END NPS MOD *********************************************
C
      IF (JINIT.EQ.0) THEN
         JINIT=1
         LLSW=0
         JDAYSV=-1
         JTIMSV=-1
      ENDIF
      IF (IFUNC.EQ.2) THEN

**** NPS MOD *******************************************************
*    replaced call to MOVWC using EQUIVed variables

*         CALL MOVWC(IARR,CLLSW)
         I2CV = IARR(1)
         CLLSW = CI2CV
**** END NPS MOD ***************************************************

         IF (CLLSW.EQ.'LL') LLSW=0
         IF (CLLSW.EQ.'XY') LLSW=1
         GOSINI=0
         RETURN
      ENDIF
      JTYPE=IARR(1)

**** NPS MOD **************************************************
*  Replaced call to LIT with EQUIV's
*
*      IF (JTYPE.NE.LIT('GOES')) GOTO 90
      CI4CV = 'GOES'
      IF (JTYPE .NE. I4CV) GOTO 90
**** END NPS MOD ************************************************

      JDAY=IARR(2)
      JTIME=IARR(3)
      IF(JDAY.EQ.JDAYSV.AND.JTIME.EQ.JTIMSV) GO TO 10
C
C-----INITIALIZE NAVCOM
      NAVDAY=MOD(JDAY,100000)
      DO 20 N=7,12
      IF(IARR(N).GT.0) GO TO 25
   20 CONTINUE
      GO TO 90
   25 IETIMY=ICON1(IARR(5))
      IETIMH=100*(IARR(6)/100)+IROUND(.6*MOD(IARR(6),100))
      SEMIMA=FLOAT(IARR(7))/100.0
      OECCEN=FLOAT(IARR(8))/1000000.0
      ORBINC=FLOAT(IARR(9))/1000.0
      XMEANA=FLOAT(IARR(10))/1000.0
      PERHEL=FLOAT(IARR(11))/1000.0
      ASNODE=FLOAT(IARR(12))/1000.0
      CALL EPOCH(IETIMY,IETIMH,SEMIMA,OECCEN,XMEANA)
      IF (IARR(5).EQ.0.OR.IARR(9).EQ.0) GOTO 90
      DECLIN=FLALO(IARR(13))
      RASCEN=FLALO(IARR(14))
      PICLIN=IARR(15)
      IF (IARR(15).GE.1000000) PICLIN=PICLIN/10000.
      IF (IARR(13).EQ.0.AND.IARR(14).EQ.0.AND.IARR(15).EQ.0)
     *   GOTO 90
      SPINRA=IARR(16)/1000.0
      IF(IARR(16).NE.0.AND.SPINRA.LT.300.0) SPINRA=60000.0/SPINRA
      IF (IARR(16).EQ.0) GOTO 90
      DEGLIN=FLALO(IARR(17))
      LINTOT=IARR(18)
      DEGELE=FLALO(IARR(19))
      IELTOT=IARR(20)
      PITCH=FLALO(IARR(21))
      YAW=FLALO(IARR(22))
      ROLL=FLALO(IARR(23))
      SKEW=IARR(29)/100000.0
      IF (IARR(29).EQ.MISVAL) SKEW=0.
C
C-----INITIALIZE BETCOM
      IAJUST=IARR(25)
      ISEANG=IARR(28)
      IBTCON=6289920
      NEGBET=3144960
C
C-----INITIALIZE NAVINI COMMON BLOCK
      EMEGA=.26251617
      AB=40546851.22
      ASQ=40683833.48
      BSQ=40410330.18
      R=6371.221
      RSQ=R*R
      RDPDG=1.745329252E-02
      NUMSEN=MOD(LINTOT/100000,100)
      IF(NUMSEN.LT.1)NUMSEN=1
      TOTLIN=NUMSEN*MOD(LINTOT,100000)
      RADLIN=RDPDG*DEGLIN/(TOTLIN-1.0)
      TOTELE=IELTOT
      RADELE=RDPDG*DEGELE/(TOTELE-1.0)
      PICELE=(1.0+TOTELE)/2.0
      CPITCH=RDPDG*PITCH
      CYAW=RDPDG*YAW
      CROLL=RDPDG*ROLL
      PSKEW=ATAN2(SKEW,RADLIN/RADELE)
      STP=SIN(CPITCH)
      CTP=COS(CPITCH)
      STY=SIN(CYAW-PSKEW)
      CTY =COS(CYAW-PSKEW)
      STR=SIN(CROLL)
      CTR=COS(CROLL)
      ROTM11=CTR*CTP
      ROTM13=STY*STR*CTP+CTY*STP
      ROTM21=-STR
      ROTM23=STY*CTR
      ROTM31=(-CTR)*STP
      ROTM33=CTY*CTP-STY*STR*STP
      RFACT=ROTM31**2+ROTM33**2
      ROASIN=ATAN2(ROTM31,ROTM33)
      TMPSCL=SPINRA/3600000.0
      DEC=DECLIN*RDPDG
      SINDEC=SIN(DEC)
      COSDEC=COS(DEC)
      RAS=RASCEN*RDPDG
      SINRAS=SIN(RAS)
      COSRAS=COS(RAS)
      B11=-SINRAS
      B12=COSRAS
      B13=0.0
      B21=(-SINDEC)*COSRAS
      B22=(-SINDEC)*SINRAS
      B23=COSDEC
      B31=COSDEC*COSRAS
      B32=COSDEC*SINRAS
      B33=SINDEC
      XREF=RAERAC(NAVDAY,0,0.0)*RDPDG
C
C-----TIME-SPECIFIC PARAMETERS (INCL GAMMA)
      PICTIM=FLALO(JTIME)
      GAMMA=FLOAT(IARR(39))/100.
      GAMDOT=FLOAT(IARR(40))/100.
C
C-----INITIALIZE VASCOM
      IF (JDAY/100000.GT.25.AND.IARR(31).GT.0) THEN
C        THIS SECTION DOES VAS BIRDS
C        IT USES TIMES AND SCAN LINE FROM BETA RECORDS
         SCAN1=FLOAT(IARR(31))
         TIME1=FLALO(IARR(32))
         SCAN2=FLOAT(IARR(35))
         TIME2=FLALO(IARR(36))
      ELSE
C        THIS SECTION DOES THE OLD GOES BIRDS
         SCAN1=1.
         TIME1=FLALO(JTIME)
         SCAN2=FLOAT(MOD(LINTOT,100000))
         TIME2=TIME1+SCAN2*TMPSCL
      ENDIF
C
C-----ALL DONE. EVERYTHING OK
 10   CONTINUE
      JDAYSV=JDAY
      JTIMSV=JTIME
      GOSINI=0
      RETURN
 90   GOSINI=-1
      RETURN
      END
C ********************************************************************
C
      INTEGER FUNCTION GOSSAE(XLIN,XELE,XDUM,XPAR,YPAR,ZPAR)
C TRANSFORMS SAT COOR TO EARTH COOR.
C ALL PARAMETERS REAL*4
C INPUTS:
C XLIN,XELE ARE SATELLITE LINE AND ELEMENT (IMAGE COORDS.)
C XDUM IS DUMMY (IGNORE)
C OUTPUTS:
C XPAR,YPAR,ZPAR REPRESENT EITHER LAT,LON,(DUMMY) OR X,Y,Z DEPENDING
C ON THE OPTION SET IN PRIOR NVXINI CALL WITH IFUNC=2.
C FUNC VAL IS 0 (OK) OR -1 (CAN'T; E.G. OFF OF EARTH)
C
      COMMON/NAVCOM/NAVDAY,LINTOT,DEGLIN,IELTOT,DEGELE,SPINRA,IETIMY,IET
     1IMH,SEMIMA,OECCEN,ORBINC,PERHEL,ASNODE,NOPCLN,DECLIN,RASCEN,PICLIN
     2,PRERAT,PREDIR,PITCH,YAW,ROLL,SKEW
      COMMON/NAVINI/
     1  EMEGA,AB,ASQ,BSQ,R,RSQ,
     2  RDPDG,
     3  NUMSEN,TOTLIN,RADLIN,
     4  TOTELE,RADELE,PICELE,
     5  CPITCH,CYAW,CROLL,
     6  PSKEW,
     7  RFACT,ROASIN,TMPSCL,
     8  B11,B12,B13,B21,B22,B23,B31,B32,B33,
     9  GAMMA,GAMDOT,
     A  ROTM11,ROTM13,ROTM21,ROTM23,ROTM31,ROTM33,
     B  PICTIM,XREF
      COMMON /NVUNIT/ LLSW
      DATA PI/3.14159265/
C
      ILIN=IROUND(XLIN)
      PARLIN=(ILIN-1)/NUMSEN+1
      FRAMET=TMPSCL*PARLIN
      SAMTIM=FRAMET+PICTIM
      CALL SATVEC(SAMTIM,XSAT,YSAT,ZSAT)
      YLIN=(XLIN-PICLIN)*RADLIN
      YELE=(XELE-PICELE+GAMMA+GAMDOT*SAMTIM)*RADELE
      XCOR=B11*XSAT+B12*YSAT+B13*ZSAT
      YCOR=B21*XSAT+B22*YSAT+B23*ZSAT
      ROT=ATAN2(YCOR,XCOR)+PI
      YELE=YELE-ROT
      COSLIN=COS(YLIN )
      SINLIN=SIN(YLIN)
      SINELE=SIN(YELE)
      COSELE=COS(YELE)
      ELI=ROTM11*COSLIN-ROTM13*SINLIN
      EMI=ROTM21*COSLIN-ROTM23*SINLIN
      ENI=ROTM31*COSLIN-ROTM33*SINLIN
      TEMP=ELI
      ELI=COSELE*ELI+SINELE*EMI
      EMI=(-SINELE)*TEMP+COSELE*EMI
      ELO=B11*ELI+B21*EMI+B31*ENI
      EMO=B12*ELI+B22*EMI+B32*ENI
      ENO=B13*ELI+B23*EMI+B33*ENI
      BASQ=BSQ/ASQ
      ONEMSQ=1.0-BASQ
      AQ=BASQ+ONEMSQ*ENO**2
      BQ=2.0*((ELO*XSAT+EMO*YSAT)*BASQ+ENO*ZSAT)
      CQ=(XSAT**2+YSAT**2)*BASQ+ZSAT**2-BSQ
      RAD=BQ**2-4.0*AQ*CQ
      IF(RAD.LT.1.0)GO TO 2
      S=(-(BQ+SQRT(RAD)))/(2.0*AQ)
      X=XSAT+ELO*S
      Y=YSAT+EMO*S
      Z=ZSAT+ENO*S
      CT=COS(EMEGA*SAMTIM+XREF)
      ST=SIN(EMEGA*SAMTIM+XREF)
      X1=CT*X+ST*Y
      Y1=(-ST)*X+CT*Y
      IF (LLSW.EQ.0) THEN
         CALL NXYZLL(X1,Y1,Z,XPAR,YPAR)
         ZPAR=0.
      ELSE
         XPAR=X1
         YPAR=Y1
         ZPAR=Z
      ENDIF
      GOSSAE=0
      RETURN
    2 GOSSAE=-1
      RETURN
      END
C ********************************************************************
C
      INTEGER FUNCTION GOSEAS(XPAR,YPAR,ZPAR,XLIN,XELE,XDUM)
C 5/26/82;  TRANSFORM EARTH TO SATELLITE COORDS
C ALL PARAMETERS REAL*4
C INPUTS:
C XPAR,YPAR,ZPAR REPRESENT EITHER LAT,LON,(DUMMY) OR X,Y,Z DEPENDING
C ON THE OPTION SET IN PRIOR NVXINI CALL WITH IFUNC=2.
C OUTPUTS:
C XLIN,XELE ARE SATELLITE LINE AND ELEMENT (IMAGE COORDS.)
C XDUM IS DUMMY (IGNORE)
C FUNC VAL IS 0 (OK) OR -1 (CAN'T; E.G. BAD LAT/LON)
C
      COMMON/NAVINI/
     1  EMEGA,AB,ASQ,BSQ,R,RSQ,
     2  RDPDG,
     3  NUMSEN,TOTLIN,RADLIN,
     4  TOTELE,RADELE,PICELE,
     5  CPITCH,CYAW,CROLL,
     6  PSKEW,
     7  RFACT,ROASIN,TMPSCL,
     8  B11,B12,B13,B21,B22,B23,B31,B32,B33,
     9  GAMMA,GAMDOT,
     A  ROTM11,ROTM13,ROTM21,ROTM23,ROTM31,ROTM33,
     B  PICTIM,XREF
      COMMON/NAVCOM/NAVDAY,LINTOT,DEGLIN,IELTOT,DEGELE,SPINRA,IETIMY,IET
     1IMH,SEMIMA,OECCEN,ORBINC,PERHEL,ASNODE,NOPCLN,DECLIN,RASCEN,PICLIN
     2,PRERAT,PREDIR,PITCH,YAW,ROLL,SKEW
      COMMON/VASCOM/SCAN1,TIME1,SCAN2,TIME2
      COMMON /NVUNIT/ LLSW
      DATA OLDLIN/910./,ORBTIM/-99999./
C
      GOSEAS=0
      IF (LLSW.EQ.0) THEN
         IF (ABS(XPAR).GT.90.) THEN
            GOSEAS=-1
            RETURN
         ENDIF
         CALL NLLXYZ(XPAR,YPAR,X1,Y1,Z)
      ELSE
         X1=XPAR
         Y1=YPAR
         Z=ZPAR
      ENDIF
      XDUM=0.0
      SAMTIM=TIME1
      DO 50 I=1,2
      IF(ABS(SAMTIM-ORBTIM).LT.0.0005) GO TO 10
      CALL SATVEC(SAMTIM,XSAT,YSAT,ZSAT)
      ORBTIM=SAMTIM
      XHT=SQRT(XSAT**2+YSAT**2+ZSAT**2)
   10 CT=COS(EMEGA*SAMTIM+XREF)
      ST=SIN(EMEGA*SAMTIM+XREF)
      X=CT*X1-ST*Y1
      Y= ST*X1+CT*Y1
      VCSTE1=X-XSAT
      VCSTE2=Y-YSAT
      VCSTE3=Z-ZSAT
      VCSES3=B31*VCSTE1+B32*VCSTE2+B33*VCSTE3
      ZNORM=SQRT(VCSTE1**2+VCSTE2**2+VCSTE3**2)
      X3=VCSES3/ZNORM
      UMV=ATAN2(X3,SQRT(RFACT-X3**2))-ROASIN
      XLIN=PICLIN-UMV/RADLIN
      PARLIN=IFIX(XLIN-1.0)/NUMSEN
      IF(I.EQ.2) GO TO 50
      SAMTIM=TIME2
      OLDLIN=XLIN
   50 CONTINUE
      SCNNUM=(IFIX(OLDLIN+XLIN)/2.0-1.0)/8.0
      SCNFRC=(SCNNUM-SCAN1)/(SCAN2-SCAN1)
      XLIN=OLDLIN+SCNFRC*(XLIN-OLDLIN)
      SAMTIM=TIME1+TMPSCL*(SCNNUM-SCAN1)
      CALL SATVEC(SAMTIM,XSAT,YSAT,ZSAT)
      COSA=X*XSAT+Y*YSAT+Z*ZSAT
      CTST=0.0001*R*XHT+RSQ
      IF(COSA.LT.CTST) GOSEAS=-1
      XSATS1=B11*XSAT+B12*YSAT+B13*ZSAT
      YSATS2=B21*XSAT+B22*YSAT+B23*ZSAT
      CT=COS(EMEGA*SAMTIM+XREF)
      ST=SIN(EMEGA*SAMTIM+XREF)
      X=CT*X1-ST*Y1
      Y= ST*X1+CT*Y1
      VCSTE1=X-XSAT
      VCSTE2=Y-YSAT
      VCSTE3=Z-ZSAT
      VCSES1=B11*VCSTE1+B12*VCSTE2+B13*VCSTE3
      VCSES2=B21*VCSTE1+B22*VCSTE2+B23*VCSTE3
      VCSES3=B31*VCSTE1+B32*VCSTE2+B33*VCSTE3
      XNORM=SQRT(ZNORM**2-VCSES3**2)
      YNORM=SQRT(XSATS1**2+YSATS2**2)
      ZNORM=SQRT(VCSTE1**2+VCSTE2**2+VCSTE3**2)
      X3=VCSES3/ZNORM
      UMV=ATAN2(X3,SQRT(RFACT-X3**2))-ROASIN
      SLIN=SIN(UMV)
      CLIN=COS(UMV)
      U=ROTM11*CLIN+ROTM13*SLIN
      V=ROTM21*CLIN+ROTM23*SLIN
      XELE=PICELE+ASIN((XSATS1*VCSES2-YSATS2*VCSES1)/(XNORM*YNORM))/RADE
     1LE
      XELE=XELE+ATAN2(V,U)/RADELE
      XELE=XELE-GAMMA-GAMDOT*SAMTIM
      RETURN
      END
C
C
C
	INTEGER FUNCTION GOSOPT(IFUNC,XIN,XOUT)
C************************************************************************
C* GOSOPT								*
C*									*
C* INTEGER GOSOPT(IFUNC,XIN,XOUT)					*
C*									*
C* Input parameters:                                                    *
C*	 IFUNC	INTEGER	'SPOS'    SUBSATELLITE LAT/LON			*
C*                                                                      *
C* Output parameters:                                                   *
C*       XIN(*) 	REAL	NOT USED				*
C*       XOUT(2) 	REAL	1. SUB-SATELLITE LATITUDE		*
C*		        2. SUB-SATELLITE LONGITUDE			*
C**									*
C* Log:									*
C*									*
C************************************************************************
      REAL*4 XIN(*),XOUT(2)
      CHARACTER*4 CFUNC
*********************************************************
*  replaced call to CLIT with EQUIV's
*
      CHARACTER*4    CI4CV
      INTEGER*4       I4CV
      EQUIVALENCE   ( I4CV, CI4CV )
      I4CV  =  IFUNC
      CFUNC =  CI4CV
********************************************************************
      GOSOPT=0
      IF(CFUNC.EQ.'SPOS') THEN
         CALL SATPOS(0,ITIMC(PICTIM),X,Y,Z)
         CALL NXYZLL(X,Y,Z,XOUT(1),XOUT(2))
      ELSE
         GOSOPT=1
      ENDIF
      RETURN
      END
C ********************************************************************
C
      SUBROUTINE SATPOS(INORB,NTIME,X,Y,Z)
C $ CALCULATE SATELLITE POSITION VECTOR FROM THE EARTH'S CENTER.
C $ INORB = (I) INPUT  INITIALIZATION FLAG - SHOULD = 0 ON FIRST CALL TO
C $   SATPOS, 1 ON ALL SUBSEQUENT CALLS.
C $ NTIME = (I) INPUT  TIME (HOURS, MINUTES, SECONDS) IN HHMMSS FORMAT
C $ X, Y, Z = (R) OUTPUT  COORDINATES OF POSITION VECTOR
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 DEGLIN,DEGELE,SPINRA,SEMIMA,OECCEN,ORBINC,PERHEL
      REAL*4 ASNODE,DECLIN,RASCEN,PICLIN,PRERAT,PREDIR,PITCH,YAW
      REAL*4 ROLL,SKEW
      REAL*4 X,Y,Z
CCC     REAL*8 PI,RDPDG,RE,GRACON,SOLSID,SHA
CCC     REAL*8 DIFTIM,ECANM1,ECANOM,RA,XMANOM,TIMDIF
CCC     REAL*8 DABS,DMOD,DSQRT,DSIN,DCOS,DATAN2
      COMMON/NAVCOM/NAVDAY,LINTOT,DEGLIN,IELTOT,DEGELE,SPINRA,IETIMY,IET
     1IMH,SEMIMA,OECCEN,ORBINC,PERHEL,ASNODE,NOPCLN,DECLIN,RASCEN,PICLIN
     2,PRERAT,PREDIR,PITCH,YAW,ROLL,SKEW
C
      IF(INORB.NE.0)GO TO 1
      INORB=1
      PI=3.14159265D0
      RDPDG=PI/180.0
      RE=6378.388
      GRACON=.07436574D0
      SOLSID=1.00273791D0
      SHA=100.26467D0
      SHA=RDPDG*SHA
      IRAYD=74001
      IRAHMS=0
      O=RDPDG*ORBINC
      P=RDPDG*PERHEL
      A=RDPDG*ASNODE
      SO=SIN(O)
      CO=COS(O)
      SP=SIN(P)*SEMIMA
      CP=COS(P)*SEMIMA
      SA=SIN(A)
      CA=COS(A)
      PX=CP*CA-SP*SA*CO
      PY=CP*SA+SP*CA*CO
      PZ=SP*SO
      QX=(-SP)*CA-CP*SA*CO
      QY=(-SP)*SA+CP*CA*CO
      QZ=CP*SO
      SROME2=SQRT(1.0-OECCEN)*SQRT(1.0+OECCEN)
      XMMC=GRACON*RE*DSQRT(RE/SEMIMA)/SEMIMA
 1    DIFTIM=TIMDIF(IETIMY,IETIMH,NAVDAY,NTIME)
      XMANOM=XMMC*DIFTIM
      ECANM1=XMANOM
      EPSILN=1.0E-8
      DO 2 I=1,20
      ECANOM=XMANOM+OECCEN*DSIN(ECANM1)
      IF(DABS(ECANOM-ECANM1).LT.EPSILN)GO TO 3
 2    ECANM1=ECANOM
 3    XOMEGA=DCOS(ECANOM)-OECCEN
      YOMEGA=SROME2*DSIN(ECANOM)
      XS=XOMEGA*PX+YOMEGA*QX
      YS=XOMEGA*PY+YOMEGA*QY
      ZS=XOMEGA*PZ+YOMEGA*QZ
      DIFTIM=TIMDIF(IRAYD,IRAHMS,NAVDAY,NTIME)
      RA=DIFTIM*SOLSID*PI/720.0D0+SHA
      RAS=DMOD(RA,2.0*PI)
      CRA=COS(RAS)
      SRA=SIN(RAS)
      X=CRA*XS+SRA*YS
      Y=(-SRA)*XS+CRA*YS
      Z=ZS
      RETURN
      END
C ********************************************************************
C    FROM THIS POINT ON THE ROUTINES INCLUDED ARE MCIDAS SUBROUTINES
C THAT ARE CALLED BY THE NAVIGATION ROUTINES TO PERFORM SPECIFIC LOW
C LEVEL TASKS. THEY ARE ALL WRITTEN IN FORTRAN/77 EXCEPT MOVB WHICH IS
C IN IBM ASSEMBLER. THE FORTRAN ROUTINES CAN BE COMPILED ALONG WITH THE
C ROUTINES ABOVE. THE ASSEMBLER ROUTINE MUST EITHER BE ASSEMBLED OR
C REWRITTEN IN FORTRAN. THE REWRITING IS NOT RECOMMENDED.
C ********************************************************************
C
      FUNCTION ICON1(YYMMDD)
C     CONVERTS YYMMDD TO YYDDD
      IMPLICIT INTEGER(A-Z)
      DIMENSION NUM(12)
      DATA NUM/0,31,59,90,120,151,181,212,243,273,304,334/
C
      YEAR=MOD(YYMMDD/10000,100)
      MONTH=MOD(YYMMDD/100,100)
      DAY=MOD(YYMMDD,100)
      IF(MONTH.LT.0.OR.MONTH.GT.12)MONTH=1
      JULDAY=DAY+NUM(MONTH)
      IF(MOD(YEAR,4).EQ.0.AND.MONTH.GT.2) JULDAY=JULDAY+1
      ICON1=1000*YEAR+JULDAY
      RETURN
      END
C ********************************************************************
C
      SUBROUTINE EPOCH(IETIMY,IETIMH,SEMIMA,OECCEN,XMEANA)
C EPOCH  PHILLI 0173 NAV: FINDS TIME OF PERIGEE FROM KEPLERIAN EPOCH
      PARAMETER (PI=3.14159265)
      PARAMETER (RDPDG=PI/180.0)
      PARAMETER (RE=6378.388)
      PARAMETER (GRACON=0.07436574)
      LEAPYR(IY)=366-(MOD(IY,4)+3)/4
C
      XMMC=GRACON*SQRT(RE/SEMIMA)**3
      XMANOM=RDPDG*XMEANA
      TIME=(XMANOM-OECCEN*SIN(XMANOM))/(60.0*XMMC)
      TIME1=FLALO(IETIMH)
      TIME=TIME1-TIME
      IDAY=0
      IF(TIME.GT.48.0)GO TO 8
      IF(TIME.GT.24.0)GO TO 1
      IF(TIME.LT.-24.0)GO TO 2
      IF(TIME.LT.0.0)GO TO 3
      GO TO 4
 8    TIME=TIME-48.0
      IDAY=2
      GO TO 4
 1    TIME=TIME-24.0
      IDAY=1
      GO TO 4
 2    TIME=TIME+48.0
      IDAY=-2
      GO TO 4
 3    TIME=TIME+24.0
      IDAY=-1
 4    IETIMH=ITIMC(TIME)
      IF(IDAY.EQ.0)RETURN
      JYEAR=MOD(IETIMY/1000,100)
      JDAY=MOD(IETIMY,1000)
      JDAY=JDAY+IDAY
      IF(JDAY.LT.1)GO TO 5
      JTOT=LEAPYR(JYEAR)
      IF(JDAY.GT.JTOT)GO TO 6
      GO TO 7
 5    JYEAR=JYEAR-1
      JDAY=LEAPYR(JYEAR)+JDAY
      GO TO 7
 6    JYEAR=JYEAR+1
      JDAY=JDAY-JTOT
 7    IETIMY=1000*JYEAR+JDAY
      RETURN
      END
C ********************************************************************
C
      FUNCTION RAERAC(IYRDY,IHMS,RAE)
C RAERAC PHILLI 0174 NAV: CONVERTS EARTH LON TO CELESTIAL LON
C INPUT PARAMETERS
C     IYRDY = YEAR AND JULIAN DAY (INTEGER YYDDD)
C     IHMS = TIME (INTEGER HHMMSS)
C     RAE = EARTH LONGITUDE (REAL*4 DEGREES)
C FUNCTION VALUE IS CELESTIAL LONGITUDE IN REAL*4 DEGREES
C REF: ESCOBAL, "METHODS OF ORBIT DETERMINATION." WILEY & SONS, 1965
C GREENWICH SIDEREAL TIME := ANGLE BETWEEN PRIME MERID. & 0 DEG R.A.
C JULIAN DATE := # DAYS ELAPSED SINCE 12 NOON ON JAN 1, 4713 B.C.
C APPROXIMATE FORMULA FOR GREENWICH SIDEREAL TIME AT 0Z:
C G.S.T (DEG) = S(0) = 99.6909833 + 36000.7689*C + 0.00038708*C*C ,WHERE
C    C = TIME IN CENTURIES = (J.D. - 2415020.0) / 36525
C FOR G.S.T. AT OTHER TIMES OF (SAME) DAY, USE:
C G.S.T AT TIME T = S(T) = S(0) + (T * DS/DT)
C DS/DT = 1 + (1 / 365.24219879) = 1.00273790927 REVOLUTIONS/DAY
C       = 0.250684477 DEGREES/MINUTE
C FROM TABLE, J.D. AT 0Z ON JAN 1,1974 = 2442048.5
C THEN S(0) AT 0Z ON JAN 1,1974 = 100.2601800
C
      DOUBLE PRECISION TIMDIF,RAHA,SOLSID,SHA
      SHA=100.26467D0
      IRAYD=74001
      IRAHMS=0
      SOLSID=1.00273791D0
      RAHA=RAE+TIMDIF(IRAYD,IRAHMS,IYRDY,IHMS)*SOLSID/4.0D0+SHA
      RAC=DMOD(RAHA,360.0D0)
      IF(RAC.LT.0.0)RAC=RAC+360.0
      RAERAC=RAC
      RETURN
      END
C ********************************************************************
C
      FUNCTION RACRAE(IYRDY,IHMS,RAC)
C RACRAE PHILLI 0174 NAV: CONVERTS CELESTIAL ONG TO EARTH LON
C INPUT PARAMETERS--
C     IYRDY = YEAR AND JULIAN DAY (INTEGER YYDDD)
C     IHMS = TIME (INTEGER HHMMSS)
C     RAC = CELESTIAL LONGITUDE (REAL*4 DEGREES)
C FUNCTION VALUE IS EARTH LONGITUDE IN REAL*4 DEGREES
C
      DOUBLE PRECISION TIMDIF,RAHA,SOLSID,SHA
      SHA=100.26467D0
      IRAYD=74001
      IRAHMS=0
      SOLSID=1.00273791D0
      RAHA=RAC-SHA+TIMDIF(IYRDY,IHMS,IRAYD,IRAHMS)*SOLSID/4.0D0
      RAE=DMOD(RAHA,360.0D0)
      IF(RAE.LT.0.0)RAE=RAE+360.0
      RACRAE=RAE
      RETURN
      END
C ********************************************************************
C
C VECTOR EARTH-CENTER-TO-SAT (FUNC OF TIME)
      SUBROUTINE SATVEC(SAMTIM,X,Y,Z)
      DOUBLE PRECISION TWOPI,PI720,DE,TE,DRA,TRA,DNAV,TDIFRA,TDIFE
      DOUBLE PRECISION PI,RDPDG,RE,GRACON,SOLSID,SHA
      DOUBLE PRECISION DIFTIM,ECANM1,ECANOM,XMANOM
      DOUBLE PRECISION DABS,DSQRT,DSIN,DCOS
      COMMON/NAVCOM/NAVDAY,LINTOT,DEGLIN,IELTOT,DEGELE,SPINRA,IETIMY,IET
     1IMH,SEMIMA,OECCEN,ORBINC,PERHEL,ASNODE,NOPCLN,DECLIN,RASCEN,PICLIN
     2,PRERAT,PREDIR,PITCH,YAW,ROLL,SKEW
      DATA NAVSAV/0/
C
C NPS MOD
C
C commented this next statement out to force the evaluation of the
C variables which follow (up to statement label 10) because some
C of the values (xmmc in particular) were not being saved across
C invocations of this routine. (Should a separate common be used?.)
C
*      IF(NAVDAY.EQ.NAVSAV) GO TO 10
C
C end NPS MOD
C
      NAVSAV=NAVDAY
      PI=3.14159265D0
      TWOPI=2.0*PI
      PI720=PI/720.
      RDPDG=PI/180.0
      RE=6378.388
      GRACON=.07436574D0
      SOLSID=1.00273791D0
      SHA=100.26467D0
      SHA=RDPDG*SHA
      IRAYD=74001
      IRAHMS=0
      O=RDPDG*ORBINC
      P=RDPDG*PERHEL
      A=RDPDG*ASNODE
      SO=SIN(O)
      CO=COS(O)
      SP=SIN(P)*SEMIMA
      CP=COS(P)*SEMIMA
      SA=SIN(A)
      CA=COS(A)
      PX=CP*CA-SP*SA*CO
      PY=CP*SA+SP*CA*CO
      PZ=SP*SO
      QX=(-SP)*CA-CP*SA*CO
      QY=(-SP)*SA+CP*CA*CO
      QZ=CP*SO
      SROME2=SQRT(1.0-OECCEN)*SQRT(1.0+OECCEN)
      XMMC=GRACON*RE*DSQRT(RE/SEMIMA)/SEMIMA
      IEY=MOD(IETIMY/1000,100)
      IED=MOD(IETIMY,1000)
      IEFAC=(IEY-1)/4+1
      DE=365*(IEY-1)+IEFAC+IED-1
      TE=1440.0*DE+60.0*FLALO(IETIMH)
      IRAY=IRAYD/1000
      IRAD=MOD(IRAYD,1000)
      IRAFAC=(IRAY-1)/4+1
      DRA=365*(IRAY-1)+IRAFAC+IRAD-1
      TRA=1440.0*DRA+60.0*FLALO(IRAHMS)
      INAVY=MOD(NAVDAY/1000,100)
      INAVD=MOD(NAVDAY,1000)
      INFAC=(INAVY-1)/4+1
      DNAV=365*(INAVY-1)+INFAC+INAVD-1
      TDIFE=DNAV*1440.-TE
      TDIFRA=DNAV*1440.-TRA
      EPSILN=1.0E-8
   10 TIMSAM=SAMTIM*60.0
      DIFTIM=TDIFE+TIMSAM
      XMANOM=XMMC*DIFTIM
      ECANM1=XMANOM
      DO 2 I=1,20
      ECANOM=XMANOM+OECCEN*DSIN(ECANM1)
      IF(DABS(ECANOM-ECANM1).LT.EPSILN)GO TO 3
 2    ECANM1=ECANOM
 3    XOMEGA=DCOS(ECANOM)-OECCEN
      YOMEGA=SROME2*DSIN(ECANOM)
      Z =XOMEGA*PZ+YOMEGA*QZ
      Y =XOMEGA*PY+YOMEGA*QY
      X =XOMEGA*PX+YOMEGA*QX
      RETURN
      END
C ********************************************************************
C
      SUBROUTINE NLLXYZ(XLAT,XLON,X,Y,Z)
C-----CONVERT LAT,LON TO EARTH CENTERED X,Y,Z
C     (DALY, 1978)
C-----XLAT,XLON ARE IN DEGREES, WITH NORTH AND WEST POSITIVE
C-----X,Y,Z ARE GIVEN IN KM. THEY ARE THE COORDINATES IN A RECTANGULAR
C        FRAME WITH ORIGIN AT THE EARTH CENTER, WHOSE POSITIVE
C        X-AXIS PIERCES THE EQUATOR AT LON 0 DEG, WHOSE POSITIVE Y-AXIS
C        PIERCES THE EQUATOR AT LON 90 DEG, AND WHOSE POSITIVE Z-AXIS
C        INTERSECTS THE NORTH POLE.
      DATA ASQ/40683833.48/,BSQ/40410330.18/,AB/40546851.22/
      DATA RDPDG/1.7453292E-02/
      YLAT=RDPDG*XLAT
C-----CONVERT TO GEOCENTRIC (SPHERICAL) LATITUDE
      YLAT=ATAN2(BSQ*SIN(YLAT),ASQ*COS(YLAT))
      YLON=(-RDPDG)*XLON
      SNLT=SIN(YLAT)
      CSLT=COS(YLAT)
      CSLN=COS(YLON)
      SNLN=SIN(YLON)
      TNLT=(SNLT/CSLT)**2
      R=AB*SQRT((1.0+TNLT)/(BSQ+ASQ*TNLT))
      X=R*CSLT*CSLN
      Y=R*CSLT*SNLN
      Z=R*SNLT
      RETURN
      END
C ********************************************************************
C
      SUBROUTINE NXYZLL(X,Y,Z,XLAT,XLON)
C-----CONVERT EARTH-CENTERED X,Y,Z TO LAT & LON
C-----X,Y,Z ARE GIVEN IN KM. THEY ARE THE COORDINATES IN A RECTANGULAR
C        COORDINATE SYSTEM WITH ORIGIN AT THE EARTH CENTER, WHOSE POS.
C        X-AXIS PIERCES THE EQUATOR AT LON 0 DEG, WHOSE POSITIVE Y-AXIS
C        PIERCES THE EQUATOR AT LON 90 DEG, AND WHOSE POSITIVE Z-AXIS
C        INTERSECTS THE NORTH POLE.
C-----XLAT,XLON ARE IN DEGREES, WITH NORTH AND WEST POSITIVE
      DATA RDPDG/1.745329252E-2/
      DATA ASQ/40683833.48/,BSQ/40410330.18/
C
      XLAT=100.0
      XLON=200.0
      IF(X.EQ.0..AND.Y.EQ.0..AND.Z.EQ.0.) GO TO 90
      A=ATAN(Z/SQRT(X*X+Y*Y))
C-----CONVERT TO GEODETIC LATITUDE
      XLAT=ATAN2(ASQ*SIN(A),BSQ*COS(A))/RDPDG
      XLON=(-ATAN2(Y,X))/RDPDG
   90 RETURN
      END


!
! Copyright (c) Stanford University, The Regents of the University of
!               California, and others.
!
! All Rights Reserved.
!
! See Copyright-SimVascular.txt for additional details.
!
! 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.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!-----------------------------------------------------------------------
!
!     This module defines data structures for ten Tusscher-Panfilov
!     epicardial cellular activation model for cardiac electrophysiology
!
!-----------------------------------------------------------------------

      MODULE TTPMOD
      IMPLICIT NONE

      CONTAINS
!-----------------------------------------------------------------------
      SUBROUTINE TTP_INIT(imyo, nX, nG, X, Xg, X0, Xg0)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: imyo, nX, nG
      REAL(KINd=8), INTENT(OUT) :: X(nX), Xg(nG)
      REAL(KIND=8), INTENT(IN), OPTIONAL :: X0(nX), Xg0(nG)

      SELECT CASE (imyo)
      CASE (1) ! EPI !
!        Initialize state variables
         X(1)   = -85.23D0      ! V      (units: mV)
         X(2)   =  136.89D0     ! K_i    (units: mM)
         X(3)   =  8.6040D0     ! Na_i   (units: mM)
         X(4)   =  1.26D-4      ! Ca_i   (units: mM)
         X(5)   =  3.6D-4       ! Ca_ss  (units: mM)
         X(6)   =  3.64D0       ! Ca_sr  (units: mM)
         X(7)   =  9.073D-1     ! R'     (dimensionless)

!        Initialize gating variables
         Xg(1)  =  6.21D-3      ! x_r1   (dimensionless)
         Xg(2)  =  4.712D-1     ! x_r2   (dimensionless)
         Xg(3)  =  9.5D-3       ! x_s    (dimensionless)
         Xg(4)  =  1.72D-3      ! m      (dimensionless)
         Xg(5)  =  7.444D-1     ! h      (dimensionless)
         Xg(6)  =  7.045D-1     ! j      (dimensionless)
         Xg(7)  =  3.373D-5     ! d      (dimensionless)
         Xg(8)  =  7.888D-1     ! f      (dimensionless)
         Xg(9)  =  9.755D-1     ! f_2    (dimensionless)
         Xg(10) =  9.953D-1     ! f_cass (dimensionless)
         Xg(11) =  9.99998D-1   ! s      (dimensionless)
         Xg(12) =  2.42D-8      ! r      (dimensionless)

      CASE (2) ! ENDO !
!        Initialize state variables
         X(1)   = -86.709D0     ! V      (units: mV)
         X(2)   =  138.4D0      ! K_i    (units: mM)
         X(3)   =  10.355D0     ! Na_i   (units: mM)
         X(4)   =  1.30D-4      ! Ca_i   (units: mM)
         X(5)   =  3.6D-4       ! Ca_ss  (units: mM)
         X(6)   =  3.715D0      ! Ca_sr  (units: mM)
         X(7)   =  9.068D-1     ! R'     (dimensionless)

!        Initialize gating variables
         Xg(1)  =  4.48D-3      ! x_r1   (dimensionless)
         Xg(2)  =  4.76D-1      ! x_r2   (dimensionless)
         Xg(3)  =  8.7D-3       ! x_s    (dimensionless)
         Xg(4)  =  1.55D-3      ! m      (dimensionless)
         Xg(5)  =  7.573D-1     ! h      (dimensionless)
         Xg(6)  =  7.225D-1     ! j      (dimensionless)
         Xg(7)  =  3.164D-5     ! d      (dimensionless)
         Xg(8)  =  8.009D-1     ! f      (dimensionless)
         Xg(9)  =  9.778D-1     ! f_2    (dimensionless)
         Xg(10) =  9.953D-1     ! f_cass (dimensionless)
         Xg(11) =  3.212D-1     ! s      (dimensionless)
         Xg(12) =  2.235D-8     ! r      (dimensionless)

      CASE (3) ! MID-MYO !
!        Initialize state variables
         X(1)   = -85.423D0     ! V      (units: mV)
         X(2)   =  138.52D0     ! K_i    (units: mM)
         X(3)   =  10.132D0     ! Na_i   (units: mM)
         X(4)   =  1.53D-4      ! Ca_i   (units: mM)
         X(5)   =  4.2D-4       ! Ca_ss  (units: mM)
         X(6)   =  4.272D0      ! Ca_sr  (units: mM)
         X(7)   =  8.978D-1     ! R'     (dimensionless)

!        Initialize gating variables
         Xg(1)  =  1.65D-2      ! x_r1   (dimensionless)
         Xg(2)  =  4.730D-1     ! x_r2   (dimensionless)
         Xg(3)  =  1.74D-2      ! x_s    (dimensionless)
         Xg(4)  =  1.65D-3      ! m      (dimensionless)
         Xg(5)  =  7.490D-1     ! h      (dimensionless)
         Xg(6)  =  6.788D-1     ! j      (dimensionless)
         Xg(7)  =  3.288D-5     ! d      (dimensionless)
         Xg(8)  =  7.026D-1     ! f      (dimensionless)
         Xg(9)  =  9.526D-1     ! f_2    (dimensionless)
         Xg(10) =  9.942D-1     ! f_cass (dimensionless)
         Xg(11) =  9.99998D-1   ! s      (dimensionless)
         Xg(12) =  2.347D-8     ! r      (dimensionless)

      END SELECT

      IF (PRESENT(X0)) THEN
         IF (SIZE(X0,1) .NE. nX) THEN
            STOP "ERROR: inconsistent array size (TTP initialization)"
         END IF
         X(:)  = X0(:)
      END IF

      IF (PRESENT(Xg0)) THEN
         IF (SIZE(Xg0,1) .NE. nG) THEN
            STOP "ERROR: inconsistent array size (TTP initialization)"
         END IF
         Xg(:) = Xg0(:)
      END IF

      RETURN
      END SUBROUTINE TTP_INIT
!-----------------------------------------------------------------------
!     Time integration performed using Forward Euler method
      SUBROUTINE TTP_INTEGFE(imyo, nX, nG, X, Xg, Ts, dt, Istim, Ksac,
     2   RPAR)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: imyo, nX, nG
      REAL(KIND=8), INTENT(INOUT) :: X(nX), Xg(nG), RPAR(18)
      REAL(KIND=8), INTENT(IN) :: Ts, dt, Istim, Ksac

      REAL(KIND=8) :: f(nX)

!     Get time derivatives (RHS)
      CALL TTP_GETF(imyo, nX, nG, X, Xg, f, Istim, Ksac, RPAR)

!     Update gating variables
      CALL TTP_UPDATEG(imyo, dt, nX, nG, X, Xg)

!     Update state variables
      X = X + dt*f(:)

      RETURN
      END SUBROUTINE TTP_INTEGFE
!-----------------------------------------------------------------------
!     Time integration performed using 4th order Runge-Kutta method
      SUBROUTINE TTP_INTEGRK(imyo, nX, nG, X, Xg, Ts, dt, Istim, Ksac,
     2   RPAR)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: imyo, nX, nG
      REAL(KIND=8), INTENT(INOUT) :: X(nX), Xg(nG), RPAR(18)
      REAL(KIND=8), INTENT(IN) :: Ts, dt, Istim, Ksac

      REAL(KIND=8) :: dt6, Xrk(nX), Xgr(nG), frk(nX,4)

      dt6 = dt/6.0D0

!     RK4: 1st pass
      Xrk = X
      CALL TTP_GETF(imyo, nX, nG, Xrk, Xg, frk(:,1), Istim, Ksac,
     2   RPAR)

!     Update gating variables by half-dt
      Xgr = Xg
      CALL TTP_UPDATEG(imyo, 0.5D0*dt, nX, nG, X, Xgr)

!     RK4: 2nd pass
      Xrk = X + 0.5D0*dt*frk(:,1)
      CALL TTP_GETF(imyo, nX, nG, Xrk, Xgr, frk(:,2), Istim, Ksac,
     2   RPAR)

!     RK4: 3rd pass
      Xrk = X + 0.5D0*dt*frk(:,2)
      CALL TTP_GETF(imyo, nX, nG, Xrk, Xgr, frk(:,3), Istim, Ksac,
     2   RPAR)

!     Update gating variables by full-dt
      Xgr = Xg
      CALL TTP_UPDATEG(imyo, dt, nX, nG, X, Xgr)

!     RK4: 4th pass
      Xrk = X + dt*frk(:,3)
      CALL TTP_GETF(imyo, nX, nG, Xrk, Xgr, frk(:,4), Istim, Ksac,
     2   RPAR)

      X = X + dt6*(frk(:,1) + 2.0D0*(frk(:,2) + frk(:,3)) + frk(:,4))
      Xg = Xgr

      RETURN
      END SUBROUTINE TTP_INTEGRK
!-----------------------------------------------------------------------
!     Compute currents and time derivatives of state variables
      SUBROUTINE TTP_GETF(i, nX, nG, X, Xg, dX, I_stim, K_sac, RPAR)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: i, nX, nG
      REAL(KIND=8), INTENT(IN) :: X(nX), Xg(nG), I_stim, K_sac
      REAL(KIND=8), INTENT(OUT) :: dX(nX)
      REAL(KIND=8), INTENT(INOUT) :: RPAR(18)

      INCLUDE "PARAMS_TTP.f"

      REAL(KIND=8) :: RT, a, b, tau, sq5, e1, e2, e3, e4, n1, n2, d1,
     2   d2, d3, I_sac

!     Local copies of state variables
      V     = X(1)
      K_i   = X(2)
      Na_i  = X(3)
      Ca_i  = X(4)
      Ca_ss = X(5)
      Ca_sr = X(6)
      R_bar = X(7)

!     Local copies of gating variables
      xr1   = Xg(1)
      xr2   = Xg(2)
      xs    = Xg(3)
      m     = Xg(4)
      h     = Xg(5)
      j     = Xg(6)
      d     = Xg(7)
      f     = Xg(8)
      f2    = Xg(9)
      fcass = Xg(10)
      s     = Xg(11)
      r     = Xg(12)

!     Stretch-activated currents
      I_sac = K_sac * (Vrest - V)

!      Diff = 1.0D0 / (1.0D1 * rho * Cm * sV)
      RT   = Rc * Tc / Fc
      E_K  = RT * LOG(K_o/K_i)
      E_Na = RT * LOG(Na_o/Na_i)
      E_Ca = 0.5D0 * RT * LOG(Ca_o/Ca_i)
      E_Ks = RT * LOG( (K_o + p_KNa*Na_o)/(K_i + p_KNa*Na_i) )

!     I_Na: Fast sodium current
      I_Na = G_Na * (m**3.0D0) * h * j * (V - E_Na)

!     I_to: transient outward current
      I_to = G_to(i) * r * s * (V - E_K)

!     I_K1: inward rectifier outward current
      e1   = EXP(0.06D0*(V - E_K - 200.0D0))
      e2   = EXP(2.0D-4*(V - E_K + 100.0D0))
      e3   = EXP(0.1D0*(V - E_K - 10.0D0))
      e4   = EXP(-0.5D0*(V - E_K))
      a    = 0.1D0/(1.0D0 + e1)
      b    = (3.0D0*e2 + e3) / (1.0D0 + e4)
      tau  = a / (a + b)
      sq5  = SQRT(K_o/5.4D0)
      I_K1 = G_K1 * sq5 * tau * (V - E_K)

!     I_Kr: rapid delayed rectifier current
      I_Kr = G_Kr * sq5 * xr1 * xr2 * (V - E_K)

!     I_Ks: slow delayed rectifier current
      I_Ks = G_Ks(i) * (xs**2.0D0) * (V - E_Ks)

!     I_CaL: L-type Ca current
      a     = 2.0D0*(V-15.0D0)/RT
      b     = 2.0D0*a*Fc * (0.25D0*Ca_ss*EXP(a) - Ca_o) / (EXP(a)-1.0D0)
      I_CaL = G_CaL * d * f * f2 * fcass * b

!     I_NaCa: Na-Ca exchanger current
      e1     = EXP(gamma*V/RT)
      e2     = EXP((gamma-1.0D0)*V/RT)
      n1     = e1*(Na_i**3.0D0)*Ca_o - e2*(Na_o**3.0D0)*Ca_i*alpha
      d1     = K_mNai**3.0D0 + Na_o**3.0D0
      d2     = K_mCa + Ca_o
      d3     = 1.0D0 + K_sat*e2
      I_NaCa = K_NaCa * n1 / (d1*d2*d3)

!     I_NaK: Na-K pump current
      e1    = EXP(-0.1D0*V/RT)
      e2    = EXP(-V/RT)
      n1    = P_NaK * K_o * Na_i
      d1    = K_o + K_mK
      d2    = Na_i + K_mNa
      d3    = 1.0D0 + 0.1245D0*e1 + 0.0353D0*e2
      I_NaK = n1 / (d1*d2*d3)

!     I_pCa: plateau Ca current
      I_pCa = G_pCa * Ca_i / (K_pCa + Ca_i)

!     I_pK: plateau K current
      I_pK  = G_pK * (V-E_K) / (1.0D0 + EXP((25.0D0-V)/5.98D0))

!     I_bCa: background Ca current
      I_bCa = G_bCa * (V - E_Ca)

!     I_bNa: background Na current
      I_bNa = G_bNa * (V - E_Na)

!     I_leak: Sacroplasmic Reticulum Ca leak current
      I_leak = V_leak * (Ca_sr - Ca_i)

!     I_up: Sacroplasmic Reticulum Ca pump current
      I_up  = Vmax_up / (1.0D0 + (K_up/Ca_i)**2.0D0)

!     I_rel: Ca induced Ca current (CICR)
      k_casr = max_sr - ((max_sr-min_sr)/(1.0D0 + (EC/Ca_sr)**2.0D0) )
      k1     = k1p / k_casr
      O      = k1 * R_bar * (Ca_ss**2.0D0) / (k3 + k1*(Ca_ss**2.0D0))
      I_rel  = V_rel * O * (Ca_sr - Ca_ss)

!     I_xfer: diffusive Ca current between Ca subspae and cytoplasm
      I_xfer = V_xfer * (Ca_ss - Ca_i)

!-----------------------------------------------------------------------
!     Now compute time derivatives
!     dV/dt: rate of change of transmembrane voltage
      dX(1)  = -(I_Na + I_to + I_K1 + I_Kr + I_Ks + I_CaL + I_NaCa +
     2   I_NaK + I_pCa + I_pK + I_bCa + I_bNa  + I_stim) + I_sac

!     dK_i/dt
      dX(2)  = -(Cm/(V_c*Fc)) * (I_K1 + I_to + I_Kr + I_Ks + I_pK -
     2   2D0*I_NaK + I_stim)

!     dNa_i/dt
      dX(3)  = -(Cm/(V_c*Fc)) * (I_Na + I_bNa + 3.0D0*(I_NaK + I_NaCa))

!     dCa_i/dt
      n1     = (I_leak - I_up)*V_sr/V_c + I_xfer
      n2     = -(Cm/(V_c*Fc)) * (I_bCa + I_pCa - 2.0D0*I_Naca) /2.0D0
      d1     = 1.0D0 + K_bufc*Buf_c/(Ca_i + K_bufc)**2.0D0
      dX(4)  = (n1 + n2)/d1

!     dCa_ss: rate of change of Ca_ss
      n1     = (-I_CaL*Cm/(2.0D0*Fc) + I_rel*V_sr - V_c*I_xfer) / V_ss
      d1     = 1.0D0 + K_bufss*Buf_ss/(Ca_ss + K_bufss)**2.0D0
      dX(5)  = n1 / d1

!     dCa_sr: rate of change of Ca_sr
      n1     = I_up - I_leak - I_rel
      d1     = 1.0D0 + K_bufsr*Buf_sr/(Ca_sr + K_bufsr)**2.0D0
      dX(6)  = n1 / d1

!     Rbar: ryanodine receptor
      k2     = k2p * k_casr
      dX(7)  = -k2*Ca_ss*R_bar + k4*(1.0D0 - R_bar)

!     Quantities to be written to file
      RPAR(3)  = I_Na
      RPAR(4)  = I_K1
      RPAR(5)  = I_to
      RPAR(6)  = I_Kr
      RPAR(7)  = I_Ks
      RPAR(8)  = I_CaL
      RPAR(9)  = I_NaCa
      RPAR(10) = I_NaK
      RPAR(11) = I_pCa
      RPAR(12) = I_pK
      RPAR(13) = I_bCa
      RPAR(14) = I_bNa
      RPAR(15) = I_leak
      RPAR(16) = I_up
      RPAR(17) = I_rel
      RPAR(18) = I_xfer

      RETURN
      END SUBROUTINE TTP_GETF
!-----------------------------------------------------------------------
!     Update all the gating variables
      SUBROUTINE TTP_UPDATEG(i, dt, n, nG, X, Xg)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: i, n, nG
      REAL(KIND=8), INTENT(IN) :: dt, X(n)
      REAL(KIND=8), INTENT(INOUT) :: Xg(nG)

      INCLUDE "PARAMS_TTP.f"

      REAL(KIND=8) :: a, b, c, tau

      V     = X(1)
      Ca_ss = X(5)

      xr1   = Xg(1)
      xr2   = Xg(2)
      xs    = Xg(3)
      m     = Xg(4)
      h     = Xg(5)
      j     = Xg(6)
      d     = Xg(7)
      f     = Xg(8)
      f2    = Xg(9)
      fcass = Xg(10)
      s     = Xg(11)
      r     = Xg(12)

!     xr1: activation gate for I_Kr
      xr1i   = 1.0D0/(1.0D0 + EXP(-(26.0D0+V)/7.0D0))
      a      = 450.0D0/(1.0D0 + EXP(-(45.0D0+V)/10.0D0))
      b      = 6.0D0/(1.0D0 + EXP((30.0D0+V)/11.5D0))
      tau    = a*b
      Xg(1)  = xr1i - (xr1i - xr1)*EXP(-dt/tau)

!     xr2: inactivation gate for I_Kr
      xr2i   = 1.0D0 /(1.0D0 + EXP((88.0D0+V)/24.0D0))
      a      = 3.0D0 /(1.0D0 + EXP(-(60.0D0+V)/20.0D0))
      b      = 1.12D0/(1.0D0 + EXP(-(60.0D0-V)/20.0D0))
      tau    = a*b
      Xg(2)  = xr2i - (xr2i - xr2)*EXP(-dt/tau)

!     xs: activation gate for I_Ks
      xsi    = 1.0D0/(1.0D0 + EXP(-(5.0D0+V)/14.0D0))
      a      = 1400.0D0/SQRT(1.0D0 + EXP((5.0D0-V)/6.0D0))
      b      = 1.0D0/(1D0 + EXP((V-35.0D0)/15.0D0))
      tau    = a*b + 80.0D0
      Xg(3)  = xsi - (xsi - xs)*EXP(-dt/tau)

!     m: activation gate for I_Na
      mi     = 1.0D0/( (1.0D0 + EXP(-(56.86D0+V)/9.03D0))**2.0D0 )
      a      = 1.0D0/(1.0D0 + EXP(-(60.0D0+V)/5.0D0))
      b      = 0.1D0/(1.0D0 + EXP((35.0D0+V)/5.0D0))
     2       + 0.1D0/(1.0D0 + EXP((V-50.0D0)/200.0D0))
      tau    = a*b
      Xg(4)  = mi - (mi - m)*EXP(-dt/tau)

!     h: fast inactivation gate for I_Na
      hi     = 1.0D0/( (1.0D0 + EXP((71.55D0+V)/7.43D0))**2.0D0 )
      IF (V .GE. -40.0D0) THEN
         a   = 0.0D0
         b   = 0.77D0/(0.13D0*(1.0D0 + EXP(-(10.66D0+V)/11.1D0)))
      ELSE
         a   = 5.7D-2*EXP(-(80.0D0+V)/6.8D0)
         b   = 2.7D0*EXP(0.079D0*V) + 310000.0D0*EXP(0.3485D0*V)
      END IF
      tau    = 1.0D0 / (a + b)
      Xg(5)  = hi - (hi - h)*EXP(-dt/tau)

!     j: slow inactivation gate for I_Na
      ji     = 1.0D0/( (1.0D0 + EXP((71.55D0+V)/7.43D0))**2.0D0 )
      IF (V .GE. -40.0D0) THEN
         a   = 0.0D0
         b   = 6D-1*EXP(5.7D-2*V)/(1.0D0 + EXP(-0.1D0*(V+32.0D0)))
      ELSE
         a   = -(25428.0D0*EXP(0.2444D0*V) + 6.948D-6*EXP(-0.04391D0*V))
     2       * (V+37.78D0) / (1.0D0 + EXP(0.311D0*(79.23D0+V)))
         b   = 0.02424D0*EXP(-0.01052D0*V) /
     2         (1.0D0 + EXP(-0.1378D0*(40.14D0+V)))
      END IF
      tau    = 1.0D0 / (a + b)
      Xg(6)  = ji - (ji - j)*EXP(-dt/tau)

!     d: activation gate for I_CaL
      di     = 1.0D0/(1.0D0 + EXP(-(8.0D0+V)/7.5D0))
      a      = 1.4D0/(1.0D0 + EXP(-(35.0D0+V)/13.0D0)) + 0.25D0
      b      = 1.4D0/(1.0D0 + EXP((5.0D0+V)/5.0D0))
      c      = 1.0D0/(1.0D0 + EXP((50.0D0-V)/20.0D0))
      tau    = a*b + c
      Xg(7)  = di - (di - d)*EXP(-dt/tau)

!     f: slow inactivation gate for I_CaL
      fi     = 1.0D0/(1.0D0 + EXP((20.0D0+V)/7.0D0))
      a      = 1102.5D0*EXP(-((V+27.0D0)**2.0D0)/225.0D0)
      b      = 200.0D0/(1.0D0 + EXP((13.0D0-V)/10.0D0))
      c      = 180.0D0/(1.0D0 + EXP((30.0D0+V)/10.0D0)) + 20.0D0
      tau    = a + b + c
c!     for spiral wave breakup
c      IF (V .GT. 0D0) tau = tau*2.0D0
      Xg(8)  = fi - (fi - f)*EXP(-dt/tau)

!     f2: fast inactivation gate for I_CaL
      f2i    = 0.67D0/(1.0D0 + EXP((35.0D0+V)/7.0D0)) + 0.33D0
      a      = 562.0D0*EXP(-((27.0D0+V)**2.0D0) /240.0D0)
      b      = 31.0D0/(1.0D0 + EXP((25.0D0-V)/10.0D0))
      c      = 80.0D0/(1.0D0 + EXP((30.0D0+V)/10.0D0))
      tau    = a + b + c
      Xg(9)  = f2i - (f2i - f2)*EXP(-dt/tau)

!     fCass: inactivation gate for I_CaL into subspace
      c      = 1.0D0/(1.0D0 + (Ca_ss/0.05D0)**2.0D0)
      fcassi = 0.6D0*c  + 0.4D0
      tau    = 80.0D0*c + 2.0D0
      Xg(10) = fcassi - (fcassi - fcass)*EXP(-dt/tau)

!     s: inactivation gate for I_to
      IF (i.EQ.1 .OR. i.EQ.3) THEN
         si  = 1.0D0/(1.0D0 + EXP((20.0D0+V)/5.0D0))
         tau = 85.0D0*EXP(-((V+45.0D0)**2.0D0) /320.0D0)
     2       + 5.0D0/(1.0D0+EXP((V-20.0D0)/5.0D0)) + 3.0D0
      ELSE IF (i .EQ. 2) THEN
         si  = 1.0D0/(1.0D0 + EXP((28.0D0+V)/5.0D0))
         tau = 1000.0D0*EXP(-((V+67.0D0)**2.0D0) /1000.0D0) + 8.0D0
      END IF
      Xg(11) = si - (si - s)*EXP(-dt/tau)

!     r: activation gate for I_to
      ri     = 1.0D0/(1.0D0 + EXP((20.0D0-V)/6.0D0))
      tau    = 9.5D0*EXP(-((V+40.0D0)**2.0D0) /1800.0D0) + 0.8D0
      Xg(12) = ri - (ri - r)*EXP(-dt/tau)

      RETURN
      END SUBROUTINE TTP_UPDATEG
!-----------------------------------------------------------------------
!     Time integration performed using Crank-Nicholson method
      SUBROUTINE TTP_INTEGCN2(imyo, nX, nG, Xn, Xg, Ts, dt, Istim,
     2   Ksac, IPAR, RPAR)
      USE MATFUN
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: imyo, nX, nG
      INTEGER, INTENT(INOUT) :: IPAR(2)
      REAL(KIND=8), INTENT(INOUT) :: Xn(nX), Xg(nG), RPAR(18)
      REAL(KIND=8), INTENT(IN) :: Ts, dt, Istim, Ksac

      REAL(KIND=8), PARAMETER :: eps = EPSILON(eps)

      INTEGER :: i, k, itMax
      LOGICAL :: l1, l2, l3
      REAL(KIND=8) :: t, atol, rtol, Xk(nX), fn(nX), fk(nX), rK(nX),
     2   Im(nX,nX), JAC(nX,nX), rmsA, rmsR

      itMax = IPAR(1)
      atol  = RPAR(1)
      rtol  = RPAR(2)

      Im = MAT_ID(nX)
      CALL TTP_GETF(imyo, nX, nG, Xn, Xg, fn, Istim, Ksac, RPAR)

      k  = 0
      Xk = Xn
      l1 = .FALSE.
      l2 = .FALSE.
      l3 = .FALSE.
      t  = Ts + dt
      DO
         k = k + 1

         CALL TTP_GETF(imyo, nX, nG, Xk, Xg, fk, Istim, Ksac, RPAR)
         rK(:) = Xk(:) - Xn(:) - 0.5D0*dt*(fk(:) + fn(:))

         rmsA = 0D0
         rmsR = 0D0
         DO i=1, nX
            rmsA = rmsA + rK(i)**2.0D0
            rmsR = rmsR + ( rK(i) / (Xk(i)+eps) )**2.0D0
         END DO
         rmsA = SQRT(rmsA/REAL(nX,KIND=8))
         rmsR = SQRT(rmsR/REAL(nX,KIND=8))

         l1   = k .GT. itMax
         l2   = rmsA .LE. atol
         l3   = rmsR .LE. rtol
         IF (l1 .OR. l2 .OR. l3) EXIT

         CALL TTP_GETJ(imyo, nX, nG, Xk, Xg, JAC, Ksac)
         JAC = Im - 0.5D0*dt*JAC
         JAC = MAT_INV(JAC, nX)
         rK  = MATMUL(JAC, rK)
         Xk  = Xk - rK
      END DO
      Xn(:) = Xk(:)
      CALL TTP_UPDATEG(imyo, dt, nX, nG, Xn, Xg)
      CALL TTP_GETF(imyo, nX, nG, Xn, Xg, fn, Istim, Ksac, RPAR)

      IF (.NOT.l2 .AND. .NOT.l3) IPAR(2) = IPAR(2) + 1

      RETURN
      END SUBROUTINE TTP_INTEGCN2
!-----------------------------------------------------------------------
      SUBROUTINE TTP_GETJ(i, nX, nG, X, Xg, JAC, Ksac)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: i, nX, nG
      REAL(KIND=8), INTENT(IN) :: X(nX), Xg(nG), Ksac
      REAL(KIND=8), INTENT(OUT) :: JAC(nX,nX)

      INCLUDE "PARAMS_TTP.f"

      REAL(KIND=8) :: RT, a, b, c, tau, sq5, e1, e2, e3, e4, n1, n2, d1,
     2   d2, d3

!     Local copies of state variables
      V     = X(1)
      K_i   = X(2)
      Na_i  = X(3)
      Ca_i  = X(4)
      Ca_ss = X(5)
      Ca_sr = X(6)
      R_bar = X(7)

!     Local copies of gating variables
      xr1   = Xg(1)
      xr2   = Xg(2)
      xs    = Xg(3)
      m     = Xg(4)
      h     = Xg(5)
      j     = Xg(6)
      d     = Xg(7)
      f     = Xg(8)
      f2    = Xg(9)
      fcass = Xg(10)
      s     = Xg(11)
      r     = Xg(12)

      RT    = Rc * Tc / Fc
      E_K   = RT * LOG(K_o/K_i)
      E_Na  = RT * LOG(Na_o/Na_i)
      E_Ca  = 0.5D0 * RT * LOG(Ca_o/Ca_i)
      E_Ks  = RT * LOG( (K_o + p_KNa*Na_o)/(K_i + p_KNa*Na_i) )

      E_K_Ki   = -RT / K_i
      E_Na_Nai = -RT / Na_i
      E_Ca_Cai = -RT / Ca_i / 2.0D0
      E_Ks_Ki  = -RT / (K_i + p_KNa*Na_i)
      E_Ks_Nai = p_KNa * E_Ks_Ki

!     I_Na: Fast sodium current
      I_Na = G_Na * (m**3.0D0) * h * j * (V - E_Na)
      I_Na_V   = G_Na * (m**3.0D0) * h * j
      I_Na_Nai = I_Na_V * (-E_Na_Nai)

!     I_to: transient outward current
      I_to = G_to(i) * r * s * (V - E_K)
      I_to_V  = G_to(i) * r * s
      I_to_Ki = I_to_V * (-E_K_Ki)

!     I_K1: inward rectifier outward current
      e1   = EXP(0.06D0*(V - E_K - 200.0D0))
      e2   = EXP(2.0D-4*(V - E_K + 100.0D0))
      e3   = EXP(0.1D0*(V - E_K - 10.0D0))
      e4   = EXP(-0.5D0*(V - E_K))
      a    = 0.1D0/(1.0D0 + e1)
      b    = (3.0D0*e2 + e3) / (1.0D0 + e4)
      tau  = a / (a + b)
      sq5  = SQRT(K_o/5.4D0)
      n1   = -0.006D0*e1/(1.0D0 + e1)**2.0D0
      n2   = (6.0D-4*e2 + 0.1D0*e3 + 0.5D0*b*e4)/(1.0D0 + e4)
      n1   = (a + b)*n1 - a*(n1 + n2)
      d1   = (a + b)**2.0D0
      I_K1 = G_K1 * sq5 * tau * (V - E_K)
      I_K1_V  = G_K1 * sq5 * (tau + (V - E_K)*n1/d1)
      I_K1_Ki = I_K1_V * (-E_K_Ki)

!     I_Kr: rapid delayed rectifier current
      I_Kr = G_Kr * sq5 * xr1 * xr2 * (V - E_K)
      I_Kr_V   = G_Kr * sq5 * xr1 * xr2
      I_Kr_Ki  = I_Kr_V * (-E_K_Ki)

!     I_Ks: slow delayed rectifier current
      I_Ks = G_Ks(i) * (xs**2.0D0) * (V - E_Ks)
      I_Ks_V   = G_Ks(i) * (xs**2.0D0)
      I_Ks_Ki  = I_Ks_V * (-E_Ks_Ki)
      I_Ks_Nai = I_Ks_V * (-E_Ks_Nai)

!     I_CaL: L-type Ca current
      a     = 2.0D0*(V-15.0D0)/RT
      b     = (0.25D0*Ca_ss*EXP(a) - Ca_o) / (EXP(a)-1.0D0)
      c     = G_CaL * d * f * f2 * fcass * (2.0D0*a*Fc)
      n1    = (EXP(a)/RT) / (EXP(a)-1.0D0)
      I_CaL = c * b
      I_CaL_V     = I_CaL/(V-15.0D0) + n1*(c*0.5D0*Ca_ss - 2.0D0*I_CaL)
      I_CaL_Cass  = c * 0.25D0 * n1 * RT

!     I_NaCa: Na-Ca exchanger current
      e1     = EXP(gamma*V/RT)
      e2     = EXP((gamma-1.0D0)*V/RT)
      n1     = e1*(Na_i**3.0D0)*Ca_o - e2*(Na_o**3.0D0)*Ca_i*alpha
      d1     = K_mNai**3.0D0 + Na_o**3.0D0
      d2     = K_mCa + Ca_o
      d3     = 1.0D0 + K_sat*e2
      c      = 1.0D0/(d1*d2*d3)
      I_NaCa = K_NaCa * n1 * c

      n1     = K_NaCa * c * ( e1*(Na_i**3.0D0)*Ca_o*(gamma/RT) -
     2    e2*(Na_o**3.0D0)*Ca_i*alpha*((gamma-1.0D0)/RT) )
      n2     = I_NaCa*K_sat*((gamma-1.0D0)/RT)*e2/d3
      I_NaCa_V   = n1 - n2
      I_NaCa_Nai =  K_NaCa * e1 * (3.0D0*Na_i**2.0D0) * Ca_o * c
      I_NaCa_Cai = -K_NaCa * e2 * (Na_o**3.0D0) * alpha * c

!     I_NaK: Na-K pump current
      e1    = EXP(-0.1D0*V/RT)
      e2    = EXP(-V/RT)
      n1    = P_NaK * K_o * Na_i
      d1    = K_o + K_mK
      d2    = Na_i + K_mNa
      d3    = 1.0D0 + 0.1245D0*e1 + 0.0353D0*e2
      I_NaK = n1 / (d1*d2*d3)
      n1    = (0.01245D0*e1 + 0.0353D0*e2)/RT
      I_NaK_V   = I_NaK * n1 / d3
      I_NaK_Nai = I_NaK * K_mNa/(Na_i*d2)

!     I_pCa: plateau Ca current
      d1 = (K_pCa + Ca_i)
      I_pCa = G_pCa * Ca_i / d1
      I_pCa_Cai = G_pCa * K_pCa/(d1*d1)

!     I_pK: plateau K current
      e1 = EXP((25.0D0-V)/5.98D0)
      I_pK  = G_pK * (V-E_K) / (1.0D0 + e1)
      I_pK_V  = (G_pK + I_pK*e1/5.98D0) / (1.0D0+e1)
      I_pK_Ki = G_pK * (-E_K_Ki) / (1.0D0 + e1)

!     I_bCa: background Ca current
      I_bCa = G_bCa * (V - E_Ca)
      I_bCa_V = G_bCa
      I_bCa_Cai = G_bca * (-E_Ca_Cai)

!     I_bNa: background Na current
      I_bNa = G_bNa * (X(1) - E_Na)
      I_bNa_V = G_bNa
      I_bNa_Nai = G_bNa * (-E_Na_Nai)

!     I_leak: Sacroplasmic Reticulum Ca leak current
      I_leak = V_leak * (Ca_sr - Ca_i)
      I_leak_Cai  = -V_leak
      I_leak_Casr =  V_leak

!     I_up: Sacroplasmic Reticulum Ca pump current
      d1 = 1.0D0 + (K_up/Ca_i)**2.0D0
      I_up  = Vmax_up / d1
      I_up_Cai = (I_up / d1) * (2.0D0*K_up**2.0D0 / Ca_i**3.0D0)

!     I_rel: Ca induced Ca current (CICR)
      n1 = max_sr - min_sr
      d1 = 1.0D0 + (EC/Ca_sr)**2.0D0
      k_casr = max_sr - (n1/d1)
      k1     = k1p / k_casr
      n2     = Ca_ss*2.0D0
      d2     = k3 + k1*n2
      O      = k1 * R_bar * n2 / d2
      I_rel  = V_rel * O * (Ca_sr - Ca_ss)

      k_casr_sr = (n1 / (d1**2.0D0)) * (2.0D0*EC**2.0D0 / Ca_sr**3.0D0)
      k1_casr   = -k1p * k_casr_sr / (k_casr**2.0D0)
      O_Cass = 2.0D0 * k3 * O / (Ca_ss * d2)
      O_Casr = k1_casr * n2 * (R_bar - O) / d2
      O_Rbar = k1 * n2 / d2

      I_rel_Cass = V_rel * (O_Cass*(Ca_sr - Ca_ss) - O)
      I_rel_Casr = V_rel * (O_Casr*(Ca_sr - Ca_ss) + O)
      I_rel_Rbar = V_rel * O_Rbar *(Ca_sr - Ca_ss)

!     I_xfer: diffusive Ca current between Ca subspae and cytoplasm
      I_xfer = V_xfer * (Ca_ss - Ca_i)
      I_xfer_Cai  = -V_xfer
      I_xfer_Cass =  V_xfer

!-----------------------------------------------------------------------
!     Compute Jacobian matrix
      JAC = 0D0
      c   = Cm/(V_c*Fc)

!     V
      JAC(1,1)  = -(I_Na_V + I_to_V + I_K1_V + I_Kr_V + I_Ks_V + I_CaL_V
     2   + I_NaCa_V + I_NaK_V + I_pK_V + I_bCa_V + I_bNa_V + Ksac)
      JAC(1,2)  = -(I_to_Ki + I_K1_Ki + I_Kr_Ki + I_Ks_Ki + I_pK_Ki)
      JAC(1,3)  = -(I_Na_Nai + I_Ks_Nai + I_NaCa_Nai + I_NaK_Nai
     2   + I_bNa_Nai)
      JAC(1,4)  = -(I_NaCa_Cai + I_pCa_Cai + I_bCa_Cai)
      JAC(1,5) = -I_CaL_Cass

!     K_i
      JAC(2,1)  = -c * (I_K1_V + I_to_V + I_Kr_V + I_Ks_V + I_pK_V
     2   - 2D0*I_NaK_V )
      JAC(2,2)  = -c * (I_K1_Ki + I_to_Ki + I_Kr_Ki + I_Ks_Ki + I_pK_Ki)
      JAC(2,3)  = -c * (I_Ks_Nai - 2D0*I_NaK_Nai)

!     Na_i
      JAC(3,1)  = -c * (I_Na_V + I_bNa_V + 3.0D0*(I_NaK_V + I_NaCa_V))
      JAC(3,3)  = -c * (I_Na_Nai + I_bNa_Nai + 3.0D0*(I_NaK_Nai +
     2   I_NaCa_Nai))
      JAC(3,4)  = -c * (3.0D0*I_NaCa_Cai)

!     Ca_i
      n1 = (I_leak - I_up)*V_sr/V_c + I_xfer
     2   - c*(I_bCa + I_pCa - 2.0D0*I_NaCa)/2.0D0
      n2 = (I_leak_Cai - I_up_Cai)*V_sr/V_c + I_xfer_Cai
     2   - c*(I_bCa_Cai + I_pCa_Cai - 2.0D0*I_NaCa_Cai)/2.0D0
      d1 = 1.0D0 + K_bufc*Buf_c/(Ca_i + K_bufc)**2.0D0
      d2 = 2.0D0*K_bufc*Buf_c/(Ca_i + K_bufc)**3.0D0
      JAC(4,1)  = -c * (I_bCa_V - 2.0D0*I_NaCa_V) / 2.0D0 / d1
      JAC(4,3)  = c * I_NaCa_Nai / d1
      JAC(4,4)  = (n2 + n1*d2/d1) / d1
      JAC(4,5) = I_xfer_Cass / d1
      JAC(4,6) = (I_leak_Casr*V_sr/V_c) / d1

!     Ca_ss
      a  = Cm/(2.0D0*Fc*V_ss)
      b  = V_sr / V_ss
      c  = V_c / V_ss
      n1 = -a*I_CaL + b*I_rel - c*I_xfer
      n2 = -a*I_CaL_Cass + b*I_rel_Cass - c*I_xfer_Cass
      d1 = 1.0D0 + K_bufss*Buf_ss/(Ca_ss + K_bufss)**2.0D0
      d2 = 2.0D0*K_bufss*Buf_ss/(Ca_ss + K_bufss)**3.0D0
      JAC(5,1)  = -a * I_CaL_V / d1
      JAC(5,4)  = -c * I_xfer_Cai / d1
      JAC(5,5) = (n2 + n1*d2/d1) / d1
      JAC(5,6) = b * I_rel_Casr / d1
      JAC(5,7) = b * I_rel_Rbar / d1

!     Ca_sr
      n1 = I_up - I_leak - I_rel
      n2 = -(I_leak_Casr + I_rel_Casr)
      d1 = 1.0D0 + K_bufsr*Buf_sr/(Ca_sr + K_bufsr)**2.0D0
      d2 = 2.0D0*K_bufsr*Buf_sr/(Ca_sr + K_bufsr)**3.0D0
      JAC(6,4) = (I_up_Cai - I_leak_Cai) / d1
      JAC(6,5) = -I_rel_Cass / d1
      JAC(6,6) = (n2 + n1*d2/d1) / d1
      JAC(6,7) = -I_rel_Rbar / d1

!     Rbar: ryanodine receptor
      k2 = k2p * k_casr
      JAC(7,5) = -k2 * R_bar
      JAC(7,6) = -(k2p * k_casr_sr) * Ca_ss * R_bar
      JAC(7,7) = -(k2*Ca_ss + k4)

      RETURN
      END SUBROUTINE TTP_GETJ
!-----------------------------------------------------------------------
!     Compute activation force for electromechanics based on active
!     stress model
      SUBROUTINE TTP_ACTVSTRS(c_Ca, dt, Tact, epsX)
      IMPLICIT NONE
      REAL(KIND=8), INTENT(IN) :: c_Ca, dt
      REAL(KIND=8), INTENT(OUT) :: epsX
      REAL(KIND=8), INTENT(INOUT) :: Tact

      INCLUDE "PARAMS_TTP.f"

      REAL(KIND=8) :: nr

      epsX = EXP(-EXP(-xi_T*(c_Ca - Ca_crit)))
      epsX = eps_0 + (eps_i - eps_0)*epsX
      nr   = Tact + epsX*dt*eta_T*(c_Ca - Ca_rest)
      Tact = nr / (1.0D0 + epsX*dt)

      RETURN
      END SUBROUTINE TTP_ACTVSTRS
!-----------------------------------------------------------------------
!     Compute macroscopic fiber strain based on sacromere force-length
!     relationship and calcium concentration
      SUBROUTINE TTP_ACTVSTRN(c_Ca, I4f, dt, gf)
      IMPLICIT NONE
      REAL(KIND=8), INTENT(IN) :: c_Ca, I4f, dt
      REAL(KIND=8), INTENT(INOUT) :: gf

      INCLUDE "PARAMS_TTP.f"

      REAL(KIND=8) :: SL, Fa, rtmp

!     fiber length
      SL = I4f * SL0

!     Sacromere force-length relationship
      IF (SL.GE.SLmin .AND. SL.LE.SLmax) THEN
         SL = 0.5D0*f0 + fc1*COS(SL) + fs1*SIN(SL) +
     2      fc2*COS(2.0D0*SL) + fs2*SIN(2.0D0*SL)  +
     3      fc3*COS(3.0D0*SL) + fs3*SIN(3.0D0*SL)
      ELSE
         SL = 0.0D0
      END IF

!     Active force
      Fa   = alFa * (c_Ca-c_Ca0)*(c_Ca-c_Ca0) * SL

      rtmp = 2.0D0*I4f*(1.0D0/(1.0D0+gf)**3.0D0 - 1.0D0)
      gf = gf + dt*(Fa + rtmp)/(mu_Ca * c_Ca * c_Ca)

      RETURN
      END SUBROUTINE TTP_ACTVSTRN
!-----------------------------------------------------------------------
      END MODULE TTPMOD
!#######################################################################