C
C	$Id: hlsrgb.f,v 1.5 2008-07-27 00:16:53 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE HLSRGB ( H, L, S, R, G, B )
C
C_BEGIN PROLOGUE HLSRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the Hue, Lightness, and Saturation color space to
C    Red, Green, and Blue intensity values in the RGB color
C    space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Hue, Lightness, Saturation (HLS) color space to color values
C    in the Red, Green, and Blue (RGB) color space.
C    The input value H is a floating point number in the
C    range [0.,360.); a value of H=0. in the input space
C    will result in a full blue (red and green values of 0.)
C    in the RGB space.  The input value L is in the range
C    [0.,100.]; lightness is used to signify the amount of light--
C    L=0. will result in R=G=B=0. and L=1. will result in
C    R=G=B=1. regardless of H and S.  The input value S is
C    in the range [0.,100.];  saturation is a measure of the
C    mixture of white light with a pure fully-saturated hue--
C    S=0. will result in R=G=B=L.  The output values
C    R, G, and B are red, green, and blue intensities
C    in the range 0. to 1. .
C
C_ARGUMENTS
C
C H       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input color
C         in HLS color space.  H=0. corresponds to blue.
C
C L       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the lightness value of the
C         input color in HLS color space.  Lightness is a measure
C         of the quantity of light--a lightness of 0. is black,
C         and a lightness of 100. gives white.  The pure hues occur
C         at lightness value 50.
C
C S       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the saturation value of the
C         input color in HLS color space.  Saturation is a measure
C         of how much white light is mixed with the color. Colors
C         having a satuartion value of 0. represent greys
C         with a grey intensity value equal to the lightness L.
C         Colors with a saturation value of 100. are
C         fully saturated colors.  The hue is undefined
C         when S=0.  The fully saturated pure hues occur when S=100.
C         and L=50.
C
C R       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    SIGPLC
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded at NCAR by Roy Barnes
C    using the algorithm presented in Foley and van Dam (see
C    REFERENCES below); it was prepared for the NCAR Graphics
C    package by Fred Clare.
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The idea of the algorithm can be understood if one were to
C    plot the red output values vs. hue for S=100. and L=50.  The red
C    values so plotted form a piecewise linear curve.  The blue
C    and green values plotted in the same way form the same
C    piecewise linear curve except shifted.  Decreasing the
C    saturation pushes the curves toward the lightness value,
C    and varying the lightness introduces an amplitude scale
C    factor and vertical offset.
C
C_EXAMPLES
C    Example 1 --  Pure hue to red.
C          SUBROUTINE HLS2
C          REAL    R,G,B,EPS
C          PARAMETER (EPS=0.00001)
C          CALL HLSRGB(120.,50.,100.,R,G,B)
C          IF ( (ABS(R-1.) .GT. EPS) .OR. (ABS(G) .GT. EPS) .OR.
C         *     (ABS(B) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' HLS2 returned incorrect values')
C          END
C
C_END PROLOGUE HLSRGB
C
      REAL   H,HH,L,S,R,G,B,LL,SS,M1,M2,SIGPLC
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT HLSRGB
      HH = MOD(H,360.)
      IF (HH .LT. 0.) HH = HH+360.
      IF (L.LT.0. .OR. L.GT.100.)
     *      CALL SETER(' HLSRGB - L out of range',1,1)
      IF (S.LT.0. .OR. S.GT.100.)
     *      CALL SETER(' HLSRGB - S out of range',1,1)
C
C  Normalize lightness and saturation values.
C
      LL = L/100.
      SS = S/100.
      IF (SS .EQ. 0.0) THEN
C
C  Achromatic case; RGB value is a grey equal to the lightness.
C
         R = LL
         G = LL
         B = LL
      ELSE
C
C  Calculate the max and min of the generic piecewise linear
C  color component function.
C
         IF (LL .LE. 0.5) THEN
             M2 = LL * (1.0 + SS)
         ELSE
             M2 = LL + SS - (LL * SS)
         ENDIF
         M1 = 2.0 * LL - M2
C
C  Compute RGB values.
C
         R = SIGPLC(M1,M2,HH+  0.)
         G = SIGPLC(M1,M2,HH-120.)
         B = SIGPLC(M1,M2,HH+120.)
      ENDIF
      RETURN
      END


module m_constants
    implicit none

    integer, public, parameter :: dp = kind(1.0d0)
    integer, public, parameter :: mystd = 6
    integer, public, parameter :: mytmp = 100

    real(dp), public, parameter :: zero = 0.0_dp
    real(dp), public, parameter :: one  = 1.0_dp
    real(dp), public, parameter :: pi   = 3.1415926535897932_dp

    complex(dp), public, parameter :: czi   = dcmplx(0.0_dp, 1.0_dp)
    complex(dp), public, parameter :: cone  = dcmplx(1.0_dp, 0.0_dp)
    complex(dp), public, parameter :: czero = dcmplx(0.0_dp, 0.0_dp)

    real(dp), public, parameter :: ev2k = 11604.505008098_dp

end module m_constants


      SUBROUTINE vander(x,w,q,n)
      INTEGER n,NMAX
      DOUBLE PRECISION q(n),w(n),x(n)
      PARAMETER (NMAX=100)
      INTEGER i,j,k
      DOUBLE PRECISION b,s,t,xx,c(NMAX)
      if(n.eq.1)then
        w(1)=q(1)
      else
        do 11 i=1,n
          c(i)=0.d0
11      continue
        c(n)=-x(1)
        do 13 i=2,n
          xx=-x(i)
          do 12 j=n+1-i,n-1
            c(j)=c(j)+xx*c(j+1)
12        continue
          c(n)=c(n)+xx
13      continue
        do 15 i=1,n
          xx=x(i)
          t=1.d0
          b=1.d0
          s=q(n)
          do 14 k=n,2,-1
            b=c(k)+xx*b
            s=s+q(k-1)*b
            t=xx*t+b
14        continue
          w(i)=s/t
15      continue
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/vander.for


*dk,ranpts_lg
      subroutine ranpts_lg(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr)

C#######################################################################
C
C     PURPOSE -
C       This routine is used to add random points to the region of space
C       defined by the minimum and maximum coordinate values
C       using the specified geometry, plus the specified local origin shift
C       (local origin specified in xyz coordinates!)
C
C     INPUT ARGUMENTS -
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
C
C     OUTPUT ARGUMENTS -
C        ierr - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C     LOCAL VARIABLES -
C        * GEOMETRY LABEL
C           cgeom =  xyz ==> x , y , z cartesian geometry
C                 =  rtz ==> r , theta , z ==> cylindrical geometry
C                 =  rtp ==> r , theta , phi  ==> spherical geometry
C                            theta runs from 0 to 180, 0 is +z axis
C           NOTE: angles are in degrees
C        * TARGET POINT SPACING
C           spacing (uniform)
C
C        * MIN,MAX COORDINATES (in "cgeom" coordinates)
C           rext(1,j)=(rmin1,rmin2,rmin3)
C           rext(2,j)=(rmax1,rmax2,rmax3)
C        * CARTESIAN COORDINATES OF LOCAL ORIGIN (in "xyz" coordinates)
C           roff(j)=(xoff,yoff,zoff)
C        * EDGE PROTECTION DISTANCE
C           edgedist   (recommended: spacing/2)
C        * RANDOM NUMBER SEEDS
C           ranseed1,ranseed2 (large-ish integers, ranseed1>ranseed2)
C
C     FORMAT -
C
C       RANPTS / cgeom / spacing /  rmin1,rmin2,rmin3 / rmax1,rmax2,rmax3 &
C                 [/ xoff,yoff,zoff / edgedist / ranseed1,ranseed2 ]
C
C     DEFAULTS if not present -
C       "ranpts" without any arguments will add a point at the origin
C       cgeom = 'xyz'
C            allowed values are [xyz|XYZ|rtz|RTZ|rtp|RTP]
C            (anything else except blank returns error)
C       spacing = 1
C       rext(1,j) = 0
C       rext(2,j) = rext(1,j)
C       roff(j) = 0
C       edgedist = 1/2*spacing
C       ranseed1,ranseed2 = -1 (random number generator not re-seeded)
C
C     EXAMPLES -
C       random points with target spacing 0.1 in a 1x1x1 box
C             ranpts / xyz / .1 / 0 0 0 / 1 1 1 /
C       random points with target spacing 0.1 in a cylinder
C          of radius 1 centered at xyz=(2,3,4) and with an
c          edge protection distance of 0.2
C             ranpts/ rtz / .1 /  0,0,0 / 1,180,360 / 2,3,4 / 0.2
C       random points with target spacing 0.5 on the surface of a sphere
C          of radius 5 with new random seeds
C             ranpts/ rtp / .5 /  5,0,0 / 5,180,360 /  , ,  /  / 98765 4321/
C
C     CAVEATS -
C       * filter should be used afterwards to remove possibly duplicate points
C       * mistyped input after "ranpts/[cgeom]" always returns successful
C         point addition, but may be very different than desired
C       * not clever about area(theta) for rtp geom -> constrained theta
C         to be between 0 and 180 so don't have to worry about negative areas.
C         Also constrained r to be positive for rtz,rtp
C
C     CHANGE HISTORY -
C
C        $Log: ranpts_lg.f,v $
C        Revision 2.00  2007/11/09 20:03:59  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.4   23 Aug 2001 12:58:14   jtg
CPVCS    generates warning instead of error if ndimensions_geom not 3
CPVCS
CPVCS       Rev 1.3   Thu Apr 06 13:40:18 2000   dcg
CPVCS    replace get_info_i and set_info_i calls
CPVCS
CPVCS       Rev 1.2   Thu Oct 07 13:35:34 1999   gable
CPVCS    Changed format of screen output from i6 to i11
CPVCS
CPVCS       Rev 1.1   Sat Jul 10 22:02:46 1999   jtg
CPVCS    fixed typo in header examples.
CPVCS
CPVCS       Rev 1.0   Sat Jul 10 20:48:12 1999   jtg
CPVCS    Initial revision.
C
C#######################################################################
c ........................................................................

      implicit none

      include 'chydro.h'
      include 'consts.h'

      integer nwds, imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
      character*132 logmess

      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      real*8 xic(*), yic(*), zic(*)

      character*32 cgeom
      character*32 cmo, isubname

      integer ierr,icscode,ipointi,ipointj,ilen,ityp
     &  ,icount,nnodes,nnodes_new,nnodes_save,icntin
     &  ,j,iwd,i1,i2,i3,i4,geom_dim
     &  ,nadd(14),ranseed1,ranseed2,ind,maxends(5)

      real*8 rrr,theta,phi,degtorad,pi,xxx,rand_lg
     &  ,spacing,edgedist,rext(2,3),roff(3)
     &  ,r0(14),r1(14)

C#######################################################################
C get some initial info

      isubname='ranpts_lg'

      ierr=0

      call cmo_get_name(cmo,ierr)
      if (ierr.ne.0) then
         ierr=1
         goto 9999
      endif

      call cmo_get_info('ipointi',cmo
     &                ,ipointi,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=2
         goto 9999
      endif
      call cmo_get_info('ipointj',cmo
     &                ,ipointj,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=3
         goto 9999
      endif

      call cmo_get_info('nnodes',cmo,nnodes,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=4
         goto 9999
      endif

      call cmo_get_info('ndimensions_geom',cmo,geom_dim
     &                  ,ilen,ityp,ierr)
      if (ierr.ne.0) then
         ierr=5
         goto 9999
      elseif (geom_dim.ne.3) then
         write(logmess,*) '  RANPTS WARNING - ndimensions_geom.ne.3'
         call writloga('default',0,logmess,0,icscode)
         ! ierr=6
         ! goto 9999
      endif

C ******************************************************************
C assign the constants

      pi=four*atan(one)
      degtorad=pi/180.0d0

C assign the local variables

C assign the geometry type
      if (msgtype(2).eq.1.or.msgtype(2).eq.2) then
         ! probably mistyped
         ierr=7
         goto 9999
      elseif (msgtype(2).ne.3) then
         cgeom='xyz'
      else
         cgeom=cmsgin(2)
         if (cgeom.eq.'RTZ') then
            cgeom='rtz'
         elseif (cgeom.eq.'RTP') then
            cgeom='rtp'
         elseif (cgeom.eq.'XYZ') then
            cgeom='xyz'
         elseif (cgeom.ne.'rtz'.and.cgeom.ne.'rtp'
     &       .and.cgeom.ne.'xyz') then
            ! probably mistyped
            ierr=8
            goto 9999
         endif
      endif

      icount=ipointj

C assign the spacing
      if (nwds.lt.3) then
         spacing=one
      elseif (msgtype(3) .eq. 1) then
         spacing=imsgin(3)
      elseif (msgtype(3) .eq. 2) then
         spacing=xmsgin(3)
      else
         spacing=one
      endif
      if (spacing.le.zero) goto 9999

C assign the minima
      do j=1,3
         iwd=j+3
         if (iwd.gt.nwds) then
            rext(1,j)=zero
         elseif (msgtype(iwd) .eq. 1) then
            rext(1,j)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            rext(1,j)=xmsgin(iwd)
         else
            rext(1,j)=zero
         endif
      enddo

C assign the maxima
      do j=1,3
         iwd=j+6
         if (iwd.gt.nwds) then
            rext(2,j)=rext(1,j)
         elseif (msgtype(iwd) .eq. 1) then
            rext(2,j)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            rext(2,j)=xmsgin(iwd)
         else
            rext(2,j)=rext(1,j)
         endif
      enddo

C check the extremes

      ! check min,max relation correct
      do j=1,3
         if (rext(1,j).gt.rext(2,j)) then
            goto 9999
         elseif (rext(1,j).eq.rext(2,j)) then
            maxends(j)=1
         else
            maxends(j)=2
         endif
      enddo

      i1=0
      ! make sure r positive for rtz,rtp geometries
      if (cgeom.eq.'rtp'.or.cgeom.eq.'rtz') then
         if (rext(2,1).lt.zero) then
            goto 9999
         elseif (rext(1,1).le.zero) then
            maxends(1)=-maxends(1)
            if (rext(1,1).lt.zero) i1=1
            rext(1,1)=zero
         endif
      endif
      if (cgeom.eq.'rtp') then
         ! restrict theta to [0,180]
         if (rext(2,2).lt.zero.or.rext(1,2).gt.180.d0) goto 9999
         maxends(4)=2
         if (rext(1,2).le.zero) then
            if (rext(1,2).lt.zero) i1=i1+2
            rext(1,2)=zero
            maxends(4)=1
         endif
         maxends(5)=2
         if (rext(2,2).ge.180.d0) then
            if (rext(2,2).gt.180.d0) i1=i1+4
            rext(2,2)=180.d0
            maxends(5)=1
         endif
         ! restrict phi range to 360 degrees
         phi=rext(2,3)-rext(1,3)
         if (phi.ge.360.d0) then
            if (phi.gt.360.d0) i1=i1+8
            maxends(3)=1
            rext(2,3)=rext(1,3)+360.d0
         endif
         ! convert angles to radians
         rext(1,2)=rext(1,2)*degtorad
         rext(2,2)=rext(2,2)*degtorad
         rext(1,3)=rext(1,3)*degtorad
         rext(2,3)=rext(2,3)*degtorad
      elseif (cgeom.eq.'rtz') then
         ! restrict theta range to 360 degrees
         theta=rext(2,2)-rext(1,2)
         if (theta.ge.360.d0) then
            if (theta.gt.360.d0) i1=i1+2
            maxends(2)=1
            rext(2,2)=rext(1,2)+360.d0
         endif
         ! convert angles to radians
         rext(1,2)=rext(1,2)*degtorad
         rext(2,2)=rext(2,2)*degtorad
      endif
      if (i1.gt.0) then
         if (cgeom.eq.'rtp') then
            write(logmess,*)
     &          'RANPTS WARNING: r,theta,phi range truncated ',i1
         else
            write(logmess,*)
     &          'RANPTS WARNING: r,theta range truncated ',i1
         endif
         call writloga('default',0,logmess,0,icscode)
      endif

C assign the origin shift
      do j=1,3
         iwd=j+9
         if (iwd.gt.nwds) then
            roff(j)=zero
         elseif (msgtype(iwd) .eq. 1) then
            roff(j)=imsgin(iwd)
         elseif (msgtype(iwd) .eq. 2) then
            roff(j)=xmsgin(iwd)
         else
            roff(j)=zero
         endif
      enddo

C assign the edge protection factor
      if (nwds.lt.13) then
         edgedist=half*spacing
      elseif (msgtype(13) .eq. 1) then
         edgedist=imsgin(13)
      elseif (msgtype(13) .eq. 2) then
         edgedist=xmsgin(13)
      else
         edgedist=half*spacing
      endif

C assign the random_number seeds (use golden mean x 10^8 as default)
      if (nwds.ge.15) then
         if (msgtype(14) .eq. 1) then
            ranseed1=imsgin(14)
         elseif (msgtype(14) .eq. 2) then
            ranseed1=xmsgin(14)
         else
            ranseed1=-1
         endif
         if (msgtype(15) .eq. 1) then
            ranseed2=imsgin(15)
         elseif (msgtype(15) .eq. 2) then
            ranseed2=xmsgin(15)
         else
            ranseed2=-1
         endif
         if (ranseed1.gt.0.and.ranseed2.gt.0) then
            call seed_rand_lg(ranseed1,ranseed2)
         endif
      endif

C ******************************************************************
C figure out number of points to add
c inside is offset from outside by edgedist
c add points on the 8 corners + the "insides" of the 12 lines + 6 faces + volume
c need to use "insides" in order to not screw up lagrit's connect algorithm
c (spacing between inside and surface determined by edgedist)

      if (cgeom.eq.'rtp') then ! ........................................

c n(j)=d(j)/spacing:
c   dr=rmax-rmin, rav=(rmax+rmin)/2,
c   dtheta=thetamax-thetamin, thetaav=(thetamax-thetamin)/2,
c       dcostheta=cos(thetamin)-cos(thetamax)
c   dphi=phimax-phimin
c   d(1)=dr, d(2)=rmin*dtheta, d(3)=rmax*dtheta
c   A(r,theta) = dtheta*(rmax^2-rmin^2)/2 = d(5)*d(1)
c   -> d(4) = rav*dtheta
c   d(5)=rmin*sin(thetamin)*dphi
c   d(6)=rmax*sin(thetamin)*dphi
c   d(7)=rmin*sin(thetamax)*dphi
c   d(8)=rmax*sin(thetamax)*dphi
c   A(r,phi) at thetamin = dphi*sin(thetamin)*(rmax^2-rmin^2)/2 = d(9)*d(1)
c   -> d(9)=dphi*sin(thetamin)*rav
c   A(r,phi) at thetamax = dphi*sin(thetamax)*(rmax^2-rmin^2)*/2 = d(10)*d(1)
c   -> d(10)=dphi*sin(thetamax)*rav
c   A(theta,phi) at rmin = dphi*rmin^2*dcostheta = d(2)*d(11)
c   -> d(11)=dphi*rmin*dcostheta/dtheta
c   A(theta,phi) at rmax = dphi*rmax^2*dcostheta = d(3)*d(12)
c   -> d(12)=dphi*rmax*dcostheta/dtheta
c   V(r,theta,phi) = dphi*dcostheta*(rmax^3-rmin^3)/3 = d(1)*d(4)*d(13)
c   -> d(13)=dphi*dcostheta*(rmax^2+rmax*rmin+rmin^2)/(3*dtheta)
c Note: 11,12,13 need theta range to be between 0-180 => constrained
c rescale and add xyz origin shift after assignment

         nadd(1)=(rext(2,1)-rext(1,1)-edgedist)/spacing
         r0(1)=rext(1,1)+edgedist
         r1(1)=rext(2,1)-rext(1,1)-two*edgedist
         theta=(rext(2,2)-rext(1,2))
         do i1=1,2
            i2=1+i1
            rrr=rext(i1,1)
            nadd(i2)=(rrr*theta-edgedist)/spacing
            if (rrr.le.zero) then
               if (edgedist.gt.zero) then
                  rrr=edgedist
               else
                  rrr=spacing
               endif
            endif
            if (rrr.gt.zero) then
               xxx=edgedist/rrr
               r0(i2)=rext(1,2)+xxx
               r1(i2)=rext(2,2)-rext(1,2)-two*xxx
            endif
         enddo
         rrr=half*(rext(1,1)+rext(2,1))
         nadd(4)=(rrr*theta-edgedist)/spacing
         phi=(rext(2,3)-rext(1,3))
         do i1=1,2
         do i2=1,2
            i3=4+i1+(i2-1)*2
            rrr=rext(i1,1)
            theta=rext(i2,2)
            rrr=rrr*sin(theta)
            nadd(i3)=(rrr*phi-edgedist)/spacing
            if (rrr.le.zero) then
               if (edgedist.gt.zero) then
                  rrr=edgedist
               else
                  rrr=spacing
               endif
            endif
            if (rrr.gt.zero) then
               xxx=edgedist/rrr
               r0(i3)=rext(1,3)+xxx
               r1(i3)=rext(2,3)-rext(1,3)-two*xxx
            endif
         enddo
         enddo
         rrr=half*(rext(1,1)+rext(2,1))
         xxx=sin(rext(1,2))
         nadd(9)=(rrr*xxx*phi-edgedist)/spacing
         xxx=sin(rext(2,2))
         nadd(10)=(rrr*xxx*phi-edgedist)/spacing
         theta=(rext(2,2)-rext(1,2))
         if (theta.gt.zero) then
            xxx=(cos(rext(1,2))-cos(rext(2,2)))/theta
            rrr=(rext(2,1)**2+rext(2,1)*rext(1,1)+rext(1,1)**2)*one3rd
            nadd(11)=(phi*xxx*rext(1,1)-edgedist)/spacing
            nadd(12)=(phi*xxx*rext(2,1)-edgedist)/spacing
            nadd(13)=(phi*xxx*rrr-edgedist)/spacing
         else
            nadd(11)=0
            nadd(12)=0
            nadd(13)=0
         endif
         do ind=1,13
            if (nadd(ind).lt.0) nadd(ind)=0
         enddo

         ! maxends(1)=-2 if rmin=0, rmax>0
         !            =-1 if rmin=rmax=0
         !            =1 if rmin=rmax>0
         !            =2 if rmin>0, rmax>rmin
         ! maxends(2)=1 if thetamin=thetamax
         !            =2 if thetamin<thetamax
         ! maxends(4)=2 if 0<thetamin
         !            =1 if 0=thetamin
         ! maxends(5)=2 if thetamax<pi
         !            =1 if thetamax=pi
         ! maxends(3)=1 if phimax-phimin=2*pi or phimax=phimin
         !            =2 if 0<phimax-phimin<2*pi

         ! only need to worry about r overwrites if rmin=0
         !    for the p-edges (see below)
         ! should modify nadds so, eg, use n_vol rather than n1*n2*n3

         ! corners ...........
         nnodes_new=maxends(3)*maxends(2)*abs(maxends(1))
         ! r edges ...........
         ! correct for double count of ends if maxends(3)=2
         ! but thetamin=0 (maxends(4)=1) or thetamax=pi (maxends(5)=1))
         ! => use maxends 3->4,5 for thetamin,max
         do i2=1,maxends(2)
         i4=3+i2
         do i3=1,min(maxends(i4),maxends(3))
            nnodes_new=nnodes_new+nadd(1)
         enddo
         enddo
         ! t edges ...........
         if (maxends(1).lt.0) then
            ! don't do r overwrites if rmin=0 -> only do rmax
            j=abs(maxends(1))
         else
            ! rmin>0 -> do both rmin and rmax
            j=1
         endif
         do i1=j,abs(maxends(1))
            i2=1+i1
            nnodes_new=nnodes_new+nadd(i2)*maxends(3)
         enddo
         ! p edges ...........
         do i1=1,abs(maxends(1))
         do i2=1,maxends(2)
            i3=4+i1+(i2-1)*2
            nnodes_new=nnodes_new+nadd(i3)
         enddo
         enddo
         ! rt faces ...........
         nnodes_new=nnodes_new+nadd(1)*nadd(4)*maxends(3)
         ! rp faces ...........
         do i2=1,maxends(2)
            i3=8+i2
            nnodes_new=nnodes_new+nadd(1)*nadd(i3)
         enddo
         ! tp faces ...........
         do i1=1,abs(maxends(1))
            i2=1+i1
            i3=10+i1
            nnodes_new=nnodes_new+nadd(i2)*nadd(i3)
         enddo
         ! rtp volume ..........
         nnodes_new=nnodes_new+nadd(1)*nadd(4)*nadd(13)

      else if (cgeom.eq.'rtz') then ! ...................................

c n(j)=d(j)/spacing:
c   dr=rmax-rmin, rav=(rmax+rmin)/2, dtheta=thetamax-thetamin, dz=zmax-zmin
c   d(1)=dr, d(2)=rmin*dtheta, d(4)=rmax*dtheta, d(3)=dz
c   A(r,theta)=dtheta*(rmax^2-rmin^2)/2=d(5)*d(1) -> d(5)=rav*dtheta
c rescale and add xyz origin shift after assignment

         do j=1,3,2
            nadd(j)=(rext(2,j)-rext(1,j)-edgedist)/spacing
            r0(j)=rext(1,j)+edgedist
            r1(j)=rext(2,j)-rext(1,j)-two*edgedist
         enddo

         theta=(rext(2,2)-rext(1,2))
         do i1=1,2
            i2=2*i1
            rrr=rext(i1,1)
            nadd(i2)=(rrr*theta-edgedist)/spacing
            if (rrr.le.zero) then
               if (edgedist.gt.zero) then
                  rrr=edgedist
               else
                  rrr=spacing
               endif
            endif
            if (rrr.gt.zero) then
               xxx=edgedist/rrr
               r0(i2)=rext(1,2)+xxx
               r1(i2)=rext(2,2)-rext(1,2)-two*xxx
            endif
         enddo
         rrr=half*(rext(1,1)+rext(2,1))
         nadd(5)=(rrr*theta-edgedist)/spacing

         do ind=1,5
            if (nadd(ind).lt.0) nadd(ind)=0
         enddo

         ! maxends(1)=-2 if rmin=0, rmax>0
         !            =-1 if rmin=rmax=0
         !            =1 if rmin=rmax>0
         !            =2 if rmin>0, rmax>rmin
         ! maxends(2)=1 if thetamax-thetamin=2*pi or thetamax=thetamin
         !            =2 if 0<thetamax-thetamin<2*pi
         ! maxends(3)=1 if zmin=zmax
         !            =2 if zmin<zmax

         ! z-edges r overwrite if rmin=0 fixed (see below)
         ! should modify nadds so, eg, use n_vol rather than n1*n2*n3

         ! corners ...........
         nnodes_new=maxends(3)*maxends(2)*abs(maxends(1))
         ! r edges ...........
         nnodes_new=nnodes_new+nadd(1)*maxends(2)*maxends(3)
         ! z edges ...........
         if (maxends(1).lt.0) then
            ! don't do r overwrites if rmin=0 -> only do 1 theta at rmin=0
            do i1=1,abs(maxends(1))
            do i2=1,min(i1,maxends(2))
               nnodes_new=nnodes_new+nadd(3)
            enddo
            enddo
         else
            ! do both theta's at rmin>0
            nnodes_new=nnodes_new+nadd(3)*abs(maxends(1))*maxends(2)
         endif
         ! t edges ...........
         do i1=1,abs(maxends(1))
            i2=2*i1
            nnodes_new=nnodes_new+nadd(i2)*maxends(3)
         enddo
         ! rz faces ...........
         nnodes_new=nnodes_new+nadd(1)*nadd(3)*maxends(2)
         ! tz faces ...........
         do i1=1,abs(maxends(1))
            i2=2*i1
            nnodes_new=nnodes_new+nadd(i2)*nadd(3)
         enddo
         ! rt faces ...........
         nnodes_new=nnodes_new+nadd(1)*nadd(5)*maxends(3)
         ! rtz volume ..........
         nnodes_new=nnodes_new+nadd(1)*nadd(5)*nadd(3)

      else ! if (geom.eq.'xyz') then ! .................................

c n(j)=d(j)/spacing:
c   dr(j)=rmax(j)-rmin(j)

         do j=1,3
            nadd(j)=(rext(2,j)-rext(1,j)-edgedist)/spacing
            r0(j)=rext(1,j)+edgedist
            r1(j)=rext(2,j)-rext(1,j)-two*edgedist
         enddo

         ! modify so, eg, use n_vol rather than n1*n2*n3:
         !   nadd(4) vs nadd(2)*nadd(3)
         !   nadd(5) vs nadd(1)*nadd(3)
         !   nadd(6) vs nadd(1)*nadd(2)
         !   nadd(7) vs nadd(1)*nadd(2)*nadd(3)
         xxx=spacing*spacing
         if (nadd(2).le.0.or.nadd(3).le.0) then
            nadd(4)=0
         else
            nadd(4)=(rext(2,2)-rext(1,2)-edgedist)
     &             *(rext(2,3)-rext(1,3)-edgedist)/xxx
         endif
         if (nadd(1).le.0.or.nadd(3).le.0) then
            nadd(5)=0
         else
            nadd(5)=(rext(2,1)-rext(1,1)-edgedist)
     &             *(rext(2,3)-rext(1,3)-edgedist)/xxx
         endif
         if (nadd(1).le.0.or.nadd(2).le.0) then
            nadd(6)=0
         else
            nadd(6)=(rext(2,2)-rext(1,2)-edgedist)
     &             *(rext(2,1)-rext(1,1)-edgedist)/xxx
         endif
         xxx=xxx*spacing
         if (nadd(1).le.0.or.nadd(2).le.0.or.nadd(3).le.0) then
            nadd(7)=0
         else
            nadd(7)=(rext(2,1)-rext(1,1)-edgedist)
     &             *(rext(2,2)-rext(1,2)-edgedist)
     &             *(rext(2,3)-rext(1,3)-edgedist)/xxx
         endif

         ! zero any negative n's
         do ind=1,7
            if (nadd(ind).lt.0) nadd(ind)=0
         enddo

         ! maxends(j)=1 if rmin=rmax
         !            =2 if rmin<rmax

         ! corners ...........
         nnodes_new=maxends(3)*maxends(2)*maxends(1)
         ! xyz edges ...........
         nnodes_new=nnodes_new+nadd(1)*maxends(2)*maxends(3)
         nnodes_new=nnodes_new+nadd(2)*maxends(1)*maxends(3)
         nnodes_new=nnodes_new+nadd(3)*maxends(1)*maxends(2)
         ! xyz faces ...........
         nnodes_new=nnodes_new+nadd(4)*maxends(1)
         nnodes_new=nnodes_new+nadd(5)*maxends(2)
         nnodes_new=nnodes_new+nadd(6)*maxends(3)
         ! xyz volume ..........
         nnodes_new=nnodes_new+nadd(7)

      endif !...........................................................

C ******************************************************************
C increment storage

      icntin=icount
      nnodes_save=ipointj
      nnodes=nnodes+nnodes_new
      call cmo_set_info('nnodes',cmo,nnodes,1,1,ierr)
      if (ierr.ne.0) then
        ierr=1
        goto 9998
      endif
      call cmo_newlen(cmo,ierr)
      if (ierr.ne.0) then
        ierr=2
        goto 9998
      endif
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=3
        goto 9998
      endif
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=4
        goto 9998
      endif
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr)
      if (ierr.ne.0) then
        ierr=5
        goto 9998
      endif

C ******************************************************************
C TRANSFORM POINTS AND VELOCITIES TO LOCAL COORD. SYSTEM
C (copied from RZ)

      if (normflgc .gt. 0) call chglocl(1,icount,1)

C ******************************************************************
C assign the new node positions
c inside is offset from outside by edgedist
c add points on the 8 corners + the "insides" of the 12 lines + 6 faces + volume
c need to use "insides" in order to not screw up lagrit's connect algorithm
c (see notes in counting section above)
c Note that for x=(y*((1+r)^p-r^p)+r^p)^(1/p)-r
c with r=r0/r1 and y uniformly distributed between 0 and 1,
c then x is between 0 and 1 and (r0+x*r1)^p is
c uniformly distributed between r0^p and (r0+r1)^p
c Note that for x=(1/th1)*cos^(-1)(cos(th0)+y*(cos(th0+th1)-cos(th0)))-th0/th1
c with y uniformly distributed between 0 and 1,
c then x is between 0 and 1 and cos(th0+x*th1) is
c uniformly distributed between cos(th0) and cos(th0+th1)

      call mmverify()

c     ! corners, all geomtries  .........
      do i1=1,abs(maxends(1))
      do i2=1,maxends(2)
      do i3=1,maxends(3)
         icount=icount+1
         xic(icount)=rext(i1,1)
         yic(icount)=rext(i2,2)
         zic(icount)=rext(i3,3)
      enddo
      enddo
      enddo

      if (cgeom.eq.'rtp') then ! ........................................
c (see notes in counting section above)

         ! maxends(1)=-2 if rmin=0, rmax>0
         !            =-1 if rmin=rmax=0
         !            =1 if rmin=rmax>0
         !            =2 if rmin>0, rmax>rmin
         ! maxends(2)=1 if thetamin=thetamax
         !            =2 if thetamin<thetamax
         ! maxends(4)=2 if 0<thetamin
         !            =1 if 0=thetamin
         ! maxends(5)=2 if thetamax<pi
         !            =1 if thetamax=pi
         ! maxends(3)=1 if phimax-phimin=2*pi or phimax=phimin
         !            =2 if 0<phimax-phimin<2*pi

         phi=rext(2,3)-rext(1,3)
         if (maxends(3).ne.1) phi=zero

c        ! r edges ...........
         ! use phi maxends 3->4,5 for thetamin,max
         do i1=1,nadd(1)
         do i2=1,maxends(2)
         i4=3+i2
         do i3=1,min(maxends(i4),maxends(3))
            icount=icount+1
            rrr=r0(1)+r1(1)*rand_lg()
            xic(icount)=rrr
            if (phi.gt.pi.and.maxends(i4).eq.1.and.rrr.gt.zero) then
               xxx=edgedist/rrr
               yic(icount)=rext(i2,2)-xxx+rand_lg()*two*xxx
               zic(icount)=rext(i3,3)
            else
               xxx=rext(i2,2)
               yic(icount)=xxx
               rrr=rrr*sin(xxx)
               if (phi.gt.pi.and.rrr.gt.0) then
                  xxx=edgedist/rrr
                  zic(icount)=rext(i3,3)-xxx+rand_lg()*two*xxx
               else
                  zic(icount)=rext(i3,3)
               endif
            endif
         enddo
         enddo
         enddo
c        ! t edges ...........
         if (maxends(1).lt.0) then
            j=abs(maxends(1))
         else
            j=1
         endif
         do i1=j,abs(maxends(1))
         i2=1+i1
         do i4=1,nadd(i2)
         do i3=1,maxends(3)
            icount=icount+1
            rrr=rext(i1,1)
            xic(icount)=rrr
            xxx=r0(i2)+r1(i2)*rand_lg()
            yic(icount)=xxx
            rrr=rrr*sin(xxx)
            if (phi.gt.pi.and.rrr.gt.0) then
               xxx=edgedist/rrr
               zic(icount)=rext(i3,3)-xxx+rand_lg()*two*xxx
            else
               zic(icount)=rext(i3,3)
            endif
         enddo
         enddo
         enddo
c        ! p edges ...........
         do i1=1,abs(maxends(1))
         do i2=1,maxends(2)
         i3=4+i1+(i2-1)*2
         do i4=1,nadd(i3)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=rext(i2,2)
            zic(icount)=r0(i3)+r1(i3)*rand_lg()
         enddo
         enddo
         enddo

c        ! rt faces ...........
         theta=rext(2,2)-rext(1,2)
         do i4=1,nadd(1)*nadd(4)
         do i3=1,maxends(3)
            icount=icount+1
            rrr=r0(1)/r1(1)
            rrr=sqrt(rrr*rrr+rand_lg()*(one+two*rrr))-rrr
            rrr=r0(1)+r1(1)*rrr
            xic(icount)=rrr
            if (rrr*theta.gt.two*edgedist) then
               xxx=edgedist/rrr
               xxx=rext(1,2)+xxx+rand_lg()*(theta-two*xxx)
            else
               xxx=half*(rext(2,2)+rext(1,2))
            endif
            yic(icount)=xxx
            rrr=rrr*sin(xxx)
            if (phi.gt.pi.and.rrr.gt.0) then
               xxx=edgedist/rrr
               zic(icount)=rext(i3,3)-xxx+rand_lg()*two*xxx
            else
               zic(icount)=rext(i3,3)
            endif
         enddo
         enddo
c        ! rp faces ...........
         do i2=1,maxends(2)
         i3=8+i2
         do i4=1,nadd(1)*nadd(i3)
            icount=icount+1
            rrr=r0(1)/r1(1)
            rrr=sqrt(rrr*rrr+rand_lg()*(one+two*rrr))-rrr
            rrr=r0(1)+r1(1)*rrr
            xic(icount)=rrr
            theta=rext(i2,2)
            yic(icount)=theta
            rrr=rrr*sin(theta)
            phi=rext(2,3)-rext(1,3)
            if (rrr*phi.gt.two*edgedist) then
               xxx=edgedist/rrr
               zic(icount)=rext(1,3)+xxx+rand_lg()*(phi-two*xxx)
            else
               zic(icount)=half*(rext(2,3)+rext(1,3))
            endif
         enddo
         enddo
c        ! tp faces ...........
         do i1=1,abs(maxends(1))
         i2=1+i1
         i3=10+i1
         do i4=1,nadd(i2)*nadd(i3)
            icount=icount+1
            rrr=rext(i1,1)
            xic(icount)=rrr
            theta=r0(i2)
            phi=r1(i2)
            xxx=cos(theta)
            xxx=acos(  (cos(theta+phi)-xxx)*rand_lg() + xxx )
     &                           /phi - theta/phi
            theta=r0(i2)+xxx*r1(i2)
            yic(icount)=theta
            rrr=rrr*sin(theta)
            phi=rext(2,3)-rext(1,3)
            if (rrr*phi.gt.two*edgedist) then
               xxx=edgedist/rrr
               zic(icount)=rext(1,3)+xxx+rand_lg()*(phi-two*xxx)
            else
               zic(icount)=half*(rext(2,3)+rext(1,3))
            endif
         enddo
         enddo

c        ! rtp volume ..........
         do i4=1,nadd(1)*nadd(4)*nadd(13)
            icount=icount+1

            rrr=r0(1)/r1(1)
            rrr=( (one+3.d0*rrr+3.d0*rrr*rrr)*rand_lg()
     &              +rrr*rrr*rrr )**one3rd - rrr
            rrr=r0(1)+r1(1)*rrr
            xic(icount)=rrr

            theta=rext(2,2)-rext(1,2)
            if (rrr*theta.gt.two*edgedist) then
               xxx=edgedist/rrr
               phi=theta-two*xxx
               theta=rext(1,2)+xxx
               xxx=cos(theta)
               xxx=acos( (cos(theta+phi)-xxx)*rand_lg() + xxx )
     &                         /phi - theta/phi
               theta=theta+xxx*phi
            else
               theta=half*(rext(2,2)+rext(1,2))
            endif
            yic(icount)=theta

            rrr=rrr*sin(theta)
            phi=rext(2,3)-rext(1,3)
            if (rrr*phi.gt.two*edgedist) then
               xxx=edgedist/rrr
               zic(icount)=rext(1,3)+xxx+rand_lg()*(phi-two*xxx)
            else
               zic(icount)=half*(rext(2,3)+rext(1,3))
            endif

         enddo

         if (icount.ne.icntin+nnodes_new) goto 9998

c        ! convert spherical to xyz
         do ind=icntin+1,icntin+nnodes_new
            rrr=xic(ind)
            theta=yic(ind)
            phi=zic(ind)
            xic(ind)=rrr*sin(theta)*cos(phi)
            yic(ind)=rrr*sin(theta)*sin(phi)
            zic(ind)=rrr*cos(theta)
         enddo

      else if (cgeom.eq.'rtz') then ! ...................................
c (see notes in counting section above)

         ! maxends(1)=-2 if rmin=0, rmax>0
         !            =-1 if rmin=rmax=0
         !            =1 if rmin=rmax>0
         !            =2 if rmin>0, rmax>rmin
         ! maxends(2)=1 if thetamax-thetamin=2*pi or thetamax=thetamin
         !            =2 if 0<thetamax-thetamin<2*pi
         ! maxends(3)=1 if zmin=zmax
         !            =2 if zmin<zmax

c theta range = 360: should not even print theta faces or
c edges and should extend r faces,edges over whole
c side (so only 4 edges, 4 faces)

c        ! r edges ...........
         theta=rext(2,2)-rext(1,2)
         if (maxends(2).ne.1) theta=zero
         do i1=1,nadd(1)
         do i2=1,maxends(2)
         do i3=1,maxends(3)
            icount=icount+1
            rrr=r0(1)+r1(1)*rand_lg()
            xic(icount)=rrr
            if (theta.gt.pi.and.rrr.gt.zero) then
               phi=edgedist/rrr
               yic(icount)=rext(i2,2)-phi+rand_lg()*two*phi
            else
               yic(icount)=rext(i2,2)
            endif
            zic(icount)=rext(i3,3)
         enddo
         enddo
         enddo
c        ! z edges ...........
         do i3=1,nadd(3)
         do i1=1,abs(maxends(1))
            if (maxends(1).lt.0) then
               i4=min(i1,maxends(2))
            else
               i4=maxends(2)
            endif
            do i2=1,i4
               icount=icount+1
               rrr=rext(i1,1)
               xic(icount)=rrr
               if (theta.gt.pi.and.rrr.gt.zero) then
                  phi=edgedist/rrr
                  yic(icount)=rext(i2,2)-phi+rand_lg()*two*phi
               else
                  yic(icount)=rext(i2,2)
               endif
               zic(icount)=r0(3)+r1(3)*rand_lg()
            enddo
         enddo
         enddo
c        ! t edges ...........
         do i1=1,abs(maxends(1))
         i2=2*i1
         do i4=1,nadd(i2)
         do i3=1,maxends(3)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=r0(i2)+r1(i2)*rand_lg()
            zic(icount)=rext(i3,3)
         enddo
         enddo
         enddo

c        ! rz faces ...........
         do i4=1,nadd(1)*nadd(3)
         do i2=1,maxends(2)
            icount=icount+1
            rrr=r0(1)+r1(1)*rand_lg()
            xic(icount)=rrr
            if (theta.gt.pi.and.rrr.gt.zero) then
               phi=edgedist/rrr
               yic(icount)=rext(i2,2)-phi+rand_lg()*two*phi
            else
               yic(icount)=rext(i2,2)
            endif
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo
         enddo

c        ! tz faces ...........
         do i1=1,abs(maxends(1))
         i2=2*i1
         do i4=1,nadd(i2)*nadd(3)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=r0(i2)+r1(i2)*rand_lg()
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo
         enddo

c        ! rt faces ...........
         do i4=1,nadd(1)*nadd(5)
         do i3=1,maxends(3)
            icount=icount+1
            rrr=r0(1)/r1(1)
            rrr=sqrt(rrr*rrr+rand_lg()*(one+two*rrr))-rrr
            rrr=r0(1)+r1(1)*rrr
            xic(icount)=rrr
            theta=rext(2,2)-rext(1,2)
            if (rrr*theta.gt.two*edgedist) then
               phi=edgedist/rrr
               yic(icount)=rext(1,2)+phi+rand_lg()*(theta-two*phi)
            else
               yic(icount)=half*(rext(2,2)+rext(1,2))
            endif
            zic(icount)=rext(i3,3)
         enddo
         enddo

c        ! rtz volume ..........
         do i4=1,nadd(1)*nadd(5)*nadd(3)
            icount=icount+1
            rrr=r0(1)/r1(1)
            rrr=sqrt(rrr*rrr+rand_lg()*(one+two*rrr))-rrr
            rrr=r0(1)+r1(1)*rrr
            xic(icount)=rrr
            theta=rext(2,2)-rext(1,2)
            if (rrr*theta.gt.two*edgedist) then
               phi=edgedist/rrr
               yic(icount)=rext(1,2)+phi+rand_lg()*(theta-two*phi)
            else
               yic(icount)=half*(rext(2,2)+rext(1,2))
            endif
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo

         if (icount.ne.icntin+nnodes_new) goto 9998

c        ! convert cylindrical to xyz
         do ind=icntin+1,icntin+nnodes_new
            rrr=xic(ind)
            theta=yic(ind)
            xic(ind)=rrr*cos(theta)
            yic(ind)=rrr*sin(theta)
            ! zic(ind)=zic(ind)
         enddo

      else ! if (geom.eq.'xyz') then ! .................................
c (see notes in counting section above)

         ! maxends(j)=1 if rmin=rmax
         !            =2 if rmin<rmax

c        ! xyz edges ...........
         do i1=1,nadd(1)
         do i2=1,maxends(2)
         do i3=1,maxends(3)
            icount=icount+1
            xic(icount)=r0(1)+r1(1)*rand_lg()
            yic(icount)=rext(i2,2)
            zic(icount)=rext(i3,3)
         enddo
         enddo
         enddo
         do i2=1,nadd(2)
         do i1=1,maxends(1)
         do i3=1,maxends(3)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=r0(2)+r1(2)*rand_lg()
            zic(icount)=rext(i3,3)
         enddo
         enddo
         enddo
         do i3=1,nadd(3)
         do i1=1,maxends(1)
         do i2=1,maxends(2)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=rext(i2,2)
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo
         enddo
         enddo

c        ! xyz faces ...........
         do i4=1,nadd(4)
         do i1=1,maxends(1)
            icount=icount+1
            xic(icount)=rext(i1,1)
            yic(icount)=r0(2)+r1(2)*rand_lg()
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo
         enddo
         do i4=1,nadd(5)
         do i2=1,maxends(2)
            icount=icount+1
            xic(icount)=r0(1)+r1(1)*rand_lg()
            yic(icount)=rext(i2,2)
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo
         enddo
         do i4=1,nadd(6)
         do i3=1,maxends(3)
            icount=icount+1
            xic(icount)=r0(1)+r1(1)*rand_lg()
            yic(icount)=r0(2)+r1(2)*rand_lg()
            zic(icount)=rext(i3,3)
         enddo
         enddo

c        ! xyz volume ..........
         do i4=1,nadd(7)
            icount=icount+1
            xic(icount)=r0(1)+r1(1)*rand_lg()
            yic(icount)=r0(2)+r1(2)*rand_lg()
            zic(icount)=r0(3)+r1(3)*rand_lg()
         enddo

         if (icount.ne.icntin+nnodes_new) goto 9998

      endif !...........................................................

      call mmverify()

c     ! add xyz shift
      do ind=icntin+1,icntin+nnodes_new
         xic(ind)=roff(1)+xic(ind)
         yic(ind)=roff(2)+yic(ind)
         zic(ind)=roff(3)+zic(ind)
      enddo

C ******************************************************************
C TRANSFORM POINTS AND VELOCITIES TO NORMAL COORD. SYSTEM
C (copied from RZ)

      if (normflgc .gt. 0) call chgnorm(1,icount,1)

C ******************************************************************
C PRINT OUT THE POINT NUMBERS GENERATED
C also come here if error after start (error resets to no nodes added)

 9998 write(logmess,6000) icntin+1,icount
 6000 format('  RANPTS GENERATED POINTS ',i11,' TO ',i11)
      call writloga('default',0,logmess,0,icscode)

C ******************************************************************
C SET UP THE USUAL CFT IMMUNE STATEMENT IN CASE DDT IS NEEDED.
C (copied from RZ)

      ipointi=nnodes_save+1
      ipointj=icount

      nnodes=ipointj
      call cmo_set_info('nnodes',cmo,nnodes,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10

      call cmo_set_info('ipointi',cmo
     &                ,ipointi,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10
      call cmo_set_info('ipointj',cmo
     &                ,ipointj,1,1,icscode)
      if (icscode.ne.0) ierr=ierr+10

C ******************************************************************
C NORMAL RETURN
c (and error return if error after start adding)

      if (icntin+1.gt.icount.and.ierr.eq.0) ierr=-1

      return

C ******************************************************************
C ERROR RETURN (at least for errors before anything done)

 9999 continue
      write(logmess,*) '  RANPTS ERROR - no points added'
      call writloga('default',0,logmess,0,icscode)

      return

C#######################################################################
      end

C#######################################################################


module local_routines
    !!
    !! Setup NTHMP benchmark problem 4.
    !!
    use global_mod, only: dp, ip, charlen, wall_elevation, g => gravity
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use read_raster_mod, only: read_gdal_raster
    use which_mod, only: which
    use file_io_mod, only: count_file_lines
    use linear_interpolator_mod, only: linear_interpolator_type
    implicit none

    contains

    subroutine set_initial_conditions_BP1(domain, d, beach_slope, land_length, sea_length, X0, X1, H, gamma0)
        class(domain_type), target, intent(inout):: domain
        real(dp), intent(in) :: d, beach_slope, land_length, sea_length, X0, X1, H, gamma0

        integer(ip) :: i,j, ngauge
        real(dp):: x,y, elev, stage, vel
        real(dp), allocatable:: gauge_xy(:,:)

        do j = 1, domain%nx(2)
            do i = 1, domain%nx(1)
                x = domain%x(i)
                y = domain%y(j)
                elev = max(-x * beach_slope, -d)
                stage = H * (1.0_dp/cosh(gamma0*(x - X1)/d))**2
                vel = - sqrt(g/d) * stage
                domain%U(i,j,ELV) = elev
                domain%U(i,j,STG) = stage
                domain%U(i,j,UH) = vel*d
                domain%U(i,j,VH) = 0.0_dp
            end do
        end do
        !print*, 'Stage initial range: ', maxval(domain%U(:,:,1)), minval(domain%U(:,:,1))

        ! Add reflective walls, with zero velocity, and stage>=elev
        domain%U(:,1,ELV) = wall_elevation
        domain%U(:,domain%nx(2),ELV) = wall_elevation
        domain%U(domain%nx(1),:,ELV) = wall_elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV)+1.0e-07_dp)
        domain%U(:,1,UH) = 0.0_dp
        domain%U(domain%nx(1),:,UH) = 0.0_dp
        domain%U(:,domain%nx(2),UH) = 0.0_dp

        if(allocated(domain%manning_squared)) then
            ! The runup in this problem can be sensitive to friction
            ! This value is 'tuned' to work ok on both problems, but we could
            ! change runup for the large-amplitude case quite a bit by adjusting this.
            domain%manning_squared = 0.005_dp*0.005_dp
        end if

        ! Get gauge points -- every d/10
        ngauge = nint((maxval(domain%x) - minval(domain%x))/d * 10 )
        allocate(gauge_xy(2, ngauge))
        do i = 1, ngauge
            gauge_xy(1,i) = minval(domain%x) + d/20.0_dp + (i-1)*d/10.0_dp
            gauge_xy(2,i) = 0.0_dp
        end do

        call domain%setup_point_gauges(gauge_xy)

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program BP04
    !!
    !! NTHMP benchmark problem 4 -- solitary wave on a simple beach. This has
    !! various experimental results, leading to a dimensionless relation between
    !! the onshore runup and offshore wave height.
    !!

    use global_mod, only: ip, dp, minimum_allowed_depth, pi
    use domain_mod, only: domain_type
    use linear_interpolator_mod, only: linear_interpolator_type
    use local_routines
    implicit none

    integer(ip):: j
    real(dp):: last_write_time, rain_rate
    type(domain_type):: domain

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 0.025_dp
    real(dp), parameter :: final_time = 50.0_dp

    ! Domain info
    character(charlen) :: timestepping_method, tempchar != 'linear' !'rk2' !'linear'

    ! length/width
    real(dp), dimension(2) :: global_lw, global_ll
    integer(ip), dimension(2) :: global_nx

    ! Local variables
    real(dp) :: timestep, L, dx, tank_width, tank_length, initial_depth, &
        beach_slope, beta, X0, X1, gamma0, H, land_length, sea_length, h_on_d

    call get_command_argument(1, timestepping_method)
    call get_command_argument(2, tempchar)
    read(tempchar, *) initial_depth
    call get_command_argument(3, tempchar)
    read(tempchar, *) h_on_d

    ! Geometric parameters as specified in the description
    beta = atan(1.0_dp/19.85_dp)
    beach_slope = tan(beta)
    X0 = initial_depth / beach_slope
    H = h_on_d * initial_depth
    gamma0 = sqrt(3.0_dp * H / (4.0_dp * initial_depth))
    L = initial_depth * acosh(sqrt(20.0_dp))/gamma0
    X1 = X0 + L

    ! Tank geometry
    tank_width = 0.14_dp
    land_length = 3.0_dp * X0 ! Set this so that inundation can occur
    sea_length = X0 + L + 10.0_dp * L ! Set this so the sea boundary is far enough away.
    tank_length = sea_length + land_length

    ! Resolution
    dx = 0.02_dp !(0.5_dp/12.0_dp)

    ! Model parameters. Note we apply the boundary on the right. x = 0 is the shoreline
    global_lw = [tank_length, tank_width]
    global_ll = [-land_length, -tank_width/2.0_dp]
    global_nx = nint(global_lw/dx)

    domain%timestepping_method = timestepping_method

    ! Allocate domain -- must have set timestepping method BEFORE this
    call domain%allocate_quantities(global_lw, global_nx, global_ll, verbose=.false.)

    call domain%log_outputs()

    write(domain%logfile_unit, *) 'timestepping method: ', TRIM(timestepping_method)
    write(domain%logfile_unit, *) 'initial depth: ', initial_depth
    write(domain%logfile_unit, *) 'h_on_d: ', h_on_d
    write(domain%logfile_unit, *) 'd: ', initial_depth, ' H: ', H, ' beach slope: ', beach_slope, &
        ' X0 :', X0, ' X1: ', X1, ' L: ', L, ' gamma: ', gamma0
    write(domain%logfile_unit, *) 'll: ', global_ll

    ! Call local routine to set initial conditions
    call set_initial_conditions_BP1(domain, initial_depth, beach_slope, &
        land_length, sea_length, X0, X1, H, gamma0)

    ! Linear requires a fixed timestep
    if (.not. domain%adaptive_timestepping) then
        timestep = domain%stationary_timestep_max() * 0.5_dp
    end if

    ! Trick to get the code to write out just after the first timestep
    last_write_time = domain%time - approximate_writeout_frequency

    ! Evolve the code
    do while (.true.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            last_write_time = last_write_time + approximate_writeout_frequency

            call domain%print()
            call domain%write_to_output_files(time_only=.true.)
            call domain%write_gauge_time_series()

        end if

        if (domain%time > final_time) exit

        ! Variable timestep
        if(.not. domain%adaptive_timestepping) then
            call domain%evolve_one_step(timestep = timestep)
        else
            call domain%evolve_one_step()
        end if

    end do

    call domain%write_max_quantities()

    ! Print timing info
    call domain%timer%print(domain%logfile_unit)

    call domain%finalise()

end program


! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2022, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! This example solves a 2D elliptic PDE
!
!    d^2 u / dx^2 + d^2 u / dy^2 = u^3 - u - 2.0
!
! subject to homogeneous Dirichlet boundary conditions.
! The PDE is discretized on a uniform NX+2 by NY+2 grid with
! central differencing, and with boundary values eliminated,
! leaving a system of size NEQ = NX*NY.
! The nonlinear system is solved by KINSOL using the SUNBAND linear
! solver.
! ------------------------------------------------------------------

module prob_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none

  integer(c_long), parameter :: nx = 31
  integer(c_long), parameter :: ny = 31
  integer(c_long), parameter :: neq = nx*ny
  integer(c_long), parameter :: skip = 3
  real(c_double),  parameter :: ftol = 1.d-12

contains

  ! ----------------------------------------------------------------
  ! func: The nonlinear residual function
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function func(sunvec_u, sunvec_f, user_data) &
       result(ierr) bind(C)

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    type(N_Vector)       :: sunvec_u  ! solution N_Vector
    type(N_Vector)       :: sunvec_f  ! rhs N_Vector
    type(c_ptr),   value :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: u(:,:), f(:,:)

    ! internal variables
    integer(c_long) :: i, j
    real(c_double)  :: dx, dy, hdiff, vdiff, hdc, vdc, uij, udn, uup, ult, urt

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors, casting as 2D Fortran arrays
    u(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_u)
    f(1:nx, 1:ny) => FN_VGetArrayPointer(sunvec_f)

    ! set shortcut constants
    dx = 1.d0/(nx+1)
    dy = 1.d0/(ny+1)
    hdc = 1.d0/(dx*dx)
    vdc = 1.d0/(dy*dy)

    ! loop over domain, computing residual
    do j = 1,ny
       do i = 1,nx

          ! Extract u at x_i, y_j and four neighboring points
          uij = u(i,j)
          udn = 0.d0
          if (j > 1)  udn = u(i,j-1)
          uup = 0.d0
          if (j < ny) uup = u(i,j+1)
          ult = 0.d0
          if (i > 1)  ult = u(i-1,j)
          urt = 0.d0
          if (i < nx) urt = u(i+1,j)

          ! Evaluate diffusion components
          hdiff = hdc*(ult - 2.d0*uij + urt)
          vdiff = vdc*(uup - 2.d0*uij + udn)

          ! Set residual at x_i, y_j
          f(i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.d0
       end do
    end do

    ! return success
    ierr = 0
    return

  end function func

end module prob_mod

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fsundials_context_mod
  use fkinsol_mod                ! Fortran interface to KINSOL
  use fnvector_serial_mod        ! Fortran interface to serial N_Vector
  use fsunmatrix_band_mod        ! Fortran interface to band SUNMatrix
  use fsunlinsol_band_mod        ! Fortran interface to band SUNLinearSolver
  use fsundials_matrix_mod       ! Fortran interface to generic SUNMatrix
  use fsundials_nvector_mod      ! Fortran interface to generic N_Vector
  use fsundials_linearsolver_mod ! Fortran interface to generic SUNLinearSolver
  use prob_mod                   ! problem-defining functions

  !======= Declarations =========
  implicit none

  ! local variables
  real(c_double)  :: fnormtol, fnorm(1)
  integer(c_int)  :: ierr
  integer(c_long) :: mset, msubset

  type(c_ptr)                    :: sunctx        ! sundials context
  type(N_Vector),        pointer :: sunvec_u      ! sundials vectors
  type(N_Vector),        pointer :: sunvec_s
  type(SUNMatrix),       pointer :: sunmat_J      ! sundials matrix
  type(SUNLinearSolver), pointer :: sunlinsol_LS  ! sundials linear solver

  type(c_ptr) :: kmem ! KINSOL memory

  ! solution and scaling vectors; nx, ny are set in the prob_mod module
  real(c_double), dimension(nx,ny) :: u, scale

  !======= Internals ============

  ! -------------------------
  ! Print problem description

  print *, " "
  print *, "2D elliptic PDE on unit square"
  print *, "   d^2 u / dx^2 + d^2 u / dy^2 = u^3 - u + 2.0"
  print *, " + homogeneous Dirichlet boundary conditions"
  print *, " "
  print *, "Solution method: Modified Newton with band linear solver"
  print '(2(a,i2),a,i3)', "Problem size: ", nx, " x ", ny, " = ", neq

  ! -------------------------
  ierr = FSUNContext_Create(c_null_ptr, sunctx)
  if (ierr /= 0) then
    print *, 'ERROR in FSUNContext_Create'
    stop 1
  end if

  ! -------------------------
  ! Set initial guess, and disable scaling

  u = 0.d0
  scale = 1.d0

  ! -------------------------
  ! Create vectors for solution and scales

  sunvec_u => FN_VMake_Serial(neq, u, sunctx)
  if (.not. associated(sunvec_u)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  sunvec_s => FN_VMake_Serial(neq, scale, sunctx)
  if (.not. associated(sunvec_s)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  ! -------------------------
  ! Initialize and allocate memory for KINSOL

  kmem = FKINCreate(sunctx)
  if (.not. c_associated(kmem)) then
     print *, 'ERROR: kmem = NULL'
     stop 1
  end if

  ! sunvec_u is used as a template

  ierr = FKINInit(kmem, c_funloc(func), sunvec_u)
  if (ierr /= 0) then
     print *, 'Error in FKINInit, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! -------------------------
  ! Set optional inputs

  fnormtol = ftol
  ierr = FKINSetFuncNormTol(kmem, fnormtol)
  if (ierr /= 0) then
     print *, 'Error in FKINSetFuncNormTol, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! -------------------------
  ! Create a band matrix

  sunmat_J => FSUNBandMatrix(neq, nx, nx, sunctx)
  if (.not. associated(sunmat_J)) then
     print *,'ERROR: sunmat = NULL'
     stop 1
  end if

  ! -------------------------
  ! Create a band linear solver

  sunlinsol_LS => FSUNLinSol_Band(sunvec_u, sunmat_J, sunctx)
  if (.not. associated(sunlinsol_LS)) then
     print *,'ERROR: sunlinsol = NULL'
     stop 1
  end if

  ! -------------------------
  ! Attach band linear solver

  ierr = FKINSetLinearSolver(kmem, sunlinsol_LS, sunmat_J)
  if (ierr /= 0) then
     print *, 'Error in FKINSetLinearSolver, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! -------------------------
  ! Parameters for Modified Newton

  ! Force a Jacobian re-evaluation every mset iterations
  mset = 100
  ierr = FKINSetMaxSetupCalls(kmem, mset)
  if (ierr /= 0) then
     print *, 'Error in FKINSetMaxSetupCalls, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! Every msubset iterations, test if a Jacobian evaluation is necessary
  msubset = 1
  ierr = FKINSetMaxSubSetupCalls(kmem, msubset)
  if (ierr /= 0) then
     print *, 'Error in FKINSetMaxSubSetupCalls, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! -------------------------
  ! Call KINSol to solve problem
  !
  ! arguments: KINSol memory block
  !            Initial guess on input, solution on output
  !            Globalization strategy choice
  !            Scaling vector for the solution
  !            Scaling vector for the residual

  ierr = FKINSol(kmem, sunvec_u, KIN_LINESEARCH, sunvec_s, sunvec_s)
  if (ierr /= 0) then
     print *, 'Error in FKINSol, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! -------------------------
  ! Print solution and solver statistics

  ! Get scaled norm of the system function
  ierr = FKINGetFuncNorm(kmem, fnorm)
  if (ierr /= 0) then
     print *, 'Error in FKINGetFuncNorm, ierr = ', ierr, '; halting'
     stop 1
  end if
  print *, " "
  print *, "Computed solution (||F|| = ", fnorm,"):"
  print *, " "
  call PrintOutput(u)
  call PrintFinalStats(kmem)

  ! clean up
  call FKINFree(kmem)
  ierr = FSUNLinSolFree(sunlinsol_LS)
  call FSUNMatDestroy(sunmat_J)
  call FN_VDestroy(sunvec_u)
  call FN_VDestroy(sunvec_s)
  ierr = FSUNContext_Free(sunctx)

end program main

! ----------------------------------------------------------------
! PrintOutput: prints solution at selected points
! ----------------------------------------------------------------
subroutine PrintOutput(u)

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding
  use prob_mod

  !======= Declarations =========
  implicit none

  ! calling variable
  real(c_double), dimension(nx,ny) :: u

  ! internal variables
  integer(c_long) :: i, j
  real(c_double)  :: dx, dy, x, y

  !======= Internals ============

  ! set shortcuts
  dx = 1.d0/(nx+1)
  dy = 1.d0/(ny+1)

  write(*,'(13x)',advance='no')
  do i = 1,nx,skip
     x = i*dx
     write(*,'(f8.5,1x)',advance='no') x
  end do
  print *, " "
  print *, " "

  do j = 1,ny,skip
     y = j*dy
     write(*,'(f8.5,5x)',advance='no') y
     do i = 1,nx,skip
        write(*,'(f8.5,1x)',advance='no') u(i,j)
     end do
     print *, " "
  end do
  return

end subroutine PrintOutput

! ----------------------------------------------------------------
! PrintFinalStats
!
! Print KINSOL statstics to standard out
! ----------------------------------------------------------------
subroutine PrintFinalStats(kmem)

  !======= Inclusions ===========
  use iso_c_binding
  use fkinsol_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: kmem

  integer(c_int)  :: ierr
  integer(c_long) :: nni(1), nfe(1), nje(1), nfeB(1), lenrw(1), leniw(1)
  integer(c_long) :: lenrwB(1), leniwB(1), nbcfails(1), nbacktr(1)

  !======= Internals ============

  ! Main solver statistics

  ierr = FKINGetNumNonlinSolvIters(kmem, nni)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumNonlinSolvIters, ierr = ', ierr, '; halting'
     stop 1
  end if

  ierr = FKINGetNumFuncEvals(kmem, nfe)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumFuncEvals, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! Linesearch statistics

  ierr = FKINGetNumBetaCondFails(kmem, nbcfails)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumBetaCondFails, ierr = ', ierr, '; halting'
     stop 1
  end if

  ierr = FKINGetNumBacktrackOps(kmem, nbacktr)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumBacktrackOps, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! Main solver workspace size

  ierr = FKINGetWorkSpace(kmem, lenrw, leniw)
  if (ierr /= 0) then
     print *, 'Error in FKINGetWorkSpace, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! Band linear solver statistics

  ierr = FKINGetNumJacEvals(kmem, nje)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumJacEvals, ierr = ', ierr, '; halting'
     stop 1
  end if

  ierr = FKINGetNumLinFuncEvals(kmem, nfeB)
  if (ierr /= 0) then
     print *, 'Error in FKINGetNumLinFuncEvals, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! Band linear solver workspace size

  ierr = FKINGetLinWorkSpace(kmem, lenrwB, leniwB)
  if (ierr /= 0) then
     print *, 'Error in FKINGetLinWorkSpace, ierr = ', ierr, '; halting'
     stop 1
  end if

  print *, ' '
  print *, 'Final Statistics..'
  print *, ' '
  print '(2(A,i6))'    ,'nni      =', nni,      '    nfe     =', nfe
  print '(2(A,i6))'    ,'nbcfails =', nbcfails, '    nbacktr =', nbacktr
  print '(2(A,i6))'    ,'nje      =', nje,      '    nfeB    =', nfeB
  print *, ' '
  print '(2(A,i6))'    ,'lenrw    =', lenrw,    '    leniw   =', leniw
  print '(2(A,i6))'    ,'lenrwB   =', lenrwB,   '    leniwB  =', leniwB

  return

end subroutine PrintFinalStats


C  file dede_lfF.f
C  Initializer for parameter common block
      subroutine initmod(odeparms)
      external odeparms
      double precision parms(5)
      common /myparms/parms

      call odeparms(5, parms)
      return
      end

C  Derivatives and one output variable
      subroutine derivs(neq, t, y, ydot, yout, ip)
      integer neq, ip(*)
      double precision t, y(neq), ydot(neq), yout(*)

      double precision N, P, ytau(2), tlag
      integer nr(2)

      double precision f, g, e, m, tau
      common /myparms/f, g, e, m, tau

      if (ip(1) < 2) call rexit("nout should be at least 2")

      N = y(1)
      P = y(2)
      nr(1) = 0
      nr(2) = 1
      ytau(1) = 1.0
      ytau(2) = 1.0

      tlag = t - tau
      if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau)

      ydot(1) = f * N - g * N * P
      ydot(2) = e * g * ytau(1) * ytau(2) - m * P

      yout(1) = ytau(1)
      yout(2) = ytau(2)

      return
      end


      SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C,
     $                   LDC, D, LDD, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform a transformation on the parameters (A,B,C,D) of a
C     system, which is equivalent to a bilinear transformation of the
C     corresponding transfer function matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPE    CHARACTER*1
C             Indicates the type of the original system and the
C             transformation to be performed as follows:
C             = 'D':  discrete-time   -> continuous-time;
C             = 'C':  continuous-time -> discrete-time.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     ALPHA,  (input) DOUBLE PRECISION
C     BETA    Parameters specifying the bilinear transformation.
C             Recommended values for stable systems: ALPHA = 1,
C             BETA = 1.  ALPHA <> 0, BETA <> 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state matrix A of the original system.
C             On exit, the leading N-by-N part of this array contains
C                              _
C             the state matrix A of the transformed system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B of the original system.
C             On exit, the leading N-by-M part of this array contains
C                              _
C             the input matrix B of the transformed system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C of the original system.
C             On exit, the leading P-by-N part of this array contains
C                               _
C             the output matrix C of the transformed system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the input/output matrix D for the original system.
C             On exit, the leading P-by-M part of this array contains
C                                     _
C             the input/output matrix D of the transformed system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C             For optimum performance LDWORK >= MAX(1,N*NB), where NB
C             is the optimal blocksize.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrix (ALPHA*I + A) is exactly singular;
C             = 2:  if the matrix  (BETA*I - A) is exactly singular.
C
C     METHOD
C
C     The parameters of the discrete-time system are transformed into
C     the parameters of the continuous-time system (TYPE = 'D'), or
C     vice-versa (TYPE = 'C') by the transformation:
C
C     1.  Discrete -> continuous
C         _                     -1
C         A = beta*(alpha*I + A)  * (A - alpha*I)
C         _                                     -1
C         B = sqrt(2*alpha*beta) * (alpha*I + A)  * B
C         _                                         -1
C         C = sqrt(2*alpha*beta) * C * (alpha*I + A)
C         _                        -1
C         D = D - C * (alpha*I + A)  * B
C
C     which is equivalent to the bilinear transformation
C
C                       z - alpha
C         z -> s = beta ---------  .
C                       z + alpha
C
C     of one transfer matrix onto the other.
C
C     2.  Continuous -> discrete
C         _                     -1
C         A = alpha*(beta*I - A)  * (beta*I + A)
C         _                                    -1
C         B = sqrt(2*alpha*beta) * (beta*I - A)  * B
C         _                                        -1
C         C = sqrt(2*alpha*beta) * C * (beta*I - A)
C         _                       -1
C         D = D + C * (beta*I - A)  * B
C
C     which is equivalent to the bilinear transformation
C
C                      beta + s
C       s -> z = alpha -------- .
C                      beta - s
C
C     of one transfer matrix onto the other.
C
C     REFERENCES
C
C     [1] Al-Saggaf, U.M. and Franklin, G.F.
C         Model reduction via balanced realizations: a extension and
C         frequency weighting techniques.
C         IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988.
C
C     NUMERICAL ASPECTS
C                                                      3
C     The time taken is approximately proportional to N .
C     The accuracy depends mainly on the condition number of the matrix
C     to be inverted.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and
C                  A. Varga, German Aerospace Research Establishment,
C                  Oberpfaffenhofen, Germany, Nov. 1996.
C     Supersedes Release 2.0 routine AB04AD by W. van der Linden, and
C     A.J. Geurts, Technische Hogeschool Eindhoven, Holland.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Bilinear transformation, continuous-time system, discrete-time
C     system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPE
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LTYPE
      INTEGER           I, IP
      DOUBLE PRECISION  AB2, PALPHA, PBETA, SQRAB2
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL,
     $                  DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SIGN, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      LTYPE = LSAME( TYPE, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( ALPHA.EQ.ZERO ) THEN
         INFO = -5
      ELSE IF( BETA.EQ.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -14
      ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB04MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, P ).EQ.0 )
     $   RETURN
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      IF (LTYPE) THEN
C
C        Discrete-time to continuous-time with (ALPHA, BETA).
C
         PALPHA = ALPHA
         PBETA = BETA
      ELSE
C
C        Continuous-time to discrete-time with (ALPHA, BETA) is
C        equivalent with discrete-time to continuous-time with
C        (-BETA, -ALPHA), if B and C change the sign.
C
         PALPHA = -BETA
         PBETA = -ALPHA
      END IF
C
      AB2 = PALPHA*PBETA*TWO
      SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA )
C                          -1
C     Compute (alpha*I + A)  .
C
      DO 10 I = 1, N
         A(I,I)  =  A(I,I) + PALPHA
   10 CONTINUE
C
      CALL DGETRF( N, N, A, LDA, IWORK, INFO )
C
      IF (INFO.NE.0) THEN
C
C        Error return.
C
         IF (LTYPE) THEN
            INFO = 1
         ELSE
            INFO = 2
         END IF
         RETURN
      END IF
C                         -1
C     Compute  (alpha*I+A)  *B.
C
      CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO )
C                               -1
C     Compute  D - C*(alpha*I+A)  *B.
C
      CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C,
     $            LDC, B, LDB, ONE, D, LDD )
C
C     Scale B by  sqrt(2*alpha*beta).
C
      CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO )
C                                                -1
C     Compute  sqrt(2*alpha*beta)*C*(alpha*I + A)  .
C
      CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N,
     $            SQRAB2, A, LDA, C, LDC )
C
      CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE,
     $            A, LDA, C, LDC )
C
C     Apply column interchanges to the solution matrix.
C
      DO 20 I = N-1, 1, -1
         IP = IWORK(I)
         IF ( IP.NE.I )
     $      CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 )
  20  CONTINUE
C                               -1
C     Compute beta*(alpha*I + A)  *(A - alpha*I) as
C                                        -1
C     beta*I - 2*alpha*beta*(alpha*I + A)  .
C
C     Workspace: need N;  prefer N*NB.
C
      CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C
      DO 30 I = 1, N
         CALL DSCAL(N, -AB2, A(1,I), 1)
         A(I,I) = A(I,I) + PBETA
   30 CONTINUE
C
      RETURN
C *** Last line of AB04MD ***
      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.

!>    @brief inter cell interpolation
!>    @param[in] I0 i-dimension
!>    @param[in] J0 j-dimension
!>    @param[in] K0 k-dimension
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] vals state variables (values)
!>    @param[in] px I0-direction interpolation position
!>    @param[in] py J0-direction interpolation position
!>    @param[in] pz K0-direction interpolation position
!>    @param[in] delx I0-direction cell dimensions (delta size)
!>    @param[in] dely J0-direction cell dimensions (delta size)
!>    @param[in] delz K0-direction cell dimensions (delta size)
!>    @param[in] delxa I0-direction absolute cell position
!>    @param[in] delya J0-direction absolute cell position
!>    @param[in] delza K0-direction absolute cell position
!>    @return interpolated value
      DOUBLE PRECISION FUNCTION interpolatepol(i0,j0,k0, i,j,k, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
        IMPLICIT NONE
!       i,j,k cell index (first corner - 3D)
        INTEGER i, j, k, i0, j0, k0, mode3d
!       corrected i,j,k, can be eliminated later - px,py,pz is inside the [i,j,k] cell ([0,0,0] corner)
        INTEGER c_i, c_j, c_k
!       state variables (values)
        DOUBLE PRECISION vals(i0,j0,k0)
!       x,y,z cell dimensions (delta size)
        DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
!       x,y,z absolute cell position
        DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
!       x,y,z interpolation position
        DOUBLE PRECISION px, py, pz
!
        DOUBLE PRECISION interpolate_3d, interpolate_am
        EXTERNAL interpolate_3d, interpolate_am
        INTRINSIC max, min

!       correct i-index
        c_i = i
        IF (px<delxa(i)) c_i = i-1
        IF (px>delxa(min(i+1,i0))) c_i = i+1
        c_i = min(max(c_i,1),i0)
!       correct j-index
        c_j = j
        IF (py<delya(j)) c_j = j-1
        IF (py>delya(min(j+1,j0))) c_j = j+1
        c_j = min(max(c_j,1),j0)
!       correct k-index
        c_k = k
        IF (pz<delza(k)) c_k = k-1
        IF (pz>delza(min(k+1,k0))) c_k = k+1
        c_k = min(max(c_k,1),k0)
!
        mode3d = 3
        interpolatepol = interpolate_3d(i0,j0,k0, c_i,c_j,c_k, mode3d, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
!
        RETURN
      END

!>    @brief inter cell interpolation (piece wise ???-methode), mode version
!>    @param[in] I0 i-dimension
!>    @param[in] J0 j-dimension
!>    @param[in] K0 k-dimension
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] mode3d direction mode, 1==I0, 2==J0, 3==K0
!>    @param[in] vals state variables (values)
!>    @param[in] px I0-direction interpolation position
!>    @param[in] py J0-direction interpolation position
!>    @param[in] pz K0-direction interpolation position
!>    @param[in] delx I0-direction cell dimensions (delta size)
!>    @param[in] dely J0-direction cell dimensions (delta size)
!>    @param[in] delz K0-direction cell dimensions (delta size)
!>    @param[in] delxa I0-direction absolute cell position
!>    @param[in] delya J0-direction absolute cell position
!>    @param[in] delza K0-direction absolute cell position
!>    @return piece wise ???-methode interpolated value
      DOUBLE PRECISION RECURSIVE FUNCTION interpolate_3d(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, &
        delx,dely,delz, delxa,delya,delza)
        IMPLICIT NONE
!       i,j,k cell index (first corner - 3D)
        INTEGER i, j, k, i0, j0, k0, mode3d
!       state variables (values)
        DOUBLE PRECISION vals(i0,j0,k0)
!       x,y,z cell dimensions (delta size)
        DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
!       x,y,z absolute cell position
        DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
!       x,y,z interpolation position
        DOUBLE PRECISION px, py, pz
!
        DOUBLE PRECISION d_a2, d_a3, d_a4, d_a5, d_d23, d_d34, d_d45, dp
        DOUBLE PRECISION pw_uk_interpol, pw_cr_interpol, interpolate_3d_wrapper, lin_interpol
        EXTERNAL pw_uk_interpol, pw_cr_interpol, interpolate_3d_wrapper, lin_interpol
        INTRINSIC min, max

        IF (mode3d==0) THEN
          interpolate_3d = vals(i,j,k)
          RETURN
        END IF
        IF (mode3d==1) THEN
!         prepare X-direction interpolation, compute directly
!         cell size deltas
          d_d23 = (delx(max(i-1,1))+delx(i))*0.5d0
          d_d34 = (delx(i)+delx(min(i+1,I0)))*0.5d0
          d_d45 = (delx(min(i+1,I0))+delx(min(i+2,I0)))*0.5d0
!         (x) delta
          dp = px -delxa(i)
!         function values
          d_a2 = interpolate_3d_wrapper(i0,j0,k0, max(i-1,1),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a4 = interpolate_3d_wrapper(i0,j0,k0, min(i+1,I0),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a5 = interpolate_3d_wrapper(i0,j0,k0, min(i+2,I0),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
!         sanity check
          IF (px<delxa(i).OR.(px>delxa(min(i+1,I0)).AND.i<I0)) THEN
            WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: i-cell index (',i, &
              ') incorrect for position :',px
            STOP
          END IF
        END IF
        IF (mode3d==2) THEN
!         prepare Y-direction interpolation, consist of X-direction interpolations
!         cell size deltas
          d_d23 = (dely(max(j-1,1))+dely(j))*0.5d0
          d_d34 = (dely(j)+dely(min(j+1,J0)))*0.5d0
          d_d45 = (dely(min(j+1,J0))+dely(min(j+2,J0)))*0.5d0
!         (y) delta
          dp = py -delya(j)
!         function values
          d_a2 = interpolate_3d_wrapper(i0,j0,k0, i,max(j-1,1),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a4 = interpolate_3d_wrapper(i0,j0,k0, i,min(j+1,J0),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a5 = interpolate_3d_wrapper(i0,j0,k0, i,min(j+2,J0),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
!         sanity check
          IF (py<delya(j).OR.(py>delya(min(j+1,J0)).AND.j<J0)) THEN
            WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: j-cell index (',j, &
              ') incorrect for position :',py
            STOP
          END IF
        END IF
        IF (mode3d==3) THEN
!         prepare Z-direction interpolation, consist of Y-direction interpolations
!         cell size deltas
          d_d23 = (delz(max(k-1,1))+delz(k))*0.5d0
          d_d34 = (delz(k)+delz(min(k+1,K0)))*0.5d0
          d_d45 = (delz(min(k+1,K0))+delz(min(k+2,K0)))*0.5d0
!         (z) delta
          dp = pz -delza(k)
!         function values
          d_a2 = interpolate_3d_wrapper(i0,j0,k0, i,j,max(k-1,1), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a4 = interpolate_3d_wrapper(i0,j0,k0, i,j,min(k+1,K0), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
          d_a5 = interpolate_3d_wrapper(i0,j0,k0, i,j,min(k+2,K0), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
!         sanity check
          IF (pz<delza(k).OR.(pz>delza(min(k+1,K0)).AND.k<K0)) THEN
            WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: k-cell index (',k, &
              ') incorrect for position :',pz
            STOP
          END IF
        END IF
!
!       compute unknown-methode interpolation
        interpolate_3d = pw_uk_interpol(d_a2, d_a3, d_a4, d_a5, dp, d_d23, d_d34, d_d45)
!.UNUSED/ compute Catmull-Rom interpolation
!        interpolate_3d = pw_cr_interpol(d_a2, d_a3, d_a4, d_a5, dp, d_d23, d_d34, d_d45)
!.UNUSED/ compute linear interpolation
!        interpolate_3d = lin_interpol(d_a3, d_a4, dp, d_d34)
!
        RETURN
      END

!>    @brief wrapper routine for the inter cell interpolation (piece wise ???-methode), mode version
!>    @param[in] I0 i-dimension
!>    @param[in] J0 j-dimension
!>    @param[in] K0 k-dimension
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] mode3d direction mode, 1==I0, 2==J0, 3==K0
!>    @param[in] vals state variables (values)
!>    @param[in] px I0-direction interpolation position
!>    @param[in] py J0-direction interpolation position
!>    @param[in] pz K0-direction interpolation position
!>    @param[in] delx I0-direction cell dimensions (delta size)
!>    @param[in] dely J0-direction cell dimensions (delta size)
!>    @param[in] delz K0-direction cell dimensions (delta size)
!>    @param[in] delxa I0-direction absolute cell position
!>    @param[in] delya J0-direction absolute cell position
!>    @param[in] delza K0-direction absolute cell position
!>    @return piece wise ???-methode interpolated value
      DOUBLE PRECISION RECURSIVE FUNCTION interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, &
        delx,dely,delz, delxa,delya,delza)
        IMPLICIT NONE
!       i,j,k cell index (first corner - 3D)
        INTEGER i, j, k, i0, j0, k0, mode3d
!       state variables (values)
        DOUBLE PRECISION vals(i0,j0,k0)
!       x,y,z cell dimensions (delta size)
        DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
!       x,y,z absolute cell position
        DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
!       x,y,z interpolation position
        DOUBLE PRECISION px, py, pz
!
        DOUBLE PRECISION interpolate_3d
        EXTERNAL interpolate_3d
        interpolate_3d_wrapper = interpolate_3d(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
        RETURN
      END

!>    @brief piece wise unknown-methode interpolation
!>    @param[in] f_am value x_a-1
!>    @param[in] f_a value x_a
!>    @param[in] f_b value x_b
!>    @param[in] f_bp value x_b+1
!>    @param[in] dp relative position >= 0, for [x_a x_b] intervall, difference from x_a
!>    @param[in] d_aam (delta) cell size, for [x_a-1 x_a] interval
!>    @param[in] d_ba (delta) cell size, for [x_a x_b] interval
!>    @param[in] d_bpb (delta) cell size, for [x_b x_b+1] interval
!>    @return interpolated value
      DOUBLE PRECISION FUNCTION pw_uk_interpol(f_am, f_a, f_b, f_bp, dp, d_aam, d_ba, d_bpb)
        IMPLICIT NONE
!       f_* function values for all nodes
!       dp: relative position >= 0
!       d_* (delta) cell size, for all x_* intervals
        DOUBLE PRECISION f_am, f_a, f_b, f_bp, dp, d_aam, d_ba, d_bpb
        DOUBLE PRECISION ds, gf_sm, gf_xm, gf_am, gf_bm, i_s, gf_s
        DOUBLE PRECISION gf_b_a
        INTRINSIC max, min, dabs
        LOGICAL test_null
        EXTERNAL test_null

! g_s = (2.0d0*f_b -2.0d0*f_a -gf_am*(ds-a) -gf_bm*(b-ds))/(b-a)
! ds = (g_s*(b-a) -2.0d0*f_b +2.0d0*f_a -gf_am*a +gf_bm*b) /(gf_bm -gf_am)
! mit a:=0, b:=d_ba ->
! g_s = (f_b+f_b -f_a-f_a -gf_am*ds -gf_bm*(d_ba-ds))/d_ba
! ds = (g_s*d_ba -f_b-f_b +f_a+f_a +gf_bm*d_ba) /(gf_bm -gf_am)

!       mean gradient between [a b]
        gf_s = (f_b -f_a) /d_ba
!       gradient mean for (a)
        gf_am = 0.5d0 *((f_a -f_am) /d_aam +gf_s)
!       gradient mean for (b)
        gf_bm = 0.5d0 *(gf_s +(f_bp -f_b) /d_bpb)
!
        gf_b_a = gf_bm -gf_am
!       delta (x) sattle point
        ds = 0.5d0*d_ba
!       gradient for the sattle point (s)
        gf_sm = 2.0d0*gf_s -0.5d0 *(gf_am +gf_bm)
!
        IF (dp<ds) THEN
!         gradient for (x)
          gf_xm = gf_am +dp *(gf_sm -gf_am) /ds
!         f_x, result for (x)
          pw_uk_interpol = f_a +(gf_am +gf_xm) *dp *0.5d0
        ELSE
!         integral area [a s]
          i_s = (gf_sm +gf_am) *ds *0.5d0
!         gradient for (x)
          gf_xm = gf_sm +(dp -ds) *(gf_bm -gf_sm) /(d_ba -ds)
!         f_x, result for (x)
          pw_uk_interpol = f_a +(gf_sm +gf_xm) *(dp -ds) *0.5d0 +i_s
        ENDIF
!
        RETURN
      END


subroutine MATH(a,b)
        real*8 :: a,b
        print *, cos(b) + sin(b) + sqrt(b) + exp(b) + a**b
   !$omp target map(tofrom:a)
        a = cos(b) + sin(b) + sqrt(b) + exp(b) + a**b
   !$omp end target
        end subroutine
program main
   REAL*8 :: x,y
   x = 2.0
   y = 12.0
   call MATH(x,y)
   print *,x
end program


C
C************************ NORMRES ***********************************
C
      real*8 function normres(nequ,ndir,noddir,vec,scr)
c
c  calcultes the Euclidian length of vector vec,
c  not considering the "ndir" components given in vector "noddir"
c
      implicit none
      integer  nequ,ndir
      integer  i
cxcx  integer  noddir(ndir)
      integer  noddir(*)
cxcx  real*8   vec(nequ),scr(nequ)
      real*8   vec(*),scr(*)
      real*8   zero
      real*8   dnrm2

      parameter (zero=0.d0)

      if (ndir.eq.0) then
         normres=dnrm2(nequ,vec,1)
      else
         call dcopy(nequ,vec,1,scr,1)
         do i=1,ndir
            scr(noddir(i))=zero
         end do
         normres=dnrm2(nequ,scr,1)
      end if

      return
      end


      REAL*8 FUNCTION ERTROT(TSEC50,KPRECES)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE GIVES THE EARTH ROTATION RATE.
C
C  THE ROTATION RATE IS DEFINED AS TWOPI DIVIDED BY THE NUMBER OF
C  SECONDS BETWEEN SUCCESSIVE CROSSINGS OF THE X-AXIS BY A GIVEN
C  MERIDIAN ON THE ROTATING EARTH.
C
C
C  VARIABLE  DIM  TYPE I/O  DESCRIPTION
C  --------  ---  ---- ---  -----------
C
C  TSEC50     1   R*8   I   SECONDS SINCE 1/1/1950, 0.0 HRS. UT.
C
C                           NOT USED. PRESENT HERE TO ALLOW FOR FUTURE
C                           EXPANSION OF THE ROUTINE TO INCLUDE SLOWING
C                           OF THE RATE AND, IN THE CASE OF A SYSTEM
C                           WITH A PRECESSING X-AXIS, A TIME DEPENDENT
C                           PRECESSION RATE.
C
C                           HENCE: ONLY TWO VALUES ARE NOW POSSIBLE:
C                                  ONE FOR PRECESSING X-AXIS
C                                  ONE FOR FIXED X-AXIS
C
C  KPRECES    1   I*4   I   FLAG INDICATING WHETHER THE X-AXIS IS
C                           PRECESSING OR NOT.
C                           = 0, NOT PRECESSING(EX: MEAN OF 1950.0)
C                           = OTHERWISE, PRECESSING. MEAN OF DATE.
C
C  ERTROT     1    R*8  O   ROTATION RATE RETURNED AS THE FUNCTION
C                           VALUE. RAD/SEC.
C
C********************************************************************
C
C  CODED BY C PETRUZZO 10/82
C      MODIFIED.......
C           CJP. 6/83. REPLACED METHOD OF ASSIGNING RATE FOR A FIXED
C                      X-AXIS.
C
C********************************************************************
C
      INTEGER INIT/1/
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 ROTMTX(3,3),SECDAY/86400.D0/
C
      IBUG=0
      LUBUG=6
C
      IF(INIT.EQ.1) THEN
        INIT=0
C
C       SET NUMBER OF SECONDS IN A SIDEREAL DAY.
C       SIDEREAL DAY= TIME BETWEEN SUCCESSIVE TRANSITS OF
C       THE PRECESSING EQUINOX BY AN EARTH'S MERIDIAN.
C       ONE SIDEREAL DAY= 23 HR, 56 MIN, 4.09054 SEC; SOURCE IS
C       ASTRONOMICAL ALMANAC, 1983, PAGE L-7.
        SIDDAY=23.D0*3600.D0 + 56.D0*60.D0 + 4.09054D0
C
C       COMPUTE EARTH ROTATION RATE FOR PRECESSING X-AXIS(RAD/SEC).
        OMEGAP=TWOPI/SIDDAY
C
C       COMPUTE THE ROTATION RATE FOR A FIXED X-AXIS(RAD/SEC).
        TDIFF=SECDAY*365.25D0   ! 1 YEAR
        RARATE=PRECES50(TDIFF,1)/TDIFF   ! RACN PRECESSION, RAD/SEC.
        OMEGAF=OMEGAP+RARATE
C
        IF(IBUG.EQ.1) THEN
          WRITE(LUBUG,1001) SIDDAY,OMEGAP,OMEGAP*DEGRAD,
     *          RARATE*DEGRAD*3600.D0*86400.D0*365.25D0,
     *          RARATE*DEGRAD,OMEGAF,OMEGAF*DEGRAD
 1001     FORMAT(/,' ERTROT DEBUG.'/,
     *     '  SIDDAY(SEC)=',G25.16/,
     *     '  OMEGAP(RAD/SEC, DEG/SEC)=',2G25.16/,
     *     '  RARATE(ARCSEC/YR)=',G25.16/,'  RARATE(DEG/SEC)=',G25.16/,
     *     '  OMEGAF(RAD/SEC, DEG/SEC)=',2G25.16)
          END IF
        END IF
C
      IF(KPRECES.EQ.0) THEN
        ERTROT=OMEGAF
      ELSE
        ERTROT=OMEGAP
        END IF
C
      RETURN
      END


! --- potential and force fields

      subroutine derivs(nb,x,v,dv,ddv)

      use cdat, only : ipot

      implicit real*8(a-h,o-z)

      real*8,intent(IN) :: x(nb)
      real*8,intent(out),dimension(nb) :: v,dv,ddv

! --- eckart barrier
!      v0 = 16d0
!      a = 0.8d0
!
!      do i=1,ntraj
!        v(i) = v0/cosh(x(i)/a)**2
!        dv(i) = -2d0*v0*tanh(x(i)/a)/a/(cosh(x(i)/a))**2
!        ddv(i) = 4d0*v0*tanh(x(i)/a)**2/a**2/cosh(x(i)/a)**2-2d0*v0* &
!                 (1d0-tanh(x(i)/a)**2)/a**2/cosh(x(i)/a)**2
!      enddo
      if (ipot == 1) then
! ----- quatic oscilator
        ak = 1d0
        ak2 = 0.0d0

        do i=1,nb

          dv(i) = ak*x(i) + 4d0*ak2*x(i)**3
          v(i)  = ak*x(i)**2/2d0 + ak2*x(i)**4
          ddv(i) = ak + 12d0*ak2*x(i)**2
!          ddv(i) = 0d0
        enddo

      elseif(ipot == 2) then

!------morse potential with extra bound potential at the right side
      de = 0.176d0
      x0 = 1.4d0
      a = 1.02d0
      b = 0d0

      do i=1,nb
        d = (1d0-exp(-a*(x(i)-x0)))
        v(i) = de*d**2
        dv(i) = 2*de*d*a*exp(-a*(x(i)-x0))
        ddv(i)=2*de*(-d*exp(-a*((x(i)-x0)))*a**2+(exp(-a*(x(i)-x0)))**2*a**2)
      enddo

      elseif( ipot == 3) then
!---------doulbe well---------------------------
      eta = 1.3544d0
      do i=1,Ntraj
        v(i) = 1d0/16d0/eta*x(i)**4-0.5d0*x(i)**2
        dv(i) = 1d0/4d0/eta*x(i)**3-x(i)
        ddv(i) = 3d0/4d0/eta*x(i)**2-1d0
      enddo

      endif

      return
      end subroutine derivs


        program mm
          real   , allocatable :: a(:,:),b(:,:)
          integer              :: l=5,m=6,n=4
          a = reshape([1:l*m],[l,m])
          b = reshape([1:m*n],[m,n])
          print'(<n>f15.7)',transpose(matmul(a,b))
        end program