C$Procedure  HX2DP  ( Hexadecimal string to d.p. number )

      SUBROUTINE HX2DP ( STRING, NUMBER, ERROR, ERRMSG )

C$ Abstract
C
C     Convert a string representing a double precision number in a
C     base 16 ``scientific notation'' into its equivalent double
C     precision number.
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     None.
C
C$ Keywords
C
C     ALPHANUMERIC
C     CONVERSION
C
C$ Declarations
C
      CHARACTER*(*)         STRING
      DOUBLE PRECISION      NUMBER
      LOGICAL               ERROR
      CHARACTER*(*)         ERRMSG
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     STRING     I   String to be converted to double precision.
C     NUMBER     O   Double precision value to be returned.
C     ERROR      O   A logical flag which is .TRUE. on error.
C     ERRMSG     O   A descriptive error message.
C
C$ Detailed_Input
C
C     STRING   A character string containing a base 16 ``scientific
C              notation'' representation of a double precision number
C              which is to be converted to a double precision number,
C              e.g.:
C
C                 '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3 = 672.0
C
C              and
C
C                 '-B^1' = - ( 11/16 ) * 16**1             = -11.0
C
C              The following table describes the character set used to
C              represent the hexadecimal digits and their corresponding
C              values.
C
C              Character     Value         Character     Value
C              ---------    -------        ---------    -------
C                 '0'         0.0D0           '8'         8.0D0
C                 '1'         1.0D0           '9'         9.0D0
C                 '2'         2.0D0         'A','a'      10.0D0
C                 '3'         3.0D0         'B','b'      11.0D0
C                 '4'         4.0D0         'C','c'      12.0D0
C                 '5'         5.0D0         'D','d'      13.0D0
C                 '6'         6.0D0         'E','e'      14.0D0
C                 '7'         7.0D0         'F','f'      15.0D0
C
C              The carat, or hat, character, '^', is used to
C              distinguish the exponent.
C
C              The plus sign, '+', and the minus sign, '-', are used,
C              and they have their usual meanings.
C
C              A base 16 ``scientific notation'' character string which
C              is to be parsed by this routine should consist of a sign,
C              '+' or '-' (the plus sign is optional for nonnegative
C              numbers), followed immediately by a contiguous sequence
C              of hexadecimal digits, the exponent character, and a
C              signed hexadecimal exponent. The exponent is required,
C              but the sign is optional for a nonnegative exponent.
C
C              A number in base 16 ``scientific notation'' consists of
C              a contiguous sequence of characters with one of the
C              following formats:
C
C                  (1)   h h h h  ... h ^H H  ... H
C                         1 2 3 4      n  1 2      m
C
C                  (2)   +h h h h  ... h ^H H  ... H
C                          1 2 3 4      n  1 2      m
C
C                  (3)   -h h h h  ... h ^H H  ... H
C                          1 2 3 4      n  1 2      m
C
C                  (4)    h h h h  ... h ^+H H  ... H
C                          1 2 3 4      n   1 2      m
C
C                  (5)   +h h h h  ... h ^+H H  ... H
C                          1 2 3 4      n   1 2      m
C
C                  (6)   -h h h h  ... h ^+H H  ... H
C                          1 2 3 4      n   1 2      m
C
C                  (7)   h h h h  ... h ^-H H  ... H
C                         1 2 3 4      n   1 2      m
C
C                  (8)   +h h h h  ... h ^-H H  ... H
C                          1 2 3 4      n   1 2      m
C
C                  (9)   -h h h h  ... h ^-H H  ... H
C                          1 2 3 4      n   1 2      m
C
C              where
C
C                 h  and H  denote hexadecimal digits;
C                  i      j
C
C                 ^         denotes exponentiation;
C
C              and
C
C                 + and - have their usual interpretations.
C
C             STRING may have leading and trailing blanks, but blanks
C             embedded within the significant portion of the input
C             string are not allowed.
C
C$ Detailed_Output
C
C     NUMBER   The double precision value to be returned. The value of
C              this argument is not changed if an error occurs while
C              parsing the input string.
C
C     ERROR    A logical flag which indicates whether an error occurred
C              while attempting to parse NUMBER from the input
C              character string STRING. ERROR will have the value
C              .TRUE. if an error occurs. It will have the value
C              .FALSE. otherwise.
C
C     ERRMSG   Contains a descriptive error message if an error
C              occurs while attempting to parse the number NUMBER
C              from the hexadecimal character string STRING, blank
C              otherwise.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)   If an unexpected character is encountered, an appropriate
C          error message will be set, and the routine will exit. The
C          value of NUMBER will be unchanged.
C
C     2)   If the input string represents a number that is larger in
C          absolute magnitude than the maximum representable
C          double precision number an appropriate error message
C          will be set, and the routine will exit. The value of
C          NUMBER will be unchanged.
C
C     3)   If the input string is blank, an appropriate error message
C          will be set, and the routine will exit. The value of
C          NUMBER will be unchanged.
C
C     4)   If the string has too many digits in the mantissa, > MAXMAN,
C          then an appropriate error message will be set, and the
C          routine will exit. The value of NUMBER will be unchanged.
C
C     5)   If the error message string is not long enough to contain
C          the entire error message, the error message will be
C          truncated on the right.
C
C     6)   This routine does NOT check for underflow errors when
C          constructing a double precision number.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine will convert a character string containing a number
C     in base 16 ``scientific notation'' into its equivalent double
C     precision number.
C
C     This routine is one of a pair of routines which are used to
C     perform conversions between double precision numbers and
C     an equivalent base 16 ``scientific notation'' character string
C     representation:
C
C           DP2HX  -- Convert a double precision number into a base 16
C                     ``scientific notation'' character string.
C
C           HX2DP  -- Convert a base 16 ``scientific notation''
C                     character string into a double precision number.
C
C$ Examples
C
C     The following argument values illustrate the action of HX2DP.
C
C     Note: The hat or carat, '^', signals an exponent.
C
C
C         STRING                  NUMBER         ERROR   ERRMSG
C         ----------------------  -------------  ------  ------
C          89705F4136B4A6^-7            2.0D-9   .FALSE.   ' '
C          1^1                          1.0D0    .FALSE.   ' '
C         -1^1                         -1.0D0    .FALSE.   ' '
C          4^3                       1024.0D0    .FALSE.   ' '
C         -4^3                      -1024.0D0    .FALSE.   ' '
C          7F5EB^5                 521707.0D0    .FALSE.   ' '
C          7F5eb^5                 521707.0D0    .FALSE.   ' '
C          7f5eb^5                 521707.0D0    .FALSE.   ' '
C          1B^2                        27.0D0    .FALSE.   ' '
C         +1B^2                        27.0D0    .FALSE.   ' '
C         +1B^+2                       27.0D0    .FALSE.   ' '
C          0^0                          0.0D0    .FALSE.   ' '
C
C          STRING = ' '
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: A blank input string is not allowed.'
C
C          STRING = '-AB238Z^2'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Illegal character ''Z'' encountered.'
C
C          STRING = '234ABC'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Missing exponent.'
C
C          STRING = '234ABC^'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Missing exponent.'
C
C          STRING = '4ABC123AB346523BDC568798C247367^1'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Too many digits in the mantissa.'
C
C          The following examples are machine dependent.
C
C          For a VAX using D_floating arithmetic we get:
C
C          STRING = '23BCE^30'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Number is too large to be represented.'
C
C          STRING = '-2abc3^22'
C          NUMBER = ( Not defined )
C          ERROR  = .TRUE.
C          ERRMSG = 'ERROR: Number is too small to be represented.'
C
C$ Restrictions
C
C     The maximum number of digits in a hexadecimal mantissa is given
C     by the parameter MAXMAN. The current value of MAXMAN is more
C     than sufficient for most double precision implementations,
C     providing almost twice as many digits as can actually be
C     produced. This value may be changed when a greater precision is
C     known to exist among all of the supported platforms.
C
C$ Author_and_Institution
C
C     K.R. Gehringer   (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1994 (KRG)
C
C        Fixed a typo in the description of the input argument STRING.
C        The example showing the expansion of 160 into hexadecimal
C        was incorrect. 160 was replaced with 672 which makes the
C        example correct.
C
C-    SPICELIB Version 1.0.0, 26-OCT-1992 (KRG)
C
C-&

C$ Index_Entries
C
C     convert signed normalized hexadecimal string to d.p.
C     convert encoded d.p. number to d.p. number
C     convert base 16 scientific notation d.p. number
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.0.1, 10-MAR-1994 (KRG)
C
C        Fixed a typo in the description of the input argument STRING.
C        The example showing the expansion of 160 into hexadecimal
C        was incorrect. 160 was replaced with 672 which makes the
C        example correct.
C
C        Old Example:
C
C           '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3 = 160.0
C
C        New Example:
C
C           '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3 = 672.0
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMIN
      DOUBLE PRECISION      DPMAX
C
C     Local Parameters
C
      CHARACTER*(1)         EXPCHR
      PARAMETER           ( EXPCHR = '^' )

      DOUBLE PRECISION      BASE
      PARAMETER           ( BASE = 16.0D0 )

      DOUBLE PRECISION      INVBAS
      PARAMETER           ( INVBAS = 1.0D0/BASE )

      INTEGER               MAXDIG
      PARAMETER           ( MAXDIG = 16 )

      INTEGER               MAXMAN
      PARAMETER           ( MAXMAN = 31 )
C
C     Local variables
C
      DOUBLE PRECISION      DPVAL(0:MAXDIG-1)
      DOUBLE PRECISION      MAXDP
      DOUBLE PRECISION      MINDP
      DOUBLE PRECISION      SCALES(MAXMAN)
      DOUBLE PRECISION      TMPNUM

      INTEGER               DIGBEG
      INTEGER               DIGEND
      INTEGER               I
      INTEGER               IEXPCH
      INTEGER               IEXPON
      INTEGER               IMINUS
      INTEGER               IPLUS
      INTEGER               ISPACE
      INTEGER               IVAL(MAXMAN+1)
      INTEGER               LCCBEG
      INTEGER               LCCEND
      INTEGER               LETTER
      INTEGER               NDIGIT
      INTEGER               POSITN
      INTEGER               STRBEG
      INTEGER               STREND
      INTEGER               UCCBEG
      INTEGER               UCCEND

      LOGICAL               FIRST
      LOGICAL               MORE
      LOGICAL               NEGTIV
      LOGICAL               FNDEXP
C
C     Saved variables
C
      SAVE                  DPVAL
      SAVE                  MAXDP
      SAVE                  MINDP
      SAVE                  SCALES

      SAVE                  DIGBEG
      SAVE                  DIGEND
      SAVE                  IEXPCH
      SAVE                  IMINUS
      SAVE                  IPLUS
      SAVE                  ISPACE
      SAVE                  LCCBEG
      SAVE                  LCCEND
      SAVE                  UCCBEG
      SAVE                  UCCEND

      SAVE                  FIRST
C
C     Initial values
C
      DATA                  DPVAL   /
     .                                 0.0D0,  1.0D0,  2.0D0,  3.0D0,
     .                                 4.0D0,  5.0D0,  6.0D0,  7.0D0,
     .                                 8.0D0,  9.0D0, 10.0D0, 11.0D0,
     .                                12.0D0, 13.0D0, 14.0D0, 15.0D0
     .                              /

      DATA                  FIRST   / .TRUE. /

C
C     Here is a brief outline of the algorithm used to convert the
C     character string into its equivalent double precision number.
C
C        The input hexadecimal string is scanned from left to right.
C
C        0) Any leading white space is skipped.
C
C        1) The length of the significant portion of the string
C           is determined.
C
C        2) The sign of the mantissa is determined.
C
C        3) The digits of the hexadecimal mantissa are parsed.
C
C        4) The exponent of the number is parsed.
C
C        5) The mantissa of the double precision number is generated
C           by summing appropriately scaled values of the hexadecimal
C           mantissa digits which were collected in step 2. The
C           summation is performed so that the summands are added
C           in order of increasing magnitude to eliminate a potential
C           loss of significance which might occur otherwise. This
C           yields a number in the range of 1/BASE and 1.0 or zero.
C
C        6) The double precision number is then scaled by the exponent
C           obtained in step 3.
C
      IF ( FIRST ) THEN
C
C        If this is the first call, set up the array that is used to
C        properly scale each of the hexadecimal digits when summing
C        them to build a double precision number. Right now, the value
C        of MAXMAN, the maximum number of digits in a hexadecimal
C        mantissa, is 31. MAXMAN = 31 is more than sufficient for most
C        current double precision implementations, providing almost
C        twice as many digits as can actually be produced. This value
C        may be changed when a greater precision is known to exist on
C        any of the supported platforms.
C
         FIRST = .FALSE.

         SCALES(1) = INVBAS
         DO I = 2, MAXMAN

            SCALES(I) = INVBAS * SCALES(I-1)

         END DO
C
C        Initialize the upper and lower bounds for the decimal digits,
C        the upper and lower bounds for the uppercase hexadecimal
C        digits, the upper and lower bounds for the lowercase
C        hexadecimal digits, the space, the plus sign, and the minus
C        sign in the character sequence.
C
         DIGBEG = ICHAR( '0' )
         DIGEND = ICHAR( '9' )
         UCCBEG = ICHAR( 'A' )
         UCCEND = ICHAR( 'F' )
         LCCBEG = ICHAR( 'a' )
         LCCEND = ICHAR( 'f' )
         IMINUS = ICHAR( '-' )
         IPLUS  = ICHAR( '+' )
         ISPACE = ICHAR( ' ' )
C
C        Also get the integer value for the exponent character.
C
         IEXPCH = ICHAR( EXPCHR )
C
C        Initialize some boundary values for error checking while
C        constructing the desired double precision number. These
C        are used to help determine whether an overflow condition
C        is imminent due to the overly large magnitude of a positive
C        or negative number.
C
         MINDP = DPMIN() * INVBAS
         MAXDP = DPMAX() * INVBAS

      END IF
C
C     There are no errors initially, so set the error flag to
C     .FALSE.
C
      ERROR = .FALSE.
C
C     If the string is blank, set the error flag and return immediately.
C
      IF ( STRING .EQ. ' ' ) THEN

         ERROR  = .TRUE.
         ERRMSG = 'ERROR: A blank input string is not allowed.'
         RETURN

      END IF
C
C     Initialize a few other things.
C
      ERRMSG = ' '
      TMPNUM = 0.0D0
C
C     Assume that the number is nonnegative.
C
      NEGTIV = .FALSE.
C
C     Skip any leading white space. We know that there is at least
C     one nonblank character at this point, so we will not loop
C     off the end of the string.
C
      STRBEG = 1

      DO WHILE ( ICHAR( STRING(STRBEG:STRBEG ) ) .EQ. ISPACE )

         STRBEG = STRBEG + 1

      END DO
C
C     Now, we want to find the end of the significant portion of
C     the input string and the position of the exponent character.
C
      STREND = STRBEG + 1
      MORE   = .TRUE.

      DO WHILE ( MORE )

         IF ( STREND .LE. LEN( STRING ) ) THEN

            IF ( STRING(STREND:) .NE. ' ' ) THEN

               STREND = STREND + 1

            ELSE

               MORE = .FALSE.

            END IF

         ELSE

            MORE = .FALSE.

         END IF

      END DO
C
C     At this point, STREND is one larger than the length of the
C     significant portion of the string because we incremented
C     its value after the test. We will subtract one from the
C     value of STREND so that it exactly represents the position
C     of the last significant character in the string.
C
      STREND = STREND - 1
C
C     Set the position pointer to the beginning of the significant
C     part, i.e., the nonblank part, of the string, because we are
C     now ready to try and parse the number.
C
      POSITN = STRBEG
C
C     The first character should be either a plus sign, '+', a
C     minus sign, '-', or a digit, '0' - '9', 'A' - 'F', or
C     'a' - 'f'. Anything else is bogus and we will catch it in
C     the main loop below.
C
C     If the character is a minus sign, we want to set the value of
C     NEGTIV to .TRUE. and increment the position.
C
C     If the character is a plus sign, we want to increment the
C     position.
C
      IF ( ICHAR( STRING(POSITN:POSITN) ) .EQ. IMINUS ) THEN

         NEGTIV = .TRUE.
         POSITN = POSITN + 1

      ELSE IF ( ICHAR( STRING(POSITN:POSITN) ) .EQ. IPLUS ) THEN

         POSITN = POSITN + 1

      END IF
C
C     Collect all of the digits in the mantissa, storing them
C     for later conversion. We do this because we want to add
C     the digits of the mantissa in increasing order so that we
C     do not lose any significance.
C
C     A normalized hexadecimal number must have an exponent,
C     which is represented by the hat character, EXPCHR, which
C     s why that test is part of the loop termination.
C
C     We currently have no digits, and we have not found the
C     exponent character yet.
C
      NDIGIT = 0
      FNDEXP = .FALSE.
      DO WHILE ( ( POSITN .LE. STREND ) .AND. ( .NOT. FNDEXP ) )

         LETTER = ICHAR( STRING(POSITN:POSITN) )

         IF ( ( LETTER .GE. DIGBEG ) .AND.
     .        ( LETTER .LE. DIGEND ) ) THEN

            POSITN       = POSITN + 1
            NDIGIT       = NDIGIT + 1
            IVAL(NDIGIT) = LETTER - DIGBEG

         ELSE IF ( ( LETTER .GE. UCCBEG ) .AND.
     .             ( LETTER .LE. UCCEND ) ) THEN

            POSITN       = POSITN + 1
            NDIGIT       = NDIGIT + 1
            IVAL(NDIGIT) = 10 + LETTER - UCCBEG

         ELSE IF ( ( LETTER .GE. LCCBEG ) .AND.
     .             ( LETTER .LE. LCCEND ) ) THEN

            POSITN       = POSITN + 1
            NDIGIT       = NDIGIT + 1
           IVAL(NDIGIT) = 10 + LETTER - LCCBEG

         ELSE IF ( LETTER .EQ. IEXPCH ) THEN
C
C           We have found the exponent character, so set the
C           indicator and increment the position.
C
            FNDEXP = .TRUE.
            POSITN = POSITN + 1

         ELSE

            ERROR  = .TRUE.
            ERRMSG = 'ERROR: Illegal character ''#'' encountered.'
            CALL REPMC( ERRMSG, '#', CHAR( LETTER ), ERRMSG )
            RETURN

         END IF
C
C        We need to make sure that the number of mantissa digits
C        remains less than or equal to the number of mantissa
C        digits that we declared, see the MAXMAN parameter.
C
         IF ( NDIGIT .GT. MAXMAN ) THEN

            ERROR  = .TRUE.
            ERRMSG = 'ERROR: Too many digits in the mantissa.'
            RETURN

         END IF

      END DO
C
C     At this point, we have found an exponent character, and:
C
C        1) We are beyond the end of the significant portion of the
C           string, which is an error: no exponent digits were found.
C
C        2) We are positioned on the first digit of the exponent,
C           and are ready to try and parse it.
C
      IF ( POSITN .LE. STREND ) THEN
C
C        If there is at least one significant character left in the
C        string, we need to try and parse it as an exponent.
C
         CALL HX2INT( STRING(POSITN:), IEXPON, ERROR, ERRMSG )

         IF ( ERROR ) THEN
C
C           If an error occurred while attempting to parse the
C           exponent, we simply want to exit. The error message
C           is already set.
C
            RETURN

         END IF

      ELSE

         ERROR  = .TRUE.
         ERRMSG = 'ERROR: Missing exponent.'
         RETURN

      END IF
C
C     We now have everything that we need to build the double
C     precision number, a mantissa and an exponent. So, let's
C     start building the number. We need to be careful that we
C     do not overflow when we scale the number using the exponent.
C
C     First, we build up the mantissa ...
C
      IF ( NEGTIV ) THEN

         DO WHILE ( NDIGIT .GT. 0 )

            TMPNUM = TMPNUM - DPVAL(IVAL(NDIGIT)) * SCALES(NDIGIT)
            NDIGIT = NDIGIT - 1

         END DO

      ELSE

         DO WHILE ( NDIGIT .GT. 0 )

            TMPNUM = TMPNUM + DPVAL(IVAL(NDIGIT)) * SCALES(NDIGIT)
            NDIGIT = NDIGIT - 1

         END DO

      END IF
C
C     At this point, one of the following is true:
C
C        1)  -1     <  TMPNUM <= -1/BASE
C
C        2)  1/BASE <= TMPNUM <  1
C
C     or
C
C        3) TMPNUM = 0.0D0
C
C     Now we to scale the normalized number using the exponent. If
C     the exponent is zero, we will simply fall through the loop
C     structures below at no greater cost than a few comparisons.
C
      IF ( IEXPON .LT. 0 ) THEN
C
C        We do not check for any sort of underflow conditions.
C
         DO I = 1, -IEXPON

            TMPNUM = TMPNUM * INVBAS

         END DO

      ELSE

         IF ( NEGTIV ) THEN

            DO I = 1, IEXPON

               IF ( TMPNUM .GE. MINDP ) THEN

                  TMPNUM = TMPNUM * BASE

               ELSE

                  ERROR  = .TRUE.
                  ERRMSG = 'ERROR: Number is too small to be'//
     .                     ' represented.'
                  RETURN

               END IF

            END DO

         ELSE

            DO I = 1, IEXPON

               IF ( TMPNUM .LE. MAXDP ) THEN

                  TMPNUM = TMPNUM * BASE

               ELSE

                  ERROR  = .TRUE.
                  ERRMSG = 'ERROR: Number is too large to be'//
     .                     ' represented.'
                  RETURN

               END IF

            END DO

         END IF

      END IF
C
C     If we got to here, we have successfully parsed the hexadecimal
C     string into a double precision number. So, set the value and
C     return.
C
      NUMBER = TMPNUM

      RETURN
      END


!***************************************************************
!
!  MINIMAL BASIS STO-3G CALCULATION ON HEH+
!
!  THIS IS A LITTYLE DUMMY MAIN PROGRAM WHICH CALLS HFCALC
!
!***************************************************************
      program main
        implicit double precision(A-H, O-Z)
        IOP = 2
        N = 3               ! `N` in STO-NG
        R = 1.4632D0        ! Bond length
        ZETA1 = 2.0925D0    ! Slater function exponent
        ZETA2 = 1.24D0      ! Slater function exponent
        Za = 2.0D0          ! Nuclear charges of He
        Zb = 1.0D0          ! Nuclear charges of H
        call HFcalc(IOP, N, R, ZETA1, ZETA2, Za, Zb)
      end

!***************************************************************
      subroutine HFcalc(IOP, N, R, ZETA1, ZETA2, Za, Zb)
!     Does a Hatree-Fock calculations for a two-electron diatomic
!     using the 1s minimal STO-NG basis set
!
!     IOP = 0   No priting whatsoever (to optimize exponents, say)
!     IOP = 1   Print only converged results
!     IOP = 2   Print every Iteration
!     N         STO-NG calculation (N=1, 2 or 3)
!     R         Bondlength (AU)
!     ZETA1     Slater orbital exponent (function 1)
!     ZETA2     Slater orbital exponent (function 2)
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        if (IOP == 0) goto 20
          print 10, N, Za, Zb
10        format(1H1, 2X, 4HSTO-, I1, 21HG FOR ATOMIC NUMBERS ,F5.2, 5H AND F5.2,//)
20        continue
! Calculate all the one and two-electron integrals
        call Intgrl(IOP, N, R, ZETA1, ZETA2, Za, Zb)
! Be inefficient and put all integrals in pretty arrays
        call Colect(IOP, N, R, ZETA1, ZETA2, Za, Zb)
! Perform the SCF calculation
        call SCF(IOP, N, R, ZETA1, ZETA2, Za, Zb)
        return
      end subroutine HFcalc

!***************************************************************
      subroutine INTGRL(IOP, N, R, ZETA1, ZETA2, Za, Zb)
!
!     Calculates all the basic integrals needed for scf calculation
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        common/int/ S12, &              ! global variables?
                    T11, T12, T22, &
                    V11A, V12A, V22A, V11B, V12B, V22B, &
                    V1111, V2111, V2121, V2211, V2221, V2222
        dimension Coef(3, 3), Expon(3, 3), D1(3), A1(3), D2(3), A2(3)
        data PI /3.1415926535898D0/
! These are the contraction coefficients and exponents for
! a normalized 1S slater orbital with exponent 1.0 in terms of
! normalized 1S primitive gaussians
        data Coef, Expon/ 1.0D0     , 2*0.0D0   ,                   &
                          0.678914D0, 0.430129D0, 0.0D0,            &
                          0.444635D0, 0.535328D0, 0.154329D0,       &
                          0.270950D0, 2*0.0D0   ,                   &
                          0.151623D0, 0.851819D0, 0.0D0,            &
                          0.109818D0, 0.405771D0, 2.22766D0/
        R2 = R * R
! Scale the exponents (A) of primitive gaussians
! Include normalization in contraction coefficients (D)
        do 10 i = 1, N
          A1(i) = Expon(i, N) * (ZETA1 ** 2)
          D1(i) = Coef (i, N) * ((2.0D0 * A1(i) / PI) ** 0.75D0 )
          A2(i) = Expon(i, N) * (ZETA2 ** 2)
          D2(i) = Coef (i, N) * ((2.0D0 * A2(i) / PI) ** 0.75D0 )
10      continue
! D and A are now the contraction coefficients and exponents
! in terms of unnormalized primitive gaussians
        S12   = 0.0D0
        T11   = 0.0D0
        T12   = 0.0D0
        T22   = 0.0D0
        V11A  = 0.0D0
        V12A  = 0.0D0
        V22A  = 0.0D0
        V11B  = 0.0D0
        V12B  = 0.0D0
        V22B  = 0.0D0
        V1111 = 0.0D0
        V2111 = 0.0D0
        V2121 = 0.0D0
        V2211 = 0.0D0
        V2221 = 0.0D0
        V2222 = 0.0D0
! Calculate one-electron integrals
! center A is first atom, center B is second atom
! origin is on center A
! V12A = off-diagonal nuclear attraction to center A, etc
        do 20 i = 1, N
          do 20 j = 1, N
! Rap2 = squared distance between center A and center P, etc
            R_AP   = A2(J) * R / (A1(I) + A2(J))
            R_AP2  = R_AP ** 2
            R_BP2  = (R - R_AP) ** 2

            S12    = S12  + S(A1(i), A2(j), R2)    * D1(i) * D2(j)
            T11    = T11  + T(A1(i), A1(j), 0.0D0) * D1(i) * D1(j)
            T12    = T12  + T(A1(i), A2(j), R2)    * D1(i) * D2(j)
            T22    = T22  + T(A2(i), A2(j), 0.0D0) * D2(i) * D2(j)

            V11A   = V11A + V(A1(i), A1(j), 0.0D0, 0.0D0, Za) * D1(i) * D1(j)
            V12A   = V12A + V(A1(i), A2(j), R2   , R_AP2, Za) * D1(i) * D2(j)
            V22A   = V22A + V(A2(i), A2(j), 0.0D0, R2   , Za) * D2(i) * D2(j)
            V11B   = V11B + V(A1(i), A1(j), 0.0D0, R2   , Zb) * D1(i) * D1(j)
            V12B   = V12B + V(A1(i), A2(j), R2   , R_BP2, Zb) * D1(i) * D2(j)
            V22B   = V22B + V(A2(i), A2(j), 0.0D0, 0.0D0, Zb) * D2(i) * D2(j)
20      continue
! Calculate two-electron integrals
        do 30 i = 1, N
          do 30 j = 1, N
            do 30 k = 1, N
              do 30 l = 1, N
                R_AP  = A2(i) * R / (A2(i) + A1(j))
                R_BP  = R - R_AP
                R_AQ  = A2(K) * R / (A2(k) + A1(l))
                R_BQ  = R - R_AQ
                R_PQ  = R_AP - R_AQ

                R_AP2 = R_AP ** 2
                R_BP2 = R_BP ** 2
                R_AQ2 = R_AQ ** 2
                R_BQ2 = R_BQ ** 2
                R_PQ2 = R_PQ ** 2

                V1111 = V1111 + TwoE(A1(i), A1(j), A1(k), A1(l), 0.0D0, 0.0D0, 0.0D0) &
                  * D1(i) * D1(j) * D1(k) * D1(l)
                V2111 = V2111 + TwoE(A2(i), A1(j), A1(k), A1(l), R2   , 0.0D0, R_AP2) &
                  * D2(i) * D1(j) * D1(k) * D1(l)
                V2121 = V2121 + TwoE(A2(i), A1(j), A2(k), A1(l), R2   , R2   , R_PQ2) &
                  * D2(i) * D1(j) * D2(k) * D1(l)
                V2211 = V2211 + TwoE(A2(i), A2(j), A1(k), A1(l), 0.0D0, 0.0D0, R2   ) &
                  * D2(i) * D2(j) * D1(k) * D1(l)
                V2221 = V2221 + TwoE(A2(i), A2(j), A2(k), A1(l), 0.0D0, R2   , R_BQ2) &
                  * D2(i) * D2(j) * D2(k) * D1(l)
                V2222 = V2222 + TwoE(A2(i), A2(j), A2(k), A2(l), 0.0D0, 0.0D0, 0.0D0) &
                  * D2(i) * D2(j) * D2(k) * D2(l)
30      continue

        if (IOP == 0) goto 90
        print 40
40      format(3x, 1HR, 10x, 5HZETA1, 6x, 5HZETA2, 6x, 3HS12, 8x, 3HT11/)
        print 50, R, ZETA1, ZETA2, S12, T11
50      format(5f11.6,//)
        print 60
60      format(3x, 3HT12, 8x, 3HT22, 8X, 4HV11A, 7x, 4HV12A, 7x, 4HV22A/)
        print 50, T12, T22, V11A, V12A, V22A
        print 70
70      format(3x, 4HV11B, 7x, 4HV12B, 7x, 4HV22B, 7x, 5HV1111, 6x, 5HV2111/)
        print 50, V11B, V12B, V22B, V1111, V2111
        print 80
80      format (3x, 5HV2121, 6x, 5HV2211, 6x, 5HV2221, 6x, 5HV2222/)
        print 50, V2121, V2211, V2221, V2222
90      return
      end subroutine INTGRL
!***************************************************************
      function F0(arg)
!
!     Calculates the F function
!     F0 only (S-type orbitals)
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        data PI /3.1415926535898D0/
        if (arg < 1.0D-6) goto 10
! F0 in terms of the error function
        F0 = DSQRT(PI / arg) * DERF(DSQRT(arg)) / 2.0D0
        goto 20
! Asynptotic value for small argumets
10      F0 = 1.0D0 - arg / 3.0D0
20      continue
        return
      end function F0
!***************************************************************
      function DERF(arg)
!
!     Calculates the error function according to a rational
!     approximation from M. Abramowitz and I.A. Stegun,
!     handbook of mathematical functions, Dover.
!     Absolute error is less than 1.5E-7
!     Can be replaced by a built-in function on some machines
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        dimension A(5)
        data P /0.327591100D0/
        data A /0.254829592D0, -0.284496736D0, 1.42143741D0, &
               -1.453152027D0,  1.061405429D0/
        T  = 1.0D0 / (1.0D0 + P * arg)
        TN = T
        POLY = A(1) * TN
        do 10 i = 2, 5
          TN = TN * T
          POLY = POLY + A(i) * TN   ! Taylor expansion ?
10      continue
        DERF = 1.0D0 - POLY * DEXP(- ARG ** 2)
        return
      end function DERF
!***************************************************************
      function S(A, B, R_AB2)
!
!     Calculates overlaps for un-normalized primitives
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        data PI /3.1415926535898D0/
        S = (PI / (A + B)) ** 1.5D0 * DEXP(-A * B * R_AB2 / (A + B))
        return
      end function S
!***************************************************************
      function T(A, B, R_AB2)
!
!     Calculates kinetic energy integrals for un-normalized primitives
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        data PI /3.1415926535898D0/
        T = A * B / (A + B) * (3.0D0 - 2.0D0 * A * B * R_AB2 / (A + B)) * (PI / (A + B)) ** 1.5D0 &
          * DEXP(-A * B * R_AB2 / (A + B))
        return
      end function T
!***************************************************************
      function V(A, B, R_AB2, R_CP2, ZC)
!
!     Calculates un-normalized nuclear attraction integrals
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        data PI/3.1415926535898D0/
        V = 2.0D0 * PI / (A + B) * F0((A + B) * R_CP2) * DEXP(-A * B * R_AB2 / (A + B))
        V = -V * ZC
        return
      end function V
!***************************************************************
      function TwoE(A, B, C, D, R_AB2, R_CD2, R_PQ2)
!
!     Calculates two-electron integrals for un-normalized primitives
!     A, B, C, D are the exponents alpha, beta, etc.
!     R_AB2 equals squared distance between center A and center B
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        data PI /3.1415926535898D0/
        TwoE = 2.0D0 * (PI ** 2.5D0) / ((A + B) * (C + D) * DSQRT(A + B + C + D)) &
          * F0((A + B) * (C + D) * R_PQ2 / (A + B + C + D)) &
          * DEXP(-A * B * R_AB2 / (A + B) - C * D * R_CD2 / (C + D) )
        return
      end function TwoE
!***************************************************************
      subroutine Colect(IOP, N, R, ZETA1, ZETA2, ZA, ZB)
!
!     This takes the basic integrals from common and assembles the
!     relevant matrices, that is S, H, X, XT, and two-electron integrals
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        common /Matrix/ S(2, 2), X(2, 2), XT(2, 2), H(2, 2), F(2, 2), G(2, 2), C(2, 2), &
          FPrime(2, 2), CPrime(2, 2), P(2, 2), OldP(2, 2), TT(2, 2, 2, 2), E(2, 2)
        common/int/ S12, &              ! global variables?
                    T11, T12, T22, &
                    V11A, V12A, V22A, V11B, V12B, V22B, &
                    V1111, V2111, V2121, V2211, V2221, V2222
! From core hamiltonian
        H(1, 1) = T11 + V11A + V11B
        H(1, 2) = T12 + V12A + V12B
        H(2, 1) = H(1, 2)             ! Hermitian operator
        H(2, 2) = T22 + V22A + V22B
! From overlap matrix
        S(1, 1) = 1.0D0
        S(1, 2) = S12
        S(2, 1) = S(1, 2)
        S(2, 2) = 1.0D0
! Use canonical orthogonalization
        X(1, 1) = 1.0D0 / DSQRT(2.0D0 * (1.0D0 + S12))
        X(2, 1) = X(1, 1)
        X(1, 2) = 1.0D0 / DSQRT(2.0D0 * (1.0D0 - S12))
        X(2, 2) = -X(1, 2)
! Transpose of transformation matrix
        XT(1, 1) = X(1, 1)
        XT(1, 2) = X(2, 1)
        XT(2, 1) = X(1, 2)
        XT(2, 2) = X(2, 2)
! Matrix of two-electron integrals
        TT(1, 1, 1, 1) = V1111
        TT(2, 1, 1, 1) = V2111
        TT(1, 2, 1, 1) = V2111
        TT(1, 1, 2, 1) = V2111
        TT(1, 1, 1, 2) = V2111
        TT(2, 1, 2, 1) = V2121
        TT(1, 2, 2, 1) = V2121
        TT(2, 1, 1, 2) = V2121
        TT(1, 2, 1, 2) = V2121
        TT(2, 2, 1, 1) = V2211
        TT(1, 1, 2, 2) = V2211
        TT(2, 2, 2, 1) = V2221
        TT(2, 2, 1, 2) = V2221
        TT(2, 1, 2, 2) = V2221
        TT(1, 2, 2, 2) = V2221
        TT(2, 2, 2, 2) = V2222

        if (IOP == 0) goto 40
        call MatOut(S, 2, 2, 2, 2, 4HS    )
        call MatOut(X, 2, 2, 2, 2, 4HX    )
        call MatOut(H, 2, 2, 2, 2, 4HH    )
        print 10
10      format(//)
        do 30 i = 1, 2
          do 30 j = 1, 2
            do 30 k = 1, 2
              do 30 l = 1, 2
                print 20, i, j, k, l, TT(i, j, k, l)
20      format(3X, 1H(,4I2,2H ), F10.6)
30      continue
40      return
      end subroutine Colect
!***************************************************************
      subroutine SCF(IOP, N, R, ZETA1, ZETA2, Za, Zb)
!
!     Performs the SCF iterations
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        common /Matrix/ S(2, 2), X(2, 2), XT(2, 2), H(2, 2), F(2, 2), G(2, 2), C(2, 2), &
          FPrime(2, 2), CPrime(2, 2), P(2, 2), OldP(2, 2), TT(2, 2, 2, 2), E(2, 2)
        data PI /3.1415926535898D0/
! convergence criterion for density matrix
        data crit /1.0D-4/
! Maximum number of iterations
        data MaxIt /25/
! Iteration number
        iter = 0
! Use core-hamiltonian for initial guess at F. i.e. (P = 0)
        do 10 i = 1, 2
          do 10 j = 1, 2
10          P(i, j) = 0.0D0
        if (IOP < 2) goto 20
        call MatOut(P, 2, 2, 2, 2, 4HP    )
! start of iteration loop
20      iter = iter + 1
        if (IOP < 2) goto 40
        print 30, iter
30      format (/, 4x, 28HSTART OF ITERATION NUMBER = , I2)
40      continue
! From two-elextron part of fock matrix from P
        call FormG
        if (IOP < 2) goto 50
        call MatOut(G, 2, 2, 2, 2, 4HG    )
50      continue
! Add core hamiltonian to get fock matrix
        do 60 i = 1, 2
          do 60 j = 1, 2
            F(i, j) = H(i, j) + G(i, j)
60      continue
! Calculate electronic energy
        en = 0.0D0
        do 70 i = 1, 2
          do 70 j = 1, 2
            en = en + 0.5D0 * P(i, j) * (H(i, j) + F(i, j))
70      continue
        if (IOP < 2) goto 90
        call MatOut(F, 2, 2, 2, 2, 4HF    )
        print 80, en
80      format (///, 4x, 20HELECTRONIC ENERGY = ,D20.12)
90      continue
! Transform fock matrix using G for temporary storage
        call Mult(F, X, G, 2, 2)
        call Mult(XT, G, FPrime, 2, 2)
! Diagonalize transformed fock matrix
        call Diag(FPrime, CPrime, E)
! Transform eigenvectors to get matrix C
        call mult(X, CPrime, C, 2, 2)
! Form new density matrix
        do 100 i = 1, 2
          do 100 j = 1, 2
! save present density matrix
! before creating new one
            OldP(i, j) = P(i, j)
            P(i, j) = 0.0D0
            do 100 k = 1, 1
              P(i, j) = P(i, j) + 2.0D0 * C(i,k) * C(j, k)  ! eval product ?
100     continue
        if (IOP < 2) goto 110
        call MatOut(FPrime, 2, 2, 2, 2, 4HF'   )
        call MatOut(CPrime, 2, 2, 2, 2, 4HC'   )
        call MatOut(E, 2, 2, 2, 2, 4HE    )
        call MatOut(C, 2, 2, 2, 2, 4HC    )
        call MatOut(P, 2, 2, 2, 2, 4HP    )
110     continue
! Calculate delta
        Delta = 0.0D0
        do 120 i = 1, 2
          do 120 j = 1, 2
            Delta = Delta + (P(i, j) - OldP(i, j)) ** 2
120     continue
        Delta = DSQRT(Delta / 4.0D0)
        if (IOP == 0) goto 140
        print 130, Delta
130     format(/, 4x, 39HDELTA(CONVERGENCE OF DENSITY MATRIX) = &
          F10.6, /)
140     continue
! Check for convergence
        if (Delta < crit) goto 160
! Not yet converged
! Test for maximum nunber of iterations
! If maximum number not yet reached then
! go back for another iteration
        if (iter < MaxIt) goto 20
! Something wrong here
        print 150
150     format (4x, 21HNO CONVERGENCE IN SCF)
        stop
160     continue
! Calculation converged if it got here
! Add nuclear repulsion to get total energy
        ENT = en + Za * Zb / R
        if (IOP == 1) goto 180
        print 170, en, ENT
170     format(//, 4x, 21HCALCULATION CONVERGED, //, &
          4x, 20HELECTRONIC ENERGY = , D20.12, // &
          4x, 20HTOTAL ENERGY =      , D20.12)
180     continue
        if (IOP /= 1) goto 190
! Print out the final results if
! have not done so already
        call MatOut (G, 2, 2, 2, 2, 4HG    )
        call MatOut (F, 2, 2, 2, 2, 4HF    )
        call MatOut (E, 2, 2, 2, 2, 4HE    )
        call MatOut (C, 2, 2, 2, 2, 4HC    )
        call MatOut (P, 2, 2, 2, 2, 4HP    )
190     continue
! PS matrix has mulliken populations
        call mult(P, S, OldP, 2, 2)
        if (IOP == 0) goto 200
        call MatOut(OldP, 2, 2, 2, 2, 4HPS    )
200     continue
        return
      end subroutine SCF
!***************************************************************
      subroutine FormG
!
!     Calculates the G matrix from the density matrix
!     and two-electron integrals
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        common /Matrix/ S(2, 2), X(2, 2), XT(2, 2), H(2, 2), F(2, 2), G(2, 2), C(2, 2), &
          FPrime(2, 2), CPrime(2, 2), P(2, 2), OldP(2, 2), TT(2, 2, 2, 2), E(2, 2)
        do 10 i = 1, 2
          do 10 j = 1, 2
            G(i, j) = 0.0D0
            do 10 k = 1, 2
              do 10 l = 1, 2
                G(i, j) = G(i, j) + P(k, l) * (TT(i, j, k, l) - 0.5D0 * TT(i, l, k, j))
10      continue
        return
      end subroutine FormG
!***************************************************************
      subroutine Diag(F, C, E)
! Diagonalizes F to give eigenvectors in C and eigenvalues in E
! Theta is the angle describing solution
!***************************************************************
        implicit double precision(A-H, O-Z)
        dimension F(2, 2), C(2, 2), E(2, 2)
        data PI/3.1415926535898D0/
        if (DABS(F(1, 1) - F(2, 2)) > 1.0D-20) goto 10
! Here is symmetry determined solution (Homonuclear diatomic)
        Theta = PI / 4.0D0
        goto 20
10      continue
! Solution for heteronuclear diatomic
        Theta = 0.5D0 * DATAN(2.0D0 * F(1, 2) / (F(1, 1) - F(2, 2)))
20      continue
        C(1, 1) =  DCOS(Theta)
        C(2, 1) =  DSIN(Theta)
        C(1, 2) =  DSIN(Theta)
        C(2, 2) = -DCOS(Theta)
        E(1, 1) = F(1, 1) * DCOS(Theta) ** 2 + F(2, 2) * DSIN(Theta) ** 2 &
          + F(1, 2) * DSIN(2.0D0 * Theta)
        E(2, 2) = F(2, 2) * DCOS(Theta) ** 2 + F(1, 1) * DSIN(Theta) ** 2 &
          - F(1, 2) * DSIN(2.0D0 * Theta)
        E(2, 1) = 0.0D0
        E(1, 2) = 0.0D0
! Order eigenvalues and eigenvectors
        if (E(2, 2) > E(1, 1)) goto 30
        temp = E(2, 2)
        E(2, 2) = E(1, 1)
        E(1, 1) = temp
        temp = C(1, 2)
        C(1, 2) = C(1, 1)
        C(1, 1) = temp
        temp = C(2, 2)
        C(2, 2) = C(2, 1)
        C(2, 1) = temp
30      return
      end subroutine Diag
!***************************************************************
      subroutine mult(A, B, C, IM, M)
!
!     Multiplies two square matrices A and B to get C
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        dimension A(IM, IM), B(IM, IM), C(IM, IM)
        do 10 i = 1, M
          do 10 j = 1, M
            C(i, j) = 0.0D0
            do 10 K = 1, M
10      C(i, j) = C(i, j) + A(i, k) * B(k, j)
        return
      end subroutine mult

!***************************************************************
      subroutine MatOut(A, IM, IN, M, N, LABEL)
!
!     Print Matrices of site M by N
!
!***************************************************************
        implicit double precision(A-H, O-Z)
        dimension A(IM, IN)
        ihigh  = 0
10      low    = ihigh + 1
        ihigh  = ihigh + 8
        ihigh  = MIN0(ihigh, N)
        print 20, LABEL, (i, i=low, ihigh)
20      format(///, 3x, 5H THE , a4, 6H ARRAY, /, 15x, 5(10x, I3, 6X)//)
        do 30 i = 1, M
30      print 40, I, (A(i, j), j=low, ihigh)
40      format (I10, 5x, 5(1x, d18.10))
        if (N - ihigh) 50, 50, 10
50      return
      end subroutine MatOut


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_HYD_A3_B3_C3_D3

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_HYD_A3_B3_C3 , MR_CALC_RAW_HYD_D3

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_HYD_A3_B3_C3( NI , NJ , NK , HYD_A3 , HYD_B3 , HYD_C3 )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,    2:NK  ) :: HYD_A3
    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,    1:NK  ) :: HYD_B3
    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,    1:NK-1) :: HYD_C3

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          !BLOCK
            HYD_B3( I , J , K ) = MW( I , J )
          !END BLOCK
        END DO
      END DO
    END DO

    DO K = 2 , NK
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            HYD_A3( I , J , K ) =-DT * PHI * EKZ * MW( I , J ) * VZW( I , J ,K-1) / ( H( I , J ) * DSIGMA )**2
            HYD_B3( I , J , K ) = HYD_B3( I , J , K ) - HYD_A3( I , J , K )
          ELSE
            HYD_A3( I , J , K ) = 0.0
          END IF
        END DO
      END DO
    END DO

    DO K = 1 , NK-1
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            HYD_C3( I , J , K ) = HYD_A3( I , J ,K+1)
            HYD_B3( I , J , K ) = HYD_B3( I , J , K ) - HYD_C3( I , J , K )
          ELSE
            HYD_C3( I , J , K ) = 0.0
          END IF
        END DO
      END DO
    END DO

  END SUBROUTINE MR_CALC_HYD_A3_B3_C3

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_RAW_HYD_D3( NI , NJ , NK , HYD_D3 )

    USE MR_MOD_CALC_HYD_ADV_N_DIF_Z
    USE MR_MOD_CALC_HYD_ADV_N_DIF_XY
    USE MR_MOD_CALC_HYD_BAR_XY
    USE MR_MOD_CALC_HYD_COR_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:2,1:NK  ) :: HYD_D3

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2,1:NK) :: HYD_ADV_Z  , HYD_DIF_Z
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2     ) :: HYD_ADV_XY , HYD_DIF_XY , HYD_BAR_XY , HYD_COR_XY

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK

      DO DIM = 1 , 2

        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            !BLOCK
              HYD_D3( I , J ,DIM, K ) = MW( I , J ) * UV( I , J ,DIM, K )
            !END BLOCK
          END DO
        END DO

      END DO

    END DO

  ! ASSIGN NONEQUILIBRIUM TERMS
    CALL MR_CALC_HYD_ADV_N_DIF_Z( NI , NJ , NK , HYD_ADV_Z , HYD_DIF_Z )

    DO K = 1 , NK

      CALL MR_CALC_HYD_ADV_N_DIF_XY( NI , NJ , K , HYD_ADV_XY , HYD_DIF_XY )
     !CALL MR_CALC_HYD_BAR_XY( NI , NJ , K , HYD_BAR_XY )
     !CALL MR_CALC_HYD_COR_XY( NI , NJ , K , HYD_COR_XY )

      DO DIM = 1 , 2

        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
              HYD_D3( I , J ,DIM, K ) = HYD_D3( I , J ,DIM, K ) +  &
              & HYD_ADV_XY( I , J ,DIM) + HYD_ADV_Z( I , J ,DIM, K ) +   &
              & HYD_DIF_XY( I , J ,DIM) + HYD_DIF_Z( I , J ,DIM, K ) !+   &
             !& HYD_BAR_XY( I , J ,DIM) +   &
             !& HYD_COR_XY( I , J ,DIM)
            END IF
          END DO
        END DO

      END DO

    END DO

  END SUBROUTINE MR_CALC_RAW_HYD_D3

  END MODULE MR_MOD_CALC_HYD_A3_B3_C3_D3


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Do a surface interpolation W to compute its minimum value.
c Note: W(0,0) is assumed to be an integral minimum.

      subroutine compute_dn(W,ia,ja,dn)
      implicit none
c Inputs...
      integer*4 ia,ja		!half-window size of shape template
      integer*2 W(-ia:ia,-ja:ja)
c Output...
      real*4 dn			!surface interpolated min value of B

c Local variables...
      integer a,b,c		!because the W(i,j) are integers
      real x,y			!because we divide by 2.
      real dnx,dny		!horizontal and vertical minima
      integer i,j,dnij

c Interpolate mindn to sub-pixel accuracy...
c The calculations are centered at W(0,0) and involves only 5 pixels:
c                  W(0,-1)
c         W(-1,0)  W(0,0)   W(+1,0)
c                  W(0,+1)

c Find the horizontal minimum by fitting W(-1,0), W(0,0), W(+1,0)
c to a parabola...

      if (W(0,0).lt.0) goto 50	!no interpolation is possible

c Horizontal interpolation using W(-1,0), W(0,0) and W(1,0)...
      dnx = -999
      if (W(-1,0).lt.0 .or. W(1,0).lt.0) goto 30
      a = W(1,0) - 2*W(0,0) + W(-1,0)
      if (a.eq.0) goto 30	!skip if straight line
      b = W(1,0) - W(-1,0)
      c = W(0,0)
      x = -b/(2.*a)		!x value of minimum
      dnx = a*x**2 + b*x + c	!interpolated minimum dn

   30 continue

c Vertical interpolation using W(0,-1), W(0,0) and W(0,1)...
      dny = -999
      if (W(0,-1).lt.0 .or. W(0,1).lt.0) goto 40
      a = W(0,1) - 2*W(0,0) + W(0,-1)
      if (a.eq.0) goto 40
      b = W(0,1) - W(0,-1)
      c = W(0,0)
      y = -b/(2.*a)
      dny = a*y**2 + b*y + c

   40 continue
      dn = 256
      if (dnx.ne.-999) then
         if (dny.ne.-999) then
            dn = (dnx+dny)/2
         else
            dn = dnx
         endif
      else
         if (dny.ne.-999) dn=dny
      endif
      if (dn.lt.0) dn=0
      if (dn.eq.256) dn=W(0,0)	!Use center if both interpolations failed
      return

c Here if W(0,0) is invalid.  Set dn equal to minimum of 8 neighbors...

   50 continue
      dn = 256
      do j=-1,1
         do i=-1,1
            dnij = W(i,j)
            if (dnij.ge.0 .and. dnij.lt.dn) dn=dnij
         enddo
      enddo
      if (dn.ne.256) return	!return if dn has been set

c If all else fails, set dn equal to minimum of W...

      do j=-ja,ja
         do i=-ia,ia
            dnij = W(i,j)
            if (dnij.ge.0 .and. dnij.lt.dn) dn=dnij
         enddo
      enddo
      return
      end


module globalModule
implicit none

	real(kind=8), parameter :: PK = 1.3806503d-16, UMA = 1.66053873d-24, PC = 2.99792458d10
	real(kind=8), parameter :: PH = 6.62606876d-27, PHK = PH / PK, PHC = 2.d0 * PH / PC**2
	real(kind=8), parameter :: PME = 9.10938188d-28, PE = 4.8032d-10, PI = 3.14159265359d0
	real(kind=8), parameter :: PHC2 = 2.d0 * PH * PC**2
	real(kind=8), parameter :: SQRTPI = 1.77245385091d0, EARTH_SUN_DISTANCE = 1.495979d13
	real(kind=8), parameter :: LARMOR = PE/(4.d0*PI*PME*PC), PMP = 1.67262158d-24
	real(kind=8), parameter :: NUCLEAR_MAGNETON = PE*PH/(2.d0*PI*PMP)
	real(kind=8), parameter :: BOHR_MAGNETON = PE*PH/(2.d0*PI*PME)
	real(kind=8), parameter :: PH2C3 = 2.d0 * PH**2 * PC**3, PERTURBATION = 0.005d0
	real(kind=8), parameter :: OPA = PI * PE**2 / (PME * PC), EV_ERG = 1.60217646d-12, GRAV = 2.7398d4
	real(kind=8), parameter :: BOHR_R = (PH/(2.d0*PI))**2/(PME*PE**2), CEV_ERG = 1.60217646d-12

	type atmosphereType
		character(len=256) :: file
		integer :: nDepths, nNodes, modelsInChunk
		real(kind=8) :: abundance
		real(kind=8), dimension(:), pointer :: lTau500, height, T, nodes, niovern, ui, u1, u2, u3, n2overn1, n1overn0, microturbulence, vmac, B, thetaB, chiB
		real(kind=8), dimension(:), pointer :: opacity500, splitting, molecularAbundance, molecularPartition, molecularEquilibrium
 		real(kind=8), dimension(:), pointer :: Pe, Pg, PH, PHminus, PHplus, PH2, PH2plus, PTotal, nHtot, TOrdered, lTau500Ordered
 		real(kind=8), dimension(:,:), pointer :: lTau500Chunk, TChunk, vmacChunk, BChunk, thetaBChunk, chiBChunk, PeChunk
 		real(kind=8), dimension(:,:), pointer :: profile, zeeman_voigt, zeeman_faraday, coefficients
 		integer, dimension(:), pointer :: order, xPosChunk, yPosChunk
	end type atmosphereType

	type atmosphere3DType
		character(len=256) :: file
		integer :: nDepths
		real(kind=8), dimension(:), pointer :: lTau500
		real(kind=8), dimension(:,:,:), pointer :: T, vmac, B, thetaB, chiB, Pe
	end type atmosphere3DType

	type transitionType
		integer :: nLambda, element, ionization, nComponents(3)
		logical :: active, molecule
		real(kind=8) :: lambda0, gf, Elow, gu, Ju, gl, Jl, sigmaABO, alphaABO, lambdaLeft, lambdaRight, mass
		real(kind=8) :: frequency0, boundary
		real(kind=8), dimension(:), pointer :: lineOpacity, backOpacity, dopplerWidth, deltaNu, damping
		real(kind=8), dimension(:,:), pointer :: source, splitting, strength, opacityContinuum
		real(kind=8), dimension(:,:,:), pointer :: opacity
	end type transitionType

	type lineListType
		integer :: nLines, nLambdaTotal
		type(transitionType), dimension(:), pointer :: transition
		real(kind=8), dimension(:,:), pointer :: source, opacityContinuum, boundary
		real(kind=8), dimension(:,:,:), pointer :: opacity, stokesOut
		real(kind=8), dimension(:), pointer :: lambda, frequency, contOpacityForInterpolation, lambdaForInterpolation
		real(kind=8), pointer :: valuesNetCDF(:,:)
		integer :: startNetCDF(4), countNetCDF(4)
	end type lineListType

	type configType
		integer :: nPixelsChunk, nx, ny, nDepths, nRegions, nprocs, verbose, remainingColumns, activeSlaves, zeemanSynthesis, chemicalEquilibriumOption
		integer :: outputID, nx_id, ny_id, nstokes_id, nRegions_id, initialPixel
		integer, pointer :: regionSize_id(:), regionLambda_id(:), regionStokes_id(:)
		character(len=100) :: PeFile, TFile, BFile, thetaBFile, chiBFile, vFile, out_file, lTau500File
	end type configType

	real(kind=8), parameter :: CHPartitionT(15) = (/1000.d0,1500.d0,2000.d0,2500.d0,3000.d0,3500.d0,4000.d0,4500.d0,5000.d0,5500.d0,6000.d0,6500.d0,7000.d0,7500.d0,8000.d0/)
	real(kind=8), parameter :: CHPartitionU(15) = (/135.80691,218.34335,313.03912,422.82003,549.45839,694.31549,858.62851,1043.5906,1250.3427,1479.9248,1733.2079,&
		2010.8152,2313.0385,2639.7540,2990.3400/)
	real(kind=8), parameter :: CHEquilibrium(9) = (/7.04641,-8.49562,-9.63745,-8.30710,-1.72875,-4.09372,0.94498,-1.01589,0.04693/)

	real(kind=8), dimension(92) :: atomicE1, atomicE2, atomicWeight, atomicAbundance, atomicAffinity
	character(len=2), dimension(92) :: atomicName

	type(atmosphereType) :: atmosphere
	type(configType) :: config
	type(atmosphere3DType) :: atmosphere3D
	type(lineListType), pointer :: lineList(:)

	real(kind=8) :: identity(4,4)

	integer :: packageSizeAtmosphere, packageSizeStokes, myrank
	character, allocatable :: packageAtmosphere(:), packageStokes(:)

end module globalModule


      SUBROUTINE WAVPOL (A,B,E,F,WR,WI,XKX,XKZ)
c	calculate vector E from the dispersion determinant (A + iB)
c	normalized to unit length
c	and B (called F here) from del x E + (1/c)dB/dt = 0
c
	implicit integer (i,j,k,l,m,n)
	implicit real (a-h,o-z)
      DIMENSION A(3,3), B(3,3), E(6), F(6), DMR(3,3), DMI(3,3)
c	find largest minor of the dispersion determinant
C**************
C	TRANSPOSE A + iB
	do i = 1,3
	do j = 1,3
	  dmr(i,j) = a(j,i)
	  dmi(i,j) = b(j,i)
	enddo
	enddo
	do i = 1,3
	do j = 1,3
	  a(i,j) = dmr(i,j)
	  b(i,j) = dmi(i,j)
	enddo
	enddo
c***********
      DM=0.
      DO 105 I=1,3
        DO 105 J=1,3
        N1=MOD(I,3)+1
        N2=MOD(I+1,3)+1
        M1=MOD(J,3)+1
        M2=MOD(J+1,3)+1
        DMR(I,J)=PR(A(N1,M1),B(N1,M1),A(N2,M2),B(N2,M2))-PR(A(N1,M2),B(N
     1  1,M2),A(N2,M1),B(N2,M1))
        DMI(I,J)=PI(A(N1,M1),B(N1,M1),A(N2,M2),B(N2,M2))-PI(A(N1,M2),B(N
     1  1,M2),A(N2,M1),B(N2,M1))
        DMT=ABS(DMR(I,J))+ABS(DMI(I,J))
	print 1005,i,j,n1,n2,m1,m2,dmt
 1005	format(6i5,e13.4)
        IF (DM-DMT) 100,100,105
  100   DM=DMT
        IMAX=I
        JMAX=J
  105   CONTINUE
c	use Kramer;s rule to solve for relative E
      I=IMAX
      J=JMAX
      N1=MOD(I,3)+1
      N2=MOD(I+1,3)+1
      M1=MOD(J,3)+1
      M2=MOD(J+1,3)+1
      DO K=1,6
	E(K)=0.
      ENDDO
      E(2*J-1)=1.
      E(2*J)=0.
	print*,'set one E to 1',(e(k),k=1,6)
      F(1)=PR(A(N2,M2),B(N2,M2),A(N1,J),B(N1,J))-PR(A(N1,M2),B(N1,M2),A(
     1N2,J),B(N2,J))
      F(2)=PI(A(N2,M2),B(N2,M2),A(N1,J),B(N1,J))-PI(A(N1,M2),B(N1,M2),A(
     1N2,J),B(N2,J))
      F(3)=PR(A(N1,M1),B(N1,M1),A(N2,J),B(N2,J))-PR(A(N2,M1),B(N2,M1),A(
     1N1,J),B(N1,J))
      F(4)=PI(A(N1,M1),B(N1,M1),A(N2,J),B(N2,J))-PI(A(N2,M1),B(N2,M1),A(
     1N1,J),B(N1,J))
	print*,'result f',(f(k),k=1,6)
      E(2*M1-1)=-QR(F(1),F(2),DMR(I,J),DMI(I,J))
      E(2*M1)=-QI(F(1),F(2),DMR(I,J),DMI(I,J))
      E(2*M2-1)=-QR(F(3),F(4),DMR(I,J),DMI(I,J))
      E(2*M2)=-QI(F(3),F(4),DMR(I,J),DMI(I,J))
	print*,'result E',(E(k),k=1,6)
	print*,'m1,m2,e',m1,m2,(e(k),k=1,6)
      T=0.
      DO 110 N=1,6
  110   T=T+E(N)**2
      T=SQRT(T)
      DO 115 N=1,6
  115   E(N)=E(N)/T
c	find B using Maxwell equation.
      F(1)=-XKZ*QR(E(3),E(4),WR,WI)
      F(2)=-XKZ*QI(E(3),E(4),WR,WI)
      F(3)=XKZ*QR(E(1),E(2),WR,WI)-XKX*QR(E(5),E(6),WR,WI)
      F(4)=XKZ*QI(E(1),E(2),WR,WI)-XKX*QI(E(5),E(6),WR,WI)
      F(5)=XKX*QR(E(3),E(4),WR,WI)
      F(6)=XKX*QI(E(3),E(4),WR,WI)
	print*,'result B',(f(k),k=1,6)
	print*,'check equations'    ! order of indices checks
	k = 1
	f(1) = pr(A(k,1),B(k,1),E(1),E(2)) + pr(A(k,2),B(k,2),E(3),E(4))
     1		+ pr(A(k,3),B(k,3),E(5),E(6))
	f(2) = pi(A(k,1),B(k,1),E(1),E(2)) + pi(A(k,2),B(k,2),E(3),E(4))
     1		+ pi(A(k,3),B(k,3),E(5),E(6))
        print*,k,f(1),f(2)
	k = 2
	f(3) = pr(A(k,1),B(k,1),E(1),E(2)) + pr(A(k,2),B(k,2),E(3),E(4))
     1		+ pr(A(k,3),B(k,3),E(5),E(6))
	f(4) = pi(A(k,1),B(k,1),E(1),E(2)) + pi(A(k,2),B(k,2),E(3),E(4))
     1		+ pi(A(k,3),B(k,3),E(5),E(6))
        print*,k,f(3),f(4)
	k = 3
	f(5) = pr(A(k,1),B(k,1),E(1),E(2)) + pr(A(k,2),B(k,2),E(3),E(4))
     1		+ pr(A(k,3),B(k,3),E(5),E(6))
	f(6) = pi(A(k,1),B(k,1),E(1),E(2)) + pi(A(k,2),B(k,2),E(3),E(4))
     1		+ pi(A(k,3),B(k,3),E(5),E(6))
	print*,k,f(5),f(6)
      RETURN
      END