!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! 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.
!

module MExAlg1p3e1

    use MArrays
    use MIntrinsicRandom
    use MFileReader
    use MUReport

    implicit none
    private

    integer, parameter :: NUMBER_OF_EXECUTIONS = 128

    type, public :: TExAlg1p3e1
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present()
        integer, dimension(:,:), allocatable :: list
        integer, dimension(:), allocatable   :: sequence
        integer, dimension(:), allocatable   :: buffer

        type(TFileReader) fileReader

        integer index
        integer count
        integer minimum
        real    start

        call fileReader%readAdjacencyList('Samples/kargerMinCut', list)
        allocate(sequence(size(list)))
        allocate(buffer(size(list)))

        call cpu_time(start)

        minimum  = huge(minimum)
        do index = 1, NUMBER_OF_EXECUTIONS
            buffer = 0
            count  = randomizedContraction(list, buffer, .false.)
            if (count < minimum) then
                sequence = buffer
                minimum  = count

                print '(A,I)', 'Found minimum: ', minimum
            end if
        end do

        call report('Alg1p3e1', 'Randomized Contraction', '', start)

        minimum = randomizedContraction(list, sequence, .true.)
        print '(A,I)', 'Minimum number of cuts: ', minimum

        deallocate(list)
        deallocate(sequence)
        deallocate(buffer)
    end subroutine

    function randomizedContraction(original, sequence, defined) result(value)
        integer, dimension(:,:), allocatable, intent(in)   :: original
        integer, dimension(:), allocatable, intent(in out) :: sequence
        logical, intent(in) :: defined

        type(TArrays) arrays

        integer, dimension(:,:), allocatable :: list
        integer, dimension(:,:), allocatable :: count
        logical, dimension(:,:), allocatable :: mask
        integer vertex1, vertex2
        integer index
        integer value

        allocate(list(size(original, 1),  size(original, 2)))
        allocate(count(size(original, 1), size(original, 2)))
        allocate(mask(size(original, 1),  size(original, 2)))

        list       = original
        count      = 0
        count(:,1) = (/ (index, index = 1, size(count, 1)) /)

        do while (size(list, 1) > 2)
            call selectRandomEdge(list, vertex1, vertex2, sequence, defined)

            mask            = .true.
            mask(vertex2,:) = .false.
            mask(:,vertex2) = .false.

            ! add connection from second vertex to the first one
            list(vertex1,:) = list(vertex1,:) + list(vertex2,:)
            list(:,vertex1) = list(:,vertex1) + list(:,vertex2)

            ! remove self-loops
            forall (index = 1:size(list, 1))
                list(index, index) = 0
            end forall

            ! remove vertex from array and mask
            list = reshape(pack(list, mask), (/ size(list, 1) - 1, size(list, 2) - 1 /))
            call arrays%resize(list, size(list, 1) - 1, size(list, 2) - 1)
            deallocate(mask)
            allocate(mask(size(list, 1), size(list, 2)))

            call countEdges(list, count, vertex1, vertex2)
        end do

        value = countCuts(original, count, defined)

        deallocate(list)
        deallocate(count)
        deallocate(mask)
    end function

    subroutine selectRandomEdge(list, vertex1, vertex2, sequence, defined)
        integer, dimension(:,:), allocatable, intent(in)   :: list
        integer, dimension(:), allocatable, intent(in out) :: sequence
        integer, intent(out) :: vertex1
        integer, intent(out) :: vertex2
        logical, intent(in)  :: defined

        type(TIntrinsicRandom), save :: random
        integer, save :: position = 1
        integer index
        integer left, right

        vertex1 = random%random(1, size(list, 1))
        vertex2 = random%random(1, size(list, 2))

        left    = -1
        right   = -1

        ! select closest connection to randomly selected vertex
        do index = (vertex2), 1, -1
            if (list(vertex1, index) /= 0) then
                left = index
                exit
            end if
        end do

        do index = (vertex2), size(list, 2)
            if (list(vertex1, index) /= 0) then
                right = index
                exit
            end if
        end do

        if ((((vertex2 - left) < (right - vertex2)) .and. left /= -1) .or. right == -1) then
            vertex2 = left
        else
            vertex2 = right
        end if

        if (defined == .false.) then
            do index = 1, size(sequence)
                if (sequence(index) == 0) then
                    sequence(index)     = vertex1
                    sequence(index + 1) = vertex2
                    position = 1

                    exit
                end if
            end do
        end if

        if (defined == .true.) then
            vertex1  = sequence(position)
            vertex2  = sequence(position + 1)
            position = position + 2
        end if
    end subroutine

    subroutine countEdges(list, count, vertex1, vertex2)
        integer, dimension(:,:), allocatable, intent(in out) :: list
        integer, dimension(:,:), allocatable, intent(in out) :: count
        integer, intent(in) :: vertex1
        integer, intent(in) :: vertex2

        type(TArrays) arrays
        logical, dimension(:,:), allocatable :: mask
        integer index, jndex, kndex

        allocate(mask(size(count, 1), size(count, 2)))
        mask            = .true.
        mask(vertex2,:) = .false.

        do index = 1, size(count, 2)
            if (count(vertex1, index) == 0) then
                count(vertex1:vertex1, index:size(count, 2)) = &
                        count(vertex2:vertex2, 1:(size(count, 2) - index + 1))
                exit
            end if
        end do
        count = reshape(pack(count, mask), (/ size(count, 1) - 1, size(count, 2) /))
        call arrays%resize(count, size(count, 1) - 1, size(count, 2))

        deallocate(mask)
    end subroutine

    function countCuts(list, count, defined) result(value)
        integer, dimension(:,:), allocatable, intent(in) :: list
        integer, dimension(:,:), allocatable, intent(in) :: count
        logical, intent(in) :: defined

        integer index, jndex
        integer vertex1, vertex2
        integer value

        value = 0

        do index = 1, size(count, 2)
            vertex1 = count(1, index)
            if (vertex1 == 0) then
                exit
            end if

            do jndex = 1, size(count, 2)
                vertex2 = count(2, jndex)
                if (vertex2 == 0) then
                    exit
                end if

                if (list(vertex1, vertex2) /= 0) then
                    if (defined) then
                        print '(A,I,I,A)', 'Cut: [', vertex1, vertex2, ']'
                    end if

                    value = value + 1
                end if
            end do
        end do
    end function
end module


<ompts:test>
<ompts:testdescription>Test which checks the omp do lastprivate clause by counting up a variable in a parallelized loop. Each thread saves the next summand in a lastprivate variable i0. At the end i0 is compared to the value of the expected last summand.</ompts:testdescription>
<ompts:version>2.0</ompts:version>
<ompts:directive>omp do private</ompts:directive>
<ompts:dependences>omp parallel firstprivate, omp critical</ompts:dependences>
<ompts:testcode>
      INTEGER FUNCTION <ompts:testcode:functionname>do_lastprivate</ompts:testcode:functionname>()
        IMPLICIT NONE
        INTEGER sum,known_sum
<ompts:orphan:vars>
        INTEGER sum0,i0,i
        COMMON /orphvars/ sum0,i0,i
</ompts:orphan:vars>
        INCLUDE "omp_testsuite.f"
        sum = 0
        sum0 = 0
        i0 = -1
!$omp parallel firstprivate(sum0)
<ompts:orphan>
!$omp do schedule(static,7) <ompts:check>lastprivate(i0)</ompts:check>
        DO i=1, LOOPCOUNT
          sum0 = sum0 + i
          i0 = i
        END DO
<ompts:check>!$omp end do</ompts:check>
</ompts:orphan>
!$omp critical
        sum = sum + sum0
!$omp end critical
!$omp end parallel
      known_sum = (LOOPCOUNT*(LOOPCOUNT+1))/2
        IF ( known_sum .EQ. sum .AND. i0 .EQ. LOOPCOUNT ) THEN
          <testfunctionname></testfunctionname> = 1
        ELSE
          <testfunctionname></testfunctionname> = 0
        END IF
      END FUNCTION
</ompts:testcode>
</ompts:test>


c=======================================================================
      subroutine spraschpoi(datastr,imiss,ngrid,nmissing,nsubject,p,y,
     &                      roffset,
     &                      a0b0,b0,prec,psiinv,sb,smu,tau1,tau2,
     &                      mcmc,nsave,
     &                      acrate,cpo,cpov,
     &                      cdfsave,randsave,thetasave,
     &                      alpha,b,bclus,beta,mu,ncluster,sigma2,
     &                      sigmainv,ss,
     &                      betac,ccluster,cstrt,fsavet,iflagp,prob,
     &                      seed,
     &                      workmhp,workvp,
     &                      xtx,xty,grid,workcpo)
c=======================================================================
c
c     Subroutine `spraschpoi' to run a Markov chain in the
c     semiparametric Rasch Poissin Count model. In this routine, inference
c     is based on  the Polya urn representation of Dirichlet process.
c     The algorithm 8 with m=1 of Neal (2000) is used to sample the
c     configurations.
c
c     Copyright: Alejandro Jara, 2006 - 2010.
c
c     Version 3.0:
c
c     Last modification: 05-09-2009.
c
c     Changes and Bug fixes:
c
c     Version 2.0 to Version 3.0:
c          - Add computation of functionals.
c          - Improve efficiency of DP part.
c          - CDF samples are returned now.
c
c     Version 1.0 to Version 2.0:
c          - Add offset.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The author's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c---- Data -------------------------------------------------------------
c
c        datastr     :  integer matrix giving the position of missing
c                       data points, datastr(nmissing,2)
c        imiss       :  integer indicating whether missing data are
c                       present (1) or absent (0).
c        ngrid       :  integer giving the size of the grid where
c                       the cdf estimate is evaluated.
c        nmissing    :  integer giving the number of missing
c                       observations.
c        nsubject    :  integer giving the number of subjects.
c        p           :  integer giving the number of items.
c        roffset     :  real matrix giving the offsets,
c                       roffset(nsubject,p).
c        y           :  integer matrix giving the response variable,
c                       y(nsubject,p).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        aa0, ab0    :  real giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       alpha ~ Gamma(aa0,ab0). If aa0<0 the precision
c                       parameter is considered as a constant.
c        b0          :  real vector giving the prior mean of difficulty
c                       parameters, b0(p-1).
c        prec        :  real matrix giving the prior precision matrix
c                       for the difficulty parameters, prec(p-1,p-1).
c        psiinv      :  real giving the prior precision
c                       for the baseline mean, psiinv.
c        sb          :  real vector giving the product of the prior
c                       precision and prior mean for the difficulty
c                       parameters, sb(p-1).
c        smu         :  real vector giving the product of the prior
c                       precision and prior mean for the baseline mean,
c                       smu.
c        tau1, tau2  :  reals giving the hyperparameters of the prior
c                       distribution for the inverse of the random
c                       variance, 1/sigma2 ~ Gamma(tau1/2,tau2/2).
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        acrate      :  real vector giving the MH acceptance rate,
c                       acrate(2).
c        cpo         :  real matrix giving the cpo, cpo(nsubject,p).
c        cdfsave     :  real matrix containing the mcmc samples for the
c                       cdf, cdfsave(nsave,ngrid).
c        randsave    :  real matrix containing the mcmc samples for
c                       the random effects and prediction,
c                       randsave(nsave,nsubject+1)
c        thetasave   :  real matrix containing the mcmc samples for
c                       the fixed effects,and mean and covariance of
c                       the baseline distribution,
c                       thetsave(nsave,p+5).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        alpha       :  real giving the current value of the precision
c                       parameter of the Dirichlet process.
c        b           :  real vector giving the current value of the
c                       random effects, b(nsubject).
c        bclus       :  real vector giving the current value of the
c                       different values of random effects,
c                       bclus(nsubject).
c        beta        :  real vector giving the current value of the
c                       difficulty parameters, beta(p-1).
c        mu          :  real giving the mean of the normal
c                       base line distribution for the random effects,
c                       mu.
c        ncluster    :  integer giving the number of clusters in the
c                       random effects.
c        sigma       :  real giving the current value of the
c                       standard deviation for normal base line
c                       distribution for the random effects,
c                       sigma.
c        sigmainv    :  real used to save the inverse of the base line
c                       variance for the random effects,
c                       sigmainv.
c        ss          :  integer vector giving the cluster label for
c                       each subject, ss(nsubject).
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        acrate2     :  real used to calculate the acceptance rate.
c        betac       :  real vector giving the current value of the
c                       candidate for difficulty parameters,
c                       betac(p-1).
c        ccluster    :  integer vector indicating the number of
c                       subjects in each cluster, ccluster(nsubject).
c        detlog      :  real used to save the log-determinant in a
c                       matrix inversion process.
c        dispcount   :  index.
c        evali       :  integer indicator used in updating the state.
c        fsavet      :  real vector used to store the cdf,
c                       fsavet(ngrid).
c        grid        :  real vector giving the grid where the density
c                       estimate is evaluated, grid(ngrid) .
c        i           :  index.
c        ii          :  index.
c        iflag       :  integer vector used to invert the of the lhs
c                       least square solution for the difficulties,
c                       iflag(p-1).
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        k           :  index.
c        l           :  index.
c        prob        :  real vector used to update the cluster
c                       structure, prob(nsubject+100).
c        ns          :  integer indicator used in updating the state.
c        nscan       :  integer indicating the total number of MCMC
c                       scans.
c        runif       :  uniform random number generator.
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c        since       :  index.
c        skipcount   :  index.
c        theta       :  real used to save randomnly generated
c                       random effects, theta.
c        thetac      :  real used to save randomnly generated
c                       random effects, thetac.
c        tmp1        :  real used to accumulate quantities.
c        tmp2        :  real used to accumulate quantities.
c        workmhp     :  real vector used to update the difficulties,
c                       workmhp((p-1)*p/2).
c        workvp      :  real vector used to update the difficulties,
c                       workvp(p-1).
c        xtx         :  real matrix givind the product X^tX,
c                       xtx(p-1,p-1).
c        xty         :  real vector used to save the product
c                       Xt(Y-Zb), xty(p-1).
c        zty         :  real used to save the product
c                       Zt(Y-Xbeta), zty.
c        ztz         :  real used to save the product
c                       ZtSigma^1Z, ztz.
c        ztzinv      :  real used to save the inverted
c                       ztz, ztzinv.
c=======================================================================
      implicit none

c+++++Data
      integer imiss,ngrid,nmissing,nsubject,p
      integer datastr(nmissing,2),y(nsubject,p)
      real*8 roffset(nsubject,p)

c+++++Prior
      real*8 aa0,ab0,a0b0(2),b0(p-1),prec(p-1,p-1),psiinv
      real*8 sb(p-1),smu
      real*8 tau1,tau2

c+++++MCMC parameters
      integer mcmc(3),nburn,nskip,nsave,ndisplay

c+++++Output
      real*8 acrate(2)
      real*8 cpo(nsubject,p)
      real*8 cpov(nsubject)
      real*8 cdfsave(nsave,ngrid)
      real*8 randsave(nsave,nsubject+1)
      real*8 thetasave(nsave,p+5)

c+++++Current values of the parameters
      integer ncluster,ss(nsubject)
      real*8 alpha,beta(p-1),b(nsubject)
      real*8 bclus(nsubject+100)
      real*8 mu,sigma2,sigmainv

c+++++Working space - Loops
      integer ii,i,j,k

c+++++Working space - Random effects
      real*8 fsavet(ngrid)
      real*8 cdfnorm,dnrm,grid(ngrid),thetac
      real*8 zty,ztz,ztzinv

c+++++Working space - RNG
      integer rpois,seed(2),seed1,seed2
      real*8 rgamma,rnorm
      real runif

c+++++Working space - MCMC
      integer iscan,isave,nscan
      integer sprint,skipcount,dispcount
      real*8 dpoiss
      real*8 logcgkn,logcgko
      real*8 loglikn,logliko
      real*8 logpriorn,logprioro
      real*8 ratio

c+++++Working space - Configurations
      integer ccluster(nsubject),evali,isample,ok
      integer cstrt(nsubject,nsubject)
      integer ns
      integer since
      real*8 prob(nsubject+2)
      real*8 tmp1,tmp2,tmp3
      real*8 theta

c+++++Working space - Difficulty parameters
      integer iflagp(p-1)
      real*8 betac(p-1)
      real*8 detlog
      real*8 xtx(p-1,p-1),xty(p-1)
      real*8 workmhp((p-1)*p/2)
      real*8 workvp(p-1)

c+++++Working space - CPO
      real*8 workcpo(nsubject,p)

c+++++Working space - GLM part
      integer yij
      real*8 acrate2
      real*8 eta,gprime,mean,offset,ytilde

c+++++CPU time
      real*8 sec00,sec0,sec1,sec

c++++ DP (functional parameter)
      real*8 eps,rbeta,weight
      real*8 mureal,sigma2real,mu2real
      parameter(eps=0.01)

c++++ parameters
      nburn=mcmc(1)
      nskip=mcmc(2)
      ndisplay=mcmc(3)
      aa0=a0b0(1)
      ab0=a0b0(2)

c++++ set random number generator
      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c++++ cluster structure
      do i=1,nsubject
         ccluster(ss(i))=ccluster(ss(i))+1
         cstrt(ss(i),ccluster(ss(i)))=i
      end do
      sigmainv=1.d0/sigma2

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      call cpu_time(sec0)
      sec00=0.d0

      do iscan=1,nscan

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++
c+++++++ missing data
c++++++++++++++++++++++++++++++++++
         if(imiss.eq.1)then
            do ii=1,nmissing
               i=datastr(ii,1)
               j=datastr(ii,2)
               if(j.eq.1)then
                 eta=b(i)+roffset(i,j)
                else
                 eta=b(i)-beta(j-1)+roffset(i,j)
               end if

               mean=exp(eta)
               y(i,j)=rpois(mean)
            end do
         end if

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++
c+++++++ difficulty parameters
c++++++++++++++++++++++++++++++++++

         do i=1,p-1
            do j=1,p-1
               xtx(i,j)=prec(i,j)
            end do
            xty(i)=sb(i)
         end do

         logliko=0.d0

         do i=1,nsubject
            do j=1,p-1
               yij=y(i,j+1)
               eta=b(i)-beta(j)+roffset(i,j+1)
               offset=b(i)+roffset(i,j+1)
               mean=exp(eta)
               gprime=exp(-eta)
               ytilde=eta+(dble(yij)-mean)*gprime-offset

               xtx(j,j)=xtx(j,j)+1.d0/gprime
               xty(j)=xty(j)-ytilde/gprime

               logliko=logliko+dpoiss(dble(yij),mean,1)
            end do
         end do

         call inverse(xtx,p-1,iflagp)

         do i=1,p-1
            tmp1=0.d0
            do j=1,p-1
               tmp1=tmp1+xtx(i,j)*xty(j)
            end do
            workvp(i)=tmp1
         end do

         call rmvnorm(p-1,workvp,xtx,workmhp,xty,betac)

c+++++++ evaluating the candidate generating kernel

         call dmvnd(p-1,betac,workvp,xtx,logcgko,iflagp)

c+++++++ prior ratio

         logprioro=0.d0
         logpriorn=0.d0

         do i=1,p-1
            do j=1,p-1
               logpriorn=logpriorn+(betac(i)-b0(i))*
     &                    prec(i,j)      *
     &                   (betac(j)-b0(j))

               logprioro=logprioro+(beta(i) -b0(i))*
     &                    prec(i,j)      *
     &                   (beta(j) -b0(j))
            end do
         end do

         logpriorn=-0.5d0*logpriorn
         logprioro=-0.5d0*logprioro

c+++++++ candidate generating kernel contribution

         do i=1,p-1
            do j=1,p-1
               xtx(i,j)=prec(i,j)
            end do
            xty(i)=sb(i)
         end do

         loglikn=0.d0

         do i=1,nsubject
            do j=1,p-1
               yij=y(i,j+1)
               eta=b(i)-betac(j)+roffset(i,j+1)
               offset=b(i)+roffset(i,j+1)
               mean=exp(eta)
               gprime=exp(-eta)
               ytilde=eta+(dble(yij)-mean)*gprime-offset

               xtx(j,j)=xtx(j,j)+1.d0/gprime
               xty(j)=xty(j)-ytilde/gprime

               loglikn=loglikn+dpoiss(dble(yij),mean,1)
            end do
         end do

         call inverse(xtx,p-1,iflagp)

         do i=1,p-1
            tmp1=0.d0
            do j=1,p-1
               tmp1=tmp1+xtx(i,j)*xty(j)
            end do
            workvp(i)=tmp1
         end do

c+++++++ evaluating the candidate generating kernel

         call dmvnd(p-1,beta,workvp,xtx,logcgkn,iflagp)

c+++++++ mh step

         ratio=loglikn-logliko+logcgkn-logcgko+
     &         logpriorn-logprioro

         if(log(runif()).lt.ratio)then
            acrate(1)=acrate(1)+1.d0
            do i=1,p-1
               beta(i)=betac(i)
            end do
         end if

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++
c+++++++ random effects
c++++++++++++++++++++++++++++++++++

c++++++++++++++++++++++++++++++
c+++++++ a) Polya Urn
c++++++++++++++++++++++++++++++

         do i=1,nsubject

            ns=ccluster(ss(i))

            if(ns.gt.1)then
               isample=1
               ccluster(ss(i))=ccluster(ss(i))-1

               j=1
               ok=0
               do while(ok.eq.0.and.j.le.ns)
                  if(cstrt(ss(i),j).eq.i)ok=j
                  j=j+1
               end do

               do j=ok,ns-1
                  cstrt(ss(i),j)=cstrt(ss(i),j+1)
               end do

             else
               isample=2
               since=ss(i)

               if(since.lt.ncluster)then

                  call relabelrasch(i,since,nsubject,ncluster,
     &                              ccluster,ss,cstrt,bclus)

               end if
               ccluster(ncluster)=ccluster(ncluster)-1
               ncluster=ncluster-1
            end if

            do j=1,ncluster

               tmp1=0.d0

               yij=y(i,1)
               eta=bclus(j)+roffset(i,1)
               mean=exp(eta)
               tmp1=tmp1+dpoiss(dble(yij),mean,1)

               do k=1,p-1
                  yij=y(i,k+1)
                  eta=bclus(j)-beta(k)+roffset(i,k+1)
                  mean=exp(eta)
                  tmp1=tmp1+dpoiss(dble(yij),mean,1)
               end do

               prob(j)=exp(log(dble(ccluster(j)))+
     &                        tmp1)
            end do

            if(isample.eq.1)then
               theta=rnorm(mu,sqrt(sigma2))
               bclus(ncluster+1)=theta
            end if

            theta=bclus(ncluster+1)
            tmp1=0.d0

            yij=y(i,1)
            eta=theta+roffset(i,1)
            mean=exp(eta)
            tmp1=tmp1+dpoiss(dble(yij),mean,1)

            do k=1,p-1
               yij=y(i,k+1)
               eta=theta-beta(k)+roffset(i,k+1)
               mean=exp(eta)
               tmp1=tmp1+dpoiss(dble(yij),mean,1)
            end do

            prob(ncluster+1)=alpha*exp(tmp1)

            call simdisc(prob,nsubject+100,ncluster+1,evali)

            ss(i)=evali
            ccluster(evali)=ccluster(evali)+1
            cstrt(evali,ccluster(evali))=i

            if(evali.gt.ncluster)then
               ncluster=ncluster+1
            end if

         end do

c++++++++++++++++++++++++++++++
c+++++++ b) Resampling step
c++++++++++++++++++++++++++++++

         acrate2=0.d0

         do i=1,ncluster

c++++++++++ check if the user has requested an interrupt
            call rchkusr()

            ztz=1.d0/sigma2
            zty=mu/sigma2

            logliko=0.d0

            ns=ccluster(i)
            do j=1,ns

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

               ii=cstrt(i,j)

               do k=1,p
                  if(k.eq.1)then
                     eta=bclus(i)+roffset(ii,k)
                     offset=roffset(ii,k)
                    else
                     eta=bclus(i)-beta(k-1)+roffset(ii,k)
                     offset=roffset(ii,k)-beta(k-1)
                  end if

                  yij=y(ii,k)
                  mean=exp(eta)
                  gprime=exp(-eta)
                  ytilde=eta+(dble(yij)-mean)*gprime-offset

                  ztz=ztz+1.d0/gprime
                  zty=zty+ytilde/gprime

                  logliko=logliko+dpoiss(dble(yij),mean,1)
               end do
            end do

            ztz=1.d0/ztz
            zty=ztz*zty

            thetac=rnorm(zty,sqrt(ztz))

c++++++++++ evaluating the candidate generating kernel

            logcgko=dnrm(thetac,zty,sqrt(ztz),1)

c++++++++++ prior ratio

            logprioro=0.d0
            logpriorn=0.d0

            logpriorn=(thetac-mu)*
     &            sigmainv*
     &           (thetac-mu)

            logprioro=(bclus(i)-mu)*
     &            sigmainv*
     &           (bclus(i)-mu)

            logpriorn=-0.5d0*logpriorn
            logprioro=-0.5d0*logprioro

c++++++++++ candidate generating kernel contribution

            ztz=1.d0/sigma2
            zty=mu/sigma2

            loglikn=0.d0

            ns=ccluster(i)
            do j=1,ns

c+++++++++++++ check if the user has requested an interrupt
               call rchkusr()

               ii=cstrt(i,j)

               do k=1,p
                  if(k.eq.1)then
                     eta=thetac+roffset(ii,k)
                     offset=roffset(ii,k)
                    else
                     eta=thetac-beta(k-1)+roffset(ii,k)
                     offset=roffset(ii,k)-beta(k-1)
                  end if

                  yij=y(ii,k)
                  mean=exp(eta)
                  gprime=exp(-eta)
                  ytilde=eta+(dble(yij)-mean)*gprime-offset

                  ztz=ztz+1.d0/gprime
                  zty=zty+ytilde/gprime

                  loglikn=loglikn+dpoiss(dble(yij),mean,1)
               end do
            end do

            ztz=1.d0/ztz
            zty=ztz*zty

c++++++++++ evaluating the candidate generating kernel

            theta=bclus(i)
            logcgkn=dnrm(theta,zty,sqrt(ztz),1)

c++++++++++ mh step

            ratio=loglikn-logliko+logcgkn-logcgko+
     &            logpriorn-logprioro

            if(log(runif()).lt.ratio)then
               acrate2=acrate2+1.d0
               bclus(i)=thetac
            end if
         end do

         acrate(2)=acrate(2)+acrate2/dble(ncluster)

         do i=1,nsubject
            b(i)=bclus(ss(i))
         end do

c++++++++++++++++++++++++++++++++++
c+++++++ Base line distribution
c++++++++++++++++++++++++++++++++++

c+++++++ check if the user has requested an interrupt
         call rchkusr()

         if(psiinv.gt.0.d0)then
            tmp2=smu
            tmp1=1.d0/(sigmainv*dble(ncluster)+psiinv)
            do i=1,ncluster
               tmp2=tmp2+sigmainv*bclus(i)
            end do
            mean=tmp1*tmp2
            mu=rnorm(mean,sqrt(tmp1))
         end if

c+++++++ check if the user has requested an interrupt
         call rchkusr()

         if(tau1.gt.0.d0)then
            tmp1=0.d0
            do i=1,ncluster
               tmp1=tmp1+(bclus(i)-mu)*(bclus(i)-mu)
            end do

            sigma2=1.d0/
     &             rgamma(0.5d0*(dble(ncluster)+tau1),0.5d0*(tmp1+tau2))

            sigmainv=1.d0/sigma2
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ Precision parameter
c++++++++++++++++++++++++++++++++++
         if(aa0.gt.0.d0)then
            call samalph(alpha,aa0,ab0,ncluster,nsubject)
         end if

c++++++++++++++++++++++++++++++++++
c+++++++ save samples
c++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

c+++++++++++++ difficulty parameters

               do i=1,p-1
                  thetasave(isave,i)=beta(i)
               end do

c+++++++++++++ Partially sampling the DP for mean and variance

               do i=1,ngrid
                  fsavet(i)=0.d0
               end do

               mureal=0.d0
               mu2real=0.d0
               sigma2real=0.d0

               do i=1,ncluster
                   prob(i)=real(ccluster(i))/(alpha+real(nsubject))
               end do
               prob(ncluster+1)=alpha/(alpha+dble(nsubject))
               call simdisc(prob,nsubject+100,ncluster+1,evali)

               if(evali.le.ncluster)then
                  theta=bclus(evali)
               end if
               if(evali.eq.ncluster+1)then
                  theta=rnorm(mu,sqrt(sigma2))
               end if

               tmp1=rbeta(1.d0,alpha+dble(nsubject))
               tmp2=tmp1
               weight=(1.d0-tmp1)

               mureal=tmp1*theta
               mu2real=tmp1*theta*theta
               do j=1,ngrid
                  if(theta.le.grid(j))then
                     fsavet(j)=fsavet(j)+tmp1
                  end if
               end do

               do while((1.0-tmp2).gt.eps)
                  call rchkusr()

                  tmp3=rbeta(1.d0,alpha+real(nsubject))
                  tmp1=weight*tmp3
                  weight=weight*(1.0-tmp3)

                  call simdisc(prob,nsubject+100,ncluster+1,evali)

                  if(evali.le.ncluster)then
                     theta=bclus(evali)
                  end if
                  if(evali.eq.ncluster+1)then
                     theta=rnorm(mu,sqrt(sigma2))
                  end if

                  mureal=mureal+tmp1*theta
                  mu2real=mu2real+tmp1*theta*theta

                  do j=1,ngrid
                     if(theta.le.grid(j))then
                        fsavet(j)=fsavet(j)+tmp1
                     end if
                  end do
                  tmp2=tmp2+tmp1
               end do

               tmp3=1.d0
               tmp1=weight*tmp3
               call simdisc(prob,nsubject+100,ncluster+1,evali)

               if(evali.le.ncluster)then
                  theta=bclus(evali)
               end if
               if(evali.eq.ncluster+1)then
                  theta=rnorm(mu,sqrt(sigma2))
               end if

               mureal=mureal+tmp1*theta
               mu2real=mu2real+tmp1*theta*theta

               do j=1,ngrid
                  if(theta.le.grid(j))then
                     fsavet(j)=fsavet(j)+tmp1
                  end if
               end do

               sigma2real=mu2real-mureal*mureal

               thetasave(isave,p)=mureal
               thetasave(isave,p+1)=sigma2real

               do i=1,ngrid
                  cdfsave(isave,i)=fsavet(i)
               end do

c+++++++++++++ baseline mean

               thetasave(isave,p+2)=mu

c+++++++++++++ baseline stansard deviation

               thetasave(isave,p+3)=sigma2

c+++++++++++++ cluster information

               thetasave(isave,p+4)=ncluster
               thetasave(isave,p+5)=alpha

c+++++++++++++ random effects

               do i=1,nsubject
                  randsave(isave,i)=b(i)
               end do

c+++++++++++++ predictive information

               do i=1,ncluster
                  prob(i)=dble(ccluster(i))/(alpha+dble(nsubject))
               end do
               prob(ncluster+1)=alpha/(alpha+dble(nsubject))

               call simdisc(prob,nsubject+100,ncluster+1,evali)

               if(evali.le.ncluster)then
                  theta=bclus(evali)
               end if
               if(evali.gt.ncluster)then
                  theta=rnorm(mu,sqrt(sigma2))
               end if
               randsave(isave,nsubject+1)=theta

c+++++++++++++ cpo

               tmp3=0.d0
               do i=1,nsubject
                  tmp2=0.d0
                  do j=1,p
                     yij=y(i,j)
                     if(j.eq.1)then
                       eta=b(i)+roffset(i,j)
                      else
                       eta=b(i)-beta(j-1)+roffset(i,j)
                     end if
                     mean=exp(eta)
                     tmp1=dpoiss(dble(yij),mean,1)
                     cpo(i,j)=cpo(i,j)+1.0d0/exp(tmp1)
                     tmp2=tmp2+tmp1
                     tmp3=tmp3+log(dble(isave)/cpo(i,j))
                  end do
                  cpov(i)=cpov(i)+1.d0/exp(tmp2)
               end do
c               call dblepr("LPML",-1,tmp3,1)

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  tmp1=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if

      end do

      acrate(1)=acrate(1)/dble(nscan)
      acrate(2)=acrate(2)/dble(nscan)

      do i=1,nsubject
         do j=1,p
            cpo(i,j)=dble(nsave)/cpo(i,j)
         end do
         cpov(i)=dble(nsave)/cpov(i)
      end do

      return
      end

c=======================================================================
      subroutine relabelrasch(ind,since,nsubject,ncluster,ccluster,
     &                        ss,cstrt,bclus)
c=======================================================================
c     relabel the clusters after the elimination of one of them
c     A.J.V., 2006
      implicit none
      integer i,j,ind,since,nsubject,ncluster,ccluster(nsubject)
      integer ss(nsubject),ii,ns
      integer cstrt(nsubject,nsubject)
      real*8 bclus(nsubject+100),theta

      theta=bclus(since)

      do i=since+1,ncluster

         ns=ccluster(i)

         do j=1,ns
c++++++++++ check if the user has requested an interrupt
            call rchkusr()
            ii=cstrt(i,j)
            ss(ii)=i-1
         end do

         do j=1,ns
            cstrt(i-1,j)=cstrt(i,j)
         end do

         bclus(i-1)=bclus(i)
         ccluster(i-1)=ccluster(i)
      end do

      ss(ind)=ncluster

      bclus(ncluster)=theta
      ccluster(ncluster)=1

      return
      end


      DOUBLE PRECISION FUNCTION iau_ERA00 ( DJ1, DJ2 )
*+
*  - - - - - - - - - -
*   i a u _ E R A 0 0
*  - - - - - - - - - -
*
*  Earth rotation angle (IAU 2000 model).
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  canonical model.
*
*  Given:
*     DJ1,DJ2     d      UT1 as a 2-part Julian Date (see note)
*
*  The result is the Earth rotation angle (radians), in the range 0 to
*  2pi.
*
*  Notes:
*
*  1) The UT1 date DJ1+DJ2 is a Julian Date, apportioned in any
*     convenient way between the arguments DJ1 and DJ2.  For example,
*     JD(UT1)=2450123.7 could be expressed in any of these ways,
*     among others:
*
*             DJ1            DJ2
*
*         2450123.7D0        0D0        (JD method)
*          2451545D0      -1421.3D0     (J2000 method)
*         2400000.5D0     50123.2D0     (MJD method)
*         2450123.5D0       0.2D0       (date & time method)
*
*     The JD method is the most natural and convenient to use in
*     cases where the loss of several decimal digits of resolution
*     is acceptable.  The J2000 and MJD methods are good compromises
*     between resolution and convenience.  The date & time method is
*     best matched to the algorithm used:  maximum accuracy (or, at
*     least, minimum noise) is delivered when the DJ1 argument is for
*     0hrs UT1 on the day in question and the DJ2 argument lies in the
*     range 0 to 1, or vice versa.
*
*  2) The algorithm is adapted from Expression 22 of Capitaine et al.
*     2000.  The time argument has been expressed in days directly,
*     and, to retain precision, integer contributions have been
*     eliminated.  The same formulation is given in IERS Conventions
*     (2003), Chap. 5, Eq. 14.
*
*  Called:
*     iau_ANP      normalize angle into range 0 to 2pi
*
*  References:
*
*     Capitaine N., Guinot B. and McCarthy D.D, 2000, Astron.
*     Astrophys., 355, 398-405.
*
*     McCarthy, D. D., Petit, G. (eds.), IERS Conventions (2003),
*     IERS Technical Note No. 32, BKG (2004)
*
*  This revision:  2009 December 15
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION DJ1, DJ2

*  2Pi
      DOUBLE PRECISION D2PI
      PARAMETER ( D2PI = 6.283185307179586476925287D0 )

*  Reference epoch (J2000.0), JD
      DOUBLE PRECISION DJ00
      PARAMETER ( DJ00 = 2451545D0 )

      DOUBLE PRECISION D1, D2, T, F

      DOUBLE PRECISION iau_ANP

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*  Days since fundamental epoch.
      IF ( DJ1 .LT. DJ2 ) THEN
         D1 = DJ1
         D2 = DJ2
      ELSE
         D1 = DJ2
         D2 = DJ1
      END IF
      T = D1 + ( D2-DJ00 )

*  Fractional part of T (days).
      F = MOD ( D1, 1D0 ) + MOD ( D2, 1D0 )

*  Earth rotation angle at this UT1.
      iau_ERA00 = iau_ANP ( D2PI * ( F + 0.7790572732640D0
     :                                 + 0.00273781191135448D0 * T ) )

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


      subroutine fourg (data,n,isign,work)
c     cooley-tukey fast fourier transform in usasi basic fortran.
c     one-dimensional transform of complex data, arbitrary number of
c     points.  n points can be transformed in time proportional to
c     n*log(n) (for n non-prime), whereas other methods take n**2 time.
c     furthermore, because fewer arithmetic operations are performed,
c     less error is built up.  the transform done is--
c     dimension data(n),transform(n),work(n)
c     complex data,transform,work
c     transform(k) = sum(data(j)*exp(isign*2*pi*i*(j-1)*(k-1)/n)),
c     summed from j = 1 to n for all k from 1 to n.  the transform
c     values are returned to data, replacing the input.  n may be any
c     positive number, but it should be non-prime for speed.  isign =
c     +1 or -1.  a -1 transform followed by a +1 one (or vice versa)
c     returns n times the original data.  work is a one-dimensional
c     complex array of length n used for working storage.
c     running time is proportional to n * (sum of the prime factors of
c     n).  for example, n = 1960, time is t0 * 1960 * (2+2+2+5+7+7).
c     naive methods directly implementing the summation run in time
c     proportional to n**2.  an upper bound for the rms relative error
c     is 3 * 2**(-b) * sum(f**1.5), where b is the number of bits in
c     the floating point fraction and the sum is over the prime
c     factors of n.  written by norman brenner, mit lincoln laboratory,
c     august 1968.  see--ieee transactions on audio and e
c     (june 1967), special issue on the fast fourier transform.
      dimension data(1), work(1), ifact(32)
      twopi=6.283185307*float(isign)
c     factor n into its prime factors, nfact in number.  for example,
c     for n = 1960, nfact = 6 and ifact(if) = 2, 2, 2, 5, 7 and 7.
      if=0
      npart=n
      do 50 id=1,n,2
      idiv=id
      if (id-1) 10,10,20
 10   idiv=2
 20   iquot=npart/idiv
      if (npart-idiv*iquot) 40,30,40
 30   if=if+1
      ifact(if)=idiv
      npart=iquot

      go to 20
 40   if (iquot-idiv) 60,60,50
 50   continue
 60   if (npart-1) 80,80,70
 70   if=if+1
      ifact(if)=npart
 80   nfact=if
c     shuffle the data array by reversing the digits of the index.
c     replace data(i) by data(irev) for all i from 1 to n.  irev-1 is
c     the integer whose digit representation in the multi-radix
c     notation of factors ifact(if) is the reverse of the r
c     of i-1.  for example, if all ifact(if) = 2, then for i-1 = 11001,
c     irev-1 = 10011.  a work array of length n is needed.
      ip0=2
      ip3=ip0*n
      iwork=1
      i3rev=1
      do 110 i3=1,ip3,ip0
      work(iwork)=data(i3rev)
      work(iwork+1)=data(i3rev+1)
      ip2=ip3
      do 100 if=1,nfact
      ip1=ip2/ifact(if)
      i3rev=i3rev+ip1
      if (i3rev-ip2) 110,110,90
 90   i3rev=i3rev-ip2
 100  ip2=ip1
 110  iwork=iwork+ip0
      iwork=1
      do 120 i3=1,ip3,ip0
      data(i3)=work(iwork)
      data(i3+1)=work(iwork+1)
 120  iwork=iwork+ip0
c     phase-shifted fourier transform of length ifact(if).
c     iprod=ip1/ip0
c     irem=n/(ifact(if)*iprod)
c     dimension data(iprod,ifact(if),irem),work(ifact(if))
c     complex data,work
c     data(i1,j2,i3) = sum(data(i1,i2,i3) * w**(i2-1)), summed over
c     i2 = 1 to ifact(if) for all i1 from 1 to iprod, j2 from 1 to

c     ifact(if) and i3 from 1 to irem.
c     w = exp(isign*2*pi*i*(i1-1+iprod*(j2-1))/(iprod*ifact(if))).
      if=0
      ip1=ip0
 130  if (ip1-ip3) 140,240,240
 140  if=if+1
      ifcur=ifact(if)
      ip2=ip1*ifcur
      theta=twopi/float(ifcur)
      sinth=sin(theta/2.)
      rootr=-2.*sinth*sinth
c     cos(theta)-1, for accuracy
      rooti=sin(theta)
      theta=twopi/float(ip2/ip0)
      sinth=sin(theta/2.)
      wstpr=-2.*sinth*sinth
      wstpi=sin(theta)
      wminr=1.
      wmini=0.
      do 230 i1=1,ip1,ip0
      if (ifcur-2) 150,150,170
 150  do 160 i3=i1,ip3,ip2
      j0=i3
      j1=i3+ip1
      tempr=wminr*data(j1)-wmini*data(j1+1)
      tempi=wminr*data(j1+1)+wmini*data(j1)
      data(j1)=data(j0)-tempr
      data(j1+1)=data(j0+1)-tempi
      data(j0)=data(j0)+tempr
 160  data(j0+1)=data(j0+1)+tempi
      go to 220
 170  iwmax=ip0*ifcur
      do 210 i3=i1,ip3,ip2
      i2max=i3+ip2-ip1
      wr=wminr
      wi=wmini
      do 200 iwork=1,iwmax,ip0
      i2=i2max
      sumr=data(i2)
      sumi=data(i2+1)

 180  i2=i2-ip1
      tempr=sumr
      sumr=wr*sumr-wi*sumi+data(i2)
      sumi=wr*sumi+wi*tempr+data(i2+1)
      if (i2-i3) 190,190,180
 190  work(iwork)=sumr
      work(iwork+1)=sumi
      tempr=wr
      wr=wr*rootr-wi*rooti+wr
 200  wi=tempr*rooti+wi*rootr+wi
      iwork=1
      do 210 i2=i3,i2max,ip1
      data(i2)=work(iwork)
      data(i2+1)=work(iwork+1)
 210  iwork=iwork+ip0
 220  tempr=wminr
      wminr=wminr*wstpr-wmini*wstpi+wminr
 230  wmini=tempr*wstpi+wmini*wstpr+wmini
      ip1=ip2
      go to 130
 240  return
      end


      SUBROUTINE ERRANL(PHI,U,V,DIV,ZETA,LN,GPHS,L2CTR,NFLAG)
C
C THIS ROUTINE COMPUTES VARIOUS FORMS OF SCALAR ERROR ESTIMATES
C BY COMPARISON WITH THE ANALYTIC SOLUTIONS
C THE ROUTINE THEN PLOTS THE ANALYTIC SOLUTION AND THE DEPARTURE
C (THE ERROR) BY CALLING THE STANDARD PLOTTING ROUTINE WITH
C VARIABLES PLACED INTO THE WORKSPACE (IF GPHS = .TRUE.).
C
C CALLED BY: STSWM
C CALLS: AGSETI, ANLYTC, ANOTAT, EZXY, GLAT, PLOTS, WEIGHT
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C Constants
      INCLUDE 'consts.i'
C Initial Conditions (test case 4 special treatment)
      INCLUDE 'finit.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C HEIGHT
      REAL PHI(NLON+2,NLAT)
C U WIND VELOCITY
      REAL U(NLON+2,NLAT)
C V WIND VELOCITY
      REAL V(NLON+2,NLAT)
C DIVERGENCE
      REAL DIV(NLON+2,NLAT,LVLS)
C VORTICITY
      REAL ZETA(NLON+2,NLAT,LVLS)
C CURRENT TIMELEVEL OF DIVERGENCE,VORTICITY
      INTEGER LN
C IF .TRUE. PLOT CURRENT ANALYTIC SOLUTION AND ERROR
      LOGICAL GPHS
C ARRAY LOCATION TO STORE ERRORS FOR LATER PLOTTING
      INTEGER L2CTR
C IF .TRUE. CAUSES PLOTS OF TIME HISTORY OF ERRORS
      LOGICAL NFLAG
C
C------ Local Variables ------------------------------------------------
C
C     STORAGE ARRAYS FOR ERROR MEASURES
C     SUFFICIENT FOR UP TO NGRPHS ENTRIES
C     SAVE ERROR MEASURES IN ARRAY FOR PLOTTING
C
C     L1, L2 AND L(INFINITY) ERRORS FOR HEIGHT AND
C     VECTOR VELOCITY, TIME
C
      REAL PL1G(NGRPHS),VL1G(NGRPHS),VL2G(NGRPHS), PL2G(NGRPHS),
     $     PINFG(NGRPHS),VINFG(NGRPHS),TME(NGRPHS)
      SAVE PL1G,VL1G,PL2G,VL2G,PINFG,VINFG,TME
C
C     MINIMUM, MAXIMUM, MEAN AND VARIANCE
C
      REAL PMING(NGRPHS),PMAXG(NGRPHS),PAVGG(NGRPHS),PVARG(NGRPHS)
      SAVE PMING,PMAXG,PAVGG,PVARG
C
C     GRID WEIGHTS
C
      REAL WTS
C
C     NORMALIZATION CONSTANTS (FOR COMPARABLE GRAPHS)
C     SAVES INITIAL VALUES OF ANALYTIC SOLUTION
C     AND THEN PLOTS ERRORS AS RELATIVE ERRORS
C
      REAL MINN,MAXN,MEANN,VARN
      SAVE MINN,MAXN,MEANN,VARN
C
C     FIELDS FOR ANALYTIC SOLUTION
C
      REAL UANL(NLON+2,NLAT),VANL(NLON+2,NLAT),PANL(NLON+2,NLAT),
     $     DANL(NLON+2,NLAT),ZANL(NLON+2,NLAT)
C
C     TEMPORARY VARIABLES FOR COMPUTED SOLUTION
C
      REAL MINP,MAXP,MAXV,MEAN,VAR,
     $     VMAX,PINF,VL1,PL1,VL2,PL2,VLEN
C
C     TEMPORARY VARIABLES FOR ANALYTIC SOLUTION
C
      REAL MEANT,VART,MINT,MAXT,
     $     VMAXT,PINFT,VL1T,PL1T,VL2T,PL2T,VLENT,PABS
C
C     TEMPORARY VARIABLES FOR ERROR MEASURES
C
      INTEGER I,J
      REAL VDIFF
C
C     CHARACTER ARRAYS FOR PLOT TITLES
C
      CHARACTER*64 GPH
      CHARACTER*40 XAXIS
      CHARACTER*1 DASH(1)
      SAVE DASH
C
C----- External Functions ----------------------------------------------
C
C     GAUSSIAN GRID AND WEIGHTS
C
      EXTERNAL GLAT, WEIGHT
      REAL GLAT, WEIGHT
C
C----- Initialized Variables -------------------------------------------
C
C     FULL LINE GRAPHS
C
      DATA DASH(1) / '$' /
C
C----- Executable Statements -------------------------------------------
C
      IF (NFLAG) THEN
         IF (.NOT. LGPHS) THEN
C
C           NO PLOTING OUTPUT -> RETURN
C
         ELSE
C
C        PLOT TIME DEPENDENCE OF ERRORS
C
C        GRAPH AXIS TEXT
C
         CALL AGSETI('LINE/MAXIMUM.', 64)
         XAXIS = 'TIME IN HOURS$'
C
C        PLOT HEIGHT ERROR OVER TIME
C
         WRITE(GPH,5) 'HEIGHT ERROR,TEST ',ICOND,CHEXP,STRUNC,INT(DT)
    5    FORMAT(A18,I2,',EXP.',A4,',',A6,',DT = ',I4,' SEC$')
C
         CALL ANOTAT(XAXIS,'L1-NORM$',1,1,0,DASH)
         CALL EZXY(TME, PL1G, L2CTR, GPH)
C
         CALL ANOTAT(XAXIS,'L2-NORM$',1,1,0,DASH)
         CALL EZXY(TME, PL2G, L2CTR, GPH)
C
         CALL ANOTAT(XAXIS,'L(INF)-NORM$',1,1,0,DASH)
         CALL EZXY(TME, PINFG, L2CTR, GPH)
C
C        PLOT WIND ERROR OVER TIME
C
         WRITE(GPH,5) 'WIND ERROR,  TEST ',ICOND,CHEXP,STRUNC,INT(DT)

         CALL ANOTAT(XAXIS,'L1-NORM$',1,1,0,DASH)
         CALL EZXY(TME,VL1G, L2CTR, GPH)
C
         CALL ANOTAT(XAXIS,'L2-NORM$',1,1,0,DASH)
         CALL EZXY(TME,VL2G, L2CTR, GPH)
C
         CALL ANOTAT(XAXIS,'L(INF)-NORM$',1,1,0,DASH)
         CALL EZXY(TME, VINFG, L2CTR, GPH)
C
C        PLOT MINIMUM/MAXIMUM
C
         WRITE(GPH,5) 'HEIGHT MIN., TEST ',ICOND,CHEXP,STRUNC,INT(DT)
C
         CALL ANOTAT(XAXIS,'RELATIVE ERROR$',1,1,0,DASH)
         CALL EZXY(TME, PMING, L2CTR, GPH)
C
         WRITE(GPH,5) 'HEIGHT MAX., TEST ',ICOND,CHEXP,STRUNC,INT(DT)
C
         CALL ANOTAT(XAXIS,'RELATIVE ERROR$',1,1,0,DASH)
         CALL EZXY(TME, PMAXG, L2CTR, GPH)
C
C        PLOT NORMALIZED MEAN/VARIANCE
C
         WRITE(GPH,5) 'HEIGHT AVG., TEST ',ICOND,CHEXP,STRUNC,INT(DT)
C
         CALL ANOTAT(XAXIS,'RELATIVE ERROR$',1,1,0,DASH)
         CALL EZXY(TME, PAVGG, L2CTR, GPH)
C
         WRITE(GPH,5) 'HEIGHT VAR., TEST ',ICOND,CHEXP,STRUNC,INT(DT)
C
         CALL ANOTAT(XAXIS,'RELATIVE ERROR$',1,1,0,DASH)
         CALL EZXY(TME, PVARG, L2CTR, GPH)
C
C        DONE TIME SERIES PLOTS -> RETURN
C
         ENDIF
C
      ELSE
C
C     DO ERROR ANALYSIS ON MODEL GRID
C
C     INITIALIZE ERROR VARIABLES
C
      VMAX  = 0.0
      VMAXT = 0.0
      PINF  = 0.0
      PINFT = 0.0
      VL1   = 0.0
      VL1T  = 0.0
      PL1   = 0.0
      PL1T  = 0.0
      VL2   = 0.0
      VL2T  = 0.0
      PL2   = 0.0
      PL2T  = 0.0
      MINP  = PHI(1,1)
      MAXP  = PHI(1,1)
      MAXV  = 0.0
      MEAN  = 0.0
      MEANT = 0.0
      VAR   = 0.0
      VART  = 0.0
C
C     GET ANALYTIC SOLUTION
C     CALL ROUTINE FOR TIME DEPENDENT ANALYTIC SOLUTIONS WHICH WILL BE
C     STUCK IN UANL, VANL, PANL, DANL AND ZANL
C
      CALL ANLYTC(1,1,NSTEP*DT,ICOND,UANL,VANL,PANL,DANL,ZANL)
C
      DO 120 J=1,NLAT
C
C        WEIGHT INDEPENDENT OF LONGITUDE
C
         WTS = WEIGHT(1,J)
C
C        CALCULATE COMPONENTS OF L2 NORM, AND OTHER MEASURES OF ERROR
C        FOR SMALL U, SMALL V, AND HEIGHT
C
         DO 10 I=1,NLON
C
C           WEIGH DATA DEPENDENT ON LATITUDE & LONGITUDE
C
C           WTS   = WEIGHT(I,J)
C
            VLEN  = SQRT(U(I,J)**2+V(I,J)**2)
            VDIFF = SQRT((U(I,J)-UANL(I,J))**2 +
     $              (V(I,J)-VANL(I,J))**2)
C
C           L1 ERRORS
C
            VL1   = VL1 + VDIFF*WTS
            PL1   = PL1 + ABS(PHI(I,J)-PANL(I,J))*WTS
C
C           L2 ERRORS
C
            VL2   = VL2 + VDIFF**2*WTS
            PL2   = PL2 + (PHI(I,J)-PANL(I,J))**2*WTS
C
C           L(INFINITY) ERRORS
C
            IF (VDIFF .GT. VMAX) THEN
               VMAX  = VDIFF
            ENDIF
            IF (ABS(PANL(I,J)-PHI(I,J)) .GT. PINF) THEN
               PINF  = ABS(PANL(I,J)-PHI(I,J))
            ENDIF
C
C           MAXIMUM WIND COMPUTED
C
            IF (PHI(I,J) .LT. MINP) THEN
               MINP = PHI(I,J)
            ENDIF
C
            IF (PHI(I,J) .GT. MAXP) THEN
               MAXP = PHI(I,J)
            ENDIF
            IF (VLEN .GT. MAXV) THEN
               MAXV = VLEN
            ENDIF
C
C           MINIMUM/MAXIMUM ANALYTIC SOLUTION
C
            IF ((I .EQ. 1) .AND. (J .EQ. 1)) THEN
               MINT = PANL(1,1)
               MAXT = PANL(1,1)
            ELSE
               IF (PANL(I,J) .LT. MINT) THEN
                  MINT = PANL(I,J)
               ENDIF
               IF (PANL(I,J) .GT. MAXT) THEN
                  MAXT = PANL(I,J)
               ENDIF
            ENDIF
C
C           MEAN VALUES
C
            MEAN = MEAN + PHI(I,J)*WTS
            MEANT = MEANT + PANL(I,J)*WTS
C
C           ERROR NORMALIZATION
C
            IF (ICOND .NE. 4) THEN
               PABS  = ABS(PANL(I,J))
               VLENT = SQRT(UANL(I,J)**2+VANL(I,J)**2)
            ELSE
C
C     SPECIAL HANDLING FOR CASE 4: SUBTRACT MEAN FLOW TO COMPUTE
C     ERROR RELATIVE TO FORCING
C     SEE PAPER BY BROWNING ET. AL.: A COMPARISON OF THREE
C     NUMERICAL METHODS FOR ... P. 1072 !
C
               PABS  = ABS(PANL(I,J) - PHICON(J))
               VLENT = SQRT((UANL(I,J) - UCON(J))**2
     $                 + (VANL(I,J) - VCON(J))**2)
            ENDIF
            PL1T  = PL1T + PABS*WTS
            VL1T  = VL1T + VLENT*WTS
            PL2T  = PL2T + PABS**2*WTS
            VL2T  = VL2T + VLENT**2*WTS
C
            IF (VLENT .GT. VMAXT) THEN
               VMAXT  = VLENT
            ENDIF
            IF (PABS .GT. PINFT) THEN
               PINFT  = PABS
            ENDIF
   10    CONTINUE
C
C        NEXT LATITUDE
C
  120 CONTINUE
C
C     COMPUTE VARIANCE
C
      DO 70 J=1,NLAT
         WTS = WEIGHT(1,J)
         DO 60 I=1,NLON
C           WTS = WEIGHT(I,J)
            VAR  = VAR + (PHI(I,J)-MEAN)**2*WTS
            VART = VART + (PANL(I,J)-MEANT)**2*WTS
   60    CONTINUE
   70 CONTINUE
C
C     CALCULATE L1 ERRORS
C
      IF (VL1T .NE. 0.0) THEN
         VL1G(L2CTR) = VL1/VL1T
      ELSE
         VL1G(L2CTR) = VL1
      ENDIF
C
      IF (PL1T .NE. 0.0) THEN
         PL1G(L2CTR) = PL1/PL1T
      ELSE
         PL1G(L2CTR) = PL1
      ENDIF
C
C     CALCULATE L2 ERRORS
C
      IF (VL2T .NE. 0.0) THEN
         VL2G(L2CTR) = SQRT(VL2/VL2T)
      ELSE
         VL2G(L2CTR) = SQRT(VL2)
      ENDIF
C
      IF (PL2T .NE. 0.0) THEN
         PL2G(L2CTR) = SQRT(PL2/PL2T)
      ELSE
         PL2G(L2CTR) = SQRT(PL2)
      ENDIF
C
C     CALCULATE L(INFINITY) ERRORS
C
      IF (VMAXT .NE. 0.0) THEN
         VINFG(L2CTR) = VMAX/VMAXT
      ELSE
         VINFG(L2CTR) = VMAX
      ENDIF
C
      IF (PINFT .NE. 0.0) THEN
         PINFG(L2CTR) = PINF/PINFT
      ELSE
         PINFG(L2CTR) = PINF
      ENDIF
C
C     HEIGHT MIN,MAX,MEAN AND VARIANCE
C     SAVE INITIAL VALUES FOR TIME-INDEPENDENT NORMALIZATION
C
      IF (L2CTR .EQ. 1) THEN
         MINN  = MINT
         MAXN  = MAXT
         MEANN = MEANT
         VARN  = VART
         WRITE(6,986) MINN,MAXN,MEANT,VART
  986    FORMAT (/, ' ERRANL: INITIAL VALUES FOR NORMALIZ',
     $              'ATION OF RELATIVE ERRORS',/,
     $              ' (SLIGHTLY GRID DEPENDENT!)',/,
     $              ' HEIGHT MIN./MAX. = ',1PE16.9,'/',1PE16.9,/,
     $              ' HEIGHT AVG./VAR. = ',1PE16.9,'/',1PE16.9)
C
      ELSEIF (L2CTR .GT. 1) THEN
C
C     PRINT RESULTS
C
         WRITE (6,987) NSTEP, TAU
  987    FORMAT (/, ' ERRANL: ERROR ESTIMATES FOR NSTEP = ', I4,
     $           ', TAU = ', 0PF6.2, ' HRS')
C
         WRITE (6,122) PL1G(L2CTR),PL2G(L2CTR),PINFG(L2CTR)
  122    FORMAT (' HEIGHT ERROR',/,
     $           ' L1 = ', 1PE16.9, ', L2 = ', 1PE16.9,
     $           ' L(INF) = ', 1PE16.9)
C
         WRITE (6,123) VL1G(L2CTR),VL2G(L2CTR),VINFG(L2CTR)
  123    FORMAT (' VECTOR WIND ERROR',/,
     $           ' L1 = ', 1PE16.9, ', L2 = ', 1PE16.9,
     $           ' L(INF) = ', 1PE16.9)
C
         WRITE (6,124) MINP,MAXP
  124    FORMAT (' HEIGHT MIN./MAX.  = ',1PE16.9,'/',1PE16.9)
C
         WRITE (6,126) MEAN,VAR
  126    FORMAT (' HEIGHT AVG./VAR.  = ',1PE16.9,'/',1PE16.9)
C
C        CHECK FOR ARRAY OVERFLOW
C
         IF (L2CTR .GE. NGRPHS) THEN
            WRITE (0,905) L2CTR
  905       FORMAT(/,' STSWM: FATAL ERROR IN SUBROUTINE ERRANL ',
     $         /,' ARGUMENT L2CTR EXCEEDS ALLOCATED ',
     $           'STORAGE FOR VARIABLES L2CTR = ',I4, /)
            STOP
         ENDIF
      ENDIF
C
C     SAVE RELATIVE ERRORS FOR LATER PLOTTING
C
      PMING(L2CTR) = (MINP-MINT)/(MAXN-MINN)
      PMAXG(L2CTR) = (MAXP-MAXT)/(MAXN-MINN)
      PAVGG(L2CTR) = (MEAN-MEANT)/MEANN
      PVARG(L2CTR) = (VAR-VART)/VARN
C
C     SAVE TIME POINT
C
      TME(L2CTR) = TAU
C
C     2D PLOTS OF ANALYTIC SOLUTION AND ERROR
C
      IF (GPHS) THEN
C
C        PLOTS OF ANALYTIC SOLUTION
C        CALLING ARGUMENT = 2
C
         CALL PLOTS (2,PANL,PHI,UANL,VANL,ZANL,DANL,1,1)
C
C        NEXT CALL TO GRAPHICS PROCEDURE PLOTS ERRORS IN SOLUTION
C        STICK ERROR FIELDS INTO UANL, VANL, ZANL, DANL, AND PANL
C
         DO 260 J=1,NLAT
C
C           ANALYTIC SOLUTION IS STILL IN xANL FROM PREVIOUS CALL TO
C           ANLYTC; SUBTRACT FROM COMPUTED SOLUTION FOR ERROR
C
            DO 250 I=1,NLON
               UANL(I,J) = U(I,J)-UANL(I,J)
               VANL(I,J) = V(I,J)-VANL(I,J)
               PANL(I,J) = PHI(I,J)-PANL(I,J)
               ZANL(I,J) = ZETA(I,J,LN)-ZANL(I,J)
               DANL(I,J) = DIV(I,J,LN)-DANL(I,J)
  250       CONTINUE
  260    CONTINUE
C
C        PLOTS OF ERROR (ANALYTIC - COMPUTED)
C        CALLING ARGUMENT = 1
C
         CALL PLOTS (1,PANL,PANL,UANL,VANL,ZANL,DANL,1,1)
C
C        END 2D PLOTS
C
      ENDIF
C
C     END ERROR ANALYSIS ON GRID
C
      ENDIF
C
      RETURN
      END


module material_content_test
  use material_content_m, only: material_content_t
  use random_sample_m, only: random_sample_t
  use vegetables, only: test_item_t, describe, it, result_t, assert_that, assert_not
  implicit none
  private
  public :: test_material_content

contains
  function test_material_content() result(tests)

    type(test_item_t) :: tests

    tests = describe( &
        "material_content_t", &
        [ it("is not marked as user_defined initially", check_not_user_defined) &
        , it("is marked as user_defined after being constructed", check_user_defined) &
        , it("contents are not negative", check_contents_not_negative) &
        , it("two material contents are within 6 sigma of eachother", check_difference) &
        ])
  end function

  function check_not_user_defined() result(result_)

    type(result_t) :: result_

    type(material_content_t) :: content

    result_ = assert_not(content%user_defined())
  end function

  function check_user_defined() result(result_)

    type(result_t) :: result_

    type(material_content_t) :: content
    type(random_sample_t) :: samples

    call samples%define()

    content = material_content_t( &
        Cu_ave = 0.1, Ni_ave = 0.2, Cu_sig = 0.01, Ni_sig = 0.01, samples=samples)

    result_ = assert_that(content%user_defined())
  end function

  function check_contents_not_negative() result(result_)
    type(result_t) :: result_

    type(material_content_t) :: content
    type(random_sample_t) :: samples

    call samples%define()

    content = material_content_t( &
        Cu_ave = 0.1, Ni_ave = 0.2, Cu_sig = 0.01, Ni_sig = 0.01, samples=samples)

    result_ = &
        assert_that(content%Cu() > 0.0, "Cu") &
        .and.assert_that(content%Ni() > 0.0, "Ni")
  end function

  function check_difference() result(result_)
    type(result_t) :: result_

    real, parameter :: CU_SIG = 0.01, NI_SIG = 0.01, CU_AVE = 0.1, NI_AVE = 0.2
    type(material_content_t) :: content1
    type(random_sample_t) :: samples1
    type(material_content_t) :: content2
    type(random_sample_t) :: samples2

    call samples1%define()
    call samples2%define()

    content1 = material_content_t( &
        Cu_ave = CU_AVE, Ni_ave = NI_AVE, Cu_sig = CU_SIG, Ni_sig = NI_SIG, samples=samples1)
    content2 = material_content_t( &
        Cu_ave = CU_AVE, Ni_ave = NI_AVE, Cu_sig = CU_SIG, Ni_sig = NI_SIG, samples=samples2)

    result_ = assert_that(content1%within_tolerance(content2, 6.*max(CU_SIG, NI_SIG)))
  end function
end module


!     Calculation of equivalentwidth
      REAL*4 FUNCTION EW(mode,x,y,n,xb,xe)
!     mode=0 --> equivalentwidth   (ew > 0 : absorption  ew<0 : emission)
!     mode=1 --> integral
!     x,y    --> function
!     xb,xe  --> start and end value
      INTEGER*4   mode,n
      REAL*8 x(n),xb,xe, sum
      REAL*8 y(n)

      EW  = 0.D0
***      print*, x,y,n,xb,xe
      ib = 1
      ie = n
      DO i=2,n
       IF (x(i-1).LT.xb) THEN
          ib = i
       ELSE
          GOTO 10
       ENDIF
      ENDDO
 10   CONTINUE
      DO i=n-1,ib,-1
       IF (x(i+1).GT.xe) THEN
          ie = i
       ELSE
          GOTO 20
       ENDIF
      ENDDO
 20   CONTINUE

      sum = 0.D0
      IF (mode.EQ.0) THEN
         DO i=ib,ie-1
           sum = sum + DBLE(2. - ( y(i) + y(i+1) ) )  *
     *                       0.5D0 * (x(i+1) - x(i))
         END DO
         EW = sum
         RETURN
      ELSEIF (mode.EQ.1) THEN
         DO i=ib,ie-1
           sum = sum + DBLE( y(i) + y(i+1) ) *
     *                       0.5D0 * ( x(i+1) - x(i) )
         END DO
         EW = sum
         RETURN
      ELSE
         WRITE(*,*) ' EW: Unknown mode ! '
      ENDIF

      print*, 'ew ', ew

      RETURN
      END