!	Find the size specifications for the quadrature points.
!	dimpoints gives the number  of points per diemnsion if a
!	grid is used.
!	If a grid is used, then the grid has ngrid points.
!	In all cases, the number of quadrature points is nquad.
!	cross-polytope quadrature is used if cross is .true.
!	Each grid dimension has the same number of points if
!	equalpoints is .true.
!	If even is .true. and a grid is used, then
!		evenly spaced quadrature points are used.
!	A complete grid is used if a grid is used and fullgrid is .true.
!	If guasshermite is .true., even is .false., and a grid is used,
!		then Gauss-Hermite quadrature points and weights are
!		produced.
!	A grid is used if grid is .true. and cross and simplex are .true.
!	normal indicates that the latent vector has a normal distribution.
!	Simplex quadrature is used if simplex is .true. and cross is .false.
!	The subroutine returns grid and fullgrid as .false. if  simplex  or
!		cross is .true.
!	The subroutine returns simplex as .false. if cross is .true.
!	In the default case, cross is .false., even is .false., fullgrid is .true.,
!		gausshermite is .true., grid is .true., and simplex is .false.
!	The default value of each element of dimpoints is 5 if Gauss-Hermite
!		quadrature is used and 6 if a grid is used and Gauss-Hermite
!		quadrature is not used.  If Gauss-Hermite quadrature is used, then no
!		element of dimpoints is permitted to exceed 30.
!		Any element of dimpoints is forced to be at least 2 if a grid is used.
!	If a grid is used but nquad is less than 2, then fullgrid is set to .true.
!	If nquad exceeds ngrid and a grid is used, then nquad is set to ngrid.
!	If a full grid is used, then nquad is set to ngrid.
!	If cross is .true., then nquad is set to twice size(dimpoints).
!	If simplex is returned as .true., then nquad is size(dimpoints)+1.
!	If simplex, cross, and grid are .false., then nquad must be given and
!		at least 2.  Otherwise, processing ends with an error message.

subroutine getquadsize(dimpoints,ngrid,nquad,&
	cross,equalpoints,even,fullgrid,gausshermite,grid,normal,simplex,&
	pspread)

implicit none

interface
!	Obtain number of quadrature points for each dimension.
!	The result is placed in dimpoints.
	subroutine getdimpoints(dimpoints)
		implicit none
		integer,intent(out)::dimpoints(:)
	end subroutine getdimpoints
end interface

integer,intent(out)::dimpoints(:),ngrid,nquad
logical,intent(out)::cross,equalpoints,even,fullgrid,gausshermite,grid,normal,simplex
real(kind=8),intent(out)::pspread
!	dimsize is the number of points per dimension.
!	io is the flag for input errors.
integer,parameter::maxquad=30
integer::dimsize,io

namelist/quadsize/dimsize,nquad,cross,equalpoints,even,fullgrid,gausshermite,grid,normal,simplex,&
		pspread
!	Default values.
dimsize=5
nquad=0
cross=.false.
equalpoints=.true.
even=.false.
fullgrid=.true.
gausshermite=.true.
grid=.true.
normal=.true.
simplex=.false.

pspread=0.0_8

read(*,nml=quadsize,iostat=io)
if(io/=0) stop "Quadrature points not successfully specified."
!	Resolve discrepancies.
if(even)gausshermite=.false.
if(cross.or.simplex)grid=.false.
if(cross)simplex=.false.
if(.not.grid)then
	even=.false.
	fullgrid=.false.
	gausshermite=.false.
!	Count points.
	if(cross) nquad=2*size(dimpoints)
	if(simplex) nquad=size(dimpoints)+1

else
	if(equalpoints)then
		if(dimsize<1)dimsize=5
		if(gausshermite)dimsize=min(dimsize,maxquad)
		dimpoints=dimsize
	else
		call getdimpoints(dimpoints)
		if(gausshermite)dimpoints=min(dimpoints,maxquad)
	end if
	ngrid=product(dimpoints)
	if(fullgrid.or.nquad<2)then
		nquad=ngrid
	else
		nquad=min(nquad,ngrid)
		if(nquad==ngrid)fullgrid=.true.
	end if
end if

if(nquad<1) stop "Insufficient quadrature points"
return
end subroutine getquadsize


program main
    ! 2D model of crystal growth based on diffusion-limited aggregation
    implicit none
    integer :: clock, n, i
    integer, allocatable :: seed(:)
    integer, parameter :: map_size_x = 1024, map_size_y = 1024, n_particle = 1000
    integer :: map(0:map_size_x - 1, 0:map_size_y - 1)
    integer :: x, y

    ! seed initialization
    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(put = seed)

    ! map initialization
    do x = 0, map_size_x - 1
        do y = 0, map_size_y - 1
            map(x, y) = 0
        end do
    end do
    map(map_size_x / 2, map_size_y / 2) = 1
    open(unit = 1, file = 'crystal.txt', status = 'unknown')
    write(1, '(2i5)') map_size_x / 2, map_size_y / 2
    close(1)

    ! particle aggregation
    do i = 1, n_particle
        do while (.true.)
            call INITIAL_POSITION(x, y, map_size_x, map_size_y)
            if (map(x, y) == 0) exit
        end do
        do while (.true.)
            call RANDOM_WALK(x, y, map_size_x, map_size_y)
            if ((map(modulo(x - 1, map_size_x), y) == 1) &
                .or. (map(modulo(x + 1, map_size_x), y) == 1) &
                .or. (map(x, modulo(y - 1, map_size_y)) == 1) &
                .or. (map(x, modulo(y + 1, map_size_y))) == 1) then
                map(x, y) = 1
                exit
            end if
        end do
        open(unit = 1, file = 'crystal.txt', status = 'old', position = 'append')
        write(1, '(2i5)') x, y
        close(1)
    end do
    close(1)
end program main

subroutine INITIAL_POSITION(x, y, map_size_x, map_size_y)
    real :: r
    integer, intent(inout) :: x, y
    integer, intent(in) :: map_size_x, map_size_y

    call RANDOM_NUMBER(r)
    if (r < .25d0) then
        x = 0
        y = floor(r * 4.d0 * dble(map_size_y))
    elseif (r < .5d0) then
        x = map_size_x - 1
        y = floor((r - .25d0) * 4.d0 * dble(map_size_y))
    elseif (r < .75d0) then
        x = floor((r - .5d0) * 4.d0 * dble(map_size_x))
        y = 0
    else
        x = floor((r - .75d0) * 4.d0 * dble(map_size_x))
        y = map_size_y - 1
    end if
end subroutine INITIAL_POSITION

subroutine RANDOM_WALK(x, y, map_size_x, map_size_y)
    real :: r
    integer, intent(inout) :: x, y
    integer, intent(in) :: map_size_x, map_size_y

    call RANDOM_NUMBER(r)
    if (r < .25d0) then
        x = modulo(x - 1, map_size_x)
    elseif (r < .5d0) then
        x = modulo(x + 1, map_size_x)
    elseif (r < .75d0) then
        y = modulo(y - 1, map_size_y)
    else
        y = modulo(y + 1, map_size_y)
    end if
end subroutine RANDOM_WALK


c
c-------------------------------------------------------------------------------------
c
       subroutine prepbigstep(nvar,naux,lcheck,mptr,nx,midub,
     .                       valbgc,auxbgc,mi2tot)

       use amr_module
       implicit double precision (a-h,o-z)

       double precision valdub(nvar,midub)
       double precision auxdub(naux,midub)
       double precision valbgc(nvar,mi2tot)
       double precision auxbgc(naux,mi2tot)
       dimension fp(nvar,mi2tot)
       dimension fm(nvar,mi2tot)

       !for setaux timing
       integer :: clock_start, clock_finish, clock_rate
       real(kind=8) :: cpu_start, cpu_finish

          hx  = hxposs(lcheck)
          hx2 = 2.d0*hx
          dt  = possk(lcheck)
          dt2 = 2. * dt
          time  = rnode(timemult,mptr)
          tpre  = time - dt

          mitot  = nx + 2*nghost
          ng2    = 2*nghost
          locold = node(store2,mptr)
          xlow   = rnode(cornxlo,mptr) - nghost*hx2
c

c         # transfer soln. into grid with twice the ghost cells
          call copysol(valdub,alloc(locold),nvar,mitot,
     1              nghost,midub,ng2)

c
          if (naux .gt. 0) then
              xl     = rnode(cornxlo, mptr)
              mx = midub - 4*nghost
              auxdub = NEEDS_TO_BE_SET  ! signal that needs a val

              call system_clock(clock_start, clock_rate)
              call cpu_time(cpu_start)
              call setaux(2*nghost,mx,xl,hx,
     &                    naux,auxdub)
              call system_clock(clock_finish, clock_rate)
              call cpu_time(cpu_finish)
              timeSetaux = timeSetaux + clock_finish - clock_start
              timeSetauxCPU = timeSetauxCPU + cpu_finish - cpu_start

              call auxcoarsen(auxdub,midub,
     1                     auxbgc,mi2tot,naux,auxtype)
          endif

c         # fill it - use enlarged (before coarsening) aux arrays
          call bound(tpre,nvar,ng2,valdub,midub,mptr,
     1               auxdub,naux)

c         coarsen by 2 in every direction
          call coarsen(valdub,midub,
     1                 valbgc,mi2tot,nvar)

          cfl_level = 0.d0   ! normally set in advanc
          call stepgrid(valbgc,fm,fp,
     1                mi2tot,nghost,
     2                dt2,dtnew2,hx2,nvar,
     3                xlow,tpre,mptr,naux,auxbgc)

c         update counts for error estimation work
          evol = evol + (nx/2)
           return
           end


! Convert and scale between "true" (material) parameters (mpar) used for analysis and the scaled variables (xvar) used for optimization
! glob%ipar_sctype controls how the parameters are scaled:
! 0: No scaling
! 1: Linear scaling so that between 0 and 1
! 2: Log scaling, so that between 0 and 1
! 3: Inverse scaling, then linear scaling so that between 0 and 1
!
! To add further scaling options:
! Add in routines true_to_scaled and scaled_to_true
! If this scaling does not produce a range (0,1), then you should treat this is in the
! get_lower_bounds and get_upper_bounds functions

module convert_mpar_mod
    use types_mod
    use output_mod
    use usr_interface_mod
    implicit none

    private
    ! xvar is the array of parameters seen by the optimization routines
    ! mpar is the array of parameters seen by the material routine
    ! ipar is the array of parameters given by the input file
    public :: xvar_to_mpar
    public :: ipar_to_xvar
    public :: xvar_to_ipar
    public :: get_lower_bounds, get_upper_bounds

    contains

subroutine xvar_to_ipar(ipar, xvar, glob)
    implicit none
    type(glob_typ)      :: glob
    double precision    ::  ipar(:), xvar(:)
    procedure(user_xvar_to_ipar_template),pointer:: user_xvar_to_ipar ! Addresss to user subroutine

    ipar = glob%ipar_init
    if (glob%user_scale) then
        user_xvar_to_ipar => glob%xvar_to_ipar_addr
        call user_xvar_to_ipar(ipar, xvar, glob%ipar_optim, glob%ipar_min, glob%ipar_max)
    else
        ! "un-scale" the optimized material parameters, and put them on the correct place in mpar
        ipar(glob%ipar_optim) = scaled_to_true(xvar, glob)
    endif

end subroutine xvar_to_ipar

subroutine xvar_to_mpar(mpar, xvar, glob)
    implicit none
    type(glob_typ)      ::  glob
    double precision    ::  mpar(:), xvar(:)
    procedure(user_xvar_to_mpar_template),pointer:: user_xvar_to_mpar ! Addresss to user subroutine

    mpar = glob%ipar_init
    if (glob%user_scale) then
        user_xvar_to_mpar => glob%xvar_to_mpar_addr
        call user_xvar_to_mpar(mpar, glob%ipar_init, xvar, glob%ipar_optim, glob%ipar_min, glob%ipar_max)
    else
        ! "un-scale" the optimized material parameters, and put them on the correct place in mpar
        mpar(glob%ipar_optim) = scaled_to_true(xvar, glob)
    endif

end subroutine xvar_to_mpar

subroutine ipar_to_xvar(ipar, xvar, glob)
    implicit none
    type(glob_typ)      ::  glob
    double precision    ::  ipar(:), xvar(:)
    procedure(user_ipar_to_xvar_template),pointer:: user_ipar_to_xvar ! Addresss to user subroutine

    if (glob%user_scale) then
        user_ipar_to_xvar => glob%ipar_to_xvar_addr
        call user_ipar_to_xvar(ipar, xvar, glob%ipar_optim, glob%ipar_min, glob%ipar_max)
    else
        xvar = true_to_scaled(ipar(glob%ipar_optim), glob)
    endif

end subroutine ipar_to_xvar

function true_to_scaled(true_par, glob) result(scal_par)
implicit none
    double precision, parameter     :: invtol = 1.d-30  !Minimum value to allow normal inverse scaling
    double precision    :: true_par(:)
    type (glob_typ)     :: glob
    double precision    :: scal_par(size(true_par))
    integer             :: k1, sctype
    double precision    :: minval, maxval

    do k1=1,size(true_par)
        sctype = glob%ipar_sctype(k1)

        minval = glob%ipar_min(k1) ! minimum value
        maxval = glob%ipar_max(k1) ! maximum value
        if      (sctype==0) then    ! No scaling
            scal_par(k1) = true_par(k1)
        elseif  (sctype==1) then    ! Linear scaling
            scal_par(k1) = (true_par(k1)-minval)/(maxval-minval)
        elseif  (sctype==2) then    ! Log scaling
            if ((minval<=0.d0).or.(maxval<=0.d0)) then
                call write_output('Parameter nr. '//int2str(k1)//': Range values must greater than zero for log scaling', 'error', 'opt')
            endif
            scal_par(k1) = (log(true_par(k1)) - log(minval)) / (log(maxval) - log(minval))
        elseif  (sctype==3) then    ! Inverse scaling
            if ((abs(minval)<invtol).or.(abs(maxval)<invtol)) then
                call write_output('Parameter nr. '//int2str(k1)//': Range values cannot be too close to zero for inverse scaling', 'error', 'opt', halt=.false.)
                call write_output('Min abs value is '//dbl2str(invtol)//', current min = '//dbl2str(minval)//' and max = '//dbl2str(maxval), 'error', 'opt', loc=.false.)
            endif
            if (abs(true_par(k1))<invtol) then
                call write_output('Parameter nr. '//int2str(k1)//'= '//dbl2str(true_par(k1))//'. Inverse scaling is dangerous', 'error', 'opt', halt=.false.)
                call write_output('Setting parameter to (almost) infinity', 'error', 'opt', loc=.false.)
                scal_par(k1) = sign(1.d0, true_par(k1))*huge(1.d0)
            else
                scal_par(k1) = 1/true_par(k1)
            endif
            scal_par(k1) = (scal_par(k1)-1/maxval)/(1/minval-1/maxval)
        else
            call write_output('Parameter nr. '//int2str(k1)//': ipar_sctype = '//int2str(sctype)//' is not supported', 'error', 'opt')
        endif

    enddo

end function true_to_scaled

function scaled_to_true(scal_par, glob) result(true_par)
implicit none
    double precision, parameter     :: invtol = 1.d-30  !Minimum value to allow normal inverse scaling
    double precision    :: scal_par(:)
    type (glob_typ)     :: glob
    double precision    :: true_par(size(scal_par))
    integer             :: k1, sctype
    double precision    :: minval, maxval

    do k1=1,size(scal_par)
        sctype = glob%ipar_sctype(k1)
        minval = glob%ipar_min(k1) ! minimum value
        maxval = glob%ipar_max(k1) ! maximum value
        if      (sctype==0) then    ! No scaling
            true_par(k1) = scal_par(k1)
        elseif  (sctype==1) then    ! Linear scaling
            true_par(k1) = scal_par(k1)*(maxval-minval) + minval
        elseif  (sctype==2) then    ! Log scaling
            true_par(k1) = minval*(maxval/minval)**(scal_par(k1))
        elseif  (sctype==3) then    ! Inverse scaling
            true_par(k1) = scal_par(k1)*(1/minval-1/maxval) + 1/maxval
            if (abs(true_par(k1))<invtol) then
                call write_output('Parameter nr. '//int2str(k1)//'= '//dbl2str(true_par(k1))//'. Inverse scaling is dangerous', 'error', 'opt', halt=.false.)
                call write_output('Setting parameter to (almost) infinity', 'error', 'opt', loc=.false.)
                true_par(k1) = sign(1.d0, true_par(k1))*huge(1.d0)
            else
                true_par(k1) = 1/true_par(k1)
            endif
        else
            call write_output('Parameter nr. '//int2str(k1)//': ipar_sctype = '//int2str(sctype)//' is not supported', 'error', 'opt')
        endif
    enddo

end function scaled_to_true

function get_lower_bounds(glob) result(lb)
implicit none
    type(glob_typ)       :: glob
    double precision    :: lb(size(glob%ipar_sctype))
    integer             :: k1

    lb = 0.d0   ! Default
    do k1=1,size(lb)
        if (glob%ipar_sctype(k1)==0) then !parameters not scaled, use initial range
            lb(k1) = glob%ipar_min(k1)
        endif
    enddo
end function

function get_upper_bounds(glob) result(ub)
implicit none
    type(glob_typ)       :: glob
    double precision    :: ub(size(glob%ipar_sctype))
    integer             :: k1

    ub = 1.d0   ! Default
    do k1=1,size(ub)
        if (glob%ipar_sctype(k1)==0) then !parameters not scaled, use initial range
            ub(k1) = glob%ipar_max(k1)
        endif
    enddo
end function

end module convert_mpar_mod


      subroutine pc2ev(xget,yget,x,nx,y,ny,ilinx,iliny,
     >                   f,inf2,ict,fval,ier)
C
C  evaluate a piecewise bilinear interpolant on a rectilinear
C  grid -- this is C1 in both directions.
C
C  this subroutine calls two subroutines:
C     herm2xy  -- find cell containing (xget,yget)
C     pc2fcn -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
      real xget,yget                    ! target of this interpolation
      real x(nx)                        ! ordered x grid
      real y(ny)                        ! ordered y grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
      integer iliny                     ! iliny=1 => assume y evenly spaced
C
      real f(inf2,ny)                   ! function data
C
C       f 2nd dimension inf2 must be .ge. nx
C       contents of f:
C
C  f(i,j) = f @ x(i),y(j)
C
      integer ict(4)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C  ict(3)=1 -- return df/dy  (0, don't)
C  ict(4)=1 -- return d2f/dxdy (0, don't)
C
C output arguments:
C =================
C
      real fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C  fval(3) receives the third output (depends on ict(...) spec)
C  fval(4) receives the fourth output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1,1,1]
C   on output fval= [f,df/dx,df/dy,d2f/dxdy]
C
C    on input ict = [1,0,0,0]
C   on output fval= [f] ... elements 2 & 3 & 4 never referenced
C
C    on input ict = [0,1,1,0]
C   on output fval= [df/dx,df/dy] ... element 3 & 4 never referenced
C
C    on input ict = [0,0,1,0]
C   on output fval= [df/dy] ... elements 2 & 3 & 4 never referenced.
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer, dimension(1) :: i, j  ! cell indices
C
C  normalized displacement from (x(i),y(j)) corner of cell.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C    yparam=0 @y(j)  yparam=1 @y(j+1)
C
      real, dimension(1) :: xparam, yparam
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i)), hyi = 1/(y(j+1)-y(j))
C
      real, dimension(1) :: hx, hy
      real, dimension(1) :: hxi, hyi
C
C  0 .le. xparam .le. 1
C  0 .le. yparam .le. 1
C
C---------------------------------------------------------------------
C
      call herm2xy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i,j,xparam,yparam,hx,hxi,hy,hyi,ier)
      if(ier.ne.0) return
c
      call pc2fcn(ict,1,1,
     >   fval,i,j,xparam,yparam,hx,hxi,hy,hyi,f,inf2,ny)
C
      return
      end
C---------------------------------------------------------------------
C  evaluate piecewise bilinear function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine pc2fcn(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
      integer ict(4)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec),jj(ivec)         ! target cells (i,j)
      real xparam(ivec),yparam(ivec)
                          ! normalized displacements from (i,j) corners
C
      real hx(ivec),hy(ivec)            ! grid spacing, and
      real hxi(ivec),hyi(ivec)          ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      real fin(inf2,ny)                 ! interpolant data (cf "pc2ev")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  pc2ev comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii,jj and parameter inputs
C     xparam,yparam,hx,hxi,hy,hyi are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C
      real sum
      integer v
C
C   ...in x direction
C
      do v=1,ivec
         i=ii(v)
         j=jj(v)
c
         xp=xparam(v)
         xpi=1.0-xp
C
C   ...in y direction
C
         yp=yparam(v)
         ypi=1.0-yp
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            sum=ypi*(xpi*fin(i,j)+xp*fin(i+1,j))
     >         + yp*(xpi*fin(i,j+1)+xp*fin(i+1,j+1))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            sum=ypi*(fin(i+1,j)-fin(i,j))
     >         + yp*(fin(i+1,j+1)-fin(i,j+1))
            fval(v,iadr)=sum*hxi(v)
C
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            iadr=iadr+1
C
            sum=xpi*(fin(i,j+1)-fin(i,j))
     >         + xp*(fin(i+1,j+1)-fin(i+1,j))
            fval(v,iadr)=sum*hyi(v)
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dxdy:
C
            iadr=iadr+1
C
            sum=fin(i+1,j+1)-fin(i,j+1)-fin(i+1,j)+fin(i,j)
            fval(v,iadr)=sum*hxi(v)*hyi(v)
         endif
C
      enddo                             ! vector loop
C
      return
      end
C---------------------------------------------------------------------
C  evaluate piecewise bilinear function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C    --optimized for VARIATION along x axis ONLY--
C
      subroutine pc2fcnx(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
      integer ict(4)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec),jj               ! target cells (i,j)
      real xparam(ivec),yparam
                          ! normalized displacements from (i,j) corners
C
      real hx(ivec),hy                  ! grid spacing, and
      real hxi(ivec),hyi                ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      real fin(inf2,ny)                 ! interpolant data (cf "pc2ev")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  pc2ev comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii,jj and parameter inputs
C     xparam,yparam,hx,hxi,hy,hyi are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C
      real sum
      integer v
C
C   ...in x direction
C
      j=jj
C
C   ...in y direction
C
      yp=yparam
      ypi=1.0-yp
C
      do v=1,ivec
         i=ii(v)
c
         xp=xparam(v)
         xpi=1.0-xp
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            sum=ypi*(xpi*fin(i,j)+xp*fin(i+1,j))
     >         + yp*(xpi*fin(i,j+1)+xp*fin(i+1,j+1))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            sum=ypi*(fin(i+1,j)-fin(i,j))
     >         + yp*(fin(i+1,j+1)-fin(i,j+1))
            fval(v,iadr)=sum*hxi(v)
C
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            iadr=iadr+1
C
            sum=xpi*(fin(i,j+1)-fin(i,j))
     >         + xp*(fin(i+1,j+1)-fin(i+1,j))
            fval(v,iadr)=sum*hyi
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dxdy:
C
            iadr=iadr+1
C
            sum=fin(i+1,j+1)-fin(i,j+1)-fin(i+1,j)+fin(i,j)
            fval(v,iadr)=sum*hxi(v)*hyi
         endif
C
      enddo                             ! vector loop
C
      return
      end


*DECK DQAGP
      SUBROUTINE DQAGP (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, RESULT,
     +   ABSERR, NEVAL, IER, LENIW, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  DQAGP
C***PURPOSE  The routine calculates an approximation result to a given
C            definite integral I = Integral of F over (A,B),
C            hopefully satisfying following claim for accuracy
C            break points of the integration interval, where local
C            difficulties of the integrand may occur (e.g.
C            SINGULARITIES, DISCONTINUITIES), are provided by the user.
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1
C***TYPE      DOUBLE PRECISION (QAGP-S, DQAGP-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE,
C             GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE,
C             SINGULARITIES AT USER SPECIFIED POINTS
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a definite integral
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the integrand
C                     Function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Lower limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            NPTS2  - Integer
C                     Number equal to two more than the number of
C                     user-supplied break points within the integration
C                     range, NPTS.GE.2.
C                     If NPTS2.LT.2, The routine will end with IER = 6.
C
C            POINTS - Double precision
C                     Vector of dimension NPTS2, the first (NPTS2-2)
C                     elements of which are the user provided break
C                     points. If these points do not constitute an
C                     ascending sequence there will be an automatic
C                     sorting.
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     The routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine.
C                             The estimates for integral and error are
C                             less reliable. it is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. one can allow more
C                             subdivisions by increasing the value of
C                             LIMIT (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties. If
C                             the position of a local difficulty can be
C                             determined (i.e. SINGULARITY,
C                             DISCONTINUITY within the interval), it
C                             should be supplied to the routine as an
C                             element of the vector points. If necessary
C                             an appropriate special-purpose integrator
C                             must be used, which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 4 The algorithm does not converge.
C                             roundoff error is detected in the
C                             extrapolation table.
C                             It is presumed that the requested
C                             tolerance cannot be achieved, and that
C                             the returned RESULT is the best which
C                             can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. it must be noted that
C                             divergence can occur with any other value
C                             of IER.GT.0.
C                         = 6 The input is invalid because
C                             NPTS2.LT.2 or
C                             break points are specified outside
C                             the integration range or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero.  Except when LENIW or LENW or NPTS2
C                             is invalid, IWORK(1), IWORK(LIMIT+1),
C                             WORK(LIMIT*2+1) and WORK(LIMIT*3+1)
C                             are set to zero.
C                             WORK(1) is set to A and WORK(LIMIT+1)
C                             to B (where LIMIT = (LENIW-NPTS2)/2).
C
C         DIMENSIONING PARAMETERS
C            LENIW - Integer
C                    Dimensioning parameter for IWORK
C                    LENIW determines LIMIT = (LENIW-NPTS2)/2,
C                    which is the maximum number of subintervals in the
C                    partition of the given integration interval (A,B),
C                    LENIW.GE.(3*NPTS2-2).
C                    If LENIW.LT.(3*NPTS2-2), the routine will end with
C                    IER = 6.
C
C            LENW  - Integer
C                    Dimensioning parameter for WORK
C                    LENW must be at least LENIW*2-NPTS2.
C                    If LENW.LT.LENIW*2-NPTS2, the routine will end
C                    with IER = 6.
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, which
C                    determines the number of significant elements
C                    actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least LENIW. on return,
C                    the first K elements of which contain
C                    pointers to the error estimates over the
C                    subintervals, such that WORK(LIMIT*3+IWORK(1)),...,
C                    WORK(LIMIT*3+IWORK(K)) form a decreasing
C                    sequence, with K = LAST if LAST.LE.(LIMIT/2+2), and
C                    K = LIMIT+1-LAST otherwise
C                    IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) Contain the
C                     subdivision levels of the subintervals, i.e.
C                     if (AA,BB) is a subinterval of (P1,P2)
C                     where P1 as well as P2 is a user-provided
C                     break point or integration LIMIT, then (AA,BB) has
C                     level L if ABS(BB-AA) = ABS(P2-P1)*2**(-L),
C                    IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) have
C                     no significance for the user,
C                    note that LIMIT = (LENIW-NPTS2)/2.
C
C            WORK  - Double precision
C                    Vector of dimension at least LENW
C                    on return
C                    WORK(1), ..., WORK(LAST) contain the left
C                     end points of the subintervals in the
C                     partition of (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain
C                     the right end points,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain
C                     the integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     contain the corresponding error estimates,
C                    WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2)
C                     contain the integration limits and the
C                     break points sorted in an ascending sequence.
C                    note that LIMIT = (LENIW-NPTS2)/2.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAGPE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DQAGP
C
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL,
     1  NPTS2
C
      DIMENSION IWORK(*),POINTS(*),WORK(*)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAGP
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2)
     1  GO TO 10
C
C         PREPARE CALL FOR DQAGPE.
C
      LIMIT = (LENIW-NPTS2)/2
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
      L4 = LIMIT+L3
C
      CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     1  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4),
     2  IWORK(1),IWORK(L1),IWORK(L2),LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAGP',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


C    Presented below is a FORTRAN 77 adaptation of one of the Pascal codes
C    that appears in [8].  This code is portable to any machine that has a
C    maximum integer greater than, or equal to, 2**31-1.  Thus, this code
C    should run on any 32-bit machine.  The code meets all of the
C    requirements of the "minimal standard" as described in [8].  <p>
C
C    We ran it on all of the systems mentioned in this article.  In general,
C    the execution times for running the portable code were 2 to 50 times
C    slower  than the random number generator supplied by the vendor.
C    For versions of  random number generators that implement the minimal
C    standard on machines  with a maximum integer less than 2**31-1, or
C    generators that are more  specific to machines with 64-bit arithmetic,
C    see [8].

      SUBROUTINE SRAND(ISEED)
C
C  This subroutine sets the integer seed to be used with the
C  companion RAND function to the value of ISEED.  A flag is
C  set to indicate that the sequence of pseudo-random numbers
C  for the specified seed should start from the beginning.
C
      COMMON /SEED/JSEED,IFRST
C
      JSEED = ISEED
      IFRST = 0
C
      RETURN
      END
      REAL FUNCTION RAND()
C
C  This function returns a pseudo-random number for each invocation.
C  It is a FORTRAN 77 adaptation of the "Integer Version 2" minimal
C  standard number generator whose Pascal code appears in the article:
C
C     Park, Steven K. and Miller, Keith W., "Random Number Generators:
C     Good Ones are Hard to Find", Communications of the ACM,
C     October, 1988.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      COMMON  /SEED/JSEED,IFRST
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      RAND = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END
      BLOCKDATA RANDBD
      COMMON /SEED/JSEED,IFRST
C
      DATA JSEED,IFRST/123456789,0/
C
      END


submodule(forlab) forlab_x
    use forlab_kinds
    implicit none

contains
    module procedure rmut_sp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure rmut_dp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure rmut_qp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure cmut_sp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure cmut_dp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure cmut_qp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure rcmut_sp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure rcmut_dp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure rcmut_qp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure crmut_sp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure crmut_dp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

    module procedure crmut_qp
        if (size(m1, 2) == size(m2, 1)) then
            ret = matmul(m1, m2)
        else
            print *, 'size(matrix_1, 2) /= size(matrix_2, 1)'
        end if
    end procedure

end submodule


       MODULE CQL_kinds_m

!----------------------------------------------------------------------
!  Kind specifications
!-------------------------------------------------------------------------------
!For REAL variables:
!  Use p=6, r=35   for single precision on 32 bit machine
!  Use p=12,r=100  for double precision on 32 bit machine
!                  for single precision on 64 bit machine
!Parameters for SELECTED_REAL_KIND:
!  p                   -number of digits
!  r                   -range of exponent from -r to r
!
! For INTEGER variables:
!	Use r=8 for single precision on 32 bit machine
!-------------------------------------------------------------------------------

	IMPLICIT NONE

	PRIVATE

! Defaults
      INTEGER, PARAMETER :: default_real = kind(1.0)
      INTEGER, PARAMETER :: default_int = kind(1)
      INTEGER, PARAMETER :: default_complex = kind(1.0)

! *8 kinds

      REAL*8, PARAMETER :: xdbl_real = 1.
      INTEGER*8, PARAMETER :: xdbl_int = 1
      INTEGER, PARAMETER :: dbl_real = kind(xdbl_real)
      INTEGER, PARAMETER :: dbl_int = kind(xdbl_int)
      INTEGER, PARAMETER :: dbl_complex = kind(xdbl_real)

! Selected kinds

       INTEGER, PARAMETER :: rspec = SELECTED_REAL_KIND(p=12,r=100)
       INTEGER, PARAMETER :: ispec = SELECTED_INT_KIND(r=100)

! Exported kinds

      INTEGER, PUBLIC, PARAMETER :: real_kind = default_real
      INTEGER, PUBLIC, PARAMETER :: int_kind = default_int
      INTEGER, PUBLIC, PARAMETER :: comp_kind = default_complex

       END MODULE CQL_kinds_m


      double complex function A1phiAQggmpppL(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1, Eq. 4.16
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3,mhsq
      zab2(j1,j2,j3,j4)=+za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)
      s3(j1,j2,j3)=s(j1,j2)+s(j1,j3)+s(j2,j3)
      mhsq=s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j2,j3)+s(j2,j4)+s(j3,j4)
      A1phiAQggmpppL=
     . 0.5d0*za(j1,j2)*zab2(j1,j3,j4,j2)/(za(j2,j3)*za(j3,j4)*za(j4,j1))
     . +0.5d0*za(j1,j3)*zb(j3,j4)/(za(j2,j3)*za(j3,j4))
     . +2d0*zab2(j1,j3,j4,j2)**2/(za(j3,j4)*za(j4,j1)*zab2(j3,j1,j4,j2))
     . -2d0*zab2(j1,j2,j3,j4)**2*zab2(j2,j1,j3,j4)
     . /(za(j1,j2)*za(j2,j3)*s3(j1,j2,j3)*zab2(j3,j1,j2,j4))
     . -2d0*zb(j2,j4)**3*mhsq**2
     . /(zb(j1,j2)*s3(j4,j1,j2)*zab2(j3,j1,j2,j4)*zab2(j3,j1,j4,j2))
     . -1d0/3d0*za(j1,j3)*zb(j3,j4)*za(j4,j1)/(za(j1,j2)*za(j3,j4)**2)
      return
      end

      double complex function A1phiAQggmpppR(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1, Eq. 4.17
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4
      double complex zab2
      zab2(j1,j2,j3,j4)=+za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)
      A1phiAQggmpppR=
     . -0.5d0*zab2(j1,j2,j3,j4)/(za(j2,j3)*za(j3,j4))
     . -0.5d0*za(j1,j2)*zb(j2,j3)*za(j3,j1)
     .  /(za(j2,j3)*za(j3,j4)*za(j4,j1))
      return
      end

      double complex function A1phiAQggmpppF(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1, Eq. 4.18
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4
      A1phiAQggmpppF=
     . +1d0/3d0*za(j1,j3)*zb(j3,j4)*za(j4,j1)/(za(j1,j2)*za(j3,j4)**2)
      return
      end


      FUNCTION FNCTN(X,A,IFNC,NTERMS)
C TBHK &KFCTN <860206.1554>

C **********************************************************************

C+ FNCTN &KFCTN F  Functions for fitting data with CLFT

C  FUNCTIONAL DESCRIPTION:  Provides funstional forms for fitting
C    to data. The functions currently coded are:
C    1- Gaussians   A(1),A(4),... amplitudes
C                   A(2),A(5),... offsets from X=0
C                   A(3),A(6),... halfwidths
C       Multiple Gaussians are added: Guas1 + Gaus2 + Gaus3 +...
C    2- Polynomials A(1) + A(2)*X + A(3)*X*X + .......
C    3- Cosines     A(1)          amplitude
C                   A(2),A(4),... phases
C                   A(3),A(5),... wavelengths
C       Multiple cosines are multiplied: Cos1 * Cos2 * Cos3 *...
C    4- Hyperfine structure: deuterated ammonia 1(1,1,+)-1(0,1,-);
C       low optical depth case. The parameters A(1) - A(3) are defined
C       as for a single Gaussian.
C    5- Hyperfine structure: deuterated ammonia 1(1,1,+)-1(0,1,-);
C       optical depth treated as a parameter. A(1) - A(3) are the
C       Gaussian profile parameters. A(4) is the optical depth.
C    6- Symmetric rotor multiplet: methyl acetylene J=6-5
C          A(1) - column density
C          A(2) - peak antenna temperature
C          A(3) - LSR velocity
C          A(4) - line width
C    7- Symmetric rotor multiplet: methyl acetylene J=5-4
C          Parameters as for (6) above.
C    8- Hyperfine structure: deuterated ammonia 2(1,2,-)-2(0,2,+);
C       low optical depth case. The parameters A(1) - A(3) are defined
C       as for a single Gaussian.
C    9- Hyperfine structure: deuterated ammonia 2(1,2,-)-2(0,2,+);
C       optical depth treated as a parameter. A(1) - A(3) are the
C       Gaussian profile parameters. A(4) is the optical depth.
C   10- Hyperfine structure: ammonia 1(1);
C       low optical depth case. The parameters A(1) - A(3) are defined
C       as for a single Gaussian.
C   11- Hyperfine structure: ammonia 1(1);
C       optical depth treated as a parameter. A(1) - A(3) are the
C       Gaussian profile parameters. A(4) is the optical depth.
C   12- Hyperfine structure: ammonia 2(2);
C       low optical depth case. The parameters A(1) - A(3) are defined
C       as for a single Gaussian.
C   13- Hyperfine structure: ammonia 2(2);
C       optical depth treated as a parameter. A(1) - A(3) are the
C       Gaussian profile parameters. A(4) is the optical depth.
C   14- Pulse arrival time (seconds vs MHz).  A(1) is arrival time of
C       undispersed pulse. A(2) is the dispersion measure.

C  CALLING SEQUENCE:  RETURN = FNCTN( X,A,IFNC,NTERMS )
C     ARG   I/O/M  TYPE    DESCRIPTION
C    ------  ---   ----    ---------------------------------------------
C    RETURN: OUT   F       value of the dependent variable
C    X     : IN    F       value of independent variable
C    A     : IN    F       array of parameters for function
C    IFNC  : IN    I       functional form indicator
C    NTERMS: IN    I       number of parameters in the function

C  SUBROUTINES CALLED:

C  REVISION HISTORY:
C    DATE      PROGRAMMER      DESCRIPTION OF CHANGES
C    --------  --------------  ----------------------------------------
C    3Oct84    T.B.H.Kuiper    added ammonia
C    20Jan84   T.B.H.Kuiper    added propyne, deut. ammonia
C    20Mar83   Tim Thompson    increased from 11 to 21 parameters
C    24Aug80   T.B.H.Kuiper    last pre-HEAD revision

C  OPERATING ENVIRONMENT:
C    Language           : HP 1000 FORTRAN 4X
C    System Dependencies: none
C    Hardware Required  : none

C  NOTES: The spectroscopic parameters for multiplets are contained
C    in the doubly dimensioned arrays DF, E, G,  and S. The second
C    index MOLDAT, specifies the molecule and transition:
C       1  : deuterated ammonia 1(1,1,+)-1(0,1,-) [85.9 GHz]
C       2  : methyl acetylene J=6-5 [102.5 GHz]
C       3  : methyl acetylene J=5-4 [85.4 GHz]
C       4  : deuterated ammonia 2(1,2,-)-2(0,2,+) [74.2 GHz]
C       5  : ammonia 1(1) [23.69 GHz]
C       6  : ammonia 2(2) [23.72 GHz]

C  KEYWORDS (FNCTN ): JPL-RAG,MATH,DATA REDUCTION,

C **********************************************************************
C  VARIABLE DICTIONARY
C  -------- ----------
C    COMPNT: one component of a hyperfine multiplet
C    DF    : frequency offset from principal hyperfine component
C    E     : rotational energy levels
C    ENL   : column density
C    FREQ  : frequency of the transition in MHz
C    G     : inclusive stat.weight, line str. factor for sym. rot.
C    I     : loop index
C    II    : secondary index derived from I
C    ITAU  : specifier for optical depth case
C    MOLDAT: index for molecular data
C    NCOMPS: number of hyperfine components
C    NCOS  : number of cosines in cosine function
C    NGAUSS: number of gaussians in fitting function
C    PI    : radians in a semicircle
C    S     : line strengths of the hyperfine components
C    SQRLN2: twice the square root of logarithm of 2
C    T     : peak antenna temperature
C    V0    : offset from main component
C    W     : line width
C **********************************************************************

      COMMON/LUS/ LU
      real*8 A, X
      DIMENSION A(21),DF(7,6),S(7,6),E(7,6),G(7,6),FREQ(6)
Cf2py intent(in) X
Cf2py intent(in) A
Cf2py intent(in) IFNC
Cf2py intent(in) NTERMS
      DATA DF/ 0.000, 0.047,-0.567,  0.614,  1.465, -1.487,  0.000,
     +         0.000,-1.960,-7.840,-17.637,-31.348,-48.967,  0.000,
     +         0.000,-1.634,-6.534,-14.700,-26.127,  0.000,  0.000,
     +         0.000,-0.175, 0.315, -0.951,  1.266, -1.655,  1.795,
     +         0.000,-0.599, 0.597, -1.539,  1.539,  0.000,  0.000,
     +         0.000,-1.315, 1.315, -2.046,  2.046,  0.000,  0.000/
      DATA S/0.416, 0.083, 0.139, 0.139, 0.111, 0.111, 0.000,
     +       0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     +       0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     +       0.415, 0.150, 0.231, 0.052, 0.052, 0.050, 0.050,
     +       0.500, 0.140, 0.140, 0.110, 0.110, 0.000, 0.000,
     +       0.796, 0.052, 0.052, 0.050, 0.050, 0.000, 0.000/
      DATA E/0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000,
     &       8.5520, 13.403, 27.957, 52.209, 86.153, 129.78, 0.0000,
     &        5.701, 10.553, 25.106, 49.358, 83.303, 0.0000, 0.0000,
     &        0.000,  0.000,  0.000,  0.000,  0.000, 0.0000, 0.0000,
     &        0.000,  0.000,  0.000,  0.000,  0.000, 0.0000, 0.0000,
     &        0.000,  0.000,  0.000,  0.000,  0.000, 0.0000, 0.0000/
      DATA G/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &       3.000, 2.920, 2.670, 4.500, 1.670, 0.916, 0.000,
     &       2.500, 2.400, 2.100, 3.200, 0.900, 0.000, 0.000,
     &       0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &       0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &       0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/
      DATA FREQ/85926.270, 102499.110, 85431.220, 74155.485,
     &          23694.496,  23722.633/
      DATA PI/3.1415926/, SQRLN2/1.665109/

C     Statement functions for symmetric rotor calculation
      real*8 VV, VV0, WW
      real*8      V0,  W
      F(TT)     = 1.26E-13*(1.-EXP(-FREQ(MOLDAT)*4.783E-5/TT))/SQRT(TT)
      FF(II,TT)        = G(II,MOLDAT)*EXP(-1.44*E(II,MOLDAT)/TT)
      EX(II,VV,VV0,WW) = EXP(-2.773*((VV-VV0-DF(II,MOLDAT))/WW)**2)

      GO TO (120,100,140,160,160,170,170,160,160,160,
     &       160,160,160,180,1000),IFNC

C     Polynomial (IFNC=2)
  100 FNCTN=A(1)
      DO 110 I=2,NTERMS
  110   FNCTN = FNCTN + A(I)*X**(I-1)
      return

C     Gaussian (IFNC=1)
  120 IF (IFNC.LT.1) GO TO 1000
      FNCTN = 0.
      NGAUSS=NTERMS/3
      DO 130 I=1,NGAUSS
        II=(I-1)*3
  130   FNCTN = FNCTN
     &          + A(II+1)*EXP( -( (X-A(II+2))*SQRLN2/A(II+3) )**2 )
      return

C     Cosine (IFNC=3)
  140 FNCTN=A(1)
      NCOS=(NTERMS-1)/2
      DO 150 I=1,NCOS
  150   FNCTN = FNCTN * COS((X-A(2*I))*2*PI/A(2*I+1))
      return

C     Hyperfine structure (IFNC=4,5,8,9)
  160 FNCTN=0.
      IF (IFNC.EQ.4) THEN
C       Deuterated ammonia [85.9 GHz]; low optical depth case
        ITAU=0
        NCOMPS=6
        MOLDAT=1
      ELSE IF (IFNC.EQ.5) THEN
C       Deuterated ammonia [85.9 GHz]; fitted optical depth
        ITAU=1
        NCOMPS=6
        MOLDAT=1
      ELSE IF (IFNC.EQ.8) THEN
C       Deuterated ammonia [74.2 GHz]; low optical depth case
        ITAU=0
        NCOMPS=7
        MOLDAT=4
      ELSE IF (IFNC.EQ.9) THEN
C       Deuterated ammonia [74.2 GHz]; fitted optical depth
        ITAU=1
        NCOMPS=7
        MOLDAT=4
      ELSE IF (IFNC.EQ.10) THEN
C       Ammonia [23.69 GHz]; low optical depth
        ITAU=0
        NCOMPS=5
        MOLDAT=5
      ELSE IF (IFNC.EQ.11) THEN
C       Ammonia [23.69 GHz]; fitted optical depth
        ITAU=1
        NCOMPS=5
        MOLDAT=5
      ELSE IF (IFNC.EQ.12) THEN
C       Ammonia [23.72 GHz]; low optical depth
        ITAU=0
        NCOMPS=5
        MOLDAT=6
      ELSE IF (IFNC.EQ.13) THEN
C       Ammonia [23.72 GHz]; fitted optical depth
        ITAU=1
        NCOMPS=5
        MOLDAT=6
      ELSE
        GO TO 1000
      END IF

      FNCTN=0.
      T   = A(1)
      V0  = A(2)
      W   = A(3)
      TAU = A(4)
      DO 162 I=1,NCOMPS
  162   FNCTN = FNCTN + S(I,MOLDAT)*EX(I,X,V0,W)
      FNCTN = FNCTN/S(1,MOLDAT)
      IF (ITAU.EQ.0) THEN
        FNCTN = T*FNCTN
      ELSE
        FNCTN = T*(1.-EXP(-TAU*FNCTN))
      END IF
      return

C     Symmetric Rotors (IFNC=6,7)
  170 ENL = A(1)
      T   = A(2)
      V0  = A(3)
      W   = A(4)
      IF (IFNC.EQ.6) THEN
        MOLDAT=2
        NCOMPS=6
      else
        MOLDAT=3
        NCOMPS=5
      END IF

      FNCTN=0.
      DO 172 I=1,NCOMPS
  172   FNCTN = FNCTN + FF(I,T)*EX(I,X,V0,W)
      FNCTN = FNCTN*ENL*F(T)/ABS(W)
      return

      # Time delay from plasma dispersion
  180 FNCTN = A(1) + 4150.*A(2)/X**2
      return

C     Invalid function code
 1000 WRITE(LU,1001) IFNC
 1001 FORMAT('FNCTN error: Function code',I6,' is invalid.')
      RETURN
      END


MODULE special_fun
CONTAINS
  SUBROUTINE HYGFZ(A,B,C,Z,ZHF)
!
!       ======================================================
!       Purpose: Compute the hypergeometric function for a
!                complex argument, F(a,b,c,z)
!       Input :  a --- Parameter
!                b --- Parameter
!                c --- Parameter,  c <> 0,-1,-2,...
!                z --- Complex argument
!       Output:  ZHF --- F(a,b,c,z)
!       Routines called:
!            (1) GAMMA for computing gamma function
!            (2) PSI for computing psi function
!       ======================================================
!
    IMPLICIT NONE
    LOGICAL::L0,L1,L2,L3,L4,L5,L6
    REAL(KIND(1d0)),INTENT(INOUT)::A,B,C
    COMPLEX(KIND(1d0)),INTENT(INOUT)::Z
    COMPLEX(KIND(1d0)),INTENT(OUT)::ZHF
    REAL(KIND(1d0))::X,Y,EPS,AA,BB,A0,PI,EL,CA,CB,GAB,GABC,GBA
    REAL(KIND(1d0))::GC,GA,GB,GCAB,GCA,GCB,G0,G1,G2,G3,GCBK
    REAL(KIND(1d0))::X1,GM,GAM,GBM,PA,PB,RM,SM,SP0,SP,PAC,PCA
    INTEGER::NM,K,MCAB,M,J,MAB,NCA,NCB
    COMPLEX(KIND(1d0))::ZR,Z1,ZC0,ZR0,ZW,ZF0,Z00,ZC1,ZF1,ZP,ZP0,ZR1
    REAL(KIND(1d0))::RK1,RK2,SJ1,SJ2,SQ,T0,W0,WS
    X=REAL(Z)
    Y=DIMAG(Z)
    EPS=1.0D-15
    L0=C.EQ.INT(C).AND.C.LT.0.0D0
    L1=DABS(1.0D0-X).LT.EPS.AND.Y.EQ.0.0D0.AND.C-A-B.LE.0.0D0
    L2=CDABS(Z+1.0D0).LT.EPS.AND.DABS(C-A+B-1.0D0).LT.EPS
    L3=A.EQ.INT(A).AND.A.LT.0.0D0
    L4=B.EQ.INT(B).AND.B.LT.0.0D0
    L5=C-A.EQ.INT(C-A).AND.C-A.LE.0.0D0
    L6=C-B.EQ.INT(C-B).AND.C-B.LE.0.0D0
    AA=A
    BB=B
    A0=CDABS(Z)
    IF (A0.GT.0.95D0) EPS=1.0D-8
    PI=3.141592653589793D0
    EL=.5772156649015329D0
    IF (L0.OR.L1) THEN
       WRITE(*,*)'The hypergeometric series is divergent'
       RETURN
    ENDIF
    IF (A0.EQ.0.0D0.OR.A.EQ.0.0D0.OR.B.EQ.0.0D0) THEN
       ZHF=(1.0D0,0.0D0)
    ELSE IF (Z.EQ.1.0D0.AND.C-A-B.GT.0.0D0) THEN
       CALL GAMMA(C,GC)
       CALL GAMMA(C-A-B,GCAB)
       CALL GAMMA(C-A,GCA)
       CALL GAMMA(C-B,GCB)
       ZHF=GC*GCAB/(GCA*GCB)
    ELSE IF (L2) THEN
       G0=DSQRT(PI)*2.0D0**(-A)
       CALL GAMMA(C,G1)
       CALL GAMMA(1.0D0+A/2.0D0-B,G2)
       CALL GAMMA(0.5D0+0.5D0*A,G3)
       ZHF=G0*G1/(G2*G3)
    ELSE IF (L3.OR.L4) THEN
       IF (L3) NM=INT(ABS(A))
       IF (L4) NM=INT(ABS(B))
       ZHF=(1.0D0,0.0D0)
       ZR=(1.0D0,0.0D0)
       DO K=1,NM
          ZR=ZR*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*Z
          ZHF=ZHF+ZR ! 10
       ENDDO
    ELSE IF (L5.OR.L6) THEN
       IF (L5) NM=INT(ABS(C-A))
       IF (L6) NM=INT(ABS(C-B))
       ZHF=(1.0D0,0.0D0)
       ZR=(1.0D0,0.0D0)
       DO K=1,NM
          ZR=ZR*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*Z
          ZHF=ZHF+ZR ! 15
       ENDDO
       ZHF=(1.0D0-Z)**(C-A-B)*ZHF
    ELSE IF (A0.LE.1.0D0) THEN
       IF (X.LT.0.0D0) THEN
          Z1=Z/(Z-1.0D0)
          IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN
             A=BB
             B=AA
          ENDIF
          ZC0=1.0D0/((1.0D0-Z)**A)
          ZHF=(1.0D0,0.0D0)
          ZR0=(1.0D0,0.0D0)
          DO K=1,500
             ZR0=ZR0*(A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*Z1
             ZHF=ZHF+ZR0
             IF (CDABS(ZHF-ZW).LT.CDABS(ZHF)*EPS)EXIT ! GO TO 25
             ZW=ZHF ! 20
          ENDDO
          ZHF=ZC0*ZHF ! 25
       ELSE IF (A0.GE.0.90D0) THEN
          GM=0.0D0
          MCAB=INT(C-A-B+EPS*DSIGN(1.0D0,C-A-B))
          IF (DABS(C-A-B-MCAB).LT.EPS) THEN
             M=INT(C-A-B)
             CALL GAMMA(A,GA)
             CALL GAMMA(B,GB)
             CALL GAMMA(C,GC)
             CALL GAMMA(A+M,GAM)
             CALL GAMMA(B+M,GBM)
             CALL PSI(A,PA)
             CALL PSI(B,PB)
             IF (M.NE.0) GM=1.0D0
             DO J=1,ABS(M)-1
                GM=GM*J ! 30
             ENDDO
             RM=1.0D0
             DO J=1,ABS(M)
                RM=RM*J ! 35
             ENDDO
             ZF0=(1.0D0,0.0D0)
             ZR0=(1.0D0,0.0D0)
             ZR1=(1.0D0,0.0D0)
             SP0=0.D0
             SP=0.0D0
             IF (M.GE.0) THEN
                ZC0=GM*GC/(GAM*GBM)
                ZC1=-GC*(Z-1.0D0)**M/(GA*GB*RM)
                DO K=1,M-1
                   ZR0=ZR0*(A+K-1.D0)*(B+K-1.D0)/(K*(K-M))*(1.D0-Z)
                   ZF0=ZF0+ZR0 ! 40
                ENDDO
                DO K=1,M
                   SP0=SP0+1.0D0/(A+K-1.0D0)+1.0/(B+K-1.0D0)-1.D0/K ! 45
                ENDDO
                ZF1=PA+PB+SP0+2.0D0*EL+CDLOG(1.0D0-Z)
                DO K=1,500
                   SP=SP+(1.0D0-A)/(K*(A+K-1.0D0))+(1.0D0-B)/&
                        (K*(B+K-1.0D0))
                   SM=0.0D0
                   DO J=1,M
                      SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0D0)) &
                           +1.0D0/(B+J+K-1.0D0)
                      !    CONTINUE 50
                   ENDDO
                   ZP=PA+PB+2.0D0*EL+SP+SM+CDLOG(1.0D0-Z)
                   ZR1=ZR1*(A+M+K-1.0D0)*(B+M+K-1.0D0)/(K*(M+K)) &
                        *(1.0D0-Z)
                   ZF1=ZF1+ZR1*ZP
                   IF (CDABS(ZF1-ZW).LT.CDABS(ZF1)*EPS)EXIT ! GO TO 60
                   ZW=ZF1 ! 55
                ENDDO
                ZHF=ZF0*ZC0+ZF1*ZC1 ! 60
             ELSE IF (M.LT.0) THEN
                M=-M
                ZC0=GM*GC/(GA*GB*(1.0D0-Z)**M)
                ZC1=-(-1)**M*GC/(GAM*GBM*RM)
                DO K=1,M-1
                   ZR0=ZR0*(A-M+K-1.0D0)*(B-M+K-1.0D0)/(K*(K-M))&
                        *(1.0D0-Z)
                   ZF0=ZF0+ZR0 ! 65
                ENDDO
                DO K=1,M
                   SP0=SP0+1.0D0/K ! 70
                ENDDO
                ZF1=PA+PB-SP0+2.0D0*EL+CDLOG(1.0D0-Z)
                DO K=1,500
                   SP=SP+(1.0D0-A)/(K*(A+K-1.0D0))+(1.0D0-B)/(K*&
                        (B+K-1.0D0))
                   SM=0.0D0
                   DO J=1,M
                      SM=SM+1.0D0/(J+K) ! 75
                   ENDDO
                   ZP=PA+PB+2.0D0*EL+SP-SM+CDLOG(1.0D0-Z)
                   ZR1=ZR1*(A+K-1.D0)*(B+K-1.D0)/(K*(M+K))*(1.D0-Z)
                   ZF1=ZF1+ZR1*ZP
                   IF (CDABS(ZF1-ZW).LT.CDABS(ZF1)*EPS)EXIT ! GO TO 85
                   ZW=ZF1 ! 80
                ENDDO
                ZHF=ZF0*ZC0+ZF1*ZC1 ! 85
             ENDIF
          ELSE
             CALL GAMMA(A,GA)
             CALL GAMMA(B,GB)
             CALL GAMMA(C,GC)
             CALL GAMMA(C-A,GCA)
             CALL GAMMA(C-B,GCB)
             CALL GAMMA(C-A-B,GCAB)
             CALL GAMMA(A+B-C,GABC)
             ZC0=GC*GCAB/(GCA*GCB)
             ZC1=GC*GABC/(GA*GB)*(1.0D0-Z)**(C-A-B)
             ZHF=(0.0D0,0.0D0)
             ZR0=ZC0
             ZR1=ZC1
             DO K=1,500
                ZR0=ZR0*(A+K-1.D0)*(B+K-1.D0)/(K*(A+B-C+K))*(1.D0-Z)
                ZR1=ZR1*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C-A-B+K))&
                     *(1.0D0-Z)
                ZHF=ZHF+ZR0+ZR1
                IF (CDABS(ZHF-ZW).LT.CDABS(ZHF)*EPS)EXIT ! GO TO 95
                ZW=ZHF ! 90
             ENDDO
             ZHF=ZHF+ZC0+ZC1 ! 95
          ENDIF
       ELSE
          Z00=(1.0D0,0.0D0)
          IF (C-A.LT.A.AND.C-B.LT.B) THEN
             Z00=(1.0D0-Z)**(C-A-B)
             A=C-A
             B=C-B
          ENDIF
          ZHF=(1.0D0,0.D0)
          ZR=(1.0D0,0.0D0)
          DO K=1,1500
             ZR=ZR*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*Z
             ZHF=ZHF+ZR
             IF(CDABS(ZHF-ZW).LE.CDABS(ZHF)*EPS)EXIT !  GO TO 105
             ZW=ZHF ! 100
          ENDDO
          ZHF=Z00*ZHF ! 105
       ENDIF
    ELSE IF (A0.GT.1.0D0) THEN
       MAB=INT(A-B+EPS*DSIGN(1.0D0,A-B))
       IF (DABS(A-B-MAB).LT.EPS.AND.A0.LE.1.1D0) B=B+EPS
       IF (DABS(A-B-MAB).GT.EPS) THEN
          CALL GAMMA(A,GA)
          CALL GAMMA(B,GB)
          CALL GAMMA(C,GC)
          CALL GAMMA(A-B,GAB)
          CALL GAMMA(B-A,GBA)
          CALL GAMMA(C-A,GCA)
          CALL GAMMA(C-B,GCB)
          ZC0=GC*GBA/(GCA*GB*(-Z)**A)
          ZC1=GC*GAB/(GCB*GA*(-Z)**B)
          ZR0=ZC0
          ZR1=ZC1
          ZHF=(0.0D0,0.0D0)
          DO K=1,500
             ZR0=ZR0*(A+K-1.0D0)*(A-C+K)/((A-B+K)*K*Z)
             ZR1=ZR1*(B+K-1.0D0)*(B-C+K)/((B-A+K)*K*Z)
             ZHF=ZHF+ZR0+ZR1
             IF (CDABS((ZHF-ZW)/ZHF).LE.EPS)EXIT ! GO TO 115
             ZW=ZHF ! 110
          ENDDO
          ZHF=ZHF+ZC0+ZC1 ! 115
       ELSE
          IF (A-B.LT.0.0D0) THEN
             A=BB
             B=AA
          ENDIF
          CA=C-A
          CB=C-B
          NCA=INT(CA+EPS*DSIGN(1.0D0,CA))
          NCB=INT(CB+EPS*DSIGN(1.0D0,CB))
          IF (DABS(CA-NCA).LT.EPS.OR.DABS(CB-NCB).LT.EPS) C=C+EPS
          CALL GAMMA(A,GA)
          CALL GAMMA(C,GC)
          CALL GAMMA(C-B,GCB)
          CALL PSI(A,PA)
          CALL PSI(C-A,PCA)
          CALL PSI(A-C,PAC)
          MAB=INT(A-B+EPS)
          ZC0=GC/(GA*(-Z)**B)
          CALL GAMMA(A-B,GM)
          ZF0=GM/GCB*ZC0
          ZR=ZC0
          DO K=1,MAB-1
             ZR=ZR*(B+K-1.0D0)/(K*Z)
             T0=A-B-K
             CALL GAMMA(T0,G0)
             CALL GAMMA(C-B-K,GCBK)
             ZF0=ZF0+ZR*G0/GCBK ! 120
          ENDDO
          IF (MAB.EQ.0) ZF0=(0.0D0,0.0D0)
          ZC1=GC/(GA*GCB*(-Z)**A)
          SP=-2.0D0*EL-PA-PCA
          DO J=1,MAB
             SP=SP+1.0D0/J ! 125
          ENDDO
          ZP0=SP+CDLOG(-Z)
          SQ=1.0D0
          DO J=1,MAB
             SQ=SQ*(B+J-1.0D0)*(B-C+J)/J ! 130
          ENDDO
          ZF1=(SQ*ZP0)*ZC1
          ZR=ZC1
          RK1=1.0D0
          SJ1=0.0D0
          DO K=1,10000
             ZR=ZR/Z
             RK1=RK1*(B+K-1.0D0)*(B-C+K)/(K*K)
             RK2=RK1
             DO J=K+1,K+MAB
                RK2=RK2*(B+J-1.0D0)*(B-C+J)/J ! 135
             ENDDO
             SJ1=SJ1+(A-1.0D0)/(K*(A+K-1.0D0))+(A-C-1.0D0)/&
                  (K*(A-C+K-1.0D0))
             SJ2=SJ1
             DO J=K+1,K+MAB
                SJ2=SJ2+1.0D0/J ! 140
             ENDDO
             ZP=-2.0D0*EL-PA-PAC+SJ2-1.0D0/(K+A-C)&
                  -PI/DTAN(PI*(K+A-C))+CDLOG(-Z)
             ZF1=ZF1+RK2*ZR*ZP
             WS=CDABS(ZF1)
             IF (DABS((WS-W0)/WS).LT.EPS)EXIT ! GO TO 150
             W0=WS ! 145
          ENDDO
          ZHF=ZF0+ZF1 ! 150
       ENDIF
    ENDIF
    A=AA ! 155
    B=BB
    IF (K.GT.150) WRITE(*,160)
160 FORMAT(1X,'Warning! You should check the accuracy in HYGFZ')
    RETURN
  END SUBROUTINE HYGFZ

  SUBROUTINE HYGFX(A,B,C,X,HF)
!
!       ====================================================
!       Purpose: Compute hypergeometric function F(a,b,c,x),2F1
!       Input :  a --- Parameter
!                b --- Parameter
!                c --- Parameter, c <> 0,-1,-2,...
!                x --- Argument   ( x < 1 )
!       Output:  HF --- F(a,b,c,x)
!       Routines called:
!            (1) GAMMA for computing gamma function
!            (2) PSI for computing psi function
!       ====================================================
!
    IMPLICIT NONE
    REAL(KIND(1d0)),INTENT(INOUT)::A,B,C,X
    REAL(KIND(1d0)),INTENT(OUT)::HF
    LOGICAL::L0,L1,L2,L3,L4,L5
    REAL(KIND(1d0)),PARAMETER::PI=3.141592653589793D0
    REAL(KIND(1d0)),PARAMETER::EL=.5772156649015329D0
    REAL(KIND(1d0))::EPS,GC,GB,GCAB,GCA,GCB,GABC,G1,G2,G3,R
    REAL(KIND(1d0))::AA,BB,X1,GM,GAM,GBM,RM,F0,R0,R1,SP0,SP
    REAL(KIND(1d0))::A0,SM,C0,C1,F1,G0,GA,HW,PA,PB,RP
    INTEGER::NM,K,M,J
    L0=C.EQ.INT(C).AND.C.LT.0.0
    L1=1.0D0-X.LT.1.0D-15.AND.C-A-B.LE.0.0
    L2=A.EQ.INT(A).AND.A.LT.0.0
    L3=B.EQ.INT(B).AND.B.LT.0.0
    L4=C-A.EQ.INT(C-A).AND.C-A.LE.0.0
    L5=C-B.EQ.INT(C-B).AND.C-B.LE.0.0
    IF (L0.OR.L1) THEN
       WRITE(*,*)'The hypergeometric series is divergent'
       RETURN
    ENDIF
    EPS=1.0D-15
    IF (X.GT.0.95)EPS=1.0D-8
    IF (X.EQ.0.0.OR.A.EQ.0.0.OR.B.EQ.0.0) THEN
       HF=1.0D0
       RETURN
    ELSE IF (1.0D0-X.EQ.EPS.AND.C-A-B.GT.0.0) THEN
       CALL GAMMA(C,GC)
       CALL GAMMA(C-A-B,GCAB)
       CALL GAMMA(C-A,GCA)
       CALL GAMMA(C-B,GCB)
       HF=GC*GCAB/(GCA*GCB)
       RETURN
    ELSE IF (1.0D0+X.LE.EPS.AND.DABS(C-A+B-1.0).LE.EPS) THEN
       G0=DSQRT(PI)*2.0D0**(-A)
       CALL GAMMA(C,G1)
       CALL GAMMA(1.0D0+A/2.0-B,G2)
       CALL GAMMA(0.5D0+0.5*A,G3)
       HF=G0*G1/(G2*G3)
       RETURN
    ELSE IF (L2.OR.L3) THEN
       IF (L2) NM=INT(ABS(A))
       IF (L3) NM=INT(ABS(B))
       HF=1.0D0
       R=1.0D0
       DO K=1,NM
          R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
          HF=HF+R ! 10
       ENDDO
       RETURN
    ELSE IF (L4.OR.L5) THEN
       IF (L4) NM=INT(ABS(C-A))
       IF (L5) NM=INT(ABS(C-B))
       HF=1.0D0
       R=1.0D0
       DO K=1,NM
          R=R*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*X
          HF=HF+R ! 15
       ENDDO
       HF=(1.0D0-X)**(C-A-B)*HF
       RETURN
    ENDIF
    AA=A
    BB=B
    X1=X
    IF (X.LT.0.0D0) THEN
       X=X/(X-1.0D0)
       IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN
          A=BB
          B=AA
       ENDIF
       B=C-B
    ENDIF
    IF (X.GE.0.75D0) THEN
       GM=0.0D0
       IF (DABS(C-A-B-INT(C-A-B)).LT.1.0D-15) THEN
          M=INT(C-A-B)
          CALL GAMMA(A,GA)
          CALL GAMMA(B,GB)
          CALL GAMMA(C,GC)
          CALL GAMMA(A+M,GAM)
          CALL GAMMA(B+M,GBM)
          CALL PSI(A,PA)
          CALL PSI(B,PB)
          IF (M.NE.0) GM=1.0D0
          DO J=1,ABS(M)-1
             GM=GM*J ! 30
          ENDDO
          RM=1.0D0
          DO J=1,ABS(M)
             RM=RM*J ! 35
          ENDDO
          F0=1.0D0
          R0=1.0D0
          R1=1.0D0
          SP0=0.D0
          SP=0.0D0
          IF (M.GE.0) THEN
             C0=GM*GC/(GAM*GBM)
             C1=-GC*(X-1.0D0)**M/(GA*GB*RM)
             DO K=1,M-1
                R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(K-M))*(1.0-X)
                F0=F0+R0 ! 40
             ENDDO
             DO K=1,M
                SP0=SP0+1.0D0/(A+K-1.0)+1.0/(B+K-1.0)-1.0/K ! 45
             ENDDO
             F1=PA+PB+SP0+2.0D0*EL+DLOG(1.0D0-X)
             DO K=1,250
                SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                SM=0.0D0
                DO J=1,M
                   SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0))+1.0/&
                        (B+J+K-1.0)  ! 50
                ENDDO
                RP=PA+PB+2.0D0*EL+SP+SM+DLOG(1.0D0-X)
                R1=R1*(A+M+K-1.0D0)*(B+M+K-1.0)/(K*(M+K))*(1.0-X)
                F1=F1+R1*RP
                IF (DABS(F1-HW).LT.DABS(F1)*EPS)EXIT ! GO TO 60
                HW=F1 ! 55
             ENDDO
             HF=F0*C0+F1*C1 ! 60
          ELSE IF (M.LT.0) THEN
             M=-M
             C0=GM*GC/(GA*GB*(1.0D0-X)**M)
             C1=-(-1)**M*GC/(GAM*GBM*RM)
             DO K=1,M-1
                R0=R0*(A-M+K-1.0D0)*(B-M+K-1.0)/(K*(K-M))*(1.0-X)
                F0=F0+R0 ! 65
             ENDDO
             DO K=1,M
                SP0=SP0+1.0D0/K ! 70
             ENDDO
             F1=PA+PB-SP0+2.0D0*EL+DLOG(1.0D0-X)
             DO K=1,250
                SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                SM=0.0D0
                DO J=1,M
                   SM=SM+1.0D0/(J+K) ! 75
                ENDDO
                RP=PA+PB+2.0D0*EL+SP-SM+DLOG(1.0D0-X)
                R1=R1*(A+K-1.0D0)*(B+K-1.0)/(K*(M+K))*(1.0-X)
                F1=F1+R1*RP
                IF (DABS(F1-HW).LT.DABS(F1)*EPS)EXIT ! GO TO 85
                HW=F1 ! 80
             ENDDO
             HF=F0*C0+F1*C1 ! 85
          ENDIF
       ELSE
          CALL GAMMA(A,GA)
          CALL GAMMA(B,GB)
          CALL GAMMA(C,GC)
          CALL GAMMA(C-A,GCA)
          CALL GAMMA(C-B,GCB)
          CALL GAMMA(C-A-B,GCAB)
          CALL GAMMA(A+B-C,GABC)
          C0=GC*GCAB/(GCA*GCB)
          C1=GC*GABC/(GA*GB)*(1.0D0-X)**(C-A-B)
          HF=0.0D0
          R0=C0
          R1=C1
          DO K=1,250
             R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(A+B-C+K))*(1.0-X)
             R1=R1*(C-A+K-1.0D0)*(C-B+K-1.0)/(K*(C-A-B+K))&
                  *(1.0-X)
             HF=HF+R0+R1
             IF (DABS(HF-HW).LT.DABS(HF)*EPS)EXIT ! GO TO 95
             HW=HF ! 90
          ENDDO
          HF=HF+C0+C1 ! 95
       ENDIF
    ELSE
       A0=1.0D0
       IF (C.GT.A.AND.C.LT.2.0D0*A.AND.&
            C.GT.B.AND.C.LT.2.0D0*B) THEN
          A0=(1.0D0-X)**(C-A-B)
          A=C-A
          B=C-B
       ENDIF
       HF=1.0D0
       R=1.0D0
       DO K=1,250
          R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
          HF=HF+R
          IF (DABS(HF-HW).LE.DABS(HF)*EPS)EXIT ! GO TO 105
          HW=HF ! 100
       ENDDO
       HF=A0*HF
    ENDIF
    IF (X1.LT.0.0D0) THEN
       X=X1
       C0=1.0D0/(1.0D0-X)**AA
       HF=C0*HF
    ENDIF
    A=AA
    B=BB
    IF (K.GT.120) WRITE(*,115)
115 FORMAT(1X,'Warning! You should check the accuracy in HYGFX')
    RETURN
  END SUBROUTINE HYGFX

  SUBROUTINE GAMMA(X,GA)
!
!       ==================================================
!       Purpose: Compute gamma function â(x)
!       Input :  x  --- Argument of â(x)
!                       ( x is not equal to 0,-1,-2,úúú)
!       Output:  GA --- â(x)
!       ==================================================
!
    IMPLICIT NONE
    REAL(KIND(1d0)),INTENT(IN)::X
    REAL(KIND(1d0)),INTENT(OUT)::GA
    REAL(KIND(1d0)),DIMENSION(26)::G
    REAL(KIND(1d0)),PARAMETER::PI=3.141592653589793D0
    REAL(KIND(1d0))::Z,R,GR
    INTEGER::M1,K,M
    IF (X.EQ.INT(X)) THEN
       IF (X.GT.0.0D0) THEN
          GA=1.0D0
          M1=X-1
          DO K=2,M1
             GA=GA*K ! 10
          ENDDO
       ELSE
          GA=1.0D+300
       ENDIF
    ELSE
       IF (DABS(X).GT.1.0D0) THEN
          Z=DABS(X)
          M=INT(Z)
          R=1.0D0
          DO K=1,M
             R=R*(Z-K) ! 15
          ENDDO
          Z=Z-M
       ELSE
          Z=X
       ENDIF
       G(1:26)=(/1.0D0,0.5772156649015329D0,&
            -0.6558780715202538D0, -0.420026350340952D-1,&
            0.1665386113822915D0,-.421977345555443D-1,&
            -.96219715278770D-2, .72189432466630D-2,&
            -.11651675918591D-2, -.2152416741149D-3,&
            .1280502823882D-3, -.201348547807D-4,&
            -.12504934821D-5, .11330272320D-5,&
            -.2056338417D-6, .61160950D-8,&
            .50020075D-8, -.11812746D-8,&
            .1043427D-9, .77823D-11,&
            -.36968D-11, .51D-12,&
            -.206D-13, -.54D-14, .14D-14, .1D-15/)
       GR=G(26)
       DO K=25,1,-1
          GR=GR*Z+G(K) ! 20
       ENDDO
       GA=1.0D0/(GR*Z)
       IF (DABS(X).GT.1.0D0) THEN
          GA=GA*R
          IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
       ENDIF
    ENDIF
    RETURN
  END SUBROUTINE GAMMA

  SUBROUTINE PSI(X,PS)
!
!  ======================================
!      Purpose: Compute Psi function
!      Input :  x  --- Argument of psi(x)
!      Output:  PS --- psi(x)
! ======================================
!
    IMPLICIT NONE
    REAL(KIND(1d0)),INTENT(IN)::X
    REAL(KIND(1d0)),INTENT(OUT)::PS
    REAL(KIND(1d0))::PI,EL,S,XA
    INTEGER::N,K
    REAL(KIND(1d0))::A1,A2,A3,A4,A5,A6,A7,A8,X2
    XA=DABS(X)
    PI=3.141592653589793D0
    EL=.5772156649015329D0
    S=0.0D0
    IF (X.EQ.INT(X).AND.X.LE.0.0) THEN
       PS=1.0D+300
       RETURN
    ELSE IF (XA.EQ.INT(XA)) THEN
       N=XA
       DO K=1 ,N-1
          S=S+1.0D0/K
       ENDDO
       PS=-EL+S
    ELSE IF (XA+.5.EQ.INT(XA+.5)) THEN
       N=XA-.5
       DO K=1,N
          S=S+1.0/(2.0D0*K-1.0D0) ! 20
       ENDDO
       PS=-EL+2.0D0*S-1.386294361119891D0
    ELSE
       IF (XA.LT.10.0) THEN
          N=10-INT(XA)
          DO K=0,N-1
             S=S+1.0D0/(XA+K)
          ENDDO
          XA=XA+N
       ENDIF
       X2=1.0D0/(XA*XA)
       A1=-.8333333333333D-01
       A2=.83333333333333333D-02
       A3=-.39682539682539683D-02
       A4=.41666666666666667D-02
       A5=-.75757575757575758D-02
       A6=.21092796092796093D-01
       A7=-.83333333333333333D-01
       A8=.4432598039215686D0
       PS=DLOG(XA)-.5D0/XA+X2*(((((((A8*X2+A7)*X2+&
            A6)*X2+A5)*X2+A4)*X2+A3)*X2+A2)*X2+A1)
       PS=PS-S
    ENDIF
    IF (X.LT.0.0) PS=PS-PI*DCOS(PI*X)/DSIN(PI*X)-1.0D0/X
    RETURN
  END SUBROUTINE PSI
END MODULE SPECIAL_FUN


! Learn_dg - A quick and dirty project to deploy a working DG solver
! Copyright (c) 2017, Chris Coutinho
! All rights reserved.
!
! Licensed under the BSD-2 clause license. See LICENSE for details.

submodule (mod_assembly) smod_assemble_2D
    use, intrinsic  :: iso_fortran_env, only: wp => real64
    use             :: mod_linalg,      only: inv2, det2
    use             :: mod_legendre,    only: getAlpha => getAlpha2D
    use             :: mod_integration, only: integrate
    use             :: lib_array,       only: linspace
    implicit none

contains

    module function assembleElementalMatrix2D(N, d1, d2, xy) result(Ie)
        ! Dummy variables
        integer,                  intent(in)  :: N, d1, d2
        real(wp), dimension(N,2), intent(in)  :: xy
        real(wp), dimension(N,N)              :: Ie

        ! Local variables
        integer                           :: node1, node2
        real(wp), dimension(N,N), target  :: alpha

        ! Get the coefficients of the basis functions (alpha)
        ! Supported 2D basis functions:
        !   Bi-linear quadrilaterals (N=4)
        !   Bi-quadratic quadrilaterals (N=9)
        !   Bi-cubic quadrilaterals (N=16)
        !   Bi-quartic quadrilaterals (N=25)
        alpha = getAlpha(N)

        Ie = 0._wp

        outer: do node1 = 1, N
            inner: do node2 = 1, N

                ! fun is now implicitly defined using the following: node1, node2, d1, and d2
                Ie(node1,node2) = Ie(node1,node2) + integrate(fun, [-1._wp, 1._wp], [-1._wp, 1._wp])

            enddo inner
        enddo outer
        return
    contains
        function fun(xi, eta) result(out)
            ! Dummy variables
            real(wp), dimension(:,:), intent(in)  :: xi, eta
            real(wp), dimension(:,:), allocatable :: out

            ! Local variables
            integer                         :: ii, jj, num_pts
            real(wp), parameter             :: eps = epsilon(0e0)
            real(wp)                        :: fun1, fun2
            real(wp), dimension(2)          :: dfun1, dfun2
            real(wp)                        :: detJ
            real(wp), dimension(2,2)        :: J, invJ
            real(wp), dimension(:), pointer :: alpha_row

            ! Initialize function output. Actual number of pts is num_pts*num_pts,
            ! because the meshgrid goes in both x and y directions. Only need one.
            num_pts = size(xi,1)

            allocate(out(num_pts,num_pts))
            out = 0._wp

            outer: do ii = 1, num_pts
                inner: do jj = 1, num_pts

                    ! Calculate Jacobian, inverse Jacobian, and determinant of finite
                    ! element at (xi,eta)
                    J     = getJacobian(N, xi(ii,jj), eta(ii,jj), xy, alpha)
                    invJ  = inv2(J)
                    detJ  = det2(J)

                    alpha_row => alpha(:,node1)

                    ! If fun1 is just N_i, use dot_product to determine N_i
                    if ( d1 == 0 ) then
                        fun1 = dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)))
                    else

                        ! If fun1 contains a derivative, need to calc N_i,xi and N_i,eta
                        dfun1(1) = ( &
                            dot_product(alpha_row, getArow(N, xi(ii,jj)+eps, eta(ii,jj))) - &
                            dot_product(alpha_row, getArow(N, xi(ii,jj)-eps, eta(ii,jj))) &
                            ) / ( 2._wp*eps )

                        dfun1(2) = ( &
                            dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)+eps)) - &
                            dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)-eps)) &
                            ) / ( 2._wp*eps )

                        ! N_i,x = dxi/dx * N_i,xi + deta/dx * N_i,eta
                        fun1 = dot_product(invJ(d1,:), dfun1)

                    endif

                    alpha_row => alpha(:,node2)

                    ! If fun2 is just N_i, use dot_product to determine N_i
                    if ( d2 == 0 ) then
                        fun2 = dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)))
                    else

                        ! If fun2 contains a derivative, need to calc N_i,xi and N_i,eta
                        dfun2(1) =  ( &
                            dot_product(alpha_row, getArow(N, xi(ii,jj)+eps, eta(ii,jj))) - &
                            dot_product(alpha_row, getArow(N, xi(ii,jj)-eps, eta(ii,jj))) &
                            ) / ( 2._wp*eps )

                        dfun2(2) =  ( &
                            dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)+eps)) - &
                            dot_product(alpha_row, getArow(N, xi(ii,jj), eta(ii,jj)-eps)) &
                            ) / ( 2._wp*eps )

                        ! N_i,y = dxi/dy * N_i,xi + deta/dy * N_i,eta
                        fun2 = dot_product(invJ(d2,:), dfun2)

                    endif

                    out(ii,jj) = fun1 * fun2 * detJ

                enddo inner
            enddo outer
            return
        end function fun
    end function assembleElementalMatrix2D

    module subroutine assemble2D(points, cells, diff, vel, GlobalA)
        integer,  intent(in),   dimension(:,:)  :: cells
        real(wp), intent(in)                    :: diff
        real(wp), intent(in),   dimension(2)    :: vel
        real(wp), intent(in),   dimension(:,:)  :: points
        real(wp), intent(out),  dimension(:,:)  :: GlobalA

        integer                                 :: ii, jj
        integer                                 :: num_cells, num_pts
        real(wp), parameter                     :: eps = epsilon(0e0)
        real(wp), dimension(:,:), allocatable   :: Ie, xy

        GlobalA   = 0._wp
        num_cells = size(cells, 1)
        num_pts   = size(cells, 2)

        allocate(xy(num_pts, 2), Ie(num_pts, num_pts))

        ! NOTE: This is assuming that all elements have the same number of points
        !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(ii, xy, Ie) REDUCTION(+:GlobalA)
        !$OMP DO
        outer: do ii = 1, num_cells

            xy = points(cells(ii,:), :)

            ! *** Elemental matrix for diffusion in X and Y ***

            Ie  = assembleElementalMatrix(num_pts, 1, 1, xy) + &
                & assembleElementalMatrix(num_pts, 2, 2, xy)

            GlobalA(cells(ii,:), cells(ii,:)) = &
                & GlobalA(cells(ii,:), cells(ii,:)) - diff*Ie

            ! Add elemental matrix for velcity in X (1) and Y (2) to GlobalA
            adv: do jj = 1, 2
                if ( abs(vel(jj)) .gt. eps ) then

                    Ie = assembleElementalMatrix(num_pts, 0, jj, xy)

                    GlobalA(cells(ii,:), cells(ii,:)) = &
                        & GlobalA(cells(ii,:), cells(ii,:)) - vel(jj)*Ie

                endif
            enddo adv
        enddo outer
        !$OMP END DO NOWAIT
        !$OMP END PARALLEL

        deallocate(Ie, xy)
        return
    end subroutine assemble2D

end submodule


	SUBROUTINE MR_INTP  ( sclhgt, iztype, nlev, ipt, stndat, iret )
C************************************************************************
C* MR_INTP								*
C*									*
C* This subroutine computes pressure for the significant wind data.	*
C* The data must be ordered according to height before calling this	*
C* subroutine.  The pressure is computed using the scale heights 	*
C* previously computed.  If scale heights are not available (i.e.,	*
C* iztype = 1), the subroutine will compute pressure from the 		*
C* bounding values of height assuming that height varies linearly 	*
C* with the logarithm of pressure.					*
C*									*
C* MR_INTP  ( SCLHGT, IZTYPE, NLEV, IPT, STNDAT, IRET )			*
C*									*
C* Input parameters:							*
C*	SCLHGT ( NLEV )	REAL		Scale height			*
C*	IZTYPE		INTEGER		Type of height interpolation	*
C*					  1 = int wrt log p		*
C*					  2 = moist hydrostatic comp	*
C*					  3 = scaled moist hydro comp	*
C*	NLEV		INTEGER		Number of levels		*
C*	IPT    ( NLEV )	INTEGER		Pointers to ordered data	*
C*									*
C* Input and output parameters:						*
C*	STNDAT (6,NLEV)	REAL		Station data			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/86						*
C* T. Piper/GSC		11/98	Updated prolog				*
C* T. Piper/SAIC	 1/02	Initialized pt & zt, not always set	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	REAL		sclhgt (*), stndat (6,*)
	INTEGER		ipt (*)
	LOGICAL		start
C
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Loop through all the levels using the scale height computed
C*	previously.  Start at the top of the sounding.
C
	pt = RMISSD
	zt = RMISSD
	IF ( ( iztype .eq. 2 ) .or. ( iztype .eq. 3 ) ) THEN
	  start = .false.
	  DO  i = nlev, 2, -1
	    p = stndat ( 1, ipt (i) )
	    h = stndat ( 6, ipt (i) )
	    s = sclhgt ( ipt (i) )
	    IF  ( (.not. ERMISS (p) ) .and. (.not. ERMISS (h) ) .and.
     +		  (.not. ERMISS (s) ) )  THEN
		start = .true.
		pt    =  p
		st    =  s
		ht    =  h
	      ELSE IF ( start .and. ( .not. ERMISS (h) ) .and.
     +			( ERMISS ( p ) ) ) THEN
C
C*		Reverse the computation for the moist height to compute
C*		pressure.
C
		IF ( .not. ERMISS ( st ) ) THEN
		    stndat (1, ipt (i) ) = pt * EXP ( ( ht - h ) / st )
		END IF
	    END IF
	END DO
C
C*	If scale heights were not available for computation, interpolate
C*	log p linearly with z.
C
	  ELSE
	    i    = 1
	    ilev = 0
	    klev = 0
	    DO WHILE ( i .le. nlev )
C
C*		Check for both pressure and height data at this level.
C
		p = stndat ( 1, ipt (i) )
		z = stndat ( 6, ipt (i) )
		IF ((.not. ERMISS (p) ) .and. (.not. ERMISS (z) )) THEN
		    klev = i
		    pt   = p
		    zt   = z
		END IF
C
C*		If two bounding levels have been found, interpolate
C*		missing values of p.
C
		IF ( (ilev .ne. 0 ) .and. (klev .ne. 0) ) THEN
		    DO  j = ilev+1, klev-1
			z = stndat ( 6, ipt (j) )
			IF ( .not. ERMISS (z) ) THEN
			    stndat ( 1, ipt (j) ) = pb *
     +				EXP ( ( z - zb ) * ALOG ( pt/ pb ) /
     +				( zt - zb ) )
			END IF
		    END DO
		END IF
C
C*		Change the top level to the bottom level.
C
		ilev = klev
		pb   = pt
		zb   = zt
C
C*		Increment current level.
C
		i = i + 1
	    END DO
	END IF
C*
	RETURN
	END


c ------------------------------------------------------------
      subroutine chgrid (fx, x, nx, fy, y, ny)
!  piecewise quadratic interpolation from grid x to grid y,  by
!  aitken's divided difference scheme.   nx,ny are array dimensions?
!  note that ny is reset in chgrid

      dimension fx(nx), x(nx), fy(ny), y(ny)

      iy=1
      do 20 ix = 3, nx
   10   if (iy .gt. ny) goto 30
        yy=y(iy)
        if (yy .gt. x(ix)) goto 20
        a1=x(ix-2)-yy
        a2=x(ix-1)-yy
        a3=x(ix)-yy
        a12=(fx(ix-2)*a2-fx(ix-1)*a1)/(x(ix-1)-x(ix-2))
        a13=(fx(ix-2)*a3-fx(ix)*a1)/(x(ix)-x(ix-2))
        fy(iy)=(a12*a3-a13*a2)/(x(ix)-x(ix-1))
        if (iy .gt. ny) goto 30
        iy=iy+1
        goto 10
   20 continue
   30 ny=iy-1
      return
      end