module local_routines
    !! Setup for plane wave propagation problem with nesting
    use global_mod, only: dp, ip, charlen, wall_elevation, gravity, pi
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use linear_interpolator_mod, only: linear_interpolator_type

    implicit none

    contains

    ! Main setup routine
    subroutine set_initial_conditions(domain)
        class(domain_type), target, intent(inout):: domain

        integer(ip):: i, j
        character(len=charlen):: initial_stage
        real(dp), allocatable:: x(:)
        real(dp) :: wall, stage0, x0, d0, a0, k0
        real(dp) :: gauge_xy(3,3)

        wall = 50.0_dp
        allocate(x(domain%nx(1)))
        x = domain%x

        ! Define the initial wave
        x0 = 0.0_dp
        d0 = -100.0_dp
        a0 = 0.001_dp
        k0 = 1.0_dp / (250.0_dp * 38.0_dp)

        do j = 1, domain%nx(2)
            do i = 1, domain%nx(1)
               !stage0 = a0 * cos(2*pi*(x(i) - x0)*k0) * exp(-((x(i) - x0) / 30000.0_dp)**2)
               if(abs(x(i) - x0)*k0 < 3.25_dp) then
                   stage0 = a0 * cos(2*pi*(x(i) - x0)*k0)
               else
                   stage0 = 0.0_dp
               end if
               domain%U(i,j,STG) = stage0
               domain%U(i,j,ELV) = d0 !+ 20 * a0 * (mod(i, 3) - 0.5_dp) ! Interesting to see what a depth perturbation does -- not much.
               domain%U(i,j,UH) = (-d0) * sqrt(gravity/(-d0))*stage0
               domain%U(i,j,VH) = 0.0_dp
            end do
        end do

        ! Wall boundaries
        !domain%U(1,:,ELV) = wall
        !domain%U(:,1,ELV) = wall
        !domain%U(domain%nx(1),:,ELV) = wall
        !domain%U(:,domain%nx(2),ELV) = wall

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV) + 1.0e-07_dp)

        deallocate(x)

        print*, 'Elevation range: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

        if(domain%timestepping_method /= 'linear') then
            domain%manning_squared = 0.0_dp
        end if

        !@ Gauges
        !gauge_xy(1:3, 1) = [4.521, 1.196, 5.0]
        !gauge_xy(1:3, 2) = [4.521, 1.696, 7.0]
        !gauge_xy(1:3, 3) = [4.521, 2.196, 9.0]
        !call domain%setup_point_gauges(xy_coords = gauge_xy(1:2,:), gauge_ids=gauge_xy(3,:))

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program nesting_reflection
    !! Plane wave propagation problem with nesting. This problem can highlight weaknesses
    !! in structured grid finite-volume methods with TVD limiters, which tend to dissipate the wave too
    !! quickly. That is unrelated to the use of nesting - rather it's due to limiter clipping.
    !! That issue can be solved using non-TVD limiting, or no limiting. Alternatively, the leapfrog schemes
    !! are better suited to this kind of problem.

    use global_mod, only: ip, dp, minimum_allowed_depth, charlen
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type, setup_multidomain, test_multidomain_mod
    use boundary_mod, only: boundary_stage_transmissive_normal_momentum, flather_boundary
    use local_routines
    use timer_mod
    use logging_mod, only: log_output_unit
    implicit none

    ! Useful misc variables
    integer(ip):: j, i, i0, j0, centoff, nd, lg
    real(dp):: last_write_time, gx(4), gy(4)

    ! Type holding all domains
    type(multidomain_type) :: md

    type(timer_type) :: program_timer

    real(dp), parameter :: mesh_refine = 1.0_dp ! Increase/decrease resolution by this amount

    real(dp) ::  global_dt = 3.985_dp / mesh_refine

    ! Approx timestep between outputs
    real(dp) :: approximate_writeout_frequency = 5.00_dp
    real(dp) :: final_time = 3600.0_dp

    integer(ip), parameter :: inner_mesh_refine = 3_ip

    ! Length/width
    real(dp), parameter :: global_lw(2) = [100000.0_dp , 5000.0_dp/mesh_refine]
    ! Lower-left corner coordinate
    real(dp), parameter :: global_ll(2) = -global_lw/2.0_dp
    ! Resolution
    real(dp), parameter :: res_d1 = 250.0_dp/mesh_refine
    real(dp), parameter :: res_d2 = 250.0_dp/mesh_refine * 1.0_dp/inner_mesh_refine

    real(dp) :: lower_left(2), upper_right(2)

    ! Standard test version
    ! Run the '2 domain' version
    integer(ip), parameter :: n_domains = 2_ip
    ! Allow overshoots to prevent excess dissipation
    real(dp), parameter :: nonlinear_theta = 4.0_dp
    character(len=charlen) :: compute_fluxes_inner_method = "DE1_low_fr_diffusion" ! "DE1" -- distinguishes 'rk2' and 'midpoint'

    !@ Alternate version -- shows the dissipation of the regular 'DE1' type approach.
    !@ Similar behaviour is seen in 1D "Basilisk", which employs a very similar algorithm.
    !@ Note the dissipation also occurs with >1 domain (but n_domains=1 for simplicity here)
    !integer(ip), parameter :: n_domains = 1_ip
    !real(dp), parameter :: nonlinear_theta = 1.3_dp
    !character(len=charlen), parameter :: compute_fluxes_inner_method = 'DE1' !'DE1_low_fr_diffusion'

    character(len=charlen) :: ts_method

    call program_timer%timer_start('setup')

    call get_command_argument(1, ts_method)

    ! Periodic BC
    md%periodic_xs = [global_ll(1) , global_ll(1) + global_lw(1)]
    md%periodic_ys = [global_ll(2) , global_ll(2) + global_lw(2)]

    !
    ! Setup basic metadata
    !
    if(n_domains == 4) then
        ! Version with 4 domains
        nd = 4
        allocate(md%domains(nd))

        ! Left domain
        md%domains(1)%lower_left = global_ll
        md%domains(1)%lw = [global_lw(1)/3.0_dp, global_lw(2)]
        md%domains(1)%nx = nint(md%domains(1)%lw/res_d1)
        md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
        md%domains(1)%timestepping_refinement_factor = 1_ip
        md%domains(1)%dx_refinement_factor = 1.0_dp
        md%domains(1)%timestepping_method = ts_method

        ! Main domain
        md%domains(2)%lower_left = [global_ll(1) + 1.0_dp/3.0_dp * global_lw(1), global_ll(2)]
        md%domains(2)%lw = [global_lw(1)/3.0_dp, global_lw(2)/2.0_dp]
        md%domains(2)%nx = nint(md%domains(2)%lw/res_d2)
        md%domains(2)%dx = md%domains(2)%lw/md%domains(2)%nx
        md%domains(2)%timestepping_refinement_factor = 1_ip
        md%domains(2)%dx_refinement_factor = nint(res_d1/res_d2)
        md%domains(2)%timestepping_method = ts_method

        ! Right domain
        md%domains(3)%lower_left = [global_ll(1) + global_lw(1)*2.0/3.0, global_ll(2)]
        md%domains(3)%lw = [global_lw(1)/3.0_dp, global_lw(2)]
        md%domains(3)%nx = nint(md%domains(1)%lw/res_d1)
        md%domains(3)%dx = md%domains(1)%lw/md%domains(1)%nx
        md%domains(3)%timestepping_refinement_factor = 1_ip
        md%domains(3)%dx_refinement_factor = 1.0_dp
        md%domains(3)%timestepping_method = ts_method

        ! Main domain
        md%domains(4)%lower_left = [global_ll(1) + 1.0_dp/3.0_dp * global_lw(1), 0.0_dp]
        md%domains(4)%lw = [global_lw(1)/3.0_dp, global_lw(2)/2.0_dp]
        md%domains(4)%nx = nint(md%domains(2)%lw/res_d2)
        md%domains(4)%dx = md%domains(2)%lw/md%domains(2)%nx
        md%domains(4)%timestepping_refinement_factor = 1_ip
        md%domains(4)%dx_refinement_factor = nint(res_d1/res_d2)
        md%domains(4)%timestepping_method = ts_method

        ! Allow overshoots to prevent excess dissipation
        md%domains(1)%theta = nonlinear_theta
        md%domains(2)%theta = nonlinear_theta
        md%domains(3)%theta = nonlinear_theta
        md%domains(4)%theta = nonlinear_theta

    else if(n_domains == 2) then
        ! Version with 2 domains.
        nd = 2
        allocate(md%domains(nd))

        ! Large domain
        md%domains(1)%lower_left = global_ll
        md%domains(1)%lw = [global_lw(1), global_lw(2)]
        md%domains(1)%nx = nint(md%domains(1)%lw/res_d1)
        md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
        md%domains(1)%timestepping_refinement_factor = 1_ip
        md%domains(1)%dx_refinement_factor = 1.0_dp
        md%domains(1)%timestepping_method = ts_method

        ! Inner domain
        lower_left  = [global_ll(1) + 1.0_dp/3.0_dp * global_lw(1), global_ll(2)]
        upper_right = [global_ll(1) + 2.0_dp/3.0_dp * global_lw(1), global_ll(2) + global_lw(2)]
        call md%domains(2)%match_geometry_to_parent(&
            parent_domain = md%domains(1), &
            lower_left = lower_left, &
            upper_right = upper_right, &
            dx_refinement_factor = inner_mesh_refine, &
            timestepping_refinement_factor = inner_mesh_refine)
        md%domains(2)%timestepping_method = ts_method

        ! Allow overshoots to prevent excess dissipation
        md%domains(1)%theta = nonlinear_theta
        md%domains(2)%theta = nonlinear_theta

    else if(n_domains == 1) then
        ! Single domain
        nd = 1
        allocate(md%domains(nd))

        md%domains(1)%lower_left = global_ll
        md%domains(1)%lw = [global_lw(1), global_lw(2)]
        md%domains(1)%nx = nint(md%domains(1)%lw/res_d1)
        md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
        md%domains(1)%timestepping_refinement_factor = 1_ip
        md%domains(1)%dx_refinement_factor = 1.0_dp
        md%domains(1)%timestepping_method = ts_method

        ! Allow overshoots to prevent excess dissipation
        md%domains(1)%theta = nonlinear_theta

    end if

    ! Experiment with non-default compute fluxes approaches
    do j = 1, size(md%domains)
        md%domains(j)%compute_fluxes_inner_method = compute_fluxes_inner_method
    end do

    ! Allocate domains and prepare comms
    call md%setup()

    ! Initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions(md%domains(j))
    end do
    call md%make_initial_conditions_consistent()

    ! NOTE: For stability in 'null' regions, we set them to 'high land' that
    ! should be inactive.
    call md%set_null_regions_to_dry()

    print*, 'End setup'

    ! Print the gravity-wave CFL limit, to guide timestepping
    do j = 1, size(md%domains)
        print*, 'domain: ', j, 'ts: ', &
            md%domains(j)%stationary_timestep_max()
    end do

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    call program_timer%timer_end('setup')
    call program_timer%timer_start('evolve')

    ! Trick to get the code to write out at the first timestep
    last_write_time = -approximate_writeout_frequency
    ! Evolve the code
    do while (.true.)

        ! IO
        call program_timer%timer_start('IO')
        call md%write_outputs_and_print_statistics(approximate_writeout_frequency=approximate_writeout_frequency)
        call program_timer%timer_end('IO')

        if (md%domains(1)%time > final_time) exit
        call md%evolve_one_step(global_dt)

    end do

    call program_timer%timer_end('evolve')
    call md%finalise_and_print_timers

    print*, ''
    call program_timer%print(output_file_unit=log_output_unit)

end program


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err
      integer qdata,j,w,u,v
      integer qf_setup,qf_mass
      integer q,i
      parameter(q=8)
      real*8 jj(q)
      real*8 ww(q)
      real*8 uu(q)
      real*8 vv(q)
      real*8 vvv(q)
      real*8 x
      character arg*32
      integer*8 joffset,uoffset,voffset,woffset

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedqfunctioncreateinteriorbyname(ceed,'Mass1DBuild',qf_setup,err)
      call ceedqfunctioncreateinteriorbyname(ceed,'MassApply',qf_mass,err)

      do i=0,q-1
        jj(i+1)=1
        x=2.0*i/(q-1)-1
        ww(i+1)=1-x*x
        uu(i+1)=2+3*x+5*x*x
        vvv(i+1)=ww(i+1)*uu(i+1)
      enddo

      call ceedvectorcreate(ceed,q,j,err)
      joffset=0
      call ceedvectorsetarray(j,ceed_mem_host,ceed_use_pointer,jj,joffset,err)
      call ceedvectorcreate(ceed,q,w,err)
      woffset=0
      call ceedvectorsetarray(w,ceed_mem_host,ceed_use_pointer,ww,woffset,err)
      call ceedvectorcreate(ceed,q,u,err)
      uoffset=0
      call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err)
      call ceedvectorcreate(ceed,q,v,err)
      call ceedvectorsetvalue(v,0.d0,err)
      call ceedvectorcreate(ceed,q,qdata,err)
      call ceedvectorsetvalue(qdata,0.d0,err)

      call ceedqfunctionapply(qf_setup,q,j,w,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &qdata,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,err)

      call ceedqfunctionapply(qf_mass,q,u,qdata,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
      do i=1,q
        if (abs(vv(i+voffset)-vvv(i)) > 1.0D-14) then
! LCOV_EXCL_START
          write(*,*) 'v(i)=',vv(i+voffset),', vv(i)=',vvv(i)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(v,vv,voffset,err)

      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(w,err)
      call ceedvectordestroy(qdata,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


c     DRDBESJN
c>> 1999-01-07 DRDBESJN Krogh Added external statement.
c>> 1996-05-31 DRDBESJN Krogh  Changes to use M77CON
c>> 1994-09-01 DRDBESJN WVS Moved formats to top for C conversion
c>> 1992-04-29 DRDBESJN CAO Replaced '1' in format.
c>> 1987-12-09 DRDBESJN Lawson  Initial Code.
c--D replaces "?": DR?BESJN, ?BESJN, ?BESYN
c     DEMONSTRATION PROGRAM FOR BESSEL function.
c
      double precision X(3),ALPHA(3),BJ(2),BY(2),Z,PI2
      external DBESJN, DBESYN
      integer I, N
c
      data X / 0.5D0, 1.5D0, 3.2D0 /
      data ALPHA / 1.5D0, 3.0D0, 7.8D0 /
      data PI2 / 1.5707963267948966192313216D0 /
c
  100 format(' ',4X,A1,9X,A2,11X,A7,11X,A7,12X,A1)
  200 format(' ',26X,A9,9X,A9/' ')
  300 format(' ',F6.2,5X,F6.2,4X,G15.8,5X,G15.8,G13.2)
  400 format(' ',21X,2(G15.8,5X)/' ')
c
      print 100,'X','NU','J(NU,X)','Y(NU,X)','Z'
      print 200,'J(NU+1,X)','Y(NU+1,X)'
c
      do 500 I = 1,3
        N = 2
        call DBESJN(X(I),ALPHA(I),N,BJ)
        call DBESYN(X(I),ALPHA(I),N,BY)
        Z = PI2 * X(I) * (BJ(2)*BY(1) - BJ(1)*BY(2)) - 1.D0
        print 300,X(I),ALPHA(I),BJ(1),BY(1),Z
        print 400,BJ(2),BY(2)
  500 continue
c
      end


!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine dylmr2 (nylm, ngy, g, gg, dylm, ipol)
  !-----------------------------------------------------------------------
  !
  !     compute \partial Y_lm(G) \over \partial (G)_ipol
  !     using simple numerical derivation (SdG)
  !     The spherical harmonics are calculated in ylmr2
  !
  USE kinds, ONLY : DP
  implicit none
  !
  !    here the I/O variables
  !
  integer :: nylm, ngy, ipol
  ! input: number of spherical harmonics
  ! input: the number of g vectors to compute
  ! input: desired polarization
  real(DP) :: g (3, ngy), gg (ngy), dylm (ngy, nylm)
  ! input: the coordinates of g vectors
  ! input: the moduli of g vectors
  ! output: the spherical harmonics derivatives
  !
  !    and here the local variables
  !
  integer :: ig, lm
  ! counter on g vectors
  ! counter on l,m component

  real(DP), parameter :: delta = 1.d-6
  real(DP), allocatable :: dg (:), dgi (:), gx (:,:), ggx (:), ylmaux (:,:)
  ! dg is the finite increment for numerical derivation:
  ! dg = delta |G| = delta * sqrt(gg)
  ! dgi= 1 /(delta * sqrt(gg))
  ! gx = g +/- dg
  ! ggx = gx^2
  !
  allocate ( gx(3,ngy), ggx(ngy), dg(ngy), dgi(ngy), ylmaux(ngy,nylm) )

!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig)
  do ig = 1, ngy
     dg (ig) = delta * sqrt (gg (ig) )
     if (gg (ig) .gt. 1.d-9) then
        dgi (ig) = 1.d0 / dg (ig)
     else
        dgi (ig) = 0.d0
     endif
  enddo
!$OMP END PARALLEL DO

  call dcopy (3 * ngy, g, 1, gx, 1)

!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig)
  do ig = 1, ngy
     gx (ipol, ig) = g (ipol, ig) + dg (ig)
     ggx (ig) = gx (1, ig) * gx (1, ig) + &
                gx (2, ig) * gx (2, ig) + &
                gx (3, ig) * gx (3, ig)
  enddo
!$OMP END PARALLEL DO

  call ylmr2 (nylm, ngy, gx, ggx, dylm)

!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig)
  do ig = 1, ngy
     gx (ipol, ig) = g (ipol, ig) - dg (ig)
     ggx (ig) = gx (1, ig) * gx (1, ig) + &
                gx (2, ig) * gx (2, ig) + &
                gx (3, ig) * gx (3, ig)
  enddo
!$OMP END PARALLEL DO

  call ylmr2 (nylm, ngy, gx, ggx, ylmaux)

  call daxpy (ngy * nylm, - 1.d0, ylmaux, 1, dylm, 1)

  do lm = 1, nylm
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ig)
     do ig = 1, ngy
        dylm (ig, lm) = dylm (ig, lm) * 0.5d0 * dgi (ig)
     enddo
!$OMP END PARALLEL DO
  enddo

  deallocate ( gx, ggx, dg, dgi, ylmaux )

  return
end subroutine dylmr2


*DECK DPLINT
      SUBROUTINE DPLINT (N, X, Y, C)
C***BEGIN PROLOGUE  DPLINT
C***PURPOSE  Produce the polynomial which interpolates a set of discrete
C            data points.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      DOUBLE PRECISION (POLINT-S, DPLINT-D)
C***KEYWORDS  POLYNOMIAL INTERPOLATION
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C        Subroutine DPLINT is designed to produce the polynomial which
C     interpolates the data  (X(I),Y(I)), I=1,...,N.  DPLINT sets up
C     information in the array C which can be used by subroutine DPOLVL
C     to evaluate the polynomial and its derivatives and by subroutine
C     DPOLCF to produce the coefficients.
C
C     Formal Parameters
C     *** All TYPE REAL variables are DOUBLE PRECISION ***
C     N  - the number of data points  (N .GE. 1)
C     X  - the array of abscissas (all of which must be distinct)
C     Y  - the array of ordinates
C     C  - an array of information used by subroutines
C     *******  Dimensioning Information  *******
C     Arrays X,Y, and C must be dimensioned at least N in the calling
C     program.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPLINT
      INTEGER I,K,KM1,N
      DOUBLE PRECISION DIF,C(*),X(*),Y(*)
C***FIRST EXECUTABLE STATEMENT  DPLINT
      IF (N .LE. 0) GO TO 91
      C(1)=Y(1)
      IF(N .EQ. 1) RETURN
      DO 10010 K=2,N
      C(K)=Y(K)
      KM1=K-1
      DO 10010 I=1,KM1
C     CHECK FOR DISTINCT X VALUES
      DIF = X(I)-X(K)
      IF (DIF .EQ. 0.0) GO TO 92
      C(K) = (C(I)-C(K))/DIF
10010 CONTINUE
      RETURN
   91 CALL XERMSG ('SLATEC', 'DPLINT', 'N IS ZERO OR NEGATIVE.', 2, 1)
      RETURN
   92 CALL XERMSG ('SLATEC', 'DPLINT',
     +   'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1)
      RETURN
      END


subroutine cTuberiaSimple()
    use messages
        implicit none
        !Variables independietes
        real :: d,ks,H,E,Sigma_km,p,nu,zy,l

        !Variables dependietes
        real :: hf1,ksd,vi, hfi_1, Q
        integer :: i
        character :: option !es la opción par cambiar los ejemplos (y/n)

        !Constantes
        real, parameter :: pi = 4 * atan (1.0), g = 9.81

        print *, char(10),"         <<<<1: Comprobacion de disenio de tuberia simple>>>>",char(10)

        !Paso 1: Etapa de lectura

        d=0.293; ks=1.5e-6; H=43.5; E=1e-8; Sigma_km=11.8; p=998.2; nu=1.007e-6; zy=0; l=730 !DEBUG
        print"('Por defecto, se cargaran datos del ejemplo 2.1'/)"
        do i = 1,10

        print datosEjercicio1, l,H,d,ks,Sigma_km,p,nu,zy,E

        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(9) como un vector con el sgte formato: "
            print*,"l, H, d, ks, Sigma_Km, p, nu, z, E"
            read(*,*)l, H, d, ks, Sigma_Km, p, nu, zy, E  !DEBUG
            print*, char(10)
        end if
        end do

        !Paso 2: Primera suposicion Suponer hf1
        hf1 = H-zy

        !Paso 3: Segunda operacion Calcular Ksd
        ksd = ks/d

        print"(a6,a18,a12,a15,a18)", "H", "ks/d", "hf1", "v", "hfi_1"

        !Paso 4: Inicializar la iteracion
        do i = 1,100

        !Paso 4: 1ra subrutina Calcular vi ec 2.3

        vi = cal_vi(ks,nu,g,d,hf1)

        !Paso 5: 2da subrutina calcular hfi_1
        hfi_1 = cal_hfi_1(H,zy,Sigma_km,vi,g)
        !print *, "hfi_1 = ", hfi_1, char(10)

        !Paso 6: Condicion ERROR

        print*, H,ksd,hf1,vi,hfi_1

        if (abs(hf1 - hfi_1)<E) then
            exit
        else
            hf1 = hfi_1
        end if
        end do

        !Paso 7: Calcular Q
        Q = vi * pi/4 * d ** 2
        print *, char(10)
        print *, "Q = ", Q, "m3/s"
        print *, "Q = ", Q*1000, "l/s"
        print *, char(10)
        Print *, "FIN"
        read(*,*)

    contains

    function cal_vi(ks,nu,g,d,hf1)
        implicit none
        real :: cal_vi,ks,nu,g,d,hf1

        cal_vi = (2.51 * nu * sqrt(l)) / (d * sqrt(2 * g * d * hf1))
        cal_vi = (ks / (3.7 * d)) + cal_vi
        cal_vi = (-2 * sqrt(2 * g * d * hf1) / sqrt(l)) * log10(cal_vi)

    end function cal_vi

    function cal_hfi_1(H,zy,Sigma_km,vi,g)
        implicit none
        real ::cal_hfi_1,H,zy,Sigma_km,vi,g
        cal_hfi_1 = H - zy - Sigma_km * ((vi ** 2) / (2 * g))
    end function cal_hfi_1

    end subroutine cTuberiaSimple


!> @cite scipy
!>

REAL(kind = REAL64), PARAMETER                                                  :: const_1sigma = 6.826894921370859e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_2sigma = 9.544997361036416e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_3sigma = 9.973002039367398e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_4sigma = 9.999366575163338e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_5sigma = 9.999994266968563e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_6sigma = 9.999999980268247e-01_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_amu = 1.660539040000000e-27_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_c = 2.997924580000000e+08_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_e = 1.602176620800000e-19_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_eps0 = 8.854187817620389e-12_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_g = 9.806649999999999e+00_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_h = 6.626070040000000e-34_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_kb = 1.380648520000000e-23_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_me = 9.109383560000000e-31_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_mn = 1.674927471000000e-27_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_mp = 1.672621898000000e-27_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_mu0 = 1.256637061435917e-06_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_na = 6.022140857000000e+23_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_pi = 3.141592653589793e+00_REAL64
REAL(kind = REAL64), PARAMETER                                                  :: const_sig = 5.670367000000000e-08_REAL64


        subroutine radarhist(NX_L,NY_L,NZ_L,dbz_3d
     1                      ,ilow,ihigh,jlow,jhigh
     1                      ,lmask_3d,lun_out)

        real dbz_3d(NX_L,NY_L,NZ_L)
        logical lmask_3d(NX_L,NY_L,NZ_L)

        parameter (nbins=10)

        integer ihist(nbins)
        integer ihist_2d(NZ_L,nbins)

!       Initialize histograms
        ihist = 0
        ihist_2d = 0

!       Define area of interest
        klow = 1
        khigh = NZ_L

        hist_low = 0.
        hist_intvl = 10.

!       Note bin #1 is from 0-10 dbz and so on at 10dbz increments
        do k = klow,khigh
        do i = ilow,ihigh
        do j = jlow,jhigh
            if(lmask_3d(i,j,k))then
                ibin = int( (dbz_3d(i,j,k)-hist_low) / hist_intvl ) + 1
                if(ibin .ge. 1 .and. ibin .le. 10)then
                   ihist(ibin) = ihist(ibin) + 1
                   ihist_2d(k,ibin) = ihist_2d(k,ibin) + 1
                endif
            endif
        enddo ! j
        enddo ! i
        enddo ! k

!       Write full volume histogram
        do ibin = 1,nbins
            v1 = hist_low + hist_intvl * float(ibin-1)
            v2 = hist_low + hist_intvl * float(ibin  )
            write(lun_out,1)ibin,v1,v2,ihist(ibin)
 1          format(' bin/range/count = ',i10,f6.1,f6.1,i10)
        enddo ! ibin

!       Write histogram by level
        write(lun_out,*)
        write(lun_out,*)' Histogram by level'
        write(lun_out,*)'  Level    bin1      bin2      bin3      bin4'
     1                 ,'      bin5      bin6      bin7      bin8  '
     1                 ,'    bin9     bin10'
        do k = klow,khigh
            write(lun_out,2)k,(ihist_2d(k,ibin),ibin=1,nbins)
 2          format(i4,2x,10i10)
        enddo ! k

        return
        end


program modulo_01
real :: x1
integer :: i1
x1 = 3.3
print*, modulo(x1, 3.)
print*, modulo(x1, 2.)
print*, modulo(x1, 1.)
i1 = 4
print*, modulo(i1, 6)
print*, modulo(i1, 3)
print*, modulo(i1, 1)
end program


submodule (Prng_Class) sm_rngExponential
!! Generate random number from an exponential distribution.

  ! Original Version
  ! Author: Alan Miller
  ! The base functions were originally inside http://www.netlib.org/random/random.f90.

  ! Updated version:
  ! Version 2.00, 11 November 2016
  ! Increased precision to double
  !
  ! Updated again
  ! Added overloaded operations for single number, nD arrays
  !     Author: Leon Foks
implicit none

contains
  !====================================================================!
  module procedure rngExponential_d1_Prng!(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  ! Adapted from Fortran 77 code from the book:
  !     Dagpunar, J. 'Principles of random variate generation'
  !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

  ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
  ! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL
  ! TO EXP(-random_exponential), USING INVERSION.
!  class(Prng) :: this
!  real(r64)  :: res
!  real(r64) :: lambda
  if (lambda <= 0.d0) call eMsg('Prng%rngExponential: lambda must be > 0')
  call rngExponential_unscaled_d1(this, res)
  res = res / lambda
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngExponential_d1D_Prng!(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  ! class(Prng) :: this
  ! real(r64) :: res(:)
  ! real(r64) :: lambda
  integer :: i, N
  real(r64) :: wk

  N = size(res)

  if (lambda <= 0.d0) call eMsg('Prng%rngExponential: lambda must be > 0')
  wk = 1.d0 / lambda
  do i = 1, N
    call rngExponential_unscaled_d1(this, res(i))
    res(i) = wk * res(i)
  end do

  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngExponential_d2D_Prng!(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  ! class(Prng) :: this
  ! real(r64) :: res(:, :)
  ! real(r64) :: lambda
  integer(i32) :: i, iSub(2)
  integer(i32) :: n, nSub(2)
  real(r64) :: wk, wk2

  if (lambda <= 0.d0) call eMsg('Prng%rngExponential: lambda must be > 0')
  wk2 = 1.d0 / lambda

  nSub = shape(res)
  n = size(res)
  do i = 1, n
    iSub = ind2sub(i, nSub)
    call rngExponential_unscaled_d1(this, wk)
    res(iSub(1), iSub(2)) = wk2 * wk
  enddo
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngExponential_d3D_Prng!(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  ! class(Prng) :: this
  ! real(r64) :: res(:,:,:)
  ! real(r64) :: lambda
  integer(i32) :: i, iSub(3)
  integer(i32) :: n, nSub(3)
  real(r64) :: wk, wk2

  if (lambda <= 0.d0) call eMsg('Prng%rngExponential: lambda must be > 0')
  wk2 = 1.d0 / lambda

  nSub = shape(res)
  n = size(res)
  do i = 1, n
    iSub = ind2sub(i, nSub)
    call rngExponential_unscaled_d1(this, wk)
    res(iSub(1), iSub(2), iSub(3)) = wk2 * wk
  enddo
  end procedure
  !====================================================================!

  !====================================================================!
  module procedure rngExponential_unscaled_d1!(this, res)
  !====================================================================!
  ! Adapted from Fortran 77 code from the book:
  !     Dagpunar, J. 'Principles of random variate generation'
  !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

  ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
  ! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL
  ! TO EXP(-random_exponential), USING INVERSION.
  !class(Prng)  :: this
  !real(r64)  :: res
  call this%rngUniform(res, 0.d0, 1.d0)

  do while (res == 0.d0)
    call this%rngUniform(res, 0.d0, 1.d0)
  end do
  res = -log(res)
  end procedure
  !====================================================================!
end submodule


!##############################################################################
! PROGRAM household3
!
! ## The life cycle model with wage and interest rate risk
!
! 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)
!
!##############################################################################
include "prog05_03m.f90"

program household3

    use globals
    use toolbox

    implicit none
    real*8 :: x(1+n_w*n_R)
    real*8 :: fret, low(1+n_w*n_R), up(1+n_w*n_R)
    integer :: j, iw, ir2, ir3, ic

    ! discretize w
    call log_normal_discrete(w, weight_w, mu_w, sig_w)

    ! discretize R
    call log_normal_discrete(R, weight_R, mu_R, sig_R)

    ! lower and upper border and initial guess
    low = 0d0
    up(1) = mu_w
    ic = 2
    do iw = 1, n_w
        do ir2 = 1, n_R
            up(ic) = R(ir2)*mu_w+w(iw)
            ic = ic+1
        enddo
    enddo
    x = up/2d0

    ! minimization routine
    call fminsearch(x, fret, low, up, utility)

    ! set up data for output
    do iw = 1, n_w
        do ir2 = 1, n_R
            do ir3 = 1, n_R
                wag(1,iw,ir2,ir3) = mu_w
                inc(1,iw,ir2,ir3) = mu_w
                sav(1,iw,ir2,ir3) = a(2,1,1)

                wag(2,iw,ir2,ir3) = w(iw)
                inc(2,iw,ir2,ir3) = w(iw)+R(ir2)*a(2,1,1)
                sav(2,iw,ir2,ir3) = a(3,iw,ir2)

                wag(3,iw,ir2,ir3) = 0d0
                inc(3,iw,ir2,ir3) = R(ir3)*a(3,iw,ir2)
                sav(3,iw,ir2,ir3) = 0d0
            enddo
        enddo
    enddo

    ! output
    write(*,'(/a/)')' AGE   CONS   WAGE    INC    SAV'
    do j = 1, 3
        write(*,'(i4,4f7.2,a)')j,E(c(j,:,:,:)),E(wag(j,:,:,:)),&
            E(inc(j,:,:,:)),E(sav(j,:,:,:)),' (MEAN)'
        write(*,'(4x,4f7.2,a/)')Std(c(j,:,:,:)),Std(wag(j,:,:,:)),&
            Std(inc(j,:,:,:)),Std(sav(j,:,:,:)),' (STD)'
    enddo

    write(*,'(/2(a,f6.2))')' E(w) = ',sum(weight_w*w),'   Var(w) = ', &
        sum(weight_w*w**2)-sum(weight_w*w)**2
    write(*,'(2(a,f6.2))')' E(R) = ',sum(weight_R*R),'   Var(R) = ', &
        sum(weight_R*R**2)-sum(weight_R*R)**2

end program


! THIS VERSION: GALAHAD 2.2 - 23/04/2008 AT 16:30 GMT.
   PROGRAM GALAHAD_LSQP_EXAMPLE
   USE GALAHAD_LSQP_double                       ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
   TYPE ( QPT_problem_type ) :: p
   TYPE ( LSQP_data_type ) :: data
   TYPE ( LSQP_control_type ) :: control
   TYPE ( LSQP_inform_type ) :: info
   INTEGER, PARAMETER :: n = 3, m = 2, a_ne = 4
   INTEGER :: i, s
! start problem data
   ALLOCATE( p%X_l( n ), p%X_u( n ) )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ) )
   ALLOCATE( p%X( n ), p%Y( m ), p%Z( n ) )
   p%new_problem_structure = .TRUE.           ! new structure
   p%n = n ; p%m = m ; p%f = 0.0_wp           ! dimensions & objective constant
   p%C_l = (/ 1.0_wp, 2.0_wp /)               ! constraint lower bound
   p%C_u = (/ 2.0_wp, 2.0_wp /)               ! constraint upper bound
   p%X_l = (/ - 1.0_wp, - infinity, - infinity /) ! variable lower bound
   p%X_u = (/ 1.0_wp, infinity, 2.0_wp /)     ! variable upper bound
   p%gradient_kind = 0
! sparse co-ordinate storage format: integer components
   CALL SMT_put( p%A%type, 'COORDINATE', s )  ! storage for H and A
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%A%row = (/ 1, 1, 2, 2 /)                 ! Jacobian A
   p%A%col = (/ 1, 2, 2, 3 /) ; p%A%ne = a_ne
! integer components complete
   CALL LSQP_initialize( data, control )      ! Initialize control parameters
   control%infinity = infinity                ! Set infinity
   control%restore_problem = 1                ! Restore vector data on exit
   DO i = 0, 2
     p%X = (/  -2.0_wp, 1.0_wp,  3.0_wp /)         ! set x0
     p%Y = 0.0_wp ; p%Z = 0.0_wp                   ! start multipliers from zero
! sparse co-ordinate storage format: real components
     p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! Jacobian A
! real components complete
     p%Hessian_kind = 2 - i
     IF ( p%Hessian_kind == 0 ) THEN
       control%stop_c = 10.0_wp ** ( - 16 ) ; control%itref_max = 2
     END IF
     IF ( p%Hessian_kind == 2 ) THEN
       ALLOCATE( p%WEIGHT( n ) ) ; p%WEIGHT = (/ 0.1_wp, 1.0_wp, 2.0_wp /)
       ALLOCATE( p%X0( n ) )
     END IF
     IF ( p%Hessian_kind /= 0 ) p%X0 = p%X
     CALL LSQP_solve( p, data, control, info )     ! Solve problem
     IF ( info%status == 0 ) THEN                  ! Successful return
       IF ( p%Hessian_kind == 0 ) THEN
         WRITE( 6, "( ' Eg ', I1, I6, ' iterations. Optimal potential value =',&
        &       ES12.4, /, ' Analytic center  = ', ( 5ES12.4 ) )" )            &
         i + 1, info%iter, info%potential, p%X
       ELSE
         WRITE( 6, "( ' Eg ', I1, I6, ' iterations. Optimal objective value =',&
        &       ES12.4, /, ' Optimal solution = ', ( 5ES12.4 ) )" )            &
         i + 1, info%iter, info%obj, p%X
       END IF
     ELSE                                          !  Error returns
       WRITE( 6, "( ' LSQP_solve exit status = ', I6 ) " ) info%status
     END IF
   END DO
   CALL LSQP_terminate( data, control, info )      !  delete internal workspace
   END PROGRAM GALAHAD_LSQP_EXAMPLE


      program test
         use minpack_module
      implicit none

!     **********
!
!     THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT
!     INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES.
!     FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF
!     THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN
!     THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF
!     THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE
!     DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION
!     REQUIRED BY AND RECEIVED FROM CHKDER.
!
!     SUBPROGRAMS CALLED
!
!       MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , ldfjac , lnp , mode , n , nprob , nread , nwrite
      integer na(14) , np(14)
      logical a(14)
      double precision cp , one
      double precision diff(10) , err(10) , errmax(14) , errmin(14) ,   &
                     & fjac(10,10) , fvec1(10) , fvec2(10) , x1(10) ,   &
                     & x2(10)
!
!     LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5.
!     LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6.
!
      data nread , nwrite/5 , 6/
!
      data a(1) , a(2) , a(3) , a(4) , a(5) , a(6) , a(7) , a(8) ,      &
         & a(9) , a(10) , a(11) , a(12) , a(13) , a(14)/.false. ,       &
         & .false. , .false. , .true. , .false. , .false. , .false. ,   &
         & .true. , .false. , .false. , .false. , .false. , .true. ,    &
         & .false./
      data cp , one/1.23d-1 , 1.0d0/
      ldfjac = 10
      n = 10
      do nprob = 1, 15
      if ( nprob==15 ) then
         write (nwrite,99002) lnp
99002    format ('1SUMMARY OF ',i3,' TESTS OF CHKDER'/)
         write (nwrite,99003)
99003    format (' NPROB   N    STATUS     ERRMIN         ERRMAX'/)
         do i = 1 , lnp
            write (nwrite,99004) np(i) , na(i) , a(i) , errmin(i) ,     &
                               & errmax(i)
99004       format (i4,i6,6x,l1,3x,2d15.7)
         enddo
         stop
      else
         call initpt(n,x1,nprob,one)
         do i = 1 , n
            x1(i) = x1(i) + cp
            cp = -cp
         enddo
         write (nwrite,99005) nprob , n , a(nprob)
99005    format (///5x,' PROBLEM',i5,5x,' WITH DIMENSION',i5,2x,' IS  ',&
               & l1)
         mode = 1
         call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err)
         mode = 2
         call vecfcn(n,x1,fvec1,nprob)
         call errjac(n,x1,fjac,ldfjac,nprob)
         call vecfcn(n,x2,fvec2,nprob)
         call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err)
         errmin(nprob) = err(1)
         errmax(nprob) = err(1)
         do i = 1 , n
            diff(i) = fvec2(i) - fvec1(i)
            if ( errmin(nprob)>err(i) ) errmin(nprob) = err(i)
            if ( errmax(nprob)<err(i) ) errmax(nprob) = err(i)
         enddo
         np(nprob) = nprob
         lnp = nprob
         na(nprob) = n
         write (nwrite,99006) (fvec1(i),i=1,n)
99006    format (//5x,' FIRST FUNCTION VECTOR   '//(5x,5d15.7))
         write (nwrite,99007) (diff(i),i=1,n)
99007    format (//5x,' FUNCTION DIFFERENCE VECTOR'//(5x,5d15.7))
         write (nwrite,99008) (err(i),i=1,n)
99008    format (//5x,' ERROR VECTOR'//(5x,5d15.7))
      endif
      end do
      end program test

      subroutine errjac(n,x,Fjac,Ldfjac,Nprob)
      implicit none

      integer n , Ldfjac , Nprob
      double precision x(n) , Fjac(Ldfjac,n)
!     **********
!
!     SUBROUTINE ERRJAC
!
!     THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE
!     JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM
!     DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN.
!     VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST
!     FOR CHKDER.
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB)
!
!     WHERE
!
!       N IS A POSITIVE INTEGER VARIABLE.
!
!       X IS AN ARRAY OF LENGTH N.
!
!       FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE
!         JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY
!         INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X.
!
!       LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N
!         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
!
!       NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
!
!     SUBPROGRAMS CALLED
!
!       FORTRAN-SUPPLIED ... atan,cos,exp,DMIN1,sin,sqrt,
!                            MAX0,MIN0
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , ivar , j , k , k1 , k2 , ml , mu
      double precision c1 , c3 , c4 , c5 , c6 , c9 , eight , fiftn ,    &
                     & five , four , h , hundrd , one , prod , six ,    &
                     & sum , sum1 , sum2 , temp , temp1 , temp2 ,       &
                     & temp3 , temp4 , ten , three , ti , tj , tk ,     &
                     & tpi , twenty , two , zero
      double precision dfloat
      data zero , one , two , three , four , five , six , eight , ten , &
         & fiftn , twenty , hundrd/0.0d0 , 1.0d0 , 2.0d0 , 3.0d0 ,      &
         & 4.0d0 , 5.0d0 , 6.0d0 , 8.0d0 , 1.0d1 , 1.5d1 , 2.0d1 ,      &
         & 1.0d2/
      data c1 , c3 , c4 , c5 , c6 , c9/1.0d4 , 2.0d2 , 2.02d1 , 1.98d1 ,&
         & 1.8d2 , 2.9d1/
      dfloat(ivar) = ivar
!
!     JACOBIAN ROUTINE SELECTOR.
!
      select case (Nprob)
      case (2)
!
!     POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT
!     (3,3).
!
         do k = 1 , 4
            do j = 1 , 4
               Fjac(k,j) = zero
            enddo
         enddo
         Fjac(1,1) = one
         Fjac(1,2) = ten
         Fjac(2,3) = sqrt(five)
         Fjac(2,4) = -Fjac(2,3)
         Fjac(3,2) = two*(x(2)-two*x(3))
         Fjac(3,3) = two*Fjac(3,2)
         Fjac(4,1) = two*sqrt(ten)*(x(1)-x(4))
         Fjac(4,4) = -Fjac(4,1)
      case (3)
!
!     POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN
!     REVERSED.
!
         Fjac(1,1) = -c1*x(2)
         Fjac(1,2) = -c1*x(1)
         Fjac(2,1) = exp(-x(1))
         Fjac(2,2) = exp(-x(2))
      case (4)
!
!     WOOD FUNCTION WITHOUT ERROR.
!
         do k = 1 , 4
            do j = 1 , 4
               Fjac(k,j) = zero
            enddo
         enddo
         temp1 = x(2) - three*x(1)**2
         temp2 = x(4) - three*x(3)**2
         Fjac(1,1) = -c3*temp1 + one
         Fjac(1,2) = -c3*x(1)
         Fjac(2,1) = -two*c3*x(1)
         Fjac(2,2) = c3 + c4
         Fjac(2,4) = c5
         Fjac(3,3) = -c6*temp2 + one
         Fjac(3,4) = -c6*x(3)
         Fjac(4,2) = c5
         Fjac(4,3) = -two*c6*x(3)
         Fjac(4,4) = c6 + c4
      case (5)
!
!     HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING
!     ELEMENTS (2,1) AND (2,2).
!
         tpi = eight*atan(one)
         temp = x(1)**2 + x(2)**2
         temp1 = tpi*temp
         temp2 = sqrt(temp)
         Fjac(1,1) = hundrd*x(2)/temp1
         Fjac(1,2) = -hundrd*x(1)/temp1
         Fjac(1,3) = ten
         Fjac(2,1) = five*x(1)/temp2
         Fjac(2,2) = five*x(2)/temp2
         Fjac(2,3) = zero
         Fjac(3,1) = zero
         Fjac(3,2) = zero
         Fjac(3,3) = one
      case (6)
!
!     WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF
!     TEMP1.
!
         do k = 1 , n
            do j = k , n
               Fjac(k,j) = zero
            enddo
         enddo
         do i = 1 , 29
            ti = dfloat(i)/c9
            sum1 = zero
            temp = one
            do j = 2 , n
               sum1 = sum1 + dfloat(j-1)*temp*x(j)
               temp = ti*temp
            enddo
            sum2 = zero
            temp = one
            do j = 1 , n
               sum2 = sum2 + temp*x(j)
               temp = ti*temp
            enddo
            temp1 = two*(sum1+sum2**2+one)
            temp2 = two*sum2
            temp = ti**2
            tk = one
            do k = 1 , n
               tj = tk
               do j = k , n
                  Fjac(k,j) = Fjac(k,j)                                 &
                            & + tj*((dfloat(k-1)/ti-temp2)*(dfloat(j-1) &
                            & /ti-temp2)-temp1)
                  tj = ti*tj
               enddo
               tk = temp*tk
            enddo
         enddo
         Fjac(1,1) = Fjac(1,1) + six*x(1)**2 - two*x(2) + three
         Fjac(1,2) = Fjac(1,2) - two*x(1)
         Fjac(2,2) = Fjac(2,2) + one
         do k = 1 , n
            do j = k , n
               Fjac(j,k) = Fjac(k,j)
            enddo
         enddo
      case (7)
!
!     CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE.
!
         tk = one/dfloat(n)
         do j = 1 , n
            temp1 = one
            temp2 = two*x(j) - one
            temp = two*temp2
            temp3 = zero
            temp4 = two
            do k = 1 , n
               Fjac(k,j) = two*tk*temp4
               ti = four*temp2 + temp*temp4 - temp3
               temp3 = temp4
               temp4 = ti
               ti = temp*temp2 - temp1
               temp1 = temp2
               temp2 = ti
            enddo
         enddo
      case (8)
!
!     BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR.
!
         prod = one
         do j = 1 , n
            prod = x(j)*prod
            do k = 1 , n
               Fjac(k,j) = one
            enddo
            Fjac(j,j) = two
         enddo
         do j = 1 , n
            temp = x(j)
            if ( temp==zero ) then
               temp = one
               prod = one
               do k = 1 , n
                  if ( k/=j ) prod = x(k)*prod
               enddo
            endif
            Fjac(n,j) = prod/temp
         enddo
      case (9)
!
!     DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR
!     AFFECTING THE JACOBIAN DIAGONAL.
!
         h = one/dfloat(n+1)
         do k = 1 , n
            temp = three*(x(k)+dfloat(k)*h+one)**2
            do j = 1 , n
               Fjac(k,j) = zero
            enddo
            Fjac(k,k) = four + temp*h**2
            if ( k/=1 ) Fjac(k,k-1) = -one
            if ( k/=n ) Fjac(k,k+1) = -one
         enddo
      case (10)
!
!     DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING
!     THE JACOBIAN DIAGONAL.
!
         h = one/dfloat(n+1)
         do k = 1 , n
            tk = dfloat(k)*h
            do j = 1 , n
               tj = dfloat(j)*h
               temp = three*(x(j)+tj+one)**2
               Fjac(k,j) = h*min(tj*(one-tk),tk*(one-tj))*temp/two
            enddo
            Fjac(k,k) = Fjac(k,k) - one
         enddo
      case (11)
!
!     TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE
!     OFFDIAGONAL ELEMENTS OF THE JACOBIAN.
!
         do j = 1 , n
            temp = sin(x(j))
            do k = 1 , n
               Fjac(k,j) = -temp
            enddo
            Fjac(j,j) = dfloat(j+1)*temp - cos(x(j))
         enddo
      case (12)
!
!     VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING
!     THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN.
!
         sum = zero
         do j = 1 , n
            sum = sum + dfloat(j)*(x(j)-one)
         enddo
         temp = one + six*sum**2
         do k = 1 , n
            do j = k , n
               Fjac(k,j) = dfloat(k*j)/temp
               Fjac(j,k) = Fjac(k,j)
            enddo
            Fjac(k,k) = Fjac(k,k) + one
         enddo
      case (13)
!
!     BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR.
!
         do k = 1 , n
            do j = 1 , n
               Fjac(k,j) = zero
            enddo
            Fjac(k,k) = three - four*x(k)
            if ( k/=1 ) Fjac(k,k-1) = -one
            if ( k/=n ) Fjac(k,k+1) = -two
         enddo
      case (14)
!
!     BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN
!     DIAGONAL.
!
         ml = 5
         mu = 1
         do k = 1 , n
            do j = 1 , n
               Fjac(k,j) = zero
            enddo
            k1 = max0(1,k-ml)
            k2 = min0(k+mu,n)
            do j = k1 , k2
               if ( j/=k ) Fjac(k,j) = -(one+two*x(j))
            enddo
            Fjac(k,k) = two - fiftn*x(k)**2
         enddo
      case default
!
!     ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1).
!
         Fjac(1,1) = one
         Fjac(1,2) = zero
         Fjac(2,1) = -twenty*x(1)
         Fjac(2,2) = ten
      end select
!
!     LAST CARD OF SUBROUTINE ERRJAC.
!
      end

      subroutine initpt(n,x,Nprob,Factor)
      implicit none

      integer n , Nprob
      double precision Factor
      double precision x(n)
!     **********
!
!     SUBROUTINE INITPT
!
!     THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR
!     THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE
!     RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING
!     POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS
!     ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE
!     SUBROUTINE RETURNS THE VECTOR  X(J) = FACTOR, J=1,...,N.
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE INITPT(N,X,NPROB,FACTOR)
!
!     WHERE
!
!       N IS A POSITIVE INTEGER INPUT VARIABLE.
!
!       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD
!         STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR.
!
!       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
!
!       FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF
!         THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO
!         MULTIPLICATION IS PERFORMED.
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer ivar , j
      double precision c1 , h , half , one , three , tj , zero
      double precision dfloat
      data zero , half , one , three , c1/0.0d0 , 5.0d-1 , 1.0d0 ,      &
         & 3.0d0 , 1.2d0/
      dfloat(ivar) = ivar
!
!     SELECTION OF INITIAL POINT.
!
      select case (Nprob)
      case (2)
!
!     POWELL SINGULAR FUNCTION.
!
         x(1) = three
         x(2) = -one
         x(3) = zero
         x(4) = one
      case (3)
!
!     POWELL BADLY SCALED FUNCTION.
!
         x(1) = zero
         x(2) = one
      case (4)
!
!     WOOD FUNCTION.
!
         x(1) = -three
         x(2) = -one
         x(3) = -three
         x(4) = -one
      case (5)
!
!     HELICAL VALLEY FUNCTION.
!
         x(1) = -one
         x(2) = zero
         x(3) = zero
      case (6)
!
!     WATSON FUNCTION.
!
         do j = 1 , n
            x(j) = zero
         enddo
      case (7)
!
!     CHEBYQUAD FUNCTION.
!
         h = one/dfloat(n+1)
         do j = 1 , n
            x(j) = dfloat(j)*h
         enddo
      case (8)
!
!     BROWN ALMOST-LINEAR FUNCTION.
!
         do j = 1 , n
            x(j) = half
         enddo
      case (9,10)
!
!     DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS.
!
         h = one/dfloat(n+1)
         do j = 1 , n
            tj = dfloat(j)*h
            x(j) = tj*(tj-one)
         enddo
      case (11)
!
!     TRIGONOMETRIC FUNCTION.
!
         h = one/dfloat(n)
         do j = 1 , n
            x(j) = h
         enddo
      case (12)
!
!     VARIABLY DIMENSIONED FUNCTION.
!
         h = one/dfloat(n)
         do j = 1 , n
            x(j) = one - dfloat(j)*h
         enddo
      case (13,14)
!
!     BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS.
!
         do j = 1 , n
            x(j) = -one
         enddo
      case default
!
!     ROSENBROCK FUNCTION.
!
         x(1) = -c1
         x(2) = one
      end select
!
!     COMPUTE MULTIPLE OF INITIAL POINT.
!
      if ( Factor/=one ) then
         if ( Nprob==6 ) then
            do j = 1 , n
               x(j) = Factor
            enddo
         else
            do j = 1 , n
               x(j) = Factor*x(j)
            enddo
         endif
      endif
!
!     LAST CARD OF SUBROUTINE INITPT.
!
      end

      subroutine vecfcn(n,x,Fvec,Nprob)
      implicit none

      integer n , Nprob
      double precision x(n) , Fvec(n)
!     **********
!
!     SUBROUTINE VECFCN
!
!     THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST
!     FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY,
!     WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION
!     N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN
!     EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1).
!
!     THE SUBROUTINE STATEMENT IS
!
!       SUBROUTINE VECFCN(N,X,FVEC,NPROB)
!
!     WHERE
!
!       N IS A POSITIVE INTEGER INPUT VARIABLE.
!
!       X IS AN INPUT ARRAY OF LENGTH N.
!
!       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB
!         FUNCTION VECTOR EVALUATED AT X.
!
!       NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE
!         NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14.
!
!     SUBPROGRAMS CALLED
!
!       FORTRAN-SUPPLIED ... atan,cos,exp,sign,sin,sqrt,
!                            MAX0,MIN0
!
!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
!
!     **********
      integer i , iev , ivar , j , k , k1 , k2 , kp1 , ml , mu
      double precision c1 , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9 ,     &
                     & eight , five , h , one , prod , sum , sum1 ,     &
                     & sum2 , temp , temp1 , temp2 , ten , three , ti , &
                     & tj , tk , tpi , two , zero
      double precision dfloat
      data zero , one , two , three , five , eight , ten/0.0d0 , 1.0d0 ,&
         & 2.0d0 , 3.0d0 , 5.0d0 , 8.0d0 , 1.0d1/
      data c1 , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9/1.0d4 , 1.0001d0 ,&
         & 2.0d2 , 2.02d1 , 1.98d1 , 1.8d2 , 2.5d-1 , 5.0d-1 , 2.9d1/
      dfloat(ivar) = ivar
!
!     PROBLEM SELECTOR.
!
      select case (Nprob)
      case (2)
!
!     POWELL SINGULAR FUNCTION.
!
         Fvec(1) = x(1) + ten*x(2)
         Fvec(2) = sqrt(five)*(x(3)-x(4))
         Fvec(3) = (x(2)-two*x(3))**2
         Fvec(4) = sqrt(ten)*(x(1)-x(4))**2
      case (3)
!
!     POWELL BADLY SCALED FUNCTION.
!
         Fvec(1) = c1*x(1)*x(2) - one
         Fvec(2) = exp(-x(1)) + exp(-x(2)) - c2
      case (4)
!
!     WOOD FUNCTION.
!
         temp1 = x(2) - x(1)**2
         temp2 = x(4) - x(3)**2
         Fvec(1) = -c3*x(1)*temp1 - (one-x(1))
         Fvec(2) = c3*temp1 + c4*(x(2)-one) + c5*(x(4)-one)
         Fvec(3) = -c6*x(3)*temp2 - (one-x(3))
         Fvec(4) = c6*temp2 + c4*(x(4)-one) + c5*(x(2)-one)
      case (5)
!
!     HELICAL VALLEY FUNCTION.
!
         tpi = eight*atan(one)
         temp1 = sign(c7,x(2))
         if ( x(1)>zero ) temp1 = atan(x(2)/x(1))/tpi
         if ( x(1)<zero ) temp1 = atan(x(2)/x(1))/tpi + c8
         temp2 = sqrt(x(1)**2+x(2)**2)
         Fvec(1) = ten*(x(3)-ten*temp1)
         Fvec(2) = ten*(temp2-one)
         Fvec(3) = x(3)
      case (6)
!
!     WATSON FUNCTION.
!
         do k = 1 , n
            Fvec(k) = zero
         enddo
         do i = 1 , 29
            ti = dfloat(i)/c9
            sum1 = zero
            temp = one
            do j = 2 , n
               sum1 = sum1 + dfloat(j-1)*temp*x(j)
               temp = ti*temp
            enddo
            sum2 = zero
            temp = one
            do j = 1 , n
               sum2 = sum2 + temp*x(j)
               temp = ti*temp
            enddo
            temp1 = sum1 - sum2**2 - one
            temp2 = two*ti*sum2
            temp = one/ti
            do k = 1 , n
               Fvec(k) = Fvec(k) + temp*(dfloat(k-1)-temp2)*temp1
               temp = ti*temp
            enddo
         enddo
         temp = x(2) - x(1)**2 - one
         Fvec(1) = Fvec(1) + x(1)*(one-two*temp)
         Fvec(2) = Fvec(2) + temp
      case (7)
!
!     CHEBYQUAD FUNCTION.
!
         do k = 1 , n
            Fvec(k) = zero
         enddo
         do j = 1 , n
            temp1 = one
            temp2 = two*x(j) - one
            temp = two*temp2
            do i = 1 , n
               Fvec(i) = Fvec(i) + temp2
               ti = temp*temp2 - temp1
               temp1 = temp2
               temp2 = ti
            enddo
         enddo
         tk = one/dfloat(n)
         iev = -1
         do k = 1 , n
            Fvec(k) = tk*Fvec(k)
            if ( iev>0 ) Fvec(k) = Fvec(k) + one/(dfloat(k)**2-one)
            iev = -iev
         enddo
      case (8)
!
!     BROWN ALMOST-LINEAR FUNCTION.
!
         sum = -dfloat(n+1)
         prod = one
         do j = 1 , n
            sum = sum + x(j)
            prod = x(j)*prod
         enddo
         do k = 1 , n
            Fvec(k) = x(k) + sum
         enddo
         Fvec(n) = prod - one
      case (9)
!
!     DISCRETE BOUNDARY VALUE FUNCTION.
!
         h = one/dfloat(n+1)
         do k = 1 , n
            temp = (x(k)+dfloat(k)*h+one)**3
            temp1 = zero
            if ( k/=1 ) temp1 = x(k-1)
            temp2 = zero
            if ( k/=n ) temp2 = x(k+1)
            Fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two
         enddo
      case (10)
!
!     DISCRETE INTEGRAL EQUATION FUNCTION.
!
         h = one/dfloat(n+1)
         do k = 1 , n
            tk = dfloat(k)*h
            sum1 = zero
            do j = 1 , k
               tj = dfloat(j)*h
               temp = (x(j)+tj+one)**3
               sum1 = sum1 + tj*temp
            enddo
            sum2 = zero
            kp1 = k + 1
            if ( n>=kp1 ) then
               do j = kp1 , n
                  tj = dfloat(j)*h
                  temp = (x(j)+tj+one)**3
                  sum2 = sum2 + (one-tj)*temp
               enddo
            endif
            Fvec(k) = x(k) + h*((one-tk)*sum1+tk*sum2)/two
         enddo
      case (11)
!
!     TRIGONOMETRIC FUNCTION.
!
         sum = zero
         do j = 1 , n
            Fvec(j) = cos(x(j))
            sum = sum + Fvec(j)
         enddo
         do k = 1 , n
            Fvec(k) = dfloat(n+k) - sin(x(k)) - sum - dfloat(k)*Fvec(k)
         enddo
      case (12)
!
!     VARIABLY DIMENSIONED FUNCTION.
!
         sum = zero
         do j = 1 , n
            sum = sum + dfloat(j)*(x(j)-one)
         enddo
         temp = sum*(one+two*sum**2)
         do k = 1 , n
            Fvec(k) = x(k) - one + dfloat(k)*temp
         enddo
      case (13)
!
!     BROYDEN TRIDIAGONAL FUNCTION.
!
         do k = 1 , n
            temp = (three-two*x(k))*x(k)
            temp1 = zero
            if ( k/=1 ) temp1 = x(k-1)
            temp2 = zero
            if ( k/=n ) temp2 = x(k+1)
            Fvec(k) = temp - temp1 - two*temp2 + one
         enddo
      case (14)
!
!     BROYDEN BANDED FUNCTION.
!
         ml = 5
         mu = 1
         do k = 1 , n
            k1 = max0(1,k-ml)
            k2 = min0(k+mu,n)
            temp = zero
            do j = k1 , k2
               if ( j/=k ) temp = temp + x(j)*(one+x(j))
            enddo
            Fvec(k) = x(k)*(two+five*x(k)**2) + one - temp
         enddo
      case default
!
!     ROSENBROCK FUNCTION.
!
         Fvec(1) = one - x(1)
         Fvec(2) = ten*(x(2)-x(1)**2)
      end select
!
!     LAST CARD OF SUBROUTINE VECFCN.
!
      end


!======================================================================!
  real function UserWRms(grid, y)
!----------------------------------------------------------------------!
!   Prescribes mean normal velocity fluctuations for the channel.      !
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real :: y
!======================================================================!
!   Wall is at y=0, and centerline at y=1                              !
!----------------------------------------------------------------------!

  UserWRms =                                                        &
   -1.030111e+003  * y**9  +  4.912363e+003  * y**8                 &
   -9.890964e+003  * y**7  +  1.092610e+004  * y**6                 &
   -7.188233e+003  * y**5  +  2.842998e+003  * y**4                 &
   -6.326466e+002  * y**3  +  5.750007e+001  * y**2                 &
   +3.613158e+000  * y**1  -  1.078184e-002

  end function UserWRms


c /***************************************************
c   hgpgen.f  for dbulhalo
c   20 Apr. 2015  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   generating halo hot gas *****/
      subroutine hgpgen(nhg,mhgp,ngr,ngz,mtothg,cnfw,rvir
     &  ,ajzhg,rcuthg,mtothgrc,flagb)
      include 'define.f'

      integer nhg,ngr,ngz
      integer flagb
      double precision mhgp,mtothg,cnfw,rvir,ajzhg
      double precision rcuthg,mtothgrc
      character filen*60
      integer i,j
      integer nrp,ndrm
      double precision rcut
      double precision ri,ro,lri,lro,dlr,rp,rr,mrp,rp2d
      double precision pfr,ph,th
c for density profile
      double precision gcv,rho0hg,rs
c *** for particles ***
      double precision xbp,ybp,zbp,vxbp,vybp,vzbp,rhobp,ubp
c *** for velocity ***
      integer ir,iz
      integer pnrizi,pnrizo,pnrozi,pnrozo
      double precision wrizi,wrizo,wrozi,wrozo
      double precision dr,dz
      double precision vsigz,vsigr,vsigph,vphm,vsig2p
      double precision vrp,vphp

c to measure profiles
      integer ndpr,ipr
      double precision lripr,lropr,mdrpr(0:MNR),dlrpr,dvdr

c *** external function
      double precision rhombhg
      external rhombhg
      integer idum
      real ran1,gasdev
      external ran1,gasdev

      idum = -111

      rs=rvir/cnfw
      gcv=9.0d0*dlog(1.0d0+(4.0d0/3.0d0)*cnfw)
     &   -8.0d0*dlog(1.0d0+cnfw)-(4.0d0*cnfw/(1.0d0+cnfw))
      rho0hg=mtothg/(4.0d0*M_PI*(rs**3)*gcv)

c *** generating particles ***
      if(myrank.eq.0) then

        write(6,*) ' hgpgen nhg=',nhg

        write(filen,'(a15)') 'output/hgas.dat'
        if(flagb.eq.0) then
          open(60,file=filen,status='unknown',form='unformatted')
          write(60) nhg
        else
          open(60,file=filen,status='unknown')
          write(60,'(a3,I10)') '#n=',nhg
        endif
      endif
c for checking profile
      lripr=dlog10(0.01d0)
      lropr=dlog10(rcuthg)
      ndpr=100
      dlrpr=(lropr-lripr)/dble(ndpr)
      do i=0,ndpr
        mdrpr(i)=0.0d0
      enddo

      do i=0,nhg-1
 67     pfr = dble(ran1(idum))
c *** search radius ***
        do j=1,ndr
          if(mrhg(j)/mtothgrc.gt.pfr) then
            goto 72
          endif
        enddo
c        write(6,*) ' Warning: in finding radius for disk'
c        write(6,*) '  pfr =',pfr
        goto 67
 72     if(j.eq.1) then
c          write(6,*) ' Warning: in finding radius for disk: j,mr,prf='
c     &      ,j,mrexpd(j),pfr
          j = 2
        endif
        pfr=pfr*mtothgrc
c bin size is set in ln(r) bin in hgtemprof.f
        rp=dexp(dlog(rmhg(j-1))
     &    +(dlog(rmhg(j))-dlog(rmhg(j-1)))
     &    *(dlog(pfr)-dlog(mrhg(j-1)))
     &    /(dlog(mrhg(j))-dlog(mrhg(j-1))))
        if(rp.gt.rcuthg) then
          goto 67
        endif
c to measure profile
        ir=int((dlog10(rp)-lripr)/dlrpr)
        if(ir.ge.0.and.ir.le.ndpr) then
          mdrpr(ir)=mdrpr(ir)+mhgp
        endif
        zbp=-rp+2.0d0*rp*dble(ran1(idum))
        ph =  2.0d0*M_PI*dble(ran1(idum))
        rp2d=dsqrt(rp**2-zbp**2)
        xbp = rp2d*dcos(ph)
        ybp = rp2d*dsin(ph)
c *** density ***
        rhobp=rho0hg*rhombhg(rp/rs)
c velocity
c no velocity dispersion for gas
c *** vphm from angular momentum
        if(rp2d.lt.rvir) then
          vphm=rp2d*ajzhg
        else
! the maximum angular momentum is rvir x ajzhg
          vphm=rvir*ajzhg
        endif
        vphp=vphm
        vrp=0.0d0
        vzbp=0.0d0
c *** convert vr,vph -> vx,vy ***
        if(rp2d.gt.0.0d0) then
          vxbp=vrp*xbp/rp2d-vphp*ybp/rp2d
          vybp=vrp*ybp/rp2d+vphp*xbp/rp2d
        else
          vxbp=0.0d0
          vybp=0.0d0
        endif
c thermal energy
        ubp=dexp(dlog(uhg(j-1))
     &    +(dlog(uhg(j))-dlog(uhg(j-1)))
     &    *(dlog(rp)-dlog(rmhg(j-1)))
     &    /(dlog(rmhg(j))-dlog(rmhg(j-1))))
c *** output
        if(myrank.eq.0) then
          if(flagb.eq.0) then
            write(60) xbp,ybp,zbp,vxbp,vybp,vzbp,mhgp,rhobp,ubp
          else
            write(60,160) xbp,ybp,zbp,vxbp,vybp,vzbp
     &       ,mhgp,rhobp,ubp,dsqrt(xbp**2+ybp**2+zbp**2)*LUKPC
     &       ,vsigph,vsigr,vsigz,rp2d,ubp*((GAM-1.0d0)/TPRHO)*TUK
 160        format(15(1pE13.5))
          endif
        endif
      enddo
      close(60)

      if(myrank.eq.0) then
        open(60,file='hgpprof.dat',status='unknown')
        do i=0,ndpr
          rp=10.0d0**(lripr+dlrpr*(dble(i)+0.5d0))
          dvdr=(4.0d0*M_PI/3.0d0)
     &      *((10.0d0**(lripr+dlrpr*dble(i+1)))**3
     &       -(10.0d0**(lripr+dlrpr*dble(i)))**3)
          write(60,'(3(1pE13.5))') rp*LUKPC,mdrpr(i)/dvdr
     &     ,rho0hg*rhombhg(rp/rs)
        enddo
        close(60)
      endif

      return
      end


      SUBROUTINE MF_RBARS

c     This routine computes values of variables which may be used to
c     form the elements of the rbar matrix, where RBAR represents
c     reflection of an elm wave from the earth's surface.  Namely,
c     rbar11=den11/(c*num11-den11) or (1./rbar11+1.)/c=num11/den11 and
c     rbar22=den22/(c*num22-den22) or (1./rbar22+1.)/c=num22/den22.
c     Derivatives wrt c=COS(THETA) are also computed if IDERIV is set
c     non-zero.  Note that the equations are formulated in such a way
c     that a smooth transition is made from the 'curved earth' form to
c     the 'flat earth' form.  See also notes in routine MF_MDHNKL
c     regarding definitions of Hankel function parameters.  The value
c     of earth's radius is such as to make 2./re=3.14e-4.  Computation
c     at THETA=90 is not excluded.

      parameter     (mxeigen=50)

      character*  8  archive,prgm_id
      character* 20  xmtr_id,path_id
      character* 40  prfl_id
      character* 80  case_id
      character*120  file_id
      integer        pflag,pindex
      real           lat,lon,lub,kvratt,n0sq,ndsq
      complex        eigen,theta,c,s,csq,ssq,ngsq,sqr,
     &                nm11, nm22, dn11, dn22,
     &               num11,num22,den11,den22,
     &                dnm11, dnm22, ddn11, ddn22,
     &               dnum11,dnum22,dden11,dden22,
     &               k1,k2,k10,k1d,k20,k2d,a0,ad,
     &               f,f0,fd,f0d,dq,df,df0,dfd,df0d,
     &               q0,h10,h20,h10p,h20p,e0,
     &               qd,h1d,h2d,h1dp,h2dp,ed,
     &               f1,f2,hg,exd,z1,z2,rbar11,rbar22

      common/lwpc_in/archive,file_id(3),prgm_id,
     &               case_id,prfl_id,xmtr_id,path_id,
     &               freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &               lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &               hofwr,topht,botht,pindex
     &      /lwpc_mf/ranger(2),rangei(2),atnmax,lub,h,
     &               eigen(mxeigen),nreigen

     &      /mf_hgts/rtol,xintrp,htntrp,d,z0,zz
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_rbrs/ num11, num22, den11, den22,
     &               dnum11,dnum22,dden11,dden22,f1,f2,hg

c     Computation which is independent of THETA.

      ngsq=CMPLX(epsr,-sigma/(omega*8.85434e-12))

      arg=3.14e-4/wavenr
      avrkot=EXP(LOG(arg)/3.)
      kvratt=1./avrkot**2
      k1=CMPLX(0.,avrkot)
      k2=CMPLX(0.,.5*arg)

      em0=-3.14e-4*h
      n0sq=1.+em0
      k10=k1/n0sq
      k20=k2/n0sq
      emd= 3.14e-4*(d-h)
      ndsq=1.+emd
      k1d=k1/ndsq
      k2d=k2/ndsq

      c=COS(theta*(.01745329252,0.))
      s=SIN(theta*(.01745329252,0.))
      csq=c*c
      ssq=s*s

      dq=(2.*kvratt)*c
      sqr=SQRT(ngsq-ssq)

      num11=(1.,0.)
      num22=(1.,0.)/sqr
      den11=(c-sqr/ngsq)*(.5,0.)
      den22=(c/sqr-(1.,0.))*(.5,0.)
      if (ideriv .eq. 1) then
         dnum11=(0.,0.)
         dnum22=-c/sqr**3
         dden11=((1.,0.)-c/(sqr*ngsq))*(.5,0.)
         dden22=(-csq/sqr**3+(1.,0.)/sqr)*(.5,0.)
      end if

      if (AIMAG(theta) .gt. -10.) then

         a0=c+k20
         ad=c+k2d

         q0=kvratt*(csq+em0)
         qd=kvratt*(csq+emd)

         if (REAL(q0) .le. 0.0 .and. REAL(qd) .le. 0.0 .and.
     &       ABS(q0) .gt. 4.2 .and. ABS(qd) .gt. 4.2) then
            ngboth = 1
         else
            ngboth = 0
         end if

         call MF_MDHNKL (q0,h10,h20,h10p,h20p,e0,ngboth)
         call MF_MDHNKL (qd,h1d,h2d,h1dp,h2dp,ed,ngboth)

         h1d =h1d *EXP(e0-ed)
         h1dp=h1dp*EXP(e0-ed)
         h2d =h2d *EXP(ed-e0)
         h2dp=h2dp*EXP(ed-e0)

         f  =h10 *h2d -h20 *h1d
         f0 =h10p*h2d -h20p*h1d
         fd =h10 *h2dp-h20 *h1dp
         f0d=h10p*h2dp-h20p*h1dp

         df  = (f0+fd)*dq
         df0 = (f0d-q0*f)*dq
         dfd = (f0d-qd*f)*dq
         df0d=-(qd*f0+q0*fd)*dq

         nm11 = num11
         nm22 = num22
         dn11 = den11
         dn22 = den22
         dnm11=dnum11
         dnm22=dnum22
         ddn11=dden11
         ddn22=dden22

         den11=-nm11*(a0*ad*f+k1d*a0*fd+k10*ad*f0+k10*k1d*f0d)
     &         +2.*dn11*(ad*f+k1d*fd)
         den22=-nm22*( c* c*f+k1 *c *fd+k1 *c *f0+k1 *k1 *f0d)
     &         +2.*dn22*( c*f+k1 *fd)
         num11=-2.*nm11*(a0*f+k10*f0)+4.*dn11*f
         num22=-2.*nm22*( c*f+k1 *f0)+4.*dn22*f
         if (ideriv .eq. 1) then
            dden11=-dnm11*(a0*ad*f+k1d*a0*fd+k10*ad*f0-k10*k1d*f0d)
     &             -nm11*((a0+ad)*f+a0*ad*df
     &                    +k1d*(fd+a0*dfd)+k10*(f0+ad*df0)+k10*k1d*df0d)
     &             +2.*ddn11*(ad*f+k1d*fd)+2.*dn11*((f+ad*df)+k1d*dfd)
            dden22=-dnm22*( c* c*f+k1 * c*fd+k1 * c*f0-k1 *k1 *f0d)
     &             -nm22*(( c+ c)*f+ c* c*df
     &                    +k1 *(fd+ c*dfd)+k1 *(f0+ c*df0)+k1 *k1 *df0d)
     &             +2.*ddn22*( c*f+k1 *fd)+2.*dn22*((f+ c*df)+k1 *dfd)
            dnum11=-2.*dnm11*(a0*f+k10*f0)-2.*nm11*((f+a0*df)+k10*df0)
     &             +4.*ddn11*f+4.*dn11*df
            dnum22=-2.*dnm22*( c*f+k1 *f0)-2.*nm22*((f+ c*df)+k1 *df0)
     &             +4.*ddn22*f+4.*dn22*df

c           Following four statements needed only for excitation factors
c           fprl at z=d
            f1= nm11*f0+(nm11*a0-2.*dn11)*f/k10
c           fprp at z=d
            f2=(nm22*f0+(nm22* c-2.*dn22)*f/k1 )*sqr
c           fprl at z=0 divided by fprl at z=d
Change 22 Feb 1994: Test for F1 being zero.
            if (ABS(f1) .eq. 0.) f1=1.e-8
            hg=EXP(-1.57e-4*d)*nm11/f1*(h10p*h20-h10*h20p)
         end if
      else

         z1=(ngsq*c-sqr)/(ngsq*c+sqr)
         z2=(c-sqr)/(c+sqr)
         exd=EXP(CMPLX(0.,-d*wavenr)*c)
         f1=(1.,0.)/exd+z1*exd
         f2=(1.,0.)/exd+z2*exd
         hg=((1.,0.)+z1)/f1
         rbar11=z1*exd**2
         rbar22=z2*exd**2
      end if
      RETURN
      END      ! MF_RBARS


      subroutine coefswdk(qsqw,ct,c0)
      implicit none
C     Authors: John Campbell and R.Keith Ellis, April 2012
C     This gives the coefficients of the virtual corrections, c0,
C     and the the integrated counterterm for
C     w decay into massless quarks
      include 'constants.f'
      include 'epinv.f'
      include 'epinv2.f'
      include 'scale.f'
      include 'alfacut.f'
      include 'includect.f'
      double precision ct,c0,qsqw,xl12

c--- this is computed in the 4d-hel scheme (scheme = 'dred')
      xl12=dlog(qsqw/musq)

c--- epinv stands for (4*pi)^ep/Gamma(1-ep)/ep  (as usual)
c----  ct is the integrated counter-term, including alpha-dependence,
c----  see Eq. (10) of arXiv:1102.1967
      if (includect) then
      ct=+2d0*epinv*(epinv2-xl12)+xl12**2+3d0*(epinv-xl12)+9d0-pisq
     &   +3d0*(aff-1d0-dlog(aff))-2d0*dlog(aff)**2
      else
      ct=0d0
      endif
c---------------------------------------------------------------
C adding term to check that the total w rate
c integrates to the right amount,as/pi,(ie result should be zero)
c for testing only!
c      ct=ct-1.5d0
c---------------------------------------------------------------
      c0=-2d0*(epinv*epinv2-epinv*xl12+half*xl12**2)
     &   -3d0*(epinv-xl12)+pisq-7d0

      return
      end


real*8 function RandomN(idum)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Minimal random number generator of Park and Miller combined with a Marsaglia
!	shift sequence. Returns a uniform random deviate between 0.0 and 1.0 (exclusive
!	of the endpoint values). This fully portable scalar generator has the
!	"traditional" (not Fortran 90) calling sequence with a random deviate as the
!	returned function value. Call with idum a negative integer to initialize;
!	thereafter, do not alter idum except to reinitialize. The period of this
!	generator is about 3.1 10^18.
!
!	Taken from numerical recipes, f90
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, parameter ::	K4B=selected_int_kind(9)
	integer(K4B), intent(inout) ::	idum
	integer(K4B), parameter ::	IA=16807,IM=2147483647,IQ=127773,IR=2836, &
					one = 1, param1 = 888889999, param2 = 777755555
	real*8, save ::	am
	integer(K4B), save ::	ix=-1, iy=-1, k

	if (idum <= 0 .or.iy < 0) then 	! Initialize.
		am=nearest(1.0,-1.0)/IM
		iy=ior(ieor(param1, abs(idum)), one)
		ix=ieor(param2, abs(idum))
		idum=abs(idum)+1 	! Set idum positive.
	endif

	ix=ieor(ix,ishft(ix,13))	! Marsaglia shift sequence with period 2^32 -1
	ix=ieor(ix,ishft(ix,-17))
	ix=ieor(ix,ishft(ix,5))
	k=iy/IQ 			! Park-Miller sequence by Schrage's method, period 2^31 -2
	iy=IA * (iy - k * IQ)-IR * k
	if (iy < 0) iy = iy + IM
	RandomN=am * ior(iand(IM, ieor(ix,iy)), one) 	! Combine the two generators with masking to
						! ensure nonzero value

end function RandomN

real*8 function RandomGaussian(idum)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Returns a normally distributed deviate with
!	zero mean and unit variance, using RandomN(idum)
!	as the source of uniform deviates. To convert to a
!	normal distribution with standard deviation sigma,
!	multiply this function by sigma.
!
!	Taken from numerical recipes f77.
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, parameter ::	K4B=selected_int_kind(9)
	integer(K4B), intent(inout) :: 	idum
	real*8 ::	rsq, v1, v2, RandomN
	real*8, save :: gset
	external	RandomN
	logical, save :: gaus_stored = .false.

	if (idum < 0) gaus_stored = .false. 	! Reinitialize.

	if (gaus_stored) then
		RandomGaussian = gset
		gaus_stored = .false.
	else					! We don't have an extra deviate handy, so
		do				! pick two uniform numbers in the square
			v1 = RandomN(idum)		! extending from -1 to +1 in each direction,
			v2 = RandomN(idum)		! see if they are in the unit circle,
			v1 = 2.0d0*v1 -1.0d0	! and if they are not, try again.
			v2 = 2.0d0*v2 -1.0d0
			rsq = v1**2 + v2**2
			if (rsq > 0.0d0 .and. rsq < 1.0d0) exit
		enddo

		rsq = sqrt(-2.0d0*log(rsq)/rsq)		! Now make the Box-Muller transformation to get
							! two normal deviates. Return one and save
							! the other for next time.
		RandomGaussian = v1*rsq
		gset = v2*rsq
		gaus_stored = .true.
	endif

end function RandomGaussian


! { dg-do run }
program main
  implicit none
  real, dimension(2) :: a
  a(1) = 2.0
  a(2) = 3.0
  if (product (a, .false.) /= 1.0) call abort
  if (product (a, .true.) /= 6.0) call abort
  if (sum (a, .false.) /= 0.0) call abort
  if (sum (a, .true.) /= 5.0) call abort
  if (maxval (a, .true.) /= 3.0) call abort
  if (maxval (a, .false.) > -1e38) call abort
  if (maxloc (a, 1, .true.) /= 2) call abort
  if (maxloc (a, 1, .false.) /= 0) call abort ! Change to F2003 requirement.
end program main


! { dg-do run }
! Tests the fix for PR31229, PR31154 and PR33334, in which
! the KIND and TYPE parameters in the function declarations
! would cause errors.
!
! Contributed by Brooks Moses <brooks@gcc.gnu.org>
!           and Tobias Burnus <burnus@gcc.gnu.org>
!
module kinds
  implicit none
  integer, parameter :: dp = selected_real_kind(6)
  type t
     integer :: i
  end type t
  interface
    real(dp) function y()
      import
    end function
  end interface
end module kinds

type(t) function func() ! The legal bit of PR33334
  use kinds
  func%i = 5
end function func

real(dp) function another_dp_before_defined ()
  use kinds
  another_dp_before_defined = real (kind (4.0_DP))
end function

module mymodule;
contains
  REAL(2*DP) function declared_dp_before_defined()
    use kinds, only: dp
    real (dp) :: x
    declared_dp_before_defined = 1.0_dp
    x = 1.0_dp
    declared_dp_before_defined = real (kind (x))
  end function
end module mymodule

  use kinds
  use mymodule
  type(t), external :: func
  type(t) :: z
  if (kind (y ()) .ne. 4) call abort ()
  if (kind (declared_dp_before_defined ()) .ne. 8) call abort ()
  if (int (declared_dp_before_defined ()) .ne. 4) call abort ()
  if (int (another_dp_before_defined ()) .ne. 4) call abort ()
  z = func()
  if (z%i .ne. 5) call abort ()
end
! { dg-final { cleanup-modules "kinds mymodule" } }


! { dg-do  run }
! { dg-additional-options "-fno-realloc-lhs -ffrontend-optimize" }
! This used to segfault at runtime.
! Original test case by Harald Anlauf.
program gfcbug142
  implicit none
  real, allocatable :: b(:,:)
  integer :: n = 5
  character(len=20) :: line
  allocate (b(n,n))
  call random_number (b)
  write (unit=line,fmt='(2I5)') shape (matmul (b, transpose (b)))
  if (line /= '    5    5') STOP 1
end program gfcbug142


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.

!>    @brief preconditioner "dummy" routine, no preconditioning (copy instead)
!>    @param[in] N length of all vectors
!>    @param[in] r vector [r]
!>    @param[out] z vector [z]
!>    @details
!>    compute [z], the solution of [K]x[z]=[r]\n
!>    [K] is substitude from [A] and work as a preconditioner\n
!>    here simple example : only copy [z]:=[r]\n
      SUBROUTINE myprco(n,r,z)
        use mod_OMP_TOOLS
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'
!     N : length of all vectors r,z
        INTEGER n
!     vectors [r], [z]
        DOUBLE PRECISION r(*), z(*)
!     thread-stuff
        INTEGER tpos, tanz

        CALL omp_part(n,tpos,tanz)
!     very simple Pre-Cond.
        CALL dcopy(tanz,r(tpos),1,z(tpos),1)
        RETURN
      END

!>    @brief simple diagonal preconditioner
!>    @param[in] N length of all vectors
!>    @param[in] r vector [r]
!>    @param[in] D diagonal vector for preconditioning
!>    @param[out] z vector [z]
!>    @details
!>    compute [z], the solution of [K]x[z]=[r]\n
!>    [K] is substitude from [A] and work as a preconditioner\n
!>    here simple example : [z]:=[r]/[d]\n
      SUBROUTINE diagprco(n,d,r,z)
        use mod_OMP_TOOLS
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'
!     N : length of all vectors r,z
        INTEGER n, i
!     vectors [r], [z]
        DOUBLE PRECISION r(n), z(n), d(n)
!     thread-stuff
        INTEGER tpos, tanz

        CALL omp_part(n,tpos,tanz)
!     works if there are not NULL-elements in [D]
!     very simple Pre-Cond.
        DO i = tpos, tpos + tanz - 1
!AW        z(i)=r(i)/D(i)
          IF (d(i)/=0.0D0) z(i) = r(i)/d(i)
        END DO
        RETURN
      END


! Dynamical matrix diagonalization of HESSFREQ.DAT
! from CRYSTAL.
!
! Contributors: Alexandr Fonari (Georgia Tech)
! MIT license, 2013
!
!---------------------------------------------------------------------
! compile as:
!    gfortran -llapack -o hessfreq_read hessfreq_read.f90
!
! run as:
!    hessfreq_read HESSFREQ.DAT
! 'masses' file format:
!    natom (1 int)
!    atom 1 mass in amu (1 float)
!    atom 2 mass in amu (1 float)
!    ...
!    atom natom mass in amu (1 float)
!
program hessfreq_read
    implicit none
    ! parameters
    INTEGER, PARAMETER :: dp=SELECTED_REAL_KIND(10)
    REAL(DP), PARAMETER :: ELECTRONMASS_SI  = 9.10938215E-31_DP   ! Kg
    REAL(DP), PARAMETER :: AMU_SI           = 1.660538782E-27_DP  ! Kg
    REAL(DP), PARAMETER :: AMU_AU           = AMU_SI / ELECTRONMASS_SI
    REAL(DP), PARAMETER :: ZERO           = 0.0_DP
    ! output
    real(DP), allocatable :: mass(:)
    real(DP), allocatable :: fc(:,:)
    real(DP), allocatable :: w2(:), dyn(:)
    ! local
    real(DP), allocatable :: WORK(:)
    integer i, j, l, nat, na, INFO
    CHARACTER(LEN=100) :: hessfreq_fname, line, fmt
    !
    external DSYEV
    external DGEEV
    !
    i = IARGC()
    if (i < 1) THEN
        write(*,'(a)') "usage: hessfreq_read HESSFREQ.DAT"
        STOP
    endif
    CALL GETARG(1, hessfreq_fname)
    !
    open(unit=15,file='masses',status='OLD',form='formatted',ERR=1000, POSITION="REWIND")
    !
    read(15,*,ERR=147) nat
    write(*,'(A,I4,A)') 'Will be reading masses for ', nat, ' atoms'
    allocate(mass(nat))
    allocate(fc(nat*3, nat*3))
    allocate(w2(nat*3))
    allocate( dyn((nat*3)**2) )
    allocate( WORK((nat*3)**2) )
    !
    do i = 1, nat
      read(15,*) mass(i)
      write(*,'(A,I4,A,F7.3,A)') 'mass(',i,') = ', mass(i),' amu'
    enddo
    close(unit=15)
    !
    write(*,*) 'Parsing ', hessfreq_fname, '...'
    open(unit=15,file=hessfreq_fname,status='OLD',form='formatted',ERR=1001, POSITION="REWIND")
    !
    ! fancy way of reading HESSFREQ file
    ! the format of which is: FORMAT(1P,4E21.13)
    j = 1
    do
        fmt=''
        read(15,'(A)', end=100) line
        l = len_trim(line)
        write(fmt,'(A,I1,A)') '(1P,',l/21,'E21.13)'
        read(line,fmt) (dyn(i), i=j, j+l/21-1)
        j = j + l/21
        fmt=''
    enddo
100 CONTINUE
    close(15)
    !
    do i = 1, nat*3
        do j = 1, nat*3
            fc(j,i) = dyn(i + (j-1)*nat*3)
!            write(*,*) i, j, fc(j,i)
        enddo
    enddo
    !
    do i = 1, nat*3
        do j = 1, nat*3
            fc(i,j) = fc(i,j)/(AMU_AU*sqrt(mass((i-1)/3+1)*mass((j-1)/3+1)))
      enddo
    enddo
    !
    ! symmetrize
    do i = 1, nat*3
        do j = 1, nat*3
            fc(j,i) = fc(i,j)
      enddo
    enddo
    !
    call DSYEV( 'V', 'U', nat*3, fc, nat*3, w2, WORK, size(WORK), INFO )
    if (INFO /= 0) THEN
        write (*,*) "INFO from DSYEV: ", INFO
        STOP
    endif
    !
!  No reason to do it now
!
    write(*,*) 'Writing frequencies and eigenvectors to dynmat.eig file...'
    open(unit=15,file='dynmat.eig',status='UNKNOWN',form='formatted',ERR=1002, POSITION="REWIND")
    !call write_eigenvectors(nat, (/ ZERO, ZERO, ZERO /), w2, fc, 15)
    call writemodes(nat, w2, fc, 15)
    close(15)
!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    do i = 1,nat*3
       do na = 1,nat
          do j = 1,3
             fc((na-1)*3+j,i) = fc((na-1)*3+j,i) / sqrt(mass(na))
          end do
       end do
    end do
    !
    write(*,*) 'Writing eigenvalues (cm-1) and eigenvectors/SQRT(mass_amu) to hessfreq.modes file...'
    open(unit=15,file='hessfreq.modes',status='UNKNOWN',form='formatted',ERR=1002, POSITION="REWIND")
    call writemodes(nat, w2, fc, 15)
    close(15)
    !
    deallocate(mass)
    deallocate(fc)
    deallocate(w2)
    deallocate(WORK)
    !
    return

1000 CONTINUE
    WRITE(*,"(A)")'ERROR: file "masses" does not exist in the current directory'
    STOP

1001 CONTINUE
    WRITE(*,"(A,A)")'ERROR: the following file does not exist ', hessfreq_fname
    STOP

1002 CONTINUE
    WRITE(*,"(A,A)")'ERROR: access denied for writing ', 'hessfreq.modes'
    STOP

147 CONTINUE
    WRITE(*,*) 'Was expecting number of atoms in the first line of "masses" file.'
    STOP

end program

subroutine writemodes (nat, w2, z, iout)
    implicit none
    ! constants
    INTEGER, PARAMETER :: dp=SELECTED_REAL_KIND(10)
    REAL(DP), PARAMETER :: AU_CMM1          = 0.2194746E+06_DP
    REAL(DP), PARAMETER :: AU_TERAHERTZ     = AU_CMM1*0.2997925E-01_DP
    ! input
    integer nat, iout
    real(DP) w2(3*nat)
    real(DP) z(nat*3, nat*3)
    ! local
    integer nat3, na, ipol, i, j
    real(DP):: freq(3*nat)
    !
    nat3=3*nat
    !
    !  write frequencies and normalized displacements
    !
    write(iout,*) 'Frequencies and eigenvectors/SQRT(mass_amu)'
    !
    do i = 1,nat3
       !
       freq(i)= sqrt(abs(w2(i)))
       if (w2(i).lt.0.0_DP) freq(i) = -freq(i)
       !
       write (iout,9010) i, freq(i)*AU_CMM1
       do na = 1,nat
          write (iout,9020) (z((na-1)*3+ipol,i),ipol=1,3)
       end do
       !
    end do
    !
    return
    !
9010 format(5x, i3, 3x, f15.6, ' (cm-1)')
9020 format (3(f10.6,3x))
    !
end subroutine writemodes
!
subroutine write_eigenvectors (nat,q,w2,z,iout)
  !-----------------------------------------------------------------------
  !
  !   write modes on output file in a readable way
  !
  implicit none
  ! constants
  INTEGER, PARAMETER :: dp=SELECTED_REAL_KIND(10)
  REAL(DP), PARAMETER :: AU_CMM1          = 0.2194746E+06_DP
  REAL(DP), PARAMETER :: AU_TERAHERTZ     = AU_CMM1*0.2997925E-01_DP
  ! input
  integer nat, iout
  real(DP) q(3), w2(3*nat)
  real(DP) z(3*nat,3*nat)
  ! local
  integer nat3, na, nta, ipol, i, j
  real(DP):: freq(3*nat)
  !
  nat3=3*nat
  !
  !  write frequencies and phonon eigenvectors
  !
  write(iout,'(5x,''diagonalizing the dynamical matrix ...''/)')
  write(iout,'(1x,''q = '',3f12.4)') q
  write(iout,'(1x,74(''*''))')
  !
  do i = 1,nat3
     !
     freq(i)= sqrt(abs(w2(i)))
     if (w2(i) < 0.0) freq(i) = -freq(i)
     write (iout,9010) i, freq(i)*AU_TERAHERTZ, freq(i)*AU_CMM1
     do na = 1,nat
        write (iout,9020) ( CMPLX(z((na-1)*3+ipol,i)), ipol=1,3)
     end do
     !
  end do
  write(iout,'(1x,74(''*''))')
  !
  return
  !
9010 format(5x,'freq(',i5,') =',f15.6,' [THz] =',f15.6,' [cm-1]')
9020 format (1x,'(',3 (f10.6,1x,f10.6,3x),')')
  !
end subroutine write_eigenvectors


module nodal_newu_module

  use bl_constants_module
  use multifab_module

  implicit none

contains

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

    subroutine mkunew(unew,phi,coeff,dx,ng)

      type(multifab) , intent(inout) :: unew
      type(multifab) , intent(in   ) :: phi
      type(multifab) , intent(in   ) :: coeff
      real(kind=dp_t), intent(in   ) :: dx(:)
      integer        , intent(in   ) :: ng
      integer :: i,dm

      real(kind=dp_t), pointer :: up(:,:,:,:)
      real(kind=dp_t), pointer :: pp(:,:,:,:)
      real(kind=dp_t), pointer :: rp(:,:,:,:)

      dm = unew%dim

      do i = 1, nfabs(unew)
         up => dataptr(unew, i)
         pp => dataptr(phi, i)
         rp  => dataptr(coeff, i)
         select case (dm)
            case (1)
              call mkunew_1d(up(:,1,1,1), pp(:,1,1,1) ,rp(:,1,1,1), dx, ng)
            case (2)
              call mkunew_2d(up(:,:,1,:), pp(:,:,1,1) ,rp(:,:,1,1), dx, ng)
            case (3)
              call mkunew_3d(up(:,:,:,:), pp(:,:,:,1), rp(:,:,:,1), dx, ng)
         end select
      end do
      call multifab_fill_boundary(unew)

    end subroutine mkunew

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

    subroutine mkunew_1d(unew,phi,coeff,dx,ng)

      integer        , intent(in   ) :: ng
      real(kind=dp_t), intent(inout) :: unew(-ng:)
      real(kind=dp_t), intent(inout) :: phi(-1:)
      real(kind=dp_t), intent(in   ) :: coeff(-1:)
      real(kind=dp_t), intent(in   ) :: dx(:)

      ! Local variables
      integer         :: i,nx
      real(kind=dp_t) :: gpx

      nx = size(phi,dim=1)-3

      do i = 0,nx-1
         gpx     = (phi(i+1) - phi(i)) /dx(1)
         unew(i) = unew(i) - gpx * coeff(i)
      end do

    end subroutine mkunew_1d

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

    subroutine mkunew_2d(unew,phi,coeff,dx,ng)

      integer        , intent(in   ) :: ng
      real(kind=dp_t), intent(inout) :: unew(-ng:,-ng:,:)
      real(kind=dp_t), intent(inout) :: phi(-1:,-1:)
      real(kind=dp_t), intent(in   ) :: coeff(-1:,-1:)
      real(kind=dp_t), intent(in   ) :: dx(:)

      ! Local variables
      integer         :: i,j,nx,ny
      real(kind=dp_t) :: gpx,gpy

      ! Local variables
      nx = size(phi,dim=1)-3
      ny = size(phi,dim=2)-3

      do j = 0,ny-1
      do i = 0,nx-1
         gpx = HALF*(phi(i+1,j) + phi(i+1,j+1) - &
                     phi(i  ,j) - phi(i  ,j+1) ) /dx(1)
         gpy = HALF*(phi(i,j+1) + phi(i+1,j+1) - &
                     phi(i,j  ) - phi(i+1,j  ) ) /dx(2)
         unew(i,j,1) = unew(i,j,1) - gpx * coeff(i,j)
         unew(i,j,2) = unew(i,j,2) - gpy * coeff(i,j)
      end do
      end do

    end subroutine mkunew_2d

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

    subroutine mkunew_3d(unew,phi,coeff,dx,ng)

      integer        , intent(in   ) :: ng
      real(kind=dp_t), intent(inout) :: unew(-ng:,-ng:,-ng:,:)
      real(kind=dp_t), intent(inout) :: phi(-ng:,-ng:,-ng:)
      real(kind=dp_t), intent(in   ) :: coeff(-1:,-1:,-1:)
      real(kind=dp_t), intent(in   ) :: dx(:)

      ! Local variables
      integer         :: nx,ny,nz,i,j,k
      real(kind=dp_t) :: gpx,gpy,gpz,ivdx,ivdy,ivdz

      nx = size(phi,dim=1)-3
      ny = size(phi,dim=2)-3
      nz = size(phi,dim=3)-3

      ivdx = ONE / dx(1)
      ivdy = ONE / dx(2)
      ivdz = ONE / dx(3)

      !$OMP PARALLEL DO PRIVATE(i,j,k,gpx,gpy,gpz)
      do k = 0,nz-1
         do j = 0,ny-1
            do i = 0,nx-1
               gpx = FOURTH* &
                    (phi(i+1,j,k  ) + phi(i+1,j+1,k  ) &
                    +phi(i+1,j,k+1) + phi(i+1,j+1,k+1) &
                    -phi(i  ,j,k  ) - phi(i  ,j+1,k  ) &
                    -phi(i  ,j,k+1) - phi(i  ,j+1,k+1) ) * ivdx
               gpy = FOURTH* &
                    (phi(i,j+1,k  ) + phi(i+1,j+1,k  ) &
                    +phi(i,j+1,k+1) + phi(i+1,j+1,k+1) &
                    -phi(i,j  ,k  ) - phi(i+1,j  ,k  ) &
                    -phi(i,j  ,k+1) - phi(i+1,j  ,k+1) ) * ivdy
               gpz = FOURTH* &
                    (phi(i,j  ,k+1) + phi(i+1,j  ,k+1) &
                    +phi(i,j+1,k+1) + phi(i+1,j+1,k+1) &
                    -phi(i,j  ,k  ) - phi(i+1,j  ,k  ) &
                    -phi(i,j+1,k  ) - phi(i+1,j+1,k  ) ) * ivdz

               unew(i,j,k,1) = unew(i,j,k,1) - gpx * coeff(i,j,k)
               unew(i,j,k,2) = unew(i,j,k,2) - gpy * coeff(i,j,k)
               unew(i,j,k,3) = unew(i,j,k,3) - gpz * coeff(i,j,k)
            end do
         end do
      end do
      !$OMP END PARALLEL DO

    end subroutine mkunew_3d

end module nodal_newu_module


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE COSQT (M,TABLE)
      IMPLICIT NONE
C
C Purpose: Generate quarter-length cosine table
C
      REAL    TABLE(513)
      INTEGER M
C
C TABLE  : Cosine table
C M      : Power of FFT
C
C Calls   0:
C Called by: FRWFFT , INVFFT
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    SCL,TWOPI,THETA
      INTEGER NPT,ND4P1,I
C
C SCL    : Scale factor
C TWOPI  : 2*PI
C THETA  : Angle
C NPT    : Nos. of points
C ND4P1  : Nos. of pts/2 plus 1
C
      DATA TWOPI/6.283185307/
C
C-----------------------------------------------------------------------
      NPT=2**M
      ND4P1=NPT/4+1
      SCL=TWOPI/REAL(NPT)
      DO 10 I=1,ND4P1
         THETA=REAL(I-1)*SCL
         TABLE(I)=COS(THETA)
 10   CONTINUE
      RETURN
      END