module local_routines
    !!
    !! NTHMP benchmark problem 9 -- Okushiri tsunami field test case
    !!

    use global_mod, only: dp, ip, charlen, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use read_raster_mod, only: multi_raster_type
    use logging_mod, only: log_output_unit
    implicit none

    contains

    subroutine set_initial_conditions_BP09(domain)
        class(domain_type), target, intent(inout):: domain
        integer(ip):: i, j
        character(len=charlen):: input_elevation(6), input_stage(1)
        real(dp), allocatable:: x(:), y(:)
        type(multi_raster_type):: elevation_data, stage_data
        real(dp), allocatable :: random_uniform(:)
        ! Use this to check the effect of very small perturbations of the initial condition
        ! Eventually  a tiny perturbation will lead to differences in the results. This seems comparable
        ! to the differences that eventually emerge in DEFAULT openmp/coarray versions, which seem
        ! to begin with differences of this order in elevation/stage. That case is due to differences in
        ! domain partitioning, and can be eliminated by providing a load_balance_partition.txt file
        real(dp), parameter :: random_perturbation_scale = 0.0e-10_dp

        ! Stage
        domain%U(:,:,STG) = 0.0e-0_dp

        ! Input rasters
        input_stage(1) = "../test_repository/BP09-FrankG-Okushiri_island/initial_condition_raster/HNO1993.tif"
        call stage_data%initialise(input_stage)

        ! Preference order for elevation: input_elevation(1) > input_elevation(2) > .... > input_elevation(6)
        input_elevation(6) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/OK24.tif"
        input_elevation(5) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/OK08.tif"
        input_elevation(4) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/OK03.tif"
        input_elevation(3) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/MO01.tif"
        input_elevation(2) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/AO15.tif"
        input_elevation(1) = "../test_repository/BP09-FrankG-Okushiri_island/bathymetry_rasters_continuous/MB05.tif"
        call elevation_data%initialise(input_elevation)

        ! Make space for x/y coordinates, at which we will look-up the rasters
        allocate(x(domain%nx(1)), y(domain%nx(1)))
        x = domain%x

        allocate(random_uniform(domain%nx(1)))

        ! Set stage and elevation row-by-row.
        do j = 1, domain%nx(2)
            y = domain%y(j)

            ! Set stage - and clip 'NA' regions (since the stage raster does no cover the entire domain)
            call stage_data%get_xy(x,y, domain%U(:,j,STG), domain%nx(1), bilinear=1_ip, na_below_limit=-1.0e+20_dp)
            where(domain%U(:,j,STG) <= -1.0e+20_dp ) domain%U(:,j,STG) = 0.0_dp

            ! Set elevation -- no need to clip NA.
            call elevation_data%get_xy(x,y, domain%U(:,j,ELV), domain%nx(1), bilinear=1_ip)

            ! Here we can experiment with the random perturbation
            call random_number(random_uniform)
            domain%U(:,j,STG) = domain%U(:,j,STG) + random_perturbation_scale * (random_uniform-0.5_dp)
            call random_number(random_uniform)
            domain%U(:,j,ELV) = domain%U(:,j,ELV) + random_perturbation_scale * (random_uniform-0.5_dp)

        end do
        call elevation_data%finalise()
        call stage_data%finalise()

        if(domain%timestepping_method == 'cliffs') then
            call domain%smooth_elevation(smooth_method = 'cliffs')
        end if

        !call domain%smooth_elevation()

        deallocate(x,y, random_uniform)

        !print*, 'CONSTANT ELEVATION FOR TESTING'
        !domain%U(:,:, ELV) = -20.0_dp

        if(domain%timestepping_method /= 'linear') then
            domain%manning_squared = 0.02_dp * 0.02_dp !0.0_dp !0.025_dp * 0.025_dp
        else
            ! Clip depths in linear solver, to avoid 'stage below the bed'
            where(domain%U(:,:,ELV) < 0.0_dp .and. domain%U(:,:,ELV) > -5.0_dp) domain%U(:,:,ELV) = -5.0_dp
        end if

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

        !write(log_output_unit,*) 'DEBUG: SETTING STAGE TO ZERO'
        !domain%U(:,:,STG) = max(0.0_dp, domain%U(:,:,ELV) + 1.0e-07_dp)

        write(log_output_unit,*) 'Stage range is: ', minval(domain%U(:,:,STG)), maxval(domain%U(:,:,STG))
        write(log_output_unit,*) 'Elev range is: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

    end subroutine

end module

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

program BP09
    !!
    !! NTHMP benchmark problem 9 -- Okushiri tsunami field test case
    !!

    use global_mod, only: ip, dp, minimum_allowed_depth, charlen, default_nonlinear_timestepping_method,&
        default_linear_timestepping_method
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type, setup_multidomain, test_multidomain_mod
    use boundary_mod, only: flather_boundary, transmissive_boundary
    use local_routines
    use timer_mod
    use logging_mod, only: log_output_unit, send_log_output_to_file
    use stop_mod, only: generic_stop
    use iso_c_binding, only: C_DOUBLE !, C_INT, C_LONG
    use coarray_intrinsic_alternatives, only : swals_mpi_init, swals_mpi_finalize

    implicit none

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

    ! Local timing object
    type(timer_type) :: program_timer

    ! Increase mesh_refine to decrease the cell size (i.e. for convergence testing)
    real(dp), parameter :: mesh_refine = 0.4_dp ! Good for more efficient testing
    !real(dp), parameter :: mesh_refine = 1.0_dp ! Standard

    ! Optionally put a "very high res" domain around monai. Slows things down and the code requires care
    ! If this is true, then also use "mesh_refine = 1.0_dp"
    !logical, parameter:: very_high_res_monai = .true.
    logical, parameter:: very_high_res_monai = .false.

    ! If using very high res domain, then reduce the entire model timestep when it becomes active
    real(dp), parameter :: very_high_res_timestep_reduction = 10.0_dp
    ! Assume(require) the very high res domain is dry before this time. If not set correctly, expect the wrong answer!
    real(dp), parameter :: very_high_res_static_before_time = 235.0_dp

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 7.50_dp !0.6_dp * (1.0_dp/0.4_dp ) * 1.0_dp/3.0_dp!7.50_dp
    real(dp), parameter :: final_time = 3600.0_dp * 1.0_dp
    !real(dp), parameter :: final_time = 30.0_dp * 1.0_dp
    !real(dp), parameter :: approximate_writeout_frequency = 0.2_dp
    !real(dp), parameter :: final_time = 10.0_dp

    ! Length/width
    real(dp), parameter, dimension(2):: global_lw = [3.9_dp, 4.6_dp]
    ! Lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = [137.6_dp, 39.6_dp]
    ! grid size (number of x/y cells). Note that dx is in lon/lat, so an increment of dx(1) is smaller than dx(2)
    integer(ip), parameter, dimension(2):: global_nx = nint(global_lw*[77, 100]*1.12_dp*mesh_refine)

    ! Refinement factor for domains
    integer(ip), parameter :: nest_ratio = 5_ip
    ! The global (i.e. outer-domain) time-step in the multidomain
    real(dp) ::  global_dt = 0.60_dp * (1.0_dp/mesh_refine) * (1.0_dp / 3.0_dp)

    ! Useful misc variables
    integer(ip):: j, nd

    call swals_mpi_init()

    call program_timer%timer_start('setup')

#ifndef SPHERICAL
    write(log_output_unit,*) 'Code assumes spherical coordinates, but SPHERICAL is not defined'
    call generic_stop
#endif

    ! nd domains in this model
    if(very_high_res_monai) then
        ! In this case we put a 30cm x 30cm cell domain around the monai inundation peak (with mesh_refine=1.0_dp)
        !
        ! It leads to a peak of > 30.0m with mesh_refine=1.0_dp (vs 31.7 obs, although the latter varies depending on which
        ! dataset is used).
        !
        ! The model needs various modifications to do this stably, and it takes more than twice as long.
        !
        ! Keep in mind the poor quality bathymetry, the steep slopes (making SWE
        ! questionable), highly localised nature of the runup-peak, and low quality observations.
        ! While the result is good, there are many ways in which to question it.
        nd = 7
    else
        ! This case has a domain res ~ 1.5x1.5m around the monai inundation peak (with mesh_refine = 1.0_dp)
        !
        ! It leads to a peak of >28.0m with mesh_refine=1.0_dp (vs 31.7 obs, although the latter varies depending on which
        ! dataset is used). So the very_high_res_monai case does better.
        !
        ! Keep in mind the poor quality bathymetry, the steep slopes (making SWE
        ! questionable), highly localised nature of the runup-peak, and low quality observations.
        ! While the result is good, there are many ways in which to question it.
        nd = 6
    end if

    allocate(md%domains(nd))

    ! Need to provide a load_balance_partition.txt file to get exact reproducibility in openmp/coarray
    call get_command_argument(1, md%load_balance_file)

    !
    ! Setup basic metadata
    !

    ! Linear domain
    md%domains(1)%lw = global_lw
    md%domains(1)%lower_left =global_ll
    md%domains(1)%nx = global_nx
    md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
    md%domains(1)%dx_refinement_factor = 1.0_dp
    md%domains(1)%timestepping_refinement_factor = 1_ip
    md%domains(1)%timestepping_method = default_linear_timestepping_method
    md%domains(1)%cliffs_minimum_allowed_depth = 5.0_dp

    ! Higher res around region of interest
    call md%domains(2)%match_geometry_to_parent(&
        parent_domain=md%domains(1), &
        lower_left  = [139.2_dp, 41.5_dp], &
        upper_right = [140.5_dp, 43.5_dp], &
        dx_refinement_factor = nest_ratio, &
        timestepping_refinement_factor = 1_ip)
    md%domains(2)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(2)%cliffs_minimum_allowed_depth = 2.0_dp

    ! Okushiri Island focus
    call md%domains(3)%match_geometry_to_parent(&
        parent_domain=md%domains(2), &
        lower_left  = [139.3_dp, 41.95_dp], &
        upper_right = [139.6_dp, 42.26_dp], &
        dx_refinement_factor = nest_ratio, &
        timestepping_refinement_factor = 2_ip)
    md%domains(3)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(3)%cliffs_minimum_allowed_depth = 1.0_dp

    ! The monai domain
    call md%domains(4)%match_geometry_to_parent(&
        parent_domain=md%domains(3), &
        lower_left  = [139.38_dp, 42.0828_dp], &
        upper_right = [139.44_dp, 42.11592_dp], &
        dx_refinement_factor = nest_ratio, &
        timestepping_refinement_factor = 6_ip,&
        rounding_method='nearest')
    md%domains(4)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(4)%cliffs_minimum_allowed_depth = 1.0_dp

    ! A more detailed Monai domain
    call md%domains(5)%match_geometry_to_parent(&
        parent_domain=md%domains(4), &
        lower_left  = [139.4150_dp, 42.0968_dp], &
        upper_right = [139.4264_dp, 42.1020_dp], &
        dx_refinement_factor = nest_ratio, &
        timestepping_refinement_factor = 6_ip,&
        rounding_method='nearest')
    md%domains(5)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(5)%cliffs_minimum_allowed_depth = 0.2_dp

    ! The Aonae domain
    call md%domains(6)%match_geometry_to_parent(&
        parent_domain=md%domains(3), &
        lower_left  = [139.440_dp, 42.030_dp], &
        upper_right = [139.5_dp, 42.070_dp], &
        dx_refinement_factor = nest_ratio, &
        timestepping_refinement_factor = 2_ip,&
        rounding_method = 'nearest')
    md%domains(6)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(6)%cliffs_minimum_allowed_depth = 0.2_dp

    if(very_high_res_monai) then
        ! An even more detailed Monai domain
        call md%domains(7)%match_geometry_to_parent(&
            parent_domain=md%domains(5), &
            !lower_left  = [139.4176_dp, 42.0935_dp], &
            lower_left  = [139.4230_dp, 42.09896_dp], &
            !upper_right = [139.4299_dp, 42.1046_dp], &
            upper_right = [139.4254_dp, 42.09995_dp], &
            dx_refinement_factor = nest_ratio, &
            timestepping_refinement_factor = 6_ip,&
            rounding_method='nearest')
        ! Older versions of the code needed euler for stability. Does it still?
        md%domains(7)%timestepping_method = 'euler'
        ! Should be dry before this time -- note also we change the time-step
        ! in the evolve loop on the basis of this value
        md%domains(7)%static_before_time = very_high_res_static_before_time
    end if

    !do j = 1, size(md%domains)
    !    ! Nearly turn off limiting
    !    md%domains(j)%theta = 4.0_dp
    !end do

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

    call md%memory_summary()

    ! Give boundary condition to domans that have non-nesting boundaries
    do j = 1, size(md%domains)
        if(any(.not.md%domains(j)%is_nesting_boundary)) md%domains(j)%boundary_subroutine => flather_boundary
    end do

    ! Set initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions_BP09(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()

    write(log_output_unit,*) 'End setup'

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

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

    flush(log_output_unit)

    !
    ! Evolve the code
    !

    do while (.true.)

        ! Print and write outputs each time-interval of "approximate_writeout_frequency"
        call md%write_outputs_and_print_statistics(&
            approximate_writeout_frequency=approximate_writeout_frequency, &
            write_grids_less_often = 1_ip, &
            write_gauges_less_often = 1_ip, &
            print_less_often = 1_ip,&
            timing_tol = 1.0e-06_dp)

        ! Finish looping at some point
        if (md%domains(1)%time > final_time) exit

        if(very_high_res_monai) then
            ! Take a different time step once the high res domain starts evolving.
            ! This will introduce a (formal) first-order error into the linear leap-frog scheme,
            ! because that requires a fixed time step, but only at the change in time point.
            ! But practically no problem (?).
            if(md%domains(1)%time < md%domains(7)%static_before_time) then
                call md%evolve_one_step(global_dt)
            else
                call md%evolve_one_step(global_dt/very_high_res_timestep_reduction)
            end if
        else
            ! Regular case
            call md%evolve_one_step(global_dt)
        end if

    end do

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

    write(log_output_unit,*) ''
    write(log_output_unit, *) 'Program timer'
    write(log_output_unit, *) ''
    call program_timer%print(log_output_unit)

    call swals_mpi_finalize()
end program


      subroutine dgefa(gmmatr,kmax,kdim,ipivot,info)
c
c     This subroutine factors the real*8 array gmmatr, using the method
c     of L-U decomposition. It is an adaptation of the 1979 Linpack
c     subroutine of the same name. The size and order of the original
c     calling sequence has been preserved:
c     (a,lda,n,ipvt,info) = (gmmatr,kmax,kdim,ipivot,info)
c
c     Note: detection of singularity using the test corresponding to
c     the condition info = -1 was not implemented in the original
c     Linpack version of the subroutine and may be missing from other
c     modern equivalents.
c
c     This subroutine uses the following pseudo-Linpack BLAS (Basic
c     Linear Algebra Subsystem) subroutines:
c
c       EQLIBU/idamax.f
c       EQLIBU/daxpy.f
c       EQLIBU/dscal.f
c
c     This subroutine is called by:
c
c       EQLIBU/msolvr.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       gmmatr = the matrix (unfactored)
c       kmax   = the declared (maximum) dimension of the matrix
c       kdim   = the used dimension of the matrix
c       ipivot = the pivot vector (used by EQLIBU/dgesl.f)
c
c     Output:
c
c       gmmatr = the matrix, factored
c       info   = error flag:
c                  = -1      singularity
c                  =  0      no singularity
c                  =  k > 0  singularity
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax
      integer info,kdim
c
      integer ipivot(kmax)
c
      real*8 gmmatr(kmax,kmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer j,k,kp1,il
      integer idamax
c
      real*8 adiv,div,tx
c
c-----------------------------------------------------------------------
c
c     Gaussian elimination with partial pivoting.
c
      info = 0
      if (kdim .ge. 2) then
        do k = 1,kdim - 1
        kp1 = k + 1
c
c       Find il = pivot index.
c
        il = idamax(kdim - k + 1,gmmatr(k,k),1) + k - 1
        ipivot(k) = il
c
c       Zero pivot implies this column already triangularized.
c
        if (gmmatr(il,k) .ne. 0.) then
c
c         Interchange if necessary.
c
          if (il .ne. k) then
            tx = gmmatr(il,k)
            gmmatr(il,k) = gmmatr(k,k)
            gmmatr(k,k) = tx
          endif
c
c         Compute multipliers.
c
          div = gmmatr(k,k)
c
c         Test for potential zero divide.
c
          adiv=abs(div)
          if (adiv.le.0.) then
            info = -1
            go to 999
          endif
          tx = -1./div
          call dscal(kdim - k,tx,gmmatr(k + 1,k),1)
c
c         Row elimination with column indexing.
c
          do j = kp1,kdim
            tx = gmmatr(il,j)
            if (il .ne. k) then
              gmmatr(il,j) = gmmatr(k,j)
              gmmatr(k,j) = tx
            endif
            call daxpy(kdim - k,tx,gmmatr(k + 1,k),1,gmmatr(k + 1,j),1)
          enddo
          go to 100
        endif
        info = k
  100   continue
      enddo
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      ipivot(kdim) = kdim
      if (gmmatr(kdim,kdim) .eq. 0.) info = kdim
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


! Copyright (c) 2012, Johannes Feist
! licensed under the MIT open source license, see LICENSE file

program printlaserfourier
  use laserfields
  implicit none
  integer :: i_field
  character(len=200) :: parfile

  parfile = 'laserfields.in'
  if (command_argument_count() >= 1) then
     call get_command_argument(1,parfile)
  end if

  call laserfields_read_parameters(trim(parfile))

  if (.not.laserfields_can_get_fourier()) then
     write(0,*) 'error: can not get analytical fourier transform for these laser fields. stopping!'
     stop 733
  end if

  write(6,'(3a)') 'ffall(w) = ',trim(get_el_fourier_transform_string()),';'
  do i_field = 1, n_laserfields
     write(6,'(a,i2.2,3a)') 'ff_',i_field,'(w) = ',trim(get_el_fourier_transform_string(all_laserfields(i_field))),';'
  end do

end program printlaserfourier


c     /* ********************************************************* *
c                 Effective Vector Boson Approximation
c     /* ********************************************************* *
c     File: ElectroweakFlux.f
c     R. Ruiz (2021 February)
c     For details, see companion paper by ..., et al [arXiv:]
c     /* ********************************************************* *
c     /* ********************************************************* *
c     function eva_fX_to_vV(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo):
c     call electroweak PDF for for vector boson (hel=V=0,+,-) from fermion
c     with fractional (0<pol<1) LH (RH) polarization of fLpol (1-fLpol)
c     - fLpol = 0.5d0 = parent fermion is spin-averaged
c     /* ********************************************************* *
c     /* ********************************************************* *
c     function eva_fF_to_vV(gg2,gF2,mv2,x,mu2,ievo):
c     electroweak PDF for vector boson (hel=V=0,+,-) from fermion (hel=F=L/R)
c     - gg2 = (coupling)^2
c     - gF2 = (L/R chiral coupling)^2
c     - mv2 = (mass of boson)^2
c     - x = momentum fraction = (E_V / E_f)
c     - mu2 = (max of evolution scale)^2
c     - ievo = for evolution by virtuality (or !=0 for pT)
c     /* ********************************************************* *
c     /* ********************************************************* *
c     /* ********************************************************* *
c     /* ********************************************************* *
      double precision function eva_fX_to_vp(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo)
      implicit none
      integer ievo
      double precision gg2,gL2,gR2,fLpol,mv2,x,mu2
      double precision eva_fL_to_vp,eva_fR_to_vp

      eva_fX_to_vp =       fLpol*eva_fL_to_vp(gg2,gL2,mv2,x,mu2,ievo)
     &             + (1d0-fLpol)*eva_fR_to_vp(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
      double precision function eva_fX_to_vm(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo)
      implicit none
      integer ievo
      double precision gg2,gL2,gR2,fLpol,mv2,x,mu2
      double precision eva_fL_to_vm,eva_fR_to_vm

      eva_fX_to_vm =       fLpol*eva_fL_to_vm(gg2,gL2,mv2,x,mu2,ievo)
     &             + (1d0-fLpol)*eva_fR_to_vm(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
      double precision function eva_fX_to_v0(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo)
      implicit none
      integer ievo
      double precision gg2,gL2,gR2,fLpol,mv2,x,mu2
      double precision eva_fL_to_v0,eva_fR_to_v0

      eva_fX_to_v0 =       fLpol*eva_fL_to_v0(gg2,gL2,mv2,x,mu2,ievo)
     &             + (1d0-fLpol)*eva_fR_to_v0(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
      double precision function eva_fX_to_fL(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo)
      implicit none
      integer ievo
      double precision gg2,gL2,gR2,fLpol,mv2,x,mu2
      double precision eva_fL_to_fL,eva_fR_to_fL

      eva_fX_to_fL =       fLpol*eva_fL_to_fL(gg2,gL2,mv2,x,mu2,ievo)
     &             + (1d0-fLpol)*eva_fR_to_fL(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
      double precision function eva_fX_to_fR(gg2,gL2,gR2,fLpol,mv2,x,mu2,ievo)
      implicit none
      integer ievo
      double precision gg2,gL2,gR2,fLpol,mv2,x,mu2
      double precision eva_fL_to_fR,eva_fR_to_fR

      eva_fX_to_fR =       fLpol*eva_fL_to_fR(gg2,gL2,mv2,x,mu2,ievo)
     &             + (1d0-fLpol)*eva_fR_to_fR(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
c     EVA (1/6) for f_L > v_+
      double precision function eva_fL_to_vp(gg2,gL2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gL2,mv2,x,mu2
      double precision coup2,split,xxlog,fourPiSq
      data fourPiSq/39.47841760435743d0/ ! = 4pi**2

c      print*,'gg2,gL2,mv2,x,mu2,ievo',gg2 !3,gL2,mv2,x,mu2,ievo
      coup2 = gg2*gL2/fourPiSq
      split = (1.d0-x)**2 / 2.d0 / x
      if(ievo.eq.0) then
         xxlog = dlog(mu2/mv2)
      else
         xxlog = dlog(mu2/mv2/(1.d0-x))
      endif

      eva_fL_to_vp = coup2*split*xxlog
      return
      end
c     /* ********************************************************* *
c     EVA (2/6) for f_L > v_-
      double precision function eva_fL_to_vm(gg2,gL2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gL2,mv2,x,mu2
      double precision coup2,split,xxlog,fourPiSq
      data fourPiSq/39.47841760435743d0/ ! = 4pi**2

      coup2 = gg2*gL2/fourPiSq
      split = 1.d0 / 2.d0 / x
      if(ievo.eq.0) then
         xxlog = dlog(mu2/mv2)
      else
         xxlog = dlog(mu2/mv2/(1.d0-x))
      endif

      eva_fL_to_vm = coup2*split*xxlog
      return
      end
c     /* ********************************************************* *
c     EVA (3/6) for f_L > v_0
      double precision function eva_fL_to_v0(gg2,gL2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gL2,mv2,x,mu2
      double precision coup2,split,xxlog,fourPiSq
      data fourPiSq/39.47841760435743d0/ ! = 4pi**2
c
      coup2 = gg2*gL2/fourPiSq
      split = (1.d0-x) / x
      xxlog = 1.d0

      eva_fL_to_v0 = coup2*split*xxlog
      return
      end
c     /* ********************************************************* *
c     EVA (4/6) for f_R > v_+
      double precision function eva_fR_to_vp(gg2,gR2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gR2,mv2,x,mu2
      double precision eva_fL_to_vm

      eva_fR_to_vp = eva_fL_to_vm(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
c     EVA (5/6) for f_R > v_-
      double precision function eva_fR_to_vm(gg2,gR2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gR2,mv2,x,mu2
      double precision eva_fL_to_vp

      eva_fR_to_vm = eva_fL_to_vp(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
c     EVA (6/6) for f_R > v_0
      double precision function eva_fR_to_v0(gg2,gR2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gR2,mv2,x,mu2
      double precision eva_fL_to_v0

      eva_fR_to_v0 = eva_fL_to_v0(gg2,gR2,mv2,x,mu2,ievo)
      return
      end
c     /* ********************************************************* *
c     EVA () for f_L > f_L
c     fL_to_fL(z) = fL_to_vp(1-z) + fL_to_vm(1-z)
      double precision function eva_fL_to_fL(gg2,gL2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gL2,mv2,x,mu2
      double precision tmpVp,tmpVm,z
      double precision eva_fL_to_vp,eva_fL_to_vm

      z = 1.d0 - x
      tmpVp = eva_fL_to_vp(gg2,gL2,mv2,z,mu2,ievo)
      tmpVm = eva_fL_to_vm(gg2,gL2,mv2,z,mu2,ievo)

      eva_fL_to_fL = tmpVp + tmpVm
      return
      end
c     /* ********************************************************* *
c     EVA () for f_R > f_R
c     fR_to_fR(z) = fR_to_vp(1-z) + fR_to_vm(1-z)
      double precision function eva_fR_to_fR(gg2,gR2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gR2,mv2,x,mu2
      double precision tmpVp,tmpVm,z
      double precision eva_fR_to_vp,eva_fR_to_vm

      z = 1.d0 - x
      tmpVp = eva_fR_to_vp(gg2,gR2,mv2,z,mu2,ievo)
      tmpVm = eva_fR_to_vm(gg2,gR2,mv2,z,mu2,ievo)

      eva_fR_to_fR = tmpVp + tmpVm
      return
      end
c     /* ********************************************************* *
c     EVA () for f_L > f_R
      double precision function eva_fL_to_fR(gg2,gL2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gL2,mv2,x,mu2

      eva_fL_to_fR = 0d0
      return
      end
c     /* ********************************************************* *
c     EVA () for f_R > f_L
      double precision function eva_fR_to_fL(gg2,gR2,mv2,x,mu2,ievo)
      implicit none
      integer ievo              ! evolution by q2 or pT2
      double precision gg2,gR2,mv2,x,mu2

      eva_fR_to_fL = 0d0
      return
      end
c     /* ********************************************************* *


C++**************************************************************************
C Program HISTO to compute histograms of lines from an image
C Written by AW, JLP (Manchester 87)
C
C JLP
C Version of 04-06-00
C--**************************************************************************
	PROGRAM HISTO
	INTEGER*4 NX,NY,NBINS,IX1,IX2,IY1,IY2
        REAL*4 XMIN,XMAX
	CHARACTER PLOTDEV*32,ANS*1,NAME*40,COMMENTS*80
	INTEGER*4 MADRID(1),IPTR
	COMMON /VMR/MADRID

10	FORMAT(A)

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

	WRITE(6,3)
3	FORMAT(' Program HISTO, Version of 04-06-00',/,
     1	' Displays the histogram of a line or a column of an image')

C Reading the image :
	PRINT *,' Enter the name of the file :'
	READ(5,10) NAME
	CALL JLP_VM_READIMAG(IPTR,NX,NY,NAME,COMMENTS)

C Drawing the histogram of a line :
 	WRITE(6,17)
17	FORMAT(' Enter the boundaries: IX1,IX2,IY1,IY2 (between 1,1 and NX,NY)')
	READ(5,*) IX1,IX2,IY1,IY2
	IF((IX1.LT.0).OR.(IX2.GT.NX).OR.(IY1.LT.0).OR.(IY2.GT.NY))THEN
	   WRITE(6,*)' Fatal error/Wrong values, outside boundaries.'
           STOP
	ENDIF

C Enter the number of bins :
	PRINT *,' Enter min, max and the number of bins (less than 2000)'
	PRINT *,' (enter (0,0) for min, max if automatic scale is wanted): '
	READ(5,*) XMIN,XMAX,NBINS
        IF(NBINS.GT.2000)THEN
        WRITE(6,*)' Fatal error, NBINS > 2000'
        STOP
        ENDIF

C Select the output device for the display :
	PRINT *,' Enter the device for displaying the histogram :'
	READ(5,10) PLOTDEV

	CALL HISTO1(MADRID(IPTR),NX,NY,IX1,IX2,IY1,IY2,
     1              XMIN,XMAX,NBINS,PLOTDEV,NAME)

C End:
	CALL JLP_END
	STOP
	END

C**************************************************************************
C Main part of HISTO :
C
C**************************************************************************
	SUBROUTINE HISTO1(IMAGE,NX,NY,IX1,IX2,IY1,IY2,
     1                    XMIN,XMAX,NBINS,PLOTDEV,NAME)
	PARAMETER (IDIM=2000)
	REAL*4 XPLOT(IDIM),YPLOT(IDIM)
	REAL*4 IMAGE(NX,NY),XMIN,XMAX
        INTEGER*4 IX1,IX2,IY1,IY2
	CHARACTER NAME*30
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,PLOTDEV*32

C Common block with NEWPLOT :
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT

C Calling HISTO2 :
	CALL HISTO2(IMAGE,NX,NY,IX1,IX2,IY1,IY2,XPLOT,YPLOT,
     1              XMIN,XMAX,NBINS)

C Displaying the histogram :
	  CHAR1='Level'
	  CHAR2='Number of pixels'
	  WRITE(TITLE,28)NAME(1:20),IX1,IX2,IY1,IY2
28	  FORMAT(A20,4(1X,I4))

	  CALL DISPLAY1(XPLOT,YPLOT,1,NBINS,CHAR1,CHAR2,TITLE,PLOTDEV)
	  IF(NOUT.NE.0)THEN
	   DO I=1,NOUT
	    PRINT *,' X, Y :',XOUT(I),YOUT(I)
	   END DO
	  ENDIF

	RETURN
	END
C**************************************************************************
*  Compute histogram of nbins from IMAGE array
*
* Input:
*     image   real array
*     nbins   integer          no of bins required
*
* Output:
*   XPLOT, YPLOT
C*****************************************************************************
	SUBROUTINE HISTO2(IMAGE,NX,NY,IX1,IX2,IY1,IY2,XPLOT,YPLOT,
     1                    XMIN,XMAX,NBINS)
	PARAMETER (IDIM=2000)
	REAL*4 IMAGE(NX,NY),XPLOT(*),YPLOT(*),V
	INTEGER*4 IX,IY,IB,IX1,IX2,IY1,IY2,IHIST(IDIM)
        CHARACTER NAME*60,COMMENTS*80

*
* Check that histogram array is clear:
	DO IB=1,NBINS
	   IHIST(IB)=0
	END DO
*
* Determine bin interval
        IF(XMIN.EQ.-1..AND.XMAX.EQ.-1.)THEN
	XMIN=IMAGE(IX1,IY1)
	XMAX=IMAGE(IX1,IY1)
	DO IY=IY1,IY2
	DO IX=IX1,IX2
	  V=IMAGE(IX,IY)
	  XMAX=AMAX1(V,XMAX)
	  XMIN=AMIN1(V,XMIN)
	END DO
	END DO
        write(6,*) 'Automatic scale: min/max',xmax,xmin
        ENDIF

C Compute the histogram now:
	XBIN=(XMAX-XMIN)/REAL(NBINS)

	DO IY=IY1,IY2
	DO IX=IX1,IX2
	  V=IMAGE(IX,IY)
	   IBIN=INT((V-XMIN)/XBIN)+1
	   IHIST(IBIN)=IHIST(IBIN)+1
	END DO
	END DO
        OPEN(9,NAME='histo.dat',STATUS='unknown',ACCESS='sequential')
	DO IB=1,NBINS
        WRITE(9,39) XMIN+XBIN*FLOAT(IB-1),IHIST(IB)
39      FORMAT(F12.3,1X,I5)
        END DO
        CLOSE(9)
*
* Generates the two arrays XPLOT, YPLOT to be plotted :
	DO IB=1,NBINS
	  XPLOT(IB)=XMIN+XBIN*FLOAT(IB-1)
	  YPLOT(IB)=FLOAT(IHIST(IB))
	END DO

        NBY=2
        NAME='histo'
        WRITE(COMMENTS,8)XMIN,XMAX,NBINS
8       FORMAT('Min/Max=',2(1X,F12.3),' Nbins:',NBINS)
        JLP_WRITE_IMAG(XPLOT,YPLOT,NBINS,NBY,NBINS,NAME,COMMENTS)
	DO IB=1,NBINS
        WRITE(9,39) XMIN+XBIN*FLOAT(IB-1),IHIST(IB)
39      FORMAT(F12.3,1X,I5)
        END DO
        CLOSE(9)
	RETURN
	END


! { dg-do run }
! { dg-options "-fno-range-check" }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
! PR fortran/34319
!
! Check support of INF/NaN for I/O.
!
program main
  implicit none
  real :: r
  complex :: z
  character(len=30) :: str

  str = "nan"
  read(str,*) r
  if (.not.isnan(r)) STOP 1
  str = "(nan,4.0)"
  read(str,*) z
  if (.not.isnan(real(z)) .or. aimag(z) /= 4.0) STOP 2
  str = "(7.0,nan)"
  read(str,*) z
  if (.not.isnan(aimag(z)) .or. real(z) /= 7.0) STOP 3

  str = "inFinity"
  read(str,*) r
  if (r <= huge(r)) STOP 4
  str = "(+inFinity,4.0)"
  read(str,*) z
  if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) STOP 5
  str = "(7.0,-inFinity)"
  read(str,*) z
  if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) STOP 6

  str = "inf"
  read(str,*) r
  if (r <= huge(r)) STOP 7
  str = "(+inf,4.0)"
  read(str,*) z
  if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) STOP 8
  str = "(7.0,-inf)"
  read(str,*) z
  if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) STOP 9

end program main


!Laplacian für 3D-Giter
!Stencil from High-Order Compact Finite Diference Schemes for Computational Mechanics
!William Frederick Spotz, B.S., M.S

module mod_laplacian3d

  use mod_types !Fortran Modul mit der Typedefiniton für Real und Integer
  use OMP_LIB !We use OpenMP threads
  implicit none

  integer(kind=ik), private :: num_ii !Anzahl der inneren Zellen in Y-Richtung
  integer(kind=ik), private :: num_jj !Anzahl der inneren Zellen in X-Richtung
  integer(kind=ik), private :: num_kk !Anzahl der inneren Zellen in Z-Richtung

  real(kind=rk), allocatable, dimension(:,:,:), public :: uu3d !Vektor uu3d ist aequivalent zur Funktion F(x,y,z)
  real(kind=rk), allocatable, dimension(:,:,:), public :: dd3d !Vektor L2(F)=d2F/dx2+d2F/dy2+d2F/dz2

contains

!Speicherreservierung für die Felder uu3d und dd3d;
subroutine alloc_mem3d(num_xx, num_yy, num_zz)
  integer(kind=ik), intent(IN) :: num_xx
  integer(kind=ik), intent(IN) :: num_yy
  integer(kind=ik), intent(IN) :: num_zz
  integer :: sys_stat !

  if(allocated(uu3d)) deallocate(uu3d)
  if(allocated(dd3d)) deallocate(dd3d)

  allocate(uu3d(0:num_yy+1,0:num_xx+1,0:num_zz+1),stat=sys_stat)
  if(sys_stat .ne. 0) then
    write(*,'(A,I0)') "Error: allocate(uu3d) returns ",sys_stat
    stop
  endif
  allocate(dd3d(1:num_yy,1:num_xx,1:num_zz),stat=sys_stat)
  if(sys_stat .ne. 0) then
    write(*,'(A,I0)') "Error: allocate(dd3d) returns ",sys_stat
    stop
  endif
  write(*,'(A,I0)') "Info: allocated(uu3d) GiB:", sizeof(uu3d)/2**30
  write(*,'(A,I0)') "Info: allocated(dd3d) GiB:", sizeof(dd3d)/2**30

  num_ii=num_yy
  num_jj=num_xx
  num_kk=num_zz
end subroutine alloc_mem3d

!Speicherfreigabe für die Felder uu3d und dd3d;
subroutine dealloc_mem3d()
  if(allocated(uu3d)) deallocate(uu3d)
  if(allocated(dd3d)) deallocate(dd3d)
  num_ii=-1_ik
  num_jj=-1_ik
  num_kk=-1_ik
end subroutine dealloc_mem3d

!Initialisierung des Felders uu3d mit f=x*y^2+z^3)
subroutine init_uu3d()
  integer(kind=ik) :: ii, jj, kk
  integer(kind=ik) :: ii_end, jj_end, kk_end
  real(kind=rk) :: hh,xx,yy,zz,val

  ii_end = num_ii+1_ik
  jj_end = num_jj+1_ik
  kk_end = num_kk+1_ik
  hh = 1.0_rk/real(num_ii,kind=rk)
  !$omp parallel do default(none) &
    !$omp& private(ii,jj,kk, &
    !$omp& xx,yy,zz,val) &
    !$omp& shared(uu3d,hh, &
    !$omp& kk_end,jj_end,ii_end)
  do kk=0, kk_end
    do jj=0, jj_end
      do ii=0, ii_end
        xx = hh*jj
        yy = hh*ii
        zz = hh*kk
        val = xx*yy*yy+zz*zz*zz
        uu3d(ii,jj,kk) = val
      end do
    end do
  end do
end subroutine

!Copy 2D Array into uu3d
subroutine copy2d_to_uu3d(data2d,zz)
  real(kind=rk), dimension(:,:), intent(in) :: data2d
  integer(kind=ik), intent(in) :: zz
  integer(kind=ik) :: ii, jj
  integer(kind=ik) :: ii_end, jj_end, kk_end

  ii_end = num_ii+1_ik
  jj_end = num_jj+1_ik
  kk_end = num_kk+1_ik
  do jj=1,num_jj
    do ii=1,num_ii
      uu3d(ii,jj,zz) = data2d(ii,jj)
    end do
  end do
  uu3d(1:num_ii,0,zz) = data2d(:,1)
  uu3d(1:num_ii,kk_end,zz) = data2d(:,num_jj)
  uu3d(0,0,zz)=data2d(1,1)
  uu3d(ii_end,0,zz)=data2d(num_ii,1)
  uu3d(0,jj_end,zz)=data2d(1,num_jj)
  uu3d(ii_end,jj_end,zz)=data2d(num_ii,num_jj)

end subroutine copy2d_to_uu3d

!Di Methode wendet den Laplace-Operator in allen Gittezellen
!Berechnungs Gebiets (kein Cache Blocking)
!Die Variablen sind:
!num_ii-Anzahl der inneren Gebietszellen in Y-Richtung
!num_jj-Anzahl der inneren Gebietszellen in X-Richtung
!num_kk-Anzahl der inneren Gebietszellen in Z-Richtung
!uu3d-Dreidimensionales Array mit den Funktionswerten
!dd3d-Dreidimensionalen Array mit der zweiten Ableitung
!temp1,..,temp9- Hilfsvariablen
subroutine laplacian_simple3d()

  integer(kind=ik) :: ii, jj, kk
  real(kind=rk) :: tmp1, tmp2, tmp3
  real(kind=rk) :: tmp4, tmp5, tmp6
  real(kind=rk) :: tmp7, tmp8, tmp9
  real(kind=rk) :: hh,xx,yy,zz,val
  real(kind=rk) :: step_inv
  hh=1.0/real(num_ii,kind=rk)
  step_inv=1.0/(30.0*hh*hh)

  !$omp parallel do default(none) &
      !$omp& private(ii,jj,kk,tmp1,tmp2,tmp3, &
      !$omp& tmp4,tmp5,tmp6,tmp7,tmp8,tmp9, &
      !$omp& xx,yy,zz,val) &
      !$omp& shared(uu3d,dd3d,num_kk,num_jj,num_ii,step_inv)
  do kk=1,num_kk
    do jj=1,num_jj
      !!DIR$ VECTOR NONTEMPORAL
      do ii=1,num_ii ! uu3d(dy,dx,dz)
        tmp1 = uu3d(ii-1,jj-1,kk-1)+3.0*uu3d(ii,jj-1,kk-1)+uu3d(ii+1,jj-1,kk-1)
        tmp2 = 3.0*uu3d(ii-1,jj,kk-1)+14.0*uu3d(ii,jj,kk-1)+3.0*uu3d(ii+1,jj,kk-1)
        tmp3 = uu3d(ii-1,jj+1,kk-1)+3.0*uu3d(ii,jj+1,kk-1)+uu3d(ii+1,jj+1,kk-1)

        tmp4 = 3.0*uu3d(ii-1,jj-1,kk)+14.0*uu3d(ii,jj-1,kk)+3.0*uu3d(ii+1,jj-1,kk)
        tmp5 = 14.0*uu3d(ii-1,jj,kk)-128.0*uu3d(ii,jj,kk)+14.0*uu3d(ii+1,jj,kk)
        tmp6 = 3.0*uu3d(ii-1,jj+1,kk)+14.0*uu3d(ii,jj+1,kk)+3.0*uu3d(ii+1,jj+1,kk)

        tmp7 = uu3d(ii-1,jj-1,kk+1)+3.0*uu3d(ii,jj-1,kk+1)+uu3d(ii+1,jj-1,kk+1)
        tmp8 = 3.0*uu3d(ii-1,jj,kk+1)+14.0*uu3d(ii,jj,kk+1)+3.0*uu3d(ii+1,jj,kk+1)
        tmp9 = uu3d(ii-1,jj+1,kk+1)+3.0*uu3d(ii,jj+1,kk+1)+uu3d(ii+1,jj+1,kk+1)

        dd3d(ii,jj,kk) = (tmp1+tmp2+tmp3+tmp4+tmp5+tmp6+tmp7+tmp8+tmp9)*step_inv
      end do
    end do
  end do
end subroutine laplacian_simple3d

!Simple-VBlocked3d Implementierung der 3D Laplace-Operators mit "virtueller"
!Aufteilung des Rechengebiets
!blk_size_xx - Anzahl der Zellen in einem Sub-Gebiet in die Richtung X
!blk_size_yy - Anzahl der Zellen in einem Sub-Gebiet in die Richtung Y
!blk_size_zz - Anzahl der Zellen in einem Sub-Gebiet in die Richtung Z
subroutine laplacian_simple_vblocked3d(blk_size_xx,blk_size_yy,blk_size_zz)
  integer(kind=ik), intent(in) :: blk_size_xx
  integer(kind=ik), intent(in) :: blk_size_yy
  integer(kind=ik), intent(in) :: blk_size_zz
  integer(kind=ik) :: iiblock, ii
  integer(kind=ik) :: jjblock, jj
  integer(kind=ik) :: kkblock, kk
  integer(kind=ik) :: blk_size_yy_one
  integer(kind=ik) :: blk_size_xx_one
  integer(kind=ik) :: blk_size_zz_one
  real(kind=rk) :: tmp1, tmp2, tmp3
  real(kind=rk) :: tmp4, tmp5, tmp6
  real(kind=rk) :: tmp7, tmp8, tmp9
  real(kind=rk) :: step_inv,hh
  hh=1.0/real(num_ii,kind=rk)
  step_inv=1.0/(30.0*hh*hh)

  blk_size_xx_one = blk_size_xx-1
  blk_size_yy_one = blk_size_yy-1
  blk_size_zz_one = blk_size_zz-1
  !$omp parallel do default(none) &
      !$omp& private(tmp1,tmp2,tmp3, &
      !$omp& tmp4,tmp5,tmp6,tmp7,tmp8,tmp9, &
      !$omp& ii,jj,kk, &
      !$omp& kkblock,jjblock,iiblock) &
      !$omp& shared(blk_size_xx_one, &
      !$omp& blk_size_yy_one,blk_size_zz_one, &
      !$omp& num_kk,num_jj,num_ii, &
      !$omp& blk_size_xx,blk_size_yy, &
      !$omp& blk_size_zz,uu3d,dd3d,step_inv)
  do kkblock=1,num_kk,blk_size_zz
    do jjblock=1,num_jj,blk_size_xx
      do iiblock=1,num_ii,blk_size_yy
        do kk=kkblock,kkblock+blk_size_zz_one
          do jj=jjblock,jjblock+blk_size_xx_one
            !!DIR$ VECTOR NONTEMPORAL
            !!DIR$ UNROLL=8
            do ii=iiblock,iiblock+blk_size_yy_one
              tmp1 = uu3d(ii-1,jj-1,kk-1)+3.0*uu3d(ii,jj-1,kk-1)+uu3d(ii+1,jj-1,kk-1)
              tmp2 = 3.0*uu3d(ii-1,jj,kk-1)+14.0*uu3d(ii,jj,kk-1)+3.0*uu3d(ii+1,jj,kk-1)
              tmp3 = uu3d(ii-1,jj+1,kk-1)+3.0*uu3d(ii,jj+1,kk-1)+uu3d(ii+1,jj+1,kk-1)

              tmp4 = 3.0*uu3d(ii-1,jj-1,kk)+14.0*uu3d(ii,jj-1,kk)+3.0*uu3d(ii+1,jj-1,kk)
              tmp5 = 14.0*uu3d(ii-1,jj,kk)-128.0*uu3d(ii,jj,kk)+14.0*uu3d(ii+1,jj,kk)
              tmp6 = 3.0*uu3d(ii-1,jj+1,kk)+14.0*uu3d(ii,jj+1,kk)+3.0*uu3d(ii+1,jj+1,kk)

              tmp7 = uu3d(ii-1,jj-1,kk+1)+3.0*uu3d(ii,jj-1,kk+1)+uu3d(ii+1,jj-1,kk+1)
              tmp8 = 3.0*uu3d(ii-1,jj,kk+1)+14.0*uu3d(ii,jj,kk+1)+3.0*uu3d(ii+1,jj,kk+1)
              tmp9 = uu3d(ii-1,jj+1,kk+1)+3.0*uu3d(ii,jj+1,kk+1)+uu3d(ii+1,jj+1,kk+1)

              dd3d(ii,jj,kk) = (tmp1+tmp2+tmp3+tmp4+tmp5+tmp6+tmp7+tmp8+tmp9)*step_inv
            end do
          end do
        end do
      end do
    end do
  end do

end subroutine laplacian_simple_vblocked3d

!Maybe Todo compute opt. block size
subroutine laplacian_auto_blk3d()
  write(*,'(A,I0)') &
    "Error: laplacian_auto_blocks is not implemented "
  stop
end subroutine laplacian_auto_blk3d

!Berechne Absolute und relative Fehlernorm der Lösung
!Theoretische Lösung ist 2.0_rk*xx+6.0*zz
! ||vv||_2
! ||uu3d||_2
! ||uu3d-vv||_2
! ||uu3d-vv||_2/||xx||_2
function laplacian_check3d() result(norm)
  integer(kind=ik) :: ii, jj, kk
  real(kind=rk), dimension(4) :: norm
  real(kind=rk) normerr, diff, normxx, normdd3d
  real(kind=rk) :: hh,xx,yy,zz,vv

  hh = 1.0_rk/real(num_ii,kind=rk)
  normerr=0.0_rk
  normxx=0.0_rk
  normdd3d=0.0_rk
  norm=0.0_rk

!  !Iteriere uber die Bloecke
!  !$omp parallel do reduction(+:normxx) &
!    !$omp& reduction(+:normdd3d) &
!    !$omp& reduction(+:normerr) &
!    !$omp& default(none) &
!    !$omp& private(zz,yy,xx,ii,jj,kk,diff,vv) &
!    !$omp& shared(dd3d,hh,num_kk,num_jj,num_ii)
  do kk=1,num_kk
    do jj=1,num_jj
      do ii=1,num_ii
        xx = hh*jj
        yy = hh*ii
        zz = hh*kk
        vv = 2.0_rk*xx+6.0*zz
        normxx=normxx + vv*vv
        normdd3d=normdd3d + dd3d(ii,jj,kk)*dd3d(ii,jj,kk)
        diff=dd3d(ii,jj,kk)-vv
        normerr=normerr+diff*diff
      end do
    end do
  end do
  normerr=SQRT(normerr)
  normxx=SQRT(normxx)
  normdd3d=SQRT(normdd3d)
  norm(1)=normxx
  norm(2)=normdd3d
  norm(3)=normerr
  norm(4)=normerr/normxx
end function laplacian_check3d

end module mod_laplacian3d


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     a program for testing all scalar analysis and synthesis subroutines
!
program test_analysis_and_synthesis_routines

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        wp, & ! Working precison
        ip, & ! Integer precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    ! Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_case(solver)
    deallocate (solver)

    ! Test regular grid
    allocate (RegularSphere :: solver)
    call test_case(solver)
    deallocate (solver)

contains

    subroutine test_case(sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLONS = 128
        integer(ip), parameter        :: NLATS = NLONS/2 + 1
        integer(ip), parameter        :: NSYNTHS = 3
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: original_scalar_function(NLATS, NLONS, NSYNTHS)
        real(wp)                      :: approximate_scalar_function(NLATS, NLONS, NSYNTHS)
        character(len=:), allocatable :: error_previous_platform

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (error_previous_platform, &
                source='     discretization error = 3.375078e-14')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (error_previous_platform, &
                source='     discretization error = 2.664535e-14')
        end select

        !  Test all analysis and synthesis subroutines.
        !  Set scalar field as (x*y*z)**k) restricted to the sphere
        associate (&
            se => original_scalar_function, &
            radial => sphere_type%unit_vectors%radial &
           )
            do k=1, NSYNTHS
                do j=1, NLONS
                    do i=1, NLATS
                        associate (&
                            x => radial(i, j)%x, &
                            y => radial(i, j)%y, &
                            z => radial(i, j)%z &
                           )
                            select case (k)
                                case(1)
                                    se(i, j, k) = exp(x + y + z)
                                case default
                                    se(i, j, k) = (x*y*z)**k
                            end select
                        end associate
                    end do
                end do
            end do
        end associate

        !  Perform analysis then synthesis
        do k = 1, NSYNTHS
            associate (&
                se => original_scalar_function(:, :, k), &
                s => approximate_scalar_function(:, :, k) &
               )

                ! Analyse function into (real) coefficients
                call sphere_type%perform_complex_analysis(se)

                ! Synthesize function from (real) coefficients
                call sphere_type%perform_complex_synthesis(s)
            end associate
        end do

        !  Compute discretization error
        associate (&
            se => original_scalar_function, &
            s => approximate_scalar_function &
           )
            associate (err2 => maxval(abs(s - se)))

                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                write (stdout, '(a)') ''
                write (stdout, '(/a/)') '     test analysis and synthesis routines *** TEST RUN *** '
                write (stdout, '(a)') ''
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing scalar analysis and synthesis'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') error_previous_platform
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     discretization error = ', err2
                write (stdout, '(a)') ''
            end associate
        end associate

        !  Release memory
        call sphere_type%destroy()
        deallocate (error_previous_platform)

    end subroutine test_case

end program test_analysis_and_synthesis_routines


! { dg-do run }
! PR fortran/26816
program test_float
   integer(1) :: i1 = 1
   integer(2) :: i2 = 1
   integer(4) :: i4 = 1
   integer(8) :: i8 = 1
   if (float(i1) /= 1.) call abort                ! { dg-warning "non-default INTEGER" }
   if (float(i2) /= 1.) call abort                ! { dg-warning "non-default INTEGER" }
   if (float(i4) /= 1.) call abort
   if (float(i8) /= 1.) call abort                ! { dg-warning "non-default INTEGER" }

   if (kind(float(i4)) /= kind(1.0)) call abort
   if (kind(float(i8)) /= kind(1.0)) call abort   ! { dg-warning "non-default INTEGER" }
end program test_float


! A number of helper subroutines that are not directly
! part of the MD Algorithm.

subroutine r8mat_uniform_ab ( m, n, a, b, seed, r )
! returns a scaled pseudorandom R8MAT.
!
!  Discussion:
!    A <= R(I,J) <= B.
!
!    An R8MAT is an array of R8's.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    31 May 2007
!
!  Author:
!    John Burkardt
!
!  Reference:
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!    Sequence Generators,
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
implicit none

!  Parameters:
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input, real ( kind = 8 ) A, B, the lower and upper limits.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.

  integer ( kind = 4 ) m        ! number of rows in the array
  integer ( kind = 4 ) n        ! number of columns in the array

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed     ! The "seed" value, which should NOT be 0.  On output, SEED has been updated.
  real ( kind = 8 ) r(m,n)      ! The array of pseudorandom values

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8MAT_UNIFORM_AB - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  do j = 1, n

    do i = 1, m

      k = seed / 127773

      seed = 16807 * ( seed - k * 127773 ) - k * 2836

      if ( seed < 0 ) then
        seed = seed + i4_huge
      end if

      r(i,j) = a + ( b - a ) * real ( seed, kind = 8 ) * 4.656612875D-10

    end do
  end do

  return
end

!*****************************************************************************80
subroutine s_to_i4 ( s, value, ierror, length )
! reads an integer value from a string.
!
!  Discussion:
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    12 January 2009
!
!  Author:
!    John Burkardt
implicit none

!  Parameters:
!    Input, character ( len = * ) S, a string to be examined.
!
!    Output, integer ( kind = 4 ) VALUE, the integer value read from the string.
!    If the string is blank, then VALUE will be returned 0.
!
!    Output, integer ( kind = 4 ) IERROR, an error flag.
!    0, no error.
!    1, an error occurred.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters
!    of S used to make the integer.
!

  character( len = * ),intent(in) :: s  ! a string to be examined.
  integer(kind=4),intent(out) :: value  ! The integer value read from the string (0 if s is blank).
  integer(kind=4),intent(out) :: ierror ! an error flag: 0, no error; 1, an error occurred
  integer(kind=4),intent(out) :: length ! the number of characters of S used to make the integer.

  character c
  integer (kind=4) i
  integer (kind=4) isgn
  integer (kind=4) state
  character :: TAB = achar ( 9 )

  value = 0
  ierror = 0
  length = 0

  state = 0
  isgn = 1

  do i = 1, len_trim ( s )

    c = s(i:i)
!
!  STATE = 0, haven't read anything.
!
    if ( state == 0 ) then

      if ( c == ' ' .or. c == TAB ) then

      else if ( c == '-' ) then
        state = 1
        isgn = -1
      else if ( c == '+' ) then
        state = 1
        isgn = +1
      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        state = 2
        value = iachar ( c ) - iachar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  STATE = 1, have read the sign, expecting digits or spaces.
!
    else if ( state == 1 ) then

      if ( c == ' ' .or. c == TAB ) then

      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        state = 2
        value = iachar ( c ) - iachar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  STATE = 2, have read at least one digit, expecting more.
!
    else if ( state == 2 ) then

      if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then

        value = 10 * value + iachar ( c ) - iachar ( '0' )

      else

        value = isgn * value
        ierror = 0
        length = i - 1
        return

      end if

    end if

  end do
!
!  If we read all the characters in the string, see if we're OK.
!
  if ( state == 2 ) then

    value = isgn * value
    ierror = 0
    length = len_trim ( s )

  else

    value = 0
    ierror = 1
    length = 0

  end if

  return
end

!*****************************************************************************80
subroutine s_to_r8 ( s, r8 )
! reads an R8 value from a string.
!
!  Discussion:
!    An "R8" value is simply a real number to be stored as a
!    variable of type "real ( kind = 8 )".
!
!    The routine will read as many characters as possible until it reaches
!    the end of the string, or encounters a character which cannot be
!    part of the number.
!
!    Legal input is:
!
!|       1 blanks,
!|       2 '+' or '-' sign,
!|       2.5 blanks
!|       3 integer part,
!|       4 decimal point,
!|       5 fraction part,
!|       6 'E' or 'e' or 'D' or 'd', exponent marker,
!|       7 exponent sign,
!|       8 exponent integer part,
!|       9 exponent decimal point,
!|      10 exponent fraction part,
!|      11 blanks,
!|      12 final comma or semicolon,
!
!    with most quantities optional.
!
!  Example:
!    ==============   ======================
!    S                 R8
!    ==============   ======================
!    '1'               1.0
!    '     1   '       1.0
!    '1A'              1.0
!    '12,34,56'        12.0
!    '  34 7'          34.0
!    '-1E2ABCD'        -100.0
!    '-1X2ABCD'        -1.0
!    ' 2E-1'           0.2
!    '23.45'           23.45
!    '-4.2E+2'         -420.0
!    '17d2'            1700.0
!    '-14e-2'         -0.14
!    'e2'              100.0
!    '-12.73e-9.23'   -12.73 * 10.0^(-9.23)
!    ==============   ======================
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    06 January 2013
!
!  Author:
!    John Burkardt

implicit none
!  Parameters:
!
!    Input, character ( len = * ) S, the string containing the
!    data to be read.  Reading will begin at position 1 and
!    terminate at the end of the string, or when no more
!    characters can be read to form a legal real.  Blanks,
!    commas, or other nonnumeric data will, in particular,
!    cause the conversion to halt.
!
!    Output, real ( kind = 8 ) R8, the value read from the string.

  character (len= * ),intent(in) :: s  ! string containing the data to be read.
  real(kind=8),intent(out)       :: r8 ! the value read from the string.

  character c
  integer(kind=4) ierror
  integer(kind=4) ihave
  integer(kind=4) isgn
  integer(kind=4) iterm
  integer(kind=4) jbot
  integer(kind=4) jsgn
  integer(kind=4) jtop
  integer(kind=4) length
  integer(kind=4) ndig
  real(kind=8) rbot
  real(kind=8) rexp
  real(kind=8) rtop
  integer ( kind = 4 ) s_length
  character  :: TAB = achar ( 9 )

  s_length = len_trim ( s )

  ierror = 0
  r8 = 0.0D+00
  length = -1
  isgn = 1
  rtop = 0
  rbot = 1
  jsgn = 1
  jtop = 0
  jbot = 1
  ihave = 1
  iterm = 0

  do

    length = length + 1

    if ( s_length < length + 1 ) then
      exit
    end if

    c = s(length+1:length+1)
!
!  Blank character.
!
    if ( c == ' ' .or. c == TAB ) then

      if ( ihave == 2 ) then

      else if ( ihave == 6 .or. ihave == 7 ) then
        iterm = 1
      else if ( 1 < ihave ) then
        ihave = 11
      end if
!
!  Comma.
!
    else if ( c == ',' .or. c == ';' ) then

      if ( ihave /= 1 ) then
        iterm = 1
        ihave = 12
        length = length + 1
      end if
!
!  Minus sign.
!
    else if ( c == '-' ) then

      if ( ihave == 1 ) then
        ihave = 2
        isgn = -1
      else if ( ihave == 6 ) then
        ihave = 7
        jsgn = -1
      else
        iterm = 1
      end if
!
!  Plus sign.
!
    else if ( c == '+' ) then

      if ( ihave == 1 ) then
        ihave = 2
      else if ( ihave == 6 ) then
        ihave = 7
      else
        iterm = 1
      end if
!
!  Decimal point.
!
    else if ( c == '.' ) then

      if ( ihave < 4 ) then
        ihave = 4
      else if ( 6 <= ihave .and. ihave <= 8 ) then
        ihave = 9
      else
        iterm = 1
      end if
!
!  Scientific notation exponent marker.
!
    else if ( c == 'E' .or. c == 'e' .or. c == 'D' .or. c == 'd' ) then

      if ( ihave < 6 ) then
        ihave = 6
      else
        iterm = 1
      end if
!
!  Digit.
!
    else if (  ihave < 11 .and. lle ( '0', c ) .and. lle ( c, '9' ) ) then

      if ( ihave <= 2 ) then
        ihave = 3
      else if ( ihave == 4 ) then
        ihave = 5
      else if ( ihave == 6 .or. ihave == 7 ) then
        ihave = 8
      else if ( ihave == 9 ) then
        ihave = 10
      end if

      ndig = iachar ( c ) - 48

      if ( ihave == 3 ) then
        rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 )
      else if ( ihave == 5 ) then
        rtop = 10.0D+00 * rtop + real ( ndig, kind = 8 )
        rbot = 10.0D+00 * rbot
      else if ( ihave == 8 ) then
        jtop = 10 * jtop + ndig
      else if ( ihave == 10 ) then
        jtop = 10 * jtop + ndig
        jbot = 10 * jbot
      end if
!
!  Anything else is regarded as a terminator.
!
    else
      iterm = 1
    end if
!
!  If we haven't seen a terminator, and we haven't examined the
!  entire string, go get the next character.
!
    if ( iterm == 1 ) then
      exit
    end if

  end do
!
!  If we haven't seen a terminator, and we have examined the
!  entire string, then we're done, and LENGTH is equal to S_LENGTH.
!
  if ( iterm /= 1 .and. length + 1 == s_length ) then
    length = s_length
  end if
!
!  Number seems to have terminated.  Have we got a legal number?
!  Not if we terminated in states 1, 2, 6 or 7!
!
  if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then
    ierror = ihave
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'S_TO_R8 - Serious error!'
    write ( *, '(a)' ) '  Illegal or nonnumeric input:'
    write ( *, '(a)' ) '    "' // trim ( s ) // '"'
    stop 1
  end if
!
!  Number seems OK.  Form it.
!
  if ( jtop == 0 ) then
    rexp = 1.0D+00
  else
    if ( jbot == 1 ) then
      rexp = 10.0D+00 ** ( jsgn * jtop )
    else
      rexp = 10.0D+00 ** ( real ( jsgn * jtop, kind = 8 ) &
        / real ( jbot, kind = 8 ) )
    end if
  end if

  r8 = real ( isgn, kind = 8 ) * rexp * rtop / rbot

  return
end

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

  implicit none

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

  call date_and_time ( values = values )

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

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

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

  return
end


************************************************************************
*
*     Subroutine MLELOAD2                            Called by: MLELOAD
*
*
*     Estimate loads using MLE.  Bias correction is done by the
*     method of Bradu and Mundlak(1970). An estimate of the variance
*     of the load is obtained by the method given in Likes (1980).
*
*     The function PHI given by Likes (1980) is used rather the
*     function GM given by Finney (1941) as coded by Cohn et al.
*     (1989). PHI takes longer to compute but can handle larger
*     arguments so there it is less likely that the computation of the
*     variance will fail. Likes (1980) gives the relation:
*
*                                     (DF+1)*A
*                     PHI[A*W,DF]=GM[----------*W]
*                                      2*DF**2
*
*     To use GM rather than PHI see C. Crawford's original LOADEST.
*
*     PHI is denoted MVUEPHI below, to distinguish it from the
*     function PHI used to calculate the probability density
*     function of the standard normal distribution.
*
*     local vars
*     ----------
*     DF2      degrees of freedom of the regression, divided by 2
*     LTE      log of transport (untransformed value fr rating curve)
*     TE       uncorrected estimated population loads (transport est)
*     V        XO * XTXINV * XT for each population value
*
************************************************************************
      SUBROUTINE MLELOAD2(NPAR,XLEST,NUMOBSE,NOBSC,PARMLE,RVARMLE,
     &                   XTXINV,SEOPT,LOADMLE,VARMLE,PLOADMLE,NOBSE)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NUMOBSE,SEOPT,NOBSC,NOBSE
      DOUBLE PRECISION RVARMLE,LOADMLE,VARMLE
      DOUBLE PRECISION PARMLE(*),PLOADMLE(*)
      DOUBLE PRECISION XLEST(NOBSE,*),XTXINV(MAXPARMS,*)
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION DF2,LTE(NUMOBSE),TE(NUMOBSE),V(NUMOBSE)
*
*     function declarations
*
      DOUBLE PRECISION MVUEPHI,PRED
*
*     calculate the estimate of the mean load
*
      DF2 = DBLE(NOBSC-NPAR)/2.D0
      LOADMLE = 0.D0
      DO 10 I=1,NUMOBSE
         CALL MATMLT(V(I),XLEST,XTXINV,NPAR,I,I,NOBSE)
         LTE(I) = PRED(NPAR,NOBSE,I,XLEST,PARMLE)
         TE(I) = DEXP(LTE(I))
         PLOADMLE(I) = TE(I)*MVUEPHI(((1.D0-V(I))*DF2*RVARMLE)/2.D0,DF2)
         LOADMLE = LOADMLE + PLOADMLE(I)
 10   CONTINUE
      LOADMLE = LOADMLE/DBLE(NUMOBSE)
*
*     estimate the variance of the mean load
*
      IF ((SEOPT .EQ. 2) .OR. (SEOPT .EQ. 3))
     &   CALL MLEVAR(NPAR,XLEST,NUMOBSE,RVARMLE,XTXINV,VARMLE,DF2,LTE,
     &               TE,V,NOBSE)

      RETURN
      END


c=======================================================================
c
c     subroutine SCHURPCA
c
c     Matrix Schur Decomposition and sorts eigenvalues (decrease order)
c     cf. SCHUR subroutine
c
c-----------------------------------------------------------------------
      SUBROUTINE schurpca ( n, M, iwork, dwork, eigval, eigvect, info)
c
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            M      : matrix (n*n)                                double
c
c     WORKSPACE
c            iwork  : vector (n)                                 integer
c            dwork  : vector ( n*(2*n+6) )                        double
c
c     OUTPUT
c            eigval : eigenvalues (n)                             double
c            eigvect  : eigenvectors (n*n)                          double
c            info   : diagnostic argument                        integer
c
c     CALL
c            SCHURO  : matrix Schur decomposition
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION M(*), eigval(*), eigvect(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pdunsorted, pdw
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for SCHURO who needs (n)
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : work(nasmax,*)
c     ----------------------------------------------------------
      pdunsorted = 1
c     pvs    : pointer unsorted vector so n more
      pdw = pdunsorted +  n
c     pdw    : pointer SCHUR0 who needs n*(2*n+6), so n*(2*n+6) more
c     pdnext  : pointer of the next dwork array
c
c     Total size of work array = n*(2*n + 7)
c
c-----------------------------------------------------------------------
c
c     Schur factorization
      CALL schuro ( n, M, iwork(piw), dwork(pdw), dwork(pdunsorted),
     &              eigval, eigvect, info )
c
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine distattach_1d(xig,pneigh,pnode,a,p,ratio,nterms)
!
!     calculates the distance between the node with coordinates
!     in "pnode" and the node with local coordinate xig
!     on a line described by "nterms" nodes with coordinates
!     in pneigh
!
      implicit none
!
      integer nterms,i,j
!
      real*8 ratio(3),pneigh(3,*),pnode(3),a,xig,p(3)
!
!
!
      if(nterms.eq.2) then
         ratio(1)=(1.d0-xig)/2.d0
         ratio(2)=(1.d0+xig)/2.d0
      elseif(nterms.eq.3) then
         ratio(1)=xig*(xig-1.d0)/2.d0
         ratio(2)=(1.d0-xig)*(1.d0+xig)
         ratio(3)=xig*(xig+1.d0)/2.d0
      else
         write(*,*) '*ERROR in distattach1d: case with ',nterms
         write(*,*) '       terms is not covered'
         call exit(201)
      endif
!
!     calculating the position in the face
!
      do i=1,3
         p(i)=0.d0
         do j=1,nterms
            p(i)=p(i)+ratio(j)*pneigh(i,j)
         enddo
      enddo
!
!     calculating the distance
!
      a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2
!
      return
      end