      double precision function bvalue(t,bcoef,n,k,x,jderiv)

c Calculates value at  x  of  jderiv-th derivative of spline from B-repr.
c The spline is taken to be continuous from the right.
c
C calls  interv()  (from ../../../appl/interv.c )
c
c******  i n p u t ******
c  t, bcoef, n, k......forms the b-representation of the spline  f  to
c        be evaluated. specifically,
c  t.....knot sequence, of length  n+k, assumed nondecreasing.
c  bcoef.....b-coefficient sequence, of length  n .
c  n.....length of  bcoef  and dimension of s(k,t),
c        a s s u m e d  positive .
c  k.....order of the spline .
c
c  w a r n i n g . . .   the restriction  k <= kmax (=20)  is imposed
c        arbitrarily by the dimension statement for  aj, dm, dm  below,
c        but is  n o w h e r e  c h e c k e d  for.
c  however in R, this is only called from bvalus() with k=4 anyway!
c
c  x.....the point at which to evaluate .
c  jderiv.....integer giving the order of the derivative to be evaluated
c        a s s u m e d  to be zero or positive.
c
c******  o u t p u t  ******
c  bvalue.....the value of the (jderiv)-th derivative of  f  at  x .
c
c******  m e t h o d  ******
c     the nontrivial knot interval  (t(i),t(i+1))  containing  x  is lo-
c  cated with the aid of  interv(). the  k  b-coeffs of  f  relevant for
c  this interval are then obtained from  bcoef (or taken to be zero if
c  not explicitly available) and are then differenced  jderiv  times to
c  obtain the b-coeffs of  (d^jderiv)f  relevant for that interval.
c  precisely, with  j = jderiv, we have from x.(12) of the text that
c
c     (d^j)f  =  sum ( bcoef(.,j)*b(.,k-j,t) )
c
c  where
c                   / bcoef(.),                     ,  j .eq. 0
c                   /
c    bcoef(.,j)  =  / bcoef(.,j-1) - bcoef(.-1,j-1)
c                   / ----------------------------- ,  j > 0
c                   /    (t(.+k-j) - t(.))/(k-j)
c
c     then, we use repeatedly the fact that
c
c    sum ( a(.)*b(.,m,t)(x) )  =  sum ( a(.,x)*b(.,m-1,t)(x) )
c  with
c                 (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1)
c    a(.,x)  =    ---------------------------------------
c                 (x - t(.))      + (t(.+m-1) - x)
c
c  to write  (d^j)f(x)  eventually as a linear combination of b-splines
c  of order  1 , and the coefficient for  b(i,1,t)(x)  must then
c  be the desired number  (d^j)f(x). (see x.(17)-(19) of text).
c
C Arguments
      integer n,k, jderiv
      DOUBLE precision t(*),bcoef(n),x
c     dimension t(n+k)
c  current fortran standard makes it impossible to specify the length of
c  t  precisely without the introduction of otherwise superfluous
c  additional arguments.

C Local Variables
      integer kmax
      parameter(kmax = 20)

      DOUBLE precision aj(kmax),dm(kmax),dp(kmax),fkmj

      integer i,ilo,imk,j,jc,jcmin,jcmax,jj,km1,kmj,mflag,nmi, jdrvp1
c
      integer interv
      external interv

c     initialize
      data i/1/

      bvalue = 0.d0
      if (jderiv .ge. k) go to 99
c
c  *** find  i  s.t.  1 <= i < n+k  and  t(i) < t(i+1) and
c      t(i) <= x < t(i+1) . if no such i can be found,  x  lies
c      outside the support of the spline  f and bvalue = 0.
c  {this case is handled in the calling R code}
c      (the asymmetry in this choice of  i  makes  f  rightcontinuous)
      if( (x.ne.t(n+1)) .or. (t(n+1).ne.t(n+k)) ) then
         i = interv ( t, n+k, x, 0, 0, i, mflag)
         if (mflag .ne. 0) then
            call rwarn('bvalue()  mflag != 0: should never happen!')
            go to 99
         endif
      else
         i = n
      endif

c  *** if k = 1 (and jderiv = 0), bvalue = bcoef(i).
      km1 = k - 1
      if (km1 .le. 0) then
         bvalue = bcoef(i)
         go to 99
      endif
c
c  *** store the k b-spline coefficients relevant for the knot interval
c     (t(i),t(i+1)) in aj(1),...,aj(k) and compute dm(j) = x - t(i+1-j),
c     dp(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable
c     from input to zero. set any t.s not obtainable equal to t(1) or
c     to t(n+k) appropriately.
      jcmin = 1
      imk = i - k
      if (imk .ge. 0) then
         do 9 j=1,km1
            dm(j) = x - t(i+1-j)
 9       continue
      else
         jcmin = 1 - imk
         do 5 j=1,i
            dm(j) = x - t(i+1-j)
 5       continue
         do 6 j=i,km1
            aj(k-j) = 0.d0
            dm(j) = dm(i)
 6       continue
      endif
c
      jcmax = k
      nmi = n - i
      if (nmi .ge. 0) then
         do 19 j=1,km1
C     the following if() happens; e.g. in   pp <- predict(cars.spl, xx)
c     -       if( (i+j) .gt. lent) write(6,9911) i+j,lent
c     -  9911         format(' i+j, lent ',2(i6,1x))
            dp(j) = t(i+j) - x
 19      continue
      else
         jcmax = k + nmi
         do 15 j=1,jcmax
            dp(j) = t(i+j) - x
 15      continue
         do 16 j=jcmax,km1
            aj(j+1) = 0.d0
            dp(j) = dp(jcmax)
 16      continue
      endif

c
      do 21 jc=jcmin,jcmax
         aj(jc) = bcoef(imk + jc)
 21   continue
c
c               *** difference the coefficients  jderiv  times.
      if (jderiv .ge. 1) then
         do 23 j=1,jderiv
            kmj = k-j
            fkmj = dble(kmj)
            ilo = kmj
            do 24 jj=1,kmj
               aj(jj) = ((aj(jj+1) - aj(jj))/(dm(ilo) + dp(jj)))*fkmj
               ilo = ilo - 1
 24         continue
 23      continue
      endif

c
c  *** compute value at  x  in (t(i),t(i+1)) of jderiv-th derivative,
c     given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv).

      if (jderiv .ne. km1) then
         jdrvp1 = jderiv + 1
         do 33 j=jdrvp1,km1
            kmj = k-j
            ilo = kmj
            do 34 jj=1,kmj
               aj(jj) = (aj(jj+1)*dm(ilo) + aj(jj)*dp(jj)) /
     *              (dm(ilo)+dp(jj))
               ilo = ilo - 1
 34         continue
 33      continue
      endif

      bvalue = aj(1)
c
   99 return
      end


          program demo_lookat
          ! Demonstrate a rotating translating tetrahedron, and doublebuffering
          use M_draw
          !
          integer TETRAHEDRON
          parameter (TETRAHEDRON = 1)
          !
          real R, tx, tz, rotval, drotval, zeye
          integer i
          logical back, backdir, fill
          character(len=50) :: device
          integer :: ios
          !
          call prefsize(300, 300)
          !
          print*,'Enter output device:'
          read(*,'(a)',iostat=ios)device
          if(ios.ne.0)device=' '
          !
          back = .true.
          backdir = .true.
          fill = .true.
          !
          call vinit(device)
          !
          ! Make the tetrahedral object
          !
          call maketheobject()
          !
          rotval = 0.0
          drotval = 5.0
          zeye = 5.0
          !
          R = 1.6
          !
          tx = 0.0
          tz = R
          !
          !all polyfill(fill)
          call backface(back)
          call backfacedir(backdir)
          call clipping(.false.)
          !
          ! set up a perspective projection with a field of view of
          ! 40.0 degrees, aspect ratio of 1.0, near clipping plane 0.1,
          ! and the far clipping plane at 1000.0.
          !
          call perspective(40.0, 1.0, 0.001, 15.0)
          call lookat(0.0, 0.0, zeye, 0.0, 0.0, 0.0, 0.0)
          !
          ! Setup drawing into the backbuffer....
          !
          if (backbuffer().lt.0) then
             call vexit()
             write(*,*)'Device can''t support doublebuffering'
             stop
          endif
          !
          ! here we loop back here ad-naseum until someone hits a non interpreted key
          !
          INFINITE: do
          !
             rotval = 0.0
          !
             do i = 0, int(359.0 / drotval)
          !
                call color(D_BLACK)
                call clear()
          !
          !  Rotate the whole scene...(this accumulates - hence
          !  drotval)
          !
                call rotate(drotval * 0.1, 'x')
                call rotate(drotval * 0.1, 'z')
          !
                call color(D_RED)
                call pushmatrix()
                call polyfill(.false.)
                call rotate(90.0, 'x')
                call circle(0.0, 0.0, R)
                call polyfill(fill)
                call popmatrix()
          !
                call color(D_BLUE)
                call move(0.0, 0.0, 0.0)
                call draw(tx, 0.0, tz)
          !
          ! Remember! The order of the transformations is
          ! the reverse of what is specified here in between
          ! the pushmatrix and the popmatrix. These ones don't
          ! accumulate because of the push and pop.
          !
                call pushmatrix()
                   call translate(tx, 0.0, tz)
                   call rotate(rotval, 'x')
                   call rotate(rotval, 'y')
                   call rotate(rotval, 'z')
                   call scale(0.4, 0.4, 0.4)
                   call callobj(TETRAHEDRON)
                call popmatrix()
          !
                tz = R * cos(rotval * 3.1415926535 / 180)
                tx = R * sin(rotval * 3.1415926535 / 180)
          !
                call swapbuffers()
          !
                select case(char(checkkey()))
                case('f')
                          fill = .not. fill
                          call polyfill(fill)
                case('b')
                          back = .not. back
                          call backface(back)
                case('d')
                          backdir = .not. backdir
                          call backfacedir(backdir)
                case(char(0))
                case default
                          call vexit()
                          stop
                 end select
          !
                rotval = rotval + drotval
          !
                !!call system_sleep(0.05)
          !
          enddo
          !
          enddo INFINITE
          !
          contains
          !
          ! maketheobject
          !
          !       generate a tetrahedron object as a series of move draws
          !
          subroutine maketheobject()

          integer TETRAHEDRON, NSIDES, NFACES, NPNTS
          parameter (TETRAHEDRON = 1, NSIDES = 3, NFACES = 4, NPNTS = 4)
          integer colface(NFACES)
          real pnts(3, NPNTS)
          integer faces(NSIDES, NFACES)
          integer i, j
          real x, y, z

          data pnts/               &
               &  -0.5, 0.866, -0.667,     &
               &  -0.5, -0.866, -0.667,    &
               &   1.0, 0.0, -0.667,       &
               &   0.0, 0.0, 1.334/

          data colface/D_GREEN, D_YELLOW, D_CYAN, D_MAGENTA/

          data faces/   &
               &  3, 2, 1,      &
               &  1, 2, 4,      &
               &  2, 3, 4,      &
               &  3, 1, 4/

          call makeobj(TETRAHEDRON)

          do i = 1, NFACES
             call makepoly()
             call color(colface(i))
             x = pnts(1, faces(1, i))
             y = pnts(2, faces(1, i))
             z = pnts(3, faces(1, i))
             call move(x, y, z)
             do j = 2, NSIDES
                x = pnts(1, faces(j,i))
                y = pnts(2, faces(j,i))
                z = pnts(3, faces(j,i))
                call draw(x, y, z)
             enddo
             call closepoly()
           enddo

           call closeobj()

           end subroutine maketheobject

          end program demo_lookat


{ recursive factorial function }
[$1=~[$1-f;!*]?]f:

{ call f with 8 and print decimal }
8f;!.


!This file is released under terms of BSD license`
!See LICENSE.txt for more information

MODULE m_ser_perturb
!-------------------------------------------------------------------------------
!
! Description:
!   This module provides tools to add random perturbation to the prognostic
!   fields. This is usefull to define threashold values for rounding error
!
! Current Code Owner: MeteoSwiss, Oliver Fuhrer
!  phone:  +41  44  256 9359
!  fax:    +XX  XX  XXX XXXX
!  email:  oliver.fuhrer@meteoswiss.ch
!
! History:
! Version    Date       Name
! ---------- ---------- ----
! VX_XX        2013/10/07 Xavier Lapillonne
!  First version, adapted from Oliver's ensemble module
!
! Description
!   These routines perturb a field with a perturbation of the following style
!
!     field = (1 + epsilon) * field
!
!   where epsilon can either be chose relative to the least significant bit (rperturb<0.0)
!   or as an absolute perturbation value (rperturb>0.0).
!
!   Note: this type of perturbation does not alter zero's and conserves the positive
!         definitiveness of a field
!==============================================================================

USE iso_c_binding

IMPLICIT NONE

! Global module variables
LOGICAL, SAVE :: lseedinit=.FALSE.

!==============================================================================
! Module procedures
!==============================================================================

INTERFACE ser_fld_perturb
   MODULE PROCEDURE         &
     ser_fld_perturb_float_0d,  &
     ser_fld_perturb_float_1d,  &
     ser_fld_perturb_float_2d,  &
     ser_fld_perturb_float_3d,  &
     ser_fld_perturb_float_4d,  &
     ser_fld_perturb_double_0d, &
     ser_fld_perturb_double_1d, &
     ser_fld_perturb_double_2d, &
     ser_fld_perturb_double_3d, &
     ser_fld_perturb_double_4d
END INTERFACE

!==============================================================================

CONTAINS

  !==============================================================================
  !+ Subroutines that perturb a field randomly
  !------------------------------------------------------------------------------

  SUBROUTINE ser_fld_perturb_float_0d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_FLOAT), INTENT(INOUT) :: fld_data  ! field data
    REAL, INTENT(IN)    :: rperturb
    REAL(KIND=C_FLOAT)                :: repsmat
    INTEGER             :: ierr      ! error code

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

  END SUBROUTINE ser_fld_perturb_float_0d

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

  SUBROUTINE ser_fld_perturb_float_1d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_FLOAT), INTENT(INOUT) :: fld_data(:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL(KIND=C_FLOAT), ALLOCATABLE :: repsmat(:)
    INTEGER :: ni,  & ! field dimensions
               ierr   ! error code

    ni = SIZE(fld_data, DIM=1)

    IF (.NOT. lseedinit) CALL init_seed

    ALLOCATE(repsmat(ni))

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_float_1d

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

  SUBROUTINE ser_fld_perturb_float_2d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_FLOAT), INTENT(INOUT) :: fld_data(:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL(KIND=C_FLOAT), ALLOCATABLE :: repsmat(:,:)     ! field data
    INTEGER :: ni, nj, & ! field dimensions
               ierr      ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)

    ALLOCATE(repsmat(ni, nj))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_float_2d

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

  SUBROUTINE ser_fld_perturb_float_3d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_FLOAT), INTENT(INOUT) :: fld_data(:,:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL :: reps
    REAL(KIND=C_FLOAT), ALLOCATABLE :: repsmat(:,:,:)     ! field data
    INTEGER :: ni, nj, nk,  & ! field dimensions
               ierr           ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)
    nk = SIZE(fld_data, DIM=3)

    ALLOCATE(repsmat(ni, nj, nk))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) !repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_float_3d

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

  SUBROUTINE ser_fld_perturb_float_4d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_FLOAT), INTENT(INOUT) :: fld_data(:,:,:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL :: reps
    REAL(KIND=C_FLOAT), ALLOCATABLE :: repsmat(:,:,:,:)     ! field data

    INTEGER :: ni, nj, nk, nz, & ! field dimensions
               ierr              ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)
    nk = SIZE(fld_data, DIM=3)
    nz = SIZE(fld_data, DIM=4)

    ALLOCATE(repsmat(ni, nj, nk, nz))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) !repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_float_4d

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

  SUBROUTINE ser_fld_perturb_double_0d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_DOUBLE), INTENT(INOUT) :: fld_data  ! field data
    REAL, INTENT(IN)    :: rperturb
    REAL(KIND=C_DOUBLE)                :: repsmat
    INTEGER             :: ierr      ! error code

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

  END SUBROUTINE ser_fld_perturb_double_0d

  SUBROUTINE ser_fld_perturb_double_1d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_DOUBLE), INTENT(INOUT) :: fld_data(:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL(KIND=C_DOUBLE), ALLOCATABLE :: repsmat(:)
    INTEGER :: ni,  & ! field dimensions
               ierr   ! error code

    ni = SIZE(fld_data, DIM=1)

    IF (.NOT. lseedinit) CALL init_seed

    ALLOCATE(repsmat(ni))

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_double_1d

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

  SUBROUTINE ser_fld_perturb_double_2d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_DOUBLE), INTENT(INOUT) :: fld_data(:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL(KIND=C_DOUBLE), ALLOCATABLE :: repsmat(:,:)     ! field data
    INTEGER :: ni, nj, & ! field dimensions
               ierr      ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)

    ALLOCATE(repsmat(ni, nj))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) ! repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_double_2d

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

  SUBROUTINE ser_fld_perturb_double_3d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_DOUBLE), INTENT(INOUT) :: fld_data(:,:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL :: reps
    REAL(KIND=C_DOUBLE), ALLOCATABLE :: repsmat(:,:,:)     ! field data
    INTEGER :: ni, nj, nk,  & ! field dimensions
               ierr           ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)
    nk = SIZE(fld_data, DIM=3)

    ALLOCATE(repsmat(ni, nj, nk))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) !repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_double_3d

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

  SUBROUTINE ser_fld_perturb_double_4d( fld_data, rperturb )

    IMPLICIT NONE

    REAL(KIND=C_DOUBLE), INTENT(INOUT) :: fld_data(:,:,:,:)  ! field data
    REAL, INTENT(IN) :: rperturb
    REAL :: reps
    REAL(KIND=C_DOUBLE), ALLOCATABLE :: repsmat(:,:,:,:)     ! field data

    INTEGER :: ni, nj, nk, nz, & ! field dimensions
               ierr              ! error code

    ni = SIZE(fld_data, DIM=1)
    nj = SIZE(fld_data, DIM=2)
    nk = SIZE(fld_data, DIM=3)
    nz = SIZE(fld_data, DIM=4)

    ALLOCATE(repsmat(ni, nj, nk, nz))

    IF (.NOT. lseedinit) CALL init_seed

    CALL RANDOM_NUMBER(repsmat) !repsmat between 0 and 1

    ! apply perturbation
    repsmat = rperturb * (2.0 * repsmat - 1.0)   ! repsmat between -rperturb and rperturb
    fld_data = fld_data * (1.0 + repsmat)

    DEALLOCATE(repsmat)

  END SUBROUTINE ser_fld_perturb_double_4d

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

  !==============================================================================
  ! init seed for random generator.
  ! Two subsequent runs should give use
  ! different sequence
  !------------------------------------------------------------------------------
  SUBROUTINE init_seed
    INTEGER, ALLOCATABLE :: seed(:)
    REAL, ALLOCATABLE :: Rseed(:)
    INTEGER :: dt(8), n, dsum, i

    ! Use the default seed to generate a first random list
    CALL RANDOM_SEED(size = n)
    ALLOCATE(seed(n), Rseed(n))
    CALL RANDOM_NUMBER(Rseed)

    ! Generate a number for the seed which should differ for every run.
    ! Concatenate hours (H), minutes (M), second (S), milliseconds (m)
    ! as follow : dsum = mmmmSSMMHH
    ! Every run on a given day are garantee to get a different dsum.
    ! Over several days it is very unlikely to get two times the same number
    ! as we would need to run at the exact same time of the day in millisecond.
    ! Note : adding days, month, year to dsum seems to make the number to
    ! large for RANDOM_SEED(PUT...) and should be avoided.
    CALL DATE_AND_TIME(values=dt)
    dsum= dt(5)+dt(6)*1e2+dt(7)*1e4+dt(8)*1e6

    ! Combine dsum with the default random list
    seed(:)=INT(Rseed*dsum, 4)
    CALL RANDOM_SEED(PUT = seed)

    ! set lseedinit
    lseedinit=.TRUE.

    DEALLOCATE(seed, rseed)

  END SUBROUTINE init_seed

END MODULE m_ser_perturb


!-----------------------------------------------------------------------
!
! Header with common subroutine
!
      include 't320-basis-f.h'
!
! Header with QFunctions
!
      include 't535-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err,i
      integer stridesu(3),stridesqd(3)
      integer erestrictx,erestrictu,erestrictui,erestrictqi
      integer bx,bu
      integer qf_setup_mass,qf_setup_diff,qf_apply
      integer op_setup_mass,op_setup_diff,op_apply
      integer qdata_mass,qdata_diff,x,a,u,v
      integer nelem,p,q,d
      integer row,col,offset
      parameter(nelem=12)
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)
      integer ndofs,nqpts,nx,ny
      parameter(nx=3)
      parameter(ny=2)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqpts=nelem*q)
      integer indx(nelem*p*p)
      real*8 arrx(d*ndofs),aa(nqpts),uu(ndofs),vv(ndofs),atrue(ndofs)
      integer*8 xoffset,aoffset,uoffset,voffset

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)
      real*8 val
      character arg*32

      external setup_mass,setup_diff,apply

      call getarg(1,arg)

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

! DoF Coordinates
      do i=0,ndofs-1
        arrx(i+1)=mod(i,(nx*2+1))
        arrx(i+1)=arrx(i+1)*(1.d0/(nx*2.d0))
        val=(i/(nx*2+1))
        arrx(i+1+ndofs)=val*(1.d0/(ny*2.d0))
      enddo
      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Qdata Vector
      call ceedvectorcreate(ceed,nqpts,qdata_mass,err)
      call ceedvectorcreate(ceed,nqpts*d*(d+1)/2,qdata_diff,err)

! Element Setup
      do i=0,5
        col=mod(i,nx)
        row=i/nx
        offset=col*2+row*(nx*2+1)*2

        indx(i*2*p+1)=2+offset
        indx(i*2*p+2)=9+offset
        indx(i*2*p+3)=16+offset
        indx(i*2*p+4)=1+offset
        indx(i*2*p+5)=8+offset
        indx(i*2*p+6)=0+offset

        indx(i*2*p+7)=14+offset
        indx(i*2*p+8)=7+offset
        indx(i*2*p+9)=0+offset
        indx(i*2*p+10)=15+offset
        indx(i*2*p+11)=8+offset
        indx(i*2*p+12)=16+offset
      enddo

! Restrictions
      call ceedelemrestrictioncreate(ceed,nelem,p,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictx,err)

      call ceedelemrestrictioncreate(ceed,nelem,p,1,1,ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictu,err)
      stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,nqpts,&
     & stridesu,erestrictui,err)

      stridesqd=[1,q,q*d*(d+1)/2]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,d*(d+1)/2,&
     & d*(d+1)/2*nqpts,stridesqd,erestrictqi,err)

! Bases
      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,d,p,q,interp,grad,qref,qweight,&
     & bx,err)
      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,&
     & bu,err)

! QFunction - setup mass
      call ceedqfunctioncreateinterior(ceed,1,setup_mass,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_mass'//char(0),qf_setup_mass,err)
      call ceedqfunctionaddinput(qf_setup_mass,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_mass,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_mass,'qdata',1,ceed_eval_none,err)

! Operator - setup mass
      call ceedoperatorcreate(ceed,qf_setup_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_mass,err)
      call ceedoperatorsetfield(op_setup_mass,'dx',erestrictx,&
     & bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_mass,'_weight',&
     & ceed_elemrestriction_none,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_mass,'qdata',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)

! QFunction - setup diff
      call ceedqfunctioncreateinterior(ceed,1,setup_diff,&
     &SOURCE_DIR&
     &//'t532-operator.h:setup_diff'//char(0),qf_setup_diff,err)
      call ceedqfunctionaddinput(qf_setup_diff,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup_diff,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup_diff,'qdata',&
     & d*(d+1)/2,ceed_eval_none,err)

! Operator - setup diff
      call ceedoperatorcreate(ceed,qf_setup_diff,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_diff,err)
      call ceedoperatorsetfield(op_setup_diff,'dx',erestrictx,&
     & bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_diff,'_weight',&
     & ceed_elemrestriction_none,bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_diff,'qdata',erestrictqi,&
     & ceed_basis_collocated,ceed_vector_active,err)

! Apply Setup Operators
      call ceedoperatorapply(op_setup_mass,x,qdata_mass,&
     & ceed_request_immediate,err)
      call ceedoperatorapply(op_setup_diff,x,qdata_diff,&
     & ceed_request_immediate,err)

! QFunction - apply
      call ceedqfunctioncreateinterior(ceed,1,apply,&
     &SOURCE_DIR&
     &//'t532-operator.h:apply'//char(0),qf_apply,err)
      call ceedqfunctionaddinput(qf_apply,'du',d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_mass',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'qdata_diff',&
     & d*(d+1)/2,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_apply,'u',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'v',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_apply,'dv',d,ceed_eval_grad,err)

! Operator - apply
      call ceedoperatorcreate(ceed,qf_apply,ceed_qfunction_none,&
     & ceed_qfunction_none,op_apply,err)
      call ceedoperatorsetfield(op_apply,'du',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'qdata_mass',erestrictui,&
     & ceed_basis_collocated,qdata_mass,err)
      call ceedoperatorsetfield(op_apply,'qdata_diff',erestrictqi,&
     & ceed_basis_collocated,qdata_diff,err)
      call ceedoperatorsetfield(op_apply,'u',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'v',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_apply,'dv',erestrictu,&
     & bu,ceed_vector_active,err)

! Assemble Diagonal
      call ceedvectorcreate(ceed,ndofs,a,err)
      call ceedoperatorlinearassemblediagonal(op_apply,a,&
     & ceed_request_immediate,err)

! Manually assemble diagonal
      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,0.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      do i=1,ndofs
        call ceedvectorgetarray(u,ceed_mem_host,uu,uoffset,err)
        uu(i+uoffset)=1.d0
        if (i>1) then
          uu(i-1+uoffset)=0.d0
        endif
        call ceedvectorrestorearray(u,uu,uoffset,err)

        call ceedoperatorapply(op_apply,u,v,ceed_request_immediate,err)

        call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
        atrue(i)=vv(voffset+i)
        call ceedvectorrestorearrayread(v,vv,voffset,err)
      enddo

! Check Output
      call ceedvectorgetarrayread(a,ceed_mem_host,aa,aoffset,err)
      do i=1,ndofs
        if (abs(aa(aoffset+i)-atrue(i))>1.0d-14) then
! LCOV_EXCL_START
          write(*,*) '[',i,'] Error in assembly: ',aa(aoffset+i),' != ',&
     &      atrue(i)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(a,aa,aoffset,err)

! Cleanup
      call ceedqfunctiondestroy(qf_setup_mass,err)
      call ceedqfunctiondestroy(qf_setup_diff,err)
      call ceedqfunctiondestroy(qf_apply,err)
      call ceedoperatordestroy(op_setup_mass,err)
      call ceedoperatordestroy(op_setup_diff,err)
      call ceedoperatordestroy(op_apply,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceedelemrestrictiondestroy(erestrictqi,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(a,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(qdata_mass,err)
      call ceedvectordestroy(qdata_diff,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


module mg_namelist

  use mg_tictoc

  implicit none

  !- control integer and real precision (global vparameters)
  integer(kind=4), parameter :: rp = 8, ip = 4

  ! smallest dimension ever for the global domain
  integer(kind=ip) :: nsmall      =   8

  integer(kind=ip) :: ns_coarsest =  40
  integer(kind=ip) :: ns_pre      =   3
  integer(kind=ip) :: ns_post     =   2

  real(kind=rp)    :: solver_prec    = 1.d-6  !- solver precision
  integer(kind=ip) :: solver_maxiter = 50      !- maximum of solver iterations

  character(len=16) :: cmatrix='real'          !- 'real' or 'simple'

  logical           :: red_black = .true.      !- .false. or .true.
  character(len=16) :: relax_method ='RB'      !- 'Gauss-Seidel', 'GS',
  !                                            !- 'Red-Black'   , 'RB',
  !                                            !- 'Four-Color'  , 'FC'

  character(len=16) :: interp_type='linear'    !- 'nearest'  or 'linear'

  character(len=16) :: restrict_type='avg'     !- 'avg'  or 'linear'

  logical           :: aggressive = .false.    !- .false. or .true.

  logical           :: netcdf_output = .false. !- .false. or .true.

  logical           :: bmask         = .false. !- Boundary mask is applied changing matirx coef to

  namelist/nhparam/    &
       solver_prec   , &
       solver_maxiter, &
       nsmall        , &
       ns_coarsest   , &
       ns_pre        , &
       ns_post       , &
       cmatrix       , &
       relax_method  , &
       interp_type   , &
       restrict_type , &
       netcdf_output , &
       aggressive    , &
       bmask

contains

  !--------------------------------------------------------------------
  subroutine read_nhnamelist(filename, verbose, vbrank)

    character(len=*), optional, intent(in) :: filename
    logical         , optional, intent(in) :: verbose
    integer(kind=4) , optional, intent(in) :: vbrank

    character(len=64) :: fn_nml
    logical           :: vb
    integer(kind=ip)  :: lun_nml = 4
    integer(kind=4)   :: rank

    logical :: exist=.false.

    !- Namelist file name, by default 'nh_namelist'
    if (present(filename)) then
       fn_nml = filename
    else
       fn_nml = 'nh_namelist'
    endif

    !- Check if a namelist file exist
    inquire(file=fn_nml, exist=exist)

    !- Read namelist file if it is present, else use default values
    if (exist) then

       open(unit=lun_nml, File=fn_nml, ACTION='READ')

       rewind(unit=lun_nml)
       read(unit=lun_nml, nml=nhparam)

    endif

    !- Print parameters or not !
    if (present(verbose)) then
       vb = verbose
    else
       vb = .true.
    endif

    if ((trim(interp_type)=='linear') .and. (trim(restrict_type)=='linear')) then
       if (rank == 0) write(*,*) "linear interp + linear restrict is not permitted"
       stop
    endif

    if (vb) then

       if (present(vbrank)) then
          rank = vbrank
       else
          rank = 0
       endif

       if (rank == 0) then
          write(*,*)'Non hydrostatic parameters:'
          write(*,*)'  - solver_prec   : ', solver_prec
          write(*,*)'  - solver_maxiter: ', solver_maxiter
          write(*,*)'  - nsmall        : ', nsmall
          write(*,*)'  - ns_coarsest   : ', ns_coarsest
          write(*,*)'  - ns_pre        : ', ns_pre
          write(*,*)'  - ns_post       : ', ns_post
          write(*,*)'  - cmatrix       : ', trim(cmatrix)
          write(*,*)'  - relax_method  : ', trim(relax_method)
          write(*,*)'  - interp_type   : ', trim(interp_type)
          write(*,*)'  - restrict_type : ', trim(restrict_type)
          write(*,*)'  - aggressive    : ', aggressive
          write(*,*)'  - netcdf_output : ', netcdf_output
          write(*,*)'  - bmask         : ', bmask
          write(*,*)'  '
       endif
    endif

  end subroutine read_nhnamelist

end module mg_namelist


! { dg-additional-options "-Ofast -fno-inline" }

subroutine check (a, b)
   real *8, intent(in) :: a(4), b(4)

   IF (abs(a(1)-b(1)) > 1) THEN
      STOP 1
   END IF
end subroutine check

program main
  real *8 :: mu(4,26), mumax(4), mumax2(4)

  integer :: i, k

  do k=1,26
     do i=1,4
        mu(i, k) = 4*(i-1) + k
     end do
  end do

  mumax = 0;
  do k=1,26
     do i=1,3
        mumax(i) = max(mumax(i), mu(i,k)+mu(i,k))
     end do
  end do

  mumax2 = 0;
  do i=1,3
     do k=1,26
        mumax2(i) = max(mumax2(i), mu(i,k)+mu(i,k))
     end do
  end do

  CALL check (mumax, mumax2)

  return
end program


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!   passing sections to a subroutine, test section descriptor construction

module mm
contains
 subroutine s(x)
  integer x(:,:)
  !call pgf90_show(x)
  x = x + 1
 end subroutine
end module
program p
 use mm
 integer d(10,10,10)
 integer r(30)
 integer e(30)
 data e/372,340,404,372,136,104,136,104,104,72, &
        372,340,404,372,136,104,136,104,104,72, &
         80,248,248,248,248,248,248,248,248,80/
 d = 0
 call s(d(:,:,1))
 call s(d(:,:,2))
 call s(d(:,:,3))
 call s(d(:,:,4))
 call s(d(:,1,:))
 call s(d(:,2,:))
 call s(d(:,3,:))
 call s(d(:,4,:))
 call s(d(2:9,:,1))
 call s(d(2:9,:,2))
 call s(d(2:9,:,3))
 call s(d(2:9,:,4))
 call s(d(2:9,1,:))
 call s(d(2:9,2,:))
 call s(d(2:9,3,:))
 call s(d(2:9,4,:))
 call s(d(2:9,3:8,1))
 call s(d(2:9,3:8,2))
 call s(d(2:9,3:8,3))
 call s(d(2:9,3:8,4))
 call s(d(2:9,1,3:8))
 call s(d(2:9,2,3:8))
 call s(d(2:9,3,3:8))
 call s(d(2:9,4,3:8))
 call s(d(2:9,1:9:2,1))
 call s(d(2:9,1:9:2,2))
 call s(d(2:9,1:9:2,3))
 call s(d(2:9,1:9:2,4))
 call s(d(2:9,1,1:9:2))
 call s(d(2:9,2,1:9:2))
 call s(d(2:9,3,1:9:2))
 call s(d(2:9,4,1:9:2))
 !open(unit=8,file='s.out')
 !write(8,'(10i4)') d
 !close(unit=8)
 do i = 1,10
  r(i) = sum(d(:,:,i))
 enddo
 do i = 1,10
  r(i+10) = sum(d(:,i,:))
 enddo
 do i = 1,10
  r(i+20) = sum(d(i,:,:))
 enddo
 !write(*,'(10i6)') r
 call check(r,e,30)
end


      subroutine runCP_iiii(k,i1,i2,i3,i4,f,Gr,Shat5,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,i1,i2,i3,i4,np
      parameter(np=2)
      double precision f(np),Gr(np,np)
      double complex Shat5(np,z4max,-2:0)

      do ep=-2,0
      Cv(ciiii(z4(i1,i2,i3,i4))+N0,ep)=
     . (Shat5(k,z4(i1,i2,i3,i4),ep)
     . -2d0*delta(k,i1)*Cv(czziii(z3(i2,i3,i4))+N0,ep)
     . -2d0*delta(k,i2)*Cv(czziii(z3(i1,i3,i4))+N0,ep)
     . -2d0*delta(k,i3)*Cv(czziii(z3(i1,i2,i4))+N0,ep)
     . -2d0*delta(k,i4)*Cv(czziii(z3(i1,i2,i3))+N0,ep)
     . -Gr(k,1)*Cv(ciiiii(z5(1,i1,i2,i3,i4))+N0,ep)
     . -Gr(k,2)*Cv(ciiiii(z5(2,i1,i2,i3,i4))+N0,ep))/f(k)
      enddo

      return
      end


subroutine scalfor(gcx, &
                   axm, bxm, axd, bxd, cx, &
                   bx, dx, ax, gm, alf)

      use stel_kinds, only: dp
      use name0, only: cp9, c1p1
      use name1, only: mpol1, nmax, nsd, nsd1
      use scalars, only: ns
      use extfld, only: ivac
      use mnarray, only: jmin2
      use inputdat, only: nfp

      implicit none

      real(kind=dp), intent(inout) :: gcx(ns,0:nmax,0:mpol1,2) ! force Fourier coefficients to precondition

      ! preconditioner matrix elements from precondn()
      real(kind=dp), intent(in)    :: axm(nsd1,2)
      real(kind=dp), intent(in)    :: bxm(nsd1,2)
      real(kind=dp), intent(in)    :: axd(nsd1,2)
      real(kind=dp), intent(in)    :: bxd(nsd1,2)
      real(kind=dp), intent(in)    :: cx (nsd   )

      real(kind=dp), intent(out) :: bx(ns,0:nmax,0:mpol1) ! temporary arrays
      real(kind=dp), intent(out) :: dx(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(out) :: ax(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(out) :: gm(*)
      real(kind=dp), intent(out) :: alf(*)

      integer :: jmax, js, m, mp, n, ntype

      jmax = ns
      if (ivac.lt.1) &
        jmax = ns-1

      do m = 0, mpol1
        mp = mod(m, 2) + 1 ! m-parity: even m --> 1, odd-m --> 2
        do n = 0, nmax

          ! assemble preconditioning matrix elements
          do js = jmin2(m), jmax
            bx(js,n,m) = axm(js  ,mp) + bxm(js  ,mp)*m**2
            dx(js,n,m) = axd(js  ,mp) + bxd(js  ,mp)*m**2 + cx(js)*(n*nfp)**2
            ax(js,n,m) = axm(js+1,mp) + bxm(js+1,mp)*m**2
          end do

          if (m.eq.1) then
            ! TODO: what is this?
            ! m=1-component of ns=2 for all n
            ! maybe has to do with m=1-constraint for innermost flux surface at js=2?
            dx(2,n,1) = dx(2,n,1) + bx(2,n,1)
          end if

          ! TODO: What happens here ?
          ! corrections at LCFS ???
          ! only relevant in free-boundary mode?
          dx(ns,n,m) = c1p1*dx(ns,n,m)
          bx(ns,n,m) =  cp9*bx(ns,n,m)
        end do
      end do

      ! solve tri-diagonal system for cc/ss and cs/sc coefficients separately
      ! in order to precondition force matrices
      do ntype = 1, 2
        ! ax: super-diagonal
        ! dx:       diagonal
        ! bx: sub  -diagonal elements
        ! gcx: right-hand side and solution
        call trid(ax, dx, bx, gcx(1,0,0,ntype), gm, alf, jmin2, jmax)
      end do

      return
end


      Subroutine RAHMBRDF (rho0,af,xk,mu,np,rm,rp,brdfint)
C***********************************************************************
C
C           A semi-empirical bidirectional reflectance model
C
C  Purpose:
C
C  To generate a single bidirectional reflectance factor value for a
C  semi-infinite medium, given the illumination and viewing geometry,
C  the optical and the structural properties of the scatterers.
C
C  Definitions:
c   geometrical conditions
C     mu1          : Illumination zenith angle, in radians
C     mu2          : Observation zenith angle, in radians
C     fi           : Relative azimuth angle, in radians
C   optical characteristics of the scatterers:
C     Rho0         : Intensity of the reflectance of the surface cover.
C                    N/D value greater or equal to 0.0 (Rho_0)
C     af           : Phase function parameter:
C                    Asymmetry factor, N/D value between -1.0 and 1.0
C     xk           : Structural parameter of the medium
C
C  References:
C
C        [1] R. Rahman, Verstraete M., and Pinty B., 1993, `A coupled
C            surface-atmosphere reflectance (CSAR) model. Part 1: Model
C            Description and Inversion on Synthetic Data', submitted to
C            JGR.
C        [2] R. Rahman, Pinty B., and Verstraete M., 1993, `A coupled
C            surface-atmosphere reflectance (CSAR) model. Part 2: a
C            semi-empirical model usable with NOAA/AVHRR data',
C            submitted to JGR.
C
C***********************************************************************
C
      integer mu,np,j,k
      real xk,af,rho0
      real rm(-mu:mu),rp(np),brdfint(-mu:mu,np)
      real coef1,coef2,cospha,geofac
      real fi,mu1,mu2,phaang,phafun,pi,tante1,tante2
C
      pi =acos(-1.0)
      mu1=rm(0)
      do 1 k=1,np
      do 2 j=1,mu
      mu2=rm(j)
      if (j.eq.mu)then
        fi=rm(-mu)
      else
        fi=rp(k)+rm(-mu)
      endif
C Compute various trigonometric expressions:
      cospha=mu1*mu2+sqrt(1.-mu1*mu1)*sqrt(1.-mu2*mu2)*cos(fi)
      phaang=acos(cospha)
      tante1=sqrt(1.-mu1*mu1)/mu1
      tante2=sqrt(1.-mu2*mu2)/mu2
      geofac=sqrt(tante1*tante1+tante2*tante2-2.0*tante1*tante2*cos(fi))
C Compute the first term
      coef1=(mu1**(xk-1.))*(mu2**(xk-1.))/((mu1+mu2)**(1.-xk))
C Compute the phase function:
      phafun=(1.0-af*af)/((1.0+af*af-2.0*af*cos(pi-phaang))**1.5)
C Compute the opposition (hot spot) function:
      coef2=1.+(1.-rho0)/(1.+geofac)
C Compute the bidirectional reflectance factor:
      brdfint(j,k)=rho0*coef1*phafun*coef2
  2   continue
  1   continue
C
      return
      end


      SUBROUTINE PHO_DOR94LO(X,Q2,Uv,Dv,Del,Udb,Sb,Gl)
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C                                                                 *
C    G R V  -  P R O T O N  - P A R A M E T R I Z A T I O N S     *
C                                                                 *
C                         1994 UPDATE                             *
C                                                                 *
C                 FOR A DETAILED EXPLANATION SEE                  *
C                   M. GLUECK, E.REYA, A.VOGT :                   *
C                   DO-TH 94/24  =  DESY 94-206                   *
C                    (TO APPEAR IN Z. PHYS. C)                    *
C                                                                 *
C   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
C        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
C             X         BETWEEN  1.E-5  AND   1.                  *
C   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
C   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
C                                                                 *
C   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
C                   M(C)  =  1.5,  M(B)  =  4.5                   *
C   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
C      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
C             LAMBDA(5)  =  0.153,                                *
C      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
C             LAMBDA(5)  =  0.131.                                *
C   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
C   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
C   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
C   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
C   GRV PARAMETRIZATION.                                          *
C                                                                 *
C   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
C   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
C   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
C                                                                 *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C...INPUT PARAMETERS :
C
C    X   = MOMENTUM FRACTION
C    Q2  = SCALE Q**2 IN GEV**2
C
C...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
C
C    UV  = U(VAL) = U - U(BAR)
C    DV  = D(VAL) = D - D(BAR)
C    DEL = D(BAR) - U(BAR)
C    UDB = U(BAR) + D(BAR)
C    SB  = S = S(BAR)
C    GL  = GLUON
C
C...LO PARAMETRIZATION :
C

      IMPLICIT NONE
      DOUBLE PRECISION ad , ae , ag , agx , akd , ake , akg , aks ,
     &                 aku , akx , alg , als , alx , as , au , bd , be ,
     &                 beg , bes , bex
      DOUBLE PRECISION bg , bgx , bkd , bke , bkg , bku , bkx , bs ,
     &                 bu , cd , ce , cg , cu , cx , dd , de , Del ,
     &                 dg , ds , dst
      DOUBLE PRECISION du , Dv , dx , eg , esg , ess , est , esx , ex ,
     &                 Gl , lam2 , mu2 , nd , ne , nu , PHO_DOR94FS ,
     &                 PHO_DOR94FV , PHO_DOR94FW , Q2 , s
      DOUBLE PRECISION s2 , s3 , Sb , Udb , Uv , X
      SAVE

      mu2 = 0.23
      lam2 = 0.2322*0.2322
      s = LOG(LOG(Q2/lam2)/LOG(mu2/lam2))
      ds = SQRT(s)
      s2 = s*s
      s3 = s2*s
C...UV :
      nu = 2.284 + 0.802*s + 0.055*s2
      aku = 0.590 - 0.024*s
      bku = 0.131 + 0.063*s
      au = -0.449 - 0.138*s - 0.076*s2
      bu = 0.213 + 2.669*s - 0.728*s2
      cu = 8.854 - 9.135*s + 1.979*s2
      du = 2.997 + 0.753*s - 0.076*s2
      Uv = PHO_DOR94FV(X,nu,aku,bku,au,bu,cu,du)
C...DV :
      nd = 0.371 + 0.083*s + 0.039*s2
      akd = 0.376
      bkd = 0.486 + 0.062*s
      ad = -0.509 + 3.310*s - 1.248*s2
      bd = 12.41 - 10.52*s + 2.267*s2
      cd = 6.373 - 6.208*s + 1.418*s2
      dd = 3.691 + 0.799*s - 0.071*s2
      Dv = PHO_DOR94FV(X,nd,akd,bkd,ad,bd,cd,dd)
C...DEL :
      ne = 0.082 + 0.014*s + 0.008*s2
      ake = 0.409 - 0.005*s
      bke = 0.799 + 0.071*s
      ae = -38.07 + 36.13*s - 0.656*s2
      be = 90.31 - 74.15*s + 7.645*s2
      ce = 0.0
      de = 7.486 + 1.217*s - 0.159*s2
      Del = PHO_DOR94FV(X,ne,ake,bke,ae,be,ce,de)
C...UDB :
      alx = 1.451
      bex = 0.271
      akx = 0.410 - 0.232*s
      bkx = 0.534 - 0.457*s
      agx = 0.890 - 0.140*s
      bgx = -0.981
      cx = 0.320 + 0.683*s
      dx = 4.752 + 1.164*s + 0.286*s2
      ex = 4.119 + 1.713*s
      esx = 0.682 + 2.978*s
      Udb = PHO_DOR94FW(X,s,alx,bex,akx,bkx,agx,bgx,cx,dx,ex,esx)
C...SB :
      als = 0.914
      bes = 0.577
      aks = 1.798 - 0.596*s
      as = -5.548 + 3.669*ds - 0.616*s
      bs = 18.92 - 16.73*ds + 5.168*s
      dst = 6.379 - 0.350*s + 0.142*s2
      est = 3.981 + 1.638*s
      ess = 6.402
      Sb = PHO_DOR94FS(X,s,als,bes,aks,as,bs,dst,est,ess)
C...GL :
      alg = 0.524
      beg = 1.088
      akg = 1.742 - 0.930*s
      bkg = -0.399*s2
      ag = 7.486 - 2.185*s
      bg = 16.69 - 22.74*s + 5.779*s2
      cg = -25.59 + 29.71*s - 7.296*s2
      dg = 2.792 + 2.215*s + 0.422*s2 - 0.104*s3
      eg = 0.807 + 2.005*s
      esg = 3.841 + 0.316*s
      Gl = PHO_DOR94FW(X,s,alg,beg,akg,bkg,ag,bg,cg,dg,eg,esg)

      END SUBROUTINE


C     FIXME: timelines for thin/thick disks shouldn't start at one point
C     Generates stars population inside a square pyramid (pencil/cone)
C     with its height direction set by longitude and latitude
      subroutine generate_cone_stars(cone_height_longitude,
     &                               cone_height_latitude,
     &                               numberOfStarsInSample,
     &                               iseed,
     &                               thick_disk_stars_fraction,
     &                               thin_disk_age,
     &                               min_longitude,
     &                               max_longitude,
     &                               min_latitude,
     &                               max_latitude,
     &                               massReductionFactor)
          implicit none

          external ran
          real ran

          real :: cone_height_longitude,
     &            cone_height_latitude,
     &            thin_disk_age,
     &            thick_disk_stars_fraction,
     &            thin_disk_stars_fraction,
     &            massReductionFactor
          integer :: iseed,
     &               numberOfStarsInSample

          integer, parameter :: numberOfStars = 6000000
          real :: starBirthTime(numberOfStars),
     &            m(numberOfStars)
          double precision :: coordinate_Theta(numberOfStars),
     &                        coordinate_R(numberOfStars),
     &                        coordinate_Zcylindr(numberOfStars)
          integer :: numberOfWDs,
     &               disk_belonging(numberOfStars),
     &               flagOfWD(numberOfStars)

          real, parameter :: PI = 4.0 * atan(1.0),
     &                       FI = PI / 180.0,
     &                       DELTA_LATITUDE = 2.64 * FI,
     &                       NORMALIZATION_CONE_HEIGHT = 0.2,
     &                       CONE_HEIGHT = 2.0,
     &                       THIN_DISK_DENSITY = 0.095 * 1.0e9,
     &                       THIN_DISK_SCALEHEIGHT = 0.25,
     &                       THICK_DISK_SCALEHEIGHT = 1.5,
     &                       SOLAR_GALACTOCENTRIC_DISTANCE = 8.5
          real :: delta_longitude,
     &            min_longitude,
     &            max_longitude,
     &            min_latitude,
     &            max_latitude,
     &            normalization_cone_mass,
     &            max_density,
     &            total_mass,
     &            longitude,
     &            latitude,
     &            density,
     &            random_valid_density,
     &            get_cone_mass,
     &            get_max_density,
     &            distance,
     &            get_density,
     &            generate_star_mass,
     &            tmax,
     &            tmdisk = 10.0,
     &            tau = 2.0,
     &            ttry,
     &            ttdisk = 12.0,
     &            ft,
     &            fz,
     &            opposite_triangle_side
          integer :: stars_count

          common /tm/ starBirthTime,
     &                m
          common /coorcil/ coordinate_R,
     &                     coordinate_Theta,
     &                     coordinate_Zcylindr
          common /index/ flagOfWD,numberOfWDs,disk_belonging

          thin_disk_stars_fraction = 1.0 - thick_disk_stars_fraction

          ! NOTE: this can be infinity
          delta_longitude = DELTA_LATITUDE / cos(cone_height_latitude)
          min_longitude = cone_height_longitude  - delta_longitude / 2.0
          max_longitude = cone_height_longitude  + delta_longitude / 2.0
          min_latitude = cone_height_latitude  - DELTA_LATITUDE / 2.0
          max_latitude = cone_height_latitude + DELTA_LATITUDE / 2.0

          total_mass = 0.0
          stars_count = 0

C         TODO: this is a boilerplate
          if (thin_disk_stars_fraction > 0.0) then

              normalization_cone_mass = get_cone_mass(
     &              cone_height_longitude,
     &              cone_height_latitude,
     &              THIN_DISK_DENSITY * thin_disk_stars_fraction,
     &               THIN_DISK_SCALEHEIGHT)
              normalization_cone_mass = normalization_cone_mass
     &                              * massReductionFactor

              max_density = get_max_density(cone_height_longitude,
     &                                      cone_height_latitude,
     &                                      THIN_DISK_SCALEHEIGHT)

              outer_do2: do
                  stars_count = stars_count + 1

                  disk_belonging(stars_count) = 1

C                 assuming uniform distribution
                  longitude = min_longitude + delta_longitude*ran(iseed)
                  latitude = min_latitude + DELTA_LATITUDE * ran(iseed)

                  inner_do2: do
                      ! Distance between Sun and random point in the cone
                      distance = CONE_HEIGHT * ran(iseed)

                      density = get_density(distance,
     &                                      longitude,
     &                                      latitude,
     &                                      THIN_DISK_SCALEHEIGHT)

                      ! Monte-Carlo accepting/rejecting method
                      ! TODO: find out if this can be outside the inner loop
                      random_valid_density = max_density * ran(iseed)

                      if (random_valid_density <= density) exit
                  end do inner_do2

C                 mass
                  m(stars_count) = generate_star_mass(iseed)
C                 converting from galactic to cyl.galactocentric
                  coordinate_R(stars_count)
     &                = opposite_triangle_side(
     &                      SOLAR_GALACTOCENTRIC_DISTANCE,
     &                      distance * abs(cos(latitude)),
     &                      longitude)
                  coordinate_Theta(stars_count)
     &                = asin(distance*abs(cos(latitude))
     &                  *sin(longitude)/coordinate_R(stars_count))
                  coordinate_Zcylindr(stars_count) = distance
     &                                               * sin(latitude)

                  if(distance < NORMALIZATION_CONE_HEIGHT) then
                      total_mass = total_mass + m(stars_count)
                  end if

                  if (total_mass >= normalization_cone_mass) exit

                  ! Assuming constant star formation rate
                  starBirthTime(stars_count) =thin_disk_age*ran(iseed)
              end do outer_do2

              total_mass = 0.0
          end if

          if (thick_disk_stars_fraction > 0.0) then

              normalization_cone_mass = get_cone_mass(
     &            cone_height_longitude,
     &            cone_height_latitude,
     &            THIN_DISK_DENSITY * thick_disk_stars_fraction,
     &            THICK_DISK_SCALEHEIGHT)
              normalization_cone_mass = normalization_cone_mass
     &                                  * massReductionFactor

              max_density = get_max_density(cone_height_longitude,
     &                                      cone_height_latitude,
     &                                      THICK_DISK_SCALEHEIGHT)

              outer_do3: do
                  stars_count = stars_count + 1

                  disk_belonging(stars_count) = 2

C                 assuming uniform distribution
                  longitude = min_longitude + delta_longitude*ran(iseed)
                  latitude = min_latitude + DELTA_LATITUDE * ran(iseed)

                  inner_do3: do
                      ! Distance between Sun and random point in the cone
                      distance = CONE_HEIGHT * ran(iseed)

                      density = get_density(distance,longitude,latitude,
     &                                          THICK_DISK_SCALEHEIGHT)

                      ! Monte-Carlo accepting/rejecting method
                      ! TODO: find out if this can be outside the inner loop
                      random_valid_density = max_density * ran(iseed)

                      if (random_valid_density <= density) exit
                  end do inner_do3

C                 mass
                  m(stars_count) = generate_star_mass(iseed)
C                 converting from galactic to cyl.galactocentric
                  coordinate_R(stars_count)
     &                = opposite_triangle_side(
     &                      SOLAR_GALACTOCENTRIC_DISTANCE,
     &                      distance * abs(cos(latitude)),
     &                      longitude)
                  coordinate_Theta(stars_count)
     &                = asin(distance*abs(cos(latitude))
     &                  *sin(longitude)/coordinate_R(stars_count))
                  coordinate_Zcylindr(stars_count) = distance
     &                                               * sin(latitude)
                  if(distance < NORMALIZATION_CONE_HEIGHT) then
                      total_mass = total_mass + m(stars_count)
                  end if
                  if (total_mass >= normalization_cone_mass) exit

                  ! Assuming constant star formation rate
                  starBirthTime(stars_count) =thin_disk_age*ran(iseed)
                  tmax = tmdisk * exp(-tmdisk/tau)
 33               ttry = ttdisk * ran(iseed)
                  ft = ttry * exp(-ttry/tau)
                  fz = tmax * ran(iseed)
                  if (fz .le. ft) then
                      starBirthTime(stars_count) = ttry
                  else
                      goto 33
                  end if
              end do outer_do3
          end if

          numberOfStarsInSample = stars_count
      end subroutine

      function get_cone_mass(cone_height_longitude,
     &                       cone_height_latitude,
     &                       density,
     &                       scaleheight) result(mass)
          implicit none
          real, intent(in) :: cone_height_longitude,
     &                                  cone_height_latitude
          real, parameter :: PI = 4.0 * atan(1.0),
     &                                   FI = PI / 180.0,
     &                                   DELTA_LATITUDE = 2.64 * FI,
     &                                THIN_DISK_DENSITY = 0.095 * 1.0e9,
     &                                   THIN_DISK_SCALEHEIGHT = 0.25
          real :: muted_cone_height_longitude,
     &                        muted_cone_height_latitude,
     &                        mass,
     &                        delta_longitude,
     &                        min_longitude,
     &                        max_longitude,
     &                        min_latitude,
     &                        max_latitude,
     &                        get_kappa_integral,
     &                        get_iota_integral,
     &                        get_lambda_integral,
     &                        density,
     &                        scaleheight

          ! We need these vars as we don't want to change values of
          ! min_latitude and max_latitude outside this function
          muted_cone_height_longitude = cone_height_longitude
          muted_cone_height_latitude = cone_height_latitude

          ! NOTE: next 2 if-blocks are a workaround
          ! We do this as the picture is symmetrical
          if (muted_cone_height_latitude < 0.0) then
              muted_cone_height_latitude = -muted_cone_height_latitude
          end if
          ! This is done in order to avoid problems with spherical
          ! coordinates near the pole
          ! Also we assume that angles are in [-90, 90] range
          if (muted_cone_height_latitude > 85.0 * FI) then
              muted_cone_height_latitude = 85.0 * FI
          end if

          delta_longitude = DELTA_LATITUDE
     &                      / cos(muted_cone_height_latitude)
          min_longitude=muted_cone_height_longitude-delta_longitude/2.0
          max_longitude=muted_cone_height_longitude+delta_longitude/2.0
          min_latitude = muted_cone_height_latitude - DELTA_LATITUDE/2.0
          max_latitude = muted_cone_height_latitude + DELTA_LATITUDE/2.0

          ! Next, we consider 3 cases:
          !   1) Both min_latitude and max_latitude are in [0; PI/2]
          !   2) min_latitude is negative and max_latitude is in [0; PI/2]
          !   3) min_latitude is in [0; PI/2] and max_latitude > PI/2

          ! TODO: add explanations about equations and integrals
          ! Case 1:
          if (min_latitude >= 0.0
     &        .and. max_latitude <= PI / 2.0) then
                  mass = density * delta_longitude
     &                   * scaleheight
     &                   * (get_kappa_integral(min_latitude,scaleheight)
     &                      - get_kappa_integral(max_latitude,
     &                                           scaleheight))
          end if

          ! Case 2:
          if (min_latitude < 0.0) then
              mass = density * delta_longitude
     &               * (get_iota_integral(abs(min_latitude),
     &                                    scaleheight)
     &                 + get_iota_integral(max_latitude,scaleheight))
          end if

          ! Case 3:
          if (max_latitude > PI / 2.0) then
              mass = density * delta_longitude
     &               * (get_lambda_integral((PI - max_latitude),
     &                                      scaleheight)
     &                   + get_lambda_integral(min_latitude,
     &                                         scaleheight))
          end if
      end function

      function get_max_density(longitude,
     &                         latitude,
     &                         scaleheight) result(max_density)
          implicit none
          real, intent(in) :: longitude,
     &                        latitude
          real :: max_density,
     &            density,
     &            distance,
     &            get_density,
     &            scaleheight
          integer :: distance_index
          integer, parameter :: DISTANCE_ITER_COUNT = 1000
          real, parameter :: CONE_HEIGHT = 2.0,
     &                       DISTANCE_INCREMENT
     &                           = CONE_HEIGHT
     &                             / float(DISTANCE_ITER_COUNT),
     &                       MONTE_CARLO_MAX_SHIFT_FACTOR = 1.1

          max_density = 0.0
          do distance_index = 1, DISTANCE_ITER_COUNT
              distance = DISTANCE_INCREMENT * float(distance_index)

              density = get_density(distance,
     &                              longitude,
     &                              latitude,
     &                              scaleheight)
              max_density = max(max_density, density)
          end do

          max_density = MONTE_CARLO_MAX_SHIFT_FACTOR * max_density
      end function

      function get_density(distance,longitude,latitude,scaleheight)
     &                                           result(density)
          implicit none
          real, intent(in) :: distance, longitude, latitude
          real :: density,
     &            pole_projection,
     &            plane_projection,
     &            galactocentric_distance,
     &            opposite_triangle_side,
     &            scaleheight
          real, parameter :: SOLAR_GALACTOCENTRIC_DISTANCE = 8.5,
     &                       THICK_DISK_SCALELENGTH = 3.0

          pole_projection = distance * abs(sin(latitude))
          plane_projection = distance * abs(cos(latitude))

          galactocentric_distance  = opposite_triangle_side(
     &                                   plane_projection,
     &                                   SOLAR_GALACTOCENTRIC_DISTANCE,
     &                                   longitude)

          density = distance * distance
     &              * exp(-abs(pole_projection) / scaleheight)
     &              * exp(-abs(galactocentric_distance)
     &                     / THICK_DISK_SCALELENGTH)
      end function

      function generate_star_mass(iseed) result(mass)
          implicit none

          external ran
          real ran

          integer, intent(inout) :: iseed
          real, parameter :: MIN_MASS = 0.4,
     &                            MAX_MASS = 50.0,
     &                            MASS_RANGE = MAX_MASS - MIN_MASS,
     &                            ALPHA_IMF = -2.35,
     &                            YMAX = MIN_MASS ** ALPHA_IMF
          real :: zy,
     &                        zx,
     &                        zyimf,
     &                        mass
         do
              ! Launching(¿lanzamos?) a number (coord y) according to
              ! function of comparison cte. (?)
              zy = YMAX * ran(iseed)
              ! Launching (¿lanzamos?) another number (coord x)
              zx = MIN_MASS + MASS_RANGE * ran(iseed)
              ! Calculating the value of the IMF for m = zx
              zyimf = zx ** ALPHA_IMF
              ! Comparing the IMF with cte function
              if (zy <= zyimf) then
                  exit
              end if
          end do

          mass = zx

      end function

      function opposite_triangle_side(adjacent_1,
     &                                adjacent_2,
     &                                enclosed_angle) result(opposite)
          implicit none
          real, intent(in) :: adjacent_1,
     &                                    adjacent_2,
     &                                    enclosed_angle
          real :: opposite

          ! cosines law
          opposite = sqrt(adjacent_1 * adjacent_1
     &                      + adjacent_2 * adjacent_2
     &                      - 2.0 * adjacent_1 * adjacent_2
     &                        * cos(enclosed_angle))
      end function

      ! Calculates an integral that is needed to compute the mass of the
      ! spherical square pyramid. Name kappa is chosen randomly.
      function get_kappa_integral(latitude,scaleheight) result(kappa)
          implicit none
          real, intent(in) :: latitude
          real :: kappa, gamma, scaleheight
          real, parameter :: NORMALIZATION_CONE_HEIGHT=0.2

          ! We use this constant just to simplify the next expressions
          gamma = scaleheight / sin(latitude)

          kappa = gamma*(gamma-exp(-NORMALIZATION_CONE_HEIGHT / gamma)
     &                         * (gamma + NORMALIZATION_CONE_HEIGHT))
      end function

      ! Calculates an integral that is needed to compute the mass of the
      ! spherical square pyramid. Case 2. Name iota is chosen randomly.
      function get_iota_integral(latitude,scaleheight) result(iota)
          implicit none
          real, intent(in) :: latitude
          real :: iota, get_kappa_integral,scaleheight
          real, parameter :: THIN_DISK_SCALEHEIGHT = 0.25,
     &                                   NORMALIZATION_CONE_HEIGHT=0.2

          iota = (NORMALIZATION_CONE_HEIGHT * NORMALIZATION_CONE_HEIGHT
     &             / 2.0
     &             - get_kappa_integral(latitude,scaleheight))
     &               * scaleheight
      end function

      ! Calculates an integral that is needed to compute the mass of the
      ! spherical square pyramid. Case 3. Name lambda is chosen randomly.
      function get_lambda_integral(latitude,scaleheight) result(lambda)
          implicit none
          real, intent(in) :: latitude
          real :: lambda, get_kappa_integral,scaleheight
          real, parameter :: THIN_DISK_SCALEHEIGHT = 0.25,
     &                                   NORMALIZATION_CONE_HEIGHT=0.2
          real, parameter :: PI = 4.0 * atan(1.0)

          lambda = -scaleheight
     &               * (get_kappa_integral((PI / 2.0),scaleheight)
     &                  - get_kappa_integral(latitude,scaleheight))
      end function


      subroutine GZHggggvsqPoles(p,sqres)
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'zprods_com.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'b0.f'
      double precision   p(4,5),sqres(-2:0)
      double precision   Hgggg,Hgggg_1234,Hgggg_1243,Hgggg_1423
      double precision   q(mxpart,4)
      integer i,j
      double precision   s12,s13,s14,s23,s24,s34
      double complex lnrat

C --  reversal of GZ notation and restore dimension of the momenta
      do i=1,4
         do j=1,4
            q(i,j) = p(j,i)*hmass
         enddo
      enddo
      call spinoru(4,q,za,zb)

      call h4g(1,2,3,4,Hgggg,Hgggg_1234,Hgggg_1243,Hgggg_1423)

      s12=s(1,2)
      s13=s(1,3)
      s14=s(1,4)
      s23=s(2,3)
      s24=s(2,4)
      s34=s(3,4)

c--- NB: removed factor of ason2pi which is restored
c--- in the wrapping routine
      sqres(-2) = -4d0*xn*Hgggg
      sqres(-1) = xn*(
     . dble(lnrat(-s12,musq)+lnrat(-s23,musq)
     .     +lnrat(-s34,musq)+lnrat(-s14,musq))*Hgggg_1234+

     . dble(lnrat(-s12,musq)+lnrat(-s24,musq)
     .     +lnrat(-s34,musq)+lnrat(-s13,musq))*Hgggg_1243+

     . dble(lnrat(-s14,musq)+lnrat(-s24,musq)
     .     +lnrat(-s23,musq)+lnrat(-s13,musq))*Hgggg_1423)

      sqres(0)  = 11d0*Hgggg
c--- The finite part which will be calculated using the semi-numerical
c--- procedure has to be added to this piece, which comes from the
c--- finite renormalization of the effective Lagrangian

c--- Add on renormalization factor
      sqres(-1)=sqres(-1)-4d0*b0*Hgggg

C       write(*,*) 'Poles Hggggv K: Born', Hgggg
C      write(*,*) 'Poles Hggggv K: 1/eps^2', sqres(-2)
C      write(*,*) 'Poles Hggggv K: 1/eps^1', sqres(-1)

      return
      end


module crosssection
    use main
    use constants
    use transition
    contains
    function diffCrossSection(v, q)
        ! Computes the differential cross section per recoil energy ds/dEr
        implicit none
        real(kind=8) :: diffCrossSection
        real(kind=8) :: v ! velocity of DM particle in lab frame
        real(kind=8) :: q

        diffCrossSection = (nuc_target%mass*mN/(2d0*pi*v*v)) * transition_probability(v, q)

    end function diffCrossSection
end module


C **********************************************************
C library of functions used in calculation of currents
C references:
C [1]   arXiv:0911.4436 (hep-ph)  D. Gomez Dumm et al. (tau -> 3pi nu)
C [2]   arXiv:0911.2640 (hep-ph) D. Gomezz Dumm et al. (tau -> KKpi nu)
C [3]   arXiv:0807.4883 (hep-ph) D. R. Boito et al. (tau -> Kpi nu)
C [4]   P. Roig, talk at (tau -> 2 pi nu)
C [5]   arXiv:0803.2039  (hep-ph) E. Arganda et al., Appendix B (tau -> KK nu)
C **********************************************************

      FUNCTION ALP1_RPT(Q,S,T,M1SQ,M2SQ,M3SQ,
     $                           MMM,MMM2,GGG)
      IMPLICIT NONE
      REAL                      Q,S,T
      DOUBLE PRECISION                M1SQ,M2SQ,M3SQ,
     &                           MMM,MMM2,GGG
C **********************************************************
C     COMPLEX FUNCTION ALP1_RPT;
C     one-resonance contribution to
C     F3pi_rcht(iform=1,2) at f3pi_rcht.f;
C     corrected  formula (8) of REF [1] including rho1,
C     the factor sqrt(2)*FV_RPT*GV_RPT/(3.*FPI_RPT**3) is included in
C     F3pi_rcht(iform1=1,2) at f3pi_rcht.f
C **********************************************************
      REAL U
      include '../parameter.inc'
      include '../funct_declar.inc'

       U= Q-S-T+M1SQ+M2SQ+M3SQ
       ALP1_RPT = - 3.*S/(1.+BETA_RHO)*
     $     (1./(S-MMM**2+i*MMM*GRHO_RCHT(S,MMM))+
     $      BETA_RHO/(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG)))
     $      +(2.*GV_RPT/FV_RPT-1.)*
     $      ((2.*Q-2.*S-U)/(1.+BETA_RHO)*
     $      (1./(S-MMM**2+i*MMM*GRHO_RCHT(S,MMM))+
     $      BETA_RHO/(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG)))+
     $      (U-S)/(1.+BETA_RHO)*
     $      (1./(T-MMM**2+i*MMM*GRHO_RCHT(T,MMM))+
     $       BETA_RHO/(T-MMM2**2+i*MMM2*GRHO1_RCHT(T,MMM2,GGG))))

      RETURN

      END

      FUNCTION BETA_RPT(Q,S,T,M1SQ,M2SQ,M3SQ,MMM,MMM2,GGG)
      IMPLICIT NONE
      REAL                      Q,S,T
      DOUBLE PRECISION                M1SQ,M2SQ,M3SQ,MMM,MMM2,GGG
C **********************************************************
C     COMPLEX FUNCTION BETA_RPT ; two-resonance contribution to
C     F3pi_rcht(iform=1,2) at f3pi_rcht.f;
C     corrected  formula (8) of REF [1] including rho1,
C     the factor 4*FA_RPT*GV_RPT/(3.*FPI_RPT**3)*QQ/D_a1(QQ)
C     is included in F3pi_rcht(iform1=1,2) at f3pi_rcht.f
C **********************************************************
      include '../parameter.inc'
      include '../funct_declar.inc'

      REAL U,LAM0_RPT,LAM1_RPT,LAM2_RPT,FF1_RPT,FF2_RPT,FF_REL

      FF_REL = FPI_RPT*FPI_RPT/(FV_RPT*FV_RPT)

       LAM1_RPT = FPI_RPT*FPI_RPT/(2.D0*SQRT(2.D0)*FA_RPT*GV_RPT)
       LAM2_RPT = -(1.-2.*FF_REL)*LAM1_RPT
       LAM0_RPT = (LAM1_RPT + LAM2_RPT)/4.

	U= Q-S-T+M1SQ+M2SQ+M3SQ

      FF1_RPT = -LAM0_RPT*M1SQ/Q +LAM1_RPT*S/Q+LAM2_RPT
      FF2_RPT = -LAM0_RPT*M1SQ/Q +LAM1_RPT*T/Q+LAM2_RPT

      BETA_RPT = -3.*(LAM1_RPT+LAM2_RPT)*S/(1.+BETA_RHO)*
     $     (1./(S-MMM**2+i*MMM*GRHO_RCHT(S,MMM))+
     $      BETA_RHO/(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG)))+
     $         FF1_RPT*(2.*Q+S-U)/(1.+BETA_RHO)*
     $     (1./(S-MMM**2+i*MMM*GRHO_RCHT(S,MMM))+
     $      BETA_RHO/(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG)))+
     $         FF2_RPT*(U-S)/(1.+BETA_RHO)*
     $     (1./(T-MMM**2+i*MMM*GRHO_RCHT(T,MMM))+
     $      BETA_RHO/(T-MMM2**2+i*MMM2*GRHO1_RCHT(T,MMM2,GGG)))

      RETURN

      END

      FUNCTION ALP1_RPT_RHO1(Q,S,T,M1SQ,M2SQ,M3SQ,
     $                           MMM,MMM2,GGG)
      IMPLICIT NONE
      REAL                      Q,S,T
      DOUBLE PRECISION                M1SQ,M2SQ,M3SQ,
     &                           MMM,MMM2,GGG
C **********************************************************
C     COMPLEX FUNCTION ALP1_RPT_RHO1;
C     one-resonance contribution to
C     F3pi_rcht(iform=1,2) at f3pi_rcht.f;
C     corrected  formula (8) of REF [1] including rho1,
C     the factor sqrt(2)*FV_RPT*GV_RPT/(3.*FPI_RPT**3) is included in
C     F3pi_rcht(iform1=1,2) at f3pi_rcht.f
C **********************************************************
      REAL U
      include '../parameter.inc'
      include '../funct_declar.inc'

       U= Q-S-T+M1SQ+M2SQ+M3SQ
       ALP1_RPT_RHO1 = - 3.*S
     $      /(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG))
     $      +(2.*GV1_RPT/FV1_RPT-1.)*
     $      (  (2.*Q-2.*S-U)
     $      /(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG))+
     $      (U-S)/(T-MMM2**2+i*MMM2*GRHO1_RCHT(T,MMM2,GGG))  )

      RETURN

      END

      FUNCTION BETA_RPT_RHO1(Q,S,T,M1SQ,M2SQ,M3SQ,MMM,MMM2,GGG)
      IMPLICIT NONE
      REAL                      Q,S,T
      DOUBLE PRECISION                M1SQ,M2SQ,M3SQ,MMM,MMM2,GGG
C **********************************************************
C     COMPLEX FUNCTION BETA_RPT_RHO1 ; two-resonance contribution to
C     F3pi_rcht(iform=1,2) at f3pi_rcht.f;
C     corrected  formula (8) of REF [1] including rho1,
C     the factor 4*FA_RPT*GV_RPT/(3.*FPI_RPT**3)*QQ/D_a1(QQ)
C     is included in F3pi_rcht(iform1=1,2) at f3pi_rcht.f
C **********************************************************
      include '../parameter.inc'
      include '../funct_declar.inc'

      REAL U,LAM0_RPT,LAM1_RPT,LAM2_RPT,FF1_RPT,FF2_RPT,FF_REL

      FF_REL = FPI_RPT*FPI_RPT/(FV1_RPT*FV1_RPT)

       LAM1_RPT = FPI_RPT*FPI_RPT/(2.D0*SQRT(2.D0)*FA_RPT*GV1_RPT)
       LAM2_RPT = -(1.-2.*FF_REL)*LAM1_RPT
       LAM0_RPT = (LAM1_RPT + LAM2_RPT)/4.

	U= Q-S-T+M1SQ+M2SQ+M3SQ

      FF1_RPT = -LAM0_RPT*M1SQ/Q +LAM1_RPT*S/Q+LAM2_RPT
      FF2_RPT = -LAM0_RPT*M1SQ/Q +LAM1_RPT*T/Q+LAM2_RPT

      BETA_RPT_RHO1 = -3.*(LAM1_RPT+LAM2_RPT)*S
     $     /(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG)) +
     $         FF1_RPT*(2.*Q+S-U)
     $     /(S-MMM2**2+i*MMM2*GRHO1_RCHT(S,MMM2,GGG))+
     $         FF2_RPT*(U-S)
     $     /(T-MMM2**2+i*MMM2*GRHO1_RCHT(T,MMM2,GGG))

      RETURN

      END


!##########################################################################
      subroutine wall_function(bound,cond)
!			Bruño Fraga Bugallo
!			Cardiff 2014
!			werner/wengle type boundary conditions
!##########################################################################
        use vars
        use multidata
        implicit none
        integer i,j,k,ib,bound,cond
        double precision delta,n_x,n_y,n_z,vnor,vtan,dvtan,sub
        double precision uc,vc,wc,rrey,small,dycell,rycell,vtankr
        double precision tausub,taupow
	  double precision aaa,bbb,const1,const2,const3,const4

        rrey=1.0/Re
        small = 1.e-30

	  SELECT CASE (cond)

	  CASE (63)
!.....specify constants for 1/6 power law ..............................
      data aaa,     bbb
     &   / 8.3, 0.1666666666/

	  CASE (64)
!.....specify constants for 1/7 power law ..............................
      data aaa,     bbb
     &   / 8.3, 0.1428571429/

	  CASE (65)
!.....specify constants for 1/8 power law ..............................
      data aaa,     bbb
     &   / 8.3, 0.125/

	end select

!.....constant factors .................................................

      const1 = 0.5 * (1. - bbb) * aaa ** ((1. + bbb) / (1. - bbb))
      const2 = (1. + bbb) / aaa
      const3 = aaa ** (2. / (1. - bbb))
      const4 = 2. / (1. + bbb)

        do ib=1,nbp

	  SELECT CASE (bound)

	  CASE (1)
              delta=0.5*dom(ib)%dx
              n_x=1.0
              n_y=0.0
              n_z=0.0
              i=dom(ib)%isp
              do k=dom(ib)%ksp-1,dom(ib)%kep+1
                 do j=dom(ib)%jsp-1,dom(ib)%jep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                    vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauww(j,k)=(sub*tausub+(1.-sub)*taupow)	!tau_1
			  dom(ib)%tauww2(j,k)=dom(ib)%tauww(j,k)/vtan		!needs to be multiplied by a velocity component to provide tau_1j
                 end do
              end do

	     CASE (2)
              delta=0.5*dom(ib)%dx
              n_x=-1.0
              n_y=0.0
              n_z=0.0
              i=dom(ib)%iep
              do k=dom(ib)%ksp-1,dom(ib)%kep+1
                 do j=dom(ib)%jsp-1,dom(ib)%jep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                    vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauwe(j,k)=(sub*tausub+(1.-sub)*taupow)	!units m2/s2
			  dom(ib)%tauwe2(j,k)=dom(ib)%tauwe(j,k)/vtan		!units m/s
                 end do
              end do

           CASE(3)
              delta=0.5*dom(ib)%dy
              n_x=0.0
              n_y=1.0
              n_z=0.0
              j=dom(ib)%jsp

              do k=dom(ib)%ksp-1,dom(ib)%kep+1
                 do i=dom(ib)%isp-1,dom(ib)%iep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                    vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauws(i,k)=(sub*tausub+(1.-sub)*taupow)
			  dom(ib)%tauws2(i,k)=dom(ib)%tauws(i,k)/vtan
                 end do
              end do

           CASE (4)
              delta=0.5*dom(ib)%dy
              n_x=0.0
              n_y=-1.0
              n_z=0.0
              j=dom(ib)%jep
              do k=dom(ib)%ksp-1,dom(ib)%kep+1
                 do i=dom(ib)%isp-1,dom(ib)%iep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                    vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauwn(i,k)=(sub*tausub+(1.-sub)*taupow)
			  dom(ib)%tauwn2(i,k)=dom(ib)%tauwn(i,k)/vtan
                 end do
              end do

           CASE (5)

              delta=0.5*dom(ib)%dz
              n_x=0.0
              n_y=0.0
              n_z=1.0
              k=dom(ib)%ksp
              do j=dom(ib)%jsp-1,dom(ib)%jep+1
                 do i=dom(ib)%isp-1,dom(ib)%iep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
			  vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauwb(i,j)=(sub*tausub+(1.-sub)*taupow)
			  dom(ib)%tauwb2(i,j)=dom(ib)%tauwb(i,j)/vtan
                 end do
              end do

           CASE (6)
              delta=0.5*dom(ib)%dz
              n_x=0.0
              n_y=0.0
              n_z=-1.0
              k=dom(ib)%kep
              do j=dom(ib)%jsp-1,dom(ib)%jep+1
                 do i=dom(ib)%isp-1,dom(ib)%iep+1
                    uc=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                    vc=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                    wc=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                    vnor=n_x*uc+n_y*vc+n_z*wc
                    vtan=sqrt(abs(uc*uc+vc*vc+wc*wc-vnor*vnor+small))

            	  dycell = 2. * delta
            	  rycell = 1. / dycell
            	  vtankr = 0.5 * rrey * rycell * const3
            	  dvtan  = vtankr - vtan
            	  sub    = MAX (SIGN(1.,dvtan),0.)

            	  tausub   = rrey * vtan / delta
            	  taupow   = ( const1 * (rrey * rycell)**(1.+bbb) +
     &                 ( const2 * (rrey * rycell)**bbb) * vtan)
     &                    ** const4
		 	  dom(ib)%tauwt(i,j)=(sub*tausub+(1.-sub)*taupow)
			  dom(ib)%tauwt2(i,j)=dom(ib)%tauwt(i,j)/vtan
                 end do
              end do

	  end select
        end do

        return
        end subroutine wall_function
!##########################################################################


    subroutine distance(Pos, Tar, rc, rnum, Dim, Dlim, np, sumiden)
    implicit none
    integer,intent(in):: Dim, rnum
    real(8),intent(in):: rc
    real(8),intent(in), dimension(:,:) :: Pos
    real(8),intent(in), dimension(:,:) :: Tar
    real(8),intent(in), dimension(1:3,1:2):: Dlim

    real(8),intent(out), dimension(1:rnum,Dim):: np
    integer,intent(out):: sumiden
    real(8), dimension(Dim)::rij,ranp
    !defined interior variables
    real(8), dimension(:,:), allocatable :: Posa
    real(8), dimension(:,:), allocatable :: Tara
    real(8), dimension(:,:), allocatable :: TemS
    real(8), dimension(:,:), allocatable :: TemA
    real(8) :: rc2,d2,radius,angle1,angle2,u,r1,r2,r3
    real(8), parameter :: Pi = 3.1415927
    integer, dimension(1:rnum):: Identify
    integer :: j, ri

    rc2=rc*rc
    ! set up the size of array for the Samples and Active Points
    allocate(Posa(lbound(Pos,dim=1):ubound(Pos,dim=1),lbound(Pos,dim=2):ubound(Pos,dim=2)))
    allocate(Tara(lbound(Pos,dim=1):ubound(Pos,dim=1),lbound(Pos,dim=2):ubound(Pos,dim=2)))
    Posa = Pos
    Tara = Tar
    ! iterative arrays
    ! randomly choose point from active list
    !call random_number(u)
    !chotar = floor(NAcore*u)
    !Tari(1) = Tar(chotar,1)
    !Tari(2) = Tar(chotar,2)

    ! store Pos(i,:) in a temporary array for faster access in j loop
    ! initilize the random samples around the active point
    ! initilize the center for the chosen point
    ! initialize the array
    do ri = 1,rnum
        ! random_number function generating the uniform random number in (0,1)

        call random_number(r1)
        call random_number(r2)
	call random_number(r3)
        radius = rc*(r1+1)

        angle1 = 2*Pi*r2
	angle2 = 2*Pi*r3
        ! x coordinate and y coordinate
        ! old terms
        ranp(1) = Tar(1,1) +  rc*cos(angle1)*sin(angle2)
        ranp(2) = Tar(1,2) +  rc*sin(angle1)*sin(angle2)
	ranp(3) = Tar(1,3) +  rc*cos(angle2)

	! maybe the fixed terms(using radius instead of rc to get more tighten pack points)
	! ranp(1) = Tar(1,1) +  radius *cos(angle1)*sin(angle2)
        ! ranp(2) = Tar(1,2) +  radius *sin(angle1)*sin(angle2)
	! ranp(3) = Tar(1,3) +  radius *cos(angle2)

	! setup the simulation boundaries
	if (ranp(1) < Dlim(1,1)) then
            ranp(1) = Dlim(1,1)
        end if
	if (ranp(1) > Dlim(1,2)) then
            ranp(1) = Dlim(1,2)
        end if
	if (ranp(2) < Dlim(2,1)) then
            ranp(2) = Dlim(2,1)
        end if
	if (ranp(2) > Dlim(2,2)) then
            ranp(2) = Dlim(2,2)
        end if
	if (ranp(3) < Dlim(3,1)) then
            ranp(3) = Dlim(3,1)
        end if
	if (ranp(3) > Dlim(3,2)) then
            ranp(3) = Dlim(3,2)
        end if

        ! try to catch if any random point from existing sample points:
        ! fast starts from the newer sample point
        ! NAtom = size(Posa,1)
        do j = ubound(Posa,dim=1),lbound(Posa,dim=1),-1
            rij = Posa(j,:) - ranp
            !compute only the squared distance and compare to squared cut
            d2=sum(rij * rij)
            if (d2 < rc2) then
                identify(ri) = 1
                exit
            end if
            identify(ri) = 0
        enddo
        if (identify(ri) == 0) then
            ! adding to sample list
            allocate(TemS(lbound(Posa,dim=1):ubound(Posa,dim=1),lbound(Posa,dim=2):ubound(Posa,dim=2)))
            allocate(TemA(lbound(Tara,dim=1):ubound(Tara,dim=1),lbound(Tara,dim=2):ubound(Tara,dim=2)))
            TemS = Posa
            TemA = Tara
            Deallocate(Posa)
            Deallocate(Tara)
            Allocate(Posa(lbound(TemS,dim=1):(ubound(TemS,dim=1)+1),lbound(TemS,dim=2):ubound(TemS,dim=2)))
            Allocate(Tara(lbound(TemA,dim=1):(ubound(TemA,dim=1)+1),lbound(TemA,dim=2):ubound(TemA,dim=2)))
            Posa(lbound(TemS,dim=1):ubound(TemS,dim=1),lbound(TemS,dim=2):ubound(TemS,dim=2)) = TemS
            Tara(lbound(TemA,dim=1):ubound(TemA,dim=1),lbound(TemA,dim=2):ubound(TemA,dim=2)) = TemA
            ! adding the new point into the allocatable array
            Posa((ubound(TemS,dim=1)+1),lbound(TemS,dim=2))=ranp(1)
            Posa((ubound(TemS,dim=1)+1),lbound(TemS,dim=2)+1)=ranp(2)
			Posa((ubound(TemS,dim=1)+1),ubound(TemS,dim=2))=ranp(3)

            Tara((ubound(TemA,dim=1)+1),lbound(TemA,dim=2))=ranp(1)
            Tara((ubound(TemA,dim=1)+1),lbound(TemA,dim=2)+1)=ranp(2)
			Tara((ubound(TemA,dim=1)+1),ubound(TemA,dim=2))=ranp(3)

            Deallocate(TemS)
            Deallocate(TemA)
            ! update the sample array and activate array
        endif
    enddo
	! calculate the summation over the identify vector
	sumiden = rnum - sum(identify)
    !allocate(np(lbound(Posa,dim=1):ubound(Posa,dim=1),lbound(Posa,dim=2):ubound(Posa,dim=2)))
    np(lbound(Tara,dim=1):ubound(Tara,dim=1),lbound(Tara,dim=2):ubound(Tara,dim=2)) = Tara
    end subroutine


      SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
      DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0,
     +     0.95105651629515357212D0,
     1     -0.8090169943749474241D0, 0.58778525229247312917D0/
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
      END