!	print individual residual data.
!	comment is used for identification.
!	resname gives names of residual elements.
!	unit unitres is the unit for output.
!	useid indicates if ids are put out.
!	covres is residual covariance matrix.
!   fit gives fitted values.
!   observed gives observed values.
!	res  gives residual.
!   sdres gives estimated residual standard errors.
!   zres gives normalized residual.

subroutine resoutput(comment,resname,id,unitres,useid,covres,fit,observed,res,sdres,zres)
implicit none
character(len=*),intent(in)::comment
character(len=*),intent(in)::resname(:)
character(len=*),intent(in),optional::id(:)
integer,intent(in)::unitres
logical,intent(in)::useid
real(kind=8),intent(in)::covres(:,:,:),fit(:,:),observed(:,:),res(:,:),sdres(:,:),zres(:,:)

!	Buffers for writing.
character(len=4)::buffer
character(len=32)::bufferid
character(len=25),allocatable::bufff(:),buffo(:),buffr(:),buffs(:),buffz(:),buffc(:,:)
!	format
character(len=7)::writefmt
!	col is column number.
!	io is error flag.
!   nw is number of weights.
!	obs is observation number.
!	row is row number.

integer::col,io,nw,obs,row
nw=size(resname)

allocate(bufff(nw),buffo(nw),buffr(nw),buffs(nw),buffz(nw),buffc(nw,nw),stat=io)
if(io/=0) stop "Allocation failure for arrays for output of individual residuals."
write(unitres,'(2a)') "Residuals ",comment
write(buffer,'(i4)') 1+2*nw*(nw+5)
writefmt='('//trim(adjustl(buffer))//'a)'
write(unit=unitres,fmt=writefmt,iostat=io) "ID",&
    (",","Observed_"//trim(adjustl(resname(row))),row=1,nw),&
    (",","Fitted_"//trim(adjustl(resname(row))),row=1,nw),&
    (",","Residual_"//trim(adjustl(resname(row))),row=1,nw),&
    (",","SE_Res_"//trim(adjustl(resname(row))),row=1,nw),&
    (",","Adj_res__"//trim(adjustl(resname(row))),row=1,nw),&
    ((",","Cov_Res_"//trim(adjustl(resname(row)))//"_"//trim(adjustl(resname(col))),&
    col=1,nw),row=1,nw)
if(io/=0) stop "Writing of individual residuals failed."

do obs=1,size(res,2)
    do row=1,nw
        write(bufff(row),'(g25.16e3)')fit(row,obs)
        write(buffo(row),'(g25.16e3)')observed(row,obs)
        write(buffr(row),'(g25.16e3)')res(row,obs)
        write(buffs(row),'(g25.16e3)')sdres(row,obs)
        write(buffz(row),'(g25.16e3)')zres(row,obs)
        do col=1,nw
            write(buffc(row,col),'(g25.16e3)')covres(row,col,obs)
        end do
    end do
    if(useid)then
        bufferid=id(obs)
    else
        write(bufferid,'(i12)') obs
    end if
    write(unit=unitres,fmt=writefmt,iostat=io) trim(adjustl(bufferid)),&
        (",",trim(adjustl(buffo(row))),row=1,nw),&
        (",",trim(adjustl(bufff(row))),row=1,nw),&
        (",",trim(adjustl(buffr(row))),row=1,nw),&
        (",",trim(adjustl(buffs(row))),row=1,nw),&
        (",",trim(adjustl(buffz(row))),row=1,nw),&
        ((",",trim(adjustl(buffc(row,col))),col=1,nw),&
        row=1,nw)

        if(io/=0) stop "Writing of individual residuals failed."
end do
return

end subroutine resoutput


!> @file
!! check to see if value exceeds threshold

!  --------------------------------------------------------------
!> @brief Check if the difference exceeds the threshold
!!
!! @param[in] blockno the block number
!! @param[in] qval the
!! @param[in] qmin the minimum q value
!! @param[in] qmax the maximum q value
!! @param[in] quad the value and adjacent values of q
!! @param[in] dx, dy the spacing in the x and y directions
!! @param[in] xc, yc the coordinate of the cell
!! @param[in] threshold the threshold
!! @param[in] init_flag true if in init stage
!! @param[in] is_ghost true if cell is a ghost cell
!! @return 1 if exceeds threshold, 0 if not, -1 if inconclusive.
!  --------------------------------------------------------------
integer function fclaw2d_clawpatch_difference_exceeds_th(blockno,&
                                     qval,qmin,qmax,quad, &
                                     dx,dy,xc,yc,threshold,&
                                     init_flag, is_ghost)
    implicit none

    double precision :: qval,qmin,qmax,threshold
    double precision :: quad(-1:1,-1:1)
    double precision :: dx,dy, xc, yc
    integer :: blockno, init_flag
    logical(kind=4) :: is_ghost

    double precision :: dqx, dqy, dq
    integer :: refine

    if (is_ghost) then
!!      # quad may have uninitialized values;  test inconclusive
        fclaw2d_clawpatch_difference_exceeds_th = -1
        return
    endif

    dqx = abs(quad(1,0) - quad(-1,0))
    dqy = abs(quad(0,1) - quad(0,-1))
    dq  = max(dqx, dqy)

    refine = 0
    if (dq .gt. threshold) then
        refine = 1
    endif

    fclaw2d_clawpatch_difference_exceeds_th = refine

end function fclaw2d_clawpatch_difference_exceeds_th


      implicit real *8 (a-h,o-z)
      integer ns,nt
      double complex zk
      double precision, allocatable :: sources(:,:),targs(:,:)
      double complex, allocatable :: h_current(:,:,:),e_charge(:,:)
      double complex, allocatable :: e_current(:,:,:)
      double complex, allocatable :: E(:,:,:),divE(:,:),curlE(:,:,:)
      double complex ima
      double precision thresh
      double precision t1,t2,omp_get_wtime
      data ima/(0.0d0,1.0d0)/

      call prini(6,13)

      ns = 4001
      nt = 3998

      nd = 2
      zk = 1.1d0 + ima*0.1d0

      allocate(sources(3,ns))
      allocate(h_current(nd,3,ns),e_current(nd,3,ns),e_charge(nd,ns))

      allocate(targs(3,nt),E(nd,3,nt),divE(nd,nt),curlE(nd,3,nt))

c
cc  generate sourcrs in the unit cube
c

c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,l)
      do i=1,ns
        sources(1,i) = hkrand(0)**2
        sources(2,i) = hkrand(0)**2
        sources(3,i) = hkrand(0)**2
        do l=1,3
          do j=1,nd
            h_current(j,l,i) = hkrand(0) + ima*hkrand(0)
            e_current(j,l,i) = hkrand(0) + ima*hkrand(0)
          enddo
        enddo

        do j=1,nd
          e_charge(j,i) = hkrand(0) + ima*hkrand(0)
        enddo
      enddo
C$OMP END PARALLEL DO

c
c   generate targets in the unit cube
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
      do i=1,nt
        targs(1,i) = hkrand(0)**2
        targs(2,i) = hkrand(0)**2
        targs(3,i) = hkrand(0)**2
        do j=1,nd
          E(j,1,i) = 0
          E(j,2,i) = 0
          E(j,3,i) = 0
        enddo
      enddo
C$OMP END PARALLEL DO

c
cc  test h_current, e_charge
cc   with fields
c
      write(6,*) 'interaction: h_current,e_charge'
      write(6,*) 'output: fields'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 0
      ifcurlE = 0
      ifh_current = 1
      ife_current = 0
      ife_charge = 1
      ier = 0

      eps = 0.5d-3

      call cpu_time(t1)
C$     t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifh_current,h_current,
     1  ife_current,e_current,ife_charge,e_charge,nt,targs,ifE,E,
     2  ifcurlE,curlE,ifdivE,divE,ier)
      call cpu_time(t2)
C$      t2 = omp_get_wtime()

c      write(*,*) 'E='
c      write(*,'(6(2x,e11.5))') E(1:2,1:3,1:2)

      call prin2('E=*',E,12)
      return
      end


      subroutine NODEINTERPMG_GETWEIGHTS(
     &           nref
     &           ,ibreflo0,ibreflo1
     &           ,ibrefhi0,ibrefhi1
     &           ,wtcrnr
     &           ,iwtcrnrlo0,iwtcrnrlo1
     &           ,iwtcrnrhi0,iwtcrnrhi1
     &           ,nwtcrnrcomp
     &           )
      implicit none
      integer nref
      integer ibreflo0,ibreflo1
      integer ibrefhi0,ibrefhi1
      integer nwtcrnrcomp
      integer iwtcrnrlo0,iwtcrnrlo1
      integer iwtcrnrhi0,iwtcrnrhi1
      REAL*8 wtcrnr(
     &           iwtcrnrlo0:iwtcrnrhi0,
     &           iwtcrnrlo1:iwtcrnrhi1,
     &           0:nwtcrnrcomp-1)
      integer iref0,iref1
      integer ib0,ib1
      integer nvwt
      integer ibmax0,ibmax1
      REAL*8 refinv, wt
      REAL*8 fraci0,fraci1
      REAL*8 wti0,wti1
      refinv = (1.0d0) / nref
      nvwt = 0
      do iref1 = ibreflo1,ibrefhi1
      do iref0 = ibreflo0,ibrefhi0
         call maxb(iref0, ibmax0)
         call maxb(iref1, ibmax1)
         fraci0 = iref0 * refinv
         fraci1 = iref1 * refinv
         do ib0 = 0, ibmax0
         do ib1 = 0, ibmax1
            wt = (1.0d0)
            call wtside(ib0, fraci0, wti0)
            wt = wt * wti0
            call wtside(ib1, fraci1, wti1)
            wt = wt * wti1
            wtcrnr( ib0,ib1, nvwt ) = wt
         end do
         end do
         nvwt = nvwt + 1
      enddo
      enddo
      return
      end
      subroutine NODEINTERPMG(
     &           fine
     &           ,ifinelo0,ifinelo1
     &           ,ifinehi0,ifinehi1
     &           ,nfinecomp
     &           ,crse
     &           ,icrselo0,icrselo1
     &           ,icrsehi0,icrsehi1
     &           ,ncrsecomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,nref
     &           ,ibreflo0,ibreflo1
     &           ,ibrefhi0,ibrefhi1
     &           ,wtcrnr
     &           ,iwtcrnrlo0,iwtcrnrlo1
     &           ,iwtcrnrhi0,iwtcrnrhi1
     &           ,nwtcrnrcomp
     &           )
      implicit none
      integer nfinecomp
      integer ifinelo0,ifinelo1
      integer ifinehi0,ifinehi1
      REAL*8 fine(
     &           ifinelo0:ifinehi0,
     &           ifinelo1:ifinehi1,
     &           0:nfinecomp-1)
      integer ncrsecomp
      integer icrselo0,icrselo1
      integer icrsehi0,icrsehi1
      REAL*8 crse(
     &           icrselo0:icrsehi0,
     &           icrselo1:icrsehi1,
     &           0:ncrsecomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      integer nref
      integer ibreflo0,ibreflo1
      integer ibrefhi0,ibrefhi1
      integer nwtcrnrcomp
      integer iwtcrnrlo0,iwtcrnrlo1
      integer iwtcrnrhi0,iwtcrnrhi1
      REAL*8 wtcrnr(
     &           iwtcrnrlo0:iwtcrnrhi0,
     &           iwtcrnrlo1:iwtcrnrhi1,
     &           0:nwtcrnrcomp-1)
      integer iref0,iref1, icrse0,icrse1
      integer ifine0,ifine1, ib0,ib1;
      integer var, ncomp, nvwt
      integer ibmax0,ibmax1
      integer icmin0,icmin1
      integer icmax0,icmax1;
      REAL*8 csum, refinv
      ncomp = nfinecomp
      if (ncomp .ne. ncrsecomp) then
         print *, 'nodeinterpmg: fine and crse incompatible'
         call MAYDAY_ERROR()
      endif
      refinv = (1.0d0) / nref
      icmin0 = iregionlo0
      icmin1 = iregionlo1
      nvwt = 0
      do iref1 = ibreflo1,ibrefhi1
      do iref0 = ibreflo0,ibrefhi0
         call maxb(iref0, ibmax0)
         call maxb(iref1, ibmax1)
         icmax0 = iregionhi0 + (1-ibmax0)
         icmax1 = iregionhi1 + (1-ibmax1)
         do icrse0 = icmin0, icmax0
         do icrse1 = icmin1, icmax1
            ifine0 = nref*icrse0 + iref0
            ifine1 = nref*icrse1 + iref1
            do var = 0, ncomp-1
               csum = 0
               do ib0 = 0, ibmax0
               do ib1 = 0, ibmax1
                  csum = csum + wtcrnr( ib0,ib1, nvwt ) *
     &              crse( icrse0+ib0,icrse1+ib1, var)
               end do
               end do
               fine ( ifine0,ifine1, var ) = csum +
     &              fine ( ifine0,ifine1, var )
            end do
         end do
         end do
         nvwt = nvwt + 1
      enddo
      enddo
      return
      end
      subroutine WTSIDE(
     &           i
     &           ,frac
     &           ,wt
     &           )
      implicit none
      integer i
      REAL*8 frac
      REAL*8 wt
      if (i .eq. 0) then
         wt = (1.0d0) - frac
      else
         wt = frac
      endif
      return
      end
      subroutine MAXB(
     &           iref
     &           ,ibmax
     &           )
      implicit none
      integer iref
      integer ibmax
      if (iref .eq. 0) then
         ibmax = 0
      else
         ibmax = 1
      endif
      return
      end


!-----------------------------------------------------------------------
!     Subroutine:    chisq_iota
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          06/12/2012
!     Description:   Calculate difference between equilbrium rotational
!                    transform and target rotational transform.
!                    Although iota is not prescribed at real space
!                    points we include it for flexibility.
!-----------------------------------------------------------------------
      SUBROUTINE chisq_vaciota(target,sigma,niter,iflag)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stellopt_runtime
      USE stellopt_targets
      USE equil_utils
      USE EZspline_obj
      USE EZspline

!-----------------------------------------------------------------------
!     Input/Output Variables
!
!-----------------------------------------------------------------------
      REAL(rprec), INTENT(in)    ::  target(nprof)
      REAL(rprec), INTENT(in)    ::  sigma(nprof)
      INTEGER,     INTENT(in)    ::  niter
      INTEGER,     INTENT(inout) ::  iflag

!-----------------------------------------------------------------------
!     Local Variables
!        lreset_s    Gets set to true if using R,PHI,Z Specification
!        ik          Dummy index
!        ier         Error Flag
!        iota_val    Holds profile evaulation
!-----------------------------------------------------------------------
      LOGICAL ::  lreset_s = .true.
      INTEGER ::  ik, ier
      REAL(rprec) :: iota_val, s11, s12, s21, s22
!----------------------------------------------------------------------
!     BEGIN SUBROUTINE
!----------------------------------------------------------------------
      IF (iflag < 0 ) RETURN
      ik = COUNT(sigma < bigno)
      IF (iflag == 1) WRITE(iunit_out,'(A,2(2X,I3.3))') 'VACIOTA ',ik,7
      IF (iflag == 1) WRITE(iunit_out,'(A)') 'R  PHI  Z  S  TARGET  SIGMA  VACIOTA'
      IF (niter >= 0) THEN
         IF (ANY(s_vaciota >= 0)) lreset_s = .false.
         ! GET s if necessary
         DO ik = 1, nprof
            IF (sigma(ik) >= bigno) CYCLE
            ier = 0
            IF (lreset_s) THEN
               CALL get_equil_s(r_vaciota(ik),phi_vaciota(ik),z_vaciota(ik),s_vaciota(ik),ier)
            END IF
            IF (s_vaciota(ik) <= 1.0 .and. s_vaciota(ik) >= 0.0 .and. ier == 0) THEN
               ier = 0
               CALL get_equil_sus(s_vaciota(ik),s11,s12,s21,s22,ier)
               iota_val = -s12/s11
            ELSE
               iota_val = 0.0
            END IF
            mtargets = mtargets + 1
            targets(mtargets) = target(ik)
            sigmas(mtargets)  = sigma(ik)
            vals(mtargets)    = iota_val
            IF (iflag == 1) WRITE(iunit_out,'(7ES22.12E3)') r_vaciota(ik),phi_vaciota(ik),z_vaciota(ik),s_vaciota(ik),target(ik),sigma(ik),iota_val
         END DO
         IF (lreset_s) s_vaciota(:) = -1.0
      ELSE
         DO ik = 1, nprof
            IF (sigma(ik) < bigno) THEN
               mtargets = mtargets + 1
               IF (niter == -2) target_dex(mtargets) = jtarget_vaciota
            END IF
         END DO
      END IF
      RETURN
!----------------------------------------------------------------------
!     END SUBROUTINE
!----------------------------------------------------------------------
      END SUBROUTINE chisq_vaciota


c$$$	program test
c$$$
c$$$	implicit none
c$$$
c$$$	integer          ncomp
c$$$	parameter       (ncomp=4)
c$$$
c$$$	integer          ndim, ncall, maxiter, neval, i1
c$$$	double precision result(ncomp)
c$$$	double precision accuracy
c$$$
c$$$	external         func
c$$$
c$$$	accuracy = 1.d-3
c$$$
c$$$	ndim    = 3
c$$$
c$$$	ncall   = 10000
c$$$	maxiter = 12
c$$$
c$$$	call vegas(func, ncomp, result, accuracy, ndim,
c$$$     +    ncall, maxiter, neval)
c$$$
c$$$c	print*, " neval  = ",neval
c$$$c	do i1=1,ncomp
c$$$c	   print*, " result(i1) = ",i1,result(i1)
c$$$c	end do
c$$$
c$$$	end
c$$$
c$$$c -------------------------------------------------------
c$$$	subroutine func(ndim, x, ncomp, result)
c$$$
c$$$	implicit none
c$$$
c$$$	integer          ndim, ncomp, i1
c$$$	double precision x(ndim), result(ncomp)
c$$$
c$$$c	print*, " input func: ndim = ",ndim
c$$$c	print*, " input func: x    = ",x
c$$$c	print*, " input func: ncomp= ",ncomp
c$$$
c$$$	do i1=1,ncomp
c$$$	   result(1) = 1.d0
c$$$	   result(2) = x(1)
c$$$	   result(3) = x(1)*x(2)
c$$$	   result(4) = x(1)*x(2)*x(3)
c$$$c	   print*, " output func ",i1,result(i1)
c$$$	end do
c$$$
c$$$	return
c$$$	end
c$$$c -------------------------------------------------------

* vegas.F
* VEGAS Monte Carlo integration of a vector either with ordinary random
* numbers or with quasi-random numbers
* based on code by M. Martinez, J. Illana, J. Bossert, and A. Vicini
* this file is part of FormCalc
* last modified 14 Sep 01 th

* ndim_max is the maximum number of dimensions the integrand may have.
* Note: if your Fortran compiler allows, replace ndim_max by ndim
* (i.e. #define ndim_max ndim) to dimension the arrays dynamically.
*#define ndim_max 3

* ncomp is the number of components of the integrand vector.
*#define ncomp 2

* If DEBUG is defined, the error is printed out after each iteration
* so that one can tune the parameters for a particular integral.
ctp #define DEBUG

* RNG determines which random-number generator is used:
* - 1 uses Fortran's ran(...) function,
* - 2 uses a Faure quasi-random sequence,
* - 3 uses a Sobol quasi-random sequence (default).
ctp #define RNG 3

************************************************************************
** vegas integrates a vector in the ndim-dimensional unit hypercube
** using the Monte-Carlo method. The ncomp-dimensional integrand is
** invoked via the subroutine func(ndim, x, ncomp, result). After
** sampling ncall points, the grid is refined. This is called one
** iteration. The iterations loop terminates if the relative error is
** below accuracy, or after maxiter iterations.

** Caution: the refinement of the grid is done only with respect to
** the highest component of the integrand vector.

	subroutine vegas_hahn(func, ncomp, result, accuracy, ndim,
     +    ncall, maxiter, neval)
	implicit none
	integer ncomp, i1
	double precision result(ncomp), accuracy
	integer ndim, ncall, maxiter, neval
	external func

	double precision fun(ncomp), sfun(ncomp), sfun2(ncomp)
	double precision sint(ncomp), sweight(ncomp)
	double precision fun2, sint2, weight
	double precision r, dr, xo, xn, err
	integer iter, call, dim, grid, g, c

	integer rng
	parameter (rng = 1)

	integer ngrid
	parameter (ngrid = 100)

	double precision xi(ngrid, ndim), d(ngrid, ndim)
	double precision x(ndim), imp(ngrid), tmp(ngrid - 1)
	integer pos(ndim)

	if (rng.eq.1) then
	   call inirandom_1(maxiter*ncall, ndim)
	else if (rng.eq.2) then
	   call inirandom_2(maxiter*ncall, ndim)
	else if (rng.eq.3) then
	   call inirandom_3(maxiter*ncall, ndim)
	else
	   print*, " rng wrong, set to 1 "
	   call inirandom_1(maxiter*ncall, ndim)
	end if
	iter = 0
	neval = 0
	do c = 1, ncomp
	  sint(c) = 0
	  sweight(c) = 0
	enddo
	sint2 = 0

* define the initial distribution of intervals
	do grid = 1, ngrid
	  r = dble(grid)/ngrid
	  do dim = 1, ndim
	    xi(grid, dim) = r
	  enddo
	enddo

* iterations loop
1	continue
	iter = iter + 1

* initialize iteration variables
	do c = 1, ncomp
	  sfun(c) = 0
	  sfun2(c) = 0
	enddo
	do dim = 1, ndim
	  do grid = 1, ngrid
	    d(grid, dim) = 0
	  enddo
	enddo

	do call = 1, ncall
	  weight = 1D0/ncall

* compute the point position
	  if (rng.eq.1) then
	     call getrandom_1(x)
	  else if (rng.eq.2) then
	     call getrandom_2(x)
	  else if (rng.eq.3) then
	     call getrandom_3(x)
	  else
	     print*, " rng wrong, set to 1 "
	     call getrandom_1(x)
	  end if
	  do dim = 1, ndim
	    r = x(dim)*ngrid + 1
	    grid = int(r)
	    xo = 0
	    if(grid .gt. 1) xo = xi(grid - 1, dim)
	    xn = xi(grid, dim) - xo
	    x(dim) = xo + (r - grid)*xn
	    pos(dim) = grid
	    weight = weight*xn*ngrid
	  enddo

* compute the function value
	  call func(ndim, x, ncomp, fun)
	  do c = 1, ncomp
	    fun2 = fun(c)*weight
	    sfun(c) = sfun(c) + fun2
	    fun2 = fun2**2
	    sfun2(c) = sfun2(c) + fun2
	  enddo
	  do dim = 1, ndim
	    d(pos(dim), dim) = d(pos(dim), dim) + fun2
	  enddo
	enddo
	neval = neval + ncall

* compute the integral and error values
	do c = 1, ncomp
	  fun2 = sfun(c)**2
	  r = sfun2(c)*ncall - fun2
	  if(r .ne. 0) then
	    weight = fun2/abs(r)*(ncall - 1)
	    sweight(c) = sweight(c) + weight
	    sint(c) = sint(c) + sfun(c)*weight
	  endif
	  if(sweight(c) .eq. 0) then
	    result(c) = 0
	  else
	    result(c) = sint(c)/sweight(c)
	  endif
	enddo
	sint2 = sint2 + fun2
	err = sqrt(sint2/(sweight(ncomp)*iter))/abs(result(ncomp))
ctp #ifdef DEBUG
ctp	print *, "iteration ", iter, "  error ", err
	if (ncomp.eq.1) then
	   print ('(A7,I3,A12,G15.6,A8,G13.4)'),
     &            "  iter=",iter,
     &            "  result=",result,
     &            "  error=",err
	else if (ncomp.eq.2) then
	   print ('(A7,I3,A12,2(G15.6),A8,G13.4)'),
     &            "  iter=",iter,
     &            "  result(i)=",result,
     &            "  error=",err
	else if (ncomp.eq.3) then
	   print ('(A7,I3,A12,3(G15.6),A8,G13.4)'),
     &            "  iter=",iter,
     &            "  result(i)=",result,
     &            "  error=",err
	else if (ncomp.eq.4) then
	   print ('(A7,I3,A12,4(G15.6),A8,G13.4)'),
     &            "  iter=",iter,
     &            "  result(i)=",result,
     &            "  error=",err
	else
	   do i1=1,ncomp
	      print ('(A7,I3,A12,I3,2x,G15.6,A8,G13.4)'),
     &            "  iter=",iter,
     &            "  result(i)=",i1,result(i1),
     &            "  error=",err
	   end do
	end if
ctp #endif
	if(result(ncomp) .eq. 0 .or. err .lt. accuracy) return
	if(iter .gt. maxiter) then
	  print *,
     +      "Warning: VEGAS failed to reach the desired accuracy."
	  print *, "Remaining relative error: ", err
	  return
	endif

* redefine the grid (importance sampling)
* - smooth the f^2 value stored for each interval
	do dim = 1, ndim
	  xo = d(1, dim)
	  xn = d(2, dim)
	  d(1, dim) = .5D0*(xo + xn)
	  x(dim) = d(1, dim)
	  do grid = 2, ngrid - 1
	    r = xo + xn
	    xo = xn
	    xn = d(grid + 1, dim)
	    d(grid, dim) = (r + xn)/3D0
	    x(dim) = x(dim) + d(grid, dim)
	  enddo
	  d(ngrid, dim) = .5D0*(xo + xn)
	  x(dim) = x(dim) + d(ngrid, dim)
	enddo

* - compute the importance function of each interval
	do dim = 1, ndim
	  r = 0
	  do grid = 1, ngrid
	    imp(grid) = 0
	    if(d(grid, dim) .gt. 0) then
	      xo = x(dim)/d(grid, dim)
	      imp(grid) = ((xo - 1)/xo/log(xo))**1.5D0
	    endif
	    r = r + imp(grid)
	  enddo
	  r = r/ngrid

* - redefine the size of each interval
	  dr = 0
	  xn = 0
	  g = 0
	  do grid = 1, ngrid - 1
	    do while(dr .lt. r)
	      g = g + 1
	      dr = dr + imp(g)
	      xo = xn
	      xn = xi(g, dim)
	    enddo
	    dr = dr - r
	    tmp(grid) = xn - (xn - xo)*dr/imp(g)
	  enddo
	  do grid = 1, ngrid - 1
	    xi(grid, dim) = tmp(grid)
	  enddo
	  xi(ngrid, dim) = 1
	enddo

	goto 1
	end

ctp #if RNG == 1

************************************************************************
** inirandom sets up the random-number generator to produce at most
** max dims-dimensional quasi-random vectors

	subroutine inirandom_1(max, dims)
	implicit none
	integer max, dims

	integer ndim
	common /rngdata_1/ ndim

	ndim = dims
	end

************************************************************************
** getrandom is a subtractive Mitchell-Moore random-number generator.
** The algorithm is n(i) = (n(i - 24) - n(i - 55)) mod m, implemented
** as a circular array with n(i + 55) = n(i) and m = 2^30 in this
** version. The array n has been initialized by setting n(i) = i and
** running the algorithm 100,000 times. Code by Ronald Kleiss.

	subroutine getrandom_1(array)
	implicit none
	double precision array(*)

	integer ndim
	common /rngdata_1/ ndim

	integer dim, j, k, l, m, n(55)
	parameter (m = 2**30)
	data k /55/, l /31/
	data n /
     +    980629335, 889272121, 422278310,1042669295, 531256381,
     +    335028099,  47160432, 788808135, 660624592, 793263632,
     +    998900570, 470796980, 327436767, 287473989, 119515078,
     +    575143087, 922274831,  21914605, 923291707, 753782759,
     +    254480986, 816423843, 931542684, 993691006, 343157264,
     +    272972469, 733687879, 468941742, 444207473, 896089285,
     +    629371118, 892845902, 163581912, 861580190,  85601059,
     +    899226806, 438711780, 921057966, 794646776, 417139730,
     +    343610085, 737162282,1024718389,  65196680, 954338580,
     +    642649958, 240238978, 722544540, 281483031,1024570269,
     +    602730138, 915220349, 651571385, 405259519, 145115737 /

	do dim = 1, ndim
	  k = mod(k, 55) + 1
	  l = mod(l, 55) + 1
	  j = n(l) - n(k)
	  if(j .lt. 0) j = j + m
	  n(k) = j
	  array(dim) = dble(j)/m
	enddo
	end

ctp #elif RNG == 2

************************************************************************
** inirandom sets up the random-number generator to produce a Faure
** sequence of at most max dims-dimensional quasi-random vectors.
** Adapted from ACM TOMS algorithm 659, see
** http://www.acm.org/pubs/citations/journals/toms/1988-14-1/p88-bratley

	subroutine inirandom_2(max, dims)
	implicit none
	integer max, dims

	integer coeff(0:19, 0:19)
	integer ndim, prime, nextn, testn, digits
	common /rngdata_2/ coeff, ndim, prime, nextn, testn, digits

	integer i, j, h

	integer primes(40)
	save primes

	data primes /
     +    1, 2, 3, 5, 5, 7, 7, 11, 11, 11, 11,
     +    13, 13, 17, 17, 17, 17, 19, 19,
     +    23, 23, 23, 23, 29, 29, 29, 29,
     +    29, 29, 31, 31, 37, 37, 37, 37,
     +    37, 37, 41, 41, 41 /

	ndim = dims
	prime = primes(dims)
	testn = prime**4
	nextn = testn - 1
	digits = 3

	h = nint(log(dble(max + testn))/log(dble(prime)))
	coeff(0, 0) = 1
	do j = 1, h
	  coeff(j, 0) = 1
	  coeff(j, j) = 1
	enddo
	do j = 1, h
	  do i = j + 1, h
	    coeff(i, j) =
     +        mod(coeff(i - 1, j) + coeff(i - 1, j - 1), prime)
	  enddo
	enddo
	end

************************************************************************
** getrandom generates a vector of random numbers

	subroutine getrandom_2(array)
	implicit none
	double precision array(*)

	integer coeff(0:19, 0:19)
	integer ndim, prime, nextn, testn, digits
	common /rngdata_2/ coeff, ndim, prime, nextn, testn, digits

	integer y(0:19), digit, dim, d, k, p
	double precision r

	p = testn
	k = nextn
	do digit = digits, 0, -1
	  p = p/prime
	  d = mod(k, p)
	  y(digit) = (k - d)/p
	  k = d
	enddo

	r = 0
	do digit = digits, 0, -1
	  r = (r + y(digit))/prime
	enddo
	array(1) = r

	do dim = 2, ndim
	  r = 0
	  p = 1
	  do digit = 0, digits
	    k = 0
	    do d = digit, digits
	      k = k + coeff(d, digit)*y(d)
	    enddo
	    y(digit) = mod(k, prime)
	    p = p*prime
	    r = r + dble(y(digit))/p
	  enddo
	  array(dim) = r
	enddo

	nextn = nextn + 1
	if(nextn .eq. testn) then
	   testn = testn*prime
	   digits = digits + 1
	endif
	end

ctp #else

************************************************************************
** inirandom sets up the random-number generator to produce a Sobol
** sequence of at most max dims-dimensional quasi-random vectors.
** Adapted from ACM TOMS algorithm 659, see
** http://www.acm.org/pubs/citations/journals/toms/1988-14-1/p88-bratley

	subroutine inirandom_3(max, dims)
	implicit none
	integer max, dims

	integer v(40, 30), lastq(40)
	integer ndim, count, norm
	common /rngdata_3/ v, lastq, ndim, count, norm

	integer bits, powers, degree, newv, dim, bit, deg, k

	integer poly(2:40), vinit(2:40, 1:8)
	save poly, vinit

	data poly / 3, 7, 11, 13, 19, 25, 37, 59, 47,
     +    61, 55, 41, 67, 97, 91, 109, 103, 115, 131,
     +    193, 137, 145, 143, 241, 157, 185, 167, 229, 171,
     +    213, 191, 253, 203, 211, 239, 247, 285, 369, 299 /

	data (vinit(dim, 1), dim = 2, 40) / 39*1 /
	data (vinit(dim, 2), dim = 3, 40) /
     +          1, 3, 1, 3, 1, 3, 3, 1,
     +    3, 1, 3, 1, 3, 1, 1, 3, 1, 3,
     +    1, 3, 1, 3, 3, 1, 3, 1, 3, 1,
     +    3, 1, 1, 3, 1, 3, 1, 3, 1, 3 /
	data (vinit(dim, 3), dim = 4, 40) /
     +             7, 5, 1, 3, 3, 7, 5,
     +    5, 7, 7, 1, 3, 3, 7, 5, 1, 1,
     +    5, 3, 3, 1, 7, 5, 1, 3, 3, 7,
     +    5, 1, 1, 5, 7, 7, 5, 1, 3, 3 /
	data (vinit(dim, 4), dim = 6, 40) /
     +                  1, 7, 9, 13, 11,
     +    1, 3, 7, 9, 5, 13, 13, 11, 3, 15,
     +    5, 3, 15, 7, 9, 13, 9, 1, 11, 7,
     +    5, 15, 1, 15, 11, 5, 3, 1, 7, 9 /
	data (vinit(dim, 5), dim = 8, 40) /
     +                            9, 3, 27,
     +    15, 29, 21, 23, 19, 11, 25, 7, 13, 17,
     +    1, 25, 29, 3, 31, 11, 5, 23, 27, 19,
     +    21, 5, 1, 17, 13, 7, 15, 9, 31, 9 /
	data (vinit(dim, 6), dim = 14, 40) /
     +            37, 33, 7, 5, 11, 39, 63,
     +    27, 17, 15, 23, 29, 3, 21, 13, 31, 25,
     +    9, 49, 33, 19, 29, 11, 19, 27, 15, 25 /
	data (vinit(dim, 7), dim = 20, 40) /
     +                                  13,
     +    33, 115, 41, 79, 17, 29, 119, 75, 73, 105,
     +    7, 59, 65, 21, 3, 113, 61, 89, 45, 107 /
	data (vinit(dim, 8), dim = 38, 40) / 7, 23, 39 /

	k = max
	bits = 0
	do while(k .ne. 0)
	  bits = bits + 1
	  k = ishft(k, -1)
	enddo

	do bit = 1, bits
	  v(1, bit) = 1
	enddo

	do dim = 2, dims
	  powers = poly(dim)

	  k = powers
	  degree = -1
	  do while(k .ne. 0)
	    degree = degree + 1
	    k = ishft(k, -1)
	  enddo

	  do bit = 1, degree
	    v(dim, bit) = vinit(dim, bit)
	  enddo

	  do bit = degree + 1, bits
	    newv = v(dim, bit - degree)
	    k = powers
	    do deg = degree, 1, -1
	      if(btest(k, 0))
     +          newv = ieor(newv, ishft(v(dim, bit - deg), deg))
	      k = ishft(k, -1)
	    enddo
	    v(dim, bit) = newv
	  enddo
	enddo

	do bit = 1, bits - 1
	  do dim = 1, dims
	    v(dim, bit) = ishft(v(dim, bit), bits - bit)
	  enddo
	enddo
	norm = ishft(1, bits)

	count = 0
	ndim = dims
	do dim = 1, dims
	  lastq(dim) = 0
	enddo
	end

************************************************************************
** getrandom generates a vector of random numbers

	subroutine getrandom_3(array)
	implicit none
	double precision array(*)

	integer v(40, 30), lastq(40)
	integer ndim, count, norm
	common /rngdata_3/ v, lastq, ndim, count, norm

	integer c, zerobit, dim

	c = count
	zerobit = 1
	do while(btest(c, 0))
	  zerobit = zerobit + 1
	  c = ishft(c, -1)
	enddo

	do dim = 1, ndim
	  lastq(dim) = ieor(lastq(dim), v(dim, zerobit))
	  array(dim) = dble(lastq(dim))/norm
	enddo

	count = count + 1
	end

ctp #endif


        INTEGER FUNCTION STR2INT( STRING )

C***********************************************************************
C Version "$Id: str2int.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr., and
C (C) 2003-2010 by Baron Advanced Meteorological Systems.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  function body starts at line 57
C
C  RETURNS:
C       INTEGER value decoded from STRING, or IMISS3 for "missing",
C       after skipping leading blanks.
C
C  PRECONDITIONS REQUIRED:
C       Properly formatted integer in STRING
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C       M3WARN()
C
C  REVISION  HISTORY:
C       Prototype 6/95 by CJC for point source prototype
C
C       Modified 03/2010 by CJC: F90 changes for I/O API v3.1
C***********************************************************************

      IMPLICIT NONE

C...........   INCLUDES:

        INCLUDE 'PARMS3.EXT'

C...........   ARGUMENTS and their descriptions:

        CHARACTER*(*), INTENT(IN   ) :: STRING

C...........   PARAMETERS

        CHARACTER*1, PARAMETER :: BLANK = ' '

C...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         SUM, SIGN
        INTEGER         I, J, K, L
        INTEGER         IC, I0
        CHARACTER*80    MESG

C***********************************************************************
C   begin body of function  STR2INT

        L = LEN( STRING )

        DO  11  I = 1, L        !  skip leading whitespace
            IF ( STRING( I:I ) .GT. BLANK ) GO TO 12
11      CONTINUE

C.......   If you get to here:  no number there

        STR2INT = IMISS3
        RETURN

12      CONTINUE

        IF( STRING( I:I ) .EQ. '-' ) THEN       !  adjust for sign
            SIGN = -1
            I    = I + 1
        ELSE IF( STRING( I:I ) .EQ. '+' ) THEN
            SIGN = 1
            I    = I + 1
        ELSE
            SIGN = 1
        END IF

        SUM = 0         !  accumulate as long as there are digits.
        K   = 0
        I0  = ICHAR( '0' )
        DO  22  J = I, L
            IC = ICHAR( STRING( J:J ) ) - I0
            IF ( IC .LT. 0  .OR.  IC .GT. 9 )  GO TO  23
            SUM = 10 * SUM  +  IC
            K   = K   +  1
22      CONTINUE
23      CONTINUE

        IF ( K .GT. 0 ) THEN
            STR2INT = SIGN * SUM
        ELSE
            MESG = 'No digits in  "' // STRING // '"'
            CALL M3WARN( 'STR2INT', 0, 0, MESG )
            STR2INT = IMISS3
        END IF

        RETURN
        END FUNCTION STR2INT


program main
   implicit none
   integer, parameter:: dp=selected_real_kind(p=32)
   real(kind=dp) :: a
   a =  1.0_dp/3
   print *, a
end program


c
c	Function varies from 0 to 1 to within 0.1%
c	as the arguement x passes from (a-da) to (a+da).
c	So "da" is the range over which the function turns on.
c
	function switchon(x,a,da)
c
	real x,a,da,c,switchon
c
	c=3.4534/da
	switchon=tanh(c*(x-a))/2+0.5
	return
	end


c
c     file tcud34sp.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c ... purpose
c
c     test program for the MUDPACK solver cud34sp
c
c ... required MUDPACK files
c
c     cud34sp.f, cud3sp.f, cudcom.f
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cud34sp
c
c **********************************************************
************************************************************
c
c     a sample program/test driver for cud34sp is below. it can be
c     executed as an initial test.  the output is listed for the
c     test case described.
c
c     test cud34sp below by solving the complex separable elliptic pde
c
c        d(cmplx(x,-x)*dp/dx)/dx + d(cmplx(y,-y)*dp/dy)/dy +
c
c        d(cmplx(z,-z)*dp/dz)/dz + cmplx(1.,-1.)*(dp/dx + dp/dy + dp/dz) +
c
c        cmplx(-(x+y+z),x+y+z)*p(x,y,z) = r(x,y,z)
c
c     on the (x,y,z) region
c
c       1/4 < x < 3/4, 1/3 < y < 2/3, 1/5 < z < 4/5
c
c     with dirchlet boundary conditions at the upper x,y,z boundaries
c     and the mixed complex derirvative boundary conditions:
c
c          (1) dp/dx + cmplx(1.,1.)*p(0.5,y,z) = gbdxa(y,z) at x = 1/4
c
c          (2) dp/dy + cmplx(-1.,-1.)*p(x,0.5,z) = gbdyc(x,z) at y = 1/3
c
c          (3) dp/dz + cmplx(1.,-1.)*p(x,y,0.5) = gbdze(x,y) at z = 1/5
c
c     note the complex number multiplying "p" must be constant along
c     each surface.
c
c     use the exact solution
c
c          pe(x,y,z) = cmplx(exp(x+y),exp(y+z))
c
c     for testing and choose a 49 by 33 by 41 grid.  First cud3sp
c     is called with 5 cycles to ensure second-order discretization
c     level error is reached (a requirement for mudpack fourth-order
c     solvers).  Then cud34sp is called for a fourth-order estimate.
c
c ******************************************************
c     output (64 bit floating point arithmetic)
c *******************************************************
c
c     cud3sp test
c
c     input arguments
c     intl =  0 nxa =  2 nxb =  1 nyc =  2 nyd =  1
c     nze =  2 nzf =  1
c     ixp =  3 jyq =  2 kzr =  3
c     iex =  5 jey =  5 kez =  5
c     nx =  49 ny =  33 nz =  49 iguess =  0 maxcy =  5
c     method =  0 work space length input =  291605
c     xa =  0.25 xb =  0.75
c     yc =  0.33 yd =  0.67
c     ze =  0.20 zf =  0.80
c     tolmax =  0.000E+00
c
c     multigrid options
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     discretization call to cud3sp intl =  0
c     ierror =  0 minimum work space =  291605
c
c     approximation call to cud3sp
c     intl =  1 method =  0 iguess =  0 maxcy =  5
c     ierror =  0
c     maximum error  =   0.287E-04
c
c     cud34sp test  ierror =  0
c     maximum error  =   0.592E-07
c
c ************************************************************
c     end of output
c ************************************************************
c
c
      program tcud34sp
      implicit none
c
c     set grid sizes with parameter statements
c
      integer iixp,jjyq,kkzr,iiex,jjey,kkez,llwork,nnx,nny,nnz
      parameter(iixp=3,jjyq=2,kkzr=3)
      parameter(iiex=5,jjey=5,kkez=5)
      parameter (nnx = iixp*2**(iiex-1)+1)
      parameter (nny = jjyq*2**(jjey-1)+1)
      parameter (nnz = kkzr*2**(kkez-1)+1)
c
c     set minimal work space (see tcud3sp.f)
c
      parameter (llwork = 291605)
c
c     dimension solution,right hand side, and work arrays
c
      complex phi(nnx,nny,nnz),rhs(nnx,nny,nnz),work(llwork)
      integer iprm(23),mgopt(4)
      real fprm(8)
c
c     put integer and floating point arguments names in contiguous
c     storeage for labelling purposes
c
      integer intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +              kez,nx,ny,nz,iguess,maxcy,method,nwork,
     +              lwrkqd,itero
      common/itcd3sp/intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,
     +              kez,nx,ny,nz,iguess,maxcy,method,nwork,
     +              lwrkqd,itero
      real xa,xb,yc,yd,ze,zf,tolmax,relmax
      common/ftcud3sp/xa,xb,yc,yd,ze,zf,tolmax,relmax
      real dlx,dly,dlz,x,y,z,errm
      complex cxx,cyy,czz,cx,cy,cz,ce,cex,cey,cez
      complex pxx,pyy,pzz,px,py,pz,pe
      integer i,j,k,ierror
      equivalence(intl,iprm)
      equivalence(xa,fprm)
c
c     declare coefficient and boundary condition input subroutines external
c
      external cfx,cfy,cfz,bndc
c
c     set for initial call
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 2
      nxb = 1
      nyc = 2
      nyd = 1
      nze = 2
      nzf = 1
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      kzr = kkzr
      iex = iiex
      jey = jjey
      kez = kkez
      nx = nnx
      ny = nny
      nz = nnz
c
c     set  5 multigrid cycles
c
      maxcy = 5
c
c     set work space length approximation from parameter statement
c
      nwork = llwork
c
c     set point relaxation (only choice with cud3sp)
c
      method = 0
c
c     set full multigrid cycling beginning at coarsest grid
c
      iguess = 0
c
c     set end points of solution region in (x,y,z) space
c
      xa = 0.25
      xb = 0.75
      yc = 1.0/3.0
      yd = 2.0/3.0
      ze = 0.20
      zf = 0.80
c
c     set default multigrid options
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
      dlz = (zf-ze)/float(nz-1)
c
c     set for no error control
c
      tolmax = 0.0
c
c     set right hand side in rhs and phi to zero
c
      do k=1,nz
	z = ze+(k-1)*dlz
	call cfz(z,czz,cz,cez)
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call cfy(y,cyy,cy,cey)
	  do i=1,nx
	    x = xa+float(i-1)*dlx
	    call cfx(x,cxx,cx,cex)
	    call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	    ce = cex+cey+cez
	    rhs(i,j,k) = cxx*pxx+cyy*pyy+czz*pzz+cx*px+cy*py+cz*pz+ce*pe
	    phi(i,j,k) = (0.,0.)
	  end do
	end do
      end do
c
c     set specified values at upper x,y,z boundaries in phi
c
      x = xb
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(nx,j,k) = pe
	end do
      end do
      y = yd
      do k=1,nz
	z = ze+(k-1)*dlz
	do i=1,nx
	  x = xa+float(i-1)*dlx
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(i,ny,k) = pe
	end do
      end do
      z = zf
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+float(i-1)*dlx
	  call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	  phi(i,j,nz) = pe
	end do
      end do
      write(*,50)
   50 format(//' cud3sp test ')
c
c     print input arguments
c
      write(*,100)intl,nxa,nxb,nyc,nyd,nze,nzf,ixp,jyq,kzr,iex,jey,kez,
     +            nx,ny,nz,iguess,maxcy,method,nwork,xa,xb,yc,yd,ze,zf,
     +            tolmax,mgopt(1),mgopt(2),mgopt(3),mgopt(4)
  100 format(/' input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' nze = ',i2, ' nzf = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' kzr = ',i2,
     +/' iex = ',i2, ' jey = ',i2, ' kez = ',i2,
     +/' nx = ',i3,' ny = ',i3,' nz = ',i3, ' iguess = ',i2,
     +/' maxcy = ',i2,
     +/' method = ',i2, ' work space length input = ',i7,
     +/' xa = ',f5.2,' xb = ',f5.2,
     +/' yc = ',f5.2,' yd = ',f5.2,
     +/' ze = ',f5.2,' zf = ',f5.2,
     +/' tolmax = ' ,e10.3
     +//' multigrid options '
     +/' kcycle = ',i2
     +/' iprer = ',i2
     +/' ipost = ',i2
     +/' intpol = ',i2 )
c
c     discretize pde only
c
      write(*,104) intl
  104 format(/' discretization call to cud3sp', ' intl = ', i2)
      call cud3sp(iprm,fprm,work,cfx,cfy,cfz,bndc,rhs,phi,mgopt,ierror)
      write (*,105) ierror,iprm(21)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     approximate pde
c
      intl = 1
      write(*,106) intl,method,iguess,maxcy
  106 format(/' approximation call to cud3sp ',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2, ' maxcy = ',i2)
      call cud3sp(iprm,fprm,work,cfx,cfy,cfz,bndc,rhs,phi,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
c
c     compute and print maximum error
c
      call error(nx,ny,nz,phi,errm)
      write(*,108) errm
  108 format(' maximum error  =  ',e10.3)
c
c     attempt fourth-order estimate
c
      call cud34sp(work,phi,ierror)
      write(*,109) ierror
  109 format(/ ' cud34sp test ', ' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
      call error(nx,ny,nz,phi,errm)
      write(*,108) errm
      end

      subroutine error(nx,ny,nz,phi,errm)
c
c     compute the error in the estimate in phi
c
      implicit none
      integer nx,ny,nz
      complex phi(nx,ny,nz)
      real xa,xb,yc,yd,ze,zf,tolmax,relmax,errm
      common/ftcud3sp/xa,xb,yc,yd,ze,zf,tolmax,relmax
      real dlx,dly,dlz,x,y,z
      complex pxx,pyy,pzz,px,py,pz,pe
      integer i,j,k
      dlx = (xb-xa)/(nx-1)
      dly = (yd-yc)/(ny-1)
      dlz = (zf-ze)/(nz-1)
      errm = 0.0
      do k=1,nz
	z = ze+(k-1)*dlz
	do j=1,ny
	  y = yc+float(j-1)*dly
	  do i=1,nx
	    x = xa+float(i-1)*dlx
	    call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	    errm = amax1(errm,abs(phi(i,j,k)-pe))
	  end do
	end do
      end do
      return
      end
c
c     complex coefficient subroutines
c
      subroutine cfx(x,cxx,cx,cex)
      implicit none
      real x
      complex cxx,cx,cex
      cxx = cmplx(x,-x)
      cx = (1.,-1.)
      cex = cmplx(-x,x)
      return
      end
      subroutine cfy(y,cyy,cy,cey)
      implicit none
      real y
      complex cyy,cy,cey
      cyy= cmplx(y,-y)
      cy = (1.,-1.)
      cey = cmplx(-y,y)
      return
      end
      subroutine cfz(z,czz,cz,cez)
      implicit none
      real z
      complex czz,cz,cez
      czz = cmplx(z,-z)
      cz = (1.,-1.)
      cez = cmplx(-z,z)
      return
      end

      subroutine bndc(kbdy,xory,yorz,cons,gbdy)
c
c     input complex derivative boundary conditions to cud3sp
c
      implicit none
      integer kbdy
      real xory,yorz,x,y,z
      complex cons,gbdy,pe,px,py,pz,pxx,pyy,pzz
      real xa,xb,yc,yd,ze,zf,tolmax,relmax
      common/ftcud3sp/xa,xb,yc,yd,ze,zf,tolmax,relmax
      if (kbdy.eq.1) then
c
c     x=xa surface
c
	x = xa
	y = xory
	z = yorz
	call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	cons = (1.,1.)
	gbdy = px+cons*pe
	return
      end if
      if (kbdy.eq.3) then
c
c     y=yc surface
c
	y = yc
	x = xory
	z = yorz
	call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	cons = (-1.,-1.)
	gbdy = py+cons*pe
	return
      end if
      if (kbdy.eq.5) then
c
c     z=ze surface
c
	z = ze
	x = xory
	y = yorz
	call exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
	cons = (1.,-1.)
	gbdy = pz + cons*pe
	return
      end if
      end

      subroutine exact(x,y,z,pxx,pyy,pzz,px,py,pz,pe)
c
c     this subroutine is used to set an exact solution for testing cud3sp
c     (i.e., setting the rhs, boundary conditions and computing the exact
c     error)
c
      implicit none
      real x,y,z,exy,eyz
      complex pe,px,py,pz,pxx,pyy,pzz
      exy = exp(x+y)
      eyz = exp(y+z)
      pe = cmplx(exy,eyz)
      px = cmplx(exy,0.)
      pxx = px
      py = pe
      pyy = pe
      pz = cmplx(0.,eyz)
      pzz = pz
      return
      end


      program loopexit2

c     Is it possible to say something about the exit value of
C     loop indices

      real t(10)

      if(n.ge.1) then

         j = 0
         do i = 1, n, 1
            t(i) = 0.
            j = j + 2
         enddo

         print *, i, j

         j = 0
         do i = 1, n, -1
            t(i) = 0.
            j = j + 2
         enddo

         print *, i, j

      endif

      if(n.ge.0) then

         j = 0
         do i = 1, n, 1
            t(i) = 0.
            j = j + 2
         enddo

         print *, i, j

      endif

      if(n.lt.1) then

         j = 0
         do i = 1, n, 1
            t(i) = 0.
            j = j + 2
         enddo

         print *, i, j

      endif

      j = 0
      do i = 1, n, 1
         t(i) = 0.
         j = j + 2
      enddo

      print *, i, j

      end


program alloctest
  integer, allocatable :: a(:, :, :)
  integer :: i, j, k
  integer :: m, n, o

  read *, m, n, o

  allocate(a(m, n, o))

  do i = 1, m
    do j = 1, n
      do k = 1, o

        a(i, j, k) = i * j * k
      end do
    end do
  end do
  print *, a
end program alloctest


       subroutine tdrot(naxes,alpha)
C      subroutine tdrot  01.09.78
       common/gfmatr/t(4,4),a(4,4),nt,nt1
      dimension i(4)
      data i/2,3,1,2/
      nt=2
      naxe=iabs(naxes)
      alrad=alpha
      if (naxes.gt.0)alrad=3.141593/180.*alpha
      call hcunit(a)
      k=i(naxe)
      l=i(naxe+1)
      a(k,k)=cos(alrad)
      a(l,l)=cos(alrad)
      a(k,l)=sin(alrad)
      a(l,k)=-sin(alrad)
      call hcmult(t,a)
       return
       end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

      DOUBLE PRECISION FUNCTION compw(p,t)

        IMPLICIT NONE

        DOUBLE PRECISION t, p
        DOUBLE PRECISION a, b, c, d, e, f, g
        DOUBLE PRECISION rhow_loc
!      external rhow_loc
        DOUBLE PRECISION a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, &
          d2, e0, e1, e2, f0, f1, f2, g0, g1, g2
        DATA a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, d2, e0, e1, &
          e2, f0, f1, f2, g0, g1, g2/ + 9.99792877961606D+02, &
          + 5.07605113140940D-04, -5.2842547816413D-10, &
          + 5.13864847162196D-02, -3.61991396354483D-06, &
          + 7.97204102509724D-12, -7.53557031774437D-03, &
          + 6.37212093275576D-05, -1.66203631393248D-13, &
          + 4.60380647957350D-05, -5.61299059722121D-10, &
          + 1.80924436489400D-15, -2.26651454175013D-07, &
          + 3.36874416675978D-12, -1.30352149261326D-17, &
          + 6.14889851856743D-10, -1.06165223196756D-14, &
          + 4.75014903737416D-20, -7.39221950969522D-13, &
          + 1.42790422913922D-17, -7.13130230531541D-23/

! liquid density
        a = a0 + a1*p + a2*p**2
        b = b0 + b1*p + b2*p**2
        c = c0 + c1*p + c2*p**2
        d = d0 + d1*p + d2*p**2
        e = e0 + e1*p + e2*p**2
        f = f0 + f1*p + f2*p**2
        g = g0 + g1*p + g2*p**2

        rhow_loc = a + b*t + c*t**2 + d*t**3 + e*t**4 + f*t**5 + g*t**6

! liquid Compressibility
        a = a1 + 2*a2*p
        b = b1 + 2*b2*p
        c = c1 + 2*c2*p
        d = d1 + 2*d2*p
        e = e1 + 2*e2*p
        f = f1 + 2*f2*p
        g = g1 + 2*g2*p

        compw = (b*t+c*t**2+d*t**3+e*t**4+f*t**5+g*t**6)/rhow_loc

        RETURN
      END


SUBROUTINE idot(bit)

!-------------------------------------------------------------
!
!  Integral discrete ordinates transport
!
!  Add sv to kmat*psii to get the new phi
!  Compute psio with jpsi*(phi+src) + kpsi*psii
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: bit
INTEGER :: i, j, k, info
REAL*8, DIMENSION(neq) :: q

! Compute the solution directly
! Always use sv and product of kmat and psii to either solve for phi, or form RHS
phi = sv
DO k = 1, 8
   DO j = 1, apo
      DO i = 1, neq
         phi(i) = phi(i) + DOT_PRODUCT(kmatz(:,i,j,k),psiiz(:,j,k))
      END DO
      DO i = 1, neq
         phi(i) = phi(i) + DOT_PRODUCT(kmaty(:,i,j,k),psiiy(:,j,k))
      END DO
      DO i = 1, neq
         phi(i) = phi(i) + DOT_PRODUCT(kmatx(:,i,j,k),psiix(:,j,k))
      END DO
   END DO
END DO

! Use LAPACK solvers if matrix was factored only
CALL dgetrs('T',neq,1,jmat,neq,piv,phi,neq,info)
IF (info /= 0) THEN
   WRITE (8,'(//,1X,A)') "ERROR: dgetrs cannot solve."
   STOP
END IF

! Compute the new angular flux values at the boundaries from jpsi and kpsi
q = phi + src

! Find psio
DO k = 1, 8
   DO j = 1, apo
      DO i = 1, xys
         psioz(i,j,k) = DOT_PRODUCT(jpsiz(:,i,j,k),q)
      END DO
   END DO
END DO
DO k = 1, 8
   DO j = 1, apo
      DO i = 1, xzs
         psioy(i,j,k) = DOT_PRODUCT(jpsiy(:,i,j,k),q)
      END DO
   END DO
END DO
DO k = 1, 8
   DO j = 1, apo
      DO i = 1, yzs
         psiox(i,j,k) = DOT_PRODUCT(jpsix(:,i,j,k),q)
      END DO
   END DO
END DO

DO k = 1, 8
   DO j = 1, apo
      DO i = 1, xys
         psioz(i,j,k) = psioz(i,j,k) + DOT_PRODUCT(kpsizz(:,i,j,k),psiiz(:,j,k))
      END DO
      DO i = 1, xys
         psioz(i,j,k) = psioz(i,j,k) + DOT_PRODUCT(kpsizy(:,i,j,k),psiiy(:,j,k))
      END DO
      DO i = 1, xys
         psioz(i,j,k) = psioz(i,j,k) + DOT_PRODUCT(kpsizx(:,i,j,k),psiix(:,j,k))
      END DO
   END DO
END DO

DO k = 1, 8
   DO j = 1, apo
      DO i = 1, xzs
         psioy(i,j,k) = psioy(i,j,k) + DOT_PRODUCT(kpsiyz(:,i,j,k),psiiz(:,j,k))
      END DO
      DO i = 1, xzs
         psioy(i,j,k) = psioy(i,j,k) + DOT_PRODUCT(kpsiyy(:,i,j,k),psiiy(:,j,k))
      END DO
      DO i = 1, xzs
         psioy(i,j,k) = psioy(i,j,k) + DOT_PRODUCT(kpsiyx(:,i,j,k),psiix(:,j,k))
      END DO
   END DO
END DO

DO k = 1, 8
   DO j = 1, apo
      DO i = 1, yzs
         psiox(i,j,k) = psiox(i,j,k) + DOT_PRODUCT(kpsixz(:,i,j,k),psiiz(:,j,k))
      END DO
      DO i = 1, xzs
         psiox(i,j,k) = psiox(i,j,k) + DOT_PRODUCT(kpsixy(:,i,j,k),psiiy(:,j,k))
      END DO
      DO i = 1, xzs
         psiox(i,j,k) = psiox(i,j,k) + DOT_PRODUCT(kpsixx(:,i,j,k),psiix(:,j,k))
      END DO
   END DO
END DO

RETURN
END SUBROUTINE idot


module m_intgrf
   implicit none
   TYPE :: intgrf_out
      REAL      :: value    ! value of the integration
      INTEGER :: ierror   ! error code
   END TYPE intgrf_out

   !     error and warning codes for intgrf function
   INTEGER, PARAMETER :: NO_ERROR = 0
   INTEGER, PARAMETER :: NEGATIVE_EXPONENT_WARNING = 1
   INTEGER, PARAMETER :: NEGATIVE_EXPONENT_ERROR = 2
CONTAINS

   !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   !
   ! Integrates function f numerically (Lagrange and Simpson integration)
   ! on grid(itype) and is much faster than intgr.
   ! (Only normal outward integration.)
   ! Before first use of this function it has to be initialized with
   ! intgrf_init.

   FUNCTION intgrf(f, atoms, itype, gridf)

      use m_juDFT
      use m_types_setup
      USE m_constants

      IMPLICIT NONE

      REAL                 :: intgrf
      type(t_atoms)        :: atoms
      INTEGER, INTENT(IN)  :: itype
      REAL, INTENT(IN)  :: gridf(atoms%jmtd, atoms%ntype)
      REAL, INTENT(IN)  :: f(:)
      !     - local -
      TYPE(intgrf_out)     :: fct_res

      fct_res = pure_intgrf(f, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, &
                            atoms%ntype, itype, gridf)
      IF (fct_res%ierror == NEGATIVE_EXPONENT_WARNING) THEN
         write (oUnit, *) 'intgrf: Warning!'// &
            'Negative exponent x in extrapolation a+c*r**x'
      ELSEIF (fct_res%ierror == NEGATIVE_EXPONENT_ERROR) THEN
         write (oUnit, *) &
            'intgrf: Negative exponent x in extrapolation a+c*r**x'
         CALL juDFT_error( &
            'intgrf: Negative exponent x in extrapolation a+c*r**x')
      END IF
      intgrf = fct_res%value

   END FUNCTION intgrf

   !     pure wrapper for intgrf with same functionality
   !     can be used within forall loops

   PURE FUNCTION pure_intgrf(f, jri, jmtd, rmsh, dx, ntype, itype, gridf)

      IMPLICIT NONE

      TYPE(intgrf_out)     :: pure_intgrf

      INTEGER, INTENT(IN)  :: itype, ntype, jmtd
      INTEGER, INTENT(IN)  :: jri(ntype)
      REAL, INTENT(IN)  :: dx(ntype), rmsh(jmtd, ntype)
      REAL, INTENT(IN)  :: gridf(jmtd, ntype)
      REAL, INTENT(IN)  :: f(:)
      !     - local -
      INTEGER                :: n
      REAL                   :: r1, h, a, x

      n = jri(itype)
      r1 = rmsh(1, itype)
      h = dx(itype)

      pure_intgrf%ierror = NO_ERROR

      ! integral from 0 to r1 approximated by leading term in power series expansion
      IF (f(1)*f(2) > 1e-10 .AND. h > 0) THEN
         IF (f(2) == f(1)) THEN
            pure_intgrf%value = r1*f(1)
         ELSE
            x = (f(3) - f(2))/(f(2) - f(1))
            a = (f(2) - x*f(1))/(1 - x)
            x = log(x)/h
            IF (x < 0) THEN
               IF (x > -1) THEN
                  pure_intgrf%ierror = NEGATIVE_EXPONENT_WARNING
               ELSE IF (x <= -1) THEN
                  pure_intgrf%ierror = NEGATIVE_EXPONENT_ERROR
                  RETURN
               END IF
            END IF

            pure_intgrf%value = r1*(f(1) + x*a)/(x + 1)

            !           x      = f(2) / f(1)
            !           x      = log(x)/h
            !           IF(x.lt.0) THEN
            !             IF(x.gt.-1) write(oUnit,'(A,ES9.1)') 'intgrf: Warning!&
            !      &                                        Negative exponent x in&
            !      &                                        extrapolation c*r**x:',x
            !             IF(x.le.-1) write(oUnit,'(A,ES9.1)') 'intgrf: Negative exponent&
            !      &                                        x in extrapolation&
            !      &                                        c*r**x:',x
            !             IF(x.le.-1) call juDFT_error('intgrf: Negative exponent&
            !      &                                        x in extrapolation &
            !      &                                        c*r**x')
            !           END IF
            !           intgrf = (r1*f(1))/(x+1)

         END IF
      ELSE
         pure_intgrf%value = 0
      END IF

      ! integrate from r(1) to r(n) by multiplying with gridf
      pure_intgrf%value = pure_intgrf%value &
                          + dot_product(gridf(:n, itype), f(:n))

   END FUNCTION pure_intgrf

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

   !     Initializes fast numerical integration intgrf (see below).

   SUBROUTINE intgrf_init(ntype, jmtd, jri, dx, rmsh, gridf)

      IMPLICIT NONE

      INTEGER, INTENT(IN)   :: ntype, jmtd
      INTEGER, INTENT(IN)   :: jri(ntype)
      REAL, INTENT(IN)   :: dx(ntype), rmsh(jmtd, ntype)
      REAL, INTENT(OUT), ALLOCATABLE  :: gridf(:, :)

      !     - local -
      INTEGER                :: i, j, itype
      INTEGER                :: n, nstep, n0 = 6
      INTEGER, PARAMETER   :: simpson(7) = (/41, 216, 27, 272, 27, 216, 41/)
      REAL                   :: r1, h, dr
      REAL                   :: r(7)
      REAL, PARAMETER      :: lagrange(7, 6) = reshape( &
      (/19087., 65112., -46461., 37504., -20211., 6312., -863., &
      -863., 25128., 46989., -16256., 7299., -2088., 271., &
      &               271., -2760., 30819., 37504., -6771., 1608., -191., &
      -191., 1608., -6771., 37504., 30819., -2760., 271., &
      &               271., -2088., 7299., -16256., 46989., 25128., -863., &
      -863., 6312., -20211., 37504., -46461., 65112., 19087./), & ! The last row is actually never used.
      (/7, 6/))

      n = jmtd
      ALLOCATE (gridf(n, ntype))

      gridf = 0

      DO itype = 1, ntype

         n = jri(itype)
         r1 = rmsh(1, itype)
         h = dx(itype)

         nstep = (n - 1)/6
         n0 = n - 6*nstep
         dr = exp(h)

         ! Calculate Lagrange-integration coefficients from r(1) to r(n0)
         r(1) = r1
         IF (n0 > 1) THEN
            DO i = 2, 7
               r(i) = r(i - 1)*dr
            END DO
            DO i = 1, 7
               gridf(i, itype) = h/60480*r(i)*sum(lagrange(i, 1:n0 - 1))
            END DO
            r(1) = r(n0)
         END IF

         ! Calculate Simpson-integration coefficients from r(n0) to r(n)
         DO i = 1, nstep
            DO j = 2, 7
               r(j) = r(j - 1)*dr
            END DO
            DO j = n0, n0 + 6
               gridf(j, itype) = gridf(j, itype) + h/140*r(j - n0 + 1)* &
                                 simpson(j - n0 + 1)
            END DO
            n0 = n0 + 6
            r(1) = r(7)
         END DO

      END DO

   END SUBROUTINE intgrf_init
end module m_intgrf


!-------------------------------------------------------------------------------
! (C) Crown copyright Met Office. All rights reserved.
!     Refer to COPYRIGHT.txt of this distribution for details.
!-------------------------------------------------------------------------------
! Check values of humidity -limit to supersat and set <0.0 to = 0.0
!-------------------------------------------------------------------------------

module ufo_gnssroonedvarcheck_humidcheck_mod

use kinds

private
public :: Ops_GPSRO_humidcheck

contains

SUBROUTINE Ops_GPSRO_humidcheck (nstate, &
                                 nlevp,  &
                                 nlevq,  &
                                 za,     &
                                 zb,     &
                                 capsupersat, &
                                 x)

use ufo_constants_mod, only: &
    rd,                      &    ! Gas constant for dry air
    grav,                    &    ! Gravitational field strength
    c_virtual                     ! Related to mw_ratio

USE ufo_utils_mod, ONLY: &
    Ops_Qsat,            &
    Ops_QsatWat

IMPLICIT NONE

! Subroutine arguments:
INTEGER, INTENT(IN)            :: nstate
INTEGER, INTENT(IN)            :: nlevp
INTEGER, INTENT(IN)            :: nlevq
REAL(kind_real), INTENT(IN)    :: za(:)
REAL(kind_real), INTENT(IN)    :: zb(:)
LOGICAL, INTENT(IN)            :: capsupersat   ! Whether to remove super-saturation (wrt ice?)
REAL(kind_real), INTENT(INOUT) :: x(:)

! Local declarations:
CHARACTER(len=*), PARAMETER :: RoutineName = "Ops_GPSRO_humidcheck"
INTEGER                     :: i
REAL(kind_real)                        :: P(nlevp)
REAL(kind_real)                        :: Q(nlevq)
REAL(kind_real)                        :: T(nlevq)
REAL(kind_real)                        :: pb(nlevq)
REAL(kind_real)                        :: qsaturated(nlevq)
REAL(kind_real)                        :: Tv
REAL(kind_real)                        :: pwt1
REAL(kind_real)                        :: pwt2

!---------------------------------------------------------------------
! 1. Check values of humidity -limit to supersat and set <0.0 to = 0.0
!---------------------------------------------------------------------

! Set up the P and Q vectors from x

P(:) = 1.0E2 * x(1:nlevp)           ! in Pa
Q(:) = 1.0E-3 * x(nlevp + 1:nstate)    ! in kg/kg

DO i = 1, nlevq

  ! Calculate `mean P' for layer

  pwt1 = (za(i + 1) - zb(i)) / (za(i + 1) - za(i))

  pwt2 = 1.0 - pwt1

  pb(i) = EXP (pwt1 * LOG (P(i)) + pwt2 * LOG (P(i + 1)))

  ! Derive the layer mean virtual temp. using the hydrostatic relationship

  Tv = grav * (za(i + 1) - za(i)) / (rd * LOG (P(i) / P(i + 1)))

  ! Calculate the temperature

  T(i) = Tv / (1.0 + C_virtual * Q(i))

END DO

! Calculate the super.sat for T and Pmean

! For T < 0 Ops_Qsat returns the saturated specific humidity over ice.
! Supersaturation with respect to ice is possible, although is largely
! suppressed when CapSupersat is true. When CapSupersat is false the
! humidity check should be done with respect to water.

IF (CapSupersat) THEN
  CALL Ops_Qsat (qsaturated, &  ! out
                 T,          &
                 Pb,         &
                 nlevq)
ELSE
  CALL Ops_QsatWat (qsaturated, &  ! out
                    T,          &
                    Pb,         &
                    nlevq)
END IF

! Check no values have gone -ve
WHERE (x(nlevp + 1:nstate) < 0.0)
  x(nlevp + 1:nstate) = 1.0E-4
END WHERE

! Limit saturated value
WHERE (x(nlevp + 1:nstate) > 1.0E3 * qsaturated(1:nlevq))
  x(nlevp + 1:nstate) = 1.0E3 * qsaturated(1:nlevq)  ! in g/kg
END WHERE

END SUBROUTINE Ops_GPSRO_humidcheck

end module ufo_gnssroonedvarcheck_humidcheck_mod