C
C   Quick implementation of the Sherpa beta1D model as a user model
C
C   See c_version/gauss2d_model_c.c for comments on the required
C   routines and the parameter values
C

C   Initialize the model. As we do not need to allocate anything
C   here we just return 0 (success).
C
      integer function ascfitUserModelInit()
      implicit none
      ascfitUserModelInit = 0
      end

C   Set up the parameter values to their initial values
C
      integer function ascfitUserModelSetParamValues(i,value, min, max,
     :     name,  descr, units, state, nameLen, descLen, unitsLen)
	
      implicit none

      integer i, state, nameLen, descLen, unitsLen
      double precision value, min, max
      character*(*) name, descr, units

      character*5  fwhm, xpos, ypos, ellip, theta, ampl
      parameter(fwhm = 'fwhm', xpos = 'xpos', ypos = 'ypos',
     :     ellip = 'ellip', theta = 'theta', ampl = 'ampl')

      ascfitUserModelSetParamValues = 0

C
C note: use 110 rather than 120 for exponents of min/max values
C       as 120 seems to cause problems
C
      if (i.eq.1) then
         value = 10.0d0
         min = 1.0d-110
         max = 1.0d110
         name(1:4) = fwhm
         state = 1
      else if (i.eq.2) then
         value = 0.0d0
         min = -1.0d110
         max = 1.0d110
         name(1:4) = xpos
         state = 1
      else if (i.eq.3) then
         value = 0.0d0
         min = -1.0d110
         max = 1.0d110
         name(1:4) = ypos
         state = 1
      else if (i.eq.4) then
         value = 0.0
         min = 0.0
         max = 0.999
         name(1:5) = ellip
         state = 0
      else if (i.eq.5) then
         value = 0.0
         min = 0.0
         max = 6.2832
         name(1:5) = theta
         state = 0
      else if (i.eq.6) then
         value = 1.0
         min = -1.0d110
         max = 1.0d110
         name(1:4) = ampl
         state = 1
      else
         ascfitUserModelSetParamValues = 1
      end if
      end

C   Evaluate the model and fill in the outValues array
C
      integer function ascfitUserModelFunction(parameterList,
     :     numberOfDimensions, numberOfData, outValues,
     :     data1, data2, data3, data4, data5, data6, data7)

      implicit none

      integer numberOfDimensions
      integer numberOfData

      double precision parameterList(numberOfData)
      double precision data1(numberOfData), data2(numberOfData),
     :     data3(numberOfData), data4(numberOfData),
     :     data5(numberOfData), data6(numberOfData),
     :     data7(numberOfData)
      double precision outValues(numberOfData)

      double precision fwhm, xpos, ypos, ellip, theta, ampl

      double precision dx, dy, xnew, ynew, radius, eterm
      double precision factor

      integer i;

C   Sanity checks
C
      if ((6.ne.parameterList(1)) .or.
     :     (2.ne.numberOfDimensions)) then
         ascfitUserModelFunction = 1
      else

         fwhm  = parameterList(2)
         xpos  = parameterList(3)
         ypos  = parameterList(4)
         ellip = parameterList(5)
         theta = parameterList(6)
         ampl  = parameterList(7)

C
C   See 'ahelp gauss2D'. No significant optimisation has
C   been attempted here.
C
         eterm = 1.0d0 - ellip
         factor = -2.0d0 * log(4.0d0)
         do i = 1, numberOfData, 1

            dx = data1(i) - xpos
            dy = data2(i) - ypos

            if (ellip .gt. 0.0d0) then
               xnew = dx * dcos(theta) + dy*dsin(theta)
               ynew = dy * dcos(theta) - dx*dsin(theta)
               radius = sqrt(xnew*xnew*eterm*eterm + ynew*ynew) / eterm
            else
               radius = sqrt(dx*dx + dy*dy)
            endif

            outValues(i) =
     :           ampl * exp( (radius/fwhm)*(radius/fwhm)*FACTOR )
         end do

         ascfitUserModelFunction = 0
      end if
      end

C   De-allocate any resources allocated by ascfitUserModelInit
C   
      subroutine ascfitUserModelCleanup()
      return
      end
  
