!***********************************************************************
subroutine sort(ra,n)
!=======================================================================
  implicit none
  integer i,j,l,n,ir
  double precision ra(n),rra
!-----------------------------------------------------------------------
  l=n/2+1
  ir=n
10 continue
  if(l.gt.1)then
     l=l-1
     rra=ra(l)
  else
     rra=ra(ir)
     ra(ir)=ra(1)
     ir=ir-1
     if(ir.eq.1)then
        ra(1)=rra
        return
     endif
  endif
  i=l
  j=l+l
20 if(j.le.ir)then
     if(j.lt.ir)then
        if(ra(j).lt.ra(j+1))j=j+1
     endif
     if(rra.lt.ra(j))then
        ra(i)=ra(j)
        i=j
        j=j+j
     else
        j=ir+1
     endif
     go to 20
  endif
  ra(i)=rra
  goto 10
  ! ---------------------------------------------------------------------
end subroutine sort
!***********************************************************************

!***********************************************************************
double precision function Planck(x)
!=======================================================================
! This function evaluates the Planck function multiplied by wavelength
! and normalized by sigma*T^4/Pi.                      [Z.I., Mar. 1996]
! =======================================================================
  implicit none
  double precision x
  ! ---------------------------------------------------------------------
  if (x.gt.100.0d0) then
     Planck = 0.0d0
  else
     if (x.lt.0.00001d0) then
        Planck = 0.155d0*x**3.0d0
     else
        Planck = 0.155d0*x**4.0d0/(dexp(x) - 1.0d0)
     end if
  end if
  ! ---------------------------------------------------------------------
  return
end function Planck
!***********************************************************************

!***********************************************************************
subroutine Simpson(n,n1,n2,x,y,integral)
!=======================================================================
! This subroutine calculates integral I(y(x)*dx). Both y and x are
! 1D arrays, y(i), x(i) with i=1,N (declared with NN). Lower and upper
! integration limits are x(N1) and x(N2), respectively. The method used
! is Simpson (trapezoid) approximation. The resulting integral is sum of
! y(i)*wgth, i=N1,N2.                                  [Z.I., Mar. 1996]
! =======================================================================
  implicit none
  !---parameter
  integer n, n1, n2
  double precision integral
  double precision,allocatable ::  x(:), y(:)
  !---locale
  integer i
  double precision wgth, dyn2
  ! ---------------------------------------------------------------------
  dyn2 = 0.0d0
  ! set integral to 0 and accumulate result in the loop
  integral = 0.0d0
  ! calculate weight, wgth, and integrate in the same loop
  if ((n2-n1).gt.100) then
     !$OMP PARALLEL DO reduction(+:integral) private(i,wgth)
     do i = n1, n2
        ! weigths
        if (i.ne.n1.and.i.ne.n2) then
           wgth = 0.5d0*(x(i+1)-x(i-1))
        else
           if (i.eq.n1) wgth = 0.5d0*(x(n1+1)-x(n1))
           if (i.eq.n2) wgth = 0.5d0*(x(n2)-x(n2-1))
        end if
        ! add contribution to the integral
        integral = integral + y(i)*wgth
     end do
     !$OMP END PARALLEL DO
  else  if (n2.gt.n1) then
     do i = n1, n2
        ! weigths
        if (i.ne.n1.and.i.ne.n2) then
           wgth = 0.5d0*(x(i+1)-x(i-1))
        else
           if (i.eq.n1) wgth = 0.5d0*(x(n1+1)-x(n1))
           if (i.eq.n2) wgth = 0.5d0*(x(n2)-x(n2-1))
        end if
        ! add contribution to the integral
        integral = integral + y(i)*wgth
     end do
  else
     integral = 0.0d0
  end if
  ! --------------------------------------------------------------------
  return
end subroutine Simpson
!***********************************************************************

!***********************************************************************
subroutine PowerInter(nn,n,x,y,xloc,iNloc,Yloc)
!=======================================================================
! This subroutine performs power law interpolation for y(x) such that
! Yloc = y(xloc). It is assumed that x is monotonously increasing.
! [based on sub LinInter by ZI'96, modified for power law interp. by MN'03]
!=======================================================================

  implicit none
  integer nn, n, i, istop, iNloc
  double precision x(nn), y(nn), xloc, Yloc, pow
! -----------------------------------------------------------------------

  if (n.gt.1) then
   if ((x(1)-xloc)*(x(n)-xloc).le.0.0d0) then
     istop = 0
     i = 1
     do while (istop.ne.1)
      i = i + 1
      if (i.gt.n) stop 'powinter ???'
      if (x(i).ge.xloc) then
        istop = 1
        iNloc = i
        if ((y(i)*y(i-1)).gt.0.0d0) then
          pow = dlog(y(i)/y(i-1))/dlog(x(i)/x(i-1))
          Yloc = y(i-1)*((xloc/x(i-1))**pow)
        else
          Yloc = 0.0d0
        end if
      end if
     end do
   else
     if (xloc.le.x(1)) Yloc = y(1)
     if (xloc.ge.x(n)) Yloc = y(n)
   end if
  else
    Yloc = y(1)
  end if
!-----------------------------------------------------------------------
  return
end subroutine PowerInter
!***********************************************************************

!***********************************************************************
subroutine PowerInt(n,n1,n2,x,y,integral)
!=======================================================================
! This subroutine calculates integral I(y(x)*dx). Both y and x are
! 1D arrays, y(i), x(i) with i=1,N (declared with NN). Lower and upper
! integration limits are x(N1) and x(N2), respectively. The method used
! is a power-law approximation for y(x) between any two points .
! (This subroutine is used for integration over size distribution) [ZI,'96]
!=======================================================================

  implicit none
  integer i, n, n1, n2
  double precision x(n), y(n), integral, pow, c, delint
  ! --------------------------------------------------------------------
  ! set integral to 0 and accumulate result in the loop
  integral = 0.0d0
  ! calculate weight, wgth, and integrate in the same loop
  if (n2.gt.n1) then
     do i = n1, n2-1
        pow = dlog(Y(i+1)/Y(i)) / dlog(x(i+1)/x(i))
        c = Y(i) / x(i)**pow
        delint=(x(i+1)**(pow+1.0d+0)-x(i)**(pow+1.0d+0))*c/(pow+1.0d+0)
        ! add contribution to the integral
        integral = integral + delint
     end do
  else
     integral = 0.0d0
     ! this was in case of single size grains
     ! integral = Y(1)
  end if
  !---------------------------------------------------------------------

  return
end subroutine PowerInt
!***********************************************************************

!***********************************************************************
subroutine scaleto1(Nmax,n,y)
!=======================================================================
! This subroutine scales vector Y such that Y(1) = 1.0
!                                                      [Z.I., Jan. 1997]
!=======================================================================
  implicit none
  integer Nmax, N, i
  double precision Y(Nmax), Scale
  !---------------------------------------------------------------------
  Scale = Y(1)
  do i = 1, N
     Y(i) = Y(i) / Scale
  end do
  !---------------------------------------------------------------------
  return
end subroutine scaleto1
!***********************************************************************

!***********************************************************************
subroutine ROMBY(fnc,a,b,ss)
!=======================================================================
! This subroutine performs Romberg integration of function func on
! interval [a,b]. The result is returned in ss. Desired accuracy is set
! to 0.002.                                            [Z.I., Feb. 1996]
! =======================================================================
  IMPLICIT NONE
  INTEGER JMAX,JMAXP,K,KM, J
  PARAMETER (JMAX=30, JMAXP=JMAX+1, K=3, KM=K-1)
  DOUBLE PRECISION a,b,fnc,ss,EPS_loc, aux, dss,h(JMAXP),s(JMAXP)
  EXTERNAL fnc
  ! ---------------------------------------------------------------------
  EPS_loc = 0.002d0
  h(1)=1.0d0
  do j=1,JMAX
     call trapzd(fnc,a,b,s(j),j)
     if (j.ge.K) then
        aux = 0.0d0
        call polint(h(j-KM),s(j-KM),K,aux,ss,dss)
        IF (dabs(dss).le.EPS_loc*dabs(ss)) RETURN
     endif
     s(j+1)=s(j)
     h(j+1)=0.25d0*h(j)
  end do
  ! --------------------------------------------------------------------
  RETURN
END subroutine ROMBY
!***********************************************************************
!!$
!!$
!!$!***********************************************************************
!!$SUBROUTINE ScaletoArea(Nmax,N,X,Y,Area)
!!$! =======================================================================
!!$! This subroutine scales a function Y(x) by the area A=Int{2*Pi Y(x)xdx}.
!!$! X and Y are 1D arrays. (Used for PSF normalization.)       [MN, Sep'04]
!!$! =======================================================================
!!$  IMPLICIT none
!!$  INTEGER Nmax, N, i
!!$  DOUBLE PRECISION Y(Nmax),X(Nmax),Fn(Nmax),Area,Pi
!!$  !-----------------------------------------------------------------------
!!$  Pi = 2.0D+00*ASIN(1.0)
!!$  DO i = 1, N
!!$     Fn(i) = Y(i)*X(i)
!!$  END DO
!!$  ! Integrate:
!!$  Area = 0.0D+00
!!$  DO i = 1, N-1
!!$     Area = Area + 0.5D+00*(Fn(i+1)+Fn(i))*(X(i+1)-X(i))
!!$  END DO
!!$  Area = 2.0D+00*Pi*Area
!!$  ! Normalize:
!!$  DO i = 1, N
!!$     Y(i) = Y(i) / Area
!!$  END DO
!!$  ! -----------------------------------------------------------------------
!!$  RETURN
!!$END SUBROUTINE ScaletoArea
!!$! ***********************************************************************
!!$
!!$!***********************************************************************
!!$subroutine shiftIns(x,Nmax,n,xins,i)
!!$!=======================================================================
!!$! Rearranges a vector X by inserting a new element Xins.    [MN, Aug'96]
!!$! =======================================================================
!!$  use interfaces
!!$  implicit none
!!$  !---parameter
!!$  integer :: Nmax,n,i
!!$  double precision :: xins
!!$  double precision,allocatable :: x(:)
!!$  !---local
!!$  integer j
!!$  ! ---------------------------------------------------------------------
!!$  do j = n+1, i+2, -1
!!$     x(j) = x(j-1)
!!$  end do
!!$  x(i+1) = xins
!!$  ! -----------------------------------------------------------------------
!!$  return
!!$end subroutine shiftIns
!***********************************************************************
!!$
!!$
!***********************************************************************
SUBROUTINE Spline(x,y,n,yp1,ypn,y2)
!=======================================================================
  INTEGER n,NMAX
  DOUBLE PRECISION yp1,ypn,x(n),y(n),y2(n)
  PARAMETER (NMAX=500)
  INTEGER i,k
  DOUBLE PRECISION p,qn,sig,un,u(NMAX)
  ! --------------------------------------------------------------------
  if (yp1.gt..99e30) then
     y2(1)=0.
     u(1)=0.
  else
     y2(1)=-0.5
     u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
  endif
  do i=2,n-1
     sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
     p=sig*y2(i-1)+2.
     y2(i)=(sig-1.)/p
     u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i)) &
          -(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
  end do
  if (ypn.gt..99e30) then
     qn=0.
     un=0.
  else
     qn=0.5
     un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
  endif
  y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
  do k=n-1,1,-1
     y2(k)=y2(k)*y2(k+1)+u(k)
  end do
  ! --------------------------------------------------------------------
  return
end subroutine Spline
!***********************************************************************

!***********************************************************************
SUBROUTINE SPLINE2(x,fun,N,coef)
! =======================================================================
! This subroutine finds coefficients coef(i,j) such that
! fun(x)=coef(i,1) + coef(i,2)*x + coef(i,3)*x^2 + coef(i,4)*x^3
! for x(i).LE.x.LE.x(i+1) is a cubic spline approximation of fun(x),
! with i=1..N.                                         [Z.I., Feb. 1995]
! =======================================================================
  use common
  IMPLICIT none
  INTEGER N, i
  DOUBLE PRECISION x(npY), coef(npY,4), secnder(npY), y2at1, y2atN, &
       Dd, xL, xR, dR, dL, fun(npY), fL, fR
  ! -----------------------------------------------------------------------
  ! find second derivative, secnder
  y2at1 = (fun(2)-fun(1))/(x(2)-x(1))
  y2atN = (fun(N)-fun(N-1))/(x(N)-x(N-1))
  CALL SPLINE(x,fun,N,y2at1,y2atN,secnder)
  ! generate coef(i,j), j=1,2,3,4
  DO i = 1, N-1
     Dd = x(i+1) - x(i)
     xL = x(i)
     xR = x(i+1)
     dL = secnder(i)
     dR = secnder(i+1)
     fL = fun(i)
     fR = fun(i+1)
     coef(i,1) = (xR*fL-xL*fR)/Dd + dL*xR*Dd/6.*((xR/Dd)**2.-1.)
     coef(i,1) = coef(i,1) - dR*xL*Dd/6. *((xL/Dd)**2.-1.)
     coef(i,2) = (fR-fL)/Dd + dL*Dd/6.*(1.-3.*(xR/Dd)**2.)
     coef(i,2) = coef(i,2) - dR*Dd/6.*(1.-3.*(xL/Dd)**2.)
     coef(i,3) = (dL*xR-dR*xL)/Dd/2.
     coef(i,4) = (dR-dL)/6./Dd
  END DO
  ! ---------------------------------------------------------------------
  RETURN
END SUBROUTINE SPLINE2
!***********************************************************************

!***********************************************************************
SUBROUTINE trapzd(func,a,b,s,n)
! =======================================================================
  IMPLICIT NONE
  INTEGER n
  DOUBLE PRECISION a,b,s,func
  EXTERNAL func
  INTEGER it,j
  DOUBLE PRECISION del,sum,tnm,x
  ! ----------------------------------------------------------------------
  IF (n.eq.1) THEN
     s=0.5d0*(b-a)*(func(a)+func(b))
  ELSE
     it=2**(n-2)
     tnm=it
     del=(b-a)/tnm
     x=a+0.5d0*del
     sum=0.
     DO j = 1, it
        sum=sum+func(x)
        x=x+del
     END DO
     s=0.5d0*(s+(b-a)*sum/tnm)
  END IF
  ! -------------------------------------------------------------------------
  RETURN
END SUBROUTINE trapzd
!***********************************************************************

!***********************************************************************
subroutine polint(xa,ya,n,x,y,dy)
  ! For polinomial interpolation, used in Subroutine Romby.
  ! ====================================================================
  implicit none
  integer n,Nmax
  double precision dy,x,y,xa(n),ya(n)
  parameter (Nmax=1000)
  integer i,m,ns
  double precision den,dif,dift,ho,hp,w,c(Nmax),d(Nmax)
  !---------------------------------------------------------------------
  c = 0.0d0
  d = 0.0d0
  ns=1
  dif=dabs(x-xa(1))
  do i=1,n
     dift=dabs(x-xa(i))
     if (dift.lt.dif) then
        ns=i
        dif=dift
     endif
     c(i)=ya(i)
     d(i)=ya(i)
  end do
  y=ya(ns)
  ns=ns-1
  do m=1,n-1
     do i=1,n-m
        ho=xa(i)-x
        hp=xa(i+m)-x
        w=c(i+1)-d(i)
        den=ho-hp
        if(den.eq.0.0d0) then
           write(6,'(a)') 'failure in polint'
           stop
        endif
        den=w/den
        d(i)=hp*den
        c(i)=ho*den
     end do
     if (2*ns.lt.n-m)then
        dy=c(ns+1)
     else
        dy=d(ns)
        ns=ns-1
     endif
     y=y+dy
  end do
!-----------------------------------------------------------------------
  return
end subroutine polint
!***********************************************************************
!!$
!!$
!!$
!***********************************************************************
subroutine doProduct(nn,yt,pt,p0,j,prd)
!=======================================================================
! This is an auxiliary subroutine which evaluates a messy expression
! needed to calculate normalization constants for a broken power law
! density.                                             [Z.I., Aug. 1996]
!=======================================================================
  implicit none
  integer nn, i, j
  double precision yt(nn), pt(nn), prd, p0
  !---------------------------------------------------------------------
  prd = yt(1)**(pt(1) - p0)
  if (j.gt.1) then
     do i = 2, j
        prd = prd * yt(i)**(pt(i) - pt(i-1))
     end do
  end if
  !---------------------------------------------------------------------
  return
end subroutine doProduct
!***********************************************************************
!!$
!!$
!***********************************************************************
subroutine gauleg(x1,x2,xg,wg,n)
!=====================================================================
  implicit none

  integer i,m,n,j
  double precision x1,x2,xm,xl,eps,delj,p,eta
  double precision xg(n),wg(n),sum,ff,p1,p2,p3,z1,z,pp
  parameter (eps=1.0d-14)
  ! -------------------------------------------------------------------
  xg = 0.0d0
  wg = 0.0d0
  m = int((n+1)/2)
  xm = 0.5d0*(x2+x1)
  xl = 0.5d0*(x2-x1)
  do i = 1, m
     z = cos(3.1415926535898d0*(dble(i) - 0.25d0)/(dble(n) + 0.5d0))
1    continue
     p1 = 1.0d0
     p2 = 0.0d0
     do j = 1, n
        p3 = p2
        p2 = p1
        p1 = ((2.0d0*dble(j)-1.0d0)*z*p2-(j-1.0d0)*p3)/dble(j)
     end do
     pp = dble(n)*(z*p1 - p2)/(z*z - 1.0d0)
     z1 = z
     z = z1-p1/pp
     if (abs(z-z1).gt.eps) go to 1
     xg(i) = xm-xl*z
     xg(n+1-i) = xm+xl*z
     wg(i) = 2.d0*xl/((1.d0-z*z)*pp*pp)
     wg(n+1-i) = wg(i)
  end do
  !-------------------------------------------------------------------
  return
end subroutine gauleg
!***********************************************************************

!**********************************************************************
SUBROUTINE ANALINT(nY,Nanal,xaux,yaux,m,aux)

!======================================================================
! This subroutine calculates integral I(x**m*y(x)*dx). Both y and x are
! 1D arrays, y(i), x(i) with i=1,Nanal. The method used is approximation
! of y(x) by y = P(x) + d/sqrt(1-x*x), where P(x) is the polynomial of
! order Nanal-1, and analytic evaluation of the integral. It is assumed
! that xaux(1)=0. Coefficients are determined from the set of Nanal
! linear equations and subsequent call to the linear system solver
! LINSYS.                                              [Z.I., Nov. 1995]
! ANALINT is called from Nordlund to evaluate analytically the contribution
! of Nanal grid points. [MN]
! =======================================================================
  use common
  IMPLICIT none
  INTERFACE
     SUBROUTINE LINSYS(Nreal,A,B,X)
       integer Nreal
       DOUBLE PRECISION,allocatable :: A(:,:), B(:), X(:)
     END SUBROUTINE LINSYS
  END INTERFACE
  !---parameter
  integer nY, Nanal
  double precision :: xaux(Nanal),yaux(Nanal)
  double precision :: m,aux
  !---local
  INTEGER i, j
  DOUBLE PRECISION b
  double precision,allocatable :: A(:,:),xaux_tmp(:),yaux_tmp(:),coeff(:)
  ! ---------------------------------------------------------------------
  allocate(A(Nanal,Nanal))
  A = 0
  allocate(xaux_tmp(Nanal))
  xaux_tmp = 0
  allocate(yaux_tmp(Nanal))
  yaux_tmp = 0
  allocate(coeff(Nanal))
  coeff = 0
  do i=1,Nanal
     xaux_tmp(i) = xaux(i)
     yaux_tmp(i) = yaux(i)
  end do
  error = 0
  ! generate matrix A and vector B
  DO i = 1, Nanal
     DO j = 1, Nanal-1
        IF (xaux_tmp(i).EQ.0.0.AND.j.EQ.1) THEN
           A(i,j) = 1.0
        ELSE
           A(i,j) = xaux_tmp(i)**(1.0*j-1.0)
        END IF
     END DO
     A(i,Nanal) = 1.0/sqrt(1.0-xaux_tmp(i)*xaux_tmp(i))
  END DO
  ! solve for the coefficients
  CALL LINSYS(Nanal,A,yaux_tmp,coeff)
  IF(error.NE.0) THEN
     CALL MSG(19)
     print*,"MSG(19)"
     RETURN
  END IF
  ! upper limit for integration:
  b = xaux_tmp(Nanal)
  ! evaluate m-dependent contribution of the last term
  IF (m.GT.0.1) THEN
     IF (m.GT.1.1) THEN
        ! this is for m=2
        aux = 0.5*(DASIN(b)-b*sqrt(1.-b*b))
     ELSE
        ! this is for m=1
        aux = 1.0 - sqrt(1.-b*b)
     ENDIF
  ELSE
     ! this is for m=0
     aux = DASIN(b)
  ENDIF
  aux = aux * coeff(Nanal)
  ! add contribution from the polynom
  DO i = 1, Nanal-1
     aux = aux + coeff(i) * (b**(m+1.0*i)) / (m+1.0*i)
  END DO
! -----------------------------------------------------------------------
  do i=1,Nanal
     xaux(i) = xaux_tmp(i)
     yaux(i) = yaux_tmp(i)
  end do
999 deallocate(A)
  deallocate(xaux_tmp)
  deallocate(yaux_tmp)
  deallocate(coeff)
  RETURN
END SUBROUTINE ANALINT
!***********************************************************************

! ***********************************************************************
SUBROUTINE ChkConv(nY,accuracy_loc,Aold,Anew,Aconv_loc)
! =======================================================================
! This subroutine checks convergence of an array A(nY) between values
! given in Aold and Anew. If the relative difference for EVERY element
! is smaller than accuracy, Aconv is assigned 1, otherwise 0.
!                                                      [Z.I., Jul. 1996]
! =======================================================================
  use common
  IMPLICIT none
  ! --- parameter
  INTEGER Aconv_loc,nY
  DOUBLE PRECISION accuracy_loc
  DOUBLE PRECISION,allocatable :: Aold(:), Anew(:)
  ! --- local
  INTEGER iY
  DOUBLE PRECISION delta
! -----------------------------------------------------------------------
  Aconv_loc = 1
  ! loop over radial positions
  DO iY = 1, nY
     ! find relative difference
     delta = dabs(Anew(iY)-Aold(iY))
     IF (delta.GT.dabs(Anew(iY))*accuracy_loc) Aconv_loc = 0
  END DO
  ! -----------------------------------------------------------------------
  RETURN
END SUBROUTINE ChkConv
! ***********************************************************************

!***********************************************************************
SUBROUTINE LINSYS(Nreal,A,B,X)
!=======================================================================
! This subroutine solves the set of linear equations [A]*[X] = [B] for
! X [A(k,1)*X(1)+A(k,2)*X(2)+...+A(k,Nreal)*X(Nreal) = B(k), k=1,Nreal).
! The real size of matrix A is Nreal x Nreal and its physical dimension
! is npY x npY, where npY comes from INCLUDE 'userpar.inc'. Both vectors
! B and X have real lengths Nreal. The set is solved by calls to LUDCMP
! and LUBKSB and the solution is improved subsequently by a call to
! MPROVE. These three subroutines are taken from Numerical Recipes.
!                                                      [Z.I., Nov. 1995]
! =======================================================================
  use common
  IMPLICIT none
  !--- parameter
  integer nY,Nreal
  DOUBLE PRECISION,allocatable :: A(:,:), B(:), X(:)
  !--- local
  INTEGER i, j
  integer ,allocatable :: indx(:)
  DOUBLE PRECISION d
  double precision,allocatable :: A1c(:,:), B1(:), A2c(:,:), B2(:)
  INTERFACE
     SUBROUTINE LUDCMP(A,N,NP,INDX,D)
       integer N,NP
       double precision :: D
       integer, allocatable :: indx(:)
       double precision,allocatable :: A(:,:),B(:)
     END SUBROUTINE LUDCMP
     SUBROUTINE LUBKSB(A,N,NP,INDX,B)
       integer N,NP
       integer, allocatable :: indx(:)
       double precision,allocatable :: A(:,:),B(:)
     END SUBROUTINE LUBKSB
     SUBROUTINE MPROVE(A,ALUD,N,NP,INDX,B,X)
       integer :: n,np
       integer,allocatable :: INDX(:)
       double precision,allocatable :: A(:,:),ALUD(:,:),B(:),X(:)
     END SUBROUTINE MPROVE
  END INTERFACE
  ! ---------------------------------------------------------------------
  allocate(indx(Nreal))
  indx = 0
  allocate(A1c(Nreal,Nreal))
  A1c = 0
  allocate(B1(Nreal))
  B1 = 0
  allocate(A2c(Nreal,Nreal))
  A2c = 0
  allocate(B2(Nreal))
  B2 = 0
  error = 0
  ! generate DOUBLE PRECISION copies of A and B (two copies because they
  ! are changed in LUDCMP and LUBKSB, but still needed for MPROVE)
  DO i = 1, Nreal
     B1(i) = B(i)
     B2(i) = B(i)
     DO j = 1, Nreal
        A1c(i,j) = A(i,j)
        A2c(i,j) = A(i,j)
     END DO
  END DO
  ! solve the system
  CALL LUDCMP(A1c,Nreal,nY,indx,d)
  IF (error.NE.0) RETURN
  CALL LUBKSB(A1c,Nreal,nY,indx,B1)
  ! improve the solution (saved in B)
  CALL MPROVE(A2c,A1c,Nreal,nY,indx,B2,B1)
  ! copy the improved solution to output vector X
  DO i = 1, Nreal
     X(i) = B1(i)
  END DO
  ! --------------------------------------------------------------------
  deallocate(indx)
  deallocate(A1c)
  deallocate(B1)
  deallocate(A2c)
  deallocate(B2)
  RETURN
END SUBROUTINE LINSYS
!***********************************************************************

! ***********************************************************************
SUBROUTINE LUBKSB(A,N,NP,INDX,B)
  IMPLICIT none
  !---parameter
  integer N,NP
  integer, allocatable :: indx(:)
  double precision,allocatable :: A(:,:),B(:)
  !---local
  integer :: i,j,ii,ll
  double precision :: sum
!!$  DIMENSION INDX(NP)
!!$  DOUBLE PRECISION A(NP,NP),B(NP)
  ! -------------------------------------------------------------------
  II=0
  !impossible to parallelize since B(J) needs to is changed and used!
  DO I=1,N
     LL=INDX(I)
     SUM=B(LL)
     B(LL)=B(I)
     IF (II.NE.0)THEN
        DO J=II,I-1
           SUM=SUM-A(I,J)*B(J)
        END DO
     ELSE IF (SUM.NE.0.) THEN
        II=I
     ENDIF
     B(I)=SUM
  END DO
  !impossible to parallelize since B(J) needs to is changed and used!
  DO I=N,1,-1
     SUM=B(I)
     IF(I.LT.N)THEN
        DO J=I+1,N
           SUM=SUM-A(I,J)*B(J)
        END DO
     ENDIF
     B(I)=SUM/A(I,I)
  END DO
  ! -------------------------------------------------------------------
  RETURN
END SUBROUTINE LUBKSB
! ***********************************************************************

! ***********************************************************************
SUBROUTINE LUDCMP(A,N,NP,INDX,D)
  IMPLICIT none
  !---parameter
  integer N,NP
  double precision :: D
  integer, allocatable :: indx(:)
  double precision,allocatable :: A(:,:),B(:)
  !---local
  integer :: i,k,j,imax,error
  DOUBLE PRECISION TINY
  PARAMETER (TINY=1.D-20)
  DOUBLE PRECISION,allocatable :: VV(:)
  double precision :: SUM,aamax,DUM
  ! ------------------------------------------------------------------
  allocate(VV(N))
  VV = 0
  error = 0
  D = 1.
  DO I = 1, N
     AAMAX=0.
     DO J = 1, N
        IF (DABS(A(I,J)).GT.AAMAX) AAMAX=DABS(A(I,J))
     END DO
     ! IF (AAMAX.EQ.0.) PAUSE 'Singular matrix.'
     IF (AAMAX.EQ.0.) THEN
        error = 5
        RETURN
     ENDIF
     VV(I)=1./AAMAX
  END DO
!!  !$OMP PARALLEL DO private(J,I,SUM,DUM,IMAX,AAMAX,D)
  DO J = 1 , N
     IF (J.GT.1) THEN
        DO I = 1, J-1
           SUM=A(I,J)
           IF (I.GT.1)THEN
              DO K = 1, I-1
                 SUM=SUM-A(I,K)*A(K,J)
              END DO
              A(I,J)=SUM
           ENDIF
        END DO
     ENDIF
     AAMAX=0.
     DO I = J, N
        SUM=A(I,J)
        IF (J.GT.1)THEN
           DO K = 1, J-1
              SUM=SUM-A(I,K)*A(K,J)
           END DO
           A(I,J)=SUM
        ENDIF
        DUM=VV(I)*DABS(SUM)
        IF (DUM.GE.AAMAX) THEN
           IMAX=I
           AAMAX=DUM
        ENDIF
     END DO
     IF (J.NE.IMAX)THEN
        DO K = 1, N
           DUM=A(IMAX,K)
           A(IMAX,K)=A(J,K)
           A(J,K)=DUM
        END DO
        D=-D
        VV(IMAX)=VV(J)
     ENDIF
     INDX(J)=IMAX
     IF(J.NE.N)THEN
        IF(A(J,J).EQ.0.)A(J,J)=TINY
        DUM=1./A(J,J)
        DO I = J+1, N
           A(I,J)=A(I,J)*DUM
        END DO
     ENDIF
  END DO
!!  !$OMP END PARALLEL DO
  IF(A(N,N).EQ.0.)A(N,N)=TINY
  !------------------------------------------------------------------
  deallocate(VV)
  RETURN
END SUBROUTINE LUDCMP
! ***********************************************************************

!***********************************************************************
SUBROUTINE MPROVE(A,ALUD,N,NP,INDX,B,X)
  IMPLICIT none
  INTERFACE
     SUBROUTINE LUBKSB(A,N,NP,INDX,B)
       integer N,NP
       integer, allocatable :: indx(:)
       double precision,allocatable :: A(:,:),B(:)
     END SUBROUTINE LUBKSB
  END INTERFACE
  !---parameter
  integer :: n,np
  integer,allocatable :: INDX(:)
  double precision,allocatable :: A(:,:),ALUD(:,:),B(:),X(:)
  !---local
  integer i,j
  DOUBLE PRECISION SDP
  double precision,allocatable :: R(:)
  ! ---------------------------------------------------------------------
  allocate(R(N))
  R = 0
  DO i = 1, N
     SDP = -B(i)
     DO j = 1, N
        SDP = SDP + A(i,j)*X(j)
     END DO
     R(i) = SDP
  END DO
  CALL LUBKSB(ALUD,N,NP,INDX,R)
  DO i = 1, N
     X(i) = X(i) - R(i)
  END DO
  ! -----------------------------------------------------------------------
  deallocate(R)
  RETURN
END SUBROUTINE MPROVE
!***********************************************************************

! ***********************************************************************
SUBROUTINE Maple3(w,z,p,MpInt)
! =====================================================================
! This function calculates indefinite integral:
!    MpInt(iC) = INT(w^(2-iC) / sqrt(w^2-p^2) * dw), for iC=1,2,3,4.
!                                                     [Z.I., Apr. 1996]
! =====================================================================
  IMPLICIT none
  DOUBLE PRECISION w, z, p, MpInt(4)
  ! ---------------------------------------------------------------------
  ! integrals
  MpInt(1) = z
  MpInt(2) = dlog(w+z)
  IF (p.GT.0.0) THEN
     MpInt(3) = dacos(p/w)/p
     MpInt(4) = z/w/p/p
  ELSE
     MpInt(3) = -1.0 / w
     MpInt(4) = -0.5 / w / w
  END IF
  ! ---------------------------------------------------------------------
  RETURN
END SUBROUTINE Maple3
!***********************************************************************

!**********************************************************************
subroutine add(np1,nr1,np2,nr2,q1,q2,q3,qout) !only needed in matrix method
!======================================================================
! This subroutine evaluates the following expression:
! [qOut] = [q1] + [q2] + [q3]. qout, q1, q2 and q2 are matrices of
! physical size (np2,np1) and real size (nr2,nr1).     [Z.I., Nov. 1995]
! ======================================================================
  implicit none
  !---parameter
  integer np1, nr1, np2, nr2
  double precision, allocatable :: q1(:,:), q2(:,:), q3(:,:),qout(:,:)
  !---local
  integer  i2, i1
  !--------------------------------------------------------------------
  ! loop over index 2
  do i2 = 1, nr2
     ! loop over index 1
     do i1 = 1, nr1
        qout(i2,i1) = q1(i2,i1) +  q2(i2,i1) + q3(i2,i1)
     end do
  end do
  !--------------------------------------------------------------------
  return
end subroutine add
!**********************************************************************
!!$
!***********************************************************************
SUBROUTINE ChkRange(dr,x)
!=======================================================================
! This subroutine checks if x is within the allowed range defined by
! dr<<1:
!         dr**2 < x < 1/dr**2
! If it is not then x = 0.0                            [Z.I., Jan. 1997]
!=======================================================================
  IMPLICIT none
  DOUBLE PRECISION x, dr
!-----------------------------------------------------------------------
  IF ((x-dr*dr)*(x-1.0d0/dr/dr).LT.0.0d0) THEN
     continue
  ELSE
     ! continue
     x = 0.0d0
  END IF
!-----------------------------------------------------------------------
  RETURN
END SUBROUTINE ChkRange
!***********************************************************************
!!$
!!$!***********************************************************************
!!$DOUBLE PRECISION FUNCTION Bessel(x)
!!$!=======================================================================
!!$! This function evaluates the Bessel function of the zeroth kind.
!!$! Formulae are from Abramowitz & Stegun.               [Z.I., Jan. 1997]
!!$! =======================================================================
!!$  use common
!!$  IMPLICIT none
!!$  INTEGER i
!!$  DOUBLE PRECISION x, c(6)
!!$  ! ---------------------------------------------------------------------
!!$  c(1) = -2.2499997D+00
!!$  c(2) =  1.2656208D+00
!!$  c(3) = -0.3163866D+00
!!$  c(4) =  0.0444479D+00
!!$  c(5) = -0.0039444D+00
!!$  c(6) =  0.00021D+00
!!$  Bessel=0.0D+00
!!$  IF (x.LE.3.0D+00)THEN
!!$     DO i=1,6
!!$        Bessel = Bessel + c(i)*(x/3.0D+00)**(2.0D+00*i)
!!$     END DO
!!$     Bessel = 1.0D+00 + Bessel
!!$  ELSE
!!$     Bessel = dsqrt(2.0D+00/Pi/x) * dcos(x-Pi/4.0D+00)
!!$  ENDIF
!!$  ! --------------------------------------------------------------------
!!$  RETURN
!!$END FUNCTION Bessel
!!$!***********************************************************************

!***********************************************************************
subroutine LinInter(nn,n,x,y,xloc,iNloc,Yloc)
!=======================================================================
! This subroutine performs linear interpolation for y(x) such that
! Yloc = y(xloc). It is assumed that x is monotonously increasing.
!                                                      [Z.I., Mar. 1996]
!=======================================================================
  implicit none
  integer nn, n, i, istop, iNloc
  double precision x(nn), y(nn), xloc, Yloc
  !---------------------------------------------------------------------
  if (n.gt.1) then
     if ((x(1)-xloc)*(x(n)-xloc).le.0.0d0) then
        istop = 0
        i = 1
        do while (istop.ne.1)
           i = i + 1
           if (i.gt.n) stop 'lininter ???'
           if (x(i).ge.xloc) then
              istop = 1
              iNloc = i
              Yloc = y(i-1) + (y(i)-y(i-1))/(x(i)-x(i-1))*(xloc-x(i-1))
           end if
        end do
     else
        if (xloc.le.x(1)) Yloc = y(1)
        if (xloc.ge.x(n)) Yloc = y(n)
     end if
  else
     Yloc = y(1)
  end if
  !---------------------------------------------------------------------
  return
end subroutine LinInter
!***********************************************************************


! { dg-do run }
! { dg-options "-O" }
! PR 80304 - this used to give a wrong result.
! Original test case by Chinoune
module test_mod
  implicit none

contains

  pure real function add(i,j,k)
    integer ,intent(in) :: i,j,k
    add = real(i+j+k)+1.
  end function add

  pure real function add2(i,j,k)
    integer ,intent(in) :: i,j,k
    add2 = real(i+j+k)
  end function add2

  subroutine check_err(a, s)
    real, dimension(:,:), intent(in) :: a
    real, intent(in) :: s
    if (abs(sum(a) - s) > 1e-5) STOP 1
  end subroutine check_err

end module test_mod

program test
  use test_mod
  implicit none

  integer :: i ,j
  real :: a(0:1,0:1) ,b(0:1,0:1)

  ! first do-concurrent loop
  a = 0.
  b = 0.
  DO CONCURRENT( i=0:1 ,j=0:1)
     a(i,j) = add(i,j,abs(i-j))
     b(i,j) = add2(i,j,abs(i-j))
  END DO
  call check_err (a, 10.)
  call check_err (b, 6.)

  ! normal do loop
  a = 0.
  b = 0.
  DO i=0,1
     DO j=0,1
        a(i,j) = add(i,j,abs(i-j))
        b(i,j) = add2(i,j,abs(i-j))
     END DO
  END DO
  call check_err (a, 10.)
  call check_err (b, 6.)

  ! second do-concuurent loop
  a = 0.
  b = 0.
  DO CONCURRENT( i=0:1 ,j=0:1)
     a(i,j) = add(i,j,abs(i-j))
     b(i,j) = add2(i,j,abs(i-j))
  END DO
  call check_err (a, 10.)
  call check_err (b, 6.)

end program test


program test_random
    use,intrinsic :: iso_fortran_env
    use random_mod
    implicit none

    print'(a)', '### random_mod test'
    print'(a)', '# random01_test'
    if (.not. random01_limits()) error stop
    print'(a)', '# randrange_limits'
    if (.not. randrange_limits()) error stop
contains
    function random01_limits() result(ret)
        integer(int32):: n,i
        real(real64),allocatable:: a(:)
        real(real64):: amin, amax
        logical:: ret

        n=10000
        allocate(a(n), source=[(random01(),i=1,n)])
        amin=a(1)
        amax=a(1)
        do i=1,n
            if (a(i)<amin) then
                amin = a(i)
            else if (a(i)>amax) then
                amax = a(i)
            end if
        end do
        ret = 0d0<=amin .and. amax<=1d0
    end function

    function randrange_limits() result(ret)
        integer(int32):: n,i
        integer(int32):: imin,imax ! 乱数の理論下限/上限
        integer(int32):: amax,amin ! 乱数の実際下限/上限
        integer(int32), allocatable:: a(:)
        logical:: ret

        n=10000
        imin=0
        imax=100
        allocate(a(n), source=[(randrange(imin,imax),i=1,n)])
        amax = a(1)
        amin = a(1)
        do i=1,n
            amax = max(amax, a(i))
            amin = min(amin, a(i))
        end do

        ret = imin<=amin .and. amax<=imax
    end function
end program test_random


    Program zggevx_example

!     ZGGEVX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_sort_realvec_rank_rearrange, &
        nagf_blas_dpyth, nagf_sort_cmplxvec_rank_rearrange, &
        nagf_sort_realvec_rank
      Use lapack_interfaces, Only: zggevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
      Logical, Parameter :: verbose = .False.
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig, scal
      Real (Kind=dp) :: abnorm, abnrm, bbnrm, eps, small, tol
      Integer :: i, ifail, ihi, ilo, info, j, k, lda, ldb, ldvr, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        temp(:), vr(:, :), work(:)
      Complex (Kind=dp) :: dummy(1, 1)
      Real (Kind=dp), Allocatable :: lscale(:), rconde(:), rcondv(:), &
        rscale(:), rwork(:)
      Integer, Allocatable :: irank(:), iwork(:)
      Logical, Allocatable :: bwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max, maxloc, nint, real, tiny
!     .. Executable Statements ..
      Write (nout, *) 'ZGGEVX Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvr = n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), vr(ldvr,n), lscale(n), &
        rconde(n), rcondv(n), rscale(n), rwork(6*n), iwork(n+2), bwork(n), &
        temp(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zggevx('Balance', 'No vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, alpha, beta, &
        dummy, 1, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, &
        rcondv, dummy, lwork, rwork, iwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2*n)*n, nint(real(dummy(1,1))))
      Allocate (work(lwork))

!     Read in the matrices A and B

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Solve the generalized eigenvalue problem

      Call zggevx('Balance', 'No vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, alpha, beta, &
        dummy, 1, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, &
        rcondv, work, lwork, rwork, iwork, bwork, info)

      If (info>0) Then
        Write (nout, *)
        Write (nout, 100) 'Failure in ZGGEVX. INFO =', info
      Else

!       Compute the machine precision, the safe range parameter
!       SMALL and sqrt(ABNRM**2+BBNRM**2)

        eps = epsilon(1.0E0_dp)
        small = tiny(1.0E0_dp)
        abnorm = nagf_blas_dpyth(abnrm, bbnrm)
        tol = eps*abnorm

!       Reorder eigenvalues by descending absolute value
        rwork(1:n) = abs(alpha(1:n)/beta(1:n))
        Allocate (irank(n))
        ifail = 0
        Call nagf_sort_realvec_rank(rwork, 1, n, 'Descending', irank, ifail)
        Call nagf_sort_cmplxvec_rank_rearrange(alpha, 1, n, irank, ifail)
        Call nagf_sort_cmplxvec_rank_rearrange(beta, 1, n, irank, ifail)
        Call nagf_sort_realvec_rank_rearrange(rconde, 1, n, irank, ifail)
!       Reorder eigenvectors accordingly
        Do j = 1, n
          temp(1:n) = vr(j, 1:n)
          Call nagf_sort_cmplxvec_rank_rearrange(temp, 1, n, irank, ifail)
          vr(j, 1:n) = temp(1:n)
        End Do
        Call nagf_sort_realvec_rank_rearrange(rcondv, 1, n, irank, ifail)

!       Print out eigenvalues and vectors and associated condition
!       number and bounds

        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, *)
        If (verbose) Then
          Write (nout, *) '         Eigenvalue           rcond    error'
        Else
          Write (nout, *) '         Eigenvalue'
        End If

        Do j = 1, n

!         Print out information on the j-th eigenvalue

          If ((abs(alpha(j)))*small>=abs(beta(j))) Then
            If (rconde(j)>0.0_dp) Then
              If (tol/rconde(j)<500.0_dp*eps) Then
                Write (nout, 140) j, rconde(j), '-'
              Else
                Write (nout, 150) j, rconde(j), tol/rconde(j)
              End If
            Else
              Write (nout, 140) j, rconde(j), 'Inf'
            End If
          Else
            eig = alpha(j)/beta(j)
            If (verbose) Then
              If (rconde(j)>0.0_dp) Then
                If (tol/rconde(j)<500.0_dp*eps) Then
                  Write (nout, 110) j, eig, rconde(j), '-'
                Else
                  Write (nout, 120) j, eig, rconde(j), tol/rconde(j)
                End If
              Else
                Write (nout, 110) j, eig, rconde(j), 'Inf'
              End If
            Else
              Write (nout, 110) j, eig
            End If
          End If

        End Do

        Write (nout, *)
        Write (nout, *) 'Eigenvectors'
        Write (nout, *)
        If (verbose) Then
          Write (nout, *) '         Eigenvector          rcond    error'
        Else
          Write (nout, *) '         Eigenvector'
        End If

        Do j = 1, n

!         Print information on j-th eigenvector
          Write (nout, *)

!         Re-normalize eigenvector, largest absolute element real (=1)
          rwork(1:n) = abs(vr(1:n,j))
          k = maxloc(rwork(1:n), 1)
          scal = (1.0_dp, 0.0_dp)/vr(k, j)
          vr(1:n, j) = vr(1:n, j)*scal

          If (verbose) Then
            If (rcondv(j)>0.0_dp) Then
              If (tol/rcondv(j)<500.0_dp*eps) Then
                Write (nout, 110) j, vr(1, j), rcondv(j), '-'
              Else
                Write (nout, 120) j, vr(1, j), rcondv(j), tol/rcondv(j)
              End If
            Else
              Write (nout, 110) j, vr(1, j), rcondv(j), 'Inf'
            End If
          Else
            Write (nout, 110) j, vr(1, j)
          End If
          Write (nout, 130) vr(2:n, j)

        End Do

        If (verbose) Then
          Write (nout, *)
          Write (nout, *) &
            'Errors below 500*machine precision are not displayed'
        End If
      End If

100   Format (1X, A, I4)
110   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 4X, &
        A)
120   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 1X, &
        1P, E8.1)
130   Format (1X, 3X, '(', 1P, E11.4, ',', E11.4, ')')
140   Format (1X, I2, 1X, '  Infinite or undetermined', 1X, 0P, F7.4, 4X, A)
150   Format (1X, I2, 1X, '  Infinite or undetermined', 1X, 0P, F7.4, 1X, 1P, &
        E8.1)

    End Program


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!     Projet MICO 1995 - Partie theorique (ver. FORTRAN/Python)
!
!            Calcule u(v) et P(u) par Newton Raphson
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!                       | P
!                       |
!                       |  a
!                       |-->
!        ^           o------o---u
!        |            \    /|
!        |             \  /  v
!        |              \/
!        |              /\
!        |             /  \
!        |            /    \
!      h |           /      \
!        |          /        \
!        |         /          \
!        |        /            \
!        |       /              \
!        |      /                \
!        v     o         |--------o
!                            b

module pars

    integer, parameter :: DP = KIND(1.0D0)   !< double precision

    real(DP) :: h = 40.     ! height
    real(DP) :: a = 24.     ! x pos of upper join
    real(DP) :: b = 40.     ! x pos of lower join
    real(DP) :: Vh = 160.   ! volume of horizontal rod
    real(DP) :: Vv = 200.   ! volume of vertical rods
    real(DP) :: E = 70000.  ! Young's modulus

    integer, parameter :: ivmax = 91
    integer, parameter :: ivmaxl = 16

end module pars

subroutine theoric(x, y, P, vl, ul, Pl)
    use pars
    implicit none

    real(DP), intent(inout) :: P(ivmax), x(ivmax), y(ivmax)    !< nonlinear response
    real(DP), intent(inout) :: Pl(ivmaxl), vl(ivmaxl), ul(ivmaxl)  !< linear response

    ! ----Declarations--------
    integer :: j
    logical :: converged
    real(DP) :: Lh, Lv
    real(DP) :: TOL
    real(DP) :: u, v, lastu, F, DF, Du

    ! ----Donnees-------------

    print *, 'computing solution from theory...'

    Lh = 2*a                       ! length of the horizontal rod
    Lv = sqrt(h**2 + (b + a)**2)   ! length of the vertical rods
    TOL = 1e-5                     ! N-R tolerance

    ! Nonlinear response
    u = 0.
    lastu = 0.

    do j = 0, ivmax-1
        ! set v
        v = real(j, KIND(v))

        ! solve u = u(v) with a N-R procedure
        lastu = 2*TOL
        converged = .false.
        do while (.not. converged)
            F = force(u, v)
            if (abs(u - lastu) > TOL) then
                DF = dforce(u, v)
                Du = -F/DF
                lastu = u
                u = u + Du
            else
                converged = .true.
            endif
        enddo

        ! compute P from u, v and fill arrays
        x(j+1) = v
        y(j+1) = u
        P(j+1) = (E*Vv/Lv**4)*(v*v + u*u - 2*h*v + 2*u*(a + b))*(v - h)
    enddo

    ! Linear response
    do j = 0, ivmaxl-1
        v = real(j, KIND(v))
        vl(j + 1) = v
        ul(j + 1) = 2*h*v*(a + b)*Vv/Lv**4/(Vh/a**2 + 2*Vv*(a + b)**2/Lv**4)
        Pl(j + 1) = -2*h*Vv*E/Lv**4*(ul(v + 1)*(a + b) - h*v)
    enddo

contains
    function force(u, v)
        implicit none
        real(DP), intent(in) :: u, v
        real(DP) :: force
        force = (Vv/Lv**4)*(v**2 + u**2 - 2*h*v + 2*u*(a + b))*(u + a + b) &
                + (8*Vh/Lh**4)*(u**2 + 2*a*u)*(u + a)
    end function

    function dforce(u, v)
        implicit none
        real(DP), intent(in) :: u, v
        real(DP) :: dforce
        dforce = (Vv/Lv**4)*((u + a + b)*(2*u + 2*(a + b)) &
                             + (v**2 + u**2 - 2*h*v + 2*u*(a + b))) &
                 + (8*Vh/Lh**4)*((2*u + 2*a)*(u + a) + (u**2 + 2*u*a))
    end function

end subroutine theoric


c this version from 18 March 1998 uses revised coefficients
c that are consistent with Cordes \& Rickett (1998, ApJ, submitted)
c modifications:
c	28 March 2001: added FUNCTION TRANSITION_FREQUENCY

      REAL FUNCTION TAUISS(d, sm, nu)
c
c calculates the pulse broadening time in ms
c from distance, scattering measure, and radio frequency
c
c input:      d = pulsar distance       (kpc)
c            sm = scattering measure    (kpc m^{-20/3})
c            nu = radio frequency       (GHz)
c output: tauss = pulse broadening time (ms)
c
      implicit none
      real d, sm,  nu
      tauiss = 1000. * (sm / 292.)**1.2 * d * nu**(-4.4)
      end
c
c
      REAL FUNCTION SCINTBW(d, sm, nu)
c
c calculates the scintillation bandwidth in kHz
c from distance, scattering measure, and radio frequency
c
c input:        d = pulsar distance       (kpc)
c              sm = scattering measure    (kpc m^{-20/3})
c              nu = radio frequency       (GHz)
c output: scintbw = scintillation bandwidth (kHz)
c
      implicit none
      real d, sm, nu
      real c1
      parameter(c1=1.16)		! for uniform, Kolmogorov medium
      real tauiss
      tauiss = 1000. * (sm / 292.)**1.2 * d * nu**(-4.4)	! ms
      scintbw = c1 / (2. * 3.14159 * tauiss)			! kHz
      end

      REAL FUNCTION SCINTIME(sm, nu, vperp)
c
c calculates the scintillation speed for given distance, galactic
c longitude and latitude, frequency, and transverse velocity
c
c input:   sm = scattering measure	(kpc m^{-20/3})
c          nu = radio frequency 	(GHz)
c       vperp = psr transverse speed  	(km/s)
c
c output: scintime = scintillation time (sec)
c
c usage: should be called with sm = smtau for appropriate
c        line of sight weighting
c reference: eqn (46) of Cordes & Lazio 1991, ApJ, 376, 123.
c
      implicit none
      real sm, nu, vperp
c nb: formerly, the coeff. in the following line was 2.3 from
c     Cordes & Lazio (1991)
      scintime = 3.3 * nu**1.2 * sm**(-0.6) * (100./vperp)
      end

      REAL FUNCTION SPECBROAD(sm, nu, vperp)
c
c calculates the bandwdith of spectral broadening
c for given scattering measure, , frequency, and transverse velocity

c input:   sm = scattering measure	(kpc m^{-20/3})
c          nu = radio frequency 	(GHz)
c       vperp = psr transverse speed  	(km/s)

c output: specbroad = spectral broadening bandwidth (Hz)
c
c usage: should be called with sm = smtau for appropriate
c        line of sight weighting
c reference: eqn (47) of Cordes & Lazio 1991, ApJ, 376, 123.
c
      implicit none
      real sm, nu, vperp
c nb: the coeff. in the following line is 0.14 Hz  from Cordes & Lazio (1991)
c it is changed to 0.097 to conform with FUNCTION SCINTIME and
c a new calculation consistent with Cordes & Rickett (1998)

      specbroad = 0.097 * nu**(-1.2) * sm**0.6 * (vperp/100.)	! Hz
      end

      REAL FUNCTION THETA_XGAL(sm, nu)
c
c calculates angular broadening for an extragalactic
c source of plane waves
c
c sm = scattering measure
c nu = radio frequency
c theta_xgal = angular broadening FWHM (mas)
c
      implicit none
      real sm, nu
      theta_xgal = 128. * sm**0.6 * nu**(-2.2)
      end
c
      REAL FUNCTION THETA_GAL(sm, nu)
c
c calculates angular broadening for a galactic
c source of spherical waves
c
c sm = scattering measure
c nu = radio frequency
c theta_gal = angular broadening FWHM (mas)
c
      implicit none
      real sm, nu
      theta_gal = 71. * sm**0.6 * nu**(-2.2)
      end
c
      FUNCTION EM (sm)
c
c units of sm are kpc m^{-20/3}
c units of em are pc cm^{-6}
c
c calculates the emission measure from the scattering measure
c using an assumed outer scale and spectral index of the
c wavenumber spectrum.
c
c for a wavenumber spectrum P_n(q) = q^{-alpha} from q_0 to q_1
c the mean square electron density is
c
c <n_e^2> =~  4pi*[C_n^2 / (alpha - 3) ] * q_0^{3 - alpha)
c
c ( an approximate form that assumes (q_0 / q_1)^{3-alpha} >> 1.
c
c Jim Cordes 18 Dec 1989
c
      data router /1./	! outer scale = 1 pc
      data pc/3.086e+18/
      data alpha/3.6666667/
      data pi/3.14159/
c
      em = sm *
     1         ( (4. * pi * 1000.) / (alpha - 3.) ) *
     2         (router*pc / (2. * 3.14159) )**(alpha-3.) *
     3         (0.01) ** (20./3.)
c
      return
      end

      REAL FUNCTION THETA_ISO(smiso, nu)
      real smiso, nu

c smiso in (kpc m^{-20/3}) x kpc^{5/3}
c    nu in GHz
c returns the isoplanatic angle in microarcsec
c 12 October 1998
c JMC

c \theta_{iso} = \delta r_s / d
c              = \left [
c	         (\lambda r_e)^2 f_{\alpha} SM_{iso}
c		 \right ]^{1/\alpha}
c where \alpha = 5/3 for Kolmogorov case.
c NB SM_{iso} = \int_0^d ds s^{\alpha} \cnsq
c    so SM_{iso} does not have the units of scattering
c    measure, but rather units of SM x Length^{\alpha}
c
c f_{\alpha} = 8\pi^2 \Gamma(1-\alpha/2) / [\alpha 2^{\alpha} \Gamma(1+\alpha/2)]
c for \alpha = 5/3, f_{\alpha}= 88.3
c
c     real r_e
c     parameter(r_e = 2.82e-13)			!cm
c     real kpc
c     parameter(kpc = 3.086e21)			!cm
c     real falpha
c     parameter(falpha=88.3)

      theta_log_radian =
     .    13.287  				! 0.6*log10(30cm*r_e)
     .  + 1.2 * alog10(nu)
     .  - 1.1676				! 0.6*log10(f_alpha)
     .  - 0.6 * alog10(smiso)
     .  - 34.383				! 1.6 * alog10(kpc)
     .  + 8.					! -(20/3)*log(100)
      theta_log_microarcsec =
     .      theta_log_radian + 11.314425	! 11.314425=alog10(microarsec/rad)
      theta_iso = 10.**theta_log_microarcsec
      return
      end

      REAL FUNCTION THETA_ISO_TEST(smiso, nu)
      real smiso, nu

c smiso in (kpc m^{-20/3}) x kpc^{5/3}
c    nu in GHz
c returns the isoplanatic angle in microarcsec
c 12 October 1998
c JMC

c \theta_{iso} = \delta r_s / d
c              = \left [
c	         (\lambda r_e)^2 f_{\alpha} SM_{iso}
c		 \right ]^{1/\alpha}
c where \alpha = 5/3 for Kolmogorov case.
c NB SM_{iso} = \int_0^d ds s^{\alpha} \cnsq
c    so SM_{iso} does not have the units of scattering
c    measure, but rather units of SM x Length^{\alpha}
c
c f_{\alpha} = 8\pi^2 \Gamma(1-\alpha/2) / [\alpha 2^{\alpha} \Gamma(1+\alpha/2)]
c for \alpha = 5/3, f_{\alpha}= 88.3
c
c     real r_e
c     parameter(r_e = 2.82e-13)			!cm
c     real kpc
c     parameter(kpc = 3.086e21)			!cm
c     real falpha
c     parameter(falpha=88.3)

      theta_log_radian =
     .    13.287  				! 0.6*log10(30cm*r_e)
     .  + 1.2 * alog10(nu)
     .  - 1.1676				! 0.6*log10(f_alpha)
     .  - 0.6 * alog10(smiso)
     .  - 34.383				! 1.6 * alog10(kpc)
     .  + 8.					! -(20/3)*log(100)
      theta_log_microarcsec =
     .      theta_log_radian + 11.314425	! 11.314425=alog10(microarsec/rad)
      theta_iso_test = 10.**theta_log_microarcsec
c     write(6,*) 'smiso, nu = ', smiso, nu
c     write(6,*) 'theta_log_radian = ', theta_log_radian
c     write(6,*) 'theta_log_microarcsec = ', theta_log_microarcsec
c     write(6,*) 'theta_iso = ', theta_iso_test
      return
      end

      REAL FUNCTION TRANSITION_FREQUENCY(sm, smtau, smtheta, dintegrate)
      implicit none
      real sm, smtau, smtheta, dintegrate
c returns the transition frequency between weak and strong scattering
c 28 March 2001
c JMC

c input:
c (all sm values in (kpc m^{-20/3}))
c	    sm = int[\cnsq]
c        smtau = int[(s/D)(1-s/D) \cnsq]
c      smtheta = int[ (1-s/D) \cnsq]
c   dintegrate = distance used to integrate \cnsq (kpc)
c output:
c   transition_frequency = GHz given by
c 	\nu_t  = 318 GHz \xi^{10/17}  SM^{6/17} D_{eff}^{5/17}
c   where
c        D_{eff} = effective path length through medium
c        D_{eff} = \int_0^dintegrate ds s \cnsq / \int_0^dintegrate ds  \cnsq
c
c   Note we can calculate D_{eff} using
c        D_{eff} = dintegrate * (sm - smtau/6 - smtau/3) / sm
c
      real deff
      real xi
      parameter(xi= 0.3989)   ! (2.*pi)^{-1/2} = fresnel scale definition factor
      real coefficient
      parameter(coefficient=318.)	     ! GHz; see NE2001 paper
      deff = (dintegrate*(sm - smtau/6. - smtheta/3.)) / sm
      transition_frequency =
     .     coefficient * xi**(10./17.) * sm**(6./17.) * deff**(5./17.)
      return
      end


subroutine densty(nz, mubar_z, T, den, P, press)
  use photochem_data, only: grav_z, p0, &
                            dz
  implicit none

  integer, intent(in) :: nz
  real(8), intent(in) :: mubar_z(nz), T(nz)
  real(8), intent(out) :: den(nz), P(nz), press(nz)

  ! local varaibles
  real*8 rgas, bk
  real*8 roverm
  real*8 t0, p1, ha, tav
  integer i
!   THIS SUBROUTINE CALCULATES ATMOSPHERIC NUMBER DENSITIES, ASSUM-
!   ING HYDROSTATIC EQUILIBRIUM
  ! g0 = g
  rgas = 8.3143E7
  bk = 1.38054E-16

  roverm = rgas/mubar_z(1)

  t0 = T(1) + (T(1)-T(2))/2.
  ha = roverm*0.5*(t0+T(1))/grav_z(1)
  p1 = p0*1E6*EXP(-0.5*DZ(1)/ha)
  DEN(1) = p1/(bk*T(1))
!
! ***** FIND DENSITY FROM HYDROSTATIC EQUILIBRIUM *****
  DO i = 2 , nz
    roverm = rgas/mubar_z(i)
    ! r = r0 + Z(i)
    ! gz = g0*(r0/r)*(r0/r)
    tav = 0.5*(T(i)+T(i-1))
    ha = roverm*tav/grav_z(i)
    DEN(i) = DEN(i-1)*EXP(-DZ(i)/ha)*T(i-1)/T(i)
  ENDDO
! ***** FIND PRESSURE FROM THIS DENSITY *********
  DO i = 1 , nz
     PRESS(i) = DEN(i)*bk*T(i) ! dynes
  ENDDO
  ! pressure in bars
  do i = 1,nz
    P(i) =  DEN(i)*1.38E-16*T(i) * 1.0e-6 !bars
  enddo

end subroutine

subroutine mean_molecular_weight(nq, usol_layer, mass, background_mu, mubar, err)
  implicit none

  integer, intent(in) :: nq
  real(8), intent(in) :: usol_layer(nq)
  real(8), intent(in) :: mass(nq)
  real(8), intent(in) :: background_mu

  real(8), intent(out) :: mubar
  character(len=1000), intent(out) :: err
  integer :: j
  real(8) :: f_background
  err = ""

  mubar = 0.d0
  do j = 1, nq
    mubar = mubar + usol_layer(j) * mass(j)
  enddo
  f_background = 1 - sum(usol_layer)

  if (f_background < 0.d0) then
    err = "Mixing ratios sum to > 1.0. Atmosphere is probably in a run-away state."
    return
  endif

  mubar = mubar + f_background * background_mu

end subroutine


!>@brief  Calculate $E(k)$  by Karman formula
!>@detail Для генерации изотропной турбулентности используем метод, предложенный в работе Rogallo [1].
!!
!! Функция Кармана спектральной плотности энергии:
!!  $${ E(k) = \frac{\sigma^2  L }{2 \pi} \frac{(\alpha k L)^4}{(1+(\alpha k L)^2)^{17/6}} }$$,
!! где _k_ - волновая частота, $\sigma = \sqrt{u'^2+v'^2+w'^2}$ - среднеквадратичное отклонение;
!!  $\alpha$ - коэффициент ??? ($\alpha\approx 1.339$). _L_ - масштаб турбулентности.
!!
function set_eturb(dk, dl_in, dsigma_in) result(de)
  USE prec_mod
  USE constants, ONLY: f_zero, f_pi
  implicit none
  real(prec), intent(IN) :: dk !< wave number
  real(prec), intent(IN), optional :: dl_in !< Integral Length Scale (set by default 0.1 m)
  real(prec), intent(IN), optional :: dsigma_in !< RMS of velocities (set by default 10 m/s)
  real(prec) :: de !< return value

  real(prec), save :: dl_def = 1.0d-1
  real(prec), save :: dsig_def = 1.0d+1
  real(prec) :: dl
  real(prec) :: dsig
  real(prec) :: dalpha
  real(prec) :: dtmp

! check if presented
  dl = dl_def ! [m]
  if(present(dl_in)) dl = dl_in

  dsig = dsig_def ! [m/s]
  if(present(dsigma_in)) dsig = dsigma_in

  ! write(*,*) "set_eturb: dl and dsig", dl,dsig

  dalpha = 1.339d0
  dtmp = (dalpha * dl * dk ) ** 2

  de = dl * 5.5d+1 / f_pi / 2.7d+1
  de = de * (dtmp * dsig)**2
  de = de / (1.d0 + dtmp)**(1.7d+1/6.0d0)

  return
end function set_eturb


!------------------------------------------------------------------------------
! MODULE: grid_utils
!
!> @author
!> Pavel Junker
!
! DESCRIPTION:
!> basically just Fortran analogs of Octave/Matlab 'linspace' and 'meshgrid'
!
! REVISION HISTORY:
! 13.03.2021 - Initial Version
!------------------------------------------------------------------------------
module grid_utils
	implicit none
	private
	integer, parameter :: DP = kind(0.D0)
	public :: grid_init_1d, grid_init_2d
contains

	pure subroutine grid_init_1d(grid, low, high, n)
		integer, intent(in) :: n
		real(kind=DP), intent(out) :: grid(1,n)
		real(kind=DP), intent(in) :: low, high
		real(kind=DP) :: a, b
		integer :: i

		! obtain axis by linear transformation of sequence 1, 2, ..., n
		a = (high - low)/(n - 1)
		b = (low*n - high)/(n - 1)
		grid(1,:) = a * [(i, i=1,n)] + b

	end subroutine grid_init_1d

	pure subroutine grid_init_2d(grid, x_low, x_high, y_low, y_high, nx, ny)
		integer, intent(in) :: nx, ny
		real(kind=DP), intent(out) :: grid(2,nx*ny)
		real(kind=DP), intent(in) :: x_low, x_high, y_low, y_high
		real(kind=DP) :: a, b
		integer :: i, j, k

		k = 1
		do i=1,nx
			do j=1,ny
				grid(:,k) = [i,j]
				k = k + 1
			end do
		end do
		! transform x axis
		a = (x_high - x_low)/(nx - 1)
		b = (x_low*nx - x_high)/(nx - 1)
		grid(1,:) = a * grid(1,:) + b
		! transform y axis
		a = (y_high - y_low)/(ny - 1)
		b = (y_low*ny - y_high)/(ny - 1)
		grid(2,:) = a * grid(2,:) + b

	end subroutine grid_init_2d

end module grid_utils


      PROGRAM SIMPLIF
      INTEGER I
      REAL*4 R
      REAL*8 D
      COMPLEX*8 C
      COMPLEX*16 DC

      I = INT(-590E-2)          !-5
      I = INT(-590D-2)          !-5
      I = INT((-590E-2, 3.4E2)) !-5
      I = INT(INT(I))           !I
      I = INT(INT(INT(R)))      !INT(R)

C     R -> I
      I = 5.9                   !5
      I = 5.9E2                 !590
      I = 590E-2                !5
      I = -5.9                  !-5
      I = -5.9E2                !-590
      I = -590E-2               !-5

C     I -> R
      R = R + 5 + 5.9 + I

C     D -> R
      R = +590.9D-2             !590.9E-2
      R = -590.9D-2             !-590.9E-2

C     R -> D
      D = +5.9E2                !5.9D2
      D = -5.9E2                !-5.9D2

C     D -> I
      I = 5.9D2                 !590
      I = 590D-2                !5
      I = -5.9D2                !-590
      I = -590D-2               !-5

      I = -R
      R = -I
      I = -D
      D = -I

C     R -> C
      C = -5.9E2                !-(5.9E2, 0.0)
      C = 590E-2                !(590E-2, 0.0)

c     D -> C
      C = -5.9D2                !-(5.9E2, 0.0)
      C = 590D-2                !(590E-2, 0.0)

C     I -> C
      C = -5                    !-(5.0, 0.0)
      C = 5                     !(5.0, 0.0)

C     C -> R
      R = (5.9D2, 3.9D2)        !5.9E2
      R = (5.9E2, 3.9)          !5.9E2
      R = (-590.9E-1, 3.4)      !-590.9E-1
      R = -(590.9E-1, 3.4)      !-590.9E-1

C     C -> D
      D = (5.9E2, 3.4E2)        !5.9D2
      D = (590E-2, 3.4E2)       !590D-2
      D = (-590E-2, 3.4E2)      !-590D-2

C     C -> I
      I = (5.9E2, 3.4E2)        !590
      I = (590E-2, 3.4E2)       !5
      I = (-590E-2, 3.4E2)      !-5

      R = SIN(R)
      D = SIN(D)
      C = SIN(C)

C     DC -> C
      C = (-5.9E2, 3.9D2)       !(-5.9E2, 3.9E2)
      C = CMPLX((-5.9E2, 3.9D2)) !(-5.9E2, 3.9E2)
      DC = (-5.9E2, 3.9D2)      !(-5.9E2, 3.9E2)

C     C -> DC
      DC = (-5.9E2, -3.9D2)     !(-5.9D2, -3.9D2)
      DC = (5.9E2, -3.9E2)      !(5.9D2, -3.9D2)
      DC = DCMPLX((5.9E2, -3.9E2))      !(5.9D2, -3.9D2)

C     DC -> D
      D = (-5.9D2, -3.9D2)      !-5.9D2

C     DC -> R
      R = (-5.9D2, -3.9D2)      !-5.9E2

C     DC -> I
      I = (-5.9D2, -3.9D2)      !-590

C     I -> DC
      DC = 5                    !(5.0, 0.0)
      DC = -5.9E2               !-(5.9D2, 0.0)
      DC = -5.9D2               !-(5.9D2, 0.0)

C others...

      I = REAL(DBLE((10.0D0,-10.0D0)))

      END


module p2grid
implicit none

contains

function index2lagpos(id,ng)
implicit none
integer(8)::id
integer(4)::ng
real(4)::index2lagpos(3)
! index range from 0 - ng^3-1
! output range is (0,ng]
integer(8)::id2
integer(4)::i,j,k
id2=id
k=id2/ng**2
id2=id2-k*ng**2
j=id2/ng
i=id2-j*ng
index2lagpos=[k,j,i]
endfunction index2lagpos

! ===== density =====
subroutine massassign(np,pos,ng,den8,cmd)
use omp_lib
implicit none
integer(4)::np
real(4)::pos(3,np)
integer(4)::ng
real(8)::den8(ng,ng,ng)
integer(4)::cmd
integer(4)::ibin,jbin,kbin,ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
real(4)::hx,hy,hz,hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1
integer(4)::pid
real(8)::tmp1,tmp2
integer(4)::i,j,k
!$omp parallel do default(shared)
do k=1,ng
  den8(:,:,k)=0.d0
enddo
!$omp end parallel do
write(*,*) 'begin mass assignment by method',cmd
if (cmd.eq.1) then
  ! NGP
  !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    !$omp atomic
    den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
  enddo
  !$omp end parallel do
elseif (cmd.eq.2) then
  ! CIC
  !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=1.-abs(hx)
    if (hx.gt.0.) then
      hxp1=hx
      hxm1=0.
    else
      hxp1=0.
      hxm1=-hx
    endif
    hy0=1.-abs(hy)
    if (hy.gt.0.) then
      hyp1=hy
      hym1=0.
    else
      hyp1=0.
      hym1=-hy
    endif
    hz0=1.-abs(hz)
    if (hz.gt.0.) then
      hzp1=hz
      hzm1=0.
    else
      hzp1=0.
      hzm1=-hz
    endif
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
elseif (cmd.eq.3) then
  ! TSC
  !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=0.75-hx**2
    hxp1=0.5*(0.5+hx)**2
    hxm1=0.5*(0.5-hx)**2
    hy0=0.75-hy**2
    hyp1=0.5*(0.5+hy)**2
    hym1=0.5*(0.5-hy)**2
    hz0=0.75-hz**2
    hzp1=0.5*(0.5+hz)**2
    hzm1=0.5*(0.5-hz)**2
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
else
  write(*,*) 'ERROR: mass assignment not specified'
endif
write(*,*) 'statistics:'
tmp1=0.d0
tmp2=0.d0
!$omp parallel do default(shared) reduction(+:tmp1,tmp2)
do k=1,ng
  den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
  tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
  tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
enddo
!$omp end parallel do
tmp2=sqrt(tmp2)
write(*,*) 'mean:',real(tmp1)
write(*,*) 'sigma:',real(tmp2)
endsubroutine massassign

! ===== density =====
subroutine massassigndown(np,pos,ng,den8,cmd,nc,coarse)
use omp_lib
implicit none
integer(8)::np
real(4)::pos(3,np)
integer(4)::ng
real(8)::den8(ng,ng,ng)
integer(4)::cmd
integer(4)::nc,coarse
integer(4)::ibin,jbin,kbin,ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
real(4)::hx,hy,hz,hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1
integer(8)::pid
integer(8)::i8,j8,k8
real(8)::tmp1,tmp2
integer(4)::i,j,k
!$omp parallel do default(shared)
do k=1,ng
  den8(:,:,k)=0.d0
enddo
!$omp end parallel do
write(*,*) 'begin mass assignment by method',cmd
if (cmd.eq.1) then
  ! NGP
  !$omp parallel do default(private) shared(np,pos,den8,nc,coarse) schedule(static)
  do pid=1,np
    k8=(pid-1)/nc/nc
    i8=(pid-1)-k8*nc*nc
    j8=i8/nc
    i8=i8-j8*nc
    if (any( mod([i8,j8,k8],coarse).ne.0 )) cycle
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    !$omp atomic
    den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
  enddo
  !$omp end parallel do
elseif (cmd.eq.2) then
  ! CIC
  !$omp parallel do default(private) shared(np,ng,pos,den8,nc,coarse) schedule(static)
  do pid=1,np
    k8=(pid-1)/nc/nc
    i8=(pid-1)-k8*nc*nc
    j8=i8/nc
    i8=i8-j8*nc
    if (any( mod([i8,j8,k8],coarse).ne.0 )) cycle
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=1.-abs(hx)
    if (hx.gt.0.) then
      hxp1=hx
      hxm1=0.
    else
      hxp1=0.
      hxm1=-hx
    endif
    hy0=1.-abs(hy)
    if (hy.gt.0.) then
      hyp1=hy
      hym1=0.
    else
      hyp1=0.
      hym1=-hy
    endif
    hz0=1.-abs(hz)
    if (hz.gt.0.) then
      hzp1=hz
      hzm1=0.
    else
      hzp1=0.
      hzm1=-hz
    endif
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
elseif (cmd.eq.3) then
  ! TSC
  !$omp parallel do default(private) shared(np,ng,pos,den8,nc,coarse) schedule(static)
  do pid=1,np
    k8=(pid-1)/nc/nc
    i8=(pid-1)-k8*nc*nc
    j8=i8/nc
    i8=i8-j8*nc
    if (any( mod([i8,j8,k8],coarse).ne.0 )) cycle
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=0.75-hx**2
    hxp1=0.5*(0.5+hx)**2
    hxm1=0.5*(0.5-hx)**2
    hy0=0.75-hy**2
    hyp1=0.5*(0.5+hy)**2
    hym1=0.5*(0.5-hy)**2
    hz0=0.75-hz**2
    hzp1=0.5*(0.5+hz)**2
    hzm1=0.5*(0.5-hz)**2
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
else
  write(*,*) 'ERROR: mass assignment not specified'
endif
write(*,*) 'statistics:'
tmp1=0.d0
tmp2=0.d0
!$omp parallel do default(shared) reduction(+:tmp1,tmp2)
do k=1,ng
  den8(:,:,k)=den8(:,:,k)/np*coarse**3*real(ng)**3-1.d0
  tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
  tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
enddo
!$omp end parallel do
tmp2=sqrt(tmp2)
write(*,*) 'mean:',real(tmp1)
write(*,*) 'sigma:',real(tmp2)
endsubroutine massassigndown

subroutine massassign_double(np,pos,ng,den8,cmd)
use omp_lib
implicit none
integer(4)::np
real(8)::pos(3,np)
integer(4)::ng
real(8)::den8(ng,ng,ng)
integer(4)::cmd
integer(4)::ibin,jbin,kbin,ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
real(8)::hx,hy,hz,hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1
integer(4)::pid
real(8)::tmp1,tmp2
integer(4)::i,j,k
!$omp parallel do default(shared)
do k=1,ng
  den8(:,:,k)=0.d0
enddo
!$omp end parallel do
write(*,*) 'begin mass assignment by method',cmd
if (cmd.eq.1) then
  ! NGP
  !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    !$omp atomic
    den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
  enddo
  !$omp end parallel do
elseif (cmd.eq.2) then
  ! CIC
  !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=1.-abs(hx)
    if (hx.gt.0.) then
      hxp1=hx
      hxm1=0.
    else
      hxp1=0.
      hxm1=-hx
    endif
    hy0=1.-abs(hy)
    if (hy.gt.0.) then
      hyp1=hy
      hym1=0.
    else
      hyp1=0.
      hym1=-hy
    endif
    hz0=1.-abs(hz)
    if (hz.gt.0.) then
      hzp1=hz
      hzm1=0.
    else
      hzp1=0.
      hzm1=-hz
    endif
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
elseif (cmd.eq.3) then
  ! TSC
  !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
  do pid=1,np
    ibin=ceiling(pos(1,pid))
    jbin=ceiling(pos(2,pid))
    kbin=ceiling(pos(3,pid))
    hx=pos(1,pid)-ibin+0.5
    hy=pos(2,pid)-jbin+0.5
    hz=pos(3,pid)-kbin+0.5
    hx0=0.75-hx**2
    hxp1=0.5*(0.5+hx)**2
    hxm1=0.5*(0.5-hx)**2
    hy0=0.75-hy**2
    hyp1=0.5*(0.5+hy)**2
    hym1=0.5*(0.5-hy)**2
    hz0=0.75-hz**2
    hzp1=0.5*(0.5+hz)**2
    hzm1=0.5*(0.5-hz)**2
    ibinm1=mod(ibin-2+ng,ng)+1
    jbinm1=mod(jbin-2+ng,ng)+1
    kbinm1=mod(kbin-2+ng,ng)+1
    ibinp1=mod(ibin+ng,ng)+1
    jbinp1=mod(jbin+ng,ng)+1
    kbinp1=mod(kbin+ng,ng)+1
    !$omp atomic
    den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
    !$omp atomic
    den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
    !$omp atomic
    den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
    !$omp atomic
    den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
    !$omp atomic
    den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
    !$omp atomic
    den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
    !$omp atomic
    den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
    !$omp atomic
    den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
    !$omp atomic
    den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
    !$omp atomic
    den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
    !$omp atomic
    den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
    !$omp atomic
    den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
    !$omp atomic
    den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
    !$omp atomic
    den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
    !$omp atomic
    den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
    !$omp atomic
    den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
    !$omp atomic
    den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
    !$omp atomic
    den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
    !$omp atomic
    den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
  enddo
  !$omp end parallel do
else
  write(*,*) 'ERROR: mass assignment not specified'
endif
write(*,*) 'statistics:'
tmp1=0.d0
tmp2=0.d0
!$omp parallel do default(shared) reduction(+:tmp1,tmp2)
do k=1,ng
  den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
  tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
  tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
enddo
!$omp end parallel do
tmp2=sqrt(tmp2)
write(*,*) 'mean:',real(tmp1)
write(*,*) 'sigma:',real(tmp2)
endsubroutine massassign_double

endmodule p2grid


!
  subroutine differentiate(x,y,z,n,f,fx,fy,fz)
!
! Computes derivatives of linear functions specified at tetrahedron vertices
!
! Input parameters:
!           Formal: x(4),y(4),z(4)    - coordinates (x,y,z) of 4 vertices
!                   n                 - number of functions to differentiate
!                   f(4,n)            - values of functions at the vertices
! Output parameters:
!           Formal: fx(n),fy(n),fz(n) - deivatives of functions over x,y and z, resp.
!
! Called routines:  dgesv             - from the Lapack library
!
  implicit none
!
  integer                          :: n
  double precision, dimension(n)   :: fx,fy,fz
  double precision, dimension(4)   :: x,y,z
  double precision, dimension(4,n) :: f
!
  integer                          :: ierr
  integer, dimension(3)            :: ipiv
  double precision, dimension(3,3) :: a,b
  double precision, dimension(:,:), allocatable :: df
!
  allocate(df(3,n))
!
  df(1,:)=f(2,:)-f(1,:)
  df(2,:)=f(3,:)-f(1,:)
  df(3,:)=f(4,:)-f(1,:)
!
  a(1,1)=x(2)-x(1)
  a(1,2)=x(3)-x(1)
  a(1,3)=x(4)-x(1)
  a(2,1)=y(2)-y(1)
  a(2,2)=y(3)-y(1)
  a(2,3)=y(4)-y(1)
  a(3,1)=z(2)-z(1)
  a(3,2)=z(3)-z(1)
  a(3,3)=z(4)-z(1)
!
  b=0.d0
  b(1,1)=1.d0
  b(2,2)=1.d0
  b(3,3)=1.d0
!
  call dgesv(3,3,a,3,ipiv,b,3,ierr)
!
  df=matmul(transpose(b),df)
!
  fx=df(1,:)
  fy=df(2,:)
  fz=df(3,:)
!
  deallocate(df)
!
  end subroutine differentiate


program tarefa2

    !Recebe os valores dos vetores
    print *, 'Digite V1: (x1, y1, z1)'
    read(*,*) x1, y1, z1
    print *, 'Digite V2: (x2, y2, z2)'
    read(*,*) x2, y2, z2

    !Calcula o módulo do vetor e divide por 2, para obter a área do triângulo
    area = (y1*z2 - y2*z1)**2 + (x2*z1 - x1*z2)**2 + (x1*y2 - x2*y1)**2
    area = sqrt(area)/2.d0
    !imprime a área
    print '(A, F8.5)', "Área triângulo: ", area

end program tarefa2


subroutine clawpack46_setaux(mbc,mx,my,mz, &
          xlower,ylower,zlower, dx,dy,dz, maux,aux)
    implicit none

    integer :: mbc, mx, my, mz, maux
    double precision :: xlower, ylower, zlower, dx, dy, dz
    double precision  :: aux(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,maux)

    integer :: i, j, k
    double precision :: xc(1-mbc:mx+mbc)
    double precision :: yc(1-mbc:my+mbc)
    double precision :: xll, yll, psi

    do i = 1-mbc,mx+mbc
        xc(i) = xlower + (i-0.5d0)*dx
    enddo

    do j = 1-mbc,my+mbc
        yc(j) = ylower + (j-0.5d0)*dy
    end do

    do k = 1-mbc,mz+mbc
        do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
                xll = xc(i)
                yll = yc(j)
                !! # difference stream function psi to get normal velocities:
                aux(i,j,k,1) = (psi(xll,     yll+dy) - psi(xll,yll)) / dy
                aux(i,j,k,2) = -(psi(xll+dx, yll)    - psi(xll,yll)) / dx
                aux(i,j,k,3) = 0
            enddo
        enddo
    end do

    return
end subroutine clawpack46_setaux


c     DRSLESUM
c>> 1995-05-28 DRSLESUM Krogh  Changes to use M77CON
c>> 1994-08-09 DRSLESUM WVS  Set up for CHGTYP
c>> 1994-07-14 DRSLESUM CLL
c>> 1992-04-29 DRSLESUM CAO Replaced '1' in format.
c>> 1991-11-19 DRSLESUM CLL
c>> 1987-12-09 DRSLESUM Lawson  Initial Code.
c--S replaces "?": ?LESUM, DR?LESUM
c
c     Demonstration driver for evaluation of a Legendre series.
c     ------------------------------------------------------------------
      integer j
      real             x,a(0:5),y,w,z
      data a/0.07e0, 0.27e0, 0.20e0, 0.28e0, 0.08e0, 0.08e0/
c     ------------------------------------------------------------------
      print '(1x,3x,a1,14x,a1,17x,a1/)','x','y','z'
      do 20 j = -10,10,2
        x = real(j) /10.e0
        call slesum (x,5,a,y)
        w = 0.35e0 * (x**4) + 0.63e0 * (x**5)
        z = y - w
        print '(1x,f5.2,5x,g15.7,g15.2)',x,y,z
   20 continue
      end


program singintquad
    implicit none
    integer, parameter :: dp=8
    real(dp) :: lowlim, uplim
    integer :: steps
    complex(dp) :: integral

    lowlim = 0.0_dp
    uplim = 1.0_dp
    steps=200  !keep steps so that interval width ~ 1.0e-2 to 1.0e-3

    CALL integ13(nume,deno,lowlim,uplim,steps,integral)

    write(*,'(A,2ES10.2e2,"i")') "The integral value is", integral

    contains

    subroutine integ13(num,den,q,p,N,integral)
        !!!--------------------------
        !This subroutine performs integration by equidistant intervals for 'nearly' singular functions using quadratic approximations.
        ! func -> function to integrate, q-> lower bound, p-> upper bound, N -> number of intervals (including q and p)
        ! OUTPUT => integral
        ! Use num, den to declare numerator, denominator respectively of the integral A(y)/B(y)
        !!!---------------------------
        real(dp), intent(in) :: q,p
        integer, intent(in) :: N
        real(dp) :: h,x
        COMPLEX(dp) :: num,den, tp(3), int, a,b,c,d,e,f
        COMPLEX(dp), intent(out) :: integral
        integer :: i,k,t
        h=(p-q)/N              ! h is the interval width.
        x=(q+h/1000)           ! x tracks the interval. h/1000 extra factor is added to skew the program a bit from the sing.
        integral=0.
        k =0;t=0                ! dummy indices to keep track of which approximation gets triggered
        write(*,'(A,F7.3, " to", F7.3)') "Integral limits", q,p
        write(*,'(A,ES8.2e2,/,A)') 'Interval width = ', h, repeat("-",10)

        ! Main LOOP below
        do i=0,N-1
                !Variables named same as the writeup
                int=0.
                a =(2.) *(den(x+h)-2.*den(x+h/2) +den(x))
                b = -den(x+h) + 4* den(x+h/2) -3*den(x)
                c = den(x)
                d =(2.) *(num(x+h)-2.*num(x+h/2) + num(x))
                e = -num(x+h) - 3.*num(x) + 4.* num(x+h/2)
                f = num(x)

                if (abs(a) .le. 1.0e-6) then
                    ! if the quad coeff. is too low then switch to linear
                    b = den(x+h)-den(x)
                    c = den(x)
                    if (abs(b) .le. 1.0e-3) then
                    	! if linear approx also requires log expansion, upto 3rd order.
                        int=h/(2*c) * (2*d/3 +e + 2*f-(2*b*e+b*f)/(3*c)+2*b**2 *f/(3*c**2))
                        ! print*, 'linearapprox', int, x
                        k= k+1
                    else
                        ! int = h/b *( d/2 +e+ d*c/b + (d*c**2 / b**2 -e*c/b + f) * log(1+b/c) ) ! old one has some typo
                        int = h/(2*b**3) * (b*(-2*c*d+b*(d+2*e)) +2*( c**2 *d - b*c*e+b**2 *f)*log((1+b/c)) )
                        t=t+1
                        ! print*, 'linear', int, x
                    endif
                else
                    tp(1)= ( -b + sqrt(b**2 - 4*a*c) )/(2*a) !x1
                    tp(2)= ( -b - sqrt(b**2 - 4*a*c) )/(2*a)  !x2
                    if ((real(tp(1)) < q .and. real(tp(1)) > p) .or. (real(tp(2)) < q .and. real(tp(2)) > p)) then
                        print*, "Quadratic approx not possible decrease interval to force linear"
                        EXIT
                    endif
                    ! int = h/a * ( d + log(1-1/tp(2)) *(d*(-b)/a +e+(d*tp(1)**2+e*tp(1)+f)/(tp(2)-tp(1))) &
                    !     - log(1-1/tp(1)) * (d*tp(1)**2+e*tp(1)+f)/(tp(2)-tp(1))  )
                    ! print*, 'quad', int, x
                    tp(1) = sqrt(4*a*c - b**2)
                    int = h*((4*a**2*atan((b+2*a)/tp(1))-4*a**2*atan(b/tp(1)))*f+(-b*tp(1)* &
                    log(abs(c+b+a))+b*tp(1)*log(abs(c))+(2*b**2-4*a*c)*atan((b+2*a)/tp(1))+(4*a*c-2*b**2)*&
                    atan(b/tp(1))+2*a*tp(1))*d+e*a*tp(1)*log(abs(c+b+a))-e*a*tp(1)*&
                    log(abs(c))-2*e*a*b*atan((b+2*a)/tp(1))+2*e*a*b*atan(b/tp(1)))/(2*a**2*tp(1))
                endif

                integral = int+integral
                x=x+h
        end do
        write(*,'(A,I5,"/",I5)') "# log expansions in linear:", k,N
        write(*,'(A,I5,"/",I5)') "# total linear approximations:", k+t,N
        write(*,'(A,I5,"/",I5,/,A)') "# total quadratic approximations:", N-k-t,N, repeat("-",10)

    end subroutine

function nume(x)
    ! this is A(y) in integral(A(y)/B(y))
    implicit none
    COMPLEX(dp) :: nume,y
    real(dp) :: x
    y= complex(x,0.)
    ! nume= complex(abs(x),0.)
    ! nume = y-sqrt(y**2-1)
    !nume = sqrt(1-y**2)
    nume=1

    return
end function nume

function deno(x)
    ! this is B(y) in integral(A(y)/B(y))
    implicit none
    COMPLEX(dp) :: deno,y
    real(dp) :: x
    y = complex(x,0)
    ! deno = complex(0.9-x,1.0e-10)
    ! deno = sqrt(y**2 -1) + complex(0.,1.0e-10)
    !deno = 1-y + complex(0.,1.0e-10)
    deno = y**2

end function deno

end program singintquad


: fib 00; dup 2 <if drop 1 ;; then 1- dup fib swap 1- fib + ;
| ." Calculating the 35th Fibonacci number using recursion... " 35 fib . cr bye

: dofibs
	0do
		." Fibonacci number " i . ." is " i fib . cr
	loop
	;

10 dofibs bye


c      double complex function aqqb_zbb(i1,i2,i3,i4,i5,i6)
c--- Note that this is the amplitude for particle labels
c--- q1, qb2, Q5, Qb6, l3, lb4
c--- This corresponds to A++(1,6,5,2) of eq. (12.3) in BDK
c--- and we note that    A++(1,6,5,2) = A++(1,4,3,2)
c      implicit none
c      include 'constants.f'
c      include 'sprods_com.f'
c      include 'zprods_com.f'
c      integer i1,i2,i3,i4,i5,i6
c      double complex t2a
c      double precision s234,s256,prop
c--- statement function
c      t2a(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)
c
c      s234=s(i2,i3)+s(i2,i4)+s(i3,i4)
c      s256=s(i2,i6)+s(i2,i5)+s(i5,i6)
c      prop=s(i5,i6)*s(i3,i4)
c      aqqb_zbb=
c     & +zb(i1,i4)*za(i5,i2)*t2a(i3,i1,i4,i6)/(prop*s256)
c     & +za(i3,i2)*zb(i6,i1)*t2a(i5,i2,i3,i4)/(prop*s234)

c      return
c      end

      double complex function aqqb_zbb_new(i1,i2,i3,i4,i5,i6)
c--- This corresponds to A++(1,2,3,4) of eq. (12.3) in BDK
c    The notation of BDK calculates the following amplitude
c
c     q3(L)----<----------q2            q3(L)------<--------q2
c                 0                             0
c                 0                             0
c                 0                             0
c     q1(R)------<--------q4            q1(R)------<--------q4
c             )                                         )
c            (                                         (
c             )                                         )
c     l5(L)-------<-------l6            l5(L)-------<-------l6
c
c     Note that this function has the property
c     Conjg(aqqb_zbb_new(i1,i2,i3,i4,i5,i6))=
C          -aqqb_zbb_new(i4,i3,i2,i1,i6,i5)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      integer i1,i2,i3,i4,i5,i6
      double complex t2a
      double precision s123,s234,prop
c--- statement function
      t2a(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)

      s123=s(i1,i2)+s(i1,i3)+s(i2,i3)
      s234=s(i2,i3)+s(i2,i4)+s(i3,i4)
      prop=s(i2,i3)*s(i5,i6)

      aqqb_zbb_new=
     & +zb(i1,i2)*za(i5,i4)*t2a(i3,i1,i2,i6)/(prop*s123)
     & +za(i3,i4)*zb(i6,i1)*t2a(i5,i3,i4,i2)/(prop*s234)

      return
      end