MODULE BIG_INTEGER_MODULE

  !  COPYRIGHT (C) 1993-2002 UNICOMP, INC.
  !
  !  DEVELOPED AT UNICOMP, INC.
  !
  !  PERMISSION TO USE, COPY, MODIFY, AND DISTRIBUTE THIS
  !  SOFTWARE IS FREELY GRANTED, PROVIDED THAT THIS NOTICE
  !  IS PRESERVED.

  !  THE MODULE NAMED BIG_INTEGERS DEFINES A NEW DATA TYPE
  !  BIG_INTEGER.  THIS DATA TYPE REPRESENTS NONNEGATIVE INTEGERS
  !  UP TO 10**N - 1, WHERE N IS THE PARAMETER (NAMED CONSTANT)
  !  NR_OF_DECIMAL_DIGITS.  THIS VALUE MAY BE CHANGED, BUT THE
  !  MODULE MUST THEN BE RECOMPILED (IT IS NOT DYNAMIC).

  !  THE FOLLOWING OPERATIONS ARE IMPLEMENTED.
  !  B REPRESENTS A BIG INTEGER, C A CHARACTER STRING,
  !  AND I AN ORDINARY INTEGER.

  !  INTEGER, PARAMETER :: NR_OF_DECIMAL_DIGITS

  !  BIG (I)
  !  BIG (C)
  !  INT (B)
  !  INT (C)
  !  CHAR (B)
  !  CHAR (I)

  !  B = I
  !  B = C
  !  I = B
  !  I = C
  !  C = B
  !  C = I

  !  B ? I, I ? B, AND B ? B, WHERE ? IS
  !    +, -, *, /,
  !    <, <=, >, >=, ==, OR /=

  !  B ** I

  !  MODULO (B, I)  [RESULT IS INTEGER]
  !  MODULO (I, B)  [RESULT IS BIG_INTEGER]
  !  MODULO (B, B)  [RESULT IS BIG_INTEGER]

  !  HUGE (B)
  !  SQRT (B)

  !  CALL PRINT_BIG (B)
  !  CALL RANDOM_NUMBER (B, LOW, HIGH)

  !  MANY OPERATIONS OF THE FORM B ? I, WHERE I < BASE,
  !  ARE IMPLEMENTED TO BE EFFICIENT AS SPECIAL CASES.

  IMPLICIT NONE

  PUBLIC :: BIG
  PUBLIC :: INT
  PUBLIC :: CHAR
  PUBLIC :: PRINT_BIG
  PUBLIC :: ASSIGNMENT (=)
  PUBLIC :: OPERATOR (+)
  PUBLIC :: OPERATOR (-)
  PUBLIC :: OPERATOR (*)
  PUBLIC :: OPERATOR (/)
  PUBLIC :: OPERATOR (**)
  PUBLIC :: MODULO
  PUBLIC :: HUGE
  PUBLIC :: SQRT
  PUBLIC :: RANDOM_NUMBER
  PUBLIC :: OPERATOR (==)
  PUBLIC :: OPERATOR (/=)
  PUBLIC :: OPERATOR (<=)
  PUBLIC :: OPERATOR (<)
  PUBLIC :: OPERATOR (>=)
  PUBLIC :: OPERATOR (>)

  PRIVATE :: BIG_GETS_INT, &
       BIG_INT, &
       BIG_GETS_CHAR, &
       BIG_CHAR, &
       INT_GETS_BIG, &
       INT_BIG, &
       INT_GETS_CHAR, &
       INT_CHAR, &
       CHAR_GETS_BIG, &
       CHAR_BIG, &
       CHAR_GETS_INT, &
       CHAR_INT

  PRIVATE :: BIG_PLUS_INT, &
       INT_PLUS_BIG, &
       BIG_PLUS_BIG, &
       BIG_MINUS_INT, &
       INT_MINUS_BIG, &
       BIG_MINUS_BIG, &
       BIG_TIMES_INT, &
       INT_TIMES_BIG, &
       BIG_TIMES_BIG, &
       BIG_DIV_INT, &
       INT_DIV_BIG, &
       BIG_DIV_BIG, &
       BIG_POWER_INT, &
       MODULO_BIG_INT, &
       MODULO_INT_BIG, &
       MODULO_BIG_BIG

  PRIVATE :: BIG_EQ_INT, &
       INT_EQ_BIG, &
       BIG_EQ_BIG, &
       BIG_NE_INT, &
       INT_NE_BIG, &
       BIG_NE_BIG, &
       BIG_LE_INT, &
       INT_LE_BIG, &
       BIG_LE_BIG, &
       BIG_GE_INT, &
       INT_GE_BIG, &
       BIG_GE_BIG, &
       BIG_LT_INT, &
       INT_LT_BIG, &
       BIG_LT_BIG, &
       BIG_GT_INT, &
       INT_GT_BIG, &
       BIG_GT_BIG

  PRIVATE :: HUGE_BIG, &
       BIG_BASE_TO_POWER, &
       PRINT_BIG_BASE, &
       SQRT_BIG, &
       MSD, &
       RANDOM_NUMBER_BIG

  INTRINSIC :: CHAR
  INTRINSIC :: INT
  INTRINSIC :: MODULO
  INTRINSIC :: HUGE
  INTRINSIC :: SQRT
  INTRINSIC :: RANDOM_NUMBER
  INTRINSIC :: RADIX
  INTRINSIC :: DIGITS

  ! THIS INDICATES THE MAXIMUM NUMBER OF DECIMAL DIGITS
  ! THAT A BIG INTEGER MAY CONTAIN.

  INTEGER, PARAMETER, PUBLIC :: NR_OF_DECIMAL_DIGITS = 150

  ! IF THE RADIX (RETURNED BY "RADIX(0)" OF THE INTEGERS ON
  ! YOUR SYSTEM IS NOT 2 CHANGE THE FOLLOWING CONSTANT TO
  ! THE LOGARITHM IN THE BASE 10 OF THE RADIX: LOG10(RADIX)

  REAL, PARAMETER, PRIVATE :: LOG_BASE_10_OF_RADIX = 0.30103

  INTEGER, PARAMETER, PRIVATE :: &
       D = DIGITS (0) / 2, &
       R = RADIX (0), &
       BASE = R ** D, &
       NR_OF_DIGITS = NR_OF_DECIMAL_DIGITS / (LOG_BASE_10_OF_RADIX * D) + 1

  ! THE BASE OF THE NUMBER SYSTEM IS R ** D,
  ! SO THAT EACH "DIGIT" IS 0 TO R**D - 1

  TYPE, PUBLIC :: BIG_INTEGER
     PRIVATE
     INTEGER, DIMENSION (0 : NR_OF_DIGITS) :: DIGIT
  END TYPE BIG_INTEGER

  INTERFACE BIG
     MODULE PROCEDURE BIG_CHAR, &
          BIG_INT
  END INTERFACE

  INTERFACE INT
     MODULE PROCEDURE INT_CHAR, &
          INT_BIG
  END INTERFACE

  INTERFACE CHAR
     MODULE PROCEDURE CHAR_BIG, &
          CHAR_INT
  END INTERFACE

  INTERFACE ASSIGNMENT (=)
     MODULE PROCEDURE BIG_GETS_INT, &
          BIG_GETS_CHAR, &
          INT_GETS_BIG, &
          INT_GETS_CHAR, &
          CHAR_GETS_BIG, &
          CHAR_GETS_INT
  END INTERFACE

  INTERFACE OPERATOR (+)
     MODULE PROCEDURE BIG_PLUS_INT, &
          BIG_PLUS_BIG
  END INTERFACE

  INTERFACE OPERATOR (-)
     MODULE PROCEDURE BIG_MINUS_INT, &
          INT_MINUS_BIG, &
          BIG_MINUS_BIG
  END INTERFACE

  INTERFACE OPERATOR (*)
     MODULE PROCEDURE BIG_TIMES_INT, &
          INT_TIMES_BIG, &
          BIG_TIMES_BIG
  END INTERFACE

  INTERFACE OPERATOR (/)
     MODULE PROCEDURE BIG_DIV_INT, &
          INT_DIV_BIG, &
          BIG_DIV_BIG
  END INTERFACE

  INTERFACE OPERATOR (**)
     MODULE PROCEDURE BIG_POWER_INT
  END INTERFACE

  INTERFACE MODULO
     MODULE PROCEDURE MODULO_BIG_INT, &
          MODULO_INT_BIG, &
          MODULO_BIG_BIG
  END INTERFACE

  INTERFACE OPERATOR (==)
     MODULE PROCEDURE BIG_EQ_INT, &
          INT_EQ_BIG, &
          BIG_EQ_BIG
  END INTERFACE

  INTERFACE OPERATOR (/=)
     MODULE PROCEDURE BIG_NE_INT, &
          INT_NE_BIG, &
          BIG_NE_BIG
  END INTERFACE

  INTERFACE OPERATOR (<=)
     MODULE PROCEDURE BIG_LE_INT, &
          INT_LE_BIG, &
          BIG_LE_BIG
  END INTERFACE

  INTERFACE OPERATOR (>=)
     MODULE PROCEDURE BIG_GE_INT, &
          INT_GE_BIG, &
          BIG_GE_BIG
  END INTERFACE

  INTERFACE OPERATOR (<)
     MODULE PROCEDURE BIG_LT_INT, &
          INT_LT_BIG, &
          BIG_LT_BIG
  END INTERFACE

  INTERFACE OPERATOR (>)
     MODULE PROCEDURE BIG_GT_INT, &
          INT_GT_BIG, &
          BIG_GT_BIG
  END INTERFACE

  INTERFACE HUGE
     MODULE PROCEDURE HUGE_BIG
  END INTERFACE

  INTERFACE SQRT
     MODULE PROCEDURE SQRT_BIG
  END INTERFACE

  INTERFACE RANDOM_NUMBER
     MODULE PROCEDURE RANDOM_NUMBER_BIG
  END INTERFACE

CONTAINS

  PURE FUNCTION BIG_CHAR (C) RESULT (B)

    CHARACTER (LEN=*), INTENT (IN) :: C
    TYPE (BIG_INTEGER) :: B
    INTEGER :: TEMP_DIGIT, N

    IF (LEN (C) > NR_OF_DECIMAL_DIGITS) THEN
       B = HUGE (B)
       RETURN
    END IF
    B % DIGIT = 0
    DO N = 1, LEN (C)
       TEMP_DIGIT = INDEX ("0123456789", C (N:N)) - 1
       IF (TEMP_DIGIT < 0) THEN
          B = HUGE (B)
       END IF
       B = B * 10 + TEMP_DIGIT
    END DO

  END FUNCTION BIG_CHAR

  PURE SUBROUTINE BIG_GETS_CHAR (B, C)

    TYPE (BIG_INTEGER), INTENT (OUT) :: B
    CHARACTER (LEN=*), INTENT (IN) :: C

    B = BIG_CHAR (TRIM (C))

  END SUBROUTINE BIG_GETS_CHAR

  PURE FUNCTION BIG_INT (I) RESULT (B)

    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: B
    INTEGER :: TEMP_I, N

    IF (I < 0) THEN
       B = HUGE (B)
    END IF

    B % DIGIT = 0
    TEMP_I = I
    DO N = 0, NR_OF_DIGITS - 1
       IF (TEMP_I == 0) THEN
          RETURN
       END IF
       B % DIGIT (N) = MODULO (TEMP_I, BASE)
       TEMP_I = TEMP_I / BASE
    END DO

    IF (TEMP_I /= 0) THEN
       B = HUGE (B)
    END IF

  END FUNCTION BIG_INT

  PURE SUBROUTINE BIG_GETS_INT (B, I)

    TYPE (BIG_INTEGER), INTENT (OUT) :: B
    INTEGER, INTENT (IN) :: I

    B = BIG (I)

  END SUBROUTINE BIG_GETS_INT

  PURE FUNCTION INT_CHAR (C) RESULT (I)

    CHARACTER (LEN=*), INTENT (IN) :: C
    INTEGER :: I

    I = INT (BIG (TRIM (C)))

  END FUNCTION INT_CHAR

  PURE SUBROUTINE INT_GETS_CHAR (I, C)

    INTEGER, INTENT (OUT) :: I
    CHARACTER (LEN=*), INTENT (IN) :: C

    I = INT_CHAR (TRIM (C))

  END SUBROUTINE INT_GETS_CHAR

  PURE FUNCTION INT_BIG (B) RESULT (I)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER :: I

    IF (MSD (B) > 1) THEN
       I = HUGE (I)
    ELSE
       I = BASE * B % DIGIT (1) + B % DIGIT (0)
    END IF

  END FUNCTION INT_BIG

  PURE SUBROUTINE INT_GETS_BIG (I, B)

    INTEGER, INTENT (OUT) :: I
    TYPE (BIG_INTEGER), INTENT (IN) :: B

    I = INT (B)

  END SUBROUTINE INT_GETS_BIG

  PURE FUNCTION CHAR_BIG (B) RESULT (C)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    CHARACTER (LEN=NR_OF_DECIMAL_DIGITS+9) :: C
    TYPE (BIG_INTEGER) :: TEMP_BIG
    INTEGER :: N, REMAINDER
    CHARACTER (LEN = *), PARAMETER :: DIGIT_CHARS = "0123456789"

    TEMP_BIG = B
    C = REPEAT (" ", LEN(C)-1) // "0"
    DO N = LEN (C), 1, -1
       IF (TEMP_BIG == 0) THEN
          EXIT
       END IF
       REMAINDER = MODULO (TEMP_BIG, 10) + 1
       TEMP_BIG = TEMP_BIG / 10
       C (N:N) = DIGIT_CHARS (REMAINDER:REMAINDER)
    END DO

    C = ADJUSTL (C)

  END FUNCTION CHAR_BIG

  PURE SUBROUTINE CHAR_GETS_BIG (C, B)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    CHARACTER (LEN=*), INTENT (OUT) :: C

    C = CHAR (B)

  END SUBROUTINE CHAR_GETS_BIG

  PURE FUNCTION CHAR_INT (I) RESULT (C)

    INTEGER, INTENT (IN) :: I
    CHARACTER (LEN=NR_OF_DECIMAL_DIGITS+9) :: C

    C = BIG (I)

  END FUNCTION CHAR_INT

  PURE SUBROUTINE CHAR_GETS_INT (C, I)

    INTEGER, INTENT (IN) :: I
    CHARACTER (LEN=*), INTENT (OUT) :: C

    C = BIG (I)

  END SUBROUTINE CHAR_GETS_INT

  PURE FUNCTION MSD (X) RESULT (MSD_RESULT)

    ! FIND MOST SIGNIFICAN DIGIT OF X

    TYPE (BIG_INTEGER), INTENT (IN) :: X
    INTEGER :: MSD_RESULT
    INTEGER :: N

    DO N = NR_OF_DIGITS, 0, -1
       IF (X % DIGIT (N) /= 0) THEN
          MSD_RESULT = N
          RETURN
       END IF
    END DO

    MSD_RESULT = -1

  END FUNCTION MSD

  PURE FUNCTION BIG_PLUS_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: BI
    INTEGER :: N, SUMM, CARRY

    IF (I < BASE) THEN
       CARRY = I
       DO N = 0, NR_OF_DIGITS - 1
          SUMM = B % DIGIT (N) + CARRY
          BI % DIGIT (N) = MODULO (SUMM, BASE)
          CARRY = SUMM / BASE
          IF (CARRY == 0) THEN
             BI % DIGIT (N+1:) = B % DIGIT (N+1:)
             RETURN
          END IF
       END DO
       IF (N==NR_OF_DIGITS) THEN
          BI = HUGE (BI)
       END IF
    ELSE
       BI = B + BIG (I)
    END IF

  END FUNCTION BIG_PLUS_INT

  PURE FUNCTION INT_PLUS_BIG (I, B) RESULT (BI)

    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: BI

    BI = B + I

  END FUNCTION INT_PLUS_BIG

  PURE FUNCTION BIG_PLUS_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    TYPE (BIG_INTEGER) :: BB
    INTEGER :: CARRY, TEMP_DIGIT, N, M

    CARRY = 0
    M = MAX (MSD (X), MSD (Y))
    DO N = 0, M
       TEMP_DIGIT = &
            X % DIGIT (N) + Y % DIGIT (N) + CARRY
       BB % DIGIT (N) = MODULO (TEMP_DIGIT, BASE)
       CARRY = TEMP_DIGIT / BASE
    END DO

    BB % DIGIT (M+1) = CARRY
    BB % DIGIT (M+2:NR_OF_DIGITS) = 0
    IF (BB % DIGIT (NR_OF_DIGITS) /= 0) THEN
       BB = HUGE (BB)
    END IF

  END FUNCTION BIG_PLUS_BIG

  PURE FUNCTION BIG_MINUS_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: BI
    INTEGER :: N, BORROW, DIFF, MSDB

    BI % DIGIT = 0
    MSDB = MSD (B)
    IF (MSDB<1 .AND. B % DIGIT (0) < I) THEN
       RETURN
    END IF

    IF (I < BASE) THEN
       BORROW = I
       DO N = 0, NR_OF_DIGITS - 1
          DIFF = B % DIGIT (N) - BORROW
          BI % DIGIT (N) = MODULO (DIFF, BASE)
          BORROW = (BASE - DIFF) / BASE
          IF (BORROW == 0) THEN
             BI % DIGIT (N+1:MSDB) = B % DIGIT (N+1:MSDB)
             RETURN
          END IF
       END DO
    ELSE
       BI = B - BIG (I)
    END IF

  END FUNCTION BIG_MINUS_INT

  PURE FUNCTION INT_MINUS_BIG (I, B) RESULT (IB)

    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: IB

    IB = BIG (I) - B

  END FUNCTION INT_MINUS_BIG

  PURE FUNCTION BIG_MINUS_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    TYPE (BIG_INTEGER) :: BB
    TYPE (BIG_INTEGER) :: TEMP_BIG
    INTEGER :: N

    TEMP_BIG = X
    DO N = 0, NR_OF_DIGITS - 1
       BB % DIGIT (N) = TEMP_BIG % DIGIT (N) - Y % DIGIT (N)
       IF (BB % DIGIT (N) < 0) THEN
          BB % DIGIT (N) = BB % DIGIT (N) + BASE
          TEMP_BIG % DIGIT (N + 1) = TEMP_BIG % DIGIT (N + 1) - 1
       END IF
    END DO

    IF (TEMP_BIG % DIGIT (NR_OF_DIGITS) < 0) THEN
       BB % DIGIT = 0
    ELSE
       BB % DIGIT (NR_OF_DIGITS) = 0
    END IF

  END FUNCTION BIG_MINUS_BIG

  PURE FUNCTION BIG_TIMES_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: BI
    INTEGER :: IB, PROD, CARRY

    IF (I < BASE) THEN
       BI % DIGIT = 0
       CARRY = 0
       DO IB = 0, MSD (B)
          PROD = B % DIGIT (IB) * I + CARRY
          BI % DIGIT (IB) = MODULO (PROD, BASE)
          CARRY = PROD / BASE
       END DO
       IF (IB==NR_OF_DIGITS .AND. CARRY /= 0) THEN
          BI = HUGE (BI)
       ELSE
          BI % DIGIT (IB) = CARRY
       END IF
    ELSE
       BI = B * BIG (I)
    END IF

  END FUNCTION BIG_TIMES_INT

  PURE FUNCTION INT_TIMES_BIG (I, B) RESULT (BI)

    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: BI

    BI = B * I

  END FUNCTION INT_TIMES_BIG

  PURE FUNCTION BIG_TIMES_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    TYPE (BIG_INTEGER) :: BB

    INTEGER :: IX, IY, IB, CARRY, PROD

    BB % DIGIT = 0

    DO IX = 0, MSD (X)
       CARRY = 0
       IB = IX
       DO IY = 0, MSD (Y)
          PROD = X % DIGIT (IX) * Y % DIGIT (IY) + BB % DIGIT (IB) + CARRY
          CARRY = PROD / BASE
          BB % DIGIT (IB) = MODULO (PROD, BASE)
          IF (IB == NR_OF_DIGITS) THEN
             BB = HUGE (BB)
             RETURN
          END IF
          IB = IB + 1
       END DO
       BB % DIGIT (IB) = BB % DIGIT (IB) + CARRY
    END DO

  END FUNCTION BIG_TIMES_BIG

  PURE FUNCTION BIG_BASE_TO_POWER (N)  RESULT (B)

    INTEGER, INTENT (IN) :: N
    TYPE (BIG_INTEGER) :: B

    IF (N < 0) THEN
       B = 0
    ELSE IF (N >= NR_OF_DIGITS) THEN
       B = HUGE (B)
    ELSE
       B % DIGIT = 0
       B % DIGIT (N) = 1
    END IF

  END FUNCTION BIG_BASE_TO_POWER

  PURE FUNCTION BIG_DIV_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: BI
    INTEGER :: N, TEMP_INT, REMAINDER

    IF (I == 0) THEN
       BI = HUGE (BI)
    ELSE IF (I < BASE) THEN
       BI % DIGIT = 0
       REMAINDER = 0
       DO N = MSD(B), 0, -1
          TEMP_INT = BASE * REMAINDER + B % DIGIT (N)
          BI % DIGIT (N) = TEMP_INT / I
          REMAINDER = MODULO (TEMP_INT, I)
       END DO
    ELSE
       BI = B / BIG (I)
    END IF

  END FUNCTION BIG_DIV_INT

  PURE FUNCTION INT_DIV_BIG (I, B) RESULT (IB)

    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: IB

    IB = BIG (I) / B

  END FUNCTION INT_DIV_BIG

  PURE FUNCTION BIG_DIV_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    TYPE (BIG_INTEGER) :: BB

    TYPE (BIG_INTEGER) :: TX, TY

    INTEGER :: MSDX, MSDY, IX, IY
    INTEGER :: V1, V2, U0, U1, U2
    INTEGER :: DD, BI, CAR, BAR, PRD

    IF (Y == 0) THEN
       BB = HUGE (BB)
       RETURN
    END IF

    MSDX = MSD(X)
    MSDY = MSD(Y)

    IF (MSDY == 0) THEN
       BB = X / Y % DIGIT (0)
       RETURN
    END IF

    BB % DIGIT = 0

    IF (MSDY < MSDY) THEN
       RETURN
    END IF

    TX = X
    TY = Y

    CAR = 0
    BAR = 0
    PRD = 0
    DD = BASE / (TY % DIGIT (MSDY) + 1)
    IF (DD /= 1) THEN
       DO IX = 0, MSDX
          TX % DIGIT (IX) = TX % DIGIT (IX) * DD + CAR
          CAR = TX % DIGIT (IX) / BASE
          TX % DIGIT (IX) = TX % DIGIT (IX) - BASE * CAR
       END DO
       TX % DIGIT (MSDX+1) = CAR
       CAR = 0
       DO IY = 0, MSDY
          TY % DIGIT (IY) = TY % DIGIT (IY) * DD + CAR
          CAR = TY % DIGIT (IY) / BASE
          TY % DIGIT (IY) = TY % DIGIT (IY) - BASE * CAR
       END DO
    END IF

    MSDX = MSDX + 1

    V1 = TY % DIGIT (MSDY)
    V2 = TY % DIGIT (MSDY-1)
    BB % DIGIT = 0

    DO MSDX = MSDX, MSDY + 1, -1

       U0 = TX % DIGIT (MSDX)
       U1 = TX % DIGIT (MSDX-1)
       U2 = TX % DIGIT (MSDX-2)

       IF (U0 == V1) THEN
          BI = BASE - 1
       ELSE
          BI = (U0*BASE + U1) / V1
       END IF

       DO
          IF (V2*BI <= (U0*BASE + U1 - BI*V1) * BASE + U2) THEN
             EXIT
          END IF
          BI = BI - 1
       END DO

       IF (BI > 0) THEN
          CAR = 0
          BAR = 0
          IX = MSDX - MSDY - 1
          DO IY = 0, MSDY
             PRD = BI * TY % DIGIT (IY) + CAR
             CAR = PRD / BASE
             PRD = PRD - BASE * CAR
             TX % DIGIT (IX) = TX % DIGIT (IX) - (PRD + BAR)
             IF (TX % DIGIT (IX) < 0) THEN
                BAR = 1
                TX % DIGIT (IX) = TX % DIGIT (IX) + BASE
             ELSE
                BAR = 0
             END IF
             IX = IX + 1
          END DO
          IF (TX % DIGIT (MSDX) < CAR + BAR) THEN
             CAR = 0
             BI = BI -1
             IX = MSDX - MSDY - 1
             DO IY = 0, MSDY
                TX % DIGIT (IX) = TX % DIGIT (IX) + TY % DIGIT (IY) + CAR
                IF (TX % DIGIT (IX) > BASE) THEN
                   CAR = 1
                   TX % DIGIT (IX) = TX % DIGIT (IX) - BASE
                ELSE
                   CAR = 0
                END IF
                IX = IX + 1
             END DO
          END IF
       END IF
       TX % DIGIT (MSDX) = 0
       BB % DIGIT (1:NR_OF_DIGITS) = BB % DIGIT (0:NR_OF_DIGITS-1)
       BB % DIGIT (0) = BI
    END DO

  END FUNCTION BIG_DIV_BIG

  PURE FUNCTION MODULO_BIG_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    INTEGER :: BI
    INTEGER :: N

    IF (I == 0) THEN
       BI = HUGE (BI)
    ELSE IF (I < BASE) THEN
       BI = 0
       DO N = MSD(B), 0, -1
          BI = MODULO (BASE * BI + B % DIGIT (N), I)
       END DO
    ELSE
       BI = MODULO (B, BIG (I))
    END IF

  END FUNCTION MODULO_BIG_INT

  PURE FUNCTION MODULO_INT_BIG (II, B) RESULT (IB)

    INTEGER, INTENT (IN) :: II
    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: IB

    IB = MODULO (BIG (II), B)

  END FUNCTION MODULO_INT_BIG

  PURE FUNCTION MODULO_BIG_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    TYPE (BIG_INTEGER) :: BB

    BB = X - X / Y * Y

  END FUNCTION MODULO_BIG_BIG

  PURE FUNCTION BIG_EQ_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) == I

  END FUNCTION BIG_EQ_INT

  PURE FUNCTION INT_EQ_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) == I

  END FUNCTION INT_EQ_BIG

  PURE FUNCTION BIG_EQ_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB

    BB = ALL (X % DIGIT == Y % DIGIT)

  END FUNCTION BIG_EQ_BIG

  PURE FUNCTION BIG_NE_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) /= I

  END FUNCTION BIG_NE_INT

  PURE FUNCTION INT_NE_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) /= I

  END FUNCTION INT_NE_BIG

  PURE FUNCTION BIG_NE_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB

    BB = ANY (X % DIGIT /= Y % DIGIT)

  END FUNCTION BIG_NE_BIG

  PURE FUNCTION BIG_LE_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) <= I

  END FUNCTION BIG_LE_INT

  PURE FUNCTION INT_LE_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = I <= INT (B)

  END FUNCTION INT_LE_BIG

  PURE FUNCTION BIG_LE_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB
    INTEGER :: N

    BB = .TRUE.
    DO N = NR_OF_DIGITS, 0, -1
       IF (X % DIGIT (N) /= Y % DIGIT (N)) THEN
          BB = (X % DIGIT (N) < Y % DIGIT (N))
          EXIT
       END IF
    END DO

  END FUNCTION BIG_LE_BIG

  PURE FUNCTION BIG_GT_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) > I

  END FUNCTION BIG_GT_INT

  PURE FUNCTION INT_GT_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = I > INT (B)

  END FUNCTION INT_GT_BIG

  PURE FUNCTION BIG_GT_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB
    INTEGER :: N

    BB = .TRUE.
    DO N = NR_OF_DIGITS, 0, -1
       IF (X % DIGIT (N) /= Y % DIGIT (N)) THEN
          BB = (X % DIGIT (N) < Y % DIGIT (N))
          EXIT
       END IF
    END DO

    BB = .NOT. BB

  END FUNCTION BIG_GT_BIG

  PURE FUNCTION BIG_LT_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) < I

  END FUNCTION BIG_LT_INT

  PURE FUNCTION INT_LT_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = I < INT (B)

  END FUNCTION INT_LT_BIG

  PURE FUNCTION BIG_LT_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB
    INTEGER :: N

    BB = .FALSE.
    DO N = NR_OF_DIGITS, 0, -1
       IF (X % DIGIT (N) /= Y % DIGIT (N)) THEN
          BB = (X % DIGIT (N) < Y % DIGIT (N))
          EXIT
       END IF
    END DO

  END FUNCTION BIG_LT_BIG

  PURE FUNCTION BIG_GE_INT (B, I) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = INT (B) >= I

  END FUNCTION BIG_GE_INT

  PURE FUNCTION INT_GE_BIG (I, B) RESULT (BI)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    LOGICAL :: BI

    BI = I >= INT (B)

  END FUNCTION INT_GE_BIG

  PURE FUNCTION BIG_GE_BIG (X, Y) RESULT (BB)

    TYPE (BIG_INTEGER), INTENT (IN) :: X, Y
    LOGICAL :: BB
    INTEGER :: N

    BB = .FALSE.
    DO N = NR_OF_DIGITS, 0, -1
       IF (X % DIGIT (N) /= Y % DIGIT (N)) THEN
          BB = (X % DIGIT (N) < Y % DIGIT (N))
          EXIT
       END IF
    END DO

    BB = .NOT. BB

  END FUNCTION BIG_GE_BIG

  PURE FUNCTION HUGE_BIG (B) RESULT (HB)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: HB

    HB % DIGIT (0) = B % DIGIT (0) ! TO AVOID DIAGNOSTIC
    HB % DIGIT = BASE - 1
    HB % DIGIT (NR_OF_DIGITS) = 0

  END FUNCTION HUGE_BIG

  PURE FUNCTION SQRT_BIG (B) RESULT (SB)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    TYPE (BIG_INTEGER) :: SB
    TYPE (BIG_INTEGER) :: OLD_SQRT_BIG, NEW_SQRT_BIG
    INTEGER :: I, N

    N = -1
    DO I = NR_OF_DIGITS, 0, -1
       IF (B % DIGIT (I) /= 0) THEN
          N = I
          EXIT
       END IF
    END DO

    IF (N == -1) THEN
       SB = 0
    ELSE IF (N == 0) THEN
       SB = INT (SQRT (REAL (B % DIGIT (0))))
    ELSE
       OLD_SQRT_BIG = 0
       IF (MODULO (N, 2) == 0) THEN
          OLD_SQRT_BIG % DIGIT (N / 2) = INT (SQRT (REAL (B % DIGIT (N))))
       ELSE
          OLD_SQRT_BIG % DIGIT ((N - 1) / 2) =  &
               INT (SQRT (REAL (BASE * B % DIGIT (N) + B % DIGIT (N-1))))
       END IF

       DO
          NEW_SQRT_BIG = (OLD_SQRT_BIG + B / OLD_SQRT_BIG) / 2
          IF (NEW_SQRT_BIG == OLD_SQRT_BIG .OR.  &
               NEW_SQRT_BIG == OLD_SQRT_BIG + 1 .OR.  &
               NEW_SQRT_BIG == 0) THEN
             EXIT
          ELSE
             OLD_SQRT_BIG = NEW_SQRT_BIG
          END IF
       END DO
       SB = OLD_SQRT_BIG
    END IF

  END FUNCTION SQRT_BIG

  RECURSIVE FUNCTION BIG_POWER_INT (B, I)  &
       RESULT (BIG_POWER_INT_RESULT)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER, INTENT (IN) :: I
    TYPE (BIG_INTEGER) :: BIG_POWER_INT_RESULT
    TYPE (BIG_INTEGER) :: TEMP_BIG

    IF (I <= 0) THEN
       BIG_POWER_INT_RESULT = 1
    ELSE
       TEMP_BIG = BIG_POWER_INT (B, I / 2)
       IF (MODULO (I, 2) == 0) THEN
          BIG_POWER_INT_RESULT = TEMP_BIG * TEMP_BIG
       ELSE
          BIG_POWER_INT_RESULT = TEMP_BIG * TEMP_BIG * B
       END IF
    END IF

  END FUNCTION BIG_POWER_INT

  SUBROUTINE PRINT_BIG (B)

    TYPE (BIG_INTEGER), INTENT (IN) :: B

    WRITE (UNIT = *, FMT = "(A)", ADVANCE = "NO") TRIM (CHAR (B))

  END SUBROUTINE PRINT_BIG

  SUBROUTINE PRINT_BIG_BASE (B)

    TYPE (BIG_INTEGER), INTENT (IN) :: B
    INTEGER :: N

    PRINT *, "BASE: ", BASE
    DO N = NR_OF_DIGITS, 1, -1
       IF (B % DIGIT (N) /= 0) THEN
          EXIT
       END IF
    END DO
    PRINT "(10I9)", B % DIGIT (N:0:-1)

  END SUBROUTINE PRINT_BIG_BASE

  SUBROUTINE RANDOM_NUMBER_BIG (R, LOW, HIGH)

    !  GENERATE BY LINEAR CONGRUENCE X' = AX + C MOD M
    !  WHERE M IS HUGE (B) + 1 = BASE ** NR_OF_DIGITS

    TYPE (BIG_INTEGER), INTENT (OUT) :: R
    TYPE (BIG_INTEGER), INTENT (IN) :: LOW, HIGH
    INTEGER :: N, I, CARRY, PROD, SUMM
    TYPE (BIG_INTEGER), SAVE :: X = BIG_INTEGER ( (/ (1, I=0,NR_OF_DIGITS-1), 0 /) )
    TYPE (BIG_INTEGER), PARAMETER :: H = BIG_INTEGER ( (/ (BASE-1, I=0,NR_OF_DIGITS-1), 0 /) )
    INTEGER, PARAMETER :: A = 16907, C = 8191

    !  MULTIPLY BY A
    CARRY = 0
    DO N = 0, NR_OF_DIGITS - 1
       PROD = X % DIGIT (N) * A + CARRY
       X % DIGIT (N) = MODULO (PROD, BASE)
       CARRY = PROD / BASE
    END DO

    !  ADD C
    CARRY = C
    DO N = 0, NR_OF_DIGITS - 1
       SUMM = X % DIGIT (N) + CARRY
       X % DIGIT (N) = MODULO (SUMM, BASE)
       CARRY = SUMM / BASE
    END DO

    R = X / (H / (HIGH -LOW + 1)) + LOW

  END SUBROUTINE RANDOM_NUMBER_BIG

END MODULE BIG_INTEGER_MODULE


! { dg-do compile }
!
! Check that ERFC_SCALED can be used in initialization expressions
  real, parameter :: r = 100*erfc_scaled(12.7)
  integer(kind=int(r)) :: i

  real(kind=8), parameter :: r8 = 100*erfc_scaled(6.77)
  integer(kind=int(r8)) :: j

  i = 12
  j = 8
  print *, i, j

  end


      subroutine dssyax(n,a,adiag,jptr,indr,x,y)
      integer n
      integer jptr(n+1), indr(*)
      double precision a(*), adiag(n), x(n), y(n)
c     **********
c
c     Subroutine dssyax
c
c     This subroutine computes the matrix-vector product y = A*x,
c     where A is a symmetric matrix with the strict lower triangular
c     part in compressed column storage.
c
c     The subroutine statement is
c
c       subroutine dssyax(n,a,adiag,jptr,indr,x,y)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of A.
c         On exit n is unchanged.
c
c       a is a double precision array of dimension *.
c         On entry a must contain the strict lower triangular part
c            of A in compressed column storage.
c         On exit a is unchanged.
c
c       adiag is a double precision array of dimension n.
c         On entry adiag must contain the diagonal elements of A.
c         On exit adiag is unchanged.
c
c       jptr is an integer array of dimension n + 1.
c         On entry jptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            jptr(j), ... , jptr(j+1) - 1.
c         On exit jptr is unchanged.
c
c       indr is an integer array of dimension *.
c         On entry indr must contain row indices for the strict
c            lower triangular part of A in compressed column storage.
c         On exit indr is unchanged.
c
c       x is a double precision array of dimension n.
c         On entry x must contain the vector x.
c         On exit x is unchanged.
c
c       y is a double precision array of dimension n.
c         On entry y need not be specified.
c         On exit y contains the product A*x.
c
c     MINPACK-2 Project. May 1998.
c     Argonne National Laboratory.
c
c     **********
      double precision zero
      parameter (zero=0.0d0)

      integer i, j
      double precision sum

      do i = 1, n
         y(i) = adiag(i)*x(i)
      end do

      do j = 1, n
         sum = zero
         do i = jptr(j), jptr(j+1) - 1
            sum = sum + a(i)*x(indr(i))
            y(indr(i)) = y(indr(i)) + a(i)*x(j)
         end do
         y(j) = y(j) + sum
      end do

      return

      end


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2015 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module solves a boundary element method for bodies using the potential formulation,
!   and by removing irregular frequencies.
!   It works with a finite or infinite fluid depth. This module is using
!   the lower order panel method. It assumes a discretization of both the body and the
!   interior of the free surface. The contour of the interior free surface is determined using
!   waterline segments. Waterline is the line where the hull of a ship meets the surface of the water,
!   in concept or reality (See http://en.wikipedia.org/wiki/Waterline)
!   Panels from both discretisation are used to derive the a system
!   of two simultaneous linear equation to solve. The main reference for the implementation is R1
!
!                       REFERENCES
!   R1:  Irregular frequency removal from the boundary integral equation for the wave-body problem
!        http://dspace.mit.edu/bitstream/handle/1721.1/11691/32279180.pdf?sequence=1
!
!   Contest Irregular Frequencies Assembly
!
!   @author TCSASSEMBLER
!   @version 1.0

MODULE SOLVE_BEM_IRREGULAR

    USE COMPUTE_GREEN_FD
    USE COMPUTE_GREEN_INFD
    USE COM_VAR
    USE COMMON_TYPE
    USE OUTPUT
    USE UTILITY
    USE COMPUTE_GREEN_FREESURFACE

    IMPLICIT NONE

    CONTAINS

    SUBROUTINE SOLVE_POTENTIAL_IRREGULAR(param, PRESSURE, PHI, MeshFS, Switch_FS,  Switch_Potential, NDS, Force, &
        & out_potential)
        !  This subroutine solves a boundary element method for a finite or infinite depth using
        !   a three dimensional dipoles implementation.
        !  Arguments
        !  param (input/temporary vars): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        !  PRESSURE (output) The array to contain the pressure at the centroid of each patch
        !  PHI (output) The array to contain the potential in the fluid domain of the given point
        !  MeshFS (input) Mesh structure used to get the points for which to compute the potential in the fluid
        !                 domain
        !  Switch_FS (input): Whether or not to compute the potential at the fluid domain
        !  Switch_Potential (input) : Whether or not to save the pressure
        !  NDS (input):  Array containing the nds at each center of a patch
        !  Force (output): Array to contain the computed dynamic forces
        !  out_potential (output): Array to contain the computed potential/pressure/centroid values

        REAL:: xx, yy, zz
        REAL:: PCOS,PSIN
        INTEGER:: ISP, IFP
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: ZIJ
        COMPLEX, DIMENSION(:), POINTER :: ZPB,ZPS
        TYPE(TMesh) :: MeshFS
        COMPLEX :: PRESSURE(:)
        COMPLEX :: PHI(:)
        INTEGER :: Switch_FS, Switch_Potential
        TYPE(TempVar), POINTER :: SolverVar
        REAL, POINTER :: SP1,SM1,SP2,SM2
        REAL, POINTER :: VSXP1,VSXP2,VSYP1,VSYP2,VSZP1,VSZP2
        REAL, POINTER :: VSXM1,VSXM2,VSYM1,VSYM2,VSZM1,VSZM2
        REAL,DIMENSION(:,:) :: NDS
        COMPLEX,DIMENSION(:) :: Force
        COMPLEX,PARAMETER :: CII=CMPLX(0.,1.)
        COMPLEX,PARAMETER :: CRR=CMPLX(0.,1.)
        REAL :: out_potential(:)
        REAL, PARAMETER :: PI=4.*ATAN(1.)
        TYPE(ParamsCommonInf), TARGET :: param
        COMPLEX,DIMENSION(:),ALLOCATABLE :: NVEL ! normal velocity at centroid of a patch
        INTEGER:: I, J
        INTEGER, DIMENSION(:), ALLOCATABLE:: IPIV
        REAL, DIMENSION(:), ALLOCATABLE:: S, RWORK
        INTEGER:: INFO, RANK, LWORK
        COMPLEX, DIMENSION(:), ALLOCATABLE:: WORK
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: A
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: B

        SolverVar => param%SolverVar

        ZPB => SolverVar%ZPB
        ZPS => SolverVar%ZPS

        SP1 => SolverVar%SP1
        SM1 => SolverVar%SM1
        SP2 => SolverVar%SP2
        SM2 => SolverVar%SM2
        VSXP1 => SolverVar%VSXP1
        VSXP2 => SolverVar%VSXP2
        VSYP1 => SolverVar%VSYP1
        VSYP2 => SolverVar%VSYP2
        VSZP1 => SolverVar%VSZP1
        VSZP2 => SolverVar%VSZP2
        VSXM1 => SolverVar%VSXM1
        VSXM2 => SolverVar%VSXM2
        VSYM1 => SolverVar%VSYM1
        VSYM2 => SolverVar%VSYM2
        VSZM1 => SolverVar%VSZM1
        VSZM2 => SolverVar%VSZM2

        ALLOCATE(ZIJ(IMX, IMX + 1))
        ALLOCATE(IPIV(IMX))
        ALLOCATE(A(IMX, IMX))
        ALLOCATE(B(IMX, 1))

        ZIJ = cmplx(0., 0.)

        NVEL = param%NVEL

        xx = 0.
        yy = 0.
        zz = 0.

        CALL COMPUTE_NEXP(param)

        Force = 0.

        DO ISP=1,IMX

            DO IFP=1,IMX

                ! Using left hand side of equation (5.33) or (5.34)  Reference
                    ! integral of green function derivative with respect to normal of field point
                    IF(param%is_infinite == 1)  THEN ! infinite case
                        call VAVINFD(2, 1,XG(ISP),YG(ISP),ZG(ISP),ISP,IFP, SolverVar)  !1/r+1/r1

                        call VNSINFD(2, 1,ISP,IFP,XG(ISP),YG(ISP),ZG(ISP), SolverVar)

                    ELSE
                        call VAVFD(2, 2,XG(ISP),YG(ISP),ZG(ISP),ISP,IFP, param%SolverVar)  !1/r+1/r1
                        call VNSFD(2, param%AM0,param%AMH,param%NEXP,ISP,IFP,XG(ISP),YG(ISP),ZG(ISP),  param%SolverVar)

                    END IF

                    PCOS = VSXM1*XN(IFP) + VSYM1*YN(IFP) + VSZM1*ZN(IFP)
                    PSIN = VSXM2*XN(IFP) + VSYM2*YN(IFP) + VSZM2*ZN(IFP)

                    ! Using left hand side of equation (5.33) or (5.34)  Reference second or third term
                    ZIJ(ISP, IFP) =  ZIJ(ISP, IFP) +  CMPLX(PCOS,PSIN) * (-4*PI)

                    IF(ISP == IFP) THEN

                        IF(param%is_interior_domain(ISP) == 1) THEN

                            ! Using left hand side of equation (5.34)  Reference, first term
                        ZIJ(ISP, IFP) =  ZIJ(ISP, IFP) - 4*PI*CRR
                        ELSE

                        ! Using left hand side of equation (5.33)  Reference, first term
                        ZIJ(ISP, IFP) =  ZIJ(ISP, IFP) + 2*PI*CRR

                        ENDIF

                    END IF

                    ! Using right hand side of equation (5.33) or (5.34)  Reference
                    ! No need to recompute green function here. It has already beeen computed
                    ! in previous instructions.

                    ZIJ(ISP, IMX + 1 ) = ZIJ(ISP, IMX + 1 ) + NVEL(IFP)*CMPLX(SP1 + SM1, SP2 + SM2)*(-4*PI)

                    IF(ZIJ(ISP, IFP) /= ZIJ(ISP, IFP)) THEN

                        ZIJ(ISP, IFP) = 1e-4

                    ENDIF

                    IF(ZIJ(ISP, IMX + 1 ) /= ZIJ(ISP, IMX + 1 )) THEN

                        ZIJ(ISP, IMX + 1 ) = 1e-4

                    ENDIF

            END DO

        END DO

        ! Setting up matrix A and B of the linear equations Ax=B
        DO I = 1,IMX

            DO J=1,IMX

                A(I, J) = ZIJ(I,J)

            END DO

            B(I, 1) = ZIJ(I, IMX + 1)

        END DO

        !------------------------------------------------!
        ! Using lapack linear solver with partial pivoting
        CALL CGESV( IMX, 1, A, IMX, IPIV, B, IMX, INFO )

        IF( INFO.GT.0 ) THEN
            WRITE(*,*)'The diagonal element of the triangular factor of A,'
            WRITE(*,*)'U(',INFO,',',INFO,') is zero, so that'
            WRITE(*,*)'A is singular; the solution could not be computed.'
            STOP
        END IF
        !------------------------------------------------!

        DO I=1,IMX
            ZPS(I) = cmplx(0., 0.)
            ZPB(I) = B(I, 1)
        END DO

           !       Assemble pressure at patches centroid
        DO J=1,IMX
            PRESSURE(J) = RHO*CII*param%W*ZPB(J) !*AIRE(i)
        END DO

          !       Save free surface elevation
        IF (Switch_FS.EQ.1) THEN
            DO j=1,MeshFS%Npoints
                PHI(j) = COMPUTE_POTENTIAL_DOMAIN_IRREGULAR(MeshFS%X(1,j),MeshFS%X(2,j),0.,param, B)
            END DO
        END IF

         !       Save output
        IF (Switch_Potential.EQ.1) THEN
            CALL SAVE_POTENTIAL(PRESSURE, out_potential)
        END IF

        !       Calculate force coefficients at centroid of panel
        DO i=1,param%n_integration
            DO j=1,param%NpanIsy
                Force(i) = Force(i) - PRESSURE(j)*NDS(i,j)
            END DO
        END DO

        ! Deallocate allocated arrays
        if (allocated(ZIJ)) deallocate(ZIJ)
        if (allocated(IPIV)) deallocate(IPIV)
        if (allocated(A)) deallocate(A)
        if (allocated(B)) deallocate(B)

    END SUBROUTINE SOLVE_POTENTIAL_IRREGULAR

    COMPLEX FUNCTION COMPUTE_POTENTIAL_DOMAIN_IRREGULAR(xx, yy, zz, param, B)
        ! Compute the potential at a given point in the fluid domain or in the boundary
        ! for the potential formulation with irregular frequency
        ! Arguments
        ! xx,yy,zz: Cartesian coordinate of the given point
        ! B: Array, solution of the linear system. Contain the phi coefficients
        ! param: common variables that contains useful variables
        !        See param definition for explanation of the member used here
        TYPE(ParamsCommonInf), TARGET :: param
        COMPLEX :: tmp
        REAL :: xx, yy, zz ! The coordinate of a point in the domain of the given patch. Point is on the free surface
        REAL :: uf,vf
        INTEGER:: IFP, ISP
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: B ! The solution to the linear system
        TYPE(TempVar), POINTER :: SolverVar
        REAL, POINTER :: SP1,SM1,SP2,SM2
        REAL, POINTER :: VSXP1,VSXP2,VSYP1,VSYP2,VSZP1,VSZP2
        REAL, POINTER :: VSXM1,VSXM2,VSYM1,VSYM2,VSZM1,VSZM2
        REAL:: PCOS,PSIN
        REAL, PARAMETER :: PI=4.*ATAN(1.)

        SolverVar => param%SolverVar

        SP1 => SolverVar%SP1
        SM1 => SolverVar%SM1
        SP2 => SolverVar%SP2
        SM2 => SolverVar%SM2
        VSXP1 => SolverVar%VSXP1
        VSXP2 => SolverVar%VSXP2
        VSYP1 => SolverVar%VSYP1
        VSYP2 => SolverVar%VSYP2
        VSZP1 => SolverVar%VSZP1
        VSZP2 => SolverVar%VSZP2
        VSXM1 => SolverVar%VSXM1
        VSXM2 => SolverVar%VSXM2
        VSYM1 => SolverVar%VSYM1
        VSYM2 => SolverVar%VSYM2
        VSZM1 => SolverVar%VSZM1
        VSZM2 => SolverVar%VSZM2

        COMPUTE_POTENTIAL_DOMAIN_IRREGULAR = cmplx(0, 0)

        ISP = 1  ! Disable ISP panel

        DO IFP=1,IMX

            SP1 = 0.
            SP2 = 0.
            SM1 = 0.
            SM2 = 0.
            VSXM1 = 0.
            VSYM1 = 0.
            VSZM1 = 0.
            VSXM2 = 0.
            VSYM2 = 0.
            VSZM2 = 0.
            ! Using right hand side of equation (5.34)  Reference
            IF(param%is_infinite == 1)  THEN ! infinite case
                CALL VVV(2, 1, IFP, xx, yy, zz, SolverVar) ! finite part
                CALL VNV(2, IFP, xx, yy, zz, SolverVar)  !infinite part

            ELSE
                CALL VVV(2, 2, IFP, xx, yy, zz, SolverVar)
                CALL VNVF(2, param%AM0, param%AMH, param%NEXP, IFP, xx, yy, zz, SolverVar)

            END IF

            tmp =  param%NVEL(IFP)*CMPLX(SP1 + SM1, SP2 + SM2)*(-4*PI)

            ! Using left hand side of equation (5.34)  Reference, second or third term
            ! integral of green function derivative with respect to normal of field point
            ! No need to recompute green function here. It has already beeen computed
            ! in previous instructions.

            PCOS = VSXM1*XN(IFP) + VSYM1*YN(IFP) + VSZM1*ZN(IFP)
            PSIN = VSXM2*XN(IFP) + VSYM2*YN(IFP) + VSZM2*ZN(IFP)
            tmp =  tmp - B(IFP, 1)*CMPLX(PCOS, PSIN)*(-4*PI)

            COMPUTE_POTENTIAL_DOMAIN_IRREGULAR = COMPUTE_POTENTIAL_DOMAIN_IRREGULAR + tmp
        END DO

        ! Dividing by constant term in front of first term in equation (5.34)
        COMPUTE_POTENTIAL_DOMAIN_IRREGULAR = COMPUTE_POTENTIAL_DOMAIN_IRREGULAR/(-4.*PI)

    END FUNCTION COMPUTE_POTENTIAL_DOMAIN_IRREGULAR

END MODULE SOLVE_BEM_IRREGULAR


c--------------------------------
      function sigz2(r)
      parameter(nrmax=1000)
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea
      common /diskpars/ sigr0, disksr, nrdisk
      common /splines/ rr(0:nrmax),fdrat(0:nrmax),drat2(0:nrmax),
     +              fszrat(0:nrmax), szrat2(0:nrmax), nrspl

c velocity dispersion is fixed so that at a height of diskz the
c density of an isothermal component has fallen by sech(1)**2=0.419974
      psizh=pot(r,zdisk)
      psi0=pot(r,0.0)
      truesigz2=(psi0-psizh)/log(0.419974)

      call splintd(rr(0),fszrat(0),szrat2(0),nrspl+1,r,fcor)
      if(fcor.lt.0) fcor=1
      sigz2=truesigz2*fcor
!      print*,'b',fcor,psi0,psizh,r
      return
      end


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      written by the UFO converter
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE COUP3()

      IMPLICIT NONE
      INCLUDE 'model_functions.inc'

      DOUBLE PRECISION PI, ZERO
      PARAMETER  (PI=3.141592653589793D0)
      PARAMETER  (ZERO=0D0)
      INCLUDE 'input.inc'
      INCLUDE 'coupl.inc'
      UV_GQQB = MDL_COMPLEXI*MDL_G_UVB_FIN_*G
      UV_GQQT = MDL_COMPLEXI*MDL_G_UVT_FIN_*G
      UV_BMASS = MDL_BMASS_UV_FIN_
      UV_TMASS = MDL_TMASS_UV_FIN_
      UVWFCT_B_0 = COND(DCMPLX(MDL_MB),DCMPLX(0.000000D+00),DCMPLX(
     $ -((MDL_G__EXP__2)/(2.000000D+00*1.600000D+01*PI**2))*MDL_CF
     $ *(4.000000D+00-3.000000D+00*REGLOG(DCMPLX(MDL_MB__EXP__2
     $ /MDL_MU_R__EXP__2)))))
      UVWFCT_T_0 = COND(DCMPLX(MDL_MT),DCMPLX(0.000000D+00),DCMPLX(
     $ -((MDL_G__EXP__2)/(2.000000D+00*1.600000D+01*PI**2))*MDL_CF
     $ *(4.000000D+00-3.000000D+00*REGLOG(DCMPLX(MDL_MT__EXP__2
     $ /MDL_MU_R__EXP__2)))))
      UVWFCT_G_1 = COND(DCMPLX(MDL_MB),DCMPLX(0.000000D+00)
     $ ,DCMPLX(((MDL_G__EXP__2)/(2.000000D+00*4.800000D+01*PI**2))
     $ *4.000000D+00*MDL_TF*REGLOG(DCMPLX(MDL_MB__EXP__2
     $ /MDL_MU_R__EXP__2))))
      UVWFCT_G_2 = COND(DCMPLX(MDL_MT),DCMPLX(0.000000D+00)
     $ ,DCMPLX(((MDL_G__EXP__2)/(2.000000D+00*4.800000D+01*PI**2))
     $ *4.000000D+00*MDL_TF*REGLOG(DCMPLX(MDL_MT__EXP__2
     $ /MDL_MU_R__EXP__2))))
      END


      subroutine genff(nperms,p,wt,msq)
c--- final-final subtraction.
c--- nperms is an argument between 1 and 2
c--- this routine calculates the jacobian associated with calculating
c--- a given final state, by contracting a final-final dipole
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      include 'debug.f'
      integer i4,i5,j,k,nperms
      double precision p(mxpart,4),z,dot,q(mxpart,4),
     . msq(-nf:nf,-nf:nf),wt4,wt5_4
      double precision facq,wt,s3i4,y,omy,jacbit,wt0
      parameter(wt0=1d0/eight/pisq)
      integer,parameter:: j4(2)=(/4,5/)
      integer,parameter:: j5(2)=(/5,4/)

      i4=j4(nperms)
      i5=j5(nperms)

c      write(6,*) 'genff:nperms',nperms
c      write(6,*) 'genff:i4',i4
c      write(6,*) 'genff:i5',i5

c first of calculate the variable's which one started with
c---nb all incoming
      s3i4=two*dot(p,3,i4)
      y=dot(p,3,i4)/(dot(p,3,i4)+dot(p,3,i5)+dot(p,i4,i5))
      z=dot(p,3,i5)/(dot(p,3,i5)+dot(p,i4,i5))
      omy=one-y

      do j=1,4
      q(1,j)=p(1,j)
      q(2,j)=p(2,j)
      q(3,j)=p(3,j)
      q(6,j)=p(6,j)
      q(7,j)=p(7,j)
      q(i4,j)=p(i4,j)+p(3,j)-p(i5,j)*y/omy
      q(i5,j)=p(i5,j)/omy
      enddo

      jacbit=four*sqrt(y)/(0.5d0/sqrt(z)+0.5d0/sqrt(1d0-z))
      wt5_4=wt0*omy*dot(q,4,5)*jacbit

      call wt4gen(q,wt4)
c---calculate total weight
      wt=wt4*wt5_4

      if (debug) then
      write(6,*) 'wt5_4 in genff',wt5_4
      write(6,*) 'wt4 in genff',wt4
      write(6,*) 'wt in genff',wt
      endif

      call qqb_wbb(q,msq)

      facq=-gsq/s3i4*(two/(one-z*(one-y))-one-z)

      do j=-nf,nf
      do k=-nf,nf
      msq(j,k)=0d0
      if     ((j .gt. 0) .and. (k .lt. 0)) then
      msq(j,k)=facq*msq(j,k)
      elseif ((j .lt. 0) .and. (k .gt. 0)) then
      msq(j,k)=facq*msq(j,k)
      endif
      enddo
      enddo

      return
      end


PROGRAM nature_obs_maooam

  USE params, only: ndim, dt, tw, t_trans, t_run, writeout
  USE params, only: natm, noc ! LUYU: add for solo
  USE params, only: tw_da
  USE aotensor_def, only: init_aotensor
  USE IC_def, only: load_IC, IC
  USE integrator, only: init_integrator,step
  USE stat
  USE m_mt, only: randn
  IMPLICIT NONE

  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: X       !< State variable in the model
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: Xnew    !< Updated state variable
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: R
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: err
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: y_obs
  REAL(KIND=8) :: t=0.D0                             !< Time variable
  REAL(KIND=8) :: t_up

  INTEGER :: i,j,k,n

  PRINT*, 'Model MAOOAM v1.3'
  PRINT*, 'Loading information...'

  CALL init_aotensor    ! Compute the tensor

  CALL load_IC          ! Load the initial condition

  CALL init_integrator  ! Initialize the integrator

  t_up=dt/t_trans*100.D0

  ALLOCATE(X(0:ndim),Xnew(0:ndim))

  X=IC

  PRINT*, 'Starting the transient time evolution...'

  DO WHILE (t<t_trans)

     CALL step(X,t,dt,Xnew)
     X=Xnew

     IF (mod(t/t_trans*100.D0,0.1)<t_up) WRITE(*,'(" Progress ",F6.1," %",A,$)') t/t_trans*100.D0,char(13)
  END DO

  PRINT*, 'Starting the time evolution...'

  CALL init_stat

  IF (writeout) THEN
      OPEN(100,file='nature.dat')
      OPEN(102,file='yobs.dat')
  END IF

  t=0.D0
  t_up=dt/t_run*100.D0

  ! Read R matrix Climatology
  ALLOCATE(R(ndim))
  ALLOCATE(err(ndim))
  ALLOCATE(y_obs(2*natm))
  PRINT*, 'Read R matrix....'
  OPEN(103,file="fort.202",action="read",form="formatted",access="sequential")
  DO n = 1, ndim
    READ(103,"(10000(D24.17,1x))") R(n)
    !print*, "n, R(n)=", n, R(n)
  ENDDO
  CLOSE(103)
  PRINT*, 'Finish reading R matrix...'

  IF (writeout) THEN
      WRITE(100,*) t,X(1:ndim)
      CALL randn(ndim,err)
      DO n = 1,2*natm
        y_obs(n) = X(n) + err(n)*R(n)*0.1 ! Use 10% climatology.
        !print*, y_obs(n)
      END DO
      WRITE(102,*) t,y_obs(1:2*natm)
  END IF

  DO WHILE (t<t_run)

     CALL step(X,t,dt,Xnew)
     X=Xnew

     IF (mod(t,tw)<dt) THEN
        IF (writeout) WRITE(100,*) t,X(1:ndim)
        CALL acc(X)

        CALL randn(ndim,err)
        DO n = 1,2*natm
          y_obs(n) = X(n) + err(n)*R(n)*0.1 ! Use 10% climatology
        END DO
        WRITE(102,*) t,y_obs(1:2*natm)
     END IF

     IF (mod(t/t_run*100.D0,0.1)<t_up) WRITE(*,'(" Progress ",F6.1," %",A,$)') t/t_run*100.D0,char(13)
  END DO

  PRINT*, 'Evolution finished.'

  IF (writeout) THEN
      CLOSE(100)
      CLOSE(102)
  END IF

END PROGRAM nature_obs_maooam


      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRI computes the inverse of a matrix using the LU factorization
*  computed by DGETRF.
*
*  This method inverts U and then computes inv(A) by solving the system
*  inv(A)*L = inv(U) for inv(A).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the factors L and U from the factorization
*          A = P*L*U as computed by DGETRF.
*          On exit, if INFO = 0, the inverse of the original matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimal performance LWORK >= N*NB, where NB is
*          the optimal blocksize returned by ILAENV.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
*                singular and its inverse could not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
     $                   NBMIN, NN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
*     and the inverse is not computed.
*
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
*
*     Solve the equation inv(A)*L = inv(U) for inv(A).
*
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
*        Use unblocked code.
*
         DO 20 J = N, 1, -1
*
*           Copy current column of L to WORK and replace with zeros.
*
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
*
*           Compute current column of inv(A).
*
            IF( J.LT.N )
     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
*
*        Use blocked code.
*
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
*
*           Copy current block column of L to WORK and replace with
*           zeros.
*
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
*
*           Compute current block column of inv(A).
*
            IF( J+JB.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
*
*     Apply column interchanges.
*
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J )
     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGETRI
*
      END
      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTI2 computes the inverse of a real upper or lower triangular
*  matrix.
*
*  This is the Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A is upper or lower triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  DIAG    (input) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading n by n upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n by n lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL, DTRMV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTI2', -INFO )
         RETURN
      END IF
*
      IF( UPPER ) THEN
*
*        Compute inverse of upper triangular matrix.
*
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
*
*           Compute elements 1:j-1 of j-th column.
*
            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
     $                  A( 1, J ), 1 )
            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
*
*        Compute inverse of lower triangular matrix.
*
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
*
*              Compute elements j+1:n of j-th column.
*
               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of DTRTI2
*
      END
      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTRI computes the inverse of a real upper or lower triangular
*  matrix A.
*
*  This is the Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  A is upper triangular;
*          = 'L':  A is lower triangular.
*
*  DIAG    (input) CHARACTER*1
*          = 'N':  A is non-unit triangular;
*          = 'U':  A is unit triangular.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading N-by-N upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
*               matrix is singular and its inverse can not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JB, NB, NN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Check for singularity if non-unit.
*
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
         INFO = 0
      END IF
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
*        Use unblocked code
*
         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
      ELSE
*
*        Use blocked code
*
         IF( UPPER ) THEN
*
*           Compute inverse of upper triangular matrix
*
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
*
*              Compute rows 1:j-1 of current block column
*
               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
   20       CONTINUE
         ELSE
*
*           Compute inverse of lower triangular matrix
*
            NN = ( ( N-1 ) / NB )*NB + 1
            DO 30 J = NN, 1, -NB
               JB = MIN( NB, N-J+1 )
               IF( J+JB.LE.N ) THEN
*
*                 Compute rows j+jb:n of current block column
*
                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
     $                        A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
     $                        A( J+JB, J ), LDA )
               END IF
*
*              Compute inverse of current diagonal block
*
               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
   30       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DTRTRI
*
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
*     ..
*
*  Purpose
*  =======
*
*  IEEECK is called from the ILAENV to verify that Infinity and
*  possibly NaN arithmetic is safe (i.e. will not trap).
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies whether to test just for inifinity arithmetic
*          or whether to test for infinity and NaN arithmetic.
*          = 0: Verify infinity arithmetic only.
*          = 1: Verify infinity and NaN arithmetic.
*
*  ZERO    (input) REAL
*          Must contain the value 0.0
*          This is passed to prevent the compiler from optimizing
*          away this code.
*
*  ONE     (input) REAL
*          Must contain the value 1.0
*          This is passed to prevent the compiler from optimizing
*          away this code.
*
*  RETURN VALUE:  INTEGER
*          = 0:  Arithmetic failed to produce the correct answers
*          = 1:  Arithmetic produced the correct answers
*
*     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
     $                   NEGZRO, NEWZRO, POSINF
*     ..
*     .. Executable Statements ..
      IEEECK = 1
*
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
*
*
*
*
*     Return if we were only asked to check infinity arithmetic
*
      IF( ISPEC.EQ.0 )
     $   RETURN
*
      NAN1 = POSINF + NEGINF
*
      NAN2 = POSINF / NEGINF
*
      NAN3 = POSINF / POSINF
*
      NAN4 = POSINF*ZERO
*
      NAN5 = NEGINF*NEGZRO
*
      NAN6 = NAN5*0.0
*
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
*
      RETURN
      END

c      END

c      LOGICAL          FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
c      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
* =====================================================================
*
*     .. Intrinsic Functions ..
c      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
c      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
c      LSAME = CA.EQ.CB
c      IF( LSAME )
c     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
c      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
c      INTA = ICHAR( CA )
c      INTB = ICHAR( CB )
*
c      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
c         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
c         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
c      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
c         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
c     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
c     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
c         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
c     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
c     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
c      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
c         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
c         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
c      END IF
c      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
c      END
c$$$      SUBROUTINE XERBLA( SRNAME, INFO )
c$$$*
c$$$*  -- LAPACK auxiliary routine (version 3.0) --
c$$$*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
c$$$*     Courant Institute, Argonne National Lab, and Rice University
c$$$*     September 30, 1994
c$$$*
c$$$*     .. Scalar Arguments ..
c$$$      CHARACTER*6        SRNAME
c$$$      INTEGER            INFO
c$$$*     ..
c$$$*
c$$$*  Purpose
c$$$*  =======
c$$$*
c$$$*  XERBLA  is an error handler for the LAPACK routines.
c$$$*  It is called by an LAPACK routine if an input parameter has an
c$$$*  invalid value.  A message is printed and execution stops.
c$$$*
c$$$*  Installers may consider modifying the STOP statement in order to
c$$$*  call system-specific exception-handling facilities.
c$$$*
c$$$*  Arguments
c$$$*  =========
c$$$*
c$$$*  SRNAME  (input) CHARACTER*6
c$$$*          The name of the routine which called XERBLA.
c$$$*
c$$$*  INFO    (input) INTEGER
c$$$*          The position of the invalid parameter in the parameter list
c$$$*          of the calling routine.
c$$$*
c$$$* =====================================================================
c$$$*
c$$$*     .. Executable Statements ..
c$$$*
c$$$      WRITE( *, FMT = 9999 )SRNAME, INFO
c$$$*
c$$$      STOP
c$$$*
c$$$ 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
c$$$     $      'an illegal value' )
c$$$*
c$$$*     End of XERBLA
c$$$*
c$$$      END


program t
! test for e, en, es, and p in format-item-list
  real::a=3.141592654
5678 format (3p,E15.7,-3p,E15.7e4,0p,EN15.5,EN10.3e5,ES10.3,ES10.3e1)
  write (*,5678) a,a,a,a,a,a
endprogram t


! The Computer Language Benchmarks Game
! https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
!
! Contributed by Tyler Funnell
!   Based heavily on C version by Mr Ledrug, and Fortran version by
!   Andrei Jirnyi
! compilation: ifort -O2 -xHost -ipo pidigits.f90 -lgmp

module gmp_mod
  ! declaring the GMP functions...
  use iso_c_binding
  type, bind(C) :: mpz_t
     private
     integer :: mp_alloc
     integer :: mp_size
     type(c_ptr) :: mp_d  ! a pointer
  end type mpz_t

  interface
     ! int mpz_cmp (mpz_t op1, mpz_t op2)
     integer(c_int) function  mpz_cmp(op1, op2) bind(C, name='__gmpz_cmp')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
     end function mpz_cmp

     ! void mpz_init (mpz_t integer)
     subroutine mpz_init(op) bind(C,name='__gmpz_init')
       import
       type(mpz_t), intent(inout) :: op
     end subroutine mpz_init

     ! void mpz_init_set_ui (mpz_t rop, unsigned long int op)
     subroutine mpz_init_set_ui(op, N) bind(C, name='__gmpz_init_set_ui')
       import
       type(mpz_t), intent(inout) :: op
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_init_set_ui

     ! unsigned long int mpz_get_ui (mpz_t op)
     integer function  mpz_get_ui(op1) bind(C, name='__gmpz_get_ui')
       import
       type(mpz_t), intent(inout) :: op1
     end function mpz_get_ui

     ! void mpz_add (mpz_t rop, mpz_t op1, mpz_t op2)
     subroutine mpz_add(op1, op2, op3) bind(C, name='__gmpz_add')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       type(mpz_t), intent(inout) :: op3
     end subroutine mpz_add

     ! void mpz_mul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_mul_ui(op1, op2, N) bind(C, name='__gmpz_mul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_mul_ui

     ! void mpz_submul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_submul_ui(op1, op2, N) bind(C, name='__gmpz_submul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_submul_ui

     ! void mpz_addmul_ui (mpz_t rop, mpz_t op1, unsigned long int op2)
     subroutine mpz_addmul_ui(op1, op2, N) bind(C, name='__gmpz_addmul_ui')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       integer(c_long), value, intent(in) :: N
     end subroutine mpz_addmul_ui

     ! void mpz_tdiv_q (mpz_t rop, mpz_t op1, mpz_t op2)
     subroutine mpz_tdiv_q(op1, op2, op3) bind(C, name='__gmpz_tdiv_q')
       import
       type(mpz_t), intent(inout) :: op1
       type(mpz_t), intent(inout) :: op2
       type(mpz_t), intent(inout) :: op3
     end subroutine mpz_tdiv_q
  end interface
end module gmp_mod

program pidigits
    use iso_c_binding
    use gmp_mod
    implicit none

    type(mpz_t) :: tmp1, tmp2, acc, den, num
    integer(c_long) :: d, k = 0, i = 0, j = 0, n = 10000
    character(len=15) :: fmtstr
    integer(8) :: intout = 0
    character(len=10) :: argv, strout

    call getarg(1, argv)
    read(argv, *) n

    call mpz_init(tmp1)
    call mpz_init(tmp2)

    call mpz_init_set_ui(acc, 0_c_long)
    call mpz_init_set_ui(den, 1_c_long)
    call mpz_init_set_ui(num, 1_c_long)

    do
        k = k + 1
        call next_term(k)

        if (mpz_cmp(num, acc) > 0) cycle

        d = extract_digit(3_c_long)
        if (d /= extract_digit(4_c_long)) cycle

        i = i + 1
        j = mod(i, 10)
        intout = intout * 10 + d
        if (j == 0) then
            write(*, '(i0.10, a, i0)') intout, achar(9)//':', i
            intout = 0
        end if

        if (i >= n) exit

        call eliminate_digit(d)
    end do

    if (j /= 0) then
        write(fmtstr, '(a, i0, a)') '(i0.', j, ', a, i0)'
        write(strout, fmtstr) intout
        write(*, '(2a, i0)') adjustl(strout), achar(9)//':', i
    end if

contains
    integer function extract_digit(nth)
        integer(c_long) nth

        call mpz_mul_ui(tmp1, num, nth)
        call mpz_add(tmp2, tmp1, acc)
        call mpz_tdiv_q(tmp1, tmp2, den)
        extract_digit = mpz_get_ui(tmp1)
        return
    end function extract_digit

    subroutine next_term(k)
        integer(c_long) k
        integer(c_long) k2

        k2 = k * 2 + 1

        call mpz_addmul_ui(acc, num, 2_c_long)
        call mpz_mul_ui(acc, acc, k2)
        call mpz_mul_ui(den, den, k2)
        call mpz_mul_ui(num, num, k)
    end subroutine next_term

    subroutine eliminate_digit(d)
        integer(c_long) d

        call mpz_submul_ui(acc, den, d)
        call mpz_mul_ui(acc, acc, 10_c_long)
        call mpz_mul_ui(num, num, 10_c_long)
    end subroutine eliminate_digit
end program pidigits


      PROGRAM rates
c
c This program reads in a mechanism file, set the molar
c concentrations of some species to some values and
c compute the equilibrium constants and rate of progress
c at T=1000K
C
      implicit  double precision (a-h,o-z)
      parameter (leniwk = 40000)
      parameter (lenwk  = 40000)
      parameter (lencwk = 2000)
      parameter (nmax = 500)
      parameter (link = 5)
      parameter (lout = 7)
      dimension ickwrk(leniwk), rckwrk(lenwk)
      character cckwrk(lencwk)*16
      dimension c(nmax), q(nmax), eq_c(nmax)

      write(*,*) 'Opening chem.bin... better be there :> '
      open(unit=link, file='chem.bin', form='unformatted')
      write(*,*) 'Opening chemkin log file: ck.log'
      open(unit=lout, file='ck.log')

      call ckinit(leniwk, lenwk, lencwk, link, lout, ickwrk,
     &            rckwrk, cckwrk)
      call ckindx(ickwrk, ckwrk, mm, ns, nr, nfit)

c     set up x here
      do i = 1, ns
         c(i) = 1.0d0
      end do

      do i = 1, nr
         q(i) = 0.0d0
         eq_c(i) = 0.0d0
      end do

      tkelv  = 1000d0

      call ckqc(tkelv, c, ickwrk, rckwrk, q)
      call ckeqc(tkelv, c, ickwrk, rckwrk, eq_c)

      write(*,*) 'rates = ( '
      do i = 1, nr
         write(*,'(A4E15.7A2E15.7A2)') '   (', q(i), ',', eq_c(i), '),'
      end do
      write(*,*) '     )'
      END

c
c END OF FILE