module global_module

  implicit none

  ! Time integration

  real(kind=8), parameter :: t_end      = 0.2d0 ! [s] total simulated time (from 0 to t_end)
  real(kind=8), parameter :: CFL_target = 0.2d0

  real(kind=8), parameter :: x_min = -0.5d0 ! [m]
  real(kind=8), parameter :: x_max = 0.5d0  ! [m]

  ! Total number of cells (including 4 ghost cells for each side)
  ! (using 4 ghost cells makes it easy to reach higher order accuracy)

  integer, parameter :: Nx = 200

  logical, parameter :: bool_PERIODIC = .false.

  ! Note: we use 4 ghost cells per side. This allows to reach up to 5th order
  ! (with the WENO method)
  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-8)

  ! Order in space
  ! 1: uniform sol in cell, first order in space
  ! 2: MUSCL with TVD slope limiter, second order in space
  ! 3: WENO 3rd order
  ! 5: WENO 5th order
  integer, parameter :: space_order = 3

  ! Order in time
  ! 1: forward Euler, first order in time
  ! 2: midpoint Euler, second order in time
  ! 3: explicit TVD Runge-Kutta, third order in time
  integer, parameter :: time_order = 3

  ! Space fluxes: choose ONLY one
  logical, parameter :: flux_type_Rusanov = .false.
  logical, parameter :: flux_type_HLL     = .true.

  ! Utilities
  real(kind=8) :: ws_maxabs ! Global variable, maximum wave speed

end module


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of TRANSPOSE
module m
  integer, parameter :: matrix(0:1,0:2) = reshape([1,2,3,4,5,6],shape(matrix))
  logical, parameter :: test_transpose_1 = all(transpose(matrix) == reshape([1,3,5,2,4,6],[3,2]))
end module


program main_program
implicit none

integer :: n2, n_grid, a, i, k, j, l, n
integer, allocatable, dimension(:) :: combination

write(*,*) 'm out of n?'
read(*,*) n2
read(*,*) n_grid

allocate ( combination(n2) )
open(unit=4, file='combination.txt', status='replace', action='write')
!
do i = 1, n2
   combination(i) = i !123
end do
write(4,*) combination
!
!--------------------------------------------------
!now, we generate all of the other combinations:
!--------------------------------------------------
!
!
a = 2
k = n2 + 1 !drives the increase of the last integer in the
!          combination, combination(m)
!
do while (combination(1) .lt. (n_grid - n2 + 1))
   if (combination(n2) .lt. n_grid) then
      combination(n2) = k !124 125 135 235
      k = k + 1
      !
      write(4,*) combination
      write(*,*) 'loop1', a, combination
      !
   else if (combination(n2) .eq. n_grid) then
      do j = 1, n2
         l = n2 - j
         if ( combination(j) .eq. (n_grid - l) ) then
            combination(j-1) = combination(j-1) + 1
            do n = j, n2
               combination(n) = combination(n-1) + 1 !134 145 234 245
                                                                !345
            end do
            k = combination(n2) + 1
            !
            write(4,*) combination
            write(*,*) 'loop2', a, combination
            !
            exit
         end if
      end do
   end if
   a = a + 1
end do

end program main_program


      FUNCTION ratval(x,cof,mm,kk)
      INTEGER kk,mm
      DOUBLE PRECISION ratval,x,cof(mm+kk+1)
      INTEGER j
      DOUBLE PRECISION sumd,sumn
      sumn=cof(mm+1)
      do 11 j=mm,1,-1
        sumn=sumn*x+cof(j)
11    continue
      sumd=0.d0
      do 12 j=mm+kk+1,mm+2,-1
        sumd=(sumd+cof(j))*x
12    continue
      ratval=sumn/(1.d0+sumd)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ratval.for


program laplace
  integer,parameter :: N1=64, N2=64
  real(8),parameter :: PI = 3.141592653589793238463

  integer :: niter=100
  real(8) :: u(N1,N2),uu(N1,N2)
  real(8) :: value = 0.0

!$xmp nodes p(4,*)
!$xmp template t(N1,N2)
!insert directive here
!insert directive here
!insert directive here
!insert directive here

!$xmp loop (i,j) on t(i,j)
  do j=1,N2
     do i=1,N1
        u(i,j)=0.0
        uu(i,j)=0.0
     end do
  end do

!insert directive here
  do j=2,N2-1
     do i=2,N1-1
        u(i,j)=sin(dble(i-1)/N1*PI)+cos(dble(j-1)/N2*PI)
     end do
  end do

  do k=1,niter

!insert directive here
     do j=2,N2-1
        do i=2,N1-1
           uu(i,j)=u(i,j)
        end do
     end do

!insert directives here
     do j=2,N2-1
        do i=2,N1-1
           u(i,j)=(uu(i-1,j) + uu(i+1,j) + uu(i,j-1) + uu(i,j+1))/4.0
        end do
     end do

  enddo

!$xmp loop (i,j) on t(i,j) !add something here
  do j=2,N2-1
     do i=2,N1-1
        value = value + dabs(uu(i,j) -u(i,j))
     end do
  end do

!$xmp task on p(1,1)
  print *, 'Verification =', value
!$xmp end task

end program laplace


FUNCTION erfcc(x)
REAL*8 erfcc,x
REAL*8 t,z
z=abs(x)
t=1./(1.+0.5*z)
erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t* &
& (.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t* &
& (1.48851587+t*(-.82215223+t*.17087277)))))))))
if (x.lt.0.) erfcc=2.-erfcc
return
END


program main
    implicit none
    real(8), parameter :: pi = acos(-1.d0), kB = 1.d0
    integer :: clock, n, i
    integer, allocatable :: seed(:)

    real(8) :: T = 1.d0, dT = .1d0, T_final = 5.d0, beta
    integer, parameter :: L_x = 32, L_y = 32
    integer :: lattice(0:L_x - 1, 0:L_y - 1)
    integer, parameter :: n_warmup = 100000, n_evol = 100000
    real(8) :: J = 1.d0, B = 0.d0
    real(8) :: M

    integer :: x, y

    ! seed initialization
    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(put = seed)

    open(unit = 1, file = 'M-T.txt', status = 'unknown')

    do while (T < T_final)

    ! spin initialization
    beta = 1.d0 / kB / T
    lattice = 1
    ! warm up
    do i = 1, n_warmup
        call EVOLUTION(lattice, L_x, L_y, beta, B, J)
    end do
    open(unit = 2, file = 'lattice.txt', status = 'unknown')
    do x = 0, L_x - 1
        do y = 0, L_y - 1
            write(2,'(3i4)') x, y, lattice(x,y)
        end do
    end do
    close(2)

    ! do while (T < T_final)
        beta = 1.d0 / kB / T
        M = 0.d0

        ! evolution
        do i = 1, n_evol
            call EVOLUTION(lattice, L_x, L_y, beta, B, J)
            M = M + dble(sum(lattice))
        end do
        M = M / dble(n_evol)
        write(*,'(2f15.5)') T, abs(M)
        write(1,'(2f15.5)') T, abs(M)
        T = T + dT
    end do
    close(1)
end program main

subroutine EVOLUTION(lattice, L_x, L_y, beta, B, J)
    implicit none
    integer, intent(in) :: L_x, L_y
    integer, intent(inout) :: lattice(0:L_x - 1, 0:L_y - 1)
    real(8), intent(in) :: beta, B, J
    real(8) :: r
    integer :: x, y
    real(8) :: dE

    call RANDOM_NUMBER(r)
    x = floor(r * dble(L_x))
    call RANDOM_NUMBER(r)
    y = floor(r * dble(L_y))

    dE = 0.d0
    dE = dE + 2.d0 * J * lattice(x,y) * (lattice(modulo(x - 1, L_x), y)&
        + lattice(modulo(x + 1, L_x), y)&
        + lattice(x, modulo(y - 1, L_y))&
        + lattice(x, modulo(y + 1, L_y)))&
        + 2.d0 * B * dble(lattice(x,y))

    call RANDOM_NUMBER(r)
    if (r < exp(-beta * dE)) then
        lattice(x,y) = -lattice(x,y)
    end if
end subroutine EVOLUTION


!!# FUNCTION MODULE: <FUN_xyINTEGRALY>
MODULE FUN_xyINTEGRALY

!!## PURPOSE
!! Integrates the function $Y$ over a polygon in 2D.

!!## METHOD
!! According to [1], the formula for the integral of $x$ over a polygon
!! is given by:
!
!! $$ S = \frac{1}{6} \sum_{i=1}^N ( y_i^2 + y_i x_{i-1} + y_{i-1}^2 )
!!                                 ( x_i - x_{i-1} ) $$
!
!! where the vertices of the polygon are given by $(x_i,y_i)$
!! for $i=1,...,N$ and $(x_0,y_0)=(x_N,y_N)$.

!!## AUTHORS
!! [jb] John Burkardt
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 10 July 2001 [jb]
!! 14 April 2007 [waw]

!!## REFERENCES
!! [1] SF Bockman,
!!     Generalizing the Formula for Areas of Polygons to Moments,
!!     American Mathematical Society Monthly,
!!     1989, pages 131-132.

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE FUN_xyAVERAGEY                              !!((05-A-FUN_xyAVERAGEY.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALY_Pg
 MODULE PROCEDURE xyINTEGRALY_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALY_Pg_Rdp
END INTERFACE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALY_Ls
 MODULE PROCEDURE xyINTEGRALY_Ls_Rsp
 MODULE PROCEDURE xyINTEGRALY_Ls_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALY_Ls
PUBLIC :: xyINTEGRALY_Ls_Rsp
PUBLIC :: xyINTEGRALY_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALY_Pg
PUBLIC :: xyINTEGRALY_Pg_Rsp
PUBLIC :: xyINTEGRALY_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyINTEGRALY_Ls_Rsp>
FUNCTION xyINTEGRALY_Ls_Rsp( Ls ) RESULT(INTEGRALY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-A-FUN_xyINTEGRALY_Ls.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALY_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALY_Ls_Rdp>
FUNCTION xyINTEGRALY_Ls_Rdp( Ls ) RESULT(INTEGRALY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-A-FUN_xyINTEGRALY_Ls.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALY_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALY_Pg_Rsp>
FUNCTION xyINTEGRALY_Pg_Rsp( N , Pg ) RESULT(INTEGRALY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALY_Pg.f90.hdr"

!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALY_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALY_Pg_Rdp>
FUNCTION xyINTEGRALY_Pg_Rdp( N , Pg ) RESULT(INTEGRALY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALY_Pg.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALY_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE


      PROGRAM FTEX07D
C
C  This program illustrates the use of CURVS1DP and CURVS2DP to
C  interpolate a smoothing tension spline for data in the plane.
C
C  Numeber of input data points and interpolation points.
C
      PARAMETER (NUM_IN=4,NUM_OUT=101)
C
C  GKS parameters.
C
      PARAMETER (IERRF=6,LUNIT=2,IWTYPE=1,IWKID=1)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION XS
      DOUBLE PRECISION YS
      DOUBLE PRECISION XSP
      DOUBLE PRECISION YSP
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION PARAM
      DOUBLE PRECISION XL
      DOUBLE PRECISION YL
      DOUBLE PRECISION XO
      DOUBLE PRECISION YO
      DOUBLE PRECISION XOO
      DOUBLE PRECISION YOO
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION D
      DOUBLE PRECISION S
      DOUBLE PRECISION EPS
      DOUBLE PRECISION XINC
      DOUBLE PRECISION T
C
C  Declare arrays.
C
      DIMENSION X(NUM_IN),Y(NUM_IN)
      DIMENSION XS(NUM_IN),YS(NUM_IN),XSP(NUM_IN),YSP(NUM_IN)
      DIMENSION TEMP(NUM_IN,19),PARAM(NUM_IN),XL(2),YL(2)
      DIMENSION XO(NUM_OUT),YO(NUM_OUT),XOO(NUM_OUT),YOO(NUM_OUT)
C
C  Specify the original data points in the plane.
C
      DATA X/0.5D0,-1.5D0,0.5D0,1.5D0/
      DATA Y/1.5D0,0.0D0,-2.5D0,-1.0D0/
C
C  Tension factor.
C
      SIGMA = 1.0D0
C
C  Specify a uniform observational weight (the interpolated
C  curve can be this far away from the original data points)..
C
      ISW = 1
      D = 0.2D0
C
C  Smoothing factor (larger values result in smoother curves).
C
      S = DBLE(NUM_IN)
C
C  Computational tolerance value.
C
      EPS = SQRT(2.D0/S)
C
C  Call CURVS1DP and CURVS2DP to calculate the smoothing spline.
C
      CALL CURVS1DP(NUM_IN,X,Y,D,ISW,S,EPS,PARAM,XS,YS,XSP,YSP,SIGMA,
     +     TEMP,IERR)
C
      XINC = 1.D0/DBLE(NUM_OUT-1)
      DO 10 I = 1,NUM_OUT
          T = DBLE(I-1)*XINC
          CALL CURVS2DP(T,NUM_IN,PARAM,XS,YS,XSP,YSP,SIGMA,XO(I),YO(I))
   10 CONTINUE
C
C  Not use CURVS1DP and CURVS2DP to compute an interpolating tension
C  spline by setting the smoothing parameter to zero.
C
      S = 0.D0
      EPS = 0.D0
      CALL CURVS1DP(NUM_IN,X,Y,D,ISW,S,EPS,PARAM,XS,YS,XSP,YSP,SIGMA,
     +     TEMP,IERR)
C
      DO 20 I = 1,NUM_OUT
          T = DBLE(I-1)*XINC
          CALL CURVS2DP(T,NUM_IN,PARAM,XS,YS,XSP,YSP,SIGMA,XOO(I),
     +         YOO(I))
   20 CONTINUE
C
C This next section plots the data. You must have a double precision
C version of NCAR Graphics in order for this section to compile and
C run correctly.  For now, it is commented out.
C
C  Plot the two curves.
C
C      CALL GOPKS(6,IBUF)
C      CALL GOPWK(IWKID,LUNIT,IWTYPE)
C      CALL GACWK(IWKID)
C
C  Define colors.
C
C      CALL GSCR(IWKID,0,1.D0,1.D0,1.D0)
C      CALL GSCR(IWKID,1,0.D0,0.D0,0.D0)
C      CALL GSCR(IWKID,2,1.D0,0.D0,0.D0)
C      CALL GSCR(IWKID,3,0.D0,0.D0,1.D0)
C
C  Main title.
C
C      CALL PCSETI('FN',25)
C      CALL PLCHHQ(0.5D0,0.95D0,'Demo for CURVS1DP/CURVS2DP',25.D0,0.D0,
C     +     0.D0)
C      CALL SET(0.1D0,0.95D0,0.2D0,0.90D0,-2.D0,3.D0,-3.D0,2.D0,1)
C
C  Background grid.
C
C      CALL GASETI('LTY',1)
C      CALL PCSETI('FN',21)
C      CALL GSPLCI(1)
C      CALL LABMOD('(F4.1)','(F4.1)',4,4,20,20,0,0,0)
C      CALL HALFAX(5,4,5,4,-2.D0,-3.D0,1,1)
C
C  Plot the smoothing spline in red, and its informational label.
C
C      CALL GSLWSC(3.D0)
C      CALL GSPLCI(2)
C      CALL GPL(NUM_OUT,XO,YO)
C      XL(1) = 0.250D0
C      XL(2) = 0.750D0
C      YL(1) = 0.625D0
C      YL(2) = 0.625D0
C      CALL GPL(2,XL,YL)
C      CALL PLCHHQ(0.875D0,0.625D0,'Smoothing spline',24.D0,0.D0,-1.D0)
C
C  Plot the tension spline in blue, and its informational label.
C
C      CALL GSPLCI(3)
C      CALL GPL(NUM_OUT,XOO,YOO)
C      XL(1) = 0.250D0
C      XL(2) = 0.750D0
C      YL(1) = 0.125D0
C      YL(2) = 0.125D0
C      CALL GPL(2,XL,YL)
C      CALL PLCHHQ(0.875D0,0.125D0,'Tension spline',24.D0,0.D0,-1.D0)
C
C  Mark the original data with black dots, and label.
C
C      CALL NGDOTS(X,Y,NUM_IN,0.13D0,1)
C      CALL NGDOTS(0.500D0,-0.375D0,1,0.13D0,1)
C      CALL PLCHHQ(0.875D0,-0.375D0,'Original data points',24.D0,0.D0,
C     +            -1.D0)
C
C      CALL FRAME
C
C      CALL GDAWK(IWKID)
C      CALL GCLWK(IWKID)
C      CALL GCLKS
C
      STOP
      END


! { dg-do run }
! Check the fix for PR28005, in which the mechanism for dealing
! with matmul (transpose (a), b) would cause wrong results for
! matmul (a(i, 1:n), b(1:n, 1:n)).
!
! Based on the original testcase contributed by
! Tobias Burnus  <tobias.burnus@physik.fu-berlin.de>
!
   implicit none
   integer, parameter         ::  nmax = 3
   integer                    ::  i, n = 2
   integer, dimension(nmax,nmax) ::  iB=0 , iC=1
   integer, dimension(nmax,nmax) ::  iX1=99, iX2=99, iChk
   iChk = reshape((/30,66,102,36,81,126,42,96,150/),(/3,3/))

! This would give 3, 3, 99
   iB = reshape((/1 ,3 ,0 ,2 ,5 ,0 ,0 ,0 ,0 /),(/3,3/))
   iX1(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) )

! This would give 4, 4, 99
   ib(3,1) = 1
   iX2(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) )

! Whereas, we should have 8, 8, 99
   if (any (iX1(1:n,1) .ne. (/8, 8, 99/))) call abort ()
   if (any (iX1 .ne. iX2)) call abort ()

! Make sure that the fix does not break transpose temporaries.
   iB = reshape((/(i, i = 1, 9)/),(/3,3/))
   ic = transpose (iB)
   iX1 = transpose (iB)
   iX1 = matmul (iX1, iC)
   iX2 = matmul (transpose (iB), iC)
   if (any (iX1 .ne. iX2)) call abort ()
   if (any (iX1 .ne. iChk)) call abort ()
end


module mesh_module
    use iso_fortran_env
    implicit none

contains

subroutine create2DRectMesh(NodCoord, ElemNod, ElemMat,xn, yn, lx, ly)
    real(real64),allocatable,intent(inout) :: NodCoord(:,:)
    integer(int32),allocatable,intent(inout) :: ElemNod(:,:)
    integer(int32),allocatable,intent(inout) :: ElemMat(:)

    integer(int32),intent(in) :: xn ! 要素分割数　for X方向
    integer(int32),intent(in) :: yn ! 要素分割数　for Y方向

    real(real64),intent(in) :: lx ! x方向長さ
    real(real64),intent(in) :: ly ! y方向長さ

    real(real64) :: unitx, unity

    integer(int32) :: i,j,n

    unitx=lx/dble(xn)
    unity=ly/dble(yn)

    ! creating rectangular mesh
    allocate(NodCoord( (xn+1)*(yn+1) , 2 ))
    allocate(ElemNod( xn*yn,4) )
    allocate(ElemMat(xn*yn) )

    n=0
    do j=1, yn+1
        do i=1, xn+1
            n=n+1
            NodCoord(n,1)=lx/dble(xn)*dble(i-1)
            NodCoord(n,2)=ly/dble(yn)*dble(j-1)
        enddo
    enddo

    n=1
    ElemNod(1,1)=1
    ElemNod(1,2)=2
    ElemNod(1,3)=yn+3
    ElemNod(1,4)=yn+2
    ElemNod(2,1)=2
    ElemNod(2,2)=3
    ElemNod(2,3)=yn+4
    ElemNod(2,4)=yn+3

    n=0
    do j=1, yn
        do i=1, xn
            n=n+1
            ElemNod(n,1)=i + (j-1)*(xn+1)
            ElemNod(n,2)=i+1 + (j-1)*(xn+1)
            ElemNod(n,3)=xn+2+i+ (j-1)*(xn+1)
            ElemNod(n,4)=xn+1+i + (j-1)*(xn+1)
            ElemMat(n)=1
        enddo
    enddo

end subroutine

end module

program main
    use iso_fortran_env
    use plantfem
    use mesh_module
    implicit none

    real(real64),allocatable :: NodCoord(:,:)
    integer(int32),allocatable :: ElemNod(:,:)
    integer(int32),allocatable :: ElemMat(:)

    integer(int32) :: xn=2 ! 要素分割数　for X方向
    integer(int32) :: yn=2 ! 要素分割数　for Y方向

    real(real64) :: lx=2.0d0 ! x方向長さ
    real(real64) :: ly=2.0d0 ! y方向長さ

    call create2DRectMesh(NodCoord=NodCoord, ElemNod=ElemNod, ElemMat=ElemMat,&
        xn=xn, yn=yn, lx=lx, ly=ly)
    ! 材料番号のみ修正
    ElemMat(4)=2

    call print(Nodcoord)
    call print(ElemNod)
    call print(ElemMat)
    ! export
    ! ...略

end program main


MODULE mo_poly

  ! This module determines wether a 2D point lies inside, outside, or
  ! on the vertice/edge of a 2D polygon
  ! and is part of the JAMS Fortran library.
  !
  ! Written  Juliane Mai, July 2012
  ! Modified Maren Goehler, July 2012 - area & center of mass

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2012 Juliane Mai
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, sp, dp
  USE mo_utils, only: eq, ge, le

  IMPLICIT NONE

  PUBLIC :: areapoly        ! compute the area of a polygon
  PUBLIC :: center_of_mass  ! compute the center of mass of a polygon
  PUBLIC :: inpoly          ! Test if 2D point is inside, outside or&
  ! on vertice/edge of a 2D polygon

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

  !     NAME
  !         areapoly

  !     PURPOSE
  !         Function for computing the area of a polygon
  !         The polygon can be convex or not.
  !
  !         The method is only applicable for 2D polygons and points.
  !
  !         http://de.wikipedia.org/wiki/Geometrischer_Schwerpunkt
  !
  !     CALLING SEQUENCE
  !         area =  areapoly(coord)

  !     INTENT(IN)
  !         real(sp/dp) :: coord(:,2)     (x,y) coordinates of edges of the polygon

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Only available in 2D version

  !     EXAMPLE
  !         polygon(:,1) = (/ 1.0_dp,2.0_dp,2.0_dp,1.0_dp /)
  !         polygon(:,2) = (/ 1.0_dp,1.0_dp,2.0_dp,2.0_dp /)
  !
  !         area = areapoly(polygon )
  !
  !         --> area = 1
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         http://de.wikipedia.org/wiki/Geometrischer_Schwerpunkt

  !     HISTORY
  !         Written,  Maren Goehler, July 2012
  INTERFACE areapoly
     MODULE PROCEDURE areapoly_sp, areapoly_dp
  END INTERFACE areapoly

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

  !     NAME
  !         center_of_mass

  !     PURPOSE
  !         Function for computing the center of mass of a polygon
  !         Computation of polygon area needed for center of mass.
  !         The polygon can be convex or not.
  !
  !         The method is only applicable for 2D polygons and points.
  !
  !         http://de.wikipedia.org/wiki/Geometrischer_Schwerpunkt
  !
  !         A = sum(xiyi+1-xi+1yi)
  !         xs = 1/(6*A) * sum(xi+xi+1)(xiyi+1-xi+1yi)
  !         ys = 1/(6*A) * sum(yi+yi+1)(xiyi+1-xi+1yi)

  !     CALLING SEQUENCE
  !         com =  center_of_mass(coord)

  !     INTENT(IN)
  !         real(sp/dp) :: coord(:,2)     (x,y) coordinates of edges of the polygon

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Only available in 2D version

  !     EXAMPLE
  !         polygon(:,1) = (/ 1.0_dp,2.0_dp,2.0_dp,1.0_dp /)
  !         polygon(:,2) = (/ 1.0_dp,1.0_dp,2.0_dp,2.0_dp /)
  !
  !         com = center_of_mass(polygon)
  !
  !         --> com = (/1.5_dp, 1.5_dp/)
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         http://de.wikipedia.org/wiki/Geometrischer_Schwerpunkt

  !     HISTORY
  !         Written,  Maren Goehler, July 2012
  INTERFACE center_of_mass
     MODULE PROCEDURE center_of_mass_sp,center_of_mass_dp
  END INTERFACE center_of_mass

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

  !     NAME
  !         inpoly

  !     PURPOSE
  !         Determines whether a 2D point falls in a polygon or is located outside or
  !         lies on a vertex or an edge of the polygon.
  !         The polygon can be convex or not.
  !
  !         The method is only applicable for 2D polygons and points.
  !
  !         The original version of the source code (pnpoly) was implemented by
  !         W. Randolph Franklin. It was insufficiently assigning vertex/edge points.

  !     CALLING SEQUENCE
  !         call inpoly( p, coord, inside )

  !     INTENT(IN)
  !         real(sp/dp) :: p(2)           coordinates of the point in question
  !         real(sp/dp) :: coord(:,2)     (x,y) coordinates of edges of the polygon

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         integer(i4) :: inside   whether point is inside (=1), outside (=-1) or
  !                                 on a vertex/edge of the polygon

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Only available in 2D version

  !     EXAMPLE
  !         polygon(:,1) = (/ 1.0_dp,2.0_dp,2.0_dp,1.0_dp /)
  !         polygon(:,2) = (/ 1.0_dp,1.0_dp,2.0_dp,2.0_dp /)
  !
  !         point = (/ 1.5, 1.5 /)
  !
  !         call inpoly( point, polygon, inside )
  !
  !         --> inside = 1 ... point is inside the polygon
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html

  !     HISTORY
  !         Written,  Juliane Mai, July 2012
  !         Modified, Juliane Mai, July 2012 - removing GOTO statements
  INTERFACE inpoly
     MODULE PROCEDURE inpoly_dp, inpoly_sp
  END INTERFACE inpoly

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

  PRIVATE

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

CONTAINS

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

  FUNCTION areapoly_dp(coord)
    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:),     INTENT(IN)     :: coord        ! Coordinates of the polygon in question
    REAL(dp)                                     :: areapoly_dp

    ! Local variables
    INTEGER(i4)                                  :: i,k          ! loop
    INTEGER(i4)                                  :: Nedges       ! number of coordinates
    REAL(dp)                                     :: xsum         ! for summing up
    REAL(dp)                                     :: ysum         ! for summing up

    xsum   = 0.0_dp
    ysum   = 0.0_dp
    Nedges = size(coord,1)

    do i = 1,  Nedges
       if (i .eq. Nedges) then
          k = 1_i4
       else
          k = i + 1_i4
       end if
       xsum = xsum + ( coord(i,1) * coord(k,2) )
       ysum = ysum + ( coord(i,2) * coord(k,1) )
    end do

    areapoly_dp = 0.5_sp * (xsum - ysum)

    RETURN
  END FUNCTION areapoly_dp

  FUNCTION areapoly_sp(coord)
    IMPLICIT NONE
    REAL(sp),   dimension(:,:),   INTENT(IN)    :: coord       ! Coordinates of the polygon in question
    REAL(sp)                                    :: areapoly_sp

    ! Local variables
    INTEGER(i4)                                 :: i,k         ! loop
    INTEGER(i4)                                 :: Nedges      ! number of coordinates
    REAL(sp)                                    :: xsum        ! for summing up
    REAL(sp)                                    :: ysum        ! for summing up

    xsum   = 0.0_sp
    ysum   = 0.0_sp
    Nedges = size(coord,1)

    do i = 1,  Nedges
       if (i .eq. Nedges) then
          k = 1_i4
       else
          k = i + 1_i4
       end if
       xsum = xsum + ( coord(i,1) * coord(k,2) )
       ysum = ysum + ( coord(i,2) * coord(k,1) )
    end do

    areapoly_sp = 0.5_sp * (xsum - ysum)

  END FUNCTION areapoly_sp

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

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

  FUNCTION center_of_mass_dp(coord)
    IMPLICIT NONE

    REAL(dp),   dimension(:,:),   INTENT(IN)    :: coord              ! Coordinates of polygon in question
    REAL(dp),dimension(2)                       :: center_of_mass_dp

    ! Local variables
    INTEGER(i4)                                 :: i,k       ! loop
    INTEGER(i4)                                 :: Nedges    ! number of coordinates
    REAL(dp)                                    :: area      ! area of the polygon
    REAL(dp)                                    :: xsum      ! for summing up
    REAL(dp)                                    :: ysum      ! for summing up
    REAL(dp)                                    :: hotspot_x ! for summing up
    REAL(dp)                                    :: hotspot_y ! for summing up

    xsum = 0.0_dp
    ysum = 0.0_dp
    Nedges = size(coord,1)

    area = areapoly_dp(coord)

    do i = 1, Nedges
       if (i .eq. Nedges ) then
          k = 1_i4
       else
          k = i + 1_i4
       end if
       ! multiply x coord by the y coord of next vertex
       xsum = xsum + ((coord(i,1) + coord(k,1)) * &
            ((coord(i,1) * coord(k,2) - coord(k,1) * coord(i,2))))

       ysum = ysum + ((coord(i,2) + coord(k,2)) * &
            ((coord(i,1) * coord(k,2) - coord(k,1) * coord(i,2))))
    end do

    hotspot_x = 1.0_dp / (6.0_dp * area) * xsum
    hotspot_y = 1.0_dp / (6.0_dp * area) * ysum

    center_of_mass_dp(1) = hotspot_x
    center_of_mass_dp(2) = hotspot_y

    RETURN
  END FUNCTION  center_of_mass_dp

  FUNCTION center_of_mass_sp(coord)
    IMPLICIT NONE

    REAL(sp),dimension(:,:),   INTENT(IN)       :: coord               ! Coordinates of polygon in question
    REAL(sp),dimension(2)                       :: center_of_mass_sp

    ! Local variables
    INTEGER(i4)                                 :: i,k       ! loop
    INTEGER(i4)                                 :: Nedges    ! number of coordinates
    REAL(sp)                                    :: area      ! area of the polygon
    REAL(sp)                                    :: xsum      ! for summing up
    REAL(sp)                                    :: ysum      ! for summing up
    REAL(sp)                                    :: hotspot_x ! for summing up
    REAL(sp)                                    :: hotspot_y ! for summing up

    xsum   = 0.0_sp
    ysum   = 0.0_sp
    Nedges = size(coord,1)

    area = areapoly_sp(coord)

    do i = 1, Nedges
       if (i .eq. Nedges ) then
          k = 1_i4
       else
          k = i + 1_i4
       end if
       ! multiply x coord by the y coord of next vertex
       xsum = xsum + ((coord(i,1) + coord(k,1)) * &
            ((coord(i,1) * coord(k,2) - coord(k,1) * coord(i,2))))

       ysum = ysum + ((coord(i,2) + coord(k,2)) * &
            ((coord(i,1) * coord(k,2) - coord(k,1) * coord(i,2))))
    end do

    hotspot_x = 1.0_sp / (6.0_sp * area) * xsum
    hotspot_y = 1.0_sp / (6.0_sp * area) * ysum

    center_of_mass_sp(1) = hotspot_x
    center_of_mass_sp(2) = hotspot_y

    RETURN
  END FUNCTION  center_of_mass_sp

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

  SUBROUTINE inpoly_dp(P,coord,erg)
    !
    REAL(dp),   dimension(2),   INTENT(IN)  :: P           ! Point in question
    REAL(dp),   dimension(:,:), INTENT(IN)  :: coord       ! Coordinates of the polygon
    INTEGER(i4),                INTENT(OUT) :: erg         ! Result:
    !     inside:         erg =  1
    !     outside:        erg = -1
    !     on vertex/edge: erg =  0

    ! Local variables
    REAL(dp), dimension(:), allocatable   :: X, Y
    REAL(dp)                              :: lx, ly
    LOGICAL                               :: MX,MY,NX,NY, test1, test2
    INTEGER(i4)                           :: N, I, J

    N  = size(coord,1)
    allocate(x(N))
    allocate(y(N))

    do i=1,N
       X(I)=coord(I,1)-P(1)
       Y(I)=coord(I,2)-P(2)
       ! Edge
       if ( eq(X(I),0.0_dp) .and. eq(Y(I),0.0_dp) ) then
          erg=0_i4
          return
       end if
    end do

    erg=-1_i4

    DO I=1,N
       J=1+MOD(I,N)
       ! vertical Vertex
       If ( eq(coord(I,1),coord(J,1)) .and. eq(coord(I,1),P(1)) ) then
          ly = (P(2)-coord(J,2)) / (coord(I,2)-coord(J,2))
          If ( ge(ly,0.0_dp) .and. le(ly,1.0_dp) ) then
             erg=0_i4
             return
          end if
       end if
       ! horizontal Vertex
       If ( eq(coord(I,2),coord(J,2)) .and. eq(coord(I,2),P(2)) ) then
          lx = (P(1)-coord(J,1)) / (coord(I,1)-coord(J,1))
          If ( ge(lx,0.0_dp ) .and. le(lx,1.0_dp) ) then
             erg=0_i4
             return
          end if
       end if
       !
       MX = ge(X(I),0.0_dp)
       NX = ge(X(J),0.0_dp)
       MY = ge(Y(I),0.0_dp)
       NY = ge(Y(J),0.0_dp)

       test1 = .NOT.((MY.OR.NY).AND.(MX.OR.NX)).OR.(MX.AND.NX)
       test2 = .NOT.(MY.AND.NY.AND.(MX.OR.NX).AND..NOT.(MX.AND.NX))

       if (.not. test1) then
          if (test2) then
             IF ((Y(I)*X(J)-X(I)*Y(J))/(X(J)-X(I)) .lt. 0.0_dp) then
                cycle
             ELSE
                IF ((Y(I)*X(J)-X(I)*Y(J))/(X(J)-X(I)) .gt. 0.0_dp) then
                   erg = -erg
                   cycle
                ELSE
                   erg = 0_i4
                   return
                END IF
             END IF
          else
             erg=-erg
          end if
       end if

    END DO

    deallocate(x)
    deallocate(y)

  END SUBROUTINE inpoly_dp

  SUBROUTINE inpoly_sp(P,coord,erg)
    !
    REAL(sp),   dimension(2),   INTENT(IN)  :: P           ! Point in question
    REAL(sp),   dimension(:,:), INTENT(IN)  :: coord       ! Coordinates of the polygon
    INTEGER(i4),                INTENT(OUT) :: erg         ! Result:
    !     inside:         erg =  1
    !     outside:        erg = -1
    !     on vertex/edge: erg =  0

    ! Local variables
    REAL(sp), dimension(:), allocatable   :: X, Y
    REAL(sp)                              :: lx, ly
    LOGICAL                               :: MX,MY,NX,NY, test1, test2
    INTEGER(i4)                           :: N, I, J

    N  = size(coord,1)
    allocate(x(N))
    allocate(y(N))

    do i=1,N
       X(I)=coord(I,1)-P(1)
       Y(I)=coord(I,2)-P(2)
       ! Edge
       if ( eq(X(I),0.0_sp) .and. eq(Y(I),0.0_sp) ) then
          erg=0_i4
          return
       end if
    end do

    erg=-1_i4

    DO I=1,N
       J=1+MOD(I,N)
       ! vertical Vertex
       If ( eq(coord(I,1),coord(J,1)) .and. eq(coord(I,1),P(1)) ) then
          ly = (P(2)-coord(J,2)) / (coord(I,2)-coord(J,2))
          If ( ge(ly,0.0_sp) .and. le(ly,1.0_sp) ) then
             erg=0_i4
             return
          end if
       end if
       ! horizontal Vertex
       If ( eq(coord(I,2),coord(J,2)) .and. eq(coord(I,2),P(2)) ) then
          lx = (P(1)-coord(J,1)) / (coord(I,1)-coord(J,1))
          If ( ge(lx,0.0_sp ) .and. le(lx,1.0_sp) ) then
             erg=0_i4
             return
          end if
       end if
       !
       MX = ge(X(I),0.0_sp)
       NX = ge(X(J),0.0_sp)
       MY = ge(Y(I),0.0_sp)
       NY = ge(Y(J),0.0_sp)

       test1 = .NOT.((MY.OR.NY).AND.(MX.OR.NX)).OR.(MX.AND.NX)
       test2 = .NOT.(MY.AND.NY.AND.(MX.OR.NX).AND..NOT.(MX.AND.NX))

       if (.not. test1) then
          if (test2) then
             IF ((Y(I)*X(J)-X(I)*Y(J))/(X(J)-X(I)) .lt. 0.0_sp) then
                cycle
             ELSE
                IF ((Y(I)*X(J)-X(I)*Y(J))/(X(J)-X(I)) .gt. 0.0_sp) then
                   erg = -erg
                   cycle
                ELSE
                   erg = 0_i4
                   return
                END IF
             END IF
          else
             erg=-erg
          end if
       end if

    END DO

    deallocate(x)
    deallocate(y)

  END SUBROUTINE inpoly_sp

END MODULE mo_poly


FUNCTION huc1(bwtdmx,bwtdmn,bctmax,bctmin)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: bctmax,bctmin,bwtdmn,bwtdmx
REAL :: huc1
!
! Local variables
!
REAL :: heatunit
!
!     author : amare retta
!     + + + purpose + + +
!     calculate single day heat units for given temperatures

!     + + + keywords + + +
!     heat units, daylength

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bctmax - maximum crop growth temperature. Debe assumed this definition
!     bctmin - minimum crop growth temperature
!     bctopt - optimum crop growth temperature. Not currently used.
!     bwtdmn - daily minimum air temperature
!     bwtdmx - daily maximum air temperature
!     huc1 - returns the value of hte function. Debe assumed this definition

!     + + + local variable definitions + + +
!     heatunit - a function. This variable holds the value returned by
!                the Heatunit function. Debe assumed this definition

!     + + + output formats + + +
!2000 format('+',109x,2(f8.2,1x))

!     + + + function declarations + + +

!     + + + end of specifications + + +

huc1 = heatunit(bwtdmx,bwtdmn,bctmin) - heatunit(bwtdmx,bwtdmn,bctmax)
IF (huc1.LT.0.) huc1 = 0.
!
END FUNCTION huc1

Project Documents/Source Code Original/Huc1.f90


subroutine clawpack46_inlinelimiter(maxm,meqn,mwaves,mbc, &
           mx,wave,s,mthlim)
!!     =====================================================

!! # Apply a limiter to the waves.
!!
!! # Version of December, 2002.
!! # Modified from the original CLAWPACK routine to eliminate calls
!! # to philim.  Since philim was called for every wave at each cell
!! # interface, this was adding substantial overhead in some cases.
!!
!! # The limiter is computed by comparing the 2-norm of each wave with
!! # the projection of the wave from the interface to the left or
!! # right onto the current wave.  For a linear system this would
!! # correspond to comparing the norms of the two waves.  For a
!! # nonlinear problem the eigenvectors are not colinear and so the
!! # projection is needed to provide more limiting in the case where the
!! # neighboring wave has large norm but points in a different direction
!! # in phase space.
!!
!! # The specific limiter used in each family is determined by the
!! # value of the corresponding element of the array mthlim.
!! # Note that a different limiter may be used in each wave family.
!!
!! # dotl and dotr denote the inner product of wave with the wave to
!! # the left or right.  The norm of the projections onto the wave are then
!! # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
!! # of wave.

    implicit none

    integer :: maxm, meqn, mwaves, mbc, mx
    integer :: mthlim(mwaves)

    double precision :: wave(meqn,mwaves,1-mbc:maxm+mbc)
    double precision :: s(mwaves,1-mbc:maxm+mbc)

    integer :: mw,i, m
    double precision :: dotr, wnorm2, dotl, r, c, th
    double precision :: wlimitr

    wave_loop : do mw = 1,mwaves
        if (mthlim(mw) .eq. 0) then
            continue
        endif
        dotr = 0.d0
        i_loop : do i = 0, mx+1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do m = 1,meqn
                wnorm2 = wnorm2 + wave(m,mw,i)**2
                dotr = dotr + wave(m,mw,i)*wave(m,mw,i+1)
            end do

            if (i .eq. 0 .or. wnorm2 .eq. 0) then
                cycle
            endif

            !! if (i .gt. 0 .and. wnorm2 .ne. 0) then
            if (s(mw,i) .gt. 0.d0) then
                r = dotl / wnorm2
            else
                r = dotr / wnorm2
            endif

            !! go to (10,20,30,40,50) mthlim(mw)
            wlimitr = 1.0
            if (mthlim(mw) .eq. 1) then
                !! 10         continue
                !! --------
                !! # minmod
                !! --------
                wlimitr = max(0., min(1., r))
                !! go to 170
            elseif (mthlim(mw) .eq. 2) then
                !! 20         continue
                !! ----------
                !! # superbee
                !! ----------
                wlimitr = max(0., min(1., 2.*r), min(2., r))
                !! go to 170
            elseif (mthlim(mw) .eq. 3) then
                !! 30         continue
                !! ----------
                !! # van Leer
                !! ----------
                wlimitr = (r + dabs(r)) / (1.d0 + dabs(r))
                !! go to 170
            elseif (mthlim(mw) .eq. 4) then
                !! 40         continue
                !! ------------------------------
                !! # monotinized centered
                !! ------------------------------
                c = (1.d0 + r)/2.d0
                wlimitr = dmax1(0.d0, dmin1(c, 2.d0, 2.d0*r))
                !! go to 170
            elseif (mthlim(mw) .eq.  5) then
                !! 50         continue
                !! ------------------------------
                !! # Beam-Warming
                !! ------------------------------
                wlimitr = r
                !! go to 170
            elseif (mthlim(mw) .eq. 6) then
                !! 60         continue
                !! ------------------------------
                !! # Generalized minmod
                !! ------------------------------
                th = 1.3
                wlimitr = dmax1(0.d0, dmin1(th*r,(1+r)/2.d0,th));
                !! go to 170
            endif

!!  170       continue

            !! # apply limiter to waves:c
            do m = 1,meqn
                wave(m,mw,i) = wlimitr * wave(m,mw,i)
            end do
        end do i_loop
    end do wave_loop

    return
end subroutine clawpack46_inlinelimiter


subroutine pTuberiaSimple()
    use metodosLineales
    use messages
    implicit none
    !variables externas
    real:: Q, l, zy, ks, d, Sigma_km, nu
    !Variables externas no en el diagrama
    real:: H, p, E

    !variables internas
    integer :: i, Re, selection
    real:: v,Sigma_hm,ksd, f,hf, Pot,A
    character :: option
    !Parametros
    real, parameter :: pi = 4 * atan (1.0), g = 9.81, p_agua = 999.1

    print *, char(10),"         <<<<2: Potencia de Tuberia Simple>>>>",char(10)

    !Etapa de lectura
    Q = 0.042;l=970;zy =16;ks=1.5e-6; d=6*0.0254;Sigma_km=9.4;nu = 1.14e-6
     write(*,*) "Por defecto, se cargaran datos del ejemplo 2.2",char(10)
        do i = 1,10
         print datosEjercicio2, Q, l, zy, ks, d, Sigma_km, nu

        write (*,'(a)',ADVANCE="NO") "Desea continuar con estos datos (y/n)? "
        read(*,*) option
        if (option == 'y')then
            exit
        else
            write(*,*) char(10),"introduzca los valores(7) como un vector con el sgte formato: "
            print*,"Q, l, zy, ks, d, Sigma_km, nu"
            read(*,*)Q, l, zy, ks, d, Sigma_km, nu  !DEBUG
            print*, char(10)
        end if
        end do

        !Calcular v, velocidad
         A = pi/4 * d**2
         v = Q /A

        !Calcular Sigma_hm, perdidas menores
         Sigma_hm = Sigma_km * ((v ** 2) / (2 * g))

        !Calcular Re y ksd
        Re = v * d / nu

        ksd = Ks / d

        !Calcular f con metodo numerico ecuacion 1.67
        print "(a6,a18,a18,a12,a12)","A","v","Sigma_hm","Re","ksd"
        write(*,*)A,v,Sigma_hm,Re,ksd,char(10)

        print *, "1- Newton"
        print *, "2- Newton-Rapson"

        do while (.true.)
            write (*,'(a)',ADVANCE="NO") ">Seleccione una opcion y presione ENTER (1 + ENTER): "
            read(*,*) selection
            select case (selection)
                case (1)
                    f= friccion1Pto(ksd,Re,0.001)
                    exit
                case (2)
                    f = friccionNewtonRapshon(ksd,Re,0.001)
                    exit
                case default
                    print *, "caso no contemplado"
            end select

        end do

        !Calcular h con 1.36
         hf = f * (l / d) * ((v ** 2) / (2 * g))

        !Calcular Htotal
        H = zy + hf + Sigma_hm

        print *, char(10)
        print "(a6,a18,a12,a12)","f","hf","H"
        write(*,*)f,hf,H,char(10)
        !Potencia
        Pot = p_agua * Q * g * H

        !Imprimir
        write(*,*) "P= ",Pot," W"
        write(*,*) "P= ",Pot/1000," kW"
        read(*,*)

    end subroutine pTuberiaSimple


	FUNCTION PS_CTOT  ( td850, t500 )
C************************************************************************
C* PS_CTOT								*
C*									*
C* This function computes the cross totals index:			*
C*									*
C*     CTOT = TD850 - T500 						*
C*									*
C* REAL PS_CTOT ( TD850, T500 )						*
C*									*
C* Input parameters:							*
C*	TD850		REAL		850 mb dewpoint in Celsius	*
C*	T500		REAL		500 mb temperature in Celsius	*
C*									*
C* Output parameters:							*
C*	PS_CTOT		REAL		Cross totals index		*
C**									*
C* Log:									*
C* M. Goodman/RDS	11/84	Original source				*
C* M. desJardins/GSFC	 3/88	Documentation				*
C************************************************************************
        INCLUDE        'GEMPRM.PRM'
        INCLUDE        'ERMISS.FNC'
C------------------------------------------------------------------------------
	IF  ( ERMISS (td850) .or. ERMISS (t500) )  THEN
	    PS_CTOT = RMISSD
	  ELSE
C
C*	    Compute the cross totals index by subtracting 500 mb
C*	    temperature from the 850 mb dewpoint.
C
	    PS_CTOT = td850 - t500
	END IF
C*
	RETURN
	END


      SUBROUTINE MB04SU( M, N, A, LDA, B, LDB, CS, TAU, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a symplectic QR decomposition of a real 2M-by-N matrix
C     [A; B],
C
C               [ A ]             [ R11  R12 ]
C               [   ] = Q * R = Q [          ],
C               [ B ]             [ R21  R22 ]
C
C     where Q is a symplectic orthogonal matrix, R11 is upper triangular
C     and R21 is strictly upper triangular.
C     If [A; B] is symplectic then, theoretically, R21 = 0 and
C     R22 = inv(R11)^T. Unblocked version.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of A and B. M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of A and B. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading M-by-N part of this array contains
C             the matrix [ R11  R12 ] and, in the zero parts of R,
C             information about the elementary reflectors used to
C             compute the symplectic QR decomposition.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,M).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix B.
C             On exit, the leading M-by-N part of this array contains
C             the matrix [ R21  R22 ] and, in the zero parts of B,
C             information about the elementary reflectors used to
C             compute the symplectic QR decomposition.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,M).
C
C     CS      (output) DOUBLE PRECISION array, dimension (2 * min(M,N))
C             On exit, the first 2*min(M,N) elements of this array
C             contain the cosines and sines of the symplectic Givens
C             rotations used to compute the symplectic QR decomposition.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
C             On exit, the first min(M,N) elements of this array
C             contain the scalar factors of some of the elementary
C             reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -10,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
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     The matrix Q is represented as a product of symplectic reflectors
C     and Givens rotations
C
C     Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C         diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                           ....
C         diag( H(k),H(k) ) G(k) diag( F(k),F(k) ),
C
C     where k = min(m,n).
C
C     Each H(i) has the form
C
C           H(i) = I - tau * w * w'
C
C     where tau is a real scalar, and w is a real vector with
C     w(1:i-1) = 0 and w(i) = 1; w(i+1:m) is stored on exit in
C     B(i+1:m,i), and tau in B(i,i).
C
C     Each F(i) has the form
C
C           F(i) = I - nu * v * v'
C
C     where nu is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
C     A(i+1:m,i), and nu in TAU(i).
C
C     Each G(i) is a Givens rotation acting on rows i of A and B,
C     where the cosine is stored in CS(2*i-1) and the sine in
C     CS(2*i).
C
C     REFERENCES
C
C     [1] Bunse-Gerstner, A.
C         Matrix factorizations for symplectic QR-like methods.
C         Linear Algebra Appl., 83, pp. 49-77, 1986.
C
C     [2] Byers, R.
C         Hamiltonian and Symplectic Algorithms for the Algebraic
C         Riccati Equation.
C         Ph.D. Dissertation, Center for Applied Mathematics,
C         Cornell University, Ithaca, NY, 1983.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires
C        8*M*N*N - 8/3*N*N*N +  2*M*N + 6*N*N + 8/3*N,  if M >= N,
C        8*M*M*N - 8/3*M*M*M + 14*M*N - 6*M*M + 8/3*N,  if M <= N,
C     floating point operations and is numerically backward stable.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESQR).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), CS(*), DWORK(*), TAU(*)
C     .. Local Scalars ..
      INTEGER           I, K
      DOUBLE PRECISION  ALPHA, NU, TEMP
C     .. External Subroutines ..
      EXTERNAL          DLARF, DLARFG, DLARTG, DROT, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO  = 0
      IF ( M.LT.0 ) THEN
         INFO = -1
      ELSE IF ( N.LT.0 ) THEN
         INFO = -2
      ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF ( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
         DWORK(1) = DBLE( MAX( 1, N ) )
         INFO = -10
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04SU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      K = MIN( M,N )
      IF ( K.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      DO 10 I = 1, K
C
C        Generate elementary reflector H(i) to annihilate B(i+1:m,i).
C
         ALPHA = B(I,I)
         CALL DLARFG( M-I+1, ALPHA, B(MIN( I+1,M ),I), 1, NU )
C
C        Apply H(i) to A(i:m,i:n) and B(i:m,i+1:n) from the left.
C
         B(I,I) = ONE
         CALL DLARF( 'Left', M-I+1, N-I+1, B(I,I), 1, NU, A(I,I), LDA,
     $               DWORK )
         IF ( I.LT.N )
     $      CALL DLARF( 'Left', M-I+1, N-I, B(I,I), 1, NU, B(I,I+1),
     $                  LDB, DWORK )
         B(I,I) = NU
C
C        Generate symplectic Givens rotation G(i) to annihilate
C        B(i,i).
C
         TEMP = A(I,I)
         CALL DLARTG( TEMP, ALPHA, CS(2*I-1), CS(2*I), A(I,I) )
         IF ( I.LT.N ) THEN
C
C           Apply G(i) to [ A(i,i+1:n); B(i,i+1:n) ] from the left.
C
            CALL DROT( N-I, A(I,I+1), LDA, B(I,I+1), LDB, CS(2*I-1),
     $                 CS(2*I) )
         END IF
C
C        Generate elementary reflector F(i) to annihilate A(i+1:m,i).
C
         CALL DLARFG( M-I+1, A(I,I), A(MIN( I+1,M ),I), 1, TAU(I) )
         IF ( I.LT.N ) THEN
C
C           Apply F(i) to A(i:m,i+1:n) and B(i:m,i+1:n) from the
C           left.
C
            TEMP = A(I,I)
            A(I,I) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A(I,I), 1, TAU(I), A(I,I+1),
     $                  LDA, DWORK )
            CALL DLARF( 'Left', M-I+1, N-I, A(I,I), 1, TAU(I), B(I,I+1),
     $                  LDB, DWORK )
            A(I,I) = TEMP
         END IF
   10 CONTINUE
      DWORK(1) = DBLE(MAX( 1, N ))
      RETURN
C *** Last line of MB04SU ***
      END


c-----------------------------------------------------------------------
c
c  compute the metrics of the mapping from global to local
c  coordinates and the jacobian of the mapping (weighted by
c  the quadrature weight
c
c-----------------------------------------------------------------------
      subroutine e3metric(  xl,      shgl,     dxidx,
     &                      shg,     WdetJ)

      include "common.h"

      real*8     xl(npro,nenl,nsd),    shgl(npro,nsd,nshl),
     &           dxidx(npro,nsd,nsd),  shg(npro,nshl,nsd),
     &           WdetJ(npro)

      real*8     dxdxi(npro,nsd,nsd),  tmp(npro), det(npro), invdet(npro)

c
c.... compute the deformation gradient
c
      dxdxi = zero
c
       do n = 1, nenl
          dxdxi(:,1,1) = dxdxi(:,1,1) + xl(:,n,1) * shgl(:,1,n)
          dxdxi(:,1,2) = dxdxi(:,1,2) + xl(:,n,1) * shgl(:,2,n)
          dxdxi(:,1,3) = dxdxi(:,1,3) + xl(:,n,1) * shgl(:,3,n)
          dxdxi(:,2,1) = dxdxi(:,2,1) + xl(:,n,2) * shgl(:,1,n)
          dxdxi(:,2,2) = dxdxi(:,2,2) + xl(:,n,2) * shgl(:,2,n)
          dxdxi(:,2,3) = dxdxi(:,2,3) + xl(:,n,2) * shgl(:,3,n)
          dxdxi(:,3,1) = dxdxi(:,3,1) + xl(:,n,3) * shgl(:,1,n)
          dxdxi(:,3,2) = dxdxi(:,3,2) + xl(:,n,3) * shgl(:,2,n)
          dxdxi(:,3,3) = dxdxi(:,3,3) + xl(:,n,3) * shgl(:,3,n)
       enddo
c
      invdet = one /( dxdxi(:,1,1)*dxdxi(:,2,2)*dxdxi(:,3,3)
     &    + dxdxi(:,2,1)*dxdxi(:,3,2)*dxdxi(:,1,3)
     &    + dxdxi(:,3,1)*dxdxi(:,1,2)*dxdxi(:,2,3)
     &    - dxdxi(:,1,1)*dxdxi(:,3,2)*dxdxi(:,2,3)
     &    - dxdxi(:,3,1)*dxdxi(:,2,2)*dxdxi(:,1,3)
     &    - dxdxi(:,2,1)*dxdxi(:,1,2)*dxdxi(:,3,3))
c
c.... compute the inverse of deformation gradient
c
       dxidx(:,1,1) =   ( dxdxi(:,2,2) * dxdxi(:,3,3)
     &                - dxdxi(:,3,2) * dxdxi(:,2,3))
       dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                - dxdxi(:,1,2) * dxdxi(:,3,3)
       dxidx(:,1,3) =  dxdxi(:,1,2) * dxdxi(:,2,3)
     &                - dxdxi(:,1,3) * dxdxi(:,2,2)
       tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
       dxidx(:,1,1) = dxidx(:,1,1) * tmp
       dxidx(:,1,2) = dxidx(:,1,2) * tmp
       dxidx(:,1,3) = dxidx(:,1,3) * tmp
       dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
       dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
       dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
       dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
       dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
       dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c
       WdetJ = Qwt(lcsyst,intp) / tmp
c
c.... compute the global gradient of shape-functions
c
       do n = 1, nshl
          shg(:,n,1) = shgl(:,1,n) * dxidx(:,1,1) +
     &                 shgl(:,2,n) * dxidx(:,2,1) +
     &                 shgl(:,3,n) * dxidx(:,3,1)
          shg(:,n,2) = shgl(:,1,n) * dxidx(:,1,2) +
     &                 shgl(:,2,n) * dxidx(:,2,2) +
     &                 shgl(:,3,n) * dxidx(:,3,2)
          shg(:,n,3) = shgl(:,1,n) * dxidx(:,1,3) +
     &                 shgl(:,2,n) * dxidx(:,2,3) +
     &                 shgl(:,3,n) * dxidx(:,3,3)
       enddo

       return
       end


PROGRAM mlpn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       ========================================================
!       Purpose: This program computes the Legendre polynomials
!                Pn(x) and their derivatives Pn'(x) using
!                subroutine LPN
!       Input :  x --- Argument of Pn(x)
!                n --- Degree of Pn(x) ( n = 0,1,...)
!       Output:  PN(n) --- Pn(x)
!                PD(n) --- Pn'(x)
!       Example:    x = 0.5
!                  n          Pn(x)            Pn'(x)
!                ---------------------------------------
!                  0       1.00000000        .00000000
!                  1        .50000000       1.00000000
!                  2       -.12500000       1.50000000
!                  3       -.43750000        .37500000
!                  4       -.28906250      -1.56250000
!                  5        .08984375      -2.22656250
!       ========================================================

DOUBLE PRECISION :: pn,pd,x
DIMENSION pn(0:100),pd(0:100)
WRITE(*,*)'  Please enter Nmax and x '
!        READ(*,*)N,X
n=5
x=.5
WRITE(*,30)x
WRITE(*,*)
CALL lpn(n,x,pn,pd)
WRITE(*,*)'  n         Pn(x)           Pn''(X)'
WRITE(*,*)'---------------------------------------'
DO  k=0,n
  WRITE(*,20)k,pn(k),pd(k)
END DO
20      FORMAT(1X,i3,2E17.8)
30      FORMAT(3X,'x =',f5.1)
END PROGRAM mlpn

SUBROUTINE lpn(n,x,pn,pd)

!       ===============================================
!       Purpose: Compute Legendre polynomials Pn(x)
!                and their derivatives Pn'(x)
!       Input :  x --- Argument of Pn(x)
!                n --- Degree of Pn(x) ( n = 0,1,...)
!       Output:  PN(n) --- Pn(x)
!                PD(n) --- Pn'(x)
!       ===============================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: pn(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pd(0:n)
IMPLICIT DOUBLE PRECISION (p,x)

pn(0)=1.0D0
pn(1)=x
pd(0)=0.0D0
pd(1)=1.0D0
p0=1.0D0
p1=x
DO  k=2,n
  pf=(2.0D0*k-1.0D0)/k*x*p1-(k-1.0D0)/k*p0
  pn(k)=pf
  IF (DABS(x) == 1.0D0) THEN
    pd(k)=0.5D0*x**(k+1)*k*(k+1.0D0)
  ELSE
    pd(k)=k*(p1-x*pf)/(1.0D0-x*x)
  END IF
  p0=p1
  p1=pf
END DO
RETURN
END SUBROUTINE lpn


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine wfn_rho
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: tmp

  rho(:)=0d0

!  do ix = 0,Nx
!    tmp = 0d0
!    do iy = 0,Nx
!      tmp = tmp + wfn(ix,iy)**2
!    end do
!    rho(ix) = tmp
!  end do

  do ix = 0,Nx
    rho(ix) = sum(wfn(ix,:)**2)
  end do
  rho = rho*dr

  do ix = 0,NR
    rho_n(ix) = sum(wfn(:,ix)**2)
  end do
  rho_n = rho_n*dx

  return
end subroutine wfn_rho


program main

!*****************************************************************************80
!
!! Demonstrates the use of NELMIN on ROSENBROCK.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 February 2008
!
!  Author:
!
!    John Burkardt
!
  use mo_kind,   only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_nelmin, only: nelmin, nelminxy

  implicit none

  integer(i4), parameter :: n = 2

  integer(i4) :: icount
  integer(i4) :: ifault
  integer(i4) :: kcount
  integer(i4) :: konvge
  integer(i4) :: numres
  real(dp) :: reqmin
  INTERFACE
     FUNCTION rosenbrock(pp)
       USE mo_kind, ONLY: dp
       IMPLICIT NONE
       REAL(dp), DIMENSION(:), INTENT(IN) :: pp
       REAL(dp) :: rosenbrock
     END FUNCTION rosenbrock
  END INTERFACE
  INTERFACE
     FUNCTION rosenbrockxy(pp, xx, yy)
       USE mo_kind, ONLY: dp
       IMPLICIT NONE
       REAL(dp), DIMENSION(:), INTENT(IN) :: pp
       REAL(dp), DIMENSION(:), INTENT(IN) :: xx
       REAL(dp), DIMENSION(:), INTENT(IN) :: yy
       REAL(dp) :: rosenbrockxy
     END FUNCTION rosenbrockxy
  END INTERFACE
  real(dp) :: start(n)
  real(dp) :: step(n)
  real(dp) :: xmin(n)
  real(dp) :: ynewlo
  real(dp) :: xx(1)
  real(dp) :: yy(1)
  real(dp), allocatable :: history(:)
  integer(i4) :: i

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_nelmin.f90'

  isgood = .True.
  start(1:n) = (/ -1.2_dp, 1.0_dp /)
  reqmin = 1.0E-08_dp
  step(1:n) = (/ 1.0_dp, 1.0_dp /)
  konvge = 10
  kcount = 500
  xmin = nelmin( rosenbrock, start, funcmin=ynewlo, varmin=reqmin, step=step, &
       konvge=konvge, maxeval=kcount, neval=icount, numrestart=numres, ierror=ifault, history=history)
  do i=50, icount, 50
     write(*,'(A15,I3,A24,F12.7)') ' Minimum after ', i, ' function evaluations:  ', history(i)
  end do
  write(*,'(A16,I3,A23,F12.7)')    ' Minimum found (',icount,' iterations):            ',ynewlo
  write(*,*) 'Call 1: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  start(1:n) = (/ -1.2_dp, 1.0_dp /)
  reqmin = 1.0E-08_dp
  step(1:n) = (/ 1.0_dp, 1.0_dp /)
  konvge = 10
  kcount = 500
  xmin = nelmin(rosenbrock, start, varmin=reqmin, step=step, konvge=konvge, maxeval=kcount)
  write(*,*) 'Call 2: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  start(1:n) = (/ -1.2_dp, 1.0_dp /)
  reqmin = 1.0E-08_dp
  konvge = 10
  kcount = 500
  xmin = nelmin(rosenbrock, start, varmin=reqmin, konvge=konvge, maxeval=kcount)
  write(*,*) 'Call 3: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  ! Less precision with new starting points
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 99)

  start(1:n) = (/ -1.2_dp, 1.0_dp /)
  konvge = 10
  kcount = 500
  xmin = nelmin(rosenbrock, start, konvge=konvge, maxeval=kcount)
  write(*,*) 'Call 4: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  start(1:n) = (/ -1.2_dp, 1.0_dp /)
  xmin = nelmin(rosenbrock, start)
  write(*,*) 'Call 5: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  start(1:n) = (/ -12.0_dp, 10.0_dp /)
  xmin = nelmin(rosenbrock, start)
  write(*,*) 'Call 6: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  start(1:n) = (/ -12.0_dp, 10.0_dp /)
  xx(1) = 1.0_dp
  yy(1) = 100.0_dp
  xmin = nelminxy(rosenbrockxy, start, xx, yy, &
                neval=icount, history=history)
  do i=50, icount, 50
     write(*,'(A15,I3,A24,F12.7)') ' Minimum after ', i, ' function evaluations:  ', history(i)
  end do
  write(*,'(A16,I3,A23,F12.7)')           ' Minimum found (',icount,' iterations):            ',ynewlo
  write(*,*) 'Call 7: ', xmin, anint(100._dp*xmin)
  isgood = isgood .and. (nint(100._dp*xmin(1)) == 100)
  isgood = isgood .and. (nint(100._dp*xmin(2)) == 100)

  if (isgood) then
     write(*,*) 'mo_nelmin double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_nelmin double precision ', color('failed!', c_red)
  endif

end program main


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  This file contains code for approximating solutions of Jacobi's differential equations
!  using Taylor series expansions.
!
!  More explicitly, these routines evaluate the functions
!
!   ~(da,db)    (da,db)                    (da,db)
!   P   (t)  = P        ( cos(t) )  r(t)  C                                               (1)
!    dnu        dnu                        dnu
!
!  where  P_dnu^(da,db) is the Jacobi polynomial of the first kind,
!
!     r(t) = cos(t/2) ^(db+1/2) sin(t/2) ^(da+1/2)
!
!  and  C_dnu^(da,db) is a normalization constant.  The normalization constant is
!  chosen so that the basis of solutions of Jacobi's differential equation consisting
!  of (1) and the corresponding Q function has Wronskian 1.  The L^2 normalized
!  Jacobi polynomials are obtained by multiplying (1) by the constant
!
!       sqrt((2*dnu+da+db+1)/pi) .
!
!  Throughout, we let p denote the quantity  dnu +(da+db+1)/2.  The square of
!  the amplitude function is
!
!
!      (da, db)       ~(da,db)   ^2    ~(da,db)  ^ 2
!     M        (t) =  P      (t)    +  Q     (t)     .                                   (2)
!      dnu             dnu               dnu
!
!  The following subroutines should be regarded as publicly callable:
!
!    jacobi_taylor_p - evaluate (1) and its first two derivatives when dnu is of
!      modest size and t is close to 0
!
!    jacobi_taylor_q - evaluate the q function corresponding to (1) and its first
!      two derivatives when dnu is of modest size and t is close to 0
!
!    jacobi_taylor_m - evaluate the amplitude (2) and its fiest two derivatives
!      when dnu is of modest szie and t is cloe to 0
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine jacobi_taylor_p(dnu,da,db,t,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the function (1) at a point near 0 when dnu is of modest size.
!

data pi / 3.14159265358979323846264338327950288d0 /

rval  = cos(t/2)**(db+0.5d0) * sin(t/2) ** (da+0.5d0)
rder  = (Cos(t/2.)**(-0.5d0 + db)*(da - db + (1 + da + db)*Cos(t))*Sin(t/2.)**(-0.5d0 + da))/4d0
rder2 =         (Cos(t/2)**(-1.5d0 + db)*(-3 - 2*da + 3*da**2 - 2*db - 2*da*db + 3*db**2 + &
           4*(da**2 - db**2)*Cos(t) + (1 + da + db)**2*Cos(2*t))*Sin(t/2)**(-1.5d0 + da))/32.0d0

x = cos(t)

call jacobi_taylor_j1(dnu,da,db,x,fval,fder,fder2)

gval  = fval
gder  = -sin(t)*fder
gder2 = -cos(t)*fder + sin(t)**2*fder2

fval  = gval*rval
fder  = gder*rval + gval*rder
fder2 = gder2*rval + 2*gder*rder + gval*rder2

!
!  Now scale by the Wronskian
!

call jacobi_gammaratio1(dnu+1,da,dd1)
call jacobi_gammaratio1(dnu+db+1,da,dd2)
dconst = dd1/dd2 * 1/pi
dconst = 1/sqrt(dconst)

val  = fval*dconst
der  = fder*dconst
der2 = fder2*dconst

end subroutine

subroutine jacobi_taylor_q(dnu,da,db,t,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the scaled, Wronskain normalized Jacobi function of the
!  second kind at a point t near 0.
!

data pi / 3.14159265358979323846264338327950288d0 /

rval  = cos(t/2)**(db+0.5d0) * sin(t/2) ** (da+0.5d0)
rder  = (Cos(t/2.)**(-0.5d0 + db)*(da - db + (1 + da + db)*Cos(t))*Sin(t/2.)**(-0.5d0 + da))/4d0
rder2 =         (Cos(t/2)**(-1.5d0 + db)*(-3 - 2*da + 3*da**2 - 2*db - 2*da*db + 3*db**2 + &
           4*(da**2 - db**2)*Cos(t) + (1 + da + db)**2*Cos(2*t))*Sin(t/2)**(-1.5d0 + da))/32.0d0

x = cos(t)

call jacobi_taylor_j4(dnu,da,db,x,fval,fder,fder2)

gval  = fval
gder  = -sin(t)*fder
gder2 = -cos(t)*fder + sin(t)**2*fder2

fval  = gval*rval
fder  = gder*rval + gval*rder
fder2 = gder2*rval + 2*gder*rder + gval*rder2

!
!  Now scale by the Wronskian
!

call jacobi_gammaratio1(dnu+1,da,dd1)
call jacobi_gammaratio1(dnu+db+1,da,dd2)
dconst = dd1/dd2 * 1/pi
dconst = 1/sqrt(dconst)

val  = fval*dconst
der  = fder*dconst
der2 = fder2*dconst

end subroutine

subroutine jacobi_taylor_j1(dnu,da,db,x,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the Jacobi function J1 at a point  x  close to 1.
!

data pi / 3.14159265358979323846264338327950288d0 /

!
!  Evaluate the hypergeometric series
!

maxterms = 100
eps0     = 1.0d-30
dterm    = 1.0d0
xx       = (x-1)/(x+1)

val0      = 0
der0      = 0
der20     = 0

do k=1,maxterms

val0   = val0  + dterm
der0   = der0  + dterm*2*(k-1)/(x**2-1)
der20  = der20 + dterm*4*(k-1)*(k-1-x)/(x**2-1)**2

dterm = dterm * xx/k
dterm = dterm * (k-dnu-db-1)*(k-dnu-1)/(k+da)

!if (abs(dterm) .lt. eps0*abs(val0)) exit

end do

!
!  Mulitply by ((1+x)/2)**n
!

val  = val0  *((1+x)/2)**dnu
der  = der0 * ((1+x)/2)**dnu + val0 * 2.0d0**(-dnu)*dnu*(1+x)**(dnu-1)
der2 = ((1 + x)**(-2 + dnu)*((-1 + dnu)*dnu*val0 + &
        (1 + x)*(2*der0*dnu + der20*(1 + x))))/2**dnu

!
!  Scale by the appropriate  constant
!

call jacobi_gammaratio1(dnu+1,da,dd1)
dconst = dd1 / gamma(1+da)

val  = val * dconst
der  = der * dconst
der2 = der2 * dconst

end subroutine

subroutine jacobi_taylor_j2(dnu,da,db,x,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the Jacobi function J2 at a point close to 1.
!

data pi / 3.14159265358979323846264338327950288d0 /

maxterms = 100
eps0     = 1.0d-30

!
!  Evaluate the hypergeometric series 2F1(-n-a,-n-a-b,1-a,(x-1)/(x+1))
!

dterm    = 1.0d0
xx       = (x-1)/(x+1)
val0     = 0
der0     = 0
der20    = 0
do k=1,maxterms
val0   = val0  + dterm
der0   = der0  + dterm*2*(k-1)/(x**2-1)
der20  = der20 + dterm*4*(k-1)*(k-1-x)/(x**2-1)**2

dterm = dterm * xx/k
dterm = dterm * (-1-da+k-dnu)*(-1-da-db+k-dnu)/(k-da)
if (abs(dterm) .lt. eps0*abs(val0)) exit
end do

!
!  Multiply by ((1+x)/2)^n
!

val2  = val0  *((1+x)/2)**dnu
der2  = der0 * ((1+x)/2)**dnu + val0 * 2.0d0**(-dnu)*dnu*(1+x)**(dnu-1)
der22 = ((1 + x)**(-2 + dnu)*((-1 + dnu)*dnu*val0 + &
        (1 + x)*(2*der0*dnu + der20*(1 + x))))/2**dnu

!
!  Multiply by ((1+x)/(1-x))^da
!

val3  = val2 * ((1+x)/(1-x))**da
der3  = (((1 + x)/(1 - x))**da*(-2*da*val2 + der2*(-1 + x**2)))/(-1 + x**2)
der32 =         (((1 + x)/(1 - x))**da*(4*da*val2*(da + x) +  &
           (-1 + x**2)*(-4*da*der2 + der22*(-1 + x**2))))/(-1 + x**2)**2

!
!  Scale by the appropriate  constant
!

call jacobi_gammaratio1(dnu+db+1,da,dd1)
dconst = 1/dd1 *1/ gamma(1-da)

val  = val3  * dconst
der  = der3  * dconst
der2 = der32 * dconst

end subroutine

recursive subroutine jacobi_taylor_j4(dnu,da,db,x,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the appropriate function of the second kind at the point x.
!

double precision :: whts(16),vals(16),ders(16),der2s(16),xs(16)

data pi / 3.14159265358979323846264338327950288d0 /

data ncheb / 16 /

data xs / -0.100000000000000000000000000000000000D+01, &
          -0.978147600733805637928566747869599532D+00, &
          -0.913545457642600895502127571985317191D+00, &
          -0.809016994374947424102293417182819080D+00, &
          -0.669130606358858213826273330686780548D+00, &
          -0.500000000000000000000000000000000096D+00, &
          -0.309016994374947424102293417182818984D+00, &
          -0.104528463267653471399834154802498051D+00, &
           0.104528463267653471399834154802498147D+00, &
           0.309016994374947424102293417182819032D+00, &
           0.499999999999999999999999999999999952D+00, &
           0.669130606358858213826273330686780452D+00, &
           0.809016994374947424102293417182819080D+00, &
           0.913545457642600895502127571985317191D+00, &
           0.978147600733805637928566747869599532D+00, &
           0.100000000000000000000000000000000000D+01  /

! data xs / -0.1000000000000000D+01, &
!           -0.9781476007338056D+00, &
!           -0.9135454576426008D+00, &
!           -0.8090169943749473D+00, &
!           -0.6691306063588579D+00, &
!           -0.4999999999999998D+00, &
!           -0.3090169943749473D+00, &
!           -0.1045284632676533D+00, &
!            0.1045284632676537D+00, &
!            0.3090169943749475D+00, &
!            0.5000000000000001D+00, &
!            0.6691306063588582D+00, &
!            0.8090169943749475D+00, &
!            0.9135454576426009D+00, &
!            0.9781476007338057D+00, &
!            0.1000000000000000D+01  /

!
!  When da of small magnitude, use interpolation to evaluate j4
!

if (abs(da) .lt. 0.01d0) then
eps0  = epsilon(0.0d0)
a     = -0.097d0
b     =  0.097d0
xx    = (2*da - (b+a) ) /(b-a)

do i=1,ncheb
alpha = xs(i)*(b-a)/2+ (b+a)/2
call jacobi_taylor_j4(dnu,alpha,db,x,vals(i),ders(i),der2s(i))
end do

!
!  do the interpolation
!

dsign = 1.0d0
do i=1,ncheb
diff    = xx - xs(i)
if (abs(diff) .lt. eps0) then
val  = vals(i)
der  = ders(i)
der2 = der2s(i)
return
endif

whts(i) = dsign/diff
dsign   = -dsign
end do
whts(1)     = whts(1)/2
whts(ncheb) = whts(ncheb)/2

dd = sum(whts)
val  = sum(vals*whts)/dd
der  = sum(ders*whts)/dd
der2 = sum(der2s*whts)/dd

else

dd1 = gamma(1-da)/(gamma(0.5d0+da)*gamma(0.5d0-da))
dd2 = gamma(1-da)/pi

call jacobi_taylor_j1(dnu,da,db,x,val1,der11,der12)
call jacobi_taylor_j2(dnu,da,db,x,val2,der21,der22)

val  = dd1*val1-dd2*val2
der  = dd1*der11-dd2*der21
der2 = dd1*der12-dd2*der22

val  = val * gamma(da)
der  = der * gamma(da)
der2 = der2* gamma(da)

endif

end subroutine

subroutine jacobi_taylor_m(dnu,da,db,t,val,der,der2)
implicit double precision (a-h,o-z)

!
!  Evaluate the scaled, Wronskain normalized Jacobi function of the
!  second kind at a point t near 0.
!

data pi / 3.14159265358979323846264338327950288d0 /

call jacobi_taylor_q(dnu,da,db,t,qval,qder,qder2)
call jacobi_taylor_p(dnu,da,db,t,pval,pder,pder2)

val  = pval**2+qval**2
der  = 2*pval*pder + 2*qval*qder
der2 = 2*pder*pder + 2*pval*pder2 + 2*qder*qder+2*qval*qder2

end subroutine