!! hello_stdcl_fortran.f90
!!
!! This is a simple OpenCL example for Parallella that performs a
!! matrix-vector multiplication on the Epiphany processor.
!!
!! THIS FILE ONLY is placed in the public domain by Brown Deer Technology, LLC.
!! in January 2013. No copyright is claimed, and you may use it for any purpose
!! you like. There is ABSOLUTELY NO WARRANTY for any purpose, expressed or
!! implied, and any warranty of any kind is explicitly disclaimed.  This
!! statement applies ONLY TO THE COMPUTER SOURCE CODE IN THIS FILE and does
!! not extend to any other software, source code, documentation, or any other
!! materials in which it may be included, or with which it is co-distributed.
!!

!! DAR !!

	program main

	use iso_c_binding
	use stdcl

	implicit none

	integer(C_INT) :: n = 64
	type(C_PTR) :: cp
	integer(C_INT) :: devnum = 0
	type(C_PTR) :: clh
	type(C_PTR) :: krn
	type(C_PTR) :: p_aa, p_b, p_c
	real(C_FLOAT), pointer :: aa(:,:), b(:), c(:)
	integer :: i,j
	type(clndrange_struct), target :: ndr
	integer(C_INT) :: rc
	type(C_PTR) :: ev

	!!!! use default contexts, if no GPU use CPU
	if (C_ASSOCIATED(stdacc)) then
		cp = stdacc
	else
		cp = stdcpu
	endif

	!!!! build CL program, get kernel
   krn = clsym(cp,C_NULL_PTR,"matvecmult_kern"//C_NULL_CHAR,0);

   !!!! allocate OpenCL device-sharable memory, associate with fortran pointers
   p_aa = clmalloc(cp,int8(n*n*4),0);
	call C_F_POINTER(p_aa,aa,[n,n])

   p_b = clmalloc(cp,int8(n*4),0);
	call C_F_POINTER(p_b,b,[n])

   p_c = clmalloc(cp,int8(n*4),0);
	call C_F_POINTER(p_c,c,[n])

   !!!! initialize vectors a[] and b[], zero c[]
	do i = 1,n
		do j = 1,n
			aa(i,j) = 1.1 * (i-1) * (j-1)
		end do
	end do

	do i = 1,n
		b(i) = 2.2 * (i-1)
	end do

	do i = 1,n
		c(i) = 0.0
	end do

   !!!! define the computational domain and workgroup size
   ndr = clndrange_init1d( 0, n, 16)

   !!!! non-blocking sync vectors a and b to device memory (copy to GPU)
   ev = clmsync(cp,devnum,p_aa,CL_MEM_DEVICE+CL_EVENT_NOWAIT)
   ev = clmsync(cp,devnum,p_b,CL_MEM_DEVICE+CL_EVENT_NOWAIT)

   !!!! set the kernel arguments
   rc = clarg_set(cp,krn,0,n);
   rc = clarg_set_global(cp,krn,1,p_aa);
   rc = clarg_set_global(cp,krn,2,p_b);
   rc = clarg_set_global(cp,krn,3,p_c);

   !!!! non-blocking fork of the OpenCL kernel to execute on the GPU
	ev = clfork(cp,devnum,krn,C_LOC(ndr),CL_EVENT_NOWAIT)

   !!!! non-blocking sync vector c to host memory (copy back to host)
	ev = clmsync(cp,devnum,p_c,CL_MEM_HOST+CL_EVENT_NOWAIT)

   !!!! force execution of operations in command queue (non-blocking call)
	rc = clflush(cp,devnum,0)

   !!!! block on completion of operations in command queue
	ev = clwait(cp,devnum,CL_ALL_EVENT)

	do i = 1,n
		write(*,*) i,b(i),c(i)
	end do

   rc = clfree(p_aa)
   rc = clfree(p_b)
   rc = clfree(p_c)

	end


!     Convert between lat/long and cartesian coordinates for mixed tri/quads
!     Input: <fname> (grid format);lat/long must be in degrees
!     Depths are not changed.
!     pgf90 -O2 -mcmodel=medium -Mbounds -Bstatic -o cpp cpp.f90
      implicit real*8(a-h,o-z)
      character*70 fname
      dimension nm(4)

      pi=3.1415926
      print*, "Input file name:"
      read(*,'(a70)') fname
      print*, "1: from lat/long to cartesian; -1: from cartesian to lat/long:"
      read*, ifl
      if(iabs(ifl).ne.1) then
	print*, "Incorrect input of ifl",ifl
	stop
      endif
      print*, "Input center of projection (in degrees):"
      read*, rlambda0,phi0
!      rlambda0=rlambda0*pi/180
!      phi0=phi0*pi/180

      open(12,file=fname,status='old')
      open(13,file="out_"//fname)
      read(12,*)
      read(12,*)ne,np
      write(13,*)real(rlambda0),real(phi0)
      write(13,*)ne,np
      do i=1,np
	read(12,*)j,xtmp,ytmp,dp
 	call cpp(ifl,xtmp,ytmp,xout,yout,rlambda0,phi0)
	write(13,'(i10,2(1x,f24.11),1x,e24.11)')j,xout,yout,dp
      enddo !i
      do i=1,ne
	read(12,*)j,k,nm(1:k)
	write(13,*)j,k,nm(1:k)
      enddo !i
      close(12)
      close(13)

      stop
      end

!     rlambda0,phi0: in degrees
      subroutine cpp(ifl,xin,yin,xout,yout,rlambda0,phi0)
      implicit real*8(a-h,o-z)
      parameter(r=6378206.4)
      parameter(pi=3.1415926)
      integer, intent(in) :: ifl
      real*8, intent(in) :: xin,yin,rlambda0,phi0
      real*8, intent(out) :: xout,yout

      rlambda=rlambda0*pi/180
      phi=phi0*pi/180
      if(ifl.eq.1) then !lat/lon to CPP
        xin1=xin*pi/180
        yin1=yin*pi/180
        xout=r*(xin1-rlambda)*cos(phi)
        yout=yin1*r
      else !ifl=-1
        xout=rlambda+xin/r/cos(phi)
        yout=yin/r
        xout=xout/pi*180
        yout=yout/pi*180
      endif

      return
      end


function termgy(n         ,y         ,z         )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: termgy.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_gpl/morphology/packages/morphology_kernel/src/termgy.f90 $
!!--description-----------------------------------------------------------------
! determines termgy
! a contribution to the bijker transport
! relation
! -
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    !
    implicit none
!
! Call variables
!
    integer, intent(in)   :: n
    real(hp)              :: termgy
    real(hp), intent(in)  :: y
    real(hp), intent(in)  :: z
!
! Local variables
!
    integer  :: i      ! running index
    real(fp) :: noemer
    real(hp) :: teller
!
!! executable statements -------------------------------------------------------
!
    if (abs(real(n, hp) - z)<=1.d-10) then
       termgy = ( - 1.d0)**(n + 1)*z*log(y)*log(y)*.5D0
    elseif (n==1) then
       termgy = y**(1.d0 - z)                                                   &
              & *(((1.d0 - z)*log(y) - 1.d0)/((1.d0 - z)*(1.d0 - z)))
    else
       teller = 1.d0
       noemer = 1.
       do i = 2, n
          teller = teller*(z - real(i, hp) + 2.d0)
          noemer = noemer*real(i, fp)
       enddo
       noemer = noemer/real(n, fp)
       termgy = ( - 1.d0)**(n + 1)*((teller*y**(real(n, hp) - z))/real(noemer, hp))     &
              & *(((real(n, hp) - z)*log(y) - 1.d0)/((real(n, hp) - z)*(real(n, hp) - z)))
    endif
end function termgy


	PROGRAM PI
	REAL A,B,S,P
	INTEGER K,US
	US = 6
	S = 0.0
	DO 1 K = 0 , 11
1	S = S + ((-1.0)**K)/(((2.0*K)+1.0)**3)
	P = (S*32.0)**(1.0/3.0)
	WRITE(US,"(F24.22)")P
	STOP
	END


!##############################################################################
!# ****************************************************************************
!# <name> scalarpde </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains the definition of scalar continuous bilinear forms.
!# Remark that only the shape of the continuous formulation is defined
!# here. The discretisation of bilinear forms is realised in higher
!# level modules.
!# </purpose>
!##############################################################################

module scalarpde

!$ use omp_lib
  use fsystem
  use derivatives

  implicit none

  private

!<constants>

!<constantblock>

  ! Maximum number of additive terms in the integral
  integer, parameter, public :: SCPDE_NNAB = 21

!</constantblock>

!</constants>

!<types>

  !<typeblock>

  ! A structure for a scalar bilinear form.
  !
  ! Example: Let us take a look at the 2D equation
  !
  !    <tex>$   \int_{\Omega}  ( \nabla u , \nabla v )  dx $</tex>
  !    <tex>$ = \int_{\Omega}  1*u_x*v_x  +  1*u_y*v_y  dx $</tex>
  !
  ! This bilinear form consists of two additive terms. Both terms have
  ! a constant coefficient '1' in front of them and consist of a combination
  ! of derivatives in different directions. The form itself is encoded
  ! with the structure t_bilinearForm as follows:
  !
  ! 1.) itermCount = 2                     -> 2 additive terms
  ! 2.) ballCoeffConstant = true           -> all coefficients constant
  ! 3.) Dcoefficients(1)  = 1.0            -> 1st coefficient
  ! 4.) Idescriptors(1,1) = DER_DERIV_X    -> u_x in the 1st term
  ! 5.) Idescriptors(2,1) = DER_DERIV_X    -> v_x in the 1st term
  ! 6.) Dcoefficients(2)  = 1.0            -> 2nd coefficient
  ! 7.) Idescriptors(1,2) = DER_DERIV_Y    -> u_y in the 2nd term
  ! 8.) Idescriptors(2,2) = DER_DERIV_Y    -> v_y in the 2nd term

  type t_bilinearForm

    ! Number of additive terms in the bilinear form
    integer :: itermCount = 0

    ! Descriptors of additive terms.
    ! Idescriptors(1,.) = trial function descriptor,
    ! Idescriptors(2,.) = test function descriptor.
    ! The descriptor itself is a DER_xxxx derivatrive
    ! identifier (c.f. module 'derivatives').
    integer, dimension(2,SCPDE_NNAB) :: Idescriptors = DER_FUNC

    ! TRUE if all coefficients in the biliear form are constant,
    ! FALSE if there is at least one nonconstant coefficient.
    logical                          :: ballCoeffConstant = .true.

    ! DEPRECATED: NOT USED ANYMORE.
    ! For every additive term in the integral:
    ! = true, if the coefficient in front of the term is constant,
    ! = false, if the coefficient is nonconstant.
    logical, dimension(SCPDE_NNAB)   :: BconstantCoeff = .true.

    ! If ballCoeffConstant=TRUE: the constant coefficients in front of
    ! each additive terms in the bilinear form.
    ! Otherwise: Not used.
    real(DP), dimension(SCPDE_NNAB)  :: Dcoefficients = 0.0_DP

    ! Only for use with UFCI: Function IDs for non-constant coefficients.
    integer, dimension(SCPDE_NNAB)   :: IfunctionIDs = 0

  end type

  public :: t_bilinearForm

  !</typeblock>

  !<typeblock>

  ! A structure for a scalar trilinear form.
  !
  ! Example: For w:R2->R let us take a look at the 2D equation
  !
  !    <tex>$   \int_{\Omega}  w ( \nabla u , \nabla v )  dx $</tex>
  !    <tex>$ = \int_{\Omega}  ( F(w) \nabla u , \nabla v )  dx $</tex>
  !    <tex>$ = \int_{\Omega}  f_1(w)*1*u_x*v_x  +  f_2(w)*1*u_y*v_y  dx $</tex>
  !    <tex>$ = \int_{\Omega}  w*1*u_x*v_x  +  w*1*u_y*v_y  dx $</tex>
  !
  ! with <tex>$F=matrix([f_1,0],[0,f_2])$</tex> specifying derivative quantifiers
  ! to be applied to w, here e.g. <tex>$f_1(w) = f_2(w) = w$</tex>.
  !
  ! This trilinear form consists of two additive terms. Both terms have
  ! a constant coefficient '1' in front of them and consist of a combination
  ! of derivatives in different directions. Additionally to that, there is
  ! a finite element function f(.) given that specifies variable coefficients.
  ! The form itself is encoded with the structure t_trilinearForm as follows:
  !
  !  1.) itermCount = 2                     -> 2 additive terms
  !  2.) ballCoeffConstant = true           -> all coefficients constant
  !  3.) Dcoefficients(1)  = 1.0            -> 1st coefficient
  !  5.) Idescriptors(1,1) = DER_FUNC       -> w(x,y) in the 1st term
  !  6.) Idescriptors(2,1) = DER_DERIV_X    -> u_x in the 1st term
  !  7.) Idescriptors(3,1) = DER_DERIV_X    -> v_x in the 1st term
  !  8.) Dcoefficients(2)  = 1.0            -> 2nd coefficient
  !  9.) Idescriptors(1,2) = DER_FUNC       -> w(x,y) in the 2nd term
  ! 10.) Idescriptors(2,2) = DER_DERIV_Y    -> u_y in the 2nd term
  ! 11.) Idescriptors(3,2) = DER_DERIV_Y    -> v_y in the 2nd term
  !
  ! One diffence to the usual meaning of the descriptors: A value of
  !   Idescriptors(1,i) = 0
  ! instead of DER_xxxx means that the function f is the constant
  ! mapping f_i(u):=1. So this disables the contribution of u for that term.

  type t_trilinearForm

    ! Number of additive terms in the bilinear form
    integer :: itermCount = 0

    ! Descriptors of additive terms.
    ! Idescriptors(1,.) = coefficient function descriptor,
    ! Idescriptors(2,.) = trial function descriptor,
    ! Idescriptors(3,.) = test function descriptor.
    ! The descriptor itself is a DER_xxxx derivatrive
    ! identifier (c.f. module 'derivatives').
    integer, dimension(3,SCPDE_NNAB) :: Idescriptors = DER_FUNC

    ! TRUE if all coefficients in the biliear form are constant,
    ! FALSE if there is at least one nonconstant coefficient.
    logical                          :: ballCoeffConstant = .true.

    ! DEPRECATED: NOT USED ANYMORE.
    ! For every additive term in the integral:
    ! = true, if the coefficient in front of the term is constant,
    ! = false, if the coefficient is nonconstant.
    logical, dimension(SCPDE_NNAB)   :: BconstantCoeff = .true.

    ! If ballCoeffConstant=TRUE: the constant coefficients in front of
    ! each additive terms in the bilinear form.
    ! Otherwise: Not used.
    real(DP), dimension(SCPDE_NNAB)  :: Dcoefficients = 0.0_DP

    ! Only for use with UFCI: Function IDs for non-constant coefficients.
    integer, dimension(SCPDE_NNAB)   :: IfunctionIDs = 0

  end type

  public :: t_trilinearForm

  !</typeblock>

  !<typeblock>

  ! A structure for a scalar linear form.
  !
  ! Example: Let us take a look at the 2D equation
  !
  !    <tex>$   \int_{\Omega}  ( f, v )   dx $</tex>
  !    <tex>$ = \int_{\Omega}  1*f*v      dx $</tex>
  !
  ! This bilinear form consists of one additive term. The term has
  ! a constant coefficient '1' in front and consist of a combination
  ! of derivatives. The form itself is encoded with the structure
  ! t_linearForm as follows:
  !
  ! 1.) itermCount = 1                     -> 1 additive term
  ! 2.) Dcoefficients(1)  = 1.0            -> 1st coefficient (actually not used)
  ! 3.) Idescriptors(1,1) = DER_FUNC       -> f in the 1st term
  ! 4.) Idescriptors(2,1) = DER_FUNC       -> v in the 1st term

  type t_linearForm

    ! Number of additive terms in the linear form
    integer :: itermCount = 0

    ! Descriptors of additive terms, i.e. test function descriptors.
    ! The descriptor itself is a DER_xxxx derivative
    ! identifier (c.f. module 'derivatives').
    integer, dimension(SCPDE_NNAB) :: Idescriptors = DER_FUNC

    ! Constant coefficients in front of each additive terms in the linear form.
    ! Note: This array is not used by the framework! Nevertheless, it can be
    ! used by the main program to pass parameters from the main program to
    ! callback routines.
    real(DP), dimension(SCPDE_NNAB)  :: Dcoefficients = 0.0_DP

    ! Only for use with UFCI: Function IDs for non-constant coefficients.
    integer, dimension(SCPDE_NNAB)   :: IfunctionIDs = 0

  end type

  public :: t_linearForm

  !</typeblock>

!</types>

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

end module


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes the stress tensor.
!! @author Ilario Mazzieri
!> @date November, 2014
!> @version 1.0
!> @param[in] nn number of 1-D Legendre nodes
!> @param[in] lambda nodal values of Lame coefficient lambda
!> @param[in] mu nodal values of Lame coefficient mu
!> @param[in] duxdx nodal values for spatial derivatives of the displacement
!> @param[in] duydx nodal values for spatial derivatives of the displacement
!> @param[in] duzdx nodal values for spatial derivatives of the displacement
!> @param[in] duxdy nodal values for spatial derivatives of the displacement
!> @param[in] duydy nodal values for spatial derivatives of the displacement
!> @param[in] duzdy nodal values for spatial derivatives of the displacement
!> @param[in] duxdz nodal values for spatial derivatives of the displacement
!> @param[in] duydz nodal values for spatial derivatives of the displacement
!> @param[in] duzdz nodal values for spatial derivatives of the displacement
!> @param[in] strain_visc_xx nodal values for viscoelastic stress tensor
!> @param[in] strain_visc_xy nodal values for viscoelastic stress tensor
!> @param[in] strain_visc_xz nodal values for viscoelastic stress tensor
!> @param[in] strain_visc_yy nodal values for viscoelastic stress tensor
!> @param[in] strain_visc_yz nodal values for viscoelastic stress tensor
!> @param[in] strain_visc_zz nodal values for viscoelastic stress tensor
!> @param[in] Ylambda anelastic coefficients (1st Lame modulus)
!> @param[in] Ymu anelastic coefficients  (2nd Lame modulus)
!> @param[in] ie  local element id
!> @param[out] sxx nodal values for the stress tensor
!> @param[out] syy nodal values for the stress tensor
!> @param[out] szz nodal values for the stress tensor
!> @param[out] syz nodal values for the stress tensor
!> @param[out] szx nodal values for the stress tensor
!> @param[out] sxy nodal values for the stress tensor

      subroutine MAKE_STRESS_TENSOR_DAMPED(nn,lambda,mu,&
                               duxdx,duydx,duzdx,&
                               duxdy,duydy,duzdy,&
                               duxdz,duydz,duzdz,&
                               strain_visc_xx, strain_visc_xy, strain_visc_xz, &
                               strain_visc_yy, strain_visc_yz, strain_visc_zz, &
                               Ylambda,Ymu, N_SLS, &
                               sxx,syy,szz,&
                               syz,szx,sxy,ie)

      implicit none

      integer*4 :: nn,N_SLS
      integer*4 :: p,q,r,ie

      real*8, dimension(N_SLS) :: Ylambda, Ymu, temp
      real*8, dimension(nn,nn,nn) :: lambda,mu
      real*8, dimension(nn,nn,nn) :: sxx,syy,szz,syz,szx,sxy
      real*8, dimension(nn,nn,nn) :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz
      real*8, dimension(nn,nn,nn,N_SLS) :: strain_visc_xx, strain_visc_xy, strain_visc_xz, &
                                           strain_visc_yy, strain_visc_yz, strain_visc_zz

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn

               temp = strain_visc_xx(p,q,r,:) + strain_visc_yy(p,q,r,:) + strain_visc_zz(p,q,r,:)

               sxx(p,q,r) = lambda(p,q,r) * (duxdx(p,q,r) +duydy(p,q,r) +duzdz(p,q,r) &
                                        - DOT_PRODUCT(Ylambda,temp)) &
                                        +2.0d0*mu(p,q,r) * (duxdx(p,q,r) - DOT_PRODUCT(Ymu,strain_visc_xx(p,q,r,:)))

               syy(p,q,r) = lambda(p,q,r) * (duxdx(p,q,r) +duydy(p,q,r) +duzdz(p,q,r) &
                                        - DOT_PRODUCT(Ylambda,temp)) &
                                        +2.0d0*mu(p,q,r) * (duydy(p,q,r) - DOT_PRODUCT(Ymu,strain_visc_yy(p,q,r,:)))

               szz(p,q,r) = lambda(p,q,r) * (duxdx(p,q,r) +duydy(p,q,r) +duzdz(p,q,r) &
                                        - DOT_PRODUCT(Ylambda,temp)) &
                                        +2.0d0*mu(p,q,r) * (duzdz(p,q,r) - DOT_PRODUCT(Ymu,strain_visc_zz(p,q,r,:)))

               syz(p,q,r) = mu(p,q,r) * (duydz(p,q,r) + duzdy(p,q,r) -  DOT_PRODUCT(Ymu,strain_visc_yz(p,q,r,:)))
               szx(p,q,r) = mu(p,q,r) * (duzdx(p,q,r) + duxdz(p,q,r) -  DOT_PRODUCT(Ymu,strain_visc_xz(p,q,r,:)))
               sxy(p,q,r) = mu(p,q,r) * (duxdy(p,q,r) + duydx(p,q,r) -  DOT_PRODUCT(Ymu,strain_visc_xy(p,q,r,:)))

              ! write(*,*) p,q,r
              ! write(*,*) temp
              ! write(*,*) DOT_PRODUCT(Ylambda,temp)
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_xx(p,q,r,:))
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_yy(p,q,r,:))
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_zz(p,q,r,:))
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_yz(p,q,r,:))
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_xz(p,q,r,:))
              ! write(*,*) DOT_PRODUCT(Ymu,strain_visc_xy(p,q,r,:))
              ! write(*,*) '--------------------------------------'
            enddo
         enddo
      enddo

      return

      end subroutine MAKE_STRESS_TENSOR_DAMPED


*     SB06ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDU, LDV, LDF
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDU = NMAX,
     $                   LDV = MMAX, LDF = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX + MAX(NMAX,3*MMAX) )
*     PARAMETER        ( LDWORK = 4*NMAX)
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, KMAX, M, N, NCONT
      CHARACTER*1      JOBU, JOBV
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), DWORK(LDWORK),
     $                 F(LDF,NMAX), U(LDU,NMAX), V(LDV,MMAX)
      INTEGER          IWORK(LIWORK), KSTAIR(NMAX)
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB01OD, DLASET, SB06ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, TOL, JOBU, JOBV
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
*           First put (A,B) into staircase form with triangular pivots
*           and determine the stairsizes.
            CALL AB01OD( 'A', JOBU, JOBV, N, M, A, LDA, B, LDB, U,
     $                   LDU, V, LDV, NCONT, KMAX, KSTAIR, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.EQ.0 ) THEN
               IF( LSAME( JOBU, 'N' ) ) THEN
*                 Initialize U as the identity matrix.
                  CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
               END IF
*              Perform "deadbeat control" to give F.
               CALL SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU,
     $                      F, LDF, DWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,N )
   60             CONTINUE
               END IF
            ELSE
               WRITE ( NOUT, FMT = 99998 ) INFO
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB06ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01OD = ',I2)
99997 FORMAT (' INFO on exit from SB06ND = ',I2)
99996 FORMAT (' The deadbeat feedback matrix F is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
      END


C     LAST UPDATE 20/06/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SYMINV(A,W,V,N,NP)
      IMPLICIT NONE
C
C Purpose: Inverts a symmetric matrix specified by the
C          arrays W,V as returned by TRED2,TQLI. N is the logical
C          dimension of A, the output matrix (square and symmetric).
C          NP are the physical dimensions of A.
C
      INTEGER N,NP
      DOUBLE PRECISION A(NP,NP),V(NP,NP),W(NP)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      DOUBLE PRECISION S,WTMP,VTMP
      INTEGER I,J,K
C
C---------------------------------------------------------------------
C
C========Loop over eigenvalues
C
      DO 50 K=1,N
         IF(W(K).NE.0.0D0)THEN
            WTMP = 1.0D0/W(K)
C
C========Accumulate diagonal elements
C
            DO 20 I=1,N
               A(I,I) = V(I,K)*WTMP*V(I,K)
 20         CONTINUE
C
C========Accumulate off-diagonal elements using symmetry
C
            DO 40 I=1,N-1
               VTMP = V(I,K)
               DO 30 J=I+1,N
                  S = VTMP*WTMP*V(J,K)
                  A(I,J) = S
                  A(J,I) = S
 30            CONTINUE
 40         CONTINUE
         ENDIF
 50   CONTINUE
      RETURN
      END


#include "error.inc"

module steinhardt_nelson_qw_module

use error_module
use system_module
use units_module
use dictionary_module
use atoms_types_module
use atoms_module
use linearalgebra_module
use angular_functions_module

implicit none
private

public :: calc_qw, calc_qw_grad

contains

subroutine calc_qw(this,l,do_q,do_w,cutoff,min_cutoff,cutoff_transition_width,mask,mask_neighbour,error)
   type(atoms), intent(inout) :: this
   integer, intent(in) :: l
   logical, intent(in), optional :: do_q, do_w
   real(dp), intent(in), optional :: cutoff, cutoff_transition_width, min_cutoff
   logical, dimension(:), intent(in), optional :: mask, mask_neighbour
   integer, intent(out), optional :: error

   real(dp), dimension(:), pointer :: ql, wl
   real(dp), dimension(3) :: diff_ij
   real(dp) :: ql_crystal, wl_crystal, my_cutoff, my_min_cutoff, my_cutoff_transition_width, r_ij, f_cut
   logical :: my_do_q, my_do_w, do_smooth_cutoff

   complex(dp), dimension(:), allocatable :: spherical_c
   complex(dp), dimension(:), allocatable :: spherical_c_crystal
   integer :: i, j, m, n, m1, m2, m3
   real(dp) :: n_bonds, n_bonds_crystal

   INIT_ERROR(error)

   my_do_q = optional_default(.false.,do_q)
   my_do_w = optional_default(.false.,do_w)
   my_cutoff = optional_default(this%cutoff,cutoff)
   my_min_cutoff = optional_default(0.0_dp,min_cutoff)
   my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width)

   do_smooth_cutoff = present(cutoff_transition_width)

   if(my_cutoff > this%cutoff) then
      call set_cutoff(this,my_cutoff)
      call calc_connect(this)
   endif

   if(my_do_q) call add_property(this, 'q'//l, 0.0_dp, ptr=ql)
   if(my_do_w) call add_property(this, 'w'//l, 0.0_dp, ptr=wl)

   if(present(mask)) then
      call check_size("mask",mask,this%N,"calc_qw",error)
   endif
   if(present(mask_neighbour)) then
      call check_size("mask_neighbour",mask_neighbour,this%N,"calc_qw",error)
   endif

   allocate(spherical_c(-l:l), spherical_c_crystal(-l:l))
   spherical_c_crystal = CPLX_ZERO

   f_cut = 1.0_dp
   n_bonds_crystal = 0.0_dp

   do i = 1, this%N

      if(present(mask)) then
         if( .not. mask(i) ) cycle
      endif

      n_bonds = 0.0_dp
      spherical_c = CPLX_ZERO

      do n = 1, n_neighbours(this,i)
         j = neighbour(this,i,n,diff=diff_ij,distance=r_ij)

         if(r_ij > my_cutoff) cycle
         if(r_ij < my_min_cutoff) cycle

         if(present(mask_neighbour)) then
            if( .not. mask_neighbour(j) ) cycle
         endif

         if(do_smooth_cutoff) then
            f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width)
         endif
         n_bonds = n_bonds + f_cut

         do m = -l, l
            spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut
         enddo

      enddo

      ! spherical_c_crystal is defined as in Steinhardt and Nelson, from ( \sum_i spherical_c(i) ) / ( \sum_i n_bonds(i))
      ! An altenative would be \sum_i ( spherical_c(i) / n_bonds(i) )
      spherical_c_crystal = spherical_c_crystal + spherical_c
      n_bonds_crystal = n_bonds_crystal + n_bonds

      if(n_bonds > 0.0_dp) spherical_c = spherical_c / n_bonds

      if(my_do_q) ql(i) = sqrt( dot_product(spherical_c,spherical_c) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) )

      if(my_do_w) then
         wl(i) = 0.0_dp
         do m1 = -l, l
            do m2 = -l, l
               m3 = -m1-m2
               if( m3 >= -l .and. m3 <= l ) wl(i) = wl(i) + spherical_c(m1) * spherical_c(m2) * spherical_c(m3) * wigner3j(l,m1,l,m2,l,m3)
            enddo
         enddo

         wl(i) = wl(i) / sqrt( dot_product(spherical_c,spherical_c)**3 )
      endif

   enddo

   if (n_bonds_crystal > 0.0_dp ) spherical_c_crystal = spherical_c_crystal / n_bonds_crystal
   if (my_do_q) then
      ql_crystal = sqrt( dot_product(spherical_c_crystal,spherical_c_crystal) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) )
      call set_value(this%params, "q"//l//"_global",ql_crystal)
   endif

   if(my_do_w) then
      wl_crystal = 0.0_dp
      do m1 = -l, l
         do m2 = -l, l
            m3 = -m1-m2
            if( m3 >= -l .and. m3 <= l ) wl_crystal = wl_crystal + spherical_c_crystal(m1) * spherical_c_crystal(m2) * spherical_c_crystal(m3) * wigner3j(l,m1,l,m2,l,m3)
         enddo
      enddo

      wl_crystal = wl_crystal / sqrt( dot_product(spherical_c_crystal(:),spherical_c_crystal(:))**3 )
      call set_value(this%params, "w"//l//"_global",wl_crystal)
   endif

   if(allocated(spherical_c)) deallocate(spherical_c)
   if(allocated(spherical_c_crystal)) deallocate(spherical_c_crystal)

endsubroutine calc_qw

subroutine calc_qw_grad(this,grad_ind,l,do_q,do_w,cutoff,cutoff_transition_width)
   type(atoms), intent(inout) :: this
   integer, intent(in) :: grad_ind
   integer, intent(in) :: l
   logical, intent(in), optional :: do_q, do_w
   real(dp), optional :: cutoff, cutoff_transition_width

   integer :: i, j, n, m
   logical :: my_do_q, my_do_w, do_smooth_cutoff
   real(dp) :: my_cutoff, my_cutoff_transition_width, ql
   real(dp) :: f_cut, df_cut(3), r_ij, diff_ij(3), n_bonds
   complex(dp), allocatable :: spherical_c(:), dspherical_c(:,:,:)
   real(dp), allocatable :: dn_bonds(:,:)
   real(dp), pointer :: ql_grad(:,:), wl_grad(:,:)

   my_do_q = optional_default(.false.,do_q)
   my_do_w = optional_default(.false.,do_w)
   my_cutoff = optional_default(this%cutoff,cutoff)
   my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width)

   do_smooth_cutoff = present(cutoff_transition_width)

   if(my_cutoff > this%cutoff) then
      call set_cutoff(this,my_cutoff)
      call calc_connect(this)
   endif

   if(my_do_q) call add_property(this, 'q'//l//'_grad', 0.0_dp, n_cols=3, ptr2=ql_grad)
   if(my_do_w) call add_property(this, 'w'//l//'_grad', 0.0_dp, n_cols=3, ptr2=wl_grad)

   if (my_do_q) ql_grad = 0.0_dp
   if (my_do_w) wl_grad = 0.0_dp

   allocate(spherical_c(-l:l), dspherical_c(3,-l:l,this%N), dn_bonds(3,this%N))
   spherical_c = CPLX_ZERO
   dspherical_c = CPLX_ZERO

   f_cut = 1.0_dp
   df_cut = 0.0_dp

   n_bonds = 0.0_dp
   dn_bonds = 0.0_dp

   i = grad_ind
   do n = 1, n_neighbours(this,i)
      j = neighbour(this,i,n,diff=diff_ij,distance=r_ij)

      if(r_ij > my_cutoff) cycle

      if(do_smooth_cutoff) then
         f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width)
         df_cut(:) = -dcoordination_function(r_ij,my_cutoff,my_cutoff_transition_width)*diff_ij/r_ij
      endif
      n_bonds = n_bonds + f_cut
      dn_bonds(:,i) = dn_bonds(:,i) + df_cut(:)
      dn_bonds(:,j) = dn_bonds(:,j) - df_cut(:)

      do m = -l, l
         spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut
         dspherical_c(:,m,i) = dspherical_c(:,m,i) - GradSphericalYCartesian(l,m,diff_ij) * f_cut + &
                                                     SphericalYCartesian(l,m,diff_ij)*df_cut
         dspherical_c(:,m,j) = dspherical_c(:,m,j) + GradSphericalYCartesian(l,m,diff_ij) * f_cut - &
                                                     SphericalYCartesian(l,m,diff_ij)*df_cut
      enddo
   enddo

   if(n_bonds > 0.0_dp) then
      do m=-l,l
         dspherical_c(:,m,i) = ((n_bonds*dspherical_c(:,m,i))-(spherical_c(m)*dn_bonds(:,i))) / (n_bonds**2)
         do n = 1, n_neighbours(this,i)
            j = neighbour(this,i,n)
            dspherical_c(:,m,j) = ((n_bonds*dspherical_c(:,m,j))-(spherical_c(m)*dn_bonds(:,j))) / (n_bonds**2)
         end do
      end do
      spherical_c(:) = spherical_c(:) / n_bonds
   end if

   if(my_do_q) then
      ql = sqrt( dot_product(spherical_c(:),spherical_c(:)) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) )
      do m=-l,l
         ql_grad(:,i) = ql_grad(:,i) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,i)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) )
         do n = 1, n_neighbours(this,i)
            j = neighbour(this,i,n)
            ql_grad(:,j) = ql_grad(:,j) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,j)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) )
         end do
      end do
   endif

   if(my_do_w) then
      call system_abort("calc_qw_grad does not support grad of w yet")
   endif

end subroutine calc_qw_grad

end module steinhardt_nelson_qw_module


      PROGRAM mperdeg
!    Given a latitude, print the meters per deg of
!  latitude and longitue.
!
      REAL alat, amlat, amlong

      PRINT *,' Enter a latitude:'
      READ *,alat
      CALL lendeg( alat, amlat, amlong)
      PRINT *,' There are ',amlat,' meters per degree latitude.'
      PRINT *,' There are ',amlong,' meters per degree longitude.'
      STOP
      END


!!<summary>Kind descriptors for the precision of integer and real values.</summary>
MODULE num_types
implicit none
private
public dp, sp, si, li
!!<member name="dp">Double precision kind for decimal precision of at least 15
!!digits, a decimal exponent range of at least 307.</member>
!!<member name="sp">Single precision kind for decimal precision of at least 6
!!digits, a decimal exponent range of at least 37.</member>
!!<member name="si">Short kind for integers that can represent all
!!values ranging from -10^1 (exclusive) to 10^1 (exclusive).</member>
!!<member name="li">Long kind for integers that can represent all
!!values ranging from -10^18 (exclusive) to 10^18 (exclusive).</member>
integer, parameter:: dp=selected_real_kind(15,307)
integer, parameter:: sp=selected_real_kind(6,37)
integer, parameter:: si=selected_int_kind(1)
integer, parameter:: li=selected_int_kind(18)
END MODULE


! Max Tegmark 171119, 190128-31, 190506, May 2020

	! Binary:
	! +: add
	! *: multiply
	! -: subtract
	! /: divide	(Put "D" instead of "/" in file, since f77 can't load backslash
	! Unary:
	!  >: increment (x -> x+1)
	!  <: decrement (x -> x-1)
	!  ~: negate  	(x-> -x)
	!  \: invert    (x->1/x) (Put "I" instead of "\" in file, since f77 can't load backslash
	!  L: logaritm  (x-> ln(x)
	!  E: exponentiate (x->exp(x))
	!  S: sin:      (x->sin(x))
	!  C: cos:      (x->cos(x))
	!  A: abs:      (x->abs(x))
	!  N: arcsin    (x->arcsin(x))
	!  T: arctan    (x->arctan(x))
	!  R: sqrt	(x->sqrt(x))
        !  O: double    (x->2*x); note that this is the letter "O", not zero
	!  J: double+1  (x->2*x+1)
	! nonary:
	!  0
	!  1
	!  P: pi
	real*8 function f(n,arities,ops,x) ! n=number of ops, x=arg vector
	implicit none
	integer nmax, n, i, j, arities(n), arity, lnblnk
	character*60 ops
	parameter(nmax=100)
	real*8 x(nmax), y, stack(nmax)
	character op
	!write(*,*) 'Evaluating function with ops = ',ops(1:n)
	!write(*,'(3f10.5,99i3)') (x(i),i=1,3), (arities(i),i=1,n)
	j = 0 ! Number of numbers on the stack
	do i=1,n
	  arity = arities(i)
	  op = ops(i:i)
	  if (arity.eq.0) then ! This is a nonary function
	    if (op.eq."0") then
              y = 0.
	    else if (op.eq."1") then
	      y = 1.
	    else if (op.eq."P") then
 	      y = 4.*atan(1.) ! pi
           else
    	      y = x(ichar(op)-96)
	    end if
	  else if (arity.eq.1) then ! This is a unary function
	    if (op.eq.">") then
             y = stack(j) + 1
	    else if (op.eq."<") then
             y = stack(j) - 1
	    else if (op.eq."~") then
              y = -stack(j)
	    else if (op.eq."\") then
             y = 1./stack(j)
	    else if (op.eq."L") then
             y = log(stack(j))
	    else if (op.eq."E") then
             y = exp(stack(j))
	    else if (op.eq."S") then
             y = sin(stack(j))
	    else if (op.eq."C") then
             y =cos(stack(j))
	    else if (op.eq."A") then
             y = abs(stack(j))
	    else if (op.eq."N") then
             y = asin(stack(j))
	    else if (op.eq."T") then
             y = atan(stack(j))
	    else if (op.eq."O") then
             y = 2.*stack(j)
	    else if (op.eq."J") then
             y = 1+2.*stack(j)
	    else
             y = sqrt(stack(j))
	    end if
	  else ! This is a binary function
	  if (op.eq."+") then
	      y = stack(j-1)+stack(j)
	    else if (op.eq."-") then
	      y = stack(j-1)-stack(j)
	    else if (op.eq."*") then
	      y = stack(j-1)*stack(j)
	    else
	      y = stack(j-1)/stack(j)
	    end if
          end if
	  j = j + 1 - arity
          stack(j) = y
	  ! write(*,'(9f10.5)') (stack(k),k=1,j)
	end do
	if (j.ne.1) stop 'DEATH ERROR: STACK UNBALANCED'
	f = stack(1)
        !write(*,'(9f10.5)') 666.,x(1),x(2),x(3),f
	return
	end

        subroutine multiloop(n,bases,i,done)
        ! Handles <n> nested loops with loop variables i(1),...i(n).
        ! Example: With n=3, bases=2, repeated calls starting with i=(000) will return
        ! 001, 010, 011, 100, 101, 110, 111, 000 (and done=.true. the last time).
        ! All it's doing is counting in mixed radix specified by the array <bases>.
        implicit none
        integer n, bases(n), i(n), k
        logical done
        done = .false.
        k = 1
555     i(k) = i(k) + 1
        if (i(k).lt.bases(k)) return
        i(k) = 0
        k = k + 1
        if (k.le.n) goto 555
        done = .true.
        return
        end

	real*8 function limit(x)
	implicit none
	real*8 x, xmax
	parameter(xmax=666.)
	if (abs(x).lt.xmax) then
 	  limit = x
	else
	  limit = sign(xmax,x)
	end if
	return
	end

	subroutine LoadMatrixTranspose(nd,n,mmax,m,A,f)
	! Reads the n x m matrix A from the file named f, stored as its transpose
	implicit none
	integer nd,mmax,n,m,j
	real*8 A(nd,mmax)
	character*60 f
	open(2,file=f,status='old')
	m = 0
555	m = m + 1
	if (m.gt.mmax) stop 'DEATH ERROR: m>mmax in LoadVectorTranspose'
	read(2,*,end=666) (A(j,m),j=1,n)
	goto 555
666	close(2)
	m = m - 1
	print *,m,' rows read from file ',f
	return
	end

	real*8 function mymedian(n,a)
        implicit none
        integer n,nmax, i
        parameter(nmax=10000000)
        real*8 a(n), b(nmax)
        if (n.gt.nmax) stop 'DEATH ERROR: n>nmax in mymedian'
        do i=1,n
          b(i) = a(i)
        end do
        call sort(n,b)
        i = nint((n+.5)/2)
        if (i.eq.0) i=1
        mymedian = b(i)
        return
        end

	subroutine permutation(n,iarr) ! Return a random permutation of the first n integer:
	integer iarr(n), idum, nmax, i
        parameter(nmax=10000000)
        real*8 arr(nmax), brr(nmax), ran1
        if (n.gt.nmax) stop "PERMUTATION DEATH ERROR: nmax TOO SMALL"
        idum = -666
        do i=1,n
          arr(i) = ran1(idum)
          brr(i) = i
        end do
        call sort2(n,arr,brr)
        do i=1,n
          iarr(i) = nint(brr(i))
        end do
	return
        end

      SUBROUTINE sort(n,arr) ! Numerical Recipes Quicksort:
      INTEGER n,M,NSTACK
      REAL*8 arr(n)
      PARAMETER (M=7,NSTACK=50)
      INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
      REAL*8 a,temp
      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do 12 j=l+1,ir
          a=arr(j)
          do 11 i=j-1,1,-1
            if(arr(i).le.a)goto 2
            arr(i+1)=arr(i)
11        continue
          i=0
2         arr(i+1)=a
12      continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        temp=arr(k)
        arr(k)=arr(l+1)
        arr(l+1)=temp
        if(arr(l+1).gt.arr(ir))then
          temp=arr(l+1)
          arr(l+1)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l).gt.arr(ir))then
          temp=arr(l)
          arr(l)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l+1).gt.arr(l))then
          temp=arr(l+1)
          arr(l+1)=arr(l)
          arr(l)=temp
        endif
        i=l+1
        j=ir
        a=arr(l)
3       continue
          i=i+1
        if(arr(i).lt.a)goto 3
4       continue
          j=j-1
        if(arr(j).gt.a)goto 4
        if(j.lt.i)goto 5
        temp=arr(i)
        arr(i)=arr(j)
        arr(j)=temp
        goto 3
5       arr(l)=arr(j)
        arr(j)=a
        jstack=jstack+2
        if(jstack.gt.NSTACK) stop 'NSTACK too small in sort'
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      END

      SUBROUTINE sort2(n,arr,brr)  ! Numerical Recipes Quicksort:
      INTEGER n,M,NSTACK
      REAL*8 arr(n),brr(n)
      PARAMETER (M=7,NSTACK=50)
      INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
      REAL*8 a,b,temp
      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do 12 j=l+1,ir
          a=arr(j)
          b=brr(j)
          do 11 i=j-1,1,-1
            if(arr(i).le.a)goto 2
            arr(i+1)=arr(i)
            brr(i+1)=brr(i)
11        continue
          i=0
2         arr(i+1)=a
          brr(i+1)=b
12      continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        temp=arr(k)
        arr(k)=arr(l+1)
        arr(l+1)=temp
        temp=brr(k)
        brr(k)=brr(l+1)
        brr(l+1)=temp
        if(arr(l+1).gt.arr(ir))then
          temp=arr(l+1)
          arr(l+1)=arr(ir)
          arr(ir)=temp
          temp=brr(l+1)
          brr(l+1)=brr(ir)
          brr(ir)=temp
        endif
        if(arr(l).gt.arr(ir))then
          temp=arr(l)
          arr(l)=arr(ir)
          arr(ir)=temp
          temp=brr(l)
          brr(l)=brr(ir)
          brr(ir)=temp
        endif
        if(arr(l+1).gt.arr(l))then
          temp=arr(l+1)
          arr(l+1)=arr(l)
          arr(l)=temp
          temp=brr(l+1)
          brr(l+1)=brr(l)
          brr(l)=temp
        endif
        i=l+1
        j=ir
        a=arr(l)
        b=brr(l)
3       continue
          i=i+1
        if(arr(i).lt.a)goto 3
4       continue
          j=j-1
        if(arr(j).gt.a)goto 4
        if(j.lt.i)goto 5
        temp=arr(i)
        arr(i)=arr(j)
        arr(j)=temp
        temp=brr(i)
        brr(i)=brr(j)
        brr(j)=temp
        goto 3
5       arr(l)=arr(j)
        arr(j)=a
        brr(l)=brr(j)
        brr(j)=b
        jstack=jstack+2
        if(jstack.gt.NSTACK)stop 'NSTACK too small in sort2'
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      END

      ! Numerical Recipes random number generator:
      FUNCTION ran1(idum)
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      REAL*8 ran1,AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
     *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/
      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=min(AM*iy,RNMX)
      return
      END


     subroutine fort_set_homog_bcs(lo,hi,domlo,domhi, &
                                   phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3)
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     phi = 0.d0

     end subroutine fort_set_homog_bcs

     ! ************************************************************************************
     ! Loops over the particles and adds their monopole contribution to phi outside the boundary
     ! ************************************************************************************

     subroutine fort_add_monopole_bcs(lo,hi,domlo,domhi, &
                                      np,part_locs,part_mass, &
                                      phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     use fundamental_constants_module, only : Gconst

     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3),np
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(in   ) :: part_locs(0:3*np-1)
     real(rt),intent(in   ) :: part_mass(0:  np-1)
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     ! Local variables
     integer          :: i,j,k,n
     real(rt) :: x,y,z,r
     real(rt) :: x0,y0,z0

     phi = 0.d0

     ! Define phi = -G M / r where r is distance from particle and M is mass of particle

     do k = lo(3)-1,hi(3)+1
         do j = lo(2)-1,hi(2)+1
             do i = lo(1)-1,hi(1)+1

                   if (i.lt.domlo(1) .or. i.gt.domhi(1) .or. &
                       j.lt.domlo(2) .or. j.gt.domhi(2) .or. &
                       k.lt.domlo(3) .or. k.gt.domhi(3)) then

                       if (i.lt.domlo(1)) then
                           x0 = (dble(i+1))*dx(1)
                       else if (i.gt.domhi(1)) then
                           x0 = (dble(i))*dx(1)
                       else
                           x0 = (dble(i)+0.5d0)*dx(1)
                       end if

                       if (j.lt.domlo(2)) then
                           y0 = (dble(j+1))*dx(2)
                       else if (j.gt.domhi(2)) then
                           y0 = (dble(j))*dx(2)
                       else
                           y0 = (dble(j)+0.5d0)*dx(2)
                       end if

                       if (k.lt.domlo(3)) then
                           z0 = (dble(k+1))*dx(3)
                       else if (k.gt.domhi(3)) then
                           z0 = (dble(k))*dx(3)
                       else
                           z0 = (dble(k)+0.5d0)*dx(3)
                       end if

                       do n = 0, np-1
                           x = x0 - part_locs(3*n  )
                           y = y0 - part_locs(3*n+1)
                           z = z0 - part_locs(3*n+2)
                           r = sqrt(x*x + y*y + z*z)
                           phi(i,j,k) = phi(i,j,k) - Gconst * part_mass(n) / r
                       end do

                   end if
              end do
         end do
     end do

     end subroutine fort_add_monopole_bcs


       subroutine fem_shapefunctions_3r
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Computes the shapefunctions and their derivatives at each gausspoint
! for each hex element in three dimensions. Called when 'fem'
! computations are used in 3-D.
!
! Author : Sai Rapaka
!

       use comai, only: icnl, nei, ns
       use combi, only: cord
       use comfem

       implicit none

       real*8, dimension(8)   :: N, dNdZeta, dNdEta, dNdMu
       real*8, dimension(8)   :: xx, yy, zz
       real*8, dimension(3,3) :: invJ

       real*8 zeta, eta, mu
       real*8 dXdZeta, dXdEta, dXdMu
       real*8 dYdZeta, dYdEta, dYdMu
       real*8 dZdZeta, dZdEta, dZdMu
       real*8 m11, m12, m13, m21, m22, m23, m31, m32, m33
       real*8 o8, dum
       integer i,j,k

       if(icnl.ne.0) return
       if(ns.ne.8)   return
       !if(ifem.ne.1) return

       do i=1,nei

         do k=1,8
           xx(k) = cord(elnode(i,k),1)
           yy(k) = cord(elnode(i,k),2)
           zz(k) = cord(elnode(i,k),3)
         enddo

         do j=1,numgausspoints
           zeta = gpcord(j,1)
           eta  = gpcord(j,2)
           mu   = gpcord(j,3)

           o8 = 1.0d0/8.0d0
           N(1) = o8*(1 - zeta)*(1 - eta)*(1 - mu)
           N(2) = o8*(1 + zeta)*(1 - eta)*(1 - mu)
           N(3) = o8*(1 + zeta)*(1 + eta)*(1 - mu)
           N(4) = o8*(1 - zeta)*(1 + eta)*(1 - mu)
           N(5) = o8*(1 - zeta)*(1 - eta)*(1 + mu)
           N(6) = o8*(1 + zeta)*(1 - eta)*(1 + mu)
           N(7) = o8*(1 + zeta)*(1 + eta)*(1 + mu)
           N(8) = o8*(1 - zeta)*(1 + eta)*(1 + mu)

           dNdZeta(1) = -o8*(1 - eta)*(1 - mu)
           dNdZeta(2) = +o8*(1 - eta)*(1 - mu)
           dNdZeta(3) = +o8*(1 + eta)*(1 - mu)
           dNdZeta(4) = -o8*(1 + eta)*(1 - mu)
           dNdZeta(5) = -o8*(1 - eta)*(1 + mu)
           dNdZeta(6) = +o8*(1 - eta)*(1 + mu)
           dNdZeta(7) = +o8*(1 + eta)*(1 + mu)
           dNdZeta(8) = -o8*(1 + eta)*(1 + mu)

           dNdEta(1) = -o8*(1 - zeta)*(1 - mu)
           dNdEta(2) = -o8*(1 + zeta)*(1 - mu)
           dNdEta(3) = +o8*(1 + zeta)*(1 - mu)
           dNdEta(4) = +o8*(1 - zeta)*(1 - mu)
           dNdEta(5) = -o8*(1 - zeta)*(1 + mu)
           dNdEta(6) = -o8*(1 + zeta)*(1 + mu)
           dNdEta(7) = +o8*(1 + zeta)*(1 + mu)
           dNdEta(8) = +o8*(1 - zeta)*(1 + mu)

           dNdMu(1) = -o8*(1 - zeta)*(1 - eta)
           dNdMu(2) = -o8*(1 + zeta)*(1 - eta)
           dNdMu(3) = -o8*(1 + zeta)*(1 + eta)
           dNdMu(4) = -o8*(1 - zeta)*(1 + eta)
           dNdMu(5) = +o8*(1 - zeta)*(1 - eta)
           dNdMu(6) = +o8*(1 + zeta)*(1 - eta)
           dNdMu(7) = +o8*(1 + zeta)*(1 + eta)
           dNdMu(8) = +o8*(1 - zeta)*(1 + eta)

           dXdZeta = 0.0d0
           dXdEta  = 0.0d0
           dXdMu   = 0.0d0
           dYdZeta = 0.0d0
           dYdEta  = 0.0d0
           dYdMu   = 0.0d0
           dZdZeta = 0.0d0
           dZdEta  = 0.0d0
           dZdMu   = 0.0d0

           do k=1,8
             dXdZeta = dXdZeta + xx(k)*dNdZeta(k)
             dXdEta  = dXdEta  + xx(k)*dNdEta(k)
             dXdMu   = dXdMu   + xx(k)*dNdMu(k)

             dYdZeta = dYdZeta + yy(k)*dNdZeta(k)
             dYdEta  = dYdEta  + yy(k)*dNdEta(k)
             dYdMu   = dYdMu   + yy(k)*dNdMu(k)

             dZdZeta = dZdZeta + zz(k)*dNdZeta(k)
             dZdEta  = dZdEta  + zz(k)*dNdEta(k)
             dZdMu   = dZdMu   + zz(k)*dNdMu(k)
           enddo

           dum = dXdZeta*(dYdEta*dZdMu - dZdEta*dYdMu)
           dum = dum + dYdZeta*(dZdEta*dXdMu - dXdEta*dZdMu)
           dum = dum + dZdZeta*(dXdEta*dYdMu - dYdEta*dXdMu)
           detJ(i,j) = dum

           ! minors
           m11 = dYdEta*dZdMu - dZdEta*dYdMu
           m12 = dXdEta*dZdMu - dZdEta*dXdMu
           m13 = dXdEta*dYdMu - dYdEta*dXdMu
           m21 = dYdZeta*dZdMu - dZdZeta*dYdMu
           m22 = dXdZeta*dZdMu - dZdZeta*dXdMu
           m23 = dXdZeta*dYdMu - dYdZeta*dXdMu
           m31 = dYdZeta*dZdEta - dZdZeta*dYdEta
           m32 = dXdZeta*dZdEta - dZdZeta*dXdEta
           m33 = dXdZeta*dYdEta - dYdZeta*dXdEta

           ! inverse of jacobian matrix
           invJ(1,1) = +m11
           invJ(1,2) = -m21
           invJ(1,3) = +m31
           invJ(2,1) = -m12
           invJ(2,2) = +m22
           invJ(2,3) = -m32
           invJ(3,1) = +m13
           invJ(3,2) = -m23
           invJ(3,3) = +m33

           invJ = invJ/detJ(i,j)

           do k = 1,ns
             Psi(i,j,k) = N(k)
             dPsidX(i,j,k) = invJ(1,1)*dNdZeta(k) + invJ(1,2)*dNdEta(k)
     &                       + invJ(1,3)*dNdMu(k)
             dPsidY(i,j,k) = invJ(2,1)*dNdZeta(k) + invJ(2,2)*dNdEta(k)
     &                       + invJ(2,3)*dNdMu(k)
             dPsidZ(i,j,k) = invJ(3,1)*dNdZeta(k) + invJ(3,2)*dNdEta(k)
     &                       + invJ(3,3)*dNdMu(k)
           enddo

         enddo

       enddo

       end subroutine fem_shapefunctions_3r


FUNCTION COMPUTE_TAU1(cstar,mact,logt,logl,logg,zz,lmdot)

  !routine to compute tau at 1um from input
  !stellar parameters.  See Villaume et al. (2015)

  USE sps_vars
  IMPLICIT NONE
  INTEGER, INTENT(in) :: cstar
  REAL(SP), INTENT(in)  :: mact,logt,logl,logg, zz,lmdot
  REAL(SP) :: compute_tau1, radius, period, vexp, vexp_max
  REAL(SP) :: rin, delta, kappa, delta_agb, mdot

  !-----------------------------------------------------------!
  !write(*,*) 'in function: ', cstar
  !dust-to-gas ratio depends on C/O
  IF (cstar.EQ.1) THEN
     delta_agb = 0.0025
  ELSE
     delta_agb = 0.01
  ENDIF

  !extinction coefficient depends on grain composition (C/O)
  IF (cstar.EQ.1) THEN
     !sum of AmC and SiC (90%+10%)
     kappa = 3200.
  ELSE
     !Sil
     kappa = 3000.
  ENDIF

  !stellar radius in solar units
  radius = SQRT(mact*msun*newton/10**logg) / rsun

  !fundamental pulsation period in days
  period = 10**( -2.07 + 1.94*LOG10(radius)-0.9*LOG10(mact) )

  !expansion velocity in km/s
  vexp     = -13.5 + 0.056*period
  !metallicity dependent maximum (Bressan et al. 1998)
  !this implicitly introduces a (strong) metallicity
  !dependence on the dust-to-gas ratio (see below)
  !vexp_max = 6.5*zz/0.008 + 0.00226*period
  vexp     = MAX(MIN(vexp,15.0),3.0)

  !mass-loss rate in Msun/yr
  IF (use_isoc_mdot.EQ.1) THEN
     IF (isoc_type.NE.'mist') THEN
        WRITE(*,*) 'ADD_AGB_DUST ERROR: use_isoc_mist=1 but isoc_type NE MIST!'
        STOP
     ENDIF
     !use Mdot from the isochrone files
     mdot = MIN(10**lmdot,1E-4)
  ELSE
     !see Vassiliadis & Wood (1993) for details
     IF (period.LT.500.) THEN
        IF (mact.LT.2.5) THEN
           mdot = 10**(-11.4+0.0123*period)
        ELSE
           mdot = 10**(-11.4+0.0125*(period-100*(mact-2.5)))
        ENDIF
     ELSE
        !superwind phase
        mdot = 10**logl/vexp*1.93E3*yr2sc/clight
     ENDIF
  ENDIF

  !inner radius (assuming Td=1100K for C-rich and
  !Td=700 for O-rich) in cm
  IF (cstar.EQ.1) THEN
    rin = 1.92E12 * (10**logl)**0.5
  ELSE
    rin = 4.74E12 * (10**logl)**0.5
  ENDIF

  !dust-to-gas ratio
  delta = delta_agb * vexp**2 / 225. * (10**logl/1E4)**(-0.6)

  !finally, compute tau (and convert to cgs)
  compute_tau1 = kappa * delta * (mdot*msun/yr2sc) &
       / rin / (4*mypi) / (vexp*1E5)

  !WRITE(*,'(13ES11.2)') mact,logl,logg,radius,period,mdot,rin,&
  !     vexp,delta,compute_tau1

END FUNCTION COMPUTE_TAU1

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

SUBROUTINE ADD_AGB_DUST(weight,tspec,mact,logt,logl,logg,zz,&
     tco,lmdot)

  !routine to add a circumstellar dust shell to AGB stars
  !computes the optical depth at 1um from stellar parameters
  !then looks up the corresponding DUSTY model given the C/O
  !ratio and Teff.

  USE sps_vars; USE sps_utils, ONLY: locate, smoothspec
  IMPLICIT NONE

  REAL(SP), DIMENSION(nspec), INTENT(inout) :: tspec
  REAL(SP), INTENT(in)  :: weight,mact,logt,logl,logg,zz,tco,lmdot
  INTEGER :: cstar,jlo,klo
  REAL(SP) :: tau1,dj,dk, compute_tau1, loggi
  REAL(SP), DIMENSION(nspec) :: dusty

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

  IF (tco.GT.1) THEN
     cstar=1
  ELSE
     cstar=0
  ENDIF

  !we need to recompute loggi here because the BaSTI
  !isochrones do not come with logg pre-tabulated
    IF (isoc_type.EQ.'bsti') THEN
        loggi = LOG10( gsig4pi*mact/10**logl ) + 4*logt
    ELSE
        loggi = logg
    ENDIF
   !compute tau1 based on input stellar parameters
   tau1 = compute_tau1(cstar,mact,logt,logl,loggi,zz,lmdot)

  !allow the user to manually adjust the tau1 value
  !by an overall scale factor
  tau1 = tau1*weight

  IF (tau1.LE.tiny_number) RETURN

  !find dusty model given tau1,tco,Teff
  jlo = MIN(MAX(locate(teff_dagb(cstar+1,:),10**logt),1),&
       nteff_dagb-1)
  klo = MIN(MAX(locate(tau1_dagb(cstar+1,:),LOG10(tau1)),1),ntau_dagb-1)

  dj   = (10**logt-teff_dagb(cstar+1,jlo)) / &
       (teff_dagb(cstar+1,jlo+1)-teff_dagb(cstar+1,jlo))
  dk   = (LOG10(tau1)-tau1_dagb(cstar+1,klo)) / &
       (tau1_dagb(cstar+1,klo+1)-tau1_dagb(cstar+1,klo))

  !don't allow extrapolation off the grid
  dj = MIN(MAX(dj,-1.0),1.0)
  dk = MIN(MAX(dk,-1.0),1.0)

  !bilinear interpolation
  dusty = (1-dj)*(1-dk)*flux_dagb(:,cstar+1,jlo,klo) + &
       dj*(1-dk)*flux_dagb(:,cstar+1,jlo+1,klo) + &
       dj*dk*flux_dagb(:,cstar+1,jlo+1,klo+1) + &
       (1-dj)*dk*flux_dagb(:,cstar+1,jlo,klo+1)

  !implement the dusty spectra (which are in units of
  !flux_out/flux_in) into the AGB spectra
!  tspec = tspec * dusty
  CALL SMOOTHSPEC(spec_lambda,tspec,10000.d0,30000.d0,100000000.d0)
  tspec = tspec * dusty

END SUBROUTINE ADD_AGB_DUST


      subroutine qltri2(p1sq,p2sq,musq,Ival)
      implicit none
      include 'qlconstants.f'
      double precision p1sq,p2sq,musq,r
      double complex qllnrat,Ival(-2:0),wlog1,wlog2

      wlog1=qllnrat(musq,-p1sq)
      wlog2=qllnrat(musq,-p2sq)
      r = (p2sq-p1sq)/p1sq

      Ival(-2)=czip
      if (abs(r) .lt. 1d-6) then
      Ival(-1)=dcmplx(1d0/p1sq)*(cone-dcmplx(r/2d0*musq/p1sq))
      Ival(0)=dcmplx(1d0/p1sq)*(wlog1-dcmplx(r/2d0)*(cone+wlog1))
      else
      Ival(-1)=(wlog1-wlog2)/dcmplx(p1sq-p2sq)
      Ival(0)=chalf*Ival(-1)*(wlog1+wlog2)
      endif
      return
      end


c****************************************************************

	subroutine norm(r_v,r_n)

c****************************************************************
c**
c**	FILE NAME: norm.f
c**
c**     DATE WRITTEN: 8/3/90
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine takes vector and returns
c**     its norm.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
        real*8 r_v(3)                              !3x1 vector

c   	OUTPUT VARIABLES:see input

c	LOCAL VARIABLES:
	real*8 r_n

c  	PROCESSING STEPS:

c       compute vector norm

        r_n = sqrt(r_v(1)**2 + r_v(2)**2 + r_v(3)**2)

        end


      subroutine n1qn2 (simul,prosca,n,x,f,g,dxmin,df1,epsg,impres,io,
     /                  mode,niter,nsim,dz,ndz,izs,rzs,dzs)
c!But
c     Minimisation sans contrainte par un algorithme
c     de quasi-Newton a memoire limitee.
c
c!Commentaires
c     Ce code est en principe destine aux problemes de grande taille,
c     n grand, mais convient egalement pour n quelconque. La methode
c     utilisee est du type quasi-Newton (BFGS) a encombrement variable,
c     ce qui permet d'utiliser au maximum la memoire declaree dispo-
c     nible. On estine que plus la memoire utilisee est importante, plus
c     rapide sera la decroissance du critere f.
c!Sous-routines appelees
c     n1qn2:    routine-chapeau qui structure la memoire declaree dispo-
c               nible et appelle n1qn2a,
c     n1qn2a:   optimiseur proprement dit,
c     strang:   routine de calcul de la direction de descente,
c     nlis0:    routine de recherche lineaire.
c
c     De son cote, l'utilisateur doit fournir:
c     1) une routine qui appelle le module d'optimisation n1qn2,
c     2) une routine de simulation, appelee simul par n1qn2, qui
c        calcule la valeur de f et de son gradient en un point donne,
c     3) une routine, appelee prosca par n1qn2, qui realise le produit
c        scalaire de deux vecteurs, ce produit scalaire doit etre
c        celui utilise pour calculer le gradient de f dans simul.
c!Liste d'appel
c     subroutine n1qn2 (simul,prosca,n,x,f,g,dxmin,df1,epsg,impres,io,
c    /                  mode,niter,nsim,dz,ndz,izs,rzs,dzs)
c
c     Dans la description des arguments qui suit, (e) signifie que
c     l'argument doit etre initialise avant l'appel de n1qn2, (s)
c     signifie que l'argument est une variable n'ayant de signification
c     qu'en sortie et (es) = (e)+(s). Les arguments du type (s) et (es)
c     sont en general modifies par n1qn2 et ne peuvent donc pas etre
c     des constantes.
c
c     simul:     Nom d'appel de la sous-routine de simulation qui
c                qui calcule la valeur de f et de son gradient g
c                a l'itere courant. Ce module doit se presenter comme
c                suit:
c                   subroutine simul (indic,n,x,f,g,izs,rzs,dzs).
c                Le nom de la sous-routine doit etre declare external
c                dans le module appelant n1qn2. Les arguments n, x, f,
c                g, izs, rzs et dzs ont la meme signification que ci-
c                dessous. N1qn2 appelle simul soit avec indic=1, dans
c                ce cas le simulateur fera ce qu'il veut mais ne chan-
c                gera pas la valeur des arguments, ou avec indic=4, dans
c                cas le simulateur calculera a la fois f et g.
c     prosca:    Nom d'appel de la sous-routine effectuant le produit
c                scalaire de deux vecteurs u et v. Ce module doit se
c                presente sous la forme:
c                   subroutine prosca (n,u,v,ps,izs,rzs,dzs).
c                Le nom de la sous-routine doit etre declare external
c                dans le module appelant n1qn2. Les argument n, izs,
c                rzs et dzs ont la meme signification que ci-dessous.
c                Les arguments u, v et ps sont des vecteurs de dimension
c                n du type double precision. Ps donne le produit
c                scalaire de u et v.
c     n(e):      Scalaire du type integer. Donne la dimension n de la
c                variable x.
c     x(es):     Vecteur de dimension n du type double precision. En
c                entree il faut fournir la valeur du point initial, en
c                sortie, c'est le point final calcule par n1qn2.
c     f(es):     Scalaire du type double precision. En entree, c'est la
c                valeur de f en x (initial), valeur que l'on obtiendra
c                en appelant le simulateur simul avant d'appeler n1qn2.
c                En sortie, c'est la valeur de f en x (final).
c     g(es):     Vecteur de dimension n du type double precision.
c                En entree, il faut fournir la valeur du gradient de f
c                en x (initial), valeur que l'on obtiendra en appelant
c                le simulateur simul avant d'appeler n1qn2. En sortie en
c                mode 1, c'est la valeur du gradient de f en x (final).
c     dxmin(e):  Scalaire du type double precision, strictement positif.
c                Cet argument definit la resolution sur x en norme
c                l-infini: deux points dont la distance en norme l-
c                infini est superieure a dxmin seront consideres comme
c                non distinguables par la routine de recherche lineaire.
c     df1(e):    Scalaire du type double precision, strictement positif.
c                Cet argument donne une estimation de la diminution
c                escomptee pour f lors de la premiere iteration.
c     epsg(es):  Scalaire du type double precision, strictement positif
c                et strictement inferieur a 1. Sa valeur en entree,
c                determine le test d'arret qui porte sur la norme
c                (prosca) du gradient. Le minimiseur considere que la
c                convergence est atteinte en x(k) et s'arrete en mode 1
c                si E(k) := |g(k)|/|g(1)| < epsg, ou g(1) et g(k) sont
c                les gradients au point d'entree et a l'iteration k,
c                respectivement. En sortie, epsg = E(k).
c     impres(e): Scalaire du type integer qui controle les sorties.
c                <0:  Rien n'est imprime et n1qn2 appelle le simulateur
c                     avec indic=1 toutes les (-impres) iterations.
c                =0:  Rien n'est imprime.
c                >=1: Impressions initiales et finales, messages
c                     d'erreurs.
c                >=3: Une ligne d'impression par iteration donnant
c                     l'ordre k de l'iteration courante menant de x(k)
c                     a x(k+1), le nombre d'appels au simulateur avant
c                     cette iteration, la valeur du critere f et sa
c                     derivee directionnelle suivant d(k).
c                >=4: Impression de nlis0.
c                >=5: Impressions supplentaires en fin d'iteration k:
c                     le test d'arret E(k+1), prosca(y(k),s(k)) qui
c                     doit etre positif, le facteur de Oren-Spedicato
c                     et l'angle de la direction de descente d(k) avec
c                     -g(k).
c     io(e):     Scalaire du type integer qui sera pris comme numero
c                de canal de sortie pour les impressions controlees
c                par impres.
c     mode(s):   Scalaire du type integer donnant le mode de sortie de
c                n1qn2.
c                <0: Impossibilite de poursuivre la recherche lineaire
c                    car le simulateur a repondu avec indic<0. Mode
c                    renvoie cette valeur de indic.
c                =0: Arret demande par le simulateur qui a repondu avec
c                    indic=0.
c                =1: Fin normale avec test sur le gradient satisfait.
c                =2: Arguments d'entree mal initialises. Il peut s'agir
c                    de n<=0, niter<=0, nsim<=0, dxmin<=0, epsg<=0,
c                    epsg>1 ou de nrz<5n+1 (pas assez de memoire
c                    allouee).
c                =3: La recherche lineaire a ete bloquee sur tmax=10^20
c                    (mode tres peu probable).
c                =4: Nombre maximal d'iterations atteint.
c                =5: Nombre maximal de simulations atteint.
c                =6: Arret sur dxmin lors de la recherche lineaire. Ce
c                    mode de sortie peut avoir des origines tres
c                    diverses. Si le nombre d'essais de pas lors de la
c                    derniere recherche lineaire est faible, cela peut
c                    signifier que dxmin a ete pris trop grand. Il peut
c                    aussi s'agir d'erreurs ou d'imprecision dans le
c                    calcul du gradient. Dans ce cas, la direction de
c                    recherche d(k) peut ne plus etre une direction de
c                    descente de f en x(k), etant donne que n1qn2
c                    s'autorise des directions d(k) pouvant faire avec
c                    -g(k) un angle proche de 90 degres. On veillera
c                    donc a calculer le gradient avec precision.
c                =7: Soit (g,d) soit (y,s) ne sont pas positifs (mode
c                    de sortie tres improbable).
c     niter(es): Scalaire du type integer, strictement positif. En
c                entree, c'est le nombre maximal d'iterations admis.
c                En sortie, c'est le nombre d'iterations effectuees.
c     nsim(es):  Scalaire du type integer, strictement positif. En
c                entree, c'est le nombre maximal de simulations admis.
c                En sortie, c'est le nombre de simulations effectuees.
c     rz(s):     Vecteur de dimension nrz du type double precision.
c                C'est l'adresse d'une zone de travail pour n1qn2.
c     nrz(e):    Scalaire du type integer, strictement positif, donnant
c                la dimension de la zone de travail rz. En plus des
c                vecteurs x et g donnes en arguments, n1qn2 a besoin
c                d'une zone de travail composee d'au moins trois
c                vecteurs de dimension n et chaque mise a jour demandee
c                necessite 1 scalaire et 2 vecteurs de dimension n
c                supplementaires. Donc si m est le nombre de mises a
c                jour desire pour la construction de la metrique
c                locale, il faudra prendre
c                   nrz >= 3*n + m*(2*n+1).
c                En fait, le nombre m est determine par n1qn2 qui prend:
c                   m = partie entiere par defaut de ((nrz-3*n)/(2*n+1))
c                Ce nombre doit etre >= 1. Il faut donc nrz >= 5*n +1,
c                sinon n1qn2 s'arrete en mode 2.
c     izs, rzs, dzs:  Adresses de zones-memoire respectivement du type
c                integer, real et double precision. Elles sont reservees
c                a l'utilisateur. N1qn2 ne les utilise pas et les
c                transmet a simul et prosca.
c!
c-----------------------------------------------------------------------
c
c     arguments
c
      integer n,impres,io,mode,niter,nsim,ndz,izs(*)
      real rzs(*)
      double precision x(*),f,g(*),dxmin,df1,epsg,dz(*)
      double precision dzs(*)
      external simul,prosca
c
c     variables locales
c
      integer m,ndzu,l1memo,id,igg,iaux,ialpha,iybar,isbar
      double precision r1,r2
      double precision ps
c
c---- impressions initiales et controle des arguments
c
      if (impres.ge.1)
     /    write (io,900) n,dxmin,df1,epsg,niter,nsim,impres
900   format (/,' n1qn2: point d''entree',/,
     /    5x,'dimension du probleme (n)              :',i6,/,
     /    5x,'precision absolue en x (dxmin)         :',d9.2,/,
     /    5x,'decroissance attendue pour f (df1)     :',d9.2,/,
     /    5x,'precision relative en g (epsg)         :',d9.2,/,
     /    5x,'nombre maximal d''iterations (niter)    :',i6,/,
     /    5x,'nombre maximal d''appels a simul (nsim) :',i6,/,
     /    5x,'niveau d''impression (impres)           :',i4)
      if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0.0d+0
     /    .or.epsg.le.0.0d+0.or.epsg.gt.1.0d+0) then
          mode=2
          if (impres.ge.1) write (io,901)
901       format (/,' >>> n1qn2 : appel incoherent')
          goto 904
      endif
      if (ndz.lt.5*n+1) then
          mode=2
          if (impres.ge.1) write (io,902)
902       format (/,' >>> n1qn2: memoire allouee insuffisante')
          goto 904
      endif
c
c---- calcul de m et des pointeurs subdivisant la zone de travail dz
c
      ndzu=ndz-3*n
      l1memo=2*n+1
      m=ndzu/l1memo
      ndzu=m*l1memo+3*n
      if (impres.ge.1) write (io,903) ndz,ndzu,m
903   format (/5x,'memoire allouee (ndz)  :',i7,/,
     /         5x,'memoire utilisee       :',i7,/,
     /         5x,'nombre de mises a jour :',i6,/)
      id=1
      igg=id+n
      iaux=igg+n
      ialpha=iaux+n
      iybar=ialpha+m
      isbar=iybar+n*m
c
c---- appel du code d'optimisation
c
      call n1qn2a (simul,prosca,n,x,f,g,dxmin,df1,epsg,
     /             impres,io,mode,niter,nsim,m,
     /             dz(id),dz(igg),dz(iaux),
     /             dz(ialpha),dz(iybar),dz(isbar),izs,rzs,dzs)
c
c---- impressions finales
c
904   continue
      if (impres.ge.1) write (io,905) mode,niter,nsim,epsg
905   format (/,1x,79('-'),/,
     /        /,1x,'n1qn2 : sortie en mode ',i2,
     /        /,5x,'nombre d''iterations              : ',i4,
     /        /,5x,'nombre d''appels a simul          : ',i6,
     /        /,5x,'precision relative atteinte sur g: ',d9.2)
      call prosca (n,x,x,ps,izs,rzs,dzs)
      r1=sqrt(ps)
      call prosca (n,g,g,ps,izs,rzs,dzs)
      r2=sqrt(ps)
      if (impres.ge.1) write (io,906) r1,f,r2
906   format (5x,'norme de x = ',d15.8,
     /      /,5x,'f          = ',d15.8,
     /      /,5x,'norme de g = ',d15.8)
c
      return
      end


SUBROUTINE ecmat(ecm,fun,ndof,nodof)
!
! This subroutine forms the element consistent mass matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::fun(:)
 REAL(iwp),INTENT(OUT)::ecm(:,:)
 INTEGER,INTENT(IN)::nodof,ndof
 INTEGER::nod,i,j
 REAL::nt(ndof,nodof),tn(nodof,ndof),zero=0.0_iwp
 nod=ndof/nodof
 nt=zero
 tn=zero
 DO i=1,nod
   DO j=1,nodof
     nt((i-1)*nodof+j,j)=fun(i)
     tn(j,(i-1)*nodof+j)=fun(i)
   END DO
 END DO
 ecm=MATMUL(nt,tn)
RETURN
END SUBROUTINE ecmat


subroutine setup_ls_func(T, T_exact, grad_phi, delx, dely, dx, dy, xp, yp, nx, ny, xi, xf)
use parallel_variables
use parameters
use kind_parameters
implicit none
include "mpif.h"

! Input variables

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(inout), dimension(-1:nx+2, xi-3:xf+3):: T
real(kind=dp), intent(inout), dimension(1:nx, xi-1:xf+1):: T_exact, grad_phi
real(kind=dp), intent(in):: delx(-2:nx+2), dely(-2:ny+2), dx(1:nx), dy(1:ny)
real(kind=dp), intent(in):: xp(-1:nx+2), yp(-1:ny+2)
! Local variables

integer:: ip, jp, it, jt, i, j
real(kind=dp):: center_x1, center_x2, center_y1, center_y2, radius1, radius2, slot_width, slot_length, temp1
real(kind=dp):: local_vol_exact

! Initialize the level-set function, T(x,y)

!radius = 0.20*pi
!center_x = 0.50*pi
!center_y = 0.20*(pi+1)
!L_perimeter = 2.0*pi*radius
!vol_exact = pi*radius*radius
!L_perimeter = 4*(2.0*radius)
!vol_exact = 4.0*radius*radius

radius = 1.2d-2
center_x = Lx/2.0d0
center_y = 6.0d-2
!radius = 1.0d-2
!center_x = Lx/2.0d0
!center_y = 1.2d-1

! Zalesak's disk
!radius = 15.0d0
!slot_width = 5.0d0
!slot_length = 25.0d0
!center_x = 50.0d0
!center_y = 75.0d0

! For merging of two bubble

!center_x1 = 0.5d0
!center_y1 = 0.35d0
!radius1 = 0.1d0

!center_x2 = 0.5d0
!center_y2 = 0.65d0
!radius2 = 0.15d0

!radius = radius1

L_perimeter = 2.0*pi*radius
vol_exact = pi*radius*radius

!inlet_velocity = reynolds_number*mu(1,1)/(rho(1,1)*hydraulic_dia)
v_ref = dsqrt(gravity*radius)
time_ref = v_ref/radius

rho_ref = rho_l
mu_ref = mu_l

reynolds_number = rho_ref*v_ref*radius/mu_ref
bond_number = rho_ref*gravity*radius*radius/surface_tension

write(*,*) 'Reference Velocity = ', v_ref
write(*,*) 'gravity = ', gravity
write(*,*) 'epsilon = ', epsilon

do jt = xi-3,xf+3

 do it = -1,nx+2

	! For Bubble drop
    !T(it,jt) = ((xp(it) - center_x)*(xp(it) - center_x) + (yp(jt) - center_y)*(yp(jt) - center_y)) - radius*radius
    T(it,jt) = dsqrt((xp(it) - center_x)*(xp(it) - center_x) + (yp(jt) - center_y)*(yp(jt) - center_y)) - radius
    !T(it,jt) = min(yp(jt)-0.05d0,dsqrt((xp(it) - center_x)*(xp(it) - center_x) + (yp(jt) - center_y)*(yp(jt) - center_y)) - radius)

    ! Merging of two bubbles
    !T(it,jt) = min(dsqrt((xp(it) - center_x1)**2 + (yp(jt) -center_y1)**2) - radius1, dsqrt((xp(it) - center_x2)*(xp(it) - center_x2) + (yp(jt) - center_y2)*(yp(jt) - center_y2)) - radius2)

    !For Rayleigh Taylor instability
    !T(it,jt) = yp(jt) -(2.0d0 + 0.05d0*cos(2.0d0*pi*xp(it)/1.0d0))

    !For dam breaking
    !T(it,jt) = max(yp(jt)-1.0d0,xp(it)-1.0d0)

    !For capillary rise
    !T(it,jt) = yp(jt) - 7.0832d-4

    ! Zalesak's disk
!    temp1 = max(abs(yp(jt)-(75.0d0-2.50d0))-25.0d0/2.0d0, abs(xp(it)-50.0d0)-5.0d0/2.0d0)
!    T(it,jt) = min(radius - dsqrt((xp(it) - center_x)*(xp(it) - center_x) + (yp(jt) - center_y)*(yp(jt) - center_y)), temp1)

 end do

end do

!! Boundary conditions for level-set function
!
!  T(1,xi-3:xf+3) = T(2,xi-3:xf+3) + delx(1)*(T(2,xi-3:xf+3) - T(3,xi-3:xf+3))/delx(2)
!  T(0,xi-3:xf+3) = T(1,xi-3:xf+3) + delx(0)*(T(1,xi-3:xf+3) - T(2,xi-3:xf+3))/delx(1)
!  T(-1,xi-3:xf+3) = T(0,xi-3:xf+3)+ delx(-1)*(T(0,xi-3:xf+3) - T(1,xi-3:xf+3))/delx(0)
!
!  T(nx,xi-3:xf+3) = T(nx-1,xi-3:xf+3) + delx(nx-1)*(T(nx-1,xi-3:xf+3) - T(nx-2,xi-3:xf+3))/delx(nx-2)
!  T(nx+1,xi-3:xf+3) = T(nx,xi-3:xf+3)+ delx(nx)*(T(nx,xi-3:xf+3) - T(nx-1,xi-3:xf+3))/delx(nx-1)
!  T(nx+2,xi-3:xf+3) = T(nx+1,xi-3:xf+3)+ delx(nx+1)*(T(nx+1,xi-3:xf+3) - T(nx,xi-3:xf+3))/delx(nx)
!
!if (xf .eq. ny-1) then
!
!  T(:,ny) = T(:,ny-1) + dely(ny-1)*(T(:,ny-1) - T(:,ny-2))/dely(ny-2)
!  T(:,ny+1) = T(:,ny) + dely(ny)*(T(:,ny) - T(:,ny-1))/dely(ny-1)
!  T(:,ny+2) = T(:,ny+1)+ dely(ny+1)*(T(:,ny+1) - T(:,ny))/dely(ny)
!
!end if
!
!if (xi .eq. 2) then
!
!  T(:,1) = T(:,2)+ dely(1)*(T(:,2) - T(:,3))/dely(2)
!  T(:,0) = T(:,1)+ dely(0)*(T(:,1) - T(:,2))/dely(1)
!  T(:,-1) = T(:,0)+ dely(-1)*(T(:,0) - T(:,1))/dely(0)
!
!end if

tlocal1 = MPI_Wtime()

call exchange_lsdata(T, nx+4, xi, xf)

tlocal2 = MPI_Wtime()

communication_time = communication_time + (tlocal2 - tlocal1)

!call kappa_func1

! Calculate the exact area/ volume
vol_exact = 0.0d0
local_vol_exact = 0.0d0
T_exact = T
do jp = xi,xf

 do ip = 1,nx

     call Heaviside(T_exact(ip,jp), H_phi_exact, epsilon)
     local_vol_exact = local_vol_exact + (1.0d0 - H_phi_exact)*dx(ip)*dy(jp)

 end do

end do

call MPI_Allreduce(local_vol_exact, vol_exact, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)

grad_phi(:,:) = 0.0d0
grad_phi(2:nx-1,xi:xf) = 1.0d0
!error_check(:,:) = 0.0d0
end subroutine


C   09/02/93 305021512  MEMBER NAME  GAUINV   *.FORT     M  E2FORT
      FUNCTION GAUINV(P0)
C  INVERSE OF (INTEGRATED) NORMAL DISTRIBUTION FUNCTION
C              1         X= Y
C     P(Y)=-----------* INTEGRAL EXP(-X**2/2) DX
C          SQRT(2*PI)    X= -INF
C     IF P(Y)=P0, THEN GAUINV(P0)=Y.
C        0 < P0 < 1 ,   -INF < Y < +INF
C  IF THIS ROUTINE IS USED TO CONVERT UNIFORM RANDOM NUMBERS TO
C  GAUSSIAN, MAXIMUM RELATIVE ERROR IN THE DISTRIBUTION FUNCTION
C  DP/DX=EXP(-X**2/2)/SQRT(2*PI) IS LESS THAN 0.640E-3 EVERYWHERE
C  IN THE RANGE  2**(-31) < P0 < 1-2**31.  (MINIMAX APPROXIMATION)
C
      IMPLICIT REAL*8(A-H,O-Z)
C------------------------
      DATA PP1/0.334624883253D0/, QQ2/0.090230446775D0/,
     1     QQ3/0.049905685242D0/, QQ4/0.027852994157D0/,
     2     QQ5/0.015645650215D0/
      DATA A3/ 4.5585614D+01/, A2/ 2.1635544D+00/, A1/ 2.7724523D+00/,
     1     A0/ 2.5050240D+00/,
     2     B4/ 4.0314354D+02/, B3/-2.7713713D+02/, B2/ 7.9731883D+01/,
     3     B1/-1.4946512D+01/, B0/ 2.2157257D+00/,
     4     C4/ 4.1394487D+03/, C3/-1.5585873D+03/, C2/ 2.4648581D+02/,
     5     C1/-2.4719139D+01/, C0/ 2.4335936D+00/,
     6     D4/ 4.0895693D+04/, D3/-8.5400893D+03/, D2/ 7.4942805D+02/,
     7     D1/-4.1028898D+01/, D0/ 2.6346872D+00/,
     8     E4/ 3.9399134D+05/, E3/-4.6004775D+04/, E2/ 2.2566998D+03/,
     9     E1/-6.8317697D+01/, E0/ 2.8224654D+00/,
     O     F0/-8.1807613D-02/, F1/-2.8358733D+00/, F2/ 1.4902469D+00/
C------------------------
      GAUINV=0.D0
      P=P0-0.5D0
      P1=ABS(P)
      IF(P1.GE.PP1) GOTO 120
      P2=P**2
      GAUINV=(((A3*P2+A2)*P2+A1)*P2+A0)*P
      RETURN
  120 Q=0.5D0-P1
      IF(Q.LE.QQ2) GOTO 140
      GAUINV=(((B4*Q+B3)*Q+B2)*Q+B1)*Q+B0
      GOTO 200
  140 IF(Q.LE.QQ3) GOTO 150
      GAUINV=(((C4*Q+C3)*Q+C2)*Q+C1)*Q+C0
      GOTO 200
  150 IF(Q.LE.QQ4) GOTO 160
      GAUINV=(((D4*Q+D3)*Q+D2)*Q+D1)*Q+D0
      GOTO 200
  160 IF(Q.LE.QQ5) GOTO 170
      GAUINV=(((E4*Q+E3)*Q+E2)*Q+E1)*Q+E0
      GOTO 200
  170 IF(Q.LE.0D0) GOTO 900
      T=SQRT(-2D0*LOG(Q))
      GAUINV=T+F0+F1/(F2+T)
  200 IF(P.LT.0D0) GAUINV=-GAUINV
      RETURN
  900 WRITE(6,910) P0
  910 FORMAT(' (FUNC.GAUINV) INVALID INPUT ARGUMENT ',1PD20.13)
      RETURN
      END
C
C CERRF *************************************************
      SUBROUTINE CERRF(XX, YY, WX, WY)
*----------------------------------------------------------------------*
* Purpose:                                                             *
*   Modification of WWERF, double precision complex error function,    *
*   written at CERN by K. Koelbig.                                     *
* Input:                                                               *
*   XX, YY    (real)    Argument to CERF.                              *
* Output:                                                              *
*   WX, WY    (real)    Function result.                               *
*----------------------------------------------------------------------*
      use tfstk, only:ktfenanq
*---- Single precision version.
      IMPLICIT DOUBLE PRECISION (A-H,O-Y), INTEGER (I-N)
C     REAL RWX, RWY
      PARAMETER         (MWFLT = 1, MREAL = 3)
*     IMPORTANT: MWNAM must be an integer multiple of MWFLT.
      PARAMETER         (MCWRD = 4)
      PARAMETER         (MCNAM = 16, MWNAM = MCNAM / MCWRD)

      PARAMETER         (CC     = 1.12837 91670 9551D0)
      PARAMETER         (ONE    = 1.D0)
      PARAMETER         (TWO    = 2.D0)
      PARAMETER         (XLIM   = 5.33D0)
      PARAMETER         (YLIM   = 4.29D0)
      DIMENSION         RX(33), RY(33)

c     XX=REAL(ZI)
c     YY=AIMAG(ZI)

      if(ktfenanq(XX) .or. ktfenanq(YY))then
        WX=0.d0
        WY=0.d0
        return
      endif

      X = ABS(XX)
      Y = ABS(YY)

      IF (Y .LT. YLIM  .AND.  X .LT. XLIM) THEN
         Q = (ONE - Y / YLIM) * SQRT(ONE - (X/XLIM)**2)
         H = ONE / (3. 2* Q)
         NC =  7+ INT(23.0*Q)
         XL = H**( 1- NC)
         XH = Y + 0.5/H
         YH = X
         NU =  10+ INT(21.0*Q)
c         write(*,'(a,i5,1p5g12.4)')'cerrf ',NU,Q,Y,YLIM,X,XLIM
         RX(NU+1) = 0.
         RY(NU+1) = 0.

         DO 10 N = NU, 1, -1
            TX = XH + N * RX(N+1)
            TY = YH - N * RY(N+1)
            TN = TX*TX + TY*TY
            RX(N) = 0. 5* TX / TN
            RY(N) = 0. 5* TY / TN
   10    CONTINUE

         SX = 0.
         SY = 0.

         DO 20 N = NC, 1, -1
            SAUX = SX + XL
            SX = RX(N) * SAUX - RY(N) * SY
            SY = RX(N) * SY + RY(N) * SAUX
            XL = H * XL
   20    CONTINUE

         WX = CC * SX
         WY = CC * SY
      ELSE
         XH = Y
         YH = X
         RX(1) = 0.
         RY(1) = 0.

         DO 30 N = 9, 1, -1
            TX = XH + N * RX(1)
            TY = YH - N * RY(1)
            TN = TX*TX + TY*TY
            RX(1) = 0. 5* TX / TN
            RY(1) = 0. 5* TY / TN
   30    CONTINUE

         WX = CC * RX(1)
         WY = CC * RY(1)
      ENDIF

      IF(Y .EQ. 0.) WX = EXP(-X**2)
      IF(YY .LT. 0.) THEN
         WX = TWO * EXP(Y*Y-X*X) * COS(TWO*X*Y) - WX
         WY = - TWO * EXP(Y*Y-X*X) * SIN(TWO*X*Y) - WY
         IF(XX .GT. 0.) WY = -WY
      ELSE
         IF(XX .LT. 0.) WY = -WY
      ENDIF
*      print *,'wx= ',wx,' wy= ',wy
C     RWX = WX
C     RWY = WY
*      print *,'rwx= ',rwx,' rwy= ',rwy

      RETURN
      END
!
!
!
      real*8 FUNCTION bessi0(x)
      implicit none
      REAL*8 x
!Returns the modified Bessel function I0(x) for any real x.
      REAL*8 ax
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,
     & q8,q9,y !Accumulate polynomials in double precision.
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
      DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
     &     1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
      DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
     &     0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,
     &     0.2635537d-1,-0.1647633d-1,0.392377d-2/
      if (abs(x).lt.3.75) then
         y=(x/3.75)**2
         bessi0=p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
      else
         ax=abs(x)
         y=3.75/ax
         bessi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4
     &        +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
      endif
      return
      END

      real*8 FUNCTION bessk0(x)
      implicit none
      REAL*8 x
! USESbessi0
! Returns the modified Bessel function K0(x) for positive real x.
      REAL*8 bessi0
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
! Accumulate polynomials in double precision.
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
     &     0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
      DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
     &     -0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
      if (x.le.2.0) then ! Polynomial fit.
         y=x*x/4.0
         bessk0=(-log(x/2.0)*bessi0(x))+(p1+y*(p2+y*(p3+
     &        y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         y=(2.0/x)
         bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+
     &        y*(q4+y*(q5+y*(q6+y*q7))))))
      endif
      return
      END

      real*8 FUNCTION bessi1(x)
      implicit none
      REAL*8 x
! Returns the modified Bessel function I1(x) for any real x.
      REAL*8 ax
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
! Accumulate polynomials in double precision.
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
      DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
     &     0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
      DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
     &     -0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,
     &     -0.2895312d-1,0.1787654d-1,-0.420059d-2/
      if (abs(x).lt.3.75) then !Polynomial fit.
         y=(x/3.75)**2
         bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         ax=abs(x)
         y=3.75/ax
         bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+
     &        y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
         if(x.lt.0.)bessi1=-bessi1
      endif
      return
      END

      real*8 FUNCTION bessk1(x)
      implicit none
      REAL*8 x
! USES bessi1
! Returns the modified Bessel function K1(x) for positive real x.
      REAL*8 bessi1
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
! Accumulate polynomials in double precision.
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
     &     -0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
      DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1,
     &     0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
      if (x.le.2.0) then !Polynomial fit.
         y=x*x/4.0
         bessk1=(log(x/2.0)*bessi1(x))+(1.0/x)*(p1+y*(p2+
     &        y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         y=2.0/x
         bessk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+
     &        y*(q4+y*(q5+y*(q6+y*q7))))))
      endif
      return
      END

      real*8 FUNCTION bessk(n,x)
      implicit none
      INTEGER n
      REAL*8 x
! USESbessk0,bessk1
! Returns the modified Bessel function Kn(x) for positive x and n ≥ 2.
      INTEGER j
      REAL*8 bk,bkm,bkp,tox,bessk0,bessk1
      if(n.lt.2) then
         write(*,*) 'bad argument n in bessk'
         stop
      endif
      tox=2.0/x
      bkm=bessk0(x)
      bk=bessk1(x)
      do j=1,n-1
         bkp=bkm+j*tox*bk
         bkm=bk
         bk=bkp
      enddo
      bessk=bk
      return
      END

      real*8 FUNCTION bessi(n,x)
      implicit none
      INTEGER n,IACC
      REAL*8 x,BIGNO,BIGNI
      PARAMETER (IACC=40,BIGNO=1.0e10,BIGNI=1.0e-10)
!C USESbessi0Returns the modified Bessel function
!In(x) for any real x and n ≥ 2.
      INTEGER j,m
      REAL*8 bi,bim,bip,tox,bessi0
      if (n.lt.2) then
         write(*,*) 'bad argument n in bessi'
         stop
      endif
      if (x.eq.0.) then
         bessi=0.
      else
         tox=2.0/abs(x)
         bip=0.0
         bi=1.0
         bessi=0.
         m=2*((n+int(sqrt(float(IACC*n))))) !Downward recurrence from even m.
         ! Make IACC larger to increase accuracy.
         do j=m,1,-1
            bim=bip+float(j)*tox*bi
            bip=bi
            bi=bim
            if (abs(bi).gt.BIGNO) then
               bessi=bessi*BIGNI
               bi=bi*BIGNI
               bip=bip*BIGNI
            endif
            if (j.eq.n) bessi=bip
         enddo
         bessi=bessi*bessi0(x)/bi
         if (x.lt.0..and.mod(n,2).eq.1) bessi=-bessi
      endif
      return
      END

      SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp)
      implicit none
      INTEGER MAXIT
      REAL*8 ri,rip,rk,rkp,x,xnu,XMIN
      DOUBLE PRECISION EPS,FPMIN,PI
      PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2.,
     &     PI=3.141592653589793d0)
!

      INTEGER i,l,nl
      DOUBLE PRECISION a,a1,b,c,d,del,del1,delh,dels,e,f,fact,
     &     fact2,ff,gam1,gam2,gammi,gampl,h,p,pimu,q,q1,q2,
     &     qnew,ril,ril1,rimu,rip1,ripl,ritemp,rk1,rkmu,rkmup,
     &     rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2
      if(x.le.0..or.xnu.lt.0.) then
         write(*,'(A,1P,2E11.3,A)')
     &        'bad arguments in bessik   ',x,xnu,'<0.'
         stop
      endif
      nl=int(xnu+.5d0)
      xmu=xnu-nl
      xmu2=xmu*xmu
      xi=1.d0/x
      xi2=2.d0*xi
      h=xnu*xi
      if(h.lt.FPMIN) h=FPMIN
      b=xi2*xnu
      d=0.d0
      c=h
      do i=1,MAXIT
         b=b+xi2
         d=1.d0/(b+d)
         c=b+1.d0/c
         del=c*d
         h=del*h
         if(abs(del-1.d0).lt.EPS)goto 1
      enddo

      write(*,*) '***** x too large in bessik; try asymp. expan. *****'

 1    continue
      ril=FPMIN
      ripl=h*ril
      ril1=ril
      rip1=ripl
      fact=xnu*xi
      do l=nl,1,-1
         ritemp=fact*ril+ripl
         fact=fact-xi
         ripl=fact*ritemp+ril
         ril=ritemp
      enddo
      f=ripl/ril
      if(x.lt.XMIN) then
         x2=.5d0*x
         pimu=PI*xmu
         if(abs(pimu).lt.EPS)then
            fact=1.d0
         else
            fact=pimu/sin(pimu)
         endif
         d=-log(x2)
         e=xmu*d
         if(abs(e).lt.EPS)then
            fact2=1.d0
         else
            fact2=sinh(e)/e
         endif
!         write(*,*) xmu
         call beschb(xmu,gam1,gam2,gampl,gammi)
         ff=fact*(gam1*cosh(e)+gam2*fact2*d)
         sum=ff
         e=exp(e)
         p=0.5d0*e/gampl
         q=0.5d0/(e*gammi)
         c=1.d0
         d=x2*x2
         sum1=p
         do i=1,MAXIT
            ff=(i*ff+p+q)/(i*i-xmu2)
            c=c*d/i
            p=p/(i-xmu)
            q=q/(i+xmu)
            del=c*ff
            sum=sum+del
            del1=c*(p-i*ff)
            sum1=sum1+del1
            if(abs(del).lt.abs(sum)*EPS) goto 2
         enddo
         write(*,*) '****** bessk series failed to converge ******'
 2       continue
         rkmu=sum
         rk1=sum1*xi2
      else
         b=2.d0*(1.d0+x)
         d=1.d0/b
         delh=d
         h=delh
         q1=0.d0
         q2=1.d0
         a1=.25d0-xmu2
         c=a1
         q=c
         a=-a1
         s=1.d0+q*delh
         do i=2,MAXIT
            a=a-2*(i-1)
            c=-a*c/i
            qnew=(q1-b*q2)/a
            q1=q2
            q2=qnew
            q=q+c*qnew
            b=b+2.d0
            d=1.d0/(b+a*d)
            delh=(b*d-1.d0)*delh
            h=h+delh
            dels=q*delh
            s=s+dels
            if(abs(dels/s).lt.EPS) goto 3
         enddo
         write(*,*) '***** bessik: failure to converge in cf2 *****'
 3       continue
         h=a1*h
         rkmu=sqrt(PI/(2.d0*x))*exp(-x)/s
         rk1=rkmu*(xmu+x+.5d0-h)*xi
      endif
      rkmup=xmu*xi*rkmu-rk1
      rimu=xi/(f*rkmu-rkmup)
      ri=(rimu*ril1)/ril
      rip=(rimu*rip1)/ril
      do i=1,nl
         rktemp=(xmu+i)*xi2*rk1+rkmu
         rkmu=rk1
         rk1=rktemp
      enddo
      rk=rkmu
      rkp=xnu*xi*rkmu-rk1
      return
      END

      SUBROUTINE beschb(x,gam1,gam2,gampl,gammi)
      INTEGER NUSE1,NUSE2
      DOUBLE PRECISION gam1,gam2,gammi,gampl,x
      PARAMETER (NUSE1=7,NUSE2=8)
! USESchebev
! Evaluates NC1 and NC2 by Chebyshev expansion for |x| ≤ 1/2.
! Also returns 1/NC(1 + x) and1/NC(1 − x). If converting to
! double precision, set NUSE1 = 7, NUSE2 = 8.
      REAL*8 xx,c1(7),c2(8),chebev
      SAVE c1,c2
      DATA c1/-1.142022680371168d0,6.5165112670737d-3,3.087090173086d-4,
     &     -3.4706269649d-6,6.9437664d-9,3.67795d-11,-1.356d-13/
      DATA c2/1.843740587300905d0,-7.68528408447867d-2,
     &     1.2719271366546d-3,-4.9717367042d-6,-3.31261198d-8,
     &     2.423096d-10,-1.702d-13,-1.49d-15/
      xx=8.d0*x*x-1.d0
      gam1=chebev(-1.d0,1.d0,c1,NUSE1,xx)
      gam2=chebev(-1.d0,1.d0,c2,NUSE2,xx)
      gampl=gam2-x*gam1
      gammi=gam2+x*gam1
      return
      END

      real*8 FUNCTION chebev(a,b,c,m,x)
      INTEGER m
      REAL*8 a,b,x,c(m)
      INTEGER j
      REAL*8 d,dd,sv,y,y2
      if ((x-a)*(x-b).gt.0.)
     &     write(*,*) '**** x not in range in chebev ****'
      d=0.
      dd=0.
      y=(2.*x-a-b)/(b-a)
      y2=2.*y
      do j=m,2,-1
         sv=d
         d=y2*d-dd+c(j)
         dd=sv
      enddo
      chebev=y*d-dd+0.5*c(1)
      return
      END


SUBROUTINE aslegf(l,m,sgm,mu,plm1m,plm,plmp1)

! ---------------------------------------------
!
! Uses a recursive relationship to compute the
!  next associated Legendre function
!
! ---------------------------------------------

IMPLICIT NONE

INTEGER, INTENT(IN) :: l, m, sgm
REAL*8, INTENT(IN) :: mu, plm1m, plm
REAL*8, INTENT(OUT) :: plmp1

plmp1 = (1.0/SQRT(1.0-mu**2))*((l-m+1)*sgm*mu*plm - (l+m-1)*plm1m)

END SUBROUTINE aslegf