!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!    Date:       22 Oct 1992
!    Time:       21:28
!    Program:    MATINV.FOR
!    Version:    6.00.00
!    Programmer: Nicolaas M de Rooij
!
      subroutine matinv(a, n, b, m, d, w, ising)
!           4-69
!           cholesky's diagonal method -- for symmetric matrices only
!           matrix inversion and / or simultaneous equation solution
!             m =  0    invert only and store inverse in a
!             m = -1    solve simultaneous equations.  solution in b
!             m =  1    combination of m = 0 and m = -1.
!             m = -2    solve simultaneous equations with already
!                       calculated upper triangular and diagonal
!                       inverse stored in a, and solution in b
!           dimension of the arrays should be equal to the value of
!        maxmd in common labeled /intgr/ of other routines in deck.
      implicit real*8 (a-h,o-z)
      dimension a(60,60), b(60), d(60), w(60)
      ising = 0
      if(m.eq.-2)go to 35
!        find upper triangular matrix and diagonal matrix
      do 30 i=1,n
         if (a(i,i).eq.0.) go to 170
         d(i) = a(i,i)
         a(i,i) = 1.
         if (i.eq.n) go to 30
         k = i + 1
         do 20 j=k,n
            do 10 l=j,n
               a(j,l) = a(j,l) - a(i,j)*a(i,l)/d(i)
   10       continue
            a(i,j) = a(i,j)/d(i)
   20    continue
   30 continue
      if (m.eq.0) go to 80
!        solve simultaneous equations
   35 w(1) = b(1)
      do 50 i=2,n
         s = 0.
         l2 = i - 1
         do 40 l=1,l2
            s = s + a(l,i)*w(l)
   40    continue
         w(i) = b(i) - s
   50 continue
      b(n) = w(n)/d(n)
      do 70 ii=2,n
         i = n + 1 - ii
         s = 0.
         l1 = i + 1
         do 60 l=l1,n
            s = s + a(i,l)*b(l)
   60    continue
         b(i) = w(i)/d(i) - s
   70 continue
   80 if (m.lt.0) return
!        invert upper triangular matrix  to get  inverse
      do 110 ii=2,n
         i = n + 1 - ii
         jj = ii - 1
         j3 = i + 1
         do 100 j2=1,jj
            j = n + 1 - j2
            s = 0.
            do 90 k=j3,j
               s = s + a(i,k)*a(k,j)
   90       continue
            a(i,j) = -s
  100    continue
  110 continue
!        multiply inverse * reciprocal diagonal * inverse transposed
      do 140 i=1,n
         do 130 j=i,n
            s = 0.
            do 120 k=j,n
               s = s + a(i,k)*a(j,k)/d(k)
  120       continue
            a(i,j) = s
  130    continue
  140 continue
!        re-symmetrize
      do 160 j=2,n
         j2 = j - 1
         do 150 i=1,j2
            a(j,i) = a(i,j)
  150    continue
  160 continue
      return
  170 ising = i
      return
      end


program test_sto_he4

! The results here are to be compared against [1]:

! [1] Doll, J. D., & Reinhardt, W. P. (1972). Many-Body Green’s Functions for
! Finite, Nonuniform Systems: Applications to Closed Shell Atoms. The Journal
! of Chemical Physics, 57(3), 1169–1184. doi:10.1063/1.1678374

use types, only: dp
use sto, only: stoints2, get_basis2, slater_sto_gauss
use utils, only: assert
use radialscf, only: doscf, kinetic_energy, slater2int22, &
    get_basis, radialC2C, &
    radiallam2lam
use hfprint, only: printall, printlam
use mbpt, only: transform_int2, mbpt2, mbpt3, mbpt4, transform_int22
use gf2, only: find_poles, find_pole_diag, total_energy, plot_poles
use sorting, only: argsort
use scf, only: ijkl2intindex, ijkl2intindex2
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :), &
    slater2(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

Lmax = 2
allocate(nbfl(0:Lmax), nl(9, 0:Lmax), zl(9, 0:Lmax), focc(2, 0:Lmax))
nbfl = 0
focc = 0
focc(:1, 0) = [2]
nbfl(0) = 5
nl(:5, 0) = [1, 1, 2, 3, 3]
zl(:5, 0) = [1.4191_dp, 2.5722_dp, 4.2625_dp, 3.9979_dp, 5.4864_dp]
nbfl(1) = 4
nl(:4, 1) = [2, 2, 3, 4]
zl(:4, 1) = [2.5834_dp, 3.6413_dp, 5.5308_dp, 5.7217_dp]
nbfl(2) = 3
nl(:3, 2) = [3, 3, 4]
zl(:3, 2) = [3.6365_dp, 4.8353_dp, 6.9694_dp]

Z = 2
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
allocate(slater2(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater2)
! We calculate the slater integrals using Gauss-Laguerre quadrature:
call slater_sto_gauss(nbfl, nl, zl, slater)
! This test is crucial: it tests that the numerical and analytical integrals
! agree to very high accuracy:
call assert(all(abs(slater2-slater) < 2e-10_dp))

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), H(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
!call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-2.86167868_dp)) < 1e-8_dp)
call assert(all(abs(lam(:2, 0) - [-0.91804537_dp, 0.88239287_dp]) < 1e-8_dp))
call assert(all(abs(lam(:2, 1) - [ 1.16674233_dp, 5.07923156_dp]) < 1e-8_dp))
call assert(all(abs(lam(:2, 2) - [ 3.79051952_dp,16.77713044_dp]) < 1e-8_dp))

end program


!***********************************/
!	Name:非構造格子から構造格子へのデータ移動
!	Alias:OOverSetS2U
!	Description:
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.11.16
!	Update:2017.11.16
!	Other:
!***********************************/
subroutine OTransferOutflowMomentum(UG,UCC,MG)
    use StructVar_Mod
    use LoopVar_Mod
    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    type(MoveGrid), intent(inout) :: MG

!    write(6,*) "Outflow rotation"

    do iCell=1, UG%GI%AllCells
        !UCC%ConservedQuantity(2:4,iCell,1,1) = matmul(MG%TM%Top2Next(1:3,1:3),UCC%ConservedQuantity(2:4,iCell,1,1))
        UCC%ConservedQuantity(2:4,iCell,1,1) = matmul(MG%TM%Next2Top(1:3,1:3),UCC%ConservedQuantity(2:4,iCell,1,1))
    end do

return
end subroutine OTransferOutflowMomentum


!-------------------------------------------------------------------------------
! (C) British Crown Copyright 2020 Met Office
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!-------------------------------------------------------------------------------

!> Evaluate the 1st and 2nd deriv. of the cost function.

module ufo_gnssroonedvarcheck_eval_derivs_mod

use kinds, only: kind_real
use missing_values_mod, only: missing_value

private
public :: Ops_GPSRO_eval_derivs_BA

contains

SUBROUTINE Ops_GPSRO_eval_derivs_BA (Nstate,  &  ! size ot state vector
                                     Nobs,    &  ! no of obs
                                     x,       &  ! current est. of soln
                                     xb,      &  ! background vector
                                     yobs,    &  ! obs. vector
                                     ycalc,   &  ! y(x)
                                     BM1,     &  ! inverse .of bsck cov matrix
                                     OM1,     &  ! inv. of obs+forw cov matrix
                                     Kmat,    &  ! gradient matrix
                                     dJ_dx,   &  ! -ve of first deriv. of cost function
                                     d2J_dx2,  & ! second deriv. of cost function.
                                     diag_d2J)   ! vector containing the diagonal values of the matrix above

IMPLICIT NONE

! Subroutine arguments:
INTEGER, INTENT(IN)         :: Nstate
INTEGER, INTENT(IN)         :: Nobs
REAL(kind_real), INTENT(IN)            :: x(:)
REAL(kind_real), INTENT(IN)            :: xb(:)
REAL(kind_real), INTENT(IN)            :: yobs(:)
REAL(kind_real), INTENT(IN)            :: ycalc(:)
REAL(kind_real), INTENT(IN)            :: BM1(:,:)
REAL(kind_real), INTENT(IN)            :: OM1(:,:)
REAL(kind_real), INTENT(IN)            :: Kmat(:,:)
REAL(kind_real), INTENT(OUT)           :: dJ_dx(:)
REAL(kind_real), INTENT(OUT)           :: d2J_dx2(:,:)
REAL(kind_real), INTENT(OUT)           :: diag_d2J(:)

! Local declarations:
CHARACTER(len=*), PARAMETER :: RoutineName = "Ops_GPSRO_eval_derivs_BA"
INTEGER                     :: i
REAL(kind_real)                        :: dx(Nstate)
REAL(kind_real)                        :: dy(Nobs)
REAL(kind_real)                        :: Bdx(Nstate)
REAL(kind_real)                        :: KO(Nstate,Nobs)

!--------------------------------------------------------
! 1. Evaluate the 1st and 2nd deriv. of the cost function
!--------------------------------------------------------

! Deviation from background

dx(:) = x(:) - xb(:)

! Obs. meas-calc

dy(:) = yobs(:) - ycalc(:)

! If absolute difference is greater than 1 radian set difference to 0

WHERE (ABS (dy(:)) > 1.0)

  dy(:) = 0.0

END WHERE

! calc. Bdx matrix   ie B^-1(x-xb)

Bdx(:) = MATMUL (BM1(:,:), dx(:))

! K^T O^-1 matrix

KO(:,:) = MATMUL (TRANSPOSE (Kmat(:,:)), OM1(:,:))

! Calculate -dJ_dx vector    -note the NEGATIVE sign

dJ_dx(:) = MATMUL (KO(:,:), dy(:)) - Bdx(:)
!print*, 'dJ_dx components'
!write(*,'(10E15.8)') dJ_dx(11), Bdx(11)
!write(*,'(10E15.8)') KO(11,:)
!write(*,'(10E15.8)') dy(:)

! d2J_dx2 MATRIX

d2J_dx2(:,:) = MATMUL (KO(:,:), Kmat(:,:)) + BM1(:,:)

! Save the diagonal terms as a vector.

DO i = 1,Nstate

  diag_d2J(i) = d2J_dx2(i,i)

END DO

END SUBROUTINE Ops_GPSRO_eval_derivs_BA

end module ufo_gnssroonedvarcheck_eval_derivs_mod


! ****************************************************
!    setsval.f90 for sdenmap2d
!  28  Apr. 2015    written by D.KAWATA
! ****************************************************

subroutine setsval(np,nx,ny,xrange,yrange)
      use gcdp_const
      use gcdp_system
      use particle
      use gcdp_kernel
      use mesh

      implicit none
      include 'mpif.h'

      integer,intent(in) :: np,nx,ny
      double precision,intent(in) :: xrange(0:1),yrange(0:1)

! parallerise along x-axis
      integer ixs,ixe
      double precision dx,dy,xmesh,ymesh
! for work
      integer i,j,pn,ierr,ip
      integer is
      double precision xij,yij,rij,hsi,ihsi,s,wij,sdencgs
! mesh data point
      integer ixm0,ixm1,iym0,iym1
      double precision xsm,xem,ysm,yem
      double precision xpm,ypm,zpm
! for work
      integer ntm,nval,nc,nct
      double precision,allocatable :: ty(:),tz(:)
      double precision,allocatable :: tdvs(:),tdvr(:)
      character filen*60

! generate mesh
      allocate(x_m(0:nx-1,0:ny-1))
      allocate(y_m(0:nx-1,0:ny-1))
      allocate(denxy_m(0:nx-1,0:ny-1))
      allocate(denxz_m(0:nx-1,0:ny-1))
      allocate(vrot_m(0:nx-1,0:ny-1))
      allocate(vrad_m(0:nx-1,0:ny-1))
      allocate(vz_m(0:nx-1,0:ny-1))
      allocate(met_m(0:nx-1,0:ny-1))

! assign x,y position
      dx=(xrange(1)-xrange(0))/dble(nx)
      dy=(yrange(1)-yrange(0))/dble(ny)

      do j=0,ny-1
        ypm=yrange(0)+0.5d0*dy+dble(j)*dy
        do i=0,nx-1
          xpm=xrange(0)+0.5d0*dx+dble(i)*dx
          x_m(i,j)=xpm
          y_m(i,j)=ypm
! initialisation
          denxy_m(i,j)=0.0d0
          denxz_m(i,j)=0.0d0
          vrot_m(i,j)=0.0d0
          vrad_m(i,j)=0.0d0
          vz_m(i,j)=0.0d0
          met_m(i,j)=0.0d0
        enddo
      enddo

! at the start and end point of mesh for x and y
      xsm=x_m(0,0)
      xem=x_m(nx-1,0)
      ysm=y_m(0,0)
      yem=y_m(0,ny-1)
! for test
!      write(filen,'(a5,i4.4)') 'contp',myrank
!      open(60,file=filen,status='unknown')

! ip=0: x-y, ip=1: x-z
      do ip=0,1
! swap y and z
        if(ip.eq.1) then

          allocate(ty(0:np-1))
          allocate(tz(0:np-1))

          do i=0,np-1
            ty(i)=yp(i)
            tz(i)=zp(i)
            yp(i)=tz(i)
            zp(i)=ty(i)
          enddo
        endif

        nc=0
        do pn=0,np-1
! exclude particles obviously not contributing
          if(yp(pn).gt.ysm-hp(pn).and.yp(pn).lt.yem+hp(pn)) then
            if(xp(pn).gt.xsm-hp(pn).and.xp(pn).lt.xem+hp(pn)) then
              nc=nc+1
! output contributing particles
!            write(60,'(4(1pE13.5))') xp(pn),yp(pn),zp(pn),massp(pn)
! x
              ixm0=(xp(pn)-hp(pn)-xsm)/dx
              if(ixm0.lt.0) then
                ixm0=0
              else if(ixm0.ge.nx) then
                ixm0=nx-1
              endif
              ixm1=(xp(pn)+hp(pn)-xsm)/dx
              if(ixm1.lt.0) then
                ixm1=0
              else if(ixm1.ge.nx) then
                ixm1=nx-1
              endif
! y
              iym0=(yp(pn)-hp(pn)-ysm)/dy
              if(iym0.lt.0) then
                iym0=0
              else if(iym1.ge.ny) then
                iym0=ny-1
              endif
              iym1=(yp(pn)+hp(pn)-y_m(0,0))/dy
              if(iym1.lt.0) then
                iym1=0
              else if(iym1.ge.ny) then
                iym1=ny-1
              endif
              do j=iym0,iym1
                do i=ixm0,ixm1
! *** smooth the values ***
                  xij = xp(pn)-x_m(i,j)
                  yij = yp(pn)-y_m(i,j)
                  rij=dsqrt(xij**2+yij**2)
                  hsi=hp(pn)
                  if(rij.lt.hsi) then
                    ihsi=1.0d0/hsi
                    s=rij*ihsi
                    is=int(s*dnktab)
                    if(is.lt.0) then
                      is=0
                    else if(is.ge.NKTAB) then
                      is=NKTAB-1
                    endif
                    wij=w_tb(is)+(w_tb(is+1)-w_tb(is))*(s-s_tb(is))*dnktab
! 2D
                    wij=wij*(ihsi**2)
                    if(ip.eq.0) then
                      denxy_m(i,j)=denxy_m(i,j)+massp(pn)*wij
! velocity field only for face-on
                      vrot_m(i,j)=vrot_m(i,j)+massp(pn)*vrotp(pn)*wij
                      vrad_m(i,j)=vrad_m(i,j)+massp(pn)*vradp(pn)*wij
                      vz_m(i,j)=vz_m(i,j)+massp(pn)*vzp(pn)*wij
                      met_m(i,j)=met_m(i,j)+massp(pn)*metp(pn)*wij
                    else
                      denxz_m(i,j)=denxz_m(i,j)+massp(pn)*wij
                    endif
                  endif
                enddo
              enddo
            endif
          endif
        enddo
        nct=0
        call MPI_ALLREDUCE(nc,nct,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,ierr)
        if(myrank.eq.0) then
          write(6,*) ' # of contributing particles=',nct
        endif
! bring back y and z
        if(ip.eq.1) then
          do i=0,np-1
            yp(i)=ty(i)
            zp(i)=tz(i)
          enddo

          deallocate(ty)
          deallocate(tz)

        endif

      enddo
!      close(60)

! sum up
      if(nprocs.gt.1) then
        ntm=nx*ny
        allocate(tdvs(0:ntm-1))
        allocate(tdvr(0:ntm-1))
        nval=6
        do ip=0,nval-1
          nc=0
          if(ip.eq.0) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=denxy_m(i,j)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.1) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=denxz_m(i,j)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.2) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=vrot_m(i,j)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.3) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=vrad_m(i,j)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.4) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=vz_m(i,j)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.5) then
            do j=0,ny-1
              do i=0,nx-1
                tdvs(nc)=met_m(i,j)
                nc=nc+1
              enddo
            enddo
          endif
          do i=0,ntm-1
            tdvr(i)=0.0d0
          enddo
          call MPI_ALLREDUCE(tdvs,tdvr,ntm,MPI_DOUBLE_PRECISION &
           ,MPI_SUM,MPI_COMM_WORLD,ierr)
          nc=0
          if(ip.eq.0) then
            do j=0,ny-1
              do i=0,nx-1
                denxy_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.1) then
            do j=0,ny-1
              do i=0,nx-1
                denxz_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.2) then
            do j=0,ny-1
              do i=0,nx-1
                vrot_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.3) then
            do j=0,ny-1
              do i=0,nx-1
                vrad_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.4) then
            do j=0,ny-1
              do i=0,nx-1
                vz_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          else if(ip.eq.5) then
            do j=0,ny-1
              do i=0,nx-1
                met_m(i,j)=tdvr(nc)
                nc=nc+1
              enddo
            enddo
          endif
        enddo
        deallocate(tdvs)
        deallocate(tdvr)
      endif

! get the mean value
      do j=0,ny-1
        do i=0,nx-1
          if(denxy_m(i,j).gt.0.0d0) then
            vrot_m(i,j)=vrot_m(i,j)/denxy_m(i,j)
            vrad_m(i,j)=vrad_m(i,j)/denxy_m(i,j)
            vz_m(i,j)=vz_m(i,j)/denxy_m(i,j)
            met_m(i,j)=met_m(i,j)/denxy_m(i,j)
          endif
        enddo
      enddo

end subroutine


program mcsphere
implicit none
integer iseed,npk
integer i,j,ipk,nDepth
real r(3),u(3)
real pi
real ran
real rmag,rmax,l,taumax,a,nScatt,sCount

open(8, FILE='mc_iso.dat', status='replace')
! initalise variables
pi=4.*ATAN(1.)

iseed=-17284!keep this throughout-CHECK this is that simple!
! using cartesian coords r_x,r_y,r_z; with |r|=rmag
rmag=0.! |r(x,y,z)|
rmax=1.
a=1.!albedo: uniform density=>albedo not a function of r(x,y,z)

! npk: no. of photon packets per optical depth tau
!....... counted using ipk- the ith photon packet
! scount: total no. of scatterings per optical depth
!........counted using scount: scatter count
nDepth=20 !number of tau_maxes to sample
npk=20000
nScatt=0
call random_seed()
do j=1,nDepth
  print*,j
  ! set a max optical depth; and set scatter count sCount=0
  taumax=real(j)
  sCount=0
!       for this depth, simulate npk photons to be emitted
  do ipk=1,npk

    call emit_photon(iseed,pi,r,u)
    do !exit cond. in loop after |r| is updated
!            ...exit when |r|>rmax
!           get a new l (from a random tau), to find new position r
    call random_number(ran)
      l=-log(ran)/taumax*rmax
      do i=1,3
        r(i)=r(i)+l*u(i)
      enddo
!          use r to update rmag, and exit loop if rmag>rmax
      rmag=sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
      if (rmag.gt.rmax) exit
!          if pkt is still in sphere, scatter isotropically
        call scatter(iseed,pi,u)
        sCount=sCount+1.
    enddo

enddo

  nScatt=sCount/(real(npk))
  write(8,*)taumax,nScatt
enddo
close(8)

end program

!-----SUBROUTINES------------------------------------------------------

subroutine emit_photon(iseed,pi,r,u)
implicit none
integer iseed, i
real r(3),u(3),pi
!     give packets initial position and direction
!     corresponding to emission of isotropic point source at origin
!     position is easy (x,y,z)=(0,0,0)
!     assuming velocity is same mag, any direction

do i=1,3
  r(i)=0.
enddo
call isotropic(iseed,pi,u)

return
end
!-------------
subroutine scatter(iseed,pi,u)
implicit none
integer iseed
real pi, u(3)
!     albedo not function of position so just return new direction
!     and increment scatter count

call isotropic(iseed,pi,u)

return
end
!------------
subroutine isotropic(iseed,pi,u)
implicit none
integer iseed
real pi, u(3),theta,phi,ran
call random_number(ran)
theta=ACOS((2.*ran-1.))

call random_number(ran)
phi=2.*pi*ran

u(1)=SIN(theta)*COS(phi)
u(2)=SIN(theta)*SIN(phi)
u(3)=COS(theta)

return
end


!=============================================================================!
        subroutine bcfix( nx, ny, ndof, bnb, r )

        integer :: ny, nx, ndof
        real    :: bnb(nx,2)
        complex :: r(ny,nx,ndof)
        complex :: tmp(nx)

        integer :: i
!=============================================================================!

        do i = 1, nx
          tmp(i)   =  bnb(i,2) * r(1,i,2) + bnb(i,1) * r(1,i,3)
          r(1,i,3) = -bnb(i,1) * r(1,i,2) + bnb(i,2) * r(1,i,3)
          r(1,i,2) = tmp(i)
        end do

        return
        end

!.... Gives wrong solution on San Diego?

!       tmp(:)   =  bnb(:,2) * r(1,:,2) + bnb(:,1) * r(1,:,3)
!       r(1,:,3) = -bnb(:,1) * r(1,:,2) + bnb(:,2) * r(1,:,3)
!       r(1,:,2) = tmp(:)

!=============================================================================!
        subroutine rbcfix( nx, ny, ndof, bnb, r )

        integer :: ny, nx, ndof
        real    :: bnb(nx,2)
        real    :: r(ny,nx,ndof)
        real    :: tmp(nx)

        integer :: i
!=============================================================================!

        do i = 1, nx
          tmp(i)   =  bnb(i,2) * r(1,i,2) + bnb(i,1) * r(1,i,3)
          r(1,i,3) = -bnb(i,1) * r(1,i,2) + bnb(i,2) * r(1,i,3)
          r(1,i,2) = tmp(i)
        end do

        return
        end


MODULE mod_prec

  IMPLICIT NONE

  ! Portable precision constants
  INTEGER, PARAMETER :: dl = SELECTED_INT_KIND(18)       ! INT64
  INTEGER, parameter :: ds = SELECTED_REAL_KIND(6,30)    ! FP32
  INTEGER, parameter :: dd = SELECTED_REAL_KIND(14,100)  ! FP64
  INTEGER, PARAMETER :: dc = KIND( (0.0_ds, 1.0_ds) )
  INTEGER, PARAMETER :: dz = KIND( (0.0_dd, 1.0_dd) )

END MODULE mod_prec


! { dg-do compile }
! { dg-options "-O -fdump-tree-original" }
module x
  implicit none
contains
  pure function myfunc(x) result(y)
    integer, intent(in) :: x
    integer, dimension(:), allocatable :: y
    allocate (y(3))
    y(1) = x
    y(2) = 2*x
    y(3) = 3*x
  end function myfunc

  pure function mychar(x) result(r)
    integer, intent(in) :: x
    character(len=2) :: r
    r = achar(x + iachar('0')) // achar(x + iachar('1'))
  end function mychar
end module x

program main
  use x
  implicit none
  integer :: n
  character(len=20) :: line
  n = 3
  write (unit=line,fmt='(3I2)') myfunc(n) + myfunc(n)
  if (line /= ' 61218') call abort
  write (unit=line,fmt='(A)') mychar(2) // mychar(2)
  if (line /= '2323') call abort
end program main
! { dg-final { scan-tree-dump-times "myfunc" 2 "original" } }
! { dg-final { scan-tree-dump-times "mychar" 2 "original" } }