c-----------------------------------------------------------------------
c Demonstration program for the DLSODKR package.
c This is the version of 15 June 2001.
c
c This version is in double precision.
c
c An ODE system is generated from the following 2-species diurnal
c kinetics advection-diffusion PDE system in 2 space dimensions:
c
c dc(i)/dt = Kh*(d/dx)**2 c(i) + V*dc(i)/dx + (d/dz)(Kv(z)*dc(i)/dz)
c                 + Ri(c1,c2,t)      for i = 1,2,   where
c   R1(c1,c2,t) = -q1*c1*c3 - q2*c1*c2 + 2*q3(t)*c3 + q4(t)*c2 ,
c   R2(c1,c2,t) =  q1*c1*c3 - q2*c1*c2 - q4(t)*c2 ,
c   Kv(z) = Kv0*exp(z/5) ,
c Kh, V, Kv0, q1, q2, and c3 are constants, and q3(t) and q4(t)
c vary diurnally.  The species are oxygen singlet and ozone.
c The problem is posed on the square
c   0 .le. x .le. 20,    30 .le. z .le. 50   (all in km),
c with homogeneous Neumann boundary conditions, and for time t in
c   0 .le. t .le. 86400 sec (1 day).
c
c The PDE system is treated by central differences on a uniform
c 10 x 10 mesh, with simple polynomial initial profiles.
c
c The problem is solved with DLSODKR, with the BDF/GMRES method and
c the block-diagonal part of the Jacobian as a left preconditioner.
c At intervals of 7200 sec (2 hrs), output includes sample values
c of c1, c2, and c2tot = total of all c2 values.
c
c Roots of the function g = d(c2tot)/dt are found, i.e. the points at
c which the total c2 (ozone) is stationary.
c
c Note: The preconditioner routines call LINPACK routines DGEFA, DGESL,
c and the BLAS routines DCOPY and DSCAL.
c-----------------------------------------------------------------------
      external fdem, jacbd, solbd, gdem
      integer mx, mz, mm, iout, istate, iwork, jacflg, jpre, jroot,
     1   jx, jz, leniw, lenrw, liw, lrw, mf, neq, nst, nsfi, nfe,
     2   nge, npe, njev, nps, nni, nli, ncfn, ncfl
      double precision q1,q2,q3,q4, a3,a4, om, c3, dz, hdco, vdco, haco,
     1   dkh, vel, dkv0, halfda, pi, twohr, rtol, floor,
     2   dx, atol, t, tout, x, cx, z, cz, y, rwork, c2tot, avdim
      common /pcom/ q1,q2,q3,q4,a3,a4,om,c3,dz,hdco,vdco,haco,mx,mz,mm
      dimension y(2,10,10), rwork(4264), iwork(235)
      data dkh/4.0d-6/, vel/0.001d0/, dkv0/1.0d-8/, halfda/4.32d4/,
     1  pi/3.1415926535898d0/, twohr/7200.0d0/, rtol/1.0d-5/,
     2  floor/100.0d0/, lrw/4264/, liw/235/, mf/22/, jpre/1/, jacflg/1/
c
c Load Common block of problem parameters.
      mx = 10
      mz = 10
      mm = mx*mz
      q1 = 1.63d-16
      q2 = 4.66d-16
      a3 = 22.62d0
      a4 = 7.601d0
      om = pi/halfda
      c3 = 3.7d16
      dx = 20.0d0/(mx - 1.0d0)
      dz = 20.0d0/(mz - 1.0d0)
      hdco = dkh/dx**2
      haco = vel/(2.0d0*dx)
      vdco = (1.0d0/dz**2)*dkv0
c Set other input arguments.
      atol = rtol*floor
      neq = 2*mx*mz
      iwork(1) = 8*mx*mz
      iwork(2) = neq
      iwork(3) = jpre
      iwork(4) = jacflg
      t = 0.0d0
      tout = 0.0d0
      istate = 1
c Set initial profiles.
      do 20 jz = 1,mz
        z = 30.0d0 + (jz - 1.0d0)*dz
        cz = (0.1d0*(z - 40.0d0))**2
        cz = 1.0d0 - cz + 0.5d0*cz**2
        do 10 jx = 1,mx
          x = (jx - 1.0d0)*dx
          cx = (0.1d0*(x - 10.0d0))**2
          cx = 1.0d0 - cx + 0.5d0*cx**2
          y(1,jx,jz) = 1.0d6*cx*cz
          y(2,jx,jz) = 1.0d12*cx*cz
 10       continue
 20     continue
c
c Write heading, problem parameters, solution parameters.
      write(6,30) mx, mz, mf, rtol, atol
 30   format('Demonstration program for DLSODKR package'//
     1       '2D diurnal kinetics-transport PDE system with 2 species'/
     2       'Spatial mesh is',i3,' by',i3/'Method flag is mf =',i3,
     3       '   Tolerances are rtol =',d8.1,'   atol =',d8.1/
     4       'Left preconditioner uses block-diagonal part of Jacobian'/
     5       'Root function finds stationary points of total ozone,'/
     6       '  i.e. roots of (d/dt)(sum of c2 over all mesh points)'/)
c
c Loop over output points, call DLSODKR, print sample solution values.
      do 70 iout = 1,13
 40     call dlsodkr (fdem, neq, y, t, tout, 1, rtol, atol, 1, istate,
     1      0, rwork, lrw, iwork, liw, jacbd, solbd, mf, gdem, 1, jroot)
        write(6,50) t,iwork(11),iwork(14),rwork(11)
 50     format(/' t =',d10.3,4x,'no. steps =',i5,
     1          '   order =',i2,'   stepsize =',d10.3)
        call c2sum (y, mx, mz, c2tot)
        write(6,60) y(1,1,1), y(1,5,5), y(1,10,10),
     1              y(2,1,1), y(2,5,5), y(2,10,10)
 60     format('   c1 (bot.left/middle/top rt.) =',3d12.3/
     1         '   c2 (bot.left/middle/top rt.) =',3d12.3)
        write(6,62)c2tot,jroot
 62     format('   total c2 =',d15.6,
     1         '   jroot =',i2' (1 = root found, 0 = no root)')
        if (istate .lt. 0) then
          write(6,65)istate
 65       format('DLSODKR returned istate = ',i3)
          go to 75
        endif
        if (istate .eq. 3) then
          istate = 2
          go to 40
        endif
        tout = tout + twohr
 70     continue
c
c Print final statistics.
 75   lenrw = iwork(17)
      leniw = iwork(18)
      nst = iwork(11)
      nsfi = iwork(24)
      nfe = iwork(12)
      nge = iwork(10)
      npe = iwork(13)
      njev = iwork(25)
      nps = iwork(21)
      nni = iwork(19)
      nli = iwork(20)
      avdim = real(nli)/real(nni)
      ncfn = iwork(22)
      ncfl = iwork(23)
      write (6,80) lenrw,leniw,nst,nsfi,nfe,nge,npe,njev,nps,nni,nli,
     1             avdim,ncfn,ncfl
 80   format(//' Final statistics:'/
     1 ' rwork size =',i5,5x,' iwork size =',i4/
     2 ' number of steps        =',i5,5x,'no. fnal. iter. steps  =',i5/
     3 ' number of f evals.     =',i5,5x,'number of g evals.     =',i5/
     4 ' number of prec. evals. =',i5,5x,'number of Jac. evals.  =',i5/
     5 ' number of prec. solves =',i5/
     6 ' number of nonl. iters. =',i5,5x,'number of lin. iters.  =',i5/
     7 ' average Krylov subspace dimension (nli/nni)  =',f8.4/
     8 ' number of conv. failures:  nonlinear =',i3,'  linear =',i3)
      stop
      end

      subroutine fdem (neq, t, y, ydot)
      integer neq,  mx, mz, mm,
     1   iblok, iblok0, idn, iup, ileft, iright, jx, jz
      double precision t, y(2,*), ydot(2,*),
     1   q1, q2, q3, q4, a3, a4, om, c3, dz, hdco, vdco, haco,
     2   c1, c1dn, c1up, c1lt, c1rt, c2, c2dn, c2up, c2lt, c2rt,
     3   czdn, czup, horad1, hord1, horad2, hord2, qq1, qq2, qq3, qq4,
     4   rkin1, rkin2, s, vertd1, vertd2, zdn, zup
      common /pcom/ q1,q2,q3,q4,a3,a4,om,c3,dz,hdco,vdco,haco,mx,mz,mm
c
c Set diurnal rate coefficients.
      s = sin(om*t)
      if (s .gt. 0.0d0) then
        q3 = exp(-a3/s)
        q4 = exp(-a4/s)
      else
        q3 = 0.0d0
        q4 = 0.0d0
      endif
c Loop over all grid points.
      do 20 jz = 1,mz
        zdn = 30.0d0 + (jz - 1.5d0)*dz
        zup = zdn + dz
        czdn = vdco*exp(0.2d0*zdn)
        czup = vdco*exp(0.2d0*zup)
        iblok0 = (jz-1)*mx
        idn = -mx
        if (jz .eq. 1) idn = mx
        iup = mx
        if (jz .eq. mz) iup = -mx
        do 10 jx = 1,mx
          iblok = iblok0 + jx
          c1 = y(1,iblok)
          c2 = y(2,iblok)
c Set kinetic rate terms.
          qq1 = q1*c1*c3
          qq2 = q2*c1*c2
          qq3 = q3*c3
          qq4 = q4*c2
          rkin1 = -qq1 - qq2 + 2.0d0*qq3 + qq4
          rkin2 = qq1 - qq2 - qq4
c Set vertical diffusion terms.
          c1dn = y(1,iblok+idn)
          c2dn = y(2,iblok+idn)
          c1up = y(1,iblok+iup)
          c2up = y(2,iblok+iup)
          vertd1 = czup*(c1up - c1) - czdn*(c1 - c1dn)
          vertd2 = czup*(c2up - c2) - czdn*(c2 - c2dn)
c Set horizontal diffusion and advection terms.
          ileft = -1
          if (jx .eq. 1) ileft = 1
          iright = 1
          if (jx .eq. mx) iright = -1
          c1lt = y(1,iblok+ileft)
          c2lt = y(2,iblok+ileft)
          c1rt = y(1,iblok+iright)
          c2rt = y(2,iblok+iright)
          hord1 = hdco*(c1rt - 2.0d0*c1 + c1lt)
          hord2 = hdco*(c2rt - 2.0d0*c2 + c2lt)
          horad1 = haco*(c1rt - c1lt)
          horad2 = haco*(c2rt - c2lt)
c Load all terms into ydot.
          ydot(1,iblok) = vertd1 + hord1 + horad1 + rkin1
          ydot(2,iblok) = vertd2 + hord2 + horad2 + rkin2
 10       continue
 20     continue
      return
      end

      subroutine gdem (neq, t, y, ng, gout)
      integer neq, ng,  mx, mz, mm,
     1   iblok, iblok0, idn, iup, ileft, iright, jx, jz
      double precision t, y(2,*), gout,
     1   q1, q2, q3, q4, a3, a4, om, c3, dz, hdco, vdco, haco,
     2   c1, c2, c2dn, c2up, c2lt, c2rt, c2dot, czdn, czup, horad2,
     3   hord2, qq1, qq2, qq4, rkin2, s, sum, vertd2, zdn, zup
      common /pcom/ q1,q2,q3,q4,a3,a4,om,c3,dz,hdco,vdco,haco,mx,mz,mm
c
c This routine computes the rates for c2 and adds them.
c
c Set diurnal rate coefficient q4.
      s = sin(om*t)
      if (s .gt. 0.0d0) then
        q4 = exp(-a4/s)
      else
        q4 = 0.0d0
      endif
      sum = 0.0d0
c Loop over all grid points.
      do 20 jz = 1,mz
        zdn = 30.0d0 + (jz - 1.5d0)*dz
        zup = zdn + dz
        czdn = vdco*exp(0.2d0*zdn)
        czup = vdco*exp(0.2d0*zup)
        iblok0 = (jz-1)*mx
        idn = -mx
        if (jz .eq. 1) idn = mx
        iup = mx
        if (jz .eq. mz) iup = -mx
        do 10 jx = 1,mx
          iblok = iblok0 + jx
          c1 = y(1,iblok)
          c2 = y(2,iblok)
c Set kinetic rate term for c2.
          qq1 = q1*c1*c3
          qq2 = q2*c1*c2
          qq4 = q4*c2
          rkin2 = qq1 - qq2 - qq4
c Set vertical diffusion terms for c2.
          c2dn = y(2,iblok+idn)
          c2up = y(2,iblok+iup)
          vertd2 = czup*(c2up - c2) - czdn*(c2 - c2dn)
c Set horizontal diffusion and advection terms for c2.
          ileft = -1
          if (jx .eq. 1) ileft = 1
          iright = 1
          if (jx .eq. mx) iright = -1
          c2lt = y(2,iblok+ileft)
          c2rt = y(2,iblok+iright)
          hord2 = hdco*(c2rt - 2.0d0*c2 + c2lt)
          horad2 = haco*(c2rt - c2lt)
c Load all terms into c2dot and sum.
          c2dot = vertd2 + hord2 + horad2 + rkin2
          sum = sum + c2dot
 10       continue
 20     continue
      gout = sum
      return
      end

      subroutine jacbd (f, neq, t, y, ysv, rewt, f0, f1, hl0, jok,
     1    bd, ipbd, ier)
      external f
      integer neq, jok, ipbd(2,*), ier, mx, mz, mm,
     1    iblok, iblok0, jx, jz, lenbd
      double precision t, y(2,*), ysv(neq), rewt(neq), f0(neq), f1(neq),
     1   hl0, bd(2,2,*),
     2   q1, q2, q3, q4, a3, a4, om, c3, dz, hdco, vdco, haco,
     3   c1, c2, czdn, czup, diag, temp, zdn, zup
      common /pcom/ q1,q2,q3,q4,a3,a4,om,c3,dz,hdco,vdco,haco,mx,mz,mm
c
        lenbd = 4*mm
c If jok = 1, copy saved block-diagonal approximate Jacobian into bd.
      if (jok .eq. 1) then
        call dcopy (lenbd, bd(1,1,mm+1), 1, bd, 1)
        go to 30
        endif
c
c If jok = -1, compute and save diagonal Jacobian blocks
c  (using q3 and q4 values computed on last f call).
      do 20 jz = 1,mz
        zdn = 30.0d0 + (jz - 1.5d0)*dz
        zup = zdn + dz
        czdn = vdco*exp(0.2d0*zdn)
        czup = vdco*exp(0.2d0*zup)
        diag = -(czdn + czup + 2.0d0*hdco)
        iblok0 = (jz-1)*mx
        do 10 jx = 1,mx
          iblok = iblok0 + jx
          c1 = y(1,iblok)
          c2 = y(2,iblok)
          bd(1,1,iblok) = (-q1*c3 - q2*c2) + diag
          bd(1,2,iblok) = -q2*c1 + q4
          bd(2,1,iblok) = q1*c3 - q2*c2
          bd(2,2,iblok) = (-q2*c1 - q4) + diag
 10       continue
 20     continue
      call dcopy (lenbd, bd, 1, bd(1,1,mm+1), 1)
c Scale by -hl0, add identity matrix and LU-decompose blocks.
 30   temp = -hl0
      call dscal (lenbd, temp, bd, 1)
      do 40 iblok = 1,mm
        bd(1,1,iblok) = bd(1,1,iblok) + 1.0d0
        bd(2,2,iblok) = bd(2,2,iblok) + 1.0d0
        call dgefa (bd(1,1,iblok), 2, 2, ipbd(1,iblok), ier)
        if (ier .ne. 0) return
 40     continue
      return
      end

      subroutine solbd (neq, t, y, f0, wk, hl0, bd, ipbd, v, lr, ier)
      integer neq, ipbd(2,*), lr, ier,  mx, mz, mm,  i
      double precision t, y(neq), f0(neq), wk(neq), hl0, bd(2,2,*),
     2   v(2,*),  q1, q2, q3, q4, a3, a4, om, c3, dz, hdco, vdco, haco
      common /pcom/ q1,q2,q3,q4,a3,a4,om,c3,dz,hdco,vdco,haco,mx,mz,mm
c Solve the block-diagonal system Px = v using LU factors stored in bd
c and pivot data in ipbd, and return the solution in v.
      ier = 0
      do 10 i = 1,mm
        call dgesl (bd(1,1,i), 2, 2, ipbd(1,i), v(1,i), 0)
 10     continue
      return
      end

      subroutine c2sum (y, mx, mz, c2tot)
      integer mx, mz, jx, jz
      double precision y(2,mx,mz), c2tot, sum
c Sum the c2 values.
      sum = 0.0d0
      do 20 jz = 1,mz
        do 20 jx = 1,mx
 20       sum = sum + y(2,jx,jz)
      c2tot = sum
      return
      end


        subroutine idz_housemat(n,vn,scal,h)
c
c       fills h with the Householder matrix
c       identity_matrix - scal * vn * adjoint(vn).
c
c       input:
c       n -- size of vn and h, though the indexing of vn goes
c            from 2 to n
c       vn -- entries 2 to n of the vector vn;
c             vn(1) is assumed to be 1
c       scal -- scalar multiplying vn * adjoint(vn)
c
c       output:
c       h -- identity_matrix - scal * vn * adjoint(vn)
c
        implicit none
        save
        integer n,j,k
        real*8 scal
        complex*16 vn(2:*),h(n,n),factor1,factor2
c
c
c       Fill h with the identity matrix.
c
        do j = 1,n
          do k = 1,n
c
            if(j .eq. k) h(k,j) = 1
            if(j .ne. k) h(k,j) = 0
c
          enddo ! k
        enddo ! j
c
c
c       Subtract from h the matrix scal*vn*adjoint(vn).
c
        do j = 1,n
          do k = 1,n
c
            if(j .eq. 1) factor1 = 1
            if(j .ne. 1) factor1 = vn(j)
c
            if(k .eq. 1) factor2 = 1
            if(k .ne. 1) factor2 = conjg(vn(k))
c
            h(k,j) = h(k,j) - scal*factor1*factor2
c
          enddo ! k
        enddo ! j
c
c
        return
        end


***********************************************************************
*                                                                     *
*     ACCUMULATECOLUMNROTATIONS.f:                                    *
*     Auxillary routine in the package PDGGHRD.                       *
*                                                                     *
*     Contributors: Björn Adlerborn                                   *
*                   Lars Karlsson                                     *
*                                                                     *
*     Department of Computing Science and HPC2N, Umea University      *
*                                                                     *
*                                                                     *
***********************************************************************
      SUBROUTINE ACCUMULATECOLUMNROTATIONS( QUERY, J0, N, NUMSEQ, DESC,
     $   CS, LDCS, NUMGROUPS, GROUPINFO, TRAFS, GTRAFPTR, INFO )

      IMPLICIT NONE

*
*     PURPOSE
*     =======
*
*     Forms and accumulates groups of rotations into orthogonal
*     matrices. TODO Expand the description of the purpose.
*
*
*     ARGUMENTS
*     =========
*
*     QUERY       (global input) LOGICAL
*
*                 Group information is computed and workspace
*                 requirements is returned when QUERY is set.
*
*     J0          (global input) INTEGER
*
*                 The first column affected by the rotations.
*
*     N           (global input) INTEGER
*
*                 The number of columns affected by the rotations.
*
*     NUMSEQ      (global input) INTEGER
*
*                 The number of rotation sequences.
*
*     DESC        (global/local input) INTEGER array
*                 dimension 9
*
*                 Descriptor for the matrix to be updated from the right
*                 by the accumulated rotations.
*
*     CS          (global input) DOUBLE PRECISION array
*                 dimension DESC( N_ ) x 2 * NUMSEQ
*
*                 The rotations themselves. The C parameters are stored
*                 in the odd-numbered columns and the S parameters in
*                 the even-numbered columns.
*
*     LDCS        (local input) INTEGER
*
*                 The column stride of CS.
*
*     NUMGROUPS   (global input/output) INTEGER
*
*                 The number of groups. Output when QUERY = .TRUE. and
*                 input otherwise.
*
*     GROUPINFO   (global input/output) INTEGER array
*                 dimension 12 x NUMGROUPS
*
*                 Table of information about each rotation group. Each
*                 column corresponds to one group. The first group
*                 corresponds to the first column. The rows of GROUPINFO
*                 have the following interpretation:
*
*                 1.  FIRSTCOLUMN - The first column affected by the group.
*                 2.  MIDDLECOLUMN - The column to the right of the distribution boundary.
*                 3.  LASTCOLUMN - The last coulmn affected by the group.
*                 4.  NUMCOLUMNS - The number of affected columns.
*                 5.  COLUMNSLEFT - The number of affected columns left of the distribution boundary.
*                 6.  COULMNSRIGHT - The number of affected colmns right of the distribution boundary.
*                 7.  SIZE - The size of the group.
*                 8.  ISLASTGROUP - 1: The last group, 0 otherwise.
*                 9.  HOMEMESHROW - The mesh row of the accumulating process.
*                 10. HOMEMESHCOL - The mesh column of the accumulating process.
*                 11. TRAFPTR - The location of the transformation matrix in memory.
*                 12. LDTRAF - The column stride of the transformation matrix.
*
*                 An upper bound for the number of required columns in GROUPINFO is
*                 ICEIL ( DESCA( N_ ), DESC( NB_ ) ) + 1
*
*     TRAFS       (local output) DOUBLE PRECISION array
*                 dimension MAX( GTRAFPTR - 1, 1 )
*
*                 The transformation matrices needed by this process.
*
*                 Referenced only when QUERY = .FALSE.
*
*     GTRAFPTR    (local input/output) INTEGER
*
*                 The size of the TRAFS array.
*
*                 Output when QUERY = .TRUE. and input otherwise.
*
*     INFO        (global output) INTEGER
*
*                 Status output.
*                 = 0: successful exit.
*
*

*
*     DECLARATIONS
*     ============
*

*
*     Constants.
*
      INTEGER CSRC_, CTXT_, LLD_, MB_, M_, NB_, N_, RSRC_
      DOUBLE PRECISION ZERO, ONE
      PARAMETER ( CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5 , NB_ = 6, RSRC_ =
     $   7, CSRC_ = 8, LLD_ = 9, ZERO = 0.0D+0, ONE = 1.0D+0 )

*
*     Scalar arguments.
*
      INTEGER N, J0, NUMSEQ, LDCS, INFO, GTRAFPTR
      LOGICAL QUERY

*
*     Array arguments.
*
      INTEGER DESC( 9 ), GROUPINFO( 12, * )
      DOUBLE PRECISION CS( LDCS, * ), TRAFS ( * )

*
*     Local scalars.
*
      INTEGER UDEF, ICTXT, NPROW, NPCOL, MYROW, MYCOL, IAM, NPROCS, NB,
     $   NUMGROUPS, LDTRAF, GROUP, LEFT, RIGHT, FIRSTCOLUMN,
     $   MIDDLECOLUMN ,LASTCOLUMN , SIZE, COLUMNSLEFT, COLUMNSRIGHT,
     $   NUMCOLUMNS, HOMEMESHROW, HOMEMESHCOL, TRAFPTR
      LOGICAL ISLASTGROUP

*
*     Externals.
*
      INTEGER INDXG2P, INDXG2L
      EXTERNAL INDXG2P, INDXG2L

*
*     EXECUTABLE STATEMENTS
*     =====================
*

*
*     Reset INFO.
*
      INFO = 0

*
*     TODO Description of the relationship between variables and groups.
*
*     Example of a regular group:
*
*
*     rots     x x x | c
*                x x | c x
*                  x | c x x
*                    | c x x x
*                    |     x x
*                    |       x
*     column 1 2 3 4 | 5 6 7 8
*            =       = =     =
*            F       d M     L
*            I       i I     A
*            R       s D     S
*            S       t D     T
*            T       . L     C
*            C       b E     O
*            O       o C     L
*            L       u O     U
*            U       n L     M
*            M       d U     N
*            N       a M
*                    r N
*                    y
*
*     SIZE = 4
*     ISLASTGROUP = .FALSE.
*     COLUMNSLEFT = 4
*     COLUMNSRIGHT = 4
*     NUMCOLUMNS = 8
*

*
*     Get process mesh information.
*
      ICTXT = DESC( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      CALL BLACS_PINFO( IAM, NPROCS )

*
*     Get the mesh rows of the left and right neighbours.
*
      LEFT = MODULO( MYCOL - 1, NPCOL )
      RIGHT = MODULO( MYCOL + 1, NPCOL )

*
*     Extract the distribution column block size.
*
      NB = DESC( NB_ )

*
*     Skip the query part unless requested.
*
      IF ( .NOT. QUERY )  GOTO 100

*
*     Reset the group counter.
*
      NUMGROUPS = 0

*
*     Set the offset in memory of the first transformation.
*
      GTRAFPTR = 1

*
*     Find the first affected column of the first group.
*
      FIRSTCOLUMN = J0

*
*     Always use process 0 as start for home mesh row
*
      HOMEMESHROW = 0

*
*     Loop until all rotations have been grouped.
*
      ISLASTGROUP = .FALSE.
      DO WHILE ( .NOT. ISLASTGROUP )
*
*        Count the new group.
*
         NUMGROUPS = NUMGROUPS + 1

*
*        Locate the first column on the right of the next distribution block boundary.
*
         MIDDLECOLUMN = 1 + NB * ((FIRSTCOLUMN + NB - 1) / NB)
*        Crop to submatrix boundary if necessary.
         IF ( MIDDLECOLUMN .GT. J0 + N - 1 ) THEN
            MIDDLECOLUMN = J0 + N
         END IF

*
*        Compute the size of the group.
*
         SIZE = MIDDLECOLUMN - FIRSTCOLUMN

*
*        Locate the last column affected by the group.
*
         LASTCOLUMN = MIDDLECOLUMN + NUMSEQ - 1
*        Crop to submatrix boundary if necessary.
         IF ( LASTCOLUMN .GT. J0 + N - 1 ) THEN
            LASTCOLUMN = J0 + N - 1
         END IF

*
*        Determine if this is the last group.
*
         ISLASTGROUP = (LASTCOLUMN .EQ. J0 + N - 1)

*
*        Compute the number of columns affected to the left and to the
*        right of the distribution boundary, respectively.
*
         COLUMNSLEFT = MIDDLECOLUMN - FIRSTCOLUMN
         COLUMNSRIGHT = LASTCOLUMN - MIDDLECOLUMN + 1

*
*        Compute the total number of affected columns.
*
         NUMCOLUMNS = LASTCOLUMN - FIRSTCOLUMN + 1

*
*        Locate the home mesh column of this group (i.e., the mesh
*        column to the right of the distribution block boundary).
*
         HOMEMESHCOL = MOD( 1 + INDXG2P( FIRSTCOLUMN, NB, UDEF,
     $      DESC(CSRC_ ), NPCOL ), NPCOL )

*
*        Populate a column of the GROUPINFO array.
*
         GROUPINFO( 1, NUMGROUPS ) = FIRSTCOLUMN
         GROUPINFO( 2, NUMGROUPS ) = MIDDLECOLUMN
         GROUPINFO( 3, NUMGROUPS ) = LASTCOLUMN
         GROUPINFO( 4, NUMGROUPS ) = NUMCOLUMNS
         GROUPINFO( 5, NUMGROUPS ) = COLUMNSLEFT
         GROUPINFO( 6, NUMGROUPS ) = COLUMNSRIGHT
         GROUPINFO( 7, NUMGROUPS ) = SIZE
         IF ( ISLASTGROUP ) THEN
            GROUPINFO( 8, NUMGROUPS ) = 1
         ELSE
            GROUPINFO( 8, NUMGROUPS ) = 0
         END IF
         GROUPINFO( 9, NUMGROUPS ) = MOD( HOMEMESHROW + ( NUMGROUPS - 1)
     $      / NPROW, NPROW )
         GROUPINFO( 10, NUMGROUPS ) = HOMEMESHCOL
         IF ( MYCOL .EQ. HOMEMESHCOL .OR. MYCOL .EQ. MODULO( HOMEMESHCOL
     $      - 1, NPCOL ) ) THEN
*
*           I need local storage for the transformation.
*
            LDTRAF = NUMCOLUMNS
            GROUPINFO( 11, NUMGROUPS ) = GTRAFPTR
            GROUPINFO( 12, NUMGROUPS ) = LDTRAF
            GTRAFPTR = GTRAFPTR + (NUMCOLUMNS * NUMCOLUMNS)
         ELSE
*
*           I will not use the transformation, so don't allocate storage for it.
*
            GROUPINFO( 11, NUMGROUPS ) = 1
            GROUPINFO( 12, NUMGROUPS ) = 1
         END IF

*
*        Locate the first affected row in the next group.
*
         FIRSTCOLUMN = MIDDLECOLUMN

*
*        Locate the next home mesh row.
*
         HOMEMESHROW = MOD( HOMEMESHROW + 1, NPROW )
      END DO

*
*     Query done; exit.
*
      RETURN

 100  CONTINUE

*
*     Non-query mode begins here.
*

*
*     Loop over all groups.
*
      DO GROUP = 1, NUMGROUPS
*
*        Extract cached group information.
*
         FIRSTCOLUMN   = GROUPINFO( 1, GROUP )
         MIDDLECOLUMN  = GROUPINFO( 2, GROUP )
         LASTCOLUMN    = GROUPINFO( 3, GROUP )
         NUMCOLUMNS    = GROUPINFO( 4, GROUP )
         COLUMNSLEFT   = GROUPINFO( 5, GROUP )
         COLUMNSRIGHT  = GROUPINFO( 6, GROUP )
         SIZE          = GROUPINFO( 7, GROUP )
         ISLASTGROUP   = GROUPINFO( 8, GROUP ) .EQ. 1
         HOMEMESHROW   = GROUPINFO( 9, GROUP )
         HOMEMESHCOL   = GROUPINFO( 10, GROUP )
         TRAFPTR       = GROUPINFO( 11, GROUP )
         LDTRAF        = GROUPINFO( 12, GROUP )

*
*        If I am the home process, then ...
*
         IF ( MYROW .EQ. HOMEMESHROW .AND. MYCOL .EQ. HOMEMESHCOL ) THEN
*
*           Reset the transformation matrix to the identity matrix.
*
            CALL KRNLACCUMULATECOLUMNROTATIONS( NUMCOLUMNS, NUMSEQ, SIZE
     $         , TRAFS( TRAFPTR ), LDTRAF, CS( FIRSTCOLUMN, 1 ), LDCS,
     $         ISLASTGROUP )
         END IF
      END DO

*
*     Loop over the groups.
*
      DO GROUP = 1, NUMGROUPS
*
*        Extract cached group information.
*
         NUMCOLUMNS  = GROUPINFO( 4, GROUP )
         HOMEMESHROW = GROUPINFO( 9, GROUP )
         HOMEMESHCOL = GROUPINFO( 10, GROUP )
         TRAFPTR     = GROUPINFO( 11, GROUP )
         LDTRAF      = GROUPINFO( 12, GROUP )

*
*        If I am the home process, then ...
*
         IF ( MYROW .EQ. HOMEMESHROW .AND. MYCOL .EQ. HOMEMESHCOL ) THEN
            IF ( NPCOL .GT. 1 ) THEN
*
*              Send the transformation matrix to the left.
*
               CALL DGESD2D( ICTXT, NUMCOLUMNS, NUMCOLUMNS,
     $            TRAFS(TRAFPTR), LDTRAF, MYROW, LEFT )
            END IF

            IF ( NPROW .GT. 1 ) THEN
*
*              Broadcast the transformation matrix along the mesh column.
*
               CALL DGEBS2D( ICTXT, 'C', ' ', NUMCOLUMNS, NUMCOLUMNS,
     $            TRAFS( TRAFPTR ), LDTRAF )
            END IF

*
*        else If I am left of the home process, then ...
*
         ELSE IF ( MYCOL .EQ. MODULO( HOMEMESHCOL - 1, NPCOL ) .AND.
     $         MYROW .EQ. HOMEMESHROW ) THEN
            IF ( NPCOL .GT. 1 ) THEN
*
*              Receive the transformation matrix from the right.
*
               CALL DGERV2D( ICTXT, NUMCOLUMNS, NUMCOLUMNS, TRAFS(
     $            TRAFPTR ), LDTRAF, MYROW, RIGHT )
            END IF

            IF ( NPROW .GT. 1 ) THEN
*
*              Broadcast the transformation matrix along the mesh column.
*
               CALL DGEBS2D( ICTXT, 'C', ' ', NUMCOLUMNS, NUMCOLUMNS,
     $            TRAFS( TRAFPTR ), LDTRAF )
            END IF

*
*        else If I will need this transformation later but am not on the home
*        mesh column, then ...
*
         ELSE IF ( ( MYCOL .EQ. HOMEMESHCOL .OR. MYCOL .EQ.
     $         MODULO(HOMEMESHCOL - 1, NPCOL ) ) .AND. MYROW .NE.
     $         HOMEMESHROW ) THEN
            IF ( NPROW .GT. 1 ) THEN
*
*              Broadcast receive the transformation matrix along the mesh row.
*
               CALL DGEBR2D( ICTXT, 'C', ' ', NUMCOLUMNS, NUMCOLUMNS,
     $            TRAFS( TRAFPTR ), LDTRAF, HOMEMESHROW, MYCOL )
            END IF
         END IF
      END DO

      RETURN

      END


program testselectionsort
        integer lst(10)
        lst = (/ 10, 9, 8, 4, 5, 6, 7, 3, 2, 1 /)
        call selectionsort(lst, 1, 10)
        call show(lst)
end program testselectionsort

subroutine selectionsort(lst, a, b)
        integer a
        integer b
        integer lst(10)
        integer i
        integer j
        integer min_id
        integer tmp
        do i = a, b-1
            min_id = i
            do j = i+1, b
                if (lst(min_id) .gt. lst(j)) then
                    min_id = j
                end if
            end do
            tmp = lst(i)
            lst(i) = lst(min_id)
            lst(min_id) = tmp
        end do
end

subroutine show(lst)
        integer lst(10)
        integer x
        do x = 1, 10
                print 100, lst(x)
        end do

100 format (i0)
end


(((23 = 7) <=> (19 = 2)) /\ ~(2 = 3))
(((31 = 29) \/ ~(14 != 25)) <=> (18 != 3))
(((28 = 35) \/ ~(10 != 9)) X ~(14 = 21))
((~(3 != 22) <=> (31 != 6)) X (30 = 34))
(((16 != 31) X (18 != 22)) /\ ~(33 = 7))
((~(20 != 30) \/ ~(26 != 18)) /\ (6 != 25))
(((24 != 38) /\ (36 = 15)) \/ (14 = 33))
(((7 = 4) X (8 = 5)) \/ ~(37 = 19))
(((39 != 22) /\ ~(23 != 37)) /\ (2 = 32))
((~(15 = 2) \/ (3 = 33)) \/ ~(11 = 20))
(((20 = 16) => ~(3 = 6)) <=> (22 = 7))
(((14 != 33) \/ (37 != 36)) => (23 = 28))
(((35 != 18) X (38 != 34)) X (40 = 21))
(((40 != 4) /\ ~(28 = 33)) => (22 != 14))
(((10 = 30) => (1 = 14)) \/ (23 = 26))
(((26 != 9) \/ (6 != 22)) X ~(38 = 40))
(((11 = 37) => (36 != 11)) <=> ~(25 = 15))
(((20 != 5) /\ (11 = 37)) X ~(25 = 5))
((~(30 = 17) <=> ~(40 = 26)) /\ (11 != 14))
(((31 = 28) <=> (26 != 40)) \/ ~(22 = 29))
((~(30 = 31) => ~(25 != 35)) \/ (34 != 23))
(((4 != 6) /\ (34 = 29)) X (9 = 25))
(((11 != 8) <=> ~(16 != 35)) \/ (2 = 8))
(((32 = 27) => (33 != 2)) /\ ~(9 = 39))
(((36 = 35) X ~(22 = 3)) => ~(40 != 29))
((~(12 != 25) <=> (25 != 27)) => ~(14 != 11))
(((22 != 20) /\ (5 != 7)) /\ (36 != 17))
((~(40 != 27) X (26 = 25)) /\ ~(21 = 15))
((~(28 != 22) <=> (21 != 3)) X (1 = 4))
((~(36 != 25) X (19 != 28)) X ~(26 = 22))
(((19 = 16) <=> (35 = 21)) \/ (40 = 18))
(((10 != 23) /\ (31 != 33)) /\ (26 != 16))
(((34 != 19) /\ (32 != 5)) => (37 != 27))
(((37 = 28) \/ (15 = 4)) X (21 != 15))
((~(9 != 2) /\ (16 != 1)) X (16 != 28))
(((22 = 32) /\ ~(18 = 37)) => (40 != 30))
((~(28 != 34) <=> ~(14 = 15)) => (39 != 38))
((~(14 = 13) <=> (20 = 9)) /\ ~(32 != 15))
(((5 = 38) <=> (38 = 16)) <=> (23 != 36))
((~(24 != 5) <=> (4 = 32)) /\ (13 = 10))
(((7 = 3) /\ ~(4 = 3)) /\ (7 != 11))
(((13 = 28) /\ (37 != 33)) <=> ~(5 = 31))
(((34 = 1) X (38 != 3)) X (29 != 5))
((~(14 = 33) X ~(1 != 17)) => (11 = 38))
(((6 = 35) \/ (8 != 11)) <=> ~(16 != 9)) 0


program test_daykm
  use simsphere_mod, only: hgt, ustar, mol, km, ntrp, deltaz, zi, zk, za, eq, &
    Vert_Spacing
  use mod_testing, only: assert, initialize_tests, report_tests
  use, intrinsic :: ieee_arithmetic
  implicit none

  ! mod_testing setup
  logical, dimension(:), allocatable :: tests
  logical :: test_failed
  integer :: i, n, ntests

  real :: arg1

  ! Three cases:
  !
  !    1) HGT=ZA, MOL=0.0, USTAR=3.0 (USTAR and MOL don't matter in this case)
  !    2) HGT=1200, MOL=-400.0, USTAR=6.0
  !    3) HGT=2100, MOL=-800.0, USTAR=9.0
  !
  ! Expected results:
  !
  real, parameter, dimension(50) :: km_I_exp = 0.0

  real, parameter, dimension(50) :: km_II_exp = (/156.257446,670.694214,  &
                                                  921.362793,647.406067,   &
                                                  234.105774,31.7086887,   &
                                                  0.0,0.0,0.0,0.0,         &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0/)

  real, parameter, dimension(50) :: km_III_exp = (/212.364990,1016.39429,  &
                                                  1794.22278,2026.54041,   &
                                                  1858.56458,1435.51331,   &
                                                  902.604553,405.056061,   &
                                                  88.0854797,2.62376094,   &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0/)

  real, parameter :: thick_I_exp = 0.0
  real, parameter :: thick_II_exp = 1150.0
  real, parameter :: thick_III_exp = 2050.0

  n = 1
  ntests = 6
  call initialize_tests(tests,ntests)

  if (ieee_support_rounding(IEEE_NEAREST)) then
    call ieee_set_rounding_mode(IEEE_NEAREST)
  end if

  ! Setup
  ntrp = 10
  do i=0,ntrp
  zi(i+1) = 50 + i*Vert_Spacing
  end do

  ! Case I
  hgt = za
  mol = 0.0
  ustar = 3.0
  call daykm(arg1)
  !write(6,*) 'Case I: thick= ',arg1
  !write(6,*) 'Case I: km: ',km
  !write(6,*) 'Case I: km_I_exp: ',km_I_exp
  tests(n) = assert(eq(km,km_I_exp), 'daykm km case I')
  n = n + 1
  tests(n) = assert(eq(arg1,thick_I_exp), 'daykm thick case I')
  n = n + 1

  ! Case II
  hgt = 1200
  mol = -400.0
  ustar = 6.0
  call daykm(arg1)
  !write(6,*) 'Case II: thick= ',arg1
  !write(6,*) 'Case II: km: ',km
  !write(6,*) 'Case II: km_II_exp: ',km_II_exp
  tests(n) = assert(eq(km,km_II_exp), 'daykm km case II')
  n = n + 1
  tests(n) = assert(eq(arg1,thick_II_exp), 'daykm thick case II')
  n = n + 1

  ! Case III
  hgt = 2100
  mol = -800.0
  ustar = 9.0
  call daykm(arg1)
  !write(6,*) 'Case III: thick= ',arg1
  !write(6,*) 'Case III: km: ',km
  !write(6,*) 'Case III: km_III_exp: ',km_III_exp
  tests(n) = assert(eq(km,km_III_exp), 'daykm km case III')
  n = n + 1
  tests(n) = assert(eq(arg1,thick_III_exp), 'daykm thick case III')
  n = n + 1

  test_failed = .false.
  call report_tests(tests,test_failed)
  if (test_failed) stop 1

end program test_daykm


program main
    use plantfem
    implicit none

    type(FEMDomain_) :: domain

    call domain%create(meshtype="Cube",x_num=10,y_num=10,z_num=10)
    call domain%resize(x=1.0d0, y=3.0d0, z=10.0d0)
    call domain%json(name="domain.json")
    call domain%msh(name="domain.msh")

end program main


*DECK CBESK
      SUBROUTINE CBESK (Z, FNU, KODE, N, CY, NZ, IERR)
C***BEGIN PROLOGUE  CBESK
C***PURPOSE  Compute a sequence of the Bessel functions K(a,z) for
C            complex argument z and real nonnegative orders a=b,b+1,
C            b+2,... where b>0.  A scaling option is available to
C            help avoid overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10B4
C***TYPE      COMPLEX (CBESK-C, ZBESK-C)
C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS,
C             MODIFIED BESSEL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C         On KODE=1, CBESK computes an N member sequence of complex
C         Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative
C         orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut
C         plane -pi<arg(Z)<=pi.  On KODE=2, CBESJ returns the scaled
C         functions
C
C            CY(L) = exp(Z)*K(FNU+L-1,Z),  L=1,...,N
C
C         which remove the exponential growth in both the left and
C         right half planes as Z goes to infinity.  Definitions and
C         notation are found in the NBS Handbook of Mathematical
C         Functions (Ref. 1).
C
C         Input
C           Z      - Nonzero argument of type COMPLEX
C           FNU    - Initial order of type REAL, FNU>=0
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            CY(L)=K(FNU+L-1,Z), L=1,...,N
C                        =2  returns
C                            CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N
C           N      - Number of terms in the sequence, N>=1
C
C         Output
C           CY     - Result vector of type COMPLEX
C           NZ     - Number of underflows set to zero
C                    NZ=0    Normal return
C                    NZ>0    CY(L)=0 for NZ values of L (if Re(Z)>0
C                            then CY(L)=0 for L=1,...,NZ; in the
C                            complementary half plane the underflows
C                            may not be in an uninterrupted sequence)
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (abs(Z) too small and/or FNU+N-1
C                            too large)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has half precision or less
C                            because abs(Z) or FNU+N-1 is large)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision because
C                            abs(Z) or FNU+N-1 is too large)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         Equations of the reference are implemented to compute K(a,z)
C         for small orders a and a+1 in the right half plane Re(z)>=0.
C         Forward recurrence generates higher orders.  The formula
C
C            K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z),  Re(z)>0
C                         t = i*pi or -i*pi
C
C         continues K to the left half plane.
C
C         For large orders, K(a,z) is computed by means of its uniform
C         asymptotic expansion.
C
C         For negative orders, the formula
C
C            K(-a,z) = K(a,z)
C
C         can be used.
C
C         CBESK assumes that a significant digit sinh function is
C         available.
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z or FNU+N-1 is
C         large, losses of significance by argument reduction occur.
C         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
C         losses exceeding half precision are likely and an error flag
C         IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF.  Also,
C         if either is larger than U2=0.5/UR, then all significance is
C         lost and IERR=4.  In order to use the INT function, arguments
C         must be further restricted not to exceed the largest machine
C         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
C         makes U2 limiting in single precision and U3 limiting in
C         double precision.  This means that one can expect to retain,
C         in the worst cases on IEEE machines, no digits in single pre-
C         cision and only 6 digits in double precision.  Similar con-
C         siderations hold for other machines.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component.  In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument, Report SAND83-0086, Sandia National
C                 Laboratories, Albuquerque, NM, May 1983.
C               3. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               4. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               5. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  CACON, CBKNU, CBUNK, CUOIK, I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C***END PROLOGUE  CBESK
C
      COMPLEX CY, Z
      REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5,
     * TOL, UFL, XX, YY, R1MACH, BB
      INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
      DIMENSION CY(N)
C***FIRST EXECUTABLE STATEMENT  CBESK
      IERR = 0
      NZ=0
      XX = REAL(Z)
      YY = AIMAG(Z)
      IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      NN = N
C-----------------------------------------------------------------------
C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
C-----------------------------------------------------------------------
      TOL = MAX(R1MACH(4),1.0E-18)
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN(ABS(K1),ABS(K2))
      ELIM = 2.303E0*(K*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*K1
      DIG = MIN(AA,18.0E0)
      AA = AA*2.303E0
      ALIM = ELIM + MAX(-AA,-41.45E0)
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
      RL = 1.2E0*DIG + 3.0E0
      AZ = ABS(Z)
      FN = FNU + (NN-1)
C-----------------------------------------------------------------------
C     TEST FOR RANGE
C-----------------------------------------------------------------------
      AA = 0.5E0/TOL
      BB=I1MACH(9)*0.5E0
      AA=MIN(AA,BB)
      IF(AZ.GT.AA) GO TO 210
      IF(FN.GT.AA) GO TO 210
      AA=SQRT(AA)
      IF(AZ.GT.AA) IERR=3
      IF(FN.GT.AA) IERR=3
C-----------------------------------------------------------------------
C     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
C-----------------------------------------------------------------------
C     UFL = EXP(-ELIM)
      UFL = R1MACH(1)*1.0E+3
      IF (AZ.LT.UFL) GO TO 180
      IF (FNU.GT.FNUL) GO TO 80
      IF (FN.LE.1.0E0) GO TO 60
      IF (FN.GT.2.0E0) GO TO 50
      IF (AZ.GT.TOL) GO TO 60
      ARG = 0.5E0*AZ
      ALN = -FN*ALOG(ARG)
      IF (ALN.GT.ELIM) GO TO 180
      GO TO 60
   50 CONTINUE
      CALL CUOIK(Z, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM)
      IF (NUF.LT.0) GO TO 180
      NZ = NZ + NUF
      NN = NN - NUF
C-----------------------------------------------------------------------
C     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
C     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
C-----------------------------------------------------------------------
      IF (NN.EQ.0) GO TO 100
   60 CONTINUE
      IF (XX.LT.0.0E0) GO TO 70
C-----------------------------------------------------------------------
C     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0.
C-----------------------------------------------------------------------
      CALL CBKNU(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 200
      NZ=NW
      RETURN
C-----------------------------------------------------------------------
C     LEFT HALF PLANE COMPUTATION
C     PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2.
C-----------------------------------------------------------------------
   70 CONTINUE
      IF (NZ.NE.0) GO TO 180
      MR = 1
      IF (YY.LT.0.0E0) MR = -1
      CALL CACON(Z, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM,
     * ALIM)
      IF (NW.LT.0) GO TO 200
      NZ=NW
      RETURN
C-----------------------------------------------------------------------
C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
C-----------------------------------------------------------------------
   80 CONTINUE
      MR = 0
      IF (XX.GE.0.0E0) GO TO 90
      MR = 1
      IF (YY.LT.0.0E0) MR = -1
   90 CONTINUE
      CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM)
      IF (NW.LT.0) GO TO 200
      NZ = NZ + NW
      RETURN
  100 CONTINUE
      IF (XX.LT.0.0E0) GO TO 180
      RETURN
  180 CONTINUE
      NZ = 0
      IERR=2
      RETURN
  200 CONTINUE
      IF(NW.EQ.(-1)) GO TO 180
      NZ=0
      IERR=5
      RETURN
  210 CONTINUE
      NZ=0
      IERR=4
      RETURN
      END


module quarter_sine_transform_routines

    use auxiliary_routines

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use real_transform_routines

    use quarter_cosine_transform_routines

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: sinq1i, sinq1b, sinq1f, sinqmi, sinqmb, sinqmf

    !---------------------------------------------------------------------------------
    ! Variables confined to the module
    !---------------------------------------------------------------------------------
    real (wp), parameter :: ZERO = 0.0_wp
    real (wp), parameter :: HALF = 0.5_wp
    real (wp), parameter :: ONE = 1.0_wp
    real (wp), parameter :: TWO = 2.0_wp
    real (wp), parameter :: THREE = 3.0_wp
    real (wp), parameter :: FOUR = 4.0_wp
    real (wp), parameter :: FIVE = 5.0_wp
    !---------------------------------------------------------------------------------

contains

    subroutine sinq1b(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! sinq1b: real backward sine quarter wave transform, 1d.
        !
        !  purpose:
        !
        !  computes the one-dimensional fourier transform of a sequence
        !  which is a sine series with odd wave numbers.  this transform is
        !  referred to as the backward transform or fourier synthesis,
        !  transforming the sequence from spectral to physical space.
        !
        !  this transform is normalized since a call to sinq1b followed
        !  by a call to sinq1f (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), on input, the sequence to be
        !  transformed.  on output, the transformed sequence.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sinq1i before the first call to routine sinq1f
        !  or sinq1b for a given transform length n.  wsave's contents may be
        !  re-used for subsequent calls to sinq1f and sinq1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least n.
        !
        !  integer ier, the error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) n
        integer (ip) ns2
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)
        real (wp) xhold

        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sinq1b', 6)
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinq1b', 8)
        else if (lenwrk < n) then
            ier = 3
            call fft_error_handler('sinq1b', 10)
        else
            ier = 0
        end if

        if (1 >= n) then
            !
            !   x(1,1) = 4.*x(1,1) line disabled by dick valent 08/26/2010
            !
            return
        else
            ns2 = n/2
            x(1,2:n:2) = -x(1,2:n:2)

            call cosq1b(n,inc,x,lenx,wsave,lensav,work,lenwrk,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sinq1b',-5)
                return
            end if

            do k=1,ns2
                kc = n-k
                xhold = x(1,k)
                x(1,k) = x(1,kc+1)
                x(1,kc+1) = xhold
            end do
        end if

    end subroutine sinq1b

    subroutine sinq1f(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! sinq1f: real forward sine quarter wave transform, 1d.
        !
        !  purpose:
        !
        !  computes the one-dimensional fourier transform of a sequence
        !  which is a sine series of odd wave numbers.  this transform is
        !  referred to as the forward transform or fourier analysis, transforming
        !  the sequence from physical to spectral space.
        !
        !  this transform is normalized since a call to sinq1f followed
        !  by a call to sinq1b (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), on input, the sequence to be
        !  transformed.  on output, the transformed sequence.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sinq1i before the first call to routine sinq1f
        !  or sinq1b for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sinq1f and sinq1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least n.
        !
        !  integer ier, the error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) n
        integer (ip) ns2
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)
        real (wp) xhold

        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sinq1f', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinq1f', 8)
            return
        else if (lenwrk < n) then
            ier = 3
            call fft_error_handler('sinq1f', 10)
            return
        else
            ier = 0
        end if

        if (n /= 1) then
            ns2 = n/2
            do k=1,ns2
                kc = n-k
                xhold = x(1,k)
                x(1,k) = x(1,kc+1)
                x(1,kc+1) = xhold
            end do

            call cosq1f(n,inc,x,lenx,wsave,lensav,work,lenwrk,local_error_flag)

            ! check error_flag
            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sinq1f',-5)
                return
            end if

            x(1,2:n:2) = -x(1,2:n:2)
        end if

    end subroutine sinq1f

    subroutine sinq1i(n, wsave, lensav, ier)
        !
        !  sinq1i: initialization for sinq1b and sinq1f.
        !
        !  purpose:
        !
        !  initializes array wsave for use in its companion routines
        !  sinq1f and sinq1b. the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave. separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors
        !  of n and also containing certain trigonometric values which will be used
        ! in routines sinq1b or sinq1f.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) lensav
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) n
        real (wp) wsave(lensav)

        if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinq1i', 3)
            return
        else
            ier = 0
        end if

        call cosq1i(n, wsave, lensav, local_error_flag)

        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sinq1i',-5)
        end if

    end subroutine sinq1i

    subroutine sinqmb(lot, jump, n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! sinqmb: real backward sine quarter wave, multiple vectors.
        !
        !  purpose:
        !
        !  sinqmb computes the one-dimensional fourier transform of multiple
        !  sequences within a real array, where each of the sequences is a
        !  sine series with odd wave numbers.  this transform is referred to as
        !  the backward transform or fourier synthesis, transforming the
        !  sequences from spectral to physical space.
        !
        !  this transform is normalized since a call to sinqmb followed
        !  by a call to sinqmf (or vice-versa) reproduces the original
        !  array  within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within array r.
        !
        !  integer jump, the increment between the locations, in
        !  array r, of the first elements of two consecutive sequences to be
        !  transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), containing lot sequences, each
        !  having length n.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.  on input, r contains the data
        !  to be transformed, and on output the transformed data.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sinqmi before the first call to routine sinqmf
        !  or sinqmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sinqmf and sinqmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*n.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lj
        integer (ip) lot
        integer (ip) m
        integer (ip) n
        integer (ip) ns2
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)
        real (wp) xhold

        if (lenx < (lot-1)*jump + inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sinqmb', 6)
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinqmb', 8)
        else if (lenwrk < lot*n) then
            ier = 3
            call fft_error_handler('sinqmb', 10)
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ier = 4
            call fft_error_handler('sinqmb', -1)
        else
            ier = 0
        end if

        lj = (lot-1)*jump+1

        if (1 >= n ) then
            x(1:lj:jump,1) =  FOUR * x(1:lj:jump,1)
        else
            ns2 = n/2
            x(2:n:2,1:lj:jump) = -x(1:lj:jump,2:n:2)

            call cosqmb(lot,jump,n,inc,x,lenx,wsave,lensav,work,lenwrk,local_error_flag)

            ! Check error_flag
            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sinqmb',-5)
                return
            end if

            do k=1,ns2
                kc = n-k
                do m=1,lj,jump
                    xhold = x(m,k)
                    x(m,k) = x(m,kc+1)
                    x(m,kc+1) = xhold
                end do
            end do
        end if

    end subroutine sinqmb

    subroutine sinqmf(lot, jump, n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! sinqmf: real forward sine quarter wave, multiple vectors.
        !
        !  purpose:
        !
        !  sinqmf computes the one-dimensional fourier transform of multiple
        !  sequences within a real array, where each sequence is a sine series
        !  with odd wave numbers.  this transform is referred to as the forward
        !  transform or fourier synthesis, transforming the sequences from
        !  spectral to physical space.
        !
        !  this transform is normalized since a call to sinqmf followed
        !  by a call to sinqmb (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within array r.
        !
        !  integer jump, the increment between the locations,
        !  in array r, of the first elements of two consecutive sequences to
        !  be transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), containing lot sequences, each
        !  having length n.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.  on input, r contains the data
        !  to be transformed, and on output the transformed data.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sinqmi before the first call to routine sinqmf
        !  or sinqmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sinqmf and sinqmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*n.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lj
        integer (ip) lot
        integer (ip) m
        integer (ip) n
        integer (ip) ns2
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)
        real (wp) xhold

        if (lenx < (lot-1)*jump + inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sinqmf', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinqmf', 8)
            return
        else if (lenwrk < lot*n) then
            ier = 3
            call fft_error_handler('sinqmf', 10)
            return
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ier = 4
            call fft_error_handler('sinqmf', -1)
            return
        else
            ier = 0
        end if

        if (n /= 1) then

            ns2 = n/2
            lj = (lot-1)*jump+1

            do k=1,ns2
                kc = n-k
                do m=1,lj,jump
                    xhold = x(m,k)
                    x(m,k) = x(m,kc+1)
                    x(m,kc+1) = xhold
                end do
            end do

            call cosqmf(lot,jump,n,inc,x,lenx,wsave,lensav,work,lenwrk,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sinqmf',-5)
                return
            end if

            x(1:lj:jump,2:n:2) = -x(1:lj:jump,2:n:2)
        end if

    end subroutine sinqmf

    subroutine sinqmi(n, wsave, lensav, ier)
        !
        !  sinqmi: initialization for sinqmb and sinqmf.
        !
        !  purpose:
        !
        !  sinqmi initializes array wsave for use in its companion routines
        !  sinqmf and sinqmb.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors
        !  of n and also containing certain trigonometric values which will be used
        !  in routines sinqmb or sinqmf.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) lensav
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) n
        real (wp) wsave(lensav)

        ier = 0

        if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('sinqmi', 3)
            return
        end if

        call cosqmi(n, wsave, lensav, local_error_flag)

        ! Check error_flag
        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sinqmi',-5)
        end if

    end subroutine sinqmi

end module quarter_sine_transform_routines


c                 fork.ftn & fold.ftn

c===================================================================
c            1-d fft of the function cx(j),j=1,lx
c                     lx
c   cx(k)= SUM (cx(j)* exp {2*pi*signi*i*(j-1)*(k-1)/lx}
c                    j=1

c        point corresponding to Nyquist frequency is lx/2+1

c===================================================================
      subroutine fork (lx,isigni,cx)
      complex cx(lx),carg,cexp,cw,ctemp
      j=1
c------------- in inverse fft, a factor of (1/lx) is applied.
      sc=1.
      if(isigni.lt.0)sc=1./real(lx)
      do 30 i=1,lx
      if(i.gt.j)go to 10
      ctemp=cx(j)*sc
      cx(j)=cx(i)*sc
      cx(i)=ctemp
   10 m=lx/2
   20 if(j.le.m)go to 30
      j=j-m
      m=m/2
      if(m.ge.1)go to 20
   30 j=j+m
      l=1
   40 istep=2*l
      do 50 m=1,l
      carg=cmplx(0.,1.)*(3.141592654*isigni*(m-1))/real(l)
      cw=cexp(carg)
      do 50 i=m,lx,istep
      ctemp=cw*cx(i+l)
      cx(i+l)=cx(i)-ctemp
   50 cx(i)=cx(i)+ctemp
      l=istep
      if(l.lt.lx)go to 40
      return
      end

c========================================================
c         Nyquist frequency is at nq = lx/2
c       folding across the symmetry axis nq+1=nq1
c   first variable (k=1) folds nowhere, starts from k=2
c========================================================
      subroutine fold  (n,nq1,u)
      complex u(1)
      np2=n+2
      do 820 k=2,nq1
  820 u(np2-k)=conjg(u(k))
      return
      end


C
C***************************************************************************
C**************************  SUBROUTINE LRANK  *****************************
C***************************************************************************
C
C
       SUBROUTINE LRANK (ID1, ID2, XY, N1, N2, NCOMP, NTOT,
     +                   TEST, PROB, D, E, R, D1, E1, R1,
     +                   D2, E2, R2, SCORE, VAR)
C     *
C     * THIS SUBROUTINE COMPUTES THE LOGRANK STATISTIC WITH CONDITIONAL     *
C     * PERMUTATION VARIANCE (HYPERGEOMETRIC VARIANCE) FROM EQUATIONS (2.2) *
C     * AND (2.3) IN LATTA, 'A MONTE-CARLO STUDY OF SOME TWO-SAMPLE RANK    *
C     * TESTS WITH CENSORED DATA', 1981, JOURNAL OF THE AMERICAN STATISTICAL*
C     * ASSOCIATION, VOL 76, PP 713-719.                                    *
C     *                                                                     *
C     * INPUT                                                               *
C     *      ID1(I) : INDICATOR OF CENSORSHIP OF XY(I)                      *
C     *      ID2(I) : INDICATOR OF GROUP; 1 OR 2                            *
C     *      XY(I)  : DATA POINTS (SORTED TO SMALLEST TO LARGEST)           *
C     *      N1     : NUMBER OF DATA POINTS IN GROUP 1                      *
C     *      N2     : NUMBER OF DATA POINTS IN GROUP 2                      *
C     *      NCOMP  : TOTAL NUMBER OF DATA POINTS = N1 + N2                 *
C     *                                                                     *
C     * OUTPUT                                                              *
C     *     TEST    : STANDARDIZED LOGRANK STATISTIC                        *
C     *     PROB    : PROBABILITY                                           *
C     *                                                                     *
C     * OTHERS                                                              *
C     *      D1(I)  : THE NUMBER OF DETECTIONS OF GROUP 1 AT XY(I)          *
C     *      D2(I)  : THE NUMBER OF DETECTIONS OF GROUP 2 AT XY(I)          *
C     *      D(I)   : THE NUMBER OF DETECTIONS AT XY(I)                     *
C     *      R1(I)  : RISK SET OF GROUP 1 AT XY(I)                          *
C     *      R2(I)  : RISK SET OF GROUP 2 AT XY(I)                          *
C     *      R(I)   : RISK SET AT XY(I)                                     *
C     *      E1(I)  : THE NUMBER OF CENSORED POINTS OF GROUP 1 BETWEEN      *
C     *                                                     XY(I) & XY(I+1) *
C     *      E2(I)  : THE NUMBER OF CENSORED POINTS OF GROUP 2 BETWEEN      *
C     *                                                     XY(I) & XY(I+1) *
C     *      E(I)   : THE NUMBER OF CENSORED POINTS BETWEEN XY(I) & XY(I+1) *
C     *      SCORE  : SCORE OF THE DATA                                     *
C     *      VAR    : VARIANCE OF THE DATA                                  *

       IMPLICIT REAL*8 (A-H, O-Z), INTEGER (I-N)

       DIMENSION ID1(NTOT),ID2(NTOT),XY(NTOT)
       DIMENSION D(NTOT),E(NTOT),R(NTOT)
       DIMENSION D1(NTOT),E1(NTOT),R1(NTOT),D2(NTOT)
       DIMENSION E2(NTOT),R2(NTOT)

       I = 1
       L = 1
       R1(L) = REAL(N1)
       R2(L) = REAL(N2)
       R(L)  = REAL(NCOMP)
       ET1 = 0.0
       ET2 = 0.0

C
C     *  IF THE SMALLEST VALUE IS CENSORED, THIS LOOP WILL GO THROUGH THE   *
C     *  DATA UNTIL THE FIRST DETECTION IS REACHED.                         *
C
   10  IF (ID1(I) .NE. 0) THEN
          IF (ID2(I) .EQ. 1) THEN
             ET1 = ET1 + 1.0
          ELSE
             ET2 = ET2 + 1.0
          ENDIF
          I = I + 1
          GOTO 10
       ENDIF
C
C     *     START LOOP; THIS LOOP CONTINUES UNTIL THE COMPUTATION IS       *
C     *     FINISHED.                                                      *
C
   20  D(L)  = 0.0
       D1(L) = 0.0
       D2(L) = 0.0
       E(L)  = 0.0
       E1(L) = 0.0
       E2(L) = 0.0
       TEMP  = XY(I)
C
C     * CHECK IF THE DATA POINT IS DETECTED OR NOT. IF DETECTED, CONTINUE. *
C     * THEN CHECK WHICH GROUP THE DATA POINT BELONGS TO.                  *
C     * COMPUTE THE SURVIVAL FUNCTION AND THE COEFFICIENT FOR THE          *
C     * APPROPRIATE GROUP.                                                *
C

  30   IF (ID1(I) .EQ. 0) THEN
          IF (ID2(I) .EQ. 1) THEN
            D1(L) = D1(L) + 1.0
          ELSE
             D2(L) = D2(L) + 1.0
          ENDIF

          D(L) = D1(L) + D2(L)

C
C     * IF THE DATA POINT IS CENSORED, START CHECKING HOW MANY CENSORED    *
C     * DATA POINTS THERE ARE BETWEEN XY(I) AND XY(I+1).                   *
C
        ELSE
           IF (ID2(I) .EQ. 1) THEN
              E1(L) = E1(L) + 1.0
           ELSE
              E2(L) = E2(L) + 1.0
           ENDIF
           E(L) = E1(L) + E2(L)
        ENDIF

       IF (I .LT. NCOMP) THEN
           I = I + 1
C
C     * IF THE DATA POINT XY(I) IS TIED WITH PREVIOUS POINTS, GO BACK      *
C     * TO ADDRESS 30, AND COUNT THE NUMBER OF TIED DATA POINTS.           *
C     * ALSO, IF XY(I) IS NOT DETECTED GO BACK TO ADDRESS 30, AND COUNT    *
C     * THE NUMBER OF THE CENSORED DATA POINTS                             *
C
         IF (TEMP .EQ. XY(I)) GOTO 30
         IF (ID1(I) .NE. 0) GOTO 30

C
C     *            COMPUTE NEW RISK SETS FOR THE NEXT STEP.                *
C
            IF (L .EQ. 1) THEN
                R1(L) = R1(L) - ET1
                R2(L) = R2(L) - ET2
                R(L)  = R1(L) + R2(L)
            ELSE
                R1(L) = R1(L-1) - D1(L-1) - E1(L-1)
                R2(L) = R2(L-1) - D2(L-1) - E2(L-1)
                R(L)  = R1(L) + R2(L)
            ENDIF
            L = L + 1
            GOTO 20
        ENDIF
C
C     *       COMPUTE THE SCORE AND VARIANCE                         *
C

        SCORE = 0.0
        VAR   = 0.0
        L1 = L - 1
        DO 200 I = 1, L1

           SCORE = SCORE + (D2(I) - (R2(I) * D(I)) / R(I))

           IF (R(I) .GT. 1.0) THEN
              VAR = VAR + D(I) * (R2(I) / R(I)) *
     +              (1.0 - (R2(I) / R(I))) * ((R(I) - D(I)) /
     +              (R(I) - 1.0))
           ENDIF

  200   CONTINUE

C
C     *        NOW COMPUTE THE LOGRANK STATISTIC                   *
C
        TEST = SCORE / DSQRT(VAR)
        PROB = 1.0 - AGAUSS (TEST)

        RETURN
        END


\ Reading the TMP75 temperature sensor
\ Original: Frans van der Markt  (3-1-2019)
\ Rewritten for PFW: Willem Ouwerkerk  (31-1-2022)
\
\ The device I2C-address for the TMP75: 0x45
\
\ Note that in the selected 12-bits mode a conversion takes
\ typical 220 ms and maximal 300 ms! When a low current is
\ important, the OS (one shot) mode should be selected. The
\ conversion time needs to be taken into account when this
\ OS mode is selected!
\
\ TMP75 resolution is .0625 degrees Celcius for each bit!
\ Precision plus & min 1 degrees typical & 2 degrees maximal.
\
\ -25 C = -400
\   0 C =  000
\  25 C =  400
\  50 C =  800
\ 100 C = 1600

hex
: TEMPERATURE)  ( -- raw-temperature )
    45 device!  1 {i2c-write    \ Address TMP75 for writing,
    0 bus!  i2c}                \ select temp. register
    2 {i2c-read                 \ Start reading the 16-bit temperature register
    bus@  bus@  i2c}  swap b+b  \ Hi-byte and low-byte, merge them too
    2/ 2/ 2/ 2/ ;               \ Remove unused lower four bits, keep sign!

\ Example, read temperature with a resolution 0.1 degree
decimal
: CELCIUS       ( -- celcius )  temperature)  625 1000 */ ;
: FAHRENHEIT    ( -- fahren. )  celcius  9 5 */  320 + ;
hex

: CONFIGURE     ( b -- )
    45 device!  2 {i2c-write  1 bus! bus!  i2c} ;

: .TEMP         ( temp -- )
    s>d dup >r  dabs            \ Save sign
    <#  #  ch . hold  #s  r> sign #> type space ;

\ Read temperature continuously, stop with ESC or hold with SPACE
: TMP75-DEMO
  i2c-on  60 configure      \ Make R0&R1 high, this sets 12-bit resolution
  begin
     125 ms                 \ Conversion time
     cr  celcius .temp      \ Use celcius scale
\    cr  fahrenheit .temp   \ Use fahrenheit scale
  key? until ;

\ End ;;;