c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vtsec.f
c
c     this file includes documentation and code for
c     subroutines vtsec and vtseci
c
c ... files which must be loaded with vtsec.f
c
c     sphcom.f, hrfft.f, vhaec.f, vhsec.f
c
c     subroutine vtsec(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvts,lwvts,work,lwork,ierror)
c
c     given the vector harmonic analysis br,bi,cr, and ci (computed
c     by subroutine vhaec) of some vector function (v,w), this
c     subroutine computes the vector function (vt,wt) which is
c     the derivative of (v,w) with respect to colatitude theta. vtsec
c     is similar to vhsec except the vector harmonics are replaced by
c     their derivative with respect to colatitude with the result that
c     (vt,wt) is computed instead of (v,w). vt(i,j) is the derivative
c     of the colatitudinal component v(i,j) at the point theta(i) =
c     (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the
c     spectral representation of (vt,wt) is given below at output
c     parameters vt,wt.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere. i.e. the arrays
c                 vt(i,j),wt(i,j) are computed for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator however the
c                 the coefficients cr and ci are zero. the synthesis
c                 is performed on the entire sphere.  i.e. the arrays
c                 vt(i,j),wt(i,j) are computed for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 2  no symmetries exist about the equator however the
c                 the coefficients br and bi are zero. the synthesis
c                 is performed on the entire sphere.  i.e. the arrays
c                 vt(i,j),wt(i,j) are computed for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 3  vt is odd and wt is even about the equator. the
c                 synthesis is performed on the northern hemisphere
c                 only.  i.e., if nlat is odd the arrays vt(i,j),wt(i,j)
c                 are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  vt is odd and wt is even about the equator and the
c                 coefficients cr and ci are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 5  vt is odd and wt is even about the equator and the
c                 coefficients br and bi are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 6  vt is even and wt is odd about the equator. the
c                 synthesis is performed on the northern hemisphere
c                 only.  i.e., if nlat is odd the arrays vt(i,j),wt(i,j)
c                 are computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  vt is even and wt is odd about the equator and the
c                 coefficients cr and ci are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 8  vt is even and wt is odd about the equator and the
c                 coefficients br and bi are zero. the synthesis is
c                 performed on the northern hemisphere only. i.e. if
c                 nlat is odd the arrays vt(i,j),wt(i,j) are computed
c                 for i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the arrays vt(i,j),wt(i,j) are computed for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls vtsec,
c            the arrays vt,wt,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays vt,wt as it appears in
c            the program that calls vtsec. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays vt,wt as it appears in
c            the program that calls vtsec. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            of (v,w) as computed by subroutine vhaec.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vtsec. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vtsec. ndab must be at
c            least nlat.
c
c     wvts   an array which must be initialized by subroutine vtseci.
c            once initialized, wvts can be used repeatedly by vtsec
c            as long as nlon and nlat remain unchanged.  wvts must
c            not be altered between calls of vtsec.
c
c     lwvts  the dimension of the array wvts as it appears in the
c            program that calls vtsec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lwvts must be at least
c
c            4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vtsec. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                    nlat*(2*nt*nlon+max0(6*l2,nlon))
c
c            if ityp .gt. 2 then lwork must be at least
c
c                    l2*(2*nt*nlon+max0(6*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     vt,wt  two or three dimensional arrays (see input parameter nt)
c            in which the derivative of (v,w) with respect to
c            colatitude theta is stored. vt(i,j),wt(i,j) contain the
c            derivatives at colatitude theta(i) = (i-1)*pi/(nlat-1)
c            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
c            are defined above at the input parameter ityp. vt and wt
c            are computed from the formulas for v and w given in
c            subroutine vhsec but with vbar and wbar replaced with
c            their derivatives with respect to colatitude. these
c            derivatives are denoted by vtbar and wtbar.
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     vt(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vtbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vtbar(m,n,theta(i))
c                   -ci(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j))
c      -(bi(m+1,n+1)*vtbar(m,n,theta(i))
c                   +cr(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     wt(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vtbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vtbar(m,n,theta(i))
c                   +bi(m+1,n+1)*wtbar(m,n,theta(i)))*cos(m*phi(j))
c      +(ci(m+1,n+1)*vtbar(m,n,theta(i))
c                   -br(m+1,n+1)*wtbar(m,n,theta(i)))*sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lwvts
c            = 10 error in the specification of lwork
c
c
c *******************************************************************
c
c     subroutine vtseci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror)
c
c     subroutine vtseci initializes the array wvts which can then be
c     used repeatedly by subroutine vtsec until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lwvts  the dimension of the array wvts as it appears in the
c            program that calls vtsec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lwvts must be at least
c
c            4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array work as it appears in the
c            program that calls vtsec. lwork must be at least
c            2*(nlat+1)
c
c     **************************************************************
c
c     output parameters
c
c     wvts   an array which is initialized for use by subroutine vtsec.
c            once initialized, wvts can be used repeatedly by vtsec
c            as long as nlat or nlon remain unchanged.  wvts must not
c            be altered between calls of vtsec.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lwvts
c            = 4  error in the specification of ldwork
c
c **********************************************************************
c
      subroutine vtsec(nlat,nlon,ityp,nt,vt,wt,idvw,jdvw,br,bi,cr,ci,
     1           mdab,ndab,wvts,lwvts,work,lwork,ierror)
c
      dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          work(1),wvts(1)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     1   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      lzz1 = 2*nlat*imid
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return
      ierror = 10
      if(ityp .le. 2 .and.
     1         lwork .lt. nlat*(2*nt*nlon+max0(6*imid,nlon))) return
      if(ityp .gt. 2 .and.
     1         lwork .lt. imid*(2*nt*nlon+max0(6*nlat,nlon))) return
      ierror = 0
      idv = nlat
      if(ityp .gt. 2) idv = imid
      lnl = nt*idv*nlon
      ist = 0
      if(ityp .le. 2) ist = imid
      iw1 = ist+1
      iw2 = lnl+1
      iw3 = iw2+ist
      iw4 = iw2+lnl
      iw5 = iw4+3*imid*nlat
      lzz1 = 2*nlat*imid
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      lwzvin = lzz1+labc
      jw1 = lwzvin+1
      jw2 = jw1+lwzvin
      call vtsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,ndab,
     1     br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3),
     2     work(iw4),work(iw5),wvts,wvts(jw1),wvts(jw2))
      return
      end
      subroutine vtsec1(nlat,nlon,ityp,nt,imid,idvw,jdvw,vt,wt,mdab,
     1   ndab,br,bi,cr,ci,idv,vte,vto,wte,wto,vb,wb,wvbin,wwbin,wrfft)
      dimension vt(idvw,jdvw,1),wt(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          vte(idv,nlon,1),vto(idv,nlon,1),wte(idv,nlon,1),
     3          wto(idv,nlon,1),wvbin(1),wwbin(1),wrfft(1),
     4          vb(imid,nlat,3),wb(imid,nlat,3)
      nlp1 = nlat+1
      mlat = mod(nlat,2)
      mlon = mod(nlon,2)
      mmax = min0(nlat,(nlon+1)/2)
      imm1 = imid
      if(mlat .ne. 0) imm1 = imid-1
      do 10 k=1,nt
      do 10 j=1,nlon
      do 10 i=1,idv
      vte(i,j,k) = 0.
      wte(i,j,k) = 0.
   10 continue
      ndo1 = nlat
      ndo2 = nlat
      if(mlat .ne. 0) ndo1 = nlat-1
      if(mlat .eq. 0) ndo2 = nlat-1
   18 itypp = ityp+1
      go to (1,100,200,300,400,500,600,700,800),itypp
c
c     case ityp=0   no symmetries
c
    1 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 15 k=1,nt
      do 15 np1=2,ndo2,2
      do 15 i=1,imm1
      vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
      wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
   15 continue
      do 16 k=1,nt
      do 16 np1=3,ndo1,2
      do 16 i=1,imid
      vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
      wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
   16 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 30 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(0,nlat,nlon,m,vb,iv,wvbin)
      call wbin(0,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 26
      do 25 k=1,nt
      do 24 np1=mp1,ndo1,2
      do 23 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
   23 continue
      if(mlat .eq. 0) go to 24
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,np1,iv)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,np1,iv)
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,np1,iv)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,np1,iv)
   24 continue
   25 continue
   26 if(mp2 .gt. ndo2) go to 30
      do 29 k=1,nt
      do 28 np1=mp2,ndo2,2
      do 27 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
   27 continue
      if(mlat .eq. 0) go to 28
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,np1,iw)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,np1,iw)
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,np1,iw)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,np1,iw)
   28 continue
   29 continue
   30 continue
      go to 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
  100 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 115 k=1,nt
      do 115 np1=2,ndo2,2
      do 115 i=1,imm1
      vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  115 continue
      do 116 k=1,nt
      do 116 np1=3,ndo1,2
      do 116 i=1,imid
      vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  116 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 130 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(0,nlat,nlon,m,vb,iv,wvbin)
      call wbin(0,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 126
      do 125 k=1,nt
      do 124 np1=mp1,ndo1,2
      do 123 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  123 continue
      if(mlat .eq. 0) go to 124
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,np1,iv)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,np1,iv)
  124 continue
  125 continue
  126 if(mp2 .gt. ndo2) go to 130
      do 129 k=1,nt
      do 128 np1=mp2,ndo2,2
      do 127 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  127 continue
      if(mlat .eq. 0) go to 128
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,np1,iw)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,np1,iw)
  128 continue
  129 continue
  130 continue
      go to 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
  200 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 215 k=1,nt
      do 215 np1=2,ndo2,2
      do 215 i=1,imm1
      wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  215 continue
      do 216 k=1,nt
      do 216 np1=3,ndo1,2
      do 216 i=1,imid
      wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  216 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 230 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(0,nlat,nlon,m,vb,iv,wvbin)
      call wbin(0,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 226
      do 225 k=1,nt
      do 224 np1=mp1,ndo1,2
      do 223 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  223 continue
      if(mlat .eq. 0) go to 224
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,np1,iv)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,np1,iv)
  224 continue
  225 continue
  226 if(mp2 .gt. ndo2) go to 230
      do 229 k=1,nt
      do 228 np1=mp2,ndo2,2
      do 227 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  227 continue
      if(mlat .eq. 0) go to 228
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,np1,iw)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,np1,iw)
  228 continue
  229 continue
  230 continue
      go to 950
c
c     case ityp=3   v odd,  w even
c
  300 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 315 k=1,nt
      do 315 np1=2,ndo2,2
      do 315 i=1,imm1
      vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  315 continue
      do 316 k=1,nt
      do 316 np1=3,ndo1,2
      do 316 i=1,imid
      wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  316 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 330 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(0,nlat,nlon,m,vb,iv,wvbin)
      call wbin(0,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 326
      do 325 k=1,nt
      do 324 np1=mp1,ndo1,2
      do 323 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  323 continue
      if(mlat .eq. 0) go to 324
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,np1,iv)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,np1,iv)
  324 continue
  325 continue
  326 if(mp2 .gt. ndo2) go to 330
      do 329 k=1,nt
      do 328 np1=mp2,ndo2,2
      do 327 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  327 continue
      if(mlat .eq. 0) go to 328
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,np1,iw)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,np1,iw)
  328 continue
  329 continue
  330 continue
      go to 950
c
c     case ityp=4   v odd,  w even, and both cr and ci equal zero
c
  400 call vbin(1,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 415 k=1,nt
      do 415 np1=2,ndo2,2
      do 415 i=1,imm1
      vto(i,1,k)=vto(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  415 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 430 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(1,nlat,nlon,m,vb,iv,wvbin)
      call wbin(1,nlat,nlon,m,wb,iw,wwbin)
      if(mp2 .gt. ndo2) go to 430
      do 429 k=1,nt
      do 428 np1=mp2,ndo2,2
      do 427 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  427 continue
      if(mlat .eq. 0) go to 428
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -bi(mp1,np1,k)*wb(imid,np1,iw)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     +br(mp1,np1,k)*wb(imid,np1,iw)
  428 continue
  429 continue
  430 continue
      go to 950
c
c     case ityp=5   v odd,  w even,     br and bi equal zero
c
  500 call vbin(2,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 516 k=1,nt
      do 516 np1=3,ndo1,2
      do 516 i=1,imid
      wte(i,1,k)=wte(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  516 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 530 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(2,nlat,nlon,m,vb,iv,wvbin)
      call wbin(2,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 530
      do 525 k=1,nt
      do 524 np1=mp1,ndo1,2
      do 523 i=1,imm1
      vto(i,2*mp1-2,k) = vto(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vto(i,2*mp1-1,k) = vto(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wte(i,2*mp1-2,k) = wte(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wte(i,2*mp1-1,k) = wte(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  523 continue
      if(mlat .eq. 0) go to 524
      wte(imid,2*mp1-2,k) = wte(imid,2*mp1-2,k)
     1                     -cr(mp1,np1,k)*vb(imid,np1,iv)
      wte(imid,2*mp1-1,k) = wte(imid,2*mp1-1,k)
     1                     -ci(mp1,np1,k)*vb(imid,np1,iv)
  524 continue
  525 continue
  530 continue
      go to 950
c
c     case ityp=6   v even  ,  w odd
c
  600 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 615 k=1,nt
      do 615 np1=2,ndo2,2
      do 615 i=1,imm1
      wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  615 continue
      do 616 k=1,nt
      do 616 np1=3,ndo1,2
      do 616 i=1,imid
      vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  616 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 630 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(0,nlat,nlon,m,vb,iv,wvbin)
      call wbin(0,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 626
      do 625 k=1,nt
      do 624 np1=mp1,ndo1,2
      do 623 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  623 continue
      if(mlat .eq. 0) go to 624
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,np1,iv)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,np1,iv)
  624 continue
  625 continue
  626 if(mp2 .gt. ndo2) go to 630
      do 629 k=1,nt
      do 628 np1=mp2,ndo2,2
      do 627 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  627 continue
      if(mlat .eq. 0) go to 628
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,np1,iw)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,np1,iw)
  628 continue
  629 continue
  630 continue
      go to 950
c
c     case ityp=7   v even, w odd   cr and ci equal zero
c
  700 call vbin(2,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 716 k=1,nt
      do 716 np1=3,ndo1,2
      do 716 i=1,imid
      vte(i,1,k)=vte(i,1,k)+br(1,np1,k)*vb(i,np1,iv)
  716 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 730 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(2,nlat,nlon,m,vb,iv,wvbin)
      call wbin(2,nlat,nlon,m,wb,iw,wwbin)
      if(mp1 .gt. ndo1) go to 730
      do 725 k=1,nt
      do 724 np1=mp1,ndo1,2
      do 723 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)+br(mp1,np1,k)*vb(i,np1,iv)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+bi(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-bi(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)+br(mp1,np1,k)*wb(i,np1,iw)
  723 continue
      if(mlat .eq. 0) go to 724
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     +br(mp1,np1,k)*vb(imid,np1,iv)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +bi(mp1,np1,k)*vb(imid,np1,iv)
  724 continue
  725 continue
  730 continue
      go to 950
c
c     case ityp=8   v even,  w odd   br and bi equal zero
c
  800 call vbin(1,nlat,nlon,0,vb,iv,wvbin)
c
c     case m = 0
c
      do 815 k=1,nt
      do 815 np1=2,ndo2,2
      do 815 i=1,imm1
      wto(i,1,k)=wto(i,1,k)-cr(1,np1,k)*vb(i,np1,iv)
  815 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) go to 950
      do 830 mp1=2,mmax
      m = mp1-1
      mp2 = mp1+1
      call vbin(1,nlat,nlon,m,vb,iv,wvbin)
      call wbin(1,nlat,nlon,m,wb,iw,wwbin)
      if(mp2 .gt. ndo2) go to 830
      do 829 k=1,nt
      do 828 np1=mp2,ndo2,2
      do 827 i=1,imm1
      vte(i,2*mp1-2,k) = vte(i,2*mp1-2,k)-ci(mp1,np1,k)*wb(i,np1,iw)
      vte(i,2*mp1-1,k) = vte(i,2*mp1-1,k)+cr(mp1,np1,k)*wb(i,np1,iw)
      wto(i,2*mp1-2,k) = wto(i,2*mp1-2,k)-cr(mp1,np1,k)*vb(i,np1,iv)
      wto(i,2*mp1-1,k) = wto(i,2*mp1-1,k)-ci(mp1,np1,k)*vb(i,np1,iv)
  827 continue
      if(mlat .eq. 0) go to 828
      vte(imid,2*mp1-2,k) = vte(imid,2*mp1-2,k)
     1                     -ci(mp1,np1,k)*wb(imid,np1,iw)
      vte(imid,2*mp1-1,k) = vte(imid,2*mp1-1,k)
     1                     +cr(mp1,np1,k)*wb(imid,np1,iw)
  828 continue
  829 continue
  830 continue
  950 do 14 k=1,nt
      call hrfftb(idv,nlon,vte(1,1,k),idv,wrfft,vb)
      call hrfftb(idv,nlon,wte(1,1,k),idv,wrfft,vb)
   14 continue
      if(ityp .gt. 2) go to 12
      do 60 k=1,nt
      do 60 j=1,nlon
      do 60 i=1,imm1
      vt(i,j,k) = .5*(vte(i,j,k)+vto(i,j,k))
      wt(i,j,k) = .5*(wte(i,j,k)+wto(i,j,k))
      vt(nlp1-i,j,k) = .5*(vte(i,j,k)-vto(i,j,k))
      wt(nlp1-i,j,k) = .5*(wte(i,j,k)-wto(i,j,k))
   60 continue
      go to 13
   12 do 11 k=1,nt
      do 11 j=1,nlon
      do 11 i=1,imm1
      vt(i,j,k) = .5*vte(i,j,k)
      wt(i,j,k) = .5*wte(i,j,k)
   11 continue
   13 if(mlat .eq. 0) return
      do 65 k=1,nt
      do 65 j=1,nlon
      vt(imid,j,k) = .5*vte(imid,j,k)
      wt(imid,j,k) = .5*wte(imid,j,k)
   65 continue
      return
      end
      subroutine vtseci(nlat,nlon,wvts,lwvts,dwork,ldwork,ierror)
c
      dimension wvts(lwvts)
      double precision dwork(ldwork)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      imid = (nlat+1)/2
      lzz1 = 2*nlat*imid
      mmax = min0(nlat,(nlon+1)/2)
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      if(lwvts .lt. 2*(lzz1+labc)+nlon+15) return
      ierror = 4
      if (ldwork .lt. 2*nlat+2) return
      ierror = 0
      call vtinit (nlat,nlon,wvts,dwork)
      lwvbin = lzz1+labc
      iw1 = lwvbin+1
      call wtinit (nlat,nlon,wvts(iw1),dwork)
      iw2 = iw1+lwvbin
      call hrffti(nlon,wvts(iw2))
      return
      end


! Reads the inputs to create the mesh
subroutine mesh
use Declarations
real(dp) :: delta_x, &    ! Horizontal space step [m]
        &   delta_y       ! Vertical space ste [m]
integer :: choice_nb_layers ! Variable to decide if vertical space step is equal to layer thicknesses (=1) or not (=0)
real(dp), allocatable :: y(:), &        ! Variable used to calculate yn
                     &   thickness(:)   ! Variable used to calculate yn

choice_nb_layers = 0

open(7,file='inputs.txt')
read(7,*) L1
read(7,*) L2
read(7,*) N
read(7,*) M
read(7,*)
read(7,*)
read(7,*) beta
read(7,*) nb_layers
allocate (thickness(nb_layers))
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
read(7,*)
do j = 1,nb_layers
   read(7,*) thickness(j)
enddo

close (7)

if (M .eq. 999) then   ! use layer thicknesses for vertical mesh resolution
   M = nb_layers + 1
   choice_nb_layers = 1
endif

!================== Allocate mesh variables =================================
allocate (y(M),xn(N,M),yn(N,M),xv(N-1,M-1),yv(N-1,M-1), Vol(N-1,M-1))
allocate (Sx_west(N-1,M-1),Sy_west(N-1,M-1),Sx_east(N-1,M-1),Sy_east(N-1,M-1))
allocate (Sx_north(N-1,M-1),Sy_north(N-1,M-1),Sx_south(N-1,M-1),Sy_south(N-1,M-1))

y(1) = 0._dp

if (choice_nb_layers .eq. 0) then
   delta_y = L2 / real(M-1,dp)
   do j = 1,M-1
      y(j+1) = y(j) + delta_y
   enddo
else
   do j=1,M-1
      y(j+1) = y(j)+thickness(j)
   enddo
endif

do j = 1,M
   xn(1,j) = dsin(beta)*y(j)
   yn(1,j) = dcos(beta)*y(j)
enddo

delta_x = L1 / real(N-1,dp)

do j = 1,M
   do i = 2,N
      xn(i,j) = xn(1,j) + real((i-1),dp) * delta_x * dcos(beta)
      yn(i,j) = yn(1,j) - dsin(beta)*real(i-1,dp)*delta_x
   enddo
enddo
do j = 1,M-1
   do i = 1,N-1
      xv(i,j) = (xn(i,j)+xn(i+1,j)+xn(i,j+1)+xn(i+1,j+1))*0.25_dp
      yv(i,j) = (yn(i,j)+yn(i+1,j)+yn(i,j+1)+yn(i+1,j+1))*0.25_dp
      Vol(i,j) = (yn(i,j+1)-yn(i,j))*delta_x/dcos(beta)
      Sx_west(i,j) = dabs(yn(i,j+1)-yn(i,j))
      Sy_west(i,j) = dabs(xn(i,j+1)-xn(i,j))
      Sx_east(i,j) = dabs(yn(i+1,j+1)-yn(i+1,j))
      Sy_east(i,j) = dabs(xn(i+1,j+1)-xn(i+1,j))
      Sx_north(i,j) = dabs(yn(i+1,j+1)-yn(i,j+1))
      Sy_north(i,j) = dabs(xn(i+1,j+1)-xn(i,j+1))
      Sx_south(i,j) = dabs(yn(i+1,j)-yn(i,j))
      Sy_south(i,j) = dabs(xn(i+1,j)-xn(i,j))
    enddo
enddo

! Check if sum of all small volumes is equal to rectangle volume
write(*,*) 'Sum of all small volumes [m2] = ', sum(Vol)
write(*,*) 'Total volume [m2] = ', L1 * L2

deallocate(y, thickness)

return
end


    MODULE cdf_gamma_mod
! ----------------------------------------------------------------------

!                              cdf_gamma_mod
!                              *=*=*=*=*=*=*

!  -  SUBROUTINE CDF_GAMMA(WHICH, CUM, CCUM, X, SHAPE, SCALE, STATUS,
!                          CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_GAMMA(X, SHAPE, SCALE, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_GAMMA(X, SHAPE, SCALE, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_GAMMA(CUM, CCUM, SHAPE, SCALE, STATUS,
!                                      CHECK_INPUT)

!                             The Distribution
!                             ================

!         The density of the GAMMA distribution is proportional to:

!                               SHAPE-1
!                      (x/SCALE)        exp(-x/SCALE)

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    four arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     1.  CUM and CCUM
!     2.  X
!     3.  SHAPE
!     4.  SCALE
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the gamma distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the gamma
!                               distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: X. The upper limit of integration of the gamma
!                        density. The lower limit is 0.
!  Range: [ 0:10^100 ]
!  - REAL (dpkind) :: SHAPE. The shape parameter of the distribution.
!  Range: [ 10^-10:10^100 ]
!  - REAL (dpkind) :: SCALE. The scale parameter of the distribution.
!  Range: [ 10^-10:10^100 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 SHAPE outside range
!     -6 SCALE outside range
!      3 CUM + CCUM is not nearly one
!     10 can not solve gamma_inverse in cdf_gamma
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!  NOTE: CUM and CCUM must add to (nearly) one.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_mathlib_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_gamma, cdf_gamma, cum_gamma, inv_gamma
! ..
    CONTAINS

!*********************************************************************

      FUNCTION ccum_gamma(x,shape,scale,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_gamma
! ..
! .. Scalar Arguments ..
! DMS OPTIONAL added
        REAL (dpkind), INTENT (IN) :: scale, shape, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_gamma(which=1,ccum=ccum_gamma,x=x,shape=shape, &
          scale=scale,status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_gamma

!*********************************************************************

      SUBROUTINE cdf_gamma(which,cum,ccum,x,shape,scale,status, &
          check_input)
! .. Use Statements ..
        USE zero_finder
        USE cdf_aux_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: scale, shape, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum, xx
        INTEGER :: ierr, zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_gamma%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = x
        params(4) = shape
        params(5) = scale

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_gamma,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF
        END IF

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)

        CASE (1)
! Calculate cum and ccum

          CALL local_cum_gamma(x,shape,scale,local_cum,local_ccum)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

          RETURN

        CASE (2)
! Calculate x

          CALL gamma_inverse(shape,xx,-one,local_cum,local_ccum,ierr)

          IF (ierr<0) THEN
            IF (has_status) THEN
              status = 10

              RETURN
            ELSE
              WRITE (*,*) 'Error in cdf_gamma call to gamma_inverse'
              WRITE (*,*) 'Status: ', ierr

              STOP 'Error in cdf_gamma call to gamma_inverse'
            END IF

          END IF

          x = xx/scale

          RETURN

        CASE (3)
! Calculate SHAPE

          shape = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_gamma,4,local)

          DO

            CALL rc_step_zf(zf_status,shape,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_gamma(x,shape,scale,try_cum,try_ccum)

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        CASE (4)
! Calculate SCALE

          CALL gamma_inverse(shape,xx,-one,local_cum,local_ccum,ierr)

          IF (ierr/=0) THEN
            IF (has_status) THEN
              status = 10

              RETURN
            ELSE
              WRITE (*,*) 'Error in cdf_gamma call to gamma_inverse'
              WRITE (*,*) 'Status: ', ierr

              STOP 'Error in cdf_gamma call to gamma_inverse'
            END IF

          END IF

          scale = xx/x

          RETURN

        END SELECT

! Gets here ONLY for which=3

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_gamma

!*********************************************************************

      FUNCTION cum_gamma(x,shape,scale,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_gamma
! ..
! .. Scalar Arguments ..
! DMS OPTIONAL added
        REAL (dpkind), INTENT (IN) :: scale, shape, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_gamma(which=1,cum=cum_gamma,x=x,shape=shape,scale=scale, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_gamma

!*********************************************************************

      SUBROUTINE gamma_inverse(a,x,x0,p,q,ierr)
! ----------------------------------------------------------------------
!            INVERSE INCOMPLETE GAMMA RATIO FUNCTION
!     GIVEN POSITIVE A, AND NON-NEGATIVE P AND Q WHERE P + Q = 1.
!     THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER
!     ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X
!     TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE
!     PARTICULAR COMPUTER ARITHMETIC BEING USED.
!                      ------------
!     X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0,
!     AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT
!     NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN
!     A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE
!     IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X.
!     X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER
!     DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET
!     X0 .LE. 0.
!     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
!     WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING
!     VALUES ...
!       IERR =  0    THE SOLUTION WAS OBTAINED. ITERATION WAS
!                    NOT USED.
!       IERR.GT.0    THE SOLUTION WAS OBTAINED. IERR ITERATIONS
!                    WERE PERFORMED.
!       IERR = -2    (INPUT ERROR) A .LE. 0
!       IERR = -3    NO SOLUTION WAS OBTAINED. THE RATIO Q/A
!                    IS TOO LARGE.
!       IERR = -4    (INPUT ERROR) P + Q .NE. 1
!       IERR = -6    20 ITERATIONS WERE PERFORMED. THE MOST
!                    RECENT VALUE OBTAINED FOR X IS GIVEN.
!                    THIS CANNOT OCCUR IF X0 .LE. 0.
!       IERR = -7    ITERATION FAILED. NO VALUE IS GIVEN FOR X.
!                    THIS MAY OCCUR WHEN X IS APPROXIMATELY 0.
!       IERR = -8    A VALUE FOR X HAS BEEN OBTAINED, BUT THE
!                    ROUTINE IS NOT CERTAIN OF ITS ACCURACY.
!                    ITERATION CANNOT BE PERFORMED IN THIS
!                    CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY
!                    WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS
!                    POSITIVE THEN THIS CAN OCCUR WHEN A IS
!                    EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY
!                    LARGE (SAY A .GE. 1.E20).
! ----------------------------------------------------------------------
!     WRITTEN BY ALFRED H. MORRIS, JR.
!        NAVAL SURFACE WEAPONS CENTER
!        DAHLGREN, VIRGINIA
!     -------------------
!     -------------------
!     LN10 = LN(10)
!     C = EULER CONSTANT
!     -------------------
!     -------------------
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: a, p, q, x0
        REAL (dpkind), INTENT (OUT) :: x
        INTEGER, INTENT (OUT) :: ierr
! ..
! .. Local Scalars ..
        REAL (dpkind) :: am1, amax, ap1, ap2, ap3, apn, b, c1, c2, c3, &
          c4, c5, d, e, e2, eps, g, h, pn, qg, qn, r, rta, s, s2, sum, t, &
          u, w, xmax, xmin, xn, y, z
        INTEGER :: iop
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, EPSILON, EXP, HUGE, LOG, MAX, SQRT, TINY
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: ac(4) = (/ 3.31125922108741E0_dpkind, &
          11.6616720288968E0_dpkind, 4.28342155967104E0_dpkind, &
          .213623493715853E0_dpkind/)
        REAL (dpkind), PARAMETER :: amin(2) = (/ 500.0E0_dpkind, &
          100.0E0_dpkind/)
        REAL (dpkind), PARAMETER :: bc(5) = (/ one, &
          6.61053765625462E0_dpkind, 6.40691597760039E0_dpkind, &
          1.27364489782223E0_dpkind, .036117081018842E0_dpkind/)
        REAL (dpkind), PARAMETER :: bmin(2) = (/ 1.E-28_dpkind, &
          1.E-13_dpkind/)
        REAL (dpkind), PARAMETER :: dmin(2) = (/ 1.E-06_dpkind, &
          1.E-04_dpkind/)
        REAL (dpkind), PARAMETER :: emin(2) = (/ 2.E-03_dpkind, &
          6.E-03_dpkind/)
        REAL (dpkind), PARAMETER :: eps0(2) = (/ 1.E-10_dpkind, &
          1.E-08_dpkind/)
        REAL (dpkind), PARAMETER :: c = .577215664901533E0_dpkind
        REAL (dpkind), PARAMETER :: ln10 = 2.302585E0_dpkind
        REAL (dpkind), PARAMETER :: tol = 1.E-5_dpkind
! ..
!     -------------------
!     ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.
!            E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.
!            XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE
!            LARGEST POSITIVE NUMBER.
        e = EPSILON(one)
        xmin = TINY(one)
        xmax = HUGE(one)

        x = zero
        IF (a<=zero) GO TO 240
        t = p + q - one
        IF (ABS(t)>e) GO TO 260

        ierr = 0
        IF (p==zero) RETURN
        IF (q==zero) GO TO 220
        IF (a==one) GO TO 230

        e2 = two*e
        amax = 0.4E-10_dpkind/(e*e)
        iop = 1

        IF (e>1.E-10_dpkind) iop = 2

        eps = eps0(iop)
        xn = x0

        IF (x0>zero) GO TO 110

!        SELECTION OF THE INITIAL APPROXIMATION XN OF X
!                       WHEN A .LT. 1

        IF (a>one) GO TO 50

        g = gamma(a+one)
        qg = q*g
        IF (qg==zero) GO TO 300

        b = qg/a

        IF (qg>0.6E0_dpkind*a) GO TO 40
        IF (a>=0.30E0_dpkind .OR. b<0.35E0_dpkind) GO TO 10

        t = EXP(-(b+c))
        u = t*EXP(t)
        xn = t*EXP(u)
        GO TO 110

10      CONTINUE
        IF (b>=0.45E0_dpkind) GO TO 40
        IF (b==zero) GO TO 300
        y = -LOG(b)
        s = half + (half-a)
        z = LOG(y)
        t = y - s*z
        IF (b<0.15E0_dpkind) GO TO 20
        xn = y - s*LOG(t) - LOG(one+s/(t+one))
        GO TO 170

20      CONTINUE
        IF (b<=0.01E0_dpkind) GO TO 30
        u = ((t+two*(three-a))*t+(two-a)*(three-a))/((t+(five-a))*t+two)
        xn = y - s*LOG(t) - LOG(u)
        GO TO 170

30      CONTINUE
        c1 = -s*z
        c2 = -s*(one+c1)
        c3 = s*((half*c1+(two-a))*c1+(2.5E0_dpkind-1.5E0_dpkind*a))
        c4 = -s*(((c1/three+(2.5E0_dpkind-1.5E0_dpkind*a))*c1+((a-six)*a+ &
          seven))*c1+((11.0E0_dpkind*a-46)*a+47.0E0_dpkind)/six)
        c5 = -s*(((((-c1/four)+(11.0E0_dpkind*a-17.0E0_dpkind)/six)*c1+ &
          (((-three*a)+13.0E0_dpkind)*a-13.0E0_dpkind))*c1+half*(((two*a- &
          25.0E0_dpkind)*a+72.0E0_dpkind)*a-61.0E0_dpkind))*c1+((( &
          25.0E0_dpkind*a-195.0E0_dpkind)*a+477.0E0_dpkind)*a- &
          379.0E0_dpkind)/twelve)

        xn = ((((c5/y+c4)/y+c3)/y+c2)/y+c1) + y

        IF (a>one) GO TO 170
        IF (b>bmin(iop)) GO TO 170
        x = xn
        RETURN

40      CONTINUE
        IF (b*q<=1.E-8_dpkind) THEN
          xn = EXP(-(q/a+c))
        ELSE

          IF (p>0.9E0_dpkind) THEN
            xn = EXP((alnrel(-q)+gamln1(a))/a)
          ELSE

            xn = EXP(LOG(p*g)/a)
          END IF
        END IF

        IF (xn==zero) GO TO 250

        t = half + (half-xn/(a+one))
        xn = xn/t
        GO TO 110

!        SELECTION OF THE INITIAL APPROXIMATION XN OF X
!                       WHEN A .GT. 1

50      CONTINUE
        IF (q>half) THEN
          w = LOG(p)
        ELSE
          w = LOG(q)
        END IF

        t = SQRT(-two*w)

        s = t - evaluate_polynomial(ac,t)/evaluate_polynomial(bc,t)

        IF (q>half) s = -s

        rta = SQRT(a)
        s2 = s*s
        xn = a + s*rta + (s2-one)/three + s*(s2-seven)/(36.0E0_dpkind*rta &
          ) - ((three*s2+seven)*s2-16.0E0_dpkind)/(810.0E0_dpkind*a) + &
          s*((nine*s2+256.0E0_dpkind)*s2-433.0E0_dpkind)/ &
          (38880.0E0_dpkind*a*rta)
        xn = MAX(xn,zero)

        IF (a<amin(iop)) GO TO 60

        x = xn
        d = half + (half-x/a)

        IF (ABS(d)<=dmin(iop)) RETURN

60      CONTINUE
        IF (p<=half) GO TO 80
        IF (xn<three*a) GO TO 170

        y = -(w+gamln(a))
        d = MAX(two,a*(a-one))

        IF (y<ln10*d) GO TO 70

        s = one - a
        z = LOG(y)
        GO TO 30

70      CONTINUE
        t = a - one
        xn = y + t*LOG(xn) - alnrel(-t/(xn+one))
        xn = y + t*LOG(xn) - alnrel(-t/(xn+one))
        GO TO 170

80      CONTINUE
        ap1 = a + one

        IF (xn>0.70E0_dpkind*ap1) GO TO 120

        w = w + gamln(ap1)

        IF (xn>0.15E0_dpkind*ap1) GO TO 90

        ap2 = a + two
        ap3 = a + three
        x = EXP((w+x)/a)
        x = EXP((w+x-LOG(one+(x/ap1)*(one+x/ap2)))/a)
        x = EXP((w+x-LOG(one+(x/ap1)*(one+x/ap2)))/a)
        x = EXP((w+x-LOG(one+(x/ap1)*(one+(x/ap2)*(one+x/ap3))))/a)
        xn = x

        IF (xn>1.E-2_dpkind*ap1) GO TO 90
        IF (xn<=emin(iop)*ap1) RETURN
        GO TO 120

90      CONTINUE
        apn = ap1
        t = xn/apn
        sum = one + t
100     CONTINUE
        apn = apn + one
        t = t*(xn/apn)
        sum = sum + t
        IF (t>1.E-4_dpkind) GO TO 100
        t = w - LOG(sum)
        xn = EXP((xn+t)/a)
        xn = xn*(one-(a*LOG(xn)-xn-t)/(a-xn))
        GO TO 120

!                 SCHRODER ITERATION USING P

110     CONTINUE
        IF (p>half) GO TO 170

120     CONTINUE
        IF (p<=1.E10_dpkind*xmin) GO TO 290
        am1 = (a-half) - half

130     CONTINUE
        IF (a<=amax) GO TO 140
        d = half + (half-xn/a)
        IF (ABS(d)<=e2) GO TO 290

140     CONTINUE
        IF (ierr>=20) GO TO 270
        ierr = ierr + 1

        CALL gratio(a,xn,pn,qn,0)

        IF (pn==zero .OR. qn==zero) GO TO 290

        r = rcomp(a,xn)

        IF (r==zero) GO TO 290

        t = (pn-p)/r
        w = half*(am1-xn)

        IF (ABS(t)<=tenth .AND. ABS(w*t)<=tenth) GO TO 150

        x = xn*(one-t)

        IF (x<=zero) GO TO 280

        d = ABS(t)
        GO TO 160

150     CONTINUE
        h = t*(one+w*t)
        x = xn*(one-h)
        IF (x<=zero) GO TO 280
        IF (ABS(w)>=one .AND. ABS(w)*t*t<=eps) RETURN
        d = ABS(h)

160     CONTINUE
        xn = x
        IF (d>tol) GO TO 130
        IF (d<=eps) RETURN
        IF (ABS(p-pn)<=tol*p) RETURN
        GO TO 130

!                 SCHRODER ITERATION USING Q

170     CONTINUE
        IF (q<=1.E10_dpkind*xmin) GO TO 290
        am1 = (a-half) - half

180     CONTINUE
        IF (a<=amax) GO TO 190
        d = half + (half-xn/a)
        IF (ABS(d)<=e2) GO TO 290

190     CONTINUE
        IF (ierr>=20) GO TO 270
        ierr = ierr + 1

        CALL gratio(a,xn,pn,qn,0)

        IF (pn==zero .OR. qn==zero) GO TO 290

        r = rcomp(a,xn)
        IF (r==zero) GO TO 290
        t = (q-qn)/r
        w = half*(am1-xn)
        IF (ABS(t)<=tenth .AND. ABS(w*t)<=tenth) GO TO 200
        x = xn*(one-t)
        IF (x<=zero) GO TO 280
        d = ABS(t)
        GO TO 210

200     CONTINUE
        h = t*(one+w*t)
        x = xn*(one-h)
        IF (x<=zero) GO TO 280
        IF (ABS(w)>=one .AND. ABS(w)*t*t<=eps) RETURN
        d = ABS(h)

210     CONTINUE
        xn = x
        IF (d>tol) GO TO 180
        IF (d<=eps) RETURN
        IF (ABS(q-qn)<=tol*q) RETURN
        GO TO 180

!                       SPECIAL CASES

220     CONTINUE
        x = xmax
        RETURN

230     CONTINUE
        IF (q>=0.9E0_dpkind) THEN
          x = -alnrel(-p)
          RETURN

        END IF

        x = -LOG(q)
        RETURN

!                       ERROR RETURN

240     CONTINUE
        ierr = -2
        RETURN

250     CONTINUE
        ierr = -3
        RETURN

260     CONTINUE
        ierr = -4
        RETURN

270     CONTINUE
        ierr = -6
        RETURN

280     CONTINUE
        ierr = -7
        RETURN

290     CONTINUE
        x = xn
        ierr = -8
        RETURN

300     CONTINUE
        x = xmax
        ierr = -8

      END SUBROUTINE gamma_inverse

!*********************************************************************

      FUNCTION inv_gamma(cum,ccum,shape,scale,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_gamma
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: scale, shape
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_gamma(2,cum=cum,ccum=ccum,x=inv_gamma,shape=shape, &
          scale=scale,status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_gamma

!*********************************************************************

      SUBROUTINE local_cum_gamma(x,shape,scale,cum,ccum)
!----------------------------------------------------------------------

!                              Function

!     Computes   the  cumulative        of    the     incomplete   gamma
!     distribution, i.e., the integral from 0 to X*SCALE of
!          (1/GAM(SHAPE))*EXP(-T)*T**(SHAPE-1) DT
!     where GAM(SHAPE) is the complete gamma function of SHAPE, i.e.,
!          GAM(SHAPE) = integral from 0 to infinity of

!                    EXP(-T)*T**(SHAPE-1) DT

!                              Arguments

!     X --> The upper limit of integration of the incomplete gamma.
!     SHAPE --> The shape parameter of the incomplete gamma.
!     SCALE --> The scale parameter of the incomplete gamma
!     CUM <-- Cumulative incomplete gamma distribution.
!     CCUM <-- Compliment of Cumulative incomplete gamma distribution.

!                              Method

!    The  cumulative  gamma and  its  inverse  are  from the  following
!    reference:
!    DiDinato, A. R. and Morris, A. H. Computation of the  incomplete
!    gamma function  ratios  and their  inverse.   ACM  Trans.  Math.
!    Softw. 12 (1986), 377-393.
!----------------------------------------------------------------------
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: scale, shape, x
! ..
! .. Local Scalars ..
        REAL (dpkind) :: arg
! ..
        IF (x<=zero) THEN
          cum = zero
          ccum = one

          RETURN
        END IF

        arg = x*scale

! Suppose NOTHING bad happens in gratio

        CALL gratio(shape,arg,cum,ccum,0)

        RETURN

      END SUBROUTINE local_cum_gamma

!*********************************************************************

    END MODULE cdf_gamma_mod


subroutine solver()
!determines the flow profile around the object. In order to do this we have to solve 2
!coupled equations:
! - calculate the streamfunction (psi) by solving Poisson's equation
! - update the vorticity by solving the vorticity transport equation (from the NS equations)
!
!First of all a potential flow is calculated around the object (solving Laplace's equation)
!then (optionally) the vorticity is turned on and alternately Poisson's equation and the
!vorticity transport equation are iterated to determine the fluid flow.

    use vars
    use parallel

    implicit none

    real :: time
    double precision :: tstart, tstop

    !$OMP PARALLEL
    !solve Laplace's equation for the irrotational flow profile (vorticity=0)
    call poisson(5000)
    !$OMP END PARALLEL

    !get the vorticity on the surface of the object

    call getvort()

    !write out the potential flow to file.

    call writetofile("potential.dat")

    !if the user has chosen to allow vorticity:
    if (vorticity) then

        ! set CFL conditions (dt << cell crossing time or cell diffusion time for stability)
        cfl_r0 = 0.25*dx*dy*R0
        cfl_v = 0.25*dx/1. !assume velocty is 1

        !dt is set according to the most restrictive CFL condition
        dt = minval((/ cfl_r0, cfl_v /))

        if (irank .eq. 0) then
            print*,''
            print*,"CFL (Reynolds, velocity)", cfl_r0, cfl_v
            print *, "Timestep=",dt
            print *, ""
        endif

        time=0.

        if (irank .eq. 0) tstart=MPI_Wtime()

        !$OMP PARALLEL

        do while (time .lt. real(nx)*crossing_times)

            !if (irank .eq. 0) print*, "t=",time,"of",nx*crossing_times

            call getv() !get the velocity

            call navier_stokes() !solve dw/dt=f(w,psi) for a timestep

            call poisson(2) !2 poisson 'relaxation' steps

            !$OMP SINGLE
            time=time+dt
            !$OMP END SINGLE
            !$OMP BARRIER

        enddo

        !$OMP END PARALLEL

        if (irank .eq. 0) then
            tstop=MPI_Wtime()
            print*,''
            print*, "Time to complete =",tstop-tstart
            print*,''
        endif

        call getvort()

    endif

end subroutine


C This one implements depth-first backtracking.
C See the 2nd program for Scheme on the "Permutations" page for the
C main idea.
C As is, the program only prints the number of n-queens configurations.
C To print also the configurations, uncomment the line after label 80.
      program queens
      implicit integer(a-z)
      parameter(l=18)
      dimension a(l),s(l),u(4*l-2)
      do 10 i=1,l
   10 a(i)=i
      do 20 i=1,4*l-2
   20 u(i)=0
      do 110 n=1,l
      m=0
      i=1
      r=2*n-1
      go to 40
   30 s(i)=j
      u(p)=1
      u(q+r)=1
      i=i+1
   40 if(i.gt.n) go to 80
      j=i
   50 z=a(i)
      y=a(j)
      p=i-y+n
      q=i+y-1
      a(i)=y
      a(j)=z
      if((u(p).eq.0).and.(u(q+r).eq.0)) goto 30
   60 j=j+1
      if(j.le.n) go to 50
   70 j=j-1
      if(j.eq.i) go to 90
      z=a(i)
      a(i)=a(j)
      a(j)=z
      go to 70
   80 m=m+1
C     print *,(a(k),k=1,n)
   90 i=i-1
      if(i.eq.0) go to 100
      p=i-a(i)+n
      q=i+a(i)-1
      j=s(i)
      u(p)=0
      u(q+r)=0
      go to 60
  100 print *,n,m
  110 continue
      end

C Output
C          1           1
C          2           0
C          3           0
C          4           2
C          5          10
C          6           4
C          7          40
C          8          92
C          9         352
C         10         724
C         11        2680
C         12       14200
C         13       73712
C         14      365596
C         15     2279184
C         16    14772512
C         17    95815104
C         18   666090624


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unihess_factor
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine factors a unitary upper Hessenberg matrix into a
! sequence of Givens' rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  H               COMPLEX(8) array of dimension (N,N)
!                    unitary matrix to be reduced
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for Givens' rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies N is invalid
!                   INFO = -2 implies H is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unihess_factor(N,H,Q,D,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  integer, intent(inout) :: INFO
  complex(8), intent(inout) :: H(N,N)

  ! compute variables
  logical :: flg
  integer :: ii
  real(8) :: nrm, tol
  real(8) :: cr, ci, s

  ! initialize info
  INFO = 0

  ! check N
  if (N < 2) then
    INFO = -1
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
    end if
    return
  end if

  ! check H
  call z_2Darray_check(N,N,H,flg)
  if (.NOT.flg) then
    INFO = -2
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"H is invalid",INFO,INFO)
    end if
    return
  end if

  ! set tol
  tol = max(10d0,dble(N))*EISCOR_DBL_EPS

  ! loop for reduction
  ! ii is the column being reduced
  do ii=1,(N-1)

    ! reduce to block diagonal
    call z_rot3_vec4gen(dble(H(ii,ii)),aimag(H(ii,ii)),dble(H(ii+1,ii)),aimag(H(ii+1,ii)),cr,ci,s,nrm)

    ! check for unitarity
    if (abs(nrm-1d0) >= tol) then
      INFO = -2
      ! print error in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"H is not unitary",INFO,INFO)
      end if
      return
    end if

    ! update H
    H(ii,ii) = cmplx(cr,-ci,kind=8)*H(ii,ii) + cmplx(s,0d0,kind=8)*H(ii+1,ii)
    H(ii+1,(ii+1):N) = cmplx(-s,0d0,kind=8)*H(ii,(ii+1):N) + cmplx(cr,ci,kind=8)*H(ii+1,(ii+1):N)

    ! store in Q
    Q(3*(ii-1)+1) = cr
    Q(3*(ii-1)+2) = ci
    Q(3*(ii-1)+3) = s

    ! store in D
    call d_rot2_vec2gen(dble(H(ii,ii)),aimag(H(ii,ii)),D(2*(ii-1)+1),D(2*(ii-1)+2),nrm)

  end do

  ! store in D
  call d_rot2_vec2gen(dble(H(N,N)),aimag(H(N,N)),D(2*(N-1)+1),D(2*(N-1)+2),nrm)

  ! check for unitarity
  if (abs(nrm-1d0) >= tol) then
    INFO = -2
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"H is not unitary",INFO,INFO)
    end if
    return
  end if

end subroutine z_unihess_factor


! { dg-do compile }
!
! Testcase from PR 54656
! Checking for NORM2 for large float kinds
!
program test
  implicit none

  ! k1 and k2 will be large real kinds, if supported, and single/double
  ! otherwise
  integer, parameter :: k1 = &
    max(selected_real_kind(precision(0.d0) + 1), kind(0.))
  integer, parameter :: k2 = &
    max(selected_real_kind(precision(0._k1) + 1), kind(0.d0))

  real(kind=k1) :: d1(10), z1
  real(kind=k2) :: d2(10), z2
  d1 = 1 ; d2 = 1
  z1 = norm2 (d1)
  z2 = norm2 (d2)

  print *, z1, z2
end program test


    Program zheevr_example

!     ZHEEVR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zscal
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zheevr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E+0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol, vl, vu
      Integer :: i, ifail, il, info, iu, k, lda, ldz, liwork, lrwork, lwork, &
        m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), work(:), z(:, :)
      Complex (Kind=dp) :: dummy(1)
      Real (Kind=dp) :: rdum(1)
      Real (Kind=dp), Allocatable :: rwork(:), w(:)
      Integer :: idum(1)
      Integer, Allocatable :: isuppz(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, conjg, max, maxloc, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZHEEVR Example Program Results'
      Write (nout, *)
!     Skip heading in data file and read N and the lower and upper
!     indices of the smallest and largest eigenvalues to be found
      Read (nin, *)
      Read (nin, *) n, il, iu
      lda = n
      ldz = n
      m = n
      Allocate (a(lda,n), z(ldz,m), w(n), isuppz(2*m))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      lrwork = -1
      Call zheevr('Vectors', 'I', 'Upper', n, a, lda, vl, vu, il, iu, abstol, &
        m, w, z, ldz, isuppz, dummy, lwork, rdum, lrwork, idum, liwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+1)*n, nint(real(dummy(1))))
      lrwork = max(24*n, nint(rdum(1)))
      liwork = max(10*n, idum(1))
      Allocate (work(lwork), rwork(lrwork), iwork(liwork))

!     Read the upper triangular part of the matrix A from data file

      Read (nin, *)(a(i,i:n), i=1, n)

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value is used instead

      abstol = zero

!     Solve the symmetric eigenvalue problem

      Call zheevr('Vectors', 'I', 'Upper', n, a, lda, vl, vu, il, iu, abstol, &
        m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Selected eigenvalues'
        Write (nout, 100) w(1:m)
        Flush (nout)

!       Normalize the eigenvectors so that the element of largest absolute
!       value is real.
        Do i = 1, m
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          Call zscal(n, conjg(z(k,i))/cmplx(abs(z(k,i)),kind=dp), z(1,i), 1)
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)
      Else
        Write (nout, 110) 'Failure in ZHEEVR. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (1X, A, I5)
    End Program


! =============================================================================
!                       Test the vorticity inversion
!
!  This unit test checks the calculation of the velocity using the
!  Taylor-Green flow:
!               u = A * cos(a * x) * sin(b * y) * sin(c * z)
!               v = B * sin(a * x) * cos(b * y) * sin(c * z)
!               w = C * sin(a * x) * sin(b * y) * cos(c * z)
!  The vorticity of this flow is
!               xi = (b * C - c * B) * sin(a * x) * cos(b * y) * cos(c * z)
!              eta = (c * A - a * C) * cos(a * x) * sin(b * y) * cos(c * z)
!             zeta = (a * B - b * A) * cos(a * x) * cos(b * y) * sin(c * z)
! =============================================================================
program test_vor2vel_2
    use unit_test
    use constants, only : zero, one, two, four, pi, twopi, f12
    use parameters, only : lower, update_parameters, dx, nx, ny, nz, extent
    use fields, only : vortg, velog, velgradg, field_alloc
    use inversion_utils, only : init_fft, fftxyp2s
    use inversion_mod, only : vor2vel, vor2vel_timer
    use timer
    implicit none

    double precision              :: error
    double precision, allocatable :: velog_ref(:, :, :, :)
    integer                       :: ix, iy, iz
    double precision              :: x, y, z, AA, BB, CC, a, b, c

    call register_timer('vorticity', vor2vel_timer)

    nx = 64
    ny = 64
    nz = 64

    lower  = (/-pi, -pi, -f12 * pi/)
    extent =  (/twopi, twopi, twopi/)

    AA = one
    BB = one
    CC = -two
    a = one
    b = one
    c = one

    allocate(velog_ref(-1:nz+1, 0:ny-1, 0:nx-1, 3))

    call update_parameters

    call field_alloc

    do ix = 0, nx-1
        x = lower(1) + ix * dx(1)
        do iy = 0, ny-1
            y = lower(2) + iy * dx(2)
            do iz = -1, nz+1
                z = lower(3) + iz * dx(3)

                ! vorticity
                vortg(iz, iy, ix, 1) = (b * CC - c * BB) * dsin(a * x) * dcos(b * y) * dcos(c * z)
                vortg(iz, iy, ix, 2) = (c * AA - a * CC) * dcos(a * x) * dsin(b * y) * dcos(c * z)
                vortg(iz, iy, ix, 3) = (a * BB - b * AA) * dcos(a * x) * dcos(b * y) * dsin(c * z)

                ! velocity (reference solution)
                velog_ref(iz, iy, ix, 1) = AA * dcos(a * x) * dsin(b * y) * dsin(c * z)
                velog_ref(iz, iy, ix, 2) = BB * dsin(a * x) * dcos(b * y) * dsin(c * z)
                velog_ref(iz, iy, ix, 3) = CC * dsin(a * x) * dsin(b * y) * dcos(c * z)

            enddo
        enddo
    enddo

    call init_fft

    call vor2vel(vortg, velog, velgradg)

    error = maxval(dabs(velog_ref(0:nz, :, :, :) - velog(0:nz, :, :, :)))

    call print_result_dp('Test inversion (vorticity)', error, atol=2.0e-3)

    deallocate(velog_ref)

end program test_vor2vel_2


! Largest prime factor
!
! The prime factors of 13195 are 5, 7, 13 and 29.
! What is the largest prime factor of the number 600851475143 ?
module Problem3

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 3. Largest prime factor.'

        write (*, '(A, I)') 'Factor 1: ', factor()
    end subroutine

    function factor()
        integer*8 factor
        integer*8 index

        factor = 600851475143
        index  = 2

        do while ((index ** 2) .le. factor)
            if (mod(factor, index) .eq. 0) then
                factor = factor / index
            else
                index = index + 1
            end if
        end do
    end function
end module


! test.f90
module mymodule
use, intrinsic :: iso_fortran_env, only: real64
contains
subroutine eikR(a,k,n,M)
    implicit none

    integer,            intent(in)    :: n
    real(real64),       intent(in)    :: a(n)
    complex(real64),    intent(in)    :: k
    complex(real64),    intent(out)   :: M(n,n)

    ! Local
    integer                         :: i, j
    real(real64)  :: rtmp(n), sinp(n), cosp(n), tmp_exp(n)
    real(real64)  :: itmp(n), a_pow_2(n)

    complex(real64) :: imk
    real(real64) :: rimk
    real(real64) :: iimk, tmp

    imk = (0,1) * k
    rimk = real(imk)
    iimk = imag(imk)

    a_pow_2 = a * a

    !$OMP PARALLEL DO DEFAULT(private) SHARED(a_pow_2, M, n, rimk,iimk)
    do j=1,n

    rtmp = a_pow_2 + a_pow_2(j)
    call vdsqrt(n, rtmp, rtmp)

    ! real part
    call vdexp(n, rimk * rtmp, tmp_exp)

    ! imag part
    call vdsincos(n, iimk * rtmp, sinp, cosp)

    ! assemble output
    M(:, j) = cmplx(tmp_exp * cosp, tmp_exp * sinp)
    end do
    !$OMP END PARALLEL DO

end subroutine eikR
end module

program test
use, intrinsic :: iso_fortran_env, only: real64
use mymodule
use omp_lib
real(real64), parameter :: pi = 4*atan(1.0)
integer :: i, j, n
real(real64), allocatable :: a(:)
complex(real64) :: k
complex(real64), allocatable :: m(:, :)
real(real64) :: t1, t2
do i = 1, 10
   t1 = omp_get_wtime()
   n = 1000*i
   if(allocated(m)) deallocate(m)
   allocate(m(n, n))
   a = [(2*j*pi/(n - 1), j=0, n - 1)]
   k = cmplx(100.0, 1.0)
   call eikr(a, k, n, m)
   t2 = omp_get_wtime()
   print *, n, t2 - t1, 'seconds'
enddo
end program


      SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the incomplete Cholesky (ICC) factor of a symmetric
C     positive definite (s.p.d.) block Toeplitz matrix T, defined by
C     either its first block row, or its first block column, depending
C     on the routine parameter TYPET.
C
C     By subsequent calls of this routine, further rows / columns of
C     the Cholesky factor can be added.
C     Furthermore, the generator of the Schur complement of the leading
C     (P+S)*K-by-(P+S)*K block in T is available, which can be used,
C     e.g., for measuring the quality of the ICC factorization.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix; the ICC factor R is upper
C                     trapezoidal;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix; the ICC factor R is lower
C                     trapezoidal; this choice leads to better
C                     localized memory references and hence a faster
C                     algorithm.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     P       (input)  INTEGER
C             The number of previously computed block rows / columns
C             of R.  0 <= P <= N.
C
C     S       (input)  INTEGER
C             The number of block rows / columns of R to compute.
C             0 <= S <= N-P.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,(N-P)*K) / (LDT,K)
C             On entry, if P = 0, then the leading K-by-N*K / N*K-by-K
C             part of this array must contain the first block row /
C             column of an s.p.d. block Toeplitz matrix.
C             If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must
C             contain the negative generator of the Schur complement of
C             the leading P*K-by-P*K part in T, computed from previous
C             calls of this routine.
C             On exit, if INFO = 0, then the leading K-by-(N-P)*K /
C             (N-P)*K-by-K part of this array contains, in the first
C             K-by-K block, the upper / lower Cholesky factor of
C             T(1:K,1:K), in the following S-1 K-by-K blocks, the
C             Householder transformations applied during the process,
C             and in the remaining part, the negative generator of the
C             Schur complement of the leading (P+S)*K-by(P+S)*K part
C             in T.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),        if TYPET = 'R';
C             LDT >= MAX(1,(N-P)*K),  if TYPET = 'C'.
C
C     R       (input/output)  DOUBLE PRECISION array, dimension
C             (LDR, N*K)       / (LDR, S*K )     if P = 0;
C             (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0.
C             On entry, if P > 0, then the leading K-by-(N-P+1)*K /
C             (N-P+1)*K-by-K part of this array must contain the
C             nonzero blocks of the last block row / column in the
C             ICC factor from a previous call of this routine. Note that
C             this part is identical with the positive generator of
C             the Schur complement of the leading P*K-by-P*K part in T.
C             If P = 0, then R is only an output parameter.
C             On exit, if INFO = 0 and P = 0, then the leading
C             S*K-by-N*K / N*K-by-S*K part of this array contains the
C             upper / lower trapezoidal ICC factor.
C             On exit, if INFO = 0 and P > 0, then the leading
C             (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this
C             array contains the upper / lower trapezoidal part of the
C             P-th to (P+S)-th block rows / columns of the ICC factor.
C             The elements in the strictly lower / upper trapezoidal
C             part are not referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1, S*K ),        if TYPET = 'R' and P = 0;
C             LDR >= MAX(1, (S+1)*K ),    if TYPET = 'R' and P > 0;
C             LDR >= MAX(1, N*K ),        if TYPET = 'C' and P = 0;
C             LDR >= MAX(1, (N-P+1)*K ),  if TYPET = 'C' and P > 0.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -11,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N+1)*K,4*K),   if P = 0;
C             LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0.
C             For optimum performance LDWORK should be larger.
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:  the reduction algorithm failed; the Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite in its leading (P+S)*K-by-(P+S)*K part.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                               3
C     The algorithm requires 0(K S (N-P)) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, April 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001,
C     Mar. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPET
      INTEGER           INFO, K, LDR, LDT, LDWORK, N, P, S
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), R(LDR,*), T(LDT,*)
C     .. Local Scalars ..
      INTEGER           COUNTR, I, IERR, MAXWRK, ST, STARTR
      LOGICAL           ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF ( K.LT.0 ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN
         INFO = -4
      ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN
         INFO = -5
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN
         INFO = -7
      ELSE IF ( LDR.LT.1 .OR.
     $        ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR.
     $        ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR.
     $   ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR.
     $   ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN
        INFO = -9
      ELSE
         IF ( P.EQ.0 ) THEN
            COUNTR = ( N + 1 )*K
         ELSE
            COUNTR = ( N - P + 2 )*K
         END IF
         COUNTR = MAX( COUNTR, 4*K )
         IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN
            DWORK(1) = MAX( 1, COUNTR )
            INFO = -11
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02FD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N, S ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 1
C
      IF ( ISROW ) THEN
C
         IF ( P.EQ.0 ) THEN
C
C           T is the first block row of a block Toeplitz matrix.
C           Bring T to proper form by triangularizing its first block.
C
            CALL DPOTRF( 'Upper', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            IF ( N.GT.1 )
     $         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                     (N-1)*K, ONE, T, LDT, T(1,K+1), LDT )
            CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR )
C
            IF ( S.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            ST = 2
            COUNTR = ( N - 1 )*K
         ELSE
            ST = 1
            COUNTR = ( N - P )*K
         END IF
C
         STARTR = 1
C
         DO 10 I = ST, S
            CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR,
     $                   R(STARTR+K,STARTR+K), LDR )
            STARTR = STARTR + K
            COUNTR = COUNTR - K
            CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR,
     $                   T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1),
     $                   LDWORK-3*K, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K )
            CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K,
     $                   R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT,
     $                   T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1),
     $                   LDWORK-3*K, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K )
  10     CONTINUE
C
      ELSE
C
         IF ( P.EQ.0 ) THEN
C
C           T is the first block column of a block Toeplitz matrix.
C           Bring T to proper form by triangularizing its first block.
C
            CALL DPOTRF( 'Lower', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            IF ( N.GT.1 )
     $         CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                     (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT )
            CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR )
C
            IF ( S.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            ST = 2
            COUNTR = ( N - 1 )*K
         ELSE
            ST = 1
            COUNTR = ( N - P )*K
         END IF
C
         STARTR = 1
C
         DO 20 I = ST, S
            CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR,
     $                   R(STARTR+K,STARTR+K), LDR )
            STARTR = STARTR + K
            COUNTR = COUNTR - K
            CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR,
     $                   T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1),
     $                   LDWORK-3*K, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K )
            CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K,
     $                   R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT,
     $                   T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1),
     $                   LDWORK-3*K, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K )
  20     CONTINUE
C
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02FD ***
      END


! ============================================================================
subroutine tfluct1(maxnx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,adq)
! ============================================================================
!   "Internal" Riemann solver for the euler equations in 1D.
!   The riemann problem is solved by assuming a discontinuity at the
!   center of the i'th cell.
!
!   On input, ql contains the state vector at the left edge of each cell
!             qr contains the state vector at the right edge of each cell
!             auxl contains the auxiliary vector at the left edge of each cell
!             auxr contains the state vector at the right edge of each cell
!             maxnx is the number of physical points (without ghost cells)
!             mbc is the number of ghost cells
!             meqn is the number of equations
!             ixyz is the dimension index
!             mx is the size of the patch for the dimension corresponding
!               to the value of ixyz
!
!   On output, adq contains the decomposition of the flux difference
!              f(qr(i)) - f(ql(i)).
!
!   For the Euler equations q = (q1, q2, q3)^T,
!   where q1 = rho, q2 = rho*u, q3 = E and
!              _                                              _
!             |                       q2                       |
!   f(q) =    |        0.5(3-gamma)q2^2/q1 + (gamma-1)q3       |
!             |_  ( gamma*q3 - 0.5(gamma-1)q2^2/q1 ) * q2/g1  _|

    implicit none
    integer,          intent(in)  :: maxnx, mx, meqn, mwaves, maux, mbc
    double precision, intent(in)  :: auxl(maux,1-mbc:maxnx+mbc)
    double precision, intent(in)  :: auxr(maux,1-mbc:maxnx+mbc)
    double precision, intent(in)  ::   ql(meqn,1-mbc:maxnx+mbc)
    double precision, intent(in)  ::   qr(meqn,1-mbc:maxnx+mbc)

    double precision, intent(out) :: adq(meqn,1-mbc:maxnx+mbc)

    integer :: i
    double precision :: gamma, gamma1

!   local storage
!   ---------------
    common /cparam/  gamma

    gamma1 = gamma - 1.d0

    do i = 1,mx
        adq(1,i) = qr(2,i) - ql(2,i)
        adq(2,i) = 0.5d0*(3.d0-gamma)*(qr(2,i)**2/qr(1,i) - ql(2,i)**2/ql(1,i)) &
                    + gamma1*(qr(3,i) - ql(3,i))
        adq(3,i) = (gamma*qr(3,i)-0.5d0*gamma1*qr(2,i)**2/qr(1,i))*qr(2,i)/qr(1,i) &
                    - (gamma*ql(3,i)-0.5d0*gamma1*ql(2,i)**2/ql(1,i))*ql(2,i)/ql(1,i)
    enddo

    return
end subroutine tfluct1


      PROGRAM LOOPNESTED
        INTEGER A, I, J, RNDINT

C       Build a two-dimensional twenty-by-twenty array.
        DIMENSION A(20,20)

C       It doesn't matter what number you put here.
        CALL SDRAND(123)

C       Fill the array with random numbers.
        DO 20 I = 1, 20
          DO 10 J = 1, 20
            A(I, J) = RNDINT(1, 20)
   10     CONTINUE
   20   CONTINUE

C       Print the numbers.
        DO 40 I = 1, 20
          DO 30 J = 1, 20
            WRITE (*,5000) I, J, A(I, J)

C           If this number is twenty, break out of both loops.
            IF (A(I, J) .EQ. 20) GOTO 50
   30     CONTINUE
   40   CONTINUE

C       If we had gone to 40, the DO loop would have continued. You can
C       label STOP instead of adding another CONTINUE, but it is good
C       form to only label CONTINUE statements as much as possible.
   50   CONTINUE
        STOP

C       Print the value so that it looks like one of those C arrays that
C       makes everybody so comfortable.
 5000   FORMAT('A[', I2, '][', I2, '] is ', I2)
      END

C FORTRAN 77 does not have come with a random number generator, but it
C is easy enough to type "fortran 77 random number generator" into your
C preferred search engine and to copy and paste what you find. The
C following code is a slightly-modified version of:
C
C     http://www.tat.physik.uni-tuebingen.de/
C         ~kley/lehre/ftn77/tutorial/subprograms.html
      SUBROUTINE SDRAND (IRSEED)
        COMMON  /SEED/ UTSEED, IRFRST
        UTSEED = IRSEED
        IRFRST = 0
        RETURN
      END
      INTEGER FUNCTION RNDINT (IFROM, ITO)
        INTEGER IFROM, ITO
        PARAMETER (MPLIER=16807, MODLUS=2147483647,                     &
     &              MOBYMP=127773, MOMDMP=2836)
        COMMON  /SEED/ UTSEED, IRFRST
        INTEGER HVLUE, LVLUE, TESTV, NEXTN
        SAVE    NEXTN
        IF (IRFRST .EQ. 0) THEN
          NEXTN = UTSEED
          IRFRST = 1
        ENDIF
        HVLUE = NEXTN / MOBYMP
        LVLUE = MOD(NEXTN, MOBYMP)
        TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
        IF (TESTV .GT. 0) THEN
          NEXTN = TESTV
        ELSE
          NEXTN = TESTV + MODLUS
        ENDIF
        IF (NEXTN .GE. 0) THEN
          RNDINT = MOD(MOD(NEXTN, MODLUS), ITO - IFROM + 1) + IFROM
        ELSE
          RNDINT = MOD(MOD(NEXTN, MODLUS), ITO - IFROM + 1) + ITO + 1
        ENDIF
        RETURN
      END


module interface_definitions

! 	use constants

    interface

		! BLAS function for computation of L2 norm
    	function dnrm2( n, x, incx )
       		use constants
    		implicit none

    		! input variables
    		integer,intent(in) ::						n
    		real(kind=dbl), dimension(:), intent(in) :: x
    		integer, intent(in) ::						incx

    		! output variables
    		real(kind=dbl) :: 							dnrm2

    	end function dnrm2

		! LAPACK subroutine for solving system of linear equations
		subroutine dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
			use constants
			implicit none

			! input variables
			integer, intent(in) :: n
			integer, intent(in) :: nrhs
			integer, intent(in) :: lda
			integer, intent(in) :: ldb

			! output variables
			real(kind=dbl), dimension(lda,n), intent(inout) :: a
			integer, dimension(n), intent(out) :: ipiv
			real(kind=dbl), dimension(lda,nrhs), intent(inout) :: b
			integer, intent(out) :: info

		end subroutine dgesv

		! LAPACK subroutine for LU factorization
		subroutine dgetrf(m, n, a, lda, ipiv, info)
			use constants
			implicit none

			! input variables
			integer, intent(in) :: m
			integer, intent(in) :: n
			integer, intent(in) :: lda

			! output variables
			real(kind=dbl), dimension(lda,n), intent(inout) :: a
			integer, dimension(n), intent(out) :: ipiv
			integer, intent(out) :: info

		end subroutine dgetrf

		! LAPACK subroutine for computation of inverse matrix based on LU factorization
		subroutine dgetri(n, a, lda, ipiv, work, lwork, info)
			use constants
			implicit none

			! input variables
			integer, intent(in) :: n
			integer, intent(in) :: lda
			integer, intent(in) :: lwork
			integer, dimension(n), intent(in) :: ipiv

			! output variables
			real(kind=dbl), dimension(lda,n), intent(inout) :: a
			real(kind=dbl), dimension(lwork), intent(out) :: work
			integer, intent(out) :: info

		end subroutine dgetri

    end interface

end module interface_definitions


program ch2301
    ! Order Calculations
    use iso_fortran_env, wp => real64
    implicit none

    integer, parameter :: nn = 10
    integer :: n
    integer, dimension(1:nn) :: nvalues = [ 1, 10, &
        100, 1000, 10000, 100000, 1000000, 10000000, &
        100000000, 1000000000 ]
    integer :: i
    character(80) :: heading

    heading = ' i           n   O(1)       O(n)'
    heading = trim(heading) // &
        '        O(n*n) O(log n)    O(n log n)'
    print *, heading
    print *, ' '
    do i = 1, nn
        n = nvalues(i)
        print 100, i, n, order_1(), order_n(n), &
            order_n_squared(n), order_log_n(n), &
            order_n_log_n(n)
    end do

100 format (1x, i2, 2x, i10, 2x, i4, 2x, i10, &
    2x, e12.4, 2x, f7.2, 2x, e12.4)
contains
    integer function order_1()
        order_1 = 1
    end function

    integer function order_n(n)
        integer, intent(in) :: n

        order_n = n
    end function

    real(wp) function order_n_squared(n)
        integer, intent(in) :: n

        order_n_squared = dble(n)*dble(n)
    end function

    real function order_log_n(n)
        integer, intent(in) :: n

        order_log_n = log(real(n))
    end function

    real function order_n_log_n(n)
        integer, intent(in) :: n

        order_n_log_n = real(n)*log(real(n))
    end function
end program


      DOUBLE PRECISION FUNCTION DBESY0 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DBESY0 Krogh  Added external statement.
C>> 1995-11-13 DBESY0 Krogh  Changes to simplify conversion to C.
C>> 1994-11-11 DBESY0 Krogh   Declared all vars.
C>> 1994-10-20 DBESY0 Krogh  Changes to use M77CON
C>> 1990-11-29 DBESY0 CLL
C>> 1985-08-02 DBESY0 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--D replaces "?": ?BESY0, ?BESJ0, ?BMP0, ?INITS, ?CSEVL, ?ERM1
c     ------------------------------------------------------------------
      EXTERNAL D1MACH, DBESJ0, DCSEVL
      INTEGER NTY0
      DOUBLE PRECISION X, BY0CS(19), AMPL, THETA, TWODPI, XSML,
     1  Y, D1MACH, DCSEVL, DBESJ0
C
C SERIES FOR BY0        ON THE INTERVAL  0.          TO  1.60000D+01
C                                        WITH WEIGHTED ERROR   8.14D-32
C                                         LOG WEIGHTED ERROR  31.09
C                               SIGNIFICANT FIGURES REQUIRED  30.31
C                                    DECIMAL PLACES REQUIRED  31.73
C
      SAVE NTY0, XSML
C
      DATA BY0CS / -.1127783939286557321793980546028D-1,
     *  -.1283452375604203460480884531838D+0,
     *  -.1043788479979424936581762276618D+0,
     *  +.2366274918396969540924159264613D-1,
     *  -.2090391647700486239196223950342D-2,
     *  +.1039754539390572520999246576381D-3,
     *  -.3369747162423972096718775345037D-5,
     *  +.7729384267670667158521367216371D-7,
     *  -.1324976772664259591443476068964D-8,
     *  +.1764823261540452792100389363158D-10,
     *  -.1881055071580196200602823012069D-12,
     *  +.1641865485366149502792237185749D-14,
     *  -.1195659438604606085745991006720D-16,
     *  +.7377296297440185842494112426666D-19,
     *  -.3906843476710437330740906666666D-21,
     *  +.1795503664436157949829120000000D-23,
     *  -.7229627125448010478933333333333D-26,
     *  +.2571727931635168597333333333333D-28,
     *  -.8141268814163694933333333333333D-31     /
C
      DATA TWODPI / 0.636619772367581343075535053490057D0 /
      DATA NTY0, XSML / 0, 0.D0 /
C     ------------------------------------------------------------------
      IF (NTY0 .eq. 0) then
      call DINITS (BY0CS, 19, 0.1D0*D1MACH(3), NTY0)
      XSML = SQRT (4.0D0*D1MACH(3))
      endif
C
      IF (X .LE. 0.D0) THEN
        DBESY0 = 0.D0
        CALL DERM1 ('DBESY0',1,0,'X IS ZERO OR NEGATIVE','X',X,'.')
      ELSE IF (X .LE. 4.D0) THEN
        IF (X .LE. XSML) THEN
          Y = 0.D0
        ELSE
          Y = X * X
        END IF
        DBESY0 = TWODPI*LOG(0.5D0*X)*DBESJ0(X) + .375D0 +
     *            DCSEVL (.125D0*Y-1.D0, BY0CS, NTY0)
      ELSE
        CALL DBMP0 (X, AMPL, THETA)
        DBESY0 = AMPL * SIN(THETA)
      END IF
C
      RETURN
C
      END