*DECK DHSTRT
      SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL,
     +   BIG, SPY, PV, YP, SF, RPAR, IPAR, H)
C***BEGIN PROLOGUE  DHSTRT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEABM, DDEBDF and DDERKF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (HSTART-S, DHSTRT-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   DHSTRT computes a starting step size to be used in solving initial
C   value problems in ordinary differential equations.
C
C **********************************************************************
C  ABSTRACT
C
C     Subroutine DHSTRT computes a starting step size to be used by an
C     initial value method in solving ordinary differential equations.
C     It is based on an estimate of the local Lipschitz constant for the
C     differential equation   (lower bound on a norm of the Jacobian) ,
C     a bound on the differential equation  (first derivative) , and
C     a bound on the partial derivative of the equation with respect to
C     the independent variable.
C     (all approximated near the initial point A)
C
C     Subroutine DHSTRT uses a function subprogram DHVNRM for computing
C     a vector norm. The maximum norm is presently utilized though it
C     can easily be replaced by any other vector norm. It is presumed
C     that any replacement norm routine would be carefully coded to
C     prevent unnecessary underflows or overflows from occurring, and
C     also, would not alter the vector or number of components.
C
C **********************************************************************
C  On input you must provide the following
C
C      DF -- This is a subroutine of the form
C                               DF(X,U,UPRIME,RPAR,IPAR)
C             which defines the system of first order differential
C             equations to be solved. For the given values of X and the
C             vector  U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must
C             evaluate the NEQ components of the system of differential
C             equations  DU/DX=DF(X,U)  and store the derivatives in the
C             array UPRIME(*), that is,  UPRIME(I) = * DU(I)/DX *  for
C             equations I=1,...,NEQ.
C
C             Subroutine DF must not alter X or U(*). You must declare
C             the name DF in an external statement in your program that
C             calls DHSTRT. You must dimension U and UPRIME in DF.
C
C             RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter
C             arrays which you can use for communication between your
C             program and subroutine DF. They are not used or altered by
C             DHSTRT. If you do not need RPAR or IPAR, ignore these
C             parameters by treating them as dummy arguments. If you do
C             choose to use them, dimension them in your program and in
C             DF as arrays of appropriate length.
C
C      NEQ -- This is the number of (first order) differential equations
C             to be integrated.
C
C      A -- This is the initial point of integration.
C
C      B -- This is a value of the independent variable used to define
C             the direction of integration. A reasonable choice is to
C             set  B  to the first point at which a solution is desired.
C             You can also use  B, if necessary, to restrict the length
C             of the first integration step because the algorithm will
C             not compute a starting step length which is bigger than
C             ABS(B-A), unless  B  has been chosen too close to  A.
C             (it is presumed that DHSTRT has been called with  B
C             different from  A  on the machine being used. Also see the
C             discussion about the parameter  SMALL.)
C
C      Y(*) -- This is the vector of initial values of the NEQ solution
C             components at the initial point  A.
C
C      YPRIME(*) -- This is the vector of derivatives of the NEQ
C             solution components at the initial point  A.
C             (defined by the differential equations in subroutine DF)
C
C      ETOL -- This is the vector of error tolerances corresponding to
C             the NEQ solution components. It is assumed that all
C             elements are positive. Following the first integration
C             step, the tolerances are expected to be used by the
C             integrator in an error test which roughly requires that
C                        ABS(LOCAL ERROR)  .LE.  ETOL
C             for each vector component.
C
C      MORDER -- This is the order of the formula which will be used by
C             the initial value method for taking the first integration
C             step.
C
C      SMALL -- This is a small positive machine dependent constant
C             which is used for protecting against computations with
C             numbers which are too small relative to the precision of
C             floating point arithmetic.  SMALL  should be set to
C             (approximately) the smallest positive DOUBLE PRECISION
C             number such that  (1.+SMALL) .GT. 1.  on the machine being
C             used. The quantity  SMALL**(3/8)  is used in computing
C             increments of variables for approximating derivatives by
C             differences.  Also the algorithm will not compute a
C             starting step length which is smaller than
C             100*SMALL*ABS(A).
C
C      BIG -- This is a large positive machine dependent constant which
C             is used for preventing machine overflows. A reasonable
C             choice is to set big to (approximately) the square root of
C             the largest DOUBLE PRECISION number which can be held in
C             the machine.
C
C      SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work
C             arrays of length NEQ which provide the routine with needed
C             storage space.
C
C      RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and
C             INTEGER type, respectively, which can be used for
C             communication between your program and the DF subroutine.
C             They are not used or altered by DHSTRT.
C
C **********************************************************************
C  On Output  (after the return from DHSTRT),
C
C      H -- is an appropriate starting step size to be attempted by the
C             differential equation method.
C
C           All parameters in the call list remain unchanged except for
C           the working arrays SPY(*),PV(*),YP(*), and SF(*).
C
C **********************************************************************
C
C***SEE ALSO  DDEABM, DDEBDF, DDERKF
C***ROUTINES CALLED  DHVNRM
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891024  Changed references from DVNORM to DHVNRM.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DHSTRT
C
      INTEGER IPAR, J, K, LK, MORDER, NEQ
      DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY,
     1      DFDUB, DFDXB, DHVNRM,
     2      DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY,
     3      SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME
      DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),
     1          SF(*),RPAR(*),IPAR(*)
      EXTERNAL DF
C
C     ..................................................................
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 160
C***FIRST EXECUTABLE STATEMENT  DHSTRT
         DX = B - A
         ABSDX = ABS(DX)
         RELPER = SMALL**0.375D0
C
C        ...............................................................
C
C             COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL
C             DERIVATIVE OF THE EQUATION WITH RESPECT TO THE
C             INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW.
C             ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE
C             LOCALLY.
C
         DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX),
     1                    100.0D0*SMALL*ABS(A)),DX)
         IF (DA .EQ. 0.0D0) DA = RELPER*DX
         CALL DF(A+DA,Y,SF,RPAR,IPAR)
         DO 10 J = 1, NEQ
            YP(J) = SF(J) - YPRIME(J)
   10    CONTINUE
         DELF = DHVNRM(YP,NEQ)
         DFDXB = BIG
         IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA)
         FBND = DHVNRM(SF,NEQ)
C
C        ...............................................................
C
C             COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ
C             CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS
C             ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN
C             LOCALLY.  THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO
C             ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES.
C             THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL
C             DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND
C             PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF
C             THE DIFFERENTIAL EQUATION.  THE THIRD PERTURBATION VECTOR
C             IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL
C             VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO
C             NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN
C             INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT
C             COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE
C             CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES.
C             ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST
C             DERIVATIVE.
C
C                               PERTURBATION VECTOR SIZE IS HELD
C                               CONSTANT FOR ALL ITERATIONS. COMPUTE
C                               THIS CHANGE FROM THE
C                                       SIZE OF THE VECTOR OF INITIAL
C                                       VALUES.
         DELY = RELPER*DHVNRM(Y,NEQ)
         IF (DELY .EQ. 0.0D0) DELY = RELPER
         DELY = SIGN(DELY,DX)
         DELF = DHVNRM(YPRIME,NEQ)
         FBND = MAX(FBND,DELF)
         IF (DELF .EQ. 0.0D0) GO TO 30
C           USE INITIAL DERIVATIVES FOR FIRST PERTURBATION
            DO 20 J = 1, NEQ
               SPY(J) = YPRIME(J)
               YP(J) = YPRIME(J)
   20       CONTINUE
         GO TO 50
   30    CONTINUE
C           CANNOT HAVE A NULL PERTURBATION VECTOR
            DO 40 J = 1, NEQ
               SPY(J) = 0.0D0
               YP(J) = 1.0D0
   40       CONTINUE
            DELF = DHVNRM(YP,NEQ)
   50    CONTINUE
C
         DFDUB = 0.0D0
         LK = MIN(NEQ+1,3)
         DO 140 K = 1, LK
C           DEFINE PERTURBED VECTOR OF INITIAL VALUES
            DO 60 J = 1, NEQ
               PV(J) = Y(J) + DELY*(YP(J)/DELF)
   60       CONTINUE
            IF (K .EQ. 2) GO TO 80
C              EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED
C              VECTOR  AND  COMPUTE CORRESPONDING DIFFERENCES
               CALL DF(A,PV,YP,RPAR,IPAR)
               DO 70 J = 1, NEQ
                  PV(J) = YP(J) - YPRIME(J)
   70          CONTINUE
            GO TO 100
   80       CONTINUE
C              USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE
C                                    IN COMPUTING ONE ESTIMATE
               CALL DF(A+DA,PV,YP,RPAR,IPAR)
               DO 90 J = 1, NEQ
                  PV(J) = YP(J) - SF(J)
   90          CONTINUE
  100       CONTINUE
C           CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE
C                          AND A LOCAL LIPSCHITZ CONSTANT
            FBND = MAX(FBND,DHVNRM(YP,NEQ))
            DELF = DHVNRM(PV,NEQ)
C        ...EXIT
            IF (DELF .GE. BIG*ABS(DELY)) GO TO 150
            DFDUB = MAX(DFDUB,DELF/ABS(DELY))
C     ......EXIT
            IF (K .EQ. LK) GO TO 160
C           CHOOSE NEXT PERTURBATION VECTOR
            IF (DELF .EQ. 0.0D0) DELF = 1.0D0
            DO 130 J = 1, NEQ
               IF (K .EQ. 2) GO TO 110
                  DY = ABS(PV(J))
                  IF (DY .EQ. 0.0D0) DY = DELF
               GO TO 120
  110          CONTINUE
                  DY = Y(J)
                  IF (DY .EQ. 0.0D0) DY = DELY/RELPER
  120          CONTINUE
               IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J)
               IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J))
               YP(J) = DY
  130       CONTINUE
            DELF = DHVNRM(YP,NEQ)
  140    CONTINUE
  150    CONTINUE
C
C        PROTECT AGAINST AN OVERFLOW
         DFDUB = BIG
  160 CONTINUE
C
C     ..................................................................
C
C          COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE
C
      YDPB = DFDXB + DFDUB*FBND
C
C     ..................................................................
C
C          DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP
C          SIZE IS TO BE BASED.  A VALUE IN THE MIDDLE OF THE ERROR
C          TOLERANCE RANGE IS SELECTED.
C
      TOLMIN = BIG
      TOLSUM = 0.0D0
      DO 170 K = 1, NEQ
         TOLEXP = LOG10(ETOL(K))
         TOLMIN = MIN(TOLMIN,TOLEXP)
         TOLSUM = TOLSUM + TOLEXP
  170 CONTINUE
      TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1))
C
C     ..................................................................
C
C          COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND
C          SECOND DERIVATIVE INFORMATION
C
C                            RESTRICT THE STEP LENGTH TO BE NOT BIGGER
C                            THAN ABS(B-A).   (UNLESS  B  IS TOO CLOSE
C                            TO  A)
      H = ABSDX
C
      IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180
C
C        BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND
C                     DERIVATIVE TERM (YDPB) ARE ZERO
         IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP
      GO TO 200
  180 CONTINUE
C
      IF (YDPB .NE. 0.0D0) GO TO 190
C
C        ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO
         IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND
      GO TO 200
  190 CONTINUE
C
C        SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO
         SRYDPB = SQRT(0.5D0*YDPB)
         IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB
  200 CONTINUE
C
C     FURTHER RESTRICT THE STEP LENGTH TO BE NOT
C                               BIGGER THAN  1/DFDUB
      IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB
C
C     FINALLY, RESTRICT THE STEP LENGTH TO BE NOT
C     SMALLER THAN  100*SMALL*ABS(A).  HOWEVER, IF
C     A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO,
C     THE ALGORITHM RETURNS  SMALL*ABS(B)  FOR THE
C                                     STEP LENGTH.
      H = MAX(H,100.0D0*SMALL*ABS(A))
      IF (H .EQ. 0.0D0) H = SMALL*ABS(B)
C
C     NOW SET DIRECTION OF INTEGRATION
      H = SIGN(H,DX)
C
      RETURN
      END


REAL FUNCTION quadf(x, a, b, c)
IMPLICIT NONE
  REAL, INTENT(IN) :: x, a, b, c
  quadf = a * x**2 + b * x + c
END FUNCTION quadf

PROGRAM test_quadf
IMPLICIT NONE
  REAL :: quadf, a, b, c, x
  WRITE(*, *) "Enter coefficients a, b, and c for a quadratic equation:"
  READ(*, *) a, b, c
  WRITE(*, *) "Enter an x value to evualate the equation:"
  READ(*, *) x
  WRITE(*, 100) 'quadf(', x, ') = ', quadf(x, a, b, c)
  100 FORMAT (A, F10.4, a, F12.4)
END PROGRAM test_quadf


      SUBROUTINE BPASS(FL,FH,FILT,NPTS,SI,SCR)
!    BPASS1 GENERATES A ZERO PHASE TIME DOMAIN FILTER.  THE IMPULSE RESPONSE
! WILL HAVE AN ENERGY OF 1., THUS ALLEVIATING SCALING PROBLEMS DUE TO DIFFERENT
! BANDWIDTHS.
!    THE DESIGN IS DONE IN THE TIME DOMAIN AND IS THE SHORTEST AND SIMPLIEST,
! BUT IS NOT AS GOOD (STEEPNESS OF CUT OFF) AS SOME OPTIMIZING METHODS.
! THE FILTER IS BETTER THE MORE POINTS IT HAS, AND IS WORSE THE LESS POINTS IT
! HAS.  39 POINTS IS A NICE NUMBER
!    THE METHOD OF DESIGN IS:
!   1) GENERATE A COSINE AT A FREQUENCY W1 WHICH IS HALFWAY BETWEEN THE CUTOFF
!     IN THE FREQUENCY DOMAIN THIS IS A SPIKE AT FREQUENCY W1.
!   2) MULTIPLY 1 BY A SINC FUNCTION OF FREQUENCY WC WHICH IS HALF THE BANDWIDTH
!     IN THE FREQUENCY DOMAIN THIS IS CONVOLVING 1 WHITH A BOX CAR.
!   3) MULTIPLY THE RESULT BY A WINDOW TO PREVENT DISCONTINUITIES.  IN THE
!     FREQUENCY DOMAIN THIS IS CONVOLVING THE BOX CAR WITH A SMOOTHING FUNCTION.
!
!  ARGUMENTS:
!      FL     - THE FREQUENCY OF THE LOW CORNER
!      FH     - THE FREQUENCY OF THE HIGH CORNER
!      FILT   - THE ARRAY TO RECEIVE THE TIME DOMAIN FILTER POINTS.
!      NPTS   - THE NUMBER OF FILTER POINTS WANTED
!      SI     - THE SAMPLE INTERVAL IN SECONDS
!      SCR    - A SCRATCH ARRAY AT LEAST NPTS/2+1 LONG
!
!
!  WRITTEN AND COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, FEBRUARY 1979
!  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
!  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
!  mod 6 Oct 09 - change the documentation - sample interval, not sample rate.
!
      DIMENSION FILT(*),SCR(*)
      PI2=6.283197
      N=NPTS/2+1                                                        ! THE CENTRE POINT OF A ZERO PHASE FILTER
      W1=(FL+FH)/2.                                                     ! FIND THE CENTRE FREQUENCY
      WC=(FH-FL)/2.                                                     ! THE WIDTH OF THE BANDPASS
!****
!****    GENERATE A COSINE WAVE
!****
      P=1./W1/SI
      DO I=1,N
         SCR(I)=COS(FLOAT(I-1)/P*PI2)
      ENDDO
!****
!****   MULTIPLY BY A HALF SINC
!****
      P=1./WC/SI
      SCR(1)=1.
      DO I=2,N
         X=FLOAT(I-1)/P*PI2
         SCR(I)=SCR(I)*SIN(X)/X
      ENDDO
!****
!****     MULTIPLY BY A GOOD WINDOW  ( HAMMING)
!****
      CALL WINDOW(-6,FILT,N,DUM)
      DO I=1,N
         SCR(I)=SCR(I)*FILT(N-I+1)
      ENDDO
!****
!****      NOW MAKE A SYMMETRICAL FILTER OUT OF IT
!****
      DO 400 I=1,N
      FILT(I)=SCR(N-I+1)
      FILT(N+I-1)=SCR(I)
  400 CONTINUE
!****
!****        MAKE THE FILTER HAVE AN ENERGY OF 1.
!****
      E=0.
      DO I=1,NPTS
         E=E+FILT(I)*FILT(I)
      ENDDO
      C=1./SQRT(E)
      DO I=1,NPTS
         FILT(I)=FILT(I)*C
      ENDDO
      RETURN
      END


        program ge

          real, allocatable :: a(:,:),b(:)
          a = reshape(                             &
          [1.0, 1.00, 1.00,  1.00,   1.00,   1.00, &
           0.0, 0.63, 1.26,  1.88,   2.51,   3.14, &
           0.0, 0.39, 1.58,  3.55,   6.32,   9.87, &
           0.0, 0.25, 1.98,  6.70,  15.88,  31.01, &
           0.0, 0.16, 2.49, 12.62,  39.90,  97.41, &
           0.0, 0.10, 3.13, 23.80, 100.28, 306.02], [6,6] )
          b = [-0.01, 0.61, 0.91, 0.99, 0.60, 0.02]
          print'(f15.7)',solve_wbs(ge_wpp(a,b))

        contains

          function solve_wbs(u) result(x) ! solve with backward substitution
            real                 :: u(:,:)
            integer              :: i,n
            real   , allocatable :: x(:)
            n = size(u,1)
            allocate(x(n))
            forall (i=n:1:-1) x(i) = ( u(i,n+1) - sum(u(i,i+1:n)*x(i+1:n)) ) / u(i,i)
          end function

          function  ge_wpp(a,b) result(u) ! gaussian eliminate with partial pivoting
            real                 :: a(:,:),b(:),upi
            integer              :: i,j,n,p
            real   , allocatable :: u(:,:)
            n = size(a,1)
            u = reshape( [a,b], [n,n+1] )
            do j=1,n
              p = maxloc(abs(u(j:n,j)),1) + j-1 ! maxloc returns indices between (1,n-j+1)
              if (p /= j) u([p,j],j) = u([j,p],j)
              u(j+1:,j) = u(j+1:,j)/u(j,j)
              do i=j+1,n+1
                upi = u(p,i)
                if (p /= j) u([p,j],i) = u([j,p],i)
                u(j+1:n,i) = u(j+1:n,i) - upi*u(j+1:n,j)
              end do
            end do
          end function

        end program


! Check that parameters are correct intercepted.
! Constants with comma separations are commonly
! used, for instance Pi = 3._dp
subroutine foo(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 3._sp
  real(dp), parameter :: three_d = 3._dp
  integer(ii), parameter :: three_i = 3_ii
  integer(il), parameter :: three_l = 3_il
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine

subroutine foo_no(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 3.
  real(dp), parameter :: three_d = 3.
  integer(ii), parameter :: three_i = 3
  integer(il), parameter :: three_l = 3
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine

subroutine foo_sum(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 2._sp + 1._sp
  real(dp), parameter :: three_d = 1._dp + 2._dp
  integer(ii), parameter :: three_i = 2_ii + 1_ii
  integer(il), parameter :: three_l = 1_il + 2_il
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine


	FUNCTION PR_ALTP  ( pres, selv )
C************************************************************************
C* PR_ALTP								*
C*									*
C* This function computes altimeter from station pressure and		*
C* elevation. The following equation is used:				*
C*									*
C*     ALTI = PR_ALTI ( PRES * ( 1 - ( SELK * GAMUSD / To ) ) ** expo ) *
C*									*
C*          SELK  =  SELV / 1000					*
C*            To  =  US Std. Atmos. sea level temp in Kelvin		*
C*                =  TMCK + 15						*
C*          expo  =  - GRAVTY / ( GAMUSD * RDGAS ) * 1000		*
C*									*
C* REAL PR_ALTP  ( PRES, SELV )						*
C*									*
C* Input parameters:							*
C*	PRES		REAL	 	Station pressure in millibars	*
C*	SELV		REAL	 	Station elevation in meters	*
C*									*
C* Output parameters:							*
C*	PR_ALTP		REAL		Altimeter in inches		*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90	Adapted from PR_PALT			*
C* T. Lee/GSC		12/99	Used TMCK				*
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
        INCLUDE  	'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	to = TMCK + 15.
	IF  ( ERMISS ( pres ) .or. ERMISS ( selv ) )  THEN
	    PR_ALTP = RMISSD
	  ELSE
	    hgtk = PR_HGMK (selv)
C
C*	    Calculate the exponent.
C
	    expo =  - ( GRAVTY / ( GAMUSD * RDGAS ) * 1000.)
C
C*	    Calculate altimeter setting.
C
	    altm = pres * ( 1. - ( hgtk * GAMUSD / to ) ) ** expo
C
C*	    Convert to inches.
C
	    PR_ALTP = PR_ALTI  ( altm )
	END IF
C*
	RETURN
	END


program factorial
!  Test the floating-point factorial approximation
   use statistical
   implicit none
   integer :: n,nfact12
   real(8) :: nfact
   character(len=80) :: arg

   if (command_argument_count() /= 1) then
      write(*,'(a)') 'Usage: fact [n]'
      stop
   endif
   call get_command_argument(1,arg) ; read(arg,*) n
   write(*,*) n,'factorial:'
   nfact = fact(n)
   write(*,*) nfact
   if (n <= 12) then
      write(*,*) 'True integer value:'
      nfact12 = fact12(n)
      write(*,*) nfact12
      write(*,*) 'Relative error of approximation =', &
                           abs(real(nfact12)-nfact)/real(nfact12)
   endif

end program factorial


program monte_carlo_pi

    use iso_fortran_env, only: i64 => int64, dp => real64
    implicit none

    real(dp), parameter :: pi = 3.141592653589_dp
    integer(i64), parameter :: trials = 10**7, unit = 1._dp
    real(dp) :: answer, time(2)

    if (this_image() == 1) call cpu_time(time(1))
    answer = monte_carlo_test(trials)
    if (this_image() == 1) call cpu_time(time(2))

    if (this_image() == 1) then
        print "(a)", " Calculate Pi with CAF "
        print "(a)", "-----------------------"
        print "('trials  = ', i13)", trials
        print "('cores   = ', i13)", num_images()
        print "('tspan   = ', f11.4, ' s')", time(2) - time(1)
        print "('pi_cal  = ', f13.8)", answer
        print "('error   = ', f12.8, '%')", percent_error(answer)
    end if

contains

    elemental real(dp) function percent_error(val)
        real(dp), intent(in) :: val

        percent_error = abs(val - pi)/pi*100._dp
    end function percent_error

    pure function in_circle(x) result(ret)
        real(dp), intent(in) :: x(2)
        logical :: ret

        if (sqrt(sum(x**2)) <= unit) then
            ret = .true.
        else
            ret = .false.
        end if
    end function in_circle

    function monte_carlo_test(num_trials) result(ret)
        integer(i64), intent(in) :: num_trials
        real(dp) :: ret
        real(dp) :: x(2)
        integer(i64) :: i, counter

        counter = 0_i64; ret = 0._dp
        do i = 1, num_trials, num_images()
            call random_number(x)
            if (in_circle(x)) counter = counter + 1
        end do

        sync all
        call co_sum(counter, result_image=1)
        if (this_image() == 1) ret = 4._dp*counter/num_trials
    end function monte_carlo_test

end program monte_carlo_pi


! { dg-do run }
! PR 33683 - we used to pick up the wrong gamma function
! from the library on some systems.
program main
  implicit none
  integer, parameter :: n_max = 20
  double precision, dimension(0:n_max) :: c
  double precision :: pi
  integer :: n
  double precision :: td, xd
  real :: ts,xs

  pi = 4 * atan(1.d0)
  c(0) = 1.
  do n=1, n_max
     c(n) = (2*n-1)*c(n-1)*0.5d0
  end do

  do n=1, n_max
     xs = n + 0.5
     xd = n + 0.5d0
     td = c(n)*sqrt(pi)
     ts = c(n)*sqrt(pi)
     if (abs(gamma(xs)-ts)/ts > 9e-6) STOP 1
     if (abs(gamma(xd)-td)/td > 5e-14) STOP 2
  end do
  call tst_s(2.3, gamma(2.3))
  call tst_s(3.7, gamma(3.7))
  call tst_s(5.5, gamma(5.5))
  call tst_d(4.2d0, gamma(4.2d0))
  call tst_d(8.1d0, gamma(8.1d0))
contains
  subroutine tst_s(a, b)
    real :: a, b
    if (abs(gamma(a) - b)/b > 1e-6) STOP 3
  end subroutine tst_s

  subroutine tst_d(a, b)
    double precision :: a,b
    if (abs(gamma(a) - b)/b > 5e-14) STOP 4
  end subroutine tst_d
end program main


FUNCTION alngam(xvalue) RESULT(fn_val)

!     ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2

!     Calculation of the logarithm of the gamma function

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: xvalue
REAL (dp)             :: fn_val

! Local variables
REAL (dp) :: x, x1, x2, y

!     Coefficients of rational functions

REAL (dp), PARAMETER :: r1(9) = (/ -2.66685511495_dp, -24.4387534237_dp,  &
                                   -21.9698958928_dp,  11.1667541262_dp,  &
                                    3.13060547623_dp,  0.607771387771_dp, &
                                    11.9400905721_dp,  31.4690115749_dp,  &
                                    15.2346874070_dp /)
REAL (dp), PARAMETER :: r2(9) = (/ -78.3359299449_dp, -142.046296688_dp,  &
                                    137.519416416_dp,  78.6994924154_dp,  &
                                    4.16438922228_dp,  47.0668766060_dp,  &
                                    313.399215894_dp,  263.505074721_dp,  &
                                    43.3400022514_dp /)
REAL (dp), PARAMETER :: r3(9) = (/ -2.12159572323E5_dp,  2.30661510616E5_dp,  &
                                    2.74647644705E4_dp, -4.02621119975E4_dp,  &
                                   -2.29660729780E3_dp, -1.16328495004E5_dp,  &
                                   -1.46025937511E5_dp, -2.42357409629E4_dp,  &
                                   -5.70691009324E2_dp /)
REAL (dp), PARAMETER :: r4(5) = (/ 0.279195317918525_dp, 0.4917317610505968_dp, &
                                   0.0692910599291889_dp, 3.350343815022304_dp, &
                                   6.012459259764103_dp /)

!     Fixed constants

REAL (dp), PARAMETER :: alr2pi = 0.918938533204673_dp, four = 4._dp,  &
                        half = 0.5_dp, one = 1._dp, onep5 = 1.5_dp,   &
                        twelve = 12._dp, zero = 0._dp

!     Machine-dependant constants.
!     A table of values is given at the top of page 399 of the paper.
!     These values are for the IEEE double-precision format for which
!     B = 2, t = 53 and U = 1023 in the notation of the paper.

REAL (dp), PARAMETER :: xlge = 5.10E6_dp, xlgst = HUGE(1.0_dp)

x = xvalue
fn_val = zero

!     Test for valid function argument

IF (x >= xlgst) THEN
  WRITE(*, *) 'AS 245: Argument x too large'
  RETURN
END IF
IF (x <= zero) THEN
  WRITE(*, *) 'AS 245: Argument x <= 0'
  RETURN
END IF

!     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined

IF (x < onep5) THEN
  IF (x < half) THEN
    fn_val = -LOG(x)
    y = x + one

!     Test whether X < machine epsilon

    IF (y == one) RETURN
  ELSE
    fn_val = zero
    y = x
    x = (x - half) - half
  END IF
  fn_val = fn_val + x * ((((r1(5)*y + r1(4))*y + r1(3))*y + r1(2))*y + r1(1)) / &
                    ((((y + r1(9))*y + r1(8))*y+ r1(7))*y + r1(6))
  RETURN
END IF

!     Calculation for 1.5 <= X < 4.0

IF (x < four) THEN
  y = (x - one) - one
  fn_val = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x + r2(1)) /  &
               ((((x + r2(9))*x + r2(8))*x + r2(7))*x+ r2(6))
  RETURN
END IF

!     Calculation for 4.0 <= X < 12.0

IF (x < twelve) THEN
  fn_val = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) /  &
           ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6))
  RETURN
END IF

!     Calculation for X >= 12.0

y = LOG(x)
fn_val = x * (y - one) - half * y + alr2pi
IF (x > xlge) RETURN
x1 = one / x
x2 = x1 * x1
fn_val = fn_val + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) /  &
         ((x2 + r4(5))*x2 + r4(4))
RETURN
END FUNCTION alngam


program problem78
  use fmzm
  implicit none
  integer            :: i
  type(im)           :: temp,divisor,neg_one,zero,one,two
  integer, parameter :: memo_size=100000
  type(im)           :: memo(0:memo_size)

  neg_one=to_im(-1)
  zero=to_im(0)
  one=to_im(1)
  two=to_im(2)
  divisor=to_im(1000000)

  ! https://oeis.org/A000041
  do i=1,memo_size
     memo(i)=to_im(-1)
  end do
  memo(0)=one

  do i=1,memo_size
     temp=partitions(i)
     if (mod(temp,divisor)==zero) then
        print *, i
        exit
     end if
  end do

contains

  pure function plus_minus(n)
    implicit none
    integer, intent(in) :: n
    integer             :: plus_minus

    plus_minus=(-1)**((n-1)/2)

  end function plus_minus

  ! https://oeis.org/A001318
  function pentagonal(n)
    implicit none
    integer, intent(in) :: n
    integer             :: m,pentagonal

    if (mod(n,2)==1) then
       m=1
    else
       m=-1
    end if
    m=m*(n+1)/2
    pentagonal=m*(3*m-1)/2

  end function pentagonal

  ! https://en.wikipedia.org/wiki/Partition_(number_theory)#Generating_function
  function partitions(n)
    use fmzm
    implicit none
    integer, intent(in) :: n
    integer             :: i
    type(im)            :: partitions

    if (n<0) then
       partitions=zero
       return
    else if (n==0) then
       partitions=one
       return
    else if (memo(n)>neg_one) then
       partitions=memo(n)
       return
    else
       partitions=zero
       i=1
       do while (pentagonal(i)<=n)
          partitions=partitions+to_im(plus_minus(i))*memo(n-pentagonal(i))
          i=i+1
       end do
       memo(n)=partitions
       return
    end if

  end function partitions

end program problem78


! Shape functions
!
! author ....... Jan Tomec
! copyright .... Copyright 2020, Project THREAD - University of Rijeka, Faculty of Civil Engineering
! credits ...... Jan Tomec, Gordan Jelenić
! license ...... GPL
! version ...... 1.0.0
! maintainer ... Jan Tomec
! email ........ jan.tomec@gradri.uniri.hr
! status ....... Development
! date ......... 06/05/2020
!
! ------------------------------------------------------------------------------

module shape_functions

	implicit none

	private

	public :: shfun, shdfun

	contains

	! evaluate shape function in given points (gauss points)
	function shfun (e_ord, pts)

		implicit none

		integer, intent (in) :: e_ord
		double precision, dimension (:), intent (in) :: pts
		double precision, dimension (e_ord + 1, size (pts)) :: shfun

		if (e_ord == 1) then
			shfun (1, :) = -0.5D0 * pts + 0.5D0
			shfun (2, :) = 0.5D0 * pts + 0.5D0
		else if (e_ord == 2) then
			shfun (1, :) = 0.5D0 * pts ** 2 - 0.5D0 * pts
			shfun (2, :) = -1.0D0 * pts ** 2 + 1.0D0
			shfun (3, :) = 0.5D0 * pts ** 2 + 0.5D0 * pts
		else
			print *, 'Module: shape_functions, Function: shfun'
			print *, 'Message: Unexpected element_order.'
			stop
		end if

	end function shfun

	! evaluate shape function derivatives in given points (gauss points)
	function shdfun (e_ord, pts)

		implicit none

		integer, intent (in) :: e_ord
		double precision, dimension (:), intent (in) :: pts
		double precision, dimension (e_ord + 1, size (pts)) :: shdfun

		if (e_ord == 1) then
			shdfun (1, :) = -0.5D0
			shdfun (2, :) = 0.5D0
		else if (e_ord == 2) then
			shdfun (1, :) = pts - 0.5D0
			shdfun (2, :) = -2.0D0 * pts
			shdfun (3, :) = pts + 0.5D0
		else
			print *, 'Module: shape_functions, Function: shdfun'
			print *, 'Message: Unexpected element_order.'
			stop
		end if

	end function shdfun

end module


      SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for a given real polynomial P(x) and a quadratic
C     polynomial B(x), the quotient polynomial Q(x) and the linear
C     remainder polynomial R(x) such that
C
C        P(x) = B(x) * Q(x) + R(x),
C
C                                 2
C     where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x)
C     and u1, u2, q(1) and q(2) are real scalars.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DP      (input) INTEGER
C             The degree of the polynomial P(x).  DP >= 0.
C
C     P       (input) DOUBLE PRECISION array, dimension (DP+1)
C             This array must contain the coefficients of P(x) in
C             increasing powers of x.
C
C     U1      (input) DOUBLE PRECISION
C             The value of the constant term of the quadratic
C             polynomial B(x).
C
C     U2      (input) DOUBLE PRECISION
C             The value of the coefficient of x of the quadratic
C             polynomial B(x).
C
C     Q       (output) DOUBLE PRECISION array, dimension (DP+1)
C             If DP >= 1 on entry, then elements Q(1) and Q(2) contain
C             the coefficients q(1) and q(2), respectively, of the
C             remainder polynomial R(x), and the next (DP-1) elements
C             of this array contain the coefficients of the quotient
C             polynomial Q(x) in increasing powers of x.
C             If DP = 0 on entry, then element Q(1) contains the
C             coefficient q(1) of the remainder polynomial R(x) = q(1);
C             Q(x) is the zero polynomial.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given the real polynomials
C
C                DP           i                           2
C        P(x) = SUM p(i+1) * x  and B(x) = u1 + u2 * x + x
C               i=0
C
C     the routine uses the recurrence relationships
C
C        q(DP+1) = p(DP+1),
C
C        q(DP) = p(DP) - u2 * q(DP+1) and
C
C        q(i)  = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1
C
C     to determine the coefficients of the quotient polynomial
C
C               DP-2          i
C        Q(x) = SUM q(i+3) * x
C               i=0
C
C     and the remainder polynomial
C
C        R(x) = q(1) + q(2) * (u2 + x).
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01KD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations,
C     quadratic polynomial.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           DP, INFO
      DOUBLE PRECISION  U1, U2
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*), Q(*)
C     .. Local Scalars ..
      INTEGER           I, N
      DOUBLE PRECISION  A, B, C
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IF ( DP.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'MC01WD', -INFO )
         RETURN
      END IF
C
      INFO = 0
      N = DP + 1
      Q(N) = P(N)
      IF ( N.GT.1 ) THEN
         B = Q(N)
         Q(N-1) = P(N-1) - U2*B
         IF ( N.GT.2 ) THEN
            A = Q(N-1)
C
            DO 20 I = N - 2, 1, -1
               C = P(I) - U2*A - U1*B
               Q(I) = C
               B = A
               A = C
   20       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of MC01WD ***
      END


      subroutine DFMIN(X,XORF,MODE,TOL)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2004-11-11 DFMIN  Krogh  Removed if (..) C3 = statement doing nil.
c>> 2000-12-01 DFMIN  Krogh  Removed unused parameter ONE.
c>> 1996-03-30 DFMIN  Krogh  Added external statement.
C>> 1994-10-20 DFMIN  Krogh  Changes to use M77CON
C>> 1994-04-20 DFMIN  CLL Edited to make DP & SP files similar.
C>> 1987-12-09 DFMIN  Lawson  Initial code.
c
C     Finds a local minimum of a function f(x) in the closed interval
c     between A and B.
c     The function f(x) is defined by code in the calling program.
c     The user must initially provide A, B, and a tolerance, TOL.
c     The function will not be evaluated at A or B unless the
c     minimization search leads to one of these endpoints.
c
c     This subroutine uses reverse communication, i.e., it returns to
c     the calling program each time it needs to have f() evaluated at a
c     new value of x.
c     ------------------------------------------------------------------
c                   Subroutine Arguments
c
c  X, XORF, MODE  [all are inout]
c     On the initial call to this subroutine to solve a
c     new problem, the user must set MODE = 0, and must set
c        X = A
c        XORF = B
c        TOL = desired tolerance
c     A and B denote endpoints defining a closed
c     interval in which a local minimum is to be found.
c     Permit A < B or A > B or A = B.  If A = B the solution, x = A,
c     will be found immediately.
c     On any call the user can set MODE negative to start or stop
c     detail printing.  On such an entry we set NP = -1 - MODE, and
c     the normal algorithm will not be executed.  On the next NP calls
c     with MODE = 0 or 1, a detail line will be printed.
c
c  TOL [in]  is an absolute tolerance on the uncertainty in the final
c     estimate of the minimizing abcissa, X1.  Recommend TOL .ge. 0.
c     This subr will set TOLI = TOL if TOL > 0., and otherwise sets
c     TOLI = 0..  The operational tolerance at any trial abcissa, X,
c     will be
c         TOL2 = 2 * abs(X) * sqrt(D1MACH(4)) + (2/3) * C3
c     where C3 = TOLI/3.D0 + D1MACH(4)**2 where TOLI = max(TOL,0.D0).
c
c     On each return this subr will set MODE to a value in the range
c     [1:3] to indicate the action needed from the calling program or
c     the status on termination.
c
c     = 1 means the calling program must evaluate
c     f(X), store the value in XORF, and then call this
c     subr again.
c
c     = 2 means normal termination.  X contains the point of the
c     minimum and XORF contains f(X).
c
c     = 3 as for 2 but the requested accuracy could not be obtained.
c
c     = 4 means termination on an error condition:
c         MODE on entry not in [0:1].
c     ------------------------------------------------------------------
c  This algorithm is due to Richard. P. Brent.  It is presented as
c  an ALGOL procedure, LOCALMIN, in his 1973 book,
c  "Algorithms for minimization without derivatives", Prentice-Hall.
c  Published as subroutine FMIN in Forsythe, Malcolm, and Moler,
c  "Computer Methods for Mathematical Computations", Prentice-Hall,
c  1977.
c  The current subroutine adapted from F.,M.& M. by C. L. Lawson, and
c  F. T. Krogh, JPL, Oct 1987, for use in Fortran 77 in the JPL
c  MATH77 library.  The changes improve performance when a minimum is
c  at an endpoint, and change the user interface to reverse
c  communication.  Unlike the original, the changed algorithm may
c  evaluate the function at one of the end points.
c     ------------------------------------------------------------------
c  Subprograms referenced: D1MACH, IERM1
c     ------------------------------------------------------------------
c  THE METHOD USED IS A COMBINATION OF  GOLDEN  SECTION  SEARCH  AND
C  SUCCESSIVE PARABOLIC INTERPOLATION.  CONVERGENCE IS NEVER MUCH SLOWER
C  THAN  THAT  FOR  A  FIBONACCI SEARCH.  IF  F  HAS A CONTINUOUS SECOND
C  DERIVATIVE WHICH IS POSITIVE AT THE MINIMUM (WHICH IS NOT  AT  AX  OR
C  BX),  THEN  CONVERGENCE  IS  SUPERLINEAR, AND USUALLY OF THE ORDER OF
C  ABOUT  1.324....
c   THE FUNCTION  F  IS NEVER EVALUATED AT TWO POINTS CLOSER TOGETHER
C  THAN  EPS*ABS(FMIN) + (TOLI/3), WHERE EPS IS APPROXIMATELY THE SQUARE
C  ROOT  OF  THE  RELATIVE  MACHINE  PRECISION.  IF F IS A UNIMODAL
C  FUNCTION AND THE COMPUTED VALUES OF F ARE ALWAYS UNIMODAL WHEN
C  SEPARATED BY AT LEAST  EPS*ABS(X) + (TOLI/3), THEN  FMIN APPROXIMATES
C  THE ABCISSA OF THE GLOBAL MINIMUM OF F ON THE INTERVAL [AX,BX] WITH
C  AN ERROR LESS THAN  3*EPS*ABS(FMIN) + TOLI.  IF F IS NOT UNIMODAL,
C  THEN FMIN MAY APPROXIMATE A LOCAL, BUT PERHAPS NON-GLOBAL, MINIMUM TO
C  THE SAME ACCURACY. (Comments from F., M. & M.)
c     ------------------------------------------------------------------
c--D replaces "?": ?FMIN
c     Both versions use IERM1
c     ------------------------------------------------------------------
      external D1MACH
      double precision X,XORF,TOL, D1MACH
      double precision A,B,C,D,E,EPS,XM,P,Q,R,TOL1,TOL2,U,V,W
      double precision FU,FV,FW,FX,XI, TOLI, C3
      double precision ASAVE, BSAVE
      double precision HALF, TWO, THREE, FIVE, ZERO, PT95
      integer MODE, NEXT, IC, NP
      parameter(HALF = 0.5D0, TWO = 2.0D0, THREE = 3.0D0)
      parameter(FIVE = 5.0D0, ZERO = 0.0D0, PT95 = 0.95D0)
      save
      data EPS / ZERO /, NP / 0 /, IC / 0 /
c     ------------------------------------------------------------------
      IF (MODE .LT. 0) THEN
         NP = -1 - MODE
         RETURN
      END IF
      IF (NP .GT. 0) THEN
         NP = NP - 1
         print*, ' In DFMIN: X= ',X,', XORF= ',XORF,', IC= ',IC
      END IF
      if(MODE .eq. 1) then
         go to (301,302), NEXT
      endif
      if( MODE .ne. 0) then
c                                           Error:  MODE > 1 on entry.
         call IERM1('DFMIN',MODE,0,
     *   'Input value of MODE exceeds 1.','MODE',MODE,'.')
         MODE = 4
         return
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C               C is the squared inverse of the "Golden Ratio", 1.618...
C               C = 0.381966
c
      C = HALF*(THREE - sqrt(FIVE))
C
C           EPS IS THE SQUARE ROOT OF THE RELATIVE MACHINE  PRECISION.
C
      if (EPS .eq. ZERO) EPS = sqrt(D1MACH(4))
C
C  INITIALIZATION
C
      A = X
      B = XORF
      if( A .gt. B) then
         XI = A
         A = B
         B = XI
      endif
c                           Now we have A .le. B
      ASAVE = A
      BSAVE = B
      TOLI = TOL
      if(TOLI .le. ZERO) TOLI = ZERO
      C3 = TOLI/THREE + EPS ** 4
      V = A + C*(B - A)
      W = V
      XI = V
      IC = 0
      E = ZERO
c                   Return to calling prog for computation of FX = f(XI)
      X = XI
      MODE = 1
      NEXT = 1
      return
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  301 continue
      NEXT = 2
      FX = XORF
      FV = FX
      FW = FX
C                                         MAIN LOOP STARTS HERE
   20 XM = HALF*(A + B)
      TOL1 = EPS*abs(XI) + C3
      TOL2 = TWO*TOL1
C                            CHECK STOPPING CRITERION
C
      if (abs(XI - XM) .le. (TOL2 - HALF*(B - A))) go to 90
C
C                            IS GOLDEN-SECTION NECESSARY ?
C
      if (abs(E) .le. TOL1) go to 40
C
C                            FIT PARABOLA
C
      R = (XI - W)*(FX - FV)
      Q = (XI - V)*(FX - FW)
      P = (XI - V)*Q - (XI - W)*R
      Q = TWO*(Q - R)
      if (Q .gt. ZERO) P = -P
      Q =  abs(Q)
      R = E
      E = D
C
C  IS PARABOLA ACCEPTABLE
C
      if (abs(P) .ge. abs(HALF*Q*R)) go to 40
      if (P .le. Q*(A - XI)) go to 40
      if (P .ge. Q*(B - XI)) go to 40
C
C  A PARABOLIC INTERPOLATION STEP
C
      D = P/Q
      U = XI + D
C
C  F MUST NOT BE EVALUATED TOO CLOSE TO A OR B
C
      if ((U - A) .lt. TOL2 .or. (B - U) .lt. TOL2)
     *    D = sign(TOL1, XM - XI)
      go to 50
C
C  A GOLDEN-SECTION STEP
C
   40 IC = IC + 1
      if (IC .gt. 3) then
         if (A .eq. ASAVE) then
            if (IC .eq. 4) then
               E = A + (EPS * abs(A) + C3) - XI
            else
               if (B .ne. W) go to 45
               E = A - XI
            end if
         else if (B .eq. BSAVE) then
            if (IC .eq. 4) then
               E = B - (EPS * abs(B) + C3) - XI
            else
               if (A .ne. W) go to 45
               E = B - XI
            end if
         else
            IC = -99
            go to 45
         end if
         D = E
         go to 50
      end if
   45 if (XI .ge. XM) then
         E = A - XI
      else
         E = B - XI
      endif
      D = C*E
C
C  F MUST NOT BE EVALUATED TOO CLOSE TO XI
C
   50 if (abs(D) .ge. TOL1) then
         U = XI + D
      else
         if (B - A .gt. THREE * TOL1) TOL1 = TOL2
         U = min(B, max(A, XI + sign(PT95*TOL1, D)))
      endif
c
c                    Return to calling prog for computation of FU = f(U)
c                    Returning with MODE = 1 and NEXT = 2
      X = U
      return
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  302 continue
      FU = XORF
C
C  UPDATE  A, B, V, W, AND XI
C
      if (FU .le. FX) then
         if (FU .eq. FX) then
            if (B - min(XI, U) .gt. max(XI, U) - A) then
               B = max(XI, U)
            else
               A = min(XI, U)
            end if
         else
            if (U .ge. XI) then
               A = XI
            else
               B = XI
            endif
         end if
         V = W
         FV = FW
         W = XI
         FW = FX
         XI = U
         FX = FU
         go to 20
      endif
c
      if (U .lt. XI) then
         A = U
      else
         B = U
      endif
      if (FU .le. FW  .or.  W .eq. XI) then
         V = W
         FV = FW
         W = U
         FW = FU
      elseif (FU .le. FV  .or.  V .eq. XI  .or.  V .eq. W) then
         V = U
         FV = FU
      endif
      go to 20
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   90 continue
         X = XI
         XORF = FX
         MODE = 2
         if ((B - A .gt. THREE*TOLI) .and. (TOLI .ne. ZERO)) MODE = 3
         return
         end


      PROGRAM xelmhes
C     driver for routine elmhes
      INTEGER NP
      PARAMETER(NP=5)
      INTEGER i,j
      REAL a(NP,NP)
      DATA a/1.0,2.0,3.0,4.0,5.0,2.0,3.0,4.0,5.0,6.0,
     *     300.0,400.0,5.0,600.0,700.0,4.0,5.0,6.0,7.0,8.0,
     *     5.0,6.0,7.0,8.0,9.0/
      write(*,'(/1x,a/)') '***** Original Matrix *****'
      do 11 i=1,NP
        write(*,'(1x,5f12.2)') (a(i,j),j=1,NP)
11    continue
      write(*,'(/1x,a/)') '***** Balance Matrix *****'
      call balanc(a,NP,NP)
      do 12 i=1,NP
        write(*,'(1x,5f12.2)') (a(i,j),j=1,NP)
12    continue
      write(*,'(/1x,a/)') '***** Reduce to Hessenberg Form *****'
      call elmhes(a,NP,NP)
      do 14 j=1,NP-2
        do 13 i=j+2,NP
          a(i,j)=0.0
13      continue
14    continue
      do 15 i=1,NP
        write(*,'(1x,5e12.4)') (a(i,j),j=1,NP)
15    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xelmhes.for


! test_m_coordinates.f90 --
!     Test program for the m_coordinates module
!
program test_m_coordinates

    use m_coordinates

    implicit none

    real, parameter :: pi = acos(-1.0)

    integer :: i
    real    :: x, y, z, z2, z3
    real    :: rad, phi ,theta, rad2, phi2, theta2

    !
    ! Spherical to cartesian
    !
    do i = 0,6
        rad = 10.0; phi = i * pi / 6.0; theta = i * pi / 12.0

        call spherical_to_cart( rad, phi, theta, x, y, z )
        call cart_to_spherical( x, y, z, rad2, phi2, theta2 )

        write( *, '(9f8.4)' ) rad, phi, theta, x, y, z, rad2, phi2, theta2
    enddo

    !
    ! Cylindrical to cartesian
    !
    do i = 0,6
        rad = 10.0; phi = i * pi / 6.0; z = i / 5.0

        call cylindrical_to_cart( rad, phi, z, x, y, z2 )
        call cart_to_cylindrical( x, y, z2, rad2, phi2, z3 )

        write( *, '(9f8.4)' ) rad, phi, z, x, y, z2, rad2, phi2, z3
    enddo

    !
    ! Polar to cartesian
    !
    do i = 0,6
        rad = 10.0; phi = i * pi / 6.0

        call polar_to_cart( rad, phi, x, y )
        call cart_to_polar( x, y, rad2, phi2 )

        write( *, '(9f8.4)' ) rad, phi, x, y, rad2, phi2
    enddo

end program


program euler_stability
    implicit none
    integer :: i, N
    real :: x, h

    h = 0.1
    N = 1. / h

    ! Euler method
    x = 1.01
    write(*,*)0., x
    do i=1,N
        x = x + h * f(x, (i - 1) * h)
        write(*,*)i * h, x
    end do

contains

    real function f(x, t)
        implicit none
        real, intent(in) :: x, t

        f = -100. * x + 100. * t + 101.
    end function
end program


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! the module precision_kind defines the precision
! this is done in order to have a transferable program

module precision_kind
    implicit none
    integer(kind=kind(1)) , parameter :: i2b = kind ( 1 ) ! simple precision integer
    integer(kind=i2b)     , parameter :: i4b = 2_i2b * i2b ! simple precision integer
    integer(kind=i2b)     , parameter :: dp = kind ( 0.0d0 ) ! double precision real
    integer(kind=i2b)     , parameter :: sp = kind ( 0.0 ) ! simple precision real
end module precision_kind

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module numbers
    use precision_kind
    implicit none
    real(dp), parameter :: pi = acos ( -1.0_dp )
    real(dp), parameter :: twopi = 2.0_dp * pi
    real(dp), parameter :: twopisq = 2.0_dp * pi ** 2
    real(dp), parameter :: fourpi = 4.0_dp * pi
end module numbers

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program hankel

    use precision_kind ! defines precisions
    use numbers

    implicit none

    integer(i2b) :: nb_input_pts ! total number of line of input file dat.in
    real(dp) , allocatable , dimension(:) :: x_in , y_in ! input x and y
    real(dp) :: kr ! k*r
    integer(i2b) :: direction ! 1 for hankel transform, 2 for inverse hankel transform
    real(dp) :: x ! radial distance
    integer(i2b) :: i , j ! dummy
    real(dp) :: A ! area under the curve
    real(dp) :: yj0 , yj1 ! dummy
    real(dp) :: xmax ! maximum value for r or k
    integer(i2b) :: nstep ! number of points between 0 and xmax

    ! read the total number of input points in dat.in -> nb_input_pts
    call get_nb_input_pts ( nb_input_pts )

    ! allocate accordingly an array that will contains all x (x_in) and another that will contain all y (y_in)
    allocate ( x_in ( nb_input_pts ) )
    allocate ( y_in ( nb_input_pts ) )

    ! read input dat.in
    open ( unit = 10 , file = 'dat.in' )
    do i = 1 , nb_input_pts
    read ( 10 , * ) x_in ( i ) , y_in ( i )
    end do

    close ( 10 )

    ! ask user if it want a transform (r -> k) or invers transform (k -> r)
    77 write (*,*) 'do you want a transform (r->k) or inverse transform (k->r) ? (1/2)'
    read (*,*) direction

    ! only correct input values are 1 and 2
    if ( direction /= 1 .and. direction /=2 ) then
    write (*,*) 'you can only type 1 or 2'
    ! send user back to choice 1 or 2
    go to 77
    end if

    ! open output file transformed.out and write a first comment line
    open ( unit = 11 , file = 'transformed.out' )
    if ( direction == 1 ) then
    write ( 11 , * ) '# k   f(k)'
    else if ( direction == 2 ) then
    write ( 11 , * ) '# r   f(r)'
    end if

    ! ask user the range over which he wants to compute f(x) (xmax)
    99 if ( direction == 1 ) then
    write ( * , * ) 'what is the maximum value you want for | k | (type a real number) ?'
    else if ( direction == 2 ) then
    write ( * , * ) 'what is the maximum value you want for | r | (type a real number) ?'
    end if
    read ( * , * ) xmax

    ! check validy of xmax

    if ( xmax <= 0.0_dp ) then
    write ( * , * ) 'xmax should be positive'
    go to 99
    end if

    ! ask user how many points he wants between 0 and xmax
    100 write ( * , * ) 'how many points do you want between 0 and ' , xmax , ' ? (enter an positive integer) '
    read ( * , * ) nstep

    ! check validy of xmax
    if ( nstep <= 0 ) then
    write ( * , * ) 'nstep should be positive'
    go to 100
    end if

    ! for nb_input_pts, one has nb_input_pts - 1 intervals on which to compute the trapeze area under the curve (A)
    ! for each x in between 0 and rmax (around 20) with a step of rstep (0.01)
    ! sum all A to get the total area which is the integral (hankel_int)
    do i = 0 , nstep
        ! for now x ranges from 0 to 20
        x = real ( i , kind = dp ) * xmax / real ( nstep , kind = dp )
        ! init integral f(x) = int ... f(k) ... dk
        A = 0.0_dp
        ! if x is zero then A = 0.0_dp. don't waste your time in the loop at dividing by zero.
        if ( abs ( x ) <= epsilon ( 1.0_dp ) ) go to 88

        do j = 1 , nb_input_pts - 1
            if ( abs ( x_in ( j ) ) <= epsilon ( 1.0_dp ) ) then! care of dividing by zero
                yj0 = y_in ( j ) * x_in ( j ) ** 2 ! because sin(0)/0 = 1.0
            else
                yj0 = y_in ( j ) * x_in ( j ) ** 2 * sin ( x_in ( j ) * x ) / ( x_in ( j ) * x )
            end if
            if ( abs ( x_in ( j + 1 ) ) <= epsilon ( 1.0_dp ) ) then
                yj1 = y_in ( j + 1 ) * x_in ( j + 1 ) ** 2 ! because sin(0)/0 = 1.0
            else
                yj1 = y_in ( j + 1 ) * x_in ( j + 1 ) ** 2 * sin ( x_in ( j + 1 ) * x ) / ( x_in ( j + 1 ) * x )
            end if
            A = A + ( x_in ( j + 1 ) - x_in ( j ) ) * ( yj0 + yj1 ) / 2.0_dp ! trapeze method for integral calculation
        end do

        ! normalize depending of transformation direction
        if ( direction == 1 ) then
            A = A * fourpi
        else if ( direction == 2 ) then
            A = A / twopisq
        end if

        ! write output file x , f(x)
        88 write (11,*) x , A

    end do

    ! close output file
    close ( 11 )

    ! deallocate x_in and y_in
    deallocate ( x_in , y_in )

end program hankel

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! this subroutine computes the total number of lines of input file

subroutine get_nb_input_pts ( nb_input_pts )

    use precision_kind

    implicit none

    integer(i2b) :: ios ! iostat of the read statement:
    integer(i2b) :: nb_input_pts

!    If the value of IOstatus is zero, the previous READ was executed flawlessly and all variables have received their input values. This is the normal case.
!    If the value of IOstatus is positive, the previous READ has encountered some problem. In general, without knowing the system dependent information, it is impossible to determine what the problem was. However, if hardware and I/O devices are working, a commonly seen problem would be illegal data. For example, supplying a real number to an integer variable. If IOstatus is positive, you cannot trust the values of the variables in the READ statement; they could all contain garbage values, or some of them are fine while the others are garbage.
!    If the value of IOstatus is negative, it means the end of the input has reached. Under this circumstance, some or all of the variables in the READ may not receive input values.

    open ( 11 , file = 'dat.in' )

    ! init the total number of input points
    nb_input_pts = 0
    do while ( .true. )
        read ( 11 , * , iostat = ios )
        if ( ios > 0 ) then
            write (*,*) 'Error in compute_ck_dipolar.f90'
            write (*,*) 'something went wrong. stop'
            stop
        else if ( ios < 0 ) then
            exit! end of file reached
        else
            nb_input_pts = nb_input_pts + 1! increment total number of input points
        end if
    end do
    close ( 11 )

    ! if 0 lines then the input file is missing
    if ( nb_input_pts == 0 ) stop 'critical stop : input file dat.in is missing'

    ! inform user
    print*,'dat.in has ' , nb_input_pts , ' lines'

end subroutine get_nb_input_pts


module julia_set_m
    use iso_fortran_env, only: real32
    implicit none
    private
    public :: generate_julia_set, draw_julia_set

contains

    function julia_point(z0, c, max_iter) result(n)
        complex(real32), intent(in) :: z0
        complex(real32), intent(in) :: c
        integer, intent(in) :: max_iter
        integer :: n

        ! local variables
        complex(real32) :: z

        z = z0
        do n = 1, max_iter
            z = z**2 + c
            if (abs(z) > 2.) exit ! z must diverge when |z| > 2
        end do

    end function julia_point

    subroutine generate_julia_set(set, xmin, xmax, ymin, ymax, c, max_iter)
        integer, dimension(:,:), intent(inout) :: set
        real(real32), intent(in) :: xmin, xmax
        real(real32), intent(in) :: ymin, ymax
        complex(real32), intent(in) :: c
        integer, intent(in) :: max_iter

        ! local variables
        integer :: i, j
        real(real32) :: xstep, ystep
        complex(real32) :: z

        xstep = (xmax - xmin) / (size(set, dim=2) - 1)
        ystep = (ymax - ymin) / (size(set, dim=1) - 1)

        do j = 1, size(set, dim=1)
            do i = 1, size(set, dim=2)
                z = complex(xmin + (i - 1) * xstep, ymin + (j - 1) * ystep)
                set(j, i) = julia_point(z, c, max_iter)
            end do
        end do

    end subroutine generate_julia_set

    subroutine draw_julia_set(set)
        integer, dimension(:,:), intent(in) :: set

        ! local variables
        character(len=size(set, dim=2)) :: row
        integer :: i, j

        do j = 1, size(set, dim=1)
            do i = 1, size(set, dim=2)
                select case (set(j, i))
                    case (1)
                        row(i:i) = ' '
                    case (2:5)
                        row(i:i) = '.'
                    case (6:10)
                        row(i:i) = ':'
                    case (11:15)
                        row(i:i) = '*'
                    case (16:20)
                        row(i:i) = 'x'
                    case (21:)
                        row(i:i) = '#'
                    case default
                        write(*, "(a)") "Error: wrong value in set"
                        stop
                end select
            end do
            write(*, "(A)") row
        end do

    end subroutine draw_julia_set

end module julia_set_m


program sieve_wheel_2

  implicit none
  integer, parameter :: i_max = 100
  integer :: i
  logical, dimension (i_max) :: is_prime

  is_prime = .true.
  is_prime (1) = .false.
  is_prime (4 : i_max : 2) = .false.
  do i = 3, int (sqrt (real (i_max))), 2
    if (is_prime (i)) is_prime (i * i : i_max : 2 * i) = .false.
  end do
  do i = 1, i_max
    if (is_prime (i)) write (*, '(i0, 1x)', advance = 'no') i
  end do
  write (*, *)

end program sieve_wheel_2


            program demo_abs
            integer :: i = -1, iout
            real :: x = -1.e0, xout, zout
            complex :: z = (-3.e0,4.e0)
            doubleprecision :: r8 = 45.78D+00, dout
               write(*,*)'INPUTS:',i,x,z,r8
               iout = abs(i)
               xout = abs(x)
               zout = abs(z)
               dout = abs(r8)
               write(*,*)'OUTPUTS:',iout,xout,zout,dout
               write ( *, '(a,f12.4,12x,f12.4)' ) ' Double precision  ', -r8, abs(r8)
               ! COMPLEX
               ! 3 - 4 -5 right triangle test :
               write(*,*)'The abs() of (3.0,4.0) should be 5.0',abs((3.0,4.0))
               ! ELEMENTAL
               write(*,*)'abs is ELEMENTAL: ',abs([-10, 20, 0, -1, -3, 100])
            end program demo_abs


c fishpk27 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c          program to illustrate the use of subroutine hwscyl to solve
c     the equation
c
c     (1/r)(d/dr)(r*(du/dr)) + (d/dz)(du/dz)
c
c     = (2*r*z)**2*(4*z**2 + 3*r**2)
c
c     on the rectangle 0 .lt. r .lt. 1, 0 .lt. z .lt. 1 with the
c     boundary conditions
c
c     u(0,z) unspecified
c                                            0 .le. z .le. 1
c     (du/dr)(1,z) = 4*z**4
c
c     and
c
c     (du/dz)(r,0) = 0
c                                            0 .le. r .le. 1
c     (du/dz)(r,1) = 4*r**4 .
c
c          the r-interval will be divided into 50 panels and the
c     z-interval will be divided into 100 panels.
c
      program thwscyl
      dimension       f(75,105)  ,bda(101)   ,bdb(101)   ,bdc(51)    ,
     1                bdd(51)    ,w(1373)    ,r(51)      ,z(101)
c
c     from dimension statement we get value of idimf.  also note that w
c     is dimensioned 4*(n+1) + (13 + int(log2(n+1)))*(m+1) .
c
      idimf = 75
      a = 0.
      b = 1.
      m = 50
      mbdcnd = 6
      c = 0.
      d = 1.
      n = 100
      nbdcnd = 3
      elmbda = 0.
c
c     auxiliary quantities.
c
      mp1 = m+1
      np1 = n+1
c
c     generate and store grid points for the purpose of computing
c     boundary data and the right side of the poisson equation.
c
      do 101 i=1,mp1
         r(i) = float(i-1)/50.
  101 continue
      do 102 j=1,np1
         z(j) = float(j-1)/100.
  102 continue
c
c     generate boundary data.
c
      do 103 j=1,np1
         bdb(j) = 4.*z(j)**4
  103 continue
      do 104 i=1,mp1
         bdc(i) = 0.
         bdd(i) = 4.*r(i)**4
  104 continue
c
c     bda is a dummy variable.
c
c
c     generate right side of equation.
c
      do 106 i=1,mp1
         do 105 j=1,np1
            f(i,j) = 4.*r(i)**2*z(j)**2*(4.*z(j)**2+3.*r(i)**2)
  105    continue
  106 continue
      call hwscyl (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error by minimizing over all a the function
c     norm(f(i,j) - a*1 - u(r(i),z(j))).  the exact solution is
c                u(r,z) = (r*z)**4 + arbitrary constant.
c
      x = 0.
      do 108 i=1,mp1
         do 107 j=1,np1
            x = x+f(i,j)-(r(i)*z(j))**4
  107    continue
  108 continue
      x = x/float(np1*mp1)
      do 110 i=1,mp1
         do 109 j=1,np1
            f(i,j) = f(i,j)-x
  109    continue
  110 continue
      err = 0.
      do 112 i=1,mp1
         do 111 j=1,np1
            x = abs(f(i,j)-(r(i)*z(j))**4)
            if (x .gt. err) err = x
  111    continue
  112 continue
      print 1001 , ierror,pertrb,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hwscyl example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/32x,20hpertrb = 2.26734e-04/
     3        18x,34hdiscretization error = 3.73672e-04/
     4        12x,33hrequired length of w array = 1118//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/32x,8hpertrb =,e12.5/
     7        18x,22hdiscretization error =,e12.5/
     8        12x,28hrequired length of w array =,f5.0)
c
      end


module coord
  use, intrinsic :: iso_fortran_env, dp => real64
  implicit none
  real(dp) :: coord_bl_a ! Boyer Lindquist parameter 'a'

  ! Coordinate identifiers
  integer, parameter :: coord_sph = 1
  integer, parameter :: coord_bl = 2

  ! For coordinate transformations selection
  abstract interface
    function pos3d_conv(r)
      import dp
      real(dp), dimension(1:3) :: r, pos3d_conv
    end function
    function vel3d_conv(v,r)
      import dp
      real(dp), dimension(1:3) :: v, r, vel3d_conv
    end function
  end interface

  procedure(pos3d_conv), pointer :: pos3d_cart_to_selected => null()
  procedure(pos3d_conv), pointer :: pos3d_selected_to_cart => null()
  procedure(vel3d_conv), pointer :: vel3d_cart_to_selected => null()
  procedure(vel3d_conv), pointer :: vel3d_selected_to_cart => null()

contains

  ! Coordinate selector
  subroutine set_coordinates(coord_syst)
    integer, intent(in) :: coord_syst
    select case(coord_syst)
    case(coord_sph)
      pos3d_cart_to_selected => pos3d_cart_to_sph
      pos3d_selected_to_cart => pos3d_sph_to_cart
      vel3d_cart_to_selected => vel3d_cart_to_sph
      vel3d_selected_to_cart => vel3d_sph_to_cart
    case(coord_bl)
      pos3d_cart_to_selected => pos3d_cart_to_bl
      pos3d_selected_to_cart => pos3d_bl_to_cart
      vel3d_cart_to_selected => vel3d_cart_to_bl
      vel3d_selected_to_cart => vel3d_bl_to_cart
    end select
  end subroutine

  ! Spherical coordinates
  function pos3d_cart_to_sph(r_cart) result(r_sph)
    real(dp), dimension(1:3) :: r_cart, r_sph
    associate(&
      & x=>r_cart(1), y=>r_cart(2), z=>r_cart(3), &
      & r=> r_sph(1), th=> r_sph(2), ph=>r_sph(3) &
      &)
      r = sqrt(x*x + y*y + z*z)
      th = acos(z/r)
      ph = atan2(y,x)
    end associate
  end function

  function pos3d_sph_to_cart(r_sph) result(r_cart)
    real(dp), dimension(1:3) :: r_cart, r_sph
    associate(&
      & x=>r_cart(1), y=>r_cart(2), z=>r_cart(3), &
      & r=> r_sph(1), th=> r_sph(2), ph=>r_sph(3) &
      &)
      x = r*sin(th)*cos(ph)
      y = r*sin(th)*sin(ph)
      z = r*cos(th)
    end associate
  end function

  function vel3d_cart_to_sph(v_cart,r_sph) result(v_sph)
    real(dp), dimension(1:3) :: v_cart, r_sph, v_sph
    associate(&
      & vx=>v_cart(1), vy=>v_cart(2), vz=>v_cart(3), &
      & r=> r_sph(1), th=> r_sph(2), ph=>r_sph(3), &
      & vr=> v_sph(1), vth=>v_sph(2), vph=>v_sph(3) &
      &)
      vr = (vy*sin(ph)+vx*cos(ph))*sin(th)+vz*cos(th)
      vth = -(vz*sin(th)+((-vy*sin(ph))-vx*cos(ph))*cos(th))/r
      vph = -(vx*sin(ph)-vy*cos(ph))/(r*sin(th))
    end associate
  end function

  function vel3d_sph_to_cart(v_sph,r_sph) result(v_cart)
    real(dp), dimension(1:3) :: v_cart, v_sph, r_sph
    associate(&
      & vx=>v_cart(1), vy=>v_cart(2), vz=>v_cart(3), &
      & r=> r_sph(1), th=> r_sph(2), ph=>r_sph(3), &
      & vr=> v_sph(1), vth=>v_sph(2), vph=>v_sph(3) &
      &)
      vx = cos(ph)*r*cos(th)*vth+cos(ph)*sin(th)*vr-sin(ph)*r*sin(th)*vph
      vy = sin(ph)*r*cos(th)*vth+sin(ph)*sin(th)*vr+cos(ph)*r*sin(th)*vph
      vz = cos(th)*vr-r*sin(th)*vth
    end associate
  end function

  ! Boyer-Lindquist coordinates
  function pos3d_cart_to_bl(r_cart) result(r_bl)
    real(dp), dimension(1:3) :: r_cart, r_bl
    real(dp) :: b
    associate(&
      & x=>r_cart(1), y=>r_cart(2), z=>r_cart(3), &
      & r=> r_bl(1), th=> r_bl(2), ph=>r_bl(3), &
      & a=>coord_bl_a &
      &)
      b = x**2 + y**2 + z**2 - a**2
      r = sqrt( (b+sqrt(b**2 + 4*a**2*z**2))/2 )
      th = acos(z/r)
      ph = atan2(y,x)
    end associate
  end function

  function pos3d_bl_to_cart(r_bl) result(r_cart)
    real(dp), dimension(1:3) :: r_bl, r_cart
    associate(&
      & x=>r_cart(1), y=>r_cart(2), z=>r_cart(3), &
      & r=> r_bl(1), th=> r_bl(2), ph=>r_bl(3), &
      & a=>coord_bl_a &
      &)
      x = sqrt(r**2 + a**2)*sin(th)*cos(ph)
      y = sqrt(r**2 + a**2)*sin(th)*sin(ph)
      z = r*cos(th)
    end associate
  end function

  function vel3d_cart_to_bl(v_cart,r_bl) result(v_bl)
    real(dp), dimension(1:3) :: v_cart, r_bl, v_bl
    associate(&
      & vx=>v_cart(1), vy=>v_cart(2), vz=>v_cart(3), &
      & r=> r_bl(1), th=> r_bl(2), ph=>r_bl(3), &
      & vr=> v_bl(1), vth=>v_bl(2), vph=>v_bl(3), &
      & a=>coord_bl_a &
      &)
      vr = (cos(th)*(r**2*vz+a**2*vz)+r*sqrt(r**2+a**2)*sin(th)*(sin(ph)*vy+&
        &cos(ph)*vx))/(a**2*cos(th)**2+r**2)
      vth = (sqrt(r**2+a**2)*cos(th)*(sin(ph)*vy+cos(ph)*vx)-r*sin(th)*vz)/(a&
        &**2*cos(th)**2+r**2)
      vph = -(sin(ph)*vx-cos(ph)*vy)/(sqrt(r**2+a**2)*sin(th))
    end associate
  end function

  function vel3d_bl_to_cart(v_bl,r_bl) result(v_cart)
    real(dp), dimension(1:3) :: v_cart, r_bl, v_bl
    associate(&
      & vx=>v_cart(1), vy=>v_cart(2), vz=>v_cart(3), &
      & r=> r_bl(1), th=> r_bl(2), ph=>r_bl(3), &
      & vr=> v_bl(1), vth=>v_bl(2), vph=>v_bl(3), &
      & a=>coord_bl_a &
      &)
      vx = (cos(ph)*(r**2+a**2)*cos(th)*vth+cos(ph)*r*sin(th)*vr-sin(ph)*(r*&
        &*2+a**2)*sin(th)*vph)/sqrt(r**2+a**2)
      vy = (sin(ph)*(r**2+a**2)*cos(th)*vth+sin(ph)*r*sin(th)*vr+cos(ph)*(r*&
        &*2+a**2)*sin(th)*vph)/sqrt(r**2+a**2)
      vz = cos(th)*vr-r*sin(th)*vth
    end associate
  end function

end module


module Integration
  implicit none

contains

  ! function, lower limit, upper limit, steps, method
  function integrate(f, a, b, in, method)
    real :: integrate
    real, intent(in) :: a, b
    integer, optional, intent(in) :: in
    character(len=*), intent(in), optional :: method
    interface
       elemental function f(ra)
         real :: f
         real, intent(in) :: ra
       end function f
    end interface

    integer :: n, i, m
    real :: h
    real, dimension(:), allocatable :: xpoints
    real, dimension(:), target, allocatable :: fpoints
    real, dimension(:), pointer :: fleft, fmid, fright

    if ( present(in) ) then
       n = in
    else
       n = 20
    end if

    if ( present(method) ) then
       select case (method)
       case ('leftrect')
          m = 1
       case ('midrect')
          m = 2
       case ('rightrect')
          m = 3
       case ( 'trapezoid' )
          m = 4
       case default
          m = 0
       end select
    else
       m = 0
    end if

    h = (b - a) / n

    allocate(xpoints(0:2*n), fpoints(0:2*n))

    xpoints = (/ (a + h*i/2, i = 0,2*n) /)

    fpoints = f(xpoints)
    fleft  => fpoints(0 : 2*n-2 : 2)
    fmid   => fpoints(1 : 2*n-1 : 2)
    fright => fpoints(2 : 2*n   : 2)

    select case (m)
    case (0) ! simpson
       integrate = h / 6.0 * sum(fleft + fright + 4.0*fmid)
    case (1) ! leftrect
       integrate = h * sum(fleft)
    case (2) ! midrect
       integrate = h * sum(fmid)
    case (3) ! rightrect
       integrate = h * sum(fright)
    case (4) ! trapezoid
       integrate = h * sum(fleft + fright) / 2
    end select

    deallocate(xpoints, fpoints)
  end function integrate

end module Integration


program test_secant
use types, only: dp
use utils, only: assert
use optimize, only: secant
implicit none

real(dp) :: x

x = secant(f1, 0.0_dp, 0.1_dp, 1e-12_dp)
 print *, x
 call assert(abs(x - 0.73908513_dp) < 1e-8_dp)

x = secant(f2, -4._dp, 4._dp, 1e-12_dp)
print *, x
call assert(abs(x - 0.86547403_dp) < 1e-8_dp)

x = secant(f3, 0._dp, 3._dp, 1e-12_dp)
print *, x
call assert(abs(x - 2.40482556_dp) < 1e-8_dp)

x = secant(f3, 3._dp, 6._dp, 1e-12_dp)
print *, x
call assert(abs(x - 5.52007811_dp) < 1e-8_dp)

x = secant(f4, -4._dp, 4._dp, 1e-12_dp)
print *, x
call assert(abs(x) < 1e-8_dp)

contains

real(dp) function f1(x)
real(dp), intent(in) :: x
f1 = cos(x) - x
end function

real(dp) function f2(x)
real(dp), intent(in) :: x
f2 = cos(x) - x**3
end function

real(dp) function f3(x)
real(dp), intent(in) :: x
f3 = bessel_jn(0, x)
end function

real(dp) function f4(x)
real(dp), intent(in) :: x
f4 = x
end function

end program


SUBROUTINE mocouf(phi,c,sigm,dsbar,theta,f)
!
! This subroutine calculates the value of the yield function
! for a Mohr-Coulomb material (phi in degrees).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::phi,c,sigm,dsbar,theta
 REAL(iwp),INTENT(OUT)::f
 REAL(iwp)::phir,snph,csph,csth,snth,one=1.0_iwp,d3=3.0_iwp,d4=4.0_iwp,   &
   d180=180.0_iwp
 phir=phi*d4*ATAN(one)/d180
 snph=SIN(phir)
 csph=COS(phir)
 csth=COS(theta)
 snth=SIN(theta)
 f=snph*sigm+dsbar*(csth/SQRT(d3)-snth*snph/d3)-c*csph
RETURN
END SUBROUTINE mocouf


program float
  implicit none

  real :: phi
  real :: qhi
  real :: srt_5
  real :: fib
  integer :: fibo

  print *, "Enter the number at:"
  read(*,*) fibo

  srt_5 = sqrt(5.0)
  phi = (1+srt_5)/2.0
  qhi = (1-srt_5)/2.0
  fib = ( (phi**fibo) - (qhi**fibo) )/srt_5

  print *, "The result is:", int(fib)

end program


Subroutine det(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Intent(Out) :: ans
	Double Precision, Dimension(n, n):: tmp
	Integer :: i

	tmp = A
	Call triangulate(tmp, n)

	ans = 1.0
	Do i = 1, n
		ans = ans * tmp(i, i)
	End Do

	If (IsNan(ans)) ans = 0.0

End Subroutine det


module rhofunc
implicit none
public
integer, parameter :: dp=kind(0.d0)
contains
    pure real(dp) function rho(x,y)
        real(dp), intent(in) :: x,y
        if (x > 0.6_dp .and. x < 0.8_dp .and. y > 0.6_dp .and. y<0.8) then
            rho = 1.0_dp
        else if (x> 0.2_dp .and. x<0.4_dp .and. y>0.2_dp .and. y<0.4_dp) then
            rho = -1.0_dp
        else
            rho = 0.0_dp
        end if
    end function

end module

program poisson
use rhofunc, only: rho
implicit none
integer, parameter :: dp=kind(0.d0), M=300
integer            :: i,j, iter
real(dp),parameter :: epsilon0=8.85E-12_dp, target=1E-6_dp, a=0.01
real(dp)           :: delta, b, e, phiprime(M,M), phi(M,M), a2, rhoarr(M,M)

delta = 1.0_dp
iter = 0
call cpu_time(b)
phiprime(:,:) = 0.0_dp
phi(:,:) = 0.0_dp
do i=1, M
    do j=1, M
        rhoarr(i,j) = rho(i*a,j*a)
    end do
end do

do while (delta > target )
    iter = iter + 1
    a2 = a**2.0_dp
    do i=2, M-1
        do j=2, M-1
            phiprime(i,j) = (phi(i+1,j) + phi(i-1,j) + phi(i,j+1) + phi(i,j-1))/4.0_dp &
            + a2/4.0_dp/epsilon0*rhoarr(i,j)
        end do
    end do
    delta = maxval(abs(phiprime - phi))
    phi = phiprime

end do
call cpu_time(e)
print *, e-b, iter
end program


!##############################################################################
! PROGRAM simplex_alg
!
! ## The simplex algorithm for solving linear constrained minimization problems
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program simplex_alg

    use toolbox

    implicit none
    real*8 :: c(2), x(2), A(3, 2), b(3)
    integer :: j

    ! set up matrix, target vector and coefficients
    A(1, :) = (/ 1d0,  1d0/)
    A(2, :) = (/ 4d0,  1d0/)
    A(3, :) = (/20d0, 10d0/)

    b(:) = (/100d0, 160d0, 1100d0/)

    c(:) = (/-120d0, -40d0/)

    ! solve linear program
    call solve_lin(x, c, A, b, 3, 0, 0)

    ! output
    write(*,'(/a,2f10.2)')'      x = ',(x(j), j=1,2)
    write(*,'(/a,f10.2)')' Cons 1 = ', b(1)-sum(A(1, :)*x)
    write(*,'(a,f10.2)')' Cons 2 = ', b(2)-sum(A(2, :)*x)
    write(*,'(a,f10.2)')' Cons 3 = ', b(3)-sum(A(3, :)*x)

end program


subroutine outnormal_hex(x,nsd,p,outnorm,area)
! calculate the outward normal for the surface  on the solid interface
! and the area of the surface for tet element cases only
real(8) x(nsd,4)
real(8) p(nsd)
integer nsd
real(8) outnorm(nsd)
real(8) area
!---------------------------
real(8) ab(nsd)
real(8) ac(nsd)
real(8) ad(nsd)

real(8) ap(nsd)
real(8) dot_pro
real(8) temp(nsd)
real(8) temp_area

ab(:)=x(:,2)-x(:,1)
ac(:)=x(:,3)-x(:,1)
ad(:)=x(:,4)-x(:,1)

ap(:)=p(:)-x(:,1)

outnorm(1)=ab(2)*ac(3)-ab(3)*ac(2)
outnorm(2)=-ab(1)*ac(3)+ab(3)*ac(1)
outnorm(3)=ab(1)*ac(2)-ab(2)*ac(1)

area=outnorm(1)**2+outnorm(2)**2+outnorm(3)**2
area=0.5*sqrt(area) ! area of abc

dot_pro=ap(1)*outnorm(1)+ap(2)*outnorm(2)+ap(3)*outnorm(3)

if (dot_pro > 0) then
outnorm(:)=-outnorm(:)
end if

outnorm(:)=outnorm(:)/area*0.5

temp(1)=ac(2)*ad(3)-ac(3)*ad(2)
temp(2)=-ac(1)*ad(3)+ac(3)*ad(1)
temp(3)=ac(1)*ad(2)-ac(2)*ad(1)

temp_area=temp(1)**2+temp(2)**2+temp(3)**2
temp_area=0.5*sqrt(temp_area) ! area of acd

area=area+temp_area

continue

end


       Subroutine POLNAD(xts,xtv,phi,pveg,ropq,ropu)
       real xts,xtv,phi,pveg,ropq,ropu

C      compute the polarized components of the surface
C      according to the Nadal and Breon model

C   xts is the sun zenith angle in degrees
C   xtv is the view zenith angle in degrees
C   phi is the relative azimuth between sun and view in degrees
C   pveg is the "percentage of vegetation" for use in ponderating
C   the polarization of bare soil and vegetation
C   ropq and ropu and the stokes parameter (Q,U) of the polarized
C   surface reflectance
        real pi,dtr,csca,sca,alpha,alphap,N,mui,mut
C   csca is the cosine of the scattering angle (sca)
C   alpha is the incidence angle used for specular reflection
C   alphap is the refraction angle after specular reflection
C   N is the refractive index of vegetation (assumed 1.5)

C   intermediate variable to compute direction of polarization
C   according to fresnel law
        real mus,muv,sinv,cksi,ksi,xf1,xf2
        N=1.5
        pi=acos(0.0)*2.0
        dtr=pi/180.0
        csca=-cos(xts*dtr)*cos(xtv*dtr)-sin(xts*dtr)
     s      *sin(xtv*dtr)*cos(phi*dtr)
        sca=acos(csca)
        alpha=(pi-sca)/2.0
        alphap=asin(sin(alpha)/N)
        mui=cos(alpha)
        mut=cos(alphap)

        xf1=(N*mut-mui)/(N*mut+mui)
        xf2=(N*mui-mut)/(N*mui+mut)
        fpalpha=0.5*(xf1*xf1-xf2*xf2)
        rpveg=fpalpha/4./(cos(xts*dtr)+cos(xtv*dtr))
        rpsoil=fpalpha/4./cos(xts*dtr)/cos(xtv*dtr)
        rpsur=rpveg*pveg+rpsoil*(1.-pveg)

C compute rotation angle for Q and U
        muv=cos(xtv*dtr)
        mus=cos(xts*dtr)
        sinv=sin(xtv*dtr)
        if (xtv.gt.0.5) then
        if (sin(phi*dtr).lt.0) then
        cksi=(muv*csca+mus)/sqrt(1.-csca*csca)/sinv
        else
        cksi=-(muv*csca+mus)/sqrt(1.-csca*csca)/sinv
        endif
        else
        cksi=0.0
        endif

        if (cksi.gt.1.) cksi=1.
        if (cksi.lt.-1.) cksi=-1.
        ksi=acos(cksi)/dtr
C        write(6,*) "KSI=",ksi
        ropq=rpsur*(2.*cksi*cksi-1.)
        ropu=-rpsur*2.*cksi*sqrt(1.-cksi*cksi)
        return
        end


      FUNCTION GOLDEN(AX,BX,CX,F,TOL,XMIN)
      PARAMETER (R=.61803399,C=.38196602)
      X0=AX
      X3=CX
      IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
        X1=BX
        X2=BX+C*(CX-BX)
      ELSE
        X2=BX
        X1=BX-C*(BX-AX)
      ENDIF
      F1=F(X1)
      F2=F(X2)
1     IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
        IF(F2.LT.F1)THEN
          X0=X1
          X1=X2
          X2=R*X1+C*X3
          F0=F1
          F1=F2
          F2=F(X2)
        ELSE
          X3=X2
          X2=X1
          X1=R*X2+C*X0
          F3=F2
          F2=F1
          F1=F(X1)
        ENDIF
      GOTO 1
      ENDIF
      IF(F1.LT.F2)THEN
        GOLDEN=F1
        XMIN=X1
      ELSE
        GOLDEN=F2
        XMIN=X2
      ENDIF
      RETURN
      END


MODULE norms

CONTAINS
  FUNCTION NORM2b( x )

    ! Compute the 2-norm of a vector
    ! This is an intrinsic function in the newest Fortran (NORM2)
    ! Provided here for users of an older Fortran

    IMPLICIT NONE
    REAL (KIND=8), INTENT( IN ) :: x( : )
    REAL (KIND=8)               :: NORM2b

    NORM2b = SQRT( DOT_PRODUCT( x, x ) )

  END FUNCTION NORM2b
END MODULE norms


program tarefab4
    implicit real(8) (a-h,o-z)
    character(70) filename
    parameter (pi = 4d0*atan(1d0))
    dimension F0(3)

    dt = 0.03d0
    tmax = 480d0

    g = 9.8d0
    a_l = 9.8d0
    F0 = (/0d0, 0.5d0, 1.2d0/)
    gama = 0.5d0
    Omega = 2d0/3d0

    do j = 1,3
        theta_i = 0.2d0
        omega_i = 0d0
        i = 0

        write(filename, '(A,I0,A)') 'saida-b4-', j, '-10407962.dat'

        open(10, file=filename)

        write(10,'(F0.6,2(" ",F0.6))') dt*i, theta_i, omega_i

        do while ( i*dt.le.tmax )

            omega_i = omega_i +dw(g, a_l, theta_i, gama, omega_i, F0(j), Omega, dt*i)*dt
            theta_i = theta_i +omega_i*dt
            if (abs(theta_i).ge.pi) then
                theta_i = -theta_i
            end if

            write(10,'(F0.6,2(" ",F0.6))') dt*i, theta_i, omega_i

            i = i+1
        end do

        close(10)

    end do

contains
    function dw(g, a_l, theta, gama, dTheta, F0, Omega, t)
        implicit real(8) (a-h,o-z)
        dw = -(g/a_l)*sin(theta) -gama*dTheta +F0*sin(Omega*t)
        return
    end function

end program tarefab4


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Find roots of the cubic equation  x**3 + a*x**2 + b*x + c = 0
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] a coefficient
!> @param[in] b coefficient
!> @param[in] c coefficient
!> @param[out] x1 first root
!> @param[out] x2 second root
!> @param[out] x3 third root

      subroutine CUBIC(a,b,c,x1,x2,x3)

      implicit none

      real*8 :: a,b,c,D,x1,x2,x3,pi,prtr,prti
      real*8 :: oot,opf,three,srth,p,q
      real*8 :: srd,tmp,u,v, cosphi, phi, cf

     !------------------------------------------------------
     ! FDLIB
     !
     ! Copyright by C. Pozrikidis, 1999
     ! All rights reserved.
     !
     ! This program is to be used only under the
     ! stipulations of the licensing agreement.
     !-------------------------------------------------------

     !-------------------------------------------------------
     ! Roots of the cubic equation:
     !
     !  x**3 + a*x**2 + b*x + c = 0
     !
     ! where a,b,c are real coefficients.
     !
     ! The roots are computed
     ! using Cardano's analytical formulae
     !
     ! See:
     !
     ! John W Harris and Horst Stocker,
     ! ``Handbook of Mathematics and Computational Science''
     ! Springer (1998).
     !
     ! john.harris@yale.edu
     !
     !-------------------------------------------------------

     !Implicit Double Precision (a-h,o-z)

     !----------
     ! constants
     !----------

      pi = 3.14159265358d0

      oot   = 1.0d0/3.0d0
      opf   = 1.5d0
      three = 3.0d0
      srth  = dsqrt(three)

      !--------
      ! prepare
      !--------

      p = (3.0D0*b-a**2)/3.0D0
      q = c+2.0D0*a**3/27.0D0-a*b/3.0D0
      D = (p/3.0D0)**3+(q/2.0D0)**2        ! discriminant

      !--------------------------------------
      ! one real, two complex conjugate roots
      !--------------------------------------

      If(D.ge.0) then

       srd  = Dsqrt(D)
       tmp  =  -0.5D0*q+srd
       u    =  Dabs(tmp)**oot
       If(tmp.lt.0) u = -u
       tmp  =  -0.5D0*q-srd
       v    =  Dabs(tmp)**oot
       If(tmp.lt.0) v = -v

       x1   = -a/3.0D0+u+v

       prtr = -a/3.0D0-0.5D0*(u+v)
       prti =   srth*0.5D0*(u-v)

       x2 = prtr
       x3 = prtr

      !-----------------
      ! three real roots
      !-----------------

      Else

       cosphi = -0.5D0*q/(Dabs(p)/3.0D0)**opf
       phi    = Dacos(cosphi)

       cf = 2.0D0*sqrt(Dabs(p)/3.0D0)

       x1 = -a/3.0D0 + cf*Dcos(phi/3.0D0)
       x2 = -a/3.0D0 - cf*Dcos((phi-pi)/3.0D0)
       x3 = -a/3.0D0 - cf*Dcos((phi+pi)/3.0D0)

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

      EndIf

      return

      end subroutine CUBIC


! -----------------------------------------------------------------------------
!
! Copyright (c) 2009 - 2012 Chris Martin, Kasia Boronska, Jenny Young,
! Peter Jimack, Mike Pilling
!
! Copyright (c) 2017 Sam Cox, Roberto Sommariva
!
! This file is part of the AtChem2 software package.
!
! This file is covered by the MIT license which can be found in the file
! LICENSE.md at the top level of the AtChem2 distribution.
!
! -----------------------------------------------------------------------------

! ******************************************************************** !
! ATCHEM2 -- MODULE atmosphereFunctions
!
! This module contains functions responsible for calculating quantities
! relevant to the atmosphere: specifically, the air density, O2 and N2
! density, and convert from RH to H2O.
! ******************************************************************** !
module atmosphere_functions_mod
contains

  ! -----------------------------------------------------------------
  ! Calculate the number density of air (molecule cm-3) from pressure
  ! (mbar) and temperature (K).
  pure function calcAirDensity( press, temp ) result ( m )
    use types_mod
    implicit none

    real(kind=DP), intent(in) :: press, temp
    real(kind=DP) :: m, press_pa

    press_pa = press * 1.0e+02_DP
    m = 1.0e-06_DP * ( 6.02214129e+23_DP / 8.3144621_DP ) * ( press_pa / temp )

    return
  end function calcAirDensity

  ! -----------------------------------------------------------------
  ! Calculate the number density of oxygen and nitrogen in the atmosphere
  ! from number density of air (molecule cm-3).
  subroutine calcAtmosphere( m, o2, n2 )
    use types_mod
    implicit none

    real(kind=DP), intent(in) :: m
    real(kind=DP), intent(out) :: o2, n2

    o2 = 0.2095_DP * m
    n2 = 0.7809_DP * m

    return
  end subroutine calcAtmosphere

  ! -----------------------------------------------------------------
  ! Convert relative humidity to water concentration (molecule cm-3).
  ! Pressure in mbar (1 mbar = 1 hPa), temperature in K. Equations
  ! from "Humidity Conversion Formulas" by Vaisala (2013).
  pure function convertRHtoH2O( rh, temp, press ) result ( h2o )
    use types_mod
    implicit none

    real(kind=DP), intent(in) :: rh, temp, press
    real(kind=DP) :: h2o, h2o_ppu, temp_c, wvp

    ! Use Eq.6 to calculate the water vapour saturation pressure and
    ! Eq.1 to calculate the water vapour pressure from relative
    ! humidity (see Vaisala paper).
    temp_c = temp - 273.15_DP
    wvp = ( rh/100.0_DP ) * ( 6.116441_DP * 10.0_DP**((7.591386_DP * temp_c)/(temp_c + 240.7263_DP)) )

    ! Calculate volume of water vapour per volume of dry air using
    ! Eq.18 (see Vaisala paper). We don't use ppm here, because doing
    ! so requires a multiplication by 1e6 then division by the same
    ! in the final line. This incurs possible rounding. Instead, we
    ! use 'parts per unit'
    h2o_ppu = wvp / (press - wvp)

    ! convert ppv to molecule cm-3
    h2o = h2o_ppu * calcAirDensity(press, temp)

    return
  end function convertRHtoH2O

  ! -----------------------------------------------------------------
  ! subroutine to calculate diurnal variations in temperature
  ! --> CURRENTLY UNUSED, BUT IT MAY BE USEFUL <--
  subroutine temperature( temp, h2o, ttime )
    use types_mod
    implicit none

    real(kind=DP) :: temp, ttime, rh, h2o, sin, h2o_factor, exponent

    temp = 289.86_DP + 8.3_DP * sin( ( 7.2722e-5_DP * ttime ) - 1.9635_DP )
    temp = 298.00_DP
    rh = 23.0_DP * sin( ( 7.2722e-5_DP * ttime ) + 1.1781_DP ) + 66.5_DP
    h2o_factor = 10.0_DP / ( 1.38e-16_DP * temp ) * rh
    exponent = -1.0_DP * ( 597.3_DP - 0.57_DP * ( temp - 273.16_DP ) ) * 18.0_DP / 1.986_DP * ( 1.0_DP / temp - 1.0_DP / 273.16_DP )
    h2o = 6.1078_DP * exp( exponent ) * h2o_factor

    return
  end subroutine temperature

end module atmosphere_functions_mod


! Even Fibonacci numbers
!
! Each new term in the Fibonacci sequence is generated by adding the previous
! two terms. By starting with 1 and 2, the first 10 terms will be:
!                1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
! By considering the terms in the Fibonacci sequence whose values do not exceed
! four million, find the sum of the even-valued terms.
module Problem2

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 2. Even Fibonacci numbers.'

        write (*, '(A, I)') 'Even 1: ', even1()
        write (*, '(A, I)') 'Even 2: ', even2()
    end subroutine

    ! A direct translation of the problem statement
    function even1()
        integer even1
        integer prev
        integer cur
        integer temp

        ! initial values
        even1 = 0
        prev  = 1
        cur   = 1
        temp  = 0

        do while (cur <= 4000000)
            if (mod(cur, 2) .eq. 0) then
                even1 = even1 + cur
            end if

            temp = cur
            cur  = cur + prev
            prev = temp
        end do
    end function

    ! only every third number is added
    function even2()
        integer even2
        integer prev
        integer cur
        integer temp

        ! initial values
        even2 = 0
        prev  = 1
        cur   = 1
        temp  = prev + cur

        do while (temp < 4000000)
            even2 = even2 + temp
            prev  = cur   + temp
            cur   = temp  + prev
            temp  = prev  + cur
        end do
    end function
end module


program problem57
  use fmzm
  implicit none
  type(im),save      :: pm,pn,qm,qn,temp
  real*8             :: pdigits, qdigits
  integer            :: i,count
  integer, parameter :: limit=1000

  pm = 0
  pn = 1
  qm = 2
  qn = 2

  count=0

  ! References:
  ! http://mathworld.wolfram.com/PellNumber.html
  ! https://en.wikipedia.org/wiki/Pell_number
  ! https://en.wikipedia.org/wiki/Square_root_of_2
  do i=1,limit
     temp=pn
     pn=2*pn+pm
     pm=temp

     temp=qn
     qn=2*qn+qm
     qm=temp

     qdigits=ceiling(to_dp(log10(to_fm(qn) / to_fm('2.0'))))
     pdigits=ceiling(to_dp(log10(to_fm(pn))))

     if (qdigits > pdigits) count=count+1
  end do

  print *, count

end program problem57


module bobyqa_test_fun

implicit none

contains

subroutine calfun (n, x, f)

    use kind_module, only: wp

    implicit none

    integer,intent(in)               :: n
    real(wp),dimension(:),intent(in) :: x
    real(wp),intent(out)             :: f

    integer :: i,j
    real(wp) :: temp

    f = 0.0_wp
    do i = 4, n, 2
        do j = 2, i - 2, 2
            temp = (x(i-1)-x(j-1)) ** 2 + (x(i)-x(j)) ** 2
            temp = max (temp, 1.0e-6_wp)
            f = f + 1.0_wp / sqrt (temp)
        end do
    end do

end subroutine calfun

end module bobyqa_test_fun

program test_bobyqa

    !*****************************************************************************************
    !>
    !  Test problem for [[bobyqa]], the objective function being the sum of
    !  the reciprocals of all pairwise distances between the points P_I,
    !  I=1,2,...,M in two dimensions, where M=N/2 and where the components
    !  of P_I are X(2*I-1) and X(2*I). Thus each vector X of N variables
    !  defines the M points P_I. The initial X gives equally spaced points
    !  on a circle. Four different choices of the pairs (N,NPT) are tried,
    !  namely (10,16), (10,21), (20,26) and (20,41). Convergence to a local
    !  minimum that is not global occurs in both the N=10 cases. The details
    !  of the results are highly sensitive to computer rounding errors. The
    !  choice IPRINT=2 provides the current X and optimal F so far whenever
    !  RHO is reduced. The bound constraints of the problem require every
    !  component of X to be in the interval [-1,1].

    use ferror
    use kind_module, only: wp
    use PowellOpt, only: bobyqa
    use bobyqa_test_fun
    implicit none

    real(wp),dimension(100) :: x, xl, xu
    integer :: i,j,m,n,jcase,npt
    real(wp) :: temp

    real(wp),parameter :: twopi  = 8.0_wp * atan (1.0_wp)
    real(wp),parameter :: bdl    = - 1.0_wp
    real(wp),parameter :: bdu    = 1.0_wp
    integer,parameter  :: iprint = 2
    integer,parameter  :: maxfun = 500000
    real(wp),parameter :: rhobeg = 1.0e-1_wp
    real(wp),parameter :: rhoend = 1.0e-6_wp

    type(errors) :: err

    call err%set_exit_on_error(.false.)

    m = 5
    mainloop: do
        n = 2 * m
        do i = 1, n
            xl (i) = bdl
            xu (i) = bdu
        end do
        do jcase = 1, 2
            npt = n + 6
            if (jcase == 2) npt = 2 * n + 1
            print 30, m, n, npt
30              format (/ / 5 x, '2D output with M =', i4, ',  N =', i4, '  and  NPT =', i4)
            do j = 1, m
                temp = real (j, wp) * twopi / real (m, wp)
                x (2*j-1) = cos (temp)
                x (2*j) = sin (temp)
            end do
            call err%reset_error_status()
            call err%reset_timeout()
            call bobyqa (n, npt, x, xl, xu, rhobeg, rhoend, iprint, maxfun, calfun, err)
            if (err%has_error_occurred()) exit mainloop
        end do
        m = m + m
        if (m > 10) exit
    end do mainloop

    contains

end program test_bobyqa


subroutine get_face_velocity(level, time, &
     vx, vx_l1, vx_l2, vx_h1, vx_h2, &
     vy, vy_l1, vy_l2, vy_h1, vy_h2, &
     dx, prob_lo) bind(C, name="get_face_velocity")

  use mempool_module, only : bl_allocate, bl_deallocate

  implicit none

  integer, intent(in) :: level
  double precision, intent(in) :: time
  integer, intent(in) :: vx_l1, vx_l2, vx_h1, vx_h2
  integer, intent(in) :: vy_l1, vy_l2, vy_h1, vy_h2
  double precision, intent(out) :: vx(vx_l1:vx_h1,vx_l2:vx_h2)
  double precision, intent(out) :: vy(vy_l1:vy_h1,vy_l2:vy_h2)
  double precision, intent(in) :: dx(2), prob_lo(2)

  integer :: i, j, plo(2), phi(2)
  double precision :: x, y
  double precision, pointer, contiguous :: psi(:,:)
  double precision, parameter :: M_PI = 3.141592653589793238462643383279502884197d0

  plo(1) = min(vx_l1-1, vy_l1-1)
  plo(2) = min(vx_l2-1, vy_l2-1)
  phi(1) = max(vx_h1  , vy_h1+1)
  phi(2) = max(vx_h2+1, vy_h2  )

  call bl_allocate(psi, plo(1), phi(1), plo(2), phi(2))

  ! streamfunction psi
  do j = plo(2), phi(2)
     y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)
     do i = plo(1), phi(1)
        x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)
        psi(i,j) =  sin(M_PI*x)**2 * sin(M_PI*y)**2 * cos (M_PI*time/2.d0) * (1.d0 / M_PI)
     end do
  end do

  ! x velocity
  do j = vx_l2, vx_h2
     y = (dble(j)+0.5d0) * dx(2) + prob_lo(2)
     do i = vx_l1, vx_h1
        x = dble(i) * dx(1) + prob_lo(1)
        vx(i,j) =  -( (psi(i,j+1)+psi(i-1,j+1)) - (psi(i,j-1)+psi(i-1,j-1)) ) * (0.25d0/dx(2))
     end do
  end do

  ! y velocity
  do j = vy_l2, vy_h2
     y = dble(j) * dx(2) + prob_lo(2)
     do i = vy_l1, vy_h1
        x = (dble(i)+0.5d0) * dx(1) + prob_lo(1)
        vy(i,j) = ( (psi(i+1,j)+psi(i+1,j-1)) - (psi(i-1,j)+psi(i-1,j-1)) ) * (0.25d0/dx(1))
     end do
  end do

  call bl_deallocate(psi)

end subroutine get_face_velocity


      subroutine wdpowe(vr,vi,p,rr,ri,ierr)
c!purpose
c     computes v^p with v complex and p real
c!calling sequence
c     subroutine wdpowe(vr,vi,p,rr,ri,ierr)
c     integer ierr
c     double precision vr,vi,p,rr,ri
c     vr   : real part of v
c     vi   : imaginary part of v
c     rr   : result's real part
c     ri   : result's imaginary part
c     ierr : error flag
c            ierr=0 if ok
c            ierr=1 if 0**0
c            ierr=2 if  0**k with k<0
c!origin
c Serge Steer INRIA 1996
c!

c     Copyright INRIA
      integer ierr
      double precision vr,vi,p,sr,si,rr,ri,infinity
c
      ierr=0
c
      if(dble(int(p)).eq.p) then
         call wipowe(vr,vi,int(p),rr,ri,ierr)
      else
         if(abs(vr)+abs(vi).ne.0.0d+0) then
            call wlog(vr,vi,sr,si)
            sr=exp(sr*p)
            si=si*p
            rr=sr*cos(si)
            ri=sr*sin(si)
         else
            if(p.gt.0.0d+0) then
               rr=0.0d+0
               ri=0.0d+0
            elseif(p.lt.0.0d+0) then
               ri=0.0d+0
               rr=infinity(ri)
               ierr=2
            else
               rr=1.0d+0
               ri=0.0d+0
            endif
         endif
      endif
c
      return
      end