      PROGRAM TEST

!   Version 1.4.

!   This is a sample program using the FMZM modules for doing arithmetic using the FM, IM, and ZM
!   derived types.

!   The program's output to the screen is also saved in file SampleFM.out.
!   The program checks all the results and the last line of the output file should be
!   "All results were ok."

!   These examples show various ways to use the FM package, but the methods used are not always
!   the most advanced for the sample problem.

      USE FMZM

      IMPLICIT NONE

!             Declare the multiple precision variables.  The three types are:
!             (FM) for multiple precision real
!             (IM) for multiple precision integer
!             (ZM) for multiple precision complex

      TYPE (FM), SAVE :: X1, X2, X3, X4
      TYPE (FM), SAVE, ALLOCATABLE :: A(:,:), B(:,:), V1(:), V2(:)
      TYPE (IM), SAVE :: I1, I2, I3
      TYPE (ZM), SAVE :: Z1, Z2, Z3, Z4

!             Declare the function name of a type (FM) function that will be passed as an argument
!             to a subroutine called from this program.

      TYPE (FM), EXTERNAL :: F

!             Declare the other variables (not multiple precision).

      CHARACTER(80)  :: ST1
      CHARACTER(175) :: FMT
      INTEGER :: ITER, J, K, KOUT, NERROR
      INTEGER :: SEED(7)
      DOUBLE PRECISION :: VALUE

!             Write output to the screen (unit *), and also to the file SampleFM.out.

      KOUT = 18
      OPEN (KOUT,FILE='SampleFM.out')

      NERROR = 0

!             1.  Find a root of the equation  f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Set precision to give at least 60 significant digits.

      CALL FM_SET(60)

!                 Use Newton's method with initial guess x = 3.12.
!                 Horner's rule is used to evaluate the function.

!                 X1 is the previous iterate.
!                 X2 is the current iterate.

!                 TO_FM is a function for converting other types of numbers to type FM.  Note that
!                 TO_FM(3.12) converts the REAL constant to FM, but it is accurate only to single
!                 precision, since the number 3.12 cannot be represented exactly in binary and has
!                 already been rounded to single precision.  Similarly, TO_FM(3.12D0) agrees with
!                 3.12 to double precision accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100)
!                 agrees to full FM accuracy.
!                 Here, TO_FM(3.12) would be ok, since Newton iteration will correct the error
!                 coming from single precision, but it is a good habit to use the more accurate
!                 form.

      X1 = TO_FM('3.12')

!                 Print the first iteration.

      FMT = "(//' Sample 1.  Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.'//"// &
            "' Iteration       Newton approximation')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!                 FM_FORM is a formatting subroutine.

      CALL FM_FORM('F65.60',X1,ST1)
      WRITE (*   ,"(/I10,4X,A)") 0,TRIM(ST1)
      WRITE (KOUT,"(/I10,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 X3 is f(X1).

         X3 = ((((X1-3)*X1+1)*X1-4)*X1+1)*X1-6

!                 X4 is f'(X1).

         X4 = (((5*X1-12)*X1+3)*X1-8)*X1+1

         X2 = X1 - X3/X4

!                 Print each iteration.

         CALL FM_FORM('F65.60',X2,ST1)
         WRITE (*   ,"(/I10,4X,A)") ITER,TRIM(ST1)
         WRITE (KOUT,"(/I10,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if X1 and X2 agree to over 60 places.

         X4 = ABS(X1-X2)
         IF (X4 < 1.0D-61) EXIT

!                 Set X1 = X2 for the next iteration.

         X1 = X2
      ENDDO

!                 Check the answer.

      X3 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358')

!                 It is slightly safer to do this test with .NOT. instead of
!                       IF (ABS(X3-X2) >= 1.0D-61) THEN
!                 because if the result of ABS(X3-X2) is FM's UNKNOWN value,
!                 the comparison returns false for all comparisons.

      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 1.'/)")
          WRITE (KOUT,"(/' Error in sample case number 1.'/)")
      ENDIF

!             2.  Higher Precision.  Compute the root above to 500 decimal places.

      CALL FM_SET(500)

!                 It is tempting to just say X1 = X3 here to initialize the start of the higher
!                 precision iterations to be the check value defined above.  That will not work,
!                 because precision has changed.  Most of the digits of X3 may be undefined at
!                 the new precision.
!                 The most flexible way to pad a lower precision value with zeros when raising
!                 precision is to use subroutine FM_EQU, but here it is easier to re-define X1
!                 from scratch at the new precision.

      X1 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358')

      DO ITER = 1, 10

!                 X3 is f(X1).

         X3 = ((((X1-3)*X1+1)*X1-4)*X1+1)*X1-6

!                 X4 is f'(X1).

         X4 = (((5*X1-12)*X1+3)*X1-8)*X1+1

         X2 = X1 - X3/X4

!                 Stop iterating if X1 and X2 agree to over 500 places.

         X4 = ABS(X1-X2)

!                 Compare this test to the similar one in case 1 above.
!                 For machines with 64-bit double precision, 1.0D-501 would be smaller than the
!                 smallest positive number.  So this error tolerance is converted to an FM number
!                 from character form.

         IF (X4 < TO_FM('1.0E-501')) EXIT

!                 Set X1 = X2 for the next iteration.

         X1 = X2
      ENDDO

!                 For very high precision output, it is sometimes more convenient to use FM_PRINT
!                 to format and print the numbers, since the line breaks are handled automatically.
!                 The unit number for the output, KW, and the format codes to be used, JFORM1 and
!                 JFORM2, are internal FM variables.
!                 Subroutine FM_SETVAR is used to re-define these, and the new values will remain in
!                 effect for any further calls to FM_PRINT.

!                 Other variables that can be changed and the options they control are listed in the
!                 documentation at the top of file FM.f95.

!                 Set the FM_PRINT format to F505.500

      CALL FM_SETVAR(' JFORM1 = 2 ')
      CALL FM_SETVAR(' JFORM2 = 500 ')

!                 Set the output screen width to 90 columns.

      CALL FM_SETVAR(' KSWIDE = 90 ')

      FMT = "(///' Sample 2.  Find the root above to 500 decimal places.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!                 Write to the output file.

      CALL FM_SETVAR(' KW = 18 ')
      CALL FM_PRINT(X2)

!                 Write to the screen (unit 6).

      CALL FM_SETVAR(' KW = 6 ')
      CALL FM_PRINT(X2)

!                 Check the answer.

      X3 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358190264999'  // &
                   '517954689783257450017151095811923431332682839420040840535954560118152245371'// &
                   '792881305271951017118938898212403662058307303983547376913282000110058273504'// &
                   '202838670709895619275413484521549282591891156945200789415818387529512010999'// &
                   '602155131321076797099026664236992803703462570149559724389392331827597552460'// &
                   '610612200485579529156910428115547013787714423708578161025641555097481179969'// &
                   '175028390105904786831680128384331143259309155577171683842444352768419176139060')

      IF (.NOT.(ABS(X3-X2) < TO_FM('1.0E-501'))) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 2.'/)")
          WRITE (KOUT,"(/' Error in sample case number 2.'/)")
      ENDIF

!             3.  Compute the Riemann zeta function for s=3.

!                 Use Gosper's formula:  zeta(3) =
!                 (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ]
!                 while k = 0, 1, ....

!                 X1 is the current partial sum.
!                 X2 is the current term.
!                 X3 is k!
!                 X4 is (2k+1)!

      CALL FM_SET(60)
      X1 = 1
      X3 = 1
      X4 = 1
      DO K = 1, 200
         X3 = K*X3
         J = 2*K*(2*K+1)
         X4 = J*X4
         X2 = X3**2
         J = (K+1)*(K+1)
         X2 = (X2/J)/X4
         IF (MOD(K,2) == 0) THEN
             X1 = X1 + X2
         ELSE
             X1 = X1 - X2
         ENDIF

!                 Test for convergence.
!                 Here the rate of convergence is much slower than in the Newton iterations above.
!                 Asking for 60 digits in the call to FM_SET will cause the internal precision to
!                 be set slightly higher than that, giving the user a few guard digits.
!                 X2 is the difference between the two most recent partial sums, so the test
!                 below will stop the sum when the last two partial sums agree to at least 65
!                 significant digits.

         IF (ABS(X2/X1) < 1.0D-65) THEN
             FMT = "(///' Sample 3.',2X,I5,' terms were added in the zeta sum.'/)"
             WRITE (*   ,FMT) K
             WRITE (KOUT,FMT) K
             EXIT
         ENDIF
      ENDDO

!                 Print the result.

      X1 = (5*X1)/4
      CALL FM_FORM('F63.60',X1,ST1)
      WRITE (*   ,"(' zeta(3) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' zeta(3) = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('1.202056903159594285399738161511449990764986292340498881792271555')
      IF (.NOT.(ABS(X1-X3) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 3.'/)")
          WRITE (KOUT,"(/' Error in sample case number 3.'/)")
      ENDIF

!             4.  Integer multiple precision calculations.

!                 Fermat's theorem says  x**(p-1) mod p = 1 when p is prime and x is not a
!                 multiple of p.
!                 If  x**(p-1) mod p  gives 1 for some p with several different x's, then it is
!                 very likely that p is prime (but it is not certain until further tests are done).

!                 Find a 70-digit number p that is "probably" prime.

!                 Use FM_RANDOM_NUMBER to generate a random 70-digit starting value and search for
!                 a prime from that point.

!                 Initialize the generator.
!                 Note that VALUE is double precision, unlike the similar Fortran intrinsic random
!                 number routine, which returns a single-precision result.

      SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093698 /)
      CALL FM_RANDOM_SEED_PUT(SEED)

!                 I1 is the value p being tested.

      I1 = 0
      I3 = TO_IM(10)**13
      DO J = 1, 6
         CALL FM_RANDOM_NUMBER(VALUE)
         I2 = 1.0D13*VALUE
         I1 = I1*I3 + I2
      ENDDO
      I3 = TO_IM(10)**70
      I1 = MOD(I1,I3)

!                 To speed up the search, test only values that are not
!                 multiples of 2, 3, 5, 7, 11, 13.

      K = 2*3*5*7*11*13
      I1 = (I1/K)*K + K + 1
      I3 = 3

      DO J = 1, 100
         I2 = I1 - 1

!                 Compute 3**(p-1) mod p

         I3 = POWER_MOD(I3,I2,I1)
         IF (I3 == 1) THEN

!                 Check that 7**(p-1) mod p is also 1.

             I3 = 7
             I3 = POWER_MOD(I3,I2,I1)
             IF (I3 == 1) THEN
                 FMT = "(///' Sample 4.',2X,I5,' values were checked before finding a prime p.'/)"
                 WRITE (*   ,FMT) J
                 WRITE (KOUT,FMT) J
                 EXIT
             ENDIF
         ENDIF

         I3 = 3
         I1 = I1 + K
      ENDDO

!                 Print the result.

      CALL IM_FORM('I72',I1,ST1)
      WRITE (*   ,"(' p =',A)") TRIM(ST1)
      WRITE (KOUT,"(' p =',A)") TRIM(ST1)

!                 Check the answer.

      I3 = TO_IM('9552131129056058313103536357738804884840825498503088946760768419490591')
      IF (.NOT.(I1 == I3)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 4.'/)")
          WRITE (KOUT,"(/' Error in sample case number 4.'/)")
      ENDIF

!             5.  Log Integral function.

!                 Estimate the number of primes less than 10**30.

      FMT = "(///' Sample 5.  Log integral.  Estimate the number of primes less than 10**30.'/"//  &
                "'            It should be accurate to about 15 significant digits.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      I2 = TO_IM(LOG_INTEGRAL(TO_FM('1.0E+30')))

!                 Print the result.

      CALL IM_FORM('I30',I2,ST1)
      WRITE (*   ,"(' int(li(1.0e+30)) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' int(li(1.0e+30)) = ',A)") TRIM(ST1)

!                 Check the answer.

      I3 = TO_IM('14692398897720447639079087669')
      IF (.NOT.(I2 == I3)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 5.'/)")
          WRITE (KOUT,"(/' Error in sample case number 5.'/)")
      ENDIF

!             6.  Gamma function.

!                 Check that gamma(1/2) is sqrt(pi)

      FMT = "(///' Sample 6.  Check that gamma(1/2) = sqrt(pi).'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X2 = GAMMA(TO_FM('0.5'))

!                 Print the result.

      CALL FM_FORM('F63.60',X2,ST1)
      WRITE (*   ,"(' gamma(1/2) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' gamma(1/2) = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = SQRT(ACOS(TO_FM(-1)))
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 6.'/)")
          WRITE (KOUT,"(/' Error in sample case number 6.'/)")
      ENDIF

!             7.  Psi and polygamma functions.

!                 Rational series can often be summed using these functions.
!                 Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
!                 16*(psi(1) - psi(9/8)) + polygamma(1,1) + polygamma(1,9/8)
!                 Reference: Abramowitz & Stegun, Handbook of Mathematical Functions,
!                 chapter 6, Example 10.

      FMT = "(///' Sample 7.  Psi and polygamma functions.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X2 = 16*(PSI(TO_FM(1)) - PSI(TO_FM(9)/8)) + POLYGAMMA(1,TO_FM(1)) + POLYGAMMA(1,TO_FM(9)/8)

!                 Print the result.

      CALL FM_FORM('F65.60',X2,ST1)
      FMT = "(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)"
      WRITE (*   ,FMT) TRIM(ST1)
      WRITE (KOUT,FMT) TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('1.3499486145413024755107829105035147950644978635837270816327396M-2')
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 7.'/)")
          WRITE (KOUT,"(/' Error in sample case number 7.'/)")
      ENDIF

!             8.  Incomplete gamma and gamma functions.

!                 Find the probability that an observed chi-square for a correct model should be
!                 less that 2.3 when the number of degrees of freedom is 5.
!                 Reference: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery, Teukolsky,
!                 Vetterling, Numerical Recipes, 1st ed., Page 165.

      FMT = "(///' Sample 8.  Incomplete gamma and gamma functions.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X1 = TO_FM(5)/2
      X2 = INCOMPLETE_GAMMA1(X1,TO_FM('2.3')/2) / GAMMA(X1)

!                 Print the result.

      CALL FM_FORM('F62.60',X2,ST1)
      WRITE (*   ,"(' Probability = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Probability = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('0.19373313011487144632751025918250599953472318607121386973066283739')
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 8.'/)")
          WRITE (KOUT,"(/' Error in sample case number 8.'/)")
      ENDIF

!             9.  Error function.

!                 Find the probability that a value drawn from a normal distribution is within
!                 1 or 2 or 3 standard deviations from the mean.

      FMT = "(///' Sample 9.  Error function.  Probability that a value drawn from a normal'/"//  &
                "'            distribution is within k standard deviations from the mean.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      DO K = 1, 3
         X1 = K / SQRT(TO_FM(2))
         X2 = ERF(X1)

!                 Print the results.

         CALL FM_FORM('F52.50',X2,ST1)
         WRITE (*   ,"(' k = ',I2,',  probability = ',A)") K,TRIM(ST1)
         WRITE (KOUT,"(' k = ',I2,',  probability = ',A)") K,TRIM(ST1)

!                 Check the answer.

         IF (K == 1) THEN
             X3 = TO_FM('0.68268949213708589717046509126407584495582593345320878197478890049')
         ELSE IF (K == 2) THEN
             X3 = TO_FM('0.95449973610364158559943472566693312505644755259664313203266799974')
         ELSE
             X3 = TO_FM('0.99730020393673981094669637046481004524434126368323870127155602929')
         ENDIF
         IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
             NERROR = NERROR + 1
             WRITE (*   ,"(/' Error in sample case number 9.'/)")
             WRITE (KOUT,"(/' Error in sample case number 9.'/)")
         ENDIF
      ENDDO

!             10. Array operations.

!                 Find the dominant eigenvalue and a corresponding eigenvector for this 5x5 matrix:

!                          3  1  4  1  5
!                          9  2  6  5  3
!                    A =   5  8  9  7  9
!                          3  2  3  8  4
!                          6  2  6  4  3

!                 Use the power method.  Compute B = A**n.  If v1 is an initial guess for the
!                 largest magnitude eigenvector, v2 = B*v1 should be a more accurate approximation.
!                 The ratio of the elements of v3 = A*v2 to those of v2 gives an estimate of the
!                 corresponding eigenvalue.  By repeatedly squaring the matrix, each iteration uses
!                 the next higher power of 2 for n.

      FMT = "(///' Sample 10.  Eigenvalue from matrix powers.')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!             These type FM arrays were declared as allocatable.  Allocate them now, and initialize.

      ALLOCATE( A(5,5) )
      ALLOCATE( B(5,5) )
      ALLOCATE( V1(5) )
      ALLOCATE( V2(5) )

!             To initialize the matrix, we can use array sections to set one row at a time, and the
!             FMZM interface will take care of converting from integer to type (FM).  If the values
!             were not integers, we could say  A(1,1:5) = (/ TO_FM(' 3.7 '),TO_FM(' 4.2 '), etc.

      A(1,1:5) = (/ 3, 1, 4, 1, 5 /)
      A(2,1:5) = (/ 9, 2, 6, 5, 3 /)
      A(3,1:5) = (/ 5, 8, 9, 7, 9 /)
      A(4,1:5) = (/ 3, 2, 3, 8, 4 /)
      A(5,1:5) = (/ 6, 2, 6, 4, 3 /)

!             Initialize all elements of the initial guess vector to 1.

      V1 = 1

      B = A
      WRITE (*   ,"(/' Iteration    eigenvalue approximation ')")
      WRITE (KOUT,"(/' Iteration    eigenvalue approximation ')")
      DO J = 1, 7
         B = MATMUL(B,B)
         V1 = MATMUL(B,V1)
         V2 = MATMUL(A,V1)
         X1 = V2(1) / V1(1)
         CALL FM_FORM('F64.57',X1,ST1)
         WRITE (*   ,"(/I10,A)") J,TRIM(ST1)
         WRITE (KOUT,"(/I10,A)") J,TRIM(ST1)
      ENDDO

!             Normalize the eigenvector (L-2 norm).

      V2 = V2 / NORM2(V2)
      WRITE (*   ,"(/' The corresponding eigenvector is'/)")
      WRITE (KOUT,"(/' The corresponding eigenvector is'/)")
      DO J = 1, 5
         CALL FM_FORM('F61.57',V2(J),ST1)
         WRITE (*   ,"(A)") TRIM(ST1)
         WRITE (KOUT,"(A)") TRIM(ST1)
      ENDDO

!                 Check the answer.

      X3 = TO_FM('23.91276717232132858935703922800330450554912919599927298216827247803204')
      IF (.NOT.(ABS(X3-X1) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 10.'/)")
          WRITE (KOUT,"(/' Error in sample case number 10.'/)")
      ENDIF

!             11. Function and subroutine example.

!                 Find the integral from 0 to 1/2 of 2*exp(-x**2)/sqrt(pi).

!                 The exact value of the integral is erf(1/2).
!                 Use a simple numerical integration routine to apply an integration rule
!                 using 100 intervals.

      CALL FM_SET(40)

      FMT = "(///' Sample 11.  Function and subroutine example.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X1 = 0
      X2 = TO_FM(' 0.5 ')
      CALL PLAN_9(F,X1,X2,100,X3)

!                 Print the result.

      CALL FM_FORM('F32.30',X3,ST1)
      WRITE (*   ,"(' Integral = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Integral = ',A)") TRIM(ST1)

!                 Check the answer.

      X4 = ERF(TO_FM('0.5'))
      IF (.NOT.(ABS(X3-X4) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 11.'/)")
          WRITE (KOUT,"(/' Error in sample case number 11.'/)")
      ENDIF

!             Complex arithmetic.

!             Set precision to give at least 30 significant digits.

      CALL FM_SET(30)

!             12. Find a complex root of the equation
!                 f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Newton's method with initial guess x = .56 + 1.06 i.

!                 Z1 is the previous iterate.
!                 Z2 is the current iterate.

      Z1 = TO_ZM('.56 + 1.06 i')

!                 Print the first iteration.

      FMT = "(///' Sample 12.  Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.',"  &
            //"//' Iteration       Newton approximation')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      CALL ZM_FORM('F32.30','F32.30',Z1,ST1)
      WRITE (*   ,"(/I6,4X,A)") 0,TRIM(ST1)
      WRITE (KOUT,"(/I6,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 Z3 is f(Z1).

         Z3 = ((((Z1-3)*Z1+1)*Z1-4)*Z1+1)*Z1-6

!                 Z4 is f'(Z1).

         Z4 = (((5*Z1-12)*Z1+3)*Z1-8)*Z1+1

         Z2 = Z1 - Z3/Z4

!                 Print each iteration.

         CALL ZM_FORM('F32.30','F32.30',Z2,ST1)
         WRITE (*   ,"(/I6,4X,A)") ITER,TRIM(ST1)
         WRITE (KOUT,"(/I6,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if Z1 and Z2 agree to over 30 places.

         IF (ABS(Z1-Z2) < 1.0D-31) EXIT

!                 Set Z1 = Z2 for the next iteration.

         Z1 = Z2
      ENDDO

!                 Check the answer.

      Z3 = TO_ZM('0.561958308335403235498111195347453 + 1.061134679604332556983391239058885 i')
      IF (.NOT.(ABS(Z3-Z2) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 12.'/)")
          WRITE (KOUT,"(/' Error in sample case number 12.'/)")
      ENDIF

!             13. Compute exp(1.23-2.34i).

!                 Use the direct Taylor series.

!                 Z1 is x.
!                 Z2 is the current term, x**n/n!.
!                 Z3 is the current partial sum.

      Z1 = TO_ZM('1.23-2.34i')
      Z2 = 1
      Z3 = 1
      DO K = 1, 100
         Z2 = Z2*Z1/K
         Z4 = Z3 + Z2

!                 Test for convergence.

!                 This is a common way to check for series convergence -- wait until the term
!                 being added is so close to zero that the sum does not change.  That is fine
!                 here, because we are using the default round-to-nearest rounding mode.

!                 There is a pitfall if we were to re-run the program with a different rounding
!                 mode.  For example, if we change the rounding mode to round toward +infinity,
!                 then at 30-digit precision the addition  1.2 + 3.4e-100  rounds up to  1.200...001
!                 and so the test to see if the sum did not change might never be satisfied.
!                 This problem can occur with either type FM or ZM sums.

!                 For cases where other rounding modes might be used, doing the convergence check
!                 like we did in the zeta sum of example 3 above is better.  Here that would be
!                    IF (ABS(Z2/Z3) < 1.0D-35) THEN

         IF (Z4 == Z3) THEN
             FMT = "(///' Sample 13.',2X,I5,' terms were added to get exp(1.23-2.34i).'/)"
             WRITE (*   ,FMT) K
             WRITE (KOUT,FMT) K
             EXIT
         ENDIF
         Z3 = Z4
      ENDDO

!                 Print the result.

      CALL ZM_FORM('F33.30','F32.30',Z3,ST1)
      WRITE (*   ,"(' Result= ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Result= ',A)") TRIM(ST1)

!                 Check the answer.

      Z4 = TO_ZM('-2.379681796854777515745457977696745 - 2.458032970832342652397461908326042 i')
      IF (.NOT.(ABS(Z4-Z3) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 13.'/)")
          WRITE (KOUT,"(/' Error in sample case number 13.'/)")
      ENDIF

!             14. Exception handling.

!                 Iterate (real) exp(x) starting at 1.0 until overflow occurs.

!                 Testing to see if a type FM number is one of the special cases (+-overflow,
!                 +-underflow or unknown) by direct comparison can be tricky.  When X1 is
!                 +overflow, the statement
!                       IF (X1 == TO_FM(' +OVERFLOW ')) THEN
!                 will return false, since the comparison routine cannot be sure that two
!                 different overflowed results would have been equal if the overflow threshold
!                 had been higher.

!                 Function IS_OVERFLOW can be used to directly check whether a number is + or -
!                 overflow, so that is a safer test.

!                 The FM warning message is written on unit KW, so in this test it appears on the
!                 screen and not in the output file.

      CALL FM_SET(60)

      X1 = TO_FM(1)

      FMT = "(///' Sample 14.  Exception handling.'//12X,"                // &
            "' Iterate exp(x) starting at 1.0 until overflow occurs.'//"  // &
            "12X,' An FM warning message will be printed before the last iteration.')"
      WRITE (*,FMT)
      FMT = "(///' Sample 14.  Exception handling.'//"                    // &
            "12X,' Iterate exp(x) starting at 1.0 until overflow occurs.')"
      WRITE (KOUT,FMT)

      DO J = 1, 10
         X1 = EXP(X1)
         CALL FM_FORM('ES60.40',X1,ST1)
         WRITE (*   ,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         WRITE (KOUT,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         IF (IS_OVERFLOW(X1)) EXIT
      ENDDO

!             Check that the last result was +overflow.

      IF (IS_OVERFLOW(X1)) THEN
          WRITE (*   ,"(/' Overflow was correctly detected.')")
          WRITE (KOUT,"(/' Overflow was correctly detected.')")
      ELSE
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 14.'/)")
          WRITE (*   ,"(/' Overflow was not correctly detected.')")
          WRITE (KOUT   ,"(/' Error in sample case number 14.'/)")
          WRITE (KOUT   ,"(/' Overflow was not correctly detected.')")
      ENDIF

      IF (NERROR == 0) THEN
          WRITE (*   ,"(//A/)") ' All results were ok -- no errors were found.'
          WRITE (KOUT,"(//A/)") ' All results were ok -- no errors were found.'
      ELSE
          WRITE (*   ,"(//I3,A/)") NERROR,' error(s) found.'
          WRITE (KOUT,"(//I3,A/)") NERROR,' error(s) found.'
      ENDIF

      STOP
      END PROGRAM TEST

      SUBROUTINE PLAN_9(F,A,B,N,RESULT)

!  Sample subroutine usage for FM.

!  Integrate F(X) from A to B using N subintervals, and return the answer in RESULT.

!  This does numerical integration using a 9-point rule.
!  It is not a very good way to do high-precision integration, but it is a short routine
!  and can often get 20 to 30 digits if f(x) is well-behaved and the interval of integration
!  is not too big.

      USE FMZM
      IMPLICIT NONE
      TYPE (FM) :: A, B, RESULT
      TYPE (FM), SAVE :: H, H8, XJ
      TYPE (FM), EXTERNAL :: F
      INTEGER :: N, J
      INTENT (IN) :: N, A, B
      INTENT (INOUT) :: RESULT

      H = (B - A)/N
      H8 = H/8
      RESULT = 0
      DO J = 1, N
         XJ = A + (J-1)*H
         RESULT = RESULT +   989*F(XJ)      + 5888*F(XJ+  H8) -   928*F(XJ+2*H8) +  &
                           10496*F(XJ+3*H8) - 4540*F(XJ+4*H8) + 10496*F(XJ+5*H8) -  &
                             928*F(XJ+6*H8) + 5888*F(XJ+7*H8) +   989*F(XJ+8*H8)
      ENDDO
      RESULT = H*RESULT/28350

      END SUBROUTINE PLAN_9

      FUNCTION F(X)     RESULT (RETURN_VALUE)

!  Sample function usage for FM.

!  The test function for the integration subroutine is  2*exp(-x**2)/sqrt(pi).

      USE FMZM
      IMPLICIT NONE
      TYPE (FM) :: RETURN_VALUE, X
      TYPE (FM), SAVE :: PI

!             Compare the usage here with the SQRT(ACOS(TO_FM(-1))) usage in the gamma example
!             in the main program.  There pi was only used once, so ACOS(TO_FM(-1)) is more like
!             what a non-multiple-precision program would do to get pi.

!             If we need pi in a function like F that will be called hundreds of times, the acos
!             call will be done every time.  Here, since the argument is -1, the acos routine will
!             recognize it as a special case and return the saved value of pi without needlessly
!             making the program slower.  But if another formula were used, like pi = 6*asin(1/2),
!             it would be better to call FM_PI, since pi would be computed only once and later calls
!             just use the saved value of pi.

!             Another reason to call FM_PI instead of using a formula is that in case the calling
!             program changed the trig function mode to degrees, instead of the default radians,
!             then ACOS(TO_FM(-1)) would give 180, not pi.

!             For this case the 2/sqrt(pi) could have been factored out of the integral so pi would
!             not be needed every time F is called, but it was left in to illustrate similar but
!             more complicated situations.

      CALL FM_PI(PI)
      RETURN_VALUE = 2*EXP(-X**2)/SQRT(PI)

      END FUNCTION F


! Created by EverLookNeverSee@GitHub on 6/1/20
! For more information see FCS/img/Exercise_08_a.png

program main
    implicit none
    ! declaring and initializing variables
    real :: sum = 0.0, theta = 1.57079, t = 1.0
    integer :: i = 0
    ! iterating and calculating cos serie till obtaining correct result
    do
        sum = sum + t
        i = i + 1
        t = t * (-theta * theta) / (2 * i * (2 * i - 1))
        if (sum + t == sum) exit
    end do
    ! printing results
    print *, "Cos(", theta, "):", sum
end program main


module funcs_mod
    implicit none

    private
    public :: factorial

contains

    recursive function factorial(n) result(f)
        implicit none
        integer, intent(in) :: n
        integer :: f
        if (n < 2) then
            f = 1
        else
            f = n*factorial(n - 1)
        end if
    end function factorial

end module funcs_mod

program recursion_test
    use :: funcs_mod, only : factorial
    implicit none
    integer, parameter :: n_min = 0, n_max = 6
    integer :: i

    do i = n_min, n_max
        print *, i, factorial(i)
    end do

end program recursion_test


module geometry
  !! Provides routines for basic geometrical and trigonometric functions in 2D and 3D.

  implicit none

  public :: norm, distance

contains

  pure real function norm(p) result(d)
    !! Returns the \(L_2\)-norm of a vector \(\mathbf{p}\),
    !! $$ \lVert \mathbf{p} \rVert = \sqrt{\sum_{i=1}^n p_i} $$

    implicit none

    real, allocatable, intent(in) :: p(:)
    integer :: l, u, i

    l = lbound(p,1)
    u = ubound(p,1)

    d = 0.0
    do i = l, u
       d = d + p(i)**2
    end do

    d = sqrt(d)

  end function norm

  pure real function distance(p, q) result(d)
    !! Returns the Euclidean distance between two points \(\mathbf{x}\) and \(\mathbf{y}\),
    !! $$ \lVert \mathbf{q} - \mathbf{p} \rVert = \sqrt{\sum_{i=1}^n \left(q_i - p_i\right)^2} $$

    implicit none

    real, allocatable, intent(in) :: p(:), q(:)
    integer :: l, u, i

    !! @todo Check rank of p vs q
    l = lbound(p,1)
    u = ubound(p,1)

    d = 0.0
    do i = l, u
       d = d + (q(i) - p(i))**2
    end do

    d = sqrt(d)

  end function distance
end module geometry


module circle
! MODULE circle
! This is a practise module intended for learning about modules in Fortran.
! It contains the following subprograms :
!   CircArea : calculates a circle's area
!   CircPeri : calculates the 'perimeter' (circumference) of a circle

  implicit none
  real, parameter::pi=atan(1.0)*4

  contains

  ! FUNCTION CircArea
  ! Input : the circle's radius
  ! Output : the circle's area
  function circarea(radius) result(area)
    real,intent(in)::radius
    real::area

    area = pi * radius * radius
    return
  end function circarea

  ! FUNCTION CircPeri
  ! Input : the circle's radius
  ! Output : the circle's circumference
  function circperi(radius) result(circumference)
    real,intent(in)::radius
    real::circumference

    circumference = 2 * pi * radius
    return
  end function circperi

end module circle


program MC_ex01_p04_Buffon
    use mc_randoms
    implicit none
    real,parameter :: pi=4.0*atan(1.0)
    integer::seed=13,iarg,j,k,n,hits
    real(8)::result,l=2,d=10,error=0
    character(len=80)::arg

    !RNG seed from arguments, default seed 13
    iarg=command_argument_count()
    if (iarg==1) then
        call get_command_argument(1,arg)
        read(arg,*) seed
    end if

    call seed_lcg(int(seed,ik))

    !Simulation part
    n=10000
    !Do 100 simulations with the new throw count
    do j=1,100
        !Simulate a single set of throws
        hits=0
        do k=1,n
            hits=hits+throw()
        end do
        if(hits==0) then
            result=0
        else
            result=n*2*l/(d*hits)
        end if
        error=error+abs(result-pi)
    end do
    error=error/100

    print*,"Error: ",error

contains
    integer function throw()
        implicit none
        real(rk)::y,alpha
        !Randomize the position and the angle of the needle.
        !It's only necessary to look at the other half of the throwing space, since the situation can always be mirrored
        y=rand_lcg()*d/2
        alpha=rand_lcg()*pi/2
        !Check if the end of the needle crosses a line
        if (l/2*sin(alpha)>=y) then
            throw=1
        else
            throw=0
        end if
    end function

end program MC_ex01_p04_Buffon


! Created by EverLookNeverSee@GitHub on 6/11/20
! For more information see FCS/img/Exercise_13.png

program main
    implicit none
    ! declaring variables
    integer :: n, i, j
    real :: tmp_1, tmp_2, tmp_3, tmp_4, tmp_5, corr, numerator, denominator
    real, allocatable, dimension(:) :: x, y
    ! initializing temporary variables
    tmp_1 = 0.0; tmp_2 = 0.0; tmp_3 = 0.0; tmp_4 = 0.0; tmp_5 = 0.0
    ! specifying number of elements in sets
    do
        print *, "Enter the number of elements in sets:"
        read *, n
        if (n <= 0) then
            print *, "You should enter a positive integer number!"
            cycle
        else
            exit
        end if
    end do
    ! allocating memory space to arrays
    allocate(x(n))
    allocate(y(n))
    ! assigning values to sets using user input
    ! x set
    do i = 1, n
        print *, "x(", i, "):"
        read *, x(i)
    end do
    ! y set
    do j = 1, n
        print *, "y(", j, "):"
        read *, y(j)
    end do
    ! --------------------------------------------------------------------
    ! tmp_1
    do i = 1, n
        tmp_1 = tmp_1 + (x(i) * y(i))
    end do
    ! tmp_2
    do i = 1, n
        tmp_2 = tmp_2 + x(i)
    end do
    ! tmp_3
    do i = 1, n
        tmp_3 = tmp_3 + y(i)
    end do
    ! tmp_4
    do i = 1, n
        tmp_4 = tmp_4 + x(i) ** 2
    end do
    ! tmp_5
    do i = 1, n
        tmp_5 = tmp_5 + y(i) ** 2
    end do
    ! --------------------------------------------------------------------
    ! calculating the numerator
    numerator = (n * tmp_1) - (tmp_2 * tmp_3)
    ! calculating denominator
    denominator = sqrt(n * tmp_4 - tmp_2 ** 2) * sqrt(n * tmp_5 - tmp_3 ** 2)
    ! calculating correlation coefficient
    corr = numerator / denominator
    ! printing result
    print *, "Correletion coefficient:", corr
end program main


      function dzasum ( n, zx, incx )

c*********************************************************************72
c
cc DZASUM takes the sum of the absolute values.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, double precision DZASUM, the sum of the absolute values.
c
      implicit none

      double precision dzasum
      integer i
      integer incx
      integer ix
      integer n
      double precision stemp
      double precision zabs1
      double complex zx(*)

      dzasum = 0.0d0
      stemp = 0.0d0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      do i = 1,n
        stemp = stemp + zabs1(zx(ix))
        ix = ix + incx
      end do
      dzasum = stemp
      return
c
c        code for increment equal to 1
c
   20 do i = 1,n
        stemp = stemp + zabs1(zx(i))
      end do
      dzasum = stemp
      return
      end
      function dznrm2 ( n, x, incx )

c*********************************************************************72
c
cc DZNRM2 returns the euclidean norm of a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Sven Hammarling
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, double precision DZNRM2, the norm of the vector.
c
      implicit none

      integer                           incx, n
      double complex x( * )

      double precision      one         , zero
      parameter           ( one = 1.0d+0, zero = 0.0d+0 )

      double precision dznrm2
      integer               ix
      double precision      norm, scale, ssq, temp

      intrinsic             abs, dimag, dble, sqrt

      if( n.lt.1 .or. incx.lt.1 )then
         norm  = zero
      else
         scale = zero
         ssq   = one

         do ix = 1, 1 + ( n - 1 )*incx, incx
            if( dble( x( ix ) ).ne.zero )then
               temp = abs( dble( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
            if( dimag( x( ix ) ).ne.zero )then
               temp = abs( dimag( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
         end do
         norm  = scale * sqrt( ssq )
      end if

      dznrm2 = norm

      return
      end
      function izamax ( n, zx, incx )

c*********************************************************************72
c
cc IZAMAX finds the index of element having maximum absolute value.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, integer IZAMAX, the index of the element of maximum
c    absolute value.
c
      implicit none

      integer izamax
      double complex zx(*)
      double precision smax
      integer i,incx,ix,n
      double precision zabs1

      izamax = 0
      if( n.lt.1 .or. incx.le.0 )return
      izamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = zabs1(zx(1))
      ix = ix + incx
      do i = 2,n
        if ( smax .lt. zabs1(zx(ix)) ) then
          izamax = i
          smax = zabs1(zx(ix))
        end if
        ix = ix + incx
      end do
      return
c
c        code for increment equal to 1
c
   20 smax = zabs1(zx(1))
      do i = 2,n
        if ( smax .lt. zabs1(zx(i)) ) then
          izamax = i
          smax = zabs1(zx(i))
        end if
      end do

      return
      end
      subroutine zaxpy ( n, za, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZAXPY computes constant times a vector plus a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in CX and CY.
c
c    Input, double complex CA, the multiplier of CX.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), the second vector.
c    On output, CY(*) has been replaced by CY(*) + CA * CX(*).
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      double complex zx(*),zy(*),za
      integer i,incx,incy,ix,iy,n
      double precision zabs1
      if(n.le.0)return
      if (zabs1(za) .eq. 0.0d0) return
      if (incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        zy(iy) = zy(iy) + za*zx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        zy(i) = zy(i) + za*zx(i)
      end do
      return
      end
      subroutine zcopy ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZCOPY copies a vector, x, to a vector, y.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in CX and CY.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Output, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      double complex zx(*),zy(*)
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        zy(iy) = zx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        zy(i) = zx(i)
      end do

      return
      end
      function zdotc ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZDOTC forms the dot product of a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, double complex ZDOTC, the conjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      double complex zdotc
      integer i,incx,incy,ix,iy,n

      ztemp = (0.0d0,0.0d0)
      zdotc = (0.0d0,0.0d0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = ztemp + dconjg(zx(ix))*zy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      zdotc = ztemp
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = ztemp + dconjg(zx(i))*zy(i)
      end do

      zdotc = ztemp

      return
      end
      function zdotu ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZDOTU forms the dot product of two vectors.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, double complex ZDOTU, the unconjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      double complex zdotu
      integer i,incx,incy,ix,iy,n

      ztemp = (0.0d0,0.0d0)
      zdotu = (0.0d0,0.0d0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = ztemp + zx(ix)*zy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      zdotu = ztemp
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = ztemp + zx(i)*zy(i)
      end do

      zdotu = ztemp

      return
      end
      subroutine zdrot ( n, zx, incx, zy, incy, c, s )

c*********************************************************************72
c
cc ZDROT applies a plane rotation.
c
c  Discussion:
c
c    The cos and sin (c and s) are double precision and the vectors
c    zx and zy are double complex.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, double complex CX(*), one of the vectors to be rotated.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), one of the vectors to be rotated.
c
c    Input, integer INCY, the increment between successive elements of CY.
c
c    Input, double precision C, S, parameters (presumably the cosine and
c    sine of some angle) that define a plane rotation.
c
      implicit none

      double complex zx(1),zy(1),ztemp
      double precision c,s
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = c*zx(ix) + s*zy(iy)
        zy(iy) = c*zy(iy) - s*zx(ix)
        zx(ix) = ztemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = c*zx(i) + s*zy(i)
        zy(i) = c*zy(i) - s*zx(i)
        zx(i) = ztemp
      end do

      return
      end
      subroutine zdscal ( n, da, zx, incx )

c*********************************************************************72
c
cc ZDSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision SA, the multiplier.
c
c    Input/output, double complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of
c    the vector CX.
c
      implicit none

      double precision da
      integer i
      integer incx
      integer ix
      integer n
      double complex zx(*)

      if ( n .le. 0 .or. incx .le. 0 ) then
        return
      end if

      if ( incx .eq. 1 ) then

        do i = 1, n
          zx(i) = dcmplx ( da, 0.0d0 ) * zx(i)
        end do

      else

        ix = 1
        do i = 1, n
          zx(ix) = dcmplx ( da, 0.0d0 ) * zx(ix)
          ix = ix + incx
        end do

      end if

      return
      end
      subroutine zrotg ( ca, cb, c, s )

c*********************************************************************72
c
cc ZROTG generates a Givens rotation.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c    Given values A and B, this routine computes:
c
c    If A = 0:
c
c      R = B
c      C = 0
c      S = (1,0).
c
c    If A /= 0:
c
c      ALPHA = A / abs ( A )
c      NORM  = sqrt ( ( abs ( A ) )^2 + ( abs ( B ) )^2 )
c      R     = ALPHA * NORM
c      C     = abs ( A ) / NORM
c      S     = ALPHA * conj ( B ) / NORM
c
c    In either case, the computed numbers satisfy the equation:
c
c    (         C    S ) * ( A ) = ( R )
c    ( -conj ( S )  C )   ( B ) = ( 0 )
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input/output, double complex CA, on input, the value A.  On output,
c    the value R.
c
c    Input, double complex CB, the value B.
c
c    Output, double precision C, the cosine of the
c    Givens rotation.
c
c    Output, double complex S, the sine of the
c    Givens rotation.
c
      implicit none

      double complex ca,cb,s
      double precision c
      double precision norm,scale
      double complex alpha

      if (cdabs(ca) .eq. 0.0d0) then
        c = 0.0d0
        s = (1.0d0,0.0d0)
        ca = cb
      else
        scale = cdabs(ca) + cdabs(cb)
        norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +
     &                     (cdabs(cb/dcmplx(scale,0.0d0)))**2)
        alpha = ca /cdabs(ca)
        c = cdabs(ca) / norm
        s = alpha * dconjg(cb) / norm
        ca = alpha * norm
      end if

      return
      end
      subroutine zscal ( n, za, zx, incx )

c*********************************************************************72
c
cc ZSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double complex CA, the multiplier.
c
c    Input/output, double complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
      implicit none

      double complex za,zx(*)
      integer i,incx,ix,n

      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      do i = 1,n
        zx(ix) = za*zx(ix)
        ix = ix + incx
      end do

      return
c
c        code for increment equal to 1
c
   20 do i = 1,n
        zx(i) = za*zx(i)
      end do

      return
      end
      subroutine zswap ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZSWAP interchanges two vectors.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, double complex CX(*), one of the vectors to swap.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), one of the vectors to swap.
c
c    Input, integer INCY, the increment between successive elements of CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = zx(ix)
        zx(ix) = zy(iy)
        zy(iy) = ztemp
        ix = ix + incx
        iy = iy + incy
      end do

      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = zx(i)
        zx(i) = zy(i)
        zy(i) = ztemp
      end do

      return
      end


subroutine fem1d_heat_steady ( n, a, b, ua, ub, k, f, x, u )

!*****************************************************************************80
!
!! FEM1D_HEAT_STEADY solves the steady 1D heat equation with finite elements.
!
!  Discussion:
!
!    The program uses the finite element method, with piecewise linear basis
!    functions to solve the steady state heat equation in one dimension.
!
!    The problem is defined on the region A <= x <= B.
!
!    The following differential equation is imposed between A and B:
!
!      - d/dx k(x) du/dx = f(x)
!
!    where k(x) and f(x) are given functions.
!
!    At the boundaries, the following conditions are applied:
!
!      u(A) = UA
!      u(B) = UB
!
!    A set of N equally spaced nodes is defined on this
!    interval, with A = X(1) < X(2) < ... < X(N) = B.
!
!    At each node I, we associate a piecewise linear basis function V(I,X),
!    which is 0 at all nodes except node I.  This implies that V(I,X) is
!    everywhere 0 except that
!
!    for X(I-1) <= X <= X(I):
!
!      V(I,X) = ( X - X(I-1) ) / ( X(I) - X(I-1) )
!
!    for X(I) <= X <= X(I+1):
!
!      V(I,X) = ( X(I+1) - X ) / ( X(I+1) - X(I) )
!
!    We now assume that the solution U(X) can be written as a linear
!    sum of these basis functions:
!
!      U(X) = sum ( 1 <= J <= N ) U(J) * V(J,X)
!
!    where U(X) on the left is the function of X, but on the right,
!    is meant to indicate the coefficients of the basis functions.
!
!    To determine the coefficient U(J), we multiply the original
!    differential equation by the basis function V(J,X), and use
!    integration by parts, to arrive at the I-th finite element equation:
!
!        Integral K(X) * U'(X) * V'(I,X) dx = Integral F(X) * V(I,X) dx
!
!    We note that the functions U(X) and U'(X) can be replaced by
!    the finite element form involving the linear sum of basis functions,
!    but we also note that the resulting integrand will only be nonzero
!    for terms where J = I - 1, I, or I + 1.
!
!    By writing this equation for basis functions I = 2 through N - 1,
!    and using the boundary conditions, we have N linear equations
!    for the N unknown coefficients U(1) through U(N), which can
!    be easily solved.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    07 April 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of nodes.
!
!    Input, real ( kind = 8 ) A, B, the left and right endpoints.
!
!    Input, real ( kind = 8 ) UA, UB, the prescribed value of U at A and B.
!
!    Input, external K, a function which evaluates k(x);
!
!    Input, external F, a function which evaluates f(x);
!
!    Input, real ( kind = 8 ) X(N), the mesh points.
!
!    Output, real ( kind = 8 ) U(N), the finite element coefficients, which
!    are also the value of the computed solution at the mesh points.
!
  implicit none

  integer ( kind = 4 ) n
  integer ( kind = 4 ), parameter :: quad_num = 2

  real ( kind = 8 ) a
  real ( kind = 8 ) abscissa(quad_num)
  real ( kind = 8 ) al
  real ( kind = 8 ) am
  real ( kind = 8 ) ar
  real ( kind = 8 ) amat(n,n)
  real ( kind = 8 ) b
  real ( kind = 8 ) bm
  real ( kind = 8 ) bvec(n)
  real ( kind = 8 ), external :: f
  real ( kind = 8 ) fxq
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  real ( kind = 8 ), external :: k
  real ( kind = 8 ) kxq
  integer ( kind = 4 ) q
  real ( kind = 8 ) weight(quad_num)
  real ( kind = 8 ) wq
  real ( kind = 8 ) u(n)
  real ( kind = 8 ) ua
  real ( kind = 8 ) ub
  real ( kind = 8 ) vl
  real ( kind = 8 ) vlp
  real ( kind = 8 ) vm
  real ( kind = 8 ) vmp
  real ( kind = 8 ) vr
  real ( kind = 8 ) vrp
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xl
  real ( kind = 8 ) xm
  real ( kind = 8 ) xq
  real ( kind = 8 ) xr
!
!  Define a quadrature rule on the interval [-1,+1].
!
  abscissa(1) = -0.577350269189625764509148780502D+00
  abscissa(2) = +0.577350269189625764509148780502D+00
  weight(1) = 1.0D+00
  weight(2) = 1.0D+00
!
!  Zero out the matrix and right hand side.
!
  amat(1:n,1:n) = 0.0D+00
  bvec(1:n) = 0.0D+00
!
!  Equation 1 is the left boundary condition, U(A) = UA;
!
  amat(1,1) = 1.0D+00
  bvec(1) = ua
!
!  Equation I involves the basis function at node I.
!  This basis function is nonzero from X(I-1) to X(I+1).
!  Equation I looks like this:
!
!    Integral K(X) U'(X) V'(I,X)
!           + C(X) * U(X) V(I,X) dx
!  = Integral F(X) V(I,X) dx
!
!  Then, we realize that U(X) = sum ( 1 <= J <= N ) U(J) * V(J,X),
!  (U(X) means the function; U(J) is the coefficient of V(J,X) ).
!
!  The only V functions that are nonzero when V(I,X) is nonzero are
!  V(I-1,X) and V(I+1,X).
!
!  Let's use the shorthand
!
!    VL(X) = V(I-1,X)
!    VM(X) = V(I,X)
!    VR(X) = V(I+1,X)
!
!  So our equation becomes
!
!    Integral K(X) [ VL'(X) U(I-1) + VM'(X) U(I) + VR'(X) U(I+1) ] * VM'(X) dx
!  = Integral F(X) VM(X) dx.
!
!
!
!  This is actually a set of N-2 linear equations for the N coefficients U.
!
!  Now gather the multipliers of U(I-1) to get the matrix entry A(I,I-1),
!  and so on.
!
  do i = 2, n - 1
!
!  Get the left, right and middle coordinates.
!
    xl = x(i-1)
    xm = x(i)
    xr = x(i+1)
!
!  Make temporary variables for A(I,I-1), A(I,I), A(I,I+1) and B(I).
!
    al = 0.0D+00
    am = 0.0D+00
    ar = 0.0D+00
    bm = 0.0D+00
!
!  We approximate the integrals by using a weighted sum of
!  the integrand values at quadrature points.
!
    do q = 1, quad_num
!
!  Integrate over the LEFT interval, between XL and XM, where:
!
!  VL(X) = ( XM - X       ) / ( XM - XL )
!  VM(X) = (      X  - XL ) / ( XM - XL )
!  VR(X) = 0
!
!  VL'(X) =             - 1 / ( XM - XL )
!  VM'(X) =             + 1 / ( XM - XL )
!  VR'(X) = 0
!
      xq = ( ( 1.0D+00 - abscissa(q) ) * xl   &
           + ( 1.0D+00 + abscissa(q) ) * xm ) &
           /   2.0D+00

      wq = weight(q) * ( xm - xl ) / 2.0D+00

      vl =  ( xm - xq ) / ( xm - xl )
      vlp =  - 1.0D+00  / ( xm - xl )

      vm =  ( xq - xl ) / ( xm - xl )
      vmp =  + 1.0D+00  / ( xm - xl )

      vr =  0.0D+00
      vrp = 0.0D+00

      kxq = k ( xq )
      fxq = f ( xq )

      al = al + wq * ( kxq * vlp * vmp )
      am = am + wq * ( kxq * vmp * vmp )
      ar = ar + wq * ( kxq * vrp * vmp )
      bm = bm + wq * ( fxq * vm )
!
!  Integrate over the RIGHT interval, between XM and XR, where:
!
!  VL(X) = 0
!  VM(X) = ( XR - X       ) / ( XR - XM )
!  VR(X) = (      X  - XM ) / ( XR - XM )
!
!  VL'(X) = 0
!  VM'(X) =             - 1 / ( XR - XM )
!  VR'(X) =             + 1 / ( XR - XM )
!
      xq = ( ( 1.0D+00 - abscissa(q) ) * xm   &
           + ( 1.0D+00 + abscissa(q) ) * xr ) &
           /   2.0D+00

      wq = weight(q) * ( xr - xm ) / 2.0D+00

      vl = 0.0D+00
      vlp = 0.0D+00

      vm = ( xr - xq ) / ( xr - xm )
      vmp = - 1.0D+00  / ( xr - xm )

      vr = ( xq - xm ) / ( xr - xm )
      vrp =  1.0D+00   / ( xr - xm )

      kxq = k ( xq )
      fxq = f ( xq )

      al = al + wq * ( kxq * vlp * vmp )
      am = am + wq * ( kxq * vmp * vmp )
      ar = ar + wq * ( kxq * vrp * vmp )
      bm = bm + wq * ( fxq * vm )

    end do

    amat(i,i-1) = al
    amat(i,i)   = am
    amat(i,i+1) = ar
    bvec(i)     = bm

  end do
!
!  Equation N is the right boundary condition, U(B) = UB;
!
  amat(n,n) = 1.0D+00
  bvec(n) = ub
!
!  Solve the linear system.
!
!  call r8mat_print ( n, n, amat, '  Matrix A:' )

  call r8mat_solve2 ( n, amat, bvec, u, ierror )

  return
end
subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows in A.
!
!    Input, integer ( kind = 4 ) N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 September 2009
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ), parameter :: incx = 5
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i2hi
  integer ( kind = 4 ) i2lo
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) inc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j2hi
  integer ( kind = 4 ) j2lo
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  if ( m <= 0 .or. n <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  (None)'
    return
  end if

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end
subroutine r8mat_solve2 ( n, a, b, x, ierror )

!*****************************************************************************80
!
!! R8MAT_SOLVE2 computes the solution of an N by N linear system.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!    The linear system may be represented as
!
!      A*X = B
!
!    If the linear system is singular, but consistent, then the routine will
!    still produce a solution.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 October 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of equations.
!
!    Input/output, real ( kind = 8 ) A(N,N).
!    On input, A is the coefficient matrix to be inverted.
!    On output, A has been overwritten.
!
!    Input/output, real ( kind = 8 ) B(N).
!    On input, B is the right hand side of the system.
!    On output, B has been overwritten.
!
!    Output, real ( kind = 8 ) X(N), the solution of the linear system.
!
!    Output, integer ( kind = 4 ) IERROR.
!    0, no error detected.
!    1, consistent singularity.
!    2, inconsistent singularity.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) amax
  real ( kind = 8 ) b(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) imax
  integer ( kind = 4 ) ipiv(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  real ( kind = 8 ) x(n)

  ierror = 0

  ipiv(1:n) = 0
  x(1:n) = 0.0D+00
!
!  Process the matrix.
!
  do k = 1, n
!
!  In column K:
!    Seek the row IMAX with the properties that:
!      IMAX has not already been used as a pivot;
!      A(IMAX,K) is larger in magnitude than any other candidate.
!
    amax = 0.0D+00
    imax = 0
    do i = 1, n
      if ( ipiv(i) == 0 ) then
        if ( amax < abs ( a(i,k) ) ) then
          imax = i
          amax = abs ( a(i,k) )
        end if
      end if
    end do
!
!  If you found a pivot row IMAX, then,
!    eliminate the K-th entry in all rows that have not been used for pivoting.
!
    if ( imax /= 0 ) then

      ipiv(imax) = k
      a(imax,k+1:n) = a(imax,k+1:n) / a(imax,k)
      b(imax) = b(imax) / a(imax,k)
      a(imax,k) = 1.0D+00

      do i = 1, n

        if ( ipiv(i) == 0 ) then
          a(i,k+1:n) = a(i,k+1:n) - a(i,k) * a(imax,k+1:n)
          b(i) = b(i) - a(i,k) * b(imax)
          a(i,k) = 0.0D+00
        end if

      end do

    end if

  end do
!
!  Now, every row with nonzero IPIV begins with a 1, and
!  all other rows are all zero.  Begin solution.
!
  do j = n, 1, -1

    imax = 0
    do k = 1, n
      if ( ipiv(k) == j ) then
        imax = k
      end if
    end do

    if ( imax == 0 ) then

      x(j) = 0.0D+00

      if ( b(j) == 0.0D+00 ) then
        ierror = 1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_SOLVE2 - Warning:'
        write ( *, '(a,i8)' ) '  Consistent singularity, equation = ', j
      else
        ierror = 2
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_SOLVE2 - Error:'
        write ( *, '(a,i8)' ) '  Inconsistent singularity, equation = ', j
      end if

    else

      x(j) = b(imax)

      do i = 1, n
        if ( i /= imax ) then
          b(i) = b(i) - a(i,j) * x(j)
        end if
      end do

    end if

  end do

  return
end
subroutine r8vec_even ( n, alo, ahi, a )

!*****************************************************************************80
!
!! R8VEC_EVEN returns an R8VEC of evenly spaced values.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!    If N is 1, then the midpoint is returned.
!
!    Otherwise, the two endpoints are returned, and N-2 evenly
!    spaced points between them.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    09 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values.
!
!    Input, real ( kind = 8 ) ALO, AHI, the low and high values.
!
!    Output, real ( kind = 8 ) A(N), N evenly spaced values.
!    Normally, A(1) = ALO and A(N) = AHI.
!    However, if N = 1, then A(1) = 0.5*(ALO+AHI).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  real ( kind = 8 ) ahi
  real ( kind = 8 ) alo
  integer ( kind = 4 ) i

  if ( n == 1 ) then

    a(1) = 0.5D+00 * ( alo + ahi )

  else

    do i = 1, n
      a(i) = ( real ( n - i,     kind = 8 ) * alo   &
             + real (     i - 1, kind = 8 ) * ahi ) &
             / real ( n     - 1, kind = 8 )
    end do

  end if

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine rotscale(X,Y,Z,nd,X0,Y0,Z0,ang1,ang2,ang3,anis1,anis2,invert,Xr,Yr,Zr)
    !-----------------------------------------------------------------------

    !              Rotate coordinates
    !              ******************

    ! This is implemented as in http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf

    ! INPUT PARAMETERS:

    !   X,Y, Z           X,Y,Z arrays with coordinates
    !   nd               number of data points
    !   X0,Y0,Z0         New origin of coordinate
    !   ang1             Azimuth angle for principal direction
    !   ang2             Dip angle for principal direction
    !   ang3             Third rotation angle
    !   anis1            First anisotropy ratio
    !   anis2            Second anisotropy ratio
    !   invert           If 0 do rotation, if 1 invert rotation

    ! Rerurn
    !   Xr,Yr,Zr         New rotated and scaled X,Y,Z arrays with coordinates

    !-----------------------------------------------------------------------

    implicit none

    ! input
    real*8, intent(in), dimension(nd) ::X,Y,Z
    real*8, intent(in) :: ang1,ang2,ang3,anis1,anis2, X0,Y0,Z0
    integer, intent(in) :: invert, nd

    ! output
    real*8, intent(out), dimension(nd) ::Xr,Yr,Zr

    ! internal variables
    real*8 ::   alpha, beta, theta, sina,sinb,sint, &
                cosa,cosb,cost,afac1,afac2, &
                X1,Y1,Z1, X2,Y2,Z2
    integer :: i

    !parameters
    real*8 :: DEG2RAD,EPSLON

    DEG2RAD=3.141592654/180.0
    EPSLON=1.e-20

    alpha = ang1 * DEG2RAD
    beta  = ang2 * DEG2RAD
    theta = ang3 * DEG2RAD

    ! Get the required sines and cosines:

    sina  = dble(sin(alpha))
    sinb  = dble(sin(beta))
    sint  = dble(sin(theta))
    cosa  = dble(cos(alpha))
    cosb  = dble(cos(beta))
    cost  = dble(cos(theta))

    ! Construct the rotation matrix in the required memory:

    afac1 = 1.0 / dble(max(anis1,EPSLON))
    afac2 = 1.0 / dble(max(anis2,EPSLON))

    if (invert == 0) then
        do i=1,nd
            !shift
            X1 = X(i)-X0
            Y1 = Y(i)-Y0
            Z1 = Z(i)-Z0
            ! rotate using equation 4 on http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf
            X2= (cosa*cost+sina*sinb*sint)*X1 + (-sina*cost+cosa*sinb*sint)*Y1 +(-cosb*sint)*Z1
            Y2=                (sina*cosb)*X1 +                 (cosa*cosb)*Y1 +      (sinb)*Z1
            Z2= (cosa*sint-sina*sinb*cost)*X1 + (-sina*sint-cosa*sinb*cost)*Y1 + (cosb*cost)*Z1
            !rescale
            Xr(i)= X2
            Yr(i)= Y2*afac1
            Zr(i)= Z2*afac2
        end do
    else
        do i=1,nd
            !rescale
            X1 = X(i)
            Y1 = Y(i)/afac1
            Z1 = Z(i)/afac2
            ! rotate using equation 5 on http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf
            X2= (cosa*cost+sina*sinb*sint)*X1 + (sina*cosb)*Y1 + (cosa*sint-sina*sinb*cost)*Z1
            Y2=(-sina*cost+cosa*sinb*sint)*X1 + (cosa*cosb)*Y1 +(-sina*sint-cosa*sinb*cost)*Z1
            Z2=               (-cosb*sint)*X1 +      (sinb)*Y1 +                (cosb*cost)*Z1
            !shift
            Xr(i) = X2+X0
            Yr(i) = Y2+Y0
            Zr(i) = Z2+Z0
        end do
    end if

    ! Return to calling program:
    return

end subroutine rotscale


subroutine bkfilter(n, y, up, dn, k, ybp, yt)

! Aubhik 20.02.2005
!
! Baxter and King (1999) Band-Pass filter
!
! y is a data vector of length n
! ybp is the band pass filtered series, with 0.0 for the first and last k observations
! n is the length of the data vector y
! up is the lower frequency
!	for example, the business cycle band will have up = 6 for quarterly data
!	and up = 1.5 for annual data
! dn is the higher frequency
!	for example, the business cycle band will have dn = 32 for quarterly data
!	and dn = 8 for annual data
! k is the number of leads and lags used by the symmetric moving-average
!	representation of the band pass filter.  Baxter and King (1999) find
!	that k = 12 is a practical choice.
!
! Algorithm provided by Bob King.  This subroutine is the Fortran 90 version of
! bpf.m and filtk.m written by Baxter and King (1999).  The band pass filter is
! a moving average involving 2k+1 terms.  The weights are symmetric and calculated
! in akvec.

implicit none

integer n, up, dn, k
real y(n), ybp(n), yt(n)

integer j
real pi, omlbar, omubar, kr, kj, theta
real akvec(k+1), avec(2*k+1), tvec(2*k+1)

intent(in):: n, up, dn, k, y
intent(out):: ybp, yt

pi = 2.0*acos(0.0)

omlbar = 2.0*pi/dble(dn)
omubar = 2.0*pi/dble(up)

akvec = 0.0
avec = 0.0

kr = dble(k)

akvec(1) = (omubar - omlbar)/pi

do j = 1, k
    kj = dble(j)
    akvec(j+1) = (dsin(dble(kj*omubar)) - dsin(dble(kj*omlbar)))/(kj*pi)
end do

theta = akvec(1) + 2.0*sum(akvec(2:k+1))
theta = -1.0*(theta/(2.0*kr + 1.0))

akvec = akvec + theta

avec(k+1) = akvec(1)

do j = 1, k
    avec(k+1 - j) = akvec(j+1)
    avec(k+1 + j) = akvec(j+1)
end do

do j = 1, k*2+1
    tvec(j) = 1.0 - avec(j)
end do

ybp = 0.0
yt = 0.0

do j = k + 1, n - k
    ybp(j) = dot_product(avec, y(j - k: j + k))
    yt(j) = dot_product(tvec, y(j - k: j + k))
end do

end subroutine bkfilter


subroutine distancef(vart, varf, ntt, ntf, nxy, dist)
! Estimate the Euclidean distance between the given atmospheric circulation
! variable, say X, daily or monthly mean and all other daily or monthly means within the training period
!
!
! INPUT->  vart(nxy,ntt)      : X array for all months/days of the training period
!          varf(nxy,ntf)      : X array for the month/day under scrutiny for the analogue search
!          ntt                : number of months/days in the training period
!          ntf                : number of months/days under scrutiny for the analogue search
!          nxy                : number of gridpoints
!
! OUTPUT-> dist(ntf,ntt)      : distance array
!
!
  implicit none
   integer                     ::ntt, ntf, nxy
   real                        vart(nxy, ntt), varf(nxy, ntf), dist(ntf, ntt)
   integer                     ::n, m

   !$OMP PARALLEL DO PRIVATE(m)
   do n=1,ntt

      do m=1,ntf
         dist(m,n)              = sqrt(sum(( vart(:,n) - varf(:,m) )**2))
      end do

   end do
   !$OMP END PARALLEL DO

end subroutine distancef


c     ===================================
c     MAIN PROGRAM
c		This program takes a function and
c		computes its definite integral in
c		a region (a, b)
c     ===================================
      program main

c	  Variables
      real*8 a, b, h, hn, error, conv, res, reslast, sum, x
      real*8 f, df2, df4
      integer n, choice, i, j, l
      j = 1
      conv = 1

c     Parameters
c		defining the region to integrate
      a = 0.0d0
      b = 1.0d0

c     User's choice of polynomial order
1     write(*,*) 'Choose the order of the polynomial (1, 2, or 3)'
      read(*,*) choice

      if ((choice.ne.1) .and. (choice.NE.2) .and. (choice.NE.3)) then
        write(*,*) '--- not supported choice ---'
        go to 1
      endif
      if (choice .eq. 1) then
        go to 10
      endif
      if (choice .eq. 2) then
        go to 20
      endif
      if (choice .eq. 3) then
        go to 30
      endif
c     end of polynomial choice

c     ---------------------------------
c	  1st degree polynomial - Trapezoid
c     ---------------------------------
10    continue
      write(*,*) 'Method of choice: Trapezoid (1st degree polynomial)'
c	  Starting parameters
      n = 2
      l = 2

15    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f0 + 2f1 + 2f2 + ... + 2fn-1 + fn
      i = 1
11    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      else
        sum = sum + 2 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 11
      endif

c	  Calculation of the result
      res = sum * (hn/2.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**2 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/12.0d0) * hn * (b-a) * df2( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 15
      endif
      go to 99
c	  End of Trapezoid

c     -------------------------------
c	  2nd degree polynomial - Simpson
c     -------------------------------
20    continue
      write(*,*) 'Method of choice: Simpson (2nd degree polynomial)'
c	  Starting parameters
      n = 2
      l = 2

25    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f1 + 4f2 + f3 + ... + fn-1 + 4fn + fn+1
      i = 1
21    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      elseif (mod(i,2).eq.0) then
        sum = sum + 4 * f(x)
      else
        sum = sum + 2 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 21
      endif

c	  Calculation of the result
      res = sum * (hn/3.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**4 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/80.0d0) * (hn**4) * (b-a) * df4( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 25
      endif

      go to 99
c	  End of Simpson

c     -----------------------------------
c	  3rd degree polynomial - Simpson 3/8
c     -----------------------------------
30    continue
      write(*,*) 'Method of choice: Simpson 3/8 (3rd degree polynomial)'
c	  Starting parameters
      n = 3
      l = 2

35    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f0 + 2f1 + 2f2 + ... + 2fn-1 + fn
      i = 1
31    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      elseif (mod(i,3).eq.1) then
        sum = sum + 2 * f(x)
      else
        sum = sum + 3 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 31
      endif

c	  Calculation of the result
      res = sum * (3.0d0*hn/8.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**4 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/12.0d0) * hn * (b-a) * df2( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 35
      endif
      go to 99
c 	  End of Simpson 3/8

99    continue
      write(*,*) '-----------------------------------'
      write(*,*) 'number of points: ', n
      write(*,*) 'result: ', res
      write(*,*) 'error', error
      write(*,*) 'convergence', conv
      end

c     =========================================
c	  FUNCTION
c		Definition of the function to integrate
c     =========================================
      real*8 function f(x)
      real*8 x

      f = log(x+2.0d-1)

      return
      end

c     =============================================
c	  FUNCTION
c		Definition of the function's 2nd derivative
c     =============================================
      real*8 function df2(x)
      real*8 x

      df2 = - 1.0d0 / (x + 2.0d-1)**2

      return
      end

c     =============================================
c	  FUNCTION
c		Definition of the function's 4th derivative
c     =============================================
      real*8 function df4(x)
      real*8 x

      df4 = - 6.0d0 / (x + 2.0d-1)**4

      return
      end

c     ==============================================
c	  FUNCTION
c		calculating the steps from the needed points
c     ==============================================
      real*8 function h(a,b,n)
      real*8 a, b
      integer n

      h = (b-a)/(n-1)

      return
      end

computational math/numerical integral calculation - differential equation integration 1.(a2).f


      subroutine cqdrtc(Coef,Sol,NSol)
c     Combutes the zeros of a quadratic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(3)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a and b are zero
      COMPLEX*16 Sol(2)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 q, Sqrt
      DOUBLE PRECISION Sgn, Root

      IF(Coef(1).eq.0.d0) THEN
         IF(Coef(2).eq.0.d0) THEN
            NSol = -1
            RETURN
         ELSE
            NSol = 1
            Sol(1) = -Coef(3)/Coef(2)
         END IF
      ELSE
         NSol = 2
         Root = DBLE(Sqrt(Coef(2)**2-4.d0*Coef(1)*Coef(3)))
         Sgn  = SIGN(DBLE(CONJG(Coef(2))*Root),1.d0)
         q    = -0.5d0*(Coef(2) + Sgn*Root)

         Sol(1) = q/Coef(1)
         Sol(2) = Coef(3)/q
      END IF

      RETURN
      END

      subroutine ccubic(Coef,Sol,NSol)
c     Combutes the zeros of a cubic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(4)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a, b, and c are zero
      COMPLEX*16 Sol(4)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 P1, P2, Q, R, Coef2(3), a, b, c
      DOUBLE PRECISION Sgn, Theta
c     PARAMETERS
      COMPLEX*16 I
      PARAMETER(I = (0.d0, 1.d0))
      DOUBLE PRECISION Pi
      PARAMETER(Pi = 3.141592653589793238462643d0)

      IF(Coef(1).eq.0.d0) THEN
         Coef2(1) = Coef(2)
         Coef2(2) = Coef(3)
         Coef2(3) = Coef(4)
         CALL CQdrtc(Coef2,Sol,NSol)
      ELSE
         a = Coef(2)/Coef(1)
         b = Coef(3)/Coef(1)
         c = Coef(4)/Coef(1)
         NSol = 3
         Q = (a**2 - 3.d0*b)/9.d0
         R = (2.d0*a**3 - 9.d0*a*b + 27.d0*c)/54.d0

         IF(((DIMAG(Q).eq.0.d0).and.(DIMAG(R).eq.0.d0)).and.
     &        (DIMAG(R**2).lt.DIMAG(Q**3))) THEN
            Theta = ACOS (DBLE(R/SQRT(Q**3)))
            Sol(1) = -2*SQRT(Q)*Cos(Theta/3.d0) - a/3.d0
            Sol(2) = -2*SQRT(Q)*Cos((Theta+2.d0*Pi)/3.d0) - a/3.d0
            Sol(3) = -2*SQRT(Q)*Cos((Theta-2.d0*Pi)/3.d0) - a/3.d0
         ELSE
            Sgn = SIGN(1.d0, DBLE(CONJG(R)*SQRT(R**2-Q**3)))
            P1 = -(R + Sgn*SQRT(R**2-Q**3))**(1.d0/3.d0)
            IF(P1.eq.0.d0) THEN
               P2 = 0.d0
            ELSE
               P2 = Q/P1
            END IF
            Sol(1) = (P1 + P2) - a/3.d0
            Sol(2) = -0.5d0*(P1 + P2) - a/3.d0 +
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
            Sol(3) = -0.5d0*(P1 + P2) - a/3.d0 -
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
         END IF
      END IF

      RETURN
      END


MODULE module_circle

    IMPLICIT NONE
    REAL, PARAMETER :: PI = 3.1415926

CONTAINS

    REAL FUNCTION circle_area( radius )
        IMPLICIT NONE
        REAL, INTENT(IN) :: radius

        circle_area=PI*(radius**2)
    END FUNCTION

    REAL FUNCTION circle_perimeter( radius )
        IMPLICIT NONE
        REAL, INTENT(IN) :: radius

        circle_perimeter=2*PI*radius
    END FUNCTION

END MODULE module_circle


PROGRAM F007

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: NTH = 10001, N = 1E+6
    INTEGER :: I, J, PRIMES_N
    LOGICAL, DIMENSION(N+1) :: INTEGERS_LIST

    ! USING THE ALGORITHM OF SIEVE OF EROSTHENES
    INTEGERS_LIST = .TRUE.
    I = 2
    DO WHILE ((I*I) <= N)
        IF (INTEGERS_LIST(I)) THEN
            J = I * I
            DO WHILE (J <= N)
                INTEGERS_LIST(J) = .FALSE.
                J = J + I
            END DO
        END IF
        I = I + 1
    END DO

    PRIMES_N = 0
    DO I = 2, N
        IF (INTEGERS_LIST(I)) THEN
            PRIMES_N = PRIMES_N + 1
            IF (PRIMES_N == NTH) THEN
                GOTO 10
            END IF
        END IF
    END DO

    10 CONTINUE

    PRINT ('(I0)'), I

END PROGRAM F007


! The number 3797 has an interesting property.
! Being prime itself, it is possible
! to continuously remove digits from left to right,
! and remain prime at each stage: 3797, 797, 97, and 7.
! Similarly we can work from right to left: 3797, 379, 37, and 3.

! Find the sum of the only eleven primes that are
! both truncatable from left to right and right to left.

! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes.

! Answer: 748317
! Project Euler: 37

program main

use euler

implicit none

        integer (kind=8), parameter :: PRIME_C = 11;
        integer (kind=8), parameter :: BASE = 10;
        integer (kind=8), parameter :: TWO = 2;
        integer (kind=8) :: c, sum, i;

        c = 0;
        sum = 0;
        i = 3;

        do while(.true.)

                if(truncatable_prime(i)) then

                        call inc(c, ONE);
                        call inc(sum, i);

                        if(c == PRIME_C) then
                                goto 24
                        endif
                endif

                call inc(i, TWO);

        end do

24      CONTINUE

        call printint(sum);

contains

        ! Establishes whether an integer is a truncatable prime. We do this
        ! efficiently by leveraging most of the work into
        ! `possibly_truncatable`, whereby we can check if a number is even
        ! remotely worth running through an expensive check to see if it is
        ! prime. We then check if it is truncatable from both L&R

        pure function truncatable_prime(i)

                integer (kind=8), intent(in) :: i;
                logical :: truncatable_prime

                truncatable_prime = .false.

                if(i < 10 .OR. (.NOT. possibly_truncatable(i))) then
                        return
                endif

                truncatable_prime = (right_trunc(i) .AND. left_trunc(i))

                return

        end function truncatable_prime

        pure function right_trunc(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: right_trunc;

                tmp = i;
                right_trunc = .false.

                do while(tmp /= 0)

                        if(.NOT. isprime(tmp)) then
                                return;
                        endif

                        tmp = tmp / 10;

                end do

                right_trunc = .true.

        end function right_trunc

        ! Truncate from the left in a method that is much akin to how we do it
        ! in the `right_trunc` function.

        pure function left_trunc(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: left_trunc

                tmp = i;
                left_trunc = .false.

                do while(tmp /= 0)

                        if(.NOT. isprime(tmp)) then
                                return;
                        endif

                        tmp = intrev(intrev(tmp) / 10);

                end do

                left_trunc = .true.

                return

        end function left_trunc

        ! For a number to be prime it must be odd, unless it is two. In this
        ! notion, we may reduce our search space by testing if any of the
        ! digits is even. If so, we know that this number is impossible to
        ! be a truncatable prime. This saves a lot of cycles as we don't need
        ! to expensively check if numbers are prime or not if they aren't even
        ! in the realms of probability of being true.

        pure function possibly_truncatable(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp, end_d;
                logical :: possibly_truncatable, has_2;

                possibly_truncatable = .false.
                has_2 = .false.
                tmp = i;

                do while(tmp /= 0)

                        ! Check if the end digit is even, but allow one
                        ! occurance of two
                        end_d = mod(tmp, BASE);

                        if(mod(end_d, 2) == 0) then

                                if (end_d == 2) then

                                        if(has_2) then
                                                return;
                                        else
                                                has_2 = .true.
                                        endif
                                else
                                        return;

                                endif
                        endif

                        tmp = tmp / BASE;
                end do

                possibly_truncatable = .true.

        end function possibly_truncatable

end program main


	FUNCTION PR_WCEQ ( tmpf, sknt )
C************************************************************************
C* PR_WCEQ								*
C*									*
C* This function computes WCEQ, the wind chill equivalent temperature,	*
C* from TMPF and SKNT.  The input values will first be converted to	*
C* Celsius and meters per second.  The output will be calculated in	*
C* Fahrenheit.								*
C*									*
C* WCEQ is the temperature with calm winds that produces the same	*
C* cooling effect as the given temperature with the given wind speed.	*
C*									*
C* The following equation is used:					*
C*									*
C*	PR_WCEQ = 33.0 - ( (33.0 - TMPC) * WCI (SPED) / WCI (1.34) )	*
C*									*
C*		where: WCI ( V ) = ( 10.0 * SQRT ( V ) + 10.45 - V )	*
C*									*
C* From: R. Falconer, "Windchill, A Useful Wintertime Weather		*
C*			Variable", Weatherwise, Dec 1968.		*
C*									*
C* REAL PR_WCEQ ( TMPF, SKNT )						*
C*									*
C* Input parameters:							*
C*	TMPF		REAL		Air temperature in deg F	*
C*	SKNT		REAL		Wind speed in knots		*
C*									*
C* Output parameters:							*
C*	PR_WCEQ		REAL		Wind Chill equivalent		*
C*					  temperature in deg F		*
C**									*
C* Log:									*
C* M. Nelson		 7/92	Environmental Information		*
C*				  Summaries C-3, 1975.			*
C* S. Jacobs/EAI	 3/93	Cleaned up				*
C* S. Jacobs/NCEP	 3/96	Recoded and commented equation		*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C*
	WCI ( vel ) = ( 10.0 * SQRT ( vel ) + 10.45 - vel )
C------------------------------------------------------------------------
C*	Convert input variables to Celsius and meters/second.
C
	tmpc = PR_TMFC ( tmpf )
	sped = PR_KNMS ( sknt )
C
C*	Compute the wind chill temp if the inputs are not missing
C*	and the wind speed is greater than 1.34 m/s.
C
	IF  ( ( ERMISS ( tmpc ) ) .or. ( ERMISS ( sped ) ) ) THEN
	    wndchl = RMISSD
	ELSE IF  ( sped .le. 1.34 )  THEN
	    wndchl = tmpc
	ELSE
	    wndchl = 33.0 - ( ( 33.0-tmpc ) * WCI(sped) / WCI(1.34) )
	END IF
C
C*	Convert to Fahrenheit for the user.
C
	PR_WCEQ = PR_TMCF ( wndchl )
C*
	RETURN
	END